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