From f94acb09d59ef8777c1b021ea26fbd54a79ca9c2 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Mon, 24 Mar 2008 10:14:02 +0000 Subject: [PATCH] some minor reformatting and improvements svn: r9075 --- collects/compiler/main.ss | 1241 +++++++++++++++++-------------------- 1 file changed, 586 insertions(+), 655 deletions(-) diff --git a/collects/compiler/main.ss b/collects/compiler/main.ss index 98feb1c31e..0778d86afd 100644 --- a/collects/compiler/main.ss +++ b/collects/compiler/main.ss @@ -14,681 +14,612 @@ ;; See manual for information about the Scheme-level interface ;; provided by this collection. -(module main scheme/base +#lang scheme/base - ;; On error, exit with 1 status code - (error-escape-handler (lambda () (exit 1))) +;; On error, exit with 1 status code +(error-escape-handler (lambda () (exit 1))) - (error-print-width 512) +(error-print-width 512) - (require (prefix-in compiler:option: "option.ss")) - (require "compiler.ss") +(require (prefix-in compiler:option: "option.ss")) +(require "compiler.ss") - ;; Read argv array for arguments and input file name - (require mzlib/cmdline - mzlib/list - dynext/file - dynext/compile - dynext/link - scheme/pretty - (lib "pack.ss" "setup") - (lib "getinfo.ss" "setup") - setup/dirs) +;; Read argv array for arguments and input file name +(require mzlib/cmdline + dynext/file + dynext/compile + dynext/link + scheme/pretty + (lib "pack.ss" "setup") + (lib "getinfo.ss" "setup") + setup/dirs) - (define dest-dir (make-parameter #f)) - (define auto-dest-dir (make-parameter #f)) +(define 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-embedded-flags (make-parameter '("-U" "--"))) - (define exe-embedded-libraries (make-parameter null)) - (define exe-aux (make-parameter null)) - (define exe-embedded-collects-path (make-parameter #f)) - (define exe-embedded-collects-dest (make-parameter #f)) - (define exe-dir-add-collects-dirs (make-parameter null)) +(define exe-output (make-parameter #f)) +(define exe-embedded-flags (make-parameter '("-U" "--"))) +(define exe-embedded-libraries (make-parameter null)) +(define exe-aux (make-parameter null)) +(define exe-embedded-collects-path (make-parameter #f)) +(define exe-embedded-collects-dest (make-parameter #f)) +(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-name (make-parameter default-plt-name)) - (define plt-files-replace (make-parameter #f)) - (define plt-files-plt-relative? (make-parameter #f)) - (define plt-files-plt-home-relative? (make-parameter #f)) - (define plt-force-install-dir? (make-parameter #f)) - (define plt-setup-collections (make-parameter null)) - (define plt-include-compiled (make-parameter #f)) +(define plt-output (make-parameter #f)) +(define plt-name (make-parameter default-plt-name)) +(define plt-files-replace (make-parameter #f)) +(define plt-files-plt-relative? (make-parameter #f)) +(define plt-files-plt-home-relative? (make-parameter #f)) +(define plt-force-install-dir? (make-parameter #f)) +(define plt-setup-collections (make-parameter null)) +(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) - (bytes->string/latin-1 - (subbytes - (path->bytes (appender (bytes->path #"x"))) - 1))) +(define (extract-suffix appender) + (bytes->string/latin-1 + (subbytes (path->bytes (appender (bytes->path #"x"))) 1))) +;; Returns (values mode files prefixes) +;; where mode is 'compile, 'make-zo, etc. +(define (parse-options argv) + (define ((add-to-param param) f v) (param (append (param) (list v)))) + (parse-command-line + "mzc" + argv + `([help-labels + "-------------------------------- mode flags ---------------------------------"] + [once-any + [("-k" "--make") + ,(lambda (f) 'make-zo) + (("Recursively compile Scheme source(s); uses/generates .dep files" ""))] + [("--cc") + ,(lambda (f) 'cc) + (,(format "Compile arbitrary file(s) for an extension: ~a -> ~a" + (extract-suffix append-c-suffix) + (extract-suffix append-object-suffix)))] + [("--ld") + ,(lambda (f name) (ld-output name) 'ld) + (,(format "Link arbitrary file(s) to create : ~a -> ~a" + (extract-suffix append-object-suffix) + (extract-suffix append-extension-suffix)) + "extension")] + [("-x" "--xform") + ,(lambda (f) 'xform) + ((,(format "Convert for 3m compilation: ~a -> ~a" + (extract-suffix append-c-suffix) + (extract-suffix append-c-suffix)) + ""))] + [("--exe") + ,(lambda (f name) (exe-output name) 'exe) + (,(format "Embed module in MzScheme to create ") + "exe")] + [("--gui-exe") + ,(lambda (f name) (exe-output name) 'gui-exe) + (,(format "Embed module in MrEd to create ") + "exe")] + [("--exe-dir") + ,(lambda (f name) (exe-dir-output name) 'exe-dir) + ((,(format "Combine executables with support files in ") "") + "dir")] + [("--c-mods") + ,(lambda (f name) (mods-output name) 'c-mods) + ((,(format "Write C-embeddable module bytecode to ") "") + "file")] + [("--collection-plt") + ,(lambda (f name) (plt-output name) 'plt-collect) + (,(format "Create .plt containing collections") + "archive")] + [("--plt") + ,(lambda (f name) (plt-output name) 'plt) + ((,(format "Create .plt containing relative files/dirs") "") + "archive")] + [("-e" "--extension") + ,(lambda (f) 'compile) + (,(format "Output ~a file(s) from Scheme source(s)" (extract-suffix append-extension-suffix)))] + [("-c" "--c-source") + ,(lambda (f) 'compile-c) + ((,(format "Output ~a file(s) from Scheme source(s)" (extract-suffix append-c-suffix)) + ""))] + [("-z" "--zo") + ,(lambda (f) 'zo) + (,(format "Output ~a file(s) from Scheme source(s)" (extract-suffix append-zo-suffix)))] + [("--collection-zos") + ,(lambda (f) 'collection-zos) + ((,(format "Compile specified collection to ~a files" (extract-suffix append-zo-suffix)) ""))] + [("--expand") + ,(lambda (f) 'expand) + (,(format "Write macro-expanded Scheme source(s) to stdout"))]] + [help-labels ""] + [once-any + [("--3m") + ,(lambda (f) (compiler:option:3m #t)) + (,(format "Compile/link for 3m, with -e/-c/--exe/etc.~a" + (if (eq? '3m (system-type 'gc)) " [current default]" "")))] + [("--cgc") + ,(lambda (f) (compiler:option:3m #f)) + (,(format "Compile/link for CGC, with -e/-c/--exe/etc.~a" + (if (eq? 'cgc (system-type 'gc)) " [current default]" "")))]] + [once-each + [("-m" "--module") + ,(lambda (f) (module-mode #t)) + ("Skip eval of top-level syntax, etc. for -e/-c/-z")] + [("--embedded") + ,(lambda (f) (compiler:option:compile-for-embedded #t)) + ("Compile for embedded run-time engine, with -c")] + [("-p" "--prefix") + ,(lambda (f v) v) + ("Add elaboration-time prefix file for -e/-c/-z" "file")] + [("-n" "--name") + ,(lambda (f name) (compiler:option:setup-prefix name)) + ("Use as extra part of public low-level names" "name")]] + [once-any + [("-d" "--destination") + ,(lambda (f d) + (unless (directory-exists? d) + (error 'mzc "the destination directory does not exist: ~s" d)) + (dest-dir d)) + ("Output -e/-c/-z/-x file(s) to " "dir")] + [("--auto-dir") + ,(lambda (f) (auto-dest-dir #t)) + (,(format "Output -z to \"compiled\", -e to ~s" + (path->string (build-path "compiled" "native" + (system-library-subpath #f)))))]] + [help-labels + "------------------- compiler/linker configuration flags ---------------------"] + [once-each + [("--tool") + ,(lambda (f v) + (let ([v (string->symbol v)]) + (use-standard-compiler v) + (use-standard-linker v))) + (,(format "Use pre-defined as C compiler/linker:~a" + (apply string-append + (apply append (map (lambda (t) + (list " " (symbol->string t))) + (get-standard-compilers))))) + "tool")] + [("--compiler") + ,(lambda (f v) (current-extension-compiler v)) + ("Use as C compiler" "compiler-path")]] + [multi + [("++ccf") + ,(add-to-param current-extension-compiler-flags) + ("Add C compiler flag" "flag")] + [("--ccf") + ,(lambda (f v) + (current-extension-compiler-flags + (remove v (current-extension-compiler-flags)))) + ("Remove C compiler flag" "flag")] + [("--ccf-clear") + ,(lambda (f) (current-extension-compiler-flags null)) + ("Clear C compiler flags")] + [("--ccf-show") + ,(lambda (f) + (printf "C compiler flags: ~s\n" + (expand-for-link-variant (current-extension-compiler-flags)))) + ("Show C compiler flags")]] + [once-each + [("--linker") + ,(lambda (f v) (current-extension-linker v)) + ("Use as C linker" "linker-path")]] + [multi + [("++ldf") + ,(add-to-param current-extension-linker-flags) + ("Add C linker flag" "flag")] + [("--ldf") + ,(lambda (f v) + (current-extension-linker-flags + (remove v (current-extension-linker-flags)))) + ("Remove C linker flag" "flag")] + [("--ldf-clear") + ,(lambda (f) (current-extension-linker-flags null)) + ("Clear C linker flags")] + [("--ldf-show") + ,(lambda (f) + (printf "C linker flags: ~s\n" + (expand-for-link-variant (current-extension-linker-flags)))) + ("Show C linker flags")] + [("++ldl") + ,(add-to-param current-standard-link-libraries) + ("Add C linker library" "lib")] + [("--ldl-show") + ,(lambda (f) + (printf "C linker libraries: ~s\n" + (expand-for-link-variant (current-standard-link-libraries)))) + ("Show C linker libraries")]] + [multi + [("++cppf") + ,(add-to-param current-extension-preprocess-flags) + ("Add C preprocess (xform) flag" "flag")] + [("--cppf") + ,(lambda (f v) + (current-extension-preprocess-flags + (remove v (current-extension-preprocess-flags)))) + ("Remove C preprocess (xform) flag" "flag")] + [("--cppf-clear") + ,(lambda (f) (current-extension-preprocess-flags null)) + ("Clear C preprocess (xform) flags")] + [("--cppf-show") + ,(lambda (f) + (printf "C compiler flags: ~s\n" + (expand-for-link-variant (current-extension-preprocess-flags)))) + ("Show C preprocess (xform) flags")]] + [help-labels + "--------------------- executable configuration flags ------------------------"] + [once-each + [("--collects-path") + ,(lambda (f i) + (exe-embedded-collects-path i)) + ("Set main collects in --[gui-]exe/--exe-dir" "path")] + [("--collects-dest") + ,(lambda (f i) (exe-embedded-collects-dest i)) + ("Add --[gui-]exe collection code to " "dir")] + [("--ico") + ,(lambda (f i) (exe-aux (cons (cons 'ico i) (exe-aux)))) + ("Windows icon for --[gui-]exe executable" ".ico-file")] + [("--icns") + ,(lambda (f i) (exe-aux (cons (cons 'icns i) (exe-aux)))) + ("Mac OS X icon for --[gui-]exe executable" ".icns-file")] + [("--orig-exe") + ,(lambda (f) (exe-aux (cons (cons 'original-exe? #t) (exe-aux)))) + ("Use original executable for --[gui-]exe instead of stub")]] + [multi + [("++lib") + ,(lambda (f l) + (exe-embedded-libraries (append (exe-embedded-libraries) (list l)))) + ("Embed in --[gui-]exe executable" "lib")] + [("++collects-copy") + ,(lambda (f d) + (exe-dir-add-collects-dirs (append (exe-dir-add-collects-dirs) (list d)))) + ("Add collects in to --exe-dir" "dir")] + [("++exf") + ,(add-to-param exe-embedded-flags) + ("Add flag to embed in --[gui-]exe executable" "flag")] + [("--exf") + ,(lambda (f v) (exe-embedded-flags (remove v (exe-embedded-flags)))) + ("Remove flag to embed in --[gui-]exe executable" "flag")] + [("--exf-clear") + ,(lambda (f) (exe-embedded-flags null)) + ("Clear flags to embed in --[gui-]exe executable")] + [("--exf-show") + ,(lambda (f) (printf "Flags to embed: ~s\n" (exe-embedded-flags))) + ("Show flag to embed in --[gui-]exe executable")]] + [help-labels + "----------------------------- .plt archive flags ----------------------------"] + [once-each + [("--plt-name") + ,(lambda (f n) (plt-name n)) + ("Set the printed describing the archive" "name")] + [("--replace") + ,(lambda (f) (plt-files-replace #t)) + ("Files in archive replace existing files when unpacked")] + [("--at-plt") + ,(lambda (f) (plt-files-plt-relative? #t)) + ("Files/dirs in archive are relative to user's add-ons directory")]] + [once-any + [("--all-users") + ,(lambda (f) (plt-files-plt-home-relative? #t)) + ("Files/dirs in archive go to PLT installation if writable")] + [("--force-all-users") + ,(lambda (f) (plt-files-plt-home-relative? #t) (plt-force-install-dir? #t)) + ("Files/dirs forced to PLT installation")]] + [once-each + [("--include-compiled") + ,(lambda (f) (plt-include-compiled #t)) + ("Include \"compiled\" subdirectories in the archive")]] + [multi + [("++setup") + ,(lambda (f c) + (plt-setup-collections (append (plt-setup-collections) (list c)))) + ("Setup after the archive is unpacked" "collect")]] + [help-labels + "----------------------- compiler optimization flags -------------------------"] + [once-each + [("--no-prop") + ,(lambda (f) (compiler:option:propagate-constants #f)) + ("Don't propagate constants")] + [("--inline") + ,(lambda (f d) + (compiler:option:max-inline-size + (with-handlers ([void (lambda (x) + (error 'mzc "bad size for --inline: ~a" d))]) + (let ([v (string->number d)]) + (unless (and (not (negative? v)) (exact? v) (real? v)) + (error 'bad)) + v)))) + ("Set the maximum inlining size" "size")] + [("--prim") + ,(lambda (f) (compiler:option:assume-primitives #t)) + ("Assume primitive bindings at top level")] + [("--stupid") + ,(lambda (f) (compiler:option:stupid #t)) + ("Compile despite obvious non-syntactic errors")] + [("--unsafe-disable-interrupts") + ,(lambda (f) (compiler:option:disable-interrupts #t)) + ("Ignore threads, breaks, and stack overflow")] + [("--unsafe-skip-tests") + ,(lambda (f) (compiler:option:unsafe #t)) + ("Skip run-time tests for some primitive operations")] + [("--unsafe-fixnum-arithmetic") + ,(lambda (f) (compiler:option:fixnum-arithmetic #t)) + ("Assume fixnum arithmetic yields a fixnum")]] + [help-labels + "-------------------------- miscellaneous flags ------------------------------"] + [once-each + [("-v") + ,(lambda (f) (compiler:option:verbose #t)) + ("Verbose mode")] + [("--save-temps") + ,(lambda (f) (compiler:option:clean-intermediate-files #f)) + ("Keep intermediate files")] + [("--debug") + ,(lambda (f) (compiler:option:debug #t)) + ("Write debugging output to dump.txt")]]) + (lambda (accum . files) + (let ([mode (let ([l (filter symbol? accum)]) + (if (null? l) 'make-zo (car l)))]) + (values + mode + files + (let ([prefixes (filter string? accum)]) + (unless (or (memq mode '(compile compile-c zo)) (null? prefixes)) + (error 'mzc "prefix files are not useful in ~a mode" mode)) + (if (module-mode) + (begin + (when (compiler:option:assume-primitives) + (error 'mzc "--prim is not useful with -m or --module")) + (unless (null? prefixes) + (error 'mzc "prefix files not allowed with -m or --module")) + #f) + `(begin + (require scheme) + ,(if (compiler:option:assume-primitives) + '(void) + '(namespace-require/copy 'scheme)) + (require compiler/cffi) + ,@(map (lambda (s) `(load ,s)) prefixes) + (void))))))) + (list "file/directory/collection"))) - ;; Returns (values mode files prefixes) - ;; where mode is 'compile, 'make-zo, etc. - (define (parse-options argv) - (parse-command-line - "mzc" - argv - `([help-labels - "-------------------------------- mode flags ---------------------------------"] - [once-any - [("-k" "--make") - ,(lambda (f) 'make-zo) - (("Recursively compile Scheme source(s); uses/generates .dep files" ""))] - [("--cc") - ,(lambda (f) 'cc) - (,(format "Compile arbitrary file(s) for an extension: ~a -> ~a" - (extract-suffix append-c-suffix) - (extract-suffix append-object-suffix)))] - [("--ld") - ,(lambda (f name) (ld-output name) 'ld) - (,(format "Link arbitrary file(s) to create : ~a -> ~a" - (extract-suffix append-object-suffix) - (extract-suffix append-extension-suffix)) - "extension")] - [("-x" "--xform") - ,(lambda (f) 'xform) - ((,(format "Convert for 3m compilation: ~a -> ~a" - (extract-suffix append-c-suffix) - (extract-suffix append-c-suffix)) - ""))] - [("--exe") - ,(lambda (f name) (exe-output name) 'exe) - (,(format "Embed module in MzScheme to create ") - "exe")] - [("--gui-exe") - ,(lambda (f name) (exe-output name) 'gui-exe) - (,(format "Embed module in MrEd to create ") - "exe")] - [("--exe-dir") - ,(lambda (f name) (exe-dir-output name) 'exe-dir) - ((,(format "Combine executables with support files in ") "") - "dir")] - [("--c-mods") - ,(lambda (f name) (mods-output name) 'c-mods) - ((,(format "Write C-embeddable module bytecode to ") "") - "file")] - [("--collection-plt") - ,(lambda (f name) (plt-output name) 'plt-collect) - (,(format "Create .plt containing collections") - "archive")] - [("--plt") - ,(lambda (f name) (plt-output name) 'plt) - ((,(format "Create .plt containing relative files/dirs") "") - "archive")] - [("-e" "--extension") - ,(lambda (f) 'compile) - (,(format "Output ~a file(s) from Scheme source(s)" (extract-suffix append-extension-suffix)))] - [("-c" "--c-source") - ,(lambda (f) 'compile-c) - ((,(format "Output ~a file(s) from Scheme source(s)" (extract-suffix append-c-suffix)) - ""))] - [("-z" "--zo") - ,(lambda (f) 'zo) - (,(format "Output ~a file(s) from Scheme source(s)" (extract-suffix append-zo-suffix)))] - [("--collection-zos") - ,(lambda (f) 'collection-zos) - ((,(format "Compile specified collection to ~a files" (extract-suffix append-zo-suffix)) ""))] - [("--expand") - ,(lambda (f) 'expand) - (,(format "Write macro-expanded Scheme source(s) to stdout"))]] - [help-labels ""] - [once-any - [("--3m") - ,(lambda (f) (compiler:option:3m #t)) - (,(format "Compile/link for 3m, with -e/-c/--exe/etc.~a" - (if (eq? '3m (system-type 'gc)) " [current default]" "")))] - [("--cgc") - ,(lambda (f) (compiler:option:3m #f)) - (,(format "Compile/link for CGC, with -e/-c/--exe/etc.~a" - (if (eq? 'cgc (system-type 'gc)) " [current default]" "")))]] - [once-each - [("-m" "--module") - ,(lambda (f) (module-mode #t)) - ("Skip eval of top-level syntax, etc. for -e/-c/-z")] - [("--embedded") - ,(lambda (f) (compiler:option:compile-for-embedded #t)) - ("Compile for embedded run-time engine, with -c")] - [("-p" "--prefix") - ,(lambda (f v) v) - ("Add elaboration-time prefix file for -e/-c/-z" "file")] - [("-n" "--name") - ,(lambda (f name) (compiler:option:setup-prefix name)) - ("Use as extra part of public low-level names" "name")]] - [once-any - [("-d" "--destination") - ,(lambda (f d) - (unless (directory-exists? d) - (error 'mzc "the destination directory does not exist: ~s" d)) - (dest-dir d)) - ("Output -e/-c/-z/-x file(s) to " "dir")] - [("--auto-dir") - ,(lambda (f) - (auto-dest-dir #t)) - (,(format "Output -z to \"compiled\", -e to ~s" - (path->string - (build-path "compiled" "native" (system-library-subpath #f)))))]] +(printf "mzc v~a [~a], Copyright (c) 2004-2008 PLT Scheme Inc.\n" + (version) + (system-type 'gc)) - [help-labels - "------------------- compiler/linker configuration flags ---------------------"] - [once-each - [("--tool") - ,(lambda (f v) - (let ([v (string->symbol v)]) - (use-standard-compiler v) - (use-standard-linker v))) - (,(format "Use pre-defined as C compiler/linker:~a" - (apply string-append - (apply append - (map (lambda (t) - (list " " (symbol->string t))) - (get-standard-compilers))))) - "tool")] - [("--compiler") - ,(lambda (f v) (current-extension-compiler v)) - ("Use as C compiler" "compiler-path")]] - [multi - [("++ccf") - ,(lambda (f v) (current-extension-compiler-flags - (append (current-extension-compiler-flags) - (list v)))) - ("Add C compiler flag" "flag")] - [("--ccf") - ,(lambda (f v) (current-extension-compiler-flags - (remove v (current-extension-compiler-flags)))) - ("Remove C compiler flag" "flag")] - [("--ccf-clear") - ,(lambda (f) (current-extension-compiler-flags null)) - ("Clear C compiler flags")] - [("--ccf-show") - ,(lambda (f) - (printf "C compiler flags: ~s~n" (expand-for-link-variant - (current-extension-compiler-flags)))) - ("Show C compiler flags")]] - [once-each - [("--linker") - ,(lambda (f v) (current-extension-linker v)) - ("Use as C linker" "linker-path")]] - [multi - [("++ldf") - ,(lambda (f v) (current-extension-linker-flags - (append (current-extension-linker-flags) - (list v)))) - ("Add C linker flag" "flag")] - [("--ldf") - ,(lambda (f v) (current-extension-linker-flags - (remove v (current-extension-linker-flags)))) - ("Remove C linker flag" "flag")] - [("--ldf-clear") - ,(lambda (f) (current-extension-linker-flags null)) - ("Clear C linker flags")] - [("--ldf-show") - ,(lambda (f) - (printf "C linker flags: ~s~n" (expand-for-link-variant - (current-extension-linker-flags)))) - ("Show C linker flags")] - [("++ldl") - ,(lambda (f v) (current-standard-link-libraries - (append (current-standard-link-libraries) - (list v)))) - ("Add C linker library" "lib")] - [("--ldl-show") - ,(lambda (f) - (printf "C linker libraries: ~s~n" (expand-for-link-variant - (current-standard-link-libraries)))) - ("Show C linker libraries")]] - [multi - [("++cppf") - ,(lambda (f v) (current-extension-preprocess-flags - (append (current-extension-preprocess-flags) - (list v)))) - ("Add C preprocess (xform) flag" "flag")] - [("--cppf") - ,(lambda (f v) (current-extension-preprocess-flags - (remove v (current-extension-preprocess-flags)))) - ("Remove C preprocess (xform) flag" "flag")] - [("--cppf-clear") - ,(lambda (f) (current-extension-preprocess-flags null)) - ("Clear C preprocess (xform) flags")] - [("--cppf-show") - ,(lambda (f) - (printf "C compiler flags: ~s~n" (expand-for-link-variant - (current-extension-preprocess-flags)))) - ("Show C preprocess (xform) flags")]] - [help-labels - "--------------------- executable configuration flags ------------------------"] - [once-each - [("--collects-path") - ,(lambda (f i) - (exe-embedded-collects-path i)) - ("Set main collects in --[gui-]exe/--exe-dir" "path")] - [("--collects-dest") - ,(lambda (f i) - (exe-embedded-collects-dest i)) - ("Add --[gui-]exe collection code to " "dir")] - [("--ico") - ,(lambda (f i) (exe-aux - (cons (cons 'ico i) - (exe-aux)))) - ("Windows icon for --[gui-]exe executable" ".ico-file")] - [("--icns") - ,(lambda (f i) (exe-aux - (cons (cons 'icns i) - (exe-aux)))) - ("Mac OS X icon for --[gui-]exe executable" ".icns-file")] - [("--orig-exe") - ,(lambda (f) (exe-aux - (cons (cons 'original-exe? #t) - (exe-aux)))) - ("Use original executable for --[gui-]exe instead of stub")]] - [multi - [("++lib") - ,(lambda (f l) (exe-embedded-libraries - (append (exe-embedded-libraries) - (list l)))) - ("Embed in --[gui-]exe executable" "lib")] - [("++collects-copy") - ,(lambda (f d) (exe-dir-add-collects-dirs - (append (exe-dir-add-collects-dirs) - (list d)))) - ("Add collects in to --exe-dir" "dir")] - [("++exf") - ,(lambda (f v) (exe-embedded-flags - (append (exe-embedded-flags) - (list v)))) - ("Add flag to embed in --[gui-]exe executable" "flag")] - [("--exf") - ,(lambda (f v) (exe-embedded-flags - (remove v (exe-embedded-flags)))) - ("Remove flag to embed in --[gui-]exe executable" "flag")] - [("--exf-clear") - ,(lambda (f) (exe-embedded-flags null)) - ("Clear flags to embed in --[gui-]exe executable")] - [("--exf-show") - ,(lambda (f) - (printf "Flags to embed: ~s~n" (exe-embedded-flags))) - ("Show flag to embed in --[gui-]exe executable")]] - [help-labels - "----------------------------- .plt archive flags ----------------------------"] - [once-each - [("--plt-name") - ,(lambda (f n) (plt-name n)) - ("Set the printed describing the archive" "name")] - [("--replace") - ,(lambda (f) (plt-files-replace #t)) - ("Files in archive replace existing files when unpacked")] - [("--at-plt") - ,(lambda (f) (plt-files-plt-relative? #t)) - ("Files/dirs in archive are relative to user's add-ons directory")]] - [once-any - [("--all-users") - ,(lambda (f) (plt-files-plt-home-relative? #t)) - ("Files/dirs in archive go to PLT installation if writable")] - [("--force-all-users") - ,(lambda (f) - (plt-files-plt-home-relative? #t) - (plt-force-install-dir? #t)) - ("Files/dirs forced to PLT installation")]] - [once-each - [("--include-compiled") - ,(lambda (f) (plt-include-compiled #t)) - ("Include \"compiled\" subdirectories in the archive")]] - [multi - [("++setup") - ,(lambda (f c) (plt-setup-collections - (append (plt-setup-collections) - (list c)))) - ("Setup after the archive is unpacked" "collect")]] - [help-labels - "----------------------- compiler optimization flags -------------------------"] +(define-values (mode source-files prefix) + (parse-options (current-command-line-arguments))) - [once-each - [("--no-prop") - ,(lambda (f) (compiler:option:propagate-constants #f)) - ("Don't propagate constants")] - [("--inline") - ,(lambda (f d) (compiler:option:max-inline-size - (with-handlers ([void - (lambda (x) - (error 'mzc "bad size for --inline: ~a" d))]) - (let ([v (string->number d)]) - (unless (and (not (negative? v)) (exact? v) (real? v)) - (error 'bad)) - v)))) - ("Set the maximum inlining size" "size")] - [("--prim") - ,(lambda (f) (compiler:option:assume-primitives #t)) - ("Assume primitive bindings at top level")] - [("--stupid") - ,(lambda (f) (compiler:option:stupid #t)) - ("Compile despite obvious non-syntactic errors")] - [("--unsafe-disable-interrupts") - ,(lambda (f) (compiler:option:disable-interrupts #t)) - ("Ignore threads, breaks, and stack overflow")] - [("--unsafe-skip-tests") - ,(lambda (f) (compiler:option:unsafe #t)) - ("Skip run-time tests for some primitive operations")] - [("--unsafe-fixnum-arithmetic") - ,(lambda (f) (compiler:option:fixnum-arithmetic #t)) - ("Assume fixnum arithmetic yields a fixnum")]] - [help-labels - "-------------------------- miscellaneous flags ------------------------------"] - [once-each - [("-v") - ,(lambda (f) (compiler:option:verbose #t)) - ("Verbose mode")] - [("--save-temps") - ,(lambda (f) (compiler:option:clean-intermediate-files #f)) - ("Keep intermediate files")] - [("--debug") - ,(lambda (f) (compiler:option:debug #t)) - ("Write debugging output to dump.txt")]]) - (lambda (accum . files) - (let ([mode (let ([l (filter symbol? accum)]) - (if (null? l) - 'make-zo - (car l)))]) - (values - mode - files - (let ([prefixes (filter string? accum)]) - (unless (memq mode '(compile compile-c zo)) - (unless (null? prefixes) - (error 'mzc "prefix files are not useful in ~a mode" mode))) - (if (module-mode) - (begin - (when (compiler:option:assume-primitives) - (error 'mzc "--prim is not useful with -m or --module")) - (unless (null? prefixes) - (error 'mzc "prefix files not allowed with -m or --module")) - #f) - `(begin - (require scheme) - ,(if (compiler:option:assume-primitives) - '(void) - '(namespace-require/copy 'scheme)) - (require compiler/cffi) - ,@(map (lambda (s) `(load ,s)) prefixes) - (void))))))) - (list "file/directory/collection"))) +(when (and (auto-dest-dir) (not (memq mode '(zo compile)))) + (error 'mzc "--auto-dir works only with -z, --zo, -e, or --extension (or default mode)")) - (printf "mzc v~a [~a], Copyright (c) 2004-2008 PLT Scheme Inc.~n" - (version) - (system-type 'gc)) +(define (never-embedded action) + (when (compiler:option:compile-for-embedded) + (error 'mzc "cannot ~a an extension for an embedded MzScheme" action))) - (define-values (mode source-files prefix) - (parse-options (current-command-line-arguments))) +(if (compiler:option:3m) + (begin (link-variant '3m) (compile-variant '3m)) + (begin (link-variant 'cgc) (compile-variant 'cgc))) - (when (auto-dest-dir) - (unless (memq mode '(zo compile)) - (error 'mzc "--auto-dir works only with -z, --zo, -e, or --extension (or default mode)"))) +(define (compiler-warning) + (fprintf (current-error-port) + "Warning: ~a\n ~a\n" + "compilation to C is usually less effective for performance" + "than relying on the bytecode just-in-time compiler.")) - (define (never-embedded action) - (when (compiler:option:compile-for-embedded) - (error 'mzc "cannot ~a an extension for an embedded MzScheme" action))) - - (if (compiler:option:3m) - (begin - (link-variant '3m) - (compile-variant '3m)) - (begin - (link-variant 'cgc) - (compile-variant 'cgc))) - - (define (compiler-warning) - (fprintf (current-error-port) - (string-append - "Warning: compilation to C is usually less effective for performance\n" - " than relying on the bytecode just-in-time compiler.\n"))) - - (case mode - [(compile) - (compiler-warning) - (never-embedded "compile") - ((compile-extensions prefix) source-files (if (auto-dest-dir) - 'auto - (dest-dir)))] - [(compile-c) - ((compile-extensions-to-c prefix) source-files (dest-dir))] - [(zo) - ((compile-zos prefix) source-files (if (auto-dest-dir) - 'auto - (dest-dir)))] - [(expand) - (for-each (lambda (src-file) - (let ([src-file (path->complete-path src-file)]) - (let-values ([(base name dir?) (split-path src-file)]) - (parameterize ([current-load-relative-directory base] - [current-namespace (make-base-namespace)] - [read-accept-reader #t]) - (call-with-input-file* - src-file - (lambda (in) - (port-count-lines! in) - (let loop () - (let ([e (read-syntax src-file in)]) - (unless (eof-object? e) - (pretty-print (syntax->datum (expand e))) - (loop)))))))))) - source-files)] - [(make-zo) - (let ([n (make-base-empty-namespace)] - [mc (dynamic-require 'mzlib/cm - 'managed-compile-zo)] - [cnh (dynamic-require 'mzlib/cm - 'manager-compile-notify-handler)] - [did-one? #f]) - (parameterize ([current-namespace n] - [cnh (lambda (p) - (set! did-one? #t) - (printf " making ~s~n" (path->string p)))]) - (for-each (lambda (file) - (unless (file-exists? file) - (error 'mzc "file does not exist: ~a" file)) - (set! did-one? #f) - (let ([name (extract-base-filename/ss file 'mzc)]) - (printf "\"~a\":~n" file) - (mc file) - (let ([dest (append-zo-suffix - (let-values ([(base name dir?) (split-path name)]) - (build-path (if (symbol? base) 'same base) - "compiled" name)))]) - (printf " [~a \"~a\"]~n" - (if did-one? - "output to" - "already up-to-date at") - dest)))) - source-files)))] - [(collection-zos) - (apply compile-collection-zos source-files)] - [(cc) - (for-each - (lambda (file) - (let* ([base (extract-base-filename/c file 'mzc)] - [dest (append-object-suffix - (let-values ([(base name dir?) (split-path base)]) - (build-path (or (dest-dir) 'same) name)))]) - (printf "\"~a\":~n" file) - (compile-extension (not (compiler:option:verbose)) - file - dest - null) - (printf " [output to \"~a\"]~n" dest))) - source-files)] - [(ld) - (extract-base-filename/ext (ld-output) 'mzc) - ;; (for-each (lambda (file) (extract-base-filename/o file 'mzc)) source-files) - (let ([dest (if (dest-dir) - (build-path (dest-dir) (ld-output)) - (ld-output))]) - (printf "~a:~n" (let ([s (apply string-append - (map (lambda (n) (format " \"~a\"" n)) source-files))]) - (substring s 1 (string-length s)))) - (link-extension (not (compiler:option:verbose)) - source-files - dest) - (printf " [output to \"~a\"]~n" dest))] - [(xform) - (for-each (lambda (file) - (let* ([out-file (path-replace-suffix file ".3m.c")] - [out-file (if (dest-dir) - (build-path (dest-dir) out-file) - out-file)]) - ((dynamic-require 'compiler/xform 'xform) - (not (compiler:option:verbose)) - file - out-file - (list (find-include-dir))) - (printf " [output to \"~a\"]~n" out-file))) - source-files)] - [(exe gui-exe) - (unless (= 1 (length source-files)) - (error 'mzc "expected a single module source file to embed; given: ~e" - source-files)) - (let ([dest ((dynamic-require '(lib "embed.ss" "compiler" "private") - 'mzc:embedding-executable-add-suffix) - (exe-output) - (eq? mode 'gui-exe))]) - ((dynamic-require '(lib "embed.ss" "compiler" "private") - 'mzc:create-embedding-executable) - dest - #:mred? (eq? mode 'gui-exe) - #:variant (if (compiler:option:3m) '3m 'cgc) - #:verbose? (compiler:option:verbose) - #:modules (cons - `(#%mzc: (file ,(car source-files))) - (map (lambda (l) - `(#t (lib ,l))) - (exe-embedded-libraries))) - #:literal-expression (parameterize ([current-namespace (make-base-namespace)]) - (compile - `(namespace-require - '',(string->symbol - (format - "#%mzc:~a" - (let-values ([(base name dir?) (split-path (car source-files))]) - (path->bytes (path-replace-suffix name #"")))))))) - #:cmdline (exe-embedded-flags) - #:collects-path (exe-embedded-collects-path) - #:collects-dest (exe-embedded-collects-dest) - #:aux (exe-aux)) - (printf " [output to \"~a\"]~n" dest))] - [(c-mods) - (let ([dest (mods-output)]) - (let-values ([(in out) (make-pipe)]) - (parameterize ([current-output-port out]) - ((dynamic-require '(lib "embed.ss" "compiler") - 'write-module-bundle) - #:modules - (append - (map (lambda (l) - `(#f (file ,l))) - source-files) - (map (lambda (l) - `(#t (lib ,l))) - (exe-embedded-libraries))))) - (close-output-port out) - (let ([out (open-output-file - dest - #:exists 'truncate/replace)]) - (fprintf out "#ifdef MZ_XFORM\n") - (fprintf out "XFORM_START_SKIP;\n") - (fprintf out "#endif\n") - (fprintf out "static void declare_modules(Scheme_Env *env) {\n") - (fprintf out " static unsigned char data[] = {") - (let loop ([pos 0]) - (let ([b (read-byte in)]) - (when (zero? (modulo pos 20)) - (fprintf out "\n ")) - (unless (eof-object? b) - (fprintf out "~a," b) - (loop (add1 pos))))) - (fprintf out "0\n };\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_VAR_IN_REG(0, eload);\n") - (fprintf out " MZ_GC_ARRAY_VAR_IN_REG(1, a, 3);\n") - (fprintf out " MZ_GC_REG();\n") - (fprintf out " eload = scheme_builtin_value(\"embedded-load\");\n") - (fprintf out " a[0] = scheme_false;\n") - (fprintf out " a[1] = scheme_false;\n") - (fprintf out " a[2] = scheme_make_sized_byte_string((char *)data, ~a, 0);\n" - (file-position in)) - (fprintf out " scheme_apply(eload, 3, a);\n") - (fprintf out " MZ_GC_UNREG();\n") - (fprintf out "}\n") - (fprintf out "#ifdef MZ_XFORM\n") - (fprintf out "XFORM_END_SKIP;\n") - (fprintf out "#endif\n") - (close-output-port out))) - (printf " [output to \"~a\"]~n" dest))] - [(exe-dir) - ((dynamic-require 'compiler/distribute - 'assemble-distribution) - (exe-dir-output) - source-files +(case mode + [(compile) + (compiler-warning) + (never-embedded "compile") + ((compile-extensions prefix) + source-files + (if (auto-dest-dir) 'auto (dest-dir)))] + [(compile-c) + ((compile-extensions-to-c prefix) source-files (dest-dir))] + [(zo) + ((compile-zos prefix) + source-files + (if (auto-dest-dir) 'auto (dest-dir)))] + [(expand) + (for ([src-file source-files]) + (let ([src-file (path->complete-path src-file)]) + (let-values ([(base name dir?) (split-path src-file)]) + (parameterize ([current-load-relative-directory base] + [current-namespace (make-base-namespace)] + [read-accept-reader #t]) + (call-with-input-file* + src-file + (lambda (in) + (port-count-lines! in) + (let loop () + (let ([e (read-syntax src-file in)]) + (unless (eof-object? e) + (pretty-print (syntax->datum (expand e))) + (loop))))))))))] + [(make-zo) + (let ([n (make-base-empty-namespace)] + [mc (dynamic-require 'mzlib/cm 'managed-compile-zo)] + [cnh (dynamic-require 'mzlib/cm 'manager-compile-notify-handler)] + [did-one? #f]) + (parameterize ([current-namespace n] + [cnh (lambda (p) + (set! did-one? #t) + (printf " making ~s\n" (path->string p)))]) + (for ([file source-files]) + (unless (file-exists? file) + (error 'mzc "file does not exist: ~a" file)) + (set! did-one? #f) + (let ([name (extract-base-filename/ss file 'mzc)]) + (printf "\"~a\":\n" file) + (mc file) + (let ([dest (append-zo-suffix + (let-values ([(base name dir?) (split-path name)]) + (build-path (if (symbol? base) 'same base) + "compiled" name)))]) + (printf " [~a \"~a\"]\n" + (if did-one? "output to" "already up-to-date at") + dest))))))] + [(collection-zos) + (apply compile-collection-zos source-files)] + [(cc) + (for ([file source-files]) + (let* ([base (extract-base-filename/c file 'mzc)] + [dest (append-object-suffix + (let-values ([(base name dir?) (split-path base)]) + (build-path (or (dest-dir) 'same) name)))]) + (printf "\"~a\":\n" file) + (compile-extension (not (compiler:option:verbose)) file dest null) + (printf " [output to \"~a\"]\n" dest)))] + [(ld) + (extract-base-filename/ext (ld-output) 'mzc) + ;; (for ([file source-files]) (extract-base-filename/o file 'mzc)) + (let ([dest (if (dest-dir) + (build-path (dest-dir) (ld-output)) + (ld-output))]) + (printf "~a:\n" (let ([s (apply string-append + (map (lambda (n) (format " \"~a\"" n)) + source-files))]) + (substring s 1 (string-length s)))) + (link-extension (not (compiler:option:verbose)) + source-files + dest) + (printf " [output to \"~a\"]\n" dest))] + [(xform) + (for ([file source-files]) + (let* ([out-file (path-replace-suffix file ".3m.c")] + [out-file (if (dest-dir) + (build-path (dest-dir) out-file) + out-file)]) + ((dynamic-require 'compiler/xform 'xform) + (not (compiler:option:verbose)) + file + out-file + (list (find-include-dir))) + (printf " [output to \"~a\"]\n" out-file)))] + [(exe gui-exe) + (unless (= 1 (length source-files)) + (error 'mzc "expected a single module source file to embed; given: ~e" + source-files)) + (let ([dest ((dynamic-require '(lib "embed.ss" "compiler" "private") + 'mzc:embedding-executable-add-suffix) + (exe-output) + (eq? mode 'gui-exe))]) + ((dynamic-require '(lib "embed.ss" "compiler" "private") + 'mzc:create-embedding-executable) + dest + #:mred? (eq? mode 'gui-exe) + #:variant (if (compiler:option:3m) '3m 'cgc) + #:verbose? (compiler:option:verbose) + #:modules (cons `(#%mzc: (file ,(car source-files))) + (map (lambda (l) `(#t (lib ,l))) + (exe-embedded-libraries))) + #:literal-expression + (parameterize ([current-namespace (make-base-namespace)]) + (compile + `(namespace-require + '',(string->symbol + (format "#%mzc:~a" + (let-values ([(base name dir?) + (split-path (car source-files))]) + (path->bytes (path-replace-suffix name #"")))))))) + #:cmdline (exe-embedded-flags) #:collects-path (exe-embedded-collects-path) - #:copy-collects (exe-dir-add-collects-dirs)) - (printf " [output to \"~a\"]~n" (exe-dir-output))] - [(plt) - (for-each (lambda (fd) - (unless (relative-path? fd) - (error - 'mzc - "file/directory is not relative to the current directory: \"~a\"" - fd))) - source-files) - (pack-plt (plt-output) (plt-name) - source-files - #:collections (map list (plt-setup-collections)) - #:file-mode (if (plt-files-replace) - 'file-replace - 'file) - #:plt-relative? (or (plt-files-plt-relative?) - (plt-files-plt-home-relative?)) - #:at-plt-home? (plt-files-plt-home-relative?) - #:test-plt-dirs (if (or (plt-force-install-dir?) - (not (plt-files-plt-home-relative?))) - #f - (list "collects" "doc" "include" "lib")) - #:requires - ;; Get current version of mzscheme for require: - (let ([i (get-info '("mzscheme"))]) - (let ([v (and i (i 'version (lambda () #f)))]) - (list (list '("mzscheme") v))))) - (printf " [output to \"~a\"]~n" (plt-output))] - [(plt-collect) - (pack-collections-plt - (plt-output) - (if (eq? default-plt-name (plt-name)) - #f - (plt-name)) - (map (lambda (sf) - (let loop ([sf sf]) - (let ([m (regexp-match "^([^/]*)/(.*)$" sf)]) - (if m - (cons (cadr m) (loop (caddr m))) - (list sf))))) - source-files) - #:replace? (plt-files-replace) - #:extra-setup-collections (map list (plt-setup-collections)) - #:file-filter (if (plt-include-compiled) - (lambda (path) - (or (regexp-match #rx"compiled$" path) - (std-filter path))) - std-filter) - #:at-plt-home? (plt-files-plt-home-relative?) - #:test-plt-collects? (not (plt-force-install-dir?))) - (printf " [output to \"~a\"]~n" (plt-output))] - [else (printf "bad mode: ~a~n" mode)])) + #:collects-dest (exe-embedded-collects-dest) + #:aux (exe-aux)) + (printf " [output to \"~a\"]\n" dest))] + [(c-mods) + (let ([dest (mods-output)]) + (let-values ([(in out) (make-pipe)]) + (parameterize ([current-output-port out]) + ((dynamic-require '(lib "embed.ss" "compiler") 'write-module-bundle) + #:modules + (append (map (lambda (l) `(#f (file ,l))) source-files) + (map (lambda (l) `(#t (lib ,l))) (exe-embedded-libraries))))) + (close-output-port out) + (let ([out (open-output-file dest #:exists 'truncate/replace)]) + (fprintf out "#ifdef MZ_XFORM\n") + (fprintf out "XFORM_START_SKIP;\n") + (fprintf out "#endif\n") + (fprintf out "static void declare_modules(Scheme_Env *env) {\n") + (fprintf out " static unsigned char data[] = {") + (let loop ([pos 0]) + (let ([b (read-byte in)]) + (when (zero? (modulo pos 20)) (fprintf out "\n ")) + (unless (eof-object? b) (fprintf out "~a," b) (loop (add1 pos))))) + (fprintf out "0\n };\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_VAR_IN_REG(0, eload);\n") + (fprintf out " MZ_GC_ARRAY_VAR_IN_REG(1, a, 3);\n") + (fprintf out " MZ_GC_REG();\n") + (fprintf out " eload = scheme_builtin_value(\"embedded-load\");\n") + (fprintf out " a[0] = scheme_false;\n") + (fprintf out " a[1] = scheme_false;\n") + (fprintf out " a[2] = scheme_make_sized_byte_string((char *)data, ~a, 0);\n" + (file-position in)) + (fprintf out " scheme_apply(eload, 3, a);\n") + (fprintf out " MZ_GC_UNREG();\n") + (fprintf out "}\n") + (fprintf out "#ifdef MZ_XFORM\n") + (fprintf out "XFORM_END_SKIP;\n") + (fprintf out "#endif\n") + (close-output-port out))) + (printf " [output to \"~a\"]\n" dest))] + [(exe-dir) + ((dynamic-require 'compiler/distribute 'assemble-distribution) + (exe-dir-output) + source-files + #:collects-path (exe-embedded-collects-path) + #:copy-collects (exe-dir-add-collects-dirs)) + (printf " [output to \"~a\"]\n" (exe-dir-output))] + [(plt) + (for ([fd source-files]) + (unless (relative-path? fd) + (error 'mzc + "file/directory is not relative to the current directory: \"~a\"" + fd))) + (pack-plt (plt-output) (plt-name) + source-files + #:collections (map list (plt-setup-collections)) + #:file-mode (if (plt-files-replace) 'file-replace 'file) + #:plt-relative? (or (plt-files-plt-relative?) + (plt-files-plt-home-relative?)) + #:at-plt-home? (plt-files-plt-home-relative?) + #:test-plt-dirs (if (or (plt-force-install-dir?) + (not (plt-files-plt-home-relative?))) + #f + '("collects" "doc" "include" "lib")) + #:requires + ;; Get current version of mzscheme for require: + (let* ([i (get-info '("mzscheme"))] + [v (and i (i 'version (lambda () #f)))]) + (list (list '("mzscheme") v)))) + (printf " [output to \"~a\"]\n" (plt-output))] + [(plt-collect) + (pack-collections-plt + (plt-output) + (if (eq? default-plt-name (plt-name)) #f (plt-name)) + (map (lambda (sf) + (let loop ([sf sf]) + (let ([m (regexp-match "^([^/]*)/(.*)$" sf)]) + (if m (cons (cadr m) (loop (caddr m))) (list sf))))) + source-files) + #:replace? (plt-files-replace) + #:extra-setup-collections (map list (plt-setup-collections)) + #:file-filter (if (plt-include-compiled) + (lambda (path) + (or (regexp-match #rx"compiled$" path) (std-filter path))) + std-filter) + #:at-plt-home? (plt-files-plt-home-relative?) + #:test-plt-collects? (not (plt-force-install-dir?))) + (printf " [output to \"~a\"]\n" (plt-output))] + [else (printf "bad mode: ~a\n" mode)])