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

switch to scheme/* libraries, minor formatting

Browse Source 
svn: r8519
This commit is contained in:
Eli Barzilay 2008-02-04 03:25:32 +00:00
parent 389000a29f
commit 160bb6a7bc
1 changed files with 41 additions and 48 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -4,13 +4,13 @@
#lang scheme/base #lang scheme/base
(require mzlib/unit (require scheme/unit
(except-in mzlib/file call-with-input-file* call-with-output-file*)
mzlib/list
mzlib/cm mzlib/cm
mzlib/port scheme/path
mzlib/match scheme/file
mzlib/process scheme/port
scheme/match
scheme/system
planet/planet-archives planet/planet-archives
planet/private/planet-shared planet/private/planet-shared
@ -35,11 +35,13 @@
(export) (export)
(define (setup-fprintf p s . args) (define (setup-fprintf 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 s . args) (define (setup-printf s . args)
(apply setup-fprintf (current-output-port) s args)) (apply setup-fprintf (current-output-port) s args))
(define (exn->string x) (if (exn? x) (exn-message x) (format "~s" x)))
(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" (setup-printf "Available variants:~a"
(apply string-append (apply string-append
@ -52,9 +54,6 @@
(for ([p (current-library-collection-paths)]) (for ([p (current-library-collection-paths)])
(setup-printf " ~a" (path->string p))) (setup-printf " ~a" (path->string p)))
(define (warning s x)
(setup-printf s (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)]) (test v) v) (let ([v (info flag mk-default)]) (test v) v)
@ -73,9 +72,7 @@
(define (record-error cc desc go fail-k) (define (record-error cc desc go fail-k)
(with-handlers ([exn:fail? (with-handlers ([exn:fail?
(lambda (x) (lambda (x)
(if (exn? x) (fprintf (current-error-port) "~a\n" (exn->string 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)) (set! errors (cons (list cc desc x) errors))
(fail-k))]) (fail-k))])
(go))) (go)))
@ -84,17 +81,13 @@
[(_ cc desc body ...) (record-error cc desc (lambda () body ...) void)])) [(_ cc desc body ...) (record-error cc desc (lambda () body ...) void)]))
(define (show-errors port) (define (show-errors port)
(for ([e (reverse errors)]) (for ([e (reverse errors)])
(let ([cc (car e)] (match-let ([(list cc desc x) e])
[desc (cadr e)]
[x (caddr e)])
(setup-fprintf port "Error during ~a for ~a" (setup-fprintf port "Error during ~a for ~a"
desc desc
(if (cc? cc) (if (cc? cc)
(format "~a (~a)" (cc-name cc) (path->string (cc-path cc))) (format "~a (~a)" (cc-name cc) (cc-path cc))
cc)) cc))
(if (exn? x) (setup-fprintf port " ~a" (exn->string x)))))
(setup-fprintf port " ~a" (exn-message x))
(setup-fprintf port " ~s" x)))))
(define (done) (define (done)
(setup-printf "Done setting up") (setup-printf "Done setting up")
@ -146,10 +139,9 @@
(collection path name info root-dir info-path shadowing-policy) (collection path name info root-dir info-path shadowing-policy)
#:inspector #f) #:inspector #f)
(define (warning-handler v) (define ((warning-handler v) exn)
(lambda (exn) (setup-printf "Warning: ~a" (exn->string exn))
(setup-printf "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)
@ -189,7 +181,7 @@
;; 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
(define (planet-spec->planet-list spec) (define (planet-spec->planet-list spec)
(match spec (match spec
[(owner pkg-name maj-str min-str) [(list 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 (unless maj
@ -229,7 +221,7 @@
;; builds a compilation job for the given subdirectory of the given cc this ;; builds a compilation job for the given subdirectory of the given cc 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) (match-let ([(list (list 'planet owner pkg-file extra-path ...) maj min)
(cc-shadowing-policy cc)]) (cc-shadowing-policy cc)])
(planet->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
@ -367,7 +359,7 @@
;; Result checker: ;; Result checker:
(λ (p) (λ (p)
(match p (match p
[(((? (λ (v) (or (string? v) (bytes? v)))) ...) ...) [(list (list (? (λ (v) (or (string? v) (bytes? v)))) ...) ...)
(void)] (void)]
[_ (error "result is not a list of lists of strings: " p)]))))) [_ (error "result is not a list of lists of strings: " p)])))))
(list cc) (list cc)
@ -541,10 +533,11 @@
(unless (file-exists? p) (unless (file-exists? p)
(error "installer file does not exist: " p)))))]) (error "installer file does not exist: " p)))))])
(let ([installer (let ([installer
(with-handlers ([exn:fail? (lambda (exn) (with-handlers ([exn:fail?
(error 'setup-plt (lambda (exn)
"error loading installer: ~a" (error 'setup-plt
(if (exn? exn) (exn-message exn) exn)))]) "error loading installer: ~a"
(exn->string exn)))])
(dynamic-require (build-path (cc-path cc) fn) (dynamic-require (build-path (cc-path cc) fn)
(case part (case part
[(pre) 'pre-installer] [(pre) 'pre-installer]
@ -591,15 +584,15 @@
(if (not (compile-mode)) (if (not (compile-mode))
(thunk) (thunk)
;; Use the indicated mode ;; Use the indicated mode
(let ([zo-compile (with-handlers ([exn:fail? (let ([zo-compile
(lambda (exn) (with-handlers ([exn:fail?
(error 'setup-plt (lambda (exn)
"error loading compiler for mode ~s: ~s" (error 'setup-plt
(compile-mode) "error loading compiler for mode ~s: ~a"
(if (exn? exn) (compile-mode)
(exn-message exn) (exn->string exn)))])
exn)))]) (dynamic-require `(lib "zo-compile.ss" ,(compile-mode))
(dynamic-require `(lib "zo-compile.ss" ,(compile-mode)) 'zo-compile))] 'zo-compile))]
[orig-kinds (use-compiled-file-paths)] [orig-kinds (use-compiled-file-paths)]
[orig-compile (current-compile)] [orig-compile (current-compile)]
[orig-namespace (namespace-anchor->empty-namespace anchor)]) [orig-namespace (namespace-anchor->empty-namespace anchor)])
@ -678,7 +671,8 @@
(set! all-ok? #t) (set! all-ok? #t)
(for ([i l]) (for ([i l])
(match i (match i
[((? (lambda (a) [(list
(? (lambda (a)
(and (bytes? a) (and (bytes? a)
(let ([p (bytes->path a)]) (let ([p (bytes->path a)])
;; If we have a root directory, ;; If we have a root directory,
@ -695,7 +689,7 @@
p) p)
"info.ss")))))) "info.ss"))))))
a) a)
((? symbol? b) ...) (list (? symbol? b) ...)
c c
(? integer? d) (? integer? d)
(? integer? e)) (? integer? e))
@ -750,10 +744,9 @@
(when (make-docs) (when (make-docs)
(setup-printf "Building documentation") (setup-printf "Building documentation")
((doc:verbose) (verbose)) ((doc:verbose) (verbose))
(with-handlers ([exn:fail? (lambda (exn) (with-handlers ([exn:fail?
(setup-printf (lambda (exn)
"Docs failure: ~a" (setup-printf "Docs failure: ~a" (exn->string exn)))])
(if (exn? exn) (exn-message exn) exn)))])
((doc:setup-scribblings) ((doc:setup-scribblings)
(if no-specific-collections? #f (map cc-path ccs-to-compile)) (if no-specific-collections? #f (map cc-path ccs-to-compile))
#f #f