From b6a9330bf1e9a3b5cfc177b1d091f8f2dae38086 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 7 Oct 2011 10:08:09 -0600 Subject: [PATCH] more `raco exe' cycle repairs --- collects/compiler/embed-unit.rkt | 40 ++++++++++++++++------------ collects/tests/racket/embed-me13.rkt | 4 +++ collects/tests/racket/embed-me14.rkt | 5 ++++ collects/tests/racket/embed.rktl | 4 ++- 4 files changed, 35 insertions(+), 18 deletions(-) create mode 100644 collects/tests/racket/embed-me13.rkt create mode 100644 collects/tests/racket/embed-me14.rkt diff --git a/collects/compiler/embed-unit.rkt b/collects/compiler/embed-unit.rkt index 3202c00b92..994deafa9d 100644 --- a/collects/compiler/embed-unit.rkt +++ b/collects/compiler/embed-unit.rkt @@ -358,8 +358,16 @@ ;; 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* ([actual-filename filename] ; `set!'ed below to adjust file suffix + [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)))] + [full-name (string->symbol + (format "~a~a" prefix name))]) + (hash-set! working filename full-name) (let ([code (get-module-code filename "compiled" compiler @@ -376,19 +384,13 @@ #:choose ;; Prefer extensions, if we're handling them: (lambda (src zo so) - (set! actual-filename src) ; remember convert soure name + (set! actual-filename src) ; remember convert source 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)))]) + #f))))]) (cond [(extension? code) (when verbose? @@ -480,7 +482,13 @@ (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) + (let* ([lookup-full-name (lambda (sub-filename) + (let ([m (assoc sub-filename (unbox codes))]) + (if m + (mod-full-name m) + ;; must have been a cycle... + (hash-ref working sub-filename))))] + [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)]) @@ -490,14 +498,12 @@ (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)]) + (cons path (lookup-full-name sub-filename))))))) + 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)) + name prefix full-name (filter (lambda (p) (and p (cdr p))) mappings) @@ -509,7 +515,7 @@ [(null? runtime-paths) null] [(let ([p (car runtime-paths)]) (and (pair? p) (eq? (car p) 'module))) - (cons (mod-full-name (assoc (car extra-files) (unbox codes))) + (cons (lookup-full-name (car extra-files)) (loop (cdr runtime-paths) (cdr extra-files)))] [else (cons #f (loop (cdr runtime-paths) extra-files))])) diff --git a/collects/tests/racket/embed-me13.rkt b/collects/tests/racket/embed-me13.rkt new file mode 100644 index 0000000000..a29c30b53e --- /dev/null +++ b/collects/tests/racket/embed-me13.rkt @@ -0,0 +1,4 @@ +#lang racket/base +(require racket/runtime-path) +(define-runtime-module-path-index _mod "embed-me14.rkt") +(dynamic-require _mod #f) diff --git a/collects/tests/racket/embed-me14.rkt b/collects/tests/racket/embed-me14.rkt new file mode 100644 index 0000000000..0de4c9e9a2 --- /dev/null +++ b/collects/tests/racket/embed-me14.rkt @@ -0,0 +1,5 @@ +#lang racket/base +(require "embed-me13.rkt") +(with-output-to-file "stdout" + (lambda () (printf "This is 14\n")) + #:exists 'append) diff --git a/collects/tests/racket/embed.rktl b/collects/tests/racket/embed.rktl index 8186067b57..be92fb8b7b 100644 --- a/collects/tests/racket/embed.rktl +++ b/collects/tests/racket/embed.rktl @@ -216,6 +216,8 @@ (one-mz-test "embed-me1d.rkt" "This is 1d\n" #f) (one-mz-test "embed-me1e.rkt" "This is 1e\n" #f) (one-mz-test "embed-me2.rkt" "This is 1\nThis is 2: #t\n" #t) + (one-mz-test "embed-me13.rkt" "This is 14\n" #f) + (one-mz-test "embed-me14.rkt" "This is 14\n" #f) ;; Try unicode expr and cmdline: (prepare dest "unicode") @@ -304,7 +306,7 @@ (try-exe (mk-dest mred?) "This is 6\n#t\n" mred? void "cts") ; <- cts copied to distribution (delete-directory/files "cts") (test #f system* (mk-dest mred?)) - + (void))) (define (try-mzc)