#lang racket/base
(require racket/path
         racket/file
         racket/port
         racket/promise
         racket/list
	 racket/contract
         syntax/moddep
         syntax/modcollapse
         xml/plist
         setup/dirs
         setup/variant
         setup/collects
         file/ico
         racket/private/so-search
         racket/private/share-search
         racket/private/link-path
         setup/cross-system
         "private/cm-minimal.rkt"
         "private/winsubsys.rkt"
         "private/macfw.rkt"
         "private/mach-o.rkt"
         "private/elf.rkt"
         "private/windlldir.rkt"
         "private/pe-rsrc.rkt"
         "private/collects-path.rkt"
         "private/configdir.rkt"
         "private/write-perm.rkt"
	 "private/win-dll-list.rkt"
         "find-exe.rkt")

(provide/contract [make-embedding-executable
                   (->* (path-string?
                         any/c
                         any/c
                         (listof (or/c (list/c (or/c symbol? #f #t)
                                               (or/c path? module-path?))
                                       (list/c (or/c symbol? #f #t)
                                               (or/c path? module-path?)
                                               (listof symbol?))))
                         (listof path-string?)
                         any/c
                         (listof string?))
                        ((listof (cons/c symbol? any/c))
                         any/c
                         symbol?
                         (or/c #f
                               path-string?
                               (listof path-string?)))
                        void?)]
                  [create-embedding-executable
                   (->* (path-string?)
                        (#:modules 
                         (listof (or/c (list/c (or/c symbol? #f #t)
                                               (or/c path? module-path?))
                                       (list/c (or/c symbol? #f #t)
                                               (or/c path? module-path?)
                                               (listof symbol?))))
                         #:configure-via-first-module? any/c
                         #:early-literal-expressions (listof any/c)
                         #:literal-files (listof path-string?)
                         #:literal-expression any/c
                         #:literal-expressions (listof any/c)
                         #:cmdline (listof string?)
                         #:gracket? any/c
                         #:mred? any/c
                         #:variant (or/c '3m 'cgc 'cs)
                         #:aux (listof (cons/c symbol? any/c))
                         #:collects-path (or/c #f
                                               path-string?
                                               (listof path-string?))
                         #:collects-dest (or/c #f path-string?)
                         #:launcher? any/c
                         #:verbose? any/c
                         #:compiler (-> any/c compiled-expression?)
                         #:expand-namespace namespace?
                         #:src-filter (-> path? any)
                         #:on-extension (or/c #f (-> path-string? boolean? any))
                         #:get-extra-imports (-> path? compiled-module-expression? (listof module-path?)))
                        void?)])

(provide write-module-bundle
         embedding-executable-is-directory?
         embedding-executable-is-actually-directory?
         embedding-executable-put-file-extension+style+filters
         embedding-executable-add-suffix)

  
(define (embedding-executable-is-directory? mred?)
  #f)

(define (embedding-executable-is-actually-directory? mred?)
  (and mred? (eq? 'macosx (cross-system-type))))

(define (embedding-executable-put-file-extension+style+filters mred?)
  (case (cross-system-type)
    [(windows) (values "exe" null '(("Executable" "*.exe")))]
    [(macosx) (if mred?
                  (values "app" '(enter-packages) '(("App" "*.app")))
                  (values #f null null))]
    [else (values #f null null)]))

(define (embedding-executable-add-suffix path mred?)
  (let* ([path (if (string? path)
                   (string->path path)
                   path)]
         [fixup (lambda (re sfx)
                  (if (regexp-match re (path->bytes path))
                      path
                      (path-add-extension path sfx #".")))])
    (case (cross-system-type)
      [(windows) (fixup #rx#".[.][eE][xX][eE]$" #".exe")]
      [(macosx) (if mred?
                    (fixup #rx#".[.][aA][pP][pP]$" #".app")
                    path)]
      [else path])))

(define (mac-dest->executable dest mred?)
  (if mred?
      (let-values ([(base name dir?) (split-path dest)])
        (build-path dest
                    "Contents" "MacOS"
                    (path-replace-extension name #"")))
      dest))

(define exe-suffix?
  (delay (equal? #"i386-cygwin" (path->bytes (cross-system-library-subpath)))))

;; Find the magic point in the binary:
(define (find-cmdline what rx)
  (let ([m (regexp-match-positions rx (current-input-port))])
    (if m
        (caar m)
        (error 
         'create-embedding-executable
         (format
          "can't find ~a position in executable"
          what)))))


(define (relativize exec-name dest adjust)
  (let ([p (find-relative-path
            (let-values ([(dir name dir?) (split-path 
                                           (normal-case-path
                                            (normalize-path dest)))])
              dir)
            (normal-case-path (normalize-path exec-name)))])
    (if (relative-path? p)
        (adjust p)
        p)))

;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (find-relevant-lib-dir f #:default [default #f])
  (or
   (for/or ([lib-dir (in-list (get-cross-lib-search-dirs))])
     (define p (build-path lib-dir f))
     (and (or (file-exists? p)
              (directory-exists? p))
          lib-dir))
   default
   (error 'find-relevant-lib-dir
          "could not find ~s"
          f)))

(define (find-in-lib f)
  (build-path (find-relevant-lib-dir f #:default (find-lib-dir))
              f))

;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (prepare-macosx-mred exec-name dest aux variant)
  (let* ([name (let-values ([(base name dir?) (split-path dest)])
                 (path-replace-extension name #""))]
         [src (find-in-lib "Starter.app")]
         [creator (let ([c (assq 'creator aux)])
                    (or (and c
                             (cdr c))
                        "MrSt"))]
         [file-types (let ([m (assq 'file-types aux)])
                       (and m
                            (pair? (cdr m))
                            (cdr m)))]
         [uti-exports (let ([m (assq 'uti-exports aux)])
                        (and m
                             (pair? (cdr m))
                             (cdr m)))]
         [resource-files (let ([m (assq 'resource-files aux)])
                           (and m
                                (cdr m)))])
    (when creator
      (unless (and (string? creator) (= 4 (string-length creator)))
        (error 'make-executable "creator is not a 4-character string: ~e" creator)))
    (when file-types
      (unless (and (list? file-types)
                   (andmap list? file-types)
                   (andmap (lambda (spec)
                             (andmap (lambda (p)
                                       (and (list? p)
                                            (= 2 (length p))
                                            (string? (car p))))
                                     spec))
                           file-types))
        (error 'make-executable "bad file-types spec: ~e" file-types)))
    (when resource-files
      (unless (and (list? resource-files)
                   (andmap path-string?
                           resource-files))
        (error 'make-executable "resource-files is not a list of paths: ~e" resource-files)))
    
    (when (or (directory-exists? dest)
              (file-exists? dest)
              (link-exists? dest))
      (delete-directory/files dest))
    (make-directory* (build-path dest "Contents" "Resources"))
    (make-directory* (build-path dest "Contents" "MacOS"))
    (copy-file exec-name (build-path dest "Contents" "MacOS" name))
    (copy-file (build-path src "Contents" "PkgInfo")
               (build-path dest "Contents" "PkgInfo"))
    (let ([icon (or (let ([icon (assq 'icns aux)])
                      (and icon
                           (cdr icon)))
                    (build-path src "Contents" "Resources" "Starter.icns"))])
      (copy-file icon
                 (build-path dest "Contents" "Resources" "Starter.icns")))
    (let ([orig-plist (call-with-input-file (build-path src
                                                        "Contents"
                                                        "Info.plist")
                        read-plist)]
          [plist-replace (lambda (plist . l)
                           (let loop ([plist plist][l l])
                             (if (null? l)
                                 plist
                                 (let ([key (car l)]
                                       [val (cadr l)])
                                   (loop `(dict
                                           ,@(let loop ([c (cdr plist)])
                                               (cond
                                                 [(null? c) (list (list 'assoc-pair key val))]
                                                 [(string=? (cadar c) key)
                                                  (cons (list 'assoc-pair key val)
                                                        (cdr c))]
                                                 [else
                                                  (cons (car c)
                                                        (loop (cdr c)))])))
                                         (cddr l))))))])
      (let* ([new-plist (plist-replace
                         orig-plist
                         
                         "CFBundleExecutable" 
                         (path->string name)
                         
                         "CFBundleSignature"
                         creator
                         
                         "CFBundleIdentifier" 
                         (format "org.racket-lang.~a" (path->string name)))]
             [new-plist (if uti-exports
                            (plist-replace
                             new-plist
                             "UTExportedTypeDeclarations"
                             (cons 'array
                                   (map (lambda (spec)
                                          (cons
                                           'dict
                                           (map (lambda (p)
                                                  (list
                                                   'assoc-pair
                                                   (car p)
                                                   (cadr p)))
                                                spec)))
                                        uti-exports)))
                            new-plist)]
             [new-plist (if file-types
                            (plist-replace
                             new-plist                                 
                             "CFBundleDocumentTypes"
                             (cons 'array
                                   (map (lambda (spec)
                                          (cons
                                           'dict
                                           (map (lambda (p)
                                                  (list
                                                   'assoc-pair
                                                   (car p)
                                                   (cadr p)))
                                                spec)))
                                        file-types)))                                
                            new-plist)])
        (call-with-output-file (build-path dest 
                                           "Contents" 
                                           "Info.plist")
          #:exists 'truncate
          (lambda (port)
            (write-plist new-plist port)))))
    (let* ([pkginfo-path (build-path dest "Contents" "PkgInfo")]
           [old-perms (ensure-writable pkginfo-path)])
      (call-with-output-file pkginfo-path
        #:exists 'truncate
        (lambda (port)
          (fprintf port "APPL~a" creator)))
      (done-writable pkginfo-path old-perms))
    (when resource-files
      (for-each (lambda (p)
                  (let-values ([(base name dir?) (split-path p)])
                    (copy-file p (build-path dest
                                             "Contents" 
                                             "Resources"
                                             name))))
                resource-files))
    (build-path dest "Contents" "MacOS" name)))

;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; Represent modules with lists starting with the filename, so we
;; can use assoc:
(define (make-mod normal-file-path normal-module-path 
                  code name full-name relative-mappings-box 
                  runtime-paths runtime-module-syms
                  actual-file-path
                  use-source?)
  (list normal-file-path normal-module-path code
        name full-name relative-mappings-box
        runtime-paths runtime-module-syms 
        actual-file-path
        use-source?))

(define (mod-file m) (strip-submod (car m)))
(define (mod-mod-path m) (cadr m))
(define (mod-code m) (caddr m))
(define (mod-name m) (list-ref m 3))
(define (mod-full-name m) (list-ref m 4))
(define (mod-mappings m) (unbox (list-ref m 5)))
(define (mod-mappings-box m) (list-ref m 5))
(define (mod-runtime-paths m) (list-ref m 6))
(define (mod-runtime-module-syms m) (list-ref m 7))
(define (mod-actual-file m) (list-ref m 8))
(define (mod-use-source? m) (list-ref m 9))

(define (file-mod-name-base path)
  (define-values (base name dir?) (split-path path))
  (path->string (path-replace-extension name #"")))

(struct file-mod-name-state (path->relative-cache used wrt-path))
(define (make-generate-file-mod-name-state wrt-path)
  (file-mod-name-state (make-hash) (make-hasheq) wrt-path))

(define (generate-file-mod-name gen-state path)
  (define mp (path->module-path path
                                #:cache (file-mod-name-state-path->relative-cache gen-state)))
  (define str
    (cond
      [(and mp (pair? mp) (eq? (car mp) 'lib) (null? (cddr mp)))
       (cadr mp)]
      [else
       (define rel (find-relative-path (file-mod-name-state-wrt-path gen-state) path))
       (path->string rel)]))
  (define sym (string->symbol (regexp-replace #rx"[.](?:ss|rkt)$" str "")))
  (define used (file-mod-name-state-used gen-state))
  (let loop ([sym sym])
    (cond
      [(hash-ref used sym #f)
       (loop (string->symbol (format "~a>" sym)))]
      [else
       (hash-set! used sym #t)
       (format "#%embedded:~a:" sym)])))

(define (normalize filename)
  (if (pair? filename)
      `(submod ,(normalize (cadr filename)) ,@(cddr filename))
      (let ([f (simplify-path (cleanse-path filename))])
        ;; Use normal-case-path on just the base part, to avoid
        ;; changing the filename case (which should match the
        ;; module-name case within the file):
        (let-values ([(base name dir?) (split-path f)])
          (if (path? base)
              (build-path (normal-case-path base) name)
              f)))))

(define (strip-submod a)
  (if (and (pair? a)
           (eq? 'submod (car a)))
      (cadr a)
      a))

(define (is-lib-path? a)
  (let ([a (strip-submod a)])
    (or (and (pair? a)
             (eq? 'lib (car a)))
        (symbol? a))))

(define (symbol-to-lib-form l)
  (if (symbol? l)
      `(lib ,(symbol->string l))
      l))
  
(define (unix-style-split p)
  (let ([m (regexp-match #rx"^([^/]*)/(.*)$" p)])
    (if m
        (cons (cadr m) (unix-style-split (caddr m)))
        (list p))))

(define (extract-last l)
  (let loop ([l l][dirs null])
    (if (null? (cdr l))
        (values (reverse dirs) (car l))
        (loop (cdr l) (cons (car l) dirs)))))

(define (adjust-ss/rkt-extension path)
  (cond
   [(file-exists? path) path]
   [(path-has-extension? path #".ss")
    (define rkt-path (path-replace-extension path #".rkt"))
    (if (file-exists? rkt-path)
        rkt-path
        path)]
   [(path-has-extension? path #".rkt")
    (define ss-path (path-replace-extension path #".ss"))
    (if (file-exists? ss-path)
        ss-path
        path)]
   [else path]))

(define (lib-module-filename collects-dest module-path)
  (let-values ([(dir file) 
                (let ([s (lib-path->string (strip-submod module-path))])
                  (extract-last (unix-style-split s)))])
    (let ([p (build-path collects-dest
                         (apply build-path dir)
                         (let ([l (use-compiled-file-paths)])
                           (if (pair? l)
                               (car l)
                               "compiled"))
                         (path-add-extension file #".zo"))])
      (let-values ([(base name dir?) (split-path p)])
        (make-directory* base)
        p))))

(define (file-date f)
  (with-handlers ([exn:fail:filesystem? (lambda (x) -inf.0)])
    (file-or-directory-modify-seconds f)))

(define-struct extension (path))

;; Loads module code, using .zo if there, compiling from .scm if not
(define (get-code filename module-path ready-code use-submods codes file-mod-names verbose? collects-dest on-extension 
                  compiler expand-namespace src-filter get-extra-imports working gen-state)
  ;; filename can have the form `(submod ,filename ,sym ...)
  (let* ([a (assoc filename (unbox codes))]
         ;; If we didn't fine `filename` as-is, check now for
         ;; using source, because in that case we'll only register the
         ;; main module even if a submodule is include in `filename`.
         [use-source?
          (and (not a)
               (src-filter (adjust-ss/rkt-extension (strip-submod filename))))]
         ;; When using source or writing to collects, keep full modules:
         [keep-full? (or use-source? collects-dest)]
         ;; When keeping a full module, strip away submodule paths:
         [filename (or (and (not a)
                            keep-full?
                            (pair? filename)
                            (cadr filename))
                       filename)]
         ;; Maybe search again after deciding whether to strip submodules:
         [a (or a 
                (and keep-full?
                     ;; Try again:
                     (assoc filename (unbox codes))))])
    (cond
     [a
      ;; Already have this module. Make sure that library-referenced
      ;;  modules are consistently referenced through library paths:
      (let ([found-lib? (is-lib-path? (mod-mod-path a))]
            [look-lib? (is-lib-path? module-path)])
        (cond
         [(and found-lib? look-lib?)
          'ok]
         [(or found-lib? look-lib?)
          (error 'find-module
                 "module referenced both as a library and through a path: ~a"
                 filename)]
         [else 'ok]))]
     [(hash-ref working filename #f)
      ;; in the process of loading the module; a cycle
      ;; is possible through `define-runtime-path'
      'ok]
     [else
      ;; First use of the module. Get code and then get code for imports.
      (when verbose?
        (eprintf "Getting ~s as ~s\n" module-path filename))
      (let* ([submod-path (if (pair? filename)
                              (cddr filename)
                              null)]
             [just-filename (strip-submod filename)]
             [root-module-path (strip-submod module-path)]
             [actual-filename just-filename] ; `set!'ed below to adjust file extension
             [name (file-mod-name-base just-filename)]
             [file-mod-name (let ([a
                                   ;; Try path with a submodule, first, then fall back to
                                   ;; just the path part if there was a `submod` wrapper:
                                   (or (assoc filename file-mod-names)
                                       (and (pair? filename)
                                            (assoc just-filename file-mod-names)))])
                              (if a
                                  (cdr a)
                                  (generate-file-mod-name gen-state just-filename)))]
             [full-name (string->symbol
                         (format "~a~a"
                                 file-mod-name
                                 (if (null? submod-path)
                                     ""
                                     submod-path)))])
        (hash-set! working filename full-name)
        (let* ([get-module-code*
                ;; Re-used when swapping code during cross-compilation.
                (lambda (#:roots [roots (current-compiled-file-roots)]
                         #:host? [host? #f])
                  (get-module-code just-filename
                                   #:roots roots
                                   #:submodule-path submod-path
                                   (let ([l (use-compiled-file-paths)])
                                     (if (pair? l)
                                         (car l)
                                         "compiled"))
                                   (cond
                                     [(and host? (cross-compiling?))
                                      (lambda (e)
                                        (parameterize ([current-compile-target-machine (system-type 'target-machine)])
                                          (compiler e)))]
                                     [(not host?)
                                      (lambda (e)
                                        ;; point at host compiled code for dependencies
                                        (parameterize ([current-compiled-file-roots (list (car (current-compiled-file-roots)))])
                                          (compiler e)))]
                                     [else
                                      compiler])
                                   (if on-extension
                                       (lambda (f l?)
                                         (on-extension f l?)
                                         #f)
                                       (lambda (file _loader?)
                                         (if _loader?
                                             (error 'create-embedding-executable
                                                    "cannot use a _loader extension: ~e"
                                                    file)
                                             (make-extension file))))
                                   #:choose
                                   ;; Prefer extensions, if we're handling them:
                                   (lambda (src zo so)
                                     (set! actual-filename src) ; remember convert source name
                                     (if on-extension
                                         #f
                                         (if (and (file-exists? so)
                                                  ((file-date so) . >= . (file-date zo)))
                                             'so
                                             #f)))))]
               [code (or ready-code (get-module-code* #:host? #t))])
          (cond
           [(extension? code)
            (when verbose?
              (eprintf " using extension: ~s\n" (extension-path code)))
            (set-box! codes
                      (cons (make-mod filename module-path code 
                                      name full-name
                                      (box null) null null
                                      actual-filename
                                      #f)
                            (unbox codes)))]
           [code
            (let ([importss (module-compiled-imports code)])
              (let* ([all-file-imports (filter (keep-import-dependency? keep-full? actual-filename)
                                               (apply append (map cdr importss)))]
                     [extra-paths
                      (map symbol-to-lib-form (append (if keep-full?
                                                          (extract-full-imports module-path actual-filename code)
                                                          null)
                                                      (if use-source?
                                                          (list 'compiler/private/read-bstr)
                                                          null)
                                                      (get-extra-imports actual-filename code)))]
                     [extract-submods
                      (lambda (submods)
                        (if use-source?
                            null
                            (for/list ([m (in-list submods)]
                                       #:when (or (member (last (module-compiled-name m)) use-submods)
                                                  (declares-always-preserved? m)))
                              m)))]
                     [prepare-code&submods
                      (lambda (code)
                        (define name (module-compiled-name code))
                        (define renamed-code
                          (cond
                            [(symbol? name) code]
                            [else (module-compiled-name code (last name))]))
                        (define pre-submods (extract-submods (module-compiled-submodules renamed-code #t)))
                        (define post-submods (extract-submods (module-compiled-submodules renamed-code #f)))
                        (define new-code
                          (cond
                            [keep-full? code]
                            [else (module-compiled-submodules
                                   (module-compiled-submodules renamed-code #f null) #t null)]))
                        (values new-code pre-submods post-submods))])
                (let*-values ([(runtime-paths)
                               (if (module-compiled-cross-phase-persistent? code)
                                   ;; avoid potentially trying to redeclare cross-phase persistent modules,
                                   ;; since redeclaration isn't allowed:
                                   null
                                   ;; check for run-time paths by visiting the module in an
                                   ;; expand-time namespace:
                                   (parameterize ([current-namespace expand-namespace])
                                     (let ([module-path
                                            (if (path? module-path)
                                                (path->complete-path module-path)
                                                module-path)])
                                       (unless (module-declared? module-path)
                                         (parameterize ([current-module-declare-name
                                                         (module-path-index-resolve (module-path-index-join
                                                                                     module-path
                                                                                     #f))])
                                           (eval code)))
                                       (define e (expand `(,#'module m racket/kernel
                                                                     (#%require (only ,module-path)
                                                                                racket/runtime-path)
                                                                     (runtime-paths ,module-path))))
                                       (syntax-case e (quote)
                                         [(_ m mz (#%mb req (quote (spec ...))))
                                          (for/list ([p (in-list (syntax->datum #'(spec ...)))])
                                            ;; Strip variable reference from 'module specs, because
                                            ;; we don't need them and they retain the namespace:
                                            (if (and (pair? p) (eq? 'module (car p)))
                                                (list 'module (cadr p))
                                                p))]
                                         [_else (error 'create-empbedding-executable
                                                       "expansion mismatch when getting external paths: ~e"
                                                       (syntax->datum e))]))))]
                              [(extra-runtime-paths) (filter-map (lambda (p)
                                                                   (and (pair? p)
                                                                        (eq? (car p) 'module)
                                                                        (cadr p)))
                                                                 runtime-paths)]
                              [(code pre-submods post-submods) (prepare-code&submods code)])
                  (let ([sub-files (map (lambda (i)
                                          ;; use `just-filename', because i has submod name embedded
                                          (normalize (resolve-module-path-index i just-filename)))
                                        all-file-imports)]
                        [sub-paths (map (lambda (i)
                                          ;; use `root-module-path', because i has submod name embedded
                                          (collapse-module-path-index i root-module-path))
                                        all-file-imports)]
                        [normalized-extra-paths (map (lambda (i) (collapse-module-path i module-path))
                                                     (append extra-runtime-paths extra-paths))]
                        [extra-files (map (lambda (i) (normalize (resolve-module-path-index (module-path-index-join i #f)
                                                                                            filename)))
                                          ;; getting runtime-module-path symbols below
                                          ;; relies on extra-runtime-paths being first:
                                          (append extra-runtime-paths extra-paths))])
                    (define (get-one-code sub-filename sub-path ready-code)
                      (get-code sub-filename sub-path ready-code null
                                codes
                                file-mod-names
                                verbose?
                                collects-dest
                                on-extension
                                compiler
                                expand-namespace
                                src-filter get-extra-imports
                                working
                                gen-state))
                    (define (get-one-submodule-code m)
                      (define name (cadr (module-compiled-name m)))
                      (define mp `(submod "." ,name))
                      (define mpi (module-path-index-join mp #f))
                      (get-one-code (resolve-module-path-index mpi filename)
                                    (if (is-lib-path? module-path)
                                        ;; Preserve `lib`-ness of module reference:
                                        (collapse-module-path-index
                                         (module-path-index-join
                                          mp
                                          (module-path-index-join module-path #f)))
                                        ;; Ok to collapse based on filename:
                                        (collapse-module-path-index mpi filename))
                                    m))
                    ;; Add code for pre submodules:
                    (for-each get-one-submodule-code pre-submods)
                    ;; Get code for imports:
                    (for-each (lambda (sf sp) (get-one-code sf sp #f))
                              (append sub-files extra-files)
                              (append sub-paths normalized-extra-paths))
                    (when verbose?
                      (unless (null? runtime-paths)
                        (eprintf "Runtime paths for ~s: ~s\n"
                                 filename
                                 runtime-paths)))
                    (if (and collects-dest
                             (is-lib-path? module-path))
                        ;; Install code as .zo:
                        (begin
                          (with-output-to-file (lib-module-filename collects-dest module-path)
                            #:exists 'truncate/replace
                            (lambda ()
                              (write code)))
                          ;; Record module as copied
                          (set-box! codes
                                    (cons (make-mod filename module-path #f
                                                    #f #f
                                                    (box null) null null
                                                    actual-filename
                                                    use-source?)
                                          (unbox codes))))
                        ;; Build up relative module resolutions, relative to this one,
                        ;; that will be requested at run-time.
                        (let* ([lookup-full-name (lambda (sub-filename)
                                                   (let ([m (assoc sub-filename (unbox codes))])
                                                     (if m
                                                         (mod-full-name m)
                                                         ;; must have been a cycle...
                                                         (hash-ref working sub-filename
                                                                   (lambda ()
                                                                     ;; If `sub-filename` was included from source,
                                                                     ;; then we'll need to use a submodule path:
                                                                     `(,(hash-ref working (strip-submod sub-filename))
                                                                       ,@(cddr sub-filename)))))))]
                               [get-submod-mapping
                                (lambda (m)
                                  (define name (cadr (module-compiled-name m)))
                                  (cons `(submod "." ,name)
                                        (lookup-full-name
                                         (collapse-module-path-index 
                                          (module-path-index-join `(submod "." ,name) #f)
                                          filename))))]
                               [mappings-box
                                (box (append
                                      (filter (lambda (p) (and p (cdr p)))
                                              (map (lambda (sub-i sub-filename sub-path)
                                                     (and (not (and collects-dest
                                                                    (is-lib-path? sub-path)))
                                                          (if sub-i
                                                              (let-values ([(path base) (module-path-index-split sub-i)])
                                                                (and base ; can be #f if path isn't relative
                                                                     (begin
                                                                       ;; Assert: base should refer to this module:
                                                                       (let-values ([(path2 base2) (module-path-index-split base)])
                                                                         (when (or path2 base2)
                                                                           (error 'embed "unexpected nested module path index ~s" base)))
                                                                       (cons path (lookup-full-name sub-filename)))))
                                                              ;; a run-time path:
                                                              (cons (if (path? sub-path)
                                                                        `(path ,(encode-link-path sub-path))
                                                                        sub-path)
                                                                    (lookup-full-name sub-filename)))))
                                                   (append all-file-imports (map (lambda (p) #f) extra-runtime-paths))
                                                   (append sub-files (take extra-files (length extra-runtime-paths)))
                                                   (append sub-paths extra-runtime-paths)))
                                      (map get-submod-mapping pre-submods)))])
                          ;; Record the module
                          ;; For cross-compilation, we need to be able to execute code using the host Racket (to find
                          ;; dependencies and runtime paths), but then we have to swap in code for the target Racket
                          ;; here, before writing it to the output.
                          (let ([code (cond
                                        [(cross-compiling?)
                                         (when verbose?
                                           (eprintf "Swapping host code of ~s for target platform~n" module-path))
                                         (define target-code
                                           (get-module-code* #:roots (cdr (current-compiled-file-roots))))
                                         ;; Apply the same trasformations to the target code that were made to the host code.
                                         (define-values (prepared-code _pre-submods _post-submods)
                                           (prepare-code&submods target-code))
                                         prepared-code]
                                        [else
                                         code])])
                            (set-box! codes
                                      (cons (make-mod filename module-path code
                                                      name full-name
                                                      mappings-box
                                                      runtime-paths
                                                      ;; extract runtime-path module symbols:
                                                      (let loop ([runtime-paths runtime-paths]
                                                                 [extra-files extra-files])
                                                        (cond
                                                          [(null? runtime-paths) null]
                                                          [(let ([p (car runtime-paths)])
                                                             (and (pair? p) (eq? (car p) 'module)))
                                                           (cons (lookup-full-name (car extra-files))
                                                                 (loop (cdr runtime-paths) (cdr extra-files)))]
                                                          [else
                                                           (cons #f (loop (cdr runtime-paths) extra-files))]))
                                                      actual-filename
                                                      use-source?)
                                            (unbox codes))))
                          ;; Add code for post submodules:
                          (for-each get-one-submodule-code post-submods)
                          ;; Add post-submodule mappings:
                          (set-box! mappings-box
                                    (append (unbox mappings-box)
                                            (map get-submod-mapping post-submods)))))))))]
           [else
            (set-box! codes
                      (cons (make-mod filename module-path code 
                                      name #f
                                      null null null
                                      actual-filename
                                      use-source?)
                            (unbox codes)))])))])))

(define ((keep-import-dependency? keep-full? path) orig-x)
  (define-values (x base) (module-path-index-split orig-x))
  (not (or (and (pair? x)
                (eq? 'quote (car x)))
           (and keep-full?
                ;; Don't try to include submodules specifically if the enclosing
                ;; module is kept fully. Any needed dependencies will be
                ;; extracted via `extract-full-imports`.
                (pair? x)
                (eq? (car x) 'submod)
                (or (equal? (cadr x) ".")
                    (equal? path
                            (normalize (resolve-module-path-index (module-path-index-join (cadr x) #f)
                                                                  path))))))))

(define (extract-full-imports module-path path code)
  ;; When embedding a module from source or otherwise keeping a full
  ;; module, we need to collect all dependencies from submodules
  ;; (recursively), because they'll be needed to start again from
  ;; source.
  (let accum-from-mod ([mod code])
    (append
     (map (lambda (i) (collapse-module-path-index i module-path))
          (filter (keep-import-dependency? #t path)
                  (apply append (map cdr (module-compiled-imports mod)))))
     (apply append
            (map accum-from-mod (module-compiled-submodules mod #t)))
     (apply append
            (map accum-from-mod (module-compiled-submodules mod #f))))))

(define (declares-always-preserved? m)
  (for/or ([s (in-list
               (append (module-compiled-submodules m #t)
                       (module-compiled-submodules m #f)))])
    (eq? (last (module-compiled-name s)) 'declare-preserve-for-embedding)))

;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (compile-using-kernel e)
  (let ([ns (make-empty-namespace)])
    (namespace-attach-module (current-namespace) ''#%kernel ns)
    (parameterize ([current-namespace ns]
                   [current-compile-target-machine (get-compile-target-machine)])
      (namespace-require ''#%kernel)
      (compile e))))

;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (lib-path->string path)
  (cond
   [(null? (cddr path))
    (if (regexp-match #rx"^[^/]*[.]" (cadr path))
        ;; mzlib
        (string-append "mzlib/" (cadr path))
        ;; new-style
        (if (regexp-match #rx"^[^/.]*$" (cadr path))
            (string-append (cadr path) "/main.ss")
            (if (regexp-match #rx"^[^.]*$" (cadr path))
                ;; need an extension:
                (string-append (cadr path) ".ss")
                (cadr path))))]
   [else
    ;; old-style multi-string:
    (string-append (apply string-append
                          (map (lambda (s)
                                 (string-append s "/"))
                               (cddr path)))
                   (cadr path))]))

(define (make-module-name-resolver code-l)
  (let ([extensions (filter (lambda (m) (extension? (mod-code m))) code-l)])
    `(module #%resolver '#%kernel
       (let-values ([(orig) (current-module-name-resolver)]
                    [(regs) (make-hasheq)]
                    [(mapping-table) (quote
                                      ,(map
                                        (lambda (m)
                                          `(,(mod-full-name m)
                                            ,(mod-mappings m)))
                                        code-l))]
                    [(library-table) (quote
                                      ,(filter values
                                               (map (lambda (m)
                                                      (let loop ([path (mod-mod-path m)])
                                                        (cond
                                                         [(and (pair? path)
                                                               (eq? 'lib (car path)))
                                                          (cons (lib-path->string path)
                                                                (mod-full-name m))]
                                                         [(and (pair? path)
                                                               (eq? 'planet (car path)))
                                                          ;; Normalize planet path
                                                          (cons (collapse-module-path path current-directory)
                                                                (mod-full-name m))]
                                                         [(and (pair? path)
                                                               (eq? 'submod (car path)))
                                                          (define m (loop (cadr path)))
                                                          (and m
                                                               (cons `(submod ,(car m) ,@(cddr path))
                                                                     (cdr m)))]
                                                         [else #f])))
                                                    code-l)))])
         (hash-set! regs 
                    (namespace-module-registry (current-namespace))
                    (vector mapping-table library-table))
         (letrec-values ([(lookup)
                          (lambda (name rel-to stx load? for-submod? orig)
                            (if (not (module-path? name))
                                ;; Bad input
                                (orig name rel-to stx load?)
                                (let-values ([(table-vec) (hash-ref regs (namespace-module-registry (current-namespace)) #f)]
                                             [(name) (if (pair? name)
                                                         (if (eq? 'submod (car name))
                                                             (if (null? (cddr name))
                                                                 (if (equal? ".." (cadr name))
                                                                     name
                                                                     (if (equal? "." (cadr name))
                                                                         name
                                                                         (cadr name))) ; strip away `submod' without a submodule path
                                                                 name)
                                                             name)
                                                         name)])
                                  (if (not table-vec)
                                      ;; No mappings in this registry
                                      (orig name rel-to stx load?)
                                      (let-values ([(mapping-table) (vector-ref table-vec 0)]
                                                   [(library-table) (vector-ref table-vec 1)])
                                        ;; Have a relative mapping?
                                        (let-values ([(a) (if rel-to
                                                              (let-values ([(v) (assq (resolved-module-path-name rel-to) mapping-table)])
                                                                (if v
                                                                    v
                                                                    ;; It we're loading a module from source, then `rel-to` might not be
                                                                    ;; our eventual name, but `(current-module-declare-name)` provides
                                                                    ;; one, so try using that to resolve the module:
                                                                    (if (current-module-declare-name)
                                                                        (assq (resolved-module-path-name (current-module-declare-name)) mapping-table)
                                                                        #f)))
                                                              #f)]
                                                     [(ss->rkt)
                                                      (lambda (s)
                                                        (regexp-replace #rx"[.]ss$" s ".rkt"))])
                                          (if a
                                              (let-values ([(a2) (assoc name (cadr a))])
                                                (if a2
                                                    (make-resolved-module-path (cdr a2))
                                                    ;; No relative mapping found (presumably a lib)
                                                    (orig name rel-to stx load?)))
                                              (let-values ([(lname)
                                                            ;; normalize `lib' to single string (same as lib-path->string):
                                                            (let-values ([(name)
                                                                          (let-values ([(name) 
                                                                                        ;; remove submod path; added back at end
                                                                                        (if (pair? name)
                                                                                            (if (eq? 'submod (car name))
                                                                                                (cadr name)
                                                                                                name)
                                                                                            name)])
                                                                            (if (symbol? name)
                                                                                (list 'lib (symbol->string name))
                                                                                name))])
                                                              (if (pair? name)
                                                                  (if (eq? 'lib (car name))
                                                                      (if (null? (cddr name))
                                                                          (if (regexp-match #rx"^[^/]*[.]" (cadr name))
                                                                              ;; mzlib
                                                                              (string-append "mzlib/" (ss->rkt (cadr name)))
                                                                              ;; new-style
                                                                              (if (regexp-match #rx"^[^/.]*$" (cadr name))
                                                                                  (string-append (cadr name) "/main.rkt")
                                                                                  (if (regexp-match #rx"^[^.]*$" (cadr name))
                                                                                      ;; need an extension:
                                                                                      (string-append (cadr name) ".rkt")
                                                                                      (ss->rkt (cadr name)))))
                                                                          ;; old-style multi-string
                                                                          (string-append (apply string-append
                                                                                                (map (lambda (s)
                                                                                                       (string-append s "/"))
                                                                                                     (cddr name)))
                                                                                         (ss->rkt (cadr name))))
                                                                      (if (eq? 'planet (car name))
                                                                          (letrec-values ([(split)
                                                                                           (lambda (s rx extension-after)
                                                                                             (let-values ([(m) (regexp-match-positions 
                                                                                                                rx
                                                                                                                s)])
                                                                                               (if m
                                                                                                   (cons (substring s 0 (caar m))
                                                                                                         (split (substring s (cdar m))
                                                                                                                rx 
                                                                                                                (- extension-after 1)))
                                                                                                   (list
                                                                                                    (if (extension-after . <= . 0)
                                                                                                        (if (regexp-match? #rx"[.]" s)
                                                                                                            s
                                                                                                            (string-append s ".rkt"))
                                                                                                        s)))))]
                                                                                          [(last-of)
                                                                                           (lambda (l)
                                                                                             (if (null? (cdr l))
                                                                                                 (car l)
                                                                                                 (last-of (cdr l))))]
                                                                                          [(not-last)
                                                                                           (lambda (l)
                                                                                             (if (null? (cdr l))
                                                                                                 null
                                                                                                 (cons (car l) (not-last (cdr l)))))])
                                                                            (if (null? (cddr name))
                                                                                ;; need to normalize:
                                                                                (let-values ([(s) (if (symbol? (cadr name))
                                                                                                      (symbol->string (cadr name))
                                                                                                      (cadr name))])
                                                                                  (let-values ([(parts) (split s #rx"/" 2)])
                                                                                    (let-values ([(vparts) (split (cadr parts) #rx":" +inf.0)])
                                                                                      (cons 'planet
                                                                                            (cons (if (null? (cddr parts))
                                                                                                      "main.rkt"
                                                                                                      (ss->rkt (last-of parts)))
                                                                                                  (cons
                                                                                                   (cons 
                                                                                                    (car parts) 
                                                                                                    (cons (string-append (car vparts) 
                                                                                                                         ".plt")
                                                                                                          (if (null? (cddr parts))
                                                                                                              null
                                                                                                              ;; FIXME: finish version parse:
                                                                                                              (cdddr parts))))
                                                                                                   (if (null? (cddr parts))
                                                                                                       null
                                                                                                       (not-last (cddr parts)))))))))
                                                                              ;; already in long form; move subcollects to end:
                                                                              (let-values ([(s) (cadr name)])
                                                                                (let-values ([(parts) (split s #rx"/" +inf.0)])
                                                                                  (if (= 1 (length parts))
                                                                                      (list* 'planet
                                                                                             (ss->rkt (cadr name))
                                                                                             (cddr name))
                                                                                      (list* 'planet
                                                                                             (ss->rkt (last-of parts))
                                                                                             (caddr name)
                                                                                             (append
                                                                                              (cdddr name)
                                                                                              (not-last parts))))))))
                                                                          #f))
                                                                  #f))]
                                                           [(planet-match?)
                                                            (lambda (a b)
                                                              (if (equal? (cons (car a) (cddr a))
                                                                          (cons (car b) (cddr b)))
                                                                  (let-values ([(a) (cadr a)]
                                                                               [(b) (cadr b)])
                                                                    (if (equal? (car a) (car b))
                                                                        (if (equal? (cadr a) (cadr b))
                                                                            ;; Everything matches up to the version...
                                                                            ;; FIXME: check version. (Since the version isn't checked,
                                                                            ;; this currently works only when a single version of the
                                                                            ;; package is used in the executable.)
                                                                            #t
                                                                            #f)
                                                                        #f))
                                                                  #f))]
                                                           [(restore-submod) (lambda (lname)
                                                                               (if (pair? name)
                                                                                   (if (eq? (car name) 'submod)
                                                                                       (list* 'submod lname (cddr name))
                                                                                       lname)
                                                                                   lname))])
                                                ;; A library mapping that we have? 
                                                (let-values ([(a3) (if lname
                                                                       (if (string? lname)
                                                                           ;; lib
                                                                           (assoc (restore-submod lname) library-table)
                                                                           ;; planet
                                                                           (ormap (lambda (e)
                                                                                    (let-values ([(e)
                                                                                                  ;; handle submodule matching first:
                                                                                                  (if (pair? name)
                                                                                                      (if (eq? (car name) 'submod)
                                                                                                          (if (pair? (car e))
                                                                                                              (if (eq? (caar e) 'submod)
                                                                                                                  (if (equal? (cddar e) (cddr name))
                                                                                                                      (cons (cadar e) (cdr e))
                                                                                                                      #f)
                                                                                                                  #f)
                                                                                                              #f)
                                                                                                          e)
                                                                                                      e)])
                                                                                      (if e
                                                                                          (if (string? (car e))
                                                                                              #f
                                                                                              (if (planet-match? (cdar e) (cdr lname))
                                                                                                  e
                                                                                                  #f))
                                                                                          #f)))
                                                                                  library-table))
                                                                       #f)])
                                                  (if a3
                                                      ;; Have it:
                                                      (make-resolved-module-path (cdr a3))
                                                      (if (if for-submod?
                                                              (if (pair? name)
                                                                  (if (eq? (car name) 'quote)
                                                                      (assq (cadr name) mapping-table)
                                                                      #f)
                                                                  #f)
                                                              #f)
                                                          ;; Report that we have mappings relative to `name`:
                                                          (make-resolved-module-path (cadr name))
                                                          ;; Let default handler try:
                                                          (orig name rel-to stx load?))))))))))))]
                         [(embedded-resolver)
                          (case-lambda 
                           [(name from-namespace)
                            ;; A notification
                            (if from-namespace
                              ;; If the source namespace has a mapping for `name',
                              ;; then copy it to the current namespace.
                              (let-values ([(name) (if name (resolved-module-path-name name) #f)])
                                (let-values ([(src-vec) (hash-ref regs (namespace-module-registry from-namespace) #f)])
                                  (let-values ([(a) (if src-vec
                                                        (assq name (vector-ref src-vec 0))
                                                        #f)])
                                    (if a
                                        (let-values ([(vec) (hash-ref regs (namespace-module-registry (current-namespace))
                                                                      (lambda ()
                                                                        (let-values ([(vec) (vector null null)])
                                                                          (hash-set! regs (namespace-module-registry (current-namespace)) vec)
                                                                          vec)))])
                                          ;; add mapping:
                                          (vector-set! vec 0 (cons a (vector-ref vec 0)))
                                          ;; add library mappings:
                                          (vector-set! vec 1 (append 
                                                              (letrec-values ([(loop)
                                                                               (lambda (l)
                                                                                 (if (null? l)
                                                                                     null
                                                                                     (if (eq? (cdar l) name)
                                                                                         (cons (car l) (loop (cdr l)))
                                                                                         (loop (cdr l)))))])
                                                                (loop library-table))
                                                              (vector-ref vec 1))))
                                        (void)))))
                              (void))
                            (orig name from-namespace)]
                           [(name rel-to stx load?)
                            (lookup name rel-to stx load? #f
                                    (lambda (name rel-to stx load?)
                                      ;; For a submodule, if we have a mapping for the base name,
                                      ;; then don't try the original handler.
                                      (let-values ([(base)
                                                    (if (pair? name)
                                                        (if (eq? (car name) 'submod)
                                                            ;; Pass #t for `for-submod?`, which causes a
                                                            ;; resolved module name to be returned for a quoted
                                                            ;; module name if we have any relative mappings for it:
                                                            (lookup (cadr name) rel-to stx load? #t (lambda (n r s l?) #f))
                                                            #f)
                                                        #f)])
                                        (if base
                                            ;; don't chain to `orig'; try `lookup` again with `(submod "." ...)`,
                                            ;; and if that still fails, just construct a submodule path:
                                            (lookup (cons 'submod (cons "." (cddr name))) base stx load? #f
                                                    (lambda (name rel-to stx load?)
                                                      (make-resolved-module-path
                                                       (cons (resolved-module-path-name base) (cddr name)))))
                                            ;; chain to `orig':
                                            (orig name rel-to stx load?)))))])])
           (current-module-name-resolver embedded-resolver))))))

(define (ss<->rkt path mk-full)
  (cond
   [(path-has-extension? path #".ss")
    (ss<->rkt (path-replace-extension path #".rkt") mk-full)]
   [(path-has-extension? path #".rkt")
    (define full-path (mk-full path))
    (if (file-exists? full-path)
        full-path
        (let ([p2 (mk-full (path-replace-extension path #".ss"))])
          (if (file-exists? p2)
              p2
              full-path)))]
   [else (mk-full path)]))

;; Write a module bundle that can be loaded with 'load' (do not embed it
;; into an executable). The bundle is written to the current output port.
(define (do-write-module-bundle outp verbose? modules 
                                early-literal-expressions config? literal-files literal-expressions 
                                collects-dest
                                on-extension program-name compiler expand-namespace 
                                src-filter get-extra-imports on-decls-done
				embedded-dlls-box)
  (let* ([program-name-bytes (if program-name
                                 (path->bytes program-name)
                                 #"?")]
         [module-paths (map cadr modules)]
         [use-submoduless (map (lambda (m) (if (pair? (cddr m)) (caddr m) '())) modules)]
         [resolve-one-path (lambda (mp)
                             (let ([f (resolve-module-path mp #f)])
                               (unless f
                                 (error 'write-module-bundle "bad module path: ~e" mp))
                               (normalize f)))]
         [files (map resolve-one-path module-paths)]
         [collapse-one (lambda (mp)
                         (collapse-module-path mp (build-path (current-directory) "dummy.rkt")))]
         [collapsed-mps (map collapse-one module-paths)]
         [gen-state (make-generate-file-mod-name-state (or (and (pair? files)
                                                                (let-values ([(base name dir) (split-path (car files))])
                                                                  base))
                                                           (current-directory)))]
         [file-mod-names (map (lambda (f m)
                                (cons f (let ([p (car m)]
                                              [f (strip-submod f)])
                                          (cond
                                            [(symbol? p) (format "~a~a" p (file-mod-name-base f))]
                                            [(eq? p #t) (generate-file-mod-name gen-state f)]
                                            [(not p) (file-mod-name-base f)]
                                            [else (error
                                                   'write-module-bundle
                                                   "bad prefix: ~e"
                                                   p)]))))
                              files modules)]
         ;; Each element is created with `make-mod'.
         ;; As we descend the module tree, we append to the front after
         ;; loading imports, so the list in the right order.
         [codes (box null)]
         [get-code-at (lambda (f mp submods)
                        (get-code f mp #f submods codes file-mod-names verbose? collects-dest
                                  on-extension compiler expand-namespace
                                  src-filter get-extra-imports
                                  (make-hash) gen-state))]
         [__
          ;; Load all code:
          (for-each get-code-at files collapsed-mps use-submoduless)]
         [config-infos (if config?
                           (let ([a (assoc (car files) (unbox codes))])
                             (let ([info (module-compiled-language-info (mod-code a))])
                               (and info
                                    (let ([get-info ((dynamic-require (vector-ref info 0) (vector-ref info 1))
                                                     (vector-ref info 2))])
                                      (get-info 'configure-runtime null)))))
                           null)])
    ;; Add module for runtime configuration:
    (when config-infos
      (for ([config-info (in-list config-infos)])
        (let ([mp (vector-ref config-info 0)])
          (get-code-at (resolve-one-path mp)
                       (collapse-one mp)
                       null))))
    ;; Drop elements of `codes' that just record copied libs:
    (set-box! codes (filter mod-code (unbox codes)))
    ;; As an accomodation to `raco demod`, make sure sibling modules of a top-level module
    ;; are reachable from each other, and submodules are reachable from the root,
    ;; because `raco demod` generates relative references directly (e.g., in bindings in
    ;; scopes in syntax objects) instead of going through a sequence of `require` paths:
    (saturate-immediate-submodule-mappings! (unbox codes))
    ;; Bind `module' to get started:
    (write (compile-using-kernel '(namespace-require '(only '#%kernel module))) outp)
    ;; Install a module name resolver that redirects
    ;; to the embedded modules
    (write (make-module-name-resolver (filter mod-code (unbox codes))) outp)
    (write (compile-using-kernel '(namespace-require ''#%resolver)) outp)
    ;; Write the extension table and copy module code:
    (let* ([l (reverse (unbox codes))]
           [extensions (filter (lambda (m) (extension? (mod-code m))) l)]
           [runtimes (filter (lambda (m) (pair? (mod-runtime-paths m))) l)]
           [table-mod
            (if (null? runtimes)
                #f
                (let* ([table-sym (module-path-index-resolve 
                                   (module-path-index-join '(lib "runtime-path-table.rkt" "racket" "private")
                                                           #f))]
                       [table-path (resolved-module-path-name table-sym)])
                  (assoc (normalize table-path) l)))])
      (unless (null? extensions)
        ;; The extension table:`
        (write 
         `(module #%extension-table '#%kernel
            (#%require '#%utils)
            (let-values ([(eXtEnSiOn-modules) ;; this name is magic for the exe->distribution process
                          (quote ,(map (lambda (m)
                                         (let ([p (extension-path (mod-code m))])
                                           (when verbose?
                                             (eprintf "Recording extension at ~s\n" p))
                                           (list (path->bytes p)
                                                 (mod-full-name m)
                                                 ;; The program name isn't used. It just helps ensures that
                                                 ;; there's plenty of room in the executable for patching
                                                 ;; the path later when making a distribution.
                                                 program-name-bytes)))
                                       extensions))])
              (for-each (lambda (pr)
                          (current-module-declare-name (make-resolved-module-path (cadr pr)))
                          (let-values ([(p) (bytes->path (car pr))])
                            (load-extension (if (relative-path? p)
                                                (let-values ([(d) (current-directory)])
                                                  (current-directory (find-system-path 'orig-dir))
                                                  (begin0
                                                   (let-values ([(p2) (find-executable-path (find-system-path 'exec-file) p #t)])
                                                     (if p2
                                                         p2
                                                         (path->complete-path p (current-directory))))
                                                   (current-directory d)))
                                                p))))
                        eXtEnSiOn-modules)))
         outp)
        (write (compile-using-kernel '(namespace-require ''#%extension-table)) outp))
      ;; Runtime-path table:
      (unless (null? runtimes)
        (unless table-mod
          (error 'create-embedding-executable "cannot find module for runtime-path table"))
        (write (compile-using-kernel
                `(current-module-declare-name (make-resolved-module-path 
                                               ',(mod-full-name table-mod))))
               outp)
        (write `(module runtime-path-table '#%kernel
                  (#%provide table)
                  (define-values (table)
                    (make-immutable-hash
                     (let-values ([(rUnTiMe-paths) ; this is a magic name for exe->distribution process
                                   ',(apply append
                                            (map (lambda (nc)
                                                   (map (lambda (p sym)
                                                          (list
                                                           (cons (mod-full-name nc)
                                                                 (if (path? p)
                                                                     (path->bytes p)
                                                                     (if (and (pair? p)
                                                                              (eq? 'module (car p)))
                                                                         (list 'module (let ([p (cadr p)])
                                                                                         (if (path? p)
                                                                                             `(path ,(encode-link-path p))
                                                                                             p)))
                                                                         p)))
                                                           (let ([p (cond
                                                                     [(bytes? p) (bytes->path p)]
                                                                     [(so-spec? p)
								      (define path (so-find p
                                                                                            (cross-system-type 'so-suffix)
                                                                                            (get-cross-lib-search-dirs)))
								      (cond
									[(and path embedded-dlls-box)
									 (set-box! embedded-dlls-box (cons path (unbox embedded-dlls-box)))
									 ;; Don't record the path in the executable since we'll
									 ;; record the whole DLL in the executable
									 #f]
									[else path])]
                                                                     [(share-spec? p) (share-find p)]
                                                                     [(and (list? p)
                                                                           (eq? 'lib (car p)))
                                                                      (let ([p (if (null? (cddr p))
                                                                                   (if (regexp-match #rx"^[^/]*[.]" (cadr p))
                                                                                       p
                                                                                       (let ([s (regexp-split #rx"/" (cadr p))])
                                                                                         (if (null? (cdr s))
                                                                                             `(lib "main.rkt" ,(cadr p))
                                                                                             (let ([s (reverse s)])
                                                                                               `(lib ,(car s) ,@(reverse (cdr s)))))))
                                                                                   p)])
                                                                        (ss<->rkt
                                                                         (cadr p)
                                                                         (lambda (file)
                                                                           (apply collection-file-path
                                                                                  file
                                                                                  (if (null? (cddr p))
                                                                                      (list "mzlib")
                                                                                      (cddr p))
                                                                                  #:check-compiled? #f))))]
                                                                     [(and (list? p)
                                                                           (eq? 'module (car p)))
                                                                      sym]
                                                                     [else p])])
                                                             (and p
                                                                  (if (symbol? p)
                                                                      p
                                                                      (path->bytes
                                                                       (simplify-path
                                                                        (if (absolute-path? p)
                                                                            p
                                                                            (build-path (path-only (mod-file nc)) p)))))))
                                                           ;; As for the extension table, a placeholder to save 
                                                           ;; room likely needed by the distribution-mangler.
                                                           ;; The extra "."s are meant to cover the relative
                                                           ;; path (even in Windows format) to runtime files,
                                                           ;; and the program name is also part of that path.
                                                           (bytes-append (make-bytes 32 (char->integer #\.)) program-name-bytes)))
                                                        (mod-runtime-paths nc)
                                                        (mod-runtime-module-syms nc)))
                                                 runtimes))])
                       rUnTiMe-paths))))
               outp))
      ;; Copy module code:
      (for-each
       (lambda (nc)
         (unless (or (extension? (mod-code nc))
                     (eq? nc table-mod))
           (when verbose?
             (eprintf "Writing module from ~s\n" (mod-file nc)))
           (write (compile-using-kernel
                   `(current-module-declare-name 
                     (make-resolved-module-path
                      ',(mod-full-name nc))))
                  outp)
           (if (mod-use-source? nc)
               (call-with-input-file* (mod-actual-file nc)
                 (lambda (inp)
                   (define bstr (port->bytes inp))
                   ;; The indirection through `compiler/private/read-bstr` ensures
                   ;; that the source module is delimited by an EOF:
                   (fprintf outp "#reader compiler/private/read-bstr ~s" bstr)))
               (write (mod-code nc) outp))))
       l))
    (write (compile-using-kernel '(current-module-declare-name #f)) outp)
    ;; Remove `module' binding before we start running user code:
    (write (compile-using-kernel '(namespace-set-variable-value! 'module #f #t)) outp)
    (write (compile-using-kernel '(namespace-undefine-variable! 'module)) outp)
    (on-decls-done outp)
    (newline outp)
    (for-each (lambda (v) (write v outp)) early-literal-expressions)
    (when config-infos
      (for ([config-info (in-list config-infos)])
        (let ([a (assoc (resolve-one-path (vector-ref config-info 0)) (unbox codes))])            
          (write (compile-using-kernel `((dynamic-require '',(mod-full-name a)
                                                          ',(vector-ref config-info 1))
                                         ',(vector-ref config-info 2)))
                 outp))))
    (for-each (lambda (f)
                (when verbose?
                  (eprintf "Copying from ~s\n" f))
                (call-with-input-file* f
                  (lambda (i)
                    (copy-port i outp))))
              literal-files)
    (for-each (lambda (v) (write v outp)) literal-expressions)))

(define (make-default-compiler expand-namespace)
  (lambda (expr)
    (parameterize ([current-namespace expand-namespace]
                   [current-compile-target-machine (get-compile-target-machine)])
      (compile expr))))

(define (write-module-bundle #:verbose? [verbose? #f]
                             #:modules [modules null]
                             #:configure-via-first-module? [config? #f]
                             #:literal-files [literal-files null]
                             #:early-literal-expressions [early-literal-expressions null]
                             #:literal-expressions [literal-expressions null]
                             #:on-extension [on-extension #f]
                             #:expand-namespace [expand-namespace (current-namespace)]
                             #:compiler [compiler (make-default-compiler expand-namespace)]
                             #:src-filter [src-filter (lambda (filename) #f)]
                             #:get-extra-imports [get-extra-imports (lambda (filename code) null)])
  (do-write-module-bundle (current-output-port) verbose? modules 
                          early-literal-expressions config? literal-files literal-expressions
                          #f ; collects-dest
                          on-extension
                          #f ; program-name 
                          compiler expand-namespace 
                          src-filter get-extra-imports
                          void
			  #f)) ; don't accumulate embedded DLLs

(define (cross-compiling?)
  (cross-multi-compile? (current-compiled-file-roots)))

(define (get-compile-target-machine)
  (if (cross-compiling?)
      (cross-system-type 'target-machine)
      (system-type 'target-machine)))


;; The old interface:
(define make-embedding-executable
  (lambda (dest mred? verbose? 
                modules 
                literal-files literal-expression
                cmdline
                [aux null]
                [launcher? #f]
                [variant (cross-system-type 'gc)]
                [collects-path #f])
    (create-embedding-executable dest
                                 #:mred? mred?
                                 #:verbose? verbose?
                                 #:modules modules
                                 #:literal-files literal-files
                                 #:literal-expression literal-expression
                                 #:cmdline cmdline
                                 #:aux aux
                                 #:launcher? launcher?
                                 #:variant variant
                                 #:collects-path collects-path)))

;; Use `write-module-bundle', but figure out how to put it into an executable
(define (create-embedding-executable dest
                                     #:mred? [really-mred? #f]
                                     #:gracket? [gracket? #f]
                                     #:verbose? [verbose? #f]
                                     #:modules [modules null]
                                     #:configure-via-first-module? [config? #f]
                                     #:literal-files [literal-files null]
                                     #:early-literal-expressions [early-literal-expressions null]
                                     #:literal-expression [literal-expression #f]
                                     #:literal-expressions [literal-expressions
                                                            (if literal-expression
                                                                (list literal-expression)
                                                                null)]
                                     #:cmdline [cmdline null]
                                     #:aux [aux null]
                                     #:launcher? [launcher? #f]
                                     #:variant [variant (cross-system-type 'gc)]
                                     #:collects-path [collects-path #f]
                                     #:collects-dest [collects-dest #f]
                                     #:on-extension [on-extension #f]
                                     #:expand-namespace [expand-namespace (current-namespace)]
                                     #:compiler [compiler (make-default-compiler expand-namespace)]
                                     #:src-filter [src-filter (lambda (filename) #f)]
                                     #:get-extra-imports [get-extra-imports (lambda (filename code) null)])
  (define mred? (or really-mred? gracket?))
  (define keep-exe? (and launcher?
                         (let ([m (assq 'forget-exe? aux)])
                           (or (not m)
                               (not (cdr m))))))
  (define unix-starter? (and (eq? (cross-system-type) 'unix)
                             (let ([m (assq 'original-exe? aux)])
                               (or (not m)
                                   (not (cdr m))))))
  (define long-cmdline? #t)
  (define relative? (let ([m (assq 'relative? aux)])
                      (and m (cdr m))))
  (define collects-path-bytes (collects-path->bytes 
                               ((if (and mred?
                                         (eq? 'macosx (cross-system-type)))
                                    mac-mred-collects-path-adjust
                                    values)
                                collects-path)))
  (define word-size (if (fixnum? (expt 2 32)) 8 4))
  (unless (or long-cmdline?
              ((apply +
                      (map (lambda (s)
                             (+ word-size (bytes-length (string->bytes/utf-8 s))))
                           cmdline)) . < . 80))
    (error 'create-embedding-executable "command line too long: ~e" cmdline))
  (check-collects-path 'create-embedding-executable collects-path collects-path-bytes)
  (let ([exe (find-exe #:cross? #t #:untethered? #t mred? variant)])
    (when verbose?
      (eprintf "Copying to ~s\n" dest))
    (let-values ([(dest-exe orig-exe osx?)
                  (cond
                    [(and mred? (eq? 'macosx (cross-system-type)))
                     (values (prepare-macosx-mred exe dest aux variant) 
                             (mac-dest->executable (find-in-lib "Starter.app")
                                                   #t)
                             #t)]
                    [unix-starter?
                     (let ([starter (find-in-lib (if (force exe-suffix?)
                                                     "starter.exe"
                                                     "starter"))])
                       (when (or (file-exists? dest)
                                 (directory-exists? dest)
                                 (link-exists? dest))
                         (delete-file dest))
                       (copy-file starter dest)
                       (values dest starter #f))]
                    [else
                     (when (or (file-exists? dest)
                               (directory-exists? dest)
                               (link-exists? dest))
                       ;; Delete-file isn't enough if the target
                       ;;  is supposed to be a directory. But
                       ;;  currently, that happens only for GRacket 
                       ;;  on Mac OS, which is handled above.
                       (delete-file dest))
                     (copy-file exe dest)
                     (values dest exe #f)])])
      (with-handlers ([void (lambda (x)
                              (if osx?
                                  (when (directory-exists? dest)
                                    (delete-directory/files dest))
                                  (when (file-exists? dest)
                                    (delete-file dest)))
                              (raise x))])
        (define old-perms (ensure-writable dest-exe))
        (when (and (eq? 'macosx (cross-system-type))
                   (not unix-starter?)
                   (get-current-framework-path (mac-dest->executable dest mred?) "Racket"))
          (remove-signature dest-exe) ;; best to do this before modifying the file in any other way
          (let ([m (or (assq 'framework-root aux)
                       (and relative? '(framework-root . #f)))])
            (if m
                (if (cdr m)
                    (update-framework-path (cdr m) 
                                           (mac-dest->executable dest mred?)
                                           mred?)
                    (when mred?
                      ;; adjust relative path, since exe may change directory :
                      (define rel (find-relative-path* dest (find-relevant-lib-dir "Racket.framework")))
                      (update-framework-path (format "@executable_path/../../../~a"
                                                     (path->directory-path rel))
                                             (mac-dest->executable dest mred?)
                                             #t)))
                ;; Check whether we need an absolute path to frameworks:
                (let ([dest (mac-dest->executable dest mred?)])
                  (when (regexp-match #rx"^@executable_path" 
                                      (get-current-framework-path dest "Racket"))
                    (update-framework-path (string-append
                                            (path->string (find-relevant-lib-dir "Racket.framework"))
                                            "/")
                                           dest
                                           mred?))))))
	(define embed-dlls? (and (eq? 'windows (cross-system-type))
				 (let ([m (assq 'embed-dlls? aux)])
				   (and m (cdr m)))))
	(define embedded-dlls-box (and embed-dlls? (box null)))
        (when (eq? 'windows (cross-system-type))
	  (cond
	    [embed-dlls?
	     (update-dll-dir dest #t)]
	    [else
	     (let ([m (or (assq 'dll-dir aux)
			  (and relative? '(dll-dir . #f)))])
	       (if m
		   (if (cdr m)
		       (update-dll-dir dest (cdr m))
		       ;; adjust relative path, since exe directory can change:
		       (update-dll-dir dest (find-relative-path* dest (find-cross-dll-dir))))
		   ;; Check whether we need an absolute path to DLLs:
		   (let ([dir (get-current-dll-dir dest)])
		     (when (relative-path? dir)
		       (let-values ([(orig-dir name dir?) (split-path 
							   (path->complete-path orig-exe))])
			 (update-dll-dir dest (build-path orig-dir dir)))))))]))
        (define (adjust-config-dir)
          (let ([m (or (assq 'config-dir aux)
                       (and relative? '(config-dir . #f)))]
                [dest->executable (lambda (dest)
                                    (if osx?
                                        (mac-dest->executable dest mred?)
                                        dest))])
            (define (gui-bin->config rel)
              ;; Find the path to config-dir relative to the executable
              (define p (find-relative-path* (if keep-exe? orig-exe dest) (find-config-dir)))
              (simplify-path
               (if (eq? rel 'same)
                   p
                   (build-path rel p))
               #f))
            (if m
                (if (cdr m)
                    (update-config-dir (dest->executable dest) (cdr m))
                    (when (and mred? (not keep-exe?))
                      (cond
                        [osx?
                         ;; adjust relative path (since GRacket is likely off by one):
                         (update-config-dir (mac-dest->executable dest mred?)
                                            (gui-bin->config "../../.."))]
                        [(eq? 'windows (cross-system-type))
                         ;; adjust relative path (since GRacket is likely off by one):
                         (update-config-dir dest (gui-bin->config 'same))]
                        [else
                         (update-config-dir dest (gui-bin->config 'same))])))
                ;; Check whether we need an absolute path to config:
                (let ([dir (get-current-config-dir (dest->executable dest))])
                  (when (relative-path? dir)
                    (let-values ([(orig-dir name dir?) (split-path 
                                                        (path->complete-path orig-exe))])
                      (update-config-dir (dest->executable dest)
                                         (build-path orig-dir dir))))))))
        (unless unix-starter? ; need to delay adjustment for Unix starter; see below
          (adjust-config-dir))
        (let ([write-module
               (lambda (s)
                 (define pos #f)
                 (do-write-module-bundle s
                                         verbose? modules 
                                         early-literal-expressions config? 
                                         literal-files literal-expressions collects-dest
                                         on-extension
                                         (file-name-from-path dest)
                                         compiler
                                         expand-namespace
                                         src-filter
                                         get-extra-imports
                                         (lambda (outp) (set! pos (file-position outp)))
					 embedded-dlls-box)
                 pos)]
		  [make-full-cmdline
		   (lambda (start decl-end end)
		     (let ([start-s (number->string start)]
			   [decl-end-s (number->string decl-end)]
                           [end-s (number->string end)])
		       (append (if launcher?
				   (if (and keep-exe?
                                            ;; a unix starter uses the same path as it execs
                                            (not unix-starter?))
				       ;; argv[0] replacement:
				       (list (path->string 
					      (if relative?
						  (relativize exe dest-exe values)
						  exe)))
				       ;; No argv[0]:
				       null)
				   (list "-k" start-s decl-end-s end-s))
			       cmdline)))]
		  [make-starter-cmdline
		   (lambda (full-cmdline)
		     (apply bytes-append
			    (map (lambda (s)
				   (bytes-append 
				    (cond
				     [(path? s) (path->bytes s)]
				     [else (string->bytes/locale s)])
				    #"\0"))
				 (append
				  (list (if relative?
					    (relativize exe dest-exe values)
					    exe)
					(let ([dir (find-cross-dll-dir)])
					  (if dir
					      (if relative?
						  (relativize dir dest-exe values)
						  dir)
					      "")))
				  full-cmdline))))]
              [write-cmdline
               (lambda (full-cmdline out)
                 (for-each
                  (lambda (s)
                    (fprintf out "~a~a~c"
                             (integer->integer-bytes 
                              (add1 (bytes-length (string->bytes/utf-8 s)) )
                              4 #t #f)
                             s
                             #\000))
                  full-cmdline)
                 (display "\0\0\0\0" out))])
          (let-values ([(start decl-end end cmdline-end)
                        (cond
                         [(eq? (cross-system-type) 'windows)
                          ;; Add as a resource
                          (define o (open-output-bytes))
                          (define decl-len (write-module o))
                          (define init-len (bytes-length (get-output-bytes o)))
                          (write-cmdline (make-full-cmdline 0 decl-len init-len) o)
                          (define bstr (get-output-bytes o))
                          (define cmdline-len (- (bytes-length bstr) init-len))
                          (define-values (pe rsrcs) (call-with-input-file*
                                                     dest-exe
                                                     read-pe+resources))
                          (define new-rsrcs (resource-set rsrcs
                                                          ;; Racket's "user-defined" type for excutable 
                                                          ;; plus command line:
                                                          257
                                                          1
                                                          1033 ; U.S. English
                                                          bstr))
                          (define new+dll-rsrcs
			    (if embed-dlls?
				(resource-set new-rsrcs
					      ;; Racket's "user-defined" type for embedded DLLs:
					      258
					      1
					      1033 ; U.S. English
					      (pack-embedded-dlls
					       (append
						(get-racket-dlls
						 (list
						  (case (cross-system-type 'gc)
						    [(3m) (if mred? 'gracket3m 'racket3m)]
						    [(cgc) (if mred? 'gracketcgc 'racketcgc)]
						    [(cs) (if mred? 'gracketcs 'racketcs)])))
						(unbox embedded-dlls-box))))
				new-rsrcs))
			  (update-resources dest-exe pe new+dll-rsrcs)
                          (values 0 decl-len init-len (+ init-len cmdline-len))]
                         [(memq (cross-system-type 'os*) '(macosx darwin))
                          ;; For Mach-O, we know how to add a proper segment
                          (remove-signature dest-exe) ; may be needed in 'darwin mode
                          (define s (open-output-bytes))
                          (define decl-len (write-module s))
                          (let* ([s (get-output-bytes s)]
                                 [cl (let ([o (open-output-bytes)])
                                       ;; position is relative to __PLTSCHEME:
                                       (let ([cmdline (make-full-cmdline 0 decl-len (bytes-length s))])
                                         (cond
                                           [unix-starter? (display (make-starter-cmdline cmdline) o)]
                                           [else (write-cmdline cmdline o)]))
                                       (get-output-bytes o))])
                            (let ([start (add-plt-segment 
                                          dest-exe 
                                          (bytes-append
                                           s
                                           cl))])
                              (let ([start 0]) ; i.e., relative to __PLTSCHEME
                                (values start
                                        (+ start decl-len)
                                        (+ start (bytes-length s))
                                        (+ start (bytes-length s) (bytes-length cl))))))]
                         [else
                          ;; Unix starter or direct embedding: Maybe ELF, in which case we 
                          ;; can add a proper section
                          (define-values (s e dl p)
                            (add-racket-section 
                             orig-exe 
                             dest-exe
                             #".rackprog"
                             (lambda (start)
                               (let ([s (open-output-bytes)])
                                 (define decl-len (write-module s))
                                 (let ([p (file-position s)])
				   (let ([cmdline (make-full-cmdline 0 decl-len p)])
				     (cond
				      [unix-starter? (display (make-starter-cmdline cmdline) s)]
				      [else (write-cmdline cmdline s)]))
                                   (values (get-output-bytes s) decl-len p))))))
                          (if (and s e)
                             ;; ELF succeeded, so make values relative to start:
                             (values 0 dl p (- e s))
                             ;; Otherwise, just add to the end of the file:
                             (let ([start (file-size dest-exe)])
                               (define decl-end
                                 (call-with-output-file* dest-exe write-module 
                                                         #:exists 'append))
                               (values start decl-end (file-size dest-exe) #f)))])])
            (when unix-starter?
              (adjust-config-dir))
            (when verbose?
              (eprintf "Setting command line\n"))
            (let ()
              (let ([full-cmdline (make-full-cmdline start decl-end end)])
                (cond
                 [collects-path-bytes
                  (when verbose?
                    (eprintf "Setting collection path\n"))
                  (set-collects-path dest-exe collects-path-bytes)]
                 [(and mred? (not keep-exe?))
                  (cond
                   [osx?
                    ;; default path in `gracket' is off by one:
                    (set-collects-path dest-exe (path->bytes
						 (build-path 'up 'up 'up
                                                             (find-relative-path* dest (find-collects-dir)))))]
                   [(eq? 'windows (cross-system-type))
                    ;; off by one in this case, too:
                    (set-collects-path dest-exe (path->bytes
                                                 (find-relative-path* dest (find-collects-dir))))])])
                (cond
                  [unix-starter?
                   (let ([numpos (with-input-from-file dest-exe 
                                   (lambda () (find-cmdline 
                                               "configuration"
                                               #"cOnFiG:")))]
                         [typepos (and (or mred? (or (eq? variant '3m)
                                                     (eq? variant 'cs)))
                                       (with-input-from-file dest-exe 
                                         (lambda () (find-cmdline 
                                                     "exeuctable type"
                                                     #"bINARy tYPe:"))))]
                         [cmdline (if cmdline-end
                                      #f
                                      (make-starter-cmdline full-cmdline))]
                         [out (open-output-file dest-exe #:exists 'update)])
                     (let ([old-cmdline-end cmdline-end]
                           [cmdline-end (or cmdline-end (+ end (bytes-length cmdline)))]
                           [write-num (lambda (n)
                                        (write-bytes (integer->integer-bytes n 4 #t #f) out))])
                       (dynamic-wind
                        void
                        (lambda ()
                          (when typepos
                            (when mred?
                              (file-position out (+ typepos 13))
                              (write-bytes #"r" out))
                            (when (eq? variant '3m)
                              (file-position out (+ typepos 15))
                              (write-bytes #"3" out))
                            (when (eq? variant 'cs)
                              (file-position out (+ typepos 15))
                              (write-bytes #"s" out))
                            (flush-output out))
                          (file-position out (+ numpos 7))
                          (write-bytes (if keep-exe? #"*" #"!") out)
                          (write-num start)
                          (write-num decl-end)
                          (write-num end)
                          (write-num cmdline-end)
                          (write-num (length full-cmdline))
                          (write-num (if mred? 1 0))
                          (flush-output out)
                          (unless old-cmdline-end
                            (file-position out end)
                            (write-bytes cmdline out)
                            (flush-output out)))
                        (lambda ()
                          (close-output-port out)))))]
                  [else
                   (let ([cmdpos (with-input-from-file dest-exe 
                                   (lambda () (find-cmdline 
                                               "cmdline"
                                               #"\\[Replace me for EXE hack")))]
                         [anotherpos (and mred?
                                          (eq? 'windows (cross-system-type))
                                          (let ([m (assq 'single-instance? aux)])
                                            (and m (not (cdr m))))
                                          (with-input-from-file dest-exe 
                                            (lambda () (find-cmdline 
                                                        "instance-check"
                                                        #"yes, please check for another"))))]
                         [out (open-output-file dest-exe #:exists 'update)]
                         [cmdline-done? cmdline-end])
                     (dynamic-wind
                      void
                      (lambda ()
                        (when anotherpos
                          (file-position out anotherpos)
                          (write-bytes #"no," out))
                        (if long-cmdline?
                            ;; write cmdline at end:
                            (unless cmdline-done?
                              (file-position out end))
                            (begin
                              ;; write (short) cmdline in the normal position:
                              (file-position out cmdpos)
                              (display "!" out)))
                        (unless cmdline-done?
                          (write-cmdline full-cmdline out))
                        (when long-cmdline?
                          ;; cmdline written at the end, in a resource, etc.;
                          ;; now put forwarding information at the normal cmdline pos
                          (let ([new-end (or cmdline-end
                                             (file-position out))])
                            (file-position out cmdpos)
                            (fprintf out "~a...~a~a"
                                     (if keep-exe? "*" "?")
                                     (integer->integer-bytes end 4 #t #f)
                                     (integer->integer-bytes (- new-end end) 4 #t #f)))))
                      (lambda ()
                        (close-output-port out)))
                     (let ([m (and (eq? 'windows (cross-system-type))
                                   (assq 'ico aux))])
                       (when m
                         (replace-all-icos (read-icos (cdr m)) dest-exe)))
                     (let ([m (and (eq? 'windows (cross-system-type))
                                   (assq 'subsystem aux))])
                       (when m
                         (set-subsystem dest-exe (cdr m)))))]))))
          (when (memq (cross-system-type 'os*) '(macosx darwin))
            (add-ad-hoc-signature dest-exe))
          (done-writable dest-exe old-perms))))))

;; For Mac OS GRacket, the actual executable is deep inside the
;;  nominal executable bundle
(define (mac-mred-collects-path-adjust p)
  (cond
    [(not p) #f]
    [(list? p) (map mac-mred-collects-path-adjust p)]
    [(relative-path? p) (build-path 'up 'up 'up p)]
    [else p]))

(define (find-relative-path* wrt-exe p)
  (define-values (wrt base name) (split-path (path->complete-path wrt-exe)))
  (find-relative-path (simplify-path wrt) (simplify-path p)))

;; To embed DLLs in the executable as resource ID 258:
(define (pack-embedded-dlls name-or-paths)
  (define bstrs (for/list ([p (in-list name-or-paths)])
		  (file->bytes (if (string? p)
				   (search-dll p)
				   p))))
  (define names (for/list ([p (in-list name-or-paths)])
		  (if (string? p)
		      p
		      (let-values ([(base name dir) (split-path p)])
			(path-element->string name)))))
  (define start-pos (+ 4 ; count
		       ;; name array:
		       (for/sum ([p (in-list names)])
			 (+ 2 (bytes-length (string->bytes/utf-8 p))))
		       ;; starting-position array:
		       (* 4 (add1 (length names)))))
  (define-values (rev-offsets total)
    (for/fold ([rev-offsets null] [total start-pos]) ([bstr (in-list bstrs)])
      (values (cons total rev-offsets)
	      (+ total (bytes-length bstr)))))
  (apply
   bytes-append
   (integer->integer-bytes (length names) 4 #t #f)
   (append
    (for/list ([p (in-list names)])
      (define bstr (string->bytes/utf-8 p))
      (bytes-append (integer->integer-bytes (bytes-length bstr) 2 #t #f) bstr))
    (for/list ([offset (in-list (reverse rev-offsets))])
      (integer->integer-bytes offset 4 #t #f))
    (list (integer->integer-bytes total 4 #t #f))
    bstrs)))

;; See note at call site for this function:
(define (saturate-immediate-submodule-mappings! mods)
  (define submods (make-hash)) ; root module name -> submod sym -> full name
  (define (immediate-submod? mp)
    (and (pair? mp)
         (eq? (car mp) 'submod)
         (pair? (cddr mp))
         (null? (cdddr mp))))
  (for ([m (in-list mods)])
    (define mp (mod-mod-path m))
    (when (immediate-submod? mp)
      (hash-update! submods (cadr mp)
                    (lambda (ht) (hash-set ht (caddr mp) (mod-full-name m)))
                    #hasheq())))
  (for ([m (in-list mods)])
    (define mp (mod-mod-path m))
    (define (add-submods! root-name make-submod-path)
      (define avail (for/hash ([m (in-list (mod-mappings m))])
                      (values (car m) #t)))
      (define additions
        (for/list ([(subm name) (in-hash (hash-ref submods root-name #hasheq()))]
                   #:do [(define rel-mp (make-submod-path subm))]
                   #:when (not (hash-ref avail rel-mp #f)))
          (cons rel-mp name)))
      (unless (null? additions)
        (define bx (mod-mappings-box m))
        (set-box! bx (append (unbox bx) additions))))
    (cond
      [(immediate-submod? mp)
       (add-submods! (cadr mp) (lambda (subm) `(submod ".." ,subm)))]
      [(not (and (pair? mp) (eq? (car mp) 'submod)))
       (add-submods! mp (lambda (subm) `(submod "." ,subm)))])))
