diff --git a/collects/config/doc.txt b/collects/config/doc.txt index 87fea98efb..e18283574d 100644 --- a/collects/config/doc.txt +++ b/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 -no corresponding `define', a definition with #f is inserted +will be automatically wrapped with `delay' when needed). If a required +export has no corresponding `define', a definition with #f is inserted automatically. diff --git a/collects/setup/configtab.ss b/collects/setup/configtab.ss index 4d426d3ede..835619b13a 100644 --- a/collects/setup/configtab.ss +++ b/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 - [(string? l) (complete-path (string->path l))] - [(bytes? l) (complete-path (bytes->path l))] - [(list? l) (map to-path l)] - [else l])) + (cond [(string? l) (complete-path (string->path l))] + [(bytes? l) (complete-path (bytes->path l))] + [(list? l) (map to-path l)] + [else l])) (define (complete-path p) - (cond - [(complete-path? p) p] - [(absolute-path? p) (exe-relative p)] - [else - (or (parameterize ([current-directory (find-system-path 'orig-dir)]) - (find-executable-path (find-system-path 'exec-file) p)) - (exe-relative p))])) + (cond [(complete-path? p) p] + [(absolute-path? p) (exe-relative p)] + [else + (or (parameterize ([current-directory (find-system-path 'orig-dir)]) + (find-executable-path (find-system-path 'exec-file) 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 - #f - "bad syntax" - stx)) + (raise-syntax-error #f "bad syntax" stx)) (for-each (lambda (name) - (unless (memq (syntax-e name) exports) - (raise-syntax-error - #f - "not a config name" - name))) + (unless (or (memq (syntax-e name) path-exports) + (memq (syntax-e name) flag-exports)) + (raise-syntax-error #f "not a config name" name))) names) (let ([syms (map syntax-e names)]) (let loop ([names names][syms syms]) - (cond - [(null? names) 'done] - [(memq (car syms) (cdr syms)) - (raise-syntax-error - #f - "duplicate definition" - (car names))] - [else - (loop (cdr names) (cdr syms))])) - #`(#%plain-module-begin - (provide #,@exports) - (define name (delay (to-path val))) ... - #,@(apply - append - (map (lambda (id) - (if (memq id syms) - () - (list #`(define #,id use-default)))) - exports)))))]))) + (cond [(null? names) 'done] + [(memq (car syms) (cdr syms)) + (raise-syntax-error #f "duplicate definition" (car names))] + [else (loop (cdr names) (cdr syms))])) + (with-syntax ([(expr ...) + (map (lambda (name val) + (if (memq name path-exports) + #`(delay #,val) val)) + (syntax->list #'(name ...)) + (syntax->list #'(val ...)))]) + #`(#%plain-module-begin + (provide #,@path-exports #,@flag-exports) + (define name expr) ... + #,@(apply append (map (lambda (id) + (if (memq id syms) + '() + (list #`(define #,id use-default)))) + path-exports)) + #,@(apply append (map (lambda (id) + (if (memq id syms) + '() + (list #`(define #,id #f)))) + flag-exports))))))]))) (provide (rename config-module-begin #%module-begin) define diff --git a/collects/setup/dirs.ss b/collects/setup/dirs.ss index 8feafb936e..bf9949ca80 100644 --- a/collects/setup/dirs.ss +++ b/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" diff --git a/collects/setup/doc.txt b/collects/setup/doc.txt index 922e635623..1debcc01d1 100644 --- a/collects/setup/doc.txt +++ b/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_ ======================== diff --git a/collects/setup/setup-unit.ss b/collects/setup/setup-unit.ss index 87d2ac9718..b8cd7e7d0f 100644 --- a/collects/setup/setup-unit.ss +++ b/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) #""))))]) diff --git a/src/Makefile.in b/src/Makefile.in index d8c647b774..e7b18c9f73 100644 --- a/src/Makefile.in +++ b/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@ diff --git a/src/copytree.ss b/src/copytree.ss index 5aebe6cd1e..6b775110dc 100644 --- a/src/copytree.ss +++ b/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)]) - (or (regexp-match #rx#"^[.]svn$" s) - (regexp-match #rx#"^compiled$" s)))) + (regexp-match #rx#"^(?:[.]svn|CVS|compiled)$" (path->bytes n))) (define (copytree src dest) - (for-each (lambda (n) - (unless (skip-name? n) - (let ([p (build-path src n)]) - (cond - [(file-exists? p) - (let ([q (build-path dest n)]) - (when (file-exists? q) - (delete-file q)) - (copy-file p q) - (let ([t (file-or-directory-modify-seconds p)]) - (file-or-directory-modify-seconds q t)))] - [(directory-exists? p) - (let ([q (build-path dest n)]) - (unless (directory-exists? q) - (make-directory q)) - (copytree p q))])))) - (directory-list src))) + (let ([src (simplify-path src #f)]) + (printf "Copying ~a -> ~a\n" src dest) + (let loop ([src src] [dest dest]) + (for-each (lambda (n) + (unless (skip-name? n) + (let ([from (build-path src n)] + [to (build-path dest n)]) + (cond + [(file-exists? from) + (when (file-exists? to) (delete-file to)) + (copy-file from to)] + [(directory-exists? from) + (unless (directory-exists? to) (make-directory to)) + (copytree from to)]) + (let ([t (file-or-directory-modify-seconds from)]) + (file-or-directory-modify-seconds to t))))) + (directory-list src))))) - (define (copytree* src dest) - (printf "Copying ~a\n to ~a\n" src dest) - (copytree src dest)) - - (copytree* (build-path pltdir "collects") collectsdir) - (copytree* (build-path pltdir "doc") docdir) - (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)) )