1;;;; srfi-1.test --- Test suite for Guile's SRFI-1 functions. -*- scheme -*-
2;;;;
3;;;; Copyright 2003-2006, 2008-2011, 2014, 2020 Free Software Foundation, Inc.
4;;;;
5;;;; This library is free software; you can redistribute it and/or
6;;;; modify it under the terms of the GNU Lesser General Public
7;;;; License as published by the Free Software Foundation; either
8;;;; version 3 of the License, or (at your option) any later version.
9;;;;
10;;;; This library is distributed in the hope that it will be useful,
11;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
12;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
13;;;; Lesser General Public License for more details.
14;;;;
15;;;; You should have received a copy of the GNU Lesser General Public
16;;;; License along with this library; if not, write to the Free Software
17;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
18
19(define-module (test-srfi-1)
20  #:use-module (test-suite lib)
21  #:use-module (ice-9 copy-tree)
22  #:use-module (srfi srfi-1))
23
24
25(define (ref-delete x lst . proc)
26  "Reference implemenation of srfi-1 `delete'."
27  (set! proc (if (null? proc) equal? (car proc)))
28  (do ((ret '())
29       (lst lst (cdr lst)))
30      ((null? lst)
31       (reverse! ret))
32    (if (not (proc x (car lst)))
33	(set! ret (cons (car lst) ret)))))
34
35(define (ref-delete-duplicates lst . proc)
36  "Reference implemenation of srfi-1 `delete-duplicates'."
37  (set! proc (if (null? proc) equal? (car proc)))
38  (if (null? lst)
39      '()
40      (do ((keep '()))
41	  ((null? lst)
42	   (reverse! keep))
43	(let ((elem (car lst)))
44	  (set! keep (cons elem keep))
45	  (set! lst  (ref-delete elem lst proc))))))
46
47
48;;
49;; alist-copy
50;;
51
52(with-test-prefix "alist-copy"
53
54  ;; return a list which is the pairs making up alist A, the spine and cells
55  (define (alist-pairs a)
56    (let more ((a a)
57	       (result a))
58      (if (pair? a)
59	  (more (cdr a) (cons a result))
60	  result)))
61
62  ;; return a list of the elements common to lists X and Y, compared with eq?
63  (define (common-elements x y)
64    (if (null? x)
65	'()
66	(if (memq (car x) y)
67	    (cons (car x) (common-elements (cdr x) y))
68	    (common-elements (cdr x) y))))
69
70  ;; validate an alist-copy of OLD to NEW
71  ;; lists must be equal, and must comprise new pairs
72  (define (valid-alist-copy? old new)
73    (and (equal? old new)
74	 (null? (common-elements old new))))
75
76  (pass-if-exception "too few args" exception:wrong-num-args
77    (alist-copy))
78
79  (pass-if-exception "too many args" exception:wrong-num-args
80    (alist-copy '() '()))
81
82  (let ((old '()))
83    (pass-if old (valid-alist-copy? old (alist-copy old))))
84
85  (let ((old '((1 . 2))))
86    (pass-if old (valid-alist-copy? old (alist-copy old))))
87
88  (let ((old '((1 . 2) (3 . 4))))
89    (pass-if old (valid-alist-copy? old (alist-copy old))))
90
91  (let ((old '((1 . 2) (3 . 4) (5 . 6))))
92    (pass-if old (valid-alist-copy? old (alist-copy old)))))
93
94;;
95;; alist-delete
96;;
97
98(with-test-prefix "alist-delete"
99
100  (pass-if "equality call arg order"
101    (let ((good #f))
102      (alist-delete 'k '((ak . 123))
103		    (lambda (k ak)
104		      (if (and (eq? k 'k) (eq? ak 'ak))
105			  (set! good #t))))
106      good))
107
108  (pass-if "delete keys greater than 5"
109    (equal? '((4 . x) (5 . y))
110	    (alist-delete 5 '((4 . x) (5 . y) (6 . z)) <)))
111
112  (pass-if "empty"
113    (equal? '() (alist-delete 'x '())))
114
115  (pass-if "(y)"
116    (equal? '() (alist-delete 'y '((y . 1)))))
117
118  (pass-if "(n)"
119    (equal? '((n . 1)) (alist-delete 'y '((n . 1)))))
120
121  (pass-if "(y y)"
122    (equal? '() (alist-delete 'y '((y . 1) (y . 2)))))
123
124  (pass-if "(n y)"
125    (equal? '((n . 1)) (alist-delete 'y '((n . 1) (y . 2)))))
126
127  (pass-if "(y n)"
128    (equal? '((n . 2)) (alist-delete 'y '((y . 1) (n . 2)))))
129
130  (pass-if "(n n)"
131    (equal? '((n . 1) (n . 2)) (alist-delete 'y '((n . 1) (n . 2)))))
132
133  (pass-if "(y y y)"
134    (equal? '() (alist-delete 'y '((y . 1) (y . 2) (y . 3)))))
135
136  (pass-if "(n y y)"
137    (equal? '((n . 1)) (alist-delete 'y '((n . 1) (y . 2) (y . 3)))))
138
139  (pass-if "(y n y)"
140    (equal? '((n . 2)) (alist-delete 'y '((y . 1) (n . 2) (y . 3)))))
141
142  (pass-if "(n n y)"
143    (equal? '((n . 1) (n . 2)) (alist-delete 'y '((n . 1) (n . 2) (y . 3)))))
144
145  (pass-if "(y y n)"
146    (equal? '( (n . 3)) (alist-delete 'y '((y . 1) (y . 2) (n . 3)))))
147
148  (pass-if "(n y n)"
149    (equal? '((n . 1) (n . 3)) (alist-delete 'y '((n . 1) (y . 2) (n . 3)))))
150
151  (pass-if "(y n n)"
152    (equal? '((n . 2) (n . 3)) (alist-delete 'y '((y . 1) (n . 2) (n . 3)))))
153
154  (pass-if "(n n n)"
155    (equal? '((n . 1) (n . 2) (n . 3)) (alist-delete 'y '((n . 1) (n . 2) (n . 3))))))
156
157;;
158;; append-map
159;;
160
161(with-test-prefix "append-map"
162
163  (with-test-prefix "one list"
164
165    (pass-if "()"
166      (equal? '() (append-map noop '(()))))
167
168    (pass-if "(1)"
169      (equal? '(1) (append-map noop '((1)))))
170
171    (pass-if "(1 2)"
172      (equal? '(1 2) (append-map noop '((1 2)))))
173
174    (pass-if "() ()"
175      (equal? '() (append-map noop '(() ()))))
176
177    (pass-if "() (1)"
178      (equal? '(1) (append-map noop '(() (1)))))
179
180    (pass-if "() (1 2)"
181      (equal? '(1 2) (append-map noop '(() (1 2)))))
182
183    (pass-if "(1) (2)"
184      (equal? '(1 2) (append-map noop '((1) (2)))))
185
186    (pass-if "(1 2) ()"
187      (equal? '(1 2) (append-map noop '(() (1 2))))))
188
189  (with-test-prefix "two lists"
190
191    (pass-if "() / 9"
192      (equal? '() (append-map noop '(()) '(9))))
193
194    (pass-if "(1) / 9"
195      (equal? '(1) (append-map noop '((1)) '(9))))
196
197    (pass-if "() () / 9 9"
198      (equal? '() (append-map noop '(() ()) '(9 9))))
199
200    (pass-if "(1) (2) / 9"
201      (equal? '(1) (append-map noop '((1) (2)) '(9))))
202
203    (pass-if "(1) (2) / 9 9"
204      (equal? '(1 2) (append-map noop '((1) (2)) '(9 9))))))
205
206;;
207;; append-reverse
208;;
209
210(with-test-prefix "append-reverse"
211
212  ;; return a list which is the cars and cdrs of LST
213  (define (list-contents lst)
214    (if (null? lst)
215	'()
216	(cons* (car lst) (cdr lst) (list-contents (cdr lst)))))
217
218  (define (valid-append-reverse revhead tail want)
219    (let ((revhead-contents (list-contents revhead))
220	  (got              (append-reverse revhead tail)))
221      (and (equal? got want)
222	   ;; revhead unchanged
223	   (equal? revhead-contents (list-contents revhead)))))
224
225  (pass-if-exception "too few args (0)" exception:wrong-num-args
226    (append-reverse))
227
228  (pass-if-exception "too few args (1)" exception:wrong-num-args
229    (append-reverse '(x)))
230
231  (pass-if-exception "too many args (3)" exception:wrong-num-args
232    (append-reverse '() '() #f))
233
234  (pass-if (valid-append-reverse '() '()      '()))
235  (pass-if (valid-append-reverse '() '(1 2 3) '(1 2 3)))
236
237  (pass-if (valid-append-reverse '(1) '()    '(1)))
238  (pass-if (valid-append-reverse '(1) '(2)   '(1 2)))
239  (pass-if (valid-append-reverse '(1) '(2 3) '(1 2 3)))
240
241  (pass-if (valid-append-reverse '(1 2) '()    '(2 1)))
242  (pass-if (valid-append-reverse '(1 2) '(3)   '(2 1 3)))
243  (pass-if (valid-append-reverse '(1 2) '(3 4) '(2 1 3 4)))
244
245  (pass-if (valid-append-reverse '(1 2 3) '()    '(3 2 1)))
246  (pass-if (valid-append-reverse '(1 2 3) '(4)   '(3 2 1 4)))
247  (pass-if (valid-append-reverse '(1 2 3) '(4 5) '(3 2 1 4 5))))
248
249;;
250;; append-reverse!
251;;
252
253(with-test-prefix "append-reverse!"
254
255  (pass-if-exception "too few args (0)" exception:wrong-num-args
256    (append-reverse!))
257
258  (pass-if-exception "too few args (1)" exception:wrong-num-args
259    (append-reverse! '(x)))
260
261  (pass-if-exception "too many args (3)" exception:wrong-num-args
262    (append-reverse! '() '() #f))
263
264  (pass-if (equal? '()      (append-reverse! '() '())))
265  (pass-if (equal? '(1 2 3) (append-reverse! '() '(1 2 3))))
266
267  (pass-if (equal? '(1)     (append-reverse! '(1) '())))
268  (pass-if (equal? '(1 2)   (append-reverse! '(1) '(2))))
269  (pass-if (equal? '(1 2 3) (append-reverse! '(1) '(2 3))))
270
271  (pass-if (equal? '(2 1)     (append-reverse! '(1 2) '())))
272  (pass-if (equal? '(2 1 3)   (append-reverse! '(1 2) '(3))))
273  (pass-if (equal? '(2 1 3 4) (append-reverse! '(1 2) '(3 4))))
274
275  (pass-if (equal? '(3 2 1)     (append-reverse! '(1 2 3) '())))
276  (pass-if (equal? '(3 2 1 4)   (append-reverse! '(1 2 3) '(4))))
277  (pass-if (equal? '(3 2 1 4 5) (append-reverse! '(1 2 3) '(4 5)))))
278
279;;
280;; assoc
281;;
282
283(with-test-prefix "assoc"
284
285  (pass-if "not found"
286    (let ((alist '((a . 1)
287		   (b . 2)
288		   (c . 3))))
289      (eqv? #f (assoc 'z alist))))
290
291  (pass-if "found"
292    (let ((alist '((a . 1)
293		   (b . 2)
294		   (c . 3))))
295      (eqv? (second alist) (assoc 'b alist))))
296
297  ;; this was wrong in guile 1.8.0 (a gremlin newly introduced in the 1.8
298  ;; series, 1.6.x and earlier was ok)
299  (pass-if "= arg order"
300    (let ((alist '((b . 1)))
301	  (good  #f))
302      (assoc 'a alist (lambda (x y)
303			(set! good (and (eq? x 'a)
304					(eq? y 'b)))))
305      good))
306
307  ;; likewise this one bad in guile 1.8.0
308  (pass-if "srfi-1 example <"
309    (let ((alist '((1 . a)
310		   (5 . b)
311		   (6 . c))))
312      (eq? (third alist) (assoc 5 alist <)))))
313
314;;
315;; break
316;;
317
318(with-test-prefix "break"
319
320  (define (test-break lst want-v1 want-v2)
321    (call-with-values
322	(lambda ()
323	  (break negative? lst))
324      (lambda (got-v1 got-v2)
325	(and (equal? got-v1 want-v1)
326	     (equal? got-v2 want-v2)))))
327
328  (pass-if "empty"
329    (test-break '() '() '()))
330
331  (pass-if "y"
332    (test-break '(1) '(1) '()))
333
334  (pass-if "n"
335    (test-break '(-1) '() '(-1)))
336
337  (pass-if "yy"
338    (test-break '(1 2) '(1 2) '()))
339
340  (pass-if "ny"
341    (test-break '(-1 1) '() '(-1 1)))
342
343  (pass-if "yn"
344    (test-break '(1 -1) '(1) '(-1)))
345
346  (pass-if "nn"
347    (test-break '(-1 -2) '() '(-1 -2)))
348
349  (pass-if "yyy"
350    (test-break '(1 2 3) '(1 2 3) '()))
351
352  (pass-if "nyy"
353    (test-break '(-1 1 2) '() '(-1 1 2)))
354
355  (pass-if "yny"
356    (test-break '(1 -1 2) '(1) '(-1 2)))
357
358  (pass-if "nny"
359    (test-break '(-1 -2 1) '() '(-1 -2 1)))
360
361  (pass-if "yyn"
362    (test-break '(1 2 -1) '(1 2) '(-1)))
363
364  (pass-if "nyn"
365    (test-break '(-1 1 -2) '() '(-1 1 -2)))
366
367  (pass-if "ynn"
368    (test-break '(1 -1 -2) '(1) '(-1 -2)))
369
370  (pass-if "nnn"
371    (test-break '(-1 -2 -3) '() '(-1 -2 -3))))
372
373;;
374;; break!
375;;
376
377(with-test-prefix "break!"
378
379  (define (test-break! lst want-v1 want-v2)
380    (call-with-values
381	(lambda ()
382	  (break! negative? lst))
383      (lambda (got-v1 got-v2)
384	(and (equal? got-v1 want-v1)
385	     (equal? got-v2 want-v2)))))
386
387  (pass-if "empty"
388    (test-break! '() '() '()))
389
390  (pass-if "y"
391    (test-break! (list 1) '(1) '()))
392
393  (pass-if "n"
394    (test-break! (list -1) '() '(-1)))
395
396  (pass-if "yy"
397    (test-break! (list 1 2) '(1 2) '()))
398
399  (pass-if "ny"
400    (test-break! (list -1 1) '() '(-1 1)))
401
402  (pass-if "yn"
403    (test-break! (list 1 -1) '(1) '(-1)))
404
405  (pass-if "nn"
406    (test-break! (list -1 -2) '() '(-1 -2)))
407
408  (pass-if "yyy"
409    (test-break! (list 1 2 3) '(1 2 3) '()))
410
411  (pass-if "nyy"
412    (test-break! (list -1 1 2) '() '(-1 1 2)))
413
414  (pass-if "yny"
415    (test-break! (list 1 -1 2) '(1) '(-1 2)))
416
417  (pass-if "nny"
418    (test-break! (list -1 -2 1) '() '(-1 -2 1)))
419
420  (pass-if "yyn"
421    (test-break! (list 1 2 -1) '(1 2) '(-1)))
422
423  (pass-if "nyn"
424    (test-break! (list -1 1 -2) '() '(-1 1 -2)))
425
426  (pass-if "ynn"
427    (test-break! (list 1 -1 -2) '(1) '(-1 -2)))
428
429  (pass-if "nnn"
430    (test-break! (list -1 -2 -3) '() '(-1 -2 -3))))
431
432;;
433;; car+cdr
434;;
435
436(with-test-prefix "car+cdr"
437
438  (pass-if "(1 . 2)"
439    (call-with-values
440	(lambda ()
441	  (car+cdr '(1 . 2)))
442      (lambda (x y)
443	(and (eqv? x 1)
444	     (eqv? y 2))))))
445
446;;
447;; concatenate and concatenate!
448;;
449
450(let ()
451  (define (common-tests concatenate-proc unmodified?)
452    (define (try lstlst want)
453      (let ((lstlst-copy (copy-tree lstlst))
454	    (got         (concatenate-proc lstlst)))
455	(if unmodified?
456	    (if (not (equal? lstlst lstlst-copy))
457		(error "input lists modified")))
458	(equal? got want)))
459
460    (pass-if-exception "too few args" exception:wrong-num-args
461      (concatenate-proc))
462
463    (pass-if-exception "too many args" exception:wrong-num-args
464      (concatenate-proc '() '()))
465
466    (pass-if-exception "number" exception:wrong-type-arg
467      (concatenate-proc 123))
468
469    (pass-if-exception "vector" exception:wrong-type-arg
470      (concatenate-proc #(1 2 3)))
471
472    (pass-if "no lists"
473      (try '() '()))
474
475    (pass-if (try '((1))       '(1)))
476    (pass-if (try '((1 2))     '(1 2)))
477    (pass-if (try '(() (1))    '(1)))
478    (pass-if (try '(() () (1)) '(1)))
479
480    (pass-if (try '((1) (2)) '(1 2)))
481    (pass-if (try '(() (1 2)) '(1 2)))
482
483    (pass-if (try '((1) 2)           '(1 . 2)))
484    (pass-if (try '((1) (2) 3)       '(1 2 . 3)))
485    (pass-if (try '((1) (2) (3 . 4)) '(1 2 3 . 4)))
486    )
487
488  (with-test-prefix "concatenate"
489    (common-tests concatenate #t))
490
491  (with-test-prefix "concatenate!"
492    (common-tests concatenate! #f)))
493
494;;
495;; count
496;;
497
498(with-test-prefix "count"
499  (pass-if-exception "no args" exception:wrong-num-args
500    (count))
501
502  (pass-if-exception "one arg" exception:wrong-num-args
503    (count noop))
504
505  (with-test-prefix "one list"
506    (define (or1 x)
507      x)
508
509    (pass-if "empty list" (= 0 (count or1 '())))
510
511    (pass-if-exception "pred arg count 0" exception:wrong-num-args
512      (count (lambda () x) '(1 2 3)))
513    (pass-if-exception "pred arg count 2" exception:wrong-num-args
514      (count (lambda (x y) x) '(1 2 3)))
515
516    (pass-if-exception "improper 1" exception:wrong-type-arg
517      (count or1 1))
518    (pass-if-exception "improper 2" exception:wrong-type-arg
519      (count or1 '(1 . 2)))
520    (pass-if-exception "improper 3" exception:wrong-type-arg
521      (count or1 '(1 2 . 3)))
522
523    (pass-if (= 0 (count or1 '(#f))))
524    (pass-if (= 1 (count or1 '(#t))))
525
526    (pass-if (= 0 (count or1 '(#f #f))))
527    (pass-if (= 1 (count or1 '(#f #t))))
528    (pass-if (= 1 (count or1 '(#t #f))))
529    (pass-if (= 2 (count or1 '(#t #t))))
530
531    (pass-if (= 0 (count or1 '(#f #f #f))))
532    (pass-if (= 1 (count or1 '(#f #f #t))))
533    (pass-if (= 1 (count or1 '(#t #f #f))))
534    (pass-if (= 2 (count or1 '(#t #f #t))))
535    (pass-if (= 3 (count or1 '(#t #t #t)))))
536
537  (with-test-prefix "two lists"
538    (define (or2 x y)
539      (or x y))
540
541    (pass-if "arg order"
542      (= 1 (count (lambda (x y)
543		    (and (= 1 x)
544			 (= 2 y)))
545		  '(1) '(2))))
546
547    (pass-if "empty lists" (= 0 (count or2 '() '())))
548
549    (pass-if-exception "pred arg count 0" exception:wrong-num-args
550      (count (lambda () #t) '(1 2 3) '(1 2 3)))
551    (pass-if-exception "pred arg count 1" exception:wrong-num-args
552      (count (lambda (x) x) '(1 2 3) '(1 2 3)))
553    (pass-if-exception "pred arg count 3" exception:wrong-num-args
554      (count (lambda (x y z) x) '(1 2 3) '(1 2 3)))
555
556    (pass-if-exception "improper first 1" exception:wrong-type-arg
557      (count or2 1 '(1 2 3)))
558    (pass-if-exception "improper first 2" exception:wrong-type-arg
559      (count or2 '(1 . 2) '(1 2 3)))
560    (pass-if-exception "improper first 3" exception:wrong-type-arg
561      (count or2 '(1 2 . 3) '(1 2 3)))
562
563    (pass-if-exception "improper second 1" exception:wrong-type-arg
564      (count or2 '(1 2 3) 1))
565    (pass-if-exception "improper second 2" exception:wrong-type-arg
566      (count or2 '(1 2 3) '(1 . 2)))
567    (pass-if-exception "improper second 3" exception:wrong-type-arg
568      (count or2 '(1 2 3) '(1 2 . 3)))
569
570    (pass-if (= 0 (count or2 '(#f) '(#f))))
571    (pass-if (= 1 (count or2 '(#t) '(#f))))
572    (pass-if (= 1 (count or2 '(#f) '(#t))))
573
574    (pass-if (= 0 (count or2 '(#f #f) '(#f #f))))
575    (pass-if (= 1 (count or2 '(#t #f) '(#t #f))))
576    (pass-if (= 2 (count or2 '(#t #t) '(#f #f))))
577    (pass-if (= 2 (count or2 '(#t #f) '(#f #t))))
578
579    (with-test-prefix "stop shortest"
580      (pass-if (= 2 (count or2 '(#t #f #t) '(#f #t))))
581      (pass-if (= 2 (count or2 '(#t #f #t #t) '(#f #t))))
582      (pass-if (= 2 (count or2 '(#t #f) '(#f #t #t))))
583      (pass-if (= 2 (count or2 '(#t #f) '(#f #t #t #t))))))
584
585  (with-test-prefix "three lists"
586    (define (or3 x y z)
587      (or x y z))
588
589    (pass-if "arg order"
590      (= 1 (count (lambda (x y z)
591		    (and (= 1 x)
592			 (= 2 y)
593			 (= 3 z)))
594		  '(1) '(2) '(3))))
595
596    (pass-if "empty lists" (= 0 (count or3 '() '() '())))
597
598    ;; currently bad pred argument gives wrong-num-args when 3 or more
599    ;; lists, as opposed to wrong-type-arg for 1 or 2 lists
600    (pass-if-exception "pred arg count 0" exception:wrong-num-args
601      (count (lambda () #t) '(1 2 3) '(1 2 3) '(1 2 3)))
602    (pass-if-exception "pred arg count 2" exception:wrong-num-args
603      (count (lambda (x y) x) '(1 2 3) '(1 2 3)'(1 2 3) ))
604    (pass-if-exception "pred arg count 4" exception:wrong-num-args
605      (count (lambda (w x y z) x) '(1 2 3) '(1 2 3) '(1 2 3)))
606
607    (pass-if-exception "improper first 1" exception:wrong-type-arg
608      (count or3 1 '(1 2 3) '(1 2 3)))
609    (pass-if-exception "improper first 2" exception:wrong-type-arg
610      (count or3 '(1 . 2) '(1 2 3) '(1 2 3)))
611    (pass-if-exception "improper first 3" exception:wrong-type-arg
612      (count or3 '(1 2 . 3) '(1 2 3) '(1 2 3)))
613
614    (pass-if-exception "improper second 1" exception:wrong-type-arg
615      (count or3 '(1 2 3) 1 '(1 2 3)))
616    (pass-if-exception "improper second 2" exception:wrong-type-arg
617      (count or3 '(1 2 3) '(1 . 2) '(1 2 3)))
618    (pass-if-exception "improper second 3" exception:wrong-type-arg
619      (count or3 '(1 2 3) '(1 2 . 3) '(1 2 3)))
620
621    (pass-if-exception "improper third 1" exception:wrong-type-arg
622      (count or3 '(1 2 3) '(1 2 3) 1))
623    (pass-if-exception "improper third 2" exception:wrong-type-arg
624      (count or3 '(1 2 3) '(1 2 3) '(1 . 2)))
625    (pass-if-exception "improper third 3" exception:wrong-type-arg
626      (count or3 '(1 2 3) '(1 2 3) '(1 2 . 3)))
627
628    (pass-if (= 0 (count or3 '(#f) '(#f) '(#f))))
629    (pass-if (= 1 (count or3 '(#t) '(#f) '(#f))))
630    (pass-if (= 1 (count or3 '(#f) '(#t) '(#f))))
631    (pass-if (= 1 (count or3 '(#f) '(#f) '(#t))))
632
633    (pass-if (= 0 (count or3 '(#f #f) '(#f #f) '(#f #f))))
634
635    (pass-if (= 1 (count or3 '(#t #f) '(#f #f) '(#f #f))))
636    (pass-if (= 1 (count or3 '(#f #t) '(#f #f) '(#f #f))))
637    (pass-if (= 1 (count or3 '(#f #f) '(#t #f) '(#f #f))))
638    (pass-if (= 1 (count or3 '(#f #f) '(#f #t) '(#f #f))))
639    (pass-if (= 1 (count or3 '(#f #f) '(#f #f) '(#t #f))))
640    (pass-if (= 1 (count or3 '(#f #f) '(#f #f) '(#f #t))))
641
642    (pass-if (= 2 (count or3 '(#t #t) '(#f #f) '(#f #f))))
643    (pass-if (= 2 (count or3 '(#f #f) '(#t #t) '(#f #f))))
644    (pass-if (= 2 (count or3 '(#f #f) '(#f #f) '(#t #t))))
645    (pass-if (= 2 (count or3 '(#f #f) '(#t #f) '(#f #t))))
646
647    (with-test-prefix "stop shortest"
648      (pass-if (= 0 (count or3 '() '(#t #t #t) '(#t #t))))
649      (pass-if (= 0 (count or3 '(#t #t #t) '() '(#t #t))))
650      (pass-if (= 0 (count or3 '(#t #t #t) '(#t #t) '())))
651
652      (pass-if (= 1 (count or3 '(#t) '(#t #t #t) '(#t #t))))
653      (pass-if (= 1 (count or3 '(#t #t #t) '(#t) '(#t #t))))
654      (pass-if (= 1 (count or3 '(#t #t #t) '(#t #t) '(#t)))))
655
656    (pass-if "apply list unchanged"
657      (let ((lst (list (list 1 2) (list 3 4) (list 5 6))))
658	(and (equal? 2 (apply count or3 lst))
659	     ;; lst unmodified
660	     (equal? '((1 2) (3 4) (5 6)) lst))))))
661
662;;
663;; delete and delete!
664;;
665
666(let ()
667  ;; Call (PROC lst) for all lists of length up to 6, with all combinations
668  ;; of elements to be retained or deleted.  Elements to retain are numbers,
669  ;; 0 upwards.  Elements to be deleted are #f.
670  (define (test-lists proc)
671    (do ((n 0 (1+ n)))
672	((>= n 6))
673      (do ((limit (ash 1 n))
674	   (i 0 (1+ i)))
675	  ((>= i limit))
676	(let ((lst '()))
677	  (do ((bit 0 (1+ bit)))
678	      ((>= bit n))
679	    (set! lst  (cons (if (logbit? bit i) bit #f) lst)))
680	  (proc lst)))))
681
682  (define (common-tests delete-proc)
683    (pass-if-exception "too few args" exception:wrong-num-args
684      (delete-proc 0))
685
686    (pass-if-exception "too many args" exception:wrong-num-args
687      (delete-proc 0 '() equal? 99))
688
689    (pass-if "empty"
690      (eq? '() (delete-proc 0 '() equal?)))
691
692    (pass-if "equal?"
693      (equal? '((1) (3))
694	      (delete-proc '(2) '((1) (2) (3)) equal?)))
695
696    (pass-if "eq?"
697      (equal? '((1) (2) (3))
698	      (delete-proc '(2) '((1) (2) (3)) eq?)))
699
700    (pass-if "called arg order"
701      (equal? '(1 2 3)
702	      (delete-proc 3 '(1 2 3 4 5) <))))
703
704  (with-test-prefix "delete"
705    (common-tests delete)
706
707    (test-lists
708     (lambda (lst)
709       (let ((lst-copy (list-copy lst)))
710	 (with-test-prefix lst-copy
711	   (pass-if "result"
712	     (equal? (delete     #f lst equal?)
713		     (ref-delete #f lst equal?)))
714	   (pass-if "non-destructive"
715	     (equal? lst-copy lst)))))))
716
717  (with-test-prefix "delete!"
718    (common-tests delete!)
719
720    (test-lists
721     (lambda (lst)
722       (pass-if lst
723	 (equal? (delete!    #f lst)
724		 (ref-delete #f lst)))))))
725
726;;
727;; delete-duplicates and delete-duplicates!
728;;
729
730(let ()
731  ;; Call (PROC lst) for all lists of length 1 <= n <= 4, with all
732  ;; combinations of numbers 1 to n in the elements
733  (define (test-lists proc)
734    (do ((n 1 (1+ n)))
735	((> n 4))
736      (do ((limit (integer-expt n n))
737	   (i 0 (1+ i)))
738	  ((>= i limit))
739	(let ((lst '()))
740	  (do ((j 0 (1+ j))
741	       (rem i (quotient rem n)))
742	      ((>= j n))
743	    (set! lst (cons (remainder rem n) lst)))
744	  (proc lst)))))
745
746  (define (common-tests delete-duplicates-proc)
747    (pass-if-exception "too few args" exception:wrong-num-args
748      (delete-duplicates-proc))
749
750    (pass-if-exception "too many args" exception:wrong-num-args
751      (delete-duplicates-proc '() equal? 99))
752
753    (pass-if "empty"
754      (eq? '() (delete-duplicates-proc '())))
755
756    (pass-if "equal? (the default)"
757      (equal? '((2))
758	      (delete-duplicates-proc '((2) (2) (2)))))
759
760    (pass-if "eq?"
761      (equal? '((2) (2) (2))
762	      (delete-duplicates-proc '((2) (2) (2)) eq?)))
763
764    (pass-if "called arg order"
765      (let ((ok #t))
766	(delete-duplicates-proc '(1 2 3 4 5)
767				(lambda (x y)
768				  (if (> x y)
769				      (set! ok #f))
770				  #f))
771	ok)))
772
773  (with-test-prefix "delete-duplicates"
774    (common-tests delete-duplicates)
775
776    (test-lists
777     (lambda (lst)
778       (let ((lst-copy (list-copy lst)))
779	 (with-test-prefix lst-copy
780	   (pass-if "result"
781	     (equal? (delete-duplicates     lst)
782		     (ref-delete-duplicates lst)))
783	   (pass-if "non-destructive"
784	     (equal? lst-copy lst)))))))
785
786  (with-test-prefix "delete-duplicates!"
787    (common-tests delete-duplicates!)
788
789    (test-lists
790     (lambda (lst)
791       (pass-if lst
792	 (equal? (delete-duplicates!    lst)
793		 (ref-delete-duplicates lst)))))))
794
795;;
796;; drop
797;;
798
799(with-test-prefix "drop"
800
801  (pass-if "'() 0"
802    (null? (drop '() 0)))
803
804  (pass-if "'(a) 0"
805    (let ((lst '(a)))
806      (eq? lst
807	   (drop lst 0))))
808
809  (pass-if "'(a b) 0"
810    (let ((lst '(a b)))
811      (eq? lst
812	   (drop lst 0))))
813
814  (pass-if "'(a) 1"
815    (let ((lst '(a)))
816      (eq? (cdr lst)
817	   (drop lst 1))))
818
819  (pass-if "'(a b) 1"
820    (let ((lst '(a b)))
821      (eq? (cdr lst)
822	   (drop lst 1))))
823
824  (pass-if "'(a b) 2"
825    (let ((lst '(a b)))
826      (eq? (cddr lst)
827	   (drop lst 2))))
828
829  (pass-if "'(a b c) 1"
830    (let ((lst '(a b c)))
831      (eq? (cddr lst)
832	   (drop lst 2))))
833
834  (pass-if "circular '(a) 0"
835    (let ((lst (circular-list 'a)))
836      (eq? lst
837	   (drop lst 0))))
838
839  (pass-if "circular '(a) 1"
840    (let ((lst (circular-list 'a)))
841      (eq? lst
842	   (drop lst 1))))
843
844  (pass-if "circular '(a) 2"
845    (let ((lst (circular-list 'a)))
846      (eq? lst
847	   (drop lst 1))))
848
849  (pass-if "circular '(a b) 1"
850    (let ((lst (circular-list 'a)))
851      (eq? (cdr lst)
852	   (drop lst 0))))
853
854  (pass-if "circular '(a b) 2"
855    (let ((lst (circular-list 'a)))
856      (eq? lst
857	   (drop lst 1))))
858
859  (pass-if "circular '(a b) 5"
860    (let ((lst (circular-list 'a)))
861      (eq? (cdr lst)
862	   (drop lst 5))))
863
864  (pass-if "'(a . b) 1"
865    (eq? 'b
866	 (drop '(a . b) 1)))
867
868  (pass-if "'(a b . c) 1"
869    (equal? 'c
870	    (drop '(a b . c) 2))))
871
872;;
873;; drop-right
874;;
875
876(with-test-prefix "drop-right"
877
878  (pass-if-exception "() -1" exception:out-of-range
879    (drop-right '() -1))
880  (pass-if (equal? '() (drop-right '() 0)))
881  (pass-if-exception "() 1" exception:wrong-type-arg
882    (drop-right '() 1))
883
884  (pass-if-exception "(1) -1" exception:out-of-range
885    (drop-right '(1) -1))
886  (pass-if (equal? '(1) (drop-right '(1) 0)))
887  (pass-if (equal? '() (drop-right '(1) 1)))
888  (pass-if-exception "(1) 2" exception:wrong-type-arg
889    (drop-right '(1) 2))
890
891  (pass-if-exception "(4 5) -1" exception:out-of-range
892    (drop-right '(4 5) -1))
893  (pass-if (equal? '(4 5) (drop-right '(4 5) 0)))
894  (pass-if (equal? '(4) (drop-right '(4 5) 1)))
895  (pass-if (equal? '() (drop-right '(4 5) 2)))
896  (pass-if-exception "(4 5) 3" exception:wrong-type-arg
897    (drop-right '(4 5) 3))
898
899  (pass-if-exception "(4 5 6) -1" exception:out-of-range
900    (drop-right '(4 5 6) -1))
901  (pass-if (equal? '(4 5 6) (drop-right '(4 5 6) 0)))
902  (pass-if (equal? '(4 5) (drop-right '(4 5 6) 1)))
903  (pass-if (equal? '(4) (drop-right '(4 5 6) 2)))
904  (pass-if (equal? '() (drop-right '(4 5 6) 3)))
905  (pass-if-exception "(4 5 6) 4" exception:wrong-type-arg
906    (drop-right '(4 5 6) 4))
907
908  (pass-if "(a b . c) 0"
909    (equal? (drop-right '(a b . c) 0) '(a b)))
910  (pass-if "(a b . c) 1"
911    (equal? (drop-right '(a b . c) 1) '(a))))
912
913;;
914;; drop-right!
915;;
916
917(with-test-prefix "drop-right!"
918
919  (pass-if-exception "() -1" exception:out-of-range
920    (drop-right! '() -1))
921  (pass-if (equal? '() (drop-right! '() 0)))
922  (pass-if-exception "() 1" exception:wrong-type-arg
923    (drop-right! '() 1))
924
925  (pass-if-exception "(1) -1" exception:out-of-range
926    (drop-right! (list 1) -1))
927  (pass-if (equal? '(1) (drop-right! (list 1) 0)))
928  (pass-if (equal? '() (drop-right! (list 1) 1)))
929  (pass-if-exception "(1) 2" exception:wrong-type-arg
930    (drop-right! (list 1) 2))
931
932  (pass-if-exception "(4 5) -1" exception:out-of-range
933    (drop-right! (list 4 5) -1))
934  (pass-if (equal? '(4 5) (drop-right! (list 4 5) 0)))
935  (pass-if (equal? '(4) (drop-right! (list 4 5) 1)))
936  (pass-if (equal? '() (drop-right! (list 4 5) 2)))
937  (pass-if-exception "(4 5) 3" exception:wrong-type-arg
938    (drop-right! (list 4 5) 3))
939
940  (pass-if-exception "(4 5 6) -1" exception:out-of-range
941    (drop-right! (list 4 5 6) -1))
942  (pass-if (equal? '(4 5 6) (drop-right! (list 4 5 6) 0)))
943  (pass-if (equal? '(4 5) (drop-right! (list 4 5 6) 1)))
944  (pass-if (equal? '(4) (drop-right! (list 4 5 6) 2)))
945  (pass-if (equal? '() (drop-right! (list 4 5 6) 3)))
946  (pass-if-exception "(4 5 6) 4" exception:wrong-type-arg
947    (drop-right! (list 4 5 6) 4)))
948
949;;
950;; drop-while
951;;
952
953(with-test-prefix "drop-while"
954
955  (pass-if (equal? '()      (drop-while odd? '())))
956  (pass-if (equal? '()      (drop-while odd? '(1))))
957  (pass-if (equal? '()      (drop-while odd? '(1 3))))
958  (pass-if (equal? '()      (drop-while odd? '(1 3 5))))
959
960  (pass-if (equal? '(2)     (drop-while odd? '(2))))
961  (pass-if (equal? '(2)     (drop-while odd? '(1 2))))
962  (pass-if (equal? '(4)     (drop-while odd? '(1 3 4))))
963
964  (pass-if (equal? '(2 1)   (drop-while odd? '(2 1))))
965  (pass-if (equal? '(4 3)   (drop-while odd? '(1 4 3))))
966  (pass-if (equal? '(4 1 3) (drop-while odd? '(4 1 3)))))
967
968;;
969;; eighth
970;;
971
972(with-test-prefix "eighth"
973  (pass-if-exception "() -1" exception:wrong-type-arg
974    (eighth '(a b c d e f g)))
975  (pass-if (eq? 'h (eighth '(a b c d e f g h))))
976  (pass-if (eq? 'h (eighth '(a b c d e f g h i)))))
977
978;;
979;; fifth
980;;
981
982(with-test-prefix "fifth"
983  (pass-if-exception "() -1" exception:wrong-type-arg
984    (fifth '(a b c d)))
985  (pass-if (eq? 'e (fifth '(a b c d e))))
986  (pass-if (eq? 'e (fifth '(a b c d e f)))))
987
988;;
989;; filter-map
990;;
991
992(with-test-prefix "filter-map"
993
994  (with-test-prefix "one list"
995    (pass-if-exception "'x" exception:wrong-type-arg
996      (filter-map noop 'x))
997
998    (pass-if-exception "'(1 . x)" exception:wrong-type-arg
999      (filter-map noop '(1 . x)))
1000
1001    (pass-if "(1)"
1002      (equal? '(1) (filter-map noop '(1))))
1003
1004    (pass-if "(#f)"
1005      (equal? '() (filter-map noop '(#f))))
1006
1007    (pass-if "(1 2)"
1008      (equal? '(1 2) (filter-map noop '(1 2))))
1009
1010    (pass-if "(#f 2)"
1011      (equal? '(2) (filter-map noop '(#f 2))))
1012
1013    (pass-if "(#f #f)"
1014      (equal? '() (filter-map noop '(#f #f))))
1015
1016    (pass-if "(1 2 3)"
1017      (equal? '(1 2 3) (filter-map noop '(1 2 3))))
1018
1019    (pass-if "(#f 2 3)"
1020      (equal? '(2 3) (filter-map noop '(#f 2 3))))
1021
1022    (pass-if "(1 #f 3)"
1023      (equal? '(1 3) (filter-map noop '(1 #f 3))))
1024
1025    (pass-if "(1 2 #f)"
1026      (equal? '(1 2) (filter-map noop '(1 2 #f)))))
1027
1028  (with-test-prefix "two lists"
1029    (pass-if-exception "'x '(1 2 3)" exception:wrong-type-arg
1030      (filter-map noop 'x '(1 2 3)))
1031
1032    (pass-if-exception "'(1 2 3) 'x" exception:wrong-type-arg
1033      (filter-map noop '(1 2 3) 'x))
1034
1035    (pass-if-exception "'(1 . x) '(1 2 3)" exception:wrong-type-arg
1036      (filter-map noop '(1 . x) '(1 2 3)))
1037
1038    (pass-if-exception "'(1 2 3) '(1 . x)" exception:wrong-type-arg
1039      (filter-map noop '(1 2 3) '(1 . x)))
1040
1041    (pass-if "(1 2 3) (4 5 6)"
1042      (equal? '(5 7 9) (filter-map + '(1 2 3) '(4 5 6))))
1043
1044    (pass-if "(#f 2 3) (4 5)"
1045      (equal? '(2) (filter-map noop '(#f 2 3) '(4 5))))
1046
1047    (pass-if "(4 #f) (1 2 3)"
1048      (equal? '(4) (filter-map noop '(4 #f) '(1 2 3))))
1049
1050    (pass-if "() (1 2 3)"
1051      (equal? '() (filter-map noop '() '(1 2 3))))
1052
1053    (pass-if "(1 2 3) ()"
1054      (equal? '() (filter-map noop '(1 2 3) '()))))
1055
1056  (with-test-prefix "three lists"
1057    (pass-if-exception "'x '(1 2 3) '(1 2 3)" exception:wrong-type-arg
1058      (filter-map noop 'x '(1 2 3) '(1 2 3)))
1059
1060    (pass-if-exception "'(1 2 3) 'x '(1 2 3)" exception:wrong-type-arg
1061      (filter-map noop '(1 2 3) 'x '(1 2 3)))
1062
1063    (pass-if-exception "'(1 2 3) '(1 2 3) 'x" exception:wrong-type-arg
1064      (filter-map noop '(1 2 3) '(1 2 3) 'x))
1065
1066    (pass-if-exception "'(1 . x) '(1 2 3) '(1 2 3)" exception:wrong-type-arg
1067      (filter-map noop '(1 . x) '(1 2 3) '(1 2 3)))
1068
1069    (pass-if-exception "'(1 2 3) '(1 . x) '(1 2 3)" exception:wrong-type-arg
1070      (filter-map noop '(1 2 3) '(1 . x) '(1 2 3)))
1071
1072    (pass-if-exception "'(1 2 3) '(1 2 3) '(1 . x)" exception:wrong-type-arg
1073      (filter-map noop '(1 2 3) '(1 2 3) '(1 . x)))
1074
1075    (pass-if "(1 2 3) (4 5 6) (7 8 9)"
1076      (equal? '(12 15 18) (filter-map + '(1 2 3) '(4 5 6) '(7 8 9))))
1077
1078    (pass-if "(#f 2 3) (4 5) (7 8 9)"
1079      (equal? '(2) (filter-map noop '(#f 2 3) '(4 5) '(7 8 9))))
1080
1081    (pass-if "(#f 2 3) (7 8 9) (4 5)"
1082      (equal? '(2) (filter-map noop '(#f 2 3) '(7 8 9) '(4 5))))
1083
1084    (pass-if "(4 #f) (1 2 3) (7 8 9)"
1085      (equal? '(4) (filter-map noop '(4 #f) '(1 2 3) '(7 8 9))))
1086
1087    (pass-if "apply list unchanged"
1088      (let ((lst (list (list 1 #f 2) (list 3 4 5) (list 6 7 8))))
1089	(and (equal? '(1 2) (apply filter-map noop lst))
1090	     ;; lst unmodified
1091	     (equal? lst '((1 #f 2) (3 4 5) (6 7 8))))))))
1092
1093;;
1094;; find
1095;;
1096
1097(with-test-prefix "find"
1098  (pass-if (eqv? #f (find odd? '())))
1099  (pass-if (eqv? #f (find odd? '(0))))
1100  (pass-if (eqv? #f (find odd? '(0 2))))
1101  (pass-if (eqv? 1 (find odd? '(1))))
1102  (pass-if (eqv? 1 (find odd? '(0 1))))
1103  (pass-if (eqv? 1 (find odd? '(0 1 2))))
1104  (pass-if (eqv? 1 (find odd? '(2 0 1))))
1105  (pass-if (eqv? 1 (find (lambda (x) (= 1 x)) '(2 0 1)))))
1106
1107;;
1108;; find-tail
1109;;
1110
1111(with-test-prefix "find-tail"
1112  (pass-if (let ((lst '()))
1113	     (eq? #f (find-tail odd? lst))))
1114  (pass-if (let ((lst '(0)))
1115	     (eq? #f (find-tail odd? lst))))
1116  (pass-if (let ((lst '(0 2)))
1117	     (eq? #f (find-tail odd? lst))))
1118  (pass-if (let ((lst '(1)))
1119	     (eq? lst (find-tail odd? lst))))
1120  (pass-if (let ((lst '(1 2)))
1121	     (eq? lst (find-tail odd? lst))))
1122  (pass-if (let ((lst '(2 1)))
1123	     (eq? (cdr lst) (find-tail odd? lst))))
1124  (pass-if (let ((lst '(2 1 0)))
1125	     (eq? (cdr lst) (find-tail odd? lst))))
1126  (pass-if (let ((lst '(2 0 1)))
1127	     (eq? (cddr lst) (find-tail odd? lst))))
1128  (pass-if (let ((lst '(2 0 1)))
1129	     (eq? (cddr lst) (find-tail (lambda (x) (= 1 x)) lst)))))
1130
1131;;
1132;; fold
1133;;
1134
1135(with-test-prefix "fold"
1136  (pass-if-exception "no args" exception:wrong-num-args
1137    (fold))
1138
1139  (pass-if-exception "one arg" exception:wrong-num-args
1140    (fold 123))
1141
1142  (pass-if-exception "two args" exception:wrong-num-args
1143    (fold 123 noop))
1144
1145  (with-test-prefix "one list"
1146
1147    (pass-if "arg order"
1148      (eq? #t (fold (lambda (x prev)
1149		      (and (= 1 x)
1150			   (= 2 prev)))
1151		    2 '(1))))
1152
1153    (pass-if "empty list" (= 123 (fold + 123 '())))
1154
1155    (pass-if-exception "proc arg count 0" exception:wrong-num-args
1156      (fold (lambda () x) 123 '(1 2 3)))
1157    (pass-if-exception "proc arg count 1" exception:wrong-num-args
1158      (fold (lambda (x) x) 123 '(1 2 3)))
1159    (pass-if-exception "proc arg count 3" exception:wrong-num-args
1160      (fold (lambda (x y z) x) 123 '(1 2 3)))
1161
1162    (pass-if-exception "improper 1" exception:wrong-type-arg
1163      (fold + 123 1))
1164    (pass-if-exception "improper 2" exception:wrong-type-arg
1165      (fold + 123 '(1 . 2)))
1166    (pass-if-exception "improper 3" exception:wrong-type-arg
1167      (fold + 123 '(1 2 . 3)))
1168
1169    (pass-if (= 3 (fold + 1 '(2))))
1170    (pass-if (= 6 (fold + 1 '(2 3))))
1171    (pass-if (= 10 (fold + 1 '(2 3 4)))))
1172
1173  (with-test-prefix "two lists"
1174
1175    (pass-if "arg order"
1176      (eq? #t (fold (lambda (x y prev)
1177		      (and (= 1 x)
1178			   (= 2 y)
1179			   (= 3 prev)))
1180		    3 '(1) '(2))))
1181
1182    (pass-if "empty lists" (= 1 (fold + 1 '() '())))
1183
1184    ;; currently bad proc argument gives wrong-num-args when 2 or more
1185    ;; lists, as opposed to wrong-type-arg for 1 list
1186    (pass-if-exception "proc arg count 2" exception:wrong-num-args
1187      (fold (lambda (x prev) x) 1 '(1 2 3) '(1 2 3)))
1188    (pass-if-exception "proc arg count 4" exception:wrong-num-args
1189      (fold (lambda (x y z prev) x) 1 '(1 2 3) '(1 2 3)))
1190
1191    (pass-if-exception "improper first 1" exception:wrong-type-arg
1192      (fold + 1 1 '(1 2 3)))
1193    (pass-if-exception "improper first 2" exception:wrong-type-arg
1194      (fold + 1 '(1 . 2) '(1 2 3)))
1195    (pass-if-exception "improper first 3" exception:wrong-type-arg
1196      (fold + 1 '(1 2 . 3) '(1 2 3)))
1197
1198    (pass-if-exception "improper second 1" exception:wrong-type-arg
1199      (fold + 1 '(1 2 3) 1))
1200    (pass-if-exception "improper second 2" exception:wrong-type-arg
1201      (fold + 1 '(1 2 3) '(1 . 2)))
1202    (pass-if-exception "improper second 3" exception:wrong-type-arg
1203      (fold + 1 '(1 2 3) '(1 2 . 3)))
1204
1205    (pass-if (= 6 (fold + 1 '(2) '(3))))
1206    (pass-if (= 15 (fold + 1 '(2 3) '(4 5))))
1207    (pass-if (= 28 (fold + 1 '(2 3 4) '(5 6 7))))
1208
1209    (with-test-prefix "stop shortest"
1210      (pass-if (= 13 (fold + 1 '(1 2 3) '(4 5))))
1211      (pass-if (= 13 (fold + 1 '(4 5) '(1 2 3))))
1212      (pass-if (= 11 (fold + 1 '(3 4) '(1 2 9 9))))
1213      (pass-if (= 11 (fold + 1 '(1 2 9 9) '(3 4)))))
1214
1215    (pass-if "apply list unchanged"
1216      (let ((lst (list (list 1 2) (list 3 4))))
1217	(and (equal? 11 (apply fold + 1 lst))
1218	     ;; lst unmodified
1219	     (equal? '((1 2) (3 4)) lst)))))
1220
1221  (with-test-prefix "three lists"
1222
1223    (pass-if "arg order"
1224      (eq? #t (fold (lambda (x y z prev)
1225		      (and (= 1 x)
1226			   (= 2 y)
1227			   (= 3 z)
1228			   (= 4 prev)))
1229		    4 '(1) '(2) '(3))))
1230
1231    (pass-if "empty lists" (= 1 (fold + 1 '() '() '())))
1232
1233    (pass-if-exception "proc arg count 3" exception:wrong-num-args
1234      (fold (lambda (x y prev) x) 1 '(1 2 3) '(1 2 3)'(1 2 3) ))
1235    (pass-if-exception "proc arg count 5" exception:wrong-num-args
1236      (fold (lambda (w x y z prev) x) 1 '(1 2 3) '(1 2 3) '(1 2 3)))
1237
1238    (pass-if-exception "improper first 1" exception:wrong-type-arg
1239      (fold + 1 1 '(1 2 3) '(1 2 3)))
1240    (pass-if-exception "improper first 2" exception:wrong-type-arg
1241      (fold + 1 '(1 . 2) '(1 2 3) '(1 2 3)))
1242    (pass-if-exception "improper first 3" exception:wrong-type-arg
1243      (fold + 1 '(1 2 . 3) '(1 2 3) '(1 2 3)))
1244
1245    (pass-if-exception "improper second 1" exception:wrong-type-arg
1246      (fold + 1 '(1 2 3) 1 '(1 2 3)))
1247    (pass-if-exception "improper second 2" exception:wrong-type-arg
1248      (fold + 1 '(1 2 3) '(1 . 2) '(1 2 3)))
1249    (pass-if-exception "improper second 3" exception:wrong-type-arg
1250      (fold + 1 '(1 2 3) '(1 2 . 3) '(1 2 3)))
1251
1252    (pass-if-exception "improper third 1" exception:wrong-type-arg
1253      (fold + 1 '(1 2 3) '(1 2 3) 1))
1254    (pass-if-exception "improper third 2" exception:wrong-type-arg
1255      (fold + 1 '(1 2 3) '(1 2 3) '(1 . 2)))
1256    (pass-if-exception "improper third 3" exception:wrong-type-arg
1257      (fold + 1 '(1 2 3) '(1 2 3) '(1 2 . 3)))
1258
1259    (pass-if (= 10 (fold + 1 '(2) '(3) '(4))))
1260    (pass-if (= 28 (fold + 1 '(2 5) '(3 6) '(4 7))))
1261    (pass-if (= 55 (fold + 1 '(2 5 8) '(3 6 9) '(4 7 10))))
1262
1263    (with-test-prefix "stop shortest"
1264      (pass-if (= 28 (fold + 1 '(2 5 9) '(3 6) '(4 7))))
1265      (pass-if (= 28 (fold + 1 '(2 5) '(3 6 9) '(4 7))))
1266      (pass-if (= 28 (fold + 1 '(2 5) '(3 6) '(4 7 9)))))
1267
1268    (pass-if "apply list unchanged"
1269      (let ((lst (list (list 1 2) (list 3 4) (list 5 6))))
1270	(and (equal? 22 (apply fold + 1 lst))
1271	     ;; lst unmodified
1272	     (equal? '((1 2) (3 4) (5 6)) lst))))))
1273
1274;;
1275;; fold-right
1276;;
1277
1278(with-test-prefix "fold-right"
1279
1280  (pass-if "one list"
1281    (equal? (iota 10)
1282            (fold-right cons '() (iota 10))))
1283
1284  (pass-if "two lists"
1285    (equal? (zip (iota 10) (map integer->char (iota 10)))
1286            (fold-right (lambda (x y z)
1287                          (cons (list x y) z))
1288                        '()
1289                        (iota 10)
1290                        (map integer->char (iota 10)))))
1291
1292  (pass-if "tail-recursive"
1293    (= 1e6 (fold-right (lambda (x y) (+ 1 y))
1294                       0
1295                       (iota 1e6)))))
1296;;
1297;; unfold
1298;;
1299
1300(with-test-prefix "unfold"
1301
1302  (pass-if "basic"
1303    (equal? (iota 10)
1304            (unfold (lambda (x) (>= x 10))
1305                    identity
1306                    1+
1307                    0)))
1308
1309  (pass-if "tail-gen"
1310    (equal? (append (iota 10) '(tail 10))
1311            (unfold (lambda (x) (>= x 10))
1312                    identity
1313                    1+
1314                    0
1315                    (lambda (seed) (list 'tail seed)))))
1316
1317  (pass-if "tail-recursive"
1318    ;; Bug #30071.
1319    (pair? (unfold (lambda (x) (>= x 1e6))
1320                   identity
1321                   1+
1322                   0))))
1323
1324;;
1325;; length+
1326;;
1327
1328(with-test-prefix "length+"
1329  (pass-if-exception "too few args" exception:wrong-num-args
1330    (length+))
1331  (pass-if-exception "too many args" exception:wrong-num-args
1332    (length+ 123 456))
1333  (pass-if-exception "not a pair" exception:wrong-type-arg
1334    (length+ 'x))
1335  (pass-if-exception "improper list" exception:wrong-type-arg
1336    (length+ '(x y . z)))
1337  (pass-if (= 0 (length+ '())))
1338  (pass-if (= 1 (length+ '(x))))
1339  (pass-if (= 2 (length+ '(x y))))
1340  (pass-if (= 3 (length+ '(x y z))))
1341  (pass-if (not (length+ (circular-list 1))))
1342  (pass-if (not (length+ (circular-list 1 2))))
1343  (pass-if (not (length+ (circular-list 1 2 3)))))
1344
1345;;
1346;; last
1347;;
1348
1349(with-test-prefix "last"
1350
1351  (pass-if-exception "empty" exception:wrong-type-arg
1352    (last '()))
1353  (pass-if "one elem"
1354    (eqv? 1 (last '(1))))
1355  (pass-if "two elems"
1356    (eqv? 2 (last '(1 2))))
1357  (pass-if "three elems"
1358    (eqv? 3 (last '(1 2 3))))
1359  (pass-if "four elems"
1360    (eqv? 4 (last '(1 2 3 4)))))
1361
1362;;
1363;; list=
1364;;
1365
1366(with-test-prefix "list="
1367
1368  (pass-if "no lists"
1369    (eq? #t (list= eqv?)))
1370
1371  (with-test-prefix "one list"
1372
1373    (pass-if "empty"
1374      (eq? #t (list= eqv? '())))
1375    (pass-if "one elem"
1376      (eq? #t (list= eqv? '(1))))
1377    (pass-if "two elems"
1378      (eq? #t (list= eqv? '(2)))))
1379
1380  (with-test-prefix "two lists"
1381
1382    (pass-if "empty / empty"
1383      (eq? #t (list= eqv? '() '())))
1384
1385    (pass-if "one / empty"
1386      (eq? #f (list= eqv? '(1) '())))
1387
1388    (pass-if "empty / one"
1389      (eq? #f (list= eqv? '() '(1))))
1390
1391    (pass-if "one / one same"
1392      (eq? #t (list= eqv? '(1) '(1))))
1393
1394    (pass-if "one / one diff"
1395      (eq? #f (list= eqv? '(1) '(2))))
1396
1397    (pass-if "called arg order"
1398      (let ((good #t))
1399	(list= (lambda (x y)
1400		 (set! good (and good (= (1+ x) y)))
1401		 #t)
1402	       '(1 3) '(2 4))
1403	good)))
1404
1405  (with-test-prefix "three lists"
1406
1407    (pass-if "empty / empty / empty"
1408      (eq? #t (list= eqv? '() '() '())))
1409
1410    (pass-if "one / empty / empty"
1411      (eq? #f (list= eqv? '(1) '() '())))
1412
1413    (pass-if "one / one / empty"
1414      (eq? #f (list= eqv? '(1) '(1) '())))
1415
1416    (pass-if "one / diff / empty"
1417      (eq? #f (list= eqv? '(1) '(2) '())))
1418
1419    (pass-if "one / one / one"
1420      (eq? #t (list= eqv? '(1) '(1) '(1))))
1421
1422    (pass-if "two / two / diff"
1423      (eq? #f (list= eqv? '(1 2) '(1 2) '(1 99))))
1424
1425    (pass-if "two / two / two"
1426      (eq? #t (list= eqv? '(1 2) '(1 2) '(1 2))))
1427
1428    (pass-if "called arg order"
1429      (let ((good #t))
1430	(list= (lambda (x y)
1431		 (set! good (and good (= (1+ x) y)))
1432		 #t)
1433	       '(1 4) '(2 5) '(3 6))
1434	good))))
1435
1436;;
1437;; list-copy
1438;;
1439
1440(with-test-prefix "list-copy"
1441  (pass-if (equal? '()          (list-copy '())))
1442  (pass-if (equal? '(1 2)       (list-copy '(1 2))))
1443  (pass-if (equal? '(1 2 3)     (list-copy '(1 2 3))))
1444  (pass-if (equal? '(1 2 3 4)   (list-copy '(1 2 3 4))))
1445  (pass-if (equal? '(1 2 3 4 5) (list-copy '(1 2 3 4 5))))
1446
1447  ;; improper lists can be copied
1448  (pass-if (equal? 1              (list-copy 1)))
1449  (pass-if (equal? '(1 . 2)       (list-copy '(1 . 2))))
1450  (pass-if (equal? '(1 2 . 3)     (list-copy '(1 2 . 3))))
1451  (pass-if (equal? '(1 2 3 . 4)   (list-copy '(1 2 3 . 4))))
1452  (pass-if (equal? '(1 2 3 4 . 5) (list-copy '(1 2 3 4 . 5)))))
1453
1454;;
1455;; list-index
1456;;
1457
1458(with-test-prefix "list-index"
1459  (pass-if-exception "no args" exception:wrong-num-args
1460    (list-index))
1461
1462  (pass-if-exception "one arg" exception:wrong-num-args
1463    (list-index noop))
1464
1465  (with-test-prefix "one list"
1466
1467    (pass-if "empty list" (eq? #f (list-index symbol? '())))
1468
1469    (pass-if-exception "pred arg count 0" exception:wrong-num-args
1470      (list-index (lambda () x) '(1 2 3)))
1471    (pass-if-exception "pred arg count 2" exception:wrong-num-args
1472      (list-index (lambda (x y) x) '(1 2 3)))
1473
1474    (pass-if-exception "improper 1" exception:wrong-type-arg
1475      (list-index symbol? 1))
1476    (pass-if-exception "improper 2" exception:wrong-type-arg
1477      (list-index symbol? '(1 . 2)))
1478    (pass-if-exception "improper 3" exception:wrong-type-arg
1479      (list-index symbol? '(1 2 . 3)))
1480
1481    (pass-if (eqv? #f (list-index symbol? '(1))))
1482    (pass-if (eqv? 0 (list-index symbol? '(x))))
1483
1484    (pass-if (eqv? #f (list-index symbol? '(1 2))))
1485    (pass-if (eqv? 0 (list-index symbol? '(x 1))))
1486    (pass-if (eqv? 1 (list-index symbol? '(1 x))))
1487
1488    (pass-if (eqv? #f (list-index symbol? '(1 2 3))))
1489    (pass-if (eqv? 0 (list-index symbol? '(x 1 2))))
1490    (pass-if (eqv? 1 (list-index symbol? '(1 x 2))))
1491    (pass-if (eqv? 2 (list-index symbol? '(1 2 x)))))
1492
1493  (with-test-prefix "two lists"
1494    (define (sym1 x y)
1495      (symbol? x))
1496    (define (sym2 x y)
1497      (symbol? y))
1498
1499    (pass-if "arg order"
1500      (eqv? 0 (list-index (lambda (x y)
1501			    (and (= 1 x)
1502				 (= 2 y)))
1503			  '(1) '(2))))
1504
1505    (pass-if "empty lists" (eqv? #f (list-index sym2 '() '())))
1506
1507    (pass-if-exception "pred arg count 0" exception:wrong-num-args
1508      (list-index (lambda () #t) '(1 2 3) '(1 2 3)))
1509    (pass-if-exception "pred arg count 1" exception:wrong-num-args
1510      (list-index (lambda (x) x) '(1 2 3) '(1 2 3)))
1511    (pass-if-exception "pred arg count 3" exception:wrong-num-args
1512      (list-index (lambda (x y z) x) '(1 2 3) '(1 2 3)))
1513
1514    (pass-if-exception "improper first 1" exception:wrong-type-arg
1515      (list-index sym2 1 '(1 2 3)))
1516    (pass-if-exception "improper first 2" exception:wrong-type-arg
1517      (list-index sym2 '(1 . 2) '(1 2 3)))
1518    (pass-if-exception "improper first 3" exception:wrong-type-arg
1519      (list-index sym2 '(1 2 . 3) '(1 2 3)))
1520
1521    (pass-if-exception "improper second 1" exception:wrong-type-arg
1522      (list-index sym2 '(1 2 3) 1))
1523    (pass-if-exception "improper second 2" exception:wrong-type-arg
1524      (list-index sym2 '(1 2 3) '(1 . 2)))
1525    (pass-if-exception "improper second 3" exception:wrong-type-arg
1526      (list-index sym2 '(1 2 3) '(1 2 . 3)))
1527
1528    (pass-if (eqv? #f (list-index sym2 '(1) '(2))))
1529    (pass-if (eqv? 0  (list-index sym2 '(1) '(x))))
1530
1531    (pass-if (eqv? #f (list-index sym2 '(1 2) '(3 4))))
1532    (pass-if (eqv? 0  (list-index sym2 '(1 2) '(x 3))))
1533    (pass-if (eqv? 1  (list-index sym2 '(1 2) '(3 x))))
1534
1535    (pass-if (eqv? #f (list-index sym2 '(1 2 3) '(3 4 5))))
1536    (pass-if (eqv? 0  (list-index sym2 '(1 2 3) '(x 3 4))))
1537    (pass-if (eqv? 1  (list-index sym2 '(1 2 3) '(3 x 4))))
1538    (pass-if (eqv? 2  (list-index sym2 '(1 2 3) '(3 4 x))))
1539
1540    (with-test-prefix "stop shortest"
1541      (pass-if (eqv? #f (list-index sym1 '(1 2 x) '(4 5))))
1542      (pass-if (eqv? #f (list-index sym2 '(4 5) '(1 2 x))))
1543      (pass-if (eqv? #f (list-index sym1 '(3 4) '(1 2 x y))))
1544      (pass-if (eqv? #f (list-index sym2 '(1 2 x y) '(3 4))))))
1545
1546  (with-test-prefix "three lists"
1547    (define (sym1 x y z)
1548      (symbol? x))
1549    (define (sym2 x y z)
1550      (symbol? y))
1551    (define (sym3 x y z)
1552      (symbol? z))
1553
1554    (pass-if "arg order"
1555      (eqv? 0 (list-index (lambda (x y z)
1556			    (and (= 1 x)
1557				 (= 2 y)
1558				 (= 3 z)))
1559			  '(1) '(2) '(3))))
1560
1561    (pass-if "empty lists" (eqv? #f (list-index sym3 '() '() '())))
1562
1563    ;; currently bad pred argument gives wrong-num-args when 3 or more
1564    ;; lists, as opposed to wrong-type-arg for 1 or 2 lists
1565    (pass-if-exception "pred arg count 0" exception:wrong-num-args
1566      (list-index (lambda () #t) '(1 2 3) '(1 2 3) '(1 2 3)))
1567    (pass-if-exception "pred arg count 2" exception:wrong-num-args
1568      (list-index (lambda (x y) x) '(1 2 3) '(1 2 3)'(1 2 3) ))
1569    (pass-if-exception "pred arg count 4" exception:wrong-num-args
1570      (list-index (lambda (w x y z) x) '(1 2 3) '(1 2 3) '(1 2 3)))
1571
1572    (pass-if-exception "improper first 1" exception:wrong-type-arg
1573      (list-index sym3 1 '(1 2 3) '(1 2 3)))
1574    (pass-if-exception "improper first 2" exception:wrong-type-arg
1575      (list-index sym3 '(1 . 2) '(1 2 3) '(1 2 3)))
1576    (pass-if-exception "improper first 3" exception:wrong-type-arg
1577      (list-index sym3 '(1 2 . 3) '(1 2 3) '(1 2 3)))
1578
1579    (pass-if-exception "improper second 1" exception:wrong-type-arg
1580      (list-index sym3 '(1 2 3) 1 '(1 2 3)))
1581    (pass-if-exception "improper second 2" exception:wrong-type-arg
1582      (list-index sym3 '(1 2 3) '(1 . 2) '(1 2 3)))
1583    (pass-if-exception "improper second 3" exception:wrong-type-arg
1584      (list-index sym3 '(1 2 3) '(1 2 . 3) '(1 2 3)))
1585
1586    (pass-if-exception "improper third 1" exception:wrong-type-arg
1587      (list-index sym3 '(1 2 3) '(1 2 3) 1))
1588    (pass-if-exception "improper third 2" exception:wrong-type-arg
1589      (list-index sym3 '(1 2 3) '(1 2 3) '(1 . 2)))
1590    (pass-if-exception "improper third 3" exception:wrong-type-arg
1591      (list-index sym3 '(1 2 3) '(1 2 3) '(1 2 . 3)))
1592
1593    (pass-if (eqv? #f (list-index sym3 '(#f) '(#f) '(#f))))
1594    (pass-if (eqv? 0  (list-index sym3 '(#f) '(#f) '(x))))
1595
1596    (pass-if (eqv? #f (list-index sym3 '(#f #f) '(#f #f) '(#f #f))))
1597    (pass-if (eqv? 0  (list-index sym3 '(#f #f) '(#f #f) '(x #f))))
1598    (pass-if (eqv? 1  (list-index sym3 '(#f #f) '(#f #f) '(#f x))))
1599
1600    (pass-if (eqv? #f (list-index sym3 '(#f #f #f) '(#f #f #f) '(#f #f #f))))
1601    (pass-if (eqv? 0  (list-index sym3 '(#f #f #f) '(#f #f #f) '(x #f #f))))
1602    (pass-if (eqv? 1  (list-index sym3 '(#f #f #f) '(#f #f #f) '(#f x #f))))
1603    (pass-if (eqv? 2  (list-index sym3 '(#f #f #f) '(#f #f #f) '(#f #f x))))
1604
1605    (with-test-prefix "stop shortest"
1606      (pass-if (eqv? #f (list-index sym2 '() '(x x x) '(x x))))
1607      (pass-if (eqv? #f (list-index sym1 '(x x x) '() '(x x))))
1608      (pass-if (eqv? #f (list-index sym2 '(x x x) '(x x) '())))
1609
1610      (pass-if (eqv? #f (list-index sym2 '(#t) '(#t x x) '(#t x))))
1611      (pass-if (eqv? #f (list-index sym1 '(#t x x) '(#t) '(#t x))))
1612      (pass-if (eqv? #f (list-index sym1 '(#t x x) '(#t x) '(#t)))))
1613
1614    (pass-if "apply list unchanged"
1615      (let ((lst (list (list 1 2) (list 3 4) (list 5 6))))
1616	(and (equal? #f (apply list-index sym3 lst))
1617	     ;; lst unmodified
1618	     (equal? '((1 2) (3 4) (5 6)) lst))))))
1619
1620;;
1621;; list-tabulate
1622;;
1623
1624(with-test-prefix "list-tabulate"
1625
1626  (pass-if-exception "-1" exception:wrong-type-arg
1627    (list-tabulate -1 identity))
1628  (pass-if "0"
1629    (equal? '() (list-tabulate 0 identity)))
1630  (pass-if "1"
1631    (equal? '(0) (list-tabulate 1 identity)))
1632  (pass-if "2"
1633    (equal? '(0 1) (list-tabulate 2 identity)))
1634  (pass-if "3"
1635    (equal? '(0 1 2) (list-tabulate 3 identity)))
1636  (pass-if "4"
1637    (equal? '(0 1 2 3) (list-tabulate 4 identity)))
1638  (pass-if "string ref proc"
1639    (equal? '(#\a #\b #\c #\d) (list-tabulate 4
1640					      (lambda (i)
1641						(string-ref "abcd" i))))))
1642
1643;;
1644;; lset=
1645;;
1646
1647(with-test-prefix "lset="
1648
1649  ;; in guile 1.6.7 and earlier, lset= incorrectly demanded at least one
1650  ;; list arg
1651  (pass-if "no args"
1652    (eq? #t (lset= eq?)))
1653
1654  (with-test-prefix "one arg"
1655
1656    (pass-if "()"
1657      (eq? #t (lset= eqv? '())))
1658
1659    (pass-if "(1)"
1660      (eq? #t (lset= eqv? '(1))))
1661
1662    (pass-if "(1 2)"
1663      (eq? #t (lset= eqv? '(1 2)))))
1664
1665  (with-test-prefix "two args"
1666
1667    (pass-if "() ()"
1668      (eq? #t (lset= eqv? '() '())))
1669
1670    (pass-if "(1) (1)"
1671      (eq? #t (lset= eqv? '(1) '(1))))
1672
1673    (pass-if "(1) (2)"
1674      (eq? #f (lset= eqv? '(1) '(2))))
1675
1676    (pass-if "(1) (1 2)"
1677      (eq? #f (lset= eqv? '(1) '(1 2))))
1678
1679    (pass-if "(1 2) (2 1)"
1680      (eq? #t (lset= eqv? '(1 2) '(2 1))))
1681
1682    (pass-if "called arg order"
1683      (let ((good #t))
1684	(lset= (lambda (x y)
1685		 (if (not (= x (1- y)))
1686		     (set! good #f))
1687		 #t)
1688	       '(1 1) '(2 2))
1689	good)))
1690
1691  (with-test-prefix "three args"
1692
1693    (pass-if "() () ()"
1694      (eq? #t (lset= eqv? '() '() '())))
1695
1696    (pass-if "(1) (1) (1)"
1697      (eq? #t (lset= eqv? '(1) '(1) '(1))))
1698
1699    (pass-if "(1) (1) (2)"
1700      (eq? #f (lset= eqv? '(1) '(1) '(2))))
1701
1702    (pass-if "(1) (1) (1 2)"
1703      (eq? #f (lset= eqv? '(1) '(1) '(1 2))))
1704
1705    (pass-if "(1 2 3) (3 2 1) (1 3 2)"
1706      (eq? #t (lset= eqv? '(1 2 3) '(3 2 1) '(1 3 2))))
1707
1708    (pass-if "called arg order"
1709      (let ((good #t))
1710	(lset= (lambda (x y)
1711		 (if (not (= x (1- y)))
1712		     (set! good #f))
1713		 #t)
1714	       '(1 1) '(2 2) '(3 3))
1715	good))))
1716
1717;;
1718;; lset-adjoin
1719;;
1720
1721(with-test-prefix "lset-adjoin"
1722
1723  ;; in guile 1.6.7 and earlier, lset-adjoin didn't actually use the given
1724  ;; `=' procedure, all comparisons were just with `equal?
1725  ;;
1726  (with-test-prefix "case-insensitive ="
1727
1728    (pass-if "(\"x\") \"X\""
1729      (equal? '("x") (lset-adjoin string-ci=? '("x") "X"))))
1730
1731  (pass-if "called arg order"
1732    (let ((good #f))
1733      (lset-adjoin (lambda (x y)
1734		     (set! good (and (= x 1) (= y 2)))
1735		     (= x y))
1736		   '(1) 2)
1737      good))
1738
1739  (pass-if (equal? '() (lset-adjoin = '())))
1740
1741  (pass-if (equal? '(1) (lset-adjoin = '() 1)))
1742
1743  (pass-if (equal? '(1) (lset-adjoin = '() 1 1)))
1744
1745  (pass-if (equal? '(2 1) (lset-adjoin = '() 1 2)))
1746
1747  (pass-if (equal? '(3 1 2) (lset-adjoin = '(1 2) 1 2 3 2 1)))
1748
1749  (pass-if "apply list unchanged"
1750    (let ((lst (list 1 2)))
1751      (and (equal? '(2 1 3) (apply lset-adjoin = '(3) lst))
1752	   ;; lst unmodified
1753	   (equal? '(1 2) lst))))
1754
1755  (pass-if "(1 1) 1 1"
1756    (equal? '(1 1) (lset-adjoin = '(1 1) 1 1)))
1757
1758  ;; duplicates among args are cast out
1759  (pass-if "(2) 1 1"
1760    (equal? '(1 2) (lset-adjoin = '(2) 1 1))))
1761
1762;;
1763;; lset-difference
1764;;
1765
1766(with-test-prefix "lset-difference"
1767
1768  (pass-if "called arg order"
1769    (let ((good #f))
1770      (lset-difference (lambda (x y)
1771			 (set! good (and (= x 1) (= y 2)))
1772			 (= x y))
1773		       '(1) '(2))
1774      good)))
1775
1776;;
1777;; lset-difference!
1778;;
1779
1780(with-test-prefix "lset-difference!"
1781
1782  (pass-if-exception "proc - num" exception:wrong-type-arg
1783    (lset-difference! 123 '(4)))
1784  (pass-if-exception "proc - list" exception:wrong-type-arg
1785    (lset-difference! (list 1 2 3) '(4)))
1786
1787  (pass-if "called arg order"
1788    (let ((good #f))
1789      (lset-difference! (lambda (x y)
1790			  (set! good (and (= x 1) (= y 2)))
1791			  (= x y))
1792			(list 1) (list 2))
1793      good))
1794
1795  (pass-if (equal? '() (lset-difference! = '())))
1796  (pass-if (equal? '(1) (lset-difference! = (list 1))))
1797  (pass-if (equal? '(1 2) (lset-difference! = (list 1 2))))
1798
1799  (pass-if (equal? '() (lset-difference! = (list ) '(3))))
1800  (pass-if (equal? '() (lset-difference! = (list 3) '(3))))
1801  (pass-if (equal? '(1) (lset-difference! = (list 1 3) '(3))))
1802  (pass-if (equal? '(1) (lset-difference! = (list 3 1) '(3))))
1803  (pass-if (equal? '(1) (lset-difference! = (list 1 3 3) '(3))))
1804  (pass-if (equal? '(1) (lset-difference! = (list 3 1 3) '(3))))
1805  (pass-if (equal? '(1) (lset-difference! = (list 3 3 1) '(3))))
1806
1807  (pass-if (equal? '(1) (lset-difference! = (list 1 2 3) '(2 3))))
1808  (pass-if (equal? '(1) (lset-difference! = (list 1 2 3) '(3 2))))
1809  (pass-if (equal? '(1) (lset-difference! = (list 1 2 3) '(3) '(2))))
1810  (pass-if (equal? '(1) (lset-difference! = (list 1 2 3) '(2) '(3))))
1811  (pass-if (equal? '(1) (lset-difference! = (list 1 2 3) '(2) '(2 3))))
1812  (pass-if (equal? '(1) (lset-difference! = (list 1 2 3) '(2) '(3 2))))
1813
1814  (pass-if (equal? '(1 2) (lset-difference! = (list 1 2 3) '(3) '(3))))
1815  (pass-if (equal? '(1 2) (lset-difference! = (list 1 3 2) '(3) '(3))))
1816  (pass-if (equal? '(1 2) (lset-difference! = (list 3 1 2) '(3) '(3))))
1817
1818  (pass-if (equal? '(1 2 3) (lset-difference! = (list 1 2 3 4) '(4))))
1819  (pass-if (equal? '(1 2 3) (lset-difference! = (list 1 2 4 3) '(4))))
1820  (pass-if (equal? '(1 2 3) (lset-difference! = (list 1 4 2 3) '(4))))
1821  (pass-if (equal? '(1 2 3) (lset-difference! = (list 4 1 2 3) '(4))))
1822
1823  (pass-if (equal? '(1 2) (lset-difference! = (list 1 2 3 4) '(4) '(3))))
1824  (pass-if (equal? '(1 2) (lset-difference! = (list 1 3 2 4) '(4) '(3))))
1825  (pass-if (equal? '(1 2) (lset-difference! = (list 3 1 2 4) '(4) '(3))))
1826  (pass-if (equal? '(1 2) (lset-difference! = (list 1 3 4 2) '(4) '(3))))
1827  (pass-if (equal? '(1 2) (lset-difference! = (list 3 1 4 2) '(4) '(3))))
1828  (pass-if (equal? '(1 2) (lset-difference! = (list 3 4 1 2) '(4) '(3)))))
1829
1830;;
1831;; lset-diff+intersection
1832;;
1833
1834(with-test-prefix "lset-diff+intersection"
1835
1836  (pass-if "called arg order"
1837    (let ((good #f))
1838      (lset-diff+intersection (lambda (x y)
1839				(set! good (and (= x 1) (= y 2)))
1840				(= x y))
1841			      '(1) '(2))
1842      good)))
1843
1844;;
1845;; lset-diff+intersection!
1846;;
1847
1848(with-test-prefix "lset-diff+intersection"
1849
1850  (pass-if "called arg order"
1851    (let ((good #f))
1852      (lset-diff+intersection (lambda (x y)
1853				(set! good (and (= x 1) (= y 2)))
1854				(= x y))
1855			      (list 1) (list 2))
1856      good)))
1857
1858;;
1859;; lset-intersection
1860;;
1861
1862(with-test-prefix "lset-intersection"
1863
1864  (pass-if "called arg order"
1865    (let ((good #f))
1866      (lset-intersection (lambda (x y)
1867			   (set! good (and (= x 1) (= y 2)))
1868			   (= x y))
1869			 '(1) '(2))
1870      good)))
1871
1872;;
1873;; lset-intersection!
1874;;
1875
1876(with-test-prefix "lset-intersection"
1877
1878  (pass-if "called arg order"
1879    (let ((good #f))
1880      (lset-intersection (lambda (x y)
1881			   (set! good (and (= x 1) (= y 2)))
1882			   (= x y))
1883			 (list 1) (list 2))
1884      good)))
1885
1886;;
1887;; lset-union
1888;;
1889
1890(with-test-prefix "lset-union"
1891
1892  (pass-if "no args"
1893    (eq? '() (lset-union eq?)))
1894
1895  (pass-if "one arg"
1896    (equal? '(1 2 3) (lset-union eq? '(1 2 3))))
1897
1898  (pass-if "'() '()"
1899    (equal? '() (lset-union eq? '() '())))
1900
1901  (pass-if "'() '(1 2 3)"
1902    (equal? '(1 2 3) (lset-union eq? '() '(1 2 3))))
1903
1904  (pass-if "'(1 2 3) '()"
1905    (equal? '(1 2 3) (lset-union eq? '(1 2 3) '())))
1906
1907  (pass-if "'(1 2 3) '(4 3 5)"
1908    (equal? '(5 4 1 2 3) (lset-union eq? '(1 2 3) '(4 3 5))))
1909
1910  (pass-if "'(1 2 3) '(4) '(3 5))"
1911    (equal? '(5 4 1 2 3) (lset-union eq? '(1 2 3) '(4) '(3 5))))
1912
1913  ;; in guile 1.6.7 and earlier, `=' was called with the arguments the wrong
1914  ;; way around
1915  (pass-if "called arg order"
1916    (let ((good #f))
1917      (lset-union (lambda (x y)
1918		    (set! good (and (= x 1) (= y 2)))
1919		    (= x y))
1920		  '(1) '(2))
1921      good)))
1922
1923;;
1924;; member
1925;;
1926
1927(with-test-prefix "member"
1928
1929  (pass-if-exception "no args" exception:wrong-num-args
1930    (member))
1931
1932  (pass-if-exception "one arg" exception:wrong-num-args
1933    (member 1))
1934
1935  (pass-if "1 (1 2 3)"
1936    (let ((lst '(1 2 3)))
1937      (eq? lst (member 1 lst))))
1938
1939  (pass-if "2 (1 2 3)"
1940    (let ((lst '(1 2 3)))
1941      (eq? (cdr lst) (member 2 lst))))
1942
1943  (pass-if "3 (1 2 3)"
1944    (let ((lst '(1 2 3)))
1945      (eq? (cddr lst) (member 3 lst))))
1946
1947  (pass-if "4 (1 2 3)"
1948    (let ((lst '(1 2 3)))
1949      (eq? #f (member 4 lst))))
1950
1951  (pass-if "called arg order"
1952    (let ((good #f))
1953      (member 1 '(2) (lambda (x y)
1954		       (set! good (and (eqv? 1 x)
1955				       (eqv? 2 y)))))
1956      good)))
1957
1958;;
1959;; ninth
1960;;
1961
1962(with-test-prefix "ninth"
1963  (pass-if-exception "() -1" exception:wrong-type-arg
1964    (ninth '(a b c d e f g h)))
1965  (pass-if (eq? 'i (ninth '(a b c d e f g h i))))
1966  (pass-if (eq? 'i (ninth '(a b c d e f g h i j)))))
1967
1968
1969;;
1970;; not-pair?
1971;;
1972
1973(with-test-prefix "not-pair?"
1974  (pass-if "inum"
1975    (eq? #t (not-pair? 123)))
1976  (pass-if "pair"
1977    (eq? #f (not-pair? '(x . y))))
1978  (pass-if "symbol"
1979    (eq? #t (not-pair? 'x))))
1980
1981;;
1982;; take
1983;;
1984
1985(with-test-prefix "take"
1986
1987  (pass-if "'() 0"
1988    (null? (take '() 0)))
1989
1990  (pass-if "'(a) 0"
1991    (null? (take '(a) 0)))
1992
1993  (pass-if "'(a b) 0"
1994    (null? (take '() 0)))
1995
1996  (pass-if "'(a b c) 0"
1997    (null? (take '() 0)))
1998
1999  (pass-if "'(a) 1"
2000    (let* ((lst '(a))
2001	   (got (take lst 1)))
2002      (and (equal? '(a) got)
2003	   (not (eq? lst got)))))
2004
2005  (pass-if "'(a b) 1"
2006    (equal? '(a)
2007	    (take '(a b) 1)))
2008
2009  (pass-if "'(a b c) 1"
2010    (equal? '(a)
2011	    (take '(a b c) 1)))
2012
2013  (pass-if "'(a b) 2"
2014    (let* ((lst '(a b))
2015	   (got (take lst 2)))
2016      (and (equal? '(a b) got)
2017	   (not (eq? lst got)))))
2018
2019  (pass-if "'(a b c) 2"
2020    (equal? '(a b)
2021	    (take '(a b c) 2)))
2022
2023  (pass-if "circular '(a) 0"
2024    (equal? '()
2025	    (take (circular-list 'a) 0)))
2026
2027  (pass-if "circular '(a) 1"
2028    (equal? '(a)
2029	    (take (circular-list 'a) 1)))
2030
2031  (pass-if "circular '(a) 2"
2032    (equal? '(a a)
2033	    (take (circular-list 'a) 2)))
2034
2035  (pass-if "circular '(a b) 5"
2036    (equal? '(a b a b a)
2037	    (take (circular-list 'a 'b) 5)))
2038
2039  (pass-if "'(a . b) 1"
2040    (equal? '(a)
2041	    (take '(a . b) 1)))
2042
2043  (pass-if "'(a b . c) 1"
2044    (equal? '(a)
2045	    (take '(a b . c) 1)))
2046
2047  (pass-if "'(a b . c) 2"
2048    (equal? '(a b)
2049	    (take '(a b . c) 2))))
2050
2051;;
2052;; take-while
2053;;
2054
2055(with-test-prefix "take-while"
2056
2057  (pass-if (equal? '()      (take-while odd? '())))
2058  (pass-if (equal? '(1)     (take-while odd? '(1))))
2059  (pass-if (equal? '(1 3)   (take-while odd? '(1 3))))
2060  (pass-if (equal? '(1 3 5) (take-while odd? '(1 3 5))))
2061
2062  (pass-if (equal? '()      (take-while odd? '(2))))
2063  (pass-if (equal? '(1)     (take-while odd? '(1 2))))
2064  (pass-if (equal? '(1 3)   (take-while odd? '(1 3 4))))
2065
2066  (pass-if (equal? '()      (take-while odd? '(2 1))))
2067  (pass-if (equal? '(1)     (take-while odd? '(1 4 3))))
2068  (pass-if (equal? '()      (take-while odd? '(4 1 3)))))
2069
2070;;
2071;; take-while!
2072;;
2073
2074(with-test-prefix "take-while!"
2075
2076  (pass-if (equal? '()      (take-while! odd? '())))
2077  (pass-if (equal? '(1)     (take-while! odd? (list 1))))
2078  (pass-if (equal? '(1 3)   (take-while! odd? (list 1 3))))
2079  (pass-if (equal? '(1 3 5) (take-while! odd? (list 1 3 5))))
2080
2081  (pass-if (equal? '()      (take-while! odd? (list 2))))
2082  (pass-if (equal? '(1)     (take-while! odd? (list 1 2))))
2083  (pass-if (equal? '(1 3)   (take-while! odd? (list 1 3 4))))
2084
2085  (pass-if (equal? '()      (take-while! odd? (list 2 1))))
2086  (pass-if (equal? '(1)     (take-while! odd? (list 1 4 3))))
2087  (pass-if (equal? '()      (take-while! odd? (list 4 1 3)))))
2088
2089;;
2090;; partition
2091;;
2092
2093(define (test-partition pred list kept-good dropped-good)
2094  (call-with-values (lambda ()
2095			(partition pred list))
2096      (lambda (kept dropped)
2097	(and (equal? kept kept-good)
2098	     (equal? dropped dropped-good)))))
2099
2100(with-test-prefix "partition"
2101
2102  (pass-if "with dropped tail"
2103    (test-partition even? '(1 2 3 4 5 6 7)
2104		    '(2 4 6) '(1 3 5 7)))
2105
2106  (pass-if "with kept tail"
2107    (test-partition even? '(1 2 3 4 5 6)
2108		    '(2 4 6) '(1 3 5)))
2109
2110  (pass-if "with everything dropped"
2111    (test-partition even? '(1 3 5 7)
2112		    '() '(1 3 5 7)))
2113
2114  (pass-if "with everything kept"
2115    (test-partition even? '(2 4 6)
2116		    '(2 4 6) '()))
2117
2118  (pass-if "with empty list"
2119    (test-partition even? '()
2120		    '() '()))
2121
2122  (pass-if "with reasonably long list"
2123    ;; the old implementation from SRFI-1 reference implementation
2124    ;; would signal a stack-overflow for a list of only 500 elements!
2125    (call-with-values (lambda ()
2126			(partition even?
2127				   (make-list 10000 1)))
2128      (lambda (even odd)
2129	(and (= (length odd) 10000)
2130	     (= (length even) 0)))))
2131
2132  (pass-if-exception "with improper list"
2133    exception:wrong-type-arg
2134    (partition symbol? '(a b . c))))
2135
2136;;
2137;; partition!
2138;;
2139
2140(define (test-partition! pred list kept-good dropped-good)
2141  (call-with-values (lambda ()
2142			(partition! pred list))
2143      (lambda (kept dropped)
2144	(and (equal? kept kept-good)
2145	     (equal? dropped dropped-good)))))
2146
2147(with-test-prefix "partition!"
2148
2149  (pass-if "with dropped tail"
2150    (test-partition! even? (list 1 2 3 4 5 6 7)
2151		     '(2 4 6) '(1 3 5 7)))
2152
2153  (pass-if "with kept tail"
2154    (test-partition! even? (list 1 2 3 4 5 6)
2155		     '(2 4 6) '(1 3 5)))
2156
2157  (pass-if "with everything dropped"
2158    (test-partition! even? (list 1 3 5 7)
2159		     '() '(1 3 5 7)))
2160
2161  (pass-if "with everything kept"
2162    (test-partition! even? (list 2 4 6)
2163		     '(2 4 6) '()))
2164
2165  (pass-if "with empty list"
2166    (test-partition! even? '()
2167		     '() '()))
2168
2169  (pass-if "with reasonably long list"
2170    ;; the old implementation from SRFI-1 reference implementation
2171    ;; would signal a stack-overflow for a list of only 500 elements!
2172    (call-with-values (lambda ()
2173			(partition! even?
2174				    (make-list 10000 1)))
2175      (lambda (even odd)
2176	(and (= (length odd) 10000)
2177	     (= (length even) 0)))))
2178
2179  (pass-if-exception "with improper list"
2180    exception:wrong-type-arg
2181    (partition! symbol? (cons* 'a 'b 'c))))
2182
2183;;
2184;; reduce
2185;;
2186
2187(with-test-prefix "reduce"
2188
2189  (pass-if "empty"
2190    (let* ((calls '())
2191	   (ret   (reduce (lambda (x prev)
2192			    (set! calls (cons (list x prev) calls))
2193			    x)
2194			  1 '())))
2195      (and (equal? calls '())
2196	   (equal? ret   1))))
2197
2198  (pass-if "one elem"
2199    (let* ((calls '())
2200	   (ret   (reduce (lambda (x prev)
2201			    (set! calls (cons (list x prev) calls))
2202			    x)
2203			  1 '(2))))
2204      (and (equal? calls '())
2205	   (equal? ret   2))))
2206
2207  (pass-if "two elems"
2208    (let* ((calls '())
2209	   (ret   (reduce (lambda (x prev)
2210			    (set! calls (cons (list x prev) calls))
2211			    x)
2212			  1 '(2 3))))
2213      (and (equal? calls '((3 2)))
2214	   (equal? ret   3))))
2215
2216  (pass-if "three elems"
2217    (let* ((calls '())
2218	   (ret   (reduce (lambda (x prev)
2219			    (set! calls (cons (list x prev) calls))
2220			    x)
2221			  1 '(2 3 4))))
2222      (and (equal? calls '((4 3)
2223			   (3 2)))
2224	   (equal? ret   4))))
2225
2226  (pass-if "four elems"
2227    (let* ((calls '())
2228	   (ret   (reduce (lambda (x prev)
2229			    (set! calls (cons (list x prev) calls))
2230			    x)
2231			  1 '(2 3 4 5))))
2232      (and (equal? calls '((5 4)
2233			   (4 3)
2234			   (3 2)))
2235	   (equal? ret   5)))))
2236
2237;;
2238;; reduce-right
2239;;
2240
2241(with-test-prefix "reduce-right"
2242
2243  (pass-if "empty"
2244    (let* ((calls '())
2245	   (ret   (reduce-right (lambda (x prev)
2246				  (set! calls (cons (list x prev) calls))
2247				  x)
2248				1 '())))
2249      (and (equal? calls '())
2250	   (equal? ret   1))))
2251
2252  (pass-if "one elem"
2253    (let* ((calls '())
2254	   (ret   (reduce-right (lambda (x prev)
2255				  (set! calls (cons (list x prev) calls))
2256				  x)
2257				1 '(2))))
2258      (and (equal? calls '())
2259	   (equal? ret   2))))
2260
2261  (pass-if "two elems"
2262    (let* ((calls '())
2263	   (ret   (reduce-right (lambda (x prev)
2264				  (set! calls (cons (list x prev) calls))
2265				  x)
2266				1 '(2 3))))
2267      (and (equal? calls '((2 3)))
2268	   (equal? ret   2))))
2269
2270  (pass-if "three elems"
2271    (let* ((calls '())
2272	   (ret   (reduce-right (lambda (x prev)
2273				  (set! calls (cons (list x prev) calls))
2274				  x)
2275				1 '(2 3 4))))
2276      (and (equal? calls '((2 3)
2277			   (3 4)))
2278	   (equal? ret   2))))
2279
2280  (pass-if "four elems"
2281    (let* ((calls '())
2282	   (ret   (reduce-right (lambda (x prev)
2283				  (set! calls (cons (list x prev) calls))
2284				  x)
2285				1 '(2 3 4 5))))
2286      (and (equal? calls '((2 3)
2287			   (3 4)
2288			   (4 5)))
2289	   (equal? ret   2)))))
2290
2291;;
2292;; remove
2293;;
2294
2295(with-test-prefix "remove"
2296
2297  (pass-if (equal? '() (remove odd? '())))
2298  (pass-if (equal? '() (remove odd? '(1))))
2299  (pass-if (equal? '(2) (remove odd? '(2))))
2300
2301  (pass-if (equal? '() (remove odd? '(1 3))))
2302  (pass-if (equal? '(2) (remove odd? '(2 3))))
2303  (pass-if (equal? '(2) (remove odd? '(1 2))))
2304  (pass-if (equal? '(2 4) (remove odd? '(2 4))))
2305
2306  (pass-if (equal? '() (remove odd? '(1 3 5))))
2307  (pass-if (equal? '(2) (remove odd? '(2 3 5))))
2308  (pass-if (equal? '(2) (remove odd? '(1 2 5))))
2309  (pass-if (equal? '(2 4) (remove odd? '(2 4 5))))
2310
2311  (pass-if (equal? '(6) (remove odd? '(1 3 6))))
2312  (pass-if (equal? '(2 6) (remove odd? '(2 3 6))))
2313  (pass-if (equal? '(2 6) (remove odd? '(1 2 6))))
2314  (pass-if (equal? '(2 4 6) (remove odd? '(2 4 6)))))
2315
2316;;
2317;; remove!
2318;;
2319
2320(with-test-prefix "remove!"
2321
2322  (pass-if (equal? '() (remove! odd? '())))
2323  (pass-if (equal? '() (remove! odd? (list 1))))
2324  (pass-if (equal? '(2) (remove! odd? (list 2))))
2325
2326  (pass-if (equal? '() (remove! odd? (list 1 3))))
2327  (pass-if (equal? '(2) (remove! odd? (list 2 3))))
2328  (pass-if (equal? '(2) (remove! odd? (list 1 2))))
2329  (pass-if (equal? '(2 4) (remove! odd? (list 2 4))))
2330
2331  (pass-if (equal? '() (remove! odd? (list 1 3 5))))
2332  (pass-if (equal? '(2) (remove! odd? (list 2 3 5))))
2333  (pass-if (equal? '(2) (remove! odd? (list 1 2 5))))
2334  (pass-if (equal? '(2 4) (remove! odd? (list 2 4 5))))
2335
2336  (pass-if (equal? '(6) (remove! odd? (list 1 3 6))))
2337  (pass-if (equal? '(2 6) (remove! odd? (list 2 3 6))))
2338  (pass-if (equal? '(2 6) (remove! odd? (list 1 2 6))))
2339  (pass-if (equal? '(2 4 6) (remove! odd? (list 2 4 6)))))
2340
2341;;
2342;; seventh
2343;;
2344
2345(with-test-prefix "seventh"
2346  (pass-if-exception "() -1" exception:wrong-type-arg
2347    (seventh '(a b c d e f)))
2348  (pass-if (eq? 'g (seventh '(a b c d e f g))))
2349  (pass-if (eq? 'g (seventh '(a b c d e f g h)))))
2350
2351;;
2352;; sixth
2353;;
2354
2355(with-test-prefix "sixth"
2356  (pass-if-exception "() -1" exception:wrong-type-arg
2357    (sixth '(a b c d e)))
2358  (pass-if (eq? 'f (sixth '(a b c d e f))))
2359  (pass-if (eq? 'f (sixth '(a b c d e f g)))))
2360
2361;;
2362;; split-at
2363;;
2364
2365(with-test-prefix "split-at"
2366
2367  (define (equal-values? lst thunk)
2368    (call-with-values thunk
2369      (lambda got
2370	(equal? lst got))))
2371
2372  (pass-if-exception "() -1" exception:out-of-range
2373    (split-at '() -1))
2374  (pass-if (equal-values? '(() ())
2375			  (lambda () (split-at '() 0))))
2376  (pass-if-exception "() 1" exception:wrong-type-arg
2377    (split-at '() 1))
2378
2379  (pass-if-exception "(1) -1" exception:out-of-range
2380    (split-at '(1) -1))
2381  (pass-if (equal-values? '(() (1)) (lambda () (split-at '(1) 0))))
2382  (pass-if (equal-values? '((1) ()) (lambda () (split-at '(1) 1))))
2383  (pass-if-exception "(1) 2" exception:wrong-type-arg
2384    (split-at '(1) 2))
2385
2386  (pass-if-exception "(4 5) -1" exception:out-of-range
2387    (split-at '(4 5) -1))
2388  (pass-if (equal-values? '(() (4 5)) (lambda () (split-at '(4 5) 0))))
2389  (pass-if (equal-values? '((4) (5)) (lambda () (split-at '(4 5) 1))))
2390  (pass-if (equal-values? '((4 5) ()) (lambda () (split-at '(4 5) 2))))
2391  (pass-if-exception "(4 5) 3" exception:wrong-type-arg
2392    (split-at '(4 5) 3))
2393
2394  (pass-if-exception "(4 5 6) -1" exception:out-of-range
2395    (split-at '(4 5 6) -1))
2396  (pass-if (equal-values? '(() (4 5 6)) (lambda () (split-at '(4 5 6) 0))))
2397  (pass-if (equal-values? '((4) (5 6)) (lambda () (split-at '(4 5 6) 1))))
2398  (pass-if (equal-values? '((4 5) (6)) (lambda () (split-at '(4 5 6) 2))))
2399  (pass-if (equal-values? '((4 5 6) ()) (lambda () (split-at '(4 5 6) 3))))
2400  (pass-if-exception "(4 5 6) 4" exception:wrong-type-arg
2401    (split-at '(4 5 6) 4)))
2402
2403;;
2404;; split-at!
2405;;
2406
2407(with-test-prefix "split-at!"
2408
2409  (define (equal-values? lst thunk)
2410    (call-with-values thunk
2411      (lambda got
2412	(equal? lst got))))
2413
2414  (pass-if-exception "() -1" exception:out-of-range
2415    (split-at! '() -1))
2416  (pass-if (equal-values? '(() ())
2417			  (lambda () (split-at! '() 0))))
2418  (pass-if-exception "() 1" exception:wrong-type-arg
2419    (split-at! '() 1))
2420
2421  (pass-if-exception "(1) -1" exception:out-of-range
2422    (split-at! (list 1) -1))
2423  (pass-if (equal-values? '(() (1)) (lambda () (split-at! (list 1) 0))))
2424  (pass-if (equal-values? '((1) ()) (lambda () (split-at! (list 1) 1))))
2425  (pass-if-exception "(1) 2" exception:wrong-type-arg
2426    (split-at! (list 1) 2))
2427
2428  (pass-if-exception "(4 5) -1" exception:out-of-range
2429    (split-at! (list 4 5) -1))
2430  (pass-if (equal-values? '(() (4 5)) (lambda () (split-at! (list 4 5) 0))))
2431  (pass-if (equal-values? '((4) (5))  (lambda () (split-at! (list 4 5) 1))))
2432  (pass-if (equal-values? '((4 5) ()) (lambda () (split-at! (list 4 5) 2))))
2433  (pass-if-exception "(4 5) 3" exception:wrong-type-arg
2434    (split-at! (list 4 5) 3))
2435
2436  (pass-if-exception "(4 5 6) -1" exception:out-of-range
2437    (split-at! (list 4 5 6) -1))
2438  (pass-if (equal-values? '(() (4 5 6)) (lambda () (split-at! (list 4 5 6) 0))))
2439  (pass-if (equal-values? '((4) (5 6))  (lambda () (split-at! (list 4 5 6) 1))))
2440  (pass-if (equal-values? '((4 5) (6))  (lambda () (split-at! (list 4 5 6) 2))))
2441  (pass-if (equal-values? '((4 5 6) ()) (lambda () (split-at! (list 4 5 6) 3))))
2442  (pass-if-exception "(4 5 6) 4" exception:wrong-type-arg
2443    (split-at! (list 4 5 6) 4)))
2444
2445;;
2446;; span
2447;;
2448
2449(with-test-prefix "span"
2450
2451  (define (test-span lst want-v1 want-v2)
2452    (call-with-values
2453	(lambda ()
2454	  (span positive? lst))
2455      (lambda (got-v1 got-v2)
2456	(and (equal? got-v1 want-v1)
2457	     (equal? got-v2 want-v2)))))
2458
2459  (pass-if "empty"
2460    (test-span '() '() '()))
2461
2462  (pass-if "y"
2463    (test-span '(1) '(1) '()))
2464
2465  (pass-if "n"
2466    (test-span '(-1) '() '(-1)))
2467
2468  (pass-if "yy"
2469    (test-span '(1 2) '(1 2) '()))
2470
2471  (pass-if "ny"
2472    (test-span '(-1 1) '() '(-1 1)))
2473
2474  (pass-if "yn"
2475    (test-span '(1 -1) '(1) '(-1)))
2476
2477  (pass-if "nn"
2478    (test-span '(-1 -2) '() '(-1 -2)))
2479
2480  (pass-if "yyy"
2481    (test-span '(1 2 3) '(1 2 3) '()))
2482
2483  (pass-if "nyy"
2484    (test-span '(-1 1 2) '() '(-1 1 2)))
2485
2486  (pass-if "yny"
2487    (test-span '(1 -1 2) '(1) '(-1 2)))
2488
2489  (pass-if "nny"
2490    (test-span '(-1 -2 1) '() '(-1 -2 1)))
2491
2492  (pass-if "yyn"
2493    (test-span '(1 2 -1) '(1 2) '(-1)))
2494
2495  (pass-if "nyn"
2496    (test-span '(-1 1 -2) '() '(-1 1 -2)))
2497
2498  (pass-if "ynn"
2499    (test-span '(1 -1 -2) '(1) '(-1 -2)))
2500
2501  (pass-if "nnn"
2502    (test-span '(-1 -2 -3) '() '(-1 -2 -3))))
2503
2504;;
2505;; span!
2506;;
2507
2508(with-test-prefix "span!"
2509
2510  (define (test-span! lst want-v1 want-v2)
2511    (call-with-values
2512	(lambda ()
2513	  (span! positive? lst))
2514      (lambda (got-v1 got-v2)
2515	(and (equal? got-v1 want-v1)
2516	     (equal? got-v2 want-v2)))))
2517
2518  (pass-if "empty"
2519    (test-span! '() '() '()))
2520
2521  (pass-if "y"
2522    (test-span! (list 1) '(1) '()))
2523
2524  (pass-if "n"
2525    (test-span! (list -1) '() '(-1)))
2526
2527  (pass-if "yy"
2528    (test-span! (list 1 2) '(1 2) '()))
2529
2530  (pass-if "ny"
2531    (test-span! (list -1 1) '() '(-1 1)))
2532
2533  (pass-if "yn"
2534    (test-span! (list 1 -1) '(1) '(-1)))
2535
2536  (pass-if "nn"
2537    (test-span! (list -1 -2) '() '(-1 -2)))
2538
2539  (pass-if "yyy"
2540    (test-span! (list 1 2 3) '(1 2 3) '()))
2541
2542  (pass-if "nyy"
2543    (test-span! (list -1 1 2) '() '(-1 1 2)))
2544
2545  (pass-if "yny"
2546    (test-span! (list 1 -1 2) '(1) '(-1 2)))
2547
2548  (pass-if "nny"
2549    (test-span! (list -1 -2 1) '() '(-1 -2 1)))
2550
2551  (pass-if "yyn"
2552    (test-span! (list 1 2 -1) '(1 2) '(-1)))
2553
2554  (pass-if "nyn"
2555    (test-span! (list -1 1 -2) '() '(-1 1 -2)))
2556
2557  (pass-if "ynn"
2558    (test-span! (list 1 -1 -2) '(1) '(-1 -2)))
2559
2560  (pass-if "nnn"
2561    (test-span! (list -1 -2 -3) '() '(-1 -2 -3))))
2562
2563;;
2564;; take!
2565;;
2566
2567(with-test-prefix "take!"
2568
2569  (pass-if-exception "() -1" exception:out-of-range
2570    (take! '() -1))
2571  (pass-if (equal? '() (take! '() 0)))
2572  (pass-if-exception "() 1" exception:wrong-type-arg
2573    (take! '() 1))
2574
2575  (pass-if-exception "(1) -1" exception:out-of-range
2576    (take! '(1) -1))
2577  (pass-if (equal? '() (take! '(1) 0)))
2578  (pass-if (equal? '(1) (take! '(1) 1)))
2579  (pass-if-exception "(1) 2" exception:wrong-type-arg
2580    (take! '(1) 2))
2581
2582  (pass-if-exception "(4 5) -1" exception:out-of-range
2583    (take! '(4 5) -1))
2584  (pass-if (equal? '() (take! '(4 5) 0)))
2585  (pass-if (equal? '(4) (take! '(4 5) 1)))
2586  (pass-if (equal? '(4 5) (take! '(4 5) 2)))
2587  (pass-if-exception "(4 5) 3" exception:wrong-type-arg
2588    (take! '(4 5) 3))
2589
2590  (pass-if-exception "(4 5 6) -1" exception:out-of-range
2591    (take! '(4 5 6) -1))
2592  (pass-if (equal? '() (take! '(4 5 6) 0)))
2593  (pass-if (equal? '(4) (take! '(4 5 6) 1)))
2594  (pass-if (equal? '(4 5) (take! '(4 5 6) 2)))
2595  (pass-if (equal? '(4 5 6) (take! '(4 5 6) 3)))
2596  (pass-if-exception "(4 5 6) 4" exception:wrong-type-arg
2597    (take! '(4 5 6) 4)))
2598
2599
2600;;
2601;; take-right
2602;;
2603
2604(with-test-prefix "take-right"
2605
2606  (pass-if-exception "() -1" exception:out-of-range
2607    (take-right '() -1))
2608  (pass-if (equal? '() (take-right '() 0)))
2609  (pass-if-exception "() 1" exception:wrong-type-arg
2610    (take-right '() 1))
2611
2612  (pass-if-exception "(1) -1" exception:out-of-range
2613    (take-right '(1) -1))
2614  (pass-if (equal? '() (take-right '(1) 0)))
2615  (pass-if (equal? '(1) (take-right '(1) 1)))
2616  (pass-if-exception "(1) 2" exception:wrong-type-arg
2617    (take-right '(1) 2))
2618
2619  (pass-if-exception "(4 5) -1" exception:out-of-range
2620    (take-right '(4 5) -1))
2621  (pass-if (equal? '() (take-right '(4 5) 0)))
2622  (pass-if (equal? '(5) (take-right '(4 5) 1)))
2623  (pass-if (equal? '(4 5) (take-right '(4 5) 2)))
2624  (pass-if-exception "(4 5) 3" exception:wrong-type-arg
2625    (take-right '(4 5) 3))
2626
2627  (pass-if-exception "(4 5 6) -1" exception:out-of-range
2628    (take-right '(4 5 6) -1))
2629  (pass-if (equal? '() (take-right '(4 5 6) 0)))
2630  (pass-if (equal? '(6) (take-right '(4 5 6) 1)))
2631  (pass-if (equal? '(5 6) (take-right '(4 5 6) 2)))
2632  (pass-if (equal? '(4 5 6) (take-right '(4 5 6) 3)))
2633  (pass-if-exception "(4 5 6) 4" exception:wrong-type-arg
2634    (take-right '(4 5 6) 4))
2635
2636  (pass-if "(a b . c) 0"
2637    (equal? (take-right '(a b . c) 0) 'c))
2638  (pass-if "(a b . c) 1"
2639    (equal? (take-right '(a b . c) 1) '(b . c))))
2640
2641;;
2642;; tenth
2643;;
2644
2645(with-test-prefix "tenth"
2646  (pass-if-exception "() -1" exception:wrong-type-arg
2647    (tenth '(a b c d e f g h i)))
2648  (pass-if (eq? 'j (tenth '(a b c d e f g h i j))))
2649  (pass-if (eq? 'j (tenth '(a b c d e f g h i j k)))))
2650
2651;;
2652;; xcons
2653;;
2654
2655(with-test-prefix "xcons"
2656  (pass-if (equal? '(y . x) (xcons 'x 'y))))
2657