From 9f2755116dcff2a2792916eab09c50cb39113e94 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Tue, 17 Sep 2013 09:00:42 -0400 Subject: [PATCH] Remove units in parts of `compiler`, `dynext`, `setup` and create the `cext-lib` package. `cext-lib` contains much of the contents of `dynext`, which is no longer very widely used. Also moved the implementation of the `mzc` executable to a more appropriate package. Also, used `lazy-require` consistently for dynamically loading implementations. --- .../compiler/commands/ctool.rkt | 4 +- pkgs/cext-lib/compiler/commands/info.rkt | 4 + .../compiler/xform.rkt | 0 .../cext-lib}/dynext/compile-sig.rkt | 0 .../cext-lib}/dynext/compile-unit.rkt | 0 .../cext-lib}/dynext/compile.rkt | 0 pkgs/cext-lib/dynext/dynext-sig.rkt | 6 + pkgs/cext-lib/dynext/dynext-unit.rkt | 6 + .../cext-lib}/dynext/dynext.rkt | 4 +- .../cext-lib}/dynext/file-sig.rkt | 0 pkgs/cext-lib/dynext/file-unit.rkt | 7 + .../cext-lib}/dynext/link-sig.rkt | 0 .../cext-lib}/dynext/link-unit.rkt | 2 +- .../cext-lib}/dynext/link.rkt | 0 .../cext-lib}/dynext/main.rkt | 0 .../cext-lib}/dynext/private/cmdargs.rkt | 0 .../cext-lib}/dynext/private/dirs.rkt | 0 .../cext-lib}/dynext/private/stdio.rkt | 0 pkgs/cext-lib/info.rkt | 10 + pkgs/compiler-lib/compiler/commands/info.rkt | 1 - pkgs/compiler-lib/compiler/commands/make.rkt | 2 +- pkgs/compiler-lib/compiler/compiler-unit.rkt | 5 + pkgs/compiler-lib/compiler/compiler.rkt | 20 - .../compiler-lib}/compiler/embed-sig.rkt | 0 pkgs/compiler-lib/compiler/embed-unit.rkt | 9 + pkgs/compiler-lib/compiler/option-unit.rkt | 7 + pkgs/compiler-lib/compiler/option.rkt | 9 - .../compiler-lib}/compiler/sig.rkt | 0 .../compiler-lib}/launcher/launcher-sig.rkt | 0 pkgs/compiler-lib/launcher/launcher-unit.rkt | 7 + .../compiler-lib}/setup/option-sig.rkt | 0 pkgs/compiler-lib/setup/option-unit.rkt | 6 + pkgs/compiler-lib/setup/setup-unit.rkt | 9 + pkgs/drracket-pkgs/drracket-test/info.rkt | 2 + pkgs/make/info.rkt | 1 + .../compiler/main.rkt | 90 +- pkgs/racket-pkgs/racket-doc/info.rkt | 4 +- pkgs/racket-pkgs/racket-test/info.rkt | 2 + .../{compiler-unit.rkt => compiler.rkt} | 37 +- racket/collects/compiler/embed-unit.rkt | 1607 ---------------- racket/collects/compiler/embed.rkt | 1608 ++++++++++++++++- racket/collects/compiler/option-unit.rkt | 16 - racket/collects/compiler/option.rkt | 32 + racket/collects/dynext/dynext-sig.rkt | 7 - racket/collects/dynext/dynext-unit.rkt | 7 - racket/collects/dynext/file-unit.rkt | 64 - racket/collects/dynext/file.rkt | 71 +- racket/collects/file/gzip.rkt | 11 +- racket/collects/launcher/launcher-unit.rkt | 945 ---------- racket/collects/launcher/launcher.rkt | 998 +++++++++- racket/collects/setup/option-unit.rkt | 67 - racket/collects/setup/option.rkt | 71 + .../collects/setup/plt-single-installer.rkt | 3 +- .../setup/{setup-unit.rkt => setup-core.rkt} | 30 +- racket/collects/setup/setup-go.rkt | 59 +- racket/collects/setup/setup.rkt | 108 +- 56 files changed, 2987 insertions(+), 2971 deletions(-) rename pkgs/{compiler-lib => cext-lib}/compiler/commands/ctool.rkt (99%) create mode 100644 pkgs/cext-lib/compiler/commands/info.rkt rename pkgs/{compiler-lib => cext-lib}/compiler/xform.rkt (100%) rename {racket/collects => pkgs/cext-lib}/dynext/compile-sig.rkt (100%) rename {racket/collects => pkgs/cext-lib}/dynext/compile-unit.rkt (100%) rename {racket/collects => pkgs/cext-lib}/dynext/compile.rkt (100%) create mode 100644 pkgs/cext-lib/dynext/dynext-sig.rkt create mode 100644 pkgs/cext-lib/dynext/dynext-unit.rkt rename {racket/collects => pkgs/cext-lib}/dynext/dynext.rkt (52%) rename {racket/collects => pkgs/cext-lib}/dynext/file-sig.rkt (100%) create mode 100644 pkgs/cext-lib/dynext/file-unit.rkt rename {racket/collects => pkgs/cext-lib}/dynext/link-sig.rkt (100%) rename {racket/collects => pkgs/cext-lib}/dynext/link-unit.rkt (99%) rename {racket/collects => pkgs/cext-lib}/dynext/link.rkt (100%) rename {racket/collects => pkgs/cext-lib}/dynext/main.rkt (100%) rename {racket/collects => pkgs/cext-lib}/dynext/private/cmdargs.rkt (100%) rename {racket/collects => pkgs/cext-lib}/dynext/private/dirs.rkt (100%) rename {racket/collects => pkgs/cext-lib}/dynext/private/stdio.rkt (100%) create mode 100644 pkgs/cext-lib/info.rkt create mode 100644 pkgs/compiler-lib/compiler/compiler-unit.rkt delete mode 100644 pkgs/compiler-lib/compiler/compiler.rkt rename {racket/collects => pkgs/compiler-lib}/compiler/embed-sig.rkt (100%) create mode 100644 pkgs/compiler-lib/compiler/embed-unit.rkt create mode 100644 pkgs/compiler-lib/compiler/option-unit.rkt delete mode 100644 pkgs/compiler-lib/compiler/option.rkt rename {racket/collects => pkgs/compiler-lib}/compiler/sig.rkt (100%) rename {racket/collects => pkgs/compiler-lib}/launcher/launcher-sig.rkt (100%) create mode 100644 pkgs/compiler-lib/launcher/launcher-unit.rkt rename {racket/collects => pkgs/compiler-lib}/setup/option-sig.rkt (100%) create mode 100644 pkgs/compiler-lib/setup/option-unit.rkt create mode 100644 pkgs/compiler-lib/setup/setup-unit.rkt rename pkgs/{compiler-lib => mzscheme}/compiler/main.rkt (91%) rename racket/collects/compiler/{compiler-unit.rkt => compiler.rkt} (94%) delete mode 100644 racket/collects/compiler/embed-unit.rkt delete mode 100644 racket/collects/compiler/option-unit.rkt create mode 100644 racket/collects/compiler/option.rkt delete mode 100644 racket/collects/dynext/dynext-sig.rkt delete mode 100644 racket/collects/dynext/dynext-unit.rkt delete mode 100644 racket/collects/dynext/file-unit.rkt delete mode 100644 racket/collects/launcher/launcher-unit.rkt delete mode 100644 racket/collects/setup/option-unit.rkt create mode 100644 racket/collects/setup/option.rkt rename racket/collects/setup/{setup-unit.rkt => setup-core.rkt} (99%) diff --git a/pkgs/compiler-lib/compiler/commands/ctool.rkt b/pkgs/cext-lib/compiler/commands/ctool.rkt similarity index 99% rename from pkgs/compiler-lib/compiler/commands/ctool.rkt rename to pkgs/cext-lib/compiler/commands/ctool.rkt index 210f241d9b..a3968d76da 100644 --- a/pkgs/compiler-lib/compiler/commands/ctool.rkt +++ b/pkgs/cext-lib/compiler/commands/ctool.rkt @@ -5,8 +5,8 @@ (error-print-width 512) -(require (prefix-in compiler:option: "../option.rkt") - "../compiler.rkt" +(require (prefix-in compiler:option: compiler/option) + compiler/compiler raco/command-name racket/cmdline dynext/file diff --git a/pkgs/cext-lib/compiler/commands/info.rkt b/pkgs/cext-lib/compiler/commands/info.rkt new file mode 100644 index 0000000000..2acc69e1f9 --- /dev/null +++ b/pkgs/cext-lib/compiler/commands/info.rkt @@ -0,0 +1,4 @@ +#lang info + +(define raco-commands + '(("ctool" compiler/commands/ctool "compile and link C-based extensions" #f))) diff --git a/pkgs/compiler-lib/compiler/xform.rkt b/pkgs/cext-lib/compiler/xform.rkt similarity index 100% rename from pkgs/compiler-lib/compiler/xform.rkt rename to pkgs/cext-lib/compiler/xform.rkt diff --git a/racket/collects/dynext/compile-sig.rkt b/pkgs/cext-lib/dynext/compile-sig.rkt similarity index 100% rename from racket/collects/dynext/compile-sig.rkt rename to pkgs/cext-lib/dynext/compile-sig.rkt diff --git a/racket/collects/dynext/compile-unit.rkt b/pkgs/cext-lib/dynext/compile-unit.rkt similarity index 100% rename from racket/collects/dynext/compile-unit.rkt rename to pkgs/cext-lib/dynext/compile-unit.rkt diff --git a/racket/collects/dynext/compile.rkt b/pkgs/cext-lib/dynext/compile.rkt similarity index 100% rename from racket/collects/dynext/compile.rkt rename to pkgs/cext-lib/dynext/compile.rkt diff --git a/pkgs/cext-lib/dynext/dynext-sig.rkt b/pkgs/cext-lib/dynext/dynext-sig.rkt new file mode 100644 index 0000000000..d4bc8b9d18 --- /dev/null +++ b/pkgs/cext-lib/dynext/dynext-sig.rkt @@ -0,0 +1,6 @@ +(module dynext-sig racket/base + + (require "compile-sig.rkt" "link-sig.rkt") + + (provide (all-from-out "compile-sig.rkt") + (all-from-out "link-sig.rkt"))) diff --git a/pkgs/cext-lib/dynext/dynext-unit.rkt b/pkgs/cext-lib/dynext/dynext-unit.rkt new file mode 100644 index 0000000000..249f0d0d3f --- /dev/null +++ b/pkgs/cext-lib/dynext/dynext-unit.rkt @@ -0,0 +1,6 @@ +#lang racket/base + +(require "compile-unit.rkt" "link-unit.rkt") + +(provide (all-from-out "compile-unit.rkt") + (all-from-out "link-unit.rkt")) diff --git a/racket/collects/dynext/dynext.rkt b/pkgs/cext-lib/dynext/dynext.rkt similarity index 52% rename from racket/collects/dynext/dynext.rkt rename to pkgs/cext-lib/dynext/dynext.rkt index 25cde65819..200c89b8ce 100644 --- a/racket/collects/dynext/dynext.rkt +++ b/pkgs/cext-lib/dynext/dynext.rkt @@ -1,7 +1,7 @@ #lang racket/base -(require "compile.rkt" "link.rkt" "file.rkt") +(require "compile.rkt" "link.rkt" dynext/file) (provide (all-from-out "compile.rkt") (all-from-out "link.rkt") - (all-from-out "file.rkt")) + (all-from-out dynext/file)) diff --git a/racket/collects/dynext/file-sig.rkt b/pkgs/cext-lib/dynext/file-sig.rkt similarity index 100% rename from racket/collects/dynext/file-sig.rkt rename to pkgs/cext-lib/dynext/file-sig.rkt diff --git a/pkgs/cext-lib/dynext/file-unit.rkt b/pkgs/cext-lib/dynext/file-unit.rkt new file mode 100644 index 0000000000..be35c903f0 --- /dev/null +++ b/pkgs/cext-lib/dynext/file-unit.rkt @@ -0,0 +1,7 @@ +#lang racket/base + +(require racket/unit "file-sig.rkt" dynext/file) + +(provide dynext:file@) + +(define-unit-from-context dynext:file@ dynext:file^) diff --git a/racket/collects/dynext/link-sig.rkt b/pkgs/cext-lib/dynext/link-sig.rkt similarity index 100% rename from racket/collects/dynext/link-sig.rkt rename to pkgs/cext-lib/dynext/link-sig.rkt diff --git a/racket/collects/dynext/link-unit.rkt b/pkgs/cext-lib/dynext/link-unit.rkt similarity index 99% rename from racket/collects/dynext/link-unit.rkt rename to pkgs/cext-lib/dynext/link-unit.rkt index 610c785d19..56d3cfe33a 100644 --- a/racket/collects/dynext/link-unit.rkt +++ b/pkgs/cext-lib/dynext/link-unit.rkt @@ -4,7 +4,7 @@ "private/dirs.rkt" "private/stdio.rkt" "private/cmdargs.rkt" - "filename-version.rkt") + dynext/filename-version) (require "link-sig.rkt") diff --git a/racket/collects/dynext/link.rkt b/pkgs/cext-lib/dynext/link.rkt similarity index 100% rename from racket/collects/dynext/link.rkt rename to pkgs/cext-lib/dynext/link.rkt diff --git a/racket/collects/dynext/main.rkt b/pkgs/cext-lib/dynext/main.rkt similarity index 100% rename from racket/collects/dynext/main.rkt rename to pkgs/cext-lib/dynext/main.rkt diff --git a/racket/collects/dynext/private/cmdargs.rkt b/pkgs/cext-lib/dynext/private/cmdargs.rkt similarity index 100% rename from racket/collects/dynext/private/cmdargs.rkt rename to pkgs/cext-lib/dynext/private/cmdargs.rkt diff --git a/racket/collects/dynext/private/dirs.rkt b/pkgs/cext-lib/dynext/private/dirs.rkt similarity index 100% rename from racket/collects/dynext/private/dirs.rkt rename to pkgs/cext-lib/dynext/private/dirs.rkt diff --git a/racket/collects/dynext/private/stdio.rkt b/pkgs/cext-lib/dynext/private/stdio.rkt similarity index 100% rename from racket/collects/dynext/private/stdio.rkt rename to pkgs/cext-lib/dynext/private/stdio.rkt diff --git a/pkgs/cext-lib/info.rkt b/pkgs/cext-lib/info.rkt new file mode 100644 index 0000000000..368314d38d --- /dev/null +++ b/pkgs/cext-lib/info.rkt @@ -0,0 +1,10 @@ +#lang info +(define collection 'multi) +(define deps '("base" + "compiler-lib" + "scheme-lib" + "rackunit-lib")) + +(define pkg-desc "Tools for managing C extensions, such as `raco ctool`") + +(define pkg-authors '(mflatt)) diff --git a/pkgs/compiler-lib/compiler/commands/info.rkt b/pkgs/compiler-lib/compiler/commands/info.rkt index a3f02f0725..1b766b6c9f 100644 --- a/pkgs/compiler-lib/compiler/commands/info.rkt +++ b/pkgs/compiler-lib/compiler/commands/info.rkt @@ -9,5 +9,4 @@ ("test" compiler/commands/test "run tests associated with files/directories" 15) ("expand" compiler/commands/expand "macro-expand source" #f) ("distribute" compiler/commands/exe-dir "prepare executable(s) in a directory for distribution" #f) - ("ctool" compiler/commands/ctool "compile and link C-based extensions" #f) ("demodularize" compiler/demodularizer/batch "produce a whole program from a single module" #f))) diff --git a/pkgs/compiler-lib/compiler/commands/make.rkt b/pkgs/compiler-lib/compiler/commands/make.rkt index 622353ac7b..b998b0e7c8 100644 --- a/pkgs/compiler-lib/compiler/commands/make.rkt +++ b/pkgs/compiler-lib/compiler/commands/make.rkt @@ -2,7 +2,7 @@ (require scheme/cmdline raco/command-name compiler/cm - "../compiler.rkt" + compiler/compiler dynext/file setup/parallel-build racket/match) diff --git a/pkgs/compiler-lib/compiler/compiler-unit.rkt b/pkgs/compiler-lib/compiler/compiler-unit.rkt new file mode 100644 index 0000000000..4f6b768420 --- /dev/null +++ b/pkgs/compiler-lib/compiler/compiler-unit.rkt @@ -0,0 +1,5 @@ +#lang racket/base + +(require compiler/compiler compiler/sig racket/unit) +(provide compiler@) +(define-unit-from-context compiler@ compiler^) \ No newline at end of file diff --git a/pkgs/compiler-lib/compiler/compiler.rkt b/pkgs/compiler-lib/compiler/compiler.rkt deleted file mode 100644 index d74daba7c4..0000000000 --- a/pkgs/compiler-lib/compiler/compiler.rkt +++ /dev/null @@ -1,20 +0,0 @@ -(module compiler racket/base - (require racket/unit) - - (require compiler/sig) - - (require dynext/compile-sig) - (require dynext/link-sig) - (require dynext/file-sig) - ;; - (require dynext/compile) - (require dynext/link) - (require dynext/file) - - (require "option.rkt") - - (require compiler/compiler-unit) - - (define-values/invoke-unit/infer compiler@) - - (provide-signature-elements compiler^)) diff --git a/racket/collects/compiler/embed-sig.rkt b/pkgs/compiler-lib/compiler/embed-sig.rkt similarity index 100% rename from racket/collects/compiler/embed-sig.rkt rename to pkgs/compiler-lib/compiler/embed-sig.rkt diff --git a/pkgs/compiler-lib/compiler/embed-unit.rkt b/pkgs/compiler-lib/compiler/embed-unit.rkt new file mode 100644 index 0000000000..6361ca61cd --- /dev/null +++ b/pkgs/compiler-lib/compiler/embed-unit.rkt @@ -0,0 +1,9 @@ +#lang racket/base +(require racket/unit + racket/contract + "sig.rkt" + compiler/embed + "embed-sig.rkt") + +(define-unit-from-context compiler:embed@ compiler:embed^) +(provide compiler:embed@) diff --git a/pkgs/compiler-lib/compiler/option-unit.rkt b/pkgs/compiler-lib/compiler/option-unit.rkt new file mode 100644 index 0000000000..c0f42328b5 --- /dev/null +++ b/pkgs/compiler-lib/compiler/option-unit.rkt @@ -0,0 +1,7 @@ +#lang racket/base + +(require racket/unit compiler/sig compiler/option) + +(provide compiler:option@) + +(define-unit-from-context compiler:option@ compiler:option^) diff --git a/pkgs/compiler-lib/compiler/option.rkt b/pkgs/compiler-lib/compiler/option.rkt deleted file mode 100644 index 1f0e166b30..0000000000 --- a/pkgs/compiler-lib/compiler/option.rkt +++ /dev/null @@ -1,9 +0,0 @@ -(module option racket/base - (require racket/unit) - - (require compiler/sig - compiler/option-unit) - - (define-values/invoke-unit/infer compiler:option@) - - (provide-signature-elements compiler:option^)) diff --git a/racket/collects/compiler/sig.rkt b/pkgs/compiler-lib/compiler/sig.rkt similarity index 100% rename from racket/collects/compiler/sig.rkt rename to pkgs/compiler-lib/compiler/sig.rkt diff --git a/racket/collects/launcher/launcher-sig.rkt b/pkgs/compiler-lib/launcher/launcher-sig.rkt similarity index 100% rename from racket/collects/launcher/launcher-sig.rkt rename to pkgs/compiler-lib/launcher/launcher-sig.rkt diff --git a/pkgs/compiler-lib/launcher/launcher-unit.rkt b/pkgs/compiler-lib/launcher/launcher-unit.rkt new file mode 100644 index 0000000000..165362229c --- /dev/null +++ b/pkgs/compiler-lib/launcher/launcher-unit.rkt @@ -0,0 +1,7 @@ +#lang racket/base + +(require racket/unit "launcher-sig.rkt" launcher/launcher) + +(provide launcher@) + +(define-unit-from-context launcher@ launcher^) diff --git a/racket/collects/setup/option-sig.rkt b/pkgs/compiler-lib/setup/option-sig.rkt similarity index 100% rename from racket/collects/setup/option-sig.rkt rename to pkgs/compiler-lib/setup/option-sig.rkt diff --git a/pkgs/compiler-lib/setup/option-unit.rkt b/pkgs/compiler-lib/setup/option-unit.rkt new file mode 100644 index 0000000000..1b36be3f1d --- /dev/null +++ b/pkgs/compiler-lib/setup/option-unit.rkt @@ -0,0 +1,6 @@ +#lang racket/base +(require racket/unit setup/option "option-sig.rkt") + +(provide setup:option@ set-flag-params) + +(define-unit-from-context setup:option@ setup-option^) \ No newline at end of file diff --git a/pkgs/compiler-lib/setup/setup-unit.rkt b/pkgs/compiler-lib/setup/setup-unit.rkt new file mode 100644 index 0000000000..addfd12088 --- /dev/null +++ b/pkgs/compiler-lib/setup/setup-unit.rkt @@ -0,0 +1,9 @@ +#lang racket/base + +(require racket/unit setup/setup-core) + +(provide setup@) +(define-unit setup@ + (import) + (export) + (setup-core)) diff --git a/pkgs/drracket-pkgs/drracket-test/info.rkt b/pkgs/drracket-pkgs/drracket-test/info.rkt index 24202aa912..cf6112e68b 100644 --- a/pkgs/drracket-pkgs/drracket-test/info.rkt +++ b/pkgs/drracket-pkgs/drracket-test/info.rkt @@ -11,6 +11,8 @@ "compatibility-lib" "gui-lib" "htdp" + "compiler-lib" + "cext-lib" "scribble-lib" "string-constants-lib")) diff --git a/pkgs/make/info.rkt b/pkgs/make/info.rkt index 148909f827..9707986d34 100644 --- a/pkgs/make/info.rkt +++ b/pkgs/make/info.rkt @@ -5,6 +5,7 @@ (define scribblings '(("make.scrbl" (multi-page) (tool-library)))) (define deps '("scheme-lib" "base" + "cext-lib" "compiler-lib" "compatibility-lib")) (define build-deps '("racket-doc" diff --git a/pkgs/compiler-lib/compiler/main.rkt b/pkgs/mzscheme/compiler/main.rkt similarity index 91% rename from pkgs/compiler-lib/compiler/main.rkt rename to pkgs/mzscheme/compiler/main.rkt index ece555c080..bb9fe2a3b2 100644 --- a/pkgs/compiler-lib/compiler/main.rkt +++ b/pkgs/mzscheme/compiler/main.rkt @@ -22,17 +22,30 @@ (error-print-width 512) (require (prefix-in compiler:option: compiler/option) - "compiler.rkt") + compiler/compiler) ;; Read argv array for arguments and input file name (require racket/cmdline dynext/file - dynext/compile - dynext/link scheme/pretty setup/pack setup/getinfo - setup/dirs) + setup/dirs + racket/lazy-require) + +(lazy-require [dynext/compile (use-standard-compiler get-standard-compilers current-extension-compiler + current-extension-compiler-flags current-extension-preprocess-flags + compile-variant compile-extension)] + [dynext/link (use-standard-linker expand-for-link-variant current-extension-linker + current-extension-linker-flags current-standard-link-libraries + link-variant link-extension)] + [compiler/cm (managed-compile-zo manager-compile-notify-handler manager-trace-handler)] + [compiler/xform (xform)] + [compiler/distribute (assemble-distribution)] + [compiler/zo-parse (zo-parse)] + [compiler/private/embed (mzc:embedding-executable-add-suffix write-module-bundle + mzc:create-embedding-executable)] + [compiler/decompile (decompile)]) (define dest-dir (make-parameter #f)) (define auto-dest-dir (make-parameter #f)) @@ -363,6 +376,11 @@ (define-values (mode source-files prefix) (parse-options (current-command-line-arguments))) +(define (compiler-warning) + (eprintf "Warning: ~a\n ~a\n" + "compilation to C is usually less effective for performance" + "than relying on the bytecode just-in-time compiler.")) + (when (compiler:option:somewhat-verbose) (printf "mzc v~a [~a], Copyright (c) 2004-2013 PLT Design Inc.\n" (version) @@ -375,11 +393,6 @@ (begin (link-variant '3m) (compile-variant '3m)) (begin (link-variant 'cgc) (compile-variant 'cgc))) -(define (compiler-warning) - (eprintf "Warning: ~a\n ~a\n" - "compilation to C is usually less effective for performance" - "than relying on the bytecode just-in-time compiler.")) - (case mode [(zo) ((compile-zos prefix #:verbose? (compiler:option:somewhat-verbose)) @@ -402,34 +415,31 @@ (pretty-print (syntax->datum (expand e))) (loop))))))))))] [(decompile) - (let ([zo-parse (dynamic-require 'compiler/zo-parse 'zo-parse)] - [decompile (dynamic-require 'compiler/decompile 'decompile)]) - (for ([zo-file source-files]) - (let ([zo-file (path->complete-path zo-file)]) - (let-values ([(base name dir?) (split-path zo-file)]) - (let ([alt-file (build-path base "compiled" (path-add-suffix name #".zo"))]) - (parameterize ([current-load-relative-directory base] - [print-graph #t]) - (pretty-print - (decompile - (call-with-input-file* - (if (file-exists? alt-file) alt-file zo-file) - (lambda (in) - (zo-parse in)))))))))))] + (for ([zo-file source-files]) + (let ([zo-file (path->complete-path zo-file)]) + (let-values ([(base name dir?) (split-path zo-file)]) + (let ([alt-file (build-path base "compiled" (path-add-suffix name #".zo"))]) + (parameterize ([current-load-relative-directory base] + [print-graph #t]) + (pretty-print + (decompile + (call-with-input-file* + (if (file-exists? alt-file) alt-file zo-file) + (lambda (in) + (zo-parse in))))))))))] [(make-zo) (let ([n (make-base-empty-namespace)] - [mc (dynamic-require 'compiler/cm 'managed-compile-zo)] - [cnh (dynamic-require 'compiler/cm 'manager-compile-notify-handler)] - [cth (dynamic-require 'compiler/cm 'manager-trace-handler)] [did-one? #f]) (parameterize ([current-namespace n] - [cth (lambda (p) - (when (compiler:option:verbose) - (printf " ~a\n" p)))] - [cnh (lambda (p) - (set! did-one? #t) - (when (compiler:option:somewhat-verbose) - (printf " making ~s\n" (path->string p))))]) + [manager-trace-handler + (lambda (p) + (when (compiler:option:verbose) + (printf " ~a\n" p)))] + [manager-compile-notify-handler + (lambda (p) + (set! did-one? #t) + (when (compiler:option:somewhat-verbose) + (printf " making ~s\n" (path->string p))))]) (for ([file source-files]) (unless (file-exists? file) (error 'mzc "file does not exist: ~a" file)) @@ -439,7 +449,7 @@ (printf "\"~a\":\n" file)) (parameterize ([compile-context-preservation-enabled (disable-inlining)]) - (mc file)) + (managed-compile-zo file)) (let ([dest (append-zo-suffix (let-values ([(base name dir?) (split-path file)]) (build-path (if (symbol? base) 'same base) @@ -487,7 +497,7 @@ [out-file (if (dest-dir) (build-path (dest-dir) out-file) out-file)]) - ((dynamic-require 'compiler/xform 'xform) + (xform (not (compiler:option:verbose)) file out-file @@ -498,12 +508,10 @@ (unless (= 1 (length source-files)) (error 'mzc "expected a single module source file to embed; given: ~e" source-files)) - (let ([dest ((dynamic-require 'compiler/private/embed - 'mzc:embedding-executable-add-suffix) + (let ([dest (mzc:embedding-executable-add-suffix (exe-output) (eq? mode 'gui-exe))]) - ((dynamic-require 'compiler/private/embed - 'mzc:create-embedding-executable) + (mzc:create-embedding-executable dest #:mred? (eq? mode 'gui-exe) #:variant (if (compiler:option:3m) '3m 'cgc) @@ -531,7 +539,7 @@ (let ([dest (mods-output)]) (let-values ([(in out) (make-pipe)]) (parameterize ([current-output-port out]) - ((dynamic-require 'compiler/embed 'write-module-bundle) + (write-module-bundle #:modules (append (map (lambda (l) `(#f (file ,l))) source-files) (map (lambda (l) `(#t (lib ,l))) (exe-embedded-libraries))))) @@ -567,7 +575,7 @@ (when (compiler:option:somewhat-verbose) (printf " [output to \"~a\"]\n" dest)))] [(exe-dir) - ((dynamic-require 'compiler/distribute 'assemble-distribution) + (assemble-distribution (exe-dir-output) source-files #:collects-path (exe-embedded-collects-path) diff --git a/pkgs/racket-pkgs/racket-doc/info.rkt b/pkgs/racket-pkgs/racket-doc/info.rkt index d5d2a970f8..add07bc8a7 100644 --- a/pkgs/racket-pkgs/racket-doc/info.rkt +++ b/pkgs/racket-pkgs/racket-doc/info.rkt @@ -16,6 +16,7 @@ "errortrace-doc" "typed-racket-doc" "unstable" + "compiler-lib" "at-exp-lib" "data-lib" "pconvert-lib" @@ -40,7 +41,8 @@ "compatibility-lib" "future-visualizer" "distributed-places-doc" - "serialize-cstruct-lib")) + "serialize-cstruct-lib" + "cext-lib")) (define pkg-desc "Base Racket documentation") diff --git a/pkgs/racket-pkgs/racket-test/info.rkt b/pkgs/racket-pkgs/racket-test/info.rkt index 8d0163cdb0..428652cc6d 100644 --- a/pkgs/racket-pkgs/racket-test/info.rkt +++ b/pkgs/racket-pkgs/racket-test/info.rkt @@ -23,6 +23,8 @@ "typed-racket-lib" "serialize-cstruct-lib" + "cext-lib" + ;; for random testing: "redex-lib")) diff --git a/racket/collects/compiler/compiler-unit.rkt b/racket/collects/compiler/compiler.rkt similarity index 94% rename from racket/collects/compiler/compiler-unit.rkt rename to racket/collects/compiler/compiler.rkt index d91ea2f08a..bc81f811f0 100644 --- a/racket/collects/compiler/compiler-unit.rkt +++ b/racket/collects/compiler/compiler.rkt @@ -2,41 +2,29 @@ ;; Main compilation procedures ;; (c) 1997-2013 PLT Design Inc. -;; The various procedures provided by this library are implemented -;; by dynamically linking to code supplied by the MzLib, dynext, and -;; compiler collections. - - -(require racket/unit - - "sig.rkt" - dynext/file-sig - dynext/link-sig - dynext/compile-sig - - syntax/toplevel +(require syntax/toplevel syntax/moddep - + dynext/file racket/file compiler/compile-file compiler/cm + compiler/option setup/getinfo setup/main-collects setup/private/omitted-paths) -(provide compiler@) +(provide compile-zos + + compile-collection-zos + compile-directory-zos + compile-directory-srcs + + current-compiler-dynamic-require-wrapper + compile-notify-handler) (define-namespace-anchor anchor) (define orig-namespace (namespace-anchor->empty-namespace anchor)) -;; ;;;;;;;; ----- The main compiler unit ------ ;;;;;;;;;; -(define-unit compiler@ - (import compiler:option^ - dynext:compile^ - dynext:link^ - dynext:file^) - (export compiler^) - (define compile-notify-handler (make-parameter void)) @@ -98,7 +86,7 @@ file)) source-files)) (for ([f source-files] [b file-bases]) - (let ([zo (append-zo-suffix b)]) + (let ([zo (path-add-suffix b #".zo")]) (compile-to-zo f zo n prefix verbose? mod?))))) (define (compile-directory-visitor dir info worker omit-root @@ -214,4 +202,3 @@ (define compile-directory-zos compile-directory) (define compile-directory-srcs get-compile-directory-srcs) - ) diff --git a/racket/collects/compiler/embed-unit.rkt b/racket/collects/compiler/embed-unit.rkt deleted file mode 100644 index 0c1ace3346..0000000000 --- a/racket/collects/compiler/embed-unit.rkt +++ /dev/null @@ -1,1607 +0,0 @@ -(module embed-unit racket/base - (require racket/unit - racket/path - racket/file - racket/port - racket/promise - racket/list - syntax/moddep - syntax/modcollapse - xml/plist - setup/dirs - setup/variant - "embed-sig.rkt" - file/ico - "private/winsubsys.rkt" - "private/macfw.rkt" - "private/mach-o.rkt" - "private/elf.rkt" - "private/windlldir.rkt" - "private/collects-path.rkt" - "private/configdir.rkt" - "find-exe.rkt") - - (provide compiler:embed@) - - (define-unit compiler:embed@ - (import) - (export compiler:embed^) - - (define (embedding-executable-is-directory? mred?) - #f) - - (define (embedding-executable-is-actually-directory? mred?) - (and mred? (eq? 'macosx (system-type)))) - - (define (embedding-executable-put-file-extension+style+filters mred?) - (case (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-replace-suffix path sfx)))]) - (case (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-suffix name #""))) - dest)) - - (define exe-suffix? - (delay (equal? #"i386-cygwin" (path->bytes (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 (prepare-macosx-mred exec-name dest aux variant) - (let* ([name (let-values ([(base name dir?) (split-path dest)]) - (path-replace-suffix name #""))] - [src (build-path (find-lib-dir) "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))))) - (call-with-output-file (build-path dest - "Contents" - "PkgInfo") - #:exists 'truncate - (lambda (port) - (fprintf port "APPL~a" creator))) - (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))) - - ;; The starter-info file is now disabled. The GRacket - ;; command line is handled the same as the Racket command - ;; line. - (define use-starter-info? #f) - (define (finish-osx-mred dest flags exec-name keep-exe? relative?) - (call-with-output-file (build-path dest - "Contents" - "Resources" - "starter-info") - #:exists 'truncate - (lambda (port) - (write-plist - `(dict ,@(if keep-exe? - `((assoc-pair "executable name" - ,(path->string - (if relative? - (relativize exec-name dest - (lambda (p) - (build-path 'up 'up 'up p))) - exec-name)))) - null) - (assoc-pair "stored arguments" - (array ,@flags))) - port)))) - - ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - ;; Represent modules with lists starting with the filename, so we - ;; can use assoc: - (define (make-mod normal-file-path normal-module-path - code name prefix full-name relative-mappings-box - runtime-paths runtime-module-syms - actual-file-path) - (list normal-file-path normal-module-path code - name prefix full-name relative-mappings-box - runtime-paths runtime-module-syms - actual-file-path)) - - (define (mod-file m) (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-prefix m) (list-ref m 4)) - (define (mod-full-name m) (list-ref m 5)) - (define (mod-mappings m) (unbox (list-ref m 6))) - (define (mod-runtime-paths m) (list-ref m 7)) - (define (mod-runtime-module-syms m) (list-ref m 8)) - (define (mod-actual-file m) (list-ref m 9)) - - (define (generate-prefix) - (format "#%embedded:~a:" (gensym))) - - (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 (is-lib-path? a) - (or (and (pair? a) - (eq? 'lib (car a))) - (symbol? a) - (and (pair? a) - (eq? 'submod (car a)) - (is-lib-path? (cadr 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 (lib-module-filename collects-dest module-path) - (let-values ([(dir file) - (let ([s (lib-path->string module-path)]) - (extract-last (unix-style-split s)))]) - (let ([p (build-path collects-dest - (apply build-path dir) - "compiled" - (path-add-suffix 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 prefixes verbose? collects-dest on-extension - compiler expand-namespace get-extra-imports working) - ;; filename can have the form `(submod ,filename ,sym ...) - (let ([a (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 (if (pair? filename) - (cadr filename) - filename)] - [root-module-path (if (and (pair? module-path) - (eq? 'submod (car module-path))) - (cadr module-path) - module-path)] - [actual-filename just-filename] ; `set!'ed below to adjust file suffix - [name (let-values ([(base name dir?) (split-path just-filename)]) - (path->string (path-replace-suffix name #"")))] - [prefix (let ([a (assoc just-filename prefixes)]) - (if a - (cdr a) - (generate-prefix)))] - [full-name (string->symbol - (format "~a~a~a" prefix name - (if (null? submod-path) - "" - submod-path)))]) - (hash-set! working filename full-name) - (let ([code (or ready-code - (get-module-code just-filename - #:submodule-path submod-path - "compiled" - 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)))))]) - (cond - [(extension? code) - (when verbose? - (eprintf " using extension: ~s\n" (extension-path code))) - (set-box! codes - (cons (make-mod filename module-path code - name prefix full-name - (box null) null null - actual-filename) - (unbox codes)))] - [code - (let ([importss (module-compiled-imports code)]) - (let ([all-file-imports (filter (lambda (x) - (let-values ([(x base) (module-path-index-split x)]) - (not (and (pair? x) - (eq? 'quote (car x)))))) - (apply append (map cdr importss)))] - [extra-paths - (map symbol-to-lib-form (get-extra-imports actual-filename code))]) - (let* ([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 visinting the module in a fresh - ;; namespace: - (parameterize ([current-namespace expand-namespace]) - (eval code) - (let ([module-path - (if (path? module-path) - (path->complete-path module-path) - module-path)]) - (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 ...)))) - (syntax->datum #'(spec ...))] - [_else (error 'create-empbedding-executable - "expansion mismatch when getting external paths: ~e" - (syntax->datum e))]))))] - - [extra-runtime-paths (filter - values - (map (lambda (p) - (and (pair? p) - (eq? (car p) 'module) - (cadr p))) - runtime-paths))] - [renamed-code (if (symbol? (module-compiled-name code)) - code - (module-compiled-name code (last (module-compiled-name code))))] - [extract-submods (lambda (l) - (if (null? use-submods) - null - (for/list ([m l] - #:when (member (cadr (module-compiled-name m)) use-submods)) - m)))] - [pre-submods (extract-submods (module-compiled-submodules renamed-code #t))] - [post-submods (extract-submods (module-compiled-submodules renamed-code #f))] - [code (module-compiled-submodules (module-compiled-submodules - renamed-code - #f - null) - #t - null)]) - (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 - prefixes - verbose? - collects-dest - on-extension - compiler - expand-namespace - get-extra-imports - working)) - (define (get-one-submodule-code m) - (define name (cadr (module-compiled-name m))) - (define mpi (module-path-index-join `(submod "." ,name) #f)) - (get-one-code (resolve-module-path-index mpi 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 #f - (box null) null null - actual-filename) - (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))))] - [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))) - (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"))) - (cons path (lookup-full-name sub-filename))))))) - all-file-imports sub-files sub-paths)) - (map get-submod-mapping pre-submods)))]) - ;; Record the module - (set-box! codes - (cons (make-mod filename module-path code - name prefix 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) - (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 #f - null null null - actual-filename) - (unbox codes)))])))]))) - - ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - (define (compile-using-kernel e) - (let ([ns (make-empty-namespace)]) - (namespace-attach-module (current-namespace) ''#%kernel ns) - (parameterize ([current-namespace ns]) - (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 a suffix: - (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? 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 - (assq (resolved-module-path-name rel-to) mapping-table) - #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 a suffix: - (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 suffix-after) - (let-values ([(m) (regexp-match-positions - rx - s)]) - (if m - (cons (substring s 0 (caar m)) - (split (substring s (cdar m)) - rx - (- suffix-after 1))) - (list - (if (suffix-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)) - ;; 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? - (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) - (lookup (cadr name) rel-to stx load? (lambda (n r s l?) #f)) - #f) - #f)]) - (if base - ;; don't chain to `orig': - (make-resolved-module-path - (list* 'submod (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) - (cond - [(regexp-match? #rx#"[.]ss$" path) - (ss<->rkt (path-replace-suffix path #".rkt"))] - [(regexp-match? #rx#"[.]rkt$" path) - (if (file-exists? path) - path - (let ([p2 (path-replace-suffix path #".ss")]) - (if (file-exists? path) - p2 - path)))] - [else path])) - - (define (path-extra-suffix p sfx) - ;; Library names may have a version number preceded - ;; by a ".", which looks like a suffix, so add the - ;; shared-library suffix using plain-old bytes append: - (let-values ([(base name dir?) (split-path p)]) - (let ([name (bytes->path (bytes-append (path->bytes name) sfx))]) - (if (path? base) - (build-path base name) - name)))) - - ;; 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) - (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)] - [prefix-mapping (map (lambda (f m) - (cons f (let ([p (car m)]) - (cond - [(symbol? p) (symbol->string p)] - [(eq? p #t) (generate-prefix)] - [(not p) ""] - [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 prefix-mapping verbose? collects-dest - on-extension compiler expand-namespace - get-extra-imports - (make-hash)))] - [__ - ;; 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))) - ;; 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 (cadr p)) - p))) - (let ([p (cond - [(bytes? p) (bytes->path p)] - [(and (list? p) (= 2 (length p)) - (eq? 'so (car p))) - (let ([fs (list - (cadr p) - (path-extra-suffix (cadr p) - (system-type 'so-suffix)))]) - (ormap (lambda (f) - (ormap (lambda (p) - (let ([p (build-path p f)]) - (and (or (file-exists? p) - (directory-exists? p)) - p))) - (get-lib-search-dirs))) - fs))] - [(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 - (apply collection-file-path - (cadr p) - (if (null? (cddr p)) - (list "mzlib") - (cddr p)))))] - [(and (list? p) - (eq? 'module (car p))) - sym] - [else p])]) - (and p - (if (symbol? p) - p - (path->bytes - (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 - (bytes-append #"................." 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 (src-filter (mod-actual-file nc)) - (call-with-input-file* (mod-actual-file nc) - (lambda (inp) - (copy-port inp outp))) - (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 (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 (lambda (expr) - (parameterize ([current-namespace expand-namespace]) - (compile expr)))] - #: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)) - - - ;; The old interface: - (define make-embedding-executable - (lambda (dest mred? verbose? - modules - literal-files literal-expression - cmdline - [aux null] - [launcher? #f] - [variant (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 (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 (lambda (expr) - (parameterize ([current-namespace expand-namespace]) - (compile expr)))] - #: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? (system-type) 'unix) - (let ([m (assq 'original-exe? aux)]) - (or (not m) - (not (cdr m)))))) - (define long-cmdline? (or (eq? (system-type) 'windows) - (eq? (system-type) 'macosx) - unix-starter?)) - (define relative? (let ([m (assq 'relative? aux)]) - (and m (cdr m)))) - (define collects-path-bytes (collects-path->bytes - ((if (and mred? - (eq? 'macosx (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 mred? variant)]) - (when verbose? - (eprintf "Copying to ~s\n" dest)) - (let-values ([(dest-exe orig-exe osx?) - (cond - [(and mred? (eq? 'macosx (system-type))) - (values (prepare-macosx-mred exe dest aux variant) - (mac-dest->executable (build-path (find-lib-dir) "Starter.app") - #t) - #t)] - [unix-starter? - (let ([starter (build-path (find-lib-dir) - (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 X, 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))]) - (when (and (eq? 'macosx (system-type)) - (not unix-starter?)) - (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 GRacket is off by one): - (update-framework-path "@executable_path/../../../lib/" - (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-lib-dir)) - "/") - dest - mred?)))))) - (when (eq? 'windows (system-type)) - (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 GRacket is off by one): - (update-dll-dir dest "lib")) - ;; 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)))))))) - (let ([m (or (assq 'config-dir aux) - (and relative? '(config-dir . #f)))] - [dest->executable (lambda (dest) - (if osx? - (mac-dest->executable dest mred?) - dest))]) - (if m - (if (cdr m) - (update-config-dir (dest->executable dest) (cdr m)) - (when mred? - (cond - [osx? - ;; adjust relative path (since GRacket is off by one): - (update-config-dir (mac-dest->executable dest mred?) - "../../../etc/")] - [(eq? 'windows (system-type)) - (unless keep-exe? - ;; adjust relative path (since GRacket is off by one): - (update-config-dir dest "etc/"))]))) - ;; 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))))))) - (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)))) - 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 (eq? 'windows (system-type)) - keep-exe?) - ;; 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-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) - (if (and (eq? (system-type) 'macosx) - (not unix-starter?)) - ;; For Mach-O, we know how to add a proper segment - (let ([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: - (write-cmdline (make-full-cmdline 0 decl-len (bytes-length s)) 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))))))) - ;; Unix starter: Maybe ELF, in which case we - ;; can add a proper section - (let-values ([(s e dl p) - (if unix-starter? - (add-racket-section - orig-exe - dest-exe - (if launcher? #".rackcmdl" #".rackprog") - (lambda (start) - (let ([s (open-output-bytes)]) - (define decl-len (write-module s)) - (let ([p (file-position s)]) - (display (make-starter-cmdline - (make-full-cmdline start - (+ start decl-len) - (+ start p))) - s) - (values (get-output-bytes s) decl-len p))))) - (values #f #f #f #f))]) - (if (and s e) - ;; ELF succeeded: - (values s (+ s dl) (+ s p) e) - ;; 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 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)] - [mred? - (cond - [osx? - ;; default path in `gracket' is off by one: - (set-collects-path dest-exe #"../../../collects")] - [(eq? 'windows (system-type)) - (unless keep-exe? - ;; off by one in this case, too: - (set-collects-path dest-exe #"collects"))])]) - (cond - [(and use-starter-info? osx?) - (finish-osx-mred dest full-cmdline exe keep-exe? relative?)] - [unix-starter? - (let ([numpos (with-input-from-file dest-exe - (lambda () (find-cmdline - "configuration" - #"cOnFiG:")))] - [typepos (and (or mred? (eq? variant '3m)) - (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)) - (flush-output out)) - (file-position out (+ numpos 7)) - (write-bytes #"!" 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 (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; - ;; 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 (and keep-exe? (eq? 'windows (system-type))) "*" "?") - (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 (system-type)) - (assq 'ico aux))]) - (when m - (replace-icos (read-icos (cdr m)) dest-exe))) - (let ([m (and (eq? 'windows (system-type)) - (assq 'subsystem aux))]) - (when m - (set-subsystem dest-exe (cdr m)))))]))))))))) - - ;; For Mac OS X 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])))) diff --git a/racket/collects/compiler/embed.rkt b/racket/collects/compiler/embed.rkt index 814b1481b6..d3bd41f8a2 100644 --- a/racket/collects/compiler/embed.rkt +++ b/racket/collects/compiler/embed.rkt @@ -1,13 +1,25 @@ #lang racket/base -(require racket/unit - racket/contract) +(require racket/path + racket/file + racket/port + racket/promise + racket/list + racket/contract + syntax/moddep + syntax/modcollapse + xml/plist + setup/dirs + setup/variant + file/ico + "private/winsubsys.rkt" + "private/macfw.rkt" + "private/mach-o.rkt" + "private/elf.rkt" + "private/windlldir.rkt" + "private/collects-path.rkt" + "private/configdir.rkt" + "find-exe.rkt") -(require "sig.rkt") - -(require "embed-unit.rkt" - "embed-sig.rkt") - -(define-values/invoke-unit/infer compiler:embed@) (provide/contract [make-embedding-executable (->* (path-string? @@ -64,3 +76,1583 @@ 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 (system-type)))) + +(define (embedding-executable-put-file-extension+style+filters mred?) + (case (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-replace-suffix path sfx)))]) + (case (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-suffix name #""))) + dest)) + +(define exe-suffix? + (delay (equal? #"i386-cygwin" (path->bytes (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 (prepare-macosx-mred exec-name dest aux variant) + (let* ([name (let-values ([(base name dir?) (split-path dest)]) + (path-replace-suffix name #""))] + [src (build-path (find-lib-dir) "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))))) + (call-with-output-file (build-path dest + "Contents" + "PkgInfo") + #:exists 'truncate + (lambda (port) + (fprintf port "APPL~a" creator))) + (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))) + +;; The starter-info file is now disabled. The GRacket +;; command line is handled the same as the Racket command +;; line. +(define use-starter-info? #f) +(define (finish-osx-mred dest flags exec-name keep-exe? relative?) + (call-with-output-file (build-path dest + "Contents" + "Resources" + "starter-info") + #:exists 'truncate + (lambda (port) + (write-plist + `(dict ,@(if keep-exe? + `((assoc-pair "executable name" + ,(path->string + (if relative? + (relativize exec-name dest + (lambda (p) + (build-path 'up 'up 'up p))) + exec-name)))) + null) + (assoc-pair "stored arguments" + (array ,@flags))) + port)))) + +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; Represent modules with lists starting with the filename, so we +;; can use assoc: +(define (make-mod normal-file-path normal-module-path + code name prefix full-name relative-mappings-box + runtime-paths runtime-module-syms + actual-file-path) + (list normal-file-path normal-module-path code + name prefix full-name relative-mappings-box + runtime-paths runtime-module-syms + actual-file-path)) + +(define (mod-file m) (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-prefix m) (list-ref m 4)) +(define (mod-full-name m) (list-ref m 5)) +(define (mod-mappings m) (unbox (list-ref m 6))) +(define (mod-runtime-paths m) (list-ref m 7)) +(define (mod-runtime-module-syms m) (list-ref m 8)) +(define (mod-actual-file m) (list-ref m 9)) + +(define (generate-prefix) + (format "#%embedded:~a:" (gensym))) + +(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 (is-lib-path? a) + (or (and (pair? a) + (eq? 'lib (car a))) + (symbol? a) + (and (pair? a) + (eq? 'submod (car a)) + (is-lib-path? (cadr 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 (lib-module-filename collects-dest module-path) + (let-values ([(dir file) + (let ([s (lib-path->string module-path)]) + (extract-last (unix-style-split s)))]) + (let ([p (build-path collects-dest + (apply build-path dir) + "compiled" + (path-add-suffix 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 prefixes verbose? collects-dest on-extension + compiler expand-namespace get-extra-imports working) + ;; filename can have the form `(submod ,filename ,sym ...) + (let ([a (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 (if (pair? filename) + (cadr filename) + filename)] + [root-module-path (if (and (pair? module-path) + (eq? 'submod (car module-path))) + (cadr module-path) + module-path)] + [actual-filename just-filename] ; `set!'ed below to adjust file suffix + [name (let-values ([(base name dir?) (split-path just-filename)]) + (path->string (path-replace-suffix name #"")))] + [prefix (let ([a (assoc just-filename prefixes)]) + (if a + (cdr a) + (generate-prefix)))] + [full-name (string->symbol + (format "~a~a~a" prefix name + (if (null? submod-path) + "" + submod-path)))]) + (hash-set! working filename full-name) + (let ([code (or ready-code + (get-module-code just-filename + #:submodule-path submod-path + "compiled" + 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)))))]) + (cond + [(extension? code) + (when verbose? + (eprintf " using extension: ~s\n" (extension-path code))) + (set-box! codes + (cons (make-mod filename module-path code + name prefix full-name + (box null) null null + actual-filename) + (unbox codes)))] + [code + (let ([importss (module-compiled-imports code)]) + (let ([all-file-imports (filter (lambda (x) + (let-values ([(x base) (module-path-index-split x)]) + (not (and (pair? x) + (eq? 'quote (car x)))))) + (apply append (map cdr importss)))] + [extra-paths + (map symbol-to-lib-form (get-extra-imports actual-filename code))]) + (let* ([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 visinting the module in a fresh + ;; namespace: + (parameterize ([current-namespace expand-namespace]) + (eval code) + (let ([module-path + (if (path? module-path) + (path->complete-path module-path) + module-path)]) + (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 ...)))) + (syntax->datum #'(spec ...))] + [_else (error 'create-empbedding-executable + "expansion mismatch when getting external paths: ~e" + (syntax->datum e))]))))] + + [extra-runtime-paths (filter + values + (map (lambda (p) + (and (pair? p) + (eq? (car p) 'module) + (cadr p))) + runtime-paths))] + [renamed-code (if (symbol? (module-compiled-name code)) + code + (module-compiled-name code (last (module-compiled-name code))))] + [extract-submods (lambda (l) + (if (null? use-submods) + null + (for/list ([m l] + #:when (member (cadr (module-compiled-name m)) use-submods)) + m)))] + [pre-submods (extract-submods (module-compiled-submodules renamed-code #t))] + [post-submods (extract-submods (module-compiled-submodules renamed-code #f))] + [code (module-compiled-submodules (module-compiled-submodules + renamed-code + #f + null) + #t + null)]) + (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 + prefixes + verbose? + collects-dest + on-extension + compiler + expand-namespace + get-extra-imports + working)) + (define (get-one-submodule-code m) + (define name (cadr (module-compiled-name m))) + (define mpi (module-path-index-join `(submod "." ,name) #f)) + (get-one-code (resolve-module-path-index mpi 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 #f + (box null) null null + actual-filename) + (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))))] + [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))) + (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"))) + (cons path (lookup-full-name sub-filename))))))) + all-file-imports sub-files sub-paths)) + (map get-submod-mapping pre-submods)))]) + ;; Record the module + (set-box! codes + (cons (make-mod filename module-path code + name prefix 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) + (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 #f + null null null + actual-filename) + (unbox codes)))])))]))) + +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define (compile-using-kernel e) + (let ([ns (make-empty-namespace)]) + (namespace-attach-module (current-namespace) ''#%kernel ns) + (parameterize ([current-namespace ns]) + (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 a suffix: + (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? 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 + (assq (resolved-module-path-name rel-to) mapping-table) + #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 a suffix: + (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 suffix-after) + (let-values ([(m) (regexp-match-positions + rx + s)]) + (if m + (cons (substring s 0 (caar m)) + (split (substring s (cdar m)) + rx + (- suffix-after 1))) + (list + (if (suffix-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)) + ;; 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? + (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) + (lookup (cadr name) rel-to stx load? (lambda (n r s l?) #f)) + #f) + #f)]) + (if base + ;; don't chain to `orig': + (make-resolved-module-path + (list* 'submod (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) + (cond + [(regexp-match? #rx#"[.]ss$" path) + (ss<->rkt (path-replace-suffix path #".rkt"))] + [(regexp-match? #rx#"[.]rkt$" path) + (if (file-exists? path) + path + (let ([p2 (path-replace-suffix path #".ss")]) + (if (file-exists? path) + p2 + path)))] + [else path])) + +(define (path-extra-suffix p sfx) + ;; Library names may have a version number preceded + ;; by a ".", which looks like a suffix, so add the + ;; shared-library suffix using plain-old bytes append: + (let-values ([(base name dir?) (split-path p)]) + (let ([name (bytes->path (bytes-append (path->bytes name) sfx))]) + (if (path? base) + (build-path base name) + name)))) + +;; 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) + (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)] + [prefix-mapping (map (lambda (f m) + (cons f (let ([p (car m)]) + (cond + [(symbol? p) (symbol->string p)] + [(eq? p #t) (generate-prefix)] + [(not p) ""] + [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 prefix-mapping verbose? collects-dest + on-extension compiler expand-namespace + get-extra-imports + (make-hash)))] + [__ + ;; 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))) + ;; 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 (cadr p)) + p))) + (let ([p (cond + [(bytes? p) (bytes->path p)] + [(and (list? p) (= 2 (length p)) + (eq? 'so (car p))) + (let ([fs (list + (cadr p) + (path-extra-suffix (cadr p) + (system-type 'so-suffix)))]) + (ormap (lambda (f) + (ormap (lambda (p) + (let ([p (build-path p f)]) + (and (or (file-exists? p) + (directory-exists? p)) + p))) + (get-lib-search-dirs))) + fs))] + [(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 + (apply collection-file-path + (cadr p) + (if (null? (cddr p)) + (list "mzlib") + (cddr p)))))] + [(and (list? p) + (eq? 'module (car p))) + sym] + [else p])]) + (and p + (if (symbol? p) + p + (path->bytes + (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 + (bytes-append #"................." 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 (src-filter (mod-actual-file nc)) + (call-with-input-file* (mod-actual-file nc) + (lambda (inp) + (copy-port inp outp))) + (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 (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 (lambda (expr) + (parameterize ([current-namespace expand-namespace]) + (compile expr)))] + #: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)) + + +;; The old interface: +(define make-embedding-executable + (lambda (dest mred? verbose? + modules + literal-files literal-expression + cmdline + [aux null] + [launcher? #f] + [variant (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 (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 (lambda (expr) + (parameterize ([current-namespace expand-namespace]) + (compile expr)))] + #: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? (system-type) 'unix) + (let ([m (assq 'original-exe? aux)]) + (or (not m) + (not (cdr m)))))) + (define long-cmdline? (or (eq? (system-type) 'windows) + (eq? (system-type) 'macosx) + unix-starter?)) + (define relative? (let ([m (assq 'relative? aux)]) + (and m (cdr m)))) + (define collects-path-bytes (collects-path->bytes + ((if (and mred? + (eq? 'macosx (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 mred? variant)]) + (when verbose? + (eprintf "Copying to ~s\n" dest)) + (let-values ([(dest-exe orig-exe osx?) + (cond + [(and mred? (eq? 'macosx (system-type))) + (values (prepare-macosx-mred exe dest aux variant) + (mac-dest->executable (build-path (find-lib-dir) "Starter.app") + #t) + #t)] + [unix-starter? + (let ([starter (build-path (find-lib-dir) + (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 X, 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))]) + (when (and (eq? 'macosx (system-type)) + (not unix-starter?)) + (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 GRacket is off by one): + (update-framework-path "@executable_path/../../../lib/" + (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-lib-dir)) + "/") + dest + mred?)))))) + (when (eq? 'windows (system-type)) + (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 GRacket is off by one): + (update-dll-dir dest "lib")) + ;; 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)))))))) + (let ([m (or (assq 'config-dir aux) + (and relative? '(config-dir . #f)))] + [dest->executable (lambda (dest) + (if osx? + (mac-dest->executable dest mred?) + dest))]) + (if m + (if (cdr m) + (update-config-dir (dest->executable dest) (cdr m)) + (when mred? + (cond + [osx? + ;; adjust relative path (since GRacket is off by one): + (update-config-dir (mac-dest->executable dest mred?) + "../../../etc/")] + [(eq? 'windows (system-type)) + (unless keep-exe? + ;; adjust relative path (since GRacket is off by one): + (update-config-dir dest "etc/"))]))) + ;; 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))))))) + (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)))) + 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 (eq? 'windows (system-type)) + keep-exe?) + ;; 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-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) + (if (and (eq? (system-type) 'macosx) + (not unix-starter?)) + ;; For Mach-O, we know how to add a proper segment + (let ([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: + (write-cmdline (make-full-cmdline 0 decl-len (bytes-length s)) 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))))))) + ;; Unix starter: Maybe ELF, in which case we + ;; can add a proper section + (let-values ([(s e dl p) + (if unix-starter? + (add-racket-section + orig-exe + dest-exe + (if launcher? #".rackcmdl" #".rackprog") + (lambda (start) + (let ([s (open-output-bytes)]) + (define decl-len (write-module s)) + (let ([p (file-position s)]) + (display (make-starter-cmdline + (make-full-cmdline start + (+ start decl-len) + (+ start p))) + s) + (values (get-output-bytes s) decl-len p))))) + (values #f #f #f #f))]) + (if (and s e) + ;; ELF succeeded: + (values s (+ s dl) (+ s p) e) + ;; 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 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)] + [mred? + (cond + [osx? + ;; default path in `gracket' is off by one: + (set-collects-path dest-exe #"../../../collects")] + [(eq? 'windows (system-type)) + (unless keep-exe? + ;; off by one in this case, too: + (set-collects-path dest-exe #"collects"))])]) + (cond + [(and use-starter-info? osx?) + (finish-osx-mred dest full-cmdline exe keep-exe? relative?)] + [unix-starter? + (let ([numpos (with-input-from-file dest-exe + (lambda () (find-cmdline + "configuration" + #"cOnFiG:")))] + [typepos (and (or mred? (eq? variant '3m)) + (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)) + (flush-output out)) + (file-position out (+ numpos 7)) + (write-bytes #"!" 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 (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; + ;; 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 (and keep-exe? (eq? 'windows (system-type))) "*" "?") + (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 (system-type)) + (assq 'ico aux))]) + (when m + (replace-icos (read-icos (cdr m)) dest-exe))) + (let ([m (and (eq? 'windows (system-type)) + (assq 'subsystem aux))]) + (when m + (set-subsystem dest-exe (cdr m)))))]))))))))) + +;; For Mac OS X 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])) diff --git a/racket/collects/compiler/option-unit.rkt b/racket/collects/compiler/option-unit.rkt deleted file mode 100644 index b8d5d69970..0000000000 --- a/racket/collects/compiler/option-unit.rkt +++ /dev/null @@ -1,16 +0,0 @@ -#lang racket/base - -(require racket/unit) -(require "sig.rkt") - -(provide compiler:option@) - -(define-unit compiler:option@ (import) (export compiler:option^) - - (define somewhat-verbose (make-parameter #f)) - (define verbose (make-parameter #f)) - (define 3m (make-parameter (eq? '3m (system-type 'gc)))) - - (define setup-prefix (make-parameter "")) - - (define compile-subcollections (make-parameter #t))) diff --git a/racket/collects/compiler/option.rkt b/racket/collects/compiler/option.rkt new file mode 100644 index 0000000000..fa3b2282da --- /dev/null +++ b/racket/collects/compiler/option.rkt @@ -0,0 +1,32 @@ +#lang racket/base + +(provide somewhat-verbose + ;; default = #f + verbose + ;; default = #f + + setup-prefix + ;; string to embed in public names; + ;; used mainly for compiling extensions + ;; with the collection name so that + ;; cross-extension conflicts are less + ;; likely in architectures that expose + ;; the public names of loaded extensions + ;; default = "" + + 3m + ;; #t => build for 3m + ;; default = #f + + compile-subcollections + ;; #t => compile collection subdirectories + ;; default = #t + ) + +(define somewhat-verbose (make-parameter #f)) +(define verbose (make-parameter #f)) +(define 3m (make-parameter (eq? '3m (system-type 'gc)))) + +(define setup-prefix (make-parameter "")) + +(define compile-subcollections (make-parameter #t)) diff --git a/racket/collects/dynext/dynext-sig.rkt b/racket/collects/dynext/dynext-sig.rkt deleted file mode 100644 index ee3eddade1..0000000000 --- a/racket/collects/dynext/dynext-sig.rkt +++ /dev/null @@ -1,7 +0,0 @@ -(module dynext-sig racket/base - - (require "compile-sig.rkt" "link-sig.rkt" "file-sig.rkt") - - (provide (all-from-out "compile-sig.rkt") - (all-from-out "link-sig.rkt") - (all-from-out "file-sig.rkt"))) diff --git a/racket/collects/dynext/dynext-unit.rkt b/racket/collects/dynext/dynext-unit.rkt deleted file mode 100644 index d2791a7fc5..0000000000 --- a/racket/collects/dynext/dynext-unit.rkt +++ /dev/null @@ -1,7 +0,0 @@ -#lang racket/base - -(require "compile-unit.rkt" "link-unit.rkt" "file-unit.rkt") - -(provide (all-from-out "compile-unit.rkt") - (all-from-out "link-unit.rkt") - (all-from-out "file-unit.rkt")) diff --git a/racket/collects/dynext/file-unit.rkt b/racket/collects/dynext/file-unit.rkt deleted file mode 100644 index 39e50627fa..0000000000 --- a/racket/collects/dynext/file-unit.rkt +++ /dev/null @@ -1,64 +0,0 @@ -#lang racket/base - -(require racket/unit "file-sig.rkt") - -(provide dynext:file@) - -(define-unit dynext:file@ (import) (export dynext:file^) - - (define (append-zo-suffix s) - (path-add-suffix s #".zo")) - - (define (append-c-suffix s) - (path-add-suffix s #".c")) - - (define (append-constant-pool-suffix s) - (path-add-suffix s #".kp")) - - (define (append-object-suffix s) - (path-add-suffix s (case (system-type) - [(unix beos macos macosx) #".o"] - [(windows) #".obj"]))) - - (define (append-extension-suffix s) - (path-add-suffix s (system-type 'so-suffix))) - - (define (extract-suffix appender) - (subbytes (path->bytes (appender (bytes->path #"x"))) 1)) - - (define-values (extract-base-filename/ss - extract-base-filename/c - extract-base-filename/kp - extract-base-filename/o - extract-base-filename/ext) - (let ([mk - (lambda (who pat kind simple) - (define rx - (byte-pregexp (bytes-append #"^(.*)\\.(?i:" pat #")$"))) - (define (extract-base-filename s [p #f]) - (unless (path-string? s) - (raise-type-error who "path or valid-path string" s)) - (cond [(regexp-match - rx (path->bytes (if (path? s) s (string->path s)))) - => (lambda (m) (bytes->path (cadr m)))] - [p (if simple - (error p "not a ~a filename (doesn't end with ~a): ~a" - kind simple s) - (path-replace-suffix s #""))] - [else #f])) - extract-base-filename)]) - (values - (mk 'extract-base-filename/ss #"rkt|ss|scm" "Racket" #f) - (mk 'extract-base-filename/c - #"c|cc|cxx|cpp|c[+][+]|m" "C" ".c, .cc, .cxx, .cpp, .c++, or .m") - (mk 'extract-base-filename/kp #"kp" "constant pool" ".kp") - (mk 'extract-base-filename/o - (case (system-type) - [(unix beos macos macosx) #"o"] - [(windows) #"obj"]) - "compiled object" - (extract-suffix append-object-suffix)) - (mk 'extract-base-filename/ext - (regexp-quote (subbytes (system-type 'so-suffix) 1) #f) - "Racket extension" - (extract-suffix append-extension-suffix)))))) diff --git a/racket/collects/dynext/file.rkt b/racket/collects/dynext/file.rkt index ff5ce27f8a..ed8358097e 100644 --- a/racket/collects/dynext/file.rkt +++ b/racket/collects/dynext/file.rkt @@ -1,9 +1,70 @@ #lang racket/base -(require racket/unit) -(require "file-sig.rkt" - "file-unit.rkt") +(provide append-zo-suffix + append-c-suffix + append-constant-pool-suffix + append-object-suffix + append-extension-suffix + + extract-base-filename/ss + extract-base-filename/c + extract-base-filename/kp + extract-base-filename/o + extract-base-filename/ext) -(define-values/invoke-unit/infer dynext:file@) +(define (append-zo-suffix s) + (path-add-suffix s #".zo")) -(provide-signature-elements dynext:file^) +(define (append-c-suffix s) + (path-add-suffix s #".c")) + +(define (append-constant-pool-suffix s) + (path-add-suffix s #".kp")) + +(define (append-object-suffix s) + (path-add-suffix s (case (system-type) + [(unix macosx) #".o"] + [(windows) #".obj"]))) + +(define (append-extension-suffix s) + (path-add-suffix s (system-type 'so-suffix))) + +(define (extract-suffix appender) + (subbytes (path->bytes (appender (bytes->path #"x"))) 1)) + +(define-values (extract-base-filename/ss + extract-base-filename/c + extract-base-filename/kp + extract-base-filename/o + extract-base-filename/ext) + (let ([mk + (lambda (who pat kind simple) + (define (extract-base-filename s [p #f]) + (define rx + (byte-pregexp (bytes-append #"^(.*)\\.(?i:" pat #")$"))) + (unless (path-string? s) + (raise-type-error who "path or valid-path string" s)) + (cond [(regexp-match + rx (path->bytes (if (path? s) s (string->path s)))) + => (lambda (m) (bytes->path (cadr m)))] + [p (if simple + (error p "not a ~a filename (doesn't end with ~a): ~a" + kind simple s) + (path-replace-suffix s #""))] + [else #f])) + extract-base-filename)]) + (values + (mk 'extract-base-filename/ss #"rkt|ss|scm" "Racket" #f) + (mk 'extract-base-filename/c + #"c|cc|cxx|cpp|c[+][+]|m" "C" ".c, .cc, .cxx, .cpp, .c++, or .m") + (mk 'extract-base-filename/kp #"kp" "constant pool" ".kp") + (mk 'extract-base-filename/o + (case (system-type) + [(unix beos macos macosx) #"o"] + [(windows) #"obj"]) + "compiled object" + (extract-suffix append-object-suffix)) + (mk 'extract-base-filename/ext + (regexp-quote (subbytes (system-type 'so-suffix) 1) #f) + "Racket extension" + (extract-suffix append-extension-suffix))))) diff --git a/racket/collects/file/gzip.rkt b/racket/collects/file/gzip.rkt index 7cd6e6d6bc..a2c6f57e61 100644 --- a/racket/collects/file/gzip.rkt +++ b/racket/collects/file/gzip.rkt @@ -186,10 +186,6 @@ (define head-vec-delta WSIZE) -;; The gzip code wasn't defined for threads (or even to be -;; multiply invoked), so we pack it up into a unit to -;; invoke each time we need it. - ;; /* Data structure describing a single value and its code string. */ (define-struct ct_data (freq code dad len) #:mutable) ;; union { @@ -374,8 +370,13 @@ #x2d02ef8d)) (define (code) + + ;; The gzip code wasn't defined for threads (or even to be + ;; multiply invoked), so we pack it up into a function to + ;; invoke each time we need it. + ;; The original code uses many `static' mutable variables, and that - ;; strategy is largely intact in this port, so we group all of the + ;; strategy is largely intact in this port, so we group all of it ;; here with local variables to instantiate with the functions. ;; /* =========================================================================== diff --git a/racket/collects/launcher/launcher-unit.rkt b/racket/collects/launcher/launcher-unit.rkt deleted file mode 100644 index 6bb7e06536..0000000000 --- a/racket/collects/launcher/launcher-unit.rkt +++ /dev/null @@ -1,945 +0,0 @@ -#lang racket/unit - -(require racket/path - racket/file - racket/list - racket/string - - compiler/embed - setup/dirs - setup/variant - - "launcher-sig.rkt" - - compiler/private/winutf16) - -(import) -(export launcher^) - -(define current-launcher-variant - (make-parameter (system-type 'gc) - (lambda (v) - (unless (memq v '(3m script-3m cgc script-cgc)) - (raise-type-error - 'current-launcher-variant - "variant symbol" - v)) - v))) - -(define (variant-available? kind cased-kind-name variant) - (cond - [(or (eq? 'unix (system-type)) - (and (eq? 'macosx (system-type)) - (eq? kind 'mzscheme))) - (let ([bin-dir (if (eq? kind 'mzscheme) - (find-console-bin-dir) - (find-lib-dir))]) - (and bin-dir - (file-exists? - (build-path bin-dir - (format "~a~a" - (case kind - [(mzscheme) 'racket] - [(mred) 'gracket]) - (variant-suffix variant #f))))))] - [(eq? 'macosx (system-type)) - ;; kind must be mred, because mzscheme case is caught above - (directory-exists? (build-path (find-lib-dir) - (format "~a~a.app" - cased-kind-name - (variant-suffix variant #f))))] - [(eq? 'windows (system-type)) - (file-exists? - (build-path - (if (eq? kind 'mzscheme) (find-console-bin-dir) (find-lib-dir)) - (format "~a~a.exe" cased-kind-name (variant-suffix variant #t))))] - [else (error "unknown system type")])) - -(define (available-variants kind) - (let* ([cased-kind-name (if (eq? kind 'mzscheme) - "Racket" - "GRacket")] - [normal-kind (system-type 'gc)] - [alt-kind (if (eq? '3m normal-kind) - 'cgc - '3m)] - [normal (if (variant-available? kind cased-kind-name normal-kind) - (list normal-kind) - null)] - [alt (if (variant-available? kind cased-kind-name alt-kind) - (list alt-kind) - null)] - [script (if (and (eq? 'macosx (system-type)) - (eq? kind 'mred) - (pair? normal)) - (if (eq? normal-kind '3m) - '(script-3m) - '(script-cgc)) - null)] - [script-alt (if (and (memq alt-kind alt) - (pair? script)) - (if (eq? alt-kind '3m) - '(script-3m) - '(script-cgc)) - null)]) - (append normal alt script script-alt))) - -(define (available-gracket-variants) - (available-variants 'mred)) -(define (available-mred-variants) - (available-variants 'mred)) - -(define (available-racket-variants) - (available-variants 'mzscheme)) -(define (available-mzscheme-variants) - (available-variants 'mzscheme)) - -(define (install-template dest kind mz mr) - (define src (build-path (find-lib-dir) - (if (eq? kind 'mzscheme) mz mr))) - (when (or (file-exists? dest) - (directory-exists? dest) - (link-exists? dest)) - (delete-directory/files dest)) - (copy-file src dest) - ;; make sure it's read/write/execute-able - (let* ([perms1 (file-or-directory-permissions dest 'bits)] - [perms2 (bitwise-ior user-read-bit user-write-bit user-execute-bit - perms1)]) - (unless (equal? perms1 perms2) - (file-or-directory-permissions dest perms2)))) - -(define (script-variant? v) - (memq v '(script-3m script-cgc))) - -(define (add-file-suffix path variant mred?) - (let ([s (variant-suffix - variant - (case (system-type) - [(unix) #f] - [(windows) #t] - [(macosx) (and mred? (not (script-variant? variant)))]))]) - (if (string=? "" s) - path - (path-replace-suffix - path - (string->bytes/utf-8 - (if (and (eq? 'windows (system-type)) - (regexp-match #rx#"[.]exe$" (path->bytes path))) - (format "~a.exe" s) - s)))))) - -(define (string-append/spaces f flags) - (string-append* (append-map (lambda (x) (list (f x) " ")) flags))) - -(define (str-list->sh-str flags) - (string-append/spaces - (lambda (s) - (string-append "'" (regexp-replace* #rx"'" s "'\"'\"'") "'")) - flags)) - -(define (str-list->dos-str flags) - (define (trans s) - (if (not (regexp-match? #rx"[ \n\t\r\v\"\\]" s)) - s - (list->string - (let loop ([l (string->list s)] [slashes '()]) - (cond [(null? l) '()] - [(char-whitespace? (car l)) - `(,@slashes #\" ,(car l) #\" ,@(loop (cdr l) '()))] - [(eq? #\\ (car l)) - `(#\\ ,@(loop (cdr l) (cons #\\ slashes)))] - [(eq? #\" (car l)) - `(,@slashes #\" #\\ #\" #\" ,@(loop (cdr l) '()))] - [else `(,(car l) ,@(loop (cdr l) '()))]))))) - (string-append/spaces trans flags)) - -(define one-arg-x-flags '((xa "-display") - (xb "-geometry") - (xc "-bg" "-background") - (xd "-fg" "-foregound") - (xe "-font") - (xf "-name") - (xg "-selectionTimeout") - (xh "-title") - (xi "-xnllanguage") - (xj "-xrm"))) -(define no-arg-x-flags '((xk "-iconic") - (xl "-rv" "-reverse") - (xm "+rv") - (xn "-synchronous") - (xo "-singleInstance"))) - -(define (skip-x-flags flags) - (let ([xfmem (lambda (flag) (lambda (xf) (member flag (cdr xf))))]) - (let loop ([f flags]) - (cond [(null? f) null] - [(ormap (xfmem (car f)) one-arg-x-flags) - (if (null? (cdr f)) null (loop (cddr f)))] - [(ormap (xfmem (car f)) no-arg-x-flags) (loop (cdr f))] - [else f])))) - -(define (output-x-arg-getter exec args) - (let ([or-flags (lambda (l) (string-append* (add-between l " | ")))]) - (string-append* - (append - (list "# Find X flags and shift them to the front\n" - "findxend() {\n" - " oneargflag=''\n" - " case \"$1\" in\n") - (map - (lambda (f) - (format (string-append - " ~a)\n" - " oneargflag=\"$1\"\n" - " ~a=\"$2\"\n" - " ;;\n") - (or-flags (cdr f)) - (car f))) - one-arg-x-flags) - (map - (lambda (f) - (format " ~a)\n ~a=yes\n ;;\n" (or-flags (cdr f)) (car f))) - no-arg-x-flags) - (list - (format (string-append - " *)\n ~a~a ~a ;;\n" - " esac\n" - " shift\n" - " if [ \"$oneargflag\" != '' ] ; then\n" - " if [ \"${1+n}\" != 'n' ] ; then echo $0: missing argument for standard X flag $oneargflag ; exit 1 ; fi\n" - " shift\n" - " fi\n" - " findxend ${1+\"$@\"}\n" - "}\nfindxend ${1+\"$@\"}\n") - exec - (string-append* - (append - (map (lambda (f) - (format " ${~a+\"~a\"} ${~a+\"$~a\"}" - (car f) (cadr f) (car f) (car f))) - one-arg-x-flags) - (map (lambda (f) - (format " ${~a+\"~a\"}" (car f) (cadr f))) - no-arg-x-flags))) - args)))))) - -(define (protect-shell-string s) - (regexp-replace* - #rx"[\"`'$\\]" (if (path? s) (path->string s) s) "\\\\&")) - -(define (normalize+explode-path p) - (explode-path (normal-case-path (simple-form-path p)))) - -(define (relativize bindir-explode dest-explode) - (let loop ([b bindir-explode] [d dest-explode]) - (if (and (pair? b) (equal? (car b) (car d))) - (loop (cdr b) (cdr d)) - (let ([p (append (map (lambda (x) 'up) (cdr d)) b)]) - (if (null? p) #f (apply build-path p)))))) - -(define (make-relative-path-header dest bindir use-librktdir?) - ;; rely only on binaries in /usr/bin:/bin - (define (has-exe? exe) - (or (file-exists? (build-path "/usr/bin" exe)) - (file-exists? (build-path "/bin" exe)))) - (let* ([has-readlink? (and (not (eq? 'macosx (system-type))) - (has-exe? "readlink"))] - [dest-explode (normalize+explode-path dest)] - [bindir-explode (normalize+explode-path bindir)]) - (if (and (has-exe? "dirname") (has-exe? "basename") - (or has-readlink? (and (has-exe? "ls") (has-exe? "sed"))) - (equal? (car dest-explode) (car bindir-explode))) - (string-append - "# Make this PATH-independent\n" - "saveP=\"$PATH\"\n" - "PATH=\"/usr/bin:/bin\"\n" - "\n" - (if has-readlink? "" - (string-append - "# imitate possibly-missing readlink\n" - "readlink() {\n" - " ls -l -- \"$1\" | sed -e \"s/^.* -> //\"\n" - "}\n" - "\n")) - "# Remember current directory\n" - "saveD=`pwd`\n" - "\n" - "# Find absolute path to this script,\n" - "# resolving symbolic references to the end\n" - "# (changes the current directory):\n" - "D=`dirname \"$0\"`\n" - "F=`basename \"$0\"`\n" - "cd \"$D\"\n" - "while test " - ;; On solaris, Edward Chrzanowski from Waterloo says that the man - ;; page says that -L is not supported, but -h is; on other systems - ;; (eg, freebsd) -h is listed as a compatibility feature - (if (regexp-match #rx"solaris" (path->string - (system-library-subpath))) - "-h" "-L") - " \"$F\"; do\n" - " P=`readlink \"$F\"`\n" - " D=`dirname \"$P\"`\n" - " F=`basename \"$P\"`\n" - " cd \"$D\"\n" - "done\n" - "D=`pwd`\n" - "\n" - "# Restore current directory\n" - "cd \"$saveD\"\n" - "\n" - "bindir=\"$D" - (if use-librktdir? - "" - (let ([s (relativize bindir-explode dest-explode)]) - (if s (string-append "/" (protect-shell-string s)) ""))) - "\"\n" - "PATH=\"$saveP\"\n") - ;; fallback to absolute path header - (make-absolute-path-header bindir)))) - -(define (make-absolute-path-header bindir) - (string-append "bindir=\""(protect-shell-string bindir)"\"\n")) - -(define (make-unix-launcher kind variant flags dest aux) - (install-template dest kind "starter-sh" "starter-sh") ; just for something that's executable - (let* ([alt-exe (let ([m (and (eq? kind 'mred) - (script-variant? variant) - (assq 'exe-name aux))]) - (and m - (format "~a~a.app/Contents/MacOS/~a~a" - (cdr m) (variant-suffix variant #t) - (cdr m) (variant-suffix variant #t))))] - [x-flags? (and (eq? kind 'mred) - (eq? (system-type) 'unix) - (not (script-variant? variant)))] - [flags (let ([m (assq 'wm-class aux)]) - (if m - (list* "-J" (cdr m) flags) - flags))] - [post-flags (cond - [x-flags? (skip-x-flags flags)] - [alt-exe null] - [else flags])] - [pre-flags (cond - [(not x-flags?) null] - [else - (let loop ([f flags]) - (if (eq? f post-flags) - null - (cons (car f) (loop (cdr f)))))])] - [pre-str (str-list->sh-str pre-flags)] - [post-str (str-list->sh-str post-flags)] - [header (string-append - "#!/bin/sh\n" - "# This script was created by make-" - (symbol->string kind)"-launcher\n")] - [use-librktdir? (if alt-exe - (let ([m (assq 'exe-is-gracket aux)]) - (and m (cdr m))) - (eq? kind 'mred))] - [dir-finder - (let ([bindir (if alt-exe - (let ([m (assq 'exe-is-gracket aux)]) - (if (and m (cdr m)) - (find-lib-dir) - (let ([p (path-only dest)]) - (if (eq? 'macosx (system-type)) - (build-path p 'up) - p)))) - (find-console-bin-dir))]) - (if (let ([a (assq 'relative? aux)]) - (and a (cdr a))) - (make-relative-path-header dest bindir use-librktdir?) - (make-absolute-path-header bindir)))] - [exec (format - "exec \"${~a}/~a~a\" ~a" - (if use-librktdir? - "librktdir" - "bindir") - (or alt-exe (case kind - [(mred) (if (eq? 'macosx (system-type)) - (format "GRacket~a.app/Contents/MacOS/Gracket" - (variant-suffix variant #t)) - "gracket")] - [(mzscheme) "racket"])) - (if alt-exe - "" - (variant-suffix variant (and (eq? kind 'mred) - (eq? 'macosx (system-type))))) - pre-str)] - [args (format - "~a~a ${1+\"$@\"}\n" - (if alt-exe "" "-N \"$0\" ") - post-str)] - [assemble-exec (if (and (eq? kind 'mred) - (not (script-variant? variant)) - (not (null? post-flags))) - output-x-arg-getter - string-append)]) - (unless (find-console-bin-dir) - (error 'make-unix-launcher "unable to locate bin directory")) - (with-output-to-file dest - #:exists 'truncate - (lambda () - (display header) - (newline) - ;; comments needed to rehack launchers when paths change - ;; (see setup/unixstyle-install.rkt) - (display "# {{{ bindir\n") - (display dir-finder) - (display "# }}} bindir\n") - (when use-librktdir? - (display "# {{{ librktdir\n") - (display "librktdir=\"$bindir/../lib\"\n") - (display "# }}} librktdir\n")) - (newline) - (display (assemble-exec exec args))))) - (check-desktop aux dest)) - -(define (check-registry aux dest) - (let ([im (assoc 'install-mode aux)]) - (when (and im (member (cdr im) '(main user))) - ;; record Windows regsistry requests, if any - (let ([m (assoc 'extension-register aux)]) - (when (and m (cdr m)) - (update-register (cdr im) - "extreg.rktd" - (path-element->string - (file-name-from-path dest)) - (if (eq? (cdr im) 'main) - ;; make icon paths relative, if possible: - (for/list ([l (in-list (cdr m))]) - (for/list ([e (in-list l)] - [i (in-naturals)]) - (if (= i 3) - (let ([p (find-relative-path (find-lib-dir) e)]) - (if (member 'up (explode-path p)) - (path->bytes e) - (path->bytes p))) - e))) - (cdr m))))) - ;; record Windows start-menu requests, if any - (let ([m (assoc 'start-menu aux)]) - (when (and m (cdr m)) - (update-register (cdr im) - "startmenu.rktd" - (path-element->string - (file-name-from-path dest)) - (cdr m))))))) - -(define (installed-executable-path->desktop-path dest user?) - (unless (path-string? dest) - (raise-argument-error 'installed-executable-path->desktop-path - "path-string?" - dest)) - (define dir (if user? - (find-user-apps-dir) - (find-apps-dir))) - (path-replace-suffix (build-path dir (file-name-from-path dest)) - #".desktop")) - -(define (installed-desktop-path->icon-path dest user? extension) - ;; We put icons files in "share" so that `setup/unixstyle-install' - ;; knows how to fix up the "Icon" path in a ".desktop" file. - (unless (path-string? dest) - (raise-argument-error 'installed-desktop-path->icon-path - "path-string?" - dest)) - (unless (bytes? extension) - (raise-argument-error 'installed-desktop-path->icon-path - "bytes?" - extension)) - (build-path (if user? - (find-user-share-dir) - (find-share-dir)) - (path-replace-suffix - (file-name-from-path dest) - (bytes-append - #"-exe-icon." - extension)))) - -(define (check-desktop aux dest) - (when (eq? 'unix (system-type)) - (let ([im (assoc 'install-mode aux)]) - (when (and im (member (cdr im) '(main user))) - (define user? (eq? (cdr im) 'user)) - ;; create Unix ".desktop" files, if any - (let ([m (assoc 'desktop aux)]) - (when (and m (cdr m)) - (define file (installed-executable-path->desktop-path dest - user?)) - (make-directory* (path-only file)) - (define (adjust-path p) - ;; A ".desktop" file is supposed to have absolute paths - ;; for the executable and icon, but we don't want absolute - ;; paths in an in-place build. So, the ".desktop" files - ;; in an in-place build won't be usable directly, but they - ;; adn be patched up by `setup/unixstyle-install'. - (let ([p (simple-form-path (path->complete-path p))]) - (if (or user? - (get-absolute-installation?)) - p - (find-relative-path (simple-form-path (path-only file)) p)))) - (install-template file 'mzscheme "starter-sh" "starter-sh") ; for something that's executable - (call-with-output-file* - file - #:exists 'truncate - (lambda (o) - (displayln (regexp-replace #rx"\n+$" (cdr m) "") o) - (fprintf o "Exec=~a\n" (adjust-path dest)) - (let ([m (or (assq 'png aux) - (assq 'ico aux))]) - (when m - (define copy-dest - (installed-desktop-path->icon-path file - user? - (filename-extension (cdr m)))) - (unless (file-exists? copy-dest) - (copy-file (cdr m) copy-dest)) - (fprintf o "Icon=~a\n" (adjust-path copy-dest)))))))))))) - -(define (update-register mode filename key val) - (define dir (if (eq? mode 'main) - (find-lib-dir) - (find-user-lib-dir))) - (make-directory* dir) - (define file (build-path dir filename)) - (define table (if (file-exists? file) - (call-with-input-file* file read) - (hash))) - (unless (hash? table) (error 'make-launcher "expected a hash table in ~a" file)) - (call-with-output-file* - file - #:exists 'truncate/replace - (lambda (o) - (write (hash-set table key val) o) - (newline o)))) - -(define (utf-16-regexp b) - (byte-regexp (bytes-append (bytes->utf-16-bytes b) - #"[^>]*" - (bytes->utf-16-bytes #">")))) - -(define (make-windows-launcher kind variant flags dest aux) - (if (not (and (let ([m (assq 'independent? aux)]) - (and m (cdr m))))) - ;; Normal launcher: - (make-embedding-executable dest (eq? kind 'mred) - #f null null null flags aux #t variant - (if (let ([a (assq 'relative? aux)]) - (and a (cdr a))) - #f - (find-collects-dir))) - ;; Independent launcher (needed for Setup PLT): - (begin - (install-template dest kind "mzstart.exe" "mrstart.exe") - (let ([bstr (bytes->utf-16-bytes - (string->bytes/utf-8 (str-list->dos-str flags)))] - [p (open-input-file dest)] - [m (utf-16-regexp #"utf-16-bytes - (bytes-append - (path->bytes (let ([bin-dir (if (eq? kind 'mred) - (find-gui-bin-dir) - (find-console-bin-dir))]) - (if (let ([m (assq 'relative? aux)]) - (and m (cdr m))) - (or (relativize (normalize+explode-path bin-dir) - (normalize+explode-path dest)) - (build-path 'same)) - bin-dir))) - ;; null wchar marks end of executable directory - #"\0\0"))] - [find-it ; Find the magic start - (lambda (magic s) - (file-position p 0) - (let ([m (regexp-match-positions magic p)]) - (if m - (car m) - (begin - (close-input-port p) - (when (file-exists? dest) (delete-file dest)) - (error 'make-windows-launcher - "Couldn't find ~a position in template" s)))))] - [exedir-poslen (find-it x "executable path")] - [command-poslen (find-it m "command-line")] - [variant-poslen (find-it v "variant")] - [pos-exedir (car exedir-poslen)] - [len-exedir (- (cdr exedir-poslen) (car exedir-poslen))] - [pos-command (car command-poslen)] - [len-command (- (cdr command-poslen) (car command-poslen))] - [pos-variant (car variant-poslen)] - [space (char->integer #\space)] - [write-magic - (lambda (p s pos len) - (file-position p pos) - (display s p) - (display (make-bytes (- len (bytes-length s)) space) p))] - [check-len - (lambda (len s es) - (when (> (bytes-length s) len) - (when (file-exists? dest) (delete-file dest)) - (error - (format - "~a exceeds limit of ~a characters with ~a characters: ~a" - es len (string-length s) s))))]) - (close-input-port p) - (check-len len-exedir exedir "executable home directory") - (check-len len-command bstr "collection/file name") - (let ([p (open-output-file dest #:exists 'update)]) - (write-magic p exedir pos-exedir len-exedir) - (write-magic p (bytes-append bstr #"\0\0") pos-command len-command) - (let* ([suffix (variant-suffix (current-launcher-variant) #t)] - [suffix-bytes - (bytes-append - (list->bytes - (append-map (lambda (c) (list c 0)) - (bytes->list (string->bytes/latin-1 suffix)))) - #"\0\0")]) - (write-magic p suffix-bytes pos-variant (bytes-length suffix-bytes))) - (close-output-port p)))))) - (check-registry aux dest)) - -;; OS X launcher code: - -;; make-macosx-launcher : symbol (listof str) pathname -> -(define (make-macosx-launcher kind variant flags dest aux) - (if (or (eq? kind 'mzscheme) (script-variant? variant)) - ;; Racket or script launcher is the same as for Unix - (make-unix-launcher kind variant flags dest aux) - ;; GRacket "launcher" is a stand-alone executable - (make-embedding-executable dest (eq? kind 'mred) #f - null null null - flags - aux - #t - variant - (if (let ([a (assq 'relative? aux)]) - (and a (cdr a))) - #f - (find-collects-dir))))) - -(define (make-macos-launcher kind variant flags dest aux) - (install-template dest kind "GoMr" "GoMr") - (let* ([p (open-input-file dest)] - [m (regexp-match-positions #rx#"" p)]) - ;; fast-forward to the end: - (let ([s (make-bytes 4096)]) - (let loop () - (if (eof-object? (read-bytes! s p)) (file-position p) (loop)))) - (let ([data-fork-size (file-position p)]) - (close-input-port p) - (let ([p (open-output-file dest #:exists 'update)] - [str (str-list->sh-str - (append (if (eq? kind 'mred) null '("-Z")) flags))]) - (file-position p (caar m)) - (display (integer->integer-bytes (string-length str) 4 #t #t) p) - (display (integer->integer-bytes data-fork-size 4 #t #t) p) - (file-position p data-fork-size) - (display str p) - (close-output-port p))))) - -(define (get-maker) - (case (system-type) - [(unix) make-unix-launcher] - [(windows) make-windows-launcher] - [(macos) make-macos-launcher] - [(macosx) make-macosx-launcher])) - -(define (make-gracket-launcher flags dest [aux null]) - ((get-maker) 'mred (current-launcher-variant) flags dest aux)) -(define (make-mred-launcher flags dest [aux null]) - ((get-maker) 'mred (current-launcher-variant) (list* "-I" "scheme/gui/init" flags) dest aux)) - -(define (make-racket-launcher flags dest [aux null]) - ((get-maker) 'mzscheme (current-launcher-variant) flags dest aux)) -(define (make-mzscheme-launcher flags dest [aux null]) - ((get-maker) 'mzscheme (current-launcher-variant) (list* "-I" "scheme/init" flags) dest aux)) - -(define (strip-suffix s) - (path-replace-suffix s #"")) - -(define (extract-aux-from-path path) - (define path-bytes (path->bytes (if (string? path) - (string->path path) - path))) - (define len (bytes-length path-bytes)) - (define (try key suffix) - (if (and (len . > . (bytes-length suffix)) - (equal? (subbytes path-bytes (- len (bytes-length suffix))) - suffix)) - (list (cons key path)) - null)) - (define (log-fail l x) - (log-error "error using ~a for ~s: ~a" - (car l) - (cdr l) - (exn-message x))) - (append - (try 'icns #".icns") - (try 'ico #".ico") - (try 'png #".png") - (try 'independent? #".lch") - (let ([l (try 'creator #".creator")]) - (if (null? l) - l - (with-handlers ([exn:fail:filesystem? (lambda (x) (log-fail l x) null)]) - (with-input-from-file (cdar l) - (lambda () - (let ([s (read-string 4)]) - (if s (list (cons (caar l) s)) null))))))) - (let ([l (try 'file-types #".filetypes")]) - (if (null? l) - l - (with-handlers ([exn:fail:filesystem? (lambda (x) (log-fail l x) null)]) - (with-input-from-file (cdar l) - (lambda () - (let*-values ([(d) (read)] - [(local-dir base dir?) (split-path path)] - [(icon-files) - (append-map - (lambda (spec) - (let ([m (assoc "CFBundleTypeIconFile" spec)]) - (if m - (list (build-path - (if (eq? local-dir 'relative) - (current-directory) - (path->complete-path local-dir)) - (format "~a.icns" (cadr m)))) - null))) - d)]) - (list (cons 'file-types d) - (cons 'resource-files - (remove-duplicates icon-files))))))))) - (let ([l (try 'file-types #".utiexports")]) - (if (null? l) - l - (with-handlers ([exn:fail:filesystem? (lambda (x) (log-fail l x) null)]) - (with-input-from-file (cdar l) - (lambda () - (let ([d (read)]) - (list (cons 'uti-exports d)))))))) - (let ([l (try 'extension-register #".extreg")]) - (if (null? l) - l - (with-handlers ([exn:fail:filesystem? (lambda (x) (log-fail l x) null)]) - (with-input-from-file (cdar l) - (lambda () - (let ([d (read)]) - (list (cons 'extension-register - ;; Make icon paths absolute: - (for/list ([l (in-list d)]) - (for/list ([e (in-list l)] - [i (in-naturals)]) - (if (= i 3) - (path->complete-path - e - (path-only - (path->complete-path path))) - e))))))))))) - (let ([l (try 'start-menu #".startmenu")]) - (if (null? l) - l - (with-handlers ([exn:fail:filesystem? (lambda (x) (log-fail l x) null)]) - (with-input-from-file (cdar l) - (lambda () - (list - (cons 'start-menu - (let ([d (read)]) - (if (real? d) - d - #t))))))))) - (let ([l (try 'wm-class #".wmclass")]) - (if (null? l) - l - (with-handlers ([exn:fail:filesystem? (lambda (x) (log-fail l x) null)]) - (list (cons 'wm-class - (regexp-replace #rx"(?:\r\n|\r|\n)$" - (file->string (cdar l)) - "")))))) - (let ([l (try 'desktop #".desktop")]) - (if (null? l) - l - (with-handlers ([exn:fail:filesystem? (lambda (x) (log-fail l x) null)]) - (list (cons 'desktop (file->string (cdar l))))))))) - -(define (build-aux-from-path aux-root) - (let ([aux-root (if (string? aux-root) (string->path aux-root) aux-root)]) - (define (try suffix) - (let ([p (path-replace-suffix aux-root suffix)]) - (if (file-exists? p) - (extract-aux-from-path p) - null))) - (append - (try #".icns") - (try #".ico") - (try #".png") - (try #".lch") - (try #".creator") - (try #".filetypes") - (try #".utiexports") - (try #".extreg") - (try #".startmenu") - (try #".wmclass") - (try #".desktop")))) - -(define (make-gracket-program-launcher file collection dest) - (make-mred-launcher (list "-l-" (string-append collection "/" file)) - dest - (build-aux-from-path - (build-path (collection-path collection) - (strip-suffix file))))) -(define (make-mred-program-launcher file collection dest) - (make-gracket-program-launcher file collection dest)) - -(define (make-racket-program-launcher file collection dest) - (make-mzscheme-launcher (list "-l-" (string-append collection "/" file)) - dest - (build-aux-from-path - (build-path (collection-path collection) - (strip-suffix file))))) -(define (make-mzscheme-program-launcher file collection dest) - (make-racket-program-launcher file collection dest)) - -(define (unix-sfx file mred?) - (string-downcase (regexp-replace* #px"\\s" file "-"))) - -(define (sfx file mred?) - (case (system-type) - [(unix) (unix-sfx file mred?)] - [(windows) - (string-append (if mred? file (unix-sfx file mred?)) ".exe")] - [else file])) - -(define (program-launcher-path name mred? user?) - (let* ([variant (current-launcher-variant)] - [mac-script? (and (eq? (system-type) 'macosx) - (script-variant? variant))]) - (let ([p (add-file-suffix - (build-path - (if (or mac-script? (not mred?)) - (if user? - (find-user-console-bin-dir) - (find-console-bin-dir)) - (if user? - (find-user-gui-bin-dir) - (find-gui-bin-dir))) - ((if mac-script? unix-sfx sfx) name mred?)) - variant - mred?)]) - (if (and (eq? (system-type) 'macosx) - (not (script-variant? variant))) - (path-replace-suffix p #".app") - p)))) - -(define (gracket-program-launcher-path name #:user? [user? #f]) - (program-launcher-path name #t user?)) -(define (mred-program-launcher-path name #:user? [user? #f]) - (gracket-program-launcher-path name #:user? user?)) - -(define (racket-program-launcher-path name #:user? [user? #f]) - (case (system-type) - [(macosx) - (add-file-suffix (build-path (if user? - (find-user-console-bin-dir) - (find-console-bin-dir)) - (unix-sfx name #f)) - (current-launcher-variant) - #f)] - [else (program-launcher-path name #f user?)])) -(define (mzscheme-program-launcher-path name #:user? [user? #f]) - (racket-program-launcher-path name #:user? user?)) - -(define (gracket-launcher-is-directory?) - #f) -(define (racket-launcher-is-directory?) - #f) -(define (mred-launcher-is-directory?) - #f) -(define (mzscheme-launcher-is-directory?) - #f) - -(define (gracket-launcher-is-actually-directory?) - (and (eq? 'macosx (system-type)) - (not (script-variant? (current-launcher-variant))))) -(define (mred-launcher-is-actually-directory?) - (gracket-launcher-is-actually-directory?)) -(define (racket-launcher-is-actually-directory?) - #f) -(define (mzscheme-launcher-is-actually-directory?) - #f) - -;; Helper: -(define (put-file-extension+style+filters type) - (case type - [(windows) (values "exe" null '(("Executable" "*.exe")))] - [(macosx) (values "app" '(packages) '(("App" "*.app")))] - [else (values #f null null)])) - -(define (gracket-launcher-add-suffix path) - (embedding-executable-add-suffix path #t)) -(define (mred-launcher-add-suffix path) - (gracket-launcher-add-suffix path)) - -(define (racket-launcher-add-suffix path) - (embedding-executable-add-suffix path #f)) -(define (mzscheme-launcher-add-suffix path) - (racket-launcher-add-suffix path)) - -(define (gracket-launcher-put-file-extension+style+filters) - (put-file-extension+style+filters - (if (and (eq? 'macosx (system-type)) - (script-variant? (current-launcher-variant))) - 'unix - (system-type)))) -(define (mred-launcher-put-file-extension+style+filters) - (gracket-launcher-put-file-extension+style+filters)) - -(define (racket-launcher-put-file-extension+style+filters) - (put-file-extension+style+filters - (if (eq? 'macosx (system-type)) 'unix (system-type)))) -(define (mzscheme-launcher-put-file-extension+style+filters) - (racket-launcher-put-file-extension+style+filters)) - -(define (gracket-launcher-up-to-date? dest [aux null]) - (racket-launcher-up-to-date? dest aux)) -(define (mred-launcher-up-to-date? dest [aux null]) - (racket-launcher-up-to-date? dest aux)) -(define (mzscheme-launcher-up-to-date? dest [aux null]) - (racket-launcher-up-to-date? dest aux)) - -(define (racket-launcher-up-to-date? dest [aux null]) - (cond - ;; When running Setup PLT under Windows, the - ;; launcher process stays running until Racket - ;; completes, which means that it cannot be - ;; overwritten at that time. So we assume - ;; that a Setup-PLT-style independent launcher - ;; is always up-to-date. - [(eq? 'windows (system-type)) - (and (let ([m (assq 'independent? aux)]) (and m (cdr m))) - (file-exists? dest))] - ;; For any other setting, we could implement - ;; a fancy check, but for now always re-create - ;; launchers. - [else #f])) - -(define (install-gracket-program-launcher file collection name) - (make-gracket-program-launcher file collection - (gracket-program-launcher-path name))) - -(define (install-racket-program-launcher file collection name) - (make-racket-program-launcher file collection - (racket-program-launcher-path name))) - -(define (install-mred-program-launcher file collection name) - (make-mred-program-launcher file collection - (mred-program-launcher-path name))) - -(define (install-mzscheme-program-launcher file collection name) - (make-mzscheme-program-launcher file collection - (mzscheme-program-launcher-path name))) diff --git a/racket/collects/launcher/launcher.rkt b/racket/collects/launcher/launcher.rkt index 288d47e701..c08bc030fb 100644 --- a/racket/collects/launcher/launcher.rkt +++ b/racket/collects/launcher/launcher.rkt @@ -1,9 +1,997 @@ #lang racket/base -(require racket/unit - "launcher-sig.rkt" - "launcher-unit.rkt") +(require racket/path + racket/file + racket/list + racket/string -(define-values/invoke-unit/infer launcher@) + compiler/embed + setup/dirs + setup/variant -(provide-signature-elements launcher^) + compiler/private/winutf16) + + +(provide make-gracket-launcher + make-racket-launcher + make-mred-launcher + make-mzscheme-launcher + + make-gracket-program-launcher + make-racket-program-launcher + make-mred-program-launcher + make-mzscheme-program-launcher + + gracket-program-launcher-path + racket-program-launcher-path + mred-program-launcher-path + mzscheme-program-launcher-path + + install-gracket-program-launcher + install-racket-program-launcher + install-mred-program-launcher + install-mzscheme-program-launcher + + gracket-launcher-up-to-date? + racket-launcher-up-to-date? + mred-launcher-up-to-date? + mzscheme-launcher-up-to-date? + + gracket-launcher-is-directory? + racket-launcher-is-directory? + mred-launcher-is-directory? + mzscheme-launcher-is-directory? + + gracket-launcher-is-actually-directory? + racket-launcher-is-actually-directory? + mred-launcher-is-actually-directory? + mzscheme-launcher-is-actually-directory? + + gracket-launcher-add-suffix + racket-launcher-add-suffix + mred-launcher-add-suffix + mzscheme-launcher-add-suffix + + gracket-launcher-put-file-extension+style+filters + racket-launcher-put-file-extension+style+filters + mred-launcher-put-file-extension+style+filters + mzscheme-launcher-put-file-extension+style+filters + + build-aux-from-path + extract-aux-from-path + current-launcher-variant + available-mred-variants + available-mzscheme-variants + available-gracket-variants + available-racket-variants + + installed-executable-path->desktop-path + installed-desktop-path->icon-path) + +(define current-launcher-variant + (make-parameter (system-type 'gc) + (lambda (v) + (unless (memq v '(3m script-3m cgc script-cgc)) + (raise-type-error + 'current-launcher-variant + "variant symbol" + v)) + v))) + +(define (variant-available? kind cased-kind-name variant) + (cond + [(or (eq? 'unix (system-type)) + (and (eq? 'macosx (system-type)) + (eq? kind 'mzscheme))) + (let ([bin-dir (if (eq? kind 'mzscheme) + (find-console-bin-dir) + (find-lib-dir))]) + (and bin-dir + (file-exists? + (build-path bin-dir + (format "~a~a" + (case kind + [(mzscheme) 'racket] + [(mred) 'gracket]) + (variant-suffix variant #f))))))] + [(eq? 'macosx (system-type)) + ;; kind must be mred, because mzscheme case is caught above + (directory-exists? (build-path (find-lib-dir) + (format "~a~a.app" + cased-kind-name + (variant-suffix variant #f))))] + [(eq? 'windows (system-type)) + (file-exists? + (build-path + (if (eq? kind 'mzscheme) (find-console-bin-dir) (find-lib-dir)) + (format "~a~a.exe" cased-kind-name (variant-suffix variant #t))))] + [else (error "unknown system type")])) + +(define (available-variants kind) + (let* ([cased-kind-name (if (eq? kind 'mzscheme) + "Racket" + "GRacket")] + [normal-kind (system-type 'gc)] + [alt-kind (if (eq? '3m normal-kind) + 'cgc + '3m)] + [normal (if (variant-available? kind cased-kind-name normal-kind) + (list normal-kind) + null)] + [alt (if (variant-available? kind cased-kind-name alt-kind) + (list alt-kind) + null)] + [script (if (and (eq? 'macosx (system-type)) + (eq? kind 'mred) + (pair? normal)) + (if (eq? normal-kind '3m) + '(script-3m) + '(script-cgc)) + null)] + [script-alt (if (and (memq alt-kind alt) + (pair? script)) + (if (eq? alt-kind '3m) + '(script-3m) + '(script-cgc)) + null)]) + (append normal alt script script-alt))) + +(define (available-gracket-variants) + (available-variants 'mred)) +(define (available-mred-variants) + (available-variants 'mred)) + +(define (available-racket-variants) + (available-variants 'mzscheme)) +(define (available-mzscheme-variants) + (available-variants 'mzscheme)) + +(define (install-template dest kind mz mr) + (define src (build-path (find-lib-dir) + (if (eq? kind 'mzscheme) mz mr))) + (when (or (file-exists? dest) + (directory-exists? dest) + (link-exists? dest)) + (delete-directory/files dest)) + (copy-file src dest) + ;; make sure it's read/write/execute-able + (let* ([perms1 (file-or-directory-permissions dest 'bits)] + [perms2 (bitwise-ior user-read-bit user-write-bit user-execute-bit + perms1)]) + (unless (equal? perms1 perms2) + (file-or-directory-permissions dest perms2)))) + +(define (script-variant? v) + (memq v '(script-3m script-cgc))) + +(define (add-file-suffix path variant mred?) + (let ([s (variant-suffix + variant + (case (system-type) + [(unix) #f] + [(windows) #t] + [(macosx) (and mred? (not (script-variant? variant)))]))]) + (if (string=? "" s) + path + (path-replace-suffix + path + (string->bytes/utf-8 + (if (and (eq? 'windows (system-type)) + (regexp-match #rx#"[.]exe$" (path->bytes path))) + (format "~a.exe" s) + s)))))) + +(define (string-append/spaces f flags) + (string-append* (append-map (lambda (x) (list (f x) " ")) flags))) + +(define (str-list->sh-str flags) + (string-append/spaces + (lambda (s) + (string-append "'" (regexp-replace* #rx"'" s "'\"'\"'") "'")) + flags)) + +(define (str-list->dos-str flags) + (define (trans s) + (if (not (regexp-match? #rx"[ \n\t\r\v\"\\]" s)) + s + (list->string + (let loop ([l (string->list s)] [slashes '()]) + (cond [(null? l) '()] + [(char-whitespace? (car l)) + `(,@slashes #\" ,(car l) #\" ,@(loop (cdr l) '()))] + [(eq? #\\ (car l)) + `(#\\ ,@(loop (cdr l) (cons #\\ slashes)))] + [(eq? #\" (car l)) + `(,@slashes #\" #\\ #\" #\" ,@(loop (cdr l) '()))] + [else `(,(car l) ,@(loop (cdr l) '()))]))))) + (string-append/spaces trans flags)) + +(define one-arg-x-flags '((xa "-display") + (xb "-geometry") + (xc "-bg" "-background") + (xd "-fg" "-foregound") + (xe "-font") + (xf "-name") + (xg "-selectionTimeout") + (xh "-title") + (xi "-xnllanguage") + (xj "-xrm"))) +(define no-arg-x-flags '((xk "-iconic") + (xl "-rv" "-reverse") + (xm "+rv") + (xn "-synchronous") + (xo "-singleInstance"))) + +(define (skip-x-flags flags) + (let ([xfmem (lambda (flag) (lambda (xf) (member flag (cdr xf))))]) + (let loop ([f flags]) + (cond [(null? f) null] + [(ormap (xfmem (car f)) one-arg-x-flags) + (if (null? (cdr f)) null (loop (cddr f)))] + [(ormap (xfmem (car f)) no-arg-x-flags) (loop (cdr f))] + [else f])))) + +(define (output-x-arg-getter exec args) + (let ([or-flags (lambda (l) (string-append* (add-between l " | ")))]) + (string-append* + (append + (list "# Find X flags and shift them to the front\n" + "findxend() {\n" + " oneargflag=''\n" + " case \"$1\" in\n") + (map + (lambda (f) + (format (string-append + " ~a)\n" + " oneargflag=\"$1\"\n" + " ~a=\"$2\"\n" + " ;;\n") + (or-flags (cdr f)) + (car f))) + one-arg-x-flags) + (map + (lambda (f) + (format " ~a)\n ~a=yes\n ;;\n" (or-flags (cdr f)) (car f))) + no-arg-x-flags) + (list + (format (string-append + " *)\n ~a~a ~a ;;\n" + " esac\n" + " shift\n" + " if [ \"$oneargflag\" != '' ] ; then\n" + " if [ \"${1+n}\" != 'n' ] ; then echo $0: missing argument for standard X flag $oneargflag ; exit 1 ; fi\n" + " shift\n" + " fi\n" + " findxend ${1+\"$@\"}\n" + "}\nfindxend ${1+\"$@\"}\n") + exec + (string-append* + (append + (map (lambda (f) + (format " ${~a+\"~a\"} ${~a+\"$~a\"}" + (car f) (cadr f) (car f) (car f))) + one-arg-x-flags) + (map (lambda (f) + (format " ${~a+\"~a\"}" (car f) (cadr f))) + no-arg-x-flags))) + args)))))) + +(define (protect-shell-string s) + (regexp-replace* + #rx"[\"`'$\\]" (if (path? s) (path->string s) s) "\\\\&")) + +(define (normalize+explode-path p) + (explode-path (normal-case-path (simple-form-path p)))) + +(define (relativize bindir-explode dest-explode) + (let loop ([b bindir-explode] [d dest-explode]) + (if (and (pair? b) (equal? (car b) (car d))) + (loop (cdr b) (cdr d)) + (let ([p (append (map (lambda (x) 'up) (cdr d)) b)]) + (if (null? p) #f (apply build-path p)))))) + +(define (make-relative-path-header dest bindir use-librktdir?) + ;; rely only on binaries in /usr/bin:/bin + (define (has-exe? exe) + (or (file-exists? (build-path "/usr/bin" exe)) + (file-exists? (build-path "/bin" exe)))) + (let* ([has-readlink? (and (not (eq? 'macosx (system-type))) + (has-exe? "readlink"))] + [dest-explode (normalize+explode-path dest)] + [bindir-explode (normalize+explode-path bindir)]) + (if (and (has-exe? "dirname") (has-exe? "basename") + (or has-readlink? (and (has-exe? "ls") (has-exe? "sed"))) + (equal? (car dest-explode) (car bindir-explode))) + (string-append + "# Make this PATH-independent\n" + "saveP=\"$PATH\"\n" + "PATH=\"/usr/bin:/bin\"\n" + "\n" + (if has-readlink? "" + (string-append + "# imitate possibly-missing readlink\n" + "readlink() {\n" + " ls -l -- \"$1\" | sed -e \"s/^.* -> //\"\n" + "}\n" + "\n")) + "# Remember current directory\n" + "saveD=`pwd`\n" + "\n" + "# Find absolute path to this script,\n" + "# resolving symbolic references to the end\n" + "# (changes the current directory):\n" + "D=`dirname \"$0\"`\n" + "F=`basename \"$0\"`\n" + "cd \"$D\"\n" + "while test " + ;; On solaris, Edward Chrzanowski from Waterloo says that the man + ;; page says that -L is not supported, but -h is; on other systems + ;; (eg, freebsd) -h is listed as a compatibility feature + (if (regexp-match #rx"solaris" (path->string + (system-library-subpath))) + "-h" "-L") + " \"$F\"; do\n" + " P=`readlink \"$F\"`\n" + " D=`dirname \"$P\"`\n" + " F=`basename \"$P\"`\n" + " cd \"$D\"\n" + "done\n" + "D=`pwd`\n" + "\n" + "# Restore current directory\n" + "cd \"$saveD\"\n" + "\n" + "bindir=\"$D" + (if use-librktdir? + "" + (let ([s (relativize bindir-explode dest-explode)]) + (if s (string-append "/" (protect-shell-string s)) ""))) + "\"\n" + "PATH=\"$saveP\"\n") + ;; fallback to absolute path header + (make-absolute-path-header bindir)))) + +(define (make-absolute-path-header bindir) + (string-append "bindir=\""(protect-shell-string bindir)"\"\n")) + +(define (make-unix-launcher kind variant flags dest aux) + (install-template dest kind "starter-sh" "starter-sh") ; just for something that's executable + (let* ([alt-exe (let ([m (and (eq? kind 'mred) + (script-variant? variant) + (assq 'exe-name aux))]) + (and m + (format "~a~a.app/Contents/MacOS/~a~a" + (cdr m) (variant-suffix variant #t) + (cdr m) (variant-suffix variant #t))))] + [x-flags? (and (eq? kind 'mred) + (eq? (system-type) 'unix) + (not (script-variant? variant)))] + [flags (let ([m (assq 'wm-class aux)]) + (if m + (list* "-J" (cdr m) flags) + flags))] + [post-flags (cond + [x-flags? (skip-x-flags flags)] + [alt-exe null] + [else flags])] + [pre-flags (cond + [(not x-flags?) null] + [else + (let loop ([f flags]) + (if (eq? f post-flags) + null + (cons (car f) (loop (cdr f)))))])] + [pre-str (str-list->sh-str pre-flags)] + [post-str (str-list->sh-str post-flags)] + [header (string-append + "#!/bin/sh\n" + "# This script was created by make-" + (symbol->string kind)"-launcher\n")] + [use-librktdir? (if alt-exe + (let ([m (assq 'exe-is-gracket aux)]) + (and m (cdr m))) + (eq? kind 'mred))] + [dir-finder + (let ([bindir (if alt-exe + (let ([m (assq 'exe-is-gracket aux)]) + (if (and m (cdr m)) + (find-lib-dir) + (let ([p (path-only dest)]) + (if (eq? 'macosx (system-type)) + (build-path p 'up) + p)))) + (find-console-bin-dir))]) + (if (let ([a (assq 'relative? aux)]) + (and a (cdr a))) + (make-relative-path-header dest bindir use-librktdir?) + (make-absolute-path-header bindir)))] + [exec (format + "exec \"${~a}/~a~a\" ~a" + (if use-librktdir? + "librktdir" + "bindir") + (or alt-exe (case kind + [(mred) (if (eq? 'macosx (system-type)) + (format "GRacket~a.app/Contents/MacOS/Gracket" + (variant-suffix variant #t)) + "gracket")] + [(mzscheme) "racket"])) + (if alt-exe + "" + (variant-suffix variant (and (eq? kind 'mred) + (eq? 'macosx (system-type))))) + pre-str)] + [args (format + "~a~a ${1+\"$@\"}\n" + (if alt-exe "" "-N \"$0\" ") + post-str)] + [assemble-exec (if (and (eq? kind 'mred) + (not (script-variant? variant)) + (not (null? post-flags))) + output-x-arg-getter + string-append)]) + (unless (find-console-bin-dir) + (error 'make-unix-launcher "unable to locate bin directory")) + (with-output-to-file dest + #:exists 'truncate + (lambda () + (display header) + (newline) + ;; comments needed to rehack launchers when paths change + ;; (see setup/unixstyle-install.rkt) + (display "# {{{ bindir\n") + (display dir-finder) + (display "# }}} bindir\n") + (when use-librktdir? + (display "# {{{ librktdir\n") + (display "librktdir=\"$bindir/../lib\"\n") + (display "# }}} librktdir\n")) + (newline) + (display (assemble-exec exec args))))) + (check-desktop aux dest)) + +(define (check-registry aux dest) + (let ([im (assoc 'install-mode aux)]) + (when (and im (member (cdr im) '(main user))) + ;; record Windows regsistry requests, if any + (let ([m (assoc 'extension-register aux)]) + (when (and m (cdr m)) + (update-register (cdr im) + "extreg.rktd" + (path-element->string + (file-name-from-path dest)) + (if (eq? (cdr im) 'main) + ;; make icon paths relative, if possible: + (for/list ([l (in-list (cdr m))]) + (for/list ([e (in-list l)] + [i (in-naturals)]) + (if (= i 3) + (let ([p (find-relative-path (find-lib-dir) e)]) + (if (member 'up (explode-path p)) + (path->bytes e) + (path->bytes p))) + e))) + (cdr m))))) + ;; record Windows start-menu requests, if any + (let ([m (assoc 'start-menu aux)]) + (when (and m (cdr m)) + (update-register (cdr im) + "startmenu.rktd" + (path-element->string + (file-name-from-path dest)) + (cdr m))))))) + +(define (installed-executable-path->desktop-path dest user?) + (unless (path-string? dest) + (raise-argument-error 'installed-executable-path->desktop-path + "path-string?" + dest)) + (define dir (if user? + (find-user-apps-dir) + (find-apps-dir))) + (path-replace-suffix (build-path dir (file-name-from-path dest)) + #".desktop")) + +(define (installed-desktop-path->icon-path dest user? extension) + ;; We put icons files in "share" so that `setup/unixstyle-install' + ;; knows how to fix up the "Icon" path in a ".desktop" file. + (unless (path-string? dest) + (raise-argument-error 'installed-desktop-path->icon-path + "path-string?" + dest)) + (unless (bytes? extension) + (raise-argument-error 'installed-desktop-path->icon-path + "bytes?" + extension)) + (build-path (if user? + (find-user-share-dir) + (find-share-dir)) + (path-replace-suffix + (file-name-from-path dest) + (bytes-append + #"-exe-icon." + extension)))) + +(define (check-desktop aux dest) + (when (eq? 'unix (system-type)) + (let ([im (assoc 'install-mode aux)]) + (when (and im (member (cdr im) '(main user))) + (define user? (eq? (cdr im) 'user)) + ;; create Unix ".desktop" files, if any + (let ([m (assoc 'desktop aux)]) + (when (and m (cdr m)) + (define file (installed-executable-path->desktop-path dest + user?)) + (make-directory* (path-only file)) + (define (adjust-path p) + ;; A ".desktop" file is supposed to have absolute paths + ;; for the executable and icon, but we don't want absolute + ;; paths in an in-place build. So, the ".desktop" files + ;; in an in-place build won't be usable directly, but they + ;; adn be patched up by `setup/unixstyle-install'. + (let ([p (simple-form-path (path->complete-path p))]) + (if (or user? + (get-absolute-installation?)) + p + (find-relative-path (simple-form-path (path-only file)) p)))) + (install-template file 'mzscheme "starter-sh" "starter-sh") ; for something that's executable + (call-with-output-file* + file + #:exists 'truncate + (lambda (o) + (displayln (regexp-replace #rx"\n+$" (cdr m) "") o) + (fprintf o "Exec=~a\n" (adjust-path dest)) + (let ([m (or (assq 'png aux) + (assq 'ico aux))]) + (when m + (define copy-dest + (installed-desktop-path->icon-path file + user? + (filename-extension (cdr m)))) + (unless (file-exists? copy-dest) + (copy-file (cdr m) copy-dest)) + (fprintf o "Icon=~a\n" (adjust-path copy-dest)))))))))))) + +(define (update-register mode filename key val) + (define dir (if (eq? mode 'main) + (find-lib-dir) + (find-user-lib-dir))) + (make-directory* dir) + (define file (build-path dir filename)) + (define table (if (file-exists? file) + (call-with-input-file* file read) + (hash))) + (unless (hash? table) (error 'make-launcher "expected a hash table in ~a" file)) + (call-with-output-file* + file + #:exists 'truncate/replace + (lambda (o) + (write (hash-set table key val) o) + (newline o)))) + +(define (utf-16-regexp b) + (byte-regexp (bytes-append (bytes->utf-16-bytes b) + #"[^>]*" + (bytes->utf-16-bytes #">")))) + +(define (make-windows-launcher kind variant flags dest aux) + (if (not (and (let ([m (assq 'independent? aux)]) + (and m (cdr m))))) + ;; Normal launcher: + (make-embedding-executable dest (eq? kind 'mred) + #f null null null flags aux #t variant + (if (let ([a (assq 'relative? aux)]) + (and a (cdr a))) + #f + (find-collects-dir))) + ;; Independent launcher (needed for Setup PLT): + (begin + (install-template dest kind "mzstart.exe" "mrstart.exe") + (let ([bstr (bytes->utf-16-bytes + (string->bytes/utf-8 (str-list->dos-str flags)))] + [p (open-input-file dest)] + [m (utf-16-regexp #"utf-16-bytes + (bytes-append + (path->bytes (let ([bin-dir (if (eq? kind 'mred) + (find-gui-bin-dir) + (find-console-bin-dir))]) + (if (let ([m (assq 'relative? aux)]) + (and m (cdr m))) + (or (relativize (normalize+explode-path bin-dir) + (normalize+explode-path dest)) + (build-path 'same)) + bin-dir))) + ;; null wchar marks end of executable directory + #"\0\0"))] + [find-it ; Find the magic start + (lambda (magic s) + (file-position p 0) + (let ([m (regexp-match-positions magic p)]) + (if m + (car m) + (begin + (close-input-port p) + (when (file-exists? dest) (delete-file dest)) + (error 'make-windows-launcher + "Couldn't find ~a position in template" s)))))] + [exedir-poslen (find-it x "executable path")] + [command-poslen (find-it m "command-line")] + [variant-poslen (find-it v "variant")] + [pos-exedir (car exedir-poslen)] + [len-exedir (- (cdr exedir-poslen) (car exedir-poslen))] + [pos-command (car command-poslen)] + [len-command (- (cdr command-poslen) (car command-poslen))] + [pos-variant (car variant-poslen)] + [space (char->integer #\space)] + [write-magic + (lambda (p s pos len) + (file-position p pos) + (display s p) + (display (make-bytes (- len (bytes-length s)) space) p))] + [check-len + (lambda (len s es) + (when (> (bytes-length s) len) + (when (file-exists? dest) (delete-file dest)) + (error + (format + "~a exceeds limit of ~a characters with ~a characters: ~a" + es len (string-length s) s))))]) + (close-input-port p) + (check-len len-exedir exedir "executable home directory") + (check-len len-command bstr "collection/file name") + (let ([p (open-output-file dest #:exists 'update)]) + (write-magic p exedir pos-exedir len-exedir) + (write-magic p (bytes-append bstr #"\0\0") pos-command len-command) + (let* ([suffix (variant-suffix (current-launcher-variant) #t)] + [suffix-bytes + (bytes-append + (list->bytes + (append-map (lambda (c) (list c 0)) + (bytes->list (string->bytes/latin-1 suffix)))) + #"\0\0")]) + (write-magic p suffix-bytes pos-variant (bytes-length suffix-bytes))) + (close-output-port p)))))) + (check-registry aux dest)) + +;; OS X launcher code: + +;; make-macosx-launcher : symbol (listof str) pathname -> +(define (make-macosx-launcher kind variant flags dest aux) + (if (or (eq? kind 'mzscheme) (script-variant? variant)) + ;; Racket or script launcher is the same as for Unix + (make-unix-launcher kind variant flags dest aux) + ;; GRacket "launcher" is a stand-alone executable + (make-embedding-executable dest (eq? kind 'mred) #f + null null null + flags + aux + #t + variant + (if (let ([a (assq 'relative? aux)]) + (and a (cdr a))) + #f + (find-collects-dir))))) + +(define (make-macos-launcher kind variant flags dest aux) + (install-template dest kind "GoMr" "GoMr") + (let* ([p (open-input-file dest)] + [m (regexp-match-positions #rx#"" p)]) + ;; fast-forward to the end: + (let ([s (make-bytes 4096)]) + (let loop () + (if (eof-object? (read-bytes! s p)) (file-position p) (loop)))) + (let ([data-fork-size (file-position p)]) + (close-input-port p) + (let ([p (open-output-file dest #:exists 'update)] + [str (str-list->sh-str + (append (if (eq? kind 'mred) null '("-Z")) flags))]) + (file-position p (caar m)) + (display (integer->integer-bytes (string-length str) 4 #t #t) p) + (display (integer->integer-bytes data-fork-size 4 #t #t) p) + (file-position p data-fork-size) + (display str p) + (close-output-port p))))) + +(define (get-maker) + (case (system-type) + [(unix) make-unix-launcher] + [(windows) make-windows-launcher] + [(macos) make-macos-launcher] + [(macosx) make-macosx-launcher])) + +(define (make-gracket-launcher flags dest [aux null]) + ((get-maker) 'mred (current-launcher-variant) flags dest aux)) +(define (make-mred-launcher flags dest [aux null]) + ((get-maker) 'mred (current-launcher-variant) (list* "-I" "scheme/gui/init" flags) dest aux)) + +(define (make-racket-launcher flags dest [aux null]) + ((get-maker) 'mzscheme (current-launcher-variant) flags dest aux)) +(define (make-mzscheme-launcher flags dest [aux null]) + ((get-maker) 'mzscheme (current-launcher-variant) (list* "-I" "scheme/init" flags) dest aux)) + +(define (strip-suffix s) + (path-replace-suffix s #"")) + +(define (extract-aux-from-path path) + (define path-bytes (path->bytes (if (string? path) + (string->path path) + path))) + (define len (bytes-length path-bytes)) + (define (try key suffix) + (if (and (len . > . (bytes-length suffix)) + (equal? (subbytes path-bytes (- len (bytes-length suffix))) + suffix)) + (list (cons key path)) + null)) + (define (log-fail l x) + (log-error "error using ~a for ~s: ~a" + (car l) + (cdr l) + (exn-message x))) + (append + (try 'icns #".icns") + (try 'ico #".ico") + (try 'png #".png") + (try 'independent? #".lch") + (let ([l (try 'creator #".creator")]) + (if (null? l) + l + (with-handlers ([exn:fail:filesystem? (lambda (x) (log-fail l x) null)]) + (with-input-from-file (cdar l) + (lambda () + (let ([s (read-string 4)]) + (if s (list (cons (caar l) s)) null))))))) + (let ([l (try 'file-types #".filetypes")]) + (if (null? l) + l + (with-handlers ([exn:fail:filesystem? (lambda (x) (log-fail l x) null)]) + (with-input-from-file (cdar l) + (lambda () + (let*-values ([(d) (read)] + [(local-dir base dir?) (split-path path)] + [(icon-files) + (append-map + (lambda (spec) + (let ([m (assoc "CFBundleTypeIconFile" spec)]) + (if m + (list (build-path + (if (eq? local-dir 'relative) + (current-directory) + (path->complete-path local-dir)) + (format "~a.icns" (cadr m)))) + null))) + d)]) + (list (cons 'file-types d) + (cons 'resource-files + (remove-duplicates icon-files))))))))) + (let ([l (try 'file-types #".utiexports")]) + (if (null? l) + l + (with-handlers ([exn:fail:filesystem? (lambda (x) (log-fail l x) null)]) + (with-input-from-file (cdar l) + (lambda () + (let ([d (read)]) + (list (cons 'uti-exports d)))))))) + (let ([l (try 'extension-register #".extreg")]) + (if (null? l) + l + (with-handlers ([exn:fail:filesystem? (lambda (x) (log-fail l x) null)]) + (with-input-from-file (cdar l) + (lambda () + (let ([d (read)]) + (list (cons 'extension-register + ;; Make icon paths absolute: + (for/list ([l (in-list d)]) + (for/list ([e (in-list l)] + [i (in-naturals)]) + (if (= i 3) + (path->complete-path + e + (path-only + (path->complete-path path))) + e))))))))))) + (let ([l (try 'start-menu #".startmenu")]) + (if (null? l) + l + (with-handlers ([exn:fail:filesystem? (lambda (x) (log-fail l x) null)]) + (with-input-from-file (cdar l) + (lambda () + (list + (cons 'start-menu + (let ([d (read)]) + (if (real? d) + d + #t))))))))) + (let ([l (try 'wm-class #".wmclass")]) + (if (null? l) + l + (with-handlers ([exn:fail:filesystem? (lambda (x) (log-fail l x) null)]) + (list (cons 'wm-class + (regexp-replace #rx"(?:\r\n|\r|\n)$" + (file->string (cdar l)) + "")))))) + (let ([l (try 'desktop #".desktop")]) + (if (null? l) + l + (with-handlers ([exn:fail:filesystem? (lambda (x) (log-fail l x) null)]) + (list (cons 'desktop (file->string (cdar l))))))))) + +(define (build-aux-from-path aux-root) + (let ([aux-root (if (string? aux-root) (string->path aux-root) aux-root)]) + (define (try suffix) + (let ([p (path-replace-suffix aux-root suffix)]) + (if (file-exists? p) + (extract-aux-from-path p) + null))) + (append + (try #".icns") + (try #".ico") + (try #".png") + (try #".lch") + (try #".creator") + (try #".filetypes") + (try #".utiexports") + (try #".extreg") + (try #".startmenu") + (try #".wmclass") + (try #".desktop")))) + +(define (make-gracket-program-launcher file collection dest) + (make-mred-launcher (list "-l-" (string-append collection "/" file)) + dest + (build-aux-from-path + (build-path (collection-path collection) + (strip-suffix file))))) +(define (make-mred-program-launcher file collection dest) + (make-gracket-program-launcher file collection dest)) + +(define (make-racket-program-launcher file collection dest) + (make-mzscheme-launcher (list "-l-" (string-append collection "/" file)) + dest + (build-aux-from-path + (build-path (collection-path collection) + (strip-suffix file))))) +(define (make-mzscheme-program-launcher file collection dest) + (make-racket-program-launcher file collection dest)) + +(define (unix-sfx file mred?) + (string-downcase (regexp-replace* #px"\\s" file "-"))) + +(define (sfx file mred?) + (case (system-type) + [(unix) (unix-sfx file mred?)] + [(windows) + (string-append (if mred? file (unix-sfx file mred?)) ".exe")] + [else file])) + +(define (program-launcher-path name mred? user?) + (let* ([variant (current-launcher-variant)] + [mac-script? (and (eq? (system-type) 'macosx) + (script-variant? variant))]) + (let ([p (add-file-suffix + (build-path + (if (or mac-script? (not mred?)) + (if user? + (find-user-console-bin-dir) + (find-console-bin-dir)) + (if user? + (find-user-gui-bin-dir) + (find-gui-bin-dir))) + ((if mac-script? unix-sfx sfx) name mred?)) + variant + mred?)]) + (if (and (eq? (system-type) 'macosx) + (not (script-variant? variant))) + (path-replace-suffix p #".app") + p)))) + +(define (gracket-program-launcher-path name #:user? [user? #f]) + (program-launcher-path name #t user?)) +(define (mred-program-launcher-path name #:user? [user? #f]) + (gracket-program-launcher-path name #:user? user?)) + +(define (racket-program-launcher-path name #:user? [user? #f]) + (case (system-type) + [(macosx) + (add-file-suffix (build-path (if user? + (find-user-console-bin-dir) + (find-console-bin-dir)) + (unix-sfx name #f)) + (current-launcher-variant) + #f)] + [else (program-launcher-path name #f user?)])) +(define (mzscheme-program-launcher-path name #:user? [user? #f]) + (racket-program-launcher-path name #:user? user?)) + +(define (gracket-launcher-is-directory?) + #f) +(define (racket-launcher-is-directory?) + #f) +(define (mred-launcher-is-directory?) + #f) +(define (mzscheme-launcher-is-directory?) + #f) + +(define (gracket-launcher-is-actually-directory?) + (and (eq? 'macosx (system-type)) + (not (script-variant? (current-launcher-variant))))) +(define (mred-launcher-is-actually-directory?) + (gracket-launcher-is-actually-directory?)) +(define (racket-launcher-is-actually-directory?) + #f) +(define (mzscheme-launcher-is-actually-directory?) + #f) + +;; Helper: +(define (put-file-extension+style+filters type) + (case type + [(windows) (values "exe" null '(("Executable" "*.exe")))] + [(macosx) (values "app" '(packages) '(("App" "*.app")))] + [else (values #f null null)])) + +(define (gracket-launcher-add-suffix path) + (embedding-executable-add-suffix path #t)) +(define (mred-launcher-add-suffix path) + (gracket-launcher-add-suffix path)) + +(define (racket-launcher-add-suffix path) + (embedding-executable-add-suffix path #f)) +(define (mzscheme-launcher-add-suffix path) + (racket-launcher-add-suffix path)) + +(define (gracket-launcher-put-file-extension+style+filters) + (put-file-extension+style+filters + (if (and (eq? 'macosx (system-type)) + (script-variant? (current-launcher-variant))) + 'unix + (system-type)))) +(define (mred-launcher-put-file-extension+style+filters) + (gracket-launcher-put-file-extension+style+filters)) + +(define (racket-launcher-put-file-extension+style+filters) + (put-file-extension+style+filters + (if (eq? 'macosx (system-type)) 'unix (system-type)))) +(define (mzscheme-launcher-put-file-extension+style+filters) + (racket-launcher-put-file-extension+style+filters)) + +(define (gracket-launcher-up-to-date? dest [aux null]) + (racket-launcher-up-to-date? dest aux)) +(define (mred-launcher-up-to-date? dest [aux null]) + (racket-launcher-up-to-date? dest aux)) +(define (mzscheme-launcher-up-to-date? dest [aux null]) + (racket-launcher-up-to-date? dest aux)) + +(define (racket-launcher-up-to-date? dest [aux null]) + (cond + ;; When running Setup PLT under Windows, the + ;; launcher process stays running until Racket + ;; completes, which means that it cannot be + ;; overwritten at that time. So we assume + ;; that a Setup-PLT-style independent launcher + ;; is always up-to-date. + [(eq? 'windows (system-type)) + (and (let ([m (assq 'independent? aux)]) (and m (cdr m))) + (file-exists? dest))] + ;; For any other setting, we could implement + ;; a fancy check, but for now always re-create + ;; launchers. + [else #f])) + +(define (install-gracket-program-launcher file collection name) + (make-gracket-program-launcher file collection + (gracket-program-launcher-path name))) + +(define (install-racket-program-launcher file collection name) + (make-racket-program-launcher file collection + (racket-program-launcher-path name))) + +(define (install-mred-program-launcher file collection name) + (make-mred-program-launcher file collection + (mred-program-launcher-path name))) + +(define (install-mzscheme-program-launcher file collection name) + (make-mzscheme-program-launcher file collection + (mzscheme-program-launcher-path name))) diff --git a/racket/collects/setup/option-unit.rkt b/racket/collects/setup/option-unit.rkt deleted file mode 100644 index f0959e42e8..0000000000 --- a/racket/collects/setup/option-unit.rkt +++ /dev/null @@ -1,67 +0,0 @@ -#lang racket/base -(require racket/unit - racket/future - "option-sig.rkt") - -(provide setup:option@ set-flag-params) - -;; a way to define a parameter that is set from an alist of names and values -(define defined-flag-params (make-parameter '())) -(define-syntax-rule (define-flag-param name default) - (define name - (let ([param (make-parameter default)]) - (defined-flag-params (cons (cons 'name param) (defined-flag-params))) - param))) -(define (set-flag-params* flags flag-params) - (for ([name+param flag-params]) - (cond [(assq (car name+param) flags) - => (lambda (x) ((cdr name+param) (cadr x)))]))) -;; this macro is used to actually do the setting, `more ...' is for additional -;; parameters to set -(define-syntax-rule (set-flag-params flags more ...) - (set-flag-params* flags (list* (cons 'more more) ... (defined-flag-params)))) - -(define-unit setup:option@ - (import) - (export setup-option^) - - (define setup-program-name (make-parameter "raco setup")) - - (define-flag-param parallel-workers (min (processor-count) - (if (fixnum? (arithmetic-shift 1 40)) - 8 ; 64-bit machine - 4))) ; 32-bit machine - (define-flag-param verbose #f) - (define-flag-param make-verbose #f) - (define-flag-param compiler-verbose #f) - (define-flag-param clean #f) - (define-flag-param compile-mode #f) - (define-flag-param make-only #f) - (define-flag-param make-zo #t) - (define-flag-param make-launchers #t) - (define-flag-param make-foreign-libs #t) - (define-flag-param make-info-domain #t) - (define-flag-param make-docs #t) - (define-flag-param make-user #t) - (define-flag-param make-planet #t) - (define-flag-param avoid-main-installation #f) - (define-flag-param make-tidy #f) - (define-flag-param make-doc-index #f) - (define-flag-param check-dependencies #t) - (define-flag-param fix-dependencies #f) - (define-flag-param call-install #t) - (define-flag-param call-post-install #t) - (define-flag-param pause-on-errors #f) - (define-flag-param force-unpacks #f) - (define-flag-param doc-pdf-dest #f) - - (define specific-collections (make-parameter null)) - (define specific-planet-dirs (make-parameter null)) - - (define archives (make-parameter null)) - (define archive-implies-reindex (make-parameter #t)) - - (define current-target-directory-getter (make-parameter current-directory)) - (define current-target-plt-directory-getter - (make-parameter - (lambda (preferred main-collects-parent-dir choices) preferred)))) diff --git a/racket/collects/setup/option.rkt b/racket/collects/setup/option.rkt new file mode 100644 index 0000000000..dc81e802ad --- /dev/null +++ b/racket/collects/setup/option.rkt @@ -0,0 +1,71 @@ +#lang racket/base +(require racket/future) + +;; other params are provided by declaration +(provide set-flag-params + setup-program-name + specific-collections + specific-planet-dirs + archives + archive-implies-reindex + current-target-directory-getter + current-target-plt-directory-getter) + +;; a way to define a parameter that is set from an alist of names and values +(define defined-flag-params (make-parameter '())) +(define-syntax-rule (define-flag-param name default) + (begin + (provide name) + (define name + (let ([param (make-parameter default)]) + (defined-flag-params (cons (cons 'name param) (defined-flag-params))) + param)))) +(define (set-flag-params* flags flag-params) + (for ([name+param flag-params]) + (cond [(assq (car name+param) flags) + => (lambda (x) ((cdr name+param) (cadr x)))]))) +;; this macro is used to actually do the setting, `more ...' is for additional +;; parameters to set +(define-syntax-rule (set-flag-params flags more ...) + (set-flag-params* flags (list* (cons 'more more) ... (defined-flag-params)))) + +(define setup-program-name (make-parameter "raco setup")) + +(define-flag-param parallel-workers (min (processor-count) + (if (fixnum? (arithmetic-shift 1 40)) + 8 ; 64-bit machine + 4))) ; 32-bit machine +(define-flag-param verbose #f) +(define-flag-param make-verbose #f) +(define-flag-param compiler-verbose #f) +(define-flag-param clean #f) +(define-flag-param compile-mode #f) +(define-flag-param make-only #f) +(define-flag-param make-zo #t) +(define-flag-param make-launchers #t) +(define-flag-param make-foreign-libs #t) +(define-flag-param make-info-domain #t) +(define-flag-param make-docs #t) +(define-flag-param make-user #t) +(define-flag-param make-planet #t) +(define-flag-param avoid-main-installation #f) +(define-flag-param make-tidy #f) +(define-flag-param make-doc-index #f) +(define-flag-param check-dependencies #t) +(define-flag-param fix-dependencies #f) +(define-flag-param call-install #t) +(define-flag-param call-post-install #t) +(define-flag-param pause-on-errors #f) +(define-flag-param force-unpacks #f) +(define-flag-param doc-pdf-dest #f) + +(define specific-collections (make-parameter null)) +(define specific-planet-dirs (make-parameter null)) + +(define archives (make-parameter null)) +(define archive-implies-reindex (make-parameter #t)) + +(define current-target-directory-getter (make-parameter current-directory)) +(define current-target-plt-directory-getter + (make-parameter + (lambda (preferred main-collects-parent-dir choices) preferred))) \ No newline at end of file diff --git a/racket/collects/setup/plt-single-installer.rkt b/racket/collects/setup/plt-single-installer.rkt index 1772212ee4..d54a744a16 100644 --- a/racket/collects/setup/plt-single-installer.rkt +++ b/racket/collects/setup/plt-single-installer.rkt @@ -1,6 +1,5 @@ #lang racket/base -(require racket/unit - "setup.rkt") +(require "setup.rkt") (provide run-single-installer install-planet-package clean-planet-package reindex-user-documentation) diff --git a/racket/collects/setup/setup-unit.rkt b/racket/collects/setup/setup-core.rkt similarity index 99% rename from racket/collects/setup/setup-unit.rkt rename to racket/collects/setup/setup-core.rkt index 49f54370c2..d22c5cc48c 100644 --- a/racket/collects/setup/setup-unit.rkt +++ b/racket/collects/setup/setup-core.rkt @@ -3,8 +3,7 @@ #lang racket/base -(require racket/unit - racket/path +(require racket/path racket/file racket/port racket/match @@ -15,10 +14,11 @@ planet/planet-archives planet/private/planet-shared - "option-sig.rkt" - compiler/sig - launcher/launcher-sig - dynext/dynext-sig + "option.rkt" + compiler/compiler + (prefix-in compiler:option: compiler/option) + launcher/launcher + dynext/file "unpack.rkt" "getinfo.rkt" @@ -54,15 +54,9 @@ #:namespace info-ns #:bootstrap? #t)))))) -(provide setup@) +(provide setup-core) -(define-unit setup@ - (import setup-option^ - compiler^ - dynext:file^ - (prefix compiler:option: compiler:option^) - launcher^) - (export) +(define (setup-core) (define name-str (setup-program-name)) (define name-sym (string->symbol name-str)) @@ -247,7 +241,7 @@ (setup-printf "WARNING" "ignoring `compile-subcollections' entry in info ~a" path-name)) - ;; this check is also done in compiler/compiler-unit, in compile-directory + ;; this check is also done in compiler/compiler, in compile-directory (and (not (eq? 'all (omitted-paths path getinfo omit-root))) (make-cc collection path (if name @@ -1733,9 +1727,9 @@ (verbose)) (set! exit-code 1))) - ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;; setup-unit Body ;; - ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; setup Body ;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (setup-printf "version" "~a [~a]" (version) (system-type 'gc)) (setup-printf "installation name" "~a" (get-installation-name)) diff --git a/racket/collects/setup/setup-go.rkt b/racket/collects/setup/setup-go.rkt index 58cdf3f6c6..bf77e3ebb6 100644 --- a/racket/collects/setup/setup-go.rkt +++ b/racket/collects/setup/setup-go.rkt @@ -1,48 +1,25 @@ (module setup-go racket/base (require "setup-cmdline.rkt" - racket/unit - - "option-sig.rkt" - "setup-unit.rkt" - "option-unit.rkt" + "option.rkt" + "setup-core.rkt" compiler/cm) - (define-values/invoke-unit/infer setup:option@) - (define-values (short-name x-flags x-specific-collections x-specific-planet-packages x-archives) (parse-cmdline (current-command-line-arguments))) - ;; Pseudo-option: - (define (all-users on?) - (when on? - (current-target-plt-directory-getter - (lambda (preferred main-collects-parent-dir choices) - main-collects-parent-dir)))) - - ;; Converting parse-cmdline results into parameter settings: - (set-flag-params x-flags - ;; these are not defined in option-unit - all-users trust-existing-zos) - (specific-collections x-specific-collections) - (archives x-archives) - (specific-planet-dirs x-specific-planet-packages) - - (setup-program-name short-name) - - (require launcher/launcher-sig - launcher/launcher-unit - - dynext/dynext-sig - dynext/dynext-unit) - - (require compiler/sig - compiler/option-unit - compiler/compiler-unit) - - (invoke-unit - (compound-unit/infer - (import (SOPTION : setup-option^)) - (export) - (link launcher@ dynext:compile@ dynext:link@ dynext:file@ - compiler:option@ compiler@ setup@)) - (import setup-option^))) + (parameterize + ;; Converting parse-cmdline results into parameter settings: + ([current-target-plt-directory-getter + (if (assq 'all-users x-flags) + (lambda (preferred main-collects-parent-dir choices) + main-collects-parent-dir) + (current-target-plt-directory-getter))] + [trust-existing-zos (or (assq 'trust-existing-zos x-flags) + (trust-existing-zos))] + [specific-collections x-specific-collections] + [archives x-archives] + [specific-planet-dirs x-specific-planet-packages] + + [setup-program-name short-name]) + + (setup-core))) diff --git a/racket/collects/setup/setup.rkt b/racket/collects/setup/setup.rkt index b8b937aae1..8d75431011 100644 --- a/racket/collects/setup/setup.rkt +++ b/racket/collects/setup/setup.rkt @@ -1,17 +1,8 @@ #lang racket/base -(require racket/unit - - ;; All the rest are to get the imports for setup@: - "option-sig.rkt" - "setup-unit.rkt" - "option-unit.rkt" - launcher/launcher-sig - launcher/launcher-unit - dynext/dynext-sig - dynext/dynext-unit - compiler/sig - compiler/option-unit - compiler/compiler-unit) +(require "option.rkt" + "setup-core.rkt" + launcher/launcher + compiler/compiler) (provide setup) @@ -26,69 +17,44 @@ #:tidy? [tidy? #f] #:avoid-main? [avoid-main? #f] #:jobs [parallel #f]) - (define-unit set-options@ - (import setup-option^ compiler^) - (export) - ;; >>>>>>>>>>>>>> <<<<<<<<<<<<<<< - ;; Here's where we tell setup the archive file: - (unless (or clean? (not file)) - (archives (list file)) - (when planet-specs - (archive-implies-reindex #f))) + (parameterize + (;; Here's where we tell setup the archive file: + [archives (if (or clean? (not file)) (archives) (list file))] + [archive-implies-reindex (if (and planet-specs (and (not clean?) file)) + #f + (archive-implies-reindex))] ;; Here's where we make get a directory: - (current-target-directory-getter - get-target-dir) + [current-target-directory-getter get-target-dir] - (when planet-specs - (specific-planet-dirs planet-specs)) + [specific-planet-dirs (if planet-specs planet-specs (specific-planet-dirs))] - (when collections - (specific-collections collections)) - - (when (or planet-specs collections) - (make-only #t)) - - (unless make-user? - (make-user #f)) - - (unless make-docs? - (make-docs #f)) - (when make-doc-index? - (make-doc-index #t)) - - (when tidy? - (make-tidy #t)) - - (when avoid-main? - (avoid-main-installation #t)) + [specific-collections (if collections collections (specific-collections))] - (when clean? - (clean #t) - (make-zo #f) - (make-launchers #f) - (make-info-domain #t) - (call-install #f) - (make-docs #f)) + [make-only (if (or planet-specs collections) #t (make-only))] - (setup-program-name "raco setup") + [make-user (if make-user? (make-user) #f)] - (when parallel - (parallel-workers parallel))) + [make-docs (if make-docs? (make-docs) #f)] + + [make-doc-index (if make-doc-index? #t (make-doc-index))] - (let/ec esc - (parameterize ([exit-handler - (lambda (v) (esc (void)))]) - (invoke-unit - (compound-unit/infer - (import) - (export) - (link launcher@ - dynext:compile@ - dynext:link@ - dynext:file@ - compiler:option@ - compiler@ - setup:option@ - set-options@ - setup@)))))) + [make-tidy (if tidy? #t (make-tidy))] + + [avoid-main-installation (if avoid-main? #t (avoid-main-installation))] + + [clean (if clean? #t (clean))] + [make-zo (if clean? #f (make-zo))] + [make-launchers (if clean? #f (make-launchers))] + [make-info-domain (if clean? #t (make-info-domain))] + [call-install (if clean? #f (call-install))] + [make-docs (if clean? #f (make-docs))] + + [setup-program-name "raco setup"] + + [parallel-workers (if parallel parallel (parallel-workers))]) + + (let/ec esc + (parameterize ([exit-handler + (lambda (v) (esc (void)))]) + (setup-core)))))