1 ;;; r6rs-conditions.test --- Test suite for R6RS (rnrs conditions)
3 ;; Copyright (C) 2010 Free Software Foundation, Inc.
5 ;; This library is free software; you can redistribute it and/or
6 ;; modify it under the terms of the GNU Lesser General Public
7 ;; License as published by the Free Software Foundation; either
8 ;; version 3 of the License, or (at your option) any later version.
10 ;; This library is distributed in the hope that it will be useful,
11 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
12 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
13 ;; Lesser General Public License for more details.
15 ;; You should have received a copy of the GNU Lesser General Public
16 ;; License along with this library; if not, write to the Free Software
17 ;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
20 (define-module (test-suite test-rnrs-conditions)
21 :use-module ((rnrs base) :version (6))
22 :use-module ((rnrs conditions) :version (6))
23 :use-module (test-suite lib))
25 (define-condition-type &a &condition make-a-condition a-condition? (foo a-foo))
26 (define-condition-type &b &condition make-b-condition b-condition? (bar b-bar))
27 (define-condition-type &c &condition make-c-condition c-condition?
32 (with-test-prefix "condition?"
33 (pass-if "condition? is #t for simple conditions"
34 (condition? (make-error)))
36 (pass-if "condition? is #t for compound conditions"
37 (condition? (condition (make-error) (make-assertion-violation))))
39 (pass-if "condition? is #f for non-conditions"
40 (not (condition? 'foo))))
42 (with-test-prefix "simple-conditions"
43 (pass-if "simple-conditions returns condition components"
44 (let* ((error (make-error))
45 (assertion (make-assertion-violation))
46 (c (condition error assertion))
47 (scs (simple-conditions c)))
48 (equal? scs (list error assertion))))
50 (pass-if "simple-conditions flattens compound conditions"
51 (let* ((implementation-restriction
52 (make-implementation-restriction-violation))
54 (c1 (condition implementation-restriction error1))
56 (assertion (make-assertion-violation))
57 (c2 (condition error2 assertion c1))
58 (scs (simple-conditions c2)))
59 (equal? scs (list error2 assertion implementation-restriction error1)))))
61 (with-test-prefix "condition-predicate"
62 (pass-if "returned procedure identifies matching simple conditions"
63 (let ((mp (condition-predicate &message))
64 (mc (make-message-condition "test")))
67 (pass-if "returned procedure identifies matching compound conditions"
68 (let* ((sp (condition-predicate &serious))
69 (vp (condition-predicate &violation))
70 (sc (make-serious-condition))
72 (c (condition sc vc)))
75 (pass-if "returned procedure is #f for non-matching simple"
76 (let ((sp (condition-predicate &serious)))
79 (pass-if "returned procedure is #f for compound without match"
80 (let* ((ip (condition-predicate &irritants))
81 (sc (make-serious-condition))
83 (c (condition sc vc)))
86 (with-test-prefix "condition-accessor"
87 (pass-if "accessor applies proc to field from simple condition"
88 (let* ((proc (lambda (c) (condition-message c)))
89 (ma (condition-accessor &message proc))
90 (mc (make-message-condition "foo")))
91 (equal? (ma mc) "foo")))
93 (pass-if "accessor applies proc to field from compound condition"
94 (let* ((proc (lambda (c) (condition-message c)))
95 (ma (condition-accessor &message proc))
96 (mc (make-message-condition "foo"))
98 (c (condition vc mc)))
99 (equal? (ma c) "foo"))))
101 (with-test-prefix "define-condition-type"
102 (pass-if "define-condition-type produces proper accessors"
103 (let ((c (condition (make-a-condition 'foo) (make-b-condition 'bar))))
104 (and (eq? (a-foo c) 'foo) (eq? (b-bar c) 'bar))))
105 (pass-if "define-condition-type works for multiple fields"
106 (let ((c (condition (make-a-condition 'foo)
107 (make-c-condition 1 2 3))))
108 (and (eq? (a-foo c) 'foo)
111 (= (c-frobotz c) 3)))))