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

handle attaches of embedded modules

Browse Source 
svn: r12225
This commit is contained in:
Matthew Flatt 2008-11-03 14:37:55 +00:00
parent 10f794defd
commit b8f6e1a91a
1 changed files with 152 additions and 117 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -546,7 +546,7 @@
(let ([extensions (filter (lambda (m) (extension? (mod-code m))) code-l)])
`(module #%resolver '#%kernel
(let-values ([(orig) (current-module-name-resolver)]
[(reg) (namespace-module-registry (current-namespace))]
[(regs) (make-hasheq)]
[(mapping-table) (quote
,(map
(lambda (m)
@ -569,10 +569,37 @@
(mod-full-name m))]
[else #f])))
code-l)))])
(hash-set! regs
(namespace-module-registry (current-namespace))
(vector mapping-table library-table))
(letrec-values ([(embedded-resolver)
(case-lambda
[(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)]
[(name rel-to stx)
(embedded-resolver name rel-to stx #t)]
@ -580,9 +607,12 @@
(if (not (module-path? name))
;; Bad input
(orig name rel-to stx load?)
(if (not (eq? reg (namespace-module-registry (current-namespace))))
;; Wrong registry
(let-values ([(table-vec) (hash-ref regs (namespace-module-registry (current-namespace)) #f)])
(if (not table-vec)
;; No mappings in this registry
(orig name rel-to stx load?)
(let-values ([(mapping-table) (vector-ref table-vec 0)]
[(library-table) (vector-ref table-vec 1)])
;; Have a relative mapping?
(let-values ([(a) (if rel-to
(assq (resolved-module-path-name rel-to) mapping-table)
@ -626,7 +656,9 @@
(cadr name))])
(letrec-values ([(split)
(lambda (s rx suffix?)
(let-values ([(m) (regexp-match-positions rx s)])
(let-values ([(m) (regexp-match-positions
rx
s)])
(if m
(cons (substring s 0 (caar m))
(split (substring s (cdar m))
@ -639,7 +671,9 @@
s)))))]
[(last-of)
(lambda (l)
(if (null? (cdr l)) (car l) (last-of (cdr l))))]
(if (null? (cdr l))
(car l)
(last-of (cdr l))))]
[(not-last)
(lambda (l)
(if (null? (cdr l))
@ -653,8 +687,9 @@
(last-of parts))
(cons
(cons (car parts)
(cons (string-append (car vparts) ".plt")
;; FIXME: finish parsing version:
(cons (string-append (car vparts)
".plt")
;; FIXME: finish version parse:
(cdddr parts)))
(not-last (cddr parts)))))))))
;; already in long form:
@ -695,7 +730,7 @@
;; Have it:
(make-resolved-module-path (cdr a3))
;; Let default handler try:
(orig name rel-to stx load?))))))))])])
(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