suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

301.16

Browse Source 
svn: r3040
This commit is contained in:
Matthew Flatt 2006-05-24 19:29:58 +00:00
parent e95512246f
commit d034f64dd2
31 changed files with 2421 additions and 1758 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

424
collects/compiler/distribute.ss Normal file
View File

@ -0,0 +1,424 @@
(module distribute mzscheme
(require (lib "kw.ss")
(lib "file.ss")
(lib "dirs.ss" "setup")
(lib "list.ss")
(prefix config: (lib "config.ss" "config"))
(lib "filename-version.ss" "dynext")
"private/macfw.ss"
"private/windlldir.ss"
"private/collects-path.ss")
(provide assemble-distribution)
(define/kw (assemble-distribution dest-dir
binaries
#:key
[collects-path #f] ; relative to dest-dir
[copy-collects null])
(let* ([types (map get-binary-type binaries)]
[_ (unless (directory-exists? dest-dir)
(make-directory dest-dir))]
[sub-dirs (map (lambda (b type)
(case (system-type)
[(windows) #f]
[(unix) "bin"]
[(macosx) (if (memq type '(mred mred3m))
#f
"bin")]))
binaries
types)]
;; Copy binaries into place:
[binaries
(map (lambda (b sub-dir type)
(let ([dest-dir (if sub-dir
(build-path dest-dir sub-dir)
dest-dir)])
(unless (directory-exists? dest-dir)
(make-directory dest-dir))
(let-values ([(base name dir?) (split-path b)])
(let ([dest (build-path dest-dir name)])
(if (and (memq type '(mred mred3m))
(eq? 'macosx (system-type)))
(begin
(copy-app b dest)
(app-to-file dest))
(begin
(copy-file* b dest)
dest))))))
binaries
sub-dirs
types)]
[single-mac-app? (and (eq? 'macosx (system-type))
(= 1 (length types))
(memq (car types) '(mred mred3m)))])
;; Create directories for libs and collects:
(let-values ([(lib-dir collects-dir relative-collects-dir)
(if single-mac-app?
;; Special case: single Mac OS X MrEd app:
(let-values ([(base name dir?)
(split-path (car binaries))])
(values
(simplify-path (build-path base 'up "Frameworks"))
(if collects-path
(build-path dest-dir collects-path)
(simplify-path (build-path base
'up
"Resources"
"collects")))
(if collects-path
(build-path 'up 'up 'up collects-path)
(build-path 'up "Resources" "collects"))))
;; General case:
(let ([relative-collects-dir
(or collects-path
(build-path "lib"
"plt"
(let-values ([(base name dir?)
(split-path (car binaries))])
(path-replace-suffix name #""))
"collects"))])
(values (build-path dest-dir "lib")
(build-path dest-dir relative-collects-dir)
relative-collects-dir)))])
(make-directory* lib-dir)
(make-directory* collects-dir)
;; Copy libs into place
(install-libs lib-dir types)
;; Copy collections into place
(for-each (lambda (dir)
(for-each (lambda (f)
(copy-directory/files*
(build-path dir f)
(build-path collects-dir f)))
(directory-list dir)))
copy-collects)
;; Patch binaries to find libs
(patch-binaries binaries types)
;; Patch binaries to find collects
(for-each (lambda (b type sub-dir)
(set-collects-path
b
(collects-path->bytes
(cond
[sub-dir
(build-path 'up relative-collects-dir)]
[(and (eq? 'macosx (system-type))
(memq type '(mred mredx))
(not single-mac-app?))
(build-path 'up 'up 'up relative-collects-dir)]
[else
relative-collects-dir]))))
binaries types sub-dirs))
;; Done!
(void)))
(define (install-libs lib-dir types)
(case (system-type)
[(windows)
(let ([copy-dll (lambda (name)
(copy-file* (search-dll (find-dll-dir) name)
(build-path lib-dir name)))]
[versionize (lambda (template)
(let ([f (search-dll (find-dll-dir)
(format template filename-version-part))])
(if (file-exists? f)
(format template filename-version-part)
(format template "xxxxxxx"))))])
(map copy-dll
(list
"iconv.dll"
"UnicoWS.dll"))
(when (or (memq 'mzscheme types)
(memq 'mred types))
(map copy-dll
(list
(versionize "libmzsch~a.dll")
(versionize "libmzgc~a.dll"))))
(when (or (memq 'mzscheme3m types)
(memq 'mred3m types))
(map copy-dll
(list
(versionize "libmzsch3m~a.dll"))))
(when (memq 'mred types)
(map copy-dll
(list
(versionize "libmred~a.dll"))))
(when (memq 'mred3m types)
(map copy-dll
(list
(versionize "libmred3m~a.dll")))))]
[(macosx)
(when (memq 'mzscheme types)
(copy-framework "MzScheme" #f lib-dir))
(when (memq 'mzscheme3m types)
(copy-framework "MzScheme" #t lib-dir))
(when (memq 'mred types)
(copy-framework "MrEd" #f lib-dir))
(when (memq 'mred3m types)
(copy-framework "MrEd" #t lib-dir))]
[(unix)
(let ([lib-plt-dir (build-path lib-dir "plt")])
(unless (directory-exists? lib-plt-dir)
(make-directory lib-plt-dir))
(let ([copy-bin
(lambda (name)
(copy-file* (build-path (find-console-bin-dir) name)
(build-path lib-plt-dir
(format "~a-~a" name (version)))))])
(when (memq 'mzscheme types)
(copy-bin "mzscheme"))
(when (memq 'mzscheme3m types)
(copy-bin "mzscheme3m"))
(when (memq 'mred types)
(copy-bin "mred"))
(when (memq 'mred3m types)
(copy-bin "mred3m")))
(when (shared-libraries?)
(when (or (memq 'mzscheme types)
(memq 'mred types))
(copy-shared-lib "mzscheme" lib-dir)
(copy-shared-lib "mzgc" lib-dir))
(when (or (memq 'mzscheme3m types)
(memq 'mred3m types))
(copy-shared-lib "mzscheme3m" lib-dir))
(when (memq 'mred types)
(copy-shared-lib "mred" lib-dir))
(when (memq 'mred types)
(copy-shared-lib "mred3m" lib-dir))))]))
(define (search-dll dll-dir dll)
(if dll-dir
(build-path dll-dir dll)
(let* ([exe-dir
(let ([exec (path->complete-path
(find-executable-path (find-system-path 'exec-file))
(find-system-path 'orig-dir))])
(let-values ([(base name dir?) (split-path exec)])
base))]
[paths (cons
exe-dir
(path-list-string->path-list
(or (getenv "PATH") "")
(list (find-system-path 'sys-dir))))])
(or (ormap (lambda (p)
(let ([p (build-path p dll)])
(and (file-exists? p)
p)))
paths)
;; Can't find it, so just use executable's dir:
(build-path exe-dir dll)))))
(define (copy-framework name 3m? lib-dir)
(let* ([fw-name (format "PLT_~a.framework" name)]
[sub-dir (build-path fw-name "Versions"
(if 3m?
(format "~a_3m" (version))
(version)))])
(make-directory* (build-path lib-dir sub-dir))
(let* ([fw-name (build-path sub-dir (format "PLT_~a" name))]
[dll-dir (find-framework fw-name)])
(copy-file* (build-path dll-dir fw-name)
(build-path lib-dir fw-name))
(let ([rsrc-src (build-path dll-dir sub-dir "Resources")])
(when (directory-exists? rsrc-src)
(copy-directory/files*
rsrc-src
(build-path lib-dir sub-dir "Resources")))))))
(define (find-framework fw-name)
(let ([dll-dir (find-dll-dir)])
(or dll-dir
(ormap (lambda (p)
(let ([f (build-path p fw-name)])
(and (file-exists? f)
p)))
'("/System/Library/Frameworks"
"/Library/Frameworks"
"~/Library/Frameworks"))
;; Can't find it, so just use relative path:
(build-path 'same))))
;; cache:
(define avail-lib-files #f)
(define (copy-shared-lib name lib-dir)
(unless avail-lib-files
(set! avail-lib-files (directory-list (find-dll-dir))))
(let* ([rx (byte-regexp (string->bytes/latin-1
(format "lib~a-~a.*[.](?:so|dylib)$" name (version))))]
[files (filter (lambda (f)
(regexp-match rx (path->bytes f)))
avail-lib-files)])
(when (null? files)
(error 'copy-shared-lib "cannot find shared library for ~a"
name))
(unless (null? (cdr files))
(error 'copy-shared-lib
"found multiple shared-library candidates for ~a: ~e"
name
files))
(copy-file* (build-path (find-dll-dir) (car files))
(build-path lib-dir (car files)))))
(define (patch-binaries binaries types)
(case (system-type)
[(windows)
(for-each (lambda (b)
(update-dll-dir b "lib"))
binaries)]
[(macosx)
(if (and (= 1 (length types))
(memq (car types) '(mred mred3m)))
;; Special case for single MrEd app:
(update-framework-path "@executable_path/../Frameworks/"
(car binaries)
#t)
;; General case:
(for-each (lambda (b type)
(update-framework-path (if (memq type '(mzscheme mzscheme3m))
"@executable_path/../lib/"
"@executable_path/../../../lib/" )
b
(memq type '(mred mred3m))))
binaries types))]
[(unix)
(for-each (lambda (b type)
(patch-stub-exe-paths b
(build-path
"../lib/plt"
(format "~a-~a" type (version)))
(and (shared-libraries?)
"../lib")))
binaries
types)]))
(define (patch-stub-exe-paths b exe shared-lib-dir)
(let-values ([(config-pos start end prog-len dll-len rest)
(with-input-from-file b
(lambda ()
(let* ([i (current-input-port)]
[m (regexp-match-positions #rx#"cOnFiG:" i)])
(unless m
(error 'patch-stub-exe-paths
"cannot find config info"))
(read-byte i)
(read-one-int i) ; start of prog data
(let ([start (read-one-int i)]
[end (read-one-int i)])
(file-position i start)
(let ([prog-len (next-bytes-length i)]
[dll-len (next-bytes-length i)])
(values (+ (cdar m) 1)
start
end
prog-len
dll-len
(read-bytes (- (- end start) prog-len dll-len))))))))])
(let ([exe-bytes (path->bytes (to-path exe))]
[shared-lib-bytes (if shared-lib-dir
(path->bytes (to-path shared-lib-dir))
#"")])
(let ([delta (- (+ prog-len dll-len)
(bytes-length exe-bytes)
(bytes-length shared-lib-bytes))])
(with-output-to-file b
(lambda ()
(let ([o (current-output-port)])
(file-position o (+ config-pos 8))
(write-one-int (+ end delta) o)
(flush-output o)
(file-position o start)
(write-bytes exe-bytes o)
(write-bytes #"\0" o)
(write-bytes shared-lib-bytes o)
(write-bytes #"\0" o)
(write-bytes rest o)
(flush-output o)))
'update)))))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Utilities
(define (shared-libraries?)
(eq? 'shared (system-type 'link)))
(define (to-path s)
(if (string? s)
(string->path s)
s))
(define (get-binary-type b)
;; Since this is called first, we also check that the executable
;; is a stub binary for Unix.
(with-input-from-file (app-to-file b)
(lambda ()
(let ([m (regexp-match #rx#"bINARy tYPe:(e?)(.)(.)(.)" (current-input-port))])
(if m
(begin
(when (eq? 'unix (system-type))
(unless (equal? (cadr m) #"e")
(error 'assemble-distribution
"file is an original PLT executable, not a stub binary: ~e"
b)))
(let ([3m? (equal? (list-ref m 4) #"3")])
(if (equal? (caddr m) #"r")
(if 3m?
'mred3m
'mred)
(if 3m?
'mzscheme3m
'mzscheme))))
(error 'assemble-distribution
"file is not a PLT executable: ~e"
b))))))
(define (write-one-int n out)
(write-bytes (integer->integer-bytes n 4 #t #f) out))
(define (read-one-int in)
(integer-bytes->integer (read-bytes 4 in) #t #f))
(define (next-bytes-length in)
(let ([m (regexp-match-positions #rx#"\0" in)])
(cdar m)))
(define (copy-file* src dest)
(when (or (file-exists? dest)
(link-exists? dest))
(delete-file dest))
(copy-file src dest)
(let ([t (file-or-directory-modify-seconds src)])
(file-or-directory-modify-seconds dest t)))
(define (copy-directory/files* src dest)
(cond
[(directory-exists? src)
(unless (directory-exists? dest)
(make-directory dest))
(for-each (lambda (f)
(copy-directory/files* (build-path src f)
(build-path dest f)))
(directory-list src))]
[else
(copy-file* src dest)]))
(define (copy-app src dest)
(when (or (file-exists? dest)
(directory-exists? dest)
(link-exists? dest))
(delete-directory/files dest))
(copy-directory/files src dest))
(define (app-to-file b)
(if (and (eq? 'macosx (system-type))
(regexp-match #rx#"[.][aA][pP][pP]$"
(path->bytes (if (string? b)
(string->path b)
b))))
(let ([no-app
(let-values ([(base name dir?) (split-path b)])
(path-replace-suffix name #""))])
(build-path b "Contents" "MacOS" no-app))
b)))

8
collects/compiler/doc.txt
View File

@ -407,7 +407,8 @@ _embedr-sig.ss_ library provides the signature, _compiler:embed^_.
[#:verbose? verbose?])
- Copies the MzScheme (if `mred?' is #f) or MrEd (otherwise) binary,
embedding code into the copied executable to be loaded on startup.
The source executable is located relative to the "mzlib" collection.
(Under Unix, the binary is actually a wrapper executable that execs
the original; see also 'original-exe? below.)
See the mzc documentation for a simpler interface that is
well-suited to programs defined with `module'.
@ -531,6 +532,11 @@ _embedr-sig.ss_ library provides the signature, _compiler:embed^_.
found relative to the launcher instead of the original
executable
_'original-exe?_ (Unix) - a boolean; #t means that the embedding
uses the original MzScheme or MrEd executable, instead
of a wrapper binary that execs the original; the default is
#f
See also `build-aux-from-path' in the "launcher" collection. The
default `aux' is `null'.

264
collects/compiler/embed-unit.ss
View File

@ -14,7 +14,8 @@
"private/winsubsys.ss"
"private/macfw.ss"
"private/mach-o.ss"
"private/windlldir.ss")
"private/windlldir.ss"
"private/collects-path.ss")
(provide compiler:embed@)
@ -496,11 +497,6 @@
literal-files)
(when literal-expression
(write literal-expression))))
(define (write-lib out libpos lib-path-bytes)
(file-position out libpos)
(write-bytes lib-path-bytes out)
(write-byte 0 out))
;; The old interface:
(define make-embedding-executable
@ -539,58 +535,48 @@
(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)
(and mred? (eq? 'macosx (system-type)))))
(and mred? (eq? 'macosx (system-type)))
unix-starter?))
(define relative? (let ([m (assq 'relative? aux)])
(and m (cdr m))))
(define collects-path-bytes (and collects-path
(cond
[(path? collects-path) (path->bytes collects-path)]
[(string? collects-path) (string->bytes/locale collects-path)]
[(and (list? collects-path)
(pair? collects-path))
(let ([l (map (lambda (p)
(cond
[(path? p) (path->bytes p)]
[(string? p) (string->bytes/locale p)]
[else #""]))
collects-path)])
(let loop ([l l])
(if (null? (cdr l))
(car l)
(bytes-append (car l) #"\0" (loop (cdr l))))))]
[else #""])))
(define collects-path-bytes (collects-path->bytes collects-path))
(unless (or long-cmdline?
((apply + (length cmdline) (map (lambda (s)
(bytes-length (string->bytes/utf-8 s)))
cmdline)) . < . 50))
(error 'create-embedding-executable "command line too long"))
(when collects-path
(unless (or (path-string? collects-path)
(and (list? collects-path)
(pair? collects-path)
(andmap path-string? collects-path)))
(raise-type-error 'create-embedding-executable "path, string, non-empty list of paths and strings, or #f"
collects-path))
(unless ((bytes-length collects-path-bytes) . <= . 1024)
(error 'create-embedding-executable "collects path list is too long")))
(check-collects-path 'create-embedding-executable collects-path collects-path-bytes)
(let ([exe (find-exe mred? variant)])
(when verbose?
(fprintf (current-error-port) "Copying to ~s~n" dest))
(let-values ([(dest-exe orig-exe osx?)
(if (and mred? (eq? 'macosx (system-type)))
(values (prepare-macosx-mred exe dest aux variant) #f #t)
(begin
(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 MrEd
;; on Mac OS X, which is handles above.
(delete-file dest))
(copy-file exe dest)
(values dest exe #f)))])
(cond
[(and mred? (eq? 'macosx (system-type)))
(values (prepare-macosx-mred exe dest aux variant) #f #t)]
[unix-starter?
(let ([starter (build-path (find-lib-dir) "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 MrEd
;; on Mac OS X, which is handles above.
(delete-file dest))
(copy-file exe dest)
(values dest exe #f)])])
(with-handlers ([void (lambda (x)
(if osx?
(when (directory-exists? dest)
@ -598,7 +584,8 @@
(when (file-exists? dest)
(delete-file dest)))
(raise x))])
(when (eq? 'macosx (system-type))
(when (and (eq? 'macosx (system-type))
(not unix-starter?))
(let ([m (assq 'framework-root aux)])
(if m
(when (cdr m)
@ -632,7 +619,8 @@
(lambda ()
(write-module-bundle verbose? modules literal-files literal-expression))])
(let-values ([(start end)
(if (eq? (system-type) 'macosx)
(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)])
(parameterize ([current-output-port s])
@ -661,76 +649,120 @@
;; No argv[0]:
null)
(list "-k" start-s end-s))
cmdline)]
[libpos (and collects-path
(let ([tag #"coLLECTs dIRECTORy:"])
(+ (with-input-from-file dest-exe
cmdline)])
(when collects-path-bytes
(when verbose?
(fprintf (current-error-port) "Setting collection path~n"))
(set-collects-path dest-exe collects-path-bytes))
(cond
[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 mred?
(with-input-from-file dest-exe
(lambda () (find-cmdline
"collects path"
tag)))
(bytes-length tag))))])
(if osx?
(begin
(finish-osx-mred dest full-cmdline exe keep-exe? relative?)
(when libpos
(call-with-output-file* dest-exe
(lambda (out)
(write-lib out libpos collects-path-bytes))
'update)))
(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 'update)])
"exeuctable type"
#"bINARy tYPe:"))))]
[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)))]
[out (open-output-file dest-exe 'update)])
(let ([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 anotherpos
(file-position out anotherpos)
(write-bytes #"no," out))
(when libpos
(write-lib out libpos collects-path-bytes))
(if long-cmdline?
;; write cmdline at end:
(file-position out end)
(begin
;; write (short) cmdline in the normal position:
(file-position out cmdpos)
(display "!" 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)
(when long-cmdline?
;; cmdline written at the end;
;; now put forwarding information at the normal cmdline pos
(let ([new-end (file-position out)])
(file-position out cmdpos)
(fprintf out "~a...~a~a"
(if keep-exe? "*" "?")
(integer->integer-bytes end 4 #t #f)
(integer->integer-bytes (- new-end end) 4 #t #f)))))
(when typepos
(file-position out (+ typepos 13))
(write-bytes #"r" out)
(flush-output out))
(file-position out (+ numpos 7))
(write-bytes #"!" out)
(write-num start)
(write-num end)
(write-num cmdline-end)
(write-num (length full-cmdline))
(write-num (if mred? 1 0))
(flush-output out)
(file-position out end)
(write-bytes cmdline out)
(flush-output out))
(lambda ()
(close-output-port out)))
(let ([m (and (eq? 'windows (system-type))
(assq 'ico aux))])
(when m
(install-icon dest-exe (cdr m))))
(let ([m (and (eq? 'windows (system-type))
(assq 'subsystem aux))])
(when m
(set-subsystem dest-exe (cdr m)))))))))))))))))
(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 'update)])
(dynamic-wind
void
(lambda ()
(when anotherpos
(file-position out anotherpos)
(write-bytes #"no," out))
(if long-cmdline?
;; write cmdline at end:
(file-position out end)
(begin
;; write (short) cmdline in the normal position:
(file-position out cmdpos)
(display "!" 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)
(when long-cmdline?
;; cmdline written at the end;
;; now put forwarding information at the normal cmdline pos
(let ([new-end (file-position out)])
(file-position out cmdpos)
(fprintf out "~a...~a~a"
(if keep-exe? "*" "?")
(integer->integer-bytes end 4 #t #f)
(integer->integer-bytes (- new-end end) 4 #t #f)))))
(lambda ()
(close-output-port out)))
(let ([m (and (eq? 'windows (system-type))
(assq 'ico aux))])
(when m
(install-icon dest-exe (cdr m))))
(let ([m (and (eq? 'windows (system-type))
(assq 'subsystem aux))])
(when m
(set-subsystem dest-exe (cdr m)))))]))))))))))))

58
collects/compiler/private/collects-path.ss Normal file
View File

@ -0,0 +1,58 @@
(module collects-path mzscheme
(provide collects-path->bytes
check-collects-path
set-collects-path)
(define (collects-path->bytes collects-path)
(and collects-path
(cond
[(path? collects-path) (path->bytes collects-path)]
[(string? collects-path) (string->bytes/locale collects-path)]
[(and (list? collects-path)
(pair? collects-path))
(let ([l (map (lambda (p)
(cond
[(path? p) (path->bytes p)]
[(string? p) (string->bytes/locale p)]
[else #""]))
collects-path)])
(let loop ([l l])
(if (null? (cdr l))
(car l)
(bytes-append (car l) #"\0" (loop (cdr l))))))]
[else #""])))
(define (check-collects-path who collects-path collects-path-bytes)
(when collects-path
(unless (or (path-string? collects-path)
(and (list? collects-path)
(pair? collects-path)
(andmap path-string? collects-path)))
(raise-type-error who "path, string, non-empty list of paths and strings, or #f"
collects-path))
(unless ((bytes-length collects-path-bytes) . <= . 1024)
(error who "collects path list is too long"))))
(define (find-cmdline rx)
(let ([m (regexp-match-positions rx (current-input-port))])
(if m
(caar m)
(error
'create-embedding-executable
"can't find collection-path position in executable"))))
(define (set-collects-path dest-exe collects-path-bytes)
(when collects-path-bytes
(let ([libpos (let ([tag #"coLLECTs dIRECTORy:"])
(+ (with-input-from-file dest-exe
(lambda () (find-cmdline tag)))
(bytes-length tag)))])
(with-output-to-file dest-exe
(lambda ()
(let ([out (current-output-port)])
(file-position out libpos)
(write-bytes collects-path-bytes out)
(write-bytes #"\0\0" out)))
'update)))))

24
collects/compiler/start.ss
View File

@ -40,11 +40,13 @@
(define ld-output (make-parameter #f))
(define exe-output (make-parameter #f))
(define exe-embedded-flags (make-parameter '("-mvq-")))
(define exe-embedded-flags (make-parameter '("-m" "-v" "-U" "-q" "--")))
(define exe-embedded-libraries (make-parameter null))
(define exe-aux (make-parameter null))
(define exe-embedded-collects-path (make-parameter #f))
(define exe-dir-output (make-parameter #f))
(define module-mode (make-parameter #f))
(define default-plt-name "archive")
@ -133,6 +135,10 @@
,(lambda (f name) (exe-output name) 'gui-exe)
(,(format "Embed module in MrEd to create <exe>")
"exe")]
[("--exe-dir")
,(lambda (f name) (exe-dir-output name) 'exe-dir)
(,(format "Combine executables with support files in <dir>")
"dir")]
[("--collection-plt")
,(lambda (f name) (plt-output name) 'plt-collect)
(,(format "Create .plt <archive> containing collections")
@ -265,7 +271,7 @@
[help-labels
"--------------------- executable configuration flags ------------------------"]
[once-each
[("--collects")
[("--collects-path")
,(lambda (f i)
(exe-embedded-collects-path i))
("Path to collects relative to --[gui-]exe executable" "path")]
@ -278,7 +284,12 @@
,(lambda (f i) (exe-aux
(cons (cons 'icns i)
(exe-aux))))
("Mac OS X icon for --[gui-]exe executable" ".icns-file")]]
("Mac OS X icon for --[gui-]exe executable" ".icns-file")]
[("--orig-exe")
,(lambda (f) (exe-aux
(cons (cons 'original-exe? #t)
(exe-aux))))
("Use original executable instead of stub")]]
[multi
[("++lib")
,(lambda (f l c) (exe-embedded-libraries
@ -521,6 +532,7 @@
'mzc:create-embedding-executable)
dest
#:mred? (eq? mode 'gui-exe)
#:variant (if (compiler:option:3m) '3m 'normal)
#:verbose? (compiler:option:verbose)
#:modules (cons
`(#%mzc: (file ,(car source-files)))
@ -539,6 +551,12 @@
#:collects-path (exe-embedded-collects-path)
#:aux (exe-aux))
(printf " [output to \"~a\"]~n" dest))]
[(exe-dir)
((dynamic-require '(lib "distribute.ss" "compiler")
'assemble-distribution)
(exe-dir-output)
source-files
#:collects-path (exe-embedded-collects-path))]
[(plt)
(for-each (lambda (fd)
(unless (relative-path? fd)

2
collects/help/bug-report.ss
View File

@ -486,7 +486,7 @@
(send environment set-value
(format "~a ~s (~a) (get-display-depth) = ~a"
(system-type)
(system-type #t)
(system-type 'machine)
(system-library-subpath)
(get-display-depth)))

3
collects/mysterx/installer.ss
View File

@ -4,7 +4,8 @@
(provide post-installer)
(define (post-installer plt-home)
(define (make-dll-path . more)
(apply build-path (find-dll-dir) more))
(and (find-dll-dir)
(apply build-path (find-dll-dir) more)))
(define (warn fmt . args) (apply fprintf (current-error-port) fmt args))
(let* ([dlls '("myspage.dll" "myssink.dll")]
[dll-paths (map make-dll-path dlls)]

2
collects/net/sendurl.ss
View File

@ -30,7 +30,7 @@
[(procedure? (external-browser))
((external-browser) url-str)]
[(eq? (system-type) 'macos)
(if (regexp-match "Blue Box" (system-type #t))
(if (regexp-match "Blue Box" (system-type 'machine))
;; Classic inside OS X:
(let loop ([l '("MSIE" "NAVG")])
(if (null? l)

1
collects/setup/configtab.ss
View File

@ -8,6 +8,7 @@
(define-for-syntax path-exports
'(doc-dir
doc-search-dirs
dll-dir
lib-dir
lib-search-dirs
include-dir

16
collects/setup/dirs.ss
View File

@ -56,6 +56,10 @@
[(not (car l)) (append default (loop (cdr l)))]
[else (cons (car l) (loop (cdr l)))]))
default))
(define (cons-user u r)
(if (use-user-specific-search-paths)
(cons u r)
r))
(define-syntax define-finder
(syntax-rules ()
@ -65,7 +69,7 @@
(provide search-id)
(define (search-id)
(combine-search (force config:search-id)
(cons (user-id) (single (id))))))]
(cons-user (user-id) (single (id))))))]
[(_ provide config:id id user-id config:search-id search-id extra-search-dir default)
(begin
(define-finder provide config:id id user-id default)
@ -73,7 +77,7 @@
(define (search-id)
(combine-search (force config:search-id)
(extra (extra-search-dir)
(cons (user-id) (single (id)))))))]
(cons-user (user-id) (single (id)))))))]
[(_ provide config:id id user-id default)
(begin
(provide id user-id)
@ -172,9 +176,8 @@
(lambda ()
(let ([m (regexp-match (byte-regexp
(bytes-append
#"("
(bytes->utf-16-bytes #"dLl dIRECTORy:")
#".*?)\0\0"))
#"((?:..)*?)\0\0"))
(current-input-port))])
(unless m (error "cannot find \"dLl dIRECTORy\" tag in binary"))
(let-values ([(dir name dir?) (split-path exe)])
@ -216,6 +219,9 @@
;; no framework reference found!?
#f)))]
[else
(find-lib-dir)])))
(if (eq? 'shared (system-type 'link))
(or (force config:dll-dir)
(find-lib-dir))
#f)])))
(define (find-dll-dir)
(force dll-dir)))

17
collects/setup/doc.txt
View File

@ -290,8 +290,9 @@ installation directories:
> (get-collects-search-dirs)
Returns the same result as `(current-library-collection-paths)'.
Returns the same result as `(current-library-collection-paths)'
(which means that this result is not sensitive to the value of the
`use-user-specific-search-paths' parameter).
> (find-doc-dir)
@ -308,7 +309,9 @@ installation directories:
Returns a list of paths to search for documentation, not including
documentation stored in individual collections. Unless it is
configured otherwise, the result includes any non-#f result of
`(find-doc-dir)' and `(find-user-doc-dir)'.
`(find-doc-dir)' and `(find-user-doc-dir)' --- but the latter is
included only if the value of the `use-user-specific-search-paths'
parameter is true.
> (find-lib-dir)
@ -333,7 +336,9 @@ installation directories:
Returns a list of paths to search for libraries. Unless it is
configured otherwise, the result includes any non-#f result of
`(find-lib-dir)', `(find-dll-dir)', and `(find-user-lib-dir)'.
`(find-lib-dir)', `(find-dll-dir)', and `(find-user-lib-dir)' ---
but the last is included only if the value of the
`use-user-specific-search-paths' parameter is true.
> (find-include-dir)
@ -351,7 +356,9 @@ installation directories:
Returns a list of paths to search for .h files. Unless it is
configured otherwise, the result includes any non-#f result of
`(find-include-dir)' and `(find-user-include-dir)'.
`(find-include-dir)' and `(find-user-include-dir)' --- but the
latter is included only if the value of the
`use-user-specific-search-paths' parameter is true.
> (find-console-bin-dir)

5
collects/tests/mzscheme/basic.ss
View File

@ -2013,8 +2013,9 @@
(test #t string? (version))
(test #t string? (banner))
(test #t symbol? (system-type))
(test (system-type) system-type #f)
(test #t string? (system-type #t))
(test (system-type) system-type 'os)
(test #t string? (system-type 'machine))
(test #t symbol? (system-type 'link))
(test #t relative-path? (system-library-subpath))
(test #t 'cmdline (let ([v (current-command-line-arguments)])

6
doc/release-notes/mzscheme/HISTORY
View File

@ -1,3 +1,9 @@
Version 301.15
Changed installation process to support more configurable directory
structure
Added use-user-specific-search-paths parameter, -U flag
Changed system-type's optional argument to 'os, 'link, or 'machine
Version 301.14
Added current-thread-initial-stack-size

14
src/configure vendored
View File

@ -11700,17 +11700,8 @@ if test "${enable_shared}" = "yes" ; then
STATIC_AR="${LTDIR}/libtool --mode=link $CC -o"
ARFLAGS=""
RANLIB=":"
exes="xxxxxxxx"
exes="${exes}${exes}"
exes="${exes}${exes}"
exes="${exes}${exes}"
exes="${exes}${exes}"
exes="${exes}${exes}"
exes="${exes}${exes}"
exes="${exes}${exes}"
padding="padding$exes"
MZLINKER="${LTDIR}/libtool --mode=link $CC${need_gcc_static_libgcc} -rpath ${absprefix}/lib -rpath ${absprefix}/lib/${padding}"
MREDLINKER="${LTDIR}/libtool --mode=link $CXX${need_gcc_static_libgcc} -rpath ${absprefix}/lib -rpath ${absprefix}/lib/${padding}"
MZLINKER="${LTDIR}/libtool --mode=link $CC${need_gcc_static_libgcc} -rpath ${absprefix}/lib"
MREDLINKER="${LTDIR}/libtool --mode=link $CXX${need_gcc_static_libgcc} -rpath ${absprefix}/lib"
PLAIN_CC="$CC"
CC="${LTDIR}/libtool --mode=compile $CC"
CXX="${LTDIR}/libtool --mode=compile $CXX"
@ -11724,6 +11715,7 @@ if test "${enable_shared}" = "yes" ; then
LTA="la"
FOREIGN_CONVENIENCE="_convenience"
FOREIGN_OBJSLIB="\$(FOREIGN_LIB)"
MZOPTIONS="$MZOPTIONS -DMZ_USES_SHARED_LIB"
else
LIBSFX=a
MREDLINKER="$CXX"

4
src/copytree.ss
View File

@ -1,7 +1,7 @@
;; This file is used to copy the PLT tree as part of `make install', and as
;; part of Unix installers. It should be invoked with the source plt directory
;; (holding a usual plt tree), and a list of path names that should be copied.
;; Not providing a good cmdline interface since it is should be as independent
;; Not providing a good cmdline interface, since it is should be as independent
;; as possible.
(module copytree mzscheme
@ -53,6 +53,8 @@
(lambda ()
(printf "(module config (lib \"configtab.ss\" \"setup\")\n")
(printf " (define doc-dir ~s)\n" docdir)
(when (eq? 'shared (system-type 'link))
(printf " (define dll-dir ~s)\n" libdir))
(printf " (define lib-dir ~s)\n" libpltdir)
(printf " (define include-dir ~s)\n" includepltdir)
(printf " (define bin-dir ~s)\n" bindir)

1
src/mred/gc2/Makefile.in
View File

@ -1371,6 +1371,7 @@ MRFWRES = PLT_MrEd.framework/Versions/$(FWVERSION)_3m/Resources/PLT_MrEd.rsrc
$(MREDLINKER) -o ../MrEd3m.app/Contents/MacOS/MrEd3m mrmain.@LTO@ -Wl,-headerpad_max_install_names -F. -framework PLT_MrEd -framework Carbon
if [ ! -d ../PLT_MrEd.framework/Versions/$(FWVERSION)_3m ] ; then mkdir ../PLT_MrEd.framework/Versions/$(FWVERSION)_3m ; fi
cp $(MRFW) ../$(MRFW)
rm -rf ../PLT_MrEd.framework/Versions/$(FWVERSION)_3m/Resources
cp -r PLT_MrEd.framework/Versions/$(FWVERSION)_3m/Resources ../PLT_MrEd.framework/Versions/$(FWVERSION)_3m/Resources
/usr/bin/install_name_tool -change "PLT_MrEd.framework/Versions/$(FWVERSION)_3m/PLT_MrEd" "@executable_path/../../../PLT_MrEd.framework/Versions/$(FWVERSION)_3m/PLT_MrEd" ../MrEd3m.app/Contents/MacOS/MrEd3m

3
src/mzscheme/Makefile.in
View File

@ -292,6 +292,7 @@ unix-install:
cd ..; $(ICP) mzscheme/libmzgc.@LIBSFX@ "$(libdir)/libmzgc.@LIBSFX@"
cd ..; $(ICP) mzscheme/libmzscheme.@LIBSFX@ "$(libdir)/libmzscheme.@LIBSFX@"
cd ..; $(ICP) mzscheme/mzscheme "$(bindir)/mzscheme"
cd ..; cp mzscheme/starter "$(libpltdir)/starter"
./mzscheme -mvqu "$(srcdir)/collects-path.ss" "$(bindir)/mzscheme@EXE_SUFFIX@" @COLLECTS_PATH@
cd ..; echo 'CC=@CC@' > $(BUILDINFO)
cd ..; echo 'CFLAGS=@CFLAGS@ @PREFLAGS@ @COMPFLAGS@' >> $(BUILDINFO)
@ -302,7 +303,7 @@ unix-install:
normal-install:
$(MAKE) unix-install
cd ..; cp mzscheme/mzdyn.o $(libpltdir)/mzdyn.o
cd ..; cp mzscheme/mzdyn.o "$(libpltdir)/mzdyn.o"
MZFWDIR = @FRAMEWORK_INSTALL_DIR@/PLT_MzScheme.framework

56
src/mzscheme/cmdline.inc
View File

@ -6,7 +6,13 @@
#define SDESC "Set! works on undefined identifiers.\n"
char *cmdline_exe_hack = "[Replace me for EXE hack ]";
char *binary_type_hack = "bINARy tYPe:" INITIAL_BIN_TYPE;
#ifdef MZ_PRECISE_GC
# define GC_PRECISION_TYPE "3"
#else
# define GC_PRECISION_TYPE "c"
#endif
char *binary_type_hack = "bINARy tYPe:" INITIAL_BIN_TYPE GC_PRECISION_TYPE;
#ifndef INITIAL_COLLECTS_DIRECTORY
# ifdef DOS_FILE_SYSTEM
@ -465,7 +471,7 @@ static int run_from_cmd_line(int argc, char *_argv[],
GC_CAN_IGNORE char **argv = _argv;
Scheme_Env *global_env;
char *prog, *sprog = NULL;
Scheme_Object *sch_argv, *collects_path = NULL;
Scheme_Object *sch_argv, *collects_path = NULL, *collects_extra = NULL;
int i;
#ifndef DONT_PARSE_COMMAND_LINE
char **evals_and_loads, *real_switch = NULL, *runner;
@ -742,6 +748,8 @@ static int run_from_cmd_line(int argc, char *_argv[],
argv[0] = "-b";
else if (!strcmp("--collects", argv[0]))
argv[0] = "-X";
else if (!strcmp("--search", argv[0]))
argv[0] = "-S";
# ifndef MZSCHEME_CMD_LINE
else if (!strcmp("--nogui", argv[0]))
argv[0] = "-Z";
@ -805,6 +813,22 @@ static int run_from_cmd_line(int argc, char *_argv[],
--argc;
collects_path = scheme_make_path(argv[0]);
break;
case 'U':
scheme_set_ignore_user_paths(1);
break;
case 'S':
if (argc < 2) {
PRINTF("%s: missing path after %s switch\n",
prog, real_switch);
goto show_need_help;
}
argv++;
--argc;
if (!collects_extra)
collects_extra = scheme_make_null();
collects_extra = scheme_make_pair(scheme_make_path(argv[0]),
collects_extra);
break;
case 'x':
no_lib_path = 1;
break;
@ -1087,15 +1111,19 @@ static int run_from_cmd_line(int argc, char *_argv[],
scheme_set_collects_path(collects_path);
/* Make list of additional collection paths: */
l = scheme_make_null();
offset = _coldir_offset;
while (1) {
len = strlen(_coldir XFORM_OK_PLUS offset);
offset += len + 1;
if (!_coldir[offset])
break;
l = scheme_make_pair(scheme_make_path(_coldir XFORM_OK_PLUS offset),
l);
if (collects_extra) {
l = collects_extra;
} else {
l = scheme_make_null();
offset = _coldir_offset;
while (1) {
len = strlen(_coldir XFORM_OK_PLUS offset);
offset += len + 1;
if (!_coldir[offset])
break;
l = scheme_make_pair(scheme_make_path(_coldir XFORM_OK_PLUS offset),
l);
}
}
/* Reverse list */
r = scheme_make_null();
@ -1177,10 +1205,12 @@ static int run_from_cmd_line(int argc, char *_argv[],
" -k <n> <m> : Load executable-embedded code from file offset <n> to <m>.\n"
" -C, --main : Like -r, then call `main' w/argument list; car is file name.\n"
" Initialization switches:\n"
" -X <dir>, --collects <dir> : libraries at <dir> relative to executable.\n"
" -X <dir>, --collects <dir> : Main collects at <dir> relative to " PROGRAM ".\n"
" -S <dir>, --search <dir> : More collects at <dir> relative to " PROGRAM ".\n"
" -U, --no-user-path : Ignores user-specific collects, etc.\n"
" -x, --no-lib-path : Skips trying to set current-library-collection-paths.\n"
" -q, --no-init-file : Skips trying to load " INIT_FILENAME ".\n"
" -N <file>, --name <file> : Set `program' to <file>.\n"
" -N <file>, --name <file> : Sets `program' to <file>.\n"
" -A : Skips defining `argv' and `program'.\n"
# ifdef MZ_USE_JIT
" -j, --no-jit : Disables just-in-time compiler.\n"

14
src/mzscheme/configure.ac
View File

@ -1038,17 +1038,8 @@ if test "${enable_shared}" = "yes" ; then
STATIC_AR="${LTDIR}/libtool --mode=link $CC -o"
ARFLAGS=""
RANLIB=":"
exes="xxxxxxxx"
exes="${exes}${exes}"
exes="${exes}${exes}"
exes="${exes}${exes}"
exes="${exes}${exes}"
exes="${exes}${exes}"
exes="${exes}${exes}"
exes="${exes}${exes}"
padding="padding$exes"
MZLINKER="${LTDIR}/libtool --mode=link $CC${need_gcc_static_libgcc} -rpath ${absprefix}/lib -rpath ${absprefix}/lib/${padding}"
MREDLINKER="${LTDIR}/libtool --mode=link $CXX${need_gcc_static_libgcc} -rpath ${absprefix}/lib -rpath ${absprefix}/lib/${padding}"
MZLINKER="${LTDIR}/libtool --mode=link $CC${need_gcc_static_libgcc} -rpath ${absprefix}/lib"
MREDLINKER="${LTDIR}/libtool --mode=link $CXX${need_gcc_static_libgcc} -rpath ${absprefix}/lib"
PLAIN_CC="$CC"
CC="${LTDIR}/libtool --mode=compile $CC"
CXX="${LTDIR}/libtool --mode=compile $CXX"
@ -1062,6 +1053,7 @@ if test "${enable_shared}" = "yes" ; then
LTA="la"
FOREIGN_CONVENIENCE="_convenience"
FOREIGN_OBJSLIB="\$(FOREIGN_LIB)"
MZOPTIONS="$MZOPTIONS -DMZ_USES_SHARED_LIB"
else
LIBSFX=a
MREDLINKER="$CXX"

4
src/mzscheme/dynsrc/Makefile.in
View File

@ -19,6 +19,7 @@ CFLAGS = @CFLAGS@ @COMPFLAGS@ @PREFLAGS@ -I$(builddir)/.. -I$(srcdir)/../include
dynlib:
$(MAKE) ../mzdyn.o
$(MAKE) ../starter
dynlib3m:
$(MAKE) ../mzdyn3m.o
@ -43,6 +44,9 @@ MZDYNDEP = ../mzdyn.o $(srcdir)/../include/ext.exp $(srcdir)/../include/mzscheme
dynexmpl.o: $(srcdir)/dynexmpl.c $(HEADERS)
$(PLAIN_CC) $(CFLAGS) -c $(srcdir)/dynexmpl.c -o dynexmpl.o
../starter: $(srcdir)/ustart.c
$(PLAIN_CC) $(CFLAGS) -o ../starter $(srcdir)/ustart.c
ILIBDIR = $(libpltdir)
# Prefix might be relative to srcdir, or it might be absolute, so we

106
src/mzscheme/dynsrc/ustart.c
View File

@ -11,34 +11,47 @@
#include <fcntl.h>
#include <errno.h>
char *config = "[Replace me with offset info ]";
/* The config string after : is replaced with ! followed by a sequence
of little-endian 4-byte ints:
start - offset into the binary
prog_end - offset; start to prog_end is the program region
end - offset; prog_end to end is the command region
count - number of cmdline args in command region
x11? - non-zero => launches MrEd for X
char *binary_type_hack = "bINARy tYPe:ezi";
In the command region, the format is a sequence of NUL-terminated strings:
exe_path - program to start (relative is w.r.t. executable)
dll_path - DLL directory if non-empty (relative is w.r.t. executable)
cmdline_arg ...
*/
char *config = "cOnFiG:[***************************";
char *binary_type_hack = "bINARy tYPe:ezic";
/* This path list is used instead of the one in the MzScheme/MrEd
binary. That way, the same MzScheme/MrEd binary can be shared
among embedding exectuables that have different collection
paths. */
static char *_coldir = "coLLECTs dIRECTORy:" /* <- this tag stays, so we can find it again */
"../collects"
"\0\0" /* <- 1st nul terminates path, 2nd terminates path list */
/* Pad with at least 1024 bytes: */
"****************************************************************"
"****************************************************************"
"****************************************************************"
"****************************************************************"
"****************************************************************"
"****************************************************************"
"****************************************************************"
"****************************************************************"
"****************************************************************"
"****************************************************************"
"****************************************************************"
"****************************************************************"
"****************************************************************"
"****************************************************************"
"****************************************************************"
"****************************************************************";
char *_coldir = "coLLECTs dIRECTORy:" /* <- this tag stays, so we can find it again */
"../collects"
"\0\0" /* <- 1st nul terminates path, 2nd terminates path list */
/* Pad with at least 1024 bytes: */
"****************************************************************"
"****************************************************************"
"****************************************************************"
"****************************************************************"
"****************************************************************"
"****************************************************************"
"****************************************************************"
"****************************************************************"
"****************************************************************"
"****************************************************************"
"****************************************************************"
"****************************************************************"
"****************************************************************"
"****************************************************************"
"****************************************************************"
"****************************************************************";
static int _coldir_offset = 19; /* Skip permanent tag */
typedef struct {
@ -86,6 +99,8 @@ static void write_str(int fd, char *s)
write(fd, s, strlen(s));
}
#if 0
/* Useful for debugging: */
static char *num_to_string(int n)
{
if (!n)
@ -101,6 +116,7 @@ static char *num_to_string(int n)
return d;
}
}
#endif
static char *string_append(char *s1, char *s2)
{
@ -192,9 +208,15 @@ int main(int argc, char **argv)
{
char *me = argv[0], *data, **new_argv;
char *exe_path, *lib_path, *dll_path;
int start, cmd_end, end, count, fd, v, x11;
int start, prog_end, end, count, fd, v, x11;
int argpos, inpos, collcount = 1;
if (config[7] == '[') {
write_str(2, argv[0]);
write_str(2, ": this is an unconfigured starter\n");
return 1;
}
if (me[0] == '/') {
/* Absolute path */
} else if (has_slash(me)) {
@ -262,11 +284,11 @@ int main(int argc, char **argv)
}
}
start = as_int(config);
cmd_end = as_int(config + 4);
end = as_int(config + 8);
count = as_int(config + 12);
x11 = as_int(config + 16);
start = as_int(config + 8);
prog_end = as_int(config + 12);
end = as_int(config + 16);
count = as_int(config + 20);
x11 = as_int(config + 24);
{
int offset, len;
@ -280,12 +302,13 @@ int main(int argc, char **argv)
}
}
data = (char *)malloc(cmd_end - start);
data = (char *)malloc(end - prog_end);
new_argv = (char **)malloc((count + argc + (2 * collcount) + 8) * sizeof(char*));
fd = open(me, O_RDONLY, 0);
lseek(fd, start, SEEK_SET);
read(fd, data, cmd_end - start);
lseek(fd, prog_end, SEEK_SET);
read(fd, data, end - prog_end);
close(fd);
exe_path = data;
data = next_string(data);
@ -296,14 +319,16 @@ int main(int argc, char **argv)
exe_path = absolutize(exe_path, me);
lib_path = absolutize(lib_path, me);
dll_path = getenv("LD_LIBRARY_PATH");
if (!dll_path) {
dll_path = "";
if (*lib_path) {
dll_path = getenv("LD_LIBRARY_PATH");
if (!dll_path) {
dll_path = "";
}
dll_path = string_append(dll_path, ":");
dll_path = string_append(lib_path, dll_path);
dll_path = string_append("LD_LIBRARY_PATH=", dll_path);
putenv(dll_path);
}
dll_path = string_append(dll_path, ":");
dll_path = string_append(lib_path, dll_path);
dll_path = string_append("LD_LIBRARY_PATH=", dll_path);
putenv(dll_path);
new_argv[0] = me;
@ -346,11 +371,6 @@ int main(int argc, char **argv)
}
}
/* Add -k flag */
new_argv[argpos++] = "-k";
new_argv[argpos++] = num_to_string(cmd_end);
new_argv[argpos++] = num_to_string(end);
/* Add built-in flags: */
while (count--) {
new_argv[argpos++] = data;

7
src/mzscheme/include/scheme.h
View File

@ -1094,6 +1094,7 @@ enum {
MZCONFIG_CODE_INSPECTOR,
MZCONFIG_USE_COMPILED_KIND,
MZCONFIG_USE_USER_PATHS,
MZCONFIG_LOAD_DIRECTORY,
MZCONFIG_WRITE_DIRECTORY,
@ -1521,13 +1522,15 @@ MZ_EXTERN int scheme_square_brackets_are_parens; /* Defaults to 1 */
MZ_EXTERN int scheme_curly_braces_are_parens; /* Defaults to 1 */
MZ_EXTERN int scheme_hash_percent_syntax_only; /* Defaults to 0 */
MZ_EXTERN int scheme_hash_percent_globals_only; /* Defaults to 0 */
MZ_EXTERN int scheme_binary_mode_stdio; /* Windows-MacOS-specific. Defaults to 0 */
MZ_EXTERN int scheme_startup_use_jit;
MZ_EXTERN int scheme_binary_mode_stdio; /* Windows-specific; Defaults to 0 */
MZ_EXTERN int scheme_startup_use_jit; /* Defaults to 1 */
MZ_EXTERN int scheme_ignore_user_paths; /* Defaults to 0 */
MZ_EXTERN void scheme_set_case_sensitive(int);
MZ_EXTERN void scheme_set_allow_set_undefined(int);
MZ_EXTERN void scheme_set_binary_mode_stdio(int);
MZ_EXTERN void scheme_set_startup_use_jit(int);
MZ_EXTERN void scheme_set_ignore_user_paths(int);
MZ_EXTERN int scheme_get_allow_set_undefined();

3008
src/mzscheme/src/cstartup.inc
View File

File diff suppressed because it is too large Load Diff

17
src/mzscheme/src/file.c
View File

@ -113,6 +113,9 @@ long scheme_creator_id = 'MzSc';
# define IS_A_SEP(x) (!(x))
#endif
MZ_DLLSPEC int scheme_ignore_user_paths;
void scheme_set_ignore_user_paths(int v) { scheme_ignore_user_paths = v; }
#define CURRENT_WD() scheme_get_param(scheme_current_config(), MZCONFIG_CURRENT_DIRECTORY)
#define TO_PATH(x) (SCHEME_PATHP(x) ? x : scheme_char_string_to_path(x))
@ -161,6 +164,7 @@ static Scheme_Object *file_or_dir_permissions(int argc, Scheme_Object *argv[]);
static Scheme_Object *file_size(int argc, Scheme_Object *argv[]);
static Scheme_Object *current_library_collection_paths(int argc, Scheme_Object *argv[]);
static Scheme_Object *use_compiled_kind(int, Scheme_Object *[]);
static Scheme_Object *use_user_paths(int, Scheme_Object *[]);
static Scheme_Object *find_system_path(int argc, Scheme_Object **argv);
#endif
@ -419,6 +423,11 @@ void scheme_init_file(Scheme_Env *env)
"use-compiled-file-paths",
MZCONFIG_USE_COMPILED_KIND),
env);
scheme_add_global_constant("use-user-specific-search-paths",
scheme_register_parameter(use_user_paths,
"use-user-specific-search-paths",
MZCONFIG_USE_USER_PATHS),
env);
}
/**********************************************************************/
@ -4433,6 +4442,14 @@ static Scheme_Object *use_compiled_kind(int argc, Scheme_Object *argv[])
-1, compiled_kind_p, "list of relative paths and strings", 1);
}
static Scheme_Object *use_user_paths(int argc, Scheme_Object *argv[])
{
return scheme_param_config("use-user-specific-search-paths",
scheme_make_integer(MZCONFIG_USE_USER_PATHS),
argc, argv,
-1, NULL, NULL, 1);
}
/********************************************************************************/
#ifndef NO_FILE_SYSTEM_UTILS

4
src/mzscheme/src/portfun.c
View File

@ -730,6 +730,10 @@ void scheme_init_port_fun_config(void)
scheme_set_root_param(MZCONFIG_USE_COMPILED_KIND,
scheme_make_immutable_pair(scheme_make_path("compiled"),
scheme_null));
scheme_set_root_param(MZCONFIG_USE_USER_PATHS,
(scheme_ignore_user_paths
? scheme_false
: scheme_true));
{
Scheme_Object *dlh;

2
src/mzscheme/src/schminc.h
View File

@ -13,7 +13,7 @@
#define USE_COMPILED_STARTUP 1
#define EXPECTED_PRIM_COUNT 863
#define EXPECTED_PRIM_COUNT 864
#ifdef MZSCHEME_SOMETHING_OMITTED
# undef USE_COMPILED_STARTUP

4
src/mzscheme/src/schvers.h
View File

@ -9,6 +9,6 @@
#define MZSCHEME_VERSION_MAJOR 301
#define MZSCHEME_VERSION_MINOR 15
#define MZSCHEME_VERSION_MINOR 16
#define MZSCHEME_VERSION "301.15" _MZ_SPECIAL_TAG
#define MZSCHEME_VERSION "301.16" _MZ_SPECIAL_TAG

11
src/mzscheme/src/startup.inc
View File

@ -3052,12 +3052,17 @@
"(case-lambda"
"(()(find-library-collection-paths null))"
"((extra-collects-dirs)"
"(let((user-too?(use-user-specific-search-paths))"
"(cons-if(lambda(f r)(if f(cons f r) r))))"
"(path-list-string->path-list"
"(if user-too?"
" (or (getenv \"PLTCOLLECTS\") \"\")"
"(cons"
" \"\")"
"(cons-if"
"(and user-too?"
"(build-path(find-system-path 'addon-dir)"
"(version)"
" \"collects\")"
" \"collects\"))"
"(let loop((l(append"
" extra-collects-dirs"
"(list(find-system-path 'collects-dir)))))"
@ -3075,7 +3080,7 @@
"(if v"
"(cons(simplify-path(path->complete-path v(current-directory)))"
"(loop(cdr l)))"
"(loop(cdr l)))))))))))"
"(loop(cdr l))))))))))))"
"(define(port? x)(or(input-port? x)(output-port? x)))"
"(define-values(struct:guard make-guard guard? guard-ref guard-set!)"
"(make-struct-type 'evt #f 1 0 #f(list(cons prop:evt 0))(current-inspector) #f '(0)))"

53
src/mzscheme/src/startup.ss
View File

@ -3501,30 +3501,35 @@
(case-lambda
[() (find-library-collection-paths null)]
[(extra-collects-dirs)
(path-list-string->path-list
(or (getenv "PLTCOLLECTS") "")
(cons
(build-path (find-system-path 'addon-dir)
(version)
"collects")
(let loop ([l (append
extra-collects-dirs
(list (find-system-path 'collects-dir)))])
(if (null? l)
null
(let* ([collects-path (car l)]
[v
(cond
[(complete-path? collects-path) collects-path]
[(absolute-path? collects-path)
(path->complete-path collects-path
(find-executable-path (find-system-path 'exec-file) #f #t))]
[else
(find-executable-path (find-system-path 'exec-file) collects-path #t)])])
(if v
(cons (simplify-path (path->complete-path v (current-directory)))
(loop (cdr l)))
(loop (cdr l))))))))]))
(let ([user-too? (use-user-specific-search-paths)]
[cons-if (lambda (f r) (if f (cons f r) r))])
(path-list-string->path-list
(if user-too?
(or (getenv "PLTCOLLECTS") "")
"")
(cons-if
(and user-too?
(build-path (find-system-path 'addon-dir)
(version)
"collects"))
(let loop ([l (append
extra-collects-dirs
(list (find-system-path 'collects-dir)))])
(if (null? l)
null
(let* ([collects-path (car l)]
[v
(cond
[(complete-path? collects-path) collects-path]
[(absolute-path? collects-path)
(path->complete-path collects-path
(find-executable-path (find-system-path 'exec-file) #f #t))]
[else
(find-executable-path (find-system-path 'exec-file) collects-path #t)])])
(if v
(cons (simplify-path (path->complete-path v (current-directory)))
(loop (cdr l)))
(loop (cdr l)))))))))]))
;; -------------------------------------------------------------------------

39
src/mzscheme/src/string.c
View File

@ -2066,15 +2066,42 @@ static void machine_details(char *s);
static Scheme_Object *system_type(int argc, Scheme_Object *argv[])
{
if (!argc || SCHEME_FALSEP(argv[0]))
return sys_symbol;
else {
char buff[1024];
if (argc) {
Scheme_Object *sym;
sym = scheme_intern_symbol("link");
if (SAME_OBJ(argv[0], sym)) {
#ifdef OS_X
return scheme_intern_symbol("framework");
#else
# ifdef DOS_FILE_SYSTEM
return scheme_intern_symbol("dll");
# else
# ifdef MZ_USES_SHARED_LIB
return scheme_intern_symbol("shared");
# else
return scheme_intern_symbol("static");
# endif
# endif
#endif
}
machine_details(buff);
sym = scheme_intern_symbol("machine");
if (SAME_OBJ(argv[0], sym)) {
char buff[1024];
machine_details(buff);
return scheme_make_utf8_string(buff);
}
return scheme_make_utf8_string(buff);
sym = scheme_intern_symbol("os");
if (!SAME_OBJ(argv[0], sym)) {
scheme_wrong_type("system-type", "'os, 'link, or 'machine", 0, argc, argv);
return NULL;
}
}
return sys_symbol;
}
static Scheme_Object *system_library_subpath(int argc, Scheme_Object *argv[])

2
src/wxwindow/src/msw/wx_win.cxx
View File

@ -1609,7 +1609,7 @@ void wxWnd::OnDropFiles(WPARAM wParam)
for (wIndex=0; wIndex < (int)gwFilesDropped; wIndex++) {
len = DragQueryFileW(hFilesInfo, wIndex, NULL, 0);
w_file = new WXGC_ATOMIC wchar_t[len + 1];
DragQueryFileW(hFilesInfo, wIndex, w_file, len);
DragQueryFileW(hFilesInfo, wIndex, w_file, len + 1);
a_file = wxNARROW_STRING(w_file);
files[wIndex] = a_file;
}