1 ;;;; srfi-1.test --- Test suite for Guile's SRFI-1 functions. -*- scheme -*-
3 ;;;; Copyright 2003, 2004, 2005, 2006, 2008 Free Software Foundation, Inc.
5 ;;;; This program is free software; you can redistribute it and/or modify
6 ;;;; it under the terms of the GNU General Public License as published by
7 ;;;; the Free Software Foundation; either version 2, or (at your option)
8 ;;;; any later version.
10 ;;;; This program 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
13 ;;;; GNU General Public License for more details.
15 ;;;; You should have received a copy of the GNU General Public License
16 ;;;; along with this software; see the file COPYING. If not, write to
17 ;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
18 ;;;; Boston, MA 02110-1301 USA
20 (define-module (test-srfi-1)
21 #:use-module (test-suite lib)
22 #:use-module (srfi srfi-1))
25 (define (ref-delete x lst . proc)
26 "Reference implemenation of srfi-1 `delete'."
27 (set! proc (if (null? proc) equal? (car proc)))
32 (if (not (proc x (car lst)))
33 (set! ret (cons (car lst) ret)))))
35 (define (ref-delete-duplicates lst . proc)
36 "Reference implemenation of srfi-1 `delete-duplicates'."
37 (set! proc (if (null? proc) equal? (car proc)))
43 (let ((elem (car lst)))
44 (set! keep (cons elem keep))
45 (set! lst (ref-delete elem lst proc))))))
52 (with-test-prefix "alist-copy"
54 ;; return a list which is the pairs making up alist A, the spine and cells
55 (define (alist-pairs a)
59 (more (cdr a) (cons a result))
62 ;; return a list of the elements common to lists X and Y, compared with eq?
63 (define (common-elements x y)
67 (cons (car x) (common-elements (cdr x) y))
68 (common-elements (cdr x) y))))
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)
74 (null? (common-elements old new))))
76 (pass-if-exception "too few args" exception:wrong-num-args
79 (pass-if-exception "too many args" exception:wrong-num-args
83 (pass-if old (valid-alist-copy? old (alist-copy old))))
85 (let ((old '((1 . 2))))
86 (pass-if old (valid-alist-copy? old (alist-copy old))))
88 (let ((old '((1 . 2) (3 . 4))))
89 (pass-if old (valid-alist-copy? old (alist-copy old))))
91 (let ((old '((1 . 2) (3 . 4) (5 . 6))))
92 (pass-if old (valid-alist-copy? old (alist-copy old)))))
98 (with-test-prefix "alist-delete"
100 (pass-if "equality call arg order"
102 (alist-delete 'k '((ak . 123))
104 (if (and (eq? k 'k) (eq? ak 'ak))
108 (pass-if "delete keys greater than 5"
109 (equal? '((4 . x) (5 . y))
110 (alist-delete 5 '((4 . x) (5 . y) (6 . z)) <)))
113 (equal? '() (alist-delete 'x '())))
116 (equal? '() (alist-delete 'y '((y . 1)))))
119 (equal? '((n . 1)) (alist-delete 'y '((n . 1)))))
122 (equal? '() (alist-delete 'y '((y . 1) (y . 2)))))
125 (equal? '((n . 1)) (alist-delete 'y '((n . 1) (y . 2)))))
128 (equal? '((n . 2)) (alist-delete 'y '((y . 1) (n . 2)))))
131 (equal? '((n . 1) (n . 2)) (alist-delete 'y '((n . 1) (n . 2)))))
134 (equal? '() (alist-delete 'y '((y . 1) (y . 2) (y . 3)))))
137 (equal? '((n . 1)) (alist-delete 'y '((n . 1) (y . 2) (y . 3)))))
140 (equal? '((n . 2)) (alist-delete 'y '((y . 1) (n . 2) (y . 3)))))
143 (equal? '((n . 1) (n . 2)) (alist-delete 'y '((n . 1) (n . 2) (y . 3)))))
146 (equal? '( (n . 3)) (alist-delete 'y '((y . 1) (y . 2) (n . 3)))))
149 (equal? '((n . 1) (n . 3)) (alist-delete 'y '((n . 1) (y . 2) (n . 3)))))
152 (equal? '((n . 2) (n . 3)) (alist-delete 'y '((y . 1) (n . 2) (n . 3)))))
155 (equal? '((n . 1) (n . 2) (n . 3)) (alist-delete 'y '((n . 1) (n . 2) (n . 3))))))
161 (with-test-prefix "append-map"
163 (with-test-prefix "one list"
166 (equal? '() (append-map noop '(()))))
169 (equal? '(1) (append-map noop '((1)))))
172 (equal? '(1 2) (append-map noop '((1 2)))))
175 (equal? '() (append-map noop '(() ()))))
178 (equal? '(1) (append-map noop '(() (1)))))
181 (equal? '(1 2) (append-map noop '(() (1 2)))))
184 (equal? '(1 2) (append-map noop '((1) (2)))))
187 (equal? '(1 2) (append-map noop '(() (1 2))))))
189 (with-test-prefix "two lists"
192 (equal? '() (append-map noop '(()) '(9))))
195 (equal? '(1) (append-map noop '((1)) '(9))))
197 (pass-if "() () / 9 9"
198 (equal? '() (append-map noop '(() ()) '(9 9))))
200 (pass-if "(1) (2) / 9"
201 (equal? '(1) (append-map noop '((1) (2)) '(9))))
203 (pass-if "(1) (2) / 9 9"
204 (equal? '(1 2) (append-map noop '((1) (2)) '(9 9))))))
210 (with-test-prefix "append-reverse"
212 ;; return a list which is the cars and cdrs of LST
213 (define (list-contents lst)
216 (cons* (car lst) (cdr lst) (list-contents (cdr lst)))))
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)
223 (equal? revhead-contents (list-contents revhead)))))
225 (pass-if-exception "too few args (0)" exception:wrong-num-args
228 (pass-if-exception "too few args (1)" exception:wrong-num-args
229 (append-reverse '(x)))
231 (pass-if-exception "too many args (3)" exception:wrong-num-args
232 (append-reverse '() '() #f))
234 (pass-if (valid-append-reverse '() '() '()))
235 (pass-if (valid-append-reverse '() '(1 2 3) '(1 2 3)))
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)))
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)))
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))))
253 (with-test-prefix "append-reverse!"
255 (pass-if-exception "too few args (0)" exception:wrong-num-args
258 (pass-if-exception "too few args (1)" exception:wrong-num-args
259 (append-reverse! '(x)))
261 (pass-if-exception "too many args (3)" exception:wrong-num-args
262 (append-reverse! '() '() #f))
264 (pass-if (equal? '() (append-reverse! '() '())))
265 (pass-if (equal? '(1 2 3) (append-reverse! '() '(1 2 3))))
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))))
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))))
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)))))
283 (with-test-prefix "assoc"
286 (let ((alist '((a . 1)
289 (eqv? #f (assoc 'z alist))))
292 (let ((alist '((a . 1)
295 (eqv? (second alist) (assoc 'b alist))))
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)))
302 (assoc 'a alist (lambda (x y)
303 (set! good (and (eq? x 'a)
307 ;; likewise this one bad in guile 1.8.0
308 (pass-if "srfi-1 example <"
309 (let ((alist '((1 . a)
312 (eq? (third alist) (assoc 5 alist <)))))
318 (with-test-prefix "break"
320 (define (test-break lst want-v1 want-v2)
323 (break negative? lst))
324 (lambda (got-v1 got-v2)
325 (and (equal? got-v1 want-v1)
326 (equal? got-v2 want-v2)))))
329 (test-break '() '() '()))
332 (test-break '(1) '(1) '()))
335 (test-break '(-1) '() '(-1)))
338 (test-break '(1 2) '(1 2) '()))
341 (test-break '(-1 1) '() '(-1 1)))
344 (test-break '(1 -1) '(1) '(-1)))
347 (test-break '(-1 -2) '() '(-1 -2)))
350 (test-break '(1 2 3) '(1 2 3) '()))
353 (test-break '(-1 1 2) '() '(-1 1 2)))
356 (test-break '(1 -1 2) '(1) '(-1 2)))
359 (test-break '(-1 -2 1) '() '(-1 -2 1)))
362 (test-break '(1 2 -1) '(1 2) '(-1)))
365 (test-break '(-1 1 -2) '() '(-1 1 -2)))
368 (test-break '(1 -1 -2) '(1) '(-1 -2)))
371 (test-break '(-1 -2 -3) '() '(-1 -2 -3))))
377 (with-test-prefix "break!"
379 (define (test-break! lst want-v1 want-v2)
382 (break! negative? lst))
383 (lambda (got-v1 got-v2)
384 (and (equal? got-v1 want-v1)
385 (equal? got-v2 want-v2)))))
388 (test-break! '() '() '()))
391 (test-break! (list 1) '(1) '()))
394 (test-break! (list -1) '() '(-1)))
397 (test-break! (list 1 2) '(1 2) '()))
400 (test-break! (list -1 1) '() '(-1 1)))
403 (test-break! (list 1 -1) '(1) '(-1)))
406 (test-break! (list -1 -2) '() '(-1 -2)))
409 (test-break! (list 1 2 3) '(1 2 3) '()))
412 (test-break! (list -1 1 2) '() '(-1 1 2)))
415 (test-break! (list 1 -1 2) '(1) '(-1 2)))
418 (test-break! (list -1 -2 1) '() '(-1 -2 1)))
421 (test-break! (list 1 2 -1) '(1 2) '(-1)))
424 (test-break! (list -1 1 -2) '() '(-1 1 -2)))
427 (test-break! (list 1 -1 -2) '(1) '(-1 -2)))
430 (test-break! (list -1 -2 -3) '() '(-1 -2 -3))))
436 (with-test-prefix "car+cdr"
447 ;; concatenate and concatenate!
451 (define (common-tests concatenate-proc unmodified?)
452 (define (try lstlst want)
453 (let ((lstlst-copy (copy-tree lstlst))
454 (got (concatenate-proc lstlst)))
456 (if (not (equal? lstlst lstlst-copy))
457 (error "input lists modified")))
460 (pass-if-exception "too few args" exception:wrong-num-args
463 (pass-if-exception "too many args" exception:wrong-num-args
464 (concatenate-proc '() '()))
466 (pass-if-exception "number" exception:wrong-type-arg
467 (concatenate-proc 123))
469 (pass-if-exception "vector" exception:wrong-type-arg
470 (concatenate-proc #(1 2 3)))
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)))
480 (pass-if (try '((1) (2)) '(1 2)))
481 (pass-if (try '(() (1 2)) '(1 2)))
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)))
488 (with-test-prefix "concatenate"
489 (common-tests concatenate #t))
491 (with-test-prefix "concatenate!"
492 (common-tests concatenate! #f)))
498 (with-test-prefix "count"
499 (pass-if-exception "no args" exception:wrong-num-args
502 (pass-if-exception "one arg" exception:wrong-num-args
505 (with-test-prefix "one list"
509 (pass-if "empty list" (= 0 (count or1 '())))
511 (pass-if-exception "pred arg count 0" exception:wrong-type-arg
512 (count (lambda () x) '(1 2 3)))
513 (pass-if-exception "pred arg count 2" exception:wrong-type-arg
514 (count (lambda (x y) x) '(1 2 3)))
516 (pass-if-exception "improper 1" exception:wrong-type-arg
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)))
523 (pass-if (= 0 (count or1 '(#f))))
524 (pass-if (= 1 (count or1 '(#t))))
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))))
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)))))
537 (with-test-prefix "two lists"
542 (= 1 (count (lambda (x y)
547 (pass-if "empty lists" (= 0 (count or2 '() '())))
549 (pass-if-exception "pred arg count 0" exception:wrong-type-arg
550 (count (lambda () #t) '(1 2 3) '(1 2 3)))
551 (pass-if-exception "pred arg count 1" exception:wrong-type-arg
552 (count (lambda (x) x) '(1 2 3) '(1 2 3)))
553 (pass-if-exception "pred arg count 3" exception:wrong-type-arg
554 (count (lambda (x y z) x) '(1 2 3) '(1 2 3)))
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)))
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)))
570 (pass-if (= 0 (count or2 '(#f) '(#f))))
571 (pass-if (= 1 (count or2 '(#t) '(#f))))
572 (pass-if (= 1 (count or2 '(#f) '(#t))))
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))))
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))))))
585 (with-test-prefix "three lists"
590 (= 1 (count (lambda (x y z)
596 (pass-if "empty lists" (= 0 (count or3 '() '() '())))
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)))
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)))
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)))
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)))
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))))
633 (pass-if (= 0 (count or3 '(#f #f) '(#f #f) '(#f #f))))
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))))
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))))
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) '())))
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)))))
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))
660 (equal? '((1 2) (3 4) (5 6)) lst))))))
663 ;; delete and delete!
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)
673 (do ((limit (ash 1 n))
677 (do ((bit 0 (1+ bit)))
679 (set! lst (cons (if (logbit? bit i) bit #f) lst)))
682 (define (common-tests delete-proc)
683 (pass-if-exception "too few args" exception:wrong-num-args
686 (pass-if-exception "too many args" exception:wrong-num-args
687 (delete-proc 0 '() equal? 99))
690 (eq? '() (delete-proc 0 '() equal?)))
694 (delete-proc '(2) '((1) (2) (3)) equal?)))
697 (equal? '((1) (2) (3))
698 (delete-proc '(2) '((1) (2) (3)) eq?)))
700 (pass-if "called arg order"
702 (delete-proc 3 '(1 2 3 4 5) <))))
704 (with-test-prefix "delete"
705 (common-tests delete)
709 (let ((lst-copy (list-copy lst)))
710 (with-test-prefix lst-copy
712 (equal? (delete #f lst equal?)
713 (ref-delete #f lst equal?)))
714 (pass-if "non-destructive"
715 (equal? lst-copy lst)))))))
717 (with-test-prefix "delete!"
718 (common-tests delete!)
723 (equal? (delete! #f lst)
724 (ref-delete #f lst)))))))
727 ;; delete-duplicates and delete-duplicates!
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)
736 (do ((limit (integer-expt n n))
741 (rem i (quotient rem n)))
743 (set! lst (cons (remainder rem n) lst)))
746 (define (common-tests delete-duplicates-proc)
747 (pass-if-exception "too few args" exception:wrong-num-args
748 (delete-duplicates-proc))
750 (pass-if-exception "too many args" exception:wrong-num-args
751 (delete-duplicates-proc '() equal? 99))
754 (eq? '() (delete-duplicates-proc '())))
756 (pass-if "equal? (the default)"
758 (delete-duplicates-proc '((2) (2) (2)))))
761 (equal? '((2) (2) (2))
762 (delete-duplicates-proc '((2) (2) (2)) eq?)))
764 (pass-if "called arg order"
766 (delete-duplicates-proc '(1 2 3 4 5)
773 (with-test-prefix "delete-duplicates"
774 (common-tests delete-duplicates)
778 (let ((lst-copy (list-copy lst)))
779 (with-test-prefix lst-copy
781 (equal? (delete-duplicates lst)
782 (ref-delete-duplicates lst)))
783 (pass-if "non-destructive"
784 (equal? lst-copy lst)))))))
786 (with-test-prefix "delete-duplicates!"
787 (common-tests delete-duplicates!)
792 (equal? (delete-duplicates! lst)
793 (ref-delete-duplicates lst)))))))
799 (with-test-prefix "drop"
802 (null? (drop '() 0)))
829 (pass-if "'(a b c) 1"
830 (let ((lst '(a b c)))
834 (pass-if "circular '(a) 0"
835 (let ((lst (circular-list 'a)))
839 (pass-if "circular '(a) 1"
840 (let ((lst (circular-list 'a)))
844 (pass-if "circular '(a) 2"
845 (let ((lst (circular-list 'a)))
849 (pass-if "circular '(a b) 1"
850 (let ((lst (circular-list 'a)))
854 (pass-if "circular '(a b) 2"
855 (let ((lst (circular-list 'a)))
859 (pass-if "circular '(a b) 5"
860 (let ((lst (circular-list 'a)))
864 (pass-if "'(a . b) 1"
868 (pass-if "'(a b . c) 1"
870 (drop '(a b . c) 2))))
876 (with-test-prefix "drop-right"
878 (pass-if-exception "() -1" exception:out-of-range
880 (pass-if (equal? '() (drop-right '() 0)))
881 (pass-if-exception "() 1" exception:wrong-type-arg
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
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))
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)))
912 (with-test-prefix "drop-right!"
914 (pass-if-exception "() -1" exception:out-of-range
915 (drop-right! '() -1))
916 (pass-if (equal? '() (drop-right! '() 0)))
917 (pass-if-exception "() 1" exception:wrong-type-arg
920 (pass-if-exception "(1) -1" exception:out-of-range
921 (drop-right! (list 1) -1))
922 (pass-if (equal? '(1) (drop-right! (list 1) 0)))
923 (pass-if (equal? '() (drop-right! (list 1) 1)))
924 (pass-if-exception "(1) 2" exception:wrong-type-arg
925 (drop-right! (list 1) 2))
927 (pass-if-exception "(4 5) -1" exception:out-of-range
928 (drop-right! (list 4 5) -1))
929 (pass-if (equal? '(4 5) (drop-right! (list 4 5) 0)))
930 (pass-if (equal? '(4) (drop-right! (list 4 5) 1)))
931 (pass-if (equal? '() (drop-right! (list 4 5) 2)))
932 (pass-if-exception "(4 5) 3" exception:wrong-type-arg
933 (drop-right! (list 4 5) 3))
935 (pass-if-exception "(4 5 6) -1" exception:out-of-range
936 (drop-right! (list 4 5 6) -1))
937 (pass-if (equal? '(4 5 6) (drop-right! (list 4 5 6) 0)))
938 (pass-if (equal? '(4 5) (drop-right! (list 4 5 6) 1)))
939 (pass-if (equal? '(4) (drop-right! (list 4 5 6) 2)))
940 (pass-if (equal? '() (drop-right! (list 4 5 6) 3)))
941 (pass-if-exception "(4 5 6) 4" exception:wrong-type-arg
942 (drop-right! (list 4 5 6) 4)))
948 (with-test-prefix "drop-while"
950 (pass-if (equal? '() (drop-while odd? '())))
951 (pass-if (equal? '() (drop-while odd? '(1))))
952 (pass-if (equal? '() (drop-while odd? '(1 3))))
953 (pass-if (equal? '() (drop-while odd? '(1 3 5))))
955 (pass-if (equal? '(2) (drop-while odd? '(2))))
956 (pass-if (equal? '(2) (drop-while odd? '(1 2))))
957 (pass-if (equal? '(4) (drop-while odd? '(1 3 4))))
959 (pass-if (equal? '(2 1) (drop-while odd? '(2 1))))
960 (pass-if (equal? '(4 3) (drop-while odd? '(1 4 3))))
961 (pass-if (equal? '(4 1 3) (drop-while odd? '(4 1 3)))))
967 (with-test-prefix "eighth"
968 (pass-if-exception "() -1" exception:out-of-range
969 (eighth '(a b c d e f g)))
970 (pass-if (eq? 'h (eighth '(a b c d e f g h))))
971 (pass-if (eq? 'h (eighth '(a b c d e f g h i)))))
977 (with-test-prefix "fifth"
978 (pass-if-exception "() -1" exception:out-of-range
980 (pass-if (eq? 'e (fifth '(a b c d e))))
981 (pass-if (eq? 'e (fifth '(a b c d e f)))))
987 (with-test-prefix "filter-map"
989 (with-test-prefix "one list"
990 (pass-if-exception "'x" exception:wrong-type-arg
991 (filter-map noop 'x))
993 (pass-if-exception "'(1 . x)" exception:wrong-type-arg
994 (filter-map noop '(1 . x)))
997 (equal? '(1) (filter-map noop '(1))))
1000 (equal? '() (filter-map noop '(#f))))
1003 (equal? '(1 2) (filter-map noop '(1 2))))
1006 (equal? '(2) (filter-map noop '(#f 2))))
1009 (equal? '() (filter-map noop '(#f #f))))
1012 (equal? '(1 2 3) (filter-map noop '(1 2 3))))
1015 (equal? '(2 3) (filter-map noop '(#f 2 3))))
1018 (equal? '(1 3) (filter-map noop '(1 #f 3))))
1021 (equal? '(1 2) (filter-map noop '(1 2 #f)))))
1023 (with-test-prefix "two lists"
1024 (pass-if-exception "'x '(1 2 3)" exception:wrong-type-arg
1025 (filter-map noop 'x '(1 2 3)))
1027 (pass-if-exception "'(1 2 3) 'x" exception:wrong-type-arg
1028 (filter-map noop '(1 2 3) 'x))
1030 (pass-if-exception "'(1 . x) '(1 2 3)" exception:wrong-type-arg
1031 (filter-map noop '(1 . x) '(1 2 3)))
1033 (pass-if-exception "'(1 2 3) '(1 . x)" exception:wrong-type-arg
1034 (filter-map noop '(1 2 3) '(1 . x)))
1036 (pass-if "(1 2 3) (4 5 6)"
1037 (equal? '(5 7 9) (filter-map + '(1 2 3) '(4 5 6))))
1039 (pass-if "(#f 2 3) (4 5)"
1040 (equal? '(2) (filter-map noop '(#f 2 3) '(4 5))))
1042 (pass-if "(4 #f) (1 2 3)"
1043 (equal? '(4) (filter-map noop '(4 #f) '(1 2 3))))
1045 (pass-if "() (1 2 3)"
1046 (equal? '() (filter-map noop '() '(1 2 3))))
1048 (pass-if "(1 2 3) ()"
1049 (equal? '() (filter-map noop '(1 2 3) '()))))
1051 (with-test-prefix "three lists"
1052 (pass-if-exception "'x '(1 2 3) '(1 2 3)" exception:wrong-type-arg
1053 (filter-map noop 'x '(1 2 3) '(1 2 3)))
1055 (pass-if-exception "'(1 2 3) 'x '(1 2 3)" exception:wrong-type-arg
1056 (filter-map noop '(1 2 3) 'x '(1 2 3)))
1058 (pass-if-exception "'(1 2 3) '(1 2 3) 'x" exception:wrong-type-arg
1059 (filter-map noop '(1 2 3) '(1 2 3) 'x))
1061 (pass-if-exception "'(1 . x) '(1 2 3) '(1 2 3)" exception:wrong-type-arg
1062 (filter-map noop '(1 . x) '(1 2 3) '(1 2 3)))
1064 (pass-if-exception "'(1 2 3) '(1 . x) '(1 2 3)" exception:wrong-type-arg
1065 (filter-map noop '(1 2 3) '(1 . x) '(1 2 3)))
1067 (pass-if-exception "'(1 2 3) '(1 2 3) '(1 . x)" exception:wrong-type-arg
1068 (filter-map noop '(1 2 3) '(1 2 3) '(1 . x)))
1070 (pass-if "(1 2 3) (4 5 6) (7 8 9)"
1071 (equal? '(12 15 18) (filter-map + '(1 2 3) '(4 5 6) '(7 8 9))))
1073 (pass-if "(#f 2 3) (4 5) (7 8 9)"
1074 (equal? '(2) (filter-map noop '(#f 2 3) '(4 5) '(7 8 9))))
1076 (pass-if "(#f 2 3) (7 8 9) (4 5)"
1077 (equal? '(2) (filter-map noop '(#f 2 3) '(7 8 9) '(4 5))))
1079 (pass-if "(4 #f) (1 2 3) (7 8 9)"
1080 (equal? '(4) (filter-map noop '(4 #f) '(1 2 3) '(7 8 9))))
1082 (pass-if "apply list unchanged"
1083 (let ((lst (list (list 1 #f 2) (list 3 4 5) (list 6 7 8))))
1084 (and (equal? '(1 2) (apply filter-map noop lst))
1086 (equal? lst '((1 #f 2) (3 4 5) (6 7 8))))))))
1092 (with-test-prefix "find"
1093 (pass-if (eqv? #f (find odd? '())))
1094 (pass-if (eqv? #f (find odd? '(0))))
1095 (pass-if (eqv? #f (find odd? '(0 2))))
1096 (pass-if (eqv? 1 (find odd? '(1))))
1097 (pass-if (eqv? 1 (find odd? '(0 1))))
1098 (pass-if (eqv? 1 (find odd? '(0 1 2))))
1099 (pass-if (eqv? 1 (find odd? '(2 0 1))))
1100 (pass-if (eqv? 1 (find (lambda (x) (= 1 x)) '(2 0 1)))))
1106 (with-test-prefix "find-tail"
1107 (pass-if (let ((lst '()))
1108 (eq? #f (find-tail odd? lst))))
1109 (pass-if (let ((lst '(0)))
1110 (eq? #f (find-tail odd? lst))))
1111 (pass-if (let ((lst '(0 2)))
1112 (eq? #f (find-tail odd? lst))))
1113 (pass-if (let ((lst '(1)))
1114 (eq? lst (find-tail odd? lst))))
1115 (pass-if (let ((lst '(1 2)))
1116 (eq? lst (find-tail odd? lst))))
1117 (pass-if (let ((lst '(2 1)))
1118 (eq? (cdr lst) (find-tail odd? lst))))
1119 (pass-if (let ((lst '(2 1 0)))
1120 (eq? (cdr lst) (find-tail odd? lst))))
1121 (pass-if (let ((lst '(2 0 1)))
1122 (eq? (cddr lst) (find-tail odd? lst))))
1123 (pass-if (let ((lst '(2 0 1)))
1124 (eq? (cddr lst) (find-tail (lambda (x) (= 1 x)) lst)))))
1130 (with-test-prefix "fold"
1131 (pass-if-exception "no args" exception:wrong-num-args
1134 (pass-if-exception "one arg" exception:wrong-num-args
1137 (pass-if-exception "two args" exception:wrong-num-args
1140 (with-test-prefix "one list"
1142 (pass-if "arg order"
1143 (eq? #t (fold (lambda (x prev)
1148 (pass-if "empty list" (= 123 (fold + 123 '())))
1150 (pass-if-exception "proc arg count 0" exception:wrong-type-arg
1151 (fold (lambda () x) 123 '(1 2 3)))
1152 (pass-if-exception "proc arg count 1" exception:wrong-type-arg
1153 (fold (lambda (x) x) 123 '(1 2 3)))
1154 (pass-if-exception "proc arg count 3" exception:wrong-type-arg
1155 (fold (lambda (x y z) x) 123 '(1 2 3)))
1157 (pass-if-exception "improper 1" exception:wrong-type-arg
1159 (pass-if-exception "improper 2" exception:wrong-type-arg
1160 (fold + 123 '(1 . 2)))
1161 (pass-if-exception "improper 3" exception:wrong-type-arg
1162 (fold + 123 '(1 2 . 3)))
1164 (pass-if (= 3 (fold + 1 '(2))))
1165 (pass-if (= 6 (fold + 1 '(2 3))))
1166 (pass-if (= 10 (fold + 1 '(2 3 4)))))
1168 (with-test-prefix "two lists"
1170 (pass-if "arg order"
1171 (eq? #t (fold (lambda (x y prev)
1177 (pass-if "empty lists" (= 1 (fold + 1 '() '())))
1179 ;; currently bad proc argument gives wrong-num-args when 2 or more
1180 ;; lists, as opposed to wrong-type-arg for 1 list
1181 (pass-if-exception "proc arg count 2" exception:wrong-num-args
1182 (fold (lambda (x prev) x) 1 '(1 2 3) '(1 2 3)))
1183 (pass-if-exception "proc arg count 4" exception:wrong-num-args
1184 (fold (lambda (x y z prev) x) 1 '(1 2 3) '(1 2 3)))
1186 (pass-if-exception "improper first 1" exception:wrong-type-arg
1187 (fold + 1 1 '(1 2 3)))
1188 (pass-if-exception "improper first 2" exception:wrong-type-arg
1189 (fold + 1 '(1 . 2) '(1 2 3)))
1190 (pass-if-exception "improper first 3" exception:wrong-type-arg
1191 (fold + 1 '(1 2 . 3) '(1 2 3)))
1193 (pass-if-exception "improper second 1" exception:wrong-type-arg
1194 (fold + 1 '(1 2 3) 1))
1195 (pass-if-exception "improper second 2" exception:wrong-type-arg
1196 (fold + 1 '(1 2 3) '(1 . 2)))
1197 (pass-if-exception "improper second 3" exception:wrong-type-arg
1198 (fold + 1 '(1 2 3) '(1 2 . 3)))
1200 (pass-if (= 6 (fold + 1 '(2) '(3))))
1201 (pass-if (= 15 (fold + 1 '(2 3) '(4 5))))
1202 (pass-if (= 28 (fold + 1 '(2 3 4) '(5 6 7))))
1204 (with-test-prefix "stop shortest"
1205 (pass-if (= 13 (fold + 1 '(1 2 3) '(4 5))))
1206 (pass-if (= 13 (fold + 1 '(4 5) '(1 2 3))))
1207 (pass-if (= 11 (fold + 1 '(3 4) '(1 2 9 9))))
1208 (pass-if (= 11 (fold + 1 '(1 2 9 9) '(3 4)))))
1210 (pass-if "apply list unchanged"
1211 (let ((lst (list (list 1 2) (list 3 4))))
1212 (and (equal? 11 (apply fold + 1 lst))
1214 (equal? '((1 2) (3 4)) lst)))))
1216 (with-test-prefix "three lists"
1218 (pass-if "arg order"
1219 (eq? #t (fold (lambda (x y z prev)
1226 (pass-if "empty lists" (= 1 (fold + 1 '() '() '())))
1228 (pass-if-exception "proc arg count 3" exception:wrong-num-args
1229 (fold (lambda (x y prev) x) 1 '(1 2 3) '(1 2 3)'(1 2 3) ))
1230 (pass-if-exception "proc arg count 5" exception:wrong-num-args
1231 (fold (lambda (w x y z prev) x) 1 '(1 2 3) '(1 2 3) '(1 2 3)))
1233 (pass-if-exception "improper first 1" exception:wrong-type-arg
1234 (fold + 1 1 '(1 2 3) '(1 2 3)))
1235 (pass-if-exception "improper first 2" exception:wrong-type-arg
1236 (fold + 1 '(1 . 2) '(1 2 3) '(1 2 3)))
1237 (pass-if-exception "improper first 3" exception:wrong-type-arg
1238 (fold + 1 '(1 2 . 3) '(1 2 3) '(1 2 3)))
1240 (pass-if-exception "improper second 1" exception:wrong-type-arg
1241 (fold + 1 '(1 2 3) 1 '(1 2 3)))
1242 (pass-if-exception "improper second 2" exception:wrong-type-arg
1243 (fold + 1 '(1 2 3) '(1 . 2) '(1 2 3)))
1244 (pass-if-exception "improper second 3" exception:wrong-type-arg
1245 (fold + 1 '(1 2 3) '(1 2 . 3) '(1 2 3)))
1247 (pass-if-exception "improper third 1" exception:wrong-type-arg
1248 (fold + 1 '(1 2 3) '(1 2 3) 1))
1249 (pass-if-exception "improper third 2" exception:wrong-type-arg
1250 (fold + 1 '(1 2 3) '(1 2 3) '(1 . 2)))
1251 (pass-if-exception "improper third 3" exception:wrong-type-arg
1252 (fold + 1 '(1 2 3) '(1 2 3) '(1 2 . 3)))
1254 (pass-if (= 10 (fold + 1 '(2) '(3) '(4))))
1255 (pass-if (= 28 (fold + 1 '(2 5) '(3 6) '(4 7))))
1256 (pass-if (= 55 (fold + 1 '(2 5 8) '(3 6 9) '(4 7 10))))
1258 (with-test-prefix "stop shortest"
1259 (pass-if (= 28 (fold + 1 '(2 5 9) '(3 6) '(4 7))))
1260 (pass-if (= 28 (fold + 1 '(2 5) '(3 6 9) '(4 7))))
1261 (pass-if (= 28 (fold + 1 '(2 5) '(3 6) '(4 7 9)))))
1263 (pass-if "apply list unchanged"
1264 (let ((lst (list (list 1 2) (list 3 4) (list 5 6))))
1265 (and (equal? 22 (apply fold + 1 lst))
1267 (equal? '((1 2) (3 4) (5 6)) lst))))))
1273 (with-test-prefix "length+"
1274 (pass-if-exception "too few args" exception:wrong-num-args
1276 (pass-if-exception "too many args" exception:wrong-num-args
1278 (pass-if (= 0 (length+ '())))
1279 (pass-if (= 1 (length+ '(x))))
1280 (pass-if (= 2 (length+ '(x y))))
1281 (pass-if (= 3 (length+ '(x y z))))
1282 (pass-if (not (length+ (circular-list 1))))
1283 (pass-if (not (length+ (circular-list 1 2))))
1284 (pass-if (not (length+ (circular-list 1 2 3)))))
1290 (with-test-prefix "last"
1292 (pass-if-exception "empty" exception:wrong-type-arg
1295 (eqv? 1 (last '(1))))
1296 (pass-if "two elems"
1297 (eqv? 2 (last '(1 2))))
1298 (pass-if "three elems"
1299 (eqv? 3 (last '(1 2 3))))
1300 (pass-if "four elems"
1301 (eqv? 4 (last '(1 2 3 4)))))
1307 (with-test-prefix "list="
1310 (eq? #t (list= eqv?)))
1312 (with-test-prefix "one list"
1315 (eq? #t (list= eqv? '())))
1317 (eq? #t (list= eqv? '(1))))
1318 (pass-if "two elems"
1319 (eq? #t (list= eqv? '(2)))))
1321 (with-test-prefix "two lists"
1323 (pass-if "empty / empty"
1324 (eq? #t (list= eqv? '() '())))
1326 (pass-if "one / empty"
1327 (eq? #f (list= eqv? '(1) '())))
1329 (pass-if "empty / one"
1330 (eq? #f (list= eqv? '() '(1))))
1332 (pass-if "one / one same"
1333 (eq? #t (list= eqv? '(1) '(1))))
1335 (pass-if "one / one diff"
1336 (eq? #f (list= eqv? '(1) '(2))))
1338 (pass-if "called arg order"
1340 (list= (lambda (x y)
1341 (set! good (and good (= (1+ x) y)))
1346 (with-test-prefix "three lists"
1348 (pass-if "empty / empty / empty"
1349 (eq? #t (list= eqv? '() '() '())))
1351 (pass-if "one / empty / empty"
1352 (eq? #f (list= eqv? '(1) '() '())))
1354 (pass-if "one / one / empty"
1355 (eq? #f (list= eqv? '(1) '(1) '())))
1357 (pass-if "one / diff / empty"
1358 (eq? #f (list= eqv? '(1) '(2) '())))
1360 (pass-if "one / one / one"
1361 (eq? #t (list= eqv? '(1) '(1) '(1))))
1363 (pass-if "two / two / diff"
1364 (eq? #f (list= eqv? '(1 2) '(1 2) '(1 99))))
1366 (pass-if "two / two / two"
1367 (eq? #t (list= eqv? '(1 2) '(1 2) '(1 2))))
1369 (pass-if "called arg order"
1371 (list= (lambda (x y)
1372 (set! good (and good (= (1+ x) y)))
1374 '(1 4) '(2 5) '(3 6))
1381 (with-test-prefix "list-copy"
1382 (pass-if (equal? '() (list-copy '())))
1383 (pass-if (equal? '(1 2) (list-copy '(1 2))))
1384 (pass-if (equal? '(1 2 3) (list-copy '(1 2 3))))
1385 (pass-if (equal? '(1 2 3 4) (list-copy '(1 2 3 4))))
1386 (pass-if (equal? '(1 2 3 4 5) (list-copy '(1 2 3 4 5))))
1388 ;; improper lists can be copied
1389 (pass-if (equal? 1 (list-copy 1)))
1390 (pass-if (equal? '(1 . 2) (list-copy '(1 . 2))))
1391 (pass-if (equal? '(1 2 . 3) (list-copy '(1 2 . 3))))
1392 (pass-if (equal? '(1 2 3 . 4) (list-copy '(1 2 3 . 4))))
1393 (pass-if (equal? '(1 2 3 4 . 5) (list-copy '(1 2 3 4 . 5)))))
1399 (with-test-prefix "list-index"
1400 (pass-if-exception "no args" exception:wrong-num-args
1403 (pass-if-exception "one arg" exception:wrong-num-args
1406 (with-test-prefix "one list"
1408 (pass-if "empty list" (eq? #f (list-index symbol? '())))
1410 (pass-if-exception "pred arg count 0" exception:wrong-type-arg
1411 (list-index (lambda () x) '(1 2 3)))
1412 (pass-if-exception "pred arg count 2" exception:wrong-type-arg
1413 (list-index (lambda (x y) x) '(1 2 3)))
1415 (pass-if-exception "improper 1" exception:wrong-type-arg
1416 (list-index symbol? 1))
1417 (pass-if-exception "improper 2" exception:wrong-type-arg
1418 (list-index symbol? '(1 . 2)))
1419 (pass-if-exception "improper 3" exception:wrong-type-arg
1420 (list-index symbol? '(1 2 . 3)))
1422 (pass-if (eqv? #f (list-index symbol? '(1))))
1423 (pass-if (eqv? 0 (list-index symbol? '(x))))
1425 (pass-if (eqv? #f (list-index symbol? '(1 2))))
1426 (pass-if (eqv? 0 (list-index symbol? '(x 1))))
1427 (pass-if (eqv? 1 (list-index symbol? '(1 x))))
1429 (pass-if (eqv? #f (list-index symbol? '(1 2 3))))
1430 (pass-if (eqv? 0 (list-index symbol? '(x 1 2))))
1431 (pass-if (eqv? 1 (list-index symbol? '(1 x 2))))
1432 (pass-if (eqv? 2 (list-index symbol? '(1 2 x)))))
1434 (with-test-prefix "two lists"
1440 (pass-if "arg order"
1441 (eqv? 0 (list-index (lambda (x y)
1446 (pass-if "empty lists" (eqv? #f (list-index sym2 '() '())))
1448 (pass-if-exception "pred arg count 0" exception:wrong-type-arg
1449 (list-index (lambda () #t) '(1 2 3) '(1 2 3)))
1450 (pass-if-exception "pred arg count 1" exception:wrong-type-arg
1451 (list-index (lambda (x) x) '(1 2 3) '(1 2 3)))
1452 (pass-if-exception "pred arg count 3" exception:wrong-type-arg
1453 (list-index (lambda (x y z) x) '(1 2 3) '(1 2 3)))
1455 (pass-if-exception "improper first 1" exception:wrong-type-arg
1456 (list-index sym2 1 '(1 2 3)))
1457 (pass-if-exception "improper first 2" exception:wrong-type-arg
1458 (list-index sym2 '(1 . 2) '(1 2 3)))
1459 (pass-if-exception "improper first 3" exception:wrong-type-arg
1460 (list-index sym2 '(1 2 . 3) '(1 2 3)))
1462 (pass-if-exception "improper second 1" exception:wrong-type-arg
1463 (list-index sym2 '(1 2 3) 1))
1464 (pass-if-exception "improper second 2" exception:wrong-type-arg
1465 (list-index sym2 '(1 2 3) '(1 . 2)))
1466 (pass-if-exception "improper second 3" exception:wrong-type-arg
1467 (list-index sym2 '(1 2 3) '(1 2 . 3)))
1469 (pass-if (eqv? #f (list-index sym2 '(1) '(2))))
1470 (pass-if (eqv? 0 (list-index sym2 '(1) '(x))))
1472 (pass-if (eqv? #f (list-index sym2 '(1 2) '(3 4))))
1473 (pass-if (eqv? 0 (list-index sym2 '(1 2) '(x 3))))
1474 (pass-if (eqv? 1 (list-index sym2 '(1 2) '(3 x))))
1476 (pass-if (eqv? #f (list-index sym2 '(1 2 3) '(3 4 5))))
1477 (pass-if (eqv? 0 (list-index sym2 '(1 2 3) '(x 3 4))))
1478 (pass-if (eqv? 1 (list-index sym2 '(1 2 3) '(3 x 4))))
1479 (pass-if (eqv? 2 (list-index sym2 '(1 2 3) '(3 4 x))))
1481 (with-test-prefix "stop shortest"
1482 (pass-if (eqv? #f (list-index sym1 '(1 2 x) '(4 5))))
1483 (pass-if (eqv? #f (list-index sym2 '(4 5) '(1 2 x))))
1484 (pass-if (eqv? #f (list-index sym1 '(3 4) '(1 2 x y))))
1485 (pass-if (eqv? #f (list-index sym2 '(1 2 x y) '(3 4))))))
1487 (with-test-prefix "three lists"
1488 (define (sym1 x y z)
1490 (define (sym2 x y z)
1492 (define (sym3 x y z)
1495 (pass-if "arg order"
1496 (eqv? 0 (list-index (lambda (x y z)
1502 (pass-if "empty lists" (eqv? #f (list-index sym3 '() '() '())))
1504 ;; currently bad pred argument gives wrong-num-args when 3 or more
1505 ;; lists, as opposed to wrong-type-arg for 1 or 2 lists
1506 (pass-if-exception "pred arg count 0" exception:wrong-num-args
1507 (list-index (lambda () #t) '(1 2 3) '(1 2 3) '(1 2 3)))
1508 (pass-if-exception "pred arg count 2" exception:wrong-num-args
1509 (list-index (lambda (x y) x) '(1 2 3) '(1 2 3)'(1 2 3) ))
1510 (pass-if-exception "pred arg count 4" exception:wrong-num-args
1511 (list-index (lambda (w x y z) x) '(1 2 3) '(1 2 3) '(1 2 3)))
1513 (pass-if-exception "improper first 1" exception:wrong-type-arg
1514 (list-index sym3 1 '(1 2 3) '(1 2 3)))
1515 (pass-if-exception "improper first 2" exception:wrong-type-arg
1516 (list-index sym3 '(1 . 2) '(1 2 3) '(1 2 3)))
1517 (pass-if-exception "improper first 3" exception:wrong-type-arg
1518 (list-index sym3 '(1 2 . 3) '(1 2 3) '(1 2 3)))
1520 (pass-if-exception "improper second 1" exception:wrong-type-arg
1521 (list-index sym3 '(1 2 3) 1 '(1 2 3)))
1522 (pass-if-exception "improper second 2" exception:wrong-type-arg
1523 (list-index sym3 '(1 2 3) '(1 . 2) '(1 2 3)))
1524 (pass-if-exception "improper second 3" exception:wrong-type-arg
1525 (list-index sym3 '(1 2 3) '(1 2 . 3) '(1 2 3)))
1527 (pass-if-exception "improper third 1" exception:wrong-type-arg
1528 (list-index sym3 '(1 2 3) '(1 2 3) 1))
1529 (pass-if-exception "improper third 2" exception:wrong-type-arg
1530 (list-index sym3 '(1 2 3) '(1 2 3) '(1 . 2)))
1531 (pass-if-exception "improper third 3" exception:wrong-type-arg
1532 (list-index sym3 '(1 2 3) '(1 2 3) '(1 2 . 3)))
1534 (pass-if (eqv? #f (list-index sym3 '(#f) '(#f) '(#f))))
1535 (pass-if (eqv? 0 (list-index sym3 '(#f) '(#f) '(x))))
1537 (pass-if (eqv? #f (list-index sym3 '(#f #f) '(#f #f) '(#f #f))))
1538 (pass-if (eqv? 0 (list-index sym3 '(#f #f) '(#f #f) '(x #f))))
1539 (pass-if (eqv? 1 (list-index sym3 '(#f #f) '(#f #f) '(#f x))))
1541 (pass-if (eqv? #f (list-index sym3 '(#f #f #f) '(#f #f #f) '(#f #f #f))))
1542 (pass-if (eqv? 0 (list-index sym3 '(#f #f #f) '(#f #f #f) '(x #f #f))))
1543 (pass-if (eqv? 1 (list-index sym3 '(#f #f #f) '(#f #f #f) '(#f x #f))))
1544 (pass-if (eqv? 2 (list-index sym3 '(#f #f #f) '(#f #f #f) '(#f #f x))))
1546 (with-test-prefix "stop shortest"
1547 (pass-if (eqv? #f (list-index sym2 '() '(x x x) '(x x))))
1548 (pass-if (eqv? #f (list-index sym1 '(x x x) '() '(x x))))
1549 (pass-if (eqv? #f (list-index sym2 '(x x x) '(x x) '())))
1551 (pass-if (eqv? #f (list-index sym2 '(#t) '(#t x x) '(#t x))))
1552 (pass-if (eqv? #f (list-index sym1 '(#t x x) '(#t) '(#t x))))
1553 (pass-if (eqv? #f (list-index sym1 '(#t x x) '(#t x) '(#t)))))
1555 (pass-if "apply list unchanged"
1556 (let ((lst (list (list 1 2) (list 3 4) (list 5 6))))
1557 (and (equal? #f (apply list-index sym3 lst))
1559 (equal? '((1 2) (3 4) (5 6)) lst))))))
1565 (with-test-prefix "list-tabulate"
1567 (pass-if-exception "-1" exception:out-of-range
1568 (list-tabulate -1 identity))
1570 (equal? '() (list-tabulate 0 identity)))
1572 (equal? '(0) (list-tabulate 1 identity)))
1574 (equal? '(0 1) (list-tabulate 2 identity)))
1576 (equal? '(0 1 2) (list-tabulate 3 identity)))
1578 (equal? '(0 1 2 3) (list-tabulate 4 identity)))
1579 (pass-if "string ref proc"
1580 (equal? '(#\a #\b #\c #\d) (list-tabulate 4
1582 (string-ref "abcd" i))))))
1588 (with-test-prefix "lset="
1590 ;; in guile 1.6.7 and earlier, lset= incorrectly demanded at least one
1593 (eq? #t (lset= eq?)))
1595 (with-test-prefix "one arg"
1598 (eq? #t (lset= eqv? '())))
1601 (eq? #t (lset= eqv? '(1))))
1604 (eq? #t (lset= eqv? '(1 2)))))
1606 (with-test-prefix "two args"
1609 (eq? #t (lset= eqv? '() '())))
1612 (eq? #t (lset= eqv? '(1) '(1))))
1615 (eq? #f (lset= eqv? '(1) '(2))))
1617 (pass-if "(1) (1 2)"
1618 (eq? #f (lset= eqv? '(1) '(1 2))))
1620 (pass-if "(1 2) (2 1)"
1621 (eq? #t (lset= eqv? '(1 2) '(2 1))))
1623 (pass-if "called arg order"
1625 (lset= (lambda (x y)
1626 (if (not (= x (1- y)))
1632 (with-test-prefix "three args"
1635 (eq? #t (lset= eqv? '() '() '())))
1637 (pass-if "(1) (1) (1)"
1638 (eq? #t (lset= eqv? '(1) '(1) '(1))))
1640 (pass-if "(1) (1) (2)"
1641 (eq? #f (lset= eqv? '(1) '(1) '(2))))
1643 (pass-if "(1) (1) (1 2)"
1644 (eq? #f (lset= eqv? '(1) '(1) '(1 2))))
1646 (pass-if "(1 2 3) (3 2 1) (1 3 2)"
1647 (eq? #t (lset= eqv? '(1 2 3) '(3 2 1) '(1 3 2))))
1649 (pass-if "called arg order"
1651 (lset= (lambda (x y)
1652 (if (not (= x (1- y)))
1655 '(1 1) '(2 2) '(3 3))
1662 (with-test-prefix "lset-adjoin"
1664 ;; in guile 1.6.7 and earlier, lset-adjoin didn't actually use the given
1665 ;; `=' procedure, all comparisons were just with `equal?
1667 (with-test-prefix "case-insensitive ="
1669 (pass-if "(\"x\") \"X\""
1670 (equal? '("x") (lset-adjoin string-ci=? '("x") "X"))))
1672 (pass-if "called arg order"
1674 (lset-adjoin (lambda (x y)
1675 (set! good (and (= x 1) (= y 2)))
1680 (pass-if (equal? '() (lset-adjoin = '())))
1682 (pass-if (equal? '(1) (lset-adjoin = '() 1)))
1684 (pass-if (equal? '(1) (lset-adjoin = '() 1 1)))
1686 (pass-if (equal? '(2 1) (lset-adjoin = '() 1 2)))
1688 (pass-if (equal? '(3 1 2) (lset-adjoin = '(1 2) 1 2 3 2 1)))
1690 (pass-if "apply list unchanged"
1691 (let ((lst (list 1 2)))
1692 (and (equal? '(2 1 3) (apply lset-adjoin = '(3) lst))
1694 (equal? '(1 2) lst))))
1696 (pass-if "(1 1) 1 1"
1697 (equal? '(1 1) (lset-adjoin = '(1 1) 1 1)))
1699 ;; duplicates among args are cast out
1701 (equal? '(1 2) (lset-adjoin = '(2) 1 1))))
1707 (with-test-prefix "lset-difference"
1709 (pass-if "called arg order"
1711 (lset-difference (lambda (x y)
1712 (set! good (and (= x 1) (= y 2)))
1721 (with-test-prefix "lset-difference!"
1723 (pass-if-exception "proc - num" exception:wrong-type-arg
1724 (lset-difference! 123 '(4)))
1725 (pass-if-exception "proc - list" exception:wrong-type-arg
1726 (lset-difference! (list 1 2 3) '(4)))
1728 (pass-if "called arg order"
1730 (lset-difference! (lambda (x y)
1731 (set! good (and (= x 1) (= y 2)))
1736 (pass-if (equal? '() (lset-difference! = '())))
1737 (pass-if (equal? '(1) (lset-difference! = (list 1))))
1738 (pass-if (equal? '(1 2) (lset-difference! = (list 1 2))))
1740 (pass-if (equal? '() (lset-difference! = (list ) '(3))))
1741 (pass-if (equal? '() (lset-difference! = (list 3) '(3))))
1742 (pass-if (equal? '(1) (lset-difference! = (list 1 3) '(3))))
1743 (pass-if (equal? '(1) (lset-difference! = (list 3 1) '(3))))
1744 (pass-if (equal? '(1) (lset-difference! = (list 1 3 3) '(3))))
1745 (pass-if (equal? '(1) (lset-difference! = (list 3 1 3) '(3))))
1746 (pass-if (equal? '(1) (lset-difference! = (list 3 3 1) '(3))))
1748 (pass-if (equal? '(1) (lset-difference! = (list 1 2 3) '(2 3))))
1749 (pass-if (equal? '(1) (lset-difference! = (list 1 2 3) '(3 2))))
1750 (pass-if (equal? '(1) (lset-difference! = (list 1 2 3) '(3) '(2))))
1751 (pass-if (equal? '(1) (lset-difference! = (list 1 2 3) '(2) '(3))))
1752 (pass-if (equal? '(1) (lset-difference! = (list 1 2 3) '(2) '(2 3))))
1753 (pass-if (equal? '(1) (lset-difference! = (list 1 2 3) '(2) '(3 2))))
1755 (pass-if (equal? '(1 2) (lset-difference! = (list 1 2 3) '(3) '(3))))
1756 (pass-if (equal? '(1 2) (lset-difference! = (list 1 3 2) '(3) '(3))))
1757 (pass-if (equal? '(1 2) (lset-difference! = (list 3 1 2) '(3) '(3))))
1759 (pass-if (equal? '(1 2 3) (lset-difference! = (list 1 2 3 4) '(4))))
1760 (pass-if (equal? '(1 2 3) (lset-difference! = (list 1 2 4 3) '(4))))
1761 (pass-if (equal? '(1 2 3) (lset-difference! = (list 1 4 2 3) '(4))))
1762 (pass-if (equal? '(1 2 3) (lset-difference! = (list 4 1 2 3) '(4))))
1764 (pass-if (equal? '(1 2) (lset-difference! = (list 1 2 3 4) '(4) '(3))))
1765 (pass-if (equal? '(1 2) (lset-difference! = (list 1 3 2 4) '(4) '(3))))
1766 (pass-if (equal? '(1 2) (lset-difference! = (list 3 1 2 4) '(4) '(3))))
1767 (pass-if (equal? '(1 2) (lset-difference! = (list 1 3 4 2) '(4) '(3))))
1768 (pass-if (equal? '(1 2) (lset-difference! = (list 3 1 4 2) '(4) '(3))))
1769 (pass-if (equal? '(1 2) (lset-difference! = (list 3 4 1 2) '(4) '(3)))))
1772 ;; lset-diff+intersection
1775 (with-test-prefix "lset-diff+intersection"
1777 (pass-if "called arg order"
1779 (lset-diff+intersection (lambda (x y)
1780 (set! good (and (= x 1) (= y 2)))
1786 ;; lset-diff+intersection!
1789 (with-test-prefix "lset-diff+intersection"
1791 (pass-if "called arg order"
1793 (lset-diff+intersection (lambda (x y)
1794 (set! good (and (= x 1) (= y 2)))
1800 ;; lset-intersection
1803 (with-test-prefix "lset-intersection"
1805 (pass-if "called arg order"
1807 (lset-intersection (lambda (x y)
1808 (set! good (and (= x 1) (= y 2)))
1814 ;; lset-intersection!
1817 (with-test-prefix "lset-intersection"
1819 (pass-if "called arg order"
1821 (lset-intersection (lambda (x y)
1822 (set! good (and (= x 1) (= y 2)))
1831 (with-test-prefix "lset-union"
1834 (eq? '() (lset-union eq?)))
1837 (equal? '(1 2 3) (lset-union eq? '(1 2 3))))
1840 (equal? '() (lset-union eq? '() '())))
1842 (pass-if "'() '(1 2 3)"
1843 (equal? '(1 2 3) (lset-union eq? '() '(1 2 3))))
1845 (pass-if "'(1 2 3) '()"
1846 (equal? '(1 2 3) (lset-union eq? '(1 2 3) '())))
1848 (pass-if "'(1 2 3) '(4 3 5)"
1849 (equal? '(5 4 1 2 3) (lset-union eq? '(1 2 3) '(4 3 5))))
1851 (pass-if "'(1 2 3) '(4) '(3 5))"
1852 (equal? '(5 4 1 2 3) (lset-union eq? '(1 2 3) '(4) '(3 5))))
1854 ;; in guile 1.6.7 and earlier, `=' was called with the arguments the wrong
1856 (pass-if "called arg order"
1858 (lset-union (lambda (x y)
1859 (set! good (and (= x 1) (= y 2)))
1868 (with-test-prefix "member"
1870 (pass-if-exception "no args" exception:wrong-num-args
1873 (pass-if-exception "one arg" exception:wrong-num-args
1876 (pass-if "1 (1 2 3)"
1877 (let ((lst '(1 2 3)))
1878 (eq? lst (member 1 lst))))
1880 (pass-if "2 (1 2 3)"
1881 (let ((lst '(1 2 3)))
1882 (eq? (cdr lst) (member 2 lst))))
1884 (pass-if "3 (1 2 3)"
1885 (let ((lst '(1 2 3)))
1886 (eq? (cddr lst) (member 3 lst))))
1888 (pass-if "4 (1 2 3)"
1889 (let ((lst '(1 2 3)))
1890 (eq? #f (member 4 lst))))
1892 (pass-if "called arg order"
1894 (member 1 '(2) (lambda (x y)
1895 (set! good (and (eqv? 1 x)
1903 (with-test-prefix "ninth"
1904 (pass-if-exception "() -1" exception:out-of-range
1905 (ninth '(a b c d e f g h)))
1906 (pass-if (eq? 'i (ninth '(a b c d e f g h i))))
1907 (pass-if (eq? 'i (ninth '(a b c d e f g h i j)))))
1914 (with-test-prefix "not-pair?"
1916 (eq? #t (not-pair? 123)))
1918 (eq? #f (not-pair? '(x . y))))
1920 (eq? #t (not-pair? 'x))))
1926 (with-test-prefix "take"
1929 (null? (take '() 0)))
1932 (null? (take '(a) 0)))
1935 (null? (take '() 0)))
1937 (pass-if "'(a b c) 0"
1938 (null? (take '() 0)))
1943 (and (equal? '(a) got)
1944 (not (eq? lst got)))))
1950 (pass-if "'(a b c) 1"
1957 (and (equal? '(a b) got)
1958 (not (eq? lst got)))))
1960 (pass-if "'(a b c) 2"
1964 (pass-if "circular '(a) 0"
1966 (take (circular-list 'a) 0)))
1968 (pass-if "circular '(a) 1"
1970 (take (circular-list 'a) 1)))
1972 (pass-if "circular '(a) 2"
1974 (take (circular-list 'a) 2)))
1976 (pass-if "circular '(a b) 5"
1977 (equal? '(a b a b a)
1978 (take (circular-list 'a 'b) 5)))
1980 (pass-if "'(a . b) 1"
1984 (pass-if "'(a b . c) 1"
1986 (take '(a b . c) 1)))
1988 (pass-if "'(a b . c) 2"
1990 (take '(a b . c) 2))))
1996 (with-test-prefix "take-while"
1998 (pass-if (equal? '() (take-while odd? '())))
1999 (pass-if (equal? '(1) (take-while odd? '(1))))
2000 (pass-if (equal? '(1 3) (take-while odd? '(1 3))))
2001 (pass-if (equal? '(1 3 5) (take-while odd? '(1 3 5))))
2003 (pass-if (equal? '() (take-while odd? '(2))))
2004 (pass-if (equal? '(1) (take-while odd? '(1 2))))
2005 (pass-if (equal? '(1 3) (take-while odd? '(1 3 4))))
2007 (pass-if (equal? '() (take-while odd? '(2 1))))
2008 (pass-if (equal? '(1) (take-while odd? '(1 4 3))))
2009 (pass-if (equal? '() (take-while odd? '(4 1 3)))))
2015 (with-test-prefix "take-while!"
2017 (pass-if (equal? '() (take-while! odd? '())))
2018 (pass-if (equal? '(1) (take-while! odd? (list 1))))
2019 (pass-if (equal? '(1 3) (take-while! odd? (list 1 3))))
2020 (pass-if (equal? '(1 3 5) (take-while! odd? (list 1 3 5))))
2022 (pass-if (equal? '() (take-while! odd? (list 2))))
2023 (pass-if (equal? '(1) (take-while! odd? (list 1 2))))
2024 (pass-if (equal? '(1 3) (take-while! odd? (list 1 3 4))))
2026 (pass-if (equal? '() (take-while! odd? (list 2 1))))
2027 (pass-if (equal? '(1) (take-while! odd? (list 1 4 3))))
2028 (pass-if (equal? '() (take-while! odd? (list 4 1 3)))))
2034 (define (test-partition pred list kept-good dropped-good)
2035 (call-with-values (lambda ()
2036 (partition pred list))
2037 (lambda (kept dropped)
2038 (and (equal? kept kept-good)
2039 (equal? dropped dropped-good)))))
2041 (with-test-prefix "partition"
2043 (pass-if "with dropped tail"
2044 (test-partition even? '(1 2 3 4 5 6 7)
2045 '(2 4 6) '(1 3 5 7)))
2047 (pass-if "with kept tail"
2048 (test-partition even? '(1 2 3 4 5 6)
2051 (pass-if "with everything dropped"
2052 (test-partition even? '(1 3 5 7)
2055 (pass-if "with everything kept"
2056 (test-partition even? '(2 4 6)
2059 (pass-if "with empty list"
2060 (test-partition even? '()
2063 (pass-if "with reasonably long list"
2064 ;; the old implementation from SRFI-1 reference implementation
2065 ;; would signal a stack-overflow for a list of only 500 elements!
2066 (call-with-values (lambda ()
2068 (make-list 10000 1)))
2070 (and (= (length odd) 10000)
2071 (= (length even) 0)))))
2073 (pass-if-exception "with improper list"
2074 exception:wrong-type-arg
2075 (partition symbol? '(a b . c))))
2081 (define (test-partition! pred list kept-good dropped-good)
2082 (call-with-values (lambda ()
2083 (partition! pred list))
2084 (lambda (kept dropped)
2085 (and (equal? kept kept-good)
2086 (equal? dropped dropped-good)))))
2088 (with-test-prefix "partition!"
2090 (pass-if "with dropped tail"
2091 (test-partition! even? (list 1 2 3 4 5 6 7)
2092 '(2 4 6) '(1 3 5 7)))
2094 (pass-if "with kept tail"
2095 (test-partition! even? (list 1 2 3 4 5 6)
2098 (pass-if "with everything dropped"
2099 (test-partition! even? (list 1 3 5 7)
2102 (pass-if "with everything kept"
2103 (test-partition! even? (list 2 4 6)
2106 (pass-if "with empty list"
2107 (test-partition! even? '()
2110 (pass-if "with reasonably long list"
2111 ;; the old implementation from SRFI-1 reference implementation
2112 ;; would signal a stack-overflow for a list of only 500 elements!
2113 (call-with-values (lambda ()
2115 (make-list 10000 1)))
2117 (and (= (length odd) 10000)
2118 (= (length even) 0)))))
2120 (pass-if-exception "with improper list"
2121 exception:wrong-type-arg
2122 (partition! symbol? (cons* 'a 'b 'c))))
2128 (with-test-prefix "reduce"
2132 (ret (reduce (lambda (x prev)
2133 (set! calls (cons (list x prev) calls))
2136 (and (equal? calls '())
2141 (ret (reduce (lambda (x prev)
2142 (set! calls (cons (list x prev) calls))
2145 (and (equal? calls '())
2148 (pass-if "two elems"
2150 (ret (reduce (lambda (x prev)
2151 (set! calls (cons (list x prev) calls))
2154 (and (equal? calls '((3 2)))
2157 (pass-if "three elems"
2159 (ret (reduce (lambda (x prev)
2160 (set! calls (cons (list x prev) calls))
2163 (and (equal? calls '((4 3)
2167 (pass-if "four elems"
2169 (ret (reduce (lambda (x prev)
2170 (set! calls (cons (list x prev) calls))
2173 (and (equal? calls '((5 4)
2182 (with-test-prefix "reduce-right"
2186 (ret (reduce-right (lambda (x prev)
2187 (set! calls (cons (list x prev) calls))
2190 (and (equal? calls '())
2195 (ret (reduce-right (lambda (x prev)
2196 (set! calls (cons (list x prev) calls))
2199 (and (equal? calls '())
2202 (pass-if "two elems"
2204 (ret (reduce-right (lambda (x prev)
2205 (set! calls (cons (list x prev) calls))
2208 (and (equal? calls '((2 3)))
2211 (pass-if "three elems"
2213 (ret (reduce-right (lambda (x prev)
2214 (set! calls (cons (list x prev) calls))
2217 (and (equal? calls '((2 3)
2221 (pass-if "four elems"
2223 (ret (reduce-right (lambda (x prev)
2224 (set! calls (cons (list x prev) calls))
2227 (and (equal? calls '((2 3)
2236 (with-test-prefix "remove"
2238 (pass-if (equal? '() (remove odd? '())))
2239 (pass-if (equal? '() (remove odd? '(1))))
2240 (pass-if (equal? '(2) (remove odd? '(2))))
2242 (pass-if (equal? '() (remove odd? '(1 3))))
2243 (pass-if (equal? '(2) (remove odd? '(2 3))))
2244 (pass-if (equal? '(2) (remove odd? '(1 2))))
2245 (pass-if (equal? '(2 4) (remove odd? '(2 4))))
2247 (pass-if (equal? '() (remove odd? '(1 3 5))))
2248 (pass-if (equal? '(2) (remove odd? '(2 3 5))))
2249 (pass-if (equal? '(2) (remove odd? '(1 2 5))))
2250 (pass-if (equal? '(2 4) (remove odd? '(2 4 5))))
2252 (pass-if (equal? '(6) (remove odd? '(1 3 6))))
2253 (pass-if (equal? '(2 6) (remove odd? '(2 3 6))))
2254 (pass-if (equal? '(2 6) (remove odd? '(1 2 6))))
2255 (pass-if (equal? '(2 4 6) (remove odd? '(2 4 6)))))
2261 (with-test-prefix "remove!"
2263 (pass-if (equal? '() (remove! odd? '())))
2264 (pass-if (equal? '() (remove! odd? (list 1))))
2265 (pass-if (equal? '(2) (remove! odd? (list 2))))
2267 (pass-if (equal? '() (remove! odd? (list 1 3))))
2268 (pass-if (equal? '(2) (remove! odd? (list 2 3))))
2269 (pass-if (equal? '(2) (remove! odd? (list 1 2))))
2270 (pass-if (equal? '(2 4) (remove! odd? (list 2 4))))
2272 (pass-if (equal? '() (remove! odd? (list 1 3 5))))
2273 (pass-if (equal? '(2) (remove! odd? (list 2 3 5))))
2274 (pass-if (equal? '(2) (remove! odd? (list 1 2 5))))
2275 (pass-if (equal? '(2 4) (remove! odd? (list 2 4 5))))
2277 (pass-if (equal? '(6) (remove! odd? (list 1 3 6))))
2278 (pass-if (equal? '(2 6) (remove! odd? (list 2 3 6))))
2279 (pass-if (equal? '(2 6) (remove! odd? (list 1 2 6))))
2280 (pass-if (equal? '(2 4 6) (remove! odd? (list 2 4 6)))))
2286 (with-test-prefix "seventh"
2287 (pass-if-exception "() -1" exception:out-of-range
2288 (seventh '(a b c d e f)))
2289 (pass-if (eq? 'g (seventh '(a b c d e f g))))
2290 (pass-if (eq? 'g (seventh '(a b c d e f g h)))))
2296 (with-test-prefix "sixth"
2297 (pass-if-exception "() -1" exception:out-of-range
2298 (sixth '(a b c d e)))
2299 (pass-if (eq? 'f (sixth '(a b c d e f))))
2300 (pass-if (eq? 'f (sixth '(a b c d e f g)))))
2306 (with-test-prefix "split-at"
2308 (define (equal-values? lst thunk)
2309 (call-with-values thunk
2313 (pass-if-exception "() -1" exception:out-of-range
2315 (pass-if (equal-values? '(() ())
2316 (lambda () (split-at '() 0))))
2317 (pass-if-exception "() 1" exception:wrong-type-arg
2320 (pass-if-exception "(1) -1" exception:out-of-range
2322 (pass-if (equal-values? '(() (1)) (lambda () (split-at '(1) 0))))
2323 (pass-if (equal-values? '((1) ()) (lambda () (split-at '(1) 1))))
2324 (pass-if-exception "(1) 2" exception:wrong-type-arg
2327 (pass-if-exception "(4 5) -1" exception:out-of-range
2328 (split-at '(4 5) -1))
2329 (pass-if (equal-values? '(() (4 5)) (lambda () (split-at '(4 5) 0))))
2330 (pass-if (equal-values? '((4) (5)) (lambda () (split-at '(4 5) 1))))
2331 (pass-if (equal-values? '((4 5) ()) (lambda () (split-at '(4 5) 2))))
2332 (pass-if-exception "(4 5) 3" exception:wrong-type-arg
2333 (split-at '(4 5) 3))
2335 (pass-if-exception "(4 5 6) -1" exception:out-of-range
2336 (split-at '(4 5 6) -1))
2337 (pass-if (equal-values? '(() (4 5 6)) (lambda () (split-at '(4 5 6) 0))))
2338 (pass-if (equal-values? '((4) (5 6)) (lambda () (split-at '(4 5 6) 1))))
2339 (pass-if (equal-values? '((4 5) (6)) (lambda () (split-at '(4 5 6) 2))))
2340 (pass-if (equal-values? '((4 5 6) ()) (lambda () (split-at '(4 5 6) 3))))
2341 (pass-if-exception "(4 5 6) 4" exception:wrong-type-arg
2342 (split-at '(4 5 6) 4)))
2348 (with-test-prefix "split-at!"
2350 (define (equal-values? lst thunk)
2351 (call-with-values thunk
2355 (pass-if-exception "() -1" exception:out-of-range
2357 (pass-if (equal-values? '(() ())
2358 (lambda () (split-at! '() 0))))
2359 (pass-if-exception "() 1" exception:wrong-type-arg
2362 (pass-if-exception "(1) -1" exception:out-of-range
2363 (split-at! (list 1) -1))
2364 (pass-if (equal-values? '(() (1)) (lambda () (split-at! (list 1) 0))))
2365 (pass-if (equal-values? '((1) ()) (lambda () (split-at! (list 1) 1))))
2366 (pass-if-exception "(1) 2" exception:wrong-type-arg
2367 (split-at! (list 1) 2))
2369 (pass-if-exception "(4 5) -1" exception:out-of-range
2370 (split-at! (list 4 5) -1))
2371 (pass-if (equal-values? '(() (4 5)) (lambda () (split-at! (list 4 5) 0))))
2372 (pass-if (equal-values? '((4) (5)) (lambda () (split-at! (list 4 5) 1))))
2373 (pass-if (equal-values? '((4 5) ()) (lambda () (split-at! (list 4 5) 2))))
2374 (pass-if-exception "(4 5) 3" exception:wrong-type-arg
2375 (split-at! (list 4 5) 3))
2377 (pass-if-exception "(4 5 6) -1" exception:out-of-range
2378 (split-at! (list 4 5 6) -1))
2379 (pass-if (equal-values? '(() (4 5 6)) (lambda () (split-at! (list 4 5 6) 0))))
2380 (pass-if (equal-values? '((4) (5 6)) (lambda () (split-at! (list 4 5 6) 1))))
2381 (pass-if (equal-values? '((4 5) (6)) (lambda () (split-at! (list 4 5 6) 2))))
2382 (pass-if (equal-values? '((4 5 6) ()) (lambda () (split-at! (list 4 5 6) 3))))
2383 (pass-if-exception "(4 5 6) 4" exception:wrong-type-arg
2384 (split-at! (list 4 5 6) 4)))
2390 (with-test-prefix "span"
2392 (define (test-span lst want-v1 want-v2)
2395 (span positive? lst))
2396 (lambda (got-v1 got-v2)
2397 (and (equal? got-v1 want-v1)
2398 (equal? got-v2 want-v2)))))
2401 (test-span '() '() '()))
2404 (test-span '(1) '(1) '()))
2407 (test-span '(-1) '() '(-1)))
2410 (test-span '(1 2) '(1 2) '()))
2413 (test-span '(-1 1) '() '(-1 1)))
2416 (test-span '(1 -1) '(1) '(-1)))
2419 (test-span '(-1 -2) '() '(-1 -2)))
2422 (test-span '(1 2 3) '(1 2 3) '()))
2425 (test-span '(-1 1 2) '() '(-1 1 2)))
2428 (test-span '(1 -1 2) '(1) '(-1 2)))
2431 (test-span '(-1 -2 1) '() '(-1 -2 1)))
2434 (test-span '(1 2 -1) '(1 2) '(-1)))
2437 (test-span '(-1 1 -2) '() '(-1 1 -2)))
2440 (test-span '(1 -1 -2) '(1) '(-1 -2)))
2443 (test-span '(-1 -2 -3) '() '(-1 -2 -3))))
2449 (with-test-prefix "span!"
2451 (define (test-span! lst want-v1 want-v2)
2454 (span! positive? lst))
2455 (lambda (got-v1 got-v2)
2456 (and (equal? got-v1 want-v1)
2457 (equal? got-v2 want-v2)))))
2460 (test-span! '() '() '()))
2463 (test-span! (list 1) '(1) '()))
2466 (test-span! (list -1) '() '(-1)))
2469 (test-span! (list 1 2) '(1 2) '()))
2472 (test-span! (list -1 1) '() '(-1 1)))
2475 (test-span! (list 1 -1) '(1) '(-1)))
2478 (test-span! (list -1 -2) '() '(-1 -2)))
2481 (test-span! (list 1 2 3) '(1 2 3) '()))
2484 (test-span! (list -1 1 2) '() '(-1 1 2)))
2487 (test-span! (list 1 -1 2) '(1) '(-1 2)))
2490 (test-span! (list -1 -2 1) '() '(-1 -2 1)))
2493 (test-span! (list 1 2 -1) '(1 2) '(-1)))
2496 (test-span! (list -1 1 -2) '() '(-1 1 -2)))
2499 (test-span! (list 1 -1 -2) '(1) '(-1 -2)))
2502 (test-span! (list -1 -2 -3) '() '(-1 -2 -3))))
2508 (with-test-prefix "take!"
2510 (pass-if-exception "() -1" exception:out-of-range
2512 (pass-if (equal? '() (take! '() 0)))
2513 (pass-if-exception "() 1" exception:wrong-type-arg
2516 (pass-if-exception "(1) -1" exception:out-of-range
2518 (pass-if (equal? '() (take! '(1) 0)))
2519 (pass-if (equal? '(1) (take! '(1) 1)))
2520 (pass-if-exception "(1) 2" exception:wrong-type-arg
2523 (pass-if-exception "(4 5) -1" exception:out-of-range
2525 (pass-if (equal? '() (take! '(4 5) 0)))
2526 (pass-if (equal? '(4) (take! '(4 5) 1)))
2527 (pass-if (equal? '(4 5) (take! '(4 5) 2)))
2528 (pass-if-exception "(4 5) 3" exception:wrong-type-arg
2531 (pass-if-exception "(4 5 6) -1" exception:out-of-range
2532 (take! '(4 5 6) -1))
2533 (pass-if (equal? '() (take! '(4 5 6) 0)))
2534 (pass-if (equal? '(4) (take! '(4 5 6) 1)))
2535 (pass-if (equal? '(4 5) (take! '(4 5 6) 2)))
2536 (pass-if (equal? '(4 5 6) (take! '(4 5 6) 3)))
2537 (pass-if-exception "(4 5 6) 4" exception:wrong-type-arg
2538 (take! '(4 5 6) 4)))
2545 (with-test-prefix "take-right"
2547 (pass-if-exception "() -1" exception:out-of-range
2548 (take-right '() -1))
2549 (pass-if (equal? '() (take-right '() 0)))
2550 (pass-if-exception "() 1" exception:wrong-type-arg
2553 (pass-if-exception "(1) -1" exception:out-of-range
2554 (take-right '(1) -1))
2555 (pass-if (equal? '() (take-right '(1) 0)))
2556 (pass-if (equal? '(1) (take-right '(1) 1)))
2557 (pass-if-exception "(1) 2" exception:wrong-type-arg
2558 (take-right '(1) 2))
2560 (pass-if-exception "(4 5) -1" exception:out-of-range
2561 (take-right '(4 5) -1))
2562 (pass-if (equal? '() (take-right '(4 5) 0)))
2563 (pass-if (equal? '(5) (take-right '(4 5) 1)))
2564 (pass-if (equal? '(4 5) (take-right '(4 5) 2)))
2565 (pass-if-exception "(4 5) 3" exception:wrong-type-arg
2566 (take-right '(4 5) 3))
2568 (pass-if-exception "(4 5 6) -1" exception:out-of-range
2569 (take-right '(4 5 6) -1))
2570 (pass-if (equal? '() (take-right '(4 5 6) 0)))
2571 (pass-if (equal? '(6) (take-right '(4 5 6) 1)))
2572 (pass-if (equal? '(5 6) (take-right '(4 5 6) 2)))
2573 (pass-if (equal? '(4 5 6) (take-right '(4 5 6) 3)))
2574 (pass-if-exception "(4 5 6) 4" exception:wrong-type-arg
2575 (take-right '(4 5 6) 4)))
2581 (with-test-prefix "tenth"
2582 (pass-if-exception "() -1" exception:out-of-range
2583 (tenth '(a b c d e f g h i)))
2584 (pass-if (eq? 'j (tenth '(a b c d e f g h i j))))
2585 (pass-if (eq? 'j (tenth '(a b c d e f g h i j k)))))
2591 (with-test-prefix "xcons"
2592 (pass-if (equal? '(y . x) (xcons 'x 'y))))