fix yet more ss<->rkt problems that interfered with *SL executables
Closes PR 11106
This commit is contained in:
Matthew Flatt
parent
8c2ba47fa5
commit
76c3c76214
|
|
@ -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))))
|
||||
|
|
|
|||
|
|
@ -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?]
|
||||
|
|
|
|||
15
collects/tests/racket/embed-me12-rd.ss
Normal file
15
collects/tests/racket/embed-me12-rd.ss
Normal file
|
|
@ -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)))
|
||||
2
collects/tests/racket/embed-me12.ss
Normal file
2
collects/tests/racket/embed-me12.ss
Normal file
|
|
@ -0,0 +1,2 @@
|
|||
#reader(lib "embed-me12-rd.rkt" "tests" "racket")
|
||||
"It goes to ~a!\n"
|
||||
|
|
@ -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)))
|
||||
|
||||
;; ----------------------------------------
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user