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

fix problems with raco exe

Browse Source 
Merge to v5.0
This commit is contained in:
Matthew Flatt 2010-05-26 17:05:33 -06:00
parent 923ff555d9
commit 7442f14305
4 changed files with 78 additions and 61 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
collects/compiler/distribute.rkt
View File

@ -234,13 +234,13 @@
(build-path exe-dir dll))))) (build-path exe-dir dll)))))
(define (copy-framework name 3m? lib-dir) (define (copy-framework name 3m? lib-dir)
(let* ([fw-name (format "PLT_~a.framework" name)] (let* ([fw-name (format "~a.framework" name)]
[sub-dir (build-path fw-name "Versions" [sub-dir (build-path fw-name "Versions"
(if 3m? (if 3m?
(format "~a_3m" (version)) (format "~a_3m" (version))
(version)))]) (version)))])
(make-directory* (build-path lib-dir sub-dir)) (make-directory* (build-path lib-dir sub-dir))
(let* ([fw-name (build-path sub-dir (format "PLT_~a" name))] (let* ([fw-name (build-path sub-dir (format "~a" name))]
[dll-dir (find-framework fw-name)]) [dll-dir (find-framework fw-name)])
(copy-file* (build-path dll-dir fw-name) (copy-file* (build-path dll-dir fw-name)
(build-path lib-dir fw-name)) (build-path lib-dir fw-name))

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

@ -621,7 +621,10 @@
;; Have a relative mapping? ;; Have a relative mapping?
(let-values ([(a) (if rel-to (let-values ([(a) (if rel-to
(assq (resolved-module-path-name rel-to) mapping-table) (assq (resolved-module-path-name rel-to) mapping-table)
#f)]) #f)]
[(ss->rkt)
(lambda (s)
(regexp-replace #rx"[.]ss$" s ".rkt"))])
(if a (if a
(let-values ([(a2) (assoc name (cadr a))]) (let-values ([(a2) (assoc name (cadr a))])
(if a2 (if a2
@ -639,20 +642,20 @@
(if (null? (cddr name)) (if (null? (cddr name))
(if (regexp-match #rx"^[^/]*[.]" (cadr name)) (if (regexp-match #rx"^[^/]*[.]" (cadr name))
;; mzlib ;; mzlib
(string-append "mzlib/" (cadr name)) (string-append "mzlib/" (ss->rkt (cadr name)))
;; new-style ;; new-style
(if (regexp-match #rx"^[^/.]*$" (cadr name)) (if (regexp-match #rx"^[^/.]*$" (cadr name))
(string-append (cadr name) "/main.ss") (string-append (cadr name) "/main.rkt")
(if (regexp-match #rx"^[^.]*$" (cadr name)) (if (regexp-match #rx"^[^.]*$" (cadr name))
;; need a suffix: ;; need a suffix:
(string-append (cadr name) ".ss") (string-append (cadr name) ".rkt")
(cadr name)))) (ss->rkt (cadr name)))))
;; old-style multi-string ;; old-style multi-string
(string-append (apply string-append (string-append (apply string-append
(map (lambda (s) (map (lambda (s)
(string-append s "/")) (string-append s "/"))
(cddr name))) (cddr name)))
(cadr name))) (ss->rkt (cadr name))))
(if (eq? 'planet (car name)) (if (eq? 'planet (car name))
(if (null? (cddr name)) (if (null? (cddr name))
;; need to normalize: ;; need to normalize:
@ -673,7 +676,7 @@
(if (suffix-after . <= . 0) (if (suffix-after . <= . 0)
(if (regexp-match? #rx"[.]" s) (if (regexp-match? #rx"[.]" s)
s s
(string-append s ".ss")) (string-append s ".rkt"))
s)))))] s)))))]
[(last-of) [(last-of)
(lambda (l) (lambda (l)
@ -689,8 +692,8 @@
(let-values ([(vparts) (split (cadr parts) #rx":" +inf.0)]) (let-values ([(vparts) (split (cadr parts) #rx":" +inf.0)])
(cons 'planet (cons 'planet
(cons (if (null? (cddr parts)) (cons (if (null? (cddr parts))
"main.ss" "main.rkt"
(last-of parts)) (ss->rkt (last-of parts)))
(cons (cons
(cons (cons
(car parts) (car parts)
@ -743,6 +746,19 @@
;; Let default handler try: ;; Let default handler try:
(orig name rel-to stx load?))))))))))])]) (orig name rel-to stx load?))))))))))])])
(current-module-name-resolver embedded-resolver)))))) (current-module-name-resolver embedded-resolver))))))
(define (ss<->rkt path)
(cond
[(regexp-match? #rx#"[.]ss$" path)
(ss<->rkt (path-replace-suffix path #".rkt"))]
[(regexp-match? #rx#"[.]rkt$" path)
(if (file-exists? path)
path
(let ([p2 (path-replace-suffix path #".ss")])
(if (file-exists? path)
p2
path)))]
[else path]))
;; Write a module bundle that can be loaded with 'load' (do not embed it ;; Write a module bundle that can be loaded with 'load' (do not embed it
;; into an executable). The bundle is written to the current output port. ;; into an executable). The bundle is written to the current output port.
@ -757,7 +773,7 @@
(normalize f)))] (normalize f)))]
[files (map resolve-one-path module-paths)] [files (map resolve-one-path module-paths)]
[collapse-one (lambda (mp) [collapse-one (lambda (mp)
(collapse-module-path mp (build-path (current-directory) "dummy.ss")))] (collapse-module-path mp (build-path (current-directory) "dummy.rkt")))]
[collapsed-mps (map collapse-one module-paths)] [collapsed-mps (map collapse-one module-paths)]
[prefix-mapping (map (lambda (f m) [prefix-mapping (map (lambda (f m)
(cons f (let ([p (car m)]) (cons f (let ([p (car m)])
@ -811,7 +827,7 @@
(if (null? runtimes) (if (null? runtimes)
#f #f
(let* ([table-sym (module-path-index-resolve (let* ([table-sym (module-path-index-resolve
(module-path-index-join '(lib "runtime-path-table.ss" "mzlib" "private") (module-path-index-join '(lib "runtime-path-table.rkt" "mzlib" "private")
#f))] #f))]
[table-path (resolved-module-path-name table-sym)]) [table-path (resolved-module-path-name table-sym)])
(assoc (normalize table-path) l)))]) (assoc (normalize table-path) l)))])
@ -887,14 +903,15 @@
p p
(let ([s (regexp-split #rx"/" (cadr p))]) (let ([s (regexp-split #rx"/" (cadr p))])
(if (null? (cdr s)) (if (null? (cdr s))
`(lib "main.ss" ,(cadr p)) `(lib "main.rkt" ,(cadr p))
(let ([s (reverse s)]) (let ([s (reverse s)])
`(lib ,(car s) ,@(reverse (cdr s))))))) `(lib ,(car s) ,@(reverse (cdr s)))))))
p)]) p)])
(build-path (if (null? (cddr p)) (ss<->rkt
(collection-path "mzlib") (build-path (if (null? (cddr p))
(apply collection-path (cddr p))) (collection-path "mzlib")
(cadr p)))] (apply collection-path (cddr p)))
(cadr p))))]
[else p])]) [else p])])
(and p (and p
(path->bytes (path->bytes

2
collects/setup/dirs.rkt
View File

@ -180,7 +180,7 @@
(build-path dir r) (build-path dir r)
r))) r)))
p)))] p)))]
[rel (get/set-dylib-path exe "PLT_M[rz]" #f)]) [rel (get/set-dylib-path exe "Racket" #f)])
(cond (cond
[(not rel) #f] ; no framework reference found!? [(not rel) #f] ; no framework reference found!?
[(regexp-match [(regexp-match

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

@ -103,10 +103,10 @@
(prepare dest filename) (prepare dest filename)
(make-embedding-executable (make-embedding-executable
dest mred? #f dest mred? #f
`((#t (lib ,filename "tests" "mzscheme"))) `((#t (lib ,filename "tests" "racket")))
null null
#f #f
`(,(flags "l") ,(string-append "tests/mzscheme/" filename))) `(,(flags "l") ,(string-append "tests/racket/" filename)))
(try-exe dest expect mred?) (try-exe dest expect mred?)
;; Try explicit prefix: ;; Try explicit prefix:
@ -116,7 +116,7 @@
(prepare dest filename) (prepare dest filename)
(make-embedding-executable (make-embedding-executable
dest mred? #f dest mred? #f
`((,pfx (lib ,filename "tests" "mzscheme")) `((,pfx (lib ,filename "tests" "racket"))
(#t (lib "scheme/init"))) (#t (lib "scheme/init")))
null null
#f #f
@ -133,7 +133,7 @@
;; Try full path, and use literal S-exp to start ;; Try full path, and use literal S-exp to start
(printf ">>>literal sexp\n") (printf ">>>literal sexp\n")
(prepare dest filename) (prepare dest filename)
(let ([path (build-path (collection-path "tests" "mzscheme") filename)]) (let ([path (build-path (collection-path "tests" "racket") filename)])
(make-embedding-executable (make-embedding-executable
dest mred? #f dest mred? #f
`((#t ,path)) `((#t ,path))
@ -146,7 +146,7 @@
;; Use `file' form: ;; Use `file' form:
(printf ">>>file\n") (printf ">>>file\n")
(prepare dest filename) (prepare dest filename)
(let ([path (build-path (collection-path "tests" "mzscheme") filename)]) (let ([path (build-path (collection-path "tests" "racket") filename)])
(make-embedding-executable (make-embedding-executable
dest mred? #f dest mred? #f
`((#t (file ,(path->string path)))) `((#t (file ,(path->string path))))
@ -159,7 +159,7 @@
;; Use relative path ;; Use relative path
(printf ">>>relative path\n") (printf ">>>relative path\n")
(prepare dest filename) (prepare dest filename)
(parameterize ([current-directory (collection-path "tests" "mzscheme")]) (parameterize ([current-directory (collection-path "tests" "racket")])
(make-embedding-executable (make-embedding-executable
dest mred? #f dest mred? #f
`((#f ,filename)) `((#f ,filename))
@ -174,13 +174,13 @@
(prepare dest filename) (prepare dest filename)
(make-embedding-executable (make-embedding-executable
dest mred? #f dest mred? #f
`((#t (lib ,filename "tests" "mzscheme")) `((#t (lib ,filename "tests" "racket"))
(#t (lib "embed-me3.ss" "tests" "mzscheme"))) (#t (lib "embed-me3.rkt" "tests" "racket")))
null null
(base-compile (base-compile
`(begin `(begin
(namespace-require '(lib "embed-me3.ss" "tests" "mzscheme")) (namespace-require '(lib "embed-me3.rkt" "tests" "racket"))
(namespace-require '(lib ,filename "tests" "mzscheme")))) (namespace-require '(lib ,filename "tests" "racket"))))
`(,(flags ""))) `(,(flags "")))
(try-exe dest (string-append "3 is here, too? #t\n" expect) mred?) (try-exe dest (string-append "3 is here, too? #t\n" expect) mred?)
@ -195,14 +195,14 @@
'(namespace-require ''#%kernel))))) '(namespace-require ''#%kernel)))))
(make-embedding-executable (make-embedding-executable
dest mred? #f dest mred? #f
`((#t (lib ,filename "tests" "mzscheme"))) `((#t (lib ,filename "tests" "racket")))
(list (list
tmp tmp
(build-path (collection-path "tests" "mzscheme") "embed-me4.ss")) (build-path (collection-path "tests" "racket") "embed-me4.rktl"))
`(with-output-to-file "stdout" `(with-output-to-file "stdout"
(lambda () (display "... and more!\n")) (lambda () (display "... and more!\n"))
'append) 'append)
`(,(flags "l") ,(string-append "tests/mzscheme/" filename))) `(,(flags "l") ,(string-append "tests/racket/" filename)))
(delete-file tmp)) (delete-file tmp))
(try-exe dest (string-append (try-exe dest (string-append
"This is the literal expression 4.\n" "This is the literal expression 4.\n"
@ -210,12 +210,12 @@
expect) expect)
mred?))) mred?)))
(one-mz-test "embed-me1.ss" "This is 1\n" #t) (one-mz-test "embed-me1.rkt" "This is 1\n" #t)
(one-mz-test "embed-me1b.ss" "This is 1b\n" #f) (one-mz-test "embed-me1b.rkt" "This is 1b\n" #f)
(one-mz-test "embed-me1c.ss" "This is 1c\n" #f) (one-mz-test "embed-me1c.rkt" "This is 1c\n" #f)
(one-mz-test "embed-me1d.ss" "This is 1d\n" #f) (one-mz-test "embed-me1d.rkt" "This is 1d\n" #f)
(one-mz-test "embed-me1e.ss" "This is 1e\n" #f) (one-mz-test "embed-me1e.rkt" "This is 1e\n" #f)
(one-mz-test "embed-me2.ss" "This is 1\nThis is 2: #t\n" #t) (one-mz-test "embed-me2.rkt" "This is 1\nThis is 2: #t\n" #t)
;; Try unicode expr and cmdline: ;; Try unicode expr and cmdline:
(prepare dest "unicode") (prepare dest "unicode")
@ -238,13 +238,13 @@
(mz-tests #t) (mz-tests #t)
(begin (begin
(prepare mr-dest "embed-me5.ss") (prepare mr-dest "embed-me5.rkt")
(make-embedding-executable (make-embedding-executable
mr-dest #t #f mr-dest #t #f
`((#t (lib "embed-me5.ss" "tests" "mzscheme"))) `((#t (lib "embed-me5.rkt" "tests" "racket")))
null null
#f #f
`("-l" "tests/mzscheme/embed-me5.ss")) `("-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:
@ -260,15 +260,15 @@
(system* mzc (system* mzc
(if mred? "--gui-exe" "--exe") (if mred? "--gui-exe" "--exe")
(path->string (mk-dest mred?)) (path->string (mk-dest mred?))
(path->string (build-path (collection-path "tests" "mzscheme") "embed-me1.ss"))) (path->string (build-path (collection-path "tests" "racket") "embed-me1.rkt")))
(try-exe (mk-dest mred?) "This is 1\n" mred?) (try-exe (mk-dest mred?) "This is 1\n" mred?)
;; Check that etc.ss isn't found if it's not included: ;; Check that etc.rkt isn't found if it's not included:
(printf ">>not included\n") (printf ">>not included\n")
(system* mzc (system* mzc
(if mred? "--gui-exe" "--exe") (if mred? "--gui-exe" "--exe")
(path->string (mk-dest mred?)) (path->string (mk-dest mred?))
(path->string (build-path (collection-path "tests" "mzscheme") "embed-me6.ss"))) (path->string (build-path (collection-path "tests" "racket") "embed-me6.rkt")))
(try-exe (mk-dest mred?) "This is 6\nno etc.ss\n" mred?) (try-exe (mk-dest mred?) "This is 6\nno etc.ss\n" mred?)
;; And it is found if it is included: ;; And it is found if it is included:
@ -276,8 +276,8 @@
(system* mzc (system* mzc
(if mred? "--gui-exe" "--exe") (if mred? "--gui-exe" "--exe")
(path->string (mk-dest mred?)) (path->string (mk-dest mred?))
"++lib" "mzlib/etc.ss" "++lib" "mzlib/etc.rkt"
(path->string (build-path (collection-path "tests" "mzscheme") "embed-me6.ss"))) (path->string (build-path (collection-path "tests" "racket") "embed-me6.rkt")))
(try-exe (mk-dest mred?) "This is 6\n#t\n" mred?) (try-exe (mk-dest mred?) "This is 6\n#t\n" mred?)
;; Or, it's found if we set the collection path: ;; Or, it's found if we set the collection path:
@ -287,7 +287,7 @@
(path->string (mk-dest mred?)) (path->string (mk-dest mred?))
"--collects-path" "--collects-path"
(path->string (find-collects-dir)) (path->string (find-collects-dir))
(path->string (build-path (collection-path "tests" "mzscheme") "embed-me6.ss"))) (path->string (build-path (collection-path "tests" "racket") "embed-me6.rkt")))
;; Don't try a distribution for this one: ;; Don't try a distribution for this one:
(try-one-exe (mk-dest mred?) "This is 6\n#t\n" mred?) (try-one-exe (mk-dest mred?) "This is 6\n#t\n" mred?)
@ -296,10 +296,10 @@
(system* mzc (system* mzc
(if mred? "--gui-exe" "--exe") (if mred? "--gui-exe" "--exe")
(path->string (mk-dest mred?)) (path->string (mk-dest mred?))
"++lib" "mzlib/etc.ss" "++lib" "mzlib/etc.rkt"
"--collects-dest" "cts" "--collects-dest" "cts"
"--collects-path" "cts" "--collects-path" "cts"
(path->string (build-path (collection-path "tests" "mzscheme") "embed-me6.ss"))) (path->string (build-path (collection-path "tests" "racket") "embed-me6.rkt")))
(try-exe (mk-dest mred?) "This is 6\n#t\n" mred? void "cts") ; <- cts copied to distribution (try-exe (mk-dest mred?) "This is 6\n#t\n" mred? void "cts") ; <- cts copied to distribution
(delete-directory/files "cts") (delete-directory/files "cts")
(test #f system* (mk-dest mred?)) (test #f system* (mk-dest mred?))
@ -326,17 +326,17 @@
(system-library-subpath))) (system-library-subpath)))
(define ext-file (define ext-file
(build-path ext-dir (append-extension-suffix "embed-me8_ss"))) (build-path ext-dir (append-extension-suffix "embed-me8_rkt")))
(define ss-file (define ss-file
(build-path (find-system-path 'temp-dir) "embed-me9.ss")) (build-path (find-system-path 'temp-dir) "embed-me9.rkt"))
(make-directory* ext-dir) (make-directory* ext-dir)
(system* mzc (system* mzc
"--cc" "--cc"
"-d" (path->string (path-only obj-file)) "-d" (path->string (path-only obj-file))
(path->string (build-path (collection-path "tests" "mzscheme") "embed-me8.c"))) (path->string (build-path (collection-path "tests" "racket") "embed-me8.c")))
(system* mzc (system* mzc
"--ld" "--ld"
(path->string ext-file) (path->string ext-file)
@ -344,7 +344,7 @@
(when (file-exists? ss-file) (when (file-exists? ss-file)
(delete-file ss-file)) (delete-file ss-file))
(copy-file (build-path (collection-path "tests" "mzscheme") "embed-me9.ss") (copy-file (build-path (collection-path "tests" "racket") "embed-me9.rkt")
ss-file) ss-file)
(system* mzc (system* mzc
@ -361,7 +361,7 @@
(system* mzc (system* mzc
(if mred? "--gui-exe" "--exe") (if mred? "--gui-exe" "--exe")
(path->string (mk-dest mred?)) (path->string (mk-dest mred?))
(path->string (build-path (collection-path "tests" "mzscheme") "embed-me10.ss"))) (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) (extension-test #f)
@ -372,7 +372,7 @@
(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" "mzscheme") "embed-me5.ss"))) (path->string (build-path (collection-path "tests" "racket") "embed-me5.rkt")))
(try-exe (mk-dest #t) "This is 5: #<class:button%>\n" #t)) (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:
@ -382,34 +382,34 @@
(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" "mzscheme") "embed-me7.ss")) (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" "mzscheme") "embed-me7.ss"))) (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
(define (try-reader-test mred?) (define (try-reader-test mred?)
(define dest (mk-dest mred?)) (define dest (mk-dest mred?))
(define filename "embed-me11.ss") (define filename "embed-me11.rkt")
(define (flags s) (define (flags s)
(string-append "-" s)) (string-append "-" s))
(create-embedding-executable (create-embedding-executable
dest dest
#:modules `((#t (lib ,filename "tests" "mzscheme"))) #:modules `((#t (lib ,filename "tests" "racket")))
#:cmdline `(,(flags "l") ,(string-append "tests/mzscheme/" filename)) #:cmdline `(,(flags "l") ,(string-append "tests/racket/" filename))
#:src-filter (lambda (f) #:src-filter (lambda (f)
(let-values ([(base name dir?) (split-path f)]) (let-values ([(base name dir?) (split-path f)])
(equal? name (string->path filename)))) (equal? name (string->path filename))))
#:get-extra-imports (lambda (f code) #:get-extra-imports (lambda (f code)
(let-values ([(base name dir?) (split-path f)]) (let-values ([(base name dir?) (split-path f)])
(if (equal? name (string->path filename)) (if (equal? name (string->path filename))
'((lib "embed-me11-rd.ss" "tests" "mzscheme")) '((lib "embed-me11-rd.rkt" "tests" "racket"))
null))) null)))
#:mred? mred?) #:mred? mred?)