1;;  Filename : test-srfi9.scm
2;;  About    : unit tests for SRFI-9
3;;
4;;  Copyright (c) 2007-2008 SigScheme Project <uim-en AT googlegroups.com>
5;;
6;;  All rights reserved.
7;;
8;;  Redistribution and use in source and binary forms, with or without
9;;  modification, are permitted provided that the following conditions
10;;  are met:
11;;
12;;  1. Redistributions of source code must retain the above copyright
13;;     notice, this list of conditions and the following disclaimer.
14;;  2. Redistributions in binary form must reproduce the above copyright
15;;     notice, this list of conditions and the following disclaimer in the
16;;     documentation and/or other materials provided with the distribution.
17;;  3. Neither the name of authors nor the names of its contributors
18;;     may be used to endorse or promote products derived from this software
19;;     without specific prior written permission.
20;;
21;;  THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS
22;;  IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
23;;  THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
24;;  PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
25;;  CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
26;;  EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
27;;  PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
28;;  PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
29;;  LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
30;;  NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
31;;  SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
32
33(define orig-vector? vector?)
34(define orig-eval    eval)
35
36(require-extension (unittest) (srfi 9))
37
38
39(test-begin "SRFI-9 overridden R5RS procedures")
40(test-false (eq? vector? orig-vector?))
41(cond-expand
42 (sigscheme
43  (test-true  (eq? eval orig-eval)))
44 (else
45  (test-false (eq? eval orig-eval))))
46(test-eq    #t (vector? (vector)))
47(test-eq    #f (vector? (list)))
48;; Overridden 'eval' must be capable of (interaction-environment).
49(test-read-eval-string "(define foo 3)")
50;; Original reference implementation of SRFI-9 lacks environment argument
51;; handling.
52(test-error (eval '(+ 2 3)))
53(test-eqv   5 (eval '(+ 2 3) (interaction-environment)))
54;; 'vector? must be evaluated to the redefined vector?.
55(test-eq    vector? (eval 'vector? (interaction-environment)))
56(test-end)
57
58(test-begin "SRFI-9 invalid forms")
59;; invalid definition placement
60(test-error (if #t (define-record-type my-rec (make-my-rec) my-rec?)))
61(test-error (test-read-eval-string
62             "(if #t (define-record-type my-rec (make-my-rec) my-rec?))"))
63;; invalid record names
64(test-error (define-record-type 'my-rec (make-my-rec) my-rec?))
65(test-error (define-record-type "my-rec" (make-my-rec) my-rec?))
66;; invalid predicate names
67(test-error (define-record-type my-rec (make-my-rec) 'my-rec?))
68(test-error (define-record-type my-rec (make-my-rec) "my-rec?"))
69;; invalid constructor
70(test-error (define-record-type my-rec make-my-rec my-rec?))
71(test-error (define-record-type my-rec '(make-my-rec) my-rec?))
72(test-error (define-record-type my-rec (list make-my-rec) my-rec?))
73(test-error (define-record-type my-rec (list 'make-my-rec) my-rec?))
74(test-error (define-record-type my-rec #(make-my-rec) my-rec?))
75(test-error (define-record-type my-rec '#(make-my-rec) my-rec?))
76;; non-existent field name in constructor
77(test-error (define-record-type my-rec (make-my-rec x) my-rec?))
78;; without accessor
79(test-error (define-record-type my-rec (make-my-rec x) my-rec?
80              (x)))
81(test-end)
82
83(test-begin "SRFI-9 no-field record")
84(test-false (symbol-bound? 'make-my-null))
85(test-false (symbol-bound? 'my-null?))
86(test-eq    (undef)
87            (define-record-type my-null (make-my-null) my-null?))
88(test-true  (procedure? make-my-null))
89(test-true  (procedure? my-null?))
90(test-error (make-my-null 0))
91(test-eq    #t (record? (make-my-null)))
92(test-true  (not (vector? (make-my-null))))
93(test-eq    #t (my-null? (make-my-null)))
94(test-false (my-null? (vector)))
95(test-end)
96
97(test-begin "SRFI-9 2-field record")
98(define x (list 'x))
99(define y (list 'y))
100(define z (list 'z))
101(test-false (symbol-bound? 'make-my-pair))
102(test-false (symbol-bound? 'my-pair?))
103(test-false (symbol-bound? 'my-pair-kar))
104(test-false (symbol-bound? 'my-pair-kdr))
105(test-false (symbol-bound? 'my-pair-set-kar!))
106(test-false (symbol-bound? 'my-pair-set-kdr!))
107(test-eq    (undef)
108            (define-record-type my-pair (make-my-pair kar kdr) my-pair?
109              (kar my-pair-kar my-pair-set-kar!)
110              (kdr my-pair-kdr my-pair-set-kdr!)))
111(test-true  (procedure? make-my-pair))
112(test-true  (procedure? my-pair?))
113(test-true  (procedure? my-pair-kar))
114(test-true  (procedure? my-pair-kdr))
115(test-true  (procedure? my-pair-set-kar!))
116(test-true  (procedure? my-pair-set-kdr!))
117(test-error (make-my-pair))
118(test-error (make-my-pair x))
119(test-error (make-my-pair x y z))
120(test-eq    #t (record? (make-my-pair x y)))
121(test-true  (not (vector? (make-my-pair x y))))
122(test-eq    #t (my-pair? (make-my-pair x y)))
123(test-false (my-pair? (vector x y)))
124(test-false (my-pair? (make-my-null)))
125(test-eq    x (my-pair-kar (make-my-pair x y)))
126(test-eq    y (my-pair-kdr (make-my-pair x y)))
127(define foo (make-my-pair x y))
128(test-eq    x (my-pair-kar foo))
129(test-eq    y (my-pair-kdr foo))
130(test-eq    (undef) (my-pair-set-kar! foo z))
131(test-eq    z (my-pair-kar foo))
132(test-eq    y (my-pair-kdr foo))
133(test-eq    (undef) (my-pair-set-kdr! foo x))
134(test-eq    z (my-pair-kar foo))
135(test-eq    x (my-pair-kdr foo))
136(test-end)
137
138(test-begin "SRFI-9 2-field record with swapped constructor tags")
139(define x (list 'x))
140(define y (list 'y))
141(define z (list 'z))
142(test-false (symbol-bound? 'make-my-pair2))
143(test-false (symbol-bound? 'my-pair2?))
144(test-false (symbol-bound? 'my-pair2-kar))
145(test-false (symbol-bound? 'my-pair2-kdr))
146(test-false (symbol-bound? 'my-pair2-set-kar!))
147(test-false (symbol-bound? 'my-pair2-set-kdr!))
148(test-eq    (undef)
149            (define-record-type my-pair2 (make-my-pair2 kdr kar) my-pair2?
150              (kar my-pair2-kar my-pair2-set-kar!)
151              (kdr my-pair2-kdr my-pair2-set-kdr!)))
152(test-true  (procedure? make-my-pair2))
153(test-true  (procedure? my-pair2?))
154(test-true  (procedure? my-pair2-kar))
155(test-true  (procedure? my-pair2-kdr))
156(test-true  (procedure? my-pair2-set-kar!))
157(test-true  (procedure? my-pair2-set-kdr!))
158(test-error (make-my-pair2))
159(test-error (make-my-pair2 x))
160(test-error (make-my-pair2 x y z))
161(test-eq    #t (record? (make-my-pair2 x y)))
162(test-true  (not (vector? (make-my-pair2 x y))))
163(test-eq    #t (my-pair2? (make-my-pair2 x y)))
164(test-false (my-pair2? (vector x y)))
165(test-eq    y (my-pair2-kar (make-my-pair2 x y)))
166(test-eq    x (my-pair2-kdr (make-my-pair2 x y)))
167(define foo (make-my-pair2 x y))
168(test-eq    y (my-pair2-kar foo))
169(test-eq    x (my-pair2-kdr foo))
170(test-eq    (undef) (my-pair2-set-kar! foo z))
171(test-eq    z (my-pair2-kar foo))
172(test-eq    x (my-pair2-kdr foo))
173(test-eq    (undef) (my-pair2-set-kdr! foo y))
174(test-eq    z (my-pair2-kar foo))
175(test-eq    y (my-pair2-kdr foo))
176(test-end)
177
178(test-begin "SRFI-9 2-field record with partial constructor tags")
179(define x (list 'x))
180(define y (list 'y))
181(define z (list 'z))
182(test-false (symbol-bound? 'make-my-pair3))
183(test-false (symbol-bound? 'my-pair3?))
184(test-false (symbol-bound? 'my-pair3-kar))
185(test-false (symbol-bound? 'my-pair3-kdr))
186(test-false (symbol-bound? 'my-pair3-set-kar!))
187(test-false (symbol-bound? 'my-pair3-set-kdr!))
188(test-eq    (undef)
189            (define-record-type my-pair3 (make-my-pair3 kdr) my-pair3?
190              (kar my-pair3-kar my-pair3-set-kar!)
191              (kdr my-pair3-kdr my-pair3-set-kdr!)))
192(test-true  (procedure? make-my-pair3))
193(test-true  (procedure? my-pair3?))
194(test-true  (procedure? my-pair3-kar))
195(test-true  (procedure? my-pair3-kdr))
196(test-true  (procedure? my-pair3-set-kar!))
197(test-true  (procedure? my-pair3-set-kdr!))
198(test-error (make-my-pair3))
199(test-error (make-my-pair3 x y))
200(test-error (make-my-pair3 x y z))
201(test-eq    #t (record? (make-my-pair3 x)))
202(test-true  (not (vector? (make-my-pair3 x))))
203(test-eq    #t (my-pair3? (make-my-pair3 x)))
204(test-false (my-pair3? (vector x y)))
205(test-false (my-pair3? (make-my-null)))
206(test-eq    (undef) (my-pair3-kar (make-my-pair3 x)))
207(test-eq    x       (my-pair3-kdr (make-my-pair3 x)))
208(define foo (make-my-pair3 x))
209(test-eq    (undef) (my-pair3-kar foo))
210(test-eq    x       (my-pair3-kdr foo))
211(test-eq    (undef) (my-pair3-set-kar! foo z))
212(test-eq    z (my-pair3-kar foo))
213(test-eq    x (my-pair3-kdr foo))
214(test-eq    (undef) (my-pair3-set-kdr! foo y))
215(test-eq    z (my-pair3-kar foo))
216(test-eq    y (my-pair3-kdr foo))
217(test-end)
218
219(test-begin "SRFI-9 2-field record without constructor tags")
220(define x (list 'x))
221(define y (list 'y))
222(define z (list 'z))
223(test-false (symbol-bound? 'make-my-pair4))
224(test-false (symbol-bound? 'my-pair4?))
225(test-false (symbol-bound? 'my-pair4-kar))
226(test-false (symbol-bound? 'my-pair4-kdr))
227(test-false (symbol-bound? 'my-pair4-set-kar!))
228(test-false (symbol-bound? 'my-pair4-set-kdr!))
229(test-eq    (undef)
230            (define-record-type my-pair4 (make-my-pair4) my-pair4?
231              (kar my-pair4-kar my-pair4-set-kar!)
232              (kdr my-pair4-kdr my-pair4-set-kdr!)))
233(test-true  (procedure? make-my-pair4))
234(test-true  (procedure? my-pair4?))
235(test-true  (procedure? my-pair4-kar))
236(test-true  (procedure? my-pair4-kdr))
237(test-true  (procedure? my-pair4-set-kar!))
238(test-true  (procedure? my-pair4-set-kdr!))
239(test-error (make-my-pair4 x))
240(test-error (make-my-pair4 x y))
241(test-error (make-my-pair4 x y z))
242(test-eq    #t (record? (make-my-pair4)))
243(test-true  (not (vector? (make-my-pair4))))
244(test-eq    #t (my-pair4? (make-my-pair4)))
245(test-false (my-pair4? (vector x y)))
246(test-eq    (undef) (my-pair4-kar (make-my-pair4)))
247(test-eq    (undef) (my-pair4-kdr (make-my-pair4)))
248(define foo (make-my-pair4))
249(test-eq    (undef) (my-pair4-kar foo))
250(test-eq    (undef) (my-pair4-kdr foo))
251(test-eq    (undef) (my-pair4-set-kar! foo z))
252(test-eq    z       (my-pair4-kar foo))
253(test-eq    (undef) (my-pair4-kdr foo))
254(test-eq    (undef) (my-pair4-set-kdr! foo x))
255(test-eq    z       (my-pair4-kar foo))
256(test-eq    x       (my-pair4-kdr foo))
257(test-end)
258
259(test-begin "SRFI-9 2-field record without modifiers")
260(test-false (symbol-bound? 'make-my-pair5))
261(test-false (symbol-bound? 'my-pair5?))
262(test-false (symbol-bound? 'my-pair5-kar))
263(test-false (symbol-bound? 'my-pair5-kdr))
264(test-eq    (undef)
265            (define-record-type my-pair5 (make-my-pair5 kar kdr) my-pair5?
266              (kar my-pair5-kar)
267              (kdr my-pair5-kdr)))
268(test-true  (procedure? make-my-pair5))
269(test-true  (procedure? my-pair5?))
270(test-true  (procedure? my-pair5-kar))
271(test-true  (procedure? my-pair5-kdr))
272(test-end)
273
274(test-report-result)
275