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

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

Browse Source 
svn: r3013
This commit is contained in:
Eli Barzilay 2006-05-22 22:36:36 +00:00
parent 481c3670a0
commit e47c53e5aa
7 changed files with 100 additions and 82 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
collects/config/doc.txt
View File

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

85
collects/setup/configtab.ss
View File

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

2
collects/setup/dirs.ss
View File

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

6
collects/setup/doc.txt
View File

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

2
collects/setup/setup-unit.ss
View File

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

2
src/Makefile.in
View File

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

78
src/copytree.ss
View File

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