1 ;;;; srfi-35.test --- Test suite for SRFI-35 -*- Scheme -*-
2 ;;;; Ludovic Courtès <ludo@gnu.org>
4 ;;;; Copyright (C) 2007, 2008, 2009 Free Software Foundation, Inc.
6 ;;;; This program is free software; you can redistribute it and/or modify
7 ;;;; it under the terms of the GNU General Public License as published by
8 ;;;; the Free Software Foundation; either version 2, or (at your option)
9 ;;;; any later version.
11 ;;;; This program is distributed in the hope that it will be useful,
12 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
13 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 ;;;; GNU General Public License for more details.
16 ;;;; You should have received a copy of the GNU General Public License
17 ;;;; along with this software; see the file COPYING. If not, write to
18 ;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
19 ;;;; Boston, MA 02110-1301 USA
21 (define-module (test-srfi-35)
22 :use-module (test-suite lib)
23 :use-module (srfi srfi-35))
26 (with-test-prefix "cond-expand"
28 (cond-expand (srfi-35 #t)
32 (with-test-prefix "condition types"
34 (condition-type? &condition))
36 (pass-if "make-condition-type"
37 (condition-type? (make-condition-type 'foo &condition '(a b))))
39 (pass-if "struct-vtable-name"
40 (let ((ct (make-condition-type 'chbouib &condition '(a b))))
41 (eq? 'chbouib (struct-vtable-name ct)))))
45 (with-test-prefix "conditions"
48 (let ((c (make-condition &condition)))
50 (condition-has-type? c &condition))))
52 (pass-if "simple condition"
53 (let* ((ct (make-condition-type 'chbouib &condition '(a b)))
54 (c (make-condition ct 'b 1 'a 0)))
56 (condition-has-type? c ct))))
58 (pass-if "simple condition with inheritance"
59 (let* ((top (make-condition-type 'foo &condition '(a b)))
60 (ct (make-condition-type 'bar top '(c d)))
61 (c (make-condition ct 'a 1 'b 2 'c 3 'd 4)))
63 (condition-has-type? c ct)
64 (condition-has-type? c top))))
66 (pass-if "condition-ref"
67 (let* ((ct (make-condition-type 'chbouib &condition '(a b)))
68 (c (make-condition ct 'b 1 'a 0)))
69 (and (eq? (condition-ref c 'a) 0)
70 (eq? (condition-ref c 'b) 1))))
72 (pass-if "condition-ref with inheritance"
73 (let* ((top (make-condition-type 'foo &condition '(a b)))
74 (ct (make-condition-type 'bar top '(c d)))
75 (c (make-condition ct 'b 1 'a 0 'd 3 'c 2)))
76 (and (eq? (condition-ref c 'a) 0)
77 (eq? (condition-ref c 'b) 1)
78 (eq? (condition-ref c 'c) 2)
79 (eq? (condition-ref c 'd) 3))))
81 (pass-if "extract-condition"
82 (let* ((ct (make-condition-type 'chbouib &condition '(a b)))
83 (c (make-condition ct 'b 1 'a 0)))
84 (equal? c (extract-condition c ct)))))
87 (with-test-prefix "compound conditions"
88 (pass-if "condition-has-type?"
89 (let* ((t1 (make-condition-type 'foo &condition '(a b)))
90 (t2 (make-condition-type 'bar &condition '(c d)))
91 (c1 (make-condition t1 'a 0 'b 1))
92 (c2 (make-condition t2 'c 2 'd 3))
93 (c (make-compound-condition c1 c2)))
95 (condition-has-type? c t1)
96 (condition-has-type? c t2))))
98 (pass-if "condition-ref"
99 (let* ((t1 (make-condition-type 'foo &condition '(a b)))
100 (t2 (make-condition-type 'bar &condition '(c d)))
101 (c1 (make-condition t1 'a 0 'b 1))
102 (c2 (make-condition t2 'c 2 'd 3))
103 (c (make-compound-condition c1 c2)))
104 (equal? (map (lambda (field)
105 (condition-ref c field))
109 (pass-if "condition-ref with same-named fields"
110 (let* ((t1 (make-condition-type 'foo &condition '(a b)))
111 (t2 (make-condition-type 'bar &condition '(a c d)))
112 (c1 (make-condition t1 'a 0 'b 1))
113 (c2 (make-condition t2 'a -1 'c 2 'd 3))
114 (c (make-compound-condition c1 c2)))
115 (equal? (map (lambda (field)
116 (condition-ref c field))
120 (pass-if "extract-condition"
121 (let* ((t1 (make-condition-type 'foo &condition '(a b)))
122 (t2 (make-condition-type 'bar &condition '(c d)))
123 (c1 (make-condition t1 'a 0 'b 1))
124 (c2 (make-condition t2 'c 2 'd 3))
125 (c (make-compound-condition c1 c2)))
126 (and (equal? c1 (extract-condition c t1))
127 (equal? c2 (extract-condition c t2)))))
129 (pass-if "extract-condition with same-named fields"
130 (let* ((t1 (make-condition-type 'foo &condition '(a b)))
131 (t2 (make-condition-type 'bar &condition '(a c)))
132 (c1 (make-condition t1 'a 0 'b 1))
133 (c2 (make-condition t2 'a -1 'c 2))
134 (c (make-compound-condition c1 c2)))
135 (and (equal? c1 (extract-condition c t1))
136 (equal? c2 (extract-condition c t2))))))
140 (with-test-prefix "syntax"
141 (pass-if "define-condition-type"
142 (let ((m (current-module)))
143 (eval '(define-condition-type &chbouib &condition
148 (eval '(and (condition-type? &chbouib)
149 (procedure? chbouib?)
150 (let ((c (make-condition &chbouib 'one 1 'two 2)))
153 (eq? (chbouib-one c) 1)
154 (eq? (chbouib-two c) 2))))
158 (let* ((t (make-condition-type 'chbouib &condition '(a b)))
159 (c (condition (t (b 2) (a 1)))))
161 (condition-has-type? c t)
162 (equal? (map (lambda (f)
167 (pass-if-exception "condition with missing fields"
168 exception:miscellaneous-error
169 (let ((t (make-condition-type 'chbouib &condition '(a b c))))
170 (condition (t (a 1) (b 2)))))
172 (pass-if "compound condition"
173 (let* ((t1 (make-condition-type 'foo &condition '(a b)))
174 (t2 (make-condition-type 'bar &condition '(c d)))
175 (c1 (make-condition t1 'a 0 'b 1))
176 (c2 (make-condition t2 'c 2 'd 3))
177 (c (condition (t1 (a 0) (b 1))
179 (and (equal? c1 (extract-condition c t1))
180 (equal? c2 (extract-condition c t2))))))
184 ;;; Examples from the SRFI.
187 (define-condition-type &c &condition
191 (define-condition-type &c1 &c
195 (define-condition-type &c2 &c
200 (make-condition &c1 'x "V1" 'a "a1"))
203 (condition (&c2 (x "V2") (b "b2"))))
206 (condition (&c1 (x "V3/1") (a "a3"))
210 (make-compound-condition v1 v2))
213 (make-compound-condition v2 v3))
216 (with-test-prefix "examples"
227 (pass-if "(not (c2? v1))"
231 (equal? (c-x v1) "V1"))
234 (equal? (c1-a v1) "a1"))
246 (pass-if "(not (c1? v2))"
250 (equal? (c-x v2) "V2"))
253 (equal? (c2-b v2) "b2"))
269 (equal? (c-x v3) "V3/1"))
272 (equal? (c1-a v3) "a3"))
275 (equal? (c2-b v3) "b3"))
291 (equal? (c-x v4) "V1"))
294 (equal? (c1-a v4) "a1"))
297 (equal? (c2-b v4) "b2"))
313 (equal? (c-x v5) "V2"))
316 (equal? (c1-a v5) "a3"))
319 (equal? (c2-b v5) "b2")))