no more PLTHOME anywhere; instead, there's a dir.ss library to find various directories

svn: r2924

collects/compiler/embed-unit.ss

@@ -7,7 +7,7 @@
 	   (lib "port.ss")
 	   (lib "moddep.ss" "syntax")
 	   (lib "plist.ss" "xml")
-	   (lib "plthome.ss" "setup")
+	   (lib "dirs.ss" "setup")
 	   (lib "kw.ss")
 	   "embed-sig.ss"
 	   "private/winicon.ss"
@@ -592,7 +592,7 @@
 									      "PLT_MrEd"
 									      "PLT_MzScheme")))
 			     (update-framework-path (string-append
-						     (path->string (build-path plthome "lib"))
+						     (path->string (find-lib-dir))
 						     "/")
 						    dest
 						    mred?))))))

collects/compiler/private/driver.ss

@@ -73,7 +73,7 @@
 	   (lib "compile-sig.ss" "dynext")
 	   (lib "link-sig.ss" "dynext")
 	   (lib "file-sig.ss" "dynext")
-	   (lib "plthome.ss" "setup"))
+	   (lib "dirs.ss" "setup"))
 
   (require "../sig.ss"
 	   "sig.ss"
@@ -1352,7 +1352,7 @@
 	      (xform (not (compiler:option:verbose)) 
 		     (path->string c-output-path)
 		     c3m-output-path
-		     (list (build-path plthome "include")
+		     (list (find-include-dir)
 			   (collection-path "compiler")))
 
 	      (clean-up-src-c))))

collects/compiler/private/mach-o.ss

@@ -166,6 +166,159 @@
 		(display (make-bytes (- outlen (bytes-length segdata)) 0) out)
 		;; Result is offset where data was written:
 		out-offset)))
+	  (lambda ()
+	    (close-input-port p)
+	    (close-output-port out)))))
+
+  #;
+  (define (get/set-dylib-path rx new-path)
+    (let-values ([(p out) (open-input-output-file file 'update)])
+      (dynamic-wind
+	  void
+	  (lambda ()
+	    (check-same #xFeedFace (read-ulong p))
+	    (read-ulong p)
+	    (read-ulong p)
+	    (check-same #x2 (read-ulong p))
+	    (let* ([cnt (read-ulong p)]
+		   [cmdssz (read-ulong p)]
+		   [min-used (round-up-page cmdssz)]
+		   [sym-tab-pos 0]
+		   [dysym-pos 0]
+		   [hints-pos 0]
+		   [link-edit-pos 0]
+		   [link-edit-addr 0]
+		   [link-edit-offset 0]
+		   [link-edit-len 0])
+	      (printf "~a cmds, length 0x~x\n" cnt cmdssz)
+	      (read-ulong p)
+	      (let loop ([cnt cnt])
+		(unless (zero? cnt)
+		  (let ([pos (file-position p)]
+			[cmd (read-ulong p)]
+			[sz (read-ulong p)])
+		    (printf "~x (~a)\n" cmd sz)
+		    (case cmd
+		      [(1)
+		       ;; Segment
+		       (let ([segname (read-bytes 16 p)]
+			     [vmaddr (read-ulong p)]
+			     [vmlen (read-ulong p)]
+			     [offset (read-ulong p)]
+			     [len (read-ulong p)])
+			 (printf "~s\n" segname)
+			 (when (equal? segname #"__LINKEDIT\0\0\0\0\0\0")
+			   (set! link-edit-pos pos)
+			   (set! link-edit-addr vmaddr)
+			   (set! link-edit-offset offset)
+			   (set! link-edit-len len))
+			 (printf "  0x~x 0x~x -> 0x~x 0x~x\n" offset len vmaddr vmlen)
+			 (read-ulong p)
+			 (read-ulong p)
+			 (let ([nsects (read-ulong p)])
+			   (read-ulong p)
+			   (let loop ([nsects nsects])
+			     (unless (zero? nsects)
+			       (let ([sect (read-bytes 16 p)]
+				     [seg (read-bytes 16 p)]
+				     [vmaddr (read-ulong p)]
+				     [vmsz (read-ulong p)]
+				     [offset (read-ulong p)])
+				 (when ((+ offset vmsz) . > . (+ cmdssz 28))
+				   (when (offset . < . min-used)
+				     (printf "   new min!\n")
+				     (set! min-used offset)))
+				 (printf "    ~s,~s 0x~x 0x~x\n"
+					 seg sect offset vmsz)
+				 (read-ulong p) (read-ulong p) (read-ulong p) (read-ulong p) (read-ulong p) (read-ulong p))
+			       (loop (sub1 nsects))))))]
+		      [(2)
+		       ;; Symbol table
+		       (set! sym-tab-pos pos)]
+		      [(#xB)
+		       ;; Dysym
+		       (set! dysym-pos pos)]
+		      [(#x16)
+		       ;; 2-level hints table
+		       (set! hints-pos pos)]
+		      [else
+		       (void)])
+		    (file-position p (+ pos sz))
+		    (loop (sub1 cnt)))))
+	      (printf "Start offset: 0x~x\n" min-used)
+	      (let ([end-cmd (+ cmdssz 28)]
+		    [new-cmd-sz 56]
+		    [outlen (round-up-page (bytes-length segdata))]
+		    [out-offset (if move-link-edit?
+				    link-edit-offset
+				    (+ link-edit-offset (round-up-page link-edit-len)))]
+		    [out-addr (+ link-edit-addr (round-up-page link-edit-len))])
+		(unless ((+ end-cmd new-cmd-sz) . < . min-used)
+		  (error 'check-header "no room for a new section load command"))
+		;; Shift commands after link-edit segment:
+		(file-position p link-edit-pos)
+		(let ([s (read-bytes (- end-cmd link-edit-pos) p)])
+		  (file-position out (+ link-edit-pos 56))
+		  (display s out))
+		(file-position out 16)
+		;; The segment:
+		(write-ulong (+ cnt 1) out)
+		(write-ulong (+ cmdssz new-cmd-sz) out)
+		(file-position out link-edit-pos)
+		(write-ulong 1 out) ; LC_SEGMENT
+		(write-ulong new-cmd-sz out)
+		(display #"__PLTSCHEME\0\0\0\0\0" out)
+		(write-ulong out-addr out)
+		(write-ulong outlen out)
+		(write-ulong out-offset out)
+		(write-ulong outlen out)
+		(write-ulong 0 out)
+		(write-ulong 0 out)
+		(write-ulong 0 out)
+		(write-ulong 4 out) ; 4 means SG_NORELOC
+		(when move-link-edit?
+		  ;; Update link-edit segment entry:
+		  (when (sym-tab-pos . > . link-edit-pos)
+		    (set! sym-tab-pos (+ sym-tab-pos 56)))
+		  (when (dysym-pos . > . link-edit-pos)
+		    (set! dysym-pos (+ dysym-pos 56)))
+		  (when (hints-pos . > . link-edit-pos)
+		    (set! hints-pos (+ hints-pos 56)))
+		  (set! link-edit-pos (+ link-edit-pos 56))
+		  (file-position out (+ link-edit-pos 32))
+		  (printf "Update to ~a\n" (+ out-offset outlen))
+		  (write-ulong (+ out-offset outlen) out)
+		  ;; Read link-edit segment:
+		  (file-position p link-edit-offset)
+		  (let ([link-edit (read-bytes link-edit-len p)])
+		    ;; Write link-edit data in new location:
+		    (file-position out (+ link-edit-offset outlen))
+		    (display link-edit out))
+		  ;; Shift symbol-table pointer:
+		  (file-position p (+ sym-tab-pos 8))
+		  (let ([symtab-offset (read-ulong p)]
+			[_ (read-ulong p)]
+			[symstr-offset (read-ulong p)])
+		    (file-position out (+ sym-tab-pos 8))
+		    (write-ulong (+ symtab-offset outlen) out)
+		    (file-position out (+ sym-tab-pos 16))
+		    (write-ulong (+ symstr-offset outlen) out))
+		  ;; Shift dysym pointers:
+		  (file-position p (+ dysym-pos 56))
+		  (let ([ind-offset (read-ulong p)])
+		    (file-position out (+ dysym-pos 56))
+		    (write-ulong (+ ind-offset outlen) out))
+		  ;; Shift hints pointer:
+		  (file-position p (+ hints-pos 8))
+		  (let ([hints-offset (read-ulong p)])
+		    (file-position out (+ hints-pos 8))
+		    (write-ulong (+ hints-offset outlen) out)))
+		;; Write segdata to former link-data offset:
+		(file-position out out-offset)
+		(display segdata out)
+		(display (make-bytes (- outlen (bytes-length segdata)) 0) out)
+		;; Result is offset where data was written:
+		out-offset)))
 	  (lambda ()
 	    (close-input-port p)
 	    (close-output-port out))))))

collects/compiler/start.ss

@@ -32,7 +32,7 @@
 	   (lib "link.ss" "dynext")
 	   (lib "pack.ss" "setup")
 	   (lib "getinfo.ss" "setup")
-	   (lib "plthome.ss" "setup"))
+	   (lib "dirs.ss" "setup"))
 
   (define dest-dir (make-parameter #f))
   (define auto-dest-dir (make-parameter #f))
@@ -498,7 +498,7 @@
 		    (not (compiler:option:verbose))
 		    file
 		    out-file
-		    (list (build-path plthome "include")))
+		    (list (find-include-dir)))
 		   (printf " [output to \"~a\"]~n" out-file)))
 	       source-files)]
     [(exe gui-exe)

collects/dynext/private/dirs.ss

@@ -1,22 +1,9 @@
 
 (module dirs mzscheme
-  (require (lib "plthome.ss" "setup"))
+  (require (lib "dirs.ss" "setup"))
 
-  (define (find-dir name)
+  (define include-dir (find-include-dir))
-    (if plthome
+  (define std-library-dir (find-lib-dir))
-	(build-path plthome name)
-	;; Try one up from each collection path:
-	(let loop ([l (current-library-collection-paths)])
-	  (if (null? l) 
-	      ;; Make up a wrong answer:
-	      (format "plt~a" name)
-	      (let ([p (build-path (car l) 'up name)])
-		(if (directory-exists? p)
-		    p
-		    (loop (cdr l))))))))
-
-  (define include-dir (find-dir "include"))
-  (define std-library-dir (find-dir "lib"))
 
   (provide include-dir std-library-dir))
 

collects/frtime/etc.ss

@@ -1,12 +1,12 @@
 
 (module etc (lib "frtime.ss" "frtime")
   (require (lib "spidey.ss")
-           (lib "plthome.ss" "setup"))
+           (lib "main-collects.ss" "setup"))
   (require-for-syntax (lib "kerncase.ss" "syntax")
 		      (lib "stx.ss" "syntax")
 		      (lib "name.ss" "syntax")
 		      (lib "context.ss" "syntax")
-		      (lib "plthome.ss" "setup")
+		      (lib "main-collects.ss" "setup")
 		      (lib "stxset.ss" "mzlib" "private"))
 
   (provide true false
@@ -441,22 +441,19 @@
    (syntax-case stx ()
      [(_)
       (let* ([source (syntax-source stx)]
-	     [local (lambda ()
+             [source (and (path? source) source)]
-		      (or (current-load-relative-directory)
+             [local (or (current-load-relative-directory) (current-directory))]
-			  (current-directory)))]
+	     [dir (path->main-collects-relative
-	     [dir (plthome-ify
+                   (or (and source (file-exists? source)
-                   (or (and source (string? source) (file-exists? source)
                             (let-values ([(base file dir?) (split-path source)])
-                              (and (string? base)
+                              (and (path? base)
-                                   (path->complete-path
+                                   (path->complete-path base local))))
-                                    base
+                       local))])
-                                    (or (current-load-relative-directory)
+        (if (and (pair? dir) (eq? 'collects (car dir)))
-                                        (current-directory))))))
-                       (local)))])
-        (if (and (pair? dir) (eq? 'plthome (car dir)))
           (with-syntax ([d dir])
-            (syntax (un-plthome-ify 'd)))
+            #'(main-collects-relative->path 'd))
-          (datum->syntax-object (quote-syntax here) dir stx)))]))
+          (with-syntax ([d (if (bytes? dir) dir (path->bytes dir))])
+            #'(bytes->path d))))]))
 
  ;; This is a macro-generating macro that wants to expand
  ;; expressions used in the generated macro. So it's weird,

collects/honu-module/info.ss

@@ -1,5 +1,5 @@
 
 (module info (lib "infotab.ss" "setup")
   (define doc.txt "doc.txt")
-  (define name "Honu's #honu"))
+  (define name "#honu"))
 

collects/launcher/launcher-unit.ss

@@ -8,7 +8,7 @@
 	   (lib "compile-sig.ss" "dynext")
 	   (lib "link-sig.ss" "dynext")
 	   (lib "embed.ss" "compiler")
-	   (lib "plthome.ss" "setup")
+	   (lib "dirs.ss" "setup")
 
 	   "launcher-sig.ss"
 
@@ -36,17 +36,21 @@
 		    [(or (eq? 'unix (system-type))
 			 (and (eq? 'macosx (system-type))
 			      (eq? kind 'mzscheme)))
-		     (if (and plthome
+		     (if (let ([bin-dir (find-console-bin-dir)])
-			      (file-exists? (build-path plthome "bin" (format "~a3m" kind))))
+			   (and bin-dir
+				(file-exists? (build-path bin-dir (format "~a3m" kind)))))
 			 '(3m)
 			 null)]
 		    [(eq? 'macosx (system-type))
 		     ;; kind must be mred, because mzscheme case caught above
-		     (if (directory-exists? (build-path plthome "MrEd3m.app"))
+		     (if (directory-exists? (build-path (find-gui-bin-dir) "MrEd3m.app"))
 			 '(3m)
 			 null)]
 		    [(eq? 'windows (system-type))
-		     (if (file-exists? (build-path plthome (format "~a3m.exe" kind)))
+		     (if (file-exists? (build-path (if (eq? kind 'mzscheme)
+						       (find-console-bin-dir)
+						       (find-gui-bin-dir))
+						   (format "~a3m.exe" kind)))
 			 '(3m)
 			 null)]
 		    [else
@@ -54,15 +58,16 @@
 		     null])]
 	       [normal (if (eq? kind 'mzscheme)
 			   '(normal) ; MzScheme is always available
-			   (if (and plthome
+			   (if (let ([gui-dir (find-gui-bin-dir)])
-				    (cond
+				 (and gui-dir
-				     [(eq? 'unix (system-type))
+				      (cond
-				      (file-exists? (build-path plthome "bin" (format "~a" kind)))]
+				       [(eq? 'unix (system-type))
-				     [(eq? 'macosx (system-type))
+					(file-exists? (build-path gui-dir (format "~a" kind)))]
-				      (directory-exists? (build-path plthome "MrEd.app"))]
+				       [(eq? 'macosx (system-type))
-				     [(eq? 'windows (system-type))
+					(directory-exists? (build-path gui-dir "MrEd.app"))]
-				      (file-exists? (build-path plthome (format "~a.exe" kind)))]
+				       [(eq? 'windows (system-type))
-				     [else #t]))
+					(file-exists? (build-path gui-dir (format "~a.exe" kind)))]
+				       [else #t])))
 			       '(normal)
 			       null))]
 	       [script (if (and (eq? 'macosx (system-type))
@@ -340,8 +345,8 @@
                         "\n")]
 	       [dir-finder
 		(let ([bindir (if alt-exe
-				  plthome
+				  (find-gui-bin-dir)
-				  (build-path plthome "bin"))])
+				  (find-console-bin-dir))])
 		  (if (let ([a (assq 'relative? aux)])
 			(and a (cdr a)))
 		      (make-relative-path-header dest bindir)
@@ -360,8 +365,8 @@
 				       (not (null? post-flags)))
 				  output-x-arg-getter
 				  string-append)])
-	  (unless plthome
+	  (unless (find-console-bin-dir)
-	    (error 'make-unix-launcher "unable to locate PLTHOME"))
+	    (error 'make-unix-launcher "unable to locate bin directory"))
 	  (let ([p (open-output-file dest 'truncate)])
 	    (fprintf p "~a~a~a"
 		     header
@@ -395,12 +400,15 @@
 		    [v (byte-regexp #"<Executable Variant: Replace This")])
 		(let* ([exedir (bytes->utf-16-bytes
 				(bytes-append
-				 (path->bytes (if (let ([m (assq 'relative? aux)])
+				 (path->bytes (let ([bin-dir (if (eq? kind 'mred)
+								 (find-gui-bin-dir)
+								 (find-console-bin-dir))])
+					       (if (let ([m (assq 'relative? aux)])
 						    (and m (cdr m)))
-						  (or (relativize (normalize+explode-path plthome)
+						  (or (relativize (normalize+explode-path bin-dir)
 								  (normalize+explode-path dest))
 						      (build-path 'same))
-						  plthome))
+						  bin-dir)))
 				 ;; null wchar marks end of executable directory
 				 #"\0\0"))]
 		       [find-it ; Find the magic start
@@ -572,12 +580,6 @@
 				 (build-path (collection-path collection)
 					     (strip-suffix file)))))
 
-      (define l-home (if (memq (system-type) '(unix))
-			 (build-path plthome "bin")
-			 plthome))
-
-      (define l-home-macosx-mzscheme (build-path plthome "bin"))
-
       (define (unix-sfx file)
 	(list->string
 	 (map
@@ -592,15 +594,15 @@
 			   [(windows) (string-append file ".exe")]
 			   [else file]))
 
-      (define (mred-program-launcher-path name)
+      (define (program-launcher-path name mred?)
 	(let* ([variant (current-launcher-variant)]
 	       [mac-script? (and (eq? (system-type) 'macosx) 
 				 (memq variant '(script script-3m)))])
 	  (let ([p (add-file-suffix 
 		    (build-path 
-		     (if mac-script?
+		     (if (or mac-script? (not mred?))
-			 l-home-macosx-mzscheme
+			 (find-console-bin-dir)
-			 l-home)
+			 (find-gui-bin-dir))
 		     ((if mac-script? unix-sfx sfx) name))
 		    variant)])
 	   (if (and (eq? (system-type) 'macosx) 
@@ -608,12 +610,15 @@
 	       (path-replace-suffix p #".app")
 	       p))))
 
+      (define (mred-program-launcher-path name)
+	(program-launcher-path name #t))
+      
       (define (mzscheme-program-launcher-path name)
 	(case (system-type)
 	  [(macosx) (add-file-suffix 
-		     (build-path l-home-macosx-mzscheme (unix-sfx name))
+		     (build-path (find-console-bin-dir) (unix-sfx name))
 		     (current-launcher-variant))]
-	  [else (mred-program-launcher-path name)]))
+	  [else (program-launcher-path name #f)]))
       
       (define (mred-launcher-is-directory?)
 	#f)

collects/make/setup-extension.ss

@@ -10,7 +10,7 @@
 	   (lib "etc.ss")
 	   (lib "launcher.ss" "launcher")
 	   (lib "xform.ss" "compiler")
-	   (rename (lib "plthome.ss" "setup") plthome* plthome))
+	   (lib "dirs.ss" "setup"))
   
   (provide pre-install
 	   with-new-flags)
@@ -32,7 +32,7 @@
     (if (string? s) s (path->string s)))
   
   (define pre-install 
-    (opt-lambda (plthome 
+    (opt-lambda (main-collects-parent-dir 
 		 collection-dir 
 		 file.c
 		 default-lib-dir
@@ -46,7 +46,7 @@
 		 [3m-too? #f])
       ;; Compile and link one file:
       (define (go file.c xform-src.c)
-	(pre-install/check-precompiled plthome
+	(pre-install/check-precompiled main-collects-parent-dir
 				       collection-dir 
 				       file.c
 				       default-lib-dir
@@ -72,7 +72,7 @@
 				     name))
 		file.c))))))
   
-  (define (pre-install/check-precompiled plthome collection-dir file.c . rest)
+  (define (pre-install/check-precompiled main-collects-parent-dir collection-dir file.c . rest)
     (let* ([base-dir (build-path collection-dir
 				 "precompiled"
 				 "native"
@@ -98,9 +98,9 @@
 	      (delete-file dest-file.so))
 	    (copy-file file.so dest-file.so))
 	  ;; Normal build...
-	  (apply pre-install/normal plthome collection-dir file.c rest))))
+	  (apply pre-install/normal main-collects-parent-dir collection-dir file.c rest))))
   
-  (define (pre-install/normal plthome
+  (define (pre-install/normal main-collects-parent-dir
 			      collection-dir
 			      file.c
 			      default-lib-dir
@@ -165,7 +165,7 @@
       (parameterize ([make-print-checking #f])
         
 	;; Used as make dependencies:
-	(define mz-inc-dir (build-path plthome* "include"))
+	(define mz-inc-dir (find-include-dir))
 	(define headers (map (lambda (name)
 			       (build-path mz-inc-dir name))
 			     '("scheme.h" "schvers.h" "schemef.h" "sconfig.h" "stypes.h")))

collects/mzlib/cm.ss

@@ -1,6 +1,6 @@
 (module cm mzscheme
   (require (lib "moddep.ss" "syntax")
-	   (lib "plthome.ss" "setup")
+	   (lib "main-collects.ss" "setup")
 	   (lib "file.ss"))
 
   (provide make-compilation-manager-load/use-compiled-handler
@@ -15,7 +15,8 @@
   (define indent (make-parameter ""))
   (define trust-existing-zos (make-parameter #f))
 
-  (define (trace-printf fmt . args) ((trace) (string-append (indent) (apply format fmt args))))
+  (define (trace-printf fmt . args) 
+    ((trace) (string-append (indent) (apply format fmt args))))
   
   (define my-max
     (case-lambda
@@ -88,8 +89,8 @@
        dep-path
        (lambda (op)
 	 (write (cons (version)
-		      (append (map plthome-ify deps)
+		      (append (map path->main-collects-relative deps)
-			      (map (lambda (x) (plthome-ify (cons 'ext x)))
+			      (map (lambda (x) (path->main-collects-relative (cons 'ext x)))
 				   external-deps)))
 		op)
 	 (newline op)))))
@@ -252,7 +253,7 @@
 				   (when (> t path-zo-time)
 				     (trace-printf "newer: ~a (~a > ~a)..." d t path-zo-time))
 				   (> t path-zo-time)))
-			       (map un-plthome-ify (cdr deps)))
+			       (map main-collects-relative->path (cdr deps)))
                         (compile-zo mode path))))))
                 (let ((stamp (get-compiled-time mode path #t)))
                   (hash-table-put! up-to-date path stamp)

collects/mzlib/etc.ss

@@ -2,13 +2,13 @@
 (module etc mzscheme
   
   (require "spidey.ss"
-           (lib "plthome.ss" "setup"))
+           (lib "main-collects.ss" "setup"))
   
   (require-for-syntax (lib "kerncase.ss" "syntax")
 		      (lib "stx.ss" "syntax")
 		      (lib "name.ss" "syntax")
 		      (lib "context.ss" "syntax")
-                      (lib "plthome.ss" "setup")
+                      (lib "main-collects.ss" "setup")
                       "list.ss"
                       "private/stxset.ss")
 
@@ -452,15 +452,15 @@
       (let* ([source (syntax-source stx)]
              [source (and (path? source) source)]
              [local (or (current-load-relative-directory) (current-directory))]
-	     [dir (plthome-ify
+	     [dir (path->main-collects-relative
                    (or (and source (file-exists? source)
                             (let-values ([(base file dir?) (split-path source)])
                               (and (path? base)
                                    (path->complete-path base local))))
                        local))])
-        (if (and (pair? dir) (eq? 'plthome (car dir)))
+        (if (and (pair? dir) (eq? 'collects (car dir)))
           (with-syntax ([d dir])
-            #'(un-plthome-ify 'd))
+            #'(main-collects-relative->path 'd))
           (with-syntax ([d (if (bytes? dir) dir (path->bytes dir))])
             #'(bytes->path d))))]))
 

collects/openssl/mzssl.ss

@@ -19,9 +19,7 @@
 	   (lib "etc.ss")
 	   (lib "kw.ss")
 	   (lib "filename-version.ss" "dynext")
-	   ;; For windows-lib-dir; remove it when that goes into
+	   (lib "dirs.ss" "setup"))
-	   ;;  a different library:
-	   (lib "winutf16.ss" "compiler" "private"))
 
   (provide ssl-available?
 	   ssl-load-fail-reason
@@ -55,26 +53,8 @@
 
   (define ssl-load-fail-reason #f)
 
-  (define windows-lib-dir
-    (delay
-      (let ([exe (parameterize ([current-directory (find-system-path 'orig-dir)])
-                   (find-executable-path (find-system-path 'exec-file)))])
-	(with-input-from-file exe
-	  (lambda ()
-	    (let ([m (regexp-match (byte-regexp 
-				    (bytes-append
-				     #"("
-				     (bytes->utf-16-bytes #"dLl dIRECTORy:")
-				     #".*?)\0\0"))
-				   (current-input-port))])
-	      (unless m (error "cannot find DLL directory"))
-	      (if (regexp-match #rx#"^<" (cadr m))
-		  #f ; no lib dir
-		  (let-values ([(dir name dir?) (split-path exe)])
-		    (build-path dir (bytes->path (utf-16-bytes->bytes (cadr m))))))))))))
-
   (define (ffi-lib-win name)
-    (let* ([d (force windows-lib-dir)]
+    (let* ([d (find-dll-dir)]
 	   [f (and d (build-path d (format "~a.dll" name)))])
       ;; Try PLT-specific lib:
       (if (and f (file-exists? f))

collects/plot/pre-installer.ss

@@ -56,7 +56,7 @@
             (delete-directory/files tmp-dir))))))
 
   (provide pre-installer)
-  (define (pre-installer plthome)
+  (define (pre-installer main-collects-parent-dir)
     (unless (directory-exists? src-dir)
       (error 'plot-preinstall "Could not find the source directory at ~a"
              src-dir))

collects/setup/doc.txt

@@ -106,7 +106,7 @@ Additional "info.ss" fields trigger additional setup actions:
    parallel to `mzscheme-launcher-names' (see above).
 
 >  mred-launcher-names - a list of executable names to be installed in
-   plt (or plt/bin) to run MrEd programs implemented by the
+   "plt" (or "plt/bin") to run MrEd programs implemented by the
    collection.  This is treated in parallel to
    `mred-launcher-libraries' and `mred-launcher-flags' similarly to
    `mzscheme-launcher-names' above.
@@ -120,11 +120,12 @@ Additional "info.ss" fields trigger additional setup actions:
 >  install-collection - a string or a path for a library module
    relative to the collection. The module must provide `installer' as
    a procedure that accepts either one or two arguments. The first
-   argument is a directory path to the PLT installation directory; the
+   argument is a directory path to the parent of the PLT
-   second argument, if accepted, is a path to the collection's own
+   installation's "collects" directory; the second argument, if
-   directory. The procedure should perform collection-specific
+   accepted, is a path to the collection's own directory. The
-   installation work, and it should avoid unnecessary work in the case
+   procedure should perform collection-specific installation work, and
-   that it is called multiple times for the same installation.
+   it should avoid unnecessary work in the case that it is called
+   multiple times for the same installation.
 
 >  pre-install-collection - like `install-collection', except that the
    corresponding installer is called *before* the normal .zo build,
@@ -237,11 +238,12 @@ parameters that control the setup process:
             in `current-target-plt-directory-getter' will be called
             [default: current-directory]
 > current-target-plt-directory-getter - a procedure that takes a
-            preferred path, the PLTHOME path, and a list of path choices;
+            preferred path, a path to the parent of the main
-            it returns a path for a "plt-relative" install; when
+            "collects" directory, and a list of path choices; it
-            unpacking an archive, either this or the procedure
+            returns a path for a "plt-relative" install; when
-            in `current-target-directory-getter' will be called
+            unpacking an archive, either this or the procedure in
-            [default: (lambda (preferred plthome choices) preferred)]
+            `current-target-directory-getter' will be called [default:
+            (lambda (preferred main-parent-dir choices) preferred)]
 
 Thus, to unpack a single .plt archive "x.plt", set the `archives'
 parameter to (list "x.plt") and leave `specific-collections' as null.
@@ -267,10 +269,47 @@ initialized between them, e.g.:
       ...)
 
 
+_Finding installation directories_
+==================================
+
+The _dirs.ss_ modules defines several procedures for locating
+installation directories:
+
+> (find-main-collects-dir)
+
+  Returns a path to the installation's main "collects" directory, or
+  #f if none can be found. (A #f result is likely only in an
+  stand-alone executable that is distributed without libraries.)
+
+> (find-console-bin-dir)
+
+  Returns a path to the installation's executable directory, where the
+  stand-alone MzScheme executable resides. The result is #f if no such
+  directory is available.
+
+> (find-include-dir)
+
+  Returns a path to the installation's "include" directory, which
+  contains .h files for building MzScheme extensions and embedding
+  programs.  The result is #f if no such directory is available.
+
+> (find-lib-dir)
+
+  Returns a path to the installation's "lib" directory, which contains
+  libraries and other build information.  The result is #f if no such
+  directory is available.
+
+> (find-dll-dir)
+
+  Returns a path to the directory that contains DLLs for use with the
+  current executable (e.g., "libmzsch.dll" under Windows). The result
+  is #f if no such directory is available.
+
+
 _Getting info.ss fields_
 ========================
 
-The _getinfo.ss_ module defines the following functions:
+The _getinfo.ss_ module defines the following procedures:
 
 > (get-info collection-names) -> (union #f (symbol (-> TST) -> TST))
 
@@ -376,15 +415,16 @@ The raw format is
    The procedure is extracted from the archive using MzScheme's `read'
    and `eval' procedures (in a fresh namespace).
 
- * An unsigned unit that drives the unpacking process. The unit accepts two
+ * An unsigned unit that drives the unpacking process. The unit
-   imports: a path string for the plt directory and an `unmztar'
+   accepts two imports: a path string for the parent of the main
-   procedure. The remainder of the unpacking process consists of invoking
+   "collects" directory and an `unmztar' procedure. The remainder of
-   this unit. It is expected that the unit will call `unmztar' procedure to
+   the unpacking process consists of invoking this unit. It is
-   unpack directories and files that are defined in the input archive after
+   expected that the unit will call `unmztar' procedure to unpack
-   this unit. The result of invoking the unit must be a list of collection
+   directories and files that are defined in the input archive after
-   paths (where each collection path is a list of strings); once the
+   this unit. The result of invoking the unit must be a list of
-   archive is unpacked, Setup PLT will compile and setup the specified
+   collection paths (where each collection path is a list of strings);
-   collections.
+   once the archive is unpacked, Setup PLT will compile and setup the
+   specified collections.
 
    The `unmztar' procedure takes one argument: a filter
    procedure. The filter procedure is called for each directory and
@@ -394,9 +434,10 @@ The raw format is
         unpacked is a directory, a file, or a file to be replaced;
 
       + a relative path string - the pathname of the directory or file
-        to be unpacked, relative to the plt directory; and
+        to be unpacked, relative to the unpack directory; and
 
-      + a path string for the plt directory.
+      + a path string for the unpack directory (which is often the
+        parent of the main "collects" directory).
 
    If the filter procedure returns #f for a directory or file, the
    directory or file is not unpacked. If the filter procedure returns
@@ -418,10 +459,10 @@ base64-encoded input archive).
 
 An unpackable is one of the following:
 
- * The symbol 'dir followed by a list. The `build-path' procedure
+ * The symbol 'dir followed by a list. The `build-path' procedure will
-   will be applied to the list to obtain a relative path for the
+   be applied to the list to obtain a relative path for the directory
-   directory (and the relative path is combined with the plt directory
+   (and the relative path is combined with the target directory path
-   path to get a complete path).
+   to get a complete path).
 
    The 'dir symbol and list are extracted from the archive using
    MzScheme's `read' (and the result is *not* `eval'uated).
@@ -524,7 +565,8 @@ general functions to help make .plt archives:
   unpacking time.
 
   If `at-plt-home?' and `plt-relative?', the archive is to be unpacked
-  relative to the plt installation directory. The default is #f.
+  relative to the parent of the PLT Scheme installation's main
+  "collects" directory. The default is #f.
 
 > (std-filter p) - returns #t unless `p', after stripping its
   directory path and converting to a byte string, matches one of the

collects/setup/main-collects.ss

@@ -0,0 +1,82 @@
+(module main-collects mzscheme
+  (require "dirs.ss")
+  
+  (provide path->main-collects-relative
+	   main-collects-relative->path)
+  
+  ;; Historical note: this module is based on the old "plthome.ss"
+
+  ;; The `path->main-collects-relative' and
+  ;; `main-collects-relative->path' functions are used to store paths
+  ;; that are relative to the main "collects" directory, such as in
+  ;; .dep files.  This means that if the plt tree is moved, .dep files
+  ;; still work. It is generally fine if
+  ;; `path->main-collects-relative' misses some usages, as long as it
+  ;; works when we prepare a distribution tree.  Otherwise, things
+  ;; will continue to work fine and .dep files will just contain
+  ;; absolute path names.  These functions work on .dep elements:
+  ;; either a pathname or a pair with a pathname in its cdr; the
+  ;; `path->main-collects-relative' pathname will itself be a pair.
+
+  (define (simplify-bytes-path bytes)
+    (path->bytes (simplify-path (bytes->path bytes))))
+
+  (define simplify-path*
+    (if (eq? 'windows (system-type))
+	(lambda (str)
+	  (regexp-replace* #rx#"\\\\" (simplify-bytes-path str) #"/"))
+	simplify-bytes-path))
+
+  (define main-collects-dir-bytes
+    (delay (and (find-main-collects-dir)
+		(path->bytes (find-main-collects-dir)))))
+
+  (define main-collects-dir/
+    (delay (and (force main-collects-dir-bytes)
+		(regexp-replace #rx#"/?$" 
+				(simplify-path* (force main-collects-dir-bytes))
+				#"/"))))
+  (define main-collects-dir/-len
+    (delay (and (force main-collects-dir/)
+		(bytes-length (force main-collects-dir/)))))
+
+  (define (maybe-cdr-op fname f)
+    (lambda (x)
+      (cond [(and (pair? x) (not (eq? 'collects (car x))))
+             (cons (car x) (f (cdr x)))]
+            [else (f x)])))
+
+  ;; path->main-collects-relative* : path-or-bytes -> datum-containing-bytes-or-path
+  (define (path->main-collects-relative* path)
+    (let* ([path (cond [(bytes? path) path]
+                       [(path?  path) (path->bytes path)]
+                       [else (error 'path->main-collects-relative
+                                    "expecting a byte-string, got ~e" path)])]
+           [path* (simplify-path* path)]
+	   [mcd-len (force main-collects-dir/-len)])
+      (cond [(and path*
+		  mcd-len
+                  (> (bytes-length path*) mcd-len)
+                  (equal? (subbytes path* 0 mcd-len)
+			  (force main-collects-dir/)))
+             (cons 'collects (subbytes path* mcd-len))]
+            [(equal? path* (force main-collects-dir/)) (cons 'collects #"")]
+            [else path])))
+
+  ;; main-collects-relative->path* : datum-containing-bytes-or-path -> path
+  (define (main-collects-relative->path* path)
+    (cond [(and (pair? path)
+                (eq? 'collects (car path))
+                (bytes? (cdr path)))
+	   (let ([dir (or (find-main-collects-dir)
+			  ;; No main "collects"? Use original working directory:
+			  (find-system-path 'orig-dir))])
+	     (if (equal? (cdr path) #"")
+		 dir
+		 (build-path dir (bytes->path (cdr path)))))]
+          [(bytes? path) (bytes->path path)]
+          [else path]))
+
+  (define path->main-collects-relative (maybe-cdr-op 'path->main-collects-relative path->main-collects-relative*))
+  (define main-collects-relative->path (maybe-cdr-op 'main-collects-relative->path main-collects-relative->path*))
+  )

collects/setup/option-unit.ss

@@ -31,4 +31,4 @@
       (define current-target-directory-getter (make-parameter current-directory))
       (define current-target-plt-directory-getter 
 	(make-parameter 
-	 (lambda (preferred plthome choices) preferred))))))
+	 (lambda (preferred main-collects-parent-dir choices) preferred))))))

collects/setup/pack.ss

@@ -90,7 +90,7 @@
         (write
          (or unpack-unit
              `(unit 
-                (import plthome mzuntar)
+                (import main-collects-parent-dir mzuntar)
                 (export)
                 (mzuntar void)
                 (quote ,collections)))

collects/setup/plthome.ss

@@ -1,83 +0,0 @@
-(module plthome mzscheme
-  (provide plthome plthome-ify un-plthome-ify)
-
-  (define plthome
-    (cond
-     [(getenv "PLTHOME") => (lambda (p) (simplify-path (string->path p)))]
-     [else (with-handlers ([void (lambda (e) #f)])
-             ;; use `split-path' to strip off the trailing "/"
-             (let-values ([(base name dir?)
-                           (split-path (simplify-path
-                                        (build-path (collection-path "mzlib")
-                                                    'up 'up)))])
-               (build-path (if (eq? 'relative base) (current-directory) base)
-                           name)))]))
-
-  ;; The plthome-ify and un-plthome-ify functions are used to store
-  ;; paths that are relative to plthome as such in dep files.  This
-  ;; means that if the plt tree is moved .dep files still work.
-  ;; `plthome-ify' uses `plthome' with a hard-wired "/" suffix, so it
-  ;; will not work properly if there is a different separator or if
-  ;; the input path uses a directory that is equivalent to plthome but
-  ;; not equal? to it.  The only processing that is performed is
-  ;; replacing all backslashes with slashes on Windows.  It is
-  ;; generally fine if this still misses some usages, as long as it
-  ;; works when we prepare a distribution tree using a proper PLTHOME
-  ;; env variable.  Otherwise, things will continue to work fine and
-  ;; .dep files will just contain absolute path names.  These
-  ;; functions work on dep elements -- either a pathname or a pair
-  ;; with a pathname in its cdr, the plthome-ified pathname will
-  ;; itself be a pair.
-
-  (define (simplify-bytes-path bytes)
-    (path->bytes (simplify-path (bytes->path bytes))))
-
-  (define simplify-path*
-    (if (eq? 'windows (system-type))
-      (lambda (str)
-        (regexp-replace* #rx#"\\\\" (simplify-bytes-path str) #"/"))
-      simplify-bytes-path))
-
-  (define plthome-bytes
-    (and plthome (path->bytes plthome)))
-  (define plthome/
-    (and plthome
-	 (regexp-replace #rx#"/?$" (simplify-path* (path->bytes plthome)) #"/")))
-  (define plthome/-len
-    (and plthome/ (bytes-length plthome/)))
-
-  (define (maybe-cdr-op fname f)
-    (lambda (x)
-      (cond [(not plthome/) (error fname "no PLTHOME and no mzlib found")]
-            [(and (pair? x) (not (eq? 'plthome (car x))))
-             (cons (car x) (f (cdr x)))]
-            [else (f x)])))
-
-  ;; plthome-ify : path-or-bytes -> datum-containing-bytes-or-path
-  (define (plthome-ify* path)
-    (let* ([path (cond [(bytes? path) path]
-                       [(path?  path) (path->bytes path)]
-                       [else (error 'plthome-ify
-                                    "expecting a byte-string, got ~e" path)])]
-           [path* (simplify-path* path)])
-      (cond [(and path*
-                  (> (bytes-length path*) plthome/-len)
-                  (equal? (subbytes path* 0 plthome/-len) plthome/))
-             (cons 'plthome (subbytes path* plthome/-len))]
-            [(equal? path* plthome-bytes) (cons 'plthome #"")]
-            [else path])))
-
-  ;; un-plthome-ify : datum-containing-bytes-or-path -> path
-  (define (un-plthome-ify* path)
-    (cond [(and (pair? path)
-                (eq? 'plthome (car path))
-                (bytes? (cdr path)))
-           (if (equal? (cdr path) #"")
-             plthome
-             (build-path plthome (bytes->path (cdr path))))]
-          [(bytes? path) (bytes->path path)]
-          [else path]))
-
-  (define plthome-ify    (maybe-cdr-op 'plthome-ify    plthome-ify*))
-  (define un-plthome-ify (maybe-cdr-op 'un-plthome-ify un-plthome-ify*))
-  )

collects/setup/setup-go.ss

@@ -18,7 +18,8 @@
   (define (all-users on?)
     (when on?
       (current-target-plt-directory-getter
-       (lambda (preferred plthome choices) plthome))))
+       (lambda (preferred main-collects-parent-dir choices) 
+	 main-collects-parent-dir))))
 
   ;; Converting parse-cmdline results into parameter settings:
   (define (do-flag name param)

collects/setup/setup-unit.ss

@@ -18,7 +18,8 @@
            
 	   "unpack.ss"
 	   "getinfo.ss"
-	   "plthome.ss")
+	   "dirs.ss"
+	   "main-collects.ss")
   
   (provide setup@)
   
@@ -38,10 +39,10 @@
 	  (apply setup-fprintf (current-output-port) s args)))
       
       (setup-printf "Setup version is ~a" (version))
-      (setup-printf "PLT home directory is ~a" (path->string plthome))
+      (setup-printf "Main collection path is ~a" (find-main-collects-dir))
-      (setup-printf "Collection paths are ~a" (if (null? (current-library-collection-paths))
+      (setup-printf "Collection search path is ~a" (if (null? (current-library-collection-paths))
-						  "empty!"
+						       "empty!"
-						  ""))
+						       ""))
       (for-each (lambda (p)
 		  (setup-printf "  ~a" (path->string p)))
 		(current-library-collection-paths))
@@ -74,7 +75,7 @@
 	 (specific-collections)
 	 (map (lambda (x) (unpack 
 			   x 
-			   plthome 
+			   (build-path (find-main-collects-dir) 'up)
 			   (lambda (s) (setup-printf "~a" s)) 
 			   (current-target-directory-getter)
 			   (force-unpacks)
@@ -377,7 +378,7 @@
               (for-each (lambda (s)
 			  (when (path-string? s)
 			    (hash-table-put! dependencies s #t)))
-			(map un-plthome-ify (cdr deps))))))
+			(map main-collects-relative->path (cdr deps))))))
 	(delete-file path))
       
       (define (delete-files-in-directory path printout dependencies)
@@ -535,9 +536,10 @@
                       (setup-printf "~aInstalling ~a"
                                     (case part [(pre) "Pre-"] [(post) "Post-"] [else ""])
                                     (cc-name cc))
-		      (if (procedure-arity-includes? installer 2)
+		      (let ([dir (build-path (find-main-collects-dir) 'up)])
-			  (installer plthome (cc-path cc))
+			(if (procedure-arity-includes? installer 2)
-			  (installer plthome))))))))
+			    (installer dir (cc-path cc))
+			    (installer dir)))))))))
            ccs-to-compile)))
       
       (do-install-part 'pre)

collects/setup/setup.ss

@@ -27,12 +27,16 @@
     (let ([a (assq flag-name flags)])
       (and a (not (cadr a)))))
 
+  (define (print-bootstrapping)
+    (fprintf (current-error-port) "setup-plt: bootstrapping from source...\n"))
+
   (if (or (on? 'clean values)
 	  (on? 'make-zo not))
       ;; Don't use .zos, in case they're out of date, and don't load
       ;;  cm:
       (when (on? 'clean values)
-	(use-compiled-file-paths null))
+	(use-compiled-file-paths null)
+	(print-bootstrapping))
   
       ;; Load the cm instance to be installed while loading Setup PLT.
       ;; This has to be dynamic, so we get a chance to turn off compiled
@@ -53,6 +57,8 @@
 		    ;;  off. If an .so file is used, we give up using
 		    ;;  compiled files.
 		    (let loop ([skip-zo? (null? (use-compiled-file-paths))])
+		      (when skip-zo?
+			(print-bootstrapping))
 		      ((let/ec escape
 			 ;; Create a new namespace, and also install load handlers
 			 ;;  to check file dates, if necessary.

collects/setup/unpack.ss

@@ -41,7 +41,7 @@
 						   (path->string base)
 						   base)))))
 
-  (define (unmztar p filter plthome print-status)
+  (define (unmztar p filter main-collects-parent-dir print-status)
     (define bufsize 4096)
     (define buffer (make-bytes bufsize))
     (let loop ()
@@ -54,8 +54,8 @@
 				  (apply build-path v)))])
 		     (unless (or (eq? s 'same) (relative-path? s))
 		       (error "expected a directory name relative path string, got" s))
-		     (when (or (eq? s 'same) (filter 'dir s plthome))
+		     (when (or (eq? s 'same) (filter 'dir s main-collects-parent-dir))
-		       (let ([d (build-path plthome s)])
+		       (let ([d (build-path main-collects-parent-dir s)])
 			 (unless (directory-exists? d)
 			   (print-status
 			    (format "  making directory ~a" (pretty-name d)))
@@ -67,8 +67,8 @@
 	       (let ([len (read p)])
 		 (unless (and (number? len) (integer? len))
 		   (error "expected a file name size, got" len))
-		 (let* ([write? (filter kind s plthome)]
+		 (let* ([write? (filter kind s main-collects-parent-dir)]
-			[path (build-path plthome s)])
+			[path (build-path main-collects-parent-dir s)])
 		   (let ([out (and write?
 				   (if (file-exists? path)
 				       (if (eq? kind 'file)
@@ -117,9 +117,9 @@
 	(mk-default)))
 
   (define unpack 
-    (opt-lambda (archive [plthome (current-directory)] [print-status (lambda (x) (printf "~a~n" x))]
+    (opt-lambda (archive [main-collects-parent-dir (current-directory)] [print-status (lambda (x) (printf "~a~n" x))]
 			 [get-target-directory (lambda () (current-directory))] [force? #f]
-			 [get-target-plt-directory (lambda (preferred plthome options) preferred)])
+			 [get-target-plt-directory (lambda (preferred main-collects-parent-dir options) preferred)])
       (let*-values ([(p64gz) (open-input-file archive)]
 		    [(p kill) (port64gz->port p64gz)])
 	(dynamic-wind
@@ -154,13 +154,15 @@
 						 ;; Check for void because old unpacker didn't use
 						 ;;  the failure thunk.
 						 (not (void? not-user-rel?)))
-					    (get-target-plt-directory plthome plthome (list plthome))
+					    (get-target-plt-directory main-collects-parent-dir
+								      main-collects-parent-dir
+								      (list main-collects-parent-dir))
 					    (let ([addons (build-path (find-system-path 'addon-dir)
 								      (version))])
 					      (get-target-plt-directory
 					       addons
-					       plthome
+					       main-collects-parent-dir
-					       (list addons plthome))))
+					       (list addons main-collects-parent-dir))))
 					(get-target-directory)))])
 		  
 		  ;; Stop if no target directory:

collects/setup/winvers.ss

@@ -1,7 +1,9 @@
 ;; This is a wrapper around `winvers-change.ss' to patch binary files with the
 ;; current version number.
 (module winvers mzscheme
-  (require (lib "file.ss") "plthome.ss")
+  (require (lib "file.ss") 
+	   "main-collects.ss"
+	   "dirs.ss")
 
   (define (make-copy)
     (let* ([tmpdir (find-system-path 'temp-dir)]
@@ -10,23 +12,22 @@
       (for-each (lambda (p)
                   (let ([dest (build-path vers p)])
                     (when (file-exists? dest) (delete-file dest))
-                    (copy-directory/files (build-path plthome p) dest)))
+                    (copy-directory/files (build-path (find-console-bin-dir) p) dest)))
                 '("mzscheme.exe" "lib"))
       (build-path vers "mzscheme.exe")))
 
   (define (patch-files)
     (parameterize ((current-command-line-arguments
-                    (vector (path->string plthome))))
+                    (vector (path->string (find-console-bin-dir)))))
       (dynamic-require `(lib "winvers-change.ss" "setup") #f)))
 
   (define collects-dir
-    (path->string (simplify-path (build-path (collection-path "mzlib") 'up))))
+    (path->string (find-main-collects-dir)))
 
   (let ([argv (current-command-line-arguments)])
     (cond
       [(equal? argv #())
        (let ([exe (make-copy)])
-         (putenv "PLTHOME" (path->string plthome))
          (printf "re-launching first time...~n")
          (subprocess
           (current-output-port) (current-input-port) (current-error-port)
@@ -38,7 +39,7 @@
        (printf "re-launching last time...~n")
        (subprocess
         (current-output-port) (current-input-port) (current-error-port)
-        (build-path plthome "mzscheme.exe")
+        (build-path (find-console-bin-dir) "mzscheme.exe")
         "-mvqL-" "winvers.ss" "setup" "finish")]
       [(equal? argv #("finish"))
        (sleep 1) ; time for other process to end