Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Fetching contributors…

Cannot retrieve contributors at this time

254 lines (195 sloc) 6.983 kb
#!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)
;;
))
Jump to Line
Something went wrong with that request. Please try again.