fix raco exe' for cycles created via define-runtime-module-path'
This commit is contained in:
Matthew Flatt
parent
a0378d956a
commit
e640041dd6
|
|
@ -341,187 +341,194 @@
|
||||||
|
|
||||||
;; Loads module code, using .zo if there, compiling from .scm if not
|
;; Loads module code, using .zo if there, compiling from .scm if not
|
||||||
(define (get-code filename module-path codes prefixes verbose? collects-dest on-extension
|
(define (get-code filename module-path codes prefixes verbose? collects-dest on-extension
|
||||||
compiler expand-namespace get-extra-imports)
|
compiler expand-namespace get-extra-imports working)
|
||||||
(let ([a (assoc filename (unbox codes))])
|
(let ([a (assoc filename (unbox codes))])
|
||||||
(if a
|
(cond
|
||||||
;; Already have this module. Make sure that library-referenced
|
[a
|
||||||
;; modules are consistently referenced through library paths:
|
;; Already have this module. Make sure that library-referenced
|
||||||
(let ([found-lib? (is-lib-path? (mod-mod-path a))]
|
;; modules are consistently referenced through library paths:
|
||||||
[look-lib? (is-lib-path? module-path)])
|
(let ([found-lib? (is-lib-path? (mod-mod-path a))]
|
||||||
|
[look-lib? (is-lib-path? module-path)])
|
||||||
|
(cond
|
||||||
|
[(and found-lib? look-lib?)
|
||||||
|
'ok]
|
||||||
|
[(or found-lib? look-lib?)
|
||||||
|
(error 'find-module
|
||||||
|
"module referenced both as a library and through a path: ~a"
|
||||||
|
filename)]
|
||||||
|
[else 'ok]))]
|
||||||
|
[(hash-ref working filename #f)
|
||||||
|
;; in the process of loading the module; a cycle
|
||||||
|
;; is possible through `define-runtime-path'
|
||||||
|
'ok]
|
||||||
|
[else
|
||||||
|
;; First use of the module. Get code and then get code for imports.
|
||||||
|
(when verbose?
|
||||||
|
(fprintf (current-error-port) "Getting ~s\n" filename))
|
||||||
|
(let ([actual-filename filename]) ; `set!'ed below to adjust file suffix
|
||||||
|
(hash-set! working filename #t)
|
||||||
|
(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)
|
||||||
|
(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
|
(cond
|
||||||
[(and found-lib? look-lib?)
|
[(extension? code)
|
||||||
'ok]
|
(when verbose?
|
||||||
[(or found-lib? look-lib?)
|
(fprintf (current-error-port) " using extension: ~s\n" (extension-path code)))
|
||||||
(error 'find-module
|
(set-box! codes
|
||||||
"module referenced both as a library and through a path: ~a"
|
(cons (make-mod filename module-path code
|
||||||
filename)]
|
name prefix (string->symbol
|
||||||
[else 'ok]))
|
(format "~a~a" prefix name))
|
||||||
;; First use of the module. Get code and then get code for imports.
|
null null null
|
||||||
(begin
|
actual-filename)
|
||||||
(when verbose?
|
(unbox codes)))]
|
||||||
(fprintf (current-error-port) "Getting ~s\n" filename))
|
[code
|
||||||
(let ([actual-filename filename]) ; `set!'ed below to adjust file suffix
|
(let ([importss (module-compiled-imports code)])
|
||||||
(let ([code (get-module-code filename
|
(let ([all-file-imports (filter (lambda (x)
|
||||||
"compiled"
|
(let-values ([(x base) (module-path-index-split x)])
|
||||||
compiler
|
(not (and (pair? x)
|
||||||
(if on-extension
|
(eq? 'quote (car x))))))
|
||||||
(lambda (f l?)
|
(apply append (map cdr importss)))]
|
||||||
(on-extension f l?)
|
[extra-paths
|
||||||
#f)
|
(map symbol-to-lib-form (get-extra-imports actual-filename code))])
|
||||||
(lambda (file _loader?)
|
(let* ([runtime-paths
|
||||||
(if _loader?
|
(parameterize ([current-namespace expand-namespace])
|
||||||
(error 'create-embedding-executable
|
(eval code)
|
||||||
"cannot use a _loader extension: ~e"
|
(let ([module-path
|
||||||
file)
|
(if (path? module-path)
|
||||||
(make-extension file))))
|
(path->complete-path module-path)
|
||||||
#:choose
|
module-path)])
|
||||||
;; Prefer extensions, if we're handling them:
|
(syntax-case (expand `(,#'module m mzscheme
|
||||||
(lambda (src zo so)
|
(require (only ,module-path)
|
||||||
(set! actual-filename src) ; remember convert soure name
|
mzlib/runtime-path)
|
||||||
(if on-extension
|
(runtime-paths ,module-path))) (quote)
|
||||||
#f
|
[(_ m mz (#%mb rfs req (quote (spec ...))))
|
||||||
(if (and (file-exists? so)
|
(syntax->datum #'(spec ...))]
|
||||||
((file-date so) . >= . (file-date zo)))
|
[_else (error 'create-empbedding-executable
|
||||||
'so
|
"expansion mismatch when getting external paths")])))]
|
||||||
#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 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* ([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")])))]
|
|
||||||
|
|
||||||
[extra-runtime-paths (filter
|
[extra-runtime-paths (filter
|
||||||
values
|
values
|
||||||
(map (lambda (p)
|
(map (lambda (p)
|
||||||
(and (pair? p)
|
(and (pair? p)
|
||||||
(eq? (car p) 'module)
|
(eq? (car p) 'module)
|
||||||
(cadr p)))
|
(cadr p)))
|
||||||
runtime-paths))])
|
runtime-paths))])
|
||||||
(let ([sub-files (map (lambda (i) (normalize (resolve-module-path-index i filename)))
|
(let ([sub-files (map (lambda (i) (normalize (resolve-module-path-index i filename)))
|
||||||
all-file-imports)]
|
all-file-imports)]
|
||||||
[sub-paths (map (lambda (i) (collapse-module-path-index i module-path))
|
[sub-paths (map (lambda (i) (collapse-module-path-index i module-path))
|
||||||
all-file-imports)]
|
all-file-imports)]
|
||||||
[normalized-extra-paths (map (lambda (i) (collapse-module-path i module-path))
|
[normalized-extra-paths (map (lambda (i) (collapse-module-path i module-path))
|
||||||
(append extra-runtime-paths extra-paths))]
|
(append extra-runtime-paths extra-paths))]
|
||||||
[extra-files (map (lambda (i) (normalize (resolve-module-path-index (module-path-index-join i #f)
|
[extra-files (map (lambda (i) (normalize (resolve-module-path-index (module-path-index-join i #f)
|
||||||
filename)))
|
filename)))
|
||||||
;; getting runtime-module-path symbols below
|
;; getting runtime-module-path symbols below
|
||||||
;; relies on extra-runtime-paths being first:
|
;; relies on extra-runtime-paths being first:
|
||||||
(append extra-runtime-paths extra-paths))])
|
(append extra-runtime-paths extra-paths))])
|
||||||
;; Get code for imports:
|
;; Get code for imports:
|
||||||
(for-each (lambda (sub-filename sub-path)
|
(for-each (lambda (sub-filename sub-path)
|
||||||
(get-code sub-filename
|
(get-code sub-filename
|
||||||
sub-path
|
sub-path
|
||||||
codes
|
codes
|
||||||
prefixes
|
prefixes
|
||||||
verbose?
|
verbose?
|
||||||
collects-dest
|
collects-dest
|
||||||
on-extension
|
on-extension
|
||||||
compiler
|
compiler
|
||||||
expand-namespace
|
expand-namespace
|
||||||
get-extra-imports))
|
get-extra-imports
|
||||||
(append sub-files extra-files)
|
working))
|
||||||
(append sub-paths normalized-extra-paths))
|
(append sub-files extra-files)
|
||||||
(when verbose?
|
(append sub-paths normalized-extra-paths))
|
||||||
(unless (null? runtime-paths)
|
(when verbose?
|
||||||
(fprintf (current-error-port) "Runtime paths for ~s: ~s\n"
|
(unless (null? runtime-paths)
|
||||||
filename
|
(fprintf (current-error-port) "Runtime paths for ~s: ~s\n"
|
||||||
runtime-paths)))
|
filename
|
||||||
(if (and collects-dest
|
runtime-paths)))
|
||||||
(is-lib-path? module-path))
|
(if (and collects-dest
|
||||||
;; Install code as .zo:
|
(is-lib-path? module-path))
|
||||||
(begin
|
;; Install code as .zo:
|
||||||
(with-output-to-file (lib-module-filename collects-dest module-path)
|
(begin
|
||||||
#:exists 'truncate/replace
|
(with-output-to-file (lib-module-filename collects-dest module-path)
|
||||||
(lambda ()
|
#:exists 'truncate/replace
|
||||||
(write code)))
|
(lambda ()
|
||||||
;; Record module as copied
|
(write code)))
|
||||||
(set-box! codes
|
;; Record module as copied
|
||||||
(cons (make-mod filename module-path #f
|
(set-box! codes
|
||||||
#f #f #f
|
(cons (make-mod filename module-path #f
|
||||||
null null null
|
#f #f #f
|
||||||
actual-filename)
|
null null null
|
||||||
(unbox codes))))
|
actual-filename)
|
||||||
;; Build up relative module resolutions, relative to this one,
|
(unbox codes))))
|
||||||
;; that will be requested at run-time.
|
;; Build up relative module resolutions, relative to this one,
|
||||||
(let ([mappings (map (lambda (sub-i sub-filename sub-path)
|
;; that will be requested at run-time.
|
||||||
(and (not (and collects-dest
|
(let ([mappings (map (lambda (sub-i sub-filename sub-path)
|
||||||
(is-lib-path? sub-path)))
|
(and (not (and collects-dest
|
||||||
(let-values ([(path base) (module-path-index-split sub-i)])
|
(is-lib-path? sub-path)))
|
||||||
(and base ; can be #f if path isn't relative
|
(let-values ([(path base) (module-path-index-split sub-i)])
|
||||||
(begin
|
(and base ; can be #f if path isn't relative
|
||||||
;; Assert: base should refer to this module:
|
(begin
|
||||||
(let-values ([(path2 base2) (module-path-index-split base)])
|
;; Assert: base should refer to this module:
|
||||||
(when (or path2 base2)
|
(let-values ([(path2 base2) (module-path-index-split base)])
|
||||||
(error 'embed "unexpected nested module path index")))
|
(when (or path2 base2)
|
||||||
(let ([m (assoc sub-filename (unbox codes))])
|
(error 'embed "unexpected nested module path index")))
|
||||||
(cons path (mod-full-name m))))))))
|
(let ([m (assoc sub-filename (unbox codes))])
|
||||||
all-file-imports sub-files sub-paths)])
|
(cons path (mod-full-name m))))))))
|
||||||
;; Record the module
|
all-file-imports sub-files sub-paths)])
|
||||||
(set-box! codes
|
;; Record the module
|
||||||
(cons (make-mod filename module-path code
|
(set-box! codes
|
||||||
name prefix (string->symbol
|
(cons (make-mod filename module-path code
|
||||||
(format "~a~a" prefix name))
|
name prefix (string->symbol
|
||||||
(filter (lambda (p)
|
(format "~a~a" prefix name))
|
||||||
(and p (cdr p)))
|
(filter (lambda (p)
|
||||||
mappings)
|
(and p (cdr p)))
|
||||||
runtime-paths
|
mappings)
|
||||||
;; extract runtime-path module symbols:
|
runtime-paths
|
||||||
(let loop ([runtime-paths runtime-paths]
|
;; extract runtime-path module symbols:
|
||||||
[extra-files extra-files])
|
(let loop ([runtime-paths runtime-paths]
|
||||||
(cond
|
[extra-files extra-files])
|
||||||
[(null? runtime-paths) null]
|
(cond
|
||||||
[(let ([p (car runtime-paths)])
|
[(null? runtime-paths) null]
|
||||||
(and (pair? p) (eq? (car p) 'module)))
|
[(let ([p (car runtime-paths)])
|
||||||
(cons (mod-full-name (assoc (car extra-files) (unbox codes)))
|
(and (pair? p) (eq? (car p) 'module)))
|
||||||
(loop (cdr runtime-paths) (cdr extra-files)))]
|
(cons (mod-full-name (assoc (car extra-files) (unbox codes)))
|
||||||
[else
|
(loop (cdr runtime-paths) (cdr extra-files)))]
|
||||||
(cons #f (loop (cdr runtime-paths) extra-files))]))
|
[else
|
||||||
actual-filename)
|
(cons #f (loop (cdr runtime-paths) extra-files))]))
|
||||||
(unbox codes)))))))))]
|
actual-filename)
|
||||||
[else
|
(unbox codes)))))))))]
|
||||||
(set-box! codes
|
[else
|
||||||
(cons (make-mod filename module-path code
|
(set-box! codes
|
||||||
name #f #f
|
(cons (make-mod filename module-path code
|
||||||
null null null
|
name #f #f
|
||||||
actual-filename)
|
null null null
|
||||||
(unbox codes)))])))))))
|
actual-filename)
|
||||||
|
(unbox codes)))])))])))
|
||||||
|
|
||||||
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
|
|
||||||
|
|
@ -822,7 +829,8 @@
|
||||||
[get-code-at (lambda (f mp)
|
[get-code-at (lambda (f mp)
|
||||||
(get-code f mp codes prefix-mapping verbose? collects-dest
|
(get-code f mp codes prefix-mapping verbose? collects-dest
|
||||||
on-extension compiler expand-namespace
|
on-extension compiler expand-namespace
|
||||||
get-extra-imports))]
|
get-extra-imports
|
||||||
|
(make-hash)))]
|
||||||
[__
|
[__
|
||||||
;; Load all code:
|
;; Load all code:
|
||||||
(for-each get-code-at files collapsed-mps)]
|
(for-each get-code-at files collapsed-mps)]
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue
Block a user