291 lines
10 KiB
Racket
291 lines
10 KiB
Racket
#lang scheme/base
|
|
|
|
(require rnrs/records/syntactic-6
|
|
rnrs/records/procedural-6
|
|
scheme/mpair
|
|
"exns.ss"
|
|
(for-syntax scheme/base))
|
|
|
|
(provide &condition
|
|
condition?
|
|
condition
|
|
simple-conditions
|
|
condition-predicate
|
|
condition-accessor
|
|
define-condition-type
|
|
|
|
&message make-message-condition message-condition? condition-message
|
|
&warning make-warning warning?
|
|
&serious make-serious-condition serious-condition?
|
|
&error make-error error?
|
|
&violation make-violation violation?
|
|
&assertion make-assertion-violation assertion-violation?
|
|
&irritants make-irritants-condition irritants-condition? condition-irritants
|
|
&who make-who-condition who-condition? condition-who
|
|
&non-continuable make-non-continuable-violation non-continuable-violation?
|
|
&implementation-restriction make-implementation-restriction-violation implementation-restriction-violation?
|
|
&lexical make-lexical-violation lexical-violation?
|
|
&syntax make-syntax-violation syntax-violation? syntax-violation-form syntax-violation-subform
|
|
&undefined make-undefined-violation undefined-violation?
|
|
|
|
&i/o make-i/o-error i/o-error?
|
|
&i/o-read make-i/o-read-error i/o-read-error?
|
|
&i/o-write make-i/o-write-error i/o-write-error?
|
|
&i/o-invalid-position make-i/o-invalid-position-error i/o-invalid-position-error? i/o-error-position
|
|
&i/o-filename make-i/o-filename-error i/o-filename-error? i/o-error-filename
|
|
&i/o-file-protection make-i/o-file-protection-error i/o-file-protection-error?
|
|
&i/o-file-is-read-only make-i/o-file-is-read-only-error i/o-file-is-read-only-error?
|
|
&i/o-file-already-exists make-i/o-file-already-exists-error i/o-file-already-exists-error?
|
|
&i/o-file-does-not-exist make-i/o-file-does-not-exist-error i/o-file-does-not-exist-error?
|
|
&i/o-port make-i/o-port-error i/o-port-error? i/o-error-port)
|
|
|
|
(define-record-type &condition (fields))
|
|
|
|
(define-struct (compound-condition exn) (conditions) #:transparent)
|
|
(define-struct (compound-condition:fail exn:fail) (conditions) #:transparent)
|
|
|
|
(define (condition? v)
|
|
(or (&condition? v)
|
|
(compound-condition? v)
|
|
(compound-condition:fail? v)
|
|
(exn? v)))
|
|
|
|
(define (condition . conds)
|
|
(for-each (lambda (c)
|
|
(unless (condition? c)
|
|
(raise-type-error 'condition "condition" c)))
|
|
conds)
|
|
(let ([conditions
|
|
(apply append
|
|
(map simple-conditions/list conds))])
|
|
((if (ormap serious-condition? conditions)
|
|
make-compound-condition:fail
|
|
make-compound-condition)
|
|
(or (ormap (lambda (c)
|
|
(and (message-condition? c)
|
|
(condition-message c)))
|
|
conditions)
|
|
"exception")
|
|
(or (ormap (lambda (c)
|
|
(and (has-continuation-marks? c)
|
|
(has-continuation-marks-marks c)))
|
|
conditions)
|
|
(current-continuation-marks))
|
|
conditions)))
|
|
|
|
(define (condition-predicate rtd)
|
|
(let ([pred (record-predicate rtd)])
|
|
(lambda (v)
|
|
(and (condition? v)
|
|
(ormap pred (simple-conditions/list v))))))
|
|
|
|
(define (condition-accessor rtd proc)
|
|
(let ([pred (record-predicate rtd)])
|
|
(unless (and (procedure? proc)
|
|
(procedure-arity-includes? proc 1))
|
|
(raise-type-error 'condition-accessor "procedure (arity 1)" proc))
|
|
(lambda (v)
|
|
(let ([v (ormap (lambda (x)
|
|
(and (pred x) x))
|
|
(simple-conditions/list v))])
|
|
(if v
|
|
(proc v)
|
|
(raise-type-error 'a-condition-accessor "specific kind of condition" v))))))
|
|
|
|
(define (simple-conditions/list c)
|
|
(cond
|
|
[(&condition? c) (list c)]
|
|
[(compound-condition? c)
|
|
(compound-condition-conditions c)]
|
|
[(compound-condition:fail? c)
|
|
(compound-condition:fail-conditions c)]
|
|
[(exn? c)
|
|
(append
|
|
(list
|
|
(make-message-condition (cond
|
|
[(exn:fail:r6rs? c)
|
|
(exn:fail:r6rs-message c)]
|
|
[(exn:fail:contract:r6rs? c)
|
|
(exn:fail:contract:r6rs-message c)]
|
|
[(exn:fail:syntax:r6rs? c)
|
|
(exn:fail:syntax:r6rs-message c)]
|
|
[else (exn-message c)]))
|
|
(make-has-continuation-marks (exn-continuation-marks c)))
|
|
(if (and (exn:fail? c)
|
|
(not (exn:fail:contract? c)))
|
|
(list (make-error))
|
|
null)
|
|
(if (exn:fail:contract? c)
|
|
(list (make-assertion-violation))
|
|
null)
|
|
(if (exn:fail:r6rs? c)
|
|
(append
|
|
(if (exn:fail:r6rs-who c)
|
|
(list (make-who-condition (exn:fail:r6rs-who c)))
|
|
null)
|
|
(list (make-irritants-condition (list->mlist (exn:fail:r6rs-irritants c)))))
|
|
null)
|
|
(if (exn:fail:contract:r6rs? c)
|
|
(append
|
|
(if (exn:fail:contract:r6rs-who c)
|
|
(list (make-who-condition (exn:fail:contract:r6rs-who c)))
|
|
null)
|
|
(list (make-irritants-condition (list->mlist (exn:fail:contract:r6rs-irritants c)))))
|
|
null)
|
|
(if (or (exn:fail:unsupported? c)
|
|
(exn:fail:contract:divide-by-zero? c)
|
|
(exn:fail:contract:non-fixnum-result? c))
|
|
(list (make-implementation-restriction-violation))
|
|
null)
|
|
(if (exn:fail:read? c)
|
|
(list (make-lexical-violation))
|
|
null)
|
|
(if (exn:fail:syntax? c)
|
|
(if (exn:fail:syntax:r6rs? c)
|
|
(append
|
|
(list (make-syntax-violation
|
|
(exn:fail:syntax:r6rs-form c)
|
|
(exn:fail:syntax:r6rs-subform c)))
|
|
(if (exn:fail:syntax:r6rs-who c)
|
|
(list (make-who-condition (exn:fail:syntax:r6rs-who c)))
|
|
null))
|
|
(let ([forms (exn:fail:syntax-exprs c)])
|
|
(list (make-syntax-violation
|
|
(if (pair? forms)
|
|
(car forms)
|
|
#f)
|
|
(if (and (pair? forms)
|
|
(pair? (cdr forms)))
|
|
(cadr forms)
|
|
#f)))))
|
|
null)
|
|
(if (exn:fail:contract:variable? c)
|
|
(list (make-undefined-violation))
|
|
null)
|
|
(if (exn:fail:filesystem:exists? c)
|
|
(list (make-i/o-file-already-exists-error "???"))
|
|
null)
|
|
(if (exn:fail:filesystem:exists-not? c)
|
|
(list (make-i/o-file-does-not-exist-error
|
|
(exn:fail:filesystem:exists-not-filename
|
|
c)))
|
|
null)
|
|
(if (exn:fail:contract:non-continuable? c)
|
|
(list (make-non-continuable-violation))
|
|
null))]
|
|
[else (raise-type-error 'simple-conditions
|
|
"condition"
|
|
c)]))
|
|
|
|
(define (simple-conditions c)
|
|
(list->mlist (simple-conditions/list c)))
|
|
|
|
(define-syntax (define-condition-type stx)
|
|
(syntax-case stx ()
|
|
[(_ type supertype
|
|
constructor predicate
|
|
(field accessor) ...)
|
|
(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
|
|
make-message-condition message-condition?
|
|
(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
|
|
make-warning warning?)
|
|
|
|
(define-condition-type &serious &condition
|
|
make-serious-condition serious-condition?)
|
|
|
|
(define-condition-type &error &serious
|
|
make-error error?)
|
|
|
|
(define-condition-type &violation &serious
|
|
make-violation violation?)
|
|
|
|
(define-condition-type &assertion &violation
|
|
make-assertion-violation assertion-violation?)
|
|
|
|
(define-condition-type &irritants &condition
|
|
make-irritants-condition irritants-condition?
|
|
(irritants condition-irritants))
|
|
|
|
(define-condition-type &who &condition
|
|
make-who-condition who-condition?
|
|
(who condition-who))
|
|
|
|
(define-condition-type &non-continuable &violation
|
|
make-non-continuable-violation
|
|
non-continuable-violation?)
|
|
|
|
(define-condition-type &implementation-restriction
|
|
&violation
|
|
make-implementation-restriction-violation
|
|
implementation-restriction-violation?)
|
|
|
|
(define-condition-type &lexical &violation
|
|
make-lexical-violation lexical-violation?)
|
|
|
|
(define-condition-type &syntax &violation
|
|
make-syntax-violation syntax-violation?
|
|
(form syntax-violation-form)
|
|
(subform syntax-violation-subform))
|
|
|
|
;; ----------------------------------------
|
|
;; i/o
|
|
|
|
(define-condition-type &undefined &violation
|
|
make-undefined-violation undefined-violation?)
|
|
|
|
(define-condition-type &i/o &error
|
|
make-i/o-error i/o-error?)
|
|
|
|
(define-condition-type &i/o-read &i/o
|
|
make-i/o-read-error i/o-read-error?)
|
|
|
|
(define-condition-type &i/o-write &i/o
|
|
make-i/o-write-error i/o-write-error?)
|
|
|
|
(define-condition-type &i/o-invalid-position &i/o
|
|
make-i/o-invalid-position-error
|
|
i/o-invalid-position-error?
|
|
(position i/o-error-position))
|
|
|
|
(define-condition-type &i/o-filename &i/o
|
|
make-i/o-filename-error i/o-filename-error?
|
|
(filename i/o-error-filename))
|
|
|
|
(define-condition-type &i/o-file-protection
|
|
&i/o-filename
|
|
make-i/o-file-protection-error
|
|
i/o-file-protection-error?)
|
|
|
|
(define-condition-type &i/o-file-is-read-only
|
|
&i/o-file-protection
|
|
make-i/o-file-is-read-only-error
|
|
i/o-file-is-read-only-error?)
|
|
|
|
(define-condition-type &i/o-file-already-exists
|
|
&i/o-filename
|
|
make-i/o-file-already-exists-error
|
|
i/o-file-already-exists-error?)
|
|
|
|
(define-condition-type &i/o-file-does-not-exist
|
|
&i/o-filename
|
|
make-i/o-file-does-not-exist-error
|
|
i/o-file-does-not-exist-error?)
|
|
|
|
(define-condition-type &i/o-port &i/o
|
|
make-i/o-port-error i/o-port-error?
|
|
(port i/o-error-port))
|