From b8f6e1a91a4796af44359f4152966ac51b4fe03d Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 3 Nov 2008 14:37:55 +0000 Subject: [PATCH] handle attaches of embedded modules svn: r12225 --- collects/compiler/embed-unit.ss | 269 ++++++++++++++++++-------------- 1 file changed, 152 insertions(+), 117 deletions(-) diff --git a/collects/compiler/embed-unit.ss b/collects/compiler/embed-unit.ss index 5d14368c73..cabba00a1f 100644 --- a/collects/compiler/embed-unit.ss +++ b/collects/compiler/embed-unit.ss @@ -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,122 +607,130 @@ (if (not (module-path? name)) ;; Bad input (orig name rel-to stx load?) - (if (not (eq? reg (namespace-module-registry (current-namespace)))) - ;; Wrong registry - (orig name rel-to stx load?) - ;; Have a relative mapping? - (let-values ([(a) (if rel-to - (assq (resolved-module-path-name rel-to) mapping-table) - #f)]) - (if a - (let-values ([(a2) (assoc name (cadr a))]) - (if a2 - (make-resolved-module-path (cdr a2)) - ;; No relative mapping found (presumably a lib) - (orig name rel-to stx load?))) - (let-values ([(lname) - ;; normalize `lib' to single string (same as lib-path->string): - (let-values ([(name) - (if (symbol? name) - (list 'lib (symbol->string name)) - name)]) - (if (pair? name) - (if (eq? 'lib (car name)) - (if (null? (cddr name)) - (if (regexp-match #rx"^[^/]*[.]" (cadr name)) - ;; mzlib - (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)) + (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) + #f)]) + (if a + (let-values ([(a2) (assoc name (cadr a))]) + (if a2 + (make-resolved-module-path (cdr a2)) + ;; No relative mapping found (presumably a lib) + (orig name rel-to stx load?))) + (let-values ([(lname) + ;; normalize `lib' to single string (same as lib-path->string): + (let-values ([(name) + (if (symbol? name) + (list 'lib (symbol->string name)) + name)]) + (if (pair? name) + (if (eq? 'lib (car name)) (if (null? (cddr name)) - ;; need to normalize: - (let-values ([(s) (if (symbol? (cadr name)) - (symbol->string (cadr name)) - (cadr name))]) - (letrec-values ([(split) - (lambda (s rx suffix?) - (let-values ([(m) (regexp-match-positions rx s)]) - (if m - (cons (substring s 0 (caar m)) - (split (substring s (cdar m)) - rx suffix?)) - (list - (if suffix? - (if (regexp-match? #rx"[.]" s) - s - (string-append s ".ss")) - s)))))] - [(last-of) - (lambda (l) - (if (null? (cdr l)) (car l) (last-of (cdr l))))] - [(not-last) - (lambda (l) - (if (null? (cdr l)) - null - (cons (car l) (not-last (cdr l)))))]) - (let-values ([(parts) (split s #rx"/" #t)]) - (let-values ([(vparts) (split (cadr parts) #rx":" #f)]) - (cons 'planet - (cons (if (null? (cddr parts)) - "main.ss" - (last-of parts)) - (cons - (cons (car parts) - (cons (string-append (car vparts) ".plt") - ;; FIXME: finish parsing version: - (cdddr parts))) - (not-last (cddr parts))))))))) - ;; already in long form: - name) - #f)) - #f))] - [(planet-match?) - (lambda (a b) - (if (equal? (cons (car a) (cddr a)) - (cons (car b) (cddr b))) - (let-values ([(a) (cadr a)] - [(b) (cadr b)]) - (if (equal? (car a) (car b)) - (if (equal? (cadr a) (cadr b)) - ;; Everything matches up to the version... - ;; FIXME: check version. (Since the version isn't checked, - ;; this currently works only when a single version of the - ;; 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?))))))))])]) + (if (regexp-match #rx"^[^/]*[.]" (cadr name)) + ;; mzlib + (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)) + ;; need to normalize: + (let-values ([(s) (if (symbol? (cadr name)) + (symbol->string (cadr name)) + (cadr name))]) + (letrec-values ([(split) + (lambda (s rx suffix?) + (let-values ([(m) (regexp-match-positions + rx + s)]) + (if m + (cons (substring s 0 (caar m)) + (split (substring s (cdar m)) + rx suffix?)) + (list + (if suffix? + (if (regexp-match? #rx"[.]" s) + s + (string-append s ".ss")) + s)))))] + [(last-of) + (lambda (l) + (if (null? (cdr l)) + (car l) + (last-of (cdr l))))] + [(not-last) + (lambda (l) + (if (null? (cdr l)) + null + (cons (car l) (not-last (cdr l)))))]) + (let-values ([(parts) (split s #rx"/" #t)]) + (let-values ([(vparts) (split (cadr parts) #rx":" #f)]) + (cons 'planet + (cons (if (null? (cddr parts)) + "main.ss" + (last-of parts)) + (cons + (cons (car parts) + (cons (string-append (car vparts) + ".plt") + ;; FIXME: finish version parse: + (cdddr parts))) + (not-last (cddr parts))))))))) + ;; already in long form: + name) + #f)) + #f))] + [(planet-match?) + (lambda (a b) + (if (equal? (cons (car a) (cddr a)) + (cons (car b) (cddr b))) + (let-values ([(a) (cadr a)] + [(b) (cadr b)]) + (if (equal? (car a) (car b)) + (if (equal? (cadr a) (cadr b)) + ;; Everything matches up to the version... + ;; FIXME: check version. (Since the version isn't checked, + ;; this currently works only when a single version of the + ;; 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)))))) ;; Write a module bundle that can be loaded with 'load' (do not embed it