254 lines
6.8 KiB
Scheme
254 lines
6.8 KiB
Scheme
#!r6rs
|
|
|
|
(library (tests r6rs conditions)
|
|
(export run-conditions-tests)
|
|
(import (rnrs)
|
|
(tests r6rs test))
|
|
|
|
|
|
(define-syntax test-cond
|
|
(syntax-rules ()
|
|
[(_ &c &parent (make arg ...) pred sel ...)
|
|
(begin
|
|
(test (pred (make arg ...)) #t)
|
|
(let ([v (make arg ...)])
|
|
(test (sel v) arg) ...
|
|
'ok)
|
|
(test ((record-predicate (record-type-descriptor &parent)) (make arg ...)) #t)
|
|
(test (record-type-parent (record-type-descriptor &c)) (record-type-descriptor &parent)))]))
|
|
|
|
;; ----------------------------------------
|
|
|
|
(define-record-type (&cond1 make-cond1 real-cond1?)
|
|
(parent &condition)
|
|
(fields
|
|
(immutable x real-cond1-x)))
|
|
|
|
(define cond1?
|
|
(condition-predicate
|
|
(record-type-descriptor &cond1)))
|
|
(define cond1-x
|
|
(condition-accessor
|
|
(record-type-descriptor &cond1)
|
|
real-cond1-x))
|
|
|
|
(define foo (make-cond1 'foo))
|
|
|
|
(define-record-type (&cond2 make-cond2 real-cond2?)
|
|
(parent &condition)
|
|
(fields
|
|
(immutable y real-cond2-y)))
|
|
|
|
(define cond2?
|
|
(condition-predicate
|
|
(record-type-descriptor &cond2)))
|
|
(define cond2-y
|
|
(condition-accessor
|
|
(record-type-descriptor &cond2)
|
|
real-cond2-y))
|
|
|
|
(define bar (make-cond2 'bar))
|
|
|
|
(define-condition-type &c &condition
|
|
make-c c?
|
|
(x c-x))
|
|
|
|
(define-condition-type &c1 &c
|
|
make-c1 c1?
|
|
(a c1-a))
|
|
|
|
(define-condition-type &c2 &c
|
|
make-c2 c2?
|
|
(b c2-b))
|
|
|
|
(define v1 (make-c1 "V1" "a1"))
|
|
|
|
(define v2 (make-c2 "V2" "b2"))
|
|
|
|
(define v3 (condition
|
|
(make-c1 "V3/1" "a3")
|
|
(make-c2 "V3/2" "b3")))
|
|
|
|
(define v4 (condition v1 v2))
|
|
|
|
(define v5 (condition v2 v3))
|
|
|
|
;; ----------------------------------------
|
|
|
|
(define (run-conditions-tests)
|
|
|
|
(test (condition? foo) #t)
|
|
(test (cond1? foo) #t)
|
|
(test (cond1-x foo) 'foo)
|
|
|
|
(test (condition? (condition foo bar)) #t)
|
|
(test (cond1? (condition foo bar)) #t)
|
|
(test (cond2? (condition foo bar)) #t)
|
|
(test (cond1? (condition foo)) #t)
|
|
(test/unspec (real-cond1? (condition foo)))
|
|
(test (real-cond1? (condition foo bar)) #f)
|
|
(test (cond1-x (condition foo bar)) 'foo)
|
|
(test (cond2-y (condition foo bar)) 'bar)
|
|
|
|
(test (simple-conditions (condition foo bar))
|
|
(list foo bar))
|
|
|
|
(test (simple-conditions
|
|
(condition foo (condition bar)))
|
|
(list foo bar))
|
|
|
|
(test (c? v1) #t)
|
|
(test (c1? v1) #t)
|
|
(test (c2? v1) #f)
|
|
(test (c-x v1) "V1")
|
|
(test (c1-a v1) "a1")
|
|
|
|
(test (c? v2) #t)
|
|
(test (c1? v2) #f)
|
|
(test (c2? v2) #t)
|
|
(test (c-x v2) "V2")
|
|
(test (c2-b v2) "b2")
|
|
|
|
(test (c? v3) #t)
|
|
(test (c1? v3) #t)
|
|
(test (c2? v3) #t)
|
|
(test (c-x v3) "V3/1")
|
|
(test (c1-a v3) "a3")
|
|
(test (c2-b v3) "b3")
|
|
|
|
(test (c? v4) #t)
|
|
(test (c1? v4) #t)
|
|
(test (c2? v4) #t)
|
|
(test (c-x v4) "V1")
|
|
(test (c1-a v4) "a1")
|
|
(test (c2-b v4) "b2")
|
|
|
|
(test (c? v5) #t)
|
|
(test (c1? v5) #t)
|
|
(test (c2? v5) #t)
|
|
(test (c-x v5) "V2")
|
|
(test (c1-a v5) "a3")
|
|
(test (c2-b v5) "b2")
|
|
|
|
(test-cond &message &condition
|
|
(make-message-condition "message")
|
|
message-condition?
|
|
condition-message)
|
|
|
|
(test-cond &warning &condition
|
|
(make-warning)
|
|
warning?)
|
|
|
|
(test-cond &serious &condition
|
|
(make-serious-condition)
|
|
serious-condition?)
|
|
|
|
(test-cond &error &serious
|
|
(make-error)
|
|
error?)
|
|
|
|
(test-cond &violation &serious
|
|
(make-violation)
|
|
violation?)
|
|
|
|
(test-cond &assertion &violation
|
|
(make-assertion-violation)
|
|
assertion-violation?)
|
|
|
|
(test-cond &irritants &condition
|
|
(make-irritants-condition (list 'sand 'salt 'acid))
|
|
irritants-condition?
|
|
condition-irritants)
|
|
|
|
(test-cond &who &condition
|
|
(make-who-condition 'new-boss)
|
|
who-condition?
|
|
condition-who)
|
|
|
|
(test-cond &non-continuable &violation
|
|
(make-non-continuable-violation)
|
|
non-continuable-violation?)
|
|
|
|
(test-cond &implementation-restriction &violation
|
|
(make-implementation-restriction-violation)
|
|
implementation-restriction-violation?)
|
|
|
|
(test-cond &lexical &violation
|
|
(make-lexical-violation)
|
|
lexical-violation?)
|
|
|
|
(test-cond &syntax &violation
|
|
(make-syntax-violation '(lambda (x) case) 'case)
|
|
syntax-violation?
|
|
syntax-violation-form
|
|
syntax-violation-subform)
|
|
|
|
(test-cond &undefined &violation
|
|
(make-undefined-violation)
|
|
undefined-violation?)
|
|
|
|
;; These tests really belong in io/ports.ss:
|
|
|
|
(test-cond &i/o &error
|
|
(make-i/o-error)
|
|
i/o-error?)
|
|
|
|
(test-cond &i/o-read &i/o
|
|
(make-i/o-read-error)
|
|
i/o-read-error?)
|
|
|
|
(test-cond &i/o-write &i/o
|
|
(make-i/o-write-error)
|
|
i/o-write-error?)
|
|
|
|
|
|
(test-cond &i/o-invalid-position &i/o
|
|
(make-i/o-invalid-position-error 10)
|
|
i/o-invalid-position-error?
|
|
i/o-error-position)
|
|
|
|
(test-cond &i/o-filename &i/o
|
|
(make-i/o-filename-error "bad.txt")
|
|
i/o-filename-error?
|
|
i/o-error-filename)
|
|
|
|
(test-cond &i/o-file-protection &i/o-filename
|
|
(make-i/o-file-protection-error "private.txt")
|
|
i/o-file-protection-error?
|
|
i/o-error-filename)
|
|
|
|
(test-cond &i/o-file-is-read-only &i/o-file-protection
|
|
(make-i/o-file-is-read-only-error "const.txt")
|
|
i/o-file-is-read-only-error?
|
|
i/o-error-filename)
|
|
|
|
(test-cond &i/o-file-already-exists &i/o-filename
|
|
(make-i/o-file-already-exists-error "x.txt")
|
|
i/o-file-already-exists-error?
|
|
i/o-error-filename)
|
|
|
|
(test-cond &i/o-file-does-not-exist &i/o-filename
|
|
(make-i/o-file-does-not-exist-error "unicorn.txt")
|
|
i/o-file-does-not-exist-error?
|
|
i/o-error-filename)
|
|
|
|
(test-cond &i/o-port &i/o
|
|
(make-i/o-port-error "Hong Kong")
|
|
i/o-port-error?
|
|
i/o-error-port)
|
|
|
|
(test-cond &i/o-decoding &i/o-port
|
|
(make-i/o-decoding-error "Hong Kong")
|
|
i/o-decoding-error?
|
|
i/o-error-port)
|
|
|
|
(test-cond &i/o-encoding &i/o-port
|
|
(make-i/o-encoding-error "Hong Kong" #\$)
|
|
i/o-encoding-error?
|
|
i/o-error-port
|
|
i/o-encoding-error-char)
|
|
|
|
;;
|
|
))
|
|
|