rico

svn: r18733

collects/compiler/commands/c-ext.ss

@@ -0,0 +1,398 @@
+#lang scheme/base
+
+;; On error, exit with 1 status code
+(error-escape-handler (lambda () (exit 1)))
+
+(error-print-width 512)
+
+(require (prefix-in compiler:option: "../option.ss")
+         "../compiler.ss"
+         rico/command-name
+         mzlib/cmdline
+         dynext/file
+         dynext/compile
+         dynext/link
+         scheme/pretty
+         setup/pack
+         setup/getinfo
+         setup/dirs)
+
+(define dest-dir (make-parameter #f))
+(define auto-dest-dir (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-dir-output (make-parameter #f))
+
+(define mods-output (make-parameter #f))
+
+(define module-mode (make-parameter #f))
+
+(define default-plt-name "archive")
+
+(define disable-inlining (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 (extract-suffix appender)
+  (bytes->string/latin-1
+   (subbytes (path->bytes (appender (bytes->path #"x"))) 1)))
+
+(define ((add-to-param param) f v) (param (append (param) (list v))))
+
+(define mzc-symbol (string->symbol (short-program+command-name)))
+
+;; Returns (values mode files prefixes)
+;;  where mode is 'compile, 'make-zo, etc.
+(define-values (mode source-files prefix)
+  (parse-command-line
+   (short-program+command-name)
+   (current-command-line-arguments)
+   `([help-labels
+      "-------------------------------- mode flags ---------------------------------"]
+     [once-any
+      [("--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 <extension>: ~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))
+         ""))]
+      [("--c-mods")
+       ,(lambda (f name) (mods-output name) 'c-mods)
+       ((,(format "Write C-embeddable module bytecode to <file>") "")
+        "file")]
+      [("-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)))]]
+     [help-labels ""]
+     [once-any
+      [("--3m")
+       ,(lambda (f) (compiler:option:3m #t))
+       (,(format "Compile/link for 3m~a"
+                 (if (eq? '3m (system-type 'gc)) " [current default]" "")))]
+      [("--cgc")
+       ,(lambda (f) (compiler:option:3m #f))
+       (,(format "Compile/link for CGC~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")]
+      [("--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 <name> as extra part of public low-level names" "name")]]
+     [once-any
+      [("-d" "--destination")
+       ,(lambda (f d)
+          (unless (directory-exists? d)
+            (error mzc-symbol "the destination directory does not exist: ~s" d))
+          (dest-dir d))
+       ("Output -e/-c/-x file(s) to <dir>" "dir")]
+      [("--auto-dir")
+       ,(lambda (f) (auto-dest-dir #t))
+       (,(format "Output -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 <tool> 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 <compiler-path> 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 <linker-path> 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
+      "-------------------- -c/-e 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-symbol "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")]
+      [("--no-prim")
+       ,(lambda (f) (compiler:option:assume-primitives #f))
+       ("Do not assume `scheme' 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:somewhat-verbose #t))
+       ("Slightly verbose mode, including version banner and output files")]
+      [("--vv")
+       ,(lambda (f) (compiler:option:somewhat-verbose #t) (compiler:option:verbose #t))
+       ("Very 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) 
+                       (error mzc-symbol "no mode flag specified")
+                       (car l)))])
+       (values
+        mode
+        files
+        (let ([prefixes (filter string? accum)])
+          (unless (or (memq mode '(compile compile-c)) (null? prefixes))
+            (error mzc-symbol "prefix files are not useful in ~a mode" mode))
+          (if (module-mode)
+            (begin
+              (unless (compiler:option:assume-primitives)
+                (error mzc-symbol "--no-prim is not useful with -m or --module"))
+              (unless (null? prefixes)
+                (error mzc-symbol "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")))
+
+(when (compiler:option:somewhat-verbose)
+  (printf "~a v~a [~a], Copyright (c) 2004-2010 PLT Scheme Inc.\n"
+          (short-program+command-name)
+          (version)
+          (system-type 'gc)))
+
+(when (and (auto-dest-dir) (not (memq mode '(zo compile))))
+  (error mzc-symbol "--auto-dir works only with -z, --zo, -e, or --extension (or default mode)"))
+
+(define (never-embedded action)
+  (when (compiler:option:compile-for-embedded)
+    (error mzc-symbol "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)
+           "Warning: ~a\n         ~a\n"
+           "compilation to C is usually less effective for performance"
+           "than relying on the bytecode just-in-time compiler."))
+
+(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))]
+  [(cc)
+   (for ([file source-files])
+     (let* ([base (extract-base-filename/c file mzc-symbol)]
+            [dest (append-object-suffix
+                   (let-values ([(base name dir?) (split-path base)])
+                     (build-path (or (dest-dir) 'same) name)))])
+       (when (compiler:option:somewhat-verbose)
+         (printf "\"~a\":\n" file))
+       (compile-extension (not (compiler:option:verbose)) file dest null)
+       (when (compiler:option:somewhat-verbose)
+         (printf " [output to \"~a\"]\n" dest))))]
+  [(ld)
+   (extract-base-filename/ext (ld-output) mzc-symbol)
+   ;; (for ([file source-files]) (extract-base-filename/o file mzc-symbol))
+   (let ([dest (if (dest-dir)
+                 (build-path (dest-dir) (ld-output))
+                 (ld-output))])
+     (when (compiler:option:somewhat-verbose)
+       (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)
+     (when (compiler:option:somewhat-verbose)
+       (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)))
+       (when (compiler:option:somewhat-verbose)
+         (printf " [output to \"~a\"]\n" out-file))))]
+  [(c-mods)
+   (let ([dest (mods-output)])
+     (let-values ([(in out) (make-pipe)])
+       (parameterize ([current-output-port out])
+         ((dynamic-require 'compiler/embed '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)))
+     (when (compiler:option:somewhat-verbose)
+       (printf " [output to \"~a\"]\n" dest)))]
+  [else (printf "bad mode: ~a\n" mode)])

collects/compiler/commands/decompile.ss

@@ -0,0 +1,25 @@
+#lang scheme/base
+(require scheme/cmdline
+         rico/command-name
+         compiler/zo-parse
+         compiler/decompile
+         scheme/pretty)
+
+(define source-files
+  (command-line
+   #:program (short-program+command-name)
+   #:args source-or-bytecode-file
+   source-or-bytecode-file))
+
+(for ([zo-file source-files])
+  (let ([zo-file (path->complete-path zo-file)])
+    (let-values ([(base name dir?) (split-path zo-file)])
+      (let ([alt-file (build-path base "compiled" (path-add-suffix name #".zo"))])
+        (parameterize ([current-load-relative-directory base]
+                       [print-graph #t])
+          (pretty-print
+           (decompile
+            (call-with-input-file*
+             (if (file-exists? alt-file) alt-file zo-file)
+             (lambda (in)
+               (zo-parse in))))))))))

collects/compiler/commands/exe-dir.ss

@@ -0,0 +1,31 @@
+#lang scheme/base
+(require scheme/cmdline
+         rico/command-name
+         compiler/distribute)
+
+(define verbose (make-parameter #f))
+(define exe-embedded-collects-path (make-parameter #f))
+(define exe-dir-add-collects-dirs (make-parameter null))
+
+(define-values (dest-dir source-files)
+  (command-line
+   #:program (short-program+command-name)
+   #:once-each
+   [("--collects-path") path "Set <path> as main collects for executables"
+    (exe-embedded-collects-path path)]
+   #:multi
+   [("++collects-copy") dir "Add collects in <dir> to directory"
+    (exe-dir-add-collects-dirs (append (exe-dir-add-collects-dirs) (list dir)))]
+   #:once-each
+   [("-v") "Verbose mode"
+    (verbose #t)]
+   #:args (dest-dir . executable)
+   (values dest-dir executable)))
+
+(assemble-distribution
+ dest-dir
+ source-files
+ #:collects-path (exe-embedded-collects-path)
+ #:copy-collects (exe-dir-add-collects-dirs))
+(when (verbose)
+  (printf " [output to \"~a\"]\n" dest-dir))

collects/compiler/commands/exe.ss

@@ -0,0 +1,90 @@
+#lang scheme/base
+(require scheme/cmdline
+         rico/command-name
+         compiler/private/embed
+         dynext/file)
+
+(define verbose (make-parameter #f))
+(define very-verbose (make-parameter #f))
+
+(define gui (make-parameter #f))
+(define 3m (make-parameter #t))
+
+(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 source-file
+  (command-line
+   #:program (short-program+command-name)
+   #:once-each
+   [("-o") file "Write executable as <file>"
+    (exe-output file)]
+   [("--gui") "Geneate GUI executable"
+    (gui #t)]
+   [("--collects-path") path "Set <path> as main collects for executable"
+    (exe-embedded-collects-path path)]
+   [("--collects-dest") dir "Write collection code to <dir>"
+    (exe-embedded-collects-dest dir)]
+   [("--ico") .ico-file "Set Windows icon for executable"
+    (exe-aux (cons (cons 'ico .ico-file) (exe-aux)))]
+   [("--icns") .icns-file "Set Mac OS X icon for executable"
+    (exe-aux (cons (cons 'icns .icns-file) (exe-aux)))]
+   [("--orig-exe") "Use original executable instead of stub"
+    (exe-aux (cons (cons 'original-exe? #t) (exe-aux)))]
+   [("--3m") "Generate using 3m variant"
+    (3m #t)]
+   [("--cgc") "Generate using CGC variant"
+    (3m #f)]
+   #:multi
+   [("++lib") lib "Embed <lib> in executable"
+    (exe-embedded-libraries (append (exe-embedded-libraries) (list lib)))]
+   [("++exf") flag "Add flag to embed in executable"
+    (exe-embedded-flags (append (exe-embedded-flags) (list flag)))]
+   [("--exf") flag "Remove flag to embed in executable"
+    (exe-embedded-flags (remove flag (exe-embedded-flags)))]
+   [("--exf-clear") "Clear flags to embed in executable"
+    (exe-embedded-flags null)]
+   [("--exf-show") "Show flags to embed in executable"
+    (printf "Flags to embed: ~s\n" (exe-embedded-flags))]
+   #:once-each
+   [("-v") "Verbose mode"
+    (verbose #t)]
+   [("--vv") "Very verbose mode"
+    (verbose #t)
+    (very-verbose #t)]
+   #:args (source-file)
+   source-file))
+
+(let ([dest (mzc:embedding-executable-add-suffix
+             (or (exe-output)
+                 (extract-base-filename/ss source-file
+                                           (string->symbol (short-program+command-name))))
+             (gui))])
+  (mzc:create-embedding-executable
+   dest
+   #:mred? (gui)
+   #:variant (if (3m) '3m 'cgc)
+   #:verbose? (very-verbose)
+   #:modules (cons `(#%mzc: (file ,source-file))
+                   (map (lambda (l) `(#t (lib ,l)))
+                        (exe-embedded-libraries)))
+   #:configure-via-first-module? #t
+   #:literal-expression
+   (parameterize ([current-namespace (make-base-namespace)])
+     (compile
+      `(namespace-require
+        '',(string->symbol
+            (format "#%mzc:~a"
+                    (let-values ([(base name dir?)
+                                  (split-path source-file)])
+                      (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))
+  (when (verbose)
+    (printf " [output to \"~a\"]\n" dest)))

collects/compiler/commands/expand.ss

@@ -0,0 +1,26 @@
+#lang scheme/base
+(require scheme/cmdline
+         rico/command-name
+         scheme/pretty)
+
+(define source-files
+  (command-line
+   #:program (short-program+command-name)
+   #:args source-file
+   source-file))
+
+(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))))))))))

collects/compiler/commands/info.ss

@@ -0,0 +1,10 @@
+#lang setup/infotab
+
+(define rico
+  '(("make" compiler/commands/make "compile source to bytecode" 100)
+    ("exe" compiler/commands/exe "create executable" 20)
+    ("pack" compiler/commands/pack "pack files/collections into a .plt archive" 10)
+    ("decompile" compiler/commands/decompile "decompile bytecode" #f)
+    ("expand" compiler/commands/expand "macro-expand source" #f)
+    ("distribute" compiler/commands/exe-dir "prepare executable(s) in a directory for distribution" #f)
+    ("c-ext" compiler/commands/c-ext "compile and link C-based extensions" #f)))

collects/compiler/commands/make.ss

@@ -0,0 +1,79 @@
+#lang scheme/base
+(require scheme/cmdline
+         rico/command-name
+         compiler/cm
+         "../compiler.ss"
+         dynext/file)
+
+(define verbose (make-parameter #f))
+(define very-verbose (make-parameter #f))
+(define disable-inlining (make-parameter #f))
+
+(define disable-deps (make-parameter #f))
+(define prefixes (make-parameter null))
+(define assume-primitives (make-parameter #t))
+
+(define source-files
+  (command-line
+   #:program (short-program+command-name)
+   #:once-each
+   [("--disable-inline") "Disable procedure inlining during compilation"
+    (disable-inlining #t)]
+   [("--no-deps") "Compile immediate files without updating depdencies"
+    (disable-deps #t)]
+   [("-p" "--prefix") file "Add elaboration-time prefix file for --no-deps"
+    (prefixes (append (prefixes) (list file)))]
+   [("--no-prim") "Do not assume `scheme' bindings at top level for --no-deps"
+    (assume-primitives #f)]
+   [("-v") "Verbose mode"
+    (verbose #t)]
+   [("--vv") "Very verbose mode"
+    (verbose #t)
+    (very-verbose #t)]
+   #:args file file))
+
+(if (disable-deps)
+    ;; Just compile one file:
+    (let ([prefix
+           `(begin
+              (require scheme)
+              ,(if (assume-primitives)
+                   '(void)
+                   '(namespace-require/copy 'scheme))
+              (require compiler/cffi)
+              ,@(map (lambda (s) `(load ,s)) (prefixes))
+              (void))])
+      ((compile-zos prefix #:verbose? (verbose))
+       source-files
+       'auto))
+    ;; Normal make:
+    (let ([n (make-base-empty-namespace)]
+          [did-one? #f])
+      (parameterize ([current-namespace n]
+                     [manager-trace-handler
+                      (lambda (p)
+                        (when (very-verbose)
+                          (printf "  ~a\n" p)))]
+                     [manager-compile-notify-handler
+                      (lambda (p)
+                        (set! did-one? #t)
+                        (when (verbose)
+                          (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)])
+            (when (verbose)
+              (printf "\"~a\":\n" file))
+            (parameterize ([compile-context-preservation-enabled
+                            (disable-inlining)])
+              (managed-compile-zo file))
+            (let ([dest (append-zo-suffix
+                         (let-values ([(base name dir?) (split-path file)])
+                           (build-path (if (symbol? base) 'same base)
+                                       "compiled" name)))])
+              (when (verbose)
+                (printf " [~a \"~a\"]\n"
+                        (if did-one? "output to" "already up-to-date at")
+                        dest))))))))

collects/compiler/commands/pack.ss

@@ -0,0 +1,99 @@
+#lang scheme/base
+(require scheme/cmdline
+         rico/command-name
+         setup/pack
+         setup/getinfo
+         compiler/distribute)
+
+(define verbose (make-parameter #f))
+
+(define collection? (make-parameter #f))
+
+(define default-plt-name "archive")
+
+(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-values (plt-output source-files)
+  (command-line
+   #:program (short-program+command-name)
+   #:once-each
+   [("--collect") "Pack collections instead of files and directories"
+    (collection? #t)]
+   [("--plt-name") name "Set the printed <name> describing the archive"
+    (plt-name name)]
+   [("--replace") "Files in archive replace existing files when unpacked"
+    (plt-files-replace #t)]
+   [("--at-plt") "Files/dirs in archive are relative to user's add-ons directory"
+    (plt-files-plt-relative? #t)]
+   #:once-any
+   [("--all-users") "Files/dirs in archive go to PLT installation if writable"
+    (plt-files-plt-home-relative? #t)]
+   [("--force-all-users") "Files/dirs forced to PLT installation"
+    (plt-files-plt-home-relative? #t) (plt-force-install-dir? #t)]
+   #:once-each
+   [("--include-compiled") "Include \"compiled\" subdirectories in the archive"
+    (plt-include-compiled #t)]
+   #:multi
+   [("++setup") collect "Setup <collect> after the archive is unpacked"
+    (plt-setup-collections (append (plt-setup-collections) (list collect)))]
+   #:once-each
+   [("-v") "Verbose mode"
+    (verbose #t)]
+   #:args (dest-file . file)
+   (values dest-file file)))
+
+(if (not (collection?))
+    ;; Files and directories
+    (begin
+      (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))))
+      (when (verbose)
+        (printf " [output to \"~a\"]\n" plt-output)))
+    ;; Collection
+    (begin
+      (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->bytes path))
+                               (std-filter path)))
+                         std-filter)
+       #:at-plt-home? (plt-files-plt-home-relative?)
+       #:test-plt-collects? (not (plt-force-install-dir?)))
+      (when (verbose)
+        (printf " [output to \"~a\"]\n" plt-output))))
+

collects/compiler/distribute.ss

@@ -75,9 +75,11 @@
 			(let* ([specific-lib-dir
                                 (build-path "lib"
                                             "plt"
-                                            (let-values ([(base name dir?) 
-                                                          (split-path (car binaries))])
-                                              (path-replace-suffix name #"")))]
+                                            (if (null? binaries)
+                                                "generic"
+                                                (let-values ([(base name dir?) 
+                                                              (split-path (car binaries))])
+                                                  (path-replace-suffix name #""))))]
                                [relative-collects-dir 
                                 (or collects-path
                                     (build-path specific-lib-dir
@@ -120,18 +122,19 @@
                        (collects-path->bytes 
                         (relative->binary-relative sub-dir type relative-collects-dir))))
                     binaries types sub-dirs)
-          ;; Copy over extensions and adjust embedded paths:
-          (copy-extensions-and-patch-binaries orig-binaries binaries types sub-dirs
-                                              exts-dir 
-                                              relative-exts-dir
-                                              relative->binary-relative)
-          ;; Copy over runtime files and adjust embedded paths:
-          (copy-runtime-files-and-patch-binaries orig-binaries binaries types sub-dirs
-                                                 exts-dir 
-                                                 relative-exts-dir
-                                                 relative->binary-relative)
-          ;; Done!
-          (void)))))
+          (unless (null? binaries)
+            ;; Copy over extensions and adjust embedded paths:
+            (copy-extensions-and-patch-binaries orig-binaries binaries types sub-dirs
+                                                exts-dir 
+                                                relative-exts-dir
+                                                relative->binary-relative)
+            ;; Copy over runtime files and adjust embedded paths:
+            (copy-runtime-files-and-patch-binaries orig-binaries binaries types sub-dirs
+                                                   exts-dir 
+                                                   relative-exts-dir
+                                                   relative->binary-relative)
+            ;; Done!
+            (void))))))
 
   (define (install-libs lib-dir types)
     (case (system-type)

collects/meta/dist-specs.ss

@@ -428,6 +428,9 @@ platform-dependent := ; hook for package rules
 mz-extras :+= (- (package: "setup-plt" #:collection "setup/")
                  (cond (not dr) => (srcfile: "plt-installer{|-sig|-unit}.ss")))
 
+;; -------------------- rico
+mz-extras :+= (package: "rico")
+
 ;; -------------------- launcher
 mz-extras :+= (- (collects: "launcher")
                  (cond (not mr) => "[Mm]r[Ss]tart*.exe"))

collects/planet/info.ss

@@ -4,3 +4,5 @@
 (define mzscheme-launcher-names '("planet"))
 (define mzscheme-launcher-libraries '("planet.ss"))
 (define scribblings '(("planet.scrbl" (multi-page) (tool))))
+
+(define rico '(("planet" planet/planet "manage Planet package installations" 80)))

collects/planet/planet.ss

@@ -11,6 +11,7 @@ PLANNED FEATURES:
            (only mzlib/list sort)
            net/url
            mzlib/match
+           rico/command-name
            
            "config.ss"
            "private/planet-shared.ss"
@@ -27,7 +28,7 @@ PLANNED FEATURES:
     (planet-logging-to-stdout #t)
     
     (svn-style-command-line
-     #:program "planet"
+     #:program (short-program+command-name)
      #:argv (current-command-line-arguments)
      "PLT Scheme PLaneT command-line tool. Provides commands to help you manipulate your local planet cache."
      ["create" "create a PLaneT archive from a directory"

collects/rico/command-name.ss

@@ -0,0 +1,23 @@
+#lang scheme/base
+
+(provide current-command-name
+         program+command-name
+         short-program+command-name)
+
+(define current-command-name (make-parameter #f))
+
+(define (program+command-name)
+  (let ([p (find-system-path 'run-file)]
+        [n (current-command-name)])
+    (if n
+        (format "~a ~a" p n)
+        p)))
+
+(define (short-program+command-name)
+  (let ([p (find-system-path 'run-file)]
+        [n (current-command-name)])
+    (let-values ([(base name dir?) (split-path p)])
+      (if n
+          (format "~a ~a" name n)
+          (path->string name)))))
+

collects/rico/info.ss

@@ -0,0 +1,6 @@
+#lang setup/infotab
+
+(define compile-omit-paths '("main.ss"))
+
+(define mzscheme-launcher-libraries '("main.ss"))
+(define mzscheme-launcher-names '("Rico"))

collects/rico/main.lch

@@ -0,0 +1,5 @@
+The context of this file doesn't matter.
+It's existence causes the launcher-maker to
+create an "independent launcher", which
+means that it doesn't depend on the exact
+MzScheme/MrEd executable or DLLs.

collects/rico/main.ss

@@ -0,0 +1,23 @@
+
+;; Because `rico setup' is used to rebuild .zos, check for "setup"
+;; directly.
+
+;; Note that this file is listed in "info.ss" so that it never gets a
+;; .zo file. Do not `require' this module from anywhere, not even 
+;; `for-label', otherwise it could get a .zo anyway.
+
+(module main '#%kernel
+  (#%require '#%min-stx
+             ;; Need to make sure they're here:
+             '#%builtin)
+
+  (let-values ([(cmdline) (current-command-line-arguments)])
+    (if (and (positive? (vector-length cmdline))
+             (equal? "setup" (vector-ref cmdline 0)))
+        (parameterize ([current-command-line-arguments
+                        (list->vector
+                         (cdr
+                          (vector->list cmdline)))])
+          (dynamic-require 'setup/main #f))
+        (dynamic-require 'rico/rico #f))))
+

collects/rico/rico.ss

@@ -0,0 +1,111 @@
+#lang scheme/base
+(require setup/getinfo
+         "command-name.ss")
+
+(define cmdline (vector->list (current-command-line-arguments)))
+
+(define (find-by-prefix hash str)
+  (let ([trie (make-hash)])
+    (for ([key (in-hash-keys hash)])
+      (for/fold ([trie trie]) ([c (string->list key)])
+        (let ([next (hash-ref trie c (lambda () (make-hash)))])
+          (if (hash-ref next #f #f)
+              (hash-set! next #f null)
+              (hash-set! next #f key))
+          (hash-set! trie c next)
+          next)))
+    (let ([t (for/fold ([trie trie]) ([c (string->list str)])
+               (and trie
+                    (hash-ref trie c #f)))])
+      (and t
+           (let ([s (hash-ref t #f #f)])
+             (if (string? s)
+                 (hash-ref hash s)
+                 'ambiguous))))))
+
+(let* ([dirs (find-relevant-directories '(rico))]
+       [infos (map get-info/full dirs)]
+       [tools (make-hash)])
+  (for-each (lambda (i d)
+              (for-each (lambda (entry)
+                          (cond
+                           [(and (list? entry)
+                                 (= (length entry) 4)
+                                 (string? (car entry))
+                                 (module-path? (cadr entry))
+                                 (string? (caddr entry))
+                                 (or (not (list-ref entry 3))
+                                     (real? (list-ref entry 3))))
+                            (let ([p (hash-ref tools (car entry) #f)])
+                              (when p
+                                (fprintf
+                                 (current-error-port)
+                                 "warning: tool ~s registered twice: ~e and ~e"
+                                 (car entry)
+                                 (car p)
+                                 d)))
+                            (hash-set! tools (car entry) entry)]
+                           [else
+                            (fprintf
+                             (current-error-port)
+                             "warning: ~s provided bad `rico' spec: ~e"
+                             d
+                             entry)]))
+                        (let ([l (i 'rico (lambda () null))])
+                          (if (list? l)
+                              l
+                              (list l)))))
+            infos
+            dirs)
+  (let ([show-all?
+         (cond
+          [(null? cmdline) #f]
+          [(or (equal? (car cmdline) "--help")
+               (equal? (car cmdline) "-h"))
+           #t]
+          [(regexp-match? #rx"^-" (car cmdline))
+           (fprintf (current-error-port) "~a: A flag must follow a command: ~a\n\n"
+                    (find-system-path 'run-file)
+                    (car cmdline))
+           #f]
+          [(or (hash-ref tools (car cmdline) #f)
+               (find-by-prefix tools (car cmdline)))
+           => (lambda (tool)
+                (if (eq? 'ambiguous tool)
+                    (begin
+                      (fprintf (current-error-port) "~a: Ambiguous command prefix: ~a\n\n"
+                               (find-system-path 'run-file)
+                               (car cmdline))
+                      #f)
+                    (parameterize ([current-command-line-arguments
+                                    (list->vector (cdr cmdline))]
+                                   [current-command-name (car tool)])
+                      (dynamic-require (cadr tool) #f)
+                      (exit))))]
+          [else
+           (fprintf (current-error-port) "~a: Unrecognized command: ~a\n\n"
+                    (find-system-path 'run-file)
+                    (car cmdline))
+           #f])])
+    (fprintf (current-error-port) "Usage: rico <command> <option> ... <arg> ...\n\n")
+    (fprintf (current-error-port) "~a commands:\n" (if show-all? 
+                                                       "Available"
+                                                       "Frequently used"))
+    (let ([l (sort (hash-map tools (lambda (k v) v))
+                   (if show-all?
+                       (lambda (a b) (string<? (car a) (car b)))
+                       (lambda (a b) (> (or (list-ref a 3) -inf.0) (or (list-ref b 3) -inf.0)))))])
+      (let ([largest (apply max 0 (map (lambda (v) (string-length (car v))) l))])
+        (for ([i (in-list l)])
+          (when (or show-all? (cadddr i))
+            (fprintf (current-error-port)
+                     "  ~a~a~a\n"
+                     (car i)
+                     (make-string (- largest -3 (string-length (car i))) #\space)
+                     (caddr i))))))
+    (printf "\nA command can be specified by an unambigous prefix.")
+    (unless show-all?
+      (printf "\nSee `rico --help' for a complete list of commands."))
+    (printf "\nSee `rico <command> --help' for help on a command."))
+  (newline)
+  (exit 1))

collects/scribblings/reference/filesystem.scrbl

@@ -123,8 +123,7 @@ by @scheme[kind], which must be one of the following:
   (or @exec{mred}) executable, or because an embedding executable
   installed an alternate path. In particular a ``launcher'' script
   created by @scheme[make-mzscheme-launcher] sets this path to the
-  script's path. In the @exec{mzscheme} executable, this path is also
-  bound initially to @scheme[program].}
+  script's path.}
 
  @item{@indexed-scheme['collects-dir] --- a path to the main
  collection of libraries (see @secref["collects"]). If this path is

collects/setup/info.ss

@@ -4,3 +4,5 @@
 
 (define mzscheme-launcher-libraries '("main.ss"))
 (define mzscheme-launcher-names '("Setup PLT"))
+
+(define rico '(("setup" setup/main "install and build libraries and documentation" 90)))

collects/setup/main.ss

@@ -23,7 +23,7 @@
         (namespace-attach-module cns ''#%builtin ns)
         ns)))
 
-  (define-values (flags specific-collections specific-planet-packages archives)
+  (define-values (short-name flags specific-collections specific-planet-packages archives)
     ;; Load the command-line parser without using .zos,
     ;;  and in its own namespace to avoid poluting the cm-managed
     ;;  namespace later
@@ -40,7 +40,7 @@
 
   (define-values (print-bootstrapping)
     (lambda ()
-      (fprintf (current-output-port) "setup-plt: bootstrapping from source...\n")))
+      (fprintf (current-output-port) "~a: bootstrapping from source...\n" short-name)))
 
   (define-values (main-collects-relative->path)
     (let ([main-collects #f])

collects/setup/option-sig.ss

@@ -5,7 +5,8 @@
   (provide setup-option^)
 
   (define-signature setup-option^
-    (verbose
+    (setup-program-name
+     verbose
      make-verbose
      compiler-verbose
      clean

collects/setup/option-unit.ss

@@ -23,6 +23,8 @@
   (import)
   (export setup-option^)
 
+  (define setup-program-name (make-parameter "setup-plt"))
+
   (define-flag-param verbose #f)
   (define-flag-param make-verbose #f)
   (define-flag-param compiler-verbose #f)

collects/setup/setup-cmdline.ss

@@ -5,7 +5,8 @@
 
 #lang scheme/base
 
-(require scheme/cmdline)
+(require scheme/cmdline
+         rico/command-name)
 
 (provide parse-cmdline)
 
@@ -23,8 +24,24 @@
   (define (add-flags l)
     (set! x-flags (append (reverse l) x-flags)))
 
+  (define-values (short-name long-name)
+    (let ([p (find-system-path 'run-file)])
+      (let-values ([(base name dir?) (split-path p)])
+        (cond
+         [(current-command-name)
+          (values (format "~a ~a" name (current-command-name))
+                  (program+command-name))]
+         ;; Hack for bootstrapping, if the program name is "rico",
+         ;; then claim to be the "setup" command:
+         [(equal? (path->string name) "rico")
+          (values (format "~a setup" name)
+                  (format "~a setup" p))]
+         [else
+          (values (path->string name) p)]))))
+
   (define-values (x-specific-collections x-archives)
     (command-line
+     #:program long-name
      #:argv argv
      #:once-each
      [("-c" "--clean") "Delete existing compiled files; implies -nxi"
@@ -103,4 +120,4 @@
                "all collections are setup")
        (exit 0))))
 
-    (values x-flags x-specific-collections x-specific-planet-packages x-archives))
+    (values short-name x-flags x-specific-collections x-specific-planet-packages x-archives))

collects/setup/setup-go.ss

@@ -10,7 +10,7 @@
 
   (define-values/invoke-unit/infer setup:option@)
 
-  (define-values (x-flags x-specific-collections x-specific-planet-packages x-archives)
+  (define-values (short-name x-flags x-specific-collections x-specific-planet-packages x-archives)
     (parse-cmdline (current-command-line-arguments)))
 
   ;; Pseudo-option:
@@ -28,6 +28,8 @@
   (archives x-archives)
   (specific-planet-dirs x-specific-planet-packages)
 
+  (setup-program-name short-name)
+
   (require launcher/launcher-sig
 	   launcher/launcher-unit
 

collects/setup/setup-unit.ss

@@ -47,9 +47,12 @@
           launcher^)
   (export)
 
+  (define name-str (setup-program-name))
+  (define name-sym (string->symbol name-str))
+
   (define (setup-fprintf p task s . args)
     (let ([task (if task (string-append task ": ") "")])
-      (apply fprintf p (string-append "setup-plt: " task s "\n") args)))
+      (apply fprintf p (string-append name-str ": " task s "\n") args)))
 
   (define (setup-printf task s . args)
     (apply setup-fprintf (current-output-port) task s args))
@@ -175,7 +178,7 @@
        info 'name (lambda () #f)
        (lambda (x)
          (when (and x (not (string? x)))
-           (error 'setup-plt
+           (error name-sym
                   "'name' result from collection ~e is not a string: ~e"
                   path x)))))
     (define path-name (path->name path))
@@ -221,13 +224,13 @@
        (let ([maj (string->number maj-str)]
              [min (string->number min-str)])
          (unless maj
-           (error 'setup-plt "bad major version for PLaneT package: ~e" maj-str))
+           (error name-sym "bad major version for PLaneT package: ~e" maj-str))
          (unless min
-           (error 'setup-plt "bad minor version for PLaneT package: ~e" min-str))
+           (error name-sym "bad minor version for PLaneT package: ~e" min-str))
          (let ([pkg (lookup-package-by-keys owner pkg-name maj min min)])
            (if pkg
              pkg
-             (error 'setup-plt "not an installed PLaneT package: (~e ~e ~e ~e)"
+             (error name-sym "not an installed PLaneT package: (~e ~e ~e ~e)"
                     owner pkg-name maj min))))]
       [_ spec]))
 
@@ -337,7 +340,7 @@
                        (cadr cc+name+id)))
                 all-ccs+names+ids)
          => (lambda (bad)
-              (error 'setup-plt
+              (error name-sym
                      "given collection path: \"~a\" refers to the same directory as another given collection path, \"~a\""
                      (cadr given-cc+name+id) bad))]))
     (map car given*-ccs+names+ids))
@@ -440,7 +443,7 @@
                                          (system-library-subpath))))
                      (lambda (x)
                        (unless (list-of path-string? x)
-                         (error 'setup-plt
+                         (error name-sym
                                 "expected a list of path strings for 'clean, got: ~s"
                                 x))))]
              [printed? #f]
@@ -542,7 +545,7 @@
               (let ([installer
                      (with-handlers ([exn:fail?
                                       (lambda (exn)
-                                        (error 'setup-plt
+                                        (error name-sym
                                                "error loading installer: ~a"
                                                (exn->string exn)))])
                        (dynamic-require (build-path (cc-path cc) fn)
@@ -599,7 +602,7 @@
       (let ([zo-compile
              (with-handlers ([exn:fail?
                               (lambda (exn)
-                                (error 'setup-plt
+                                (error name-sym
                                        "error loading compiler for mode ~s: ~a"
                                        (compile-mode)
                                        (exn->string exn)))])