suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

fix module-name resolver for embedded exe

Browse Source 
svn: r3651
This commit is contained in:
Matthew Flatt 2006-07-07 17:51:21 +00:00
parent 1db7ae24c8
commit 399f98ff14
1 changed files with 58 additions and 52 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

110
collects/compiler/embed-unit.ss
View File

@ -426,58 +426,64 @@
(cons path (mod-full-name m)) (cons path (mod-full-name m))
#f))) #f)))
code-l)))]) code-l)))])
(current-module-name-resolver (letrec ([embedded-resolver
(lambda (name rel-to stx) (case-lambda
(if (or (not name) [(name)
(not (eq? (current-namespace) ns))) ;; a notification
;; a notification,or wrong namespace (orig name)]
(orig name rel-to stx) [(name rel-to stx)
;; Have a relative mapping? (embedded-resolver name rel-to stx #t)]
(let ([a (assoc rel-to mapping-table)]) [(name rel-to stx load?)
(if a (if (not (eq? (current-namespace) ns))
(let ([a2 (assoc name (cadr a))]) ;; Wrong namespace
(if a2 (orig name rel-to stx load?)
(cdr a2) ;; Have a relative mapping?
;; No relative mapping found (presumably a lib) (let ([a (assoc rel-to mapping-table)])
(orig name rel-to stx))) (if a
;; A library mapping that we have? (let ([a2 (assoc name (cadr a))])
(let ([a3 (and (pair? name) (if a2
(eq? (car name) 'lib) (cdr a2)
(ormap (lambda (lib-entry) ;; No relative mapping found (presumably a lib)
(with-handlers ([exn:fail? (lambda (x) #f)]) (orig name rel-to stx)))
;; To check equality of library references, ;; A library mapping that we have?
;; we have to consider relative paths in the (let ([a3 (and (pair? name)
;; filename part of the name. (eq? (car name) 'lib)
(let loop ([a (build-path (ormap (lambda (lib-entry)
(apply build-path (with-handlers ([exn:fail? (lambda (x) #f)])
'same ;; To check equality of library references,
(cddar lib-entry)) ;; we have to consider relative paths in the
(cadar lib-entry))] ;; filename part of the name.
[b (build-path (let loop ([a (build-path
(apply build-path (apply build-path
'same 'same
(let ([d (cddr name)]) (cddar lib-entry))
(if (null? d) (cadar lib-entry))]
'("mzlib") [b (build-path
d))) (apply build-path
(cadr name))]) 'same
(if (equal? a b) (let ([d (cddr name)])
lib-entry (if (null? d)
(let-values ([(abase aname d?) (split-path a)]) '("mzlib")
(if (eq? aname 'same) d)))
(loop abase b) (cadr name))])
(let-values ([(bbase bname a?) (split-path b)]) (if (equal? a b)
(if (eq? bname 'same) lib-entry
(loop a bbase) (let-values ([(abase aname d?) (split-path a)])
(if (equal? aname bname) (if (eq? aname 'same)
(loop abase bbase) (loop abase b)
#f))))))))) (let-values ([(bbase bname a?) (split-path b)])
library-table))]) (if (eq? bname 'same)
(if a3 (loop a bbase)
;; Have it: (if (equal? aname bname)
(cdr a3) (loop abase bbase)
;; Let default handler try: #f)))))))))
(orig name rel-to stx)))))))))) library-table))])
(if a3
;; Have it:
(cdr a3)
;; Let default handler try:
(orig name rel-to stx load?))))))])])
(current-module-name-resolver embedded-resolver))))
;; Write a module bundle that can be loaded with 'load' (do not embed it ;; Write a module bundle that can be loaded with 'load' (do not embed it
;; into an executable). The bundle is written to the current output port. ;; into an executable). The bundle is written to the current output port.