From 329b971f44d3c85f0f82289f5d4da2c65cab70c2 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 14 Mar 2004 19:27:23 +0000 Subject: [PATCH] . original commit: e8b1a97158ca6a6720423c96888191da08c51303 --- collects/mzlib/cm.ss | 12 ++--- collects/mzlib/date.ss | 4 +- collects/mzlib/deflate.ss | 4 +- collects/mzlib/file.ss | 24 ++++------ collects/mzlib/include.ss | 4 +- collects/mzlib/list.ss | 5 +-- collects/mzlib/match.ss | 2 +- collects/mzlib/plt-match.ss | 2 +- collects/mzlib/private/sigmatch.ss | 71 ++++++++++++++++-------------- collects/mzlib/sendevent.ss | 4 +- collects/mzlib/thread.ss | 8 ++-- collects/mzlib/unit.ss | 25 ++++++----- 12 files changed, 83 insertions(+), 82 deletions(-) diff --git a/collects/mzlib/cm.ss b/collects/mzlib/cm.ss index de50352..d35d57b 100644 --- a/collects/mzlib/cm.ss +++ b/collects/mzlib/cm.ss @@ -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])]) diff --git a/collects/mzlib/date.ss b/collects/mzlib/date.ss index bfeda57..e5cbc16 100644 --- a/collects/mzlib/date.ss +++ b/collects/mzlib/date.ss @@ -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))]) diff --git a/collects/mzlib/deflate.ss b/collects/mzlib/deflate.ss index 21fcb45..5e84565 100644 --- a/collects/mzlib/deflate.ss +++ b/collects/mzlib/deflate.ss @@ -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))))) diff --git a/collects/mzlib/file.ss b/collects/mzlib/file.ss index 40ce5b5..efe873d 100644 --- a/collects/mzlib/file.ss +++ b/collects/mzlib/file.ss @@ -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: diff --git a/collects/mzlib/include.ss b/collects/mzlib/include.ss index ade839a..26a3257 100644 --- a/collects/mzlib/include.ss +++ b/collects/mzlib/include.ss @@ -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 diff --git a/collects/mzlib/list.ss b/collects/mzlib/list.ss index a49bb2b..a95ce77 100644 --- a/collects/mzlib/list.ss +++ b/collects/mzlib/list.ss @@ -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) diff --git a/collects/mzlib/match.ss b/collects/mzlib/match.ss index 9770242..c9f0de6 100644 --- a/collects/mzlib/match.ss +++ b/collects/mzlib/match.ss @@ -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 diff --git a/collects/mzlib/plt-match.ss b/collects/mzlib/plt-match.ss index 466db63..54fbe98 100644 --- a/collects/mzlib/plt-match.ss +++ b/collects/mzlib/plt-match.ss @@ -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 diff --git a/collects/mzlib/private/sigmatch.ss b/collects/mzlib/private/sigmatch.ss index 068c4f8..dde38e3 100644 --- a/collects/mzlib/private/sigmatch.ss +++ b/collects/mzlib/private/sigmatch.ss @@ -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))) diff --git a/collects/mzlib/sendevent.ss b/collects/mzlib/sendevent.ss index 0138e0d..15c5fc6 100644 --- a/collects/mzlib/sendevent.ss +++ b/collects/mzlib/sendevent.ss @@ -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)))))))) diff --git a/collects/mzlib/thread.ss b/collects/mzlib/thread.ss index 37e39e5..2fb3d95 100644 --- a/collects/mzlib/thread.ss +++ b/collects/mzlib/thread.ss @@ -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 ": 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]) diff --git a/collects/mzlib/unit.ss b/collects/mzlib/unit.ss index 801e4bb..8ca36c8 100644 --- a/collects/mzlib/unit.ss +++ b/collects/mzlib/unit.ss @@ -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))))) ;; ----------------------------------------------------------------------