Commit | Line | Data |
---|---|---|
2359a9a4 JG |
1 | ;;; r6rs-conditions.test --- Test suite for R6RS (rnrs conditions) |
2 | ||
3 | ;; Copyright (C) 2010 Free Software Foundation, Inc. | |
4 | ;; | |
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. | |
9 | ;; | |
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. | |
14 | ;; | |
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 | |
18 | \f | |
19 | ||
20 | (define-module (test-suite test-rnrs-conditions) | |
c0f6c163 | 21 | :use-module ((rnrs base) :version (6)) |
2359a9a4 JG |
22 | :use-module ((rnrs conditions) :version (6)) |
23 | :use-module (test-suite lib)) | |
24 | ||
00f79aa4 JG |
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)) | |
c0f6c163 AR |
27 | (define-condition-type &c &condition make-c-condition c-condition? |
28 | (baz c-baz) | |
29 | (qux c-qux) | |
30 | (frobotz c-frobotz)) | |
00f79aa4 | 31 | |
2359a9a4 JG |
32 | (with-test-prefix "condition?" |
33 | (pass-if "condition? is #t for simple conditions" | |
34 | (condition? (make-error))) | |
35 | ||
36 | (pass-if "condition? is #t for compound conditions" | |
37 | (condition? (condition (make-error) (make-assertion-violation)))) | |
38 | ||
39 | (pass-if "condition? is #f for non-conditions" | |
40 | (not (condition? 'foo)))) | |
41 | ||
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)))) | |
49 | ||
50 | (pass-if "simple-conditions flattens compound conditions" | |
51 | (let* ((implementation-restriction | |
52 | (make-implementation-restriction-violation)) | |
53 | (error1 (make-error)) | |
54 | (c1 (condition implementation-restriction error1)) | |
55 | (error2 (make-error)) | |
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))))) | |
60 | ||
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"))) | |
65 | (mp mc))) | |
66 | ||
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)) | |
71 | (vc (make-violation)) | |
72 | (c (condition sc vc))) | |
73 | (and (sp c) (vp c)))) | |
74 | ||
75 | (pass-if "returned procedure is #f for non-matching simple" | |
76 | (let ((sp (condition-predicate &serious))) | |
77 | (not (sp 'foo)))) | |
78 | ||
79 | (pass-if "returned procedure is #f for compound without match" | |
80 | (let* ((ip (condition-predicate &irritants)) | |
81 | (sc (make-serious-condition)) | |
82 | (vc (make-violation)) | |
83 | (c (condition sc vc))) | |
84 | (not (ip c))))) | |
85 | ||
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"))) | |
92 | ||
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")) | |
97 | (vc (make-violation)) | |
98 | (c (condition vc mc))) | |
99 | (equal? (ma c) "foo")))) | |
00f79aa4 JG |
100 | |
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)))) | |
c0f6c163 AR |
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) | |
109 | (= (c-baz c) 1) | |
110 | (= (c-qux c) 2) | |
111 | (= (c-frobotz c) 3))))) |