added "absolute-installation?" entry in config.ss, and use that to create absolute or relative launchers

svn: r3013

collects/config/doc.txt

@@ -41,6 +41,9 @@ The "config.ss" module must export the following values:
   include-search-dirs - like `doc-search-dirs', but for directories
    containing C header files
 
+  absolute-installation? - a (simple, non-delayed) boolean that is
+   true if this installation is using absolute path names
+
 In all cases, the value of an exported name can be a `delay'ed #f
 (instead of a path/string/bytes or list) to indicate the default.
 
@@ -58,6 +61,6 @@ consist of a sequence of
 
 declarations, where each `id' is one of the names that the "config.ss"
 module must export, and `val' is an expression for the value (which
-will be automatically wrapped with `delay'). If a required export has
+will be automatically wrapped with `delay' when needed). If a required
-no corresponding `define', a definition with #f is inserted
+export has no corresponding `define', a definition with #f is inserted
 automatically.

collects/setup/configtab.ss

@@ -2,10 +2,10 @@
 ;; Defines a language to be used by the "config.ss" file
 
 (module configtab mzscheme
-  
+
   ;; These are the name that need to be provided
   ;;  by the "config.ss" library:
-  (define-for-syntax exports
+  (define-for-syntax path-exports
     '(doc-dir
       doc-search-dirs
       lib-dir
@@ -13,27 +13,27 @@
       include-dir
       include-search-dirs
       bin-dir))
+  (define-for-syntax flag-exports
+    '(absolute-installation?))
 
   ;; ----------------------------------------
   ;; For configure into into absolute paths
 
   (define use-default (delay #f))
-  
+
   (define (to-path l)
-    (cond
+    (cond [(string? l) (complete-path (string->path l))]
-     [(string? l) (complete-path (string->path l))]
+          [(bytes? l) (complete-path (bytes->path l))]
-     [(bytes? l) (complete-path (bytes->path l))]
+          [(list? l) (map to-path l)]
-     [(list? l) (map to-path l)]
+          [else l]))
-     [else l]))
 
   (define (complete-path p)
-    (cond
+    (cond [(complete-path? p) p]
-     [(complete-path? p) p]
+          [(absolute-path? p) (exe-relative p)]
-     [(absolute-path? p) (exe-relative p)]
+          [else
-     [else
+           (or (parameterize ([current-directory (find-system-path 'orig-dir)])
-      (or (parameterize ([current-directory (find-system-path 'orig-dir)])
+                 (find-executable-path (find-system-path 'exec-file) p))
-	    (find-executable-path (find-system-path 'exec-file) p))
+               (exe-relative p))]))
-	  (exe-relative p))]))
 
   (define (exe-relative p)
     (let ([exec (path->complete-path 
@@ -54,38 +54,37 @@
 	[(_ (define name val) ...)
 	 (let ([names (syntax->list #'(name ...))])
 	   (unless (andmap identifier? names)
-	     (raise-syntax-error
+	     (raise-syntax-error #f "bad syntax" stx))
-	      #f
-	      "bad syntax"
-	      stx))
 	   (for-each (lambda (name)
-		       (unless (memq (syntax-e name) exports)
+		       (unless (or (memq (syntax-e name) path-exports)
-			 (raise-syntax-error
+                                   (memq (syntax-e name) flag-exports))
-			  #f
+			 (raise-syntax-error #f "not a config name" name)))
-			  "not a config name"
-			  name)))
 		     names)
 	   (let ([syms (map syntax-e names)])
 	     (let loop ([names names][syms syms])
-	       (cond
+	       (cond [(null? names) 'done]
-		[(null? names) 'done]
+                     [(memq (car syms) (cdr syms))
-		[(memq (car syms) (cdr syms))
+                      (raise-syntax-error #f "duplicate definition" (car names))]
-		 (raise-syntax-error
+                     [else (loop (cdr names) (cdr syms))]))
-		  #f
+	     (with-syntax ([(expr ...)
-		  "duplicate definition"
+                            (map (lambda (name val)
-		  (car names))]
+                                   (if (memq name path-exports)
-		[else
+                                     #`(delay #,val) val))
-		 (loop (cdr names) (cdr syms))]))
+                                 (syntax->list #'(name ...))
-	     #`(#%plain-module-begin
+                                 (syntax->list #'(val  ...)))])
-		(provide #,@exports)
+               #`(#%plain-module-begin
-		(define name (delay (to-path val))) ...
+                  (provide #,@path-exports #,@flag-exports)
-		#,@(apply
+                  (define name expr) ...
-		    append
+                  #,@(apply append (map (lambda (id)
-		    (map (lambda (id)
+                                          (if (memq id syms)
-			   (if (memq id syms)
+                                            '()
-			       ()
+                                            (list #`(define #,id use-default))))
-			       (list #`(define #,id use-default))))
+                                        path-exports))
-			 exports)))))])))
+                  #,@(apply append (map (lambda (id)
+                                          (if (memq id syms)
+                                            '()
+                                            (list #`(define #,id #f))))
+                                        flag-exports))))))])))
 
   (provide (rename config-module-begin #%module-begin)
 	   define

collects/setup/dirs.ss

@@ -3,6 +3,8 @@
 	   (lib "winutf16.ss" "compiler" "private")
 	   (lib "mach-o.ss" "compiler" "private"))
 
+  (provide (rename config:absolute-installation? absolute-installation?))
+
   ;; ----------------------------------------
   ;;  "collects"
 

collects/setup/doc.txt

@@ -367,6 +367,12 @@ installation directories:
   directory is available.
 
 
+> absolute-installation?
+
+  A binary boolean flag that is true if this installation is using
+  absolute path names.
+
+
 
 _Getting info.ss fields_
 ========================

collects/setup/setup-unit.ss

@@ -761,7 +761,7 @@
                                         [aux (list* `(exe-name . ,mzln)
 						    '(framework-root . #f)
 						    '(dll-dir . #f)
-						    '(relative? . #t)
+						    `(relative? . ,(not absolute-installation?))
 						    (build-aux-from-path
 						     (build-path (cc-path cc)
 								 (path-replace-suffix (or mzll mzln) #""))))])

src/Makefile.in

@@ -100,4 +100,4 @@ srcdir = @srcdir@
 prefix = @prefix@
 
 copytree:
-	mzscheme/mzscheme -mvqu "$(srcdir)/copytree.ss" "$(srcdir)" $(ALLDIRINFO) @INSTALL_ORIG_TREE@
+	mzscheme/mzscheme -mvqu "$(srcdir)/copytree.ss" "$(srcdir)/.." $(ALLDIRINFO) @INSTALL_ORIG_TREE@

src/copytree.ss

@@ -1,44 +1,51 @@
-
+;; 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
+;; as possible.
 (module copytree mzscheme
-  
-  (define-values (srcdir bindir collectsdir docdir libdir includepltdir libpltdir mandir origtree)
-    (apply
-     values
-     (vector->list (current-command-line-arguments))))
 
-  (define pltdir (build-path srcdir 'up))
+  (define args (vector->list (current-command-line-arguments)))
+
+  (define (path-arg)
+    (when (null? args) (error "insufficient arguments"))
+    (begin0 (car args) (set! args (cdr args))))
+
+  (define pltdir        (path-arg))
+  (define bindir        (path-arg))
+  (define collectsdir   (path-arg))
+  (define docdir        (path-arg))
+  (define libdir        (path-arg))
+  (define includepltdir (path-arg))
+  (define libpltdir     (path-arg))
+  (define mandir        (path-arg))
+  (define origtree      (path-arg))
 
   (define (skip-name? n)
-    (let ([s (path->bytes n)])
+    (regexp-match #rx#"^(?:[.]svn|CVS|compiled)$" (path->bytes n)))
-      (or (regexp-match #rx#"^[.]svn$" s)
-	  (regexp-match #rx#"^compiled$" s))))
 
   (define (copytree src dest)
-    (for-each (lambda (n)
+    (let ([src (simplify-path src #f)])
-		(unless (skip-name? n)
+      (printf "Copying ~a -> ~a\n" src dest)
-		  (let ([p (build-path src n)])
+      (let loop ([src src] [dest dest])
-		    (cond
+        (for-each (lambda (n)
-		     [(file-exists? p) 
+                    (unless (skip-name? n)
-		      (let ([q (build-path dest n)])
+                      (let ([from (build-path src  n)]
-			(when (file-exists? q)
+                            [to   (build-path dest n)])
-			  (delete-file q))
+                        (cond
-			(copy-file p q)
+                         [(file-exists? from)
-			(let ([t (file-or-directory-modify-seconds p)])
+                          (when (file-exists? to) (delete-file to))
-			  (file-or-directory-modify-seconds q t)))]
+                          (copy-file from to)]
-		     [(directory-exists? p)
+                         [(directory-exists? from)
-		      (let ([q (build-path dest n)])
+                          (unless (directory-exists? to) (make-directory to))
-			(unless (directory-exists? q)
+                          (copytree from to)])
-			  (make-directory q))
+                        (let ([t (file-or-directory-modify-seconds from)])
-			(copytree p q))]))))
+                          (file-or-directory-modify-seconds to t)))))
-	      (directory-list src)))
+                  (directory-list src)))))
 
-  (define (copytree* src dest)
+  (copytree (build-path pltdir "collects") collectsdir)
-    (printf "Copying ~a\n   to ~a\n" src dest)
+  (copytree (build-path pltdir "doc") docdir)
-    (copytree src dest))
+  (copytree (build-path pltdir "man") mandir)
-		
-  (copytree* (build-path pltdir "collects") collectsdir)
-  (copytree* (build-path pltdir "doc") docdir)
-  (copytree* (build-path pltdir "man") mandir)
 
   (unless (equal? origtree "yes")
     ;; Replace "config.ss"
@@ -48,7 +55,8 @@
 	(printf "  (define doc-dir ~s)\n" docdir)
 	(printf "  (define lib-dir ~s)\n" libpltdir)
 	(printf "  (define include-dir ~s)\n" includepltdir)
-	(printf "  (define bin-dir ~s))\n" bindir))
+	(printf "  (define bin-dir ~s)\n")
+        (printf "  (define absolute-installation? #t))\n" bindir))
       'truncate/replace))
 
   )