diff --git a/collects/compiler/embed-unit.rkt b/collects/compiler/embed-unit.rkt index 1ca92cc065..6f8be3d493 100644 --- a/collects/compiler/embed-unit.rkt +++ b/collects/compiler/embed-unit.rkt @@ -295,9 +295,12 @@ ;; Represent modules with lists starting with the filename, so we ;; can use assoc: - (define (make-mod normal-file-path normal-module-path code name prefix full-name relative-mappings runtime-paths) + (define (make-mod normal-file-path normal-module-path + code name prefix full-name relative-mappings runtime-paths + actual-file-path) (list normal-file-path normal-module-path code - name prefix full-name relative-mappings runtime-paths)) + name prefix full-name relative-mappings runtime-paths + actual-file-path)) (define (mod-file m) (car m)) (define (mod-mod-path m) (cadr m)) @@ -307,6 +310,7 @@ (define (mod-full-name m) (list-ref m 5)) (define (mod-mappings m) (list-ref m 6)) (define (mod-runtime-paths m) (list-ref m 7)) + (define (mod-actual-file m) (list-ref m 8)) (define (generate-prefix) (format "#%embedded:~a:" (gensym))) @@ -382,137 +386,146 @@ (begin (when verbose? (fprintf (current-error-port) "Getting ~s\n" filename)) - (let ([code (get-module-code filename - "compiled" - compiler - (if on-extension - (lambda (f l?) - (on-extension f l?) - #f) - (lambda (file _loader?) - (if _loader? - (error 'create-embedding-executable - "cannot use a _loader extension: ~e" - file) - (make-extension file)))) - #:choose - ;; Prefer extensions, if we're handling them: - (lambda (src zo so) + (let ([actual-filename filename]) ; `set!'ed below to adjust file suffix + (let ([code (get-module-code filename + "compiled" + compiler (if on-extension - #f - (if (and (file-exists? so) - ((file-date so) . >= . (file-date zo))) - 'so - #f))))] - [name (let-values ([(base name dir?) (split-path filename)]) - (path->string (path-replace-suffix name #"")))] - [prefix (let ([a (assoc filename prefixes)]) - (if a - (cdr a) - (generate-prefix)))]) - (cond - [(extension? code) - (when verbose? - (fprintf (current-error-port) " using extension: ~s\n" (extension-path code))) - (set-box! codes - (cons (make-mod filename module-path code - name prefix (string->symbol - (format "~a~a" prefix name)) - null null) - (unbox codes)))] - [code - (let ([importss (module-compiled-imports code)]) - (let ([all-file-imports (filter (lambda (x) - (let-values ([(x base) (module-path-index-split x)]) - (not (and (pair? x) - (eq? 'quote (car x)))))) - (apply append (map cdr importss)))] - [extra-paths (map symbol-to-lib-form (get-extra-imports filename code))]) - (let ([sub-files (map (lambda (i) (normalize (resolve-module-path-index i filename))) - all-file-imports)] - [sub-paths (map (lambda (i) (collapse-module-path-index i module-path)) - all-file-imports)] - [extra-files (map (lambda (i) (normalize (resolve-module-path-index (module-path-index-join i #f) - filename))) - extra-paths)]) - ;; Get code for imports: - (for-each (lambda (sub-filename sub-path) - (get-code sub-filename - sub-path - codes - prefixes - verbose? - collects-dest - on-extension - compiler - expand-namespace - get-extra-imports)) - (append sub-files extra-files) - (append sub-paths extra-paths)) - (let ([runtime-paths - (parameterize ([current-namespace expand-namespace]) - (eval code) - (let ([module-path - (if (path? module-path) - (path->complete-path module-path) - module-path)]) - (syntax-case (expand `(,#'module m mzscheme - (require (only ,module-path) - mzlib/runtime-path) - (runtime-paths ,module-path))) (quote) - [(_ m mz (#%mb rfs req (quote (spec ...)))) - (syntax->datum #'(spec ...))] - [_else (error 'create-empbedding-executable - "expansion mismatch when getting external paths")])))]) - (when verbose? - (unless (null? runtime-paths) - (fprintf (current-error-port) "Runtime paths for ~s: ~s\n" - filename - runtime-paths))) - (if (and collects-dest - (is-lib-path? module-path)) - ;; Install code as .zo: - (begin - (with-output-to-file (lib-module-filename collects-dest module-path) - #:exists 'truncate/replace - (lambda () - (write code))) - ;; Record module as copied - (set-box! codes - (cons (make-mod filename module-path #f - #f #f #f #f null) - (unbox codes)))) - ;; Build up relative module resolutions, relative to this one, - ;; that will be requested at run-time. - (let ([mappings (map (lambda (sub-i sub-filename sub-path) - (and (not (and collects-dest - (is-lib-path? sub-path))) - (let-values ([(path base) (module-path-index-split sub-i)]) - (and base ; can be #f if path isn't relative - (begin - ;; Assert: base should refer to this module: - (let-values ([(path2 base2) (module-path-index-split base)]) - (when (or path2 base2) - (error 'embed "unexpected nested module path index"))) - (let ([m (assoc sub-filename (unbox codes))]) - (cons path (mod-full-name m)))))))) - all-file-imports sub-files sub-paths)]) - ;; Record the module - (set-box! codes - (cons (make-mod filename module-path code - name prefix (string->symbol - (format "~a~a" prefix name)) - (filter (lambda (p) - (and p (cdr p))) - mappings) - runtime-paths) - (unbox codes)))))))))] - [else - (set-box! codes - (cons (make-mod filename module-path code - name #f #f - null null) - (unbox codes)))])))))) + (lambda (f l?) + (on-extension f l?) + #f) + (lambda (file _loader?) + (if _loader? + (error 'create-embedding-executable + "cannot use a _loader extension: ~e" + file) + (make-extension file)))) + #:choose + ;; Prefer extensions, if we're handling them: + (lambda (src zo so) + (set! actual-filename src) ; remember convert soure name + (if on-extension + #f + (if (and (file-exists? so) + ((file-date so) . >= . (file-date zo))) + 'so + #f))))] + [name (let-values ([(base name dir?) (split-path filename)]) + (path->string (path-replace-suffix name #"")))] + [prefix (let ([a (assoc filename prefixes)]) + (if a + (cdr a) + (generate-prefix)))]) + (cond + [(extension? code) + (when verbose? + (fprintf (current-error-port) " using extension: ~s\n" (extension-path code))) + (set-box! codes + (cons (make-mod filename module-path code + name prefix (string->symbol + (format "~a~a" prefix name)) + null null + actual-filename) + (unbox codes)))] + [code + (let ([importss (module-compiled-imports code)]) + (let ([all-file-imports (filter (lambda (x) + (let-values ([(x base) (module-path-index-split x)]) + (not (and (pair? x) + (eq? 'quote (car x)))))) + (apply append (map cdr importss)))] + [extra-paths + (map symbol-to-lib-form (get-extra-imports actual-filename code))]) + (let ([sub-files (map (lambda (i) (normalize (resolve-module-path-index i filename))) + all-file-imports)] + [sub-paths (map (lambda (i) (collapse-module-path-index i module-path)) + all-file-imports)] + [normalized-extra-paths (map (lambda (i) (collapse-module-path i module-path)) + extra-paths)] + [extra-files (map (lambda (i) (normalize (resolve-module-path-index (module-path-index-join i #f) + filename))) + extra-paths)]) + ;; Get code for imports: + (for-each (lambda (sub-filename sub-path) + (get-code sub-filename + sub-path + codes + prefixes + verbose? + collects-dest + on-extension + compiler + expand-namespace + get-extra-imports)) + (append sub-files extra-files) + (append sub-paths normalized-extra-paths)) + (let ([runtime-paths + (parameterize ([current-namespace expand-namespace]) + (eval code) + (let ([module-path + (if (path? module-path) + (path->complete-path module-path) + module-path)]) + (syntax-case (expand `(,#'module m mzscheme + (require (only ,module-path) + mzlib/runtime-path) + (runtime-paths ,module-path))) (quote) + [(_ m mz (#%mb rfs req (quote (spec ...)))) + (syntax->datum #'(spec ...))] + [_else (error 'create-empbedding-executable + "expansion mismatch when getting external paths")])))]) + (when verbose? + (unless (null? runtime-paths) + (fprintf (current-error-port) "Runtime paths for ~s: ~s\n" + filename + runtime-paths))) + (if (and collects-dest + (is-lib-path? module-path)) + ;; Install code as .zo: + (begin + (with-output-to-file (lib-module-filename collects-dest module-path) + #:exists 'truncate/replace + (lambda () + (write code))) + ;; Record module as copied + (set-box! codes + (cons (make-mod filename module-path #f + #f #f #f #f null + actual-filename) + (unbox codes)))) + ;; Build up relative module resolutions, relative to this one, + ;; that will be requested at run-time. + (let ([mappings (map (lambda (sub-i sub-filename sub-path) + (and (not (and collects-dest + (is-lib-path? sub-path))) + (let-values ([(path base) (module-path-index-split sub-i)]) + (and base ; can be #f if path isn't relative + (begin + ;; Assert: base should refer to this module: + (let-values ([(path2 base2) (module-path-index-split base)]) + (when (or path2 base2) + (error 'embed "unexpected nested module path index"))) + (let ([m (assoc sub-filename (unbox codes))]) + (cons path (mod-full-name m)))))))) + all-file-imports sub-files sub-paths)]) + ;; Record the module + (set-box! codes + (cons (make-mod filename module-path code + name prefix (string->symbol + (format "~a~a" prefix name)) + (filter (lambda (p) + (and p (cdr p))) + mappings) + runtime-paths + actual-filename) + (unbox codes)))))))))] + [else + (set-box! codes + (cons (make-mod filename module-path code + name #f #f + null null + actual-filename) + (unbox codes)))]))))))) ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -948,8 +961,8 @@ (make-resolved-module-path ',(mod-full-name nc)))) outp) - (if (src-filter (mod-file nc)) - (call-with-input-file* (mod-file nc) + (if (src-filter (mod-actual-file nc)) + (call-with-input-file* (mod-actual-file nc) (lambda (inp) (copy-port inp outp))) (write (mod-code nc) outp)))) diff --git a/collects/scribblings/raco/exe-api.scrbl b/collects/scribblings/raco/exe-api.scrbl index b33f841555..6085885dda 100644 --- a/collects/scribblings/raco/exe-api.scrbl +++ b/collects/scribblings/raco/exe-api.scrbl @@ -306,12 +306,15 @@ run-time path declarations in included modules, so that the path resolutions can be directed to the current locations (and, ultimately, redirected to copies in a distribution). -The @racket[#:src-filter] argument takes a path and returns true if +The @racket[#:src-filter] @racket[src-filter] argument takes a path and returns true if the corresponding file source should be included in the embedding executable in source form (instead of compiled form), @racket[#f] otherwise. The default returns @racket[#f] for all paths. Beware that the current output port may be redirected to the result executable -when the filter procedure is called. +when the filter procedure is called. Each path given to +@racket[src-filter] corresponds to the actual file name (e.g., +@filepath{.ss}/@filepath{.rkt} conversions have been applied as needed +to refer to the existing file). If the @racket[#:on-extension] argument is a procedure, the procedure is called when the traversal of module dependencies arrives at an @@ -321,7 +324,7 @@ location) to be embedded into the executable. The procedure is called with two arguments: a path for the extension, and a @racket[#f] (for historical reasons). -The @racket[#:get-extra-imports] argument takes a source pathname and +The @racket[#:get-extra-imports] @racket[extras-proc] argument takes a source pathname and compiled module for each module to be included in the executable. It returns a list of quoted module paths (absolute, as opposed to relative to the module) for extra modules to be included in the @@ -329,7 +332,9 @@ executable in addition to the modules that the source module @racket[require]s. For example, these modules might correspond to reader extensions needed to parse a module that will be included as source, as long as the reader is referenced through an absolute module -path.} +path. Each path given to @racket[extras-proc] corresponds to the +actual file name (e.g., @filepath{.ss}/@filepath{.rkt} conversions +have been applied as needed to refer to the existing file).} @defproc[(make-embedding-executable [dest path-string?] diff --git a/collects/tests/racket/embed-me12-rd.ss b/collects/tests/racket/embed-me12-rd.ss new file mode 100644 index 0000000000..682396a20b --- /dev/null +++ b/collects/tests/racket/embed-me12-rd.ss @@ -0,0 +1,15 @@ +(module embed-me11-rd mzscheme + (provide (rename *read-syntax read-syntax) + (rename *read read)) + + (define (*read port) + `(module embed-me11 mzscheme + (with-output-to-file "stdout" + (lambda () + (printf ,(read port) + ;; Use `getenv' at read time!!! + ,(getenv "ELEVEN"))) + 'append))) + + (define (*read-syntax src port) + (*read port))) diff --git a/collects/tests/racket/embed-me12.ss b/collects/tests/racket/embed-me12.ss new file mode 100644 index 0000000000..b9d5307248 --- /dev/null +++ b/collects/tests/racket/embed-me12.ss @@ -0,0 +1,2 @@ +#reader(lib "embed-me12-rd.rkt" "tests" "racket") +"It goes to ~a!\n" diff --git a/collects/tests/racket/embed.rktl b/collects/tests/racket/embed.rktl index f959ec7031..25924e8f06 100644 --- a/collects/tests/racket/embed.rktl +++ b/collects/tests/racket/embed.rktl @@ -397,23 +397,36 @@ ;; Try including source that needs a reader extension -(define (try-reader-test mred?) +(define (try-reader-test 12? mred? ss-file? ss-reader?) + ;; actual "11" files use ".rkt", actual "12" files use ".ss" (define dest (mk-dest mred?)) - (define filename "embed-me11.rkt") + (define filename (format (if ss-file? + "embed-me~a.ss" + "embed-me~a.rkt") + (if 12? "12" "11"))) (define (flags s) (string-append "-" s)) + (printf "Trying ~s ~s ~s ~s...\n" (if 12? "12" "11") mred? ss-file? ss-reader?) + (create-embedding-executable dest #:modules `((#t (lib ,filename "tests" "racket"))) #:cmdline `(,(flags "l") ,(string-append "tests/racket/" filename)) #:src-filter (lambda (f) (let-values ([(base name dir?) (split-path f)]) - (equal? name (string->path filename)))) + (equal? name (path-replace-suffix (string->path filename) + (if 12? #".ss" #".rkt"))))) #:get-extra-imports (lambda (f code) (let-values ([(base name dir?) (split-path f)]) - (if (equal? name (string->path filename)) - '((lib "embed-me11-rd.rkt" "tests" "racket")) + (if (equal? name (path-replace-suffix (string->path filename) + (if 12? #".ss" #".rkt"))) + `((lib ,(format (if ss-reader? + "embed-me~a-rd.ss" + "embed-me~a-rd.rkt") + (if 12? "12" "11")) + "tests" + "racket")) null))) #:mred? mred?) @@ -422,8 +435,11 @@ (putenv "ELEVEN" "done")) (define (try-reader) - (try-reader-test #f) - (try-reader-test #t)) + (for ([12? (in-list '(#f #t))]) + (try-reader-test 12? #f #f #f) + (try-reader-test 12? #t #f #f) + (try-reader-test 12? #f #t #f) + (try-reader-test 12? #f #f #t))) ;; ----------------------------------------