1#! /usr/bin/env sscm -C UTF-8
2;; -*- buffer-file-coding-system: utf-8 -*-
3
4;;  Filename : test-list.scm
5;;  About    : unit test for list operations
6;;
7;;  Copyright (C) 2005-2006 Kazuki Ohta <mover AT hct.zaq.ne.jp>
8;;  Copyright (c) 2007-2008 SigScheme Project <uim-en AT googlegroups.com>
9;;
10;;  All rights reserved.
11;;
12;;  Redistribution and use in source and binary forms, with or without
13;;  modification, are permitted provided that the following conditions
14;;  are met:
15;;
16;;  1. Redistributions of source code must retain the above copyright
17;;     notice, this list of conditions and the following disclaimer.
18;;  2. Redistributions in binary form must reproduce the above copyright
19;;     notice, this list of conditions and the following disclaimer in the
20;;     documentation and/or other materials provided with the distribution.
21;;  3. Neither the name of authors nor the names of its contributors
22;;     may be used to endorse or promote products derived from this software
23;;     without specific prior written permission.
24;;
25;;  THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS
26;;  IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
27;;  THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
28;;  PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
29;;  CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
30;;  EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
31;;  PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
32;;  PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
33;;  LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
34;;  NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
35;;  SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
36
37(require-extension (unittest))
38
39(define tn test-name)
40
41(define elm0 (list #t))
42(define elm1 (list #t))
43(define elm2 (list #t))
44(define elm3 (list #t))
45(define nil  '())
46(define cdr3 (cons elm3 nil))
47(define cdr2 (cons elm2 cdr3))
48(define cdr1 (cons elm1 cdr2))
49(define cdr0 (cons elm0 cdr1))
50(define lst cdr0)
51;; circular lists
52(define clst1 (list 1))
53(set-cdr! clst1 clst1)
54(define clst2 (list 1 2))
55(set-cdr! (list-tail clst2 1) clst2)
56(define clst3 (list 1 2 3))
57(set-cdr! (list-tail clst3 2) clst3)
58(define clst4 (list 1 2 3 4))
59(set-cdr! (list-tail clst4 3) clst4)
60
61
62(tn "null?")
63(if (and (provided? "sigscheme")
64         (provided? "siod-bugs"))
65    (assert-eq? (tn) #t (null? #f))
66    (assert-eq? (tn) #f (null? #f)))
67(assert-eq? (tn) #f (null? #t))
68(assert-eq? (tn) #t (null? '()))
69(if (provided? "sigscheme")
70    (begin
71      (assert-eq? (tn) #f (null? (eof)))
72      (assert-eq? (tn) #f (null? (undef)))))
73(assert-eq? (tn) #f (null? 0))
74(assert-eq? (tn) #f (null? 1))
75(assert-eq? (tn) #f (null? 3))
76(assert-eq? (tn) #f (null? -1))
77(assert-eq? (tn) #f (null? -3))
78(assert-eq? (tn) #f (null? 'symbol))
79(assert-eq? (tn) #f (null? 'SYMBOL))
80(assert-eq? (tn) #f (null? #\a))
81(assert-eq? (tn) #f (null? #\あ))
82(assert-eq? (tn) #f (null? ""))
83(assert-eq? (tn) #f (null? " "))
84(assert-eq? (tn) #f (null? "a"))
85(assert-eq? (tn) #f (null? "A"))
86(assert-eq? (tn) #f (null? "aBc12!"))
87(assert-eq? (tn) #f (null? "あ"))
88(assert-eq? (tn) #f (null? "あ0イう12!"))
89(assert-eq? (tn) #f (null? +))
90(assert-eq? (tn) #f (null? (lambda () #t)))
91
92;; syntactic keywords should not be appeared as operand
93(if sigscheme?
94    (begin
95      ;; pure syntactic keyword
96      (assert-error (tn) (lambda () (null? else)))
97      ;; expression keyword
98      (assert-error (tn) (lambda () (null? do)))))
99
100(call-with-current-continuation
101 (lambda (k)
102   (assert-eq? (tn) #f (null? k))))
103(assert-eq? (tn) #f (null? (current-output-port)))
104(assert-eq? (tn) #f (null? '(#t . #t)))
105(assert-eq? (tn) #f (null? (cons #t #t)))
106(assert-eq? (tn) #f (null? '(0 1 2)))
107(assert-eq? (tn) #f (null? (list 0 1 2)))
108;; improper lists
109(assert-eq? (tn) #f (null? '(0 . 1)))
110(assert-eq? (tn) #f (null? '(0 1 . 2)))
111(assert-eq? (tn) #f (null? '(0 1 2 . 3)))
112;; circular lists
113(assert-eq? (tn) #f (null? clst1))
114(assert-eq? (tn) #f (null? clst2))
115(assert-eq? (tn) #f (null? clst3))
116(assert-eq? (tn) #f (null? clst4))
117(assert-eq? (tn) #f (null? '#()))
118(assert-eq? (tn) #f (null? (vector)))
119(assert-eq? (tn) #f (null? '#(0 1 2)))
120(assert-eq? (tn) #f (null? (vector 0 1 2)))
121
122(tn "list?")
123(if (and (provided? "sigscheme")
124         (provided? "siod-bugs"))
125    (assert-eq? (tn) #t (list? #f))
126    (assert-eq? (tn) #f (list? #f)))
127(assert-eq? (tn) #f (list? #t))
128(assert-eq? (tn) #t (list? '()))
129(if (provided? "sigscheme")
130    (begin
131      (assert-eq? (tn) #f (list? (eof)))
132      (assert-eq? (tn) #f (list? (undef)))))
133(assert-eq? (tn) #f (list? 0))
134(assert-eq? (tn) #f (list? 1))
135(assert-eq? (tn) #f (list? 3))
136(assert-eq? (tn) #f (list? -1))
137(assert-eq? (tn) #f (list? -3))
138(assert-eq? (tn) #f (list? 'symbol))
139(assert-eq? (tn) #f (list? 'SYMBOL))
140(assert-eq? (tn) #f (list? #\a))
141(assert-eq? (tn) #f (list? #\あ))
142(assert-eq? (tn) #f (list? ""))
143(assert-eq? (tn) #f (list? " "))
144(assert-eq? (tn) #f (list? "a"))
145(assert-eq? (tn) #f (list? "A"))
146(assert-eq? (tn) #f (list? "aBc12!"))
147(assert-eq? (tn) #f (list? "あ"))
148(assert-eq? (tn) #f (list? "あ0イう12!"))
149(assert-eq? (tn) #f (list? +))
150(assert-eq? (tn) #f (list? (lambda () #t)))
151
152;; syntactic keywords should not be appeared as operand
153(if sigscheme?
154    (begin
155      ;; pure syntactic keyword
156      (assert-error (tn) (lambda () (list? else)))
157      ;; expression keyword
158      (assert-error (tn) (lambda () (list? do)))))
159
160(call-with-current-continuation
161 (lambda (k)
162   (assert-eq? (tn) #f (list? k))))
163(assert-eq? (tn) #f (list? (current-output-port)))
164(assert-eq? (tn) #f (list? '(#t . #t)))
165(assert-eq? (tn) #f (list? (cons #t #t)))
166(assert-eq? (tn) #t (list? '(0 1 2)))
167(assert-eq? (tn) #t (list? (list 0 1 2)))
168;; improper lists
169(assert-eq? (tn) #f (list? '(0 . 1)))
170(assert-eq? (tn) #f (list? '(0 1 . 2)))
171(assert-eq? (tn) #f (list? '(0 1 2 . 3)))
172;; circular lists
173(assert-eq? (tn) #f (list? clst1))
174(assert-eq? (tn) #f (list? clst2))
175(assert-eq? (tn) #f (list? clst3))
176(assert-eq? (tn) #f (list? clst4))
177(assert-eq? (tn) #f (list? '#()))
178(assert-eq? (tn) #f (list? (vector)))
179(assert-eq? (tn) #f (list? '#(0 1 2)))
180(assert-eq? (tn) #f (list? (vector 0 1 2)))
181
182(tn "list? from R5RS examples")
183(assert-eq? (tn) #t (list? '(a b c)))
184(assert-eq? (tn) #t (list? '()))
185(assert-eq? (tn) #f (list? '(a . b)))
186(assert-eq? (tn) #f (list? '(a b . c)))
187(assert-eq? (tn) #f (let ((x (list 'a)))
188                      (set-cdr! x x)
189                      (list? x)))
190
191(tn "list")
192(assert-equal? (tn) '() (list))
193(assert-equal? (tn) '(a) (list 'a))
194(assert-equal? (tn) '(7) (list (+ 3 4)))
195(assert-equal? (tn) '(7 a c) (list (+ 3 4) 'a 'c))
196(assert-equal? (tn) '(a 7 c) (list 'a (+ 3 4) 'c))
197(assert-equal? (tn) '(a c 7) (list 'a 'c (+ 3 4)))
198(assert-error  (tn) (lambda () (list . 0)))
199(assert-error  (tn) (lambda () (list 0 . 1)))
200
201(tn "length proper lists")
202(assert-equal? (tn) 0 (length '()))
203(assert-equal? (tn) 1 (length '(1)))
204(assert-equal? (tn) 2 (length '(1 2)))
205(assert-equal? (tn) 3 (length '(1 2 3)))
206(assert-equal? (tn) 4 (length '(1 2 3 4)))
207(tn "length improper lists")
208(assert-error  (tn) (lambda () (length #t)))
209(assert-error  (tn) (lambda () (length '(#t . #t))))
210(assert-error  (tn) (lambda () (length '(#t #t . #t))))
211(assert-error  (tn) (lambda () (length '(#t #t #t . #t))))
212(assert-error  (tn) (lambda () (length '(#t #t #t #t . #t))))
213(assert-error  (tn) (lambda () (length 0)))
214(assert-error  (tn) (lambda () (length '(1 . 2))))
215(assert-error  (tn) (lambda () (length '(1 2 . 3))))
216(assert-error  (tn) (lambda () (length '(1 2 3 . 4))))
217(assert-error  (tn) (lambda () (length '(1 2 3 4 . 5))))
218(tn "length circular lists")
219(assert-error  (tn) (lambda () (length clst1)))
220(assert-error  (tn) (lambda () (length clst2)))
221(assert-error  (tn) (lambda () (length clst3)))
222(assert-error  (tn) (lambda () (length clst4)))
223(tn "length from R5RS examples")
224(assert-equal? (tn) 3 (length '(a b c)))
225(assert-equal? (tn) 3 (length '(a (b) (c d e))))
226(assert-equal? (tn) 0 (length '()))
227
228(tn "append")
229(assert-equal? (tn) '() (append))
230(assert-equal? (tn) '() (append '()))
231(assert-equal? (tn) '() (append '() '()))
232(assert-equal? (tn) '() (append '() '() '()))
233(assert-equal? (tn) '(a) (append '(a) '() '()))
234(assert-equal? (tn) '(a) (append '() '(a) '()))
235(assert-equal? (tn) '(a) (append '() '() '(a)))
236(assert-equal? (tn) 'a (append 'a))
237(assert-error  (tn) (lambda () (append 'a 'b)))
238(assert-error  (tn) (lambda () (append 'a '(b))))
239(assert-error  (tn) (lambda () (append 'a '())))
240(assert-equal? (tn) '(a . b) (append '(a . b)))
241(assert-error  (tn) (lambda () (append '(a . b) '())))
242(assert-error  (tn) (lambda () (append '() '(a . b) '())))
243(assert-equal? (tn) '(a . b) (append '() '() '(a . b)))
244(assert-equal? (tn) '(1 2 3 a . b) (append '(1) '(2 3) '(a . b)))
245(assert-equal? (tn) 7 (append (+ 3 4)))
246(assert-equal? (tn) '(+ 3 4) (append '(+ 3 4)))
247
248(assert-equal? (tn) '(x y) (append '(x) '(y)))
249(assert-equal? (tn) '(a b c d) (append '(a) '(b c d)))
250(assert-equal? (tn) '(a (b) (c)) (append '(a (b)) '((c))))
251(define w '(n o))
252(define x '(d o))
253(define y '(car))
254(define z '(why))
255(assert-equal? (tn) '(n o d o car why . ta) (append w x y () z 'ta))
256(assert-equal? (tn) '(n o) w)	; test non-destructiveness
257(assert-eq?    (tn) x (cdr (append '((Calpis hosi-)) x))) ; share last
258
259(tn "append from R5RS examples")
260(assert-equal? (tn) '(x y)       (append '(x) '(y)))
261(assert-equal? (tn) '(a b c d)   (append '(a) '(b c d)))
262(assert-equal? (tn) '(a (b) (c)) (append '(a (b)) '((c))))
263(assert-equal? (tn) '(a b c . d) (append '(a b) '(c . d)))
264(assert-equal? (tn) 'a           (append '() 'a))
265
266(tn "reverse")
267(assert-equal? (tn) '() (reverse '()))
268(assert-error  (tn) (lambda () (reverse)))
269(assert-error  (tn) (lambda () (reverse '(a . b))))
270(assert-error  (tn) (lambda () (reverse 'a)))
271(assert-error  (tn) (lambda () (reverse '() '())))
272(assert-error  (tn) (lambda () (reverse '(a) '())))
273(assert-error  (tn) (lambda () (reverse '() '(a))))
274
275(tn "reverse from R5RS examples")
276(assert-equal? (tn) '(c b a) (reverse '(a b c)))
277(assert-equal? (tn) '((e (f)) d (b c) a) (reverse '(a (b c) d (e (f)))))
278
279(tn "list-tail")
280(assert-equal? (tn) '(a b c)   (list-tail '(a b c) 0))
281(assert-equal? (tn) '(b c)     (list-tail '(a b c) 1))
282(assert-equal? (tn) '(c)       (list-tail '(a b c) 2))
283(assert-equal? (tn) '()        (list-tail '(a b c) 3))
284(assert-error  (tn) (lambda () (list-tail '(a b c) 4)))
285(assert-error  (tn) (lambda () (list-tail '(a b c) -1)))
286(assert-equal? (tn) '()        (list-tail '() 0))
287(assert-error  (tn) (lambda () (list-tail '() 1)))
288(assert-error  (tn) (lambda () (list-tail '() -1)))
289(assert-eq?    (tn) cdr0       (list-tail lst 0))
290(assert-eq?    (tn) cdr1       (list-tail lst 1))
291(assert-eq?    (tn) cdr2       (list-tail lst 2))
292(assert-eq?    (tn) cdr3       (list-tail lst 3))
293(assert-eq?    (tn) nil        (list-tail lst 4))
294(assert-error  (tn) (lambda () (list-tail lst 5)))
295(assert-error  (tn) (lambda () (list-tail lst -1)))
296
297(tn "list-tail improper list")
298(assert-equal? (tn) '(a b c . d) (list-tail '(a b c . d) 0))
299(assert-equal? (tn) '(b c . d)   (list-tail '(a b c . d) 1))
300(assert-equal? (tn) '(c . d)     (list-tail '(a b c . d) 2))
301(assert-equal? (tn) 'd           (list-tail '(a b c . d) 3))
302(assert-error  (tn) (lambda ()   (list-tail '(a b c . d) 4)))
303(assert-error  (tn) (lambda ()   (list-tail '(a b c . d) -1)))
304(assert-equal? (tn) 'a           (list-tail 'a 0))
305(assert-error  (tn) (lambda ()   (list-tail 'a 1)))
306(assert-error  (tn) (lambda ()   (list-tail 'a -1)))
307
308(tn "list-ref")
309(assert-equal? (tn) 'a         (list-ref '(a b c d) 0))
310(assert-equal? (tn) 'b         (list-ref '(a b c d) 1))
311(assert-equal? (tn) 'c         (list-ref '(a b c d) 2))
312(assert-equal? (tn) 'd         (list-ref '(a b c d) 3))
313(assert-error  (tn) (lambda () (list-ref '(a b c d) 4)))
314(assert-error  (tn) (lambda () (list-ref '(a b c d) -1)))
315(assert-error  (tn) (lambda () (list-ref '() 0)))
316(assert-error  (tn) (lambda () (list-ref '() 1)))
317(assert-error  (tn) (lambda () (list-ref '() -1)))
318(assert-eq?    (tn) elm0       (list-ref lst 0))
319(assert-eq?    (tn) elm1       (list-ref lst 1))
320(assert-eq?    (tn) elm2       (list-ref lst 2))
321(assert-eq?    (tn) elm3       (list-ref lst 3))
322(assert-error  (tn) (lambda () (list-ref lst 4)))
323(assert-error  (tn) (lambda () (list-ref lst -1)))
324
325(tn "list-ref improper list")
326(assert-equal? (tn) 'a         (list-ref '(a b c . d) 0))
327(assert-equal? (tn) 'b         (list-ref '(a b c . d) 1))
328(assert-equal? (tn) 'c         (list-ref '(a b c . d) 2))
329(assert-error  (tn) (lambda () (list-ref '(a b c . d) 3)))
330(assert-error  (tn) (lambda () (list-ref '(a b c . d) 4)))
331(assert-error  (tn) (lambda () (list-ref '(a b c . d) -1)))
332(assert-error  (tn) (lambda () (list-ref 'a 0)))
333(assert-error  (tn) (lambda () (list-ref 'a 1)))
334(assert-error  (tn) (lambda () (list-ref 'a -1)))
335
336(if sigscheme?
337    (begin
338      (require-extension (sscm-ext))
339      (tn "length* proper list")
340      (assert-equal? (tn) 0 (length* '()))
341      (assert-equal? (tn) 1 (length* '(1)))
342      (assert-equal? (tn) 2 (length* '(1 2)))
343      (assert-equal? (tn) 3 (length* '(1 2 3)))
344      (assert-equal? (tn) 4 (length* '(1 2 3 4)))
345      (tn "length* dotted list")
346      (assert-equal? (tn) -1 (length* 1))
347      (assert-equal? (tn) -2 (length* '(1 . 2)))
348      (assert-equal? (tn) -3 (length* '(1 2 . 3)))
349      (assert-equal? (tn) -4 (length* '(1 2 3 . 4)))
350      (assert-equal? (tn) -5 (length* '(1 2 3 4 . 5)))
351      (tn "length* circular list")
352      (assert-eq?    (tn) #f (length* clst1))
353      (assert-eq?    (tn) #f (length* clst2))
354      (assert-eq?    (tn) #f (length* clst3))
355      (assert-eq?    (tn) #f (length* clst4))))
356
357(total-report)
358