handle attaches of embedded modules
svn: r12225
This commit is contained in:
Matthew Flatt
parent
10f794defd
commit
b8f6e1a91a
|
|
@ -546,7 +546,7 @@
|
||||||
(let ([extensions (filter (lambda (m) (extension? (mod-code m))) code-l)])
|
(let ([extensions (filter (lambda (m) (extension? (mod-code m))) code-l)])
|
||||||
`(module #%resolver '#%kernel
|
`(module #%resolver '#%kernel
|
||||||
(let-values ([(orig) (current-module-name-resolver)]
|
(let-values ([(orig) (current-module-name-resolver)]
|
||||||
[(reg) (namespace-module-registry (current-namespace))]
|
[(regs) (make-hasheq)]
|
||||||
[(mapping-table) (quote
|
[(mapping-table) (quote
|
||||||
,(map
|
,(map
|
||||||
(lambda (m)
|
(lambda (m)
|
||||||
|
|
@ -569,10 +569,37 @@
|
||||||
(mod-full-name m))]
|
(mod-full-name m))]
|
||||||
[else #f])))
|
[else #f])))
|
||||||
code-l)))])
|
code-l)))])
|
||||||
|
(hash-set! regs
|
||||||
|
(namespace-module-registry (current-namespace))
|
||||||
|
(vector mapping-table library-table))
|
||||||
(letrec-values ([(embedded-resolver)
|
(letrec-values ([(embedded-resolver)
|
||||||
(case-lambda
|
(case-lambda
|
||||||
[(name)
|
[(name)
|
||||||
;; a notification
|
;; a notification; if the name matches one of our special names,
|
||||||
|
;; assume that it's from a namespace that has the declaration
|
||||||
|
;; [it would be better if the noritifer told us the source]
|
||||||
|
(let-values ([(name) (if name (resolved-module-path-name name) #f)])
|
||||||
|
(let-values ([(a) (assq name mapping-table)])
|
||||||
|
(if a
|
||||||
|
(let-values ([(vec) (hash-ref regs (namespace-module-registry (current-namespace))
|
||||||
|
(lambda ()
|
||||||
|
(let-values ([(vec) (vector null null)])
|
||||||
|
(hash-set! regs (namespace-module-registry (current-namespace)) vec)
|
||||||
|
vec)))])
|
||||||
|
;; add mapping:
|
||||||
|
(vector-set! vec 0 (cons a (vector-ref vec 0)))
|
||||||
|
;; add library mappings:
|
||||||
|
(vector-set! vec 1 (append
|
||||||
|
(letrec-values ([(loop)
|
||||||
|
(lambda (l)
|
||||||
|
(if (null? l)
|
||||||
|
null
|
||||||
|
(if (eq? (cdar l) name)
|
||||||
|
(cons (car l) (loop (cdr l)))
|
||||||
|
(loop (cdr l)))))])
|
||||||
|
(loop library-table))
|
||||||
|
(vector-ref vec 1))))
|
||||||
|
(void))))
|
||||||
(orig name)]
|
(orig name)]
|
||||||
[(name rel-to stx)
|
[(name rel-to stx)
|
||||||
(embedded-resolver name rel-to stx #t)]
|
(embedded-resolver name rel-to stx #t)]
|
||||||
|
|
@ -580,122 +607,130 @@
|
||||||
(if (not (module-path? name))
|
(if (not (module-path? name))
|
||||||
;; Bad input
|
;; Bad input
|
||||||
(orig name rel-to stx load?)
|
(orig name rel-to stx load?)
|
||||||
(if (not (eq? reg (namespace-module-registry (current-namespace))))
|
(let-values ([(table-vec) (hash-ref regs (namespace-module-registry (current-namespace)) #f)])
|
||||||
;; Wrong registry
|
(if (not table-vec)
|
||||||
(orig name rel-to stx load?)
|
;; No mappings in this registry
|
||||||
;; Have a relative mapping?
|
(orig name rel-to stx load?)
|
||||||
(let-values ([(a) (if rel-to
|
(let-values ([(mapping-table) (vector-ref table-vec 0)]
|
||||||
(assq (resolved-module-path-name rel-to) mapping-table)
|
[(library-table) (vector-ref table-vec 1)])
|
||||||
#f)])
|
;; Have a relative mapping?
|
||||||
(if a
|
(let-values ([(a) (if rel-to
|
||||||
(let-values ([(a2) (assoc name (cadr a))])
|
(assq (resolved-module-path-name rel-to) mapping-table)
|
||||||
(if a2
|
#f)])
|
||||||
(make-resolved-module-path (cdr a2))
|
(if a
|
||||||
;; No relative mapping found (presumably a lib)
|
(let-values ([(a2) (assoc name (cadr a))])
|
||||||
(orig name rel-to stx load?)))
|
(if a2
|
||||||
(let-values ([(lname)
|
(make-resolved-module-path (cdr a2))
|
||||||
;; normalize `lib' to single string (same as lib-path->string):
|
;; No relative mapping found (presumably a lib)
|
||||||
(let-values ([(name)
|
(orig name rel-to stx load?)))
|
||||||
(if (symbol? name)
|
(let-values ([(lname)
|
||||||
(list 'lib (symbol->string name))
|
;; normalize `lib' to single string (same as lib-path->string):
|
||||||
name)])
|
(let-values ([(name)
|
||||||
(if (pair? name)
|
(if (symbol? name)
|
||||||
(if (eq? 'lib (car name))
|
(list 'lib (symbol->string name))
|
||||||
(if (null? (cddr name))
|
name)])
|
||||||
(if (regexp-match #rx"^[^/]*[.]" (cadr name))
|
(if (pair? name)
|
||||||
;; mzlib
|
(if (eq? 'lib (car name))
|
||||||
(string-append "mzlib/" (cadr name))
|
|
||||||
;; new-style
|
|
||||||
(if (regexp-match #rx"^[^/.]*$" (cadr name))
|
|
||||||
(string-append (cadr name) "/main.ss")
|
|
||||||
(if (regexp-match #rx"^[^.]*$" (cadr name))
|
|
||||||
;; need a suffix:
|
|
||||||
(string-append (cadr name) ".ss")
|
|
||||||
(cadr name))))
|
|
||||||
;; old-style multi-string
|
|
||||||
(string-append (apply string-append
|
|
||||||
(map (lambda (s)
|
|
||||||
(string-append s "/"))
|
|
||||||
(cddr name)))
|
|
||||||
(cadr name)))
|
|
||||||
(if (eq? 'planet (car name))
|
|
||||||
(if (null? (cddr name))
|
(if (null? (cddr name))
|
||||||
;; need to normalize:
|
(if (regexp-match #rx"^[^/]*[.]" (cadr name))
|
||||||
(let-values ([(s) (if (symbol? (cadr name))
|
;; mzlib
|
||||||
(symbol->string (cadr name))
|
(string-append "mzlib/" (cadr name))
|
||||||
(cadr name))])
|
;; new-style
|
||||||
(letrec-values ([(split)
|
(if (regexp-match #rx"^[^/.]*$" (cadr name))
|
||||||
(lambda (s rx suffix?)
|
(string-append (cadr name) "/main.ss")
|
||||||
(let-values ([(m) (regexp-match-positions rx s)])
|
(if (regexp-match #rx"^[^.]*$" (cadr name))
|
||||||
(if m
|
;; need a suffix:
|
||||||
(cons (substring s 0 (caar m))
|
(string-append (cadr name) ".ss")
|
||||||
(split (substring s (cdar m))
|
(cadr name))))
|
||||||
rx suffix?))
|
;; old-style multi-string
|
||||||
(list
|
(string-append (apply string-append
|
||||||
(if suffix?
|
(map (lambda (s)
|
||||||
(if (regexp-match? #rx"[.]" s)
|
(string-append s "/"))
|
||||||
s
|
(cddr name)))
|
||||||
(string-append s ".ss"))
|
(cadr name)))
|
||||||
s)))))]
|
(if (eq? 'planet (car name))
|
||||||
[(last-of)
|
(if (null? (cddr name))
|
||||||
(lambda (l)
|
;; need to normalize:
|
||||||
(if (null? (cdr l)) (car l) (last-of (cdr l))))]
|
(let-values ([(s) (if (symbol? (cadr name))
|
||||||
[(not-last)
|
(symbol->string (cadr name))
|
||||||
(lambda (l)
|
(cadr name))])
|
||||||
(if (null? (cdr l))
|
(letrec-values ([(split)
|
||||||
null
|
(lambda (s rx suffix?)
|
||||||
(cons (car l) (not-last (cdr l)))))])
|
(let-values ([(m) (regexp-match-positions
|
||||||
(let-values ([(parts) (split s #rx"/" #t)])
|
rx
|
||||||
(let-values ([(vparts) (split (cadr parts) #rx":" #f)])
|
s)])
|
||||||
(cons 'planet
|
(if m
|
||||||
(cons (if (null? (cddr parts))
|
(cons (substring s 0 (caar m))
|
||||||
"main.ss"
|
(split (substring s (cdar m))
|
||||||
(last-of parts))
|
rx suffix?))
|
||||||
(cons
|
(list
|
||||||
(cons (car parts)
|
(if suffix?
|
||||||
(cons (string-append (car vparts) ".plt")
|
(if (regexp-match? #rx"[.]" s)
|
||||||
;; FIXME: finish parsing version:
|
s
|
||||||
(cdddr parts)))
|
(string-append s ".ss"))
|
||||||
(not-last (cddr parts)))))))))
|
s)))))]
|
||||||
;; already in long form:
|
[(last-of)
|
||||||
name)
|
(lambda (l)
|
||||||
#f))
|
(if (null? (cdr l))
|
||||||
#f))]
|
(car l)
|
||||||
[(planet-match?)
|
(last-of (cdr l))))]
|
||||||
(lambda (a b)
|
[(not-last)
|
||||||
(if (equal? (cons (car a) (cddr a))
|
(lambda (l)
|
||||||
(cons (car b) (cddr b)))
|
(if (null? (cdr l))
|
||||||
(let-values ([(a) (cadr a)]
|
null
|
||||||
[(b) (cadr b)])
|
(cons (car l) (not-last (cdr l)))))])
|
||||||
(if (equal? (car a) (car b))
|
(let-values ([(parts) (split s #rx"/" #t)])
|
||||||
(if (equal? (cadr a) (cadr b))
|
(let-values ([(vparts) (split (cadr parts) #rx":" #f)])
|
||||||
;; Everything matches up to the version...
|
(cons 'planet
|
||||||
;; FIXME: check version. (Since the version isn't checked,
|
(cons (if (null? (cddr parts))
|
||||||
;; this currently works only when a single version of the
|
"main.ss"
|
||||||
;; package is used in the executable.)
|
(last-of parts))
|
||||||
#t
|
(cons
|
||||||
#f)
|
(cons (car parts)
|
||||||
#f))
|
(cons (string-append (car vparts)
|
||||||
#f))])
|
".plt")
|
||||||
;; A library mapping that we have?
|
;; FIXME: finish version parse:
|
||||||
(let-values ([(a3) (if lname
|
(cdddr parts)))
|
||||||
(if (string? lname)
|
(not-last (cddr parts)))))))))
|
||||||
;; lib
|
;; already in long form:
|
||||||
(assoc lname library-table)
|
name)
|
||||||
;; planet
|
#f))
|
||||||
(ormap (lambda (e)
|
#f))]
|
||||||
(if (string? (car e))
|
[(planet-match?)
|
||||||
#f
|
(lambda (a b)
|
||||||
(if (planet-match? (cdar e) (cdr lname))
|
(if (equal? (cons (car a) (cddr a))
|
||||||
e
|
(cons (car b) (cddr b)))
|
||||||
#f)))
|
(let-values ([(a) (cadr a)]
|
||||||
library-table))
|
[(b) (cadr b)])
|
||||||
#f)])
|
(if (equal? (car a) (car b))
|
||||||
(if a3
|
(if (equal? (cadr a) (cadr b))
|
||||||
;; Have it:
|
;; Everything matches up to the version...
|
||||||
(make-resolved-module-path (cdr a3))
|
;; FIXME: check version. (Since the version isn't checked,
|
||||||
;; Let default handler try:
|
;; this currently works only when a single version of the
|
||||||
(orig name rel-to stx load?))))))))])])
|
;; package is used in the executable.)
|
||||||
|
#t
|
||||||
|
#f)
|
||||||
|
#f))
|
||||||
|
#f))])
|
||||||
|
;; A library mapping that we have?
|
||||||
|
(let-values ([(a3) (if lname
|
||||||
|
(if (string? lname)
|
||||||
|
;; lib
|
||||||
|
(assoc lname library-table)
|
||||||
|
;; planet
|
||||||
|
(ormap (lambda (e)
|
||||||
|
(if (string? (car e))
|
||||||
|
#f
|
||||||
|
(if (planet-match? (cdar e) (cdr lname))
|
||||||
|
e
|
||||||
|
#f)))
|
||||||
|
library-table))
|
||||||
|
#f)])
|
||||||
|
(if a3
|
||||||
|
;; Have it:
|
||||||
|
(make-resolved-module-path (cdr a3))
|
||||||
|
;; Let default handler try:
|
||||||
|
(orig name rel-to stx load?))))))))))])])
|
||||||
(current-module-name-resolver embedded-resolver))))))
|
(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
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue
Block a user