cleaned up the rest of the executable creation code

svn: r9949
This commit is contained in:
Robby Findler 2008-05-25 02:26:29 +00:00
parent fadfbf73e1
commit 758f6bb839
5 changed files with 52 additions and 43 deletions

View File

@ -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))))

View File

@ -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))
(define stupid-internal-define-syntax2
(set! init-code (cons (car init-code)
(cons (string->symbol (path->string init-code-mod-name))
(cddr init-code))))
(cddr init-code)))))
(define stupid-internal-define-syntax1
(call-with-output-file init-code-tmp-filename
(λ (port)
(write init-code port))
#:exists 'truncate #:mode 'text)
#: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

View File

@ -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)

View File

@ -0,0 +1,8 @@
#lang scheme/base
(require "launcher-bootstrap.ss")
(current-namespace (make-base-empty-namespace))
(namespace-require 'scheme/base)
(startup)

View File

@ -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)
#: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)))))
null))))
`(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))))))))