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

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

Browse Source 
svn: r2924
This commit is contained in:
Matthew Flatt 2006-05-12 21:14:02 +00:00
parent c19a75a125
commit 8ed6d36b33
23 changed files with 429 additions and 253 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
collects/compiler/embed-unit.ss
View File

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

4
collects/compiler/private/driver.ss
View File

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

153
collects/compiler/private/mach-o.ss
View File

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

4
collects/compiler/start.ss
View File

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

19
collects/dynext/private/dirs.ss
View File

@ -1,22 +1,9 @@
(module dirs mzscheme
(require (lib "plthome.ss" "setup"))
(require (lib "dirs.ss" "setup"))
(define (find-dir name)
(if plthome
(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"))
(define include-dir (find-include-dir))
(define std-library-dir (find-lib-dir))
(provide include-dir std-library-dir))

29
collects/frtime/etc.ss
View File

@ -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 ()
(or (current-load-relative-directory)
(current-directory)))]
[dir (plthome-ify
(or (and source (string? source) (file-exists? source)
[source (and (path? source) source)]
[local (or (current-load-relative-directory) (current-directory))]
[dir (path->main-collects-relative
(or (and source (file-exists? source)
(let-values ([(base file dir?) (split-path source)])
(and (string? base)
(path->complete-path
base
(or (current-load-relative-directory)
(current-directory))))))
(local)))])
(if (and (pair? dir) (eq? 'plthome (car dir)))
(and (path? base)
(path->complete-path base local))))
local))])
(if (and (pair? dir) (eq? 'collects (car dir)))
(with-syntax ([d dir])
(syntax (un-plthome-ify 'd)))
(datum->syntax-object (quote-syntax here) dir stx)))]))
#'(main-collects-relative->path 'd))
(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,

2
collects/honu-module/info.ss
View File

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

71
collects/launcher/launcher-unit.ss
View File

@ -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
(file-exists? (build-path plthome "bin" (format "~a3m" kind))))
(if (let ([bin-dir (find-console-bin-dir)])
(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
(cond
[(eq? 'unix (system-type))
(file-exists? (build-path plthome "bin" (format "~a" kind)))]
[(eq? 'macosx (system-type))
(directory-exists? (build-path plthome "MrEd.app"))]
[(eq? 'windows (system-type))
(file-exists? (build-path plthome (format "~a.exe" kind)))]
[else #t]))
(if (let ([gui-dir (find-gui-bin-dir)])
(and gui-dir
(cond
[(eq? 'unix (system-type))
(file-exists? (build-path gui-dir (format "~a" kind)))]
[(eq? 'macosx (system-type))
(directory-exists? (build-path gui-dir "MrEd.app"))]
[(eq? 'windows (system-type))
(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
(build-path plthome "bin"))])
(find-gui-bin-dir)
(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
(error 'make-unix-launcher "unable to locate PLTHOME"))
(unless (find-console-bin-dir)
(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
@ -571,12 +579,6 @@
(build-aux-from-path
(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
@ -592,28 +594,31 @@
[(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?
l-home-macosx-mzscheme
l-home)
(if (or mac-script? (not mred?))
(find-console-bin-dir)
(find-gui-bin-dir))
((if mac-script? unix-sfx sfx) name))
variant)])
(if (and (eq? (system-type) 'macosx)
(not (memq variant '(script script-3m))))
(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)

14
collects/make/setup-extension.ss
View File

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

11
collects/mzlib/cm.ss
View File

@ -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)
(map (lambda (x) (plthome-ify (cons 'ext x)))
(append (map path->main-collects-relative deps)
(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)

10
collects/mzlib/etc.ss
View File

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

24
collects/openssl/mzssl.ss
View File

@ -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
;; a different library:
(lib "winutf16.ss" "compiler" "private"))
(lib "dirs.ss" "setup"))
(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))

2
collects/plot/pre-installer.ss
View File

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

98
collects/setup/doc.txt
View File

@ -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
second argument, if accepted, is a path to the collection's own
directory. The procedure should perform collection-specific
installation work, and it should avoid unnecessary work in the case
that it is called multiple times for the same installation.
argument is a directory path to the parent of the PLT
installation's "collects" directory; the second argument, if
accepted, is a path to the collection's own directory. The
procedure should perform collection-specific installation work, and
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;
it returns a path for a "plt-relative" install; when
unpacking an archive, either this or the procedure
in `current-target-directory-getter' will be called
[default: (lambda (preferred plthome choices) preferred)]
preferred path, a path to the parent of the main
"collects" directory, and a list of path choices; it
returns a path for a "plt-relative" install; when
unpacking an archive, either this or the procedure in
`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
imports: a path string for the plt directory and an `unmztar'
procedure. The remainder of the unpacking process consists of invoking
this unit. It is expected that the unit will call `unmztar' procedure to
unpack directories and files that are defined in the input archive after
this unit. The result of invoking the unit must be a list of collection
paths (where each collection path is a list of strings); once the
archive is unpacked, Setup PLT will compile and setup the specified
collections.
* An unsigned unit that drives the unpacking process. The unit
accepts two imports: a path string for the parent of the main
"collects" directory and an `unmztar' procedure. The remainder of
the unpacking process consists of invoking this unit. It is
expected that the unit will call `unmztar' procedure to unpack
directories and files that are defined in the input archive after
this unit. The result of invoking the unit must be a list of
collection paths (where each collection path is a list of strings);
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
will be applied to the list to obtain a relative path for the
directory (and the relative path is combined with the plt directory
path to get a complete path).
* The symbol 'dir followed by a list. The `build-path' procedure will
be applied to the list to obtain a relative path for the directory
(and the relative path is combined with the target directory 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

82
collects/setup/main-collects.ss Normal file
View File

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

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

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

2
collects/setup/pack.ss
View File

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

83
collects/setup/plthome.ss
View File

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

3
collects/setup/setup-go.ss
View File

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

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

@ -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 "Collection paths are ~a" (if (null? (current-library-collection-paths))
"empty!"
""))
(setup-printf "Main collection path is ~a" (find-main-collects-dir))
(setup-printf "Collection search path is ~a" (if (null? (current-library-collection-paths))
"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)
(installer plthome (cc-path cc))
(installer plthome))))))))
(let ([dir (build-path (find-main-collects-dir) 'up)])
(if (procedure-arity-includes? installer 2)
(installer dir (cc-path cc))
(installer dir)))))))))
ccs-to-compile)))
(do-install-part 'pre)

8
collects/setup/setup.ss
View File

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

22
collects/setup/unpack.ss
View File

@ -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))
(let ([d (build-path plthome s)])
(when (or (eq? s 'same) (filter 'dir s main-collects-parent-dir))
(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)]
[path (build-path plthome s)])
(let* ([write? (filter kind s main-collects-parent-dir)]
[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
(list addons plthome))))
main-collects-parent-dir
(list addons main-collects-parent-dir))))
(get-target-directory)))])
;; Stop if no target directory:

13
collects/setup/winvers.ss
View File

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