#lang racket/base (require compiler/embed racket/file racket/system racket/port launcher compiler/distribute (only-in pkg/lib installed-pkg-names)) (define (test expect f/label . args) (define r (apply (if (procedure? f/label) f/label values) args)) (unless (equal? expect r) (error "failed\n"))) (define (mk-dest-bin mred?) (case (system-type) [(windows) "e.exe"] [(unix) "e"] [(macosx) (if mred? "e.app" "e")])) (define (mk-dest mred?) (build-path (find-system-path 'temp-dir) (mk-dest-bin mred?))) (define mz-dest (mk-dest #f)) (define mr-dest (mk-dest #t)) (define dist-dir (build-path (find-system-path 'temp-dir) "e-dist")) (define dist-mz-exe (build-path (case (system-type) [(windows) 'same] [else "bin"]) (mk-dest-bin #f))) (define dist-mred-exe (build-path (case (system-type) [(windows macosx) 'same] [else "bin"]) (mk-dest-bin #t))) (define (prepare exe src) (printf "Making ~a with ~a...\n" exe src) (when (file-exists? exe) (delete-file exe))) (define (try-one-exe exe expect mred?) (printf "Running ~a\n" exe) (let ([plthome (getenv "PLTHOME")] [collects (getenv "PLTCOLLECTS")] [out (open-output-string)]) (define temp-home-dir (make-temporary-file "racket-tmp-home~a" 'directory)) ;; Try to hide usual collections: (parameterize ([current-environment-variables (environment-variables-copy (current-environment-variables))]) (putenv "PLTUSERHOME" (path->string temp-home-dir)) (when plthome (putenv "PLTHOME" (path->string (build-path (find-system-path 'temp-dir) "NOPE")))) (when collects (putenv "PLTCOLLECTS" (path->string (build-path (find-system-path 'temp-dir) "NOPE")))) ;; Execute: (parameterize ([current-directory (find-system-path 'temp-dir)]) (when (file-exists? "stdout") (delete-file "stdout")) (let ([path (if (and mred? (eq? 'macosx (system-type))) (let-values ([(base name dir?) (split-path exe)]) (build-path exe "Contents" "MacOS" (path-replace-suffix name #""))) exe)]) (test #t path (parameterize ([current-output-port out]) (system* path)))))) (delete-directory/files temp-home-dir) (let ([stdout-file (build-path (find-system-path 'temp-dir) "stdout")]) (if (file-exists? stdout-file) (test expect with-input-from-file stdout-file (lambda () (read-string 5000))) (test expect get-output-string out))))) (define (try-exe exe expect mred? [dist-hook void] #:dist? [dist? #t] . collects) (try-one-exe exe expect mred?) (when dist? ;; Build a distribution directory, and try that, too: (printf " ... from distribution ...\n") (when (directory-exists? dist-dir) (delete-directory/files dist-dir)) (assemble-distribution dist-dir (list exe) #:copy-collects collects) (dist-hook) (try-one-exe (build-path dist-dir (if mred? dist-mred-exe dist-mz-exe)) expect mred?) (delete-directory/files dist-dir))) (define (base-compile e) (parameterize ([current-namespace (make-base-namespace)]) (compile e))) (define (kernel-compile e) (parameterize ([current-namespace (make-base-empty-namespace)]) (namespace-require ''#%kernel) (compile e))) (define (mz-tests mred?) (define dest (if mred? mr-dest mz-dest)) (define (flags s) (string-append "-" s)) (define (one-mz-test filename expect literal?) ;; Try simple mode: one module, launched from cmd line: (prepare dest filename) (make-embedding-executable dest mred? #f `((#t (lib ,filename "tests" "compiler" "embed"))) null #f `(,(flags "l") ,(string-append "tests/compiler/embed/" filename))) (try-exe dest expect mred?) ;; As a launcher: (prepare dest filename) ((if mred? make-gracket-launcher make-racket-launcher) (list "-l" (string-append "tests/compiler/embed/" filename)) dest) (try-exe dest expect mred? #:dist? #f) ;; Try explicit prefix: (printf ">>>explicit prefix\n") (let ([w/prefix (lambda (pfx) (prepare dest filename) (make-embedding-executable dest mred? #f `((,pfx (lib ,filename "tests" "compiler" "embed")) (#t (lib "scheme/init"))) null #f `(,(flags "lne") "scheme/base" ,(format "(require '~a~a)" (or pfx "") (regexp-replace #rx"[.].*$" filename "")))) (try-exe dest expect mred?))]) (w/prefix #f) (w/prefix 'before:)) (when literal? ;; Try full path, and use literal S-exp to start (printf ">>>literal sexp\n") (prepare dest filename) (let ([path (build-path (collection-path "tests" "compiler" "embed") filename)]) (make-embedding-executable dest mred? #f `((#t ,path)) null (base-compile `(namespace-require '(file ,(path->string path)))) `(,(flags "")))) (try-exe dest expect mred?) ;; Use `file' form: (printf ">>>file\n") (prepare dest filename) (let ([path (build-path (collection-path "tests" "compiler" "embed") filename)]) (make-embedding-executable dest mred? #f `((#t (file ,(path->string path)))) null (base-compile `(namespace-require '(file ,(path->string path)))) `(,(flags "")))) (try-exe dest expect mred?) ;; Use relative path (printf ">>>relative path\n") (prepare dest filename) (parameterize ([current-directory (collection-path "tests" "compiler" "embed")]) (make-embedding-executable dest mred? #f `((#f ,filename)) null (base-compile `(namespace-require '',(string->symbol (regexp-replace #rx"[.].*$" filename "")))) `(,(flags "")))) (try-exe dest expect mred?) ;; Try multiple modules (printf ">>>multiple\n") (prepare dest filename) (make-embedding-executable dest mred? #f `((#t (lib ,filename "tests" "compiler" "embed")) (#t (lib "embed-me3.rkt" "tests" "compiler" "embed"))) null (base-compile `(begin (namespace-require '(lib "embed-me3.rkt" "tests" "compiler" "embed")) (namespace-require '(lib ,filename "tests" "compiler" "embed")))) `(,(flags ""))) (try-exe dest (string-append "3 is here, too? #t\n" expect) mred?) ;; Try a literal file (printf ">>>literal\n") (prepare dest filename) (let ([tmp (make-temporary-file)]) (with-output-to-file tmp #:exists 'truncate (lambda () (write (kernel-compile '(namespace-require ''#%kernel))))) (make-embedding-executable dest mred? #f `((#t (lib ,filename "tests" "compiler" "embed"))) (list tmp (build-path (collection-path "tests" "compiler" "embed") "embed-me4.rktl")) `(with-output-to-file (build-path (find-system-path 'temp-dir) "stdout") (lambda () (display "... and more!\n")) 'append) `(,(flags "l") ,(string-append "tests/compiler/embed/" filename))) (delete-file tmp)) (try-exe dest (string-append "This is the literal expression 4.\n" "... and more!\n" expect) mred?))) (one-mz-test "embed-me1.rkt" "This is 1\n" #t) (unless mred? (one-mz-test "embed-me1b.rkt" "This is 1b\n" #f) (one-mz-test "embed-me1c.rkt" "This is 1c\n" #f) (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-me1f.rkt" "This is 1f\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) (one-mz-test "embed-me15.rkt" "This is 15.\n" #f) (one-mz-test "embed-me17.rkt" "This is 17.\n" #f) (one-mz-test "embed-me18.rkt" "This is 18.\n" #f) (one-mz-test "embed-me19.rkt" "This is 19.\n" #f) (one-mz-test "embed-me21.rkt" "This is 21.\n" #f)) ;; Try unicode expr and cmdline: (prepare dest "unicode") (make-embedding-executable dest mred? #f '((#t scheme/base)) null (base-compile '(begin (require scheme/base) (eval '(define (out s) (with-output-to-file (build-path (find-system-path 'temp-dir) "stdout") (lambda () (printf s)) #:exists 'append))) (out "\uA9, \u7238, and \U1D670\n"))) `(,(flags "ne") "(out \"\u7237...\U1D671\n\")")) (try-exe dest "\uA9, \u7238, and \U1D670\n\u7237...\U1D671\n" mred?)) (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" "compiler" "embed"))) null #f `("-l" "tests/compiler/embed/embed-me5.rkt")) (try-exe mr-dest "This is 5: #\n" #t))) ;; Try the raco interface: (require setup/dirs mzlib/file) (define mzc (build-path (find-console-bin-dir) (if (eq? 'windows (system-type)) "mzc.exe" "mzc"))) (define raco (build-path (find-console-bin-dir) (if (eq? 'windows (system-type)) "raco.exe" "raco"))) (define (system+ . args) (printf "> ~a\n" (car (reverse args))) (apply system* args)) (define (short-mzc-tests mred?) (parameterize ([current-directory (find-system-path 'temp-dir)]) ;; raco exe (system+ raco "exe" "-o" (path->string (mk-dest mred?)) (if mred? "--gui" "--") (path->string (build-path (collection-path "tests" "compiler" "embed") "embed-me1.rkt"))) (try-exe (mk-dest mred?) "This is 1\n" mred?) ;; raco exe on a module with a `main' submodule (system+ raco "exe" "-o" (path->string (mk-dest mred?)) (if mred? "--gui" "--") (path->string (build-path (collection-path "tests" "compiler" "embed") "embed-me16.rkt"))) (try-exe (mk-dest mred?) "This is 16.\n" mred?))) (define (mzc-tests mred?) (short-mzc-tests mred?) (parameterize ([current-directory (find-system-path 'temp-dir)]) ;; raco exe (system+ raco "exe" "-o" (path->string (mk-dest mred?)) (if mred? "--gui" "--") (path->string (build-path (collection-path "tests" "compiler" "embed") "embed-me1.rkt"))) (try-exe (mk-dest mred?) "This is 1\n" mred?) ;; raco exe on a module with a `main' submodule (system+ raco "exe" "-o" (path->string (mk-dest mred?)) (if mred? "--gui" "--") (path->string (build-path (collection-path "tests" "compiler" "embed") "embed-me16.rkt"))) (try-exe (mk-dest mred?) "This is 16.\n" mred?) ;; raco exe on a module with a `main' submodule+ (system+ raco "exe" "-o" (path->string (mk-dest mred?)) (if mred? "--gui" "--") (path->string (build-path (collection-path "tests" "compiler" "embed") "embed-me20.rkt"))) (try-exe (mk-dest mred?) "This is 20.\n" mred?) ;; raco exe on a module with a `configure-runtime' submodule (system+ raco "exe" "-o" (path->string (mk-dest mred?)) (if mred? "--gui" "--") (path->string (build-path (collection-path "tests" "compiler" "embed") "embed-me22.rkt"))) (try-exe (mk-dest mred?) "Configure!\nThis is 22.\n" mred?) ;; raco exe on a module with serialization (system+ raco "exe" "-o" (path->string (mk-dest mred?)) (if mred? "--gui" "--") (path->string (build-path (collection-path "tests" "compiler" "embed") "embed-me23.rkt"))) (try-exe (mk-dest mred?) "1\n2\n" mred?) ;; raco exe --launcher (system+ raco "exe" "--launcher" "-o" (path->string (mk-dest mred?)) (if mred? "--gui" "--") (path->string (build-path (collection-path "tests" "compiler" "embed") "embed-me1.rkt"))) (try-exe (mk-dest mred?) "This is 1\n" mred? #:dist? #f) ;; the rest use mzc... (system+ mzc (if mred? "--gui-exe" "--exe") (path->string (mk-dest mred?)) (path->string (build-path (collection-path "tests" "compiler" "embed") "embed-me1.rkt"))) (try-exe (mk-dest mred?) "This is 1\n" mred?) (define (check-collection-path prog lib in-main?) ;; Check that etc.rkt isn't found if it's not included: (printf ">>not included\n") (system+ mzc (if mred? "--gui-exe" "--exe") (path->string (mk-dest mred?)) (path->string (build-path (collection-path "tests" "compiler" "embed") prog))) (try-exe (mk-dest mred?) "This is 6\nno etc.ss\n" mred?) ;; And it is found if it is included: (printf ">>included\n") (system+ mzc (if mred? "--gui-exe" "--exe") (path->string (mk-dest mred?)) "++lib" lib (path->string (build-path (collection-path "tests" "compiler" "embed") prog))) (try-exe (mk-dest mred?) "This is 6\n#t\n" mred?) ;; Or, it's found if we set the collection path: (printf ">>set coll path\n") (system+ mzc (if mred? "--gui-exe" "--exe") (path->string (mk-dest mred?)) "--collects-path" (path->string (find-collects-dir)) (path->string (build-path (collection-path "tests" "compiler" "embed") prog))) ;; Don't try a distribution for this one: (try-one-exe (mk-dest mred?) (if in-main? "This is 6\n#t\n" "This is 6\nno etc.ss\n") mred?) ;; Or, it's found if we set the collection path and the config path (where the latter ;; finds links for packages): (printf ">>set coll path plus config\n") (system+ mzc (if mred? "--gui-exe" "--exe") (path->string (mk-dest mred?)) "--collects-path" (path->string (find-collects-dir)) "--config-path" (path->string (find-config-dir)) (path->string (build-path (collection-path "tests" "compiler" "embed") prog))) ;; Don't try a distribution for this one: (try-one-exe (mk-dest mred?) "This is 6\n#t\n" mred?) ;; Try --collects-dest mode (printf ">>--collects-dest\n") (system+ mzc (if mred? "--gui-exe" "--exe") (path->string (mk-dest mred?)) "++lib" lib "--collects-dest" "cts" "--collects-path" "cts" (path->string (build-path (collection-path "tests" "compiler" "embed") prog))) (try-exe (mk-dest mred?) "This is 6\n#t\n" mred? void "cts") ; <- cts copied to distribution (delete-directory/files "cts") (parameterize ([current-error-port (open-output-nowhere)]) (test #f system+ (mk-dest mred?)))) (check-collection-path "embed-me6b.rkt" "racket/fixnum.rkt" #t) (check-collection-path "embed-me6.rkt" "mzlib/etc.rkt" ;; "mzlib" is found via the "collects" path ;; if it is accessible via the default ;; collection-links configuration, which is ;; essentially the same as being in installation ;; scope: (member "compatibility-lib" (installed-pkg-names #:scope 'installation))) (void))) (define (try-mzc) (mzc-tests #f) (short-mzc-tests #t)) (require dynext/file) (define (extension-test mred?) (parameterize ([current-directory (find-system-path 'temp-dir)]) (define obj-file (build-path (find-system-path 'temp-dir) (append-object-suffix "embed-me8"))) (define ext-base-dir (build-path (find-system-path 'temp-dir) "compiled")) (define ext-dir (build-path ext-base-dir "native" (system-library-subpath))) (define ext-file (build-path ext-dir (append-extension-suffix "embed-me8_rkt"))) (define ss-file (build-path (find-system-path 'temp-dir) "embed-me9.rkt")) (make-directory* ext-dir) (system+ mzc "--cc" "-d" (path->string (path-only obj-file)) (path->string (build-path (collection-path "tests" "compiler" "embed") "embed-me8.c"))) (system+ mzc "--ld" (path->string ext-file) (path->string obj-file)) (when (file-exists? ss-file) (delete-file ss-file)) (copy-file (build-path (collection-path "tests" "compiler" "embed") "embed-me9.rkt") ss-file) (system+ mzc (if mred? "--gui-exe" "--exe") (path->string (mk-dest mred?)) (path->string ss-file)) (delete-file ss-file) (try-exe (mk-dest mred?) "Hello, world!\n" mred? (lambda () (delete-directory/files ext-base-dir))) ;; openssl, which needs extra binaries under Windows (system+ mzc (if mred? "--gui-exe" "--exe") (path->string (mk-dest mred?)) (path->string (build-path (collection-path "tests" "compiler" "embed") "embed-me10.rkt"))) (try-exe (mk-dest mred?) "#t\n" mred?))) (define (try-extension) (extension-test #f) (extension-test #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" "compiler" "embed") "embed-me5.rkt"))) (try-exe (mk-dest #t) "This is 5: #\n" #t))) ;; Try including source that needs a reader extension (define (try-reader-test 12? mred? ss-file? ss-reader?) ;; actual "11" files use ".rkt", actual "12" files use ".ss" (define dest (mk-dest mred?)) (define filename (format (if ss-file? "embed-me~a.ss" "embed-me~a.rkt") (if 12? "12" "11"))) (define (flags s) (string-append "-" s)) (printf "Trying ~s ~s ~s ~s...\n" (if 12? "12" "11") mred? ss-file? ss-reader?) (create-embedding-executable dest #:modules `((#t (lib ,filename "tests" "compiler" "embed"))) #:cmdline `(,(flags "l") ,(string-append "tests/compiler/embed/" filename)) #:src-filter (lambda (f) (let-values ([(base name dir?) (split-path f)]) (equal? name (path-replace-suffix (string->path filename) (if 12? #".ss" #".rkt"))))) #:get-extra-imports (lambda (f code) (let-values ([(base name dir?) (split-path f)]) (if (equal? name (path-replace-suffix (string->path filename) (if 12? #".ss" #".rkt"))) `((lib ,(format (if ss-reader? "embed-me~a-rd.ss" "embed-me~a-rd.rkt") (if 12? "12" "11")) "tests" "compiler" "embed")) null))) #:mred? mred?) (putenv "ELEVEN" "eleven") (try-exe dest "It goes to eleven!\n" mred?) (putenv "ELEVEN" "done")) (define (try-reader) (for ([12? (in-list '(#f #t))]) (try-reader-test 12? #f #f #f) (try-reader-test 12? #t #f #f) (try-reader-test 12? #f #t #f) (try-reader-test 12? #f #f #t))) ;; ---------------------------------------- (define (try-source) (define (try-one file submod start result) (define mred? #f) (define dest (mk-dest mred?)) (printf "> ~a ~s from source\n" file submod) (create-embedding-executable dest #:modules `((#%mzc: ,(collection-file-path file "tests/compiler/embed") ,submod)) #:configure-via-first-module? #t #:literal-expression (parameterize ([current-namespace (make-base-namespace)]) (compile `(begin (namespace-require ',start)))) #:src-filter (lambda (p) (or (equal? p (collection-file-path "embed-me25.rkt" "tests/compiler/embed")) (equal? p (collection-file-path "embed-me26.rkt" "tests/compiler/embed")) (equal? p (collection-file-path "embed-me27.rkt" "tests/compiler/embed")))) #:get-extra-imports (lambda (src mod) (list 'racket/base/lang/reader))) (try-exe dest result mred?)) (try-one "embed-me25.rkt" null ''|#%mzc:embed-me25| "10\n") (try-one "embed-me25.rkt" '(main) '(submod '|#%mzc:embed-me25| main) "10\n12\n") (try-one "embed-me25.rkt" '(submod) '(submod '|#%mzc:embed-me25| submod) "11\n") (try-one "embed-me26.rkt" null ''|#%mzc:embed-me26| "'y\n10\n") (try-one "embed-me26.rkt" '(submod) '(submod '|#%mzc:embed-me26| submod) "11\n") (try-one "embed-me26.rkt" '(main) '(submod '|#%mzc:embed-me26| main) "'y\n10\n12\n")) ;; ---------------------------------------- (define planet (build-path (find-console-bin-dir) (if (eq? 'windows (system-type)) "planet.exe" "planet"))) (define (try-planet) (system+ raco "planet" "link" "racket-tester" "p1.plt" "1" "0" (path->string (collection-path "tests" "compiler" "embed" "embed-planet-1"))) (system+ raco "planet" "link" "racket-tester" "p2.plt" "2" "2" (path->string (collection-path "tests" "compiler" "embed" "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") (go '(planet "private/sub.ss" ("racket-tester" "p2.plt" 2 0)) "two\nsub\n") (go '(planet "main.ss" ("racket-tester" "p2.plt" 2 0)) "two\n") (go '(planet racket-tester/p1/dyn-sub) "out\n") (void)) (system+ raco "planet" "unlink" "racket-tester" "p1.plt" "1" "0") (system+ raco "planet" "unlink" "racket-tester" "p2.plt" "2" "2")) ;; ---------------------------------------- (define (try-*sl) (define (try-one src) (printf "Trying ~a...\n" src) (define exe (path->string (mk-dest #f))) (system+ raco "exe" "-o" exe "--" (path->string (build-path (collection-path "tests" "compiler" "embed") src))) (try-exe exe "10\n" #f)) (try-one "embed-bsl.rkt") (try-one "embed-bsla.rkt") (try-one "embed-isl.rkt") (try-one "embed-isll.rkt") (try-one "embed-asl.rkt")) ;; ---------------------------------------- (try-basic) (try-mzc) (try-extension) (try-gracket) (try-reader) (try-planet) (try-*sl) (try-source) ;; ---------------------------------------- ;; Make sure that embedding does not break future module declarations (let () (parameterize ([current-output-port (open-output-bytes)]) (write-module-bundle #:modules (list (list #f (collection-file-path "embed-me24.rkt" "tests" "compiler" "embed"))))) (parameterize ([read-accept-reader #t] [current-namespace (make-base-namespace)]) (eval (read (open-input-string "#lang racket 10")))))