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

Lots of reformatting, and some reorganization

Browse Source 
svn: r8249
This commit is contained in:
Eli Barzilay 2008-01-07 17:29:48 +00:00
parent 315dc915f5
commit 8f0f4fcdf9
1 changed files with 868 additions and 966 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -2,11 +2,10 @@
; Expects parameters to be set before invocation. ; Expects parameters to be set before invocation.
; Calls `exit' when done. ; Calls `exit' when done.
(module setup-unit scheme/base #lang scheme/base
(require mzlib/unit (require mzlib/unit
(except-in mzlib/file (except-in mzlib/file call-with-input-file* call-with-output-file*)
call-with-input-file*
call-with-output-file*)
mzlib/list mzlib/list
mzlib/cm mzlib/cm
mzlib/port mzlib/port
@ -37,37 +36,30 @@
launcher^) launcher^)
(export) (export)
(define setup-fprintf (define (setup-fprintf p s . args)
(lambda (p s . args) (apply fprintf p (string-append "setup-plt: " s "~n") args))
(apply fprintf p (string-append "setup-plt: " s "~n") args)))
(define setup-printf (define (setup-printf s . args)
(lambda (s . args) (apply setup-fprintf (current-output-port) s args))
(apply setup-fprintf (current-output-port) s args)))
(setup-printf "Setup version is ~a [~a]" (version) (system-type 'gc)) (setup-printf "Setup version is ~a [~a]" (version) (system-type 'gc))
(setup-printf "Available variants:~a" (apply string-append (setup-printf "Available variants:~a"
(apply string-append
(map (lambda (s) (format " ~a" s)) (map (lambda (s) (format " ~a" s))
(available-mzscheme-variants)))) (available-mzscheme-variants))))
(setup-printf "Main collection path is ~a" (find-collects-dir)) (setup-printf "Main collection path is ~a" (find-collects-dir))
(setup-printf "Collection search path is ~a" (if (null? (current-library-collection-paths)) (setup-printf "Collection search path is ~a"
"empty!" (if (null? (current-library-collection-paths))
"")) "empty!" ""))
(for-each (lambda (p) (for ([p (current-library-collection-paths)])
(setup-printf " ~a" (path->string p))) (setup-printf " ~a" (path->string p)))
(current-library-collection-paths))
(define (warning s x) (define (warning s x)
(setup-printf s (setup-printf s (if (exn? x) (exn-message x) x)))
(if (exn? x)
(exn-message x)
x)))
(define (call-info info flag mk-default test) (define (call-info info flag mk-default test)
(if info (if info
(let ([v (info flag mk-default)]) (let ([v (info flag mk-default)]) (test v) v)
(test v)
v)
(mk-default))) (mk-default)))
(define mode-dir (define mode-dir
@ -75,16 +67,54 @@
(build-path "compiled" (compile-mode)) (build-path "compiled" (compile-mode))
(build-path "compiled"))) (build-path "compiled")))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Errors ;;
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define errors null)
(define (record-error cc desc go)
(with-handlers ([exn:fail?
(lambda (x)
(if (exn? x)
(fprintf (current-error-port) "~a\n" (exn-message x))
(fprintf (current-error-port) "~s\n" x))
(set! errors (cons (list cc desc x) errors)))])
(go)))
(define-syntax begin-record-error
(syntax-rules ()
[(_ cc desc body ...) (record-error cc desc (lambda () body ...))]))
(define (show-errors port)
(for ([e (reverse errors)])
(let ([cc (car e)]
[desc (cadr e)]
[x (caddr e)])
(setup-fprintf port "Error during ~a for ~a (~a)"
desc (cc-name cc) (path->string (cc-path cc)))
(if (exn? x)
(setup-fprintf port " ~a" (exn-message x))
(setup-fprintf port " ~s" x)))))
(define (done)
(setup-printf "Done setting up")
(unless (null? errors)
(setup-printf "")
(show-errors (current-error-port))
(when (pause-on-errors)
(fprintf (current-error-port)
"INSTALLATION FAILED.\nPress Enter to continue...\n")
(read-line))
(exit 1))
(exit 0))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Archive Unpacking ;; ;; Archive Unpacking ;;
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define x-specific-collections (define x-specific-collections
(apply (apply append
append
(specific-collections) (specific-collections)
(map (lambda (x) (unpack (map (lambda (x)
x (unpack x
(build-path (find-collects-dir) 'up) (build-path (find-collects-dir) 'up)
(lambda (s) (setup-printf "~a" s)) (lambda (s) (setup-printf "~a" s))
(current-target-directory-getter) (current-target-directory-getter)
@ -97,70 +127,61 @@
;; - (list string[owner] string[package-name] string[maj as string] string[min as string]) ;; - (list string[owner] string[package-name] string[maj as string] string[min as string])
;; x-specific-planet-dir ::= (listof specific-planet-dir) ;; x-specific-planet-dir ::= (listof specific-planet-dir)
(define x-specific-planet-dirs (define x-specific-planet-dirs
(if (make-planet) (if (make-planet) (specific-planet-dirs) null))
(specific-planet-dirs)
null))
(define (done) (define no-specific-collections?
(setup-printf "Done setting up")) (and (null? x-specific-collections) (null? x-specific-planet-dirs)))
(unless (null? (archives)) (when (and (not (null? (archives))) no-specific-collections?)
(when (and (null? x-specific-collections) (null? x-specific-planet-dirs))
(done) (done)
(exit 0))) ; done (exit 0)) ; done
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Find Collections ;; ;; Find Collections ;;
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define-struct cc (collection path name info root-dir info-path shadowing-policy) (define-struct cc
(collection path name info root-dir info-path shadowing-policy)
#:inspector #f) #:inspector #f)
(define (warning-handler v) (define (warning-handler v)
(lambda (exn) (lambda (exn)
(setup-printf (setup-printf "Warning: ~a" (if (exn? exn) (exn-message exn) exn))
"Warning: ~a"
(if (exn? exn)
(exn-message exn)
exn))
v)) v))
;; collection->cc : listof path -> cc ;; collection->cc : listof path -> cc
(define (collection->cc collection-p) (define (collection->cc collection-p)
(let ([root-dir (ormap (lambda (p) (let* ([root-dir (ormap (lambda (p)
(parameterize ([current-library-collection-paths (parameterize ([current-library-collection-paths
(list p)]) (list p)])
(and (with-handlers ([exn:fail? (lambda (x) #f)]) (and (with-handlers ([exn:fail? (lambda (x) #f)])
(apply collection-path collection-p)) (apply collection-path collection-p))
p))) p)))
(current-library-collection-paths))]) (current-library-collection-paths))]
(let* ([info (with-handlers ([exn:fail? (warning-handler #f)]) [info (with-handlers ([exn:fail? (warning-handler #f)])
(get-info collection-p))] (get-info collection-p))]
[name (call-info info 'name (lambda () #f) [name (call-info info 'name (lambda () #f)
(lambda (x) (lambda (x)
(when x (when (and x (not (string? x)))
(unless (string? x)
(error (error
(format 'setup-plt
"'name' result from collection ~s is not a string:" "'name' result from collection ~e is not a string: ~e"
collection-p)
x)))))])
(and
name
(make-cc
collection-p collection-p
x))))])
(and name
(make-cc collection-p
(apply collection-path collection-p) (apply collection-path collection-p)
name name
info info
root-dir root-dir
(build-path root-dir "info-domain" "compiled" "cache.ss") (build-path root-dir "info-domain" "compiled" "cache.ss")
;; by convention, all collections have "version" 1 0. This forces them ;; by convention, all collections have "version" 1 0. This
;; to conflict with each other. ;; forces them to conflict with each other.
(list (cons 'lib (map path->string collection-p)) 1 0)))))) (list (cons 'lib (map path->string collection-p)) 1 0)))))
;; remove-falses : listof (union X #f) -> listof X ;; remove-falses : listof (union X #f) -> listof X
;; returns the non-false elements of l in order ;; returns the non-false elements of l in order
(define (remove-falses l) (filter (lambda (x) x) l)) (define (remove-falses l) (filter values l))
;; planet-spec->planet-list : (list string string nat nat) -> (list path string string (listof string) nat nat) | #f ;; planet-spec->planet-list : (list string string nat nat) -> (list path string string (listof string) nat nat) | #f
;; converts a planet package spec into the information needed to create a cc structure ;; converts a planet package spec into the information needed to create a cc structure
@ -169,12 +190,15 @@
[(owner pkg-name maj-str min-str) [(owner pkg-name maj-str min-str)
(let ([maj (string->number maj-str)] (let ([maj (string->number maj-str)]
[min (string->number min-str)]) [min (string->number min-str)])
(unless maj (error 'setup-plt "Bad major version for PLaneT package: ~e" maj-str)) (unless maj
(unless min (error 'setup-plt "Bad minor version for PLaneT package: ~e" min-str)) (error 'setup-plt "bad major version for PLaneT package: ~e" maj-str))
(unless min
(error 'setup-plt "bad minor version for PLaneT package: ~e" min-str))
(let ([pkg (lookup-package-by-keys owner pkg-name maj min min)]) (let ([pkg (lookup-package-by-keys owner pkg-name maj min min)])
(if pkg (if pkg
pkg pkg
(error 'setup-plt "Not an installed PLaneT package: (~e ~e ~e ~e)" owner pkg-name maj min))))] (error 'setup-plt "not an installed PLaneT package: (~e ~e ~e ~e)"
owner pkg-name maj min))))]
[_ spec])) [_ spec]))
(define (planet->cc path owner pkg-file extra-path maj min) (define (planet->cc path owner pkg-file extra-path maj min)
@ -185,14 +209,13 @@
(get-info/full path))] (get-info/full path))]
[name (call-info info 'name (lambda () (return #f)) [name (call-info info 'name (lambda () (return #f))
(lambda (x) (lambda (x)
(when x (when (and x (not (string? x)))
(unless (string? x) (error
(error 'planet->cc 'planet->cc
"'name' result from directory ~e is not a string: ~e" "'name' result from directory ~e is not a string: ~e"
path path
x)))))]) x))))])
(make-cc (make-cc #f
#f
path path
name name
info info
@ -201,12 +224,12 @@
(list `(planet ,owner ,pkg-file ,@extra-path) maj min))))) (list `(planet ,owner ,pkg-file ,@extra-path) maj min)))))
;; planet-cc->sub-cc : cc (listof bytes [encoded path]) -> cc ;; planet-cc->sub-cc : cc (listof bytes [encoded path]) -> cc
;; builds a compilation job for the given subdirectory of the given cc ;; builds a compilation job for the given subdirectory of the given cc this
;; this is an awful hack ;; is an awful hack
(define (planet-cc->sub-cc cc subdir) (define (planet-cc->sub-cc cc subdir)
(match-let ([(('planet owner pkg-file extra-path ...) maj min) (cc-shadowing-policy cc)]) (match-let ([(('planet owner pkg-file extra-path ...) maj min)
(planet->cc (cc-shadowing-policy cc)])
(apply build-path (cc-path cc) (map bytes->path subdir)) (planet->cc (apply build-path (cc-path cc) (map bytes->path subdir))
owner owner
pkg-file pkg-file
(append extra-path subdir) (append extra-path subdir)
@ -215,50 +238,28 @@
(define (cannot-compile c) (define (cannot-compile c)
(error 'setup-plt "don't know how to compile collection: ~a" (error 'setup-plt "don't know how to compile collection: ~a"
(if (= (length c) 1) (if (= (length c) 1) (car c) c)))
(car c)
c)))
(define planet-dirs-to-compile (define planet-dirs-to-compile
(if (make-planet) (if (make-planet)
(remove-falses (remove-falses (map (lambda (spec) (apply planet->cc spec))
(map (lambda (spec) (apply planet->cc spec)) (if no-specific-collections?
(if (and (null? x-specific-collections) (null? x-specific-planet-dirs))
(get-all-planet-packages) (get-all-planet-packages)
(remove-falses (map planet-spec->planet-list x-specific-planet-dirs))))) (remove-falses (map planet-spec->planet-list
x-specific-planet-dirs)))))
null)) null))
(define all-collections (define all-collections
(let ([ht (make-hash-table 'equal)]) (let ([ht (make-hash-table 'equal)])
(let loop ([collection-paths (current-library-collection-paths)]) (for ([cp (current-library-collection-paths)]
(cond #:when (directory-exists? cp)
[(null? collection-paths) [collection (directory-list cp)]
(hash-table-map ht (lambda (k v) v))] #:when (directory-exists? (build-path cp collection)))
[else (let* ([cp (car collection-paths)] (hash-table-get ht collection
[cp-contents
(if (directory-exists? cp)
(directory-list cp)
null)])
(let loop ([collections (filter
(lambda (x)
(directory-exists?
(build-path cp x)))
cp-contents)])
(cond
[(null? collections) (void)]
[else (let* ([collection (car collections)])
(hash-table-get
ht
collection
(lambda () (lambda ()
(let ([cc (collection->cc (list collection))]) (let ([cc (collection->cc (list collection))])
(when cc (when cc (hash-table-put! ht collection cc))))))
(hash-table-put! (hash-table-map ht (lambda (k v) v))))
ht
collection
cc))))))
(loop (cdr collections))])))
(loop (cdr collection-paths))]))))
;; Close over sub-collections ;; Close over sub-collections
(define (collection-closure collections-to-compile) (define (collection-closure collections-to-compile)
@ -270,34 +271,30 @@
(append (append
(map (map
(lambda (subcol) (lambda (subcol)
(or (or (collection->cc (map string->path subcol))
(collection->cc (map string->path subcol))
(cannot-compile subcol))) (cannot-compile subcol)))
(call-info info 'compile-subcollections (call-info info 'compile-subcollections
;; Default: subdirs with info.ss files ;; Default: subdirs with info.ss files
(lambda () (lambda ()
(map (map (lambda (x)
(lambda (l) (map path->string l)) (map path->string (append (cc-collection cc) (list x))))
(map (lambda (x) (append (cc-collection cc) (list x))) (filter (lambda (p)
(filter (let ([d (build-path (cc-path cc) p)])
(lambda (p)
(let ((d (build-path (cc-path cc) p)))
(and (directory-exists? d) (and (directory-exists? d)
(file-exists? (build-path d "info.ss"))))) (file-exists? (build-path d "info.ss")))))
(directory-list (cc-path cc)))))) (directory-list (cc-path cc)))))
;; Result checker: ;; Result checker:
(lambda (x) (lambda (x)
(unless (and (list? x) (unless (and (list? x)
(andmap (andmap (lambda (x)
(lambda (x)
(and (list? x) (and (list? x)
(andmap (andmap (lambda (x)
(lambda (x)
(and (path-string? x) (and (path-string? x)
(relative-path? x))) (relative-path? x)))
x))) x)))
x)) x))
(error "result is not a list of relative path string lists:" x))))) (error "result is not a list of relative path string lists:"
x)))))
(list cc) (list cc)
(loop (cdr l))))))) (loop (cdr l)))))))
@ -312,38 +309,27 @@
(equal? (split cc-1) (split cc-2)))) (equal? (split cc-1) (split cc-2))))
(define (check-again-all given-ccs) (define (check-again-all given-ccs)
(let ([all-collections (define all-collections* (collection-closure all-collections))
(collection-closure all-collections)]) (for ([cc given-ccs])
(for-each (lambda (cc) (call-with-input-file* (build-path (cc-path cc) "info.ss")
(let ((f (build-path (cc-path cc) "info.ss")))
(call-with-input-file*
f
(lambda (given-info-port) (lambda (given-info-port)
(let ([given-id (port-file-identity given-info-port)]) (define given-id (port-file-identity given-info-port))
(for-each (lambda (found-cc) (for ([found-cc all-collections*]
(unless (same-collection-name? cc found-cc) #:when (not (same-collection-name? cc found-cc)))
(let ((f (build-path (cc-path found-cc) "info.ss"))) (call-with-input-file* (build-path (cc-path found-cc) "info.ss")
(call-with-input-file*
f
(lambda (found-info-port) (lambda (found-info-port)
(when (eq? (port-file-identity found-info-port) (when (eq? (port-file-identity found-info-port) given-id)
given-id) (error 'setup-plt
(error
'setup-plt
"given collection path: ~e refers to the same info file as another path: ~e" "given collection path: ~e refers to the same info file as another path: ~e"
(apply build-path (cc-collection cc)) (apply build-path (cc-collection cc))
(apply build-path (cc-collection found-cc))))))))) (apply build-path (cc-collection found-cc))))))))))
all-collections))))))
given-ccs) given-ccs)
given-ccs))
(define collections-to-compile (define collections-to-compile
(sort (sort (if no-specific-collections?
(if (and (null? x-specific-collections) (null? x-specific-planet-dirs))
all-collections all-collections
(check-again-all (check-again-all
(map (map (lambda (c)
(lambda (c)
(or (collection->cc (map string->path c)) (or (collection->cc (map string->path c))
(cannot-compile c))) (cannot-compile c)))
x-specific-collections))) x-specific-collections)))
@ -393,9 +379,7 @@
(define (control-io-apply print-doing f args) (define (control-io-apply print-doing f args)
(if (make-verbose) (if (make-verbose)
(begin (begin (apply f args) #t)
(apply f args)
#t)
(let* ([oop (current-output-port)] (let* ([oop (current-output-port)]
[printed? #f] [printed? #f]
[on? #f] [on? #f]
@ -418,30 +402,6 @@
(apply f args) (apply f args)
printed?)))) printed?))))
(define errors null)
(define (record-error cc desc go)
(with-handlers ([exn:fail?
(lambda (x)
(if (exn? x)
(begin
(fprintf (current-error-port) "~a~n" (exn-message x)))
(fprintf (current-error-port) "~s~n" x))
(set! errors (cons (list cc desc x) errors)))])
(go)))
(define (show-errors port)
(for-each
(lambda (e)
(let ([cc (car e)]
[desc (cadr e)]
[x (caddr e)])
(setup-fprintf port
"Error during ~a for ~a (~a)"
desc (cc-name cc) (path->string (cc-path cc)))
(if (exn? x)
(setup-fprintf port " ~a" (exn-message x))
(setup-fprintf port " ~s" x))))
(reverse errors)))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Clean ;; ;; Clean ;;
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -451,32 +411,26 @@
(let ([deps (with-handlers ([exn:fail? (lambda (x) null)]) (let ([deps (with-handlers ([exn:fail? (lambda (x) null)])
(with-input-from-file path read))]) (with-input-from-file path read))])
(when (and (pair? deps) (list? deps)) (when (and (pair? deps) (list? deps))
(for-each (lambda (s) (for ([s (cdr deps)])
(let ([s (map main-collects-relative->path s)])
(when (path-string? s) (when (path-string? s)
(hash-table-put! dependencies s #t))) (hash-table-put! dependencies s #t)))))))
(map main-collects-relative->path (cdr deps))))))
(delete-file path)) (delete-file path))
(define (delete-files-in-directory path printout dependencies) (define (delete-files-in-directory path printout dependencies)
(for-each (for ([end-path (directory-list path)])
(lambda (end-path)
(let ([path (build-path path end-path)]) (let ([path (build-path path end-path)])
(cond (cond [(directory-exists? path)
[(directory-exists? path)
(void)] (void)]
[(file-exists? path) [(file-exists? path)
(printout) (printout)
(delete-file/record-dependency path dependencies)] (delete-file/record-dependency path dependencies)]
[else (error 'delete-files-in-directory [else (error 'delete-files-in-directory
"encountered ~a, neither a file nor a directory" "encountered ~a, neither a file nor a directory"
path)]))) path)]))))
(directory-list path)))
(define (clean-collection cc dependencies) (define (clean-collection cc dependencies)
(record-error (begin-record-error cc "Cleaning"
cc
"Cleaning"
(lambda ()
(let* ([info (cc-info cc)] (let* ([info (cc-info cc)]
[default (box 'default)] [default (box 'default)]
[paths (call-info [paths (call-info
@ -488,8 +442,7 @@
(build-path mode-dir "native" (system-library-subpath)))) (build-path mode-dir "native" (system-library-subpath))))
(lambda (x) (lambda (x)
(unless (or (eq? x default) (unless (or (eq? x default)
(and (list? x) (and (list? x) (andmap path-string? x)))
(andmap path-string? x)))
(error 'setup-plt "expected a list of path strings for 'clean, got: ~s" (error 'setup-plt "expected a list of path strings for 'clean, got: ~s"
x))))] x))))]
[printed? #f] [printed? #f]
@ -497,11 +450,12 @@
(lambda () (lambda ()
(unless printed? (unless printed?
(set! printed? #t) (set! printed? #t)
(setup-printf "Deleting files for ~a at ~a" (cc-name cc) (path->string (cc-path cc)))))]) (setup-printf "Deleting files for ~a at ~a"
(for-each (lambda (path) (cc-name cc) (path->string (cc-path cc)))))])
(for ([path paths])
(let ([full-path (build-path (cc-path cc) path)]) (let ([full-path (build-path (cc-path cc) path)])
(when (or (file-exists? full-path) (directory-exists? full-path)) (when (or (file-exists? full-path) (directory-exists? full-path))
(let loop ([path (find-relative-path (normalize-path (cc-path cc)) (let ([path (find-relative-path (normalize-path (cc-path cc))
(normalize-path full-path))]) (normalize-path full-path))])
(let loop ([path path]) (let loop ([path path])
(let-values ([(base name dir?) (split-path path)]) (let-values ([(base name dir?) (split-path path)])
@ -519,29 +473,21 @@
"attempted to clean files in ~s which is not a subdirectory of ~s" "attempted to clean files in ~s which is not a subdirectory of ~s"
full-path full-path
(cc-path cc))])))) (cc-path cc))]))))
(cond [(directory-exists? full-path)
(cond (delete-files-in-directory full-path print-message dependencies)]
[(directory-exists? full-path)
(delete-files-in-directory
full-path
print-message
dependencies)]
[(file-exists? full-path) [(file-exists? full-path)
(delete-file/record-dependency full-path dependencies) (delete-file/record-dependency full-path dependencies)
(print-message)] (print-message)]
[else (void)])))) [else (void)])))))))
paths)))))
(when (clean) (when (clean)
(let ([dependencies (make-hash-table 'equal)]) (let ([dependencies (make-hash-table 'equal)])
;; Main deletion: ;; Main deletion:
(for-each (lambda (cc) (for ([cc ccs-to-compile]) (clean-collection cc dependencies))
(clean-collection cc dependencies))
ccs-to-compile)
;; Unless specific collections were named, also ;; Unless specific collections were named, also
;; delete .zos for referenced modules and delete ;; delete .zos for referenced modules and delete
;; info-domain cache ;; info-domain cache
(when (and (null? x-specific-collections) (null? x-specific-planet-dirs)) (when no-specific-collections?
(setup-printf "Checking dependencies") (setup-printf "Checking dependencies")
(let loop ([old-dependencies dependencies]) (let loop ([old-dependencies dependencies])
(let ([dependencies (make-hash-table 'equal)] (let ([dependencies (make-hash-table 'equal)]
@ -550,45 +496,35 @@
old-dependencies old-dependencies
(lambda (file _) (lambda (file _)
(let-values ([(dir name dir?) (split-path file)]) (let-values ([(dir name dir?) (split-path file)])
(let ([base-name (path-replace-suffix name #"")]) (let* ([base-name (path-replace-suffix name #"")]
(let ([zo (build-path dir mode-dir (format "~a.zo" base-name))] [zo (build-path dir mode-dir (format "~a.zo" base-name))]
[dep (build-path dir mode-dir (format "~a.dep" base-name))]) [dep (build-path dir mode-dir (format "~a.dep" base-name))])
(when (and (file-exists? dep) (when (and (file-exists? dep) (file-exists? zo))
(file-exists? zo))
(set! did-something? #t) (set! did-something? #t)
(setup-printf " deleting ~a" zo) (setup-printf " deleting ~a" zo)
(delete-file/record-dependency zo dependencies) (delete-file/record-dependency zo dependencies)
(delete-file/record-dependency dep dependencies))))))) (delete-file/record-dependency dep dependencies))))))
(when did-something? (when did-something? (loop dependencies))))
(loop dependencies))))
(setup-printf "Clearing info-domain caches") (setup-printf "Clearing info-domain caches")
(for-each (lambda (p) (for ([p (current-library-collection-paths)])
(let ([fn (build-path p "info-domain" "compiled" "cache.ss")]) (let ([fn (build-path p "info-domain" "compiled" "cache.ss")])
(when (file-exists? fn) (when (file-exists? fn)
(with-handlers ([exn:fail:filesystem? (warning-handler (void))]) (with-handlers ([exn:fail:filesystem? (warning-handler (void))])
(with-output-to-file fn void #:exists 'truncate/replace))))) (with-output-to-file fn void #:exists 'truncate/replace))))))))
(current-library-collection-paths)))))
(when (or (make-zo) (make-so)) (when (or (make-zo) (make-so))
(compiler:option:verbose (compiler-verbose)) (compiler:option:verbose (compiler-verbose))
(compiler:option:compile-subcollections #f)) (compiler:option:compile-subcollections #f))
(define (do-install-part part) (define (do-install-part part)
(when (or (call-install) (when (or (call-install) (and (eq? part 'post) (call-post-install)))
(and (eq? part 'post) (for ([cc ccs-to-compile])
(call-post-install)))
(for-each
(lambda (cc)
(let/ec k (let/ec k
(record-error (begin-record-error cc (case part
cc
(case part
[(pre) "Early Install"] [(pre) "Early Install"]
[(general) "General Install"] [(general) "General Install"]
[(post) "Post Install"]) [(post) "Post Install"])
(lambda () (let ([fn (call-info (cc-info cc)
(let ([fn (call-info
(cc-info cc)
(case part (case part
[(pre) 'pre-install-collection] [(pre) 'pre-install-collection]
[(general) 'install-collection] [(general) 'install-collection]
@ -617,24 +553,19 @@
(let ([dir (build-path (find-collects-dir) 'up)]) (let ([dir (build-path (find-collects-dir) 'up)])
(if (procedure-arity-includes? installer 2) (if (procedure-arity-includes? installer 2)
(installer dir (cc-path cc)) (installer dir (cc-path cc))
(installer dir))))))))) (installer dir))))))))))
ccs-to-compile)))
(do-install-part 'pre) (do-install-part 'pre)
(define (make-it desc compile-directory get-namespace) (define (make-it desc compile-directory get-namespace)
;; To avoid polluting the compilation with modules that are ;; To avoid polluting the compilation with modules that are already loaded,
;; already loaded, create a fresh namespace before calling ;; create a fresh namespace before calling this function.
;; this function. ;; To avoid keeping modules in memory across collections, pass
;; To avoid keeping modules in memory across collections, ;; `make-base-namespace' as `get-namespace', otherwise use
;; pass `make-base-namespace' as `get-namespace', otherwise use
;; `current-namespace' for `get-namespace'. ;; `current-namespace' for `get-namespace'.
(for-each (lambda (cc) (for ([cc ccs-to-compile])
(parameterize ([current-namespace (get-namespace)]) (parameterize ([current-namespace (get-namespace)])
(record-error (begin-record-error cc (format "Compiling ~a" desc)
cc
(format "Compiling ~a" desc)
(lambda ()
(unless (control-io-apply (unless (control-io-apply
(case-lambda (case-lambda
[(p) [(p)
@ -645,15 +576,13 @@
;; Doing something specifically in "where" ;; Doing something specifically in "where"
(setup-fprintf p " in ~a" (setup-fprintf p " in ~a"
(path->string (path->string
(path->complete-path (path->complete-path where
where
(cc-path cc))))]) (cc-path cc))))])
compile-directory compile-directory
(list (cc-path cc) (cc-info cc))) (list (cc-path cc) (cc-info cc)))
(setup-printf "No more ~a to compile for ~a" (setup-printf "No more ~a to compile for ~a"
desc (cc-name cc)))))) desc (cc-name cc)))))
(collect-garbage)) (collect-garbage)))
ccs-to-compile))
(define (with-specified-mode thunk) (define (with-specified-mode thunk)
(if (not (compile-mode)) (if (not (compile-mode))
@ -702,45 +631,42 @@
(append (directory-list dir) (append (directory-list dir)
(info 'virtual-sources (lambda () null)))) (info 'virtual-sources (lambda () null))))
'equal)]) 'equal)])
(for-each (lambda (p) (for ([p (directory-list c)])
(when (regexp-match #rx#".zo$" (path-element->bytes p)) (when (and (regexp-match #rx#".zo$" (path-element->bytes p))
(unless (hash-table-get ok-zo-files p #f) (not (hash-table-get ok-zo-files p #f)))
(setup-fprintf (current-error-port) " deleting ~a" (build-path c p)) (setup-fprintf (current-error-port) " deleting ~a" (build-path c p))
(delete-file (build-path c p))))) (delete-file (build-path c p))))))))
(directory-list c))))))
;; Make .zos ;; Make .zos
(compile-directory-zos dir info)) (compile-directory-zos dir info))
make-base-empty-namespace)))) make-base-empty-namespace))))
(when (make-so) (make-it "extensions" compile-directory-extension current-namespace)) (when (make-so)
(make-it "extensions" compile-directory-extension current-namespace))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Info-Domain Cache ;; ;; Info-Domain Cache ;;
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(when (make-info-domain) (when (make-info-domain)
;; Each ht maps a collection root dir to an ;; Each ht maps a collection root dir to an info-domain table. Even when
;; info-domain table. Even when `collections-to-compile' ;; `collections-to-compile' is a subset of all collections, we only care
;; is a subset of all collections, we only care about ;; about those collections that exist in the same root as the ones in
;; those collections that exist in the same root as ;; `collections-to-compile'.
;; the ones in `collections-to-compile'.
(let ([ht (make-hash-table 'equal)] (let ([ht (make-hash-table 'equal)]
[ht-orig (make-hash-table 'equal)]) [ht-orig (make-hash-table 'equal)])
(for-each (lambda (cc) (for ([cc ccs-to-compile])
(let ([domain (with-handlers ([exn:fail? (lambda (x) (let* ([domain (with-handlers ([exn:fail? (lambda (x) (lambda () null))])
(lambda () null))])
(dynamic-require (dynamic-require
(build-path (cc-path cc) "info.ss") (build-path (cc-path cc) "info.ss")
'#%info-domain))]) '#%info-domain))]
;; Check whether we have a table for this cc's info-domain cache: ;; Check whether we have a table for this cc's info-domain cache:
(let ([t (hash-table-get ht [t (hash-table-get ht (cc-info-path cc)
(cc-info-path cc)
(lambda () (lambda ()
;; No table for this root, yet. Build one. ;; No table for this root, yet. Build one.
(let ([l (let ([p (cc-info-path cc)]) (let ([l (let ([p (cc-info-path cc)])
(if (file-exists? p) (if (file-exists? p)
(with-handlers ([exn:fail? (warning-handler null)]) (with-handlers ([exn:fail?
(with-input-from-file p (warning-handler null)])
read)) (with-input-from-file p read))
null))]) null))])
;; Convert list to hash table. Incluse only well-formed ;; Convert list to hash table. Incluse only well-formed
;; list elements, and only elements whose corresponding ;; list elements, and only elements whose corresponding
@ -749,19 +675,20 @@
[all-ok? #f]) [all-ok? #f])
(when (list? l) (when (list? l)
(set! all-ok? #t) (set! all-ok? #t)
(for-each (for ([i l])
(lambda (i)
(match i (match i
[((? (lambda (a) [((? (lambda (a)
(and (bytes? a) (and (bytes? a)
(let ([p (bytes->path a)]) (let ([p (bytes->path a)])
;; If we have a root directory, then the path ;; If we have a root directory,
;; must be relative to it, otherwise it must ;; then the path must be relative
;; be absolute: ;; to it, otherwise it must be
;; absolute:
(and (if (cc-root-dir cc) (and (if (cc-root-dir cc)
(relative-path? p) (relative-path? p)
(complete-path? p)) (complete-path? p))
(file-exists? (build-path (file-exists?
(build-path
(if (cc-root-dir cc) (if (cc-root-dir cc)
(build-path (cc-root-dir cc) p) (build-path (cc-root-dir cc) p)
p) p)
@ -772,28 +699,25 @@
(? integer? d) (? integer? d)
(? integer? e)) (? integer? e))
(hash-table-put! t a (list b c d e))] (hash-table-put! t a (list b c d e))]
[_ [_ (set! all-ok? #f)])))
(set! all-ok? #f)]))
l))
;; Record the table loaded for this collection root ;; Record the table loaded for this collection root
;; in the all-roots table: ;; in the all-roots table:
(hash-table-put! ht (cc-info-path cc) t) (hash-table-put! ht (cc-info-path cc) t)
;; If anything in the "cache.ss" file was bad, ;; If anything in the "cache.ss" file was bad, then
;; then claim that the old table was empty, ;; claim that the old table was empty, so that we
;; so that we definitely write the new table. ;; definitely write the new table.
(hash-table-put! ht-orig (cc-info-path cc) (hash-table-put! ht-orig (cc-info-path cc)
(and all-ok? (hash-table-copy t))) (and all-ok? (hash-table-copy t)))
t))))]) t))))])
;; Add this collection's info to the table, replacing ;; Add this collection's info to the table, replacing any information
;; any information already there. ;; already there.
(hash-table-put! t (hash-table-put! t
(path->bytes (if (cc-root-dir cc) (path->bytes (if (cc-root-dir cc)
;; Use relative path: ;; Use relative path:
(apply build-path (cc-collection cc)) (apply build-path (cc-collection cc))
;; Use absolute path: ;; Use absolute path:
(cc-path cc))) (cc-path cc)))
(cons (domain) (cc-shadowing-policy cc)))))) (cons (domain) (cc-shadowing-policy cc)))))
ccs-to-compile)
;; Write out each collection-root-specific table to a "cache.ss" file: ;; Write out each collection-root-specific table to a "cache.ss" file:
(hash-table-for-each ht (hash-table-for-each ht
(lambda (info-path ht) (lambda (info-path ht)
@ -824,10 +748,8 @@
(if (exn? exn) (if (exn? exn)
(exn-message exn) (exn-message exn)
exn)))]) exn)))])
(doc:setup-scribblings (if (and (null? x-specific-collections) (doc:setup-scribblings
(null? x-specific-planet-dirs)) (if no-specific-collections? #f (map cc-path ccs-to-compile))
#f
(map cc-path ccs-to-compile))
#f))) #f)))
(when (doc-pdf-dest) (when (doc-pdf-dest)
@ -842,13 +764,11 @@
(lambda () (lambda ()
(make-directory tmp-dir) (make-directory tmp-dir)
(doc:verbose (verbose)) (doc:verbose (verbose))
(doc:setup-scribblings (if (and (null? x-specific-collections) (doc:setup-scribblings
(null? x-specific-planet-dirs)) (if no-specific-collections? #f (map cc-path ccs-to-compile))
#f
(map cc-path ccs-to-compile))
tmp-dir) tmp-dir)
(parameterize ([current-directory tmp-dir]) (parameterize ([current-directory tmp-dir])
(for-each (lambda (f) (for ([f (directory-list)])
(define cmd (format "pdflatex \"~a\"" f)) (define cmd (format "pdflatex \"~a\"" f))
(when (regexp-match? #rx#"[.]tex$" (path-element->bytes f)) (when (regexp-match? #rx#"[.]tex$" (path-element->bytes f))
(let loop ([n 3]) (let loop ([n 3])
@ -861,8 +781,7 @@
[target (build-path dest-dir f)]) [target (build-path dest-dir f)])
(when (file-exists? target) (when (file-exists? target)
(delete-file target)) (delete-file target))
(copy-file f target)))) (copy-file f target))))))
(directory-list))))
(lambda () (lambda ()
(when (directory-exists? tmp-dir) (when (directory-exists? tmp-dir)
(delete-directory/files tmp-dir))))))) (delete-directory/files tmp-dir)))))))
@ -874,31 +793,31 @@
(when (make-launchers) (when (make-launchers)
(let ([name-list (let ([name-list
(lambda (l) (lambda (l)
(unless (and (list? l) (andmap (lambda (x) (and (path-string? x) (relative-path? x))) l)) (unless (and (list? l)
(andmap (lambda (x) (and (path-string? x) (relative-path? x)))
l))
(error "result is not a list of relative path strings:" l)))] (error "result is not a list of relative path strings:" l)))]
[flags-list [flags-list
(lambda (l) (lambda (l)
(unless (and (list? l) (andmap (lambda (fs) (andmap string? fs)) l)) (unless (and (list? l) (andmap (lambda (fs) (andmap string? fs)) l))
(error "result is not a list of strings:" l)))] (error "result is not a list of strings:" l)))]
[or-f (lambda (f) (lambda (x) (when x (f x))))]) [or-f (lambda (f) (lambda (x) (when x (f x))))])
(for-each (for ([cc ccs-to-compile])
(lambda (cc) (begin-record-error cc "Launcher Setup"
(record-error (define info (cc-info cc))
cc (define (make-launcher kind
"Launcher Setup"
(lambda ()
(let* ([info (cc-info cc)]
[make-launcher
(lambda (kind
launcher-names launcher-names
launcher-libraries launcher-libraries
launcher-flags launcher-flags
program-launcher-path program-launcher-path
make-launcher make-launcher
up-to-date?) up-to-date?)
(let ([mzlns (call-info info launcher-names (lambda () null) name-list)] (define mzlns
[mzlls (call-info info launcher-libraries (lambda () #f) (or-f name-list))] (call-info info launcher-names (lambda () null) name-list))
[mzlfs (call-info info launcher-flags (lambda () #f) (or-f flags-list))]) (define mzlls
(call-info info launcher-libraries (lambda () #f) (or-f name-list)))
(define mzlfs
(call-info info launcher-flags (lambda () #f) (or-f flags-list)))
(cond (cond
[(null? mzlns) (void)] [(null? mzlns) (void)]
[(not (or mzlls mzlfs)) [(not (or mzlls mzlfs))
@ -931,7 +850,8 @@
(list "-l-" (string-append (list "-l-" (string-append
(apply string-append (apply string-append
(map (lambda (s) (map (lambda (s)
(string-append (if (path? s) (string-append
(if (path? s)
(path->string s) (path->string s)
s) s)
"/")) "/"))
@ -949,45 +869,27 @@
"Warning: ~a launcher name list ~s doesn't match ~a list; ~s" "Warning: ~a launcher name list ~s doesn't match ~a list; ~s"
kind mzlns kind mzlns
(if (eq? 'l fault) "library" "flags") (if (eq? 'l fault) "library" "flags")
(if (eq? fault 'l) mzlls mzlfs)))])))]) (if (eq? fault 'l) mzlls mzlfs)))]))
(for-each (for ([variant (available-mred-variants)])
(lambda (variant)
(parameterize ([current-launcher-variant variant]) (parameterize ([current-launcher-variant variant])
(make-launcher (make-launcher "MrEd"
"MrEd"
'mred-launcher-names 'mred-launcher-names
'mred-launcher-libraries 'mred-launcher-libraries
'mred-launcher-flags 'mred-launcher-flags
mred-program-launcher-path mred-program-launcher-path
make-mred-launcher make-mred-launcher
mred-launcher-up-to-date?))) mred-launcher-up-to-date?)))
(available-mred-variants)) (for ([variant (available-mzscheme-variants)])
(for-each
(lambda (variant)
(parameterize ([current-launcher-variant variant]) (parameterize ([current-launcher-variant variant])
(make-launcher (make-launcher "MzScheme"
"MzScheme"
'mzscheme-launcher-names 'mzscheme-launcher-names
'mzscheme-launcher-libraries 'mzscheme-launcher-libraries
'mzscheme-launcher-flags 'mzscheme-launcher-flags
mzscheme-program-launcher-path mzscheme-program-launcher-path
make-mzscheme-launcher make-mzscheme-launcher
mzscheme-launcher-up-to-date?))) mzscheme-launcher-up-to-date?)))))))
(available-mzscheme-variants))))))
ccs-to-compile)))
(do-install-part 'general) (do-install-part 'general)
(do-install-part 'post) (do-install-part 'post)
(done) (done))
(unless (null? errors)
(setup-printf "")
(show-errors (current-error-port))
(when (pause-on-errors)
(fprintf (current-error-port)
"INSTALLATION FAILED.~nPress Enter to continue...~n")
(read-line))
(exit 1))
(exit 0)))