diff --git a/collects/compiler/embed-unit.ss b/collects/compiler/embed-unit.ss index 38304e4955..0a425084e2 100644 --- a/collects/compiler/embed-unit.ss +++ b/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?)))))) diff --git a/collects/compiler/private/driver.ss b/collects/compiler/private/driver.ss index 6c9c24722d..90eaee5caf 100644 --- a/collects/compiler/private/driver.ss +++ b/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)))) diff --git a/collects/compiler/private/mach-o.ss b/collects/compiler/private/mach-o.ss index e218f144ae..be19f21fab 100644 --- a/collects/compiler/private/mach-o.ss +++ b/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)))))) diff --git a/collects/compiler/start.ss b/collects/compiler/start.ss index e01d4f5e5e..320a9e99f4 100644 --- a/collects/compiler/start.ss +++ b/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) diff --git a/collects/dynext/private/dirs.ss b/collects/dynext/private/dirs.ss index a0b1ef3093..ad4e0bc80b 100644 --- a/collects/dynext/private/dirs.ss +++ b/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) - (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)) diff --git a/collects/frtime/etc.ss b/collects/frtime/etc.ss index 5750875372..5a644b70de 100644 --- a/collects/frtime/etc.ss +++ b/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 () - (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, diff --git a/collects/honu-module/info.ss b/collects/honu-module/info.ss index 547e425e54..e17ed3765b 100644 --- a/collects/honu-module/info.ss +++ b/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")) diff --git a/collects/launcher/launcher-unit.ss b/collects/launcher/launcher-unit.ss index fb7dbefad0..91900e54d6 100644 --- a/collects/launcher/launcher-unit.ss +++ b/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 - (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 #"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) diff --git a/collects/make/setup-extension.ss b/collects/make/setup-extension.ss index bccde3c0d9..83e7e3fd44 100644 --- a/collects/make/setup-extension.ss +++ b/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"))) diff --git a/collects/mzlib/cm.ss b/collects/mzlib/cm.ss index 40e624e09e..ecaa6c3c74 100644 --- a/collects/mzlib/cm.ss +++ b/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) - (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) diff --git a/collects/mzlib/etc.ss b/collects/mzlib/etc.ss index 9948d2dd80..b664fae6be 100644 --- a/collects/mzlib/etc.ss +++ b/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))))])) diff --git a/collects/openssl/mzssl.ss b/collects/openssl/mzssl.ss index 572943f04e..9b8c7ff28a 100644 --- a/collects/openssl/mzssl.ss +++ b/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 - ;; 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)) diff --git a/collects/plot/pre-installer.ss b/collects/plot/pre-installer.ss index 4c24c6b2a8..c82c60617b 100644 --- a/collects/plot/pre-installer.ss +++ b/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)) diff --git a/collects/setup/doc.txt b/collects/setup/doc.txt index 9dd8a634e9..29070cfa45 100644 --- a/collects/setup/doc.txt +++ b/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 - 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 diff --git a/collects/setup/main-collects.ss b/collects/setup/main-collects.ss new file mode 100644 index 0000000000..5dda03cc3f --- /dev/null +++ b/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*)) + ) diff --git a/collects/setup/option-unit.ss b/collects/setup/option-unit.ss index 0ecfd49803..ae891e5b7e 100644 --- a/collects/setup/option-unit.ss +++ b/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)))))) diff --git a/collects/setup/pack.ss b/collects/setup/pack.ss index d26eb30749..7fed21284f 100644 --- a/collects/setup/pack.ss +++ b/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))) diff --git a/collects/setup/plthome.ss b/collects/setup/plthome.ss deleted file mode 100644 index 64174632bb..0000000000 --- a/collects/setup/plthome.ss +++ /dev/null @@ -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*)) - ) diff --git a/collects/setup/setup-go.ss b/collects/setup/setup-go.ss index 92391dd752..23fb0393a8 100644 --- a/collects/setup/setup-go.ss +++ b/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) diff --git a/collects/setup/setup-unit.ss b/collects/setup/setup-unit.ss index af35987d1a..e2cc361d1e 100644 --- a/collects/setup/setup-unit.ss +++ b/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 "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) diff --git a/collects/setup/setup.ss b/collects/setup/setup.ss index 86188f6646..f5c8c6a2fa 100644 --- a/collects/setup/setup.ss +++ b/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. diff --git a/collects/setup/unpack.ss b/collects/setup/unpack.ss index d21fb3dbf9..1a53a4781a 100644 --- a/collects/setup/unpack.ss +++ b/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)) - (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: diff --git a/collects/setup/winvers.ss b/collects/setup/winvers.ss index 072d4661a6..7c1a3a6958 100644 --- a/collects/setup/winvers.ss +++ b/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