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

fix some R6RS conditions & exceptions bugs

Browse Source 
svn: r8889
This commit is contained in:
Matthew Flatt 2008-03-05 01:13:49 +00:00
parent c8f3d15c79
commit 8e32f81c1b
2 changed files with 31 additions and 20 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

49
collects/rnrs/conditions-6.ss
View File

@ -2,7 +2,8 @@
(require rnrs/records/syntactic-6 (require rnrs/records/syntactic-6
rnrs/records/procedural-6 rnrs/records/procedural-6
r6rs/private/conds) r6rs/private/conds
(for-syntax scheme/base))
(provide &condition (provide &condition
condition? condition?
@ -28,10 +29,8 @@
(define-record-type &condition (fields)) (define-record-type &condition (fields))
(define-struct (compound-condition exn) (conditions)) (define-struct (compound-condition exn) (conditions) #:transparent)
(define-struct (compound-condition:fail exn:fail) (conditions)) (define-struct (compound-condition:fail exn:fail) (conditions) #:transparent)
(define-struct has-continuation-marks (marks))
(define (condition? v) (define (condition? v)
(or (&condition? v) (or (&condition? v)
@ -45,16 +44,16 @@
(raise-type-error 'condition "condition" c))) (raise-type-error 'condition "condition" c)))
conds) conds)
(let ([conditions (let ([conditions
(make-compound-condition (apply append
(apply append (map simple-conditions conds))])
(map simple-conditions conds)))])
((if (ormap serious-condition? conditions) ((if (ormap serious-condition? conditions)
make-compound-condition:fail make-compound-condition:fail
make-compound-condition) make-compound-condition)
(ormap (lambda (c) (or (ormap (lambda (c)
(and (message-condition? c) (and (message-condition? c)
(condition-message c))) (condition-message c)))
conditions) conditions)
"exception")
(or (ormap (lambda (c) (or (ormap (lambda (c)
(and (has-continuation-marks? c) (and (has-continuation-marks? c)
(has-continuation-marks-marks c))) (has-continuation-marks-marks c)))
@ -74,7 +73,9 @@
(procedure-arity-includes? proc 1)) (procedure-arity-includes? proc 1))
(raise-type-error 'condition-accessor "procedure (arity 1)" proc)) (raise-type-error 'condition-accessor "procedure (arity 1)" proc))
(lambda (v) (lambda (v)
(let ([v (ormap pred (simple-conditions v))]) (let ([v (ormap (lambda (x)
(and (pred x) x))
(simple-conditions v))])
(if v (if v
(proc v) (proc v)
(raise-type-error 'a-condition-accessor "specific kind of condition" v)))))) (raise-type-error 'a-condition-accessor "specific kind of condition" v))))))
@ -137,17 +138,27 @@
c)])) c)]))
(define-syntax-rule (define-condition-type type supertype (define-syntax (define-condition-type stx)
constructor predicate (syntax-case stx ()
field ...) [(_ type supertype
(define-record-type (type constructor predicate) constructor predicate
(fields (immutable . field) ...) (field accessor) ...)
(parent supertype))) (with-syntax ([(tmp-acc ...) (generate-temporaries #'(field ...))])
#'(begin
(define-record-type (type constructor base-predicate)
(fields (immutable field tmp-acc) ...)
(parent supertype))
(define predicate (condition-predicate type))
(define accessor (condition-accessor type tmp-acc)) ...))]))
(define-condition-type &message &condition (define-condition-type &message &condition
make-message-condition message-condition? make-message-condition message-condition?
(message condition-message)) (message condition-message))
(define-condition-type &cont-marks &condition
make-has-continuation-marks has-continuation-marks?
(marks has-continuation-marks-marks))
(define-condition-type &warning &condition (define-condition-type &warning &condition
make-warning warning?) make-warning warning?)

2
collects/rnrs/exceptions-6.ss
View File

@ -68,7 +68,7 @@
(define (r6rs:raise exn) (define (r6rs:raise exn)
;; No barrier ;; No barrier
(raise exn #t)) (raise exn #f))
(define (raise-continuable exn) (define (raise-continuable exn)
((let/cc cont ((let/cc cont