301.16

svn: r3040

collects/compiler/distribute.ss

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

collects/compiler/doc.txt

@@ -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'.
 

collects/compiler/embed-unit.ss

@@ -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@)
 
@@ -497,11 +498,6 @@
 	  (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
 	(opt-lambda (dest mred? verbose? 
@@ -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
+	  (define collects-path-bytes (collects-path->bytes 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 #""])))
 	  (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
+	  (check-collects-path 'create-embedding-executable collects-path collects-path-bytes)
-	    (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")))
 	  (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)))
+			  (cond
-			      (values (prepare-macosx-mred exe dest aux variant) #f #t)
+			   [(and mred? (eq? 'macosx (system-type)))
-			      (begin
+			    (values (prepare-macosx-mred exe dest aux variant) #f #t)]
-				(when (or (file-exists? dest)
+			   [unix-starter?
-					  (directory-exists? dest)
+			    (let ([starter (build-path (find-lib-dir) "starter")])
-					  (link-exists? dest))
+			      (when (or (file-exists? dest)
-				  ;; Delete-file isn't enough if the target
+					(directory-exists? dest)
-				  ;;  is supposed to be a directory. But
+					(link-exists? dest))
-				  ;;  currently, that happens only for MrEd 
+				(delete-file dest))
-				  ;;  on Mac OS X, which is handles above.
+			      (copy-file starter dest)
-				  (delete-file dest))
+			      (values dest starter #f))]
-				(copy-file exe dest)
+			   [else
-				(values dest exe #f)))])
+			    (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)]
+					   cmdline)])
-			    [libpos (and collects-path
+			(when collects-path-bytes
-					 (let ([tag #"coLLECTs dIRECTORy:"])
+			  (when verbose?
-					   (+ (with-input-from-file dest-exe 
+			    (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"
+							    "exeuctable type"
-							    tag)))
+							    #"bINARy tYPe:"))))]
-					      (bytes-length tag))))])
+				[cmdline
-			(if osx?
+				 (apply bytes-append
-			    (begin
+					(map (lambda (s)
-			      (finish-osx-mred dest full-cmdline exe keep-exe? relative?)
+					       (bytes-append 
-			      (when libpos
+						(cond
-				(call-with-output-file* dest-exe
+						 [(path? s) (path->bytes s)]
-				  (lambda (out)
+						 [else (string->bytes/locale s)])
-				    (write-lib out libpos collects-path-bytes))
+						#"\0"))
-				  'update)))
+					     (append
-			    (let ([cmdpos (with-input-from-file dest-exe 
+					      (list (if relative?
-					    (lambda () (find-cmdline 
+							(relativize exe dest-exe values)
-							"cmdline"
+							exe)
-							#"\\[Replace me for EXE hack")))]
+						    (let ([dir (find-dll-dir)])
-				  [anotherpos (and mred?
+						      (if dir
-						   (eq? 'windows (system-type))
+							  (if relative?
-						   (let ([m (assq 'single-instance? aux)])
+							      (relativize dir dest-exe values)
-						     (and m (not (cdr m))))
+							      dir)
-						   (with-input-from-file dest-exe 
+							  "")))
-						     (lambda () (find-cmdline 
+					      full-cmdline)))]
-								 "instance-check"
+				[out (open-output-file dest-exe 'update)])
-								 #"yes, please check for another"))))]
+			    (let ([cmdline-end (+ end (bytes-length cmdline))]
-				  [out (open-output-file dest-exe 'update)])
+				  [write-num (lambda (n)
+					       (write-bytes (integer->integer-bytes n 4 #t #f) out))])
 			      (dynamic-wind
 				  void
 				  (lambda ()
-				    (when anotherpos
+				    (when typepos
-				      (file-position out anotherpos)
+				      (file-position out (+ typepos 13))
-				      (write-bytes #"no," out))
+				      (write-bytes #"r" out)
-				    (when libpos
+				      (flush-output out))
-				      (write-lib out libpos collects-path-bytes))
+				    (file-position out (+ numpos 7))
-				    (if long-cmdline?
+				    (write-bytes #"!" out)
-					;; write cmdline at end:
+				    (write-num start)
-					(file-position out end)
+				    (write-num end)
-					(begin
+				    (write-num cmdline-end)
-					  ;; write (short) cmdline in the normal position:
+				    (write-num (length full-cmdline))
-					  (file-position out cmdpos)
+				    (write-num (if mred? 1 0))
-					  (display "!" out)))
+				    (flush-output out)
-				    (for-each
+				    (file-position out end)
-				     (lambda (s)
+				    (write-bytes cmdline out)
-				       (fprintf out "~a~a~c"
+				    (flush-output out))
-						(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)))
+				    (close-output-port out)))))]
-			      (let ([m (and (eq? 'windows (system-type))
+			 [else
-					    (assq 'ico aux))])
+			  (let ([cmdpos (with-input-from-file dest-exe 
-				(when m
+					  (lambda () (find-cmdline 
-				  (install-icon dest-exe (cdr m))))
+						      "cmdline"
-			      (let ([m (and (eq? 'windows (system-type))
+						      #"\\[Replace me for EXE hack")))]
-					    (assq 'subsystem aux))])
+				[anotherpos (and mred?
-				(when m
+						 (eq? 'windows (system-type))
-				  (set-subsystem dest-exe (cdr m)))))))))))))))))
+						 (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)))))]))))))))))))

collects/compiler/private/collects-path.ss

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

collects/compiler/start.ss

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

collects/help/bug-report.ss

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

collects/mysterx/installer.ss

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

collects/net/sendurl.ss

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

collects/setup/configtab.ss

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

collects/setup/dirs.ss

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

collects/setup/doc.txt

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

collects/tests/mzscheme/basic.ss

@@ -2013,8 +2013,9 @@
 (test #t string? (version))
 (test #t string? (banner))
 (test #t symbol? (system-type))
-(test (system-type) system-type #f)
+(test (system-type) system-type 'os)
-(test #t string? (system-type #t))
+(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)])

doc/release-notes/mzscheme/HISTORY

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

src/configure

@@ -11700,17 +11700,8 @@ if test "${enable_shared}" = "yes" ; then
   STATIC_AR="${LTDIR}/libtool --mode=link $CC -o"
   ARFLAGS=""
   RANLIB=":"
-  exes="xxxxxxxx"
+  MZLINKER="${LTDIR}/libtool --mode=link $CC${need_gcc_static_libgcc} -rpath ${absprefix}/lib"
-  exes="${exes}${exes}"
+  MREDLINKER="${LTDIR}/libtool --mode=link $CXX${need_gcc_static_libgcc} -rpath ${absprefix}/lib"
-  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}"
   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"

src/copytree.ss

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

src/mred/gc2/Makefile.in

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

src/mzscheme/Makefile.in

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

src/mzscheme/cmdline.inc

@@ -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();
+    if (collects_extra) {
-    offset = _coldir_offset;
+      l = collects_extra;
-    while (1) {
+    } else {
-      len = strlen(_coldir XFORM_OK_PLUS offset);
+      l = scheme_make_null();
-      offset += len + 1;
+      offset = _coldir_offset;
-      if (!_coldir[offset])
+      while (1) {
-	break;
+	len = strlen(_coldir XFORM_OK_PLUS offset);
-      l = scheme_make_pair(scheme_make_path(_coldir XFORM_OK_PLUS offset),
+	offset += len + 1;
-			   l);
+	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"

src/mzscheme/configure.ac

@@ -1038,17 +1038,8 @@ if test "${enable_shared}" = "yes" ; then
   STATIC_AR="${LTDIR}/libtool --mode=link $CC -o"
   ARFLAGS=""
   RANLIB=":"
-  exes="xxxxxxxx"
+  MZLINKER="${LTDIR}/libtool --mode=link $CC${need_gcc_static_libgcc} -rpath ${absprefix}/lib"
-  exes="${exes}${exes}"
+  MREDLINKER="${LTDIR}/libtool --mode=link $CXX${need_gcc_static_libgcc} -rpath ${absprefix}/lib"
-  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}"
   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"

src/mzscheme/dynsrc/Makefile.in

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

src/mzscheme/dynsrc/ustart.c

@@ -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 */
+char *_coldir = "coLLECTs dIRECTORy:" /* <- this tag stays, so we can find it again */
-                       "../collects"
+                "../collects"
-                       "\0\0" /* <- 1st nul terminates path, 2nd terminates path list */
+                "\0\0" /* <- 1st nul terminates path, 2nd terminates path list */
-                       /* Pad with at least 1024 bytes: */
+                /* 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);
+  start = as_int(config + 8);
-  cmd_end = as_int(config + 4);
+  prog_end = as_int(config + 12);
-  end = as_int(config + 8);
+  end = as_int(config + 16);
-  count = as_int(config + 12);
+  count = as_int(config + 20);
-  x11 = as_int(config + 16);
+  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);
+  lseek(fd, prog_end, SEEK_SET);
-  read(fd, data, cmd_end - start);
+  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 (*lib_path) {
-  if (!dll_path) {
+    dll_path = getenv("LD_LIBRARY_PATH");
-    dll_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;

src/mzscheme/include/scheme.h

@@ -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_binary_mode_stdio; /* Windows-specific; Defaults to 0 */
-MZ_EXTERN int scheme_startup_use_jit;
+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();
 

src/mzscheme/src/file.c

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

src/mzscheme/src/portfun.c

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

src/mzscheme/src/schminc.h

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

src/mzscheme/src/schvers.h

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

src/mzscheme/src/startup.inc

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

src/mzscheme/src/startup.ss

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

src/mzscheme/src/string.c

@@ -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]))
+  if (argc) {
-    return sys_symbol;
+    Scheme_Object *sym;
-  else {
+    sym = scheme_intern_symbol("link");
-    char buff[1024];
+    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];
       
-    return scheme_make_utf8_string(buff);
+      machine_details(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[])

src/wxwindow/src/msw/wx_win.cxx

@@ -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;
   }