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

v3.99.0.2

Browse Source 
svn: r7706

original commit: 39cedb62ed
This commit is contained in:
Matthew Flatt 2007-11-13 12:40:00 +00:00
parent 34fe3cea91
commit 553733c465
2 changed files with 76 additions and 57 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

47
collects/launcher/launcher-sig.ss
View File

@ -1,33 +1,34 @@
(module launcher-sig (lib "a-signature.ss") #lang scheme/signature
make-mred-launcher
make-mzscheme-launcher
make-mred-program-launcher make-mred-launcher
make-mzscheme-program-launcher make-mzscheme-launcher
mred-program-launcher-path make-mred-program-launcher
mzscheme-program-launcher-path make-mzscheme-program-launcher
install-mred-program-launcher mred-program-launcher-path
install-mzscheme-program-launcher mzscheme-program-launcher-path
mred-launcher-up-to-date? install-mred-program-launcher
mzscheme-launcher-up-to-date? install-mzscheme-program-launcher
mred-launcher-is-directory? mred-launcher-up-to-date?
mzscheme-launcher-is-directory? mzscheme-launcher-up-to-date?
mred-launcher-is-actually-directory? mred-launcher-is-directory?
mzscheme-launcher-is-actually-directory? mzscheme-launcher-is-directory?
mred-launcher-add-suffix mred-launcher-is-actually-directory?
mzscheme-launcher-add-suffix mzscheme-launcher-is-actually-directory?
mred-launcher-put-file-extension+style+filters mred-launcher-add-suffix
mzscheme-launcher-put-file-extension+style+filters mzscheme-launcher-add-suffix
build-aux-from-path mred-launcher-put-file-extension+style+filters
current-launcher-variant mzscheme-launcher-put-file-extension+style+filters
available-mred-variants
available-mzscheme-variants) build-aux-from-path
current-launcher-variant
available-mred-variants
available-mzscheme-variants

68
collects/tests/mzscheme/embed.ss
View File

@ -54,7 +54,8 @@
(parameterize ([current-directory (find-system-path 'temp-dir)]) (parameterize ([current-directory (find-system-path 'temp-dir)])
(when (file-exists? "stdout") (when (file-exists? "stdout")
(delete-file "stdout")) (delete-file "stdout"))
(system* (if (and mred? (eq? 'macosx (system-type))) (test #t
system* (if (and mred? (eq? 'macosx (system-type)))
(let-values ([(base name dir?) (split-path exe)]) (let-values ([(base name dir?) (split-path exe)])
(build-path exe "Contents" "MacOS" (build-path exe "Contents" "MacOS"
(path-replace-suffix name #""))) (path-replace-suffix name #"")))
@ -73,6 +74,7 @@
[(exe expect mred? dist-hook . collects) [(exe expect mred? dist-hook . collects)
(try-one-exe exe expect mred?) (try-one-exe exe expect mred?)
;; Build a distirbution directory, and try that, too: ;; Build a distirbution directory, and try that, too:
(printf " ... from distribution ...\n")
(when (directory-exists? dist-dir) (when (directory-exists? dist-dir)
(delete-directory/files dist-dir)) (delete-directory/files dist-dir))
(assemble-distribution dist-dir (list exe) #:copy-collects collects) (assemble-distribution dist-dir (list exe) #:copy-collects collects)
@ -87,7 +89,7 @@
(define (mz-tests mred?) (define (mz-tests mred?)
(define dest (if mred? mr-dest mz-dest)) (define dest (if mred? mr-dest mz-dest))
(define (flags s) (define (flags s)
(string-append "-" (if mred? "Z" "") "mvq" s)) (string-append "-" s))
(define (one-mz-test filename expect) (define (one-mz-test filename expect)
;; Try simple mode: one module, launched from cmd line: ;; Try simple mode: one module, launched from cmd line:
(prepare dest filename) (prepare dest filename)
@ -96,19 +98,22 @@
`((#t (lib ,filename "tests" "mzscheme"))) `((#t (lib ,filename "tests" "mzscheme")))
null null
null null
`(,(flags "L") ,filename "tests/mzscheme")) `(,(flags "l") ,(string-append "tests/mzscheme/" filename)))
(try-exe dest expect mred?) (try-exe dest expect mred?)
;; Try explicit prefix: ;; Try explicit prefix:
(printf ">>>explicit prefix\n")
(let ([w/prefix (let ([w/prefix
(lambda (pfx) (lambda (pfx)
(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" "mzscheme"))
(#t (lib "scheme/init")))
null null
null null
`(,(flags "e") ,(format "(require ~a~a)" `(,(flags "ne")
,(format "(#%require '~a~a)"
(or pfx "") (or pfx "")
(regexp-replace #rx"[.].*$" filename "")))) (regexp-replace #rx"[.].*$" filename ""))))
(try-exe dest expect mred?))]) (try-exe dest expect mred?))])
@ -116,39 +121,43 @@
(w/prefix 'before:)) (w/prefix 'before:))
;; Try full path, and use literal S-exp to start ;; Try full path, and use literal S-exp to start
(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" "mzscheme") filename)])
(make-embedding-executable (make-embedding-executable
dest mred? #f dest mred? #f
`((#t ,path)) `((#t ,path))
null null
`(require (file ,(path->string path))) `(#%require (file ,(path->string path)))
`(,(flags "")))) `(,(flags ""))))
(try-exe dest expect mred?) (try-exe dest expect mred?)
;; Use `file' form: ;; Use `file' form:
(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" "mzscheme") filename)])
(make-embedding-executable (make-embedding-executable
dest mred? #f dest mred? #f
`((#t (file ,(path->string path)))) `((#t (file ,(path->string path))))
null null
`(require (file ,(path->string path))) `(#%require (file ,(path->string path)))
`(,(flags "")))) `(,(flags ""))))
(try-exe dest expect mred?) (try-exe dest expect mred?)
;; Use relative path ;; Use relative path
(printf ">>>relative path\n")
(prepare dest filename) (prepare dest filename)
(parameterize ([current-directory (collection-path "tests" "mzscheme")]) (parameterize ([current-directory (collection-path "tests" "mzscheme")])
(make-embedding-executable (make-embedding-executable
dest mred? #f dest mred? #f
`((#f ,filename)) `((#f ,filename))
null null
`(require ,(string->symbol (regexp-replace #rx"[.].*$" filename ""))) `(#%require ',(string->symbol (regexp-replace #rx"[.].*$" filename "")))
`(,(flags "")))) `(,(flags ""))))
(try-exe dest expect mred?) (try-exe dest expect mred?)
;; Try multiple modules ;; Try multiple modules
(printf ">>>multiple\n")
(prepare dest filename) (prepare dest filename)
(make-embedding-executable (make-embedding-executable
dest mred? #f dest mred? #f
@ -156,12 +165,13 @@
(#t (lib "embed-me3.ss" "tests" "mzscheme"))) (#t (lib "embed-me3.ss" "tests" "mzscheme")))
null null
`(begin `(begin
(require (lib "embed-me3.ss" "tests" "mzscheme")) (#%require (lib "embed-me3.ss" "tests" "mzscheme"))
(require (lib ,filename "tests" "mzscheme"))) (#%require (lib ,filename "tests" "mzscheme")))
`(,(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?)
;; Try a literal file ;; Try a literal file
(printf ">>>literal\n")
(prepare dest filename) (prepare dest filename)
(make-embedding-executable (make-embedding-executable
dest mred? #f dest mred? #f
@ -170,7 +180,7 @@
`(with-output-to-file "stdout" `(with-output-to-file "stdout"
(lambda () (display "... and more!\n")) (lambda () (display "... and more!\n"))
'append) 'append)
`(,(flags "L") ,filename "tests/mzscheme")) `(,(flags "l") ,(string-append "tests/mzscheme/" filename)))
(try-exe dest (string-append (try-exe dest (string-append
"This is the literal expression 4.\n" "This is the literal expression 4.\n"
"... and more!\n" "... and more!\n"
@ -184,15 +194,16 @@
(prepare dest "unicode") (prepare dest "unicode")
(make-embedding-executable (make-embedding-executable
dest mred? #f dest mred? #f
null '((#t scheme/base))
null null
`(begin `(begin
(#%require scheme/base)
(define (out s) (define (out s)
(with-output-to-file "stdout" (with-output-to-file "stdout"
(lambda () (printf s)) (lambda () (printf s))
'append)) #:exists 'append))
(out "\uA9, \u7238, and \U1D670\n")) (out "\uA9, \u7238, and \U1D670\n"))
`(,(flags "e") "(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) (mz-tests #f)
@ -205,8 +216,8 @@
`((#t (lib "embed-me5.ss" "tests" "mzscheme"))) `((#t (lib "embed-me5.ss" "tests" "mzscheme")))
null null
null null
`("-ZmvqL" "embed-me5.ss" "tests/mzscheme")) `("-l" "tests/mzscheme/embed-me5.ss"))
(try-exe mr-dest "This is 5: #<struct:class:button%>\n" #t)) (try-exe mr-dest "This is 5: #<class:button%>\n" #t))
;; Try the mzc interface: ;; Try the mzc interface:
(require (lib "dirs.ss" "setup") (require (lib "dirs.ss" "setup")
@ -225,6 +236,7 @@
(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.ss isn't found if it's not included:
(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?))
@ -232,14 +244,16 @@
(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:
(printf ">>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?))
"++lib" "etc.ss" "mzlib" "++lib" "mzlib/etc.ss"
(path->string (build-path (collection-path "tests" "mzscheme") "embed-me6.ss"))) (path->string (build-path (collection-path "tests" "mzscheme") "embed-me6.ss")))
(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:
(printf ">>set coll path\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?))
@ -250,21 +264,24 @@
(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?)
;; Try --collects-dest mode ;; Try --collects-dest mode
(printf ">>--collects-dest\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?))
"++lib" "etc.ss" "mzlib" "++lib" "mzlib/etc.ss"
"--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" "mzscheme") "embed-me6.ss")))
(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")
(try-exe (mk-dest mred?) "This is 6\nno etc.ss\n" mred?) (test #f system* (mk-dest mred?))
(void))) (void)))
(mzc-tests #t) #| REMOVEME
(mzc-tests #f) (mzc-tests #f)
(mzc-tests #t)
|#
(require (lib "file.ss" "dynext")) (require (lib "file.ss" "dynext"))
(define (extension-test mred?) (define (extension-test mred?)
@ -283,7 +300,7 @@
(system-library-subpath))) (system-library-subpath)))
(define ext-file (define ext-file
(build-path ext-dir (append-extension-suffix "embed-me8"))) (build-path ext-dir (append-extension-suffix "embed-me8_ss")))
(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.ss"))
@ -330,13 +347,14 @@
"--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" "mzscheme") "embed-me5.ss")))
(try-exe (mk-dest #t) "This is 5: #<struct:class:button%>\n" #t)) (try-exe (mk-dest #t) "This is 5: #<class:button%>\n" #t))
;; Another MrEd-specific: try embedding plot, which has extra DLLs and font files: ;; Another MrEd-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"))
(system* (build-path (find-console-bin-dir) "mred") (test #t
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" "mzscheme") "embed-me7.ss"))
(path->string direct)) (path->string direct))
@ -353,12 +371,12 @@
(define dest (mk-dest mred?)) (define dest (mk-dest mred?))
(define filename "embed-me11.ss") (define filename "embed-me11.ss")
(define (flags s) (define (flags s)
(string-append "-" (if mred? "Z" "") "mvq" s)) (string-append "-" s))
(create-embedding-executable (create-embedding-executable
dest dest
#:modules `((#t (lib ,filename "tests" "mzscheme"))) #:modules `((#t (lib ,filename "tests" "mzscheme")))
#:cmdline `(,(flags "L") ,filename "tests/mzscheme") #:cmdline `(,(flags "l") ,(string-append "tests/mzscheme/" 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))))