diff --git a/collects/planet/private/resolver.rkt b/collects/planet/private/resolver.rkt index 772bd9a028..19bbfb7624 100644 --- a/collects/planet/private/resolver.rkt +++ b/collects/planet/private/resolver.rkt @@ -174,7 +174,7 @@ See the scribble documentation on the planet/resolver module. (define resolver (case-lambda [(name) (void)] - [(spec module-path stx load? orig-paramz) + [(spec module-path stx load? submod orig-paramz) ;; ensure these directories exist (try-make-directory* (PLANET-DIR)) (try-make-directory* (CACHE-DIR)) @@ -183,6 +183,7 @@ See the scribble documentation on the planet/resolver module. (current-module-declare-name) stx load? + submod orig-paramz)])) (require racket/tcp @@ -335,7 +336,7 @@ See the scribble documentation on the planet/resolver module. ;; planet-resolve : PLANET-REQUEST (resolved-module-path | #f) syntax[PLANET-REQUEST] -> symbol ;; resolves the given request. Returns a name corresponding to the module in ;; the correct environment -(define (planet-resolve spec rmp stx load? orig-paramz) +(define (planet-resolve spec rmp stx load? submod orig-paramz) ;; install various parameters that can affect the compilation of a planet package back to their original state (parameterize ([current-compile (call-with-parameterization orig-paramz current-compile)] [current-eval (call-with-parameterization orig-paramz current-eval)] @@ -345,7 +346,7 @@ See the scribble documentation on the planet/resolver module. [powerful-security-guard (call-with-parameterization orig-paramz current-security-guard)]) (let-values ([(path pkg) (get-planet-module-path/pkg/internal spec rmp stx load?)]) (when load? (add-pkg-to-diamond-registry! pkg stx)) - (do-require path (pkg-path pkg) rmp stx load?)))) + (do-require path (pkg-path pkg) rmp stx load? submod)))) ;; resolve-planet-path : planet-require-spec -> path ;; retrieves the path to the given file in the planet package. downloads and @@ -833,9 +834,11 @@ See the scribble documentation on the planet/resolver module. ;; do-require : path path symbol syntax -> symbol ;; requires the given filename, which must be a module, in the given path. -(define (do-require file-path package-path module-path stx load?) +(define (do-require file-path package-path module-path stx load? submod) (parameterize ([current-load-relative-directory package-path]) - ((current-module-name-resolver) file-path module-path stx load?))) + ((current-module-name-resolver) + (if submod `(submod ,file-path . ,submod) file-path) + module-path stx load?))) (define *package-search-chain* (make-parameter diff --git a/collects/tests/planet/submod.rkt b/collects/tests/planet/submod.rkt new file mode 100644 index 0000000000..d523527b79 --- /dev/null +++ b/collects/tests/planet/submod.rkt @@ -0,0 +1,38 @@ +#lang racket +(require setup/dirs) + +(define planet (build-path (find-console-bin-dir) + (if (eq? 'windows (system-type)) + "planet.exe" + "planet"))) + +(void + (system* planet "link" "racket-tester" "p1.plt" "1" "0" + (path->string (collection-path "tests" "racket" "embed-planet-1")))) + +(define (test expected got) + (unless (equal? expected got) + (error "failed"))) + +(define-syntax-rule (test/exn e) + (test 'exn + (with-handlers ([exn:fail? (lambda (exn) 'exn)]) + e))) + +(test #f (module-declared? `(submod (planet racket-tester/p1) reader) #f)) +(test #f (module-declared? `(planet racket-tester/p1) #f)) +(test #f (module-declared? `(planet racket-tester/p1/none) #f)) + +(test/exn (module-declared? `(planet racket-tester/p1/none) #t)) +(test #f (module-declared? `(submod (planet racket-tester/p1/none) reader) #t)) + + +(test #f (module-declared? `(submod (planet racket-tester/p1) reader) #t)) +(test #t (module-declared? `(planet racket-tester/p1) #f)) + +(test #f (module-declared? `(submod (planet racket-tester/p1/has-sub) the-sub) #f)) +(test #t (module-declared? `(submod (planet racket-tester/p1/has-sub) the-sub) #t)) + +(void + (system* planet "unlink" "racket-tester" "p1.plt" "1" "0")) + diff --git a/collects/tests/racket/embed-planet-1/has-sub.rkt b/collects/tests/racket/embed-planet-1/has-sub.rkt new file mode 100644 index 0000000000..e9a5a07112 --- /dev/null +++ b/collects/tests/racket/embed-planet-1/has-sub.rkt @@ -0,0 +1,3 @@ +#lang racket/base + +(module+ the-sub) diff --git a/src/racket/src/startup.inc b/src/racket/src/startup.inc index 9dbad0a576..4ff49970b3 100644 --- a/src/racket/src/startup.inc +++ b/src/racket/src/startup.inc @@ -797,6 +797,13 @@ "(define-values(standard-module-name-resolver)" "(let-values()" "(define-values(planet-resolver) #f)" +"(define-values(prep-planet-resolver!)" +"(lambda()" +"(unless planet-resolver" +"(with-continuation-mark" +" parameterization-key" +" orig-paramz" +" (set! planet-resolver (dynamic-require '(lib \"planet/resolver.rkt\") 'planet-module-name-resolver))))))" "(define-values(standard-module-name-resolver)" "(case-lambda " "((s) " @@ -868,21 +875,14 @@ "(append(cdr rp) r)" " r)))))" "((and(pair? s)(eq?(car s) 'planet))" -"(unless planet-resolver" -"(with-continuation-mark" -" parameterization-key" -" orig-paramz" -" (set! planet-resolver (dynamic-require '(lib \"planet/resolver.rkt\") 'planet-module-name-resolver))))" -"(planet-resolver s relto stx load? orig-paramz))" +"(prep-planet-resolver!)" +"(planet-resolver s relto stx load? #f orig-paramz))" "((and(pair? s)" "(eq?(car s) 'submod)" "(pair?(cadr s))" "(eq?(caadr s) 'planet))" -"(define p(standard-module-name-resolver(cadr s) relto stx load?))" -"(let((p(resolved-module-path-name relto)))" -"(if(pair? p)" -"(flatten-sub-path(car p)(append(cdr p)(cddr s)))" -"(flatten-sub-path p(cddr s)))))" +"(prep-planet-resolver!)" +"(planet-resolver(cadr s) relto stx load?(cddr s) orig-paramz))" "(else" "(let((get-dir(lambda()" "(or(and relto" diff --git a/src/racket/src/startup.rktl b/src/racket/src/startup.rktl index 41c11ade6d..7bd1d1d6cc 100644 --- a/src/racket/src/startup.rktl +++ b/src/racket/src/startup.rktl @@ -921,6 +921,13 @@ (define-values (standard-module-name-resolver) (let-values () (define-values (planet-resolver) #f) + (define-values (prep-planet-resolver!) + (lambda () + (unless planet-resolver + (with-continuation-mark + parameterization-key + orig-paramz + (set! planet-resolver (dynamic-require '(lib "planet/resolver.rkt") 'planet-module-name-resolver)))))) (define-values (standard-module-name-resolver) (case-lambda [(s) @@ -996,21 +1003,14 @@ (append (cdr rp) r) r))))] [(and (pair? s) (eq? (car s) 'planet)) - (unless planet-resolver - (with-continuation-mark - parameterization-key - orig-paramz - (set! planet-resolver (dynamic-require '(lib "planet/resolver.rkt") 'planet-module-name-resolver)))) - (planet-resolver s relto stx load? orig-paramz)] + (prep-planet-resolver!) + (planet-resolver s relto stx load? #f orig-paramz)] [(and (pair? s) (eq? (car s) 'submod) (pair? (cadr s)) (eq? (caadr s) 'planet)) - (define p (standard-module-name-resolver (cadr s) relto stx load?)) - (let ([p (resolved-module-path-name relto)]) - (if (pair? p) - (flatten-sub-path (car p) (append (cdr p) (cddr s))) - (flatten-sub-path p (cddr s))))] + (prep-planet-resolver!) + (planet-resolver (cadr s) relto stx load? (cddr s) orig-paramz)] [else (let ([get-dir (lambda () (or (and relto