From a605183a0aae9f07141e204ca40100b3035add8d Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 16 Jul 2012 09:49:39 -0600 Subject: [PATCH] more submodule repairs for `raco exe' --- collects/compiler/embed-unit.rkt | 68 +++++++++++++++---- collects/tests/racket/embed-me17.rkt | 2 + collects/tests/racket/embed-me17a.rkt | 9 +++ collects/tests/racket/embed-me18.rkt | 5 ++ collects/tests/racket/embed-me18a.rkt | 9 +++ .../tests/racket/embed-planet-1/dyn-sub.rkt | 8 +++ .../tests/racket/embed-planet-1/has-sub.rkt | 5 +- collects/tests/racket/embed.rktl | 4 ++ 8 files changed, 96 insertions(+), 14 deletions(-) create mode 100644 collects/tests/racket/embed-me17.rkt create mode 100644 collects/tests/racket/embed-me17a.rkt create mode 100644 collects/tests/racket/embed-me18.rkt create mode 100644 collects/tests/racket/embed-me18a.rkt create mode 100644 collects/tests/racket/embed-planet-1/dyn-sub.rkt diff --git a/collects/compiler/embed-unit.rkt b/collects/compiler/embed-unit.rkt index c2a819cbe8..8693f44193 100644 --- a/collects/compiler/embed-unit.rkt +++ b/collects/compiler/embed-unit.rkt @@ -371,6 +371,10 @@ [just-filename (if (pair? filename) (cadr filename) filename)] + [root-module-path (if (and (pair? module-path) + (eq? 'submod (car module-path))) + (cadr module-path) + module-path)] [actual-filename just-filename] ; `set!'ed below to adjust file suffix [name (let-values ([(base name dir?) (split-path just-filename)]) (path->string (path-replace-suffix name #"")))] @@ -468,9 +472,13 @@ null) #t null)]) - (let ([sub-files (map (lambda (i) (normalize (resolve-module-path-index i filename))) + (let ([sub-files (map (lambda (i) + ;; use `just-filename', because i has submod name embedded + (normalize (resolve-module-path-index i just-filename))) all-file-imports)] - [sub-paths (map (lambda (i) (collapse-module-path-index i module-path)) + [sub-paths (map (lambda (i) + ;; use `root-module-path', because i has submod name embedded + (collapse-module-path-index i root-module-path)) all-file-imports)] [normalized-extra-paths (map (lambda (i) (collapse-module-path i module-path)) (append extra-runtime-paths extra-paths))] @@ -628,7 +636,7 @@ [(library-table) (quote ,(filter values (map (lambda (m) - (let ([path (mod-mod-path m)]) + (let loop ([path (mod-mod-path m)]) (cond [(and (pair? path) (eq? 'lib (car path))) @@ -639,6 +647,12 @@ ;; Normalize planet path (cons (collapse-module-path path current-directory) (mod-full-name m))] + [(and (pair? path) + (eq? 'submod (car path))) + (define m (loop (cadr path))) + (and m + (cons `(submod ,(car m) ,@(cddr path)) + (cdr m)))] [else #f]))) code-l)))]) (hash-set! regs @@ -701,9 +715,16 @@ (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)]) + (let-values ([(name) + ;; remove submod path; added back at end + (if (pair? name) + (if (eq? 'submod (car name)) + (cadr name) + name) + name)]) + (if (symbol? name) + (list 'lib (symbol->string name)) + name))]) (if (pair? name) (if (eq? 'lib (car name)) (if (null? (cddr name)) @@ -803,19 +824,40 @@ #t #f) #f)) - #f))]) + #f))] + [(restore-submod) (lambda (lname) + (if (pair? name) + (if (eq? (car name) 'submod) + (list* 'submod lname (cddr name)) + lname) + lname))]) ;; A library mapping that we have? (let-values ([(a3) (if lname (if (string? lname) ;; lib - (assoc lname library-table) + (assoc (restore-submod lname) library-table) ;; planet (ormap (lambda (e) - (if (string? (car e)) - #f - (if (planet-match? (cdar e) (cdr lname)) - e - #f))) + (let-values ([(e) + ;; handle submodule matching first: + (if (pair? name) + (if (eq? (car name) 'submod) + (if (pair? (car e)) + (if (eq? (caar e) 'submod) + (if (equal? (cddar e) (cddr name)) + (cons (cadar e) (cdr e)) + #f) + #f) + #f) + e) + e)]) + (if e + (if (string? (car e)) + #f + (if (planet-match? (cdar e) (cdr lname)) + e + #f)) + #f))) library-table)) #f)]) (if a3 diff --git a/collects/tests/racket/embed-me17.rkt b/collects/tests/racket/embed-me17.rkt new file mode 100644 index 0000000000..ecac985e4a --- /dev/null +++ b/collects/tests/racket/embed-me17.rkt @@ -0,0 +1,2 @@ +#lang racket/base +(require (submod "embed-me17a.rkt" sub)) diff --git a/collects/tests/racket/embed-me17a.rkt b/collects/tests/racket/embed-me17a.rkt new file mode 100644 index 0000000000..a6826d7597 --- /dev/null +++ b/collects/tests/racket/embed-me17a.rkt @@ -0,0 +1,9 @@ +#lang racket + +(define print-17 + (lambda () (printf "This is 17.\n"))) + +(module+ sub + (with-output-to-file "stdout" + print-17 + #:exists 'append)) diff --git a/collects/tests/racket/embed-me18.rkt b/collects/tests/racket/embed-me18.rkt new file mode 100644 index 0000000000..c3d9091809 --- /dev/null +++ b/collects/tests/racket/embed-me18.rkt @@ -0,0 +1,5 @@ +#lang racket/base +(require (submod tests/racket/embed-me18a sub)) +(with-output-to-file "stdout" + (dynamic-require '(submod tests/racket/embed-me18a sub) 'print-18) + #:exists 'append) diff --git a/collects/tests/racket/embed-me18a.rkt b/collects/tests/racket/embed-me18a.rkt new file mode 100644 index 0000000000..107e3fedd2 --- /dev/null +++ b/collects/tests/racket/embed-me18a.rkt @@ -0,0 +1,9 @@ +#lang racket/base +(module sub racket/base + (provide print-18) + (define (print-18) + (printf "This is 18.\n"))) + + + + \ No newline at end of file diff --git a/collects/tests/racket/embed-planet-1/dyn-sub.rkt b/collects/tests/racket/embed-planet-1/dyn-sub.rkt new file mode 100644 index 0000000000..081b7ffd4e --- /dev/null +++ b/collects/tests/racket/embed-planet-1/dyn-sub.rkt @@ -0,0 +1,8 @@ +#lang racket/base +(require (submod (planet racket-tester/p1/has-sub) the-sub)) + +(with-output-to-file "stdout" + #:exists 'append + (lambda () (displayln (dynamic-require + '(submod (planet racket-tester/p1/has-sub) the-sub) + 'out)))) diff --git a/collects/tests/racket/embed-planet-1/has-sub.rkt b/collects/tests/racket/embed-planet-1/has-sub.rkt index e9a5a07112..e2f1bb7de1 100644 --- a/collects/tests/racket/embed-planet-1/has-sub.rkt +++ b/collects/tests/racket/embed-planet-1/has-sub.rkt @@ -1,3 +1,6 @@ #lang racket/base -(module+ the-sub) +(module+ the-sub + (provide out) + (define out 'out)) + diff --git a/collects/tests/racket/embed.rktl b/collects/tests/racket/embed.rktl index 1ccbc1bafd..9f95f62cf1 100644 --- a/collects/tests/racket/embed.rktl +++ b/collects/tests/racket/embed.rktl @@ -224,6 +224,8 @@ (one-mz-test "embed-me13.rkt" "This is 14\n" #f) (one-mz-test "embed-me14.rkt" "This is 14\n" #f) (one-mz-test "embed-me15.rkt" "This is 15.\n" #f) + (one-mz-test "embed-me17.rkt" "This is 17.\n" #f) + (one-mz-test "embed-me18.rkt" "This is 18.\n" #f) ;; Try unicode expr and cmdline: (prepare dest "unicode") @@ -501,6 +503,8 @@ (go '(planet "private/sub.ss" ("racket-tester" "p2.plt" 2 0)) "two\nsub\n") (go '(planet "main.ss" ("racket-tester" "p2.plt" 2 0)) "two\n") + (go '(planet racket-tester/p1/dyn-sub) "out\n") + (void)) (system* planet "unlink" "racket-tester" "p1.plt" "1" "0")