From 195b37831b802472a24d01df1a629ee465835af6 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 9 Jul 2010 09:48:41 -0600 Subject: [PATCH] fix `planet'-path bug in module-name resolver for generated eecutables --- collects/compiler/embed-unit.rkt | 78 ++++++----- collects/meta/props | 5 + collects/tests/racket/embed-planet-1/alt.rkt | 6 + collects/tests/racket/embed-planet-1/main.rkt | 4 + .../tests/racket/embed-planet-1/other.rkt | 6 + collects/tests/racket/embed-planet-2/main.ss | 5 + .../racket/embed-planet-2/private/sub.rkt | 6 + collects/tests/racket/embed.rktl | 131 +++++++++++++----- 8 files changed, 170 insertions(+), 71 deletions(-) create mode 100644 collects/tests/racket/embed-planet-1/alt.rkt create mode 100644 collects/tests/racket/embed-planet-1/main.rkt create mode 100644 collects/tests/racket/embed-planet-1/other.rkt create mode 100644 collects/tests/racket/embed-planet-2/main.ss create mode 100644 collects/tests/racket/embed-planet-2/private/sub.rkt diff --git a/collects/compiler/embed-unit.rkt b/collects/compiler/embed-unit.rkt index 08ef7c37ad..e5665b94d3 100644 --- a/collects/compiler/embed-unit.rkt +++ b/collects/compiler/embed-unit.rkt @@ -657,37 +657,37 @@ (cddr name))) (ss->rkt (cadr name)))) (if (eq? 'planet (car name)) - (if (null? (cddr name)) - ;; need to normalize: - (let-values ([(s) (if (symbol? (cadr name)) - (symbol->string (cadr name)) - (cadr name))]) - (letrec-values ([(split) - (lambda (s rx suffix-after) - (let-values ([(m) (regexp-match-positions - rx - s)]) - (if m - (cons (substring s 0 (caar m)) - (split (substring s (cdar m)) - rx - (- suffix-after 1))) - (list - (if (suffix-after . <= . 0) - (if (regexp-match? #rx"[.]" s) - s - (string-append s ".rkt")) - s)))))] - [(last-of) - (lambda (l) - (if (null? (cdr l)) - (car l) - (last-of (cdr l))))] - [(not-last) - (lambda (l) - (if (null? (cdr l)) - null - (cons (car l) (not-last (cdr l)))))]) + (letrec-values ([(split) + (lambda (s rx suffix-after) + (let-values ([(m) (regexp-match-positions + rx + s)]) + (if m + (cons (substring s 0 (caar m)) + (split (substring s (cdar m)) + rx + (- suffix-after 1))) + (list + (if (suffix-after . <= . 0) + (if (regexp-match? #rx"[.]" s) + s + (string-append s ".rkt")) + s)))))] + [(last-of) + (lambda (l) + (if (null? (cdr l)) + (car l) + (last-of (cdr l))))] + [(not-last) + (lambda (l) + (if (null? (cdr l)) + null + (cons (car l) (not-last (cdr l)))))]) + (if (null? (cddr name)) + ;; need to normalize: + (let-values ([(s) (if (symbol? (cadr name)) + (symbol->string (cadr name)) + (cadr name))]) (let-values ([(parts) (split s #rx"/" 2)]) (let-values ([(vparts) (split (cadr parts) #rx":" +inf.0)]) (cons 'planet @@ -705,13 +705,23 @@ (cdddr parts)))) (if (null? (cddr parts)) null - (not-last (cddr parts)))))))))) - ;; already in long form: - name) + (not-last (cddr parts))))))))) + ;; already in long form; move subcollects to end: + (let-values ([(s) (cadr name)]) + (let-values ([(parts) (split s #rx"/" +inf.0)]) + (if (= 1 (length parts)) + name + (list* 'planet + (last-of parts) + (caddr name) + (append + (cdddr name) + (not-last parts)))))))) #f)) #f))] [(planet-match?) (lambda (a b) + (eprintf "pmatch? ~s ~s\n" a b) (if (equal? (cons (car a) (cddr a)) (cons (car b) (cddr b))) (let-values ([(a) (cadr a)] diff --git a/collects/meta/props b/collects/meta/props index cc6f9fcd35..150c1e106a 100755 --- a/collects/meta/props +++ b/collects/meta/props @@ -1694,6 +1694,11 @@ path/s is either such a string or a list of them. "collects/tests/racket/embed-me5.rkt" drdr:command-line (gracket-text "-t" *) "collects/tests/racket/embed-me7.rkt" drdr:command-line (gracket-text "-t" *) "collects/tests/racket/embed-me9.rkt" drdr:command-line #f +"collects/tests/racket/embed-planet-1/alt.rktl" drdr:command-line #f +"collects/tests/racket/embed-planet-1/main.rktl" drdr:command-line #f +"collects/tests/racket/embed-planet-1/other.rktl" drdr:command-line #f +"collects/tests/racket/embed-planet-2/main.ss" drdr:command-line #f +"collects/tests/racket/embed-planet-2/private/sub.rkt" drdr:command-line #f "collects/tests/racket/embed.rktl" drdr:command-line #f "collects/tests/racket/etc.rktl" drdr:command-line (racket "-f" *) "collects/tests/racket/expand.rktl" drdr:command-line #f diff --git a/collects/tests/racket/embed-planet-1/alt.rkt b/collects/tests/racket/embed-planet-1/alt.rkt new file mode 100644 index 0000000000..197192d70e --- /dev/null +++ b/collects/tests/racket/embed-planet-1/alt.rkt @@ -0,0 +1,6 @@ +#lang racket/base +(require "main.ss") + +(with-output-to-file "stdout" + #:exists 'append + (lambda () (displayln "alt"))) diff --git a/collects/tests/racket/embed-planet-1/main.rkt b/collects/tests/racket/embed-planet-1/main.rkt new file mode 100644 index 0000000000..c2ec8174a1 --- /dev/null +++ b/collects/tests/racket/embed-planet-1/main.rkt @@ -0,0 +1,4 @@ +#lang racket/base + +(with-output-to-file "stdout" + (lambda () (displayln "one"))) diff --git a/collects/tests/racket/embed-planet-1/other.rkt b/collects/tests/racket/embed-planet-1/other.rkt new file mode 100644 index 0000000000..98b95b7a4e --- /dev/null +++ b/collects/tests/racket/embed-planet-1/other.rkt @@ -0,0 +1,6 @@ +#lang racket/base +(require (planet racket-tester/p2)) + +(with-output-to-file "stdout" + #:exists 'append + (lambda () (displayln "other"))) diff --git a/collects/tests/racket/embed-planet-2/main.ss b/collects/tests/racket/embed-planet-2/main.ss new file mode 100644 index 0000000000..818ed55316 --- /dev/null +++ b/collects/tests/racket/embed-planet-2/main.ss @@ -0,0 +1,5 @@ +#lang racket/base + + +(with-output-to-file "stdout" + (lambda () (displayln "two"))) diff --git a/collects/tests/racket/embed-planet-2/private/sub.rkt b/collects/tests/racket/embed-planet-2/private/sub.rkt new file mode 100644 index 0000000000..120caf0483 --- /dev/null +++ b/collects/tests/racket/embed-planet-2/private/sub.rkt @@ -0,0 +1,6 @@ +#lang racket/base +(require "../main.ss") + +(with-output-to-file "stdout" + #:exists 'append + (lambda () (displayln "sub"))) diff --git a/collects/tests/racket/embed.rktl b/collects/tests/racket/embed.rktl index 19c392502d..25036d3566 100644 --- a/collects/tests/racket/embed.rktl +++ b/collects/tests/racket/embed.rktl @@ -234,18 +234,19 @@ `(,(flags "ne") "(out \"\u7237...\U1D671\n\")")) (try-exe dest "\uA9, \u7238, and \U1D670\n\u7237...\U1D671\n" mred?)) -(mz-tests #f) -(mz-tests #t) +(define (try-basic) + (mz-tests #f) + (mz-tests #t) -(begin - (prepare mr-dest "embed-me5.rkt") - (make-embedding-executable - mr-dest #t #f - `((#t (lib "embed-me5.rkt" "tests" "racket"))) - null - #f - `("-l" "tests/racket/embed-me5.rkt")) - (try-exe mr-dest "This is 5: #\n" #t)) + (begin + (prepare mr-dest "embed-me5.rkt") + (make-embedding-executable + mr-dest #t #f + `((#t (lib "embed-me5.rkt" "tests" "racket"))) + null + #f + `("-l" "tests/racket/embed-me5.rkt")) + (try-exe mr-dest "This is 5: #\n" #t))) ;; Try the mzc interface: (require setup/dirs @@ -306,8 +307,9 @@ (void))) -(mzc-tests #f) -(mzc-tests #t) +(define (try-mzc) + (mzc-tests #f) + (mzc-tests #t)) (require dynext/file) (define (extension-test mred?) @@ -364,32 +366,34 @@ (path->string (build-path (collection-path "tests" "racket") "embed-me10.rkt"))) (try-exe (mk-dest mred?) "#t\n" mred?))) -(extension-test #f) -(extension-test #t) +(define (try-extension) + (extension-test #f) + (extension-test #t)) -;; A GRacket-specific test with mzc: -(parameterize ([current-directory (find-system-path 'temp-dir)]) - (system* mzc - "--gui-exe" - (path->string (mk-dest #t)) - (path->string (build-path (collection-path "tests" "racket") "embed-me5.rkt"))) - (try-exe (mk-dest #t) "This is 5: #\n" #t)) +(define (try-gracket) + ;; A GRacket-specific test with mzc: + (parameterize ([current-directory (find-system-path 'temp-dir)]) + (system* mzc + "--gui-exe" + (path->string (mk-dest #t)) + (path->string (build-path (collection-path "tests" "racket") "embed-me5.rkt"))) + (try-exe (mk-dest #t) "This is 5: #\n" #t)) -;; Another GRacket-specific: try embedding plot, which has extra DLLs and font files: -(parameterize ([current-directory (find-system-path 'temp-dir)]) - (define direct (build-path (find-system-path 'temp-dir) "direct.ps")) + ;; Another GRacket-specific: try embedding plot, which has extra DLLs and font files: + (parameterize ([current-directory (find-system-path 'temp-dir)]) + (define direct (build-path (find-system-path 'temp-dir) "direct.ps")) - (test #t - system* (build-path (find-console-bin-dir) "mred") - "-qu" - (path->string (build-path (collection-path "tests" "racket") "embed-me7.rkt")) - (path->string direct)) + (test #t + system* (build-path (find-console-bin-dir) "mred") + "-qu" + (path->string (build-path (collection-path "tests" "racket") "embed-me7.rkt")) + (path->string direct)) - (system* mzc - "--gui-exe" - (path->string (mk-dest #t)) - (path->string (build-path (collection-path "tests" "racket") "embed-me7.rkt"))) - (try-exe (mk-dest #t) "plotted\n" #t)) + (system* mzc + "--gui-exe" + (path->string (mk-dest #t)) + (path->string (build-path (collection-path "tests" "racket") "embed-me7.rkt"))) + (try-exe (mk-dest #t) "plotted\n" #t))) ;; Try including source that needs a reader extension @@ -417,7 +421,60 @@ (try-exe dest "It goes to eleven!\n" mred?) (putenv "ELEVEN" "done")) -(try-reader-test #f) -(try-reader-test #t) +(define (try-reader) + (try-reader-test #f) + (try-reader-test #t)) + +;; ---------------------------------------- + +(define planet (build-path (find-console-bin-dir) (if (eq? 'windows (system-type)) + "planet.exe" + "planet"))) + +(define (try-planet) + (system* planet "link" "racket-tester" "p1.plt" "1" "0" + (path->string (collection-path "tests" "racket" "embed-planet-1"))) + (system* planet "link" "racket-tester" "p2.plt" "2" "2" + (path->string (collection-path "tests" "racket" "embed-planet-2"))) + + (let ([go (lambda (path expected) + (printf "Trying planet ~s...\n" path) + (let ([tmp (make-temporary-file)] + [dest (mk-dest #f)]) + (with-output-to-file tmp + #:exists 'truncate + (lambda () + (printf "#lang racket/base (require ~s)\n" path))) + (system* mzc "--exe" (path->string dest) (path->string tmp)) + (try-exe dest expected #f) + + (delete-directory/files dest) + + (delete-file tmp)))]) + (go '(planet racket-tester/p1) "one\n") + (go '(planet "racket-tester/p1:1") "one\n") + (go '(planet "racket-tester/p1:1:0") "one\n") + (go '(planet "racket-tester/p1:1:0/main.ss") "one\n") + (go '(planet racket-tester/p2) "two\n") + + (go '(planet racket-tester/p1/alt) "one\nalt\n") + (go '(planet racket-tester/p1/other) "two\nother\n") + (go '(planet "private/sub.rkt" ("racket-tester" "p2.plt" 2 0)) "two\nsub\n") + + (void)) + + (system* planet "unlink" "racket-tester" "p1.plt" "1" "0") + (system* planet "unlink" "racket-tester" "p2.plt" "2" "2")) + +;; ---------------------------------------- + +(try-basic) +(try-mzc) +(try-extension) +(try-gracket) +(try-reader) +(try-planet) + +;; ---------------------------------------- (report-errs)