source: project/release/5/srfi-1/trunk/tests/srfi-116.scm @ 34718

Last change on this file since 34718 was 34718, checked in by sjamaan, 21 months ago

release/5: Replace use by import in eggs

File size: 12.1 KB
Line 
1;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2;;;
3;;; SRFI 116 tests adapted for SRFI 1.
4;;;
5;;; Copyright (C) John Cowan 2014. All Rights Reserved.
6;;;
7;;; Permission is hereby granted, free of charge, to any person obtaining a
8;;; copy of this software and associated documentation files (the "Software"),
9;;; to deal in the Software without restriction, including without limitation
10;;; the rights to use, copy, modify, merge, publish, distribute, sublicense,
11;;; and/or sell copies of the Software, and to permit persons to whom the
12;;; Software is furnished to do so, subject to the following conditions:
13;;;
14;;; The above copyright notice and this permission notice shall be included in
15;;; all copies or substantial portions of the Software.
16;;;
17;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
18;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
19;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
20;;; THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
21;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
22;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
23;;; DEALINGS IN THE SOFTWARE.
24;;;
25
26(import srfi-1 test)
27
28(test-group "lists"
29
30(test-group "lists/constructors"
31  (define abc (list 'a 'b 'c))
32  (test 'a (car abc))
33  (test 'b (cadr abc))
34  (test 'c (caddr abc))
35  (test (cons 2 1) (xcons 1 2))
36  (define abc-dot-d (cons* 'a 'b 'c 'd))
37  (test 'd (cdddr abc-dot-d))
38  (test '(c c c c) (make-list 4 'c))
39  (test '(0 1 2 3) (list-tabulate 4 values))
40  (test '(0 1 2 3 4) (iota 5))
41) ; end lists/constructors
42
43(test-group "lists/predcates"
44  (test-assert (pair? (cons 1 2)))
45  (test-assert (proper-list? '()))
46  (test-assert (proper-list? '(1 2 3)))
47  (test-assert (list? '()))
48  (test-assert (list? '(1 2 3)))
49  (test-assert (dotted-list? (cons 1 2)))
50  (test-assert (dotted-list? 2))
51  (test-assert (null-list? '()))
52  (test-assert (not (null-list? '(1 2 3))))
53  (test-error (null-list? 'a))
54  (test-assert (not-pair? 'a))
55  (test-assert (not (not-pair? (cons 'a 'b))))
56  (test-assert (list= = '(1 2 3) '(1 2 3)))
57  (test-assert (not (list= = '(1 2 3 4) '(1 2 3))))
58  (test-assert (not (list= = '(1 2 3) '(1 2 3 4))))
59  (test-assert (list= = '(1 2 3) '(1 2 3)))
60  (test-assert (not (list= = '(1 2 3) '(1 2 3 4) '(1 2 3 4))))
61  (test-assert (not (list= = '(1 2 3) '(1 2 3) '(1 2 3 4))))
62) ; end list/predcates
63
64(test-group "list/cxrs"
65  (define ab (cons 'a 'b))
66  (define cd (cons 'c 'd))
67  (define ef (cons 'e 'f))
68  (define gh (cons 'g 'h))
69  (define abcd (cons ab cd))
70  (define efgh (cons ef gh))
71  (define abcdefgh (cons abcd efgh))
72  (define ij (cons 'i 'j))
73  (define kl (cons 'k 'l))
74  (define mn (cons 'm 'n))
75  (define op (cons 'o 'p))
76  (define ijkl (cons ij kl))
77  (define mnop (cons mn op))
78  (define ijklmnop (cons ijkl mnop))
79  (define abcdefghijklmnop (cons abcdefgh ijklmnop))
80  (test 'a (caar abcd))
81  (test 'b (cdar abcd))
82  (test 'c (cadr abcd))
83  (test 'd (cddr abcd))
84  (test 'a (caaar abcdefgh))
85  (test 'b (cdaar abcdefgh))
86  (test 'c (cadar abcdefgh))
87  (test 'd (cddar abcdefgh))
88  (test 'e (caadr abcdefgh))
89  (test 'f (cdadr abcdefgh))
90  (test 'g (caddr abcdefgh))
91  (test 'h (cdddr abcdefgh))
92  (test 'a (caaaar abcdefghijklmnop))
93  (test 'b (cdaaar abcdefghijklmnop))
94  (test 'c (cadaar abcdefghijklmnop))
95  (test 'd (cddaar abcdefghijklmnop))
96  (test 'e (caadar abcdefghijklmnop))
97  (test 'f (cdadar abcdefghijklmnop))
98  (test 'g (caddar abcdefghijklmnop))
99  (test 'h (cdddar abcdefghijklmnop))
100  (test 'i (caaadr abcdefghijklmnop))
101  (test 'j (cdaadr abcdefghijklmnop))
102  (test 'k (cadadr abcdefghijklmnop))
103  (test 'l (cddadr abcdefghijklmnop))
104  (test 'm (caaddr abcdefghijklmnop))
105  (test 'n (cdaddr abcdefghijklmnop))
106  (test 'o (cadddr abcdefghijklmnop))
107  (test 'p (cddddr abcdefghijklmnop))
108) ; end lists/cxrs
109
110(test-group "lists/selectors"
111  (test 'c (list-ref '(a b c d) 2))
112  (define ten (list 1 2 3 4 5 6 7 8 9 10))
113  (test 1 (first ten))
114  (test 2 (second ten))
115  (test 3 (third ten))
116  (test 4 (fourth ten))
117  (test 5 (fifth ten))
118  (test 6 (sixth ten))
119  (test 7 (seventh ten))
120  (test 8 (eighth ten))
121  (test 9 (ninth ten))
122  (test 10 (tenth ten))
123  (test-error (list-ref '() 2))
124  (test '(1 2) (call-with-values (lambda () (car+cdr (cons 1 2))) list))
125  (define abcde '(a b c d e))
126  (define dotted (cons 1 (cons 2 (cons 3 'd))))
127  (test '(a b) (take abcde 2))
128  (test '(c d e) (drop abcde 2))
129  (test '(c d e) (list-tail abcde 2))
130  (test '(1 2) (take dotted 2))
131  (test (cons 3 'd) (drop dotted 2))
132  (test (cons 3 'd) (list-tail dotted 2))
133  (test 'd (drop dotted 3))
134  (test 'd (list-tail dotted 3))
135  (test abcde (append (take abcde 4) (drop abcde 4)))
136  (test '(d e) (take-right abcde 2))
137  (test '(a b c) (drop-right abcde 2))
138  (test (cons 2 (cons 3 'd)) (take-right dotted 2))
139  (test '(1) (drop-right dotted 2))
140  (test 'd (take-right dotted 0))
141  (test '(1 2 3) (drop-right dotted 0))
142  (test abcde (call-with-values (lambda () (split-at abcde 3)) append))
143  (test 'c (last '(a b c)))
144  (test '(c) (last-pair '(a b c)))
145) ; end lists/selectors
146
147(test-group "lists/misc"
148  (test 0 (length '()))
149  (test 3 (length '(1 2 3)))
150  (test '(x y) (append '(x) '(y)))
151  (test '(a b c d) (append '(a b) '(c d)))
152  (test '(a) (append '() '(a)))
153  (test '(x y) (append '(x y)))
154  (test '() (append))
155  (test '(a b c d) (concatenate '((a b) (c d))))
156  (test '(c b a) (reverse '(a b c)))
157  (test '((e (f)) d (b c) a) (reverse '(a (b c) d (e (f)))))
158  (test (cons 2 (cons 1 'd)) (append-reverse '(1 2) 'd))
159  (test '((one 1 odd) (two 2 even) (three 3 odd))
160    (zip '(one two three) '(1 2 3) '(odd even odd)))
161  (test '((1) (2) (3)) (zip '(1 2 3)))
162  (test '(1 2 3) (unzip1 '((1) (2) (3))))
163  (test '((1 2 3) (one two three))
164    (call-with-values
165      (lambda () (unzip2 '((1 one) (2 two) (3 three))))
166      list))
167  (test '((1 2 3) (one two three) (a b c))
168    (call-with-values
169      (lambda () (unzip3 '((1 one a) (2 two b) (3 three c))))
170      list))
171  (test '((1 2 3) (one two three) (a b c) (4 5 6))
172    (call-with-values
173      (lambda () (unzip4 '((1 one a 4) (2 two b 5) (3 three c 6))))
174      list))
175  (test '((1 2 3) (one two three) (a b c) (4 5 6) (#t #f #t))
176    (call-with-values
177      (lambda () (unzip5 '((1 one a 4 #t) (2 two b 5 #f) (3 three c 6 #t))))
178      list))
179  (test 3 (count even? '(3 1 4 1 5 9 2 5 6)))
180  (test 3 (count < '(1 2 4 8) '(2 4 6 8 10 12 14 16)))
181) ; end lists/misc
182
183(test-group "lists/folds"
184  ;; We have to be careful to test both single-list and multiple-list
185  ;; code paths, as they are different in this implementation.
186
187  (define lis '(1 2 3))
188  (test 6 (fold + 0 lis))
189  (test '(3 2 1) (fold cons '() lis))
190  (test 2 (fold
191            (lambda (x count) (if (symbol? x) (+ count 1) count))
192            0
193            '(a 0 b)))
194  (test 4 (fold
195            (lambda (s max-len) (max max-len (string-length s)))
196            0
197            '("ab" "abcd" "abc")))
198  (test 32 (fold
199             (lambda (a b ans) (+ (* a b) ans))
200             0
201             '(1 2 3)
202             '(4 5 6)))
203  (define (z x y ans) (cons (list x y) ans))
204  (test '((b d) (a c))
205    (fold z '() '(a b) '(c d)))
206  (test lis (fold-right cons '() lis))
207  (test '(0 2 4) (fold-right
208                   (lambda (x l) (if (even? x) (cons x l) l))
209                   '()
210                   '(0 1 2 3 4)))
211  (test '((a c) (b d))
212    (fold-right z '() '(a b) '(c d)))
213  (test '((c) (b c) (a b c))
214    (pair-fold cons '() '(a b c)))
215  (test '(((b) (d)) ((a b) (c d)))
216    (pair-fold z '() '(a b) '(c d)))
217  (test '((a b c) (b c) (c))
218    (pair-fold-right cons '() '(a b c)))
219  (test '(((a b) (c d)) ((b) (d)))
220    (pair-fold-right z '() '(a b) '(c d)))
221  (test 5 (reduce max 0 '(1 3 5 4 2 0)))
222  (test 1 (reduce - 0 '(1 2)))
223  (test -1 (reduce-right - 0 '(1 2)))
224  (define squares '(1 4 9 16 25 36 49 64 81 100))
225  (test squares
226   (unfold (lambda (x) (> x 10))
227     (lambda (x) (* x x))
228     (lambda (x) (+ x 1))
229     1))
230  (test squares
231    (unfold-right zero?
232      (lambda (x) (* x x))
233      (lambda (x) (- x 1))
234      10))
235  (test '(1 2 3) (unfold null-list? car cdr '(1 2 3)))
236  (test '(3 2 1) (unfold-right null-list? car cdr '(1 2 3)))
237  (test '(1 2 3 4)
238    (unfold null-list? car cdr '(1 2) (lambda (x) '(3 4))))
239  (test '(b e h) (map cadr '((a b) (d e) (g h))))
240  (test '(b e h) (map-in-order cadr '((a b) (d e) (g h))))
241  (test '(5 7 9) (map + '(1 2 3) '(4 5 6)))
242  (test '(5 7 9) (map-in-order + '(1 2 3) '(4 5 6)))
243  (define z (let ((count 0)) (lambda (ignored) (set! count (+ count 1)) count)))
244  (test '(1 2) (map-in-order z '(a b)))
245  (test '#(0 1 4 9 16)
246    (let ((v (make-vector 5)))
247      (for-each (lambda (i)
248                  (vector-set! v i (* i i)))
249                '(0 1 2 3 4))
250    v))
251  (test '#(5 7 9 11 13)
252    (let ((v (make-vector 5)))
253      (for-each (lambda (i j)
254                  (vector-set! v i (+ i j)))
255                '(0 1 2 3 4)
256                '(5 6 7 8 9))
257    v))
258  (test '(1 -1 3 -3 8 -8)
259    (append-map (lambda (x) (list x (- x))) '(1 3 8)))
260  (test '(1 4 2 5 3 6)
261    (append-map list '(1 2 3) '(4 5 6)))
262  (test (vector '(0 1 2 3 4) '(1 2 3 4) '(2 3 4) '(3 4) '(4))
263    (let ((v (make-vector 5)))
264      (pair-for-each (lambda (lis) (vector-set! v (car lis) lis)) '(0 1 2 3 4))
265    v))
266  (test (vector '(5 6 7 8 9) '(6 7 8 9) '(7 8 9) '(8 9) '(9))
267    (let ((v (make-vector 5)))
268      (pair-for-each (lambda (i j) (vector-set! v (car i) j))
269                '(0 1 2 3 4)
270                '(5 6 7 8 9))
271    v))
272  (test '(1 9 49)
273    (filter-map (lambda (x) (and (number? x) (* x x))) '(a 1 b 3 c 7)))
274  (test '(5 7 9)
275    (filter-map
276      (lambda (x y) (and (number? x) (number? y) (+ x y)))
277      '(1 a 2 b 3 4)
278      '(4 0 5 y 6 z)))
279) ; end lists/folds
280
281(test-group "lists/filtering"
282  (test '(0 8 8 -4) (filter even? '(0 7 8 8 43 -4)))
283  (test (list '(one four five) '(2 3 6))
284    (call-with-values
285      (lambda () (partition symbol? '(one 2 3 four five 6)))
286      list))
287  (test '(7 43) (remove even? '(0 7 8 8 43 -4)))
288) ; end lists/filtering
289
290(test-group "lists/searching"
291  (test 2 (find even? '(1 2 3)))
292  (test #t (any  even? '(1 2 3)))
293  (test #f (find even? '(1 7 3)))
294  (test #f (any  even? '(1 7 3)))
295  (test-error (find even? (cons (1 (cons 3 x)))))
296  (test-error (any  even? (cons (1 (cons 3 x)))))
297  (test 4 (find even? '(3 1 4 1 5 9)))
298  (test '(-8 -5 0 0) (find-tail even? '(3 1 37 -8 -5 0 0)))
299  (test '(2 18) (take-while even? '(2 18 3 10 22 9)))
300  (test '(3 10 22 9) (drop-while even? '(2 18 3 10 22 9)))
301  (test (list '(2 18) '(3 10 22 9))
302    (call-with-values
303      (lambda () (span even? '(2 18 3 10 22 9)))
304      list))
305  (test (list '(3 1) '(4 1 5 9))
306    (call-with-values
307      (lambda () (break even? '(3 1 4 1 5 9)))
308      list))
309  (test #t (any integer? '(a 3 b 2.7)))
310  (test #f (any integer? '(a 3.1 b 2.7)))
311  (test #t (any < '(3 1 4 1 5) '(2 7 1 8 2)))
312  (test #t (every integer? '(1 2 3 4 5)))
313  (test #f (every integer? '(1 2 3 4.5 5)))
314  (test #t (every < '(1 2 3) '(4 5 6)))
315  (test 2 (list-index even? '(3 1 4 1 5 9)))
316  (test 1 (list-index < '(3 1 4 1 5 9 2 5 6) '(2 7 1 8 2)))
317  (test #f (list-index = '(3 1 4 1 5 9 2 5 6) '(2 7 1 8 2)))
318  (test '(a b c) (memq 'a '(a b c)))
319  (test '(b c) (memq 'b '(a b c)))
320  (test #f (memq 'a '(b c d)))
321  (test #f (memq (list 'a) '(b (a) c)))
322  (test '((a) c) (member (list 'a) '(b (a) c)))
323  (test '(101 102) (memv 101 '(100 101 102)))
324) ; end lists/searching
325
326(test-group "lists/deletion"
327  (test '(1 2 4 5) (delete 3 '(1 2 3 4 5)))
328  (test '(3 4 5) (delete 5 '(3 4 5 6 7) <))
329  (test '(a b c z) (delete-duplicates '(a b a c a b c z)))
330) ; end lists/deletion
331
332(test-group "lists/alists"
333  (define e '((a 1) (b 2) (c 3))) (test '(a 1) (assq 'a e))
334  (test '(b 2) (assq 'b e))
335  (test #f (assq 'd e))
336  (test #f (assq (list 'a) '(((a)) ((b)) ((c)))))
337  (test '((a)) (assoc (list 'a) '(((a)) ((b)) ((c)))))
338  (define e2 '((2 3) (5 7) (11 13)))
339  (test '(5 7) (assv 5 e2))
340  (test '(11 13) (assoc 5 e2 <))
341  (test (cons '(1 1) e2) (alist-cons 1 (list 1) e2))
342  (test '((2 3) (11 13)) (alist-delete 5 e2))
343  (test '((2 3) (5 7)) (alist-delete 5 e2 <))
344) ; end lists/alists
345
346(test-group "lists/mutators"
347  (define x (cons 1 2))
348  (set-car! x 3)
349  (test x '(3 . 2))
350  (set-cdr! x 4)
351  (test x '(3 . 4))
352) ; end lists/mutators
353
354) ; end lists
Note: See TracBrowser for help on using the repository browser.