suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

fix `planet'-path bug in module-name resolver for generated eecutables

Browse Source
This commit is contained in:
Matthew Flatt 2010-07-09 09:48:41 -06:00
parent 41551a4987
commit 195b37831b
8 changed files with 170 additions and 71 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

78
collects/compiler/embed-unit.rkt
View File

@ -657,37 +657,37 @@
(cddr name))) (cddr name)))
(ss->rkt (cadr name)))) (ss->rkt (cadr name))))
(if (eq? 'planet (car name)) (if (eq? 'planet (car name))
(if (null? (cddr name)) (letrec-values ([(split)
;; need to normalize: (lambda (s rx suffix-after)
(let-values ([(s) (if (symbol? (cadr name)) (let-values ([(m) (regexp-match-positions
(symbol->string (cadr name)) rx
(cadr name))]) s)])
(letrec-values ([(split) (if m
(lambda (s rx suffix-after) (cons (substring s 0 (caar m))
(let-values ([(m) (regexp-match-positions (split (substring s (cdar m))
rx rx
s)]) (- suffix-after 1)))
(if m (list
(cons (substring s 0 (caar m)) (if (suffix-after . <= . 0)
(split (substring s (cdar m)) (if (regexp-match? #rx"[.]" s)
rx s
(- suffix-after 1))) (string-append s ".rkt"))
(list s)))))]
(if (suffix-after . <= . 0) [(last-of)
(if (regexp-match? #rx"[.]" s) (lambda (l)
s (if (null? (cdr l))
(string-append s ".rkt")) (car l)
s)))))] (last-of (cdr l))))]
[(last-of) [(not-last)
(lambda (l) (lambda (l)
(if (null? (cdr l)) (if (null? (cdr l))
(car l) null
(last-of (cdr l))))] (cons (car l) (not-last (cdr l)))))])
[(not-last) (if (null? (cddr name))
(lambda (l) ;; need to normalize:
(if (null? (cdr l)) (let-values ([(s) (if (symbol? (cadr name))
null (symbol->string (cadr name))
(cons (car l) (not-last (cdr l)))))]) (cadr name))])
(let-values ([(parts) (split s #rx"/" 2)]) (let-values ([(parts) (split s #rx"/" 2)])
(let-values ([(vparts) (split (cadr parts) #rx":" +inf.0)]) (let-values ([(vparts) (split (cadr parts) #rx":" +inf.0)])
(cons 'planet (cons 'planet
@ -705,13 +705,23 @@
(cdddr parts)))) (cdddr parts))))
(if (null? (cddr parts)) (if (null? (cddr parts))
null null
(not-last (cddr parts)))))))))) (not-last (cddr parts)))))))))
;; already in long form: ;; already in long form; move subcollects to end:
name) (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))
#f))] #f))]
[(planet-match?) [(planet-match?)
(lambda (a b) (lambda (a b)
(eprintf "pmatch? ~s ~s\n" a b)
(if (equal? (cons (car a) (cddr a)) (if (equal? (cons (car a) (cddr a))
(cons (car b) (cddr b))) (cons (car b) (cddr b)))
(let-values ([(a) (cadr a)] (let-values ([(a) (cadr a)]

5
collects/meta/props
View File

@ -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-me5.rkt" drdr:command-line (gracket-text "-t" *)
"collects/tests/racket/embed-me7.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-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/embed.rktl" drdr:command-line #f
"collects/tests/racket/etc.rktl" drdr:command-line (racket "-f" *) "collects/tests/racket/etc.rktl" drdr:command-line (racket "-f" *)
"collects/tests/racket/expand.rktl" drdr:command-line #f "collects/tests/racket/expand.rktl" drdr:command-line #f

6
collects/tests/racket/embed-planet-1/alt.rkt Normal file
View File

@ -0,0 +1,6 @@
#lang racket/base
(require "main.ss")
(with-output-to-file "stdout"
#:exists 'append
(lambda () (displayln "alt")))

4
collects/tests/racket/embed-planet-1/main.rkt Normal file
View File

@ -0,0 +1,4 @@
#lang racket/base
(with-output-to-file "stdout"
(lambda () (displayln "one")))

6
collects/tests/racket/embed-planet-1/other.rkt Normal file
View File

@ -0,0 +1,6 @@
#lang racket/base
(require (planet racket-tester/p2))
(with-output-to-file "stdout"
#:exists 'append
(lambda () (displayln "other")))

5
collects/tests/racket/embed-planet-2/main.ss Normal file
View File

@ -0,0 +1,5 @@
#lang racket/base
(with-output-to-file "stdout"
(lambda () (displayln "two")))

6
collects/tests/racket/embed-planet-2/private/sub.rkt Normal file
View File

@ -0,0 +1,6 @@
#lang racket/base
(require "../main.ss")
(with-output-to-file "stdout"
#:exists 'append
(lambda () (displayln "sub")))

131
collects/tests/racket/embed.rktl
View File

@ -234,18 +234,19 @@
`(,(flags "ne") "(out \"\u7237...\U1D671\n\")")) `(,(flags "ne") "(out \"\u7237...\U1D671\n\")"))
(try-exe dest "\uA9, \u7238, and \U1D670\n\u7237...\U1D671\n" mred?)) (try-exe dest "\uA9, \u7238, and \U1D670\n\u7237...\U1D671\n" mred?))
(mz-tests #f) (define (try-basic)
(mz-tests #t) (mz-tests #f)
(mz-tests #t)
(begin (begin
(prepare mr-dest "embed-me5.rkt") (prepare mr-dest "embed-me5.rkt")
(make-embedding-executable (make-embedding-executable
mr-dest #t #f mr-dest #t #f
`((#t (lib "embed-me5.rkt" "tests" "racket"))) `((#t (lib "embed-me5.rkt" "tests" "racket")))
null null
#f #f
`("-l" "tests/racket/embed-me5.rkt")) `("-l" "tests/racket/embed-me5.rkt"))
(try-exe mr-dest "This is 5: #<class:button%>\n" #t)) (try-exe mr-dest "This is 5: #<class:button%>\n" #t)))
;; Try the mzc interface: ;; Try the mzc interface:
(require setup/dirs (require setup/dirs
@ -306,8 +307,9 @@
(void))) (void)))
(mzc-tests #f) (define (try-mzc)
(mzc-tests #t) (mzc-tests #f)
(mzc-tests #t))
(require dynext/file) (require dynext/file)
(define (extension-test mred?) (define (extension-test mred?)
@ -364,32 +366,34 @@
(path->string (build-path (collection-path "tests" "racket") "embed-me10.rkt"))) (path->string (build-path (collection-path "tests" "racket") "embed-me10.rkt")))
(try-exe (mk-dest mred?) "#t\n" mred?))) (try-exe (mk-dest mred?) "#t\n" mred?)))
(extension-test #f) (define (try-extension)
(extension-test #t) (extension-test #f)
(extension-test #t))
;; A GRacket-specific test with mzc: (define (try-gracket)
(parameterize ([current-directory (find-system-path 'temp-dir)]) ;; A GRacket-specific test with mzc:
(system* mzc (parameterize ([current-directory (find-system-path 'temp-dir)])
"--gui-exe" (system* mzc
(path->string (mk-dest #t)) "--gui-exe"
(path->string (build-path (collection-path "tests" "racket") "embed-me5.rkt"))) (path->string (mk-dest #t))
(try-exe (mk-dest #t) "This is 5: #<class:button%>\n" #t)) (path->string (build-path (collection-path "tests" "racket") "embed-me5.rkt")))
(try-exe (mk-dest #t) "This is 5: #<class:button%>\n" #t))
;; Another GRacket-specific: try embedding plot, which has extra DLLs and font files: ;; Another GRacket-specific: try embedding plot, which has extra DLLs and font files:
(parameterize ([current-directory (find-system-path 'temp-dir)]) (parameterize ([current-directory (find-system-path 'temp-dir)])
(define direct (build-path (find-system-path 'temp-dir) "direct.ps")) (define direct (build-path (find-system-path 'temp-dir) "direct.ps"))
(test #t (test #t
system* (build-path (find-console-bin-dir) "mred") system* (build-path (find-console-bin-dir) "mred")
"-qu" "-qu"
(path->string (build-path (collection-path "tests" "racket") "embed-me7.rkt")) (path->string (build-path (collection-path "tests" "racket") "embed-me7.rkt"))
(path->string direct)) (path->string direct))
(system* mzc (system* mzc
"--gui-exe" "--gui-exe"
(path->string (mk-dest #t)) (path->string (mk-dest #t))
(path->string (build-path (collection-path "tests" "racket") "embed-me7.rkt"))) (path->string (build-path (collection-path "tests" "racket") "embed-me7.rkt")))
(try-exe (mk-dest #t) "plotted\n" #t)) (try-exe (mk-dest #t) "plotted\n" #t)))
;; Try including source that needs a reader extension ;; Try including source that needs a reader extension
@ -417,7 +421,60 @@
(try-exe dest "It goes to eleven!\n" mred?) (try-exe dest "It goes to eleven!\n" mred?)
(putenv "ELEVEN" "done")) (putenv "ELEVEN" "done"))
(try-reader-test #f) (define (try-reader)
(try-reader-test #t) (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) (report-errs)