diff --git a/collects/drscheme/private/language.ss b/collects/drscheme/private/language.ss index 5308903484..4f7082915f 100644 --- a/collects/drscheme/private/language.ss +++ b/collects/drscheme/private/language.ss @@ -4,7 +4,7 @@ ;; (esp. useful when debugging the users's io) #lang scheme/unit - (require "drsig.ss" +(require "drsig.ss" string-constants mzlib/pconvert mzlib/pretty @@ -1106,19 +1106,16 @@ ((if gui? make-mred-launcher make-mzscheme-launcher) (list - "-qmvt" (path->string (build-path (collection-path "drscheme" "private") - "launcher-bootstrap.ss")) - "--" + (if gui? + "launcher-mred-bootstrap.ss" + "launcher-mz-bootstrap.ss"))) (condense-scheme-code-string (format "~s" init-code)) (path->string program-filename) (format "~s" module-language-spec) (format "~s" transformer-module-language-spec) - (format "~s" use-copy?) - (format "~s" (if gui? - (list 'mzscheme '(lib "mred/mred.ss")) - (list 'mzscheme)))) + (format "~s" use-copy?)) (if (path? executable-filename) (path->string executable-filename) executable-filename)))) diff --git a/collects/drscheme/private/launcher-bootstrap.ss b/collects/drscheme/private/launcher-bootstrap.ss index 5dfface500..d7ce4e81ab 100644 --- a/collects/drscheme/private/launcher-bootstrap.ss +++ b/collects/drscheme/private/launcher-bootstrap.ss @@ -1,7 +1,12 @@ -(module launcher-bootstrap mzscheme - (require mzlib/string - mzlib/file) - +#lang scheme/base + +(provide startup) + +(require scheme/file) + +(define (read-from-string s) (read (open-input-string s))) + +(define (startup) (define argv (current-command-line-arguments)) ;; skip first six (define program-argv (list->vector (cddr (cddddr (vector->list argv))))) @@ -11,34 +16,23 @@ (define language-module-spec (read-from-string (vector-ref argv 2))) (define transformer-module-spec (read-from-string (vector-ref argv 3))) (define use-require/copy? (read-from-string (vector-ref argv 4))) - (define to-be-copied-module-specs (read-from-string (vector-ref argv 5))) - - (define to-be-copied-module-names - (let ([get-name - (λ (spec) - (if (symbol? spec) - spec - ((current-module-name-resolver) spec #f #f)))]) - (map get-name to-be-copied-module-specs))) (define init-code-tmp-filename (make-temporary-file "drs-launcher-init~a")) (define-values (_1 init-code-mod-name _2) (split-path init-code-tmp-filename)) - (set! init-code (cons (car init-code) - (cons (string->symbol (path->string init-code-mod-name)) - (cddr init-code)))) + (define stupid-internal-define-syntax2 + (set! init-code (cons (car init-code) + (cons (string->symbol (path->string init-code-mod-name)) + (cddr init-code))))) - (call-with-output-file init-code-tmp-filename - (λ (port) - (write init-code port)) - #:exists 'truncate #:mode 'text) + (define stupid-internal-define-syntax1 + (call-with-output-file init-code-tmp-filename + (λ (port) + (write init-code port)) + #:exists 'truncate #:mode 'text)) (define init-code-proc (dynamic-require init-code-tmp-filename 'init-code)) - (define original-namespace (current-namespace)) - (current-namespace (make-namespace 'empty)) - (for-each (λ (x) (namespace-attach-module original-namespace x)) - to-be-copied-module-names) (namespace-set-variable-value! 'argv program-argv) (current-command-line-arguments program-argv) (when language-module-spec @@ -53,4 +47,4 @@ ;; safe to do this earlier? (delete-file init-code-tmp-filename) - (load program-filename)) + (load program-filename)) \ No newline at end of file diff --git a/collects/drscheme/private/launcher-mred-bootstrap.ss b/collects/drscheme/private/launcher-mred-bootstrap.ss new file mode 100644 index 0000000000..20820223ab --- /dev/null +++ b/collects/drscheme/private/launcher-mred-bootstrap.ss @@ -0,0 +1,9 @@ +#lang scheme/base + +(require scheme/gui/base "launcher-bootstrap.ss") + +(current-namespace (make-gui-empty-namespace)) +(namespace-require 'scheme/gui/base) +(namespace-require 'scheme/class) + +(startup) diff --git a/collects/drscheme/private/launcher-mz-bootstrap.ss b/collects/drscheme/private/launcher-mz-bootstrap.ss new file mode 100644 index 0000000000..f591a62c7a --- /dev/null +++ b/collects/drscheme/private/launcher-mz-bootstrap.ss @@ -0,0 +1,8 @@ +#lang scheme/base + +(require "launcher-bootstrap.ss") + +(current-namespace (make-base-empty-namespace)) +(namespace-require 'scheme/base) + +(startup) diff --git a/collects/drscheme/private/module-language.ss b/collects/drscheme/private/module-language.ss index 48a703015b..8223431967 100644 --- a/collects/drscheme/private/module-language.ss +++ b/collects/drscheme/private/module-language.ss @@ -207,17 +207,18 @@ executable-filename gui? (lambda (exe-name) - (make-embedding-executable + (create-embedding-executable exe-name - gui? - #f ;; verbose? - (list (list #f program-filename)) - null - (parameterize ([current-namespace (make-empty-namespace)]) - (namespace-require 'mzscheme) - (compile - `(namespace-require '',(string->symbol (path->string short-program-name))))) - null)))) + #:mred? gui? + #:verbose? #f ;; verbose? + #:modules (list (list #f program-filename)) + #:literal-expression + (begin + (parameterize ([current-namespace (make-base-empty-namespace)]) + (namespace-require 'scheme/base) + (compile + `(namespace-require '',(string->symbol (path->string short-program-name)))))) + #:cmdline null)))) (let ([make-launcher (if gui? make-mred-launcher make-mzscheme-launcher)]) (make-launcher (list "-qt-" (path->string program-filename)) executable-filename))))))))