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

.

Browse Source 
original commit: e8b1a97158ca6a6720423c96888191da08c51303
This commit is contained in:
Matthew Flatt 2004-03-14 19:27:23 +00:00
parent c5067c9550
commit 329b971f44
12 changed files with 83 additions and 82 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
collects/mzlib/cm.ss
View File

@ -67,7 +67,7 @@
(close-output-port (open-output-file path 'append)))
(define (compilation-failure path zo-name date-path reason)
(with-handlers ((not-break-exn? void))
(with-handlers ((exn:fail:filesystem? void))
(delete-file zo-name))
(let ([fail-path (bytes->path
(bytes-append (get-compilation-path path) #".fail"))])
@ -105,7 +105,7 @@
(if (not (directory-exists? code-dir))
(make-directory code-dir))
(let ((out (open-output-file zo-name 'replace)))
(with-handlers ((exn:application:type?
(with-handlers ((exn:fail?
(lambda (ex) (compilation-failure path zo-name #f (exn-message ex)))))
(dynamic-wind
void
@ -157,7 +157,7 @@
[() -inf.0]
[(f . l)
(if f
(with-handlers ([exn:i/o:filesystem?
(with-handlers ([exn:fail:filesystem?
(lambda (ex)
(apply first-date l))])
(file-or-directory-modify-seconds (f)))
@ -173,7 +173,7 @@
((trace) (format "~achecking: ~a" (indent) path))
(let ((path-zo-time (get-compiled-time path #f))
(path-time
(with-handlers ((exn:i/o:filesystem?
(with-handlers ((exn:fail:filesystem?
(lambda (ex)
((trace) (format "~a~a does not exist" (indent) path))
#f)))
@ -186,7 +186,7 @@
((trace) (format "~anewer src..." (indent)))
(compile-zo path))
(else
(let ((deps (with-handlers ((exn:i/o:filesystem? (lambda (ex) (list (version)))))
(let ((deps (with-handlers ((exn:fail:filesystem? (lambda (ex) (list (version)))))
(call-with-input-file (bytes->path
(bytes-append (get-compilation-path path) #".dep"))
read))))
@ -202,7 +202,7 @@
[(bytes? d) (compile-root (bytes->path d) up-to-date)]
[(path? d) (compile-root d up-to-date)]
[(and (pair? d) (eq? (car d) 'ext))
(with-handlers ((exn:i/o:filesystem?
(with-handlers ((exn:fail:filesystem?
(lambda (ex) +inf.0)))
(file-or-directory-modify-seconds (cdr d)))]
[else -inf.0])])

4
collects/mzlib/date.ss
View File

@ -260,7 +260,7 @@
(and (negative? offset) (= hi mid)))
(found lo)
(let ([mid-ok?
(with-handlers ([not-break-exn? (lambda (exn) #f)])
(with-handlers ([exn:fail? (lambda (exn) #f)])
(seconds->date mid)
#t)])
(if mid-ok?
@ -268,7 +268,7 @@
(find-between lo mid))))))])
(let loop ([lo start][offset offset])
(let ([hi (+ lo offset)])
(with-handlers ([not-break-exn?
(with-handlers ([exn:fail?
(lambda (exn)
; failed - must be between lo & hi
(find-between lo hi))])

4
collects/mzlib/deflate.ss
View File

@ -2271,10 +2271,10 @@
(dynamic-wind
void
(lambda ()
(let ([name (with-handlers ([not-break-exn? (lambda (x) #f)])
(let ([name (with-handlers ([exn:fail? (lambda (x) #f)])
(let-values ([(base name dir?) (split-path infile)])
name))]
[timestamp (with-handlers ([not-break-exn? (lambda (x) 0)])
[timestamp (with-handlers ([exn:fail:filesystem? (lambda (x) 0)])
(file-or-directory-modify-seconds infile))])
(gzip-through-ports i o name timestamp)))
(lambda () (close-output-port o)))))

24
collects/mzlib/file.ss
View File

@ -60,7 +60,7 @@
;; Use simplify-path to get rid of ..s, which can
;; allow the path to grow indefinitely in a cycle.
;; An exception must mean a cycle of links.
(with-handlers ([not-break-exn?
(with-handlers ([exn:fail:filesystem?
(lambda (x)
(error 'normalize-path "circular reference at ~s" path))])
(simplify-path path))])
@ -230,7 +230,7 @@
(define make-temporary-file
(case-lambda
[(template copy-from base-dir)
(with-handlers ([not-break-exn?
(with-handlers ([exn:fail:contract?
(lambda (x)
(raise-type-error 'make-temporary-file
"format string for 1 argument"
@ -247,14 +247,10 @@
[base-dir (build-path base-dir n)]
[(relative-path? n) (build-path tmpdir n)]
[else n]))])
(with-handlers ([exn:i/o:filesystem? (lambda (x)
(if (eq? (exn:i/o:filesystem-detail x)
'already-exists)
;; try again with a new name
(loop (- s (random 10))
(+ ms (random 10)))
;; It's something else; give up
(raise x)))])
(with-handlers ([exn:fail:filesystem:exists? (lambda (x)
;; try again with a new name
(loop (- s (random 10))
(+ ms (random 10))))])
(if copy-from
(copy-file copy-from name)
(close-output-port (open-output-file name)))
@ -267,7 +263,7 @@
(case-lambda
[(name) (find-library name "mzlib")]
[(name collection . cp)
(let ([dir (with-handlers ([not-break-exn? (lambda (exn) #f)])
(let ([dir (with-handlers ([exn:fail:filesystem? (lambda (exn) #f)])
(apply collection-path collection cp))])
(if dir
(let ([file (build-path dir name)])
@ -300,7 +296,7 @@
(not filename)
(weak-box-value pref-box))])
(or f
(let ([f (let ([v (with-handlers ([not-break-exn? (lambda (x) null)])
(let ([f (let ([v (with-handlers ([exn:fail:filesystem? (lambda (x) null)])
(let ([pref-file (or filename
(let ([f (find-system-path 'pref-file)])
(if (file-exists? f)
@ -388,9 +384,7 @@
#"LOCK"
(path->bytes name))))
dir))))])
(with-handlers ([(lambda (x)
(and (exn:i/o:filesystem? x)
(eq? (exn:i/o:filesystem-detail x) 'already-exists)))
(with-handlers ([exn:fail:filesystem:exists?
(lambda (x)
(lock-there lock-file))])
;; Grab lock:

4
collects/mzlib/include.ss
View File

@ -42,7 +42,7 @@
orig-stx))
;; Open the included file
(let ([p (with-handlers ([not-break-exn?
(let ([p (with-handlers ([exn:fail?
(lambda (exn)
(raise-syntax-error
#f
@ -58,7 +58,7 @@
;; Read expressions from file
(let ([content
(let loop ()
(let ([r (with-handlers ([not-break-exn?
(let ([r (with-handlers ([exn:fail?
(lambda (exn)
(close-input-port p)
(raise-syntax-error

5
collects/mzlib/list.ss
View File

@ -221,10 +221,9 @@
(cond
[(null? l) #f]
[(not (pair? l))
(raise (make-exn:application:mismatch
(raise (make-exn:fail:contract
(format "~a: second argument must be a (proper) list; given ~e" name list)
(current-continuation-marks)
list))]
(current-continuation-marks)))]
[else (let ([a (car l)])
(if whole-list?
(if (f a)

2
collects/mzlib/match.ss
View File

@ -138,7 +138,7 @@
(require (lib "etc.ss")
(lib "list.ss"))
(define-struct (exn:misc:match exn:misc) (value))
(define-struct (exn:misc:match exn:fail) (value))
(define match:error
(case-lambda

2
collects/mzlib/plt-match.ss
View File

@ -165,7 +165,7 @@
" given " (format "~s" regex) "; "
"other argument was " (format "~s" str)))))
(define-struct (exn:misc:match exn:misc) (value))
(define-struct (exn:misc:match exn:fail) (value))
(define match:error
(case-lambda

71
collects/mzlib/private/sigmatch.ss
View File

@ -43,12 +43,13 @@
(lambda ()
(raise
(make-exn:unit
(format
"~a: ~a is missing a value name `~a', required by ~a"
who
src-context
(sig-path-name s path)
dest-context)
(string->immutable-string
(format
"~a: ~a is missing a value name `~a', required by ~a"
who
src-context
(sig-path-name s path)
dest-context))
(current-continuation-marks)))))])
(and v
(begin
@ -56,13 +57,14 @@
(let ([p (sig-path-name s path)])
(raise
(make-exn:unit
(format
"~a: ~a contains `~a' as a sub-unit name, but ~a contains `~a' as a value name"
who
src-context
p
dest-context
p)
(string->immutable-string
(format
"~a: ~a contains `~a' as a sub-unit name, but ~a contains `~a' as a value name"
who
src-context
p
dest-context
p))
(current-continuation-marks)))))
(hash-table-put! table s #f)
#t)))]
@ -71,12 +73,13 @@
(lambda ()
(raise
(make-exn:unit
(format
"~a: ~a is missing a sub-unit name `~a', required by ~a"
who
src-context
(sig-path-name (car s) path)
dest-context)
(string->immutable-string
(format
"~a: ~a is missing a sub-unit name `~a', required by ~a"
who
src-context
(sig-path-name (car s) path)
dest-context))
(current-continuation-marks)))))])
(and v
(begin
@ -84,13 +87,14 @@
(let ([p (sig-path-name (car s) path)])
(raise
(make-exn:unit
(format
"~a: ~a contains `~a' as a value name, but ~a contains `~a' as a sub-unit name"
who
src-context
p
dest-context
p)
(string->immutable-string
(format
"~a: ~a contains `~a' as a value name, but ~a contains `~a' as a sub-unit name"
who
src-context
p
dest-context
p))
(current-continuation-marks)))))
(hash-table-put! table (car s) #f)
(check-sig-match v (cdr s) (cons (car s) path)
@ -105,13 +109,14 @@
(let ([p (sig-path-name k path)])
(raise
(make-exn:unit
(format
"~a: ~a contains an extra ~a name `~a' that is not required by ~a"
who
src-context
(if (symbol? v) 'value 'sub-unit)
p
dest-context)
(string->immutable-string
(format
"~a: ~a contains an extra ~a name `~a' that is not required by ~a"
who
src-context
(if (symbol? v) 'value 'sub-unit)
p
dest-context))
(current-continuation-marks)))))))
#t)))

4
collects/mzlib/sendevent.ss
View File

@ -5,12 +5,12 @@
(define send-event
(opt-lambda (who class msg [data (void)] [args null])
(let ([send-event (with-handlers ([not-break-exn? (lambda (x) #f)])
(let ([send-event (with-handlers ([exn:fail? (lambda (x) #f)])
(dynamic-require '(lib "mred.ss" "mred")
'send-event))])
(if send-event
(send-event who class msg data args)
(raise
(make-exn:misc:unsupported
(make-exn:fail:unsupported
"send-event: only supported in MrEd"
(current-continuation-marks))))))))

8
collects/mzlib/thread.ss
View File

@ -61,12 +61,10 @@
(let ([num (length new-state)])
(unless (procedure-arity-includes? f num)
(raise
(make-exn:application:arity
(make-exn:fail:contract:arity
(format "<procedure-from-consumer-thread>: consumer procedure arity is ~e; provided ~s argument~a"
(procedure-arity f) num (if (= 1 num) "" "s"))
(current-continuation-marks)
num
(procedure-arity f)))))
(current-continuation-marks)))))
(semaphore-wait protect)
(set! front-state (cons new-state front-state))
(semaphore-post protect)
@ -165,7 +163,7 @@
(lambda ()
;; loop to handle connections
(let loop ()
(with-handlers ([not-break-exn? handle-exn])
(with-handlers ([exn:fail:network? handle-exn])
;; Make a custodian for the next session:
(let ([c (make-custodian)])
(parameterize ([current-custodian c])

25
collects/mzlib/unit.ss
View File

@ -334,15 +334,17 @@
(unless (unit? unit)
(raise
(make-exn:unit
(format "compound-unit: result of expression for tag ~s not a unit: ~e" tag unit)
(string->immutable-string
(format "compound-unit: result of expression for tag ~s not a unit: ~e" tag unit))
(current-continuation-marks))))
(unless (= num-imports (unit-num-imports unit))
(raise
(make-exn:unit
(format "compound-unit: unit for tag ~s expects ~a imports, given ~a"
tag
(unit-num-imports unit)
num-imports)
(string->immutable-string
(format "compound-unit: unit for tag ~s expects ~a imports, given ~a"
tag
(unit-num-imports unit)
num-imports))
(current-continuation-marks))))
(list->vector
(map (lambda (ex)
@ -351,8 +353,9 @@
[(null? l)
(raise
(make-exn:unit
(format "compount-unit: unit for tag ~s has no ~s export"
tag ex)
(string->immutable-string
(format "compount-unit: unit for tag ~s has no ~s export"
tag ex))
(current-continuation-marks)))]
[(eq? (car l) ex)
i]
@ -717,13 +720,15 @@
(unless (unit? u)
(raise
(make-exn:unit
(format "invoke-unit: result of unit expression was not a unit: ~e" u)
(string->immutable-string
(format "invoke-unit: result of unit expression was not a unit: ~e" u))
(current-continuation-marks))))
(unless (= (unit-num-imports u) n)
(raise
(make-exn:unit
(format "invoke-unit: expected a unit with ~a imports, given one with ~a imports"
n (unit-num-imports u))
(string->immutable-string
(format "invoke-unit: expected a unit with ~a imports, given one with ~a imports"
n (unit-num-imports u)))
(current-continuation-marks)))))
;; ----------------------------------------------------------------------