Applied changes requested by @rmculpepper for PR #1587

* byte-regexp? values should not be considered 3D syntax.
* hash? values are now allowed in serialized syntax properties with (template … #:properties (…))
* marshalling properties which were prefab structs called map on the result of struct->vector, changed it to struct->list as the struct "name" is always serializable.

.travis.yml

@@ -46,6 +46,7 @@ script:
 - raco test -l tests/zo-path
 - raco test -l tests/xml/test
 - raco test -l tests/db/all-tests
+- raco test -c tests/stxparse
 notifications:
   irc: chat.freenode.net#racket-dev
   email:
@@ -56,3 +57,5 @@ notifications:
     on_success: change
   slack:
     secure: A19kphrabQHO8TU6qZcBaLQxdSNpm1ypEtbQsh8Ucg6HYPP7y1q7O7JZEndoMRHE9CNKZ9oXQzqR8H1IFVTlnjFFIJfkZzZ1YSNk4abSomhpWCq9daKMfwlcuTtY6PeI1nDVpka4/hiJGn9qzmaKYXle9Sl4CX2VEYp8o8PgMEs=
+    rooms:
+      secure: FsKzp4ItmOqd/YxqgsElgfjGW2/TU03p2p3ss+PQl/pKDQNnR/2b4pWCQ7GuqYibkmtiH1jYwrnuaLN4Cc+JyN7Z+zUtO4VSORsh3zt/gTsfgphMpCP6cB4sTqUh6AWsZOgzikj+fh7ORHEXVswQwlRHErTgZVEdEkWHBh4UWzc=

INSTALL.txt

@@ -53,7 +53,7 @@ If you stick with this repository, then you have several options:
 Quick Instructions: In-place Build
 ==================================
 
-On Unix (including Linux) and Mac OS X, `make' (or `make in-place')
+On Unix (including Linux) and Mac OS, `make' (or `make in-place')
 creates a build in the "racket" directory.
 
 On Windows with Microsoft Visual Studio (any version between 2008/9.0
@@ -81,9 +81,9 @@ installs into "<dir>" (which must be an absolute path) with binaries
 in "<dir>/bin", packages in "<dir>/share/racket/pkgs", documentation
 in "<dir>/share/racket/doc", etc.
 
-On Mac OS X, `make unix-style PREFIX=<dir>' builds and installs into
-"<dir>" (whichmust be an absolute path) with binaries in "<dir>/bin",
-packges in "<dir>/share/pkgs", documentation in "<dir>/doc", etc.
+On Mac OS, `make unix-style PREFIX=<dir>' builds and installs into
+"<dir>" (which must be an absolute path) with binaries in "<dir>/bin",
+packages in "<dir>/share/pkgs", documentation in "<dir>/doc", etc.
 
 On Windows, Unix-style install is not supported.
 
@@ -196,7 +196,7 @@ libraries. See the documentation for `raco setup' for information on
 the options.
 
 For cross compilation, add configuration options to
-`CONFIGURE_ARGS_qq="..."' as descibed in the "README" of "racket/src",
+`CONFIGURE_ARGS_qq="..."' as described in the "README" of "racket/src",
 but also add a `PLAIN_RACKET=...' argument for the top-level makefile
 to specify the same executable as in an `--enable-racket=...' for
 `configure'.
@@ -212,7 +212,7 @@ If you want to install packages manually out of the "pkgs" directory,
 the `local-catalog' target creates a catalog as "racket/local/catalog"
 that merges the currently configured catalog's content with pointers
 to the packages in "pkgs". A Unix-style build works that way: it
-builds and installs minimal Racket, and then it installs packags out
+builds and installs minimal Racket, and then it installs packages out
 of a catalog that is created by `make local-catalog'.
 
 To add a package catalog that is used after the content of "pkgs" but
@@ -321,7 +321,7 @@ normalizing the Windows results to "i386-win32" and "x86_63-win32",
 -<dist-suffix> is omitted unless a `#:dist-suffix' string is specified
 for the client in the site configuration, and <ext> is
 platform-specific: ".sh" for Unix (including Linux), ".dmg" or ".pkg"
-for Mac OS X, and ".exe" for Windows.
+for Mac OS, and ".exe" for Windows.
 
 Generating Installer Web Sites
 ------------------------------
@@ -517,7 +517,7 @@ In more detail:
      To create a ".tgz" archive instead of an installer (or any
      platform), set `TGZ_MODE' to "--tgz".
 
-     For a Mac OS X installer, set `SIGN_IDENTITY' as the name to
+     For a Mac OS installer, set `SIGN_IDENTITY' as the name to
      which the signing certificate is associated. Set `MAC_PKG_MODE'
      to "--mac-pkg" to create a ".pkg" installer instead of a ".dmg"
      image.

Makefile

@@ -98,7 +98,7 @@ win32-as-is:
 	$(WIN32_RUN_RACO) setup $(ALL_PLT_SETUP_OPTIONS)
 
 # ------------------------------------------------------------
-# Unix-style build (Unix and Mac OS X, only)
+# Unix-style build (Unix and Mac OS, only)
 
 PREFIX = 
 
@@ -234,7 +234,7 @@ SOURCE_MODE =
 # name or installation path:
 VERSIONLESS_MODE =
 
-# Set to "--mac-pkg" to create ".pkg"-based installers for Mac OS X,
+# Set to "--mac-pkg" to create ".pkg"-based installers for Mac OS,
 # instead of a ".dmg" for drag-and-drop installation:
 MAC_PKG_MODE =
 
@@ -271,7 +271,7 @@ BUILD_STAMP =
 # the default as the version number:
 INSTALL_NAME =
 
-# For Mac OS X, a signing identity (spaces allowed) for binaries in an
+# For Mac OS, a signing identity (spaces allowed) for binaries in an
 # installer:
 SIGN_IDENTITY = 
 

README.md

@@ -0,0 +1,34 @@
+[![Linux/Mac Build
+Status](https://travis-ci.org/racket/racket.svg?branch=master)](https://travis-ci.org/racket/racket)
+[![Windows build status](https://ci.appveyor.com/api/projects/status/hqir4eib0okk6xar?svg=true)](https://ci.appveyor.com/project/plt/racket)
+
+
+This is the source code for the core of Racket.  See
+"INSTALL.txt" for full information on building Racket.
+
+To build the full Racket distribution from this repository, run `make`
+in the top-level directory. To build the Minimal Racket, run `make
+base`.
+
+The rest of the Racket distribution source code is in other
+repositories under [the Racket GitHub
+organization](https://github.com/racket).
+
+Contribute to Racket by submitting a pull request, joining the
+[development mailing list](https://lists.racket-lang.org), or visiting
+the IRC channel.
+
+License
+-------
+
+Racket
+Copyright (c) 2010-2017 PLT Design Inc.
+
+Racket is distributed under the GNU Lesser General Public License
+(LGPL).  This implies that you may link Racket into proprietary
+applications, provided you follow the rules stated in the LGPL.  You can
+also modify Racket; if you distribute a modified version, you must
+distribute it under the terms of the LGPL, which in particular states
+that you must release the source code for the modified software.  
+
+See racket/src/COPYING_LESSER.txt for more information.

README.txt

@@ -1,17 +0,0 @@
-This is the source code for the main Racket distribution.  See
-"INSTALL.txt" for information on building Racket.
-
-License
--------
-
-Racket
-Copyright (c) 2010-2016 PLT Design Inc.
-
-Racket is distributed under the GNU Lesser General Public License
-(LGPL).  This implies that you may link Racket into proprietary
-applications, provided you follow the rules stated in the LGPL.  You can
-also modify Racket; if you distribute a modified version, you must
-distribute it under the terms of the LGPL, which in particular states
-that you must release the source code for the modified software.  
-
-See racket/src/COPYING_LESSER.txt for more information.

appveyor.yml

@@ -27,7 +27,7 @@ test_script:
 - racket\raco.exe test -l tests/match/main
 - racket\raco.exe test -l tests/zo-path
 - racket\raco.exe test -l tests/xml/test
-
+- racket\raco.exe test -c tests/stxparse
 
 notifications:
  - provider: Email
@@ -38,5 +38,5 @@ notifications:
 
  - provider: Slack
    auth_token:
-     secure: WCMkqS/3iB39INmhzQoZDNJ3zcOXLaRueWvaayOD9MW15DcWrGOAxz7dGrhh/EcQ
+     secure: VsZxuLzL7f/k5c/UEkiJKYxvNh9ss0Gq5ifwoZl4rlwzgtkU+2bOEo9zaP2FREF5Tb/iw4r7yQXdAYHPeo8GBQ2GQn2IksABPBEUkFrxj1k=
    channel: notifications

pkgs/at-exp-lib/LICENSE.txt

@@ -1,5 +1,5 @@
 at-exp-lib
-Copyright (c) 2010-2016 PLT Design Inc.
+Copyright (c) 2010-2017 PLT Design Inc.
 
 This package is distributed under the GNU Lesser General Public
 License (LGPL).  This means that you can link this package into proprietary

pkgs/at-exp-lib/at-exp/lang/reader.rkt

@@ -16,15 +16,7 @@
     (make-meta-reader
      'at-exp
      "language path"
-     (lambda (bstr)
-       (let* ([str (bytes->string/latin-1 bstr)]
-              [sym (string->symbol str)])
-         (and (module-path? sym)
-              (vector
-               ;; try submod first:
-               `(submod ,sym reader)
-               ;; fall back to /lang/reader:
-               (string->symbol (string-append str "/lang/reader"))))))
+     lang-reader-module-paths
      wrap-reader
      (lambda (orig-read-syntax)
        (define read-syntax (wrap-reader orig-read-syntax))

pkgs/base/LICENSE.txt

@@ -1,5 +1,5 @@
 base
-Copyright (c) 2010-2016 PLT Design Inc.
+Copyright (c) 2010-2017 PLT Design Inc.
 
 This package is distributed under the GNU Lesser General Public
 License (LGPL).  This means that you can link this package into proprietary

pkgs/base/info.rkt

@@ -12,7 +12,7 @@
 
 (define collection 'multi)
 
-(define version "6.4.0.15")
+(define version "6.8.0.2")
 
 (define deps `("racket-lib"
                ["racket" #:version ,version]))

pkgs/compiler-lib/LICENSE.txt

@@ -0,0 +1,11 @@
+compiler-lib
+Copyright (c) 2010-2017 PLT Design Inc.
+
+This package is distributed under the GNU Lesser General Public
+License (LGPL).  This means that you can link this package into proprietary
+applications, provided you follow the rules stated in the LGPL.  You
+can also modify this package; if you distribute a modified version,
+you must distribute it under the terms of the LGPL, which in
+particular means that you must release the source code for the
+modified software.  See http://www.gnu.org/copyleft/lesser.html
+for more information.

pkgs/compiler-lib/compiler/bundle-dist.rkt

@@ -0,0 +1,94 @@
+
+(module bundle-dist racket/base
+  (require racket/file
+           (only-in racket/base lambda)
+           racket/path
+	   racket/system
+	   file/zip
+	   file/tar)
+
+  (provide bundle-put-file-extension+style+filters
+	   bundle-directory)
+  
+  (define (bundle-file-suffix)
+    (case (system-type)
+      [(macosx) "dmg"]
+      [(windows) "zip"]
+      [(unix) "tgz"]))
+
+  (define (bundle-put-file-extension+style+filters)
+    (values (bundle-file-suffix)
+	    null
+	    (case (system-type)
+	      [(windows) '(("Zip file" "*.zip"))]
+	      [(macosx) '(("Disk image" "*.dmg"))]
+	      [(unix) '(("Gzipped tar file" "*.tgz"))])))
+
+  (define (add-suffix name suffix)
+    (if (filename-extension name)
+	name
+	(path-replace-suffix name
+			     (string->bytes/utf-8 (string-append "." suffix)))))
+
+  (define (with-prepared-directory dir for-exe? k)
+    ;; If `dir' contains multiple files, create a new
+    ;;  directory that contains a copy of `dir'
+    (if (and for-exe?
+	     (= 1 (length (directory-list dir))))
+	(k dir)
+	(let ([temp-dir (make-temporary-file "bundle-tmp-~a" 'directory)])
+	  (dynamic-wind
+	      void
+	      (lambda ()
+		(let ([dest
+		       (let-values ([(base name dir?) (split-path dir)])
+			 (build-path temp-dir name))])
+		  (make-directory dest)
+		  (let loop ([src dir][dest dest])
+		    (for-each (lambda (f)
+				(let ([src (build-path src f)]
+				      [dest (build-path dest f)])
+				  (cond
+				   [(directory-exists? src)
+				    (make-directory dest)
+				    (loop src dest)]
+				   [(file-exists? src)
+				    (copy-file src dest)
+				    (file-or-directory-modify-seconds 
+				     dest
+				     (file-or-directory-modify-seconds src))])))
+			      (directory-list src))))
+		(k temp-dir))
+	      (lambda () (delete-directory/files temp-dir))))))
+
+  (define bundle-directory
+    (lambda (target dir [for-exe? #f])
+      (let ([target (add-suffix target (bundle-file-suffix))])
+	(case (system-type)
+	  [(macosx)
+	   (with-prepared-directory
+	    dir for-exe?
+	    (lambda (dir)
+	      (let* ([cout (open-output-bytes)]
+		     [cerr (open-output-bytes)]
+		     [cin (open-input-bytes #"")]
+		     [p (process*/ports
+			 cout cin cerr
+			 "/usr/bin/hdiutil"
+			 "create" "-format" "UDZO"
+			 "-imagekey" "zlib-level=9"
+			 "-mode" "555" 
+			 "-volname" (path->string
+				     (path-replace-suffix (file-name-from-path target) #""))
+			 "-srcfolder" (path->string (cleanse-path (path->complete-path dir)))
+			 (path->string (cleanse-path (path->complete-path target))))])
+		((list-ref p 4) 'wait)
+		(unless (eq? ((list-ref p 4) 'status) 'done-ok)
+		  (error 'bundle-directory
+			 "error bundling: ~a"
+			 (regexp-replace #rx"[\r\n]*$" (get-output-string cerr) ""))))))]
+	  [(windows unix)
+	   (let-values ([(base name dir?) (split-path (path->complete-path dir))])
+	     (parameterize ([current-directory base])
+	       ((if (eq? 'unix (system-type)) tar-gzip zip) target name)))]
+	  [else (error 'bundle-directory "don't know how")])))))

pkgs/compiler-lib/compiler/commands/decompile.rkt

@@ -0,0 +1,91 @@
+#lang racket/base
+(require racket/cmdline
+         raco/command-name
+         compiler/zo-parse
+         compiler/decompile
+         compiler/compilation-path
+         racket/pretty
+         racket/format)
+
+(define (get-name)
+  (string->symbol (short-program+command-name)))
+
+(define force? #f)
+
+(define source-files
+  (command-line
+   #:program (short-program+command-name)
+   #:once-each
+   [("--force") "Ignore timestamp mimatch on associated \".zo\""
+    (set! force? #t)]
+   [("--columns" "-n") n "Format for <n> columns"
+    (let ([num (string->number n)])
+      (unless (exact-positive-integer? num)
+        (raise-user-error (get-name)
+                          "not a valid column count: ~a" n))
+      (pretty-print-columns num))]
+   #:args source-or-bytecode-file
+   source-or-bytecode-file))
+
+(define (check-files orig-file alt-file)
+  (cond
+   [(not (file-exists? alt-file))
+    (cond
+     [(file-exists? orig-file)
+      (unless (is-bytecode-file? orig-file)
+        (raise-user-error (get-name)
+                          (~a "not a bytecode file, and no associated \".zo\" file;\n"
+                              " consider using `raco make` to compile the source file to bytecode\n"
+                              "  path: ~a\n"
+                              "  tried associated path: ~a")
+                          orig-file
+                          alt-file))]
+     [else
+      (raise-user-error (get-name)
+                        (~a "no such file, and no associated \".zo\" file\n"
+                            "  path: ~a\n"
+                            "  tried associated path: ~a")
+                        orig-file
+                        alt-file)])]
+   [(not (is-bytecode-file? alt-file))
+    (raise-user-error (get-name)
+                      (~a "associated \".zo\" file is not a bytecode file\n"
+                          "  original path: ~a\n"
+                          "  associated path: ~a")
+                      orig-file
+                      alt-file)]
+   [(and (not force?)
+         ((file-or-directory-modify-seconds orig-file
+                                            #f
+                                            (lambda () -inf.0))
+          . > .
+          (file-or-directory-modify-seconds alt-file)))
+    ;; return a warning:
+    (raise-user-error (get-name)
+                      (~a "associated \".zo\" file's date is older than given file's date;\n"
+                          " consider using `raco make` to rebuild the source file, or use `--force`\n"
+                          " to skip the date check\n"
+                          "  original path: ~a\n"
+                          "  associated path: ~a")
+                      orig-file
+                      alt-file)]))
+
+(define (is-bytecode-file? orig-file)
+  (call-with-input-file*
+   orig-file
+   (lambda (i)
+     (equal? #"#~" (read-bytes 2 i)))))
+
+(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 (get-compilation-bytecode-file zo-file)])
+        (check-files zo-file alt-file)
+        (parameterize ([current-load-relative-directory base]
+                       [print-graph #t])
+          (pretty-write
+           (decompile
+            (call-with-input-file*
+             (if (file-exists? alt-file) alt-file zo-file)
+             (lambda (in)
+               (zo-parse in))))))))))

pkgs/compiler-lib/compiler/commands/exe-dir.rkt

@@ -0,0 +1,33 @@
+#lang scheme/base
+(require scheme/cmdline
+         raco/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))
+
+(module test racket/base)

pkgs/compiler-lib/compiler/commands/exe.rkt

@@ -0,0 +1,155 @@
+#lang racket/base
+(require racket/cmdline
+         raco/command-name
+         compiler/private/embed
+         launcher/launcher
+         dynext/file
+         setup/dirs)
+
+(define verbose (make-parameter #f))
+(define very-verbose (make-parameter #f))
+
+(define gui (make-parameter #f))
+(define 3m (make-parameter #t))
+(define launcher (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-config-path (make-parameter "etc"))
+(define exe-embedded-collects-path (make-parameter null))
+(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") "Generate GUI executable"
+    (gui #t)]
+   [("-l" "--launcher") "Generate a launcher"
+    (when (or (find-addon-tethered-gui-bin-dir)
+              (find-addon-tethered-console-bin-dir))
+      ;; When an addon-executable directory is configured, treat the
+      ;; addon directory more like an installation directory, instead
+      ;; of a user-specific directory: record it, and remove the -U
+      ;; flag (if any)
+      (exe-embedded-flags
+       (append
+        (list "-A" (path->string (find-system-path 'addon-dir)))
+        (remove "-U" (exe-embedded-flags)))))
+    (launcher #t)]
+   [("--config-path") path "Set <path> as configuration directory for executable"
+    (exe-embedded-config-path path)]
+   [("--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 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
+   [("++aux") aux-file "Extra executable info (based on <aux-file> suffix)"
+    (let ([auxes (extract-aux-from-path (path->complete-path aux-file))])
+      (when (null? auxes)
+        (printf " warning: no recognized information from ~s\n" aux-file))
+      (exe-aux (append auxes (exe-aux))))]
+   [("++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))])
+  (unless (file-exists? source-file)
+    (raise-user-error (string->symbol (short-program+command-name))
+                      "source file does not exist\n  path: ~a" source-file))
+  (with-handlers ([exn:fail:filesystem? (lambda (exn) (void))])
+    (call-with-input-file* dest
+      (lambda (dest-in)
+        (call-with-input-file* source-file
+          (lambda (source-in)
+            (when (equal? (port-file-identity dest-in)
+                          (port-file-identity source-in))
+              (raise-user-error (string->symbol (short-program+command-name))
+                                (string-append
+                                 "source file is the same as the destination file"
+                                 "\n  source path: ~a"
+                                 "\n  destination path: ~a")
+                                source-file
+                                dest)))))))
+  (cond
+   [(launcher)
+    (parameterize ([current-launcher-variant (if (3m) '3m 'cgc)])
+      ((if (gui) 
+           make-gracket-launcher 
+           make-racket-launcher)
+       (append (list "-t" (path->string (path->complete-path source-file)))
+               (exe-embedded-flags))
+       dest
+       (exe-aux)))]
+   [else
+    (define mod-sym (string->symbol
+                     (format "#%mzc:~a"
+                             (let-values ([(base name dir?)
+                                           (split-path source-file)])
+                               (path->bytes (path-replace-suffix name #""))))))
+    (mzc:create-embedding-executable
+     dest
+     #:mred? (gui)
+     #:variant (if (3m) '3m 'cgc)
+     #:verbose? (very-verbose)
+     #:modules (cons `(#%mzc: (file ,source-file) (main configure-runtime))
+                     (map (lambda (l) `(#t (lib ,l)))
+                          (exe-embedded-libraries)))
+     #:configure-via-first-module? #t
+     #:early-literal-expressions
+     (parameterize ([current-namespace (make-base-namespace)])
+       (define cr-sym (string->symbol (format "~a(configure-runtime)" mod-sym)))
+       (list
+        (compile
+         `(when (module-declared? '',cr-sym)
+            (dynamic-require '',cr-sym #f)))))
+     #:literal-expression
+     (parameterize ([current-namespace (make-base-namespace)])
+       (define main-sym (string->symbol (format "~a(main)" mod-sym)))
+       (compile
+        `(begin
+           (namespace-require '',mod-sym)
+           (when (module-declared? '',main-sym)
+             (dynamic-require '',main-sym #f)))))
+     #:cmdline (exe-embedded-flags)
+     #:collects-path (exe-embedded-collects-path)
+     #:collects-dest (exe-embedded-collects-dest)
+     #:aux (cons `(config-dir . ,(exe-embedded-config-path))
+                 (exe-aux)))])
+  (when (verbose)
+    (printf " [output to \"~a\"]\n" dest)))
+
+(module test racket/base)

pkgs/compiler-lib/compiler/commands/expand.rkt

@@ -0,0 +1,42 @@
+#lang racket/base
+
+(module expand racket/base
+  (require racket/cmdline
+           raco/command-name
+           racket/pretty)
+  
+  (provide show-program)
+  
+  (define (show-program expand)
+    (define source-files
+      (command-line
+       #:program (short-program+command-name)
+       #:once-each
+       [("--columns" "-n") n "Format for <n> columns"
+        (let ([num (string->number n)])
+          (unless (exact-positive-integer? num)
+            (raise-user-error (string->symbol (short-program+command-name))
+                              "not a valid column count: ~a" n))
+          (pretty-print-columns num))]
+       #: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-write (syntax->datum (expand e)))
+                     (loop))))))))))))
+
+(require (submod "." expand))
+(show-program expand)
+  

pkgs/compiler-lib/compiler/commands/info.rkt

@@ -0,0 +1,15 @@
+#lang info
+
+(define raco-commands
+  '(("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" #f)
+    ("unpack" compiler/commands/unpack "unpack files/collections from a .plt archive" #f)
+    ("decompile" compiler/commands/decompile "decompile bytecode" #f)
+    ("test" compiler/commands/test "run tests associated with files/directories" 15)
+    ("expand" compiler/commands/expand "macro-expand source" #f)
+    ("read" compiler/commands/read "read and pretty-print source" #f)
+    ("distribute" compiler/commands/exe-dir "prepare executable(s) in a directory for distribution" #f)
+    ("demodularize" compiler/demodularizer/batch "produce a whole program from a single module" #f)))
+
+(define test-responsibles '(("test.rkt" jay)))

pkgs/compiler-lib/compiler/commands/make.rkt

@@ -0,0 +1,119 @@
+#lang racket/base
+(require racket/cmdline
+         raco/command-name
+         compiler/cm
+         compiler/compiler
+         compiler/compilation-path
+         dynext/file
+         setup/parallel-build
+         setup/path-to-relative
+         racket/match)
+
+(module test racket/base)
+
+(define verbose (make-parameter #f))
+(define very-verbose (make-parameter #f))
+(define disable-inlining (make-parameter #f))
+
+(define disable-deps (make-parameter #f))
+(define disable-const (make-parameter #f))
+(define prefixes (make-parameter null))
+(define assume-primitives (make-parameter #t))
+(define worker-count (make-parameter 1))
+
+(define mzc-symbol (string->symbol (short-program+command-name)))
+
+(define source-files
+  (command-line
+   #:program (short-program+command-name)
+   #:once-each
+   [("-j") n "Compile with up to <n> tasks in parallel" 
+    (let ([num (string->number n)])
+      (unless num (raise-user-error (format "~a: bad count for -j: ~s"
+                                            (short-program+command-name) 
+                                            n)))
+      (worker-count num))]
+   [("--disable-inline") "Disable procedure inlining during compilation"
+    (disable-inlining #t)]
+   [("--disable-constant") "Disable enforcement of module constants"
+    (disable-const #t)]
+   [("--no-deps") "Compile immediate files without updating dependencies"
+    (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 . another-file) (cons file another-file)))
+
+(cond 
+  ;; Just compile one file:
+  [(disable-deps)
+    (let ([prefix
+           `(begin
+              (require scheme)
+              ,(if (assume-primitives)
+                   '(void)
+                   '(namespace-require/copy 'scheme))
+              ,@(map (lambda (s) `(load ,s)) (prefixes))
+              (void))])
+      ((compile-zos prefix #:verbose? (verbose))
+       source-files
+       'auto))]
+  ;; Normal make:
+  [(= (worker-count) 1)
+    (let ([n (make-base-empty-namespace)]
+          [did-one? #f])
+      (parameterize ([current-namespace n]
+                     [manager-trace-handler
+                      (if (very-verbose)
+                          (λ (p) (printf "  ~a\n" p))
+                          (manager-trace-handler))]
+                     [manager-compile-notify-handler
+                      (lambda (p)
+                        (set! did-one? #t)
+                        (when (verbose)
+                          (printf "  making ~s\n" p)))])
+        (for ([file source-files])
+          (unless (file-exists? file)
+            (error mzc-symbol "file does not exist: ~a" file))
+          (set! did-one? #f)
+          (let ([name (extract-base-filename/ss file mzc-symbol)])
+            (when (verbose)
+              (printf "\"~a\":\n" file))
+            (parameterize ([compile-context-preservation-enabled
+                            (disable-inlining)]
+                           [compile-enforce-module-constants
+                            (not (disable-const))])
+              (managed-compile-zo file))
+            (when (verbose)
+              (printf " [~a \"~a\"]\n"
+                      (if did-one? "output to" "already up-to-date at")
+                      (get-compilation-bytecode-file file)))))))]
+  ;; Parallel make:
+  [else
+   (define path-cache (make-hash))
+   (or (parallel-compile-files
+        source-files
+        #:worker-count (worker-count)
+        #:handler (lambda (id type work msg out err)
+                    (define (->rel p)
+                      (path->relative-string/library p #:cache path-cache))
+                    (match type
+                      ['start (when (verbose) (printf " ~a making ~a\n" id (->rel work)))]
+                      ['done (when (verbose) (printf " ~a made ~a\n" id (->rel work)))]
+                      ['output (printf " ~a output from: ~a\n~a~a" id work out err)]
+                      [else (printf " ~a error compiling ~a\n~a\n~a~a" id work msg out err)]))
+        #:options (let ([cons-if-true (lambda (bool carv cdrv)
+                                        (if bool
+                                            (cons carv cdrv)
+                                            cdrv))])
+                    (cons-if-true
+                     (very-verbose)
+                     'very-verbose
+                     (cons-if-true (disable-inlining) 'disable-inlining null))))
+       (exit 1))])

pkgs/compiler-lib/compiler/commands/pack.rkt

@@ -0,0 +1,99 @@
+#lang scheme/base
+(require scheme/cmdline
+         raco/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 mzc-symbol (string->symbol (short-program+command-name)))
+
+(define-values (plt-output source-files)
+  (command-line
+   #:program (short-program+command-name)
+   #:once-each
+   [("--collect") "<path>s specify collections instead of files/dirs"
+    (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 . path)
+   (values dest-file path)))
+
+(if (not (collection?))
+    ;; Files and directories
+    (begin
+      (for ([fd source-files])
+        (unless (relative-path? fd)
+          (error mzc-symbol
+                 "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
+                null)
+      (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))))
+
+(module test racket/base)

pkgs/compiler-lib/compiler/commands/read.rkt

@@ -0,0 +1,4 @@
+#lang racket/base
+(require (submod "expand.rkt" expand))
+
+(show-program (lambda (e) e))

pkgs/compiler-lib/compiler/commands/unpack.rkt

@@ -0,0 +1,102 @@
+#lang scheme/base
+(require scheme/cmdline
+         raco/command-name
+         setup/unpack
+         racket/file
+         racket/port
+         racket/match
+         racket/string
+         racket/pretty)
+
+(define verbose (make-parameter #f))
+
+(define just-show? (make-parameter #f))
+(define replace? (make-parameter #f))
+(define show-config? (make-parameter #f))
+
+(define mzc-symbol (string->symbol (short-program+command-name)))
+
+(define files
+  (command-line
+   #:program (short-program+command-name)
+   #:once-each
+   [("-l" "--list") "just list archive content"
+    (just-show? #t)]
+   [("-c" "--config") "show archive configuration"
+    (show-config? #t)]
+   [("-f" "--force") "replace existing files when unpacking"
+    (replace? #t)]
+   #:args archive
+   archive))
+
+(define (desc->path dir)
+  (if (path? dir)
+      dir
+      (apply build-path
+             (symbol->string (car dir))
+             (cdr dir))))
+
+(for ([filename (in-list files)])
+  (fold-plt-archive filename 
+                    (lambda (config a)
+                      (when (show-config?)
+                        (match config
+                          [`(lambda (request failure) 
+                              (case request 
+                                ((name) ,name) 
+                                ((unpacker) (quote mzscheme)) 
+                                ((requires) (quote ,reqs)) 
+                                ((conflicts) (quote ,conflicts)) 
+                                ((plt-relative?) ,plt-rel?) 
+                                ((plt-home-relative?) ,plt-home-rel?) 
+                                ((test-plt-dirs) ,test-plt-dirs) 
+                                (else (failure))))
+                           (printf "config:\n")
+                           (printf " name: ~s\n" name)
+                           (printf " requires:\n")
+                           (for ([c (in-list reqs)])
+                             (printf "  ~s ~s\n" (string-join (car c) "/") (cadr c)))
+                           (printf " conflicts:\n")
+                           (for ([c (in-list conflicts)])
+                             (printf "  ~s\n" (string-join c "/")))
+                           (cond
+                            [plt-home-rel? (printf " unpack to main installation\n")]
+                            [plt-rel? (printf " unpack to user add-ons\n")]
+                            [else (printf " unpack locally\n")])]
+                          [else
+                           (printf "config function:\n")
+                           (pretty-write config)]))
+                      a)
+                    (lambda (setup i a)
+                      (when (show-config?)
+                        (match setup
+                          [`(unit (import main-collects-parent-dir mzuntar) (export) (mzuntar void) (quote ,c))
+                           (printf "setup collections:\n")
+                           (for ([c (in-list c)])
+                             (printf " ~s\n" (string-join c "/")))]
+                          [else
+                           (printf "setup unit:\n")
+                           (pretty-write setup)]))
+                      a)
+                    (lambda (dir a)
+                      (unless (eq? dir 'same)
+                        (if (just-show?)
+                            (printf "~a\n" (path->directory-path (desc->path dir)))
+                            (make-directory* (desc->path dir))))
+                      a)
+                    (lambda (file i kind a)
+                      (if (just-show?)
+                          (printf "~a~a\n" (desc->path file)
+                                  (if (eq? kind 'file-replace)
+                                      " [replace]"
+                                      ""))
+                          (call-with-output-file*
+                           (desc->path file)
+                           #:exists (if (or (eq? kind 'file-replace)
+                                            (replace?))
+                                        'truncate/replace
+                                        'error)
+                           (lambda (o)
+                             (copy-port i o))))
+                      a)
+                    (void)))

pkgs/compiler-lib/compiler/compiler-unit.rkt

@@ -0,0 +1,5 @@
+#lang racket/base
+
+(require compiler/compiler compiler/sig racket/unit)
+(provide compiler@)
+(define-unit-from-context compiler@ compiler^)

pkgs/compiler-lib/compiler/decompile.rkt

@@ -0,0 +1,606 @@
+#lang racket/base
+(require compiler/zo-parse
+         syntax/modcollapse
+         racket/port
+         racket/match
+         racket/list
+         racket/set
+         racket/path)
+
+(provide decompile)
+
+;; ----------------------------------------
+
+(define primitive-table
+  ;; Figure out number-to-id mapping for kernel functions in `primitive'
+  (let ([bindings
+         (let ([ns (make-base-empty-namespace)])
+           (parameterize ([current-namespace ns])
+             (namespace-require ''#%kernel)
+             (namespace-require ''#%unsafe)
+             (namespace-require ''#%flfxnum)
+             (namespace-require ''#%extfl)
+             (namespace-require ''#%futures)
+             (namespace-require ''#%foreign)
+             (for/list ([l (namespace-mapped-symbols)])
+               (cons l (with-handlers ([exn:fail? (lambda (x) #f)])
+                         (compile l))))))]
+        [table (make-hash)])
+    (for ([b (in-list bindings)])
+      (let ([v (and (cdr b)
+                    (zo-parse 
+                     (open-input-bytes
+                      (with-output-to-bytes
+                          (λ () (write (cdr b)))))))])
+        (let ([n (match v
+                   [(struct compilation-top (_ _ prefix (struct primval (n)))) n]
+                   [else #f])])
+          (hash-set! table n (car b)))))
+    table))
+
+(define (list-ref/protect l pos who)
+  (list-ref l pos)
+  #;
+  (if (pos . < . (length l))
+      (list-ref l pos)
+      `(OUT-OF-BOUNDS ,who ,pos ,(length l) ,l)))
+
+;; ----------------------------------------
+
+(define-struct glob-desc (vars num-tls num-stxs num-lifts))
+
+;; Main entry:
+(define (decompile top)
+  (let ([stx-ht (make-hasheq)])
+    (match top
+      [(struct compilation-top (max-let-depth binding-namess prefix form))
+       (let-values ([(globs defns) (decompile-prefix prefix stx-ht)])
+         (expose-module-path-indexes
+          `(begin
+            ,@defns
+            ,(decompile-form form globs '(#%globals) (make-hasheq) stx-ht))))]
+      [else (error 'decompile "unrecognized: ~e" top)])))
+
+(define (expose-module-path-indexes e)
+  ;; This is a nearly general replace-in-graph function. (It seems like a lot
+  ;; of work to expose module path index content and sharing, though.)
+  (define ht (make-hasheq))
+  (define mconses null)
+  (define (x-mcons a b)
+    (define m (mcons a b))
+    (set! mconses (cons (cons m (cons a b)) mconses))
+    m)
+  (define main
+    (let loop ([e e])
+      (cond
+       [(hash-ref ht e #f)]
+       [(module-path-index? e)
+        (define ph (make-placeholder #f))
+        (hash-set! ht e ph)
+        (define-values (name base) (module-path-index-split e))
+        (placeholder-set! ph (x-mcons '#%modidx
+                                      (x-mcons (loop name)
+                                               (x-mcons (loop base)
+                                                        null))))
+        ph]
+       [(pair? e)
+        (define ph (make-placeholder #f))
+        (hash-set! ht e ph)
+        (placeholder-set! ph (cons (loop (car e))
+                                   (loop (cdr e))))
+        ph]
+       [(mpair? e)
+        (define m (mcons #f #f))
+        (hash-set! ht e m)
+        (set! mconses (cons (cons m (cons (loop (mcar e))
+                                          (loop (mcdr e))))
+                            mconses))
+        m]
+       [(box? e)
+        (define ph (make-placeholder #f))
+        (hash-set! ht e ph)
+        (placeholder-set! ph (box (loop (unbox e))))
+        ph]
+       [(vector? e)
+        (define ph (make-placeholder #f))
+        (hash-set! ht e ph)
+        (placeholder-set! ph
+                          (for/vector #:length (vector-length e) ([i (in-vector e)])
+                                      (loop i)))
+        ph]
+       [(hash? e)
+        (define ph (make-placeholder #f))
+        (hash-set! ht e ph)
+        (placeholder-set! ph
+                          ((cond
+                            [(hash-eq? ht)
+                             make-hasheq-placeholder]
+                            [(hash-eqv? ht)
+                             make-hasheqv-placeholder]
+                            [else make-hash-placeholder])
+                           (for/list ([(k v) (in-hash e)])
+                             (cons (loop k) (loop v)))))
+        ph]
+       [(prefab-struct-key e)
+        => (lambda (k)
+             (define ph (make-placeholder #f))
+             (hash-set! ht e ph)
+             (placeholder-set! ph
+                               (apply make-prefab-struct
+                                      k
+                                      (map loop
+                                           (cdr (vector->list (struct->vector e))))))
+             ph)]
+       [else
+        e])))
+  (define l (make-reader-graph (cons main mconses)))
+  (for ([i (in-list (cdr l))])
+    (set-mcar! (car i) (cadr i))
+    (set-mcdr! (car i) (cddr i)))
+  (car l))
+
+(define (decompile-prefix a-prefix stx-ht)
+  (match a-prefix
+    [(struct prefix (num-lifts toplevels stxs src-insp-desc))
+     (let ([lift-ids (for/list ([i (in-range num-lifts)])
+                       (gensym 'lift))]
+           [stx-ids (map (lambda (i) (gensym 'stx)) 
+                         stxs)])
+       (values (glob-desc 
+                (append 
+                 (map (lambda (tl)
+                        (match tl
+                          [#f '#%linkage]
+                          [(? symbol?) (string->symbol (format "_~a" tl))]
+                          [(struct global-bucket (name)) 
+                           (string->symbol (format "_~a" name))]
+                          [(struct module-variable (modidx sym pos phase constantness))
+                           (if (and (module-path-index? modidx)
+                                    (let-values ([(n b) (module-path-index-split modidx)])
+                                      (and (not n) (not b))))
+                               (string->symbol (format "_~a" sym))
+                               (string->symbol (format "_~s~a@~s~a" 
+                                                       sym 
+                                                       (match constantness
+                                                         ['constant ":c"]
+                                                         ['fixed ":f"]
+                                                         [(function-shape a pm?) 
+                                                          (if pm? ":P" ":p")]
+                                                         [(struct-type-shape c) ":t"]
+                                                         [(constructor-shape a) ":mk"]
+                                                         [(predicate-shape) ":?"]
+                                                         [(accessor-shape c) ":ref"]
+                                                         [(mutator-shape c) ":set!"]
+                                                         [else ""])
+                                                       (mpi->string modidx) 
+                                                       (if (zero? phase)
+                                                           ""
+                                                           (format "/~a" phase)))))]
+                          [else (error 'decompile-prefix "bad toplevel: ~e" tl)]))
+                      toplevels)
+                 stx-ids
+                 (if (null? stx-ids) null '(#%stx-array))
+                 lift-ids)
+                (length toplevels)
+                (length stxs)
+                num-lifts)
+               (list*
+                `(quote inspector ,src-insp-desc)
+                ;; `(quote tls ,toplevels)
+                (map (lambda (stx id)
+                       `(define ,id ,(if stx
+                                         `(#%decode-syntax 
+                                           ,(decompile-stx (stx-content stx) stx-ht))
+                                         #f)))
+                     stxs stx-ids))))]
+    [else (error 'decompile-prefix "huh?: ~e" a-prefix)]))
+
+(define (decompile-stx stx stx-ht)
+  (or (hash-ref stx-ht stx #f)
+      (let ([p (mcons #f #f)])
+        (hash-set! stx-ht stx p)
+        (match stx
+          [(stx-obj datum wrap srcloc props tamper-status)
+           (set-mcar! p (case tamper-status
+                          [(clean) 'wrap]
+                          [(tainted) 'wrap-tainted]
+                          [(armed) 'wrap-armed]))
+           (set-mcdr! p (mcons
+                         (cond
+                          [(pair? datum) 
+                           (cons (decompile-stx (car datum) stx-ht)
+                                 (let loop ([l (cdr datum)])
+                                   (cond
+                                    [(null? l) null]
+                                    [(pair? l)
+                                     (cons (decompile-stx (car l) stx-ht)
+                                           (loop (cdr l)))]
+                                    [else
+                                     (decompile-stx l stx-ht)])))]
+                          [(vector? datum)
+                           (for/vector ([e (in-vector datum)])
+                             (decompile-stx e stx-ht))]
+                          [(box? datum)
+                           (box (decompile-stx (unbox datum) stx-ht))]
+                          [else datum])
+                         (let* ([l (mcons wrap null)]
+                                [l (if (hash-count props)
+                                       (mcons props l)
+                                       l)]
+                                [l (if srcloc
+                                       (mcons srcloc l)
+                                       l)])
+                           l)))
+           p]))))
+
+(define (mpi->string modidx)
+  (cond
+   [(symbol? modidx) modidx]
+   [else 
+    (collapse-module-path-index modidx)]))
+
+(define (decompile-module mod-form orig-stack stx-ht mod-name)
+  (match mod-form
+    [(struct mod (name srcname self-modidx
+                       prefix provides requires body syntax-bodies unexported 
+                       max-let-depth dummy lang-info 
+                       internal-context binding-names
+                       flags pre-submodules post-submodules))
+     (let-values ([(globs defns) (decompile-prefix prefix stx-ht)]
+                  [(stack) (append '(#%modvars) orig-stack)]
+                  [(closed) (make-hasheq)])
+       `(,mod-name ,(if (symbol? name) name (last name)) ....
+           (quote self ,self-modidx)
+           (quote internal-context 
+                  ,(if (stx? internal-context)
+                       `(#%decode-syntax 
+                         ,(decompile-stx (stx-content internal-context) stx-ht))
+                       internal-context))
+           (quote bindings ,(for/hash ([(phase ht) (in-hash binding-names)])
+                              (values phase
+                                      (for/hash ([(sym id) (in-hash ht)])
+                                        (values sym
+                                                (if (eq? id #t)
+                                                    #t
+                                                    `(#%decode-syntax 
+                                                      ,(decompile-stx (stx-content id) stx-ht))))))))
+           (quote language-info ,lang-info)
+           ,@(if (null? flags) '() (list `(quote ,flags)))
+           ,@(let ([l (apply
+                       append
+                       (for/list ([req (in-list requires)]
+                                  #:when (pair? (cdr req)))
+                         (define l (for/list ([mpi (in-list (cdr req))])
+                                     (define p (mpi->string mpi))
+                                     (if (path? p)
+                                         (let ([d (current-load-relative-directory)])
+                                           (path->string (if d
+                                                             (find-relative-path (simplify-path d #t)
+                                                                                 (simplify-path p #f) 
+                                                                                 #:more-than-root? #t)
+                                                             p)))
+                                         p)))
+                         (if (eq? 0 (car req))
+                             l
+                             `((,@(case (car req)
+                                    [(#f) `(for-label)]
+                                    [(1) `(for-syntax)]
+                                    [else `(for-meta ,(car req))])
+                                ,@l)))))])
+               (if (null? l)
+                   null
+                   `((require ,@l))))
+           (provide ,@(apply
+                       append
+                       (for/list ([p (in-list provides)])
+                         (define phase (car p))
+                         (define l
+                           (for/list ([pv (in-list (append (cadr p) (caddr p)))])
+                             (match pv
+                               [(struct provided (name src src-name nom-src src-phase protected?))
+                                (define n (if (eq? name src-name)
+                                              name
+                                              `(rename-out [,src-name ,name])))
+                                (if protected?
+                                    `(protect-out ,n)
+                                    n)])))
+                         (if (or (null? l) (eq? phase 0))
+                             l
+                             `((,@(case phase
+                                    [(#f) `(for-label)]
+                                    [(1) `(for-syntax)]
+                                    [else `(for-meta ,phase)])
+                                ,@l))))))
+          ,@defns
+          ,@(for/list ([submod (in-list pre-submodules)])
+              (decompile-module submod orig-stack stx-ht 'module))
+          ,@(for/list ([b (in-list syntax-bodies)])
+              (let loop ([n (sub1 (car b))])
+                (if (zero? n)
+                    (cons 'begin
+                          (for/list ([form (in-list (cdr b))])
+                            (decompile-form form globs stack closed stx-ht)))
+                    (list 'begin-for-syntax (loop (sub1 n))))))
+          ,@(map (lambda (form)
+                   (decompile-form form globs stack closed stx-ht))
+                 body)
+          ,@(for/list ([submod (in-list post-submodules)])
+              (decompile-module submod orig-stack stx-ht 'module*))))]
+    [else (error 'decompile-module "huh?: ~e" mod-form)]))
+
+(define (decompile-form form globs stack closed stx-ht)
+  (match form
+    [(? mod?)
+     (decompile-module form stack stx-ht 'module)]
+    [(struct def-values (ids rhs))
+     `(define-values ,(map (lambda (tl)
+                             (match tl
+                               [(struct toplevel (depth pos const? set-const?))
+                                (list-ref/protect (glob-desc-vars globs) pos 'def-vals)]))
+                           ids)
+        ,(if (inline-variant? rhs)
+             `(begin
+                ,(list 'quote '%%inline-variant%%)
+                ,(decompile-expr (inline-variant-inline rhs) globs stack closed)
+                ,(decompile-expr (inline-variant-direct rhs) globs stack closed))
+             (decompile-expr rhs globs stack closed)))]
+    [(struct def-syntaxes (ids rhs prefix max-let-depth dummy))
+     `(define-syntaxes ,ids
+        ,(let-values ([(globs defns) (decompile-prefix prefix stx-ht)])
+           `(let ()
+              ,@defns
+              ,(decompile-form rhs globs '(#%globals) closed stx-ht))))]
+    [(struct seq-for-syntax (exprs prefix max-let-depth dummy))
+     `(begin-for-syntax
+       ,(let-values ([(globs defns) (decompile-prefix prefix stx-ht)])
+          `(let ()
+             ,@defns
+             ,@(for/list ([rhs (in-list exprs)])
+                 (decompile-form rhs globs '(#%globals) closed stx-ht)))))]
+    [(struct seq (forms))
+     `(begin ,@(map (lambda (form)
+                      (decompile-form form globs stack closed stx-ht))
+                    forms))]
+    [(struct splice (forms))
+     `(begin ,@(map (lambda (form)
+                      (decompile-form form globs stack closed stx-ht))
+                    forms))]
+    [(struct req (reqs dummy))
+     `(#%require . (#%decode-syntax ,reqs))]
+    [else
+     (decompile-expr form globs stack closed)]))
+
+(define (extract-name name)
+  (if (symbol? name)
+      (gensym name)
+      (if (vector? name)
+          (gensym (vector-ref name 0))
+          #f)))
+
+(define (extract-id expr)
+  (match expr
+    [(struct lam (name flags num-params arg-types rest? closure-map closure-types tl-map max-let-depth body))
+     (extract-name name)]
+    [(struct case-lam (name lams))
+     (extract-name name)]
+    [(struct closure (lam gen-id))
+     (extract-id lam)]
+    [else #f]))
+
+(define (extract-ids! body ids)
+  (match body
+    [(struct let-rec (procs body))
+     (for ([proc (in-list procs)]
+           [delta (in-naturals)])
+       (when (< -1 delta (vector-length ids))
+         (vector-set! ids delta (extract-id proc))))
+     (extract-ids! body ids)]
+    [(struct install-value (val-count pos boxes? rhs body))
+     (extract-ids! body ids)]
+    [(struct boxenv (pos body))
+     (extract-ids! body ids)]
+    [else #f]))
+
+(define (decompile-tl expr globs stack closed no-check?)
+  (match expr
+    [(struct toplevel (depth pos const? ready?))
+     (let ([id (list-ref/protect (glob-desc-vars globs) pos 'toplevel)])
+       (cond
+        [no-check? id]
+        [(and (not const?) (not ready?))
+         `(#%checked ,id)]
+        #;[(and const? ready?) `(#%const ,id)]
+        #;[const? `(#%iconst ,id)]
+        [else id]))]))
+
+(define (decompile-expr expr globs stack closed)
+  (match expr
+    [(struct toplevel (depth pos const? ready?))
+     (decompile-tl expr globs stack closed #f)]
+    [(struct varref (tl dummy))
+     `(#%variable-reference ,(if (eq? tl #t)
+                                 '<constant-local>
+                                 (decompile-tl tl globs stack closed #t)))]
+    [(struct topsyntax (depth pos midpt))
+     (list-ref/protect (glob-desc-vars globs) (+ midpt pos) 'topsyntax)]
+    [(struct primval (id))
+     (hash-ref primitive-table id (lambda () (error "unknown primitive: " id)))]
+    [(struct assign (id rhs undef-ok?))
+     `(set! ,(decompile-expr id globs stack closed)
+            ,(decompile-expr rhs globs stack closed))]
+    [(struct localref (unbox? offset clear? other-clears? type))
+     (let ([id (list-ref/protect stack offset 'localref)])
+       (let ([e (if unbox?
+                    `(#%unbox ,id)
+                    id)])
+         (if clear?
+             `(#%sfs-clear ,e)
+             e)))]
+    [(? lam?)
+     `(lambda . ,(decompile-lam expr globs stack closed))]
+    [(struct case-lam (name lams))
+     `(case-lambda
+       ,@(map (lambda (lam)
+                (decompile-lam lam globs stack closed))
+              lams))]
+    [(struct let-one (rhs body type unused?))
+     (let ([id (or (extract-id rhs)
+                   (gensym (or type (if unused? 'unused 'local))))])
+       `(let ([,id ,(decompile-expr rhs globs (cons id stack) closed)])
+          ,(decompile-expr body globs (cons id stack) closed)))]
+    [(struct let-void (count boxes? body))
+     (let ([ids (make-vector count #f)])
+       (extract-ids! body ids)
+       (let ([vars (for/list ([i (in-range count)]
+                              [id (in-vector ids)])
+                     (or id (gensym (if boxes? 'localvb 'localv))))])
+         `(let ,(map (lambda (i) `[,i ,(if boxes? `(#%box ?) '?)])
+                     vars)
+            ,(decompile-expr body globs (append vars stack) closed))))]
+    [(struct let-rec (procs body))
+     `(begin
+        (#%set!-rec-values ,(for/list ([p (in-list procs)]
+                                       [i (in-naturals)])
+                              (list-ref/protect stack i 'let-rec))
+                           ,@(map (lambda (proc)
+                                    (decompile-expr proc globs stack closed))
+                                  procs))
+        ,(decompile-expr body globs stack closed))]
+    [(struct install-value (count pos boxes? rhs body))
+     `(begin
+        (,(if boxes? '#%set-boxes! 'set!-values)
+         ,(for/list ([i (in-range count)])
+            (list-ref/protect stack (+ i pos) 'install-value))
+         ,(decompile-expr rhs globs stack closed))
+        ,(decompile-expr body globs stack closed))]
+    [(struct boxenv (pos body))
+     (let ([id (list-ref/protect stack pos 'boxenv)])
+       `(begin
+          (set! ,id (#%box ,id))
+          ,(decompile-expr body globs stack closed)))]
+    [(struct branch (test then else))
+     `(if ,(decompile-expr test globs stack closed)
+          ,(decompile-expr then globs stack closed)
+          ,(decompile-expr else globs stack closed))]
+    [(struct application (rator rands))
+     (let ([stack (append (for/list ([i (in-list rands)]) (gensym 'rand))
+                          stack)])
+       (annotate-unboxed
+        rands
+        (annotate-inline
+         `(,(decompile-expr rator globs stack closed)
+           ,@(map (lambda (rand)
+                    (decompile-expr rand globs stack closed))
+                  rands)))))]
+    [(struct apply-values (proc args-expr))
+     `(#%apply-values ,(decompile-expr proc globs stack closed) 
+                      ,(decompile-expr args-expr globs stack closed))]
+    [(struct with-immed-mark (key-expr val-expr body-expr))
+     (let ([id (gensym 'cmval)])
+       `(#%call-with-immediate-continuation-mark
+         ,(decompile-expr key-expr globs stack closed)
+         (lambda (,id) ,(decompile-expr body-expr globs (cons id stack) closed))
+         ,(decompile-expr val-expr globs stack closed)))]
+    [(struct seq (exprs))
+     `(begin ,@(for/list ([expr (in-list exprs)])
+                 (decompile-expr expr globs stack closed)))]
+    [(struct beg0 (exprs))
+     `(begin0
+       ,@(for/list ([expr (in-list exprs)])
+           (decompile-expr expr globs stack closed))
+       ;; Make sure a single expression doesn't look like tail position:
+       ,@(if (null? (cdr exprs)) (list #f) null))]
+    [(struct with-cont-mark (key val body))
+     `(with-continuation-mark
+          ,(decompile-expr key globs stack closed)
+          ,(decompile-expr val globs stack closed)
+          ,(decompile-expr body globs stack closed))]
+    [(struct closure (lam gen-id))
+     (if (hash-ref closed gen-id #f)
+         gen-id
+         (begin
+           (hash-set! closed gen-id #t)
+           `(#%closed ,gen-id ,(decompile-expr lam globs stack closed))))]
+    [else `(quote ,expr)]))
+
+(define (decompile-lam expr globs stack closed)
+  (match expr
+    [(struct closure (lam gen-id)) (decompile-lam lam globs stack closed)]
+    [(struct lam (name flags num-params arg-types rest? closure-map closure-types tl-map max-let-depth body))
+     (let ([vars (for/list ([i (in-range num-params)]
+                            [type (in-list arg-types)])
+                   (gensym (format "~a~a-" 
+                                   (case type 
+                                     [(ref) "argbox"] 
+                                     [(val) "arg"]
+                                     [else (format "arg~a" type)])
+                                   i)))]
+           [rest-vars (if rest? (list (gensym 'rest)) null)]
+           [captures (map (lambda (v)
+                            (list-ref/protect stack v 'lam))
+                          (vector->list closure-map))])
+       `((,@vars . ,(if rest?
+                        (car rest-vars)
+                        null))
+         ,@(if (and name (not (null? name)))
+               `(',name)
+               null)
+         ,@(if (null? flags) null `('(flags: ,@flags)))
+         ,@(if (null? captures)
+               null
+               `('(captures: ,@(map (lambda (c t)
+                                      (if t
+                                          `(,t ,c)
+                                          c))
+                                    captures
+                                    closure-types)
+                             ,@(if (not tl-map)
+                                   '()
+                                   (list
+                                    (for/list ([pos (in-list (sort (set->list tl-map) <))])
+                                      (define tl-pos
+                                        (cond
+                                         [(or (pos . < . (glob-desc-num-tls globs))
+                                              (zero? (glob-desc-num-stxs globs)))
+                                          pos]
+                                         [(= pos (glob-desc-num-tls globs))
+                                          'stx]
+                                         [else
+                                          (+ pos (glob-desc-num-stxs globs))]))
+                                      (if (eq? tl-pos 'stx)
+                                          '#%syntax
+                                          (list-ref/protect (glob-desc-vars globs)
+                                                            tl-pos
+                                                            'lam))))))))
+         ,(decompile-expr body globs
+                          (append captures
+                                  (append vars rest-vars))
+                          closed)))]))
+
+(define (annotate-inline a)
+  a)
+
+(define (annotate-unboxed args a)
+  a)
+
+;; ----------------------------------------
+
+#;
+(begin
+  (require scheme/pretty)
+  (define (try e)
+    (pretty-print
+     (decompile
+      (zo-parse (let-values ([(in out) (make-pipe)])
+                  (write (parameterize ([current-namespace (make-base-namespace)])
+                           (compile e))
+                         out)
+                  (close-output-port out)
+                  in)))))
+  (pretty-print
+   (decompile
+    (zo-parse (open-input-file "/home/mflatt/proj/plt/collects/tests/mzscheme/benchmarks/common/sboyer_ss.zo"))))
+  #;
+  (try '(lambda (q . more)
+          (letrec ([f (lambda (x) f)])
+            (lambda (g) f)))))

pkgs/compiler-lib/compiler/demodularizer/alpha.rkt

@@ -0,0 +1,20 @@
+#lang racket/base
+
+(require racket/match racket/contract compiler/zo-parse)
+
+(define (alpha-vary-ctop top)
+  (match top
+    [(struct compilation-top (max-let-depth binding-namess prefix form))
+     (make-compilation-top max-let-depth binding-namess (alpha-vary-prefix prefix) form)]))
+(define (alpha-vary-prefix p)
+  (struct-copy prefix p
+               [toplevels
+                (map (match-lambda
+                       [(and sym (? symbol?))
+                        (gensym sym)]
+                       [other
+                        other])
+                     (prefix-toplevels p))]))
+
+(provide/contract
+ [alpha-vary-ctop (compilation-top? . -> . compilation-top?)])

pkgs/compiler-lib/compiler/demodularizer/batch.rkt

@@ -0,0 +1,63 @@
+#lang racket/base
+
+#|
+Here's the idea:
+
+- Take a module's bytecode
+- Recursively get all the bytecode for modules that the target requires
+- After reading it, prune everything that isn't at phase 0 (the runtime phase)
+
+- Now that we have all the modules, the next step is to merge them into a single
+  module
+-- Although actually we collapse them into the top-level, not a module
+- To do that, we iterate through all the modules doing two things as we go:
+-- Incrementing all the global variable references by all the references in all
+   the modules
+--- So if A has 5, then B's start at index 5 and so on
+-- Replacing module variable references with the actual global variables
+   corresponding to those variables
+--- So if A's variable 'x' is in global slot 4, then if B refers to it, it 
+    directly uses slot 4, rather than a module-variable slot
+
+- At that point we have all the module code in a single top-level, but many
+  toplevels won't be used because a library function isn't really used
+- So, we do a "garbage collection" on elements of the prefix
+- First, we create a dependency graph of all toplevels and the initial scope
+- Then, we do a DFS on the initial scope and keep all those toplevels, throwing
+  away the construction of everything else
+  [XXX: This may be broken because of side-effects.]
+
+- Now we have a small amount code, but because we want to go back to source,
+  we need to fix it up a bit; because different modules may've used the same
+  names
+- So, we do alpha-renaming, but it's easy because names are only used in the
+  compilation-top prefix structure
+
+[TODO]
+
+- Next, we decompile
+- Then, it will pay to do dead code elimination and inlining, etc.
+|#
+
+(require racket/cmdline
+         racket/set
+         raco/command-name
+         "main.rkt")
+
+
+(let ([output-file (make-parameter #f)])
+  (command-line #:program (short-program+command-name)
+                #:multi
+                [("-e" "--exclude-modules") path "Exclude <path> from flattening"
+                 (current-excluded-modules (set-add (current-excluded-modules) path))]
+                #:once-each
+                [("-o") dest-filename "Write output as <dest-filename>"
+                 (output-file (string->path dest-filename))]
+                [("-g" "--garbage-collect") "Garbage-collect final module (unsound)"
+                 (garbage-collect-toplevels-enabled #t)]                         
+                [("-r" "--recompile") "Recompile final module to re-run optimizations"
+                 (recompile-enabled #t)]                         
+                #:args (filename) 
+                (demodularize filename (output-file))))
+
+(module test racket/base)

pkgs/compiler-lib/compiler/demodularizer/gc-toplevels.rkt

@@ -0,0 +1,288 @@
+#lang racket/base
+
+(require racket/match
+         racket/list
+         racket/dict
+         racket/contract
+         compiler/zo-parse
+         "util.rkt")
+
+; XXX Use efficient set structure
+(define (gc-toplevels top)
+  (match top
+    [(struct compilation-top (max-let-depth binding-namess top-prefix form))
+     (define lift-start
+       (prefix-lift-start top-prefix))
+     (define max-depgraph-index 
+       (+ (prefix-num-lifts top-prefix)
+          lift-start))
+     (define top-node max-depgraph-index)
+     (define DEP-GRAPH (make-vector (add1 top-node) (make-refs empty empty)))
+     (define build-graph! (make-build-graph! DEP-GRAPH))
+     (define _void (build-graph! (list top-node) form))
+     (define-values (used-tls stxs) (graph-dfs DEP-GRAPH top-node))
+     (define ordered-used-tls (sort (rest used-tls) <=)) ; This rest drops off the top-node
+     (define ordered-stxs (sort stxs <=))
+     (define (lift? i) (lift-start . <= . i))
+     (define-values (lifts normal-tls) (partition lift? ordered-used-tls))
+     (define new-prefix
+       (make-prefix 
+        (length lifts)
+        (for/list ([i normal-tls])
+          (list-ref (prefix-toplevels top-prefix) i))
+        (for/list ([i ordered-stxs])
+          (list-ref (prefix-stxs top-prefix) i))))
+     (define new-lift-start
+       (prefix-lift-start new-prefix))
+     ; XXX This probably breaks max-let-depth
+     (define new-form
+       ((gc-toplevels-form 
+         (lambda (pos) (index<=? pos ordered-used-tls))
+         (lambda (pos)
+           (if (lift? pos)
+               (+ new-lift-start (index<=? pos lifts))
+               (index<=? pos normal-tls)))
+         (lambda (stx-pos)
+           (index<=? stx-pos ordered-stxs))
+         (prefix-syntax-start new-prefix))
+        form))
+     (log-debug (format "Total TLS: ~S" (length normal-tls)))
+     (log-debug (format "Used TLS: ~S" normal-tls))
+     (log-debug (format "Total lifts: ~S" (length lifts)))
+     (log-debug (format "Used lifts: ~S" lifts))
+     (log-debug (format "Total stxs: ~S" (length stxs)))
+     (log-debug (format "Used stxs: ~S" ordered-stxs))
+     (make-compilation-top
+      max-let-depth
+      #hash()
+      new-prefix
+      new-form)]))
+
+(define-struct refs (tl stx) #:transparent)
+
+(define (make-build-graph! DEP-GRAPH)
+  (define (build-graph!* form lhs)
+    (match form
+      [(struct def-values (ids rhs))
+       (define new-lhs (map toplevel-pos ids))
+       ; If we require one, we should require all, so make them reference each other
+       (for-each (lambda (tl) (build-graph! new-lhs tl)) ids)
+       (build-graph! new-lhs rhs)]
+      [(? def-syntaxes?)
+       (error 'build-graph "Doesn't handle syntax")]
+      [(? seq-for-syntax?)
+       (error 'build-graph "Doesn't handle syntax")]
+      [(struct inline-variant (direct inline))
+       (build-graph! lhs direct)]
+      [(struct req (reqs dummy))
+       (build-graph! lhs dummy)]
+      [(? mod?)
+       (error 'build-graph "Doesn't handle modules")]
+      [(struct seq (forms))
+       (for-each (lambda (f) (build-graph! lhs f)) forms)]
+      [(struct splice (forms))
+       (for-each (lambda (f) (build-graph! lhs f)) forms)]
+      [(and l (struct lam (name flags num-params param-types rest? closure-map closure-types tl-map max-let-depth body)))
+       (build-graph! lhs body)]
+      [(and c (struct closure (code gen-id)))
+       (build-graph! lhs code)]
+      [(and cl (struct case-lam (name clauses)))
+       (for-each (lambda (l) (build-graph! lhs l))
+                 clauses)]
+      [(struct let-one (rhs body flonum? unused?))
+       (build-graph! lhs rhs)
+       (build-graph! lhs body)]
+      [(and f (struct let-void (count boxes? body)))
+       (build-graph! lhs body)]
+      [(and f (struct install-value (_ _ _ rhs body)))
+       (build-graph! lhs rhs)
+       (build-graph! lhs body)]
+      [(struct let-rec (procs body))
+       (for-each (lambda (l) (build-graph! lhs l)) procs)
+       (build-graph! lhs body)]
+      [(and f (struct boxenv (_ body)))
+       (build-graph! lhs body)]
+      [(and f (struct toplevel (_ pos _ _)))
+       (for-each (lambda (lhs)
+                   (dict-update! DEP-GRAPH lhs
+                                 (match-lambda 
+                                   [(struct refs (tls stxs))
+                                    (make-refs (list* pos tls) stxs)])))
+                 lhs)]
+      [(and f (struct topsyntax (_ pos _)))
+       (for-each (lambda (lhs)
+                   (dict-update! DEP-GRAPH lhs
+                                 (match-lambda 
+                                   [(struct refs (tls stxs))
+                                    (make-refs tls (list* pos stxs))])))
+                 lhs)]
+      [(struct application (rator rands))
+       (for-each (lambda (f) (build-graph! lhs f))
+                 (list* rator rands))]
+      [(struct branch (test then else))
+       (for-each (lambda (f) (build-graph! lhs f))
+                 (list test then else))]
+      [(struct with-cont-mark (key val body))
+       (for-each (lambda (f) (build-graph! lhs f))
+                 (list key val body))]
+      [(struct with-immed-mark (key val body))
+       (for-each (lambda (f) (build-graph! lhs f))
+                 (list key val body))]
+      [(struct beg0 (seq))
+       (for-each (lambda (f) (build-graph! lhs f))
+                 seq)]
+      [(struct varref (tl dummy))
+       (build-graph! lhs tl)
+       (build-graph! lhs dummy)]
+      [(and f (struct assign (id rhs undef-ok?)))
+       (build-graph! lhs id)
+       (build-graph! lhs rhs)]
+      [(struct apply-values (proc args-expr))
+       (build-graph! lhs proc)
+       (build-graph! lhs args-expr)]
+      [(and f (struct primval (id)))
+       (void)]
+      [(and f (struct localref (unbox? pos clear? other-clears? type)))
+       (void)]
+      [(and v (not (? form?)))
+       (void)]))
+  (define-values (first-build-graph!** build-graph!**) 
+    (build-form-memo build-graph!* #:void? #t))
+  (define (build-graph! lhs form) (first-build-graph!** form lhs))
+  build-graph!)
+
+(define (graph-dfs g start-node)
+  (define visited? (make-hasheq))
+  (define (visit-tl n tls stxs)
+    (if (hash-has-key? visited? n)
+        (values tls stxs)
+        (match (dict-ref g n)
+          [(struct refs (n-tls n-stxs))
+           (hash-set! visited? n #t)
+           (define-values (new-tls1 new-stxs1)
+             (for/fold ([new-tls tls]
+                        [new-stxs stxs])
+                       ([tl (in-list n-tls)])
+               (visit-tl tl new-tls new-stxs)))
+           (define new-stxs2
+             (for/fold ([new-stxs new-stxs1])
+                       ([stx (in-list n-stxs)])
+               (define this-stx (visit-stx stx))
+               (if this-stx
+                   (list* this-stx new-stxs)
+                   new-stxs)))
+           (values (list* n new-tls1)
+                   new-stxs2)])))
+  (define stx-visited? (make-hasheq))
+  (define (visit-stx n)
+    (if (hash-has-key? stx-visited? n)
+        #f
+        (begin (hash-set! stx-visited? n #t)
+               n)))
+  (visit-tl start-node empty empty))
+
+; index<=? : number? (listof number?) -> (or/c number? false/c)
+; returns the index of n in l and assumes that l is sorted by <=
+(define (index<=? n l)
+  (match l
+    [(list) #f]
+    [(list-rest f l)
+     (cond
+       [(= n f)
+        0]
+       [(< n f)
+        #f]
+       [else
+        (let ([rec (index<=? n l)])
+          (if rec (add1 rec) rec))])]))
+
+(define (identity x) x)
+(define (gc-toplevels-form keep? update-tl update-ts new-ts-midpt)
+  (define (inner-update form)
+    (match form
+      [(struct def-values (ids rhs))
+       (if (ormap (compose keep? toplevel-pos) ids)
+           (make-def-values (map update ids)
+                            (update rhs))
+           #f)]
+      [(? def-syntaxes?)
+       (error 'gc-tls "Doesn't handle syntax")]
+      [(? seq-for-syntax?)
+       (error 'gc-tls "Doesn't handle syntax")]
+      [(struct req (reqs dummy))
+       (make-req reqs (update dummy))]
+      [(? mod?)
+       (error 'gc-tls "Doesn't handle modules")]
+      [(struct seq (forms))
+       (make-seq (filter identity (map update forms)))]
+      [(struct splice (forms))
+       (make-splice (filter identity (map update forms)))]
+      [(and l (struct lam (name flags num-params param-types rest? closure-map closure-types tl-map max-let-depth body)))
+       (struct-copy lam l
+                    [toplevel-map #f] ; consevrative
+                    [body (update body)])]
+      [(and c (struct closure (code gen-id)))
+       (struct-copy closure c
+                    [code (update code)])]
+      [(and cl (struct case-lam (name clauses)))
+       (struct-copy case-lam cl
+                    [clauses (map update clauses)])]
+      [(struct let-one (rhs body type unused?))
+       (make-let-one (update rhs) (update body) type unused?)]
+      [(and f (struct let-void (count boxes? body)))
+       (struct-copy let-void f
+                    [body (update body)])]
+      [(and f (struct install-value (_ _ _ rhs body)))
+       (struct-copy install-value f
+                    [rhs (update rhs)]
+                    [body (update body)])]
+      [(struct let-rec (procs body))
+       (make-let-rec (map update procs) (update body))]
+      [(and f (struct boxenv (_ body)))
+       (struct-copy boxenv f [body (update body)])]
+      [(and f (struct toplevel (_ pos _ _)))
+       (struct-copy toplevel f
+                    [pos (update-tl pos)])]
+      [(and f (struct topsyntax (_ pos _)))
+       (struct-copy topsyntax f
+                    [pos (update-ts pos)]
+                    [midpt new-ts-midpt])]
+      [(struct application (rator rands))
+       (make-application 
+        (update rator)
+        (map update rands))]
+      [(struct branch (test then else))
+       (make-branch 
+        (update test)
+        (update then)
+        (update else))]
+      [(struct with-cont-mark (key val body))
+       (make-with-cont-mark 
+        (update key)
+        (update val)
+        (update body))]
+      [(struct beg0 (seq))
+       (make-beg0 (map update seq))]
+      [(struct varref (tl dummy))
+       (make-varref (update tl) (update dummy))]
+      [(and f (struct assign (id rhs undef-ok?)))
+       (struct-copy assign f
+                    [id (update id)]
+                    [rhs (update rhs)])]
+      [(struct apply-values (proc args-expr))
+       (make-apply-values
+        (update proc)
+        (update args-expr))]
+      [(and f (struct primval (id)))
+       f]
+      [(and f (struct localref (unbox? pos clear? other-clears? type)))
+       f]
+      [(and v (not (? form?)))
+       v]
+      ))
+  (define-values (first-update update)
+    (build-form-memo inner-update))
+  first-update)
+
+(provide/contract
+ [gc-toplevels (compilation-top? . -> . compilation-top?)])

pkgs/compiler-lib/compiler/demodularizer/info.rkt

@@ -0,0 +1,3 @@
+#lang info
+
+(define test-responsibles '((all jay)))

pkgs/compiler-lib/compiler/demodularizer/main.rkt

@@ -0,0 +1,91 @@
+#lang racket/base
+(require compiler/cm
+         compiler/zo-marshal
+         "alpha.rkt"
+         "gc-toplevels.rkt"
+         "merge.rkt"
+         "module.rkt"
+         "mpi.rkt"
+         "nodep.rkt"
+         "replace-modidx.rkt")
+
+(provide current-excluded-modules
+         garbage-collect-toplevels-enabled
+         recompile-enabled
+         demodularize)
+
+(define garbage-collect-toplevels-enabled (make-parameter #f))
+(define recompile-enabled (make-parameter #f))
+
+(define logger (make-logger 'demodularizer (current-logger)))
+
+(define (demodularize file-to-batch [output-file #f])
+  (parameterize ([current-logger logger])
+    (define-values (base name must-be-dir?) (split-path file-to-batch))
+    (when must-be-dir?
+      (error 'demodularize "Cannot run on directory: ~a" file-to-batch))
+    (unless (file-exists? file-to-batch)
+      (error 'demodularize "File does not exist: ~a" file-to-batch))
+    
+    ;; Compile
+    (log-info "Compiling module")
+    (parameterize ([current-namespace (make-base-empty-namespace)])
+      (managed-compile-zo file-to-batch))
+    
+    (define merged-zo-path 
+      (or output-file
+          (path-add-suffix file-to-batch #"_merged.zo")))
+    
+    ;; Transformations
+    (define path-cache (make-hasheq))
+    
+    (log-info "Removing dependencies")
+    (define-values (batch-nodep top-lang-info top-self-modidx get-modvar-rewrite)
+      (parameterize ([MODULE-PATHS path-cache])
+        (nodep-file file-to-batch)))
+    
+    (log-info "Merging modules")
+    (define batch-merge
+      (parameterize ([MODULE-PATHS path-cache])
+        (merge-compilation-top get-modvar-rewrite batch-nodep)))
+    
+    (define batch-gcd
+      (if (garbage-collect-toplevels-enabled)
+          (begin
+            (log-info "GC-ing top-levels")
+            (gc-toplevels batch-merge))
+          batch-merge))
+    
+    (log-info "Alpha-varying top-levels")
+    (define batch-alpha
+      (alpha-vary-ctop batch-gcd))
+    
+    (log-info "Replacing self-modidx")
+    (define batch-replace-modidx
+      (replace-modidx batch-alpha top-self-modidx))
+    
+    (define batch-modname
+      (string->symbol (regexp-replace #rx"\\.zo$" (path->string merged-zo-path) "")))
+    (log-info (format "Modularizing into ~a" batch-modname))
+    (define batch-mod
+      (wrap-in-kernel-module batch-modname batch-modname top-lang-info top-self-modidx batch-replace-modidx))
+    
+    (log-info "Writing merged zo")
+    (void
+     (with-output-to-file 
+         merged-zo-path
+       (lambda ()
+         (zo-marshal-to batch-mod (current-output-port)))
+       #:exists 'replace))
+  
+    (void
+      (when (recompile-enabled)
+        (define recomp
+          (compiled-expression-recompile 
+            (parameterize ([read-accept-compiled #t])
+              (call-with-input-file merged-zo-path read))))
+        (call-with-output-file merged-zo-path
+          (lambda (out)
+            (write recomp out))
+          #:exists 'replace)))))
+

pkgs/compiler-lib/compiler/demodularizer/merge.rkt

@@ -0,0 +1,229 @@
+#lang racket/base
+
+(require racket/list
+         racket/match
+         racket/contract
+         compiler/zo-parse
+         "util.rkt"
+         "mpi.rkt"
+         "nodep.rkt"
+         "update-toplevels.rkt")
+
+(define MODULE-TOPLEVEL-OFFSETS (make-hasheq))
+
+(define current-get-modvar-rewrite (make-parameter #f))
+(define (merge-compilation-top get-modvar-rewrite top)
+  (parameterize ([current-get-modvar-rewrite get-modvar-rewrite])
+    (match top
+      [(struct compilation-top (max-let-depth binding-namess prefix form))
+       (define-values (new-max-let-depth new-prefix gen-new-forms)
+         (merge-form max-let-depth prefix form))
+       (define total-tls (length (prefix-toplevels new-prefix)))
+       (define total-stxs (length (prefix-stxs new-prefix)))
+       (define total-lifts (prefix-num-lifts new-prefix))
+       (log-debug (format "max-let-depth ~S to ~S" max-let-depth new-max-let-depth))
+       (log-debug (format "total toplevels ~S" total-tls))
+       (log-debug (format "total stxs ~S" total-stxs))
+       (log-debug (format "num-lifts ~S" total-lifts))
+       (for ([i (in-naturals)]
+             [p (in-list (prefix-toplevels new-prefix))])
+         (log-debug (format "new-prefix tls\t~v ~v" i p)))
+       (make-compilation-top
+        new-max-let-depth #hash() new-prefix
+        (make-splice (gen-new-forms new-prefix)))]
+      [else (error 'merge "unrecognized: ~e" top)])))
+
+(define (merge-forms max-let-depth prefix forms)
+  (if (empty? forms)
+      (values max-let-depth prefix (lambda _ empty))
+      (let*-values ([(fmax-let-depth fprefix gen-fform) (merge-form max-let-depth prefix (first forms))]
+                    [(rmax-let-depth rprefix gen-rforms) (merge-forms fmax-let-depth fprefix (rest forms))])
+        (values rmax-let-depth
+                rprefix
+                (lambda args
+                  (append (apply gen-fform args)
+                          (apply gen-rforms args)))))))
+
+(define (merge-form max-let-depth prefix form)
+  (match form
+    [(? mod?)
+     (merge-module max-let-depth prefix form)]
+    [(struct seq (forms))
+     (merge-forms max-let-depth prefix forms)]
+    [(struct splice (forms))
+     (merge-forms max-let-depth prefix forms)]
+    [else
+     (values max-let-depth prefix (lambda _ (list form)))]))
+
+(define (index-of v l)
+  (for/or ([e (in-list l)]
+           [i (in-naturals)]
+           #:when (eq? e v))
+    i))
+
+(define (merge-prefix root-prefix mod-prefix)
+  (match-define (struct prefix (root-num-lifts root-toplevels root-stxs root-src-insp-desc)) root-prefix)
+  (match-define (struct prefix (mod-num-lifts mod-toplevels mod-stxs src-insp-desc)) mod-prefix)
+  (make-prefix (+ root-num-lifts mod-num-lifts)
+               (append root-toplevels mod-toplevels)
+               (append root-stxs mod-stxs)
+               root-src-insp-desc))
+
+(struct toplevel-offset-rewriter (rewrite-fun meta) #:transparent)
+
+(define (compute-new-modvar mv rw)
+  (match mv
+    [(struct module-variable (modidx sym pos phase constantness))
+     (match rw
+       [(struct modvar-rewrite (self-modidx provide->toplevel))
+        (log-debug (format "Rewriting ~a@~a of ~S" sym pos (mpi->path* modidx)))
+        (define tl (provide->toplevel sym pos))
+        (log-debug (format "Rewriting ~a@~a of ~S to ~S" sym pos (mpi->path* modidx) tl))
+        (match-define (toplevel-offset-rewriter rewrite-fun meta)
+          (hash-ref MODULE-TOPLEVEL-OFFSETS self-modidx
+                    (lambda ()
+                      (error 'compute-new-modvar "toplevel offset not yet computed: ~S" self-modidx))))
+        (log-debug (format "Rewriting ~a@~a of ~S (which is ~a) with ~S" sym pos (mpi->path* modidx) tl meta))
+        (define res (rewrite-fun tl))
+        (log-debug (format "Rewriting ~a@~a of ~S (which is ~a) with ~S and got ~S"
+                           sym pos (mpi->path* modidx) tl meta res))
+        res])]))
+
+(define (filter-rewritable-module-variable? name new-#f-idx toplevel-offset mod-toplevels)
+  (define-values
+    (i new-toplevels remap)
+    (for/fold ([i 0]
+               [new-toplevels empty]
+               [remap empty])
+              ([tl (in-list mod-toplevels)]
+               [idx (in-naturals)])
+      (log-debug (format "[~S] mod-prefix tls\t~v ~v"
+                         name idx tl))
+      (match tl
+        [(and mv (struct module-variable (modidx sym pos phase constantness)))
+         (define rw ((current-get-modvar-rewrite) modidx))
+         ;; XXX We probably don't need to deal with #f phase
+         (unless (or (not phase) (zero? phase))
+           (error 'eliminate-module-variables "Non-zero phases not supported: ~S" mv))
+         (cond
+           ; Primitive module like #%paramz
+           [(symbol? rw)
+            (log-debug (format "~S from ~S" sym rw))
+            (values (add1 i)
+                    (list* tl new-toplevels)
+                    (list* (+ i toplevel-offset) remap))]
+           [(module-path-index? rw)
+            (values (add1 i)
+                    (list* tl new-toplevels)
+                    (list* (+ i toplevel-offset) remap))]
+           [(modvar-rewrite? rw)
+            (values i
+                    new-toplevels
+                    (list* (compute-new-modvar mv rw) remap))]
+           [else
+            (error 'filter-rewritable-module-variable? "Unsupported module-rewrite: ~S" rw)])]
+        [tl
+         (cond
+           [(and new-#f-idx (not tl))
+            (log-debug (format "[~S] dropping a #f at ~v that would have been at ~v but is now at ~v"
+                               name idx (+ i toplevel-offset) new-#f-idx))
+            (values i
+                    new-toplevels
+                    (list* new-#f-idx remap))]
+           [else
+            (values (add1 i)
+                    (list* tl new-toplevels)
+                    (list* (+ i toplevel-offset) remap))])])))
+  ; XXX This would be more efficient as a vector
+  (values (reverse new-toplevels)
+          (reverse remap)))
+
+(define (merge-module max-let-depth top-prefix mod-form)
+  (match mod-form
+    [(struct mod (name srcname self-modidx
+                       mod-prefix provides requires body syntax-bodies
+                       unexported mod-max-let-depth dummy lang-info
+                       internal-context binding-names
+                       flags pre-submodules post-submodules))
+     (define top-toplevels (prefix-toplevels top-prefix))
+     (define toplevel-offset (length top-toplevels))
+     (define topsyntax-offset (length (prefix-stxs top-prefix)))
+     (define lift-offset (prefix-num-lifts top-prefix))
+     (define mod-toplevels (prefix-toplevels mod-prefix))
+     (define new-#f-idx
+       (index-of #f top-toplevels))
+     (when new-#f-idx
+       (log-debug (format "[~S] found a #f entry in prefix already at ~v, squashing"
+                          name new-#f-idx)))
+     (define-values (new-mod-toplevels toplevel-remap)
+       (filter-rewritable-module-variable? name new-#f-idx toplevel-offset mod-toplevels))
+     (define num-mod-toplevels
+       (length toplevel-remap))
+     (define mod-stxs
+       (length (prefix-stxs mod-prefix)))
+     (define mod-num-lifts
+       (prefix-num-lifts mod-prefix))
+     (define new-mod-prefix
+       (struct-copy prefix mod-prefix
+                    [toplevels new-mod-toplevels]))
+     (define offset-meta (vector name srcname self-modidx))
+     (log-debug "Setting toplevel offsets rewriter for ~S and it is currently ~S"
+                offset-meta
+                (hash-ref MODULE-TOPLEVEL-OFFSETS self-modidx #f))
+     (hash-set! MODULE-TOPLEVEL-OFFSETS self-modidx
+                (toplevel-offset-rewriter
+                 (lambda (n)
+                   (log-debug "Finding offset ~a in ~S of ~S" n toplevel-remap offset-meta)
+                   (list-ref toplevel-remap n))
+                 offset-meta))
+     (unless (= (length toplevel-remap)
+                (length mod-toplevels))
+       (error 'merge-module "Not remapping everything: ~S ~S"
+              mod-toplevels toplevel-remap))
+     (log-debug (format "[~S] Incrementing toplevels by ~a"
+                        name
+                        toplevel-offset))
+     (log-debug (format "[~S] Incrementing lifts by ~a"
+                        name
+                        lift-offset))
+     (log-debug (format "[~S] Filtered mod-vars from ~a to ~a"
+                        name
+                        (length mod-toplevels)
+                        (length new-mod-toplevels)))
+     (values (max max-let-depth mod-max-let-depth)
+             (merge-prefix top-prefix new-mod-prefix)
+             (lambda (top-prefix)
+               (log-debug (format "[~S] Updating top-levels" name))
+               (define top-lift-start (prefix-lift-start top-prefix))
+               (define mod-lift-start (prefix-lift-start mod-prefix))
+               (define total-lifts (prefix-num-lifts top-prefix))
+               (define max-toplevel (+ top-lift-start total-lifts))
+               (define update
+                 (update-toplevels
+                  (lambda (n)
+                    (define new-idx
+                      (cond
+                        [(mod-lift-start . <= . n)
+                         (log-debug (format "[~S] ~v is a lift"
+                                            name n))
+                         (define which-lift (- n mod-lift-start))
+                         (define lift-tl (+ top-lift-start lift-offset which-lift))
+                         (when (lift-tl . >= . max-toplevel)
+                           (error 'merge-module "[~S] lift error: orig(~a) which(~a) max(~a) lifts(~a) now(~a)"
+                                  name n which-lift num-mod-toplevels mod-num-lifts lift-tl))
+                         lift-tl]
+                        [else
+                         ;; xxx maybe change this to a vector after it is made to make this efficient
+                         (list-ref toplevel-remap n)]))
+                    (log-debug (format "[~S] ~v is remapped to ~v"
+                                       name n new-idx))
+                    new-idx)
+                  (lambda (n)
+                    (+ n topsyntax-offset))
+                  (prefix-syntax-start top-prefix)))
+               (map update body)))]))
+
+(provide/contract
+ [merge-compilation-top (-> get-modvar-rewrite/c
+                            compilation-top?
+                            compilation-top?)])

pkgs/compiler-lib/compiler/demodularizer/module.rkt

@@ -0,0 +1,43 @@
+#lang racket/base
+
+(require racket/list
+         racket/match
+         racket/contract
+         compiler/zo-parse
+         "util.rkt")
+
+(define (->module-path-index s)
+  (if (module-path-index? s)
+      s
+      (module-path-index-join `(quote ,s) #f)))
+
+(define (wrap-in-kernel-module name srcname lang-info self-modidx top)
+  (match top
+    [(struct compilation-top (max-let-depth binding-namess prefix form))
+     (define-values (reqs new-forms)
+       (partition req? (splice-forms form)))
+     (define requires
+       (map (compose ->module-path-index stx-obj-datum stx-content req-reqs) reqs))
+     (make-compilation-top 
+      0
+      #hash()
+      (make-prefix 0 (list #f) empty (prefix-src-inspector-desc prefix))
+      (make-mod name srcname
+                self-modidx
+                prefix
+                empty ; provides
+                (list (cons 0 requires))
+                new-forms
+                empty ; syntax-body
+                (list) ; unexported
+                max-let-depth
+                (make-toplevel 0 0 #f #f) ; dummy
+                lang-info
+                #t
+                (hash) ; no names visible via `module->namespace`
+                empty
+                empty
+                empty))]))
+
+(provide/contract
+ [wrap-in-kernel-module (symbol? symbol? lang-info/c module-path-index? compilation-top? . -> . compilation-top?)])

pkgs/compiler-lib/compiler/demodularizer/mpi.rkt

@@ -0,0 +1,41 @@
+#lang racket/base
+
+(require racket/contract
+         syntax/modresolve)
+
+(define current-module-path (make-parameter #f))
+
+(define (mpi->string modidx)
+  (cond
+    [(symbol? modidx) modidx]
+    [else 
+     (mpi->path! modidx)]))
+
+(define MODULE-PATHS (make-parameter #f))
+(define (mpi->path! mpi)
+  (hash-ref! 
+   (MODULE-PATHS) mpi 
+   (lambda ()
+     (define _pth
+       (resolve-module-path-index mpi (current-module-path)))
+     (cond
+      [(path? _pth) (simplify-path _pth #t)]
+      [(and (pair? _pth)
+            (path? (cadr _pth)))
+       (list* 'submod (simplify-path (cadr _pth) #t) (cddr _pth))]
+      [else _pth]))))
+(define (mpi->path* mpi)
+  (hash-ref (MODULE-PATHS) mpi 
+            (lambda ()
+              (error 'mpi->path* "Cannot locate cache of path for ~S" mpi))))
+
+(define submod-path/c
+  (cons/c 'submod
+          (cons/c (or/c symbol? path?)
+                  (listof symbol?))))
+
+(provide/contract
+ [MODULE-PATHS (parameter/c (or/c false/c hash?))]
+ [current-module-path (parameter/c (or/c path-string? submod-path/c))]
+ [mpi->path! (module-path-index? . -> . (or/c symbol? path? submod-path/c))]
+ [mpi->path* (module-path-index? . -> . (or/c symbol? path? pair? submod-path/c))])

pkgs/compiler-lib/compiler/demodularizer/nodep.rkt

@@ -0,0 +1,228 @@
+#lang racket/base
+
+(require racket/list
+         racket/match
+         racket/contract
+         compiler/zo-parse
+         "util.rkt"
+         "mpi.rkt"
+         racket/set)
+
+(define current-excluded-modules (make-parameter (set)))
+
+(define ZOS (make-parameter #f))
+(define MODULE-IDX-MAP (make-parameter #f))
+(define PHASE*MODULE-CACHE (make-parameter #f))
+
+(define (nodep-file file-to-batch)
+  (define idx-map (make-hash))
+  (parameterize ([ZOS (make-hash)]
+                 [MODULE-IDX-MAP idx-map]
+                 [PHASE*MODULE-CACHE (make-hasheq)])
+    (define (get-modvar-rewrite modidx)
+      (define pth (mpi->path* modidx))
+      (hash-ref idx-map pth
+                (lambda ()
+                  (error 'get-modvar-rewrite "Cannot locate modvar rewrite for ~S" pth))))
+    (match (get-nodep-module-code/path file-to-batch 0)
+      [(struct @phase (_ (struct module-code (modvar-rewrite lang-info ctop))))
+       (values ctop lang-info (modvar-rewrite-modidx modvar-rewrite) get-modvar-rewrite)])))
+
+(define (path->comp-top pth submod)
+  (hash-ref! (ZOS) (cons pth submod)
+             (λ ()
+                (define zo (call-with-input-file pth zo-parse))
+                (if submod
+                    (extract-submod zo submod)
+                    zo))))
+
+(define (extract-submod zo submod)
+  (define m (compilation-top-code zo))
+  (struct-copy compilation-top
+               zo
+               [code (let loop ([m m])
+                       (if (and (pair? (mod-name m))
+                                (equal? submod (cdr (mod-name m))))
+                           m
+                           (or (ormap loop (mod-pre-submodules m))
+                               (ormap loop (mod-post-submodules m)))))]))
+
+(define (excluded? pth)
+  (and (path? pth)
+       (set-member? (current-excluded-modules) (path->string pth))))
+
+(define (get-nodep-module-code/index mpi phase)
+  (define pth (mpi->path! mpi))
+  (cond
+    [(symbol? pth)
+     (hash-set! (MODULE-IDX-MAP) pth pth)
+     pth]
+    [(excluded? pth)
+     (hash-set! (MODULE-IDX-MAP) pth mpi)
+     mpi]
+    [else
+     (get-nodep-module-code/path pth phase)]))
+
+(define-struct @phase (phase code))
+(define-struct modvar-rewrite (modidx provide->toplevel))
+(define-struct module-code (modvar-rewrite lang-info ctop))
+(define @phase-ctop (compose module-code-ctop @phase-code))
+
+(define (get-nodep-module-code/path pth phase)
+  (define MODULE-CACHE
+    (hash-ref! (PHASE*MODULE-CACHE) phase make-hash))
+  (if (hash-ref MODULE-CACHE pth #f)
+      #f
+      (hash-ref! 
+       MODULE-CACHE pth 
+       (lambda ()
+         (define-values (base file dir?) (split-path (if (path-string? pth)
+                                                         pth
+                                                         (cadr pth))))
+         (define base-directory
+           (if (path? base) 
+               (path->complete-path base (current-directory))
+               (current-directory)))
+         (define-values (modvar-rewrite lang-info ctop)
+           (begin
+             (log-debug (format "Load ~S @ ~S" pth phase))
+             (nodep/dir
+              (parameterize ([current-load-relative-directory base-directory])
+                (path->comp-top
+                 (build-compiled-path 
+                  base 
+                  (path-add-suffix file #".zo"))
+                 (and (pair? pth) (cddr pth))))
+              pth
+              phase)))
+         (when (and phase (zero? phase))
+           (hash-set! (MODULE-IDX-MAP) pth modvar-rewrite))
+         (make-@phase 
+          phase
+          (make-module-code modvar-rewrite lang-info ctop))))))
+
+(define (nodep/dir top pth phase)
+  (define pth*
+    (cond 
+      [(string? pth) (string->path pth)]
+      [(list? pth) (cadr pth)]
+      [else pth]))
+  (parameterize ([current-module-path pth*])
+    (nodep top phase)))
+
+(define (nodep top phase)
+  (match top
+    [(struct compilation-top (max-let-depth binding-namess prefix form))
+     (define-values (modvar-rewrite lang-info new-form) (nodep-form form phase))
+     (values modvar-rewrite lang-info (make-compilation-top max-let-depth #hash() prefix new-form))]
+    [else (error 'nodep "unrecognized: ~e" top)]))
+
+(define (nodep-form form phase)
+  (if (mod? form)
+      (let-values ([(modvar-rewrite lang-info mods)
+                    (nodep-module form phase)])
+        (values modvar-rewrite lang-info (make-splice mods)))
+      (error 'nodep-form "Doesn't support non mod forms")))
+
+; XXX interning is hack to fix test/add04.ss and provide/contract renaming
+(define (intern s) (string->symbol (symbol->string s)))
+(define (construct-provide->toplevel prefix provides)
+  (define provide-ht (make-hasheq))
+  (for ([tl (prefix-toplevels prefix)]
+        [i (in-naturals)])
+      (when (symbol? tl)
+        (hash-set! provide-ht (intern tl) i)))  
+  (lambda (sym pos)
+    (define isym (intern sym))
+    (log-debug (format "Looking up ~S@~a [~S] in ~S" sym pos isym prefix))
+    (define res
+      (hash-ref provide-ht isym
+              (lambda ()
+                (error 'provide->toplevel "Cannot find ~S in ~S" sym prefix))))
+    (log-debug (format "Looked up ~S@~a and got ~v" sym pos res))
+    res))
+
+(define (nodep-module mod-form phase)
+  (match mod-form
+    [(struct mod (name srcname self-modidx
+                       prefix provides requires body syntax-bodies
+                       unexported max-let-depth dummy lang-info
+                       internal-context binding-names
+                       flags pre-submodules post-submodules))
+     (define new-prefix prefix)
+     ;; Cache all the mpi paths
+     (for-each (match-lambda
+                 [(and mv (struct module-variable (modidx sym pos phase constantness)))
+                  (mpi->path! modidx)]
+                 [tl
+                  (void)])
+               (prefix-toplevels new-prefix))
+     (define mvs (filter module-variable? (prefix-toplevels new-prefix)))
+     (log-debug (format "[~S] module-variables: ~S - ~S" name (length mvs) mvs))
+     (values (make-modvar-rewrite self-modidx (construct-provide->toplevel new-prefix provides))
+             lang-info
+             (append (requires->modlist requires phase)
+                     (if (and phase (zero? phase))
+                         (begin (log-debug (format "[~S] lang-info : ~S" name lang-info)) ; XXX Seems to always be #f now
+                                (list (make-mod name srcname self-modidx
+                                                new-prefix provides requires body empty
+                                                unexported max-let-depth dummy lang-info internal-context #hash()
+                                                empty empty empty)))
+                         (begin (log-debug (format "[~S] Dropping module @ ~S" name phase))
+                                empty))))]              
+    [else (error 'nodep-module "huh?: ~e" mod-form)]))
+
+(define (+* l r)
+  (if (and l r) (+ l r) #f))
+
+(define (requires->modlist requires current-phase)
+  (apply append
+         (map
+          (match-lambda
+            [(list-rest req-phase mpis)
+             (define phase (+* current-phase req-phase))
+             (apply append
+                    (map (compose extract-modules (lambda (mpi) (get-nodep-module-code/index mpi phase))) mpis))])
+          requires)))
+
+(define (all-but-last l)
+  (reverse (rest (reverse l))))
+
+(define REQUIRED (make-hasheq))
+(define (extract-modules ct)
+  (cond
+    [(compilation-top? ct)
+     (match (compilation-top-code ct)
+       [(and m (? mod?))
+        (list m)]
+       [(struct splice (mods))
+        mods])]
+    [(symbol? ct)
+     (if (hash-has-key? REQUIRED ct)
+         empty
+         (begin
+           (hash-set! REQUIRED ct #t)
+           (list (make-req (make-stx (make-stx-obj ct (wrap empty empty empty) #f #hasheq() 'clean)) (make-toplevel 0 0 #f #f)))))]
+    [(module-path-index? ct)
+     (if (hash-has-key? REQUIRED ct)
+         empty
+         (begin
+           (hash-set! REQUIRED ct #t)
+           (list (make-req (make-stx (make-stx-obj ct (wrap empty empty empty) #f #hasheq() 'clean)) (make-toplevel 0 0 #f #f)))))]
+    [(not ct)
+     empty]
+    [(@phase? ct)
+     (extract-modules (@phase-ctop ct))]
+    [else
+     (error 'extract-modules "Unknown extraction: ~S" ct)]))
+
+(define get-modvar-rewrite/c 
+  (module-path-index? . -> . (or/c symbol? modvar-rewrite? module-path-index?)))
+(provide/contract
+ [struct modvar-rewrite 
+         ([modidx module-path-index?]
+          [provide->toplevel (symbol? exact-nonnegative-integer? . -> . exact-nonnegative-integer?)])]
+ [get-modvar-rewrite/c contract?]
+ [current-excluded-modules (parameter/c generic-set?)]
+ [nodep-file (-> path-string?
+                 (values compilation-top? lang-info/c module-path-index? get-modvar-rewrite/c))])

pkgs/compiler-lib/compiler/demodularizer/replace-modidx.rkt

@@ -0,0 +1,29 @@
+#lang racket/base
+
+(require racket/match
+         racket/vector
+         racket/struct
+         "util.rkt")
+
+(provide replace-modidx)
+
+(define (replace-modidx expr self-modidx)
+  (define (inner-update e)
+      (match e
+        [(app prefab-struct-key (and key (not #f))) 
+         (apply make-prefab-struct key 
+                (map update
+                     (struct->list e)))]
+        [(? module-path-index?) 
+         (define-values (path mpi) (module-path-index-split e))
+         (if (not path)
+             self-modidx
+             (module-path-index-join path (update mpi)))]
+        [(cons a b)
+         (cons (update a) (update b))]
+        [(? vector?)
+         (vector-map update e)]
+        [else e]))
+  (define-values (first-update update)
+    (build-form-memo inner-update))
+  (first-update expr))

pkgs/compiler-lib/compiler/demodularizer/update-toplevels.rkt

@@ -0,0 +1,108 @@
+#lang racket/base
+
+(require racket/match
+         racket/contract
+         compiler/zo-structs
+         "util.rkt")
+
+(define (update-toplevels toplevel-updater topsyntax-updater topsyntax-new-midpt)
+  (define (inner-update form)
+    (match form
+      [(struct def-values (ids rhs))
+       (make-def-values (map update ids)
+                        (update rhs))]
+      [(? def-syntaxes?)
+       (error 'increment "Doesn't handle syntax")]
+      [(? seq-for-syntax?)
+       (error 'increment "Doesn't handle syntax")]
+      [(struct inline-variant (direct inline))
+       (update direct)]
+      [(struct req (reqs dummy))
+       (make-req reqs (update dummy))]
+      [(? mod?)
+       (error 'increment "Doesn't handle modules")]
+      [(struct seq (forms))
+       (make-seq (map update forms))]
+      [(struct splice (forms))
+       (make-splice (map update forms))]
+      [(and l (struct lam (name flags num-params param-types rest? closure-map closure-types tl-map max-let-depth body)))
+       (struct-copy lam l
+                    [toplevel-map #f] ; conservative
+                    [body (update body)])]
+      [(and c (struct closure (code gen-id)))
+       (struct-copy closure c
+                    [code (update code)])]
+      [(and cl (struct case-lam (name clauses)))
+       (define new-clauses
+         (map update clauses))
+       (struct-copy case-lam cl
+                    [clauses new-clauses])]
+      [(struct let-one (rhs body type unused?))
+       (make-let-one (update rhs) (update body) type unused?)]
+      [(and f (struct let-void (count boxes? body)))
+       (struct-copy let-void f
+                    [body (update body)])]
+      [(and f (struct install-value (_ _ _ rhs body)))
+       (struct-copy install-value f
+                    [rhs (update rhs)]
+                    [body (update body)])]
+      [(struct let-rec (procs body))
+       (make-let-rec (map update procs) (update body))]
+      [(and f (struct boxenv (_ body)))
+       (struct-copy boxenv f [body (update body)])]
+      [(and f (struct toplevel (_ pos _ _)))
+       (struct-copy toplevel f
+                    [pos (toplevel-updater pos)])]
+      [(and f (struct topsyntax (_ pos _)))
+       (struct-copy topsyntax f
+                    [pos (topsyntax-updater pos)]
+                    [midpt topsyntax-new-midpt])]
+      [(struct application (rator rands))
+       (make-application 
+        (update rator)
+        (map update rands))]
+      [(struct branch (test then else))
+       (make-branch 
+        (update test)
+        (update then)
+        (update else))]
+      [(struct with-cont-mark (key val body))
+       (make-with-cont-mark 
+        (update key)
+        (update val)
+        (update body))]
+      [(struct with-immed-mark (key val body))
+       (make-with-immed-mark 
+        (update key)
+        (update val)
+        (update body))]
+      [(struct beg0 (seq))
+       (make-beg0 (map update seq))]
+      [(struct varref (tl dummy))
+       (make-varref (update tl) (update dummy))]
+      [(and f (struct assign (id rhs undef-ok?)))
+       (struct-copy assign f
+                    [id (update id)]
+                    [rhs (update rhs)])]
+      [(struct apply-values (proc args-expr))
+       (make-apply-values
+        (update proc)
+        (update args-expr))]
+      [(and f (struct primval (id)))
+       f]
+      [(and f (struct localref (unbox? pos clear? other-clears? type)))
+       f]
+      [(and f (not (? form?)))
+       f]
+      ))
+  (define-values (first-update update)
+    (build-form-memo inner-update))
+  first-update)
+
+(provide/contract
+ [update-toplevels 
+  ((exact-nonnegative-integer? . -> . exact-nonnegative-integer?)
+   (exact-nonnegative-integer? . -> . exact-nonnegative-integer?)
+   exact-nonnegative-integer?
+   . -> .
+   (form? . -> . form?))])

pkgs/compiler-lib/compiler/demodularizer/util.rkt

@@ -0,0 +1,79 @@
+#lang racket/base
+
+(require racket/contract
+         compiler/zo-parse)
+
+(define (prefix-syntax-start pre)
+  (length (prefix-toplevels pre)))
+
+(define (prefix-lift-start pre)
+  (define syntax-start (prefix-syntax-start pre))
+  (define total-stxs (length (prefix-stxs pre)))
+  (+ syntax-start total-stxs (if (zero? total-stxs) 0 1)))
+
+(struct nothing ())
+
+(define-syntax-rule (eprintf* . args) (void))
+
+(define (build-form-memo inner-update #:void? [void? #f])
+  (define memo (make-hasheq))
+  (define (update form . args)
+    (eprintf* "Updating on ~a\n" form)
+    (define fin
+      (cond
+        [(hash-ref memo form #f) 
+         => (λ (x)
+              (eprintf* "Found in memo table\n")
+              x)]
+        [else
+         (eprintf* "Not in memo table\n")
+         (let ()
+           (define ph (make-placeholder (nothing)))
+           (hash-set! memo form ph)
+           (define nv (nothing))
+           (dynamic-wind void
+                         (λ ()
+                           (set! nv (apply inner-update form args)))
+                         (λ ()
+                           (if (nothing? nv)
+                               (eprintf* "inner-update returned nothing (or there was an escape) on ~a\n" form)
+                               (begin
+                                 (placeholder-set! ph nv)
+                                 (hash-set! memo form nv)))))
+           nv)]))
+    (eprintf* "Updating on ~a ---->\n ~a\n" form fin)
+    fin)
+  (define (first-update form . args)
+    (eprintf* "Top level update on ~a\n" form)
+    (define final (apply update form args))
+    (eprintf* "Top level update on ~a ---->\n ~a\n" form final)
+    (define fin (make-reader-graph final))
+    (eprintf* "Top level update on ~a ---->\n ~a [after reader-graph]\n" form fin)
+    fin)
+  (values first-update update))
+
+(define lang-info/c
+  (or/c #f (vector/c module-path? symbol? any/c)))
+
+
+(define (build-compiled-path base name)
+  (build-path 
+   (cond [(path? base) base]
+	 [(eq? base 'relative) 'same]
+	 [(eq? base #f) (error 'batch "Impossible")])
+   "compiled"
+   name))
+
+
+(provide/contract
+ [prefix-syntax-start (prefix? . -> . exact-nonnegative-integer?)]
+ [prefix-lift-start (prefix? . -> . exact-nonnegative-integer?)]
+ [eprintf ((string?) () #:rest (listof any/c) . ->* . void)]
+ [build-form-memo 
+  (((unconstrained-domain-> any/c))
+   (#:void? boolean?)
+   . ->* .
+   (values (unconstrained-domain-> any/c)
+           (unconstrained-domain-> any/c)))]
+ [lang-info/c contract?]
+ [build-compiled-path ((or/c path-string? (symbols 'relative) false/c) path-string? . -> . (or/c path-string? (symbols 'same 'up)))])

pkgs/compiler-lib/compiler/embed-sig.rkt

@@ -0,0 +1,13 @@
+
+(module embed-sig racket/base
+  (require racket/unit)
+  (provide compiler:embed^)
+
+  (define-signature compiler:embed^
+    (create-embedding-executable
+     make-embedding-executable
+     write-module-bundle
+     embedding-executable-is-directory?
+     embedding-executable-is-actually-directory?
+     embedding-executable-put-file-extension+style+filters
+     embedding-executable-add-suffix)))

pkgs/compiler-lib/compiler/embed-unit.rkt

@@ -0,0 +1,9 @@
+#lang racket/base
+(require racket/unit
+         racket/contract
+	 "sig.rkt"
+	 compiler/embed 
+	 "embed-sig.rkt")
+
+(define-unit-from-context compiler:embed@ compiler:embed^)
+(provide compiler:embed@)

pkgs/compiler-lib/compiler/option-unit.rkt

@@ -0,0 +1,7 @@
+#lang racket/base
+
+(require racket/unit compiler/sig compiler/option)
+
+(provide compiler:option@)
+
+(define-unit-from-context compiler:option@ compiler:option^)

pkgs/compiler-lib/compiler/sig.rkt

@@ -0,0 +1,39 @@
+#lang racket/base
+
+(require racket/unit)
+
+(provide compiler:option^
+         compiler^)
+
+;; Compiler options
+(define-signature compiler:option^
+  (somewhat-verbose ; default = #f
+   verbose ; default = #f
+   
+
+   setup-prefix ; string to embed in public names;
+                ; used mainly for compiling extensions
+                ;  with the collection name so that 
+                ;  cross-extension conflicts are less
+                ;  likely in architectures that expose
+                ;  the public names of loaded extensions
+                ; default = ""
+
+   3m ; #t => build for 3m
+      ; default = #f
+
+   compile-subcollections   ; #t => compile collection subdirectories
+                            ; default = #t
+
+   ))
+
+;; Compiler procedures
+(define-signature compiler^
+  (compile-zos
+
+   compile-collection-zos
+   compile-directory-zos
+   compile-directory-srcs
+
+   current-compiler-dynamic-require-wrapper
+   compile-notify-handler))

pkgs/compiler-lib/info.rkt

@@ -0,0 +1,16 @@
+#lang info
+
+(define collection 'multi)
+
+(define deps '(["base" #:version "6.5.0.2"]
+               "scheme-lib"
+               "rackunit-lib"
+               "zo-lib"))
+
+(define implies '("zo-lib"))
+
+(define pkg-desc "implementation (no documentation) part of \"compiler\"")
+
+(define pkg-authors '(mflatt))
+
+(define version "1.4")

pkgs/compiler-lib/launcher/launcher-sig.rkt

@@ -0,0 +1,57 @@
+#lang racket/signature
+
+make-gracket-launcher
+make-racket-launcher
+make-mred-launcher
+make-mzscheme-launcher
+
+make-gracket-program-launcher
+make-racket-program-launcher
+make-mred-program-launcher
+make-mzscheme-program-launcher
+
+gracket-program-launcher-path
+racket-program-launcher-path
+mred-program-launcher-path
+mzscheme-program-launcher-path
+
+install-gracket-program-launcher
+install-racket-program-launcher
+install-mred-program-launcher
+install-mzscheme-program-launcher
+
+gracket-launcher-up-to-date?
+racket-launcher-up-to-date?
+mred-launcher-up-to-date?
+mzscheme-launcher-up-to-date?
+
+gracket-launcher-is-directory?
+racket-launcher-is-directory?
+mred-launcher-is-directory?
+mzscheme-launcher-is-directory?
+
+gracket-launcher-is-actually-directory?
+racket-launcher-is-actually-directory?
+mred-launcher-is-actually-directory?
+mzscheme-launcher-is-actually-directory?
+
+gracket-launcher-add-suffix
+racket-launcher-add-suffix
+mred-launcher-add-suffix
+mzscheme-launcher-add-suffix
+
+gracket-launcher-put-file-extension+style+filters
+racket-launcher-put-file-extension+style+filters
+mred-launcher-put-file-extension+style+filters
+mzscheme-launcher-put-file-extension+style+filters
+
+build-aux-from-path
+extract-aux-from-path
+current-launcher-variant
+available-mred-variants
+available-mzscheme-variants
+available-gracket-variants
+available-racket-variants
+
+installed-executable-path->desktop-path
+installed-desktop-path->icon-path

pkgs/compiler-lib/launcher/launcher-unit.rkt

@@ -0,0 +1,7 @@
+#lang racket/base
+
+(require racket/unit "launcher-sig.rkt" launcher/launcher)
+
+(provide launcher@)
+
+(define-unit-from-context launcher@ launcher^)

pkgs/compiler-lib/setup/option-sig.rkt

@@ -0,0 +1,37 @@
+(module option-sig racket/base
+  (require racket/unit)
+  
+  (provide setup-option^)
+
+  (define-signature setup-option^
+    (setup-program-name
+     verbose
+     make-verbose
+     compiler-verbose
+     clean
+     compile-mode
+     make-only
+     make-zo
+     make-info-domain
+     make-foreign-libs
+     make-launchers
+     make-docs
+     make-user
+     make-planet
+     avoid-main-installation
+     make-tidy
+     make-doc-index
+     check-dependencies
+     fix-dependencies
+     call-install
+     call-post-install
+     pause-on-errors
+     parallel-workers
+     force-unpacks
+     doc-pdf-dest
+     specific-collections
+     specific-planet-dirs
+     archives
+     archive-implies-reindex
+     current-target-directory-getter
+     current-target-plt-directory-getter)))

pkgs/compiler-lib/setup/option-unit.rkt

@@ -0,0 +1,6 @@
+#lang racket/base
+(require racket/unit setup/option "option-sig.rkt")
+
+(provide setup:option@ set-flag-params)
+
+(define-unit-from-context setup:option@ setup-option^)

pkgs/compiler-lib/setup/setup-unit.rkt

@@ -0,0 +1,9 @@
+#lang racket/base
+
+(require racket/unit setup/setup-core)
+
+(provide setup@)
+(define-unit setup@
+  (import)
+  (export)
+  (setup-core))

pkgs/compiler-test/LICENSE.txt

@@ -0,0 +1,11 @@
+compiler-test
+Copyright (c) 2010-2017 PLT Design Inc.
+
+This package is distributed under the GNU Lesser General Public
+License (LGPL).  This means that you can link this package into proprietary
+applications, provided you follow the rules stated in the LGPL.  You
+can also modify this package; if you distribute a modified version,
+you must distribute it under the terms of the LGPL, which in
+particular means that you must release the source code for the
+modified software.  See http://www.gnu.org/copyleft/lesser.html
+for more information.

pkgs/compiler-test/info.rkt

@@ -0,0 +1,20 @@
+#lang info
+
+(define collection 'multi)
+
+(define deps '("base"))
+
+(define pkg-desc "tests for \"compiler-lib\"")
+
+(define pkg-authors '(mflatt))
+(define build-deps '("compiler-lib"
+                     "eli-tester"
+                     "rackunit-lib"
+                     "net-lib"
+                     "scheme-lib"
+                     "compatibility-lib"
+                     "gui-lib"
+                     "htdp-lib"
+                     "plai-lib"
+                     "rackunit-lib"))
+(define update-implies '("compiler-lib"))

pkgs/compiler-test/tests/compiler/collection-zos.rkt

@@ -0,0 +1,5 @@
+#lang racket
+(require compiler/compiler)
+
+;; minimal sanity check:
+(compile-collection-zos "setup")

pkgs/compiler-test/tests/compiler/commands/test.rkt

@@ -0,0 +1,5 @@
+#lang racket
+(require rackunit)
+(require (only-in (submod compiler/commands/test paths) collection-paths))
+
+(check-exn exn? (lambda () (collection-paths ".")))

pkgs/compiler-test/tests/compiler/ctool.rkt

@@ -0,0 +1,19 @@
+#lang racket
+(require setup/dirs)
+
+(define raco (build-path (find-console-bin-dir)
+                         (if (eq? (system-type) 'windows)
+                             "raco.exe"
+                             "raco")))
+
+(define tmp (make-temporary-file))
+
+(system* raco
+         "ctool"
+         "--3m"
+         "--c-mods"
+         tmp
+         "++lib"
+         "racket")
+
+(delete-file tmp)

pkgs/compiler-test/tests/compiler/demodularizer/demod-test.rkt

@@ -0,0 +1,53 @@
+#lang racket
+(require tests/eli-tester
+         racket/runtime-path
+         compiler/find-exe)
+
+(define (capture-output command . args)
+  (define o (open-output-string))
+  (define e (open-output-string))
+  (parameterize ([current-input-port (open-input-string "")]
+                 [current-output-port o]
+                 [current-error-port e])
+    (apply system* command args))
+  (values (get-output-string o) (get-output-string e)))
+
+(define (test-on-program filename)
+  ;; run modular program, capture output
+  (define-values (modular-output modular-error)
+    (capture-output (find-exe) filename))
+  
+  (define demod-filename 
+    (let-values ([(base filename dir?) (split-path filename)])
+      (path->string
+       (build-path
+        (find-system-path 'temp-dir)
+        (path-add-suffix filename #"_merged.zo")))))
+  
+  ;; demodularize
+  (parameterize ([current-input-port (open-input-string "")])
+    (system* (find-exe) "-l-" "raco" "demod" "-o" demod-filename filename))
+  
+  ;; run whole program
+  (define-values (whole-output whole-error)
+    (capture-output (find-exe) demod-filename))
+  
+  ;; compare output 
+  (test
+   #:failure-prefix (format "~a stdout" filename)
+   whole-output => modular-output
+   #:failure-prefix (format "~a stderr" filename)
+   whole-error => modular-error))
+
+(define-runtime-path tests "tests")
+
+(define (modular-program? filename)
+  (and (not (regexp-match #rx"merged" filename))
+       (regexp-match #rx"rkt$" filename)))
+
+(test
+ (for ([i (in-list (directory-list tests))])
+   (define ip (build-path tests i))
+   (when (modular-program? ip)
+     (printf "Checking ~a\n" ip)
+     (test-on-program (path->string ip)))))

pkgs/compiler-test/tests/compiler/demodularizer/info.rkt

@@ -0,0 +1,3 @@
+#lang info
+
+(define test-timeouts '(("demod-test.rkt" 300)))

pkgs/compiler-test/tests/compiler/demodularizer/tests/base-5.rkt

@@ -0,0 +1,2 @@
+#lang racket/base
+5

pkgs/compiler-test/tests/compiler/demodularizer/tests/kernel-5.rkt

@@ -0,0 +1,5 @@
+(module kernel-5 '#%kernel
+  (#%require racket/private/map)
+  (define-values (id) (λ (x) x))
+  (define-values (xs) (list 1 2 3 4 5))
+  (map id (map id xs)))

pkgs/compiler-test/tests/compiler/demodularizer/tests/racket-5.rkt

@@ -0,0 +1,2 @@
+#lang racket
+5

pkgs/compiler-test/tests/compiler/embed/embed-asl.rkt

@@ -0,0 +1,4 @@
+;; The first three lines of this file were inserted by DrRacket. They record metadata
+;; about the language level of this file in a form that our tools can easily process.
+#reader(lib "htdp-advanced-reader.ss" "lang")((modname ex) (read-case-sensitive #t) (teachpacks ()) (htdp-settings #(#t constructor repeating-decimal #f #t none #f ())))
+10

pkgs/compiler-test/tests/compiler/embed/embed-bsl.rkt

@@ -0,0 +1,4 @@
+;; The first three lines of this file were inserted by DrRacket. They record metadata
+;; about the language level of this file in a form that our tools can easily process.
+#reader(lib "htdp-beginner-reader.ss" "lang")((modname ex) (read-case-sensitive #t) (teachpacks ()) (htdp-settings #(#t constructor repeating-decimal #f #t none #f ())))
+10

pkgs/compiler-test/tests/compiler/embed/embed-bsla.rkt

@@ -0,0 +1,4 @@
+;; The first three lines of this file were inserted by DrRacket. They record metadata
+;; about the language level of this file in a form that our tools can easily process.
+#reader(lib "htdp-beginner-abbr-reader.ss" "lang")((modname ex) (read-case-sensitive #t) (teachpacks ()) (htdp-settings #(#t constructor repeating-decimal #f #t none #f ())))
+10

pkgs/compiler-test/tests/compiler/embed/embed-isl.rkt

@@ -0,0 +1,4 @@
+;; The first three lines of this file were inserted by DrRacket. They record metadata
+;; about the language level of this file in a form that our tools can easily process.
+#reader(lib "htdp-intermediate-reader.ss" "lang")((modname ex) (read-case-sensitive #t) (teachpacks ()) (htdp-settings #(#t constructor repeating-decimal #f #t none #f ())))
+10

pkgs/compiler-test/tests/compiler/embed/embed-isll.rkt

@@ -0,0 +1,4 @@
+;; The first three lines of this file were inserted by DrRacket. They record metadata
+;; about the language level of this file in a form that our tools can easily process.
+#reader(lib "htdp-intermediate-lambda-reader.ss" "lang")((modname ex) (read-case-sensitive #t) (teachpacks ()) (htdp-settings #(#t constructor repeating-decimal #f #t none #f ())))
+10

pkgs/compiler-test/tests/compiler/embed/embed-me1.rkt

@@ -0,0 +1,5 @@
+(module embed-me1 mzscheme
+  (with-output-to-file (build-path (find-system-path 'temp-dir) "stdout")
+    (lambda () (printf "This is 1\n"))
+    'append))
+

pkgs/compiler-test/tests/compiler/embed/embed-me10.rkt

@@ -0,0 +1,9 @@
+(module embed-me10 mzscheme
+  (require openssl/mzssl)
+
+  (with-output-to-file (build-path (find-system-path 'temp-dir) "stdout")
+    (lambda () 
+      (printf "~a\n" ssl-available?))
+    'append))
+
+

pkgs/compiler-test/tests/compiler/embed/embed-me11-rd.rkt

@@ -0,0 +1,15 @@
+(module embed-me11-rd mzscheme
+  (provide (rename *read-syntax read-syntax)
+           (rename *read read))
+
+  (define (*read port)
+    `(module embed-me11 mzscheme
+       (with-output-to-file (build-path (find-system-path 'temp-dir) "stdout")
+         (lambda () 
+           (printf ,(read port) 
+                   ;; Use `getenv' at read time!!!
+                   ,(getenv "ELEVEN")))
+         'append)))
+
+  (define (*read-syntax src port)
+    (*read port)))

pkgs/compiler-test/tests/compiler/embed/embed-me11.rkt

@@ -0,0 +1,2 @@
+#reader(lib "embed-me11-rd.ss" "tests" "compiler" "embed")
+"It goes to ~a!\n"

pkgs/compiler-test/tests/compiler/embed/embed-me12-rd.ss

@@ -0,0 +1,15 @@
+(module embed-me11-rd mzscheme
+  (provide (rename *read-syntax read-syntax)
+           (rename *read read))
+
+  (define (*read port)
+    `(module embed-me11 mzscheme
+       (with-output-to-file (build-path (find-system-path 'temp-dir) "stdout")
+         (lambda () 
+           (printf ,(read port) 
+                   ;; Use `getenv' at read time!!!
+                   ,(getenv "ELEVEN")))
+         'append)))
+
+  (define (*read-syntax src port)
+    (*read port)))

pkgs/compiler-test/tests/compiler/embed/embed-me12.ss

@@ -0,0 +1,2 @@
+#reader(lib "embed-me12-rd.rkt" "tests" "compiler" "embed")
+"It goes to ~a!\n"

pkgs/compiler-test/tests/compiler/embed/embed-me13.rkt

@@ -0,0 +1,4 @@
+#lang racket/base
+(require racket/runtime-path)
+(define-runtime-module-path-index _mod "embed-me14.rkt")
+(dynamic-require _mod #f)

pkgs/compiler-test/tests/compiler/embed/embed-me14.rkt

@@ -0,0 +1,5 @@
+#lang racket/base
+(require "embed-me13.rkt")
+(with-output-to-file (build-path (find-system-path 'temp-dir) "stdout")
+  (lambda () (printf "This is 14\n"))
+  #:exists 'append)

pkgs/compiler-test/tests/compiler/embed/embed-me15-one.rkt

@@ -0,0 +1,13 @@
+#lang racket/base
+(define two 2)
+(provide two)
+
+(module* one #f
+  (require (submod "." ".." three))
+  (define one 1)
+  (provide one two three))
+
+(module three racket/base
+  (define three 3)
+  (provide three))
+

pkgs/compiler-test/tests/compiler/embed/embed-me15.rkt

@@ -0,0 +1,5 @@
+#lang racket/base
+(require (submod "embed-me15-one.rkt" one))
+(with-output-to-file (build-path (find-system-path 'temp-dir) "stdout")
+  (lambda () (printf "This is ~a.\n" (+ 9 one two three)))
+  #:exists 'append)

pkgs/compiler-test/tests/compiler/embed/embed-me16.rkt

@@ -0,0 +1,7 @@
+#lang racket/base
+
+;; a `main' submodule:
+(module main racket/base
+  (with-output-to-file (build-path (find-system-path 'temp-dir) "stdout")
+    (lambda () (printf "This is 16.\n"))
+    #:exists 'append))

pkgs/compiler-test/tests/compiler/embed/embed-me17.rkt

@@ -0,0 +1,2 @@
+#lang racket/base
+(require (submod "embed-me17a.rkt" sub))

pkgs/compiler-test/tests/compiler/embed/embed-me17a.rkt

@@ -0,0 +1,9 @@
+#lang racket
+
+(define print-17
+  (lambda () (printf "This is 17.\n")))
+
+(module+ sub
+  (with-output-to-file (build-path (find-system-path 'temp-dir) "stdout")
+    print-17
+    #:exists 'append))

pkgs/compiler-test/tests/compiler/embed/embed-me18.rkt

@@ -0,0 +1,5 @@
+#lang racket/base
+(require (submod tests/compiler/embed/embed-me18a sub))
+(with-output-to-file (build-path (find-system-path 'temp-dir) "stdout")
+  (dynamic-require '(submod tests/compiler/embed/embed-me18a sub) 'print-18)
+  #:exists 'append)

pkgs/compiler-test/tests/compiler/embed/embed-me18a.rkt

@@ -0,0 +1,9 @@
+#lang racket/base
+(module sub racket/base
+  (provide print-18)
+  (define (print-18)
+    (printf "This is 18.\n")))
+
+
+
+  

pkgs/compiler-test/tests/compiler/embed/embed-me19.rkt

@@ -0,0 +1,14 @@
+#lang racket/base
+(require racket/runtime-path)
+
+(define-runtime-module-path plai plai)
+(define-runtime-module-path plai-reader plai/lang/reader)
+(define-runtime-module-path runtime racket/runtime-config)
+
+(parameterize ([read-accept-reader #t])
+  (namespace-require 'racket/base)
+  (eval (read (open-input-string "#lang plai 10"))))
+
+(with-output-to-file (build-path (find-system-path 'temp-dir) "stdout")
+  (lambda () (printf "This is 19.\n"))
+  #:exists 'append)

pkgs/compiler-test/tests/compiler/embed/embed-me1b.rkt

@@ -0,0 +1,9 @@
+#lang scheme/base
+
+(require scheme/runtime-path
+         (for-syntax scheme/base))
+(define-runtime-path file '(lib "icons/file.gif"))
+(with-output-to-file (build-path (find-system-path 'temp-dir) "stdout")
+  (lambda () (printf "This is 1b\n"))
+  #:exists 'append)
+

pkgs/compiler-test/tests/compiler/embed/embed-me1c.rkt

@@ -0,0 +1,9 @@
+#lang scheme/base
+
+(require scheme/runtime-path
+         (for-syntax scheme/base))
+(define-runtime-path file '(lib "etc.ss")) ; in mzlib
+(with-output-to-file (build-path (find-system-path 'temp-dir) "stdout")
+  (lambda () (printf "This is 1c\n"))
+  #:exists 'append)
+

pkgs/compiler-test/tests/compiler/embed/embed-me1d.rkt

@@ -0,0 +1,8 @@
+#lang scheme/base
+
+(require scheme/runtime-path
+         (for-syntax scheme/base))
+(define-runtime-path file '(lib "file.gif" "icons"))
+(with-output-to-file (build-path (find-system-path 'temp-dir) "stdout")
+  (lambda () (printf "This is 1d\n"))
+  #:exists 'append)

pkgs/compiler-test/tests/compiler/embed/embed-me1e.rkt

@@ -0,0 +1,8 @@
+#lang scheme/base
+
+(require scheme/runtime-path
+         (for-syntax scheme/base))
+(define-runtime-path file '(lib "html"))
+(with-output-to-file (build-path (find-system-path 'temp-dir) "stdout")
+  (lambda () (printf "This is 1e\n"))
+  #:exists 'append)

pkgs/compiler-test/tests/compiler/embed/embed-me1f.rkt

@@ -0,0 +1,12 @@
+#lang scheme/base
+
+(require scheme/runtime-path)
+
+;; Check that relative paths are preserved:
+(define-runtime-path f1 "embed-me1f1.rktl")
+(define-runtime-path f2 "sub/embed-me1f2.rktl")
+
+(with-output-to-file (build-path (find-system-path 'temp-dir) "stdout")
+  (lambda () (parameterize ([current-namespace (make-base-namespace)])
+               (load f1)))
+  #:exists 'append)

pkgs/compiler-test/tests/compiler/embed/embed-me1f1.rktl

@@ -0,0 +1 @@
+(load-relative "sub/embed-me1f2.rktl")

pkgs/compiler-test/tests/compiler/embed/embed-me2.rkt

@@ -0,0 +1,6 @@
+(module embed-me2 mzscheme
+  (require "embed-me1.ss"
+	   mzlib/etc)
+  (with-output-to-file (build-path (find-system-path 'temp-dir) "stdout")
+    (lambda () (printf "This is 2: ~a\n" true))
+    'append))

pkgs/compiler-test/tests/compiler/embed/embed-me20.rkt

@@ -0,0 +1,7 @@
+#lang racket/base
+
+;; like "embed-me16.rkt" using `module+'
+(module+ main
+  (with-output-to-file (build-path (find-system-path 'temp-dir) "stdout")
+    (lambda () (printf "This is 20.\n"))
+    #:exists 'append))

pkgs/compiler-test/tests/compiler/embed/embed-me21.rkt

@@ -0,0 +1,12 @@
+#lang racket/base
+(require racket/match)
+
+;; check using `racket/match', particularly with a pattern
+;; that eneds run-time support that may go through a
+;; compile-time `lazy-require':
+
+(match "x"
+  [(pregexp "x")
+   (with-output-to-file (build-path (find-system-path 'temp-dir) "stdout")
+     (lambda () (printf "This is 21.\n"))
+     #:exists 'append)])

pkgs/compiler-test/tests/compiler/embed/embed-me22.rkt

@@ -0,0 +1,6 @@
+#lang racket/kernel
+
+(printf "This is 22.\n")
+
+(module configure-runtime racket/kernel
+  (printf "Configure!\n"))

pkgs/compiler-test/tests/compiler/embed/embed-me23.rkt

@@ -0,0 +1,8 @@
+#lang racket/base
+(require racket/serialize)
+
+(serializable-struct foo (a b))
+
+(define f (deserialize (serialize (foo 1 2))))
+(foo-a f)
+(foo-b f)

pkgs/compiler-test/tests/compiler/embed/embed-me24.rkt

@@ -0,0 +1,3 @@
+#lang racket
+
+"Ok"

pkgs/compiler-test/tests/compiler/embed/embed-me25.rkt

@@ -0,0 +1,9 @@
+#lang racket/base
+
+(module+ main
+  12)
+
+(module submod racket/base
+  11)
+
+10

pkgs/compiler-test/tests/compiler/embed/embed-me26.rkt

@@ -0,0 +1,10 @@
+#lang racket/base
+
+(module+ main
+  12)
+
+(module submod racket/base
+  11)
+
+10
+(require (submod "embed-me27.rkt" other-submod))

pkgs/compiler-test/tests/compiler/embed/embed-me27.rkt

@@ -0,0 +1,3 @@
+#lang racket/base
+
+(module+ other-submod 'y)

pkgs/compiler-test/tests/compiler/embed/embed-me28.rkt

@@ -0,0 +1,14 @@
+#lang racket/base
+(require racket/place)
+
+(define (go)
+  (place pch
+         (place-channel-put pch 28)))
+
+(module+ main                                                                                       
+  (define p (go))
+  (define n (place-channel-get p))
+  (void (place-wait p))
+  (with-output-to-file (build-path (find-system-path 'temp-dir) "stdout")
+    (lambda () (printf "~a\n" n))
+    #:exists 'append))

pkgs/compiler-test/tests/compiler/embed/embed-me29-2.rkt

@@ -0,0 +1,5 @@
+#lang racket/base
+
+(module inside racket/base
+  (define inside 'inside)
+  (provide inside))

pkgs/compiler-test/tests/compiler/embed/embed-me29.rkt

@@ -0,0 +1,5 @@
+#lang racket/base
+
+(module main racket/base
+  (require (submod "embed-me29-2.rkt" inside))
+  inside)

pkgs/compiler-test/tests/compiler/embed/embed-me3.rkt

@@ -0,0 +1,7 @@
+(module embed-me3 mzscheme
+  (require mzlib/etc)
+  (with-output-to-file (build-path (find-system-path 'temp-dir) "stdout")
+    (lambda () 
+      (printf "3 is here, too? ~a\n" true))
+    'append))
+

pkgs/compiler-test/tests/compiler/embed/embed-me4.rktl

@@ -0,0 +1,4 @@
+(with-output-to-file "stdout"
+  (lambda () (printf "This is the literal expression 4.\n"))
+  'append)
+

pkgs/compiler-test/tests/compiler/embed/embed-me5.rkt

@@ -0,0 +1,6 @@
+(module embed-me5 mzscheme
+  (require mred)
+  (with-output-to-file (build-path (find-system-path 'temp-dir) "stdout")
+    (lambda () (printf "This is 5: ~s\n" button%))
+    'append))
+

pkgs/compiler-test/tests/compiler/embed/embed-me6.rkt

@@ -0,0 +1,8 @@
+(module embed-me6 mzscheme
+  (with-output-to-file (build-path (find-system-path 'temp-dir) "stdout")
+    (lambda () 
+      (printf "This is 6\n")
+      (with-handlers ([void (lambda (exn) (printf "no etc.ss\n"))])
+	(printf "~a\n" (dynamic-require 'mzlib/etc 'true))))
+    'append))
+

pkgs/compiler-test/tests/compiler/embed/embed-me6b.rkt

@@ -0,0 +1,8 @@
+(module embed-me6b racket/base
+  (with-output-to-file (build-path (find-system-path 'temp-dir) "stdout")
+    (lambda () 
+      (printf "This is 6\n")
+      (with-handlers ([void (lambda (exn) (printf "no etc.ss\n"))])
+	(printf "~a\n" (and (dynamic-require 'racket/fixnum #f) #t))))
+    #:exists 'append))
+