1 ;;;; srfi-35.test --- SRFI-35. -*- mode: scheme; coding: utf-8; -*-
2 ;;;; Ludovic Courtès <ludo@gnu.org>
4 ;;;; Copyright (C) 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
6 ;;;; This library is free software; you can redistribute it and/or
7 ;;;; modify it under the terms of the GNU Lesser General Public
8 ;;;; License as published by the Free Software Foundation; either
9 ;;;; version 3 of the License, or (at your option) any later version.
11 ;;;; This library 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 GNU
14 ;;;; Lesser General Public License for more details.
16 ;;;; You should have received a copy of the GNU Lesser General Public
17 ;;;; License along with this library; if not, write to the Free Software
18 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
20 (define-module (test-srfi-35)
21 :use-module (test-suite lib)
22 :use-module (srfi srfi-35))
25 (with-test-prefix "cond-expand"
27 (cond-expand (srfi-35 #t)
31 (with-test-prefix "condition types"
33 (condition-type? &condition))
35 (pass-if "make-condition-type"
36 (condition-type? (make-condition-type 'foo &condition '(a b))))
38 (pass-if "struct-vtable-name"
39 (let ((ct (make-condition-type 'chbouib &condition '(a b))))
40 (eq? 'chbouib (struct-vtable-name ct)))))
44 (with-test-prefix "conditions"
47 (let ((c (make-condition &condition)))
49 (condition-has-type? c &condition))))
51 (pass-if "simple condition"
52 (let* ((ct (make-condition-type 'chbouib &condition '(a b)))
53 (c (make-condition ct 'b 1 'a 0)))
55 (condition-has-type? c ct))))
57 (pass-if "simple condition with inheritance"
58 (let* ((top (make-condition-type 'foo &condition '(a b)))
59 (ct (make-condition-type 'bar top '(c d)))
60 (c (make-condition ct 'a 1 'b 2 'c 3 'd 4)))
62 (condition-has-type? c ct)
63 (condition-has-type? c top))))
65 (pass-if "condition-ref"
66 (let* ((ct (make-condition-type 'chbouib &condition '(a b)))
67 (c (make-condition ct 'b 1 'a 0)))
68 (and (eqv? (condition-ref c 'a) 0)
69 (eqv? (condition-ref c 'b) 1))))
71 (pass-if "condition-ref with inheritance"
72 (let* ((top (make-condition-type 'foo &condition '(a b)))
73 (ct (make-condition-type 'bar top '(c d)))
74 (c (make-condition ct 'b 1 'a 0 'd 3 'c 2)))
75 (and (eqv? (condition-ref c 'a) 0)
76 (eqv? (condition-ref c 'b) 1)
77 (eqv? (condition-ref c 'c) 2)
78 (eqv? (condition-ref c 'd) 3))))
80 (pass-if "extract-condition"
81 (let* ((ct (make-condition-type 'chbouib &condition '(a b)))
82 (c (make-condition ct 'b 1 'a 0)))
83 (equal? c (extract-condition c ct)))))
86 (with-test-prefix "compound conditions"
87 (pass-if "condition-has-type?"
88 (let* ((t1 (make-condition-type 'foo &condition '(a b)))
89 (t2 (make-condition-type 'bar &condition '(c d)))
90 (c1 (make-condition t1 'a 0 'b 1))
91 (c2 (make-condition t2 'c 2 'd 3))
92 (c (make-compound-condition c1 c2)))
94 (condition-has-type? c t1)
95 (condition-has-type? c t2))))
97 (pass-if "condition-ref"
98 (let* ((t1 (make-condition-type 'foo &condition '(a b)))
99 (t2 (make-condition-type 'bar &condition '(c d)))
100 (c1 (make-condition t1 'a 0 'b 1))
101 (c2 (make-condition t2 'c 2 'd 3))
102 (c (make-compound-condition c1 c2)))
103 (equal? (map (lambda (field)
104 (condition-ref c field))
108 (pass-if "condition-ref with same-named fields"
109 (let* ((t1 (make-condition-type 'foo &condition '(a b)))
110 (t2 (make-condition-type 'bar &condition '(a c d)))
111 (c1 (make-condition t1 'a 0 'b 1))
112 (c2 (make-condition t2 'a -1 'c 2 'd 3))
113 (c (make-compound-condition c1 c2)))
114 (equal? (map (lambda (field)
115 (condition-ref c field))
119 (pass-if "extract-condition"
120 (let* ((t1 (make-condition-type 'foo &condition '(a b)))
121 (t2 (make-condition-type 'bar &condition '(c d)))
122 (c1 (make-condition t1 'a 0 'b 1))
123 (c2 (make-condition t2 'c 2 'd 3))
124 (c (make-compound-condition c1 c2)))
125 (and (equal? c1 (extract-condition c t1))
126 (equal? c2 (extract-condition c t2)))))
128 (pass-if "extract-condition with same-named fields"
129 (let* ((t1 (make-condition-type 'foo &condition '(a b)))
130 (t2 (make-condition-type 'bar &condition '(a c)))
131 (c1 (make-condition t1 'a 0 'b 1))
132 (c2 (make-condition t2 'a -1 'c 2))
133 (c (make-compound-condition c1 c2)))
134 (and (equal? c1 (extract-condition c t1))
135 (equal? c2 (extract-condition c t2))))))
139 (with-test-prefix "syntax"
140 (pass-if "define-condition-type"
141 (let ((m (current-module)))
142 (eval '(define-condition-type &chbouib &condition
147 (eval '(and (condition-type? &chbouib)
148 (procedure? chbouib?)
149 (let ((c (make-condition &chbouib 'one 1 'two 2)))
152 (eqv? (chbouib-one c) 1)
153 (eqv? (chbouib-two c) 2))))
157 (let* ((t (make-condition-type 'chbouib &condition '(a b)))
158 (c (condition (t (b 2) (a 1)))))
160 (condition-has-type? c t)
161 (equal? (map (lambda (f)
166 (pass-if-exception "condition with missing fields"
167 exception:miscellaneous-error
168 (let ((t (make-condition-type 'chbouib &condition '(a b c))))
169 (condition (t (a 1) (b 2)))))
171 (pass-if "compound condition"
172 (let* ((t1 (make-condition-type 'foo &condition '(a b)))
173 (t2 (make-condition-type 'bar &condition '(c d)))
174 (c1 (make-condition t1 'a 0 'b 1))
175 (c2 (make-condition t2 'c 2 'd 3))
176 (c (condition (t1 (a 0) (b 1))
178 (and (equal? c1 (extract-condition c t1))
179 (equal? c2 (extract-condition c t2))))))
183 ;;; Examples from the SRFI.
186 (define-condition-type &c &condition
190 (define-condition-type &c1 &c
194 (define-condition-type &c2 &c
199 (make-condition &c1 'x "V1" 'a "a1"))
202 (condition (&c2 (x "V2") (b "b2"))))
205 (condition (&c1 (x "V3/1") (a "a3"))
209 (make-compound-condition v1 v2))
212 (make-compound-condition v2 v3))
215 (with-test-prefix "examples"
226 (pass-if "(not (c2? v1))"
230 (equal? (c-x v1) "V1"))
233 (equal? (c1-a v1) "a1"))
245 (pass-if "(not (c1? v2))"
249 (equal? (c-x v2) "V2"))
252 (equal? (c2-b v2) "b2"))
268 (equal? (c-x v3) "V3/1"))
271 (equal? (c1-a v3) "a3"))
274 (equal? (c2-b v3) "b3"))
290 (equal? (c-x v4) "V1"))
293 (equal? (c1-a v4) "a1"))
296 (equal? (c2-b v4) "b2"))
312 (equal? (c-x v5) "V2"))
315 (equal? (c1-a v5) "a3"))
318 (equal? (c2-b v5) "b2")))