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

some minor reformatting and improvements

Browse Source 
svn: r9075
This commit is contained in:
Eli Barzilay 2008-03-24 10:14:02 +00:00
parent 473136e8b1
commit f94acb09d5
1 changed files with 586 additions and 655 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

367
collects/compiler/main.ss
View File

@ -14,19 +14,18 @@
;; See manual for information about the Scheme-level interface ;; See manual for information about the Scheme-level interface
;; provided by this collection. ;; provided by this collection.
(module main scheme/base #lang scheme/base
;; On error, exit with 1 status code ;; On error, exit with 1 status code
(error-escape-handler (lambda () (exit 1))) (error-escape-handler (lambda () (exit 1)))
(error-print-width 512) (error-print-width 512)
(require (prefix-in compiler:option: "option.ss")) (require (prefix-in compiler:option: "option.ss"))
(require "compiler.ss") (require "compiler.ss")
;; Read argv array for arguments and input file name ;; Read argv array for arguments and input file name
(require mzlib/cmdline (require mzlib/cmdline
mzlib/list
dynext/file dynext/file
dynext/compile dynext/compile
dynext/link dynext/link
@ -35,48 +34,46 @@
(lib "getinfo.ss" "setup") (lib "getinfo.ss" "setup")
setup/dirs) setup/dirs)
(define dest-dir (make-parameter #f)) (define dest-dir (make-parameter #f))
(define auto-dest-dir (make-parameter #f)) (define auto-dest-dir (make-parameter #f))
(define ld-output (make-parameter #f)) (define ld-output (make-parameter #f))
(define exe-output (make-parameter #f)) (define exe-output (make-parameter #f))
(define exe-embedded-flags (make-parameter '("-U" "--"))) (define exe-embedded-flags (make-parameter '("-U" "--")))
(define exe-embedded-libraries (make-parameter null)) (define exe-embedded-libraries (make-parameter null))
(define exe-aux (make-parameter null)) (define exe-aux (make-parameter null))
(define exe-embedded-collects-path (make-parameter #f)) (define exe-embedded-collects-path (make-parameter #f))
(define exe-embedded-collects-dest (make-parameter #f)) (define exe-embedded-collects-dest (make-parameter #f))
(define exe-dir-add-collects-dirs (make-parameter null)) (define exe-dir-add-collects-dirs (make-parameter null))
(define exe-dir-output (make-parameter #f)) (define exe-dir-output (make-parameter #f))
(define mods-output (make-parameter #f)) (define mods-output (make-parameter #f))
(define module-mode (make-parameter #f)) (define module-mode (make-parameter #f))
(define default-plt-name "archive") (define default-plt-name "archive")
(define plt-output (make-parameter #f)) (define plt-output (make-parameter #f))
(define plt-name (make-parameter default-plt-name)) (define plt-name (make-parameter default-plt-name))
(define plt-files-replace (make-parameter #f)) (define plt-files-replace (make-parameter #f))
(define plt-files-plt-relative? (make-parameter #f)) (define plt-files-plt-relative? (make-parameter #f))
(define plt-files-plt-home-relative? (make-parameter #f)) (define plt-files-plt-home-relative? (make-parameter #f))
(define plt-force-install-dir? (make-parameter #f)) (define plt-force-install-dir? (make-parameter #f))
(define plt-setup-collections (make-parameter null)) (define plt-setup-collections (make-parameter null))
(define plt-include-compiled (make-parameter #f)) (define plt-include-compiled (make-parameter #f))
(define stop-at-source (make-parameter #f)) (define stop-at-source (make-parameter #f))
(define (extract-suffix appender) (define (extract-suffix appender)
(bytes->string/latin-1 (bytes->string/latin-1
(subbytes (subbytes (path->bytes (appender (bytes->path #"x"))) 1)))
(path->bytes (appender (bytes->path #"x")))
1)))
;; Returns (values mode files prefixes)
;; Returns (values mode files prefixes) ;; where mode is 'compile, 'make-zo, etc.
;; where mode is 'compile, 'make-zo, etc. (define (parse-options argv)
(define (parse-options argv) (define ((add-to-param param) f v) (param (append (param) (list v))))
(parse-command-line (parse-command-line
"mzc" "mzc"
argv argv
@ -174,12 +171,10 @@
(dest-dir d)) (dest-dir d))
("Output -e/-c/-z/-x file(s) to <dir>" "dir")] ("Output -e/-c/-z/-x file(s) to <dir>" "dir")]
[("--auto-dir") [("--auto-dir")
,(lambda (f) ,(lambda (f) (auto-dest-dir #t))
(auto-dest-dir #t))
(,(format "Output -z to \"compiled\", -e to ~s" (,(format "Output -z to \"compiled\", -e to ~s"
(path->string (path->string (build-path "compiled" "native"
(build-path "compiled" "native" (system-library-subpath #f)))))]] (system-library-subpath #f)))))]]
[help-labels [help-labels
"------------------- compiler/linker configuration flags ---------------------"] "------------------- compiler/linker configuration flags ---------------------"]
[once-each [once-each
@ -190,8 +185,7 @@
(use-standard-linker v))) (use-standard-linker v)))
(,(format "Use pre-defined <tool> as C compiler/linker:~a" (,(format "Use pre-defined <tool> as C compiler/linker:~a"
(apply string-append (apply string-append
(apply append (apply append (map (lambda (t)
(map (lambda (t)
(list " " (symbol->string t))) (list " " (symbol->string t)))
(get-standard-compilers))))) (get-standard-compilers)))))
"tool")] "tool")]
@ -200,12 +194,11 @@
("Use <compiler-path> as C compiler" "compiler-path")]] ("Use <compiler-path> as C compiler" "compiler-path")]]
[multi [multi
[("++ccf") [("++ccf")
,(lambda (f v) (current-extension-compiler-flags ,(add-to-param current-extension-compiler-flags)
(append (current-extension-compiler-flags)
(list v))))
("Add C compiler flag" "flag")] ("Add C compiler flag" "flag")]
[("--ccf") [("--ccf")
,(lambda (f v) (current-extension-compiler-flags ,(lambda (f v)
(current-extension-compiler-flags
(remove v (current-extension-compiler-flags)))) (remove v (current-extension-compiler-flags))))
("Remove C compiler flag" "flag")] ("Remove C compiler flag" "flag")]
[("--ccf-clear") [("--ccf-clear")
@ -213,8 +206,8 @@
("Clear C compiler flags")] ("Clear C compiler flags")]
[("--ccf-show") [("--ccf-show")
,(lambda (f) ,(lambda (f)
(printf "C compiler flags: ~s~n" (expand-for-link-variant (printf "C compiler flags: ~s\n"
(current-extension-compiler-flags)))) (expand-for-link-variant (current-extension-compiler-flags))))
("Show C compiler flags")]] ("Show C compiler flags")]]
[once-each [once-each
[("--linker") [("--linker")
@ -222,12 +215,11 @@
("Use <linker-path> as C linker" "linker-path")]] ("Use <linker-path> as C linker" "linker-path")]]
[multi [multi
[("++ldf") [("++ldf")
,(lambda (f v) (current-extension-linker-flags ,(add-to-param current-extension-linker-flags)
(append (current-extension-linker-flags)
(list v))))
("Add C linker flag" "flag")] ("Add C linker flag" "flag")]
[("--ldf") [("--ldf")
,(lambda (f v) (current-extension-linker-flags ,(lambda (f v)
(current-extension-linker-flags
(remove v (current-extension-linker-flags)))) (remove v (current-extension-linker-flags))))
("Remove C linker flag" "flag")] ("Remove C linker flag" "flag")]
[("--ldf-clear") [("--ldf-clear")
@ -235,27 +227,24 @@
("Clear C linker flags")] ("Clear C linker flags")]
[("--ldf-show") [("--ldf-show")
,(lambda (f) ,(lambda (f)
(printf "C linker flags: ~s~n" (expand-for-link-variant (printf "C linker flags: ~s\n"
(current-extension-linker-flags)))) (expand-for-link-variant (current-extension-linker-flags))))
("Show C linker flags")] ("Show C linker flags")]
[("++ldl") [("++ldl")
,(lambda (f v) (current-standard-link-libraries ,(add-to-param current-standard-link-libraries)
(append (current-standard-link-libraries)
(list v))))
("Add C linker library" "lib")] ("Add C linker library" "lib")]
[("--ldl-show") [("--ldl-show")
,(lambda (f) ,(lambda (f)
(printf "C linker libraries: ~s~n" (expand-for-link-variant (printf "C linker libraries: ~s\n"
(current-standard-link-libraries)))) (expand-for-link-variant (current-standard-link-libraries))))
("Show C linker libraries")]] ("Show C linker libraries")]]
[multi [multi
[("++cppf") [("++cppf")
,(lambda (f v) (current-extension-preprocess-flags ,(add-to-param current-extension-preprocess-flags)
(append (current-extension-preprocess-flags)
(list v))))
("Add C preprocess (xform) flag" "flag")] ("Add C preprocess (xform) flag" "flag")]
[("--cppf") [("--cppf")
,(lambda (f v) (current-extension-preprocess-flags ,(lambda (f v)
(current-extension-preprocess-flags
(remove v (current-extension-preprocess-flags)))) (remove v (current-extension-preprocess-flags))))
("Remove C preprocess (xform) flag" "flag")] ("Remove C preprocess (xform) flag" "flag")]
[("--cppf-clear") [("--cppf-clear")
@ -263,8 +252,8 @@
("Clear C preprocess (xform) flags")] ("Clear C preprocess (xform) flags")]
[("--cppf-show") [("--cppf-show")
,(lambda (f) ,(lambda (f)
(printf "C compiler flags: ~s~n" (expand-for-link-variant (printf "C compiler flags: ~s\n"
(current-extension-preprocess-flags)))) (expand-for-link-variant (current-extension-preprocess-flags))))
("Show C preprocess (xform) flags")]] ("Show C preprocess (xform) flags")]]
[help-labels [help-labels
"--------------------- executable configuration flags ------------------------"] "--------------------- executable configuration flags ------------------------"]
@ -274,50 +263,37 @@
(exe-embedded-collects-path i)) (exe-embedded-collects-path i))
("Set <path> main collects in --[gui-]exe/--exe-dir" "path")] ("Set <path> main collects in --[gui-]exe/--exe-dir" "path")]
[("--collects-dest") [("--collects-dest")
,(lambda (f i) ,(lambda (f i) (exe-embedded-collects-dest i))
(exe-embedded-collects-dest i))
("Add --[gui-]exe collection code to <dir>" "dir")] ("Add --[gui-]exe collection code to <dir>" "dir")]
[("--ico") [("--ico")
,(lambda (f i) (exe-aux ,(lambda (f i) (exe-aux (cons (cons 'ico i) (exe-aux))))
(cons (cons 'ico i)
(exe-aux))))
("Windows icon for --[gui-]exe executable" ".ico-file")] ("Windows icon for --[gui-]exe executable" ".ico-file")]
[("--icns") [("--icns")
,(lambda (f i) (exe-aux ,(lambda (f i) (exe-aux (cons (cons 'icns i) (exe-aux))))
(cons (cons 'icns i)
(exe-aux))))
("Mac OS X icon for --[gui-]exe executable" ".icns-file")] ("Mac OS X icon for --[gui-]exe executable" ".icns-file")]
[("--orig-exe") [("--orig-exe")
,(lambda (f) (exe-aux ,(lambda (f) (exe-aux (cons (cons 'original-exe? #t) (exe-aux))))
(cons (cons 'original-exe? #t)
(exe-aux))))
("Use original executable for --[gui-]exe instead of stub")]] ("Use original executable for --[gui-]exe instead of stub")]]
[multi [multi
[("++lib") [("++lib")
,(lambda (f l) (exe-embedded-libraries ,(lambda (f l)
(append (exe-embedded-libraries) (exe-embedded-libraries (append (exe-embedded-libraries) (list l))))
(list l))))
("Embed <lib> in --[gui-]exe executable" "lib")] ("Embed <lib> in --[gui-]exe executable" "lib")]
[("++collects-copy") [("++collects-copy")
,(lambda (f d) (exe-dir-add-collects-dirs ,(lambda (f d)
(append (exe-dir-add-collects-dirs) (exe-dir-add-collects-dirs (append (exe-dir-add-collects-dirs) (list d))))
(list d))))
("Add collects in <dir> to --exe-dir" "dir")] ("Add collects in <dir> to --exe-dir" "dir")]
[("++exf") [("++exf")
,(lambda (f v) (exe-embedded-flags ,(add-to-param exe-embedded-flags)
(append (exe-embedded-flags)
(list v))))
("Add flag to embed in --[gui-]exe executable" "flag")] ("Add flag to embed in --[gui-]exe executable" "flag")]
[("--exf") [("--exf")
,(lambda (f v) (exe-embedded-flags ,(lambda (f v) (exe-embedded-flags (remove v (exe-embedded-flags))))
(remove v (exe-embedded-flags))))
("Remove flag to embed in --[gui-]exe executable" "flag")] ("Remove flag to embed in --[gui-]exe executable" "flag")]
[("--exf-clear") [("--exf-clear")
,(lambda (f) (exe-embedded-flags null)) ,(lambda (f) (exe-embedded-flags null))
("Clear flags to embed in --[gui-]exe executable")] ("Clear flags to embed in --[gui-]exe executable")]
[("--exf-show") [("--exf-show")
,(lambda (f) ,(lambda (f) (printf "Flags to embed: ~s\n" (exe-embedded-flags)))
(printf "Flags to embed: ~s~n" (exe-embedded-flags)))
("Show flag to embed in --[gui-]exe executable")]] ("Show flag to embed in --[gui-]exe executable")]]
[help-labels [help-labels
"----------------------------- .plt archive flags ----------------------------"] "----------------------------- .plt archive flags ----------------------------"]
@ -336,9 +312,7 @@
,(lambda (f) (plt-files-plt-home-relative? #t)) ,(lambda (f) (plt-files-plt-home-relative? #t))
("Files/dirs in archive go to PLT installation if writable")] ("Files/dirs in archive go to PLT installation if writable")]
[("--force-all-users") [("--force-all-users")
,(lambda (f) ,(lambda (f) (plt-files-plt-home-relative? #t) (plt-force-install-dir? #t))
(plt-files-plt-home-relative? #t)
(plt-force-install-dir? #t))
("Files/dirs forced to PLT installation")]] ("Files/dirs forced to PLT installation")]]
[once-each [once-each
[("--include-compiled") [("--include-compiled")
@ -346,21 +320,19 @@
("Include \"compiled\" subdirectories in the archive")]] ("Include \"compiled\" subdirectories in the archive")]]
[multi [multi
[("++setup") [("++setup")
,(lambda (f c) (plt-setup-collections ,(lambda (f c)
(append (plt-setup-collections) (plt-setup-collections (append (plt-setup-collections) (list c))))
(list c))))
("Setup <collect> after the archive is unpacked" "collect")]] ("Setup <collect> after the archive is unpacked" "collect")]]
[help-labels [help-labels
"----------------------- compiler optimization flags -------------------------"] "----------------------- compiler optimization flags -------------------------"]
[once-each [once-each
[("--no-prop") [("--no-prop")
,(lambda (f) (compiler:option:propagate-constants #f)) ,(lambda (f) (compiler:option:propagate-constants #f))
("Don't propagate constants")] ("Don't propagate constants")]
[("--inline") [("--inline")
,(lambda (f d) (compiler:option:max-inline-size ,(lambda (f d)
(with-handlers ([void (compiler:option:max-inline-size
(lambda (x) (with-handlers ([void (lambda (x)
(error 'mzc "bad size for --inline: ~a" d))]) (error 'mzc "bad size for --inline: ~a" d))])
(let ([v (string->number d)]) (let ([v (string->number d)])
(unless (and (not (negative? v)) (exact? v) (real? v)) (unless (and (not (negative? v)) (exact? v) (real? v))
@ -396,16 +368,13 @@
("Write debugging output to dump.txt")]]) ("Write debugging output to dump.txt")]])
(lambda (accum . files) (lambda (accum . files)
(let ([mode (let ([l (filter symbol? accum)]) (let ([mode (let ([l (filter symbol? accum)])
(if (null? l) (if (null? l) 'make-zo (car l)))])
'make-zo
(car l)))])
(values (values
mode mode
files files
(let ([prefixes (filter string? accum)]) (let ([prefixes (filter string? accum)])
(unless (memq mode '(compile compile-c zo)) (unless (or (memq mode '(compile compile-c zo)) (null? prefixes))
(unless (null? prefixes) (error 'mzc "prefix files are not useful in ~a mode" mode))
(error 'mzc "prefix files are not useful in ~a mode" mode)))
(if (module-mode) (if (module-mode)
(begin (begin
(when (compiler:option:assume-primitives) (when (compiler:option:assume-primitives)
@ -423,50 +392,45 @@
(void))))))) (void)))))))
(list "file/directory/collection"))) (list "file/directory/collection")))
(printf "mzc v~a [~a], Copyright (c) 2004-2008 PLT Scheme Inc.~n" (printf "mzc v~a [~a], Copyright (c) 2004-2008 PLT Scheme Inc.\n"
(version) (version)
(system-type 'gc)) (system-type 'gc))
(define-values (mode source-files prefix) (define-values (mode source-files prefix)
(parse-options (current-command-line-arguments))) (parse-options (current-command-line-arguments)))
(when (auto-dest-dir) (when (and (auto-dest-dir) (not (memq mode '(zo compile))))
(unless (memq mode '(zo compile)) (error 'mzc "--auto-dir works only with -z, --zo, -e, or --extension (or default mode)"))
(error 'mzc "--auto-dir works only with -z, --zo, -e, or --extension (or default mode)")))
(define (never-embedded action) (define (never-embedded action)
(when (compiler:option:compile-for-embedded) (when (compiler:option:compile-for-embedded)
(error 'mzc "cannot ~a an extension for an embedded MzScheme" action))) (error 'mzc "cannot ~a an extension for an embedded MzScheme" action)))
(if (compiler:option:3m) (if (compiler:option:3m)
(begin (begin (link-variant '3m) (compile-variant '3m))
(link-variant '3m) (begin (link-variant 'cgc) (compile-variant 'cgc)))
(compile-variant '3m))
(begin
(link-variant 'cgc)
(compile-variant 'cgc)))
(define (compiler-warning) (define (compiler-warning)
(fprintf (current-error-port) (fprintf (current-error-port)
(string-append "Warning: ~a\n ~a\n"
"Warning: compilation to C is usually less effective for performance\n" "compilation to C is usually less effective for performance"
" than relying on the bytecode just-in-time compiler.\n"))) "than relying on the bytecode just-in-time compiler."))
(case mode (case mode
[(compile) [(compile)
(compiler-warning) (compiler-warning)
(never-embedded "compile") (never-embedded "compile")
((compile-extensions prefix) source-files (if (auto-dest-dir) ((compile-extensions prefix)
'auto source-files
(dest-dir)))] (if (auto-dest-dir) 'auto (dest-dir)))]
[(compile-c) [(compile-c)
((compile-extensions-to-c prefix) source-files (dest-dir))] ((compile-extensions-to-c prefix) source-files (dest-dir))]
[(zo) [(zo)
((compile-zos prefix) source-files (if (auto-dest-dir) ((compile-zos prefix)
'auto source-files
(dest-dir)))] (if (auto-dest-dir) 'auto (dest-dir)))]
[(expand) [(expand)
(for-each (lambda (src-file) (for ([src-file source-files])
(let ([src-file (path->complete-path src-file)]) (let ([src-file (path->complete-path src-file)])
(let-values ([(base name dir?) (split-path src-file)]) (let-values ([(base name dir?) (split-path src-file)])
(parameterize ([current-load-relative-directory base] (parameterize ([current-load-relative-directory base]
@ -480,67 +444,57 @@
(let ([e (read-syntax src-file in)]) (let ([e (read-syntax src-file in)])
(unless (eof-object? e) (unless (eof-object? e)
(pretty-print (syntax->datum (expand e))) (pretty-print (syntax->datum (expand e)))
(loop)))))))))) (loop))))))))))]
source-files)]
[(make-zo) [(make-zo)
(let ([n (make-base-empty-namespace)] (let ([n (make-base-empty-namespace)]
[mc (dynamic-require 'mzlib/cm [mc (dynamic-require 'mzlib/cm 'managed-compile-zo)]
'managed-compile-zo)] [cnh (dynamic-require 'mzlib/cm 'manager-compile-notify-handler)]
[cnh (dynamic-require 'mzlib/cm
'manager-compile-notify-handler)]
[did-one? #f]) [did-one? #f])
(parameterize ([current-namespace n] (parameterize ([current-namespace n]
[cnh (lambda (p) [cnh (lambda (p)
(set! did-one? #t) (set! did-one? #t)
(printf " making ~s~n" (path->string p)))]) (printf " making ~s\n" (path->string p)))])
(for-each (lambda (file) (for ([file source-files])
(unless (file-exists? file) (unless (file-exists? file)
(error 'mzc "file does not exist: ~a" file)) (error 'mzc "file does not exist: ~a" file))
(set! did-one? #f) (set! did-one? #f)
(let ([name (extract-base-filename/ss file 'mzc)]) (let ([name (extract-base-filename/ss file 'mzc)])
(printf "\"~a\":~n" file) (printf "\"~a\":\n" file)
(mc file) (mc file)
(let ([dest (append-zo-suffix (let ([dest (append-zo-suffix
(let-values ([(base name dir?) (split-path name)]) (let-values ([(base name dir?) (split-path name)])
(build-path (if (symbol? base) 'same base) (build-path (if (symbol? base) 'same base)
"compiled" name)))]) "compiled" name)))])
(printf " [~a \"~a\"]~n" (printf " [~a \"~a\"]\n"
(if did-one? (if did-one? "output to" "already up-to-date at")
"output to" dest))))))]
"already up-to-date at")
dest))))
source-files)))]
[(collection-zos) [(collection-zos)
(apply compile-collection-zos source-files)] (apply compile-collection-zos source-files)]
[(cc) [(cc)
(for-each (for ([file source-files])
(lambda (file)
(let* ([base (extract-base-filename/c file 'mzc)] (let* ([base (extract-base-filename/c file 'mzc)]
[dest (append-object-suffix [dest (append-object-suffix
(let-values ([(base name dir?) (split-path base)]) (let-values ([(base name dir?) (split-path base)])
(build-path (or (dest-dir) 'same) name)))]) (build-path (or (dest-dir) 'same) name)))])
(printf "\"~a\":~n" file) (printf "\"~a\":\n" file)
(compile-extension (not (compiler:option:verbose)) (compile-extension (not (compiler:option:verbose)) file dest null)
file (printf " [output to \"~a\"]\n" dest)))]
dest
null)
(printf " [output to \"~a\"]~n" dest)))
source-files)]
[(ld) [(ld)
(extract-base-filename/ext (ld-output) 'mzc) (extract-base-filename/ext (ld-output) 'mzc)
;; (for-each (lambda (file) (extract-base-filename/o file 'mzc)) source-files) ;; (for ([file source-files]) (extract-base-filename/o file 'mzc))
(let ([dest (if (dest-dir) (let ([dest (if (dest-dir)
(build-path (dest-dir) (ld-output)) (build-path (dest-dir) (ld-output))
(ld-output))]) (ld-output))])
(printf "~a:~n" (let ([s (apply string-append (printf "~a:\n" (let ([s (apply string-append
(map (lambda (n) (format " \"~a\"" n)) source-files))]) (map (lambda (n) (format " \"~a\"" n))
source-files))])
(substring s 1 (string-length s)))) (substring s 1 (string-length s))))
(link-extension (not (compiler:option:verbose)) (link-extension (not (compiler:option:verbose))
source-files source-files
dest) dest)
(printf " [output to \"~a\"]~n" dest))] (printf " [output to \"~a\"]\n" dest))]
[(xform) [(xform)
(for-each (lambda (file) (for ([file source-files])
(let* ([out-file (path-replace-suffix file ".3m.c")] (let* ([out-file (path-replace-suffix file ".3m.c")]
[out-file (if (dest-dir) [out-file (if (dest-dir)
(build-path (dest-dir) out-file) (build-path (dest-dir) out-file)
@ -550,8 +504,7 @@
file file
out-file out-file
(list (find-include-dir))) (list (find-include-dir)))
(printf " [output to \"~a\"]~n" out-file))) (printf " [output to \"~a\"]\n" out-file)))]
source-files)]
[(exe gui-exe) [(exe gui-exe)
(unless (= 1 (length source-files)) (unless (= 1 (length source-files))
(error 'mzc "expected a single module source file to embed; given: ~e" (error 'mzc "expected a single module source file to embed; given: ~e"
@ -566,42 +519,33 @@
#:mred? (eq? mode 'gui-exe) #:mred? (eq? mode 'gui-exe)
#:variant (if (compiler:option:3m) '3m 'cgc) #:variant (if (compiler:option:3m) '3m 'cgc)
#:verbose? (compiler:option:verbose) #:verbose? (compiler:option:verbose)
#:modules (cons #:modules (cons `(#%mzc: (file ,(car source-files)))
`(#%mzc: (file ,(car source-files))) (map (lambda (l) `(#t (lib ,l)))
(map (lambda (l)
`(#t (lib ,l)))
(exe-embedded-libraries))) (exe-embedded-libraries)))
#:literal-expression (parameterize ([current-namespace (make-base-namespace)]) #:literal-expression
(parameterize ([current-namespace (make-base-namespace)])
(compile (compile
`(namespace-require `(namespace-require
'',(string->symbol '',(string->symbol
(format (format "#%mzc:~a"
"#%mzc:~a" (let-values ([(base name dir?)
(let-values ([(base name dir?) (split-path (car source-files))]) (split-path (car source-files))])
(path->bytes (path-replace-suffix name #"")))))))) (path->bytes (path-replace-suffix name #""))))))))
#:cmdline (exe-embedded-flags) #:cmdline (exe-embedded-flags)
#:collects-path (exe-embedded-collects-path) #:collects-path (exe-embedded-collects-path)
#:collects-dest (exe-embedded-collects-dest) #:collects-dest (exe-embedded-collects-dest)
#:aux (exe-aux)) #:aux (exe-aux))
(printf " [output to \"~a\"]~n" dest))] (printf " [output to \"~a\"]\n" dest))]
[(c-mods) [(c-mods)
(let ([dest (mods-output)]) (let ([dest (mods-output)])
(let-values ([(in out) (make-pipe)]) (let-values ([(in out) (make-pipe)])
(parameterize ([current-output-port out]) (parameterize ([current-output-port out])
((dynamic-require '(lib "embed.ss" "compiler") ((dynamic-require '(lib "embed.ss" "compiler") 'write-module-bundle)
'write-module-bundle)
#:modules #:modules
(append (append (map (lambda (l) `(#f (file ,l))) source-files)
(map (lambda (l) (map (lambda (l) `(#t (lib ,l))) (exe-embedded-libraries)))))
`(#f (file ,l)))
source-files)
(map (lambda (l)
`(#t (lib ,l)))
(exe-embedded-libraries)))))
(close-output-port out) (close-output-port out)
(let ([out (open-output-file (let ([out (open-output-file dest #:exists 'truncate/replace)])
dest
#:exists 'truncate/replace)])
(fprintf out "#ifdef MZ_XFORM\n") (fprintf out "#ifdef MZ_XFORM\n")
(fprintf out "XFORM_START_SKIP;\n") (fprintf out "XFORM_START_SKIP;\n")
(fprintf out "#endif\n") (fprintf out "#endif\n")
@ -609,11 +553,8 @@
(fprintf out " static unsigned char data[] = {") (fprintf out " static unsigned char data[] = {")
(let loop ([pos 0]) (let loop ([pos 0])
(let ([b (read-byte in)]) (let ([b (read-byte in)])
(when (zero? (modulo pos 20)) (when (zero? (modulo pos 20)) (fprintf out "\n "))
(fprintf out "\n ")) (unless (eof-object? b) (fprintf out "~a," b) (loop (add1 pos)))))
(unless (eof-object? b)
(fprintf out "~a," b)
(loop (add1 pos)))))
(fprintf out "0\n };\n") (fprintf out "0\n };\n")
(fprintf out " Scheme_Object *eload = NULL, *a[3] = {NULL, NULL, NULL};\n") (fprintf out " Scheme_Object *eload = NULL, *a[3] = {NULL, NULL, NULL};\n")
(fprintf out " MZ_GC_DECL_REG(4);\n") (fprintf out " MZ_GC_DECL_REG(4);\n")
@ -632,63 +573,53 @@
(fprintf out "XFORM_END_SKIP;\n") (fprintf out "XFORM_END_SKIP;\n")
(fprintf out "#endif\n") (fprintf out "#endif\n")
(close-output-port out))) (close-output-port out)))
(printf " [output to \"~a\"]~n" dest))] (printf " [output to \"~a\"]\n" dest))]
[(exe-dir) [(exe-dir)
((dynamic-require 'compiler/distribute ((dynamic-require 'compiler/distribute 'assemble-distribution)
'assemble-distribution)
(exe-dir-output) (exe-dir-output)
source-files source-files
#:collects-path (exe-embedded-collects-path) #:collects-path (exe-embedded-collects-path)
#:copy-collects (exe-dir-add-collects-dirs)) #:copy-collects (exe-dir-add-collects-dirs))
(printf " [output to \"~a\"]~n" (exe-dir-output))] (printf " [output to \"~a\"]\n" (exe-dir-output))]
[(plt) [(plt)
(for-each (lambda (fd) (for ([fd source-files])
(unless (relative-path? fd) (unless (relative-path? fd)
(error (error 'mzc
'mzc
"file/directory is not relative to the current directory: \"~a\"" "file/directory is not relative to the current directory: \"~a\""
fd))) fd)))
source-files)
(pack-plt (plt-output) (plt-name) (pack-plt (plt-output) (plt-name)
source-files source-files
#:collections (map list (plt-setup-collections)) #:collections (map list (plt-setup-collections))
#:file-mode (if (plt-files-replace) #:file-mode (if (plt-files-replace) 'file-replace 'file)
'file-replace
'file)
#:plt-relative? (or (plt-files-plt-relative?) #:plt-relative? (or (plt-files-plt-relative?)
(plt-files-plt-home-relative?)) (plt-files-plt-home-relative?))
#:at-plt-home? (plt-files-plt-home-relative?) #:at-plt-home? (plt-files-plt-home-relative?)
#:test-plt-dirs (if (or (plt-force-install-dir?) #:test-plt-dirs (if (or (plt-force-install-dir?)
(not (plt-files-plt-home-relative?))) (not (plt-files-plt-home-relative?)))
#f #f
(list "collects" "doc" "include" "lib")) '("collects" "doc" "include" "lib"))
#:requires #:requires
;; Get current version of mzscheme for require: ;; Get current version of mzscheme for require:
(let ([i (get-info '("mzscheme"))]) (let* ([i (get-info '("mzscheme"))]
(let ([v (and i (i 'version (lambda () #f)))]) [v (and i (i 'version (lambda () #f)))])
(list (list '("mzscheme") v))))) (list (list '("mzscheme") v))))
(printf " [output to \"~a\"]~n" (plt-output))] (printf " [output to \"~a\"]\n" (plt-output))]
[(plt-collect) [(plt-collect)
(pack-collections-plt (pack-collections-plt
(plt-output) (plt-output)
(if (eq? default-plt-name (plt-name)) (if (eq? default-plt-name (plt-name)) #f (plt-name))
#f
(plt-name))
(map (lambda (sf) (map (lambda (sf)
(let loop ([sf sf]) (let loop ([sf sf])
(let ([m (regexp-match "^([^/]*)/(.*)$" sf)]) (let ([m (regexp-match "^([^/]*)/(.*)$" sf)])
(if m (if m (cons (cadr m) (loop (caddr m))) (list sf)))))
(cons (cadr m) (loop (caddr m)))
(list sf)))))
source-files) source-files)
#:replace? (plt-files-replace) #:replace? (plt-files-replace)
#:extra-setup-collections (map list (plt-setup-collections)) #:extra-setup-collections (map list (plt-setup-collections))
#:file-filter (if (plt-include-compiled) #:file-filter (if (plt-include-compiled)
(lambda (path) (lambda (path)
(or (regexp-match #rx"compiled$" path) (or (regexp-match #rx"compiled$" path) (std-filter path)))
(std-filter path)))
std-filter) std-filter)
#:at-plt-home? (plt-files-plt-home-relative?) #:at-plt-home? (plt-files-plt-home-relative?)
#:test-plt-collects? (not (plt-force-install-dir?))) #:test-plt-collects? (not (plt-force-install-dir?)))
(printf " [output to \"~a\"]~n" (plt-output))] (printf " [output to \"~a\"]\n" (plt-output))]
[else (printf "bad mode: ~a~n" mode)])) [else (printf "bad mode: ~a\n" mode)])