1 ;;;; srfi-1.test --- Test suite for Guile's SRFI-1 functions. -*- scheme -*-
3 ;;;; Copyright 2003-2006, 2008-2011, 2014 Free Software Foundation, Inc.
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.
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.
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
19 (define-module (test-srfi-1)
20 #:use-module (test-suite lib)
21 #:use-module (srfi srfi-1))
24 (define (ref-delete x lst . proc)
25 "Reference implemenation of srfi-1 `delete'."
26 (set! proc (if (null? proc) equal? (car proc)))
31 (if (not (proc x (car lst)))
32 (set! ret (cons (car lst) ret)))))
34 (define (ref-delete-duplicates lst . proc)
35 "Reference implemenation of srfi-1 `delete-duplicates'."
36 (set! proc (if (null? proc) equal? (car proc)))
42 (let ((elem (car lst)))
43 (set! keep (cons elem keep))
44 (set! lst (ref-delete elem lst proc))))))
51 (with-test-prefix "alist-copy"
53 ;; return a list which is the pairs making up alist A, the spine and cells
54 (define (alist-pairs a)
58 (more (cdr a) (cons a result))
61 ;; return a list of the elements common to lists X and Y, compared with eq?
62 (define (common-elements x y)
66 (cons (car x) (common-elements (cdr x) y))
67 (common-elements (cdr x) y))))
69 ;; validate an alist-copy of OLD to NEW
70 ;; lists must be equal, and must comprise new pairs
71 (define (valid-alist-copy? old new)
73 (null? (common-elements old new))))
75 (pass-if-exception "too few args" exception:wrong-num-args
78 (pass-if-exception "too many args" exception:wrong-num-args
82 (pass-if old (valid-alist-copy? old (alist-copy old))))
84 (let ((old '((1 . 2))))
85 (pass-if old (valid-alist-copy? old (alist-copy old))))
87 (let ((old '((1 . 2) (3 . 4))))
88 (pass-if old (valid-alist-copy? old (alist-copy old))))
90 (let ((old '((1 . 2) (3 . 4) (5 . 6))))
91 (pass-if old (valid-alist-copy? old (alist-copy old)))))
97 (with-test-prefix "alist-delete"
99 (pass-if "equality call arg order"
101 (alist-delete 'k '((ak . 123))
103 (if (and (eq? k 'k) (eq? ak 'ak))
107 (pass-if "delete keys greater than 5"
108 (equal? '((4 . x) (5 . y))
109 (alist-delete 5 '((4 . x) (5 . y) (6 . z)) <)))
112 (equal? '() (alist-delete 'x '())))
115 (equal? '() (alist-delete 'y '((y . 1)))))
118 (equal? '((n . 1)) (alist-delete 'y '((n . 1)))))
121 (equal? '() (alist-delete 'y '((y . 1) (y . 2)))))
124 (equal? '((n . 1)) (alist-delete 'y '((n . 1) (y . 2)))))
127 (equal? '((n . 2)) (alist-delete 'y '((y . 1) (n . 2)))))
130 (equal? '((n . 1) (n . 2)) (alist-delete 'y '((n . 1) (n . 2)))))
133 (equal? '() (alist-delete 'y '((y . 1) (y . 2) (y . 3)))))
136 (equal? '((n . 1)) (alist-delete 'y '((n . 1) (y . 2) (y . 3)))))
139 (equal? '((n . 2)) (alist-delete 'y '((y . 1) (n . 2) (y . 3)))))
142 (equal? '((n . 1) (n . 2)) (alist-delete 'y '((n . 1) (n . 2) (y . 3)))))
145 (equal? '( (n . 3)) (alist-delete 'y '((y . 1) (y . 2) (n . 3)))))
148 (equal? '((n . 1) (n . 3)) (alist-delete 'y '((n . 1) (y . 2) (n . 3)))))
151 (equal? '((n . 2) (n . 3)) (alist-delete 'y '((y . 1) (n . 2) (n . 3)))))
154 (equal? '((n . 1) (n . 2) (n . 3)) (alist-delete 'y '((n . 1) (n . 2) (n . 3))))))
160 (with-test-prefix "append-map"
162 (with-test-prefix "one list"
165 (equal? '() (append-map noop '(()))))
168 (equal? '(1) (append-map noop '((1)))))
171 (equal? '(1 2) (append-map noop '((1 2)))))
174 (equal? '() (append-map noop '(() ()))))
177 (equal? '(1) (append-map noop '(() (1)))))
180 (equal? '(1 2) (append-map noop '(() (1 2)))))
183 (equal? '(1 2) (append-map noop '((1) (2)))))
186 (equal? '(1 2) (append-map noop '(() (1 2))))))
188 (with-test-prefix "two lists"
191 (equal? '() (append-map noop '(()) '(9))))
194 (equal? '(1) (append-map noop '((1)) '(9))))
196 (pass-if "() () / 9 9"
197 (equal? '() (append-map noop '(() ()) '(9 9))))
199 (pass-if "(1) (2) / 9"
200 (equal? '(1) (append-map noop '((1) (2)) '(9))))
202 (pass-if "(1) (2) / 9 9"
203 (equal? '(1 2) (append-map noop '((1) (2)) '(9 9))))))
209 (with-test-prefix "append-reverse"
211 ;; return a list which is the cars and cdrs of LST
212 (define (list-contents lst)
215 (cons* (car lst) (cdr lst) (list-contents (cdr lst)))))
217 (define (valid-append-reverse revhead tail want)
218 (let ((revhead-contents (list-contents revhead))
219 (got (append-reverse revhead tail)))
220 (and (equal? got want)
222 (equal? revhead-contents (list-contents revhead)))))
224 (pass-if-exception "too few args (0)" exception:wrong-num-args
227 (pass-if-exception "too few args (1)" exception:wrong-num-args
228 (append-reverse '(x)))
230 (pass-if-exception "too many args (3)" exception:wrong-num-args
231 (append-reverse '() '() #f))
233 (pass-if (valid-append-reverse '() '() '()))
234 (pass-if (valid-append-reverse '() '(1 2 3) '(1 2 3)))
236 (pass-if (valid-append-reverse '(1) '() '(1)))
237 (pass-if (valid-append-reverse '(1) '(2) '(1 2)))
238 (pass-if (valid-append-reverse '(1) '(2 3) '(1 2 3)))
240 (pass-if (valid-append-reverse '(1 2) '() '(2 1)))
241 (pass-if (valid-append-reverse '(1 2) '(3) '(2 1 3)))
242 (pass-if (valid-append-reverse '(1 2) '(3 4) '(2 1 3 4)))
244 (pass-if (valid-append-reverse '(1 2 3) '() '(3 2 1)))
245 (pass-if (valid-append-reverse '(1 2 3) '(4) '(3 2 1 4)))
246 (pass-if (valid-append-reverse '(1 2 3) '(4 5) '(3 2 1 4 5))))
252 (with-test-prefix "append-reverse!"
254 (pass-if-exception "too few args (0)" exception:wrong-num-args
257 (pass-if-exception "too few args (1)" exception:wrong-num-args
258 (append-reverse! '(x)))
260 (pass-if-exception "too many args (3)" exception:wrong-num-args
261 (append-reverse! '() '() #f))
263 (pass-if (equal? '() (append-reverse! '() '())))
264 (pass-if (equal? '(1 2 3) (append-reverse! '() '(1 2 3))))
266 (pass-if (equal? '(1) (append-reverse! '(1) '())))
267 (pass-if (equal? '(1 2) (append-reverse! '(1) '(2))))
268 (pass-if (equal? '(1 2 3) (append-reverse! '(1) '(2 3))))
270 (pass-if (equal? '(2 1) (append-reverse! '(1 2) '())))
271 (pass-if (equal? '(2 1 3) (append-reverse! '(1 2) '(3))))
272 (pass-if (equal? '(2 1 3 4) (append-reverse! '(1 2) '(3 4))))
274 (pass-if (equal? '(3 2 1) (append-reverse! '(1 2 3) '())))
275 (pass-if (equal? '(3 2 1 4) (append-reverse! '(1 2 3) '(4))))
276 (pass-if (equal? '(3 2 1 4 5) (append-reverse! '(1 2 3) '(4 5)))))
282 (with-test-prefix "assoc"
285 (let ((alist '((a . 1)
288 (eqv? #f (assoc 'z alist))))
291 (let ((alist '((a . 1)
294 (eqv? (second alist) (assoc 'b alist))))
296 ;; this was wrong in guile 1.8.0 (a gremlin newly introduced in the 1.8
297 ;; series, 1.6.x and earlier was ok)
298 (pass-if "= arg order"
299 (let ((alist '((b . 1)))
301 (assoc 'a alist (lambda (x y)
302 (set! good (and (eq? x 'a)
306 ;; likewise this one bad in guile 1.8.0
307 (pass-if "srfi-1 example <"
308 (let ((alist '((1 . a)
311 (eq? (third alist) (assoc 5 alist <)))))
317 (with-test-prefix "break"
319 (define (test-break lst want-v1 want-v2)
322 (break negative? lst))
323 (lambda (got-v1 got-v2)
324 (and (equal? got-v1 want-v1)
325 (equal? got-v2 want-v2)))))
328 (test-break '() '() '()))
331 (test-break '(1) '(1) '()))
334 (test-break '(-1) '() '(-1)))
337 (test-break '(1 2) '(1 2) '()))
340 (test-break '(-1 1) '() '(-1 1)))
343 (test-break '(1 -1) '(1) '(-1)))
346 (test-break '(-1 -2) '() '(-1 -2)))
349 (test-break '(1 2 3) '(1 2 3) '()))
352 (test-break '(-1 1 2) '() '(-1 1 2)))
355 (test-break '(1 -1 2) '(1) '(-1 2)))
358 (test-break '(-1 -2 1) '() '(-1 -2 1)))
361 (test-break '(1 2 -1) '(1 2) '(-1)))
364 (test-break '(-1 1 -2) '() '(-1 1 -2)))
367 (test-break '(1 -1 -2) '(1) '(-1 -2)))
370 (test-break '(-1 -2 -3) '() '(-1 -2 -3))))
376 (with-test-prefix "break!"
378 (define (test-break! lst want-v1 want-v2)
381 (break! negative? lst))
382 (lambda (got-v1 got-v2)
383 (and (equal? got-v1 want-v1)
384 (equal? got-v2 want-v2)))))
387 (test-break! '() '() '()))
390 (test-break! (list 1) '(1) '()))
393 (test-break! (list -1) '() '(-1)))
396 (test-break! (list 1 2) '(1 2) '()))
399 (test-break! (list -1 1) '() '(-1 1)))
402 (test-break! (list 1 -1) '(1) '(-1)))
405 (test-break! (list -1 -2) '() '(-1 -2)))
408 (test-break! (list 1 2 3) '(1 2 3) '()))
411 (test-break! (list -1 1 2) '() '(-1 1 2)))
414 (test-break! (list 1 -1 2) '(1) '(-1 2)))
417 (test-break! (list -1 -2 1) '() '(-1 -2 1)))
420 (test-break! (list 1 2 -1) '(1 2) '(-1)))
423 (test-break! (list -1 1 -2) '() '(-1 1 -2)))
426 (test-break! (list 1 -1 -2) '(1) '(-1 -2)))
429 (test-break! (list -1 -2 -3) '() '(-1 -2 -3))))
435 (with-test-prefix "car+cdr"
446 ;; concatenate and concatenate!
450 (define (common-tests concatenate-proc unmodified?)
451 (define (try lstlst want)
452 (let ((lstlst-copy (copy-tree lstlst))
453 (got (concatenate-proc lstlst)))
455 (if (not (equal? lstlst lstlst-copy))
456 (error "input lists modified")))
459 (pass-if-exception "too few args" exception:wrong-num-args
462 (pass-if-exception "too many args" exception:wrong-num-args
463 (concatenate-proc '() '()))
465 (pass-if-exception "number" exception:wrong-type-arg
466 (concatenate-proc 123))
468 (pass-if-exception "vector" exception:wrong-type-arg
469 (concatenate-proc #(1 2 3)))
474 (pass-if (try '((1)) '(1)))
475 (pass-if (try '((1 2)) '(1 2)))
476 (pass-if (try '(() (1)) '(1)))
477 (pass-if (try '(() () (1)) '(1)))
479 (pass-if (try '((1) (2)) '(1 2)))
480 (pass-if (try '(() (1 2)) '(1 2)))
482 (pass-if (try '((1) 2) '(1 . 2)))
483 (pass-if (try '((1) (2) 3) '(1 2 . 3)))
484 (pass-if (try '((1) (2) (3 . 4)) '(1 2 3 . 4)))
487 (with-test-prefix "concatenate"
488 (common-tests concatenate #t))
490 (with-test-prefix "concatenate!"
491 (common-tests concatenate! #f)))
497 (with-test-prefix "count"
498 (pass-if-exception "no args" exception:wrong-num-args
501 (pass-if-exception "one arg" exception:wrong-num-args
504 (with-test-prefix "one list"
508 (pass-if "empty list" (= 0 (count or1 '())))
510 (pass-if-exception "pred arg count 0" exception:wrong-num-args
511 (count (lambda () x) '(1 2 3)))
512 (pass-if-exception "pred arg count 2" exception:wrong-num-args
513 (count (lambda (x y) x) '(1 2 3)))
515 (pass-if-exception "improper 1" exception:wrong-type-arg
517 (pass-if-exception "improper 2" exception:wrong-type-arg
518 (count or1 '(1 . 2)))
519 (pass-if-exception "improper 3" exception:wrong-type-arg
520 (count or1 '(1 2 . 3)))
522 (pass-if (= 0 (count or1 '(#f))))
523 (pass-if (= 1 (count or1 '(#t))))
525 (pass-if (= 0 (count or1 '(#f #f))))
526 (pass-if (= 1 (count or1 '(#f #t))))
527 (pass-if (= 1 (count or1 '(#t #f))))
528 (pass-if (= 2 (count or1 '(#t #t))))
530 (pass-if (= 0 (count or1 '(#f #f #f))))
531 (pass-if (= 1 (count or1 '(#f #f #t))))
532 (pass-if (= 1 (count or1 '(#t #f #f))))
533 (pass-if (= 2 (count or1 '(#t #f #t))))
534 (pass-if (= 3 (count or1 '(#t #t #t)))))
536 (with-test-prefix "two lists"
541 (= 1 (count (lambda (x y)
546 (pass-if "empty lists" (= 0 (count or2 '() '())))
548 (pass-if-exception "pred arg count 0" exception:wrong-num-args
549 (count (lambda () #t) '(1 2 3) '(1 2 3)))
550 (pass-if-exception "pred arg count 1" exception:wrong-num-args
551 (count (lambda (x) x) '(1 2 3) '(1 2 3)))
552 (pass-if-exception "pred arg count 3" exception:wrong-num-args
553 (count (lambda (x y z) x) '(1 2 3) '(1 2 3)))
555 (pass-if-exception "improper first 1" exception:wrong-type-arg
556 (count or2 1 '(1 2 3)))
557 (pass-if-exception "improper first 2" exception:wrong-type-arg
558 (count or2 '(1 . 2) '(1 2 3)))
559 (pass-if-exception "improper first 3" exception:wrong-type-arg
560 (count or2 '(1 2 . 3) '(1 2 3)))
562 (pass-if-exception "improper second 1" exception:wrong-type-arg
563 (count or2 '(1 2 3) 1))
564 (pass-if-exception "improper second 2" exception:wrong-type-arg
565 (count or2 '(1 2 3) '(1 . 2)))
566 (pass-if-exception "improper second 3" exception:wrong-type-arg
567 (count or2 '(1 2 3) '(1 2 . 3)))
569 (pass-if (= 0 (count or2 '(#f) '(#f))))
570 (pass-if (= 1 (count or2 '(#t) '(#f))))
571 (pass-if (= 1 (count or2 '(#f) '(#t))))
573 (pass-if (= 0 (count or2 '(#f #f) '(#f #f))))
574 (pass-if (= 1 (count or2 '(#t #f) '(#t #f))))
575 (pass-if (= 2 (count or2 '(#t #t) '(#f #f))))
576 (pass-if (= 2 (count or2 '(#t #f) '(#f #t))))
578 (with-test-prefix "stop shortest"
579 (pass-if (= 2 (count or2 '(#t #f #t) '(#f #t))))
580 (pass-if (= 2 (count or2 '(#t #f #t #t) '(#f #t))))
581 (pass-if (= 2 (count or2 '(#t #f) '(#f #t #t))))
582 (pass-if (= 2 (count or2 '(#t #f) '(#f #t #t #t))))))
584 (with-test-prefix "three lists"
589 (= 1 (count (lambda (x y z)
595 (pass-if "empty lists" (= 0 (count or3 '() '() '())))
597 ;; currently bad pred argument gives wrong-num-args when 3 or more
598 ;; lists, as opposed to wrong-type-arg for 1 or 2 lists
599 (pass-if-exception "pred arg count 0" exception:wrong-num-args
600 (count (lambda () #t) '(1 2 3) '(1 2 3) '(1 2 3)))
601 (pass-if-exception "pred arg count 2" exception:wrong-num-args
602 (count (lambda (x y) x) '(1 2 3) '(1 2 3)'(1 2 3) ))
603 (pass-if-exception "pred arg count 4" exception:wrong-num-args
604 (count (lambda (w x y z) x) '(1 2 3) '(1 2 3) '(1 2 3)))
606 (pass-if-exception "improper first 1" exception:wrong-type-arg
607 (count or3 1 '(1 2 3) '(1 2 3)))
608 (pass-if-exception "improper first 2" exception:wrong-type-arg
609 (count or3 '(1 . 2) '(1 2 3) '(1 2 3)))
610 (pass-if-exception "improper first 3" exception:wrong-type-arg
611 (count or3 '(1 2 . 3) '(1 2 3) '(1 2 3)))
613 (pass-if-exception "improper second 1" exception:wrong-type-arg
614 (count or3 '(1 2 3) 1 '(1 2 3)))
615 (pass-if-exception "improper second 2" exception:wrong-type-arg
616 (count or3 '(1 2 3) '(1 . 2) '(1 2 3)))
617 (pass-if-exception "improper second 3" exception:wrong-type-arg
618 (count or3 '(1 2 3) '(1 2 . 3) '(1 2 3)))
620 (pass-if-exception "improper third 1" exception:wrong-type-arg
621 (count or3 '(1 2 3) '(1 2 3) 1))
622 (pass-if-exception "improper third 2" exception:wrong-type-arg
623 (count or3 '(1 2 3) '(1 2 3) '(1 . 2)))
624 (pass-if-exception "improper third 3" exception:wrong-type-arg
625 (count or3 '(1 2 3) '(1 2 3) '(1 2 . 3)))
627 (pass-if (= 0 (count or3 '(#f) '(#f) '(#f))))
628 (pass-if (= 1 (count or3 '(#t) '(#f) '(#f))))
629 (pass-if (= 1 (count or3 '(#f) '(#t) '(#f))))
630 (pass-if (= 1 (count or3 '(#f) '(#f) '(#t))))
632 (pass-if (= 0 (count or3 '(#f #f) '(#f #f) '(#f #f))))
634 (pass-if (= 1 (count or3 '(#t #f) '(#f #f) '(#f #f))))
635 (pass-if (= 1 (count or3 '(#f #t) '(#f #f) '(#f #f))))
636 (pass-if (= 1 (count or3 '(#f #f) '(#t #f) '(#f #f))))
637 (pass-if (= 1 (count or3 '(#f #f) '(#f #t) '(#f #f))))
638 (pass-if (= 1 (count or3 '(#f #f) '(#f #f) '(#t #f))))
639 (pass-if (= 1 (count or3 '(#f #f) '(#f #f) '(#f #t))))
641 (pass-if (= 2 (count or3 '(#t #t) '(#f #f) '(#f #f))))
642 (pass-if (= 2 (count or3 '(#f #f) '(#t #t) '(#f #f))))
643 (pass-if (= 2 (count or3 '(#f #f) '(#f #f) '(#t #t))))
644 (pass-if (= 2 (count or3 '(#f #f) '(#t #f) '(#f #t))))
646 (with-test-prefix "stop shortest"
647 (pass-if (= 0 (count or3 '() '(#t #t #t) '(#t #t))))
648 (pass-if (= 0 (count or3 '(#t #t #t) '() '(#t #t))))
649 (pass-if (= 0 (count or3 '(#t #t #t) '(#t #t) '())))
651 (pass-if (= 1 (count or3 '(#t) '(#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)))))
655 (pass-if "apply list unchanged"
656 (let ((lst (list (list 1 2) (list 3 4) (list 5 6))))
657 (and (equal? 2 (apply count or3 lst))
659 (equal? '((1 2) (3 4) (5 6)) lst))))))
662 ;; delete and delete!
666 ;; Call (PROC lst) for all lists of length up to 6, with all combinations
667 ;; of elements to be retained or deleted. Elements to retain are numbers,
668 ;; 0 upwards. Elements to be deleted are #f.
669 (define (test-lists proc)
672 (do ((limit (ash 1 n))
676 (do ((bit 0 (1+ bit)))
678 (set! lst (cons (if (logbit? bit i) bit #f) lst)))
681 (define (common-tests delete-proc)
682 (pass-if-exception "too few args" exception:wrong-num-args
685 (pass-if-exception "too many args" exception:wrong-num-args
686 (delete-proc 0 '() equal? 99))
689 (eq? '() (delete-proc 0 '() equal?)))
693 (delete-proc '(2) '((1) (2) (3)) equal?)))
696 (equal? '((1) (2) (3))
697 (delete-proc '(2) '((1) (2) (3)) eq?)))
699 (pass-if "called arg order"
701 (delete-proc 3 '(1 2 3 4 5) <))))
703 (with-test-prefix "delete"
704 (common-tests delete)
708 (let ((lst-copy (list-copy lst)))
709 (with-test-prefix lst-copy
711 (equal? (delete #f lst equal?)
712 (ref-delete #f lst equal?)))
713 (pass-if "non-destructive"
714 (equal? lst-copy lst)))))))
716 (with-test-prefix "delete!"
717 (common-tests delete!)
722 (equal? (delete! #f lst)
723 (ref-delete #f lst)))))))
726 ;; delete-duplicates and delete-duplicates!
730 ;; Call (PROC lst) for all lists of length 1 <= n <= 4, with all
731 ;; combinations of numbers 1 to n in the elements
732 (define (test-lists proc)
735 (do ((limit (integer-expt n n))
740 (rem i (quotient rem n)))
742 (set! lst (cons (remainder rem n) lst)))
745 (define (common-tests delete-duplicates-proc)
746 (pass-if-exception "too few args" exception:wrong-num-args
747 (delete-duplicates-proc))
749 (pass-if-exception "too many args" exception:wrong-num-args
750 (delete-duplicates-proc '() equal? 99))
753 (eq? '() (delete-duplicates-proc '())))
755 (pass-if "equal? (the default)"
757 (delete-duplicates-proc '((2) (2) (2)))))
760 (equal? '((2) (2) (2))
761 (delete-duplicates-proc '((2) (2) (2)) eq?)))
763 (pass-if "called arg order"
765 (delete-duplicates-proc '(1 2 3 4 5)
772 (with-test-prefix "delete-duplicates"
773 (common-tests delete-duplicates)
777 (let ((lst-copy (list-copy lst)))
778 (with-test-prefix lst-copy
780 (equal? (delete-duplicates lst)
781 (ref-delete-duplicates lst)))
782 (pass-if "non-destructive"
783 (equal? lst-copy lst)))))))
785 (with-test-prefix "delete-duplicates!"
786 (common-tests delete-duplicates!)
791 (equal? (delete-duplicates! lst)
792 (ref-delete-duplicates lst)))))))
798 (with-test-prefix "drop"
801 (null? (drop '() 0)))
828 (pass-if "'(a b c) 1"
829 (let ((lst '(a b c)))
833 (pass-if "circular '(a) 0"
834 (let ((lst (circular-list 'a)))
838 (pass-if "circular '(a) 1"
839 (let ((lst (circular-list 'a)))
843 (pass-if "circular '(a) 2"
844 (let ((lst (circular-list 'a)))
848 (pass-if "circular '(a b) 1"
849 (let ((lst (circular-list 'a)))
853 (pass-if "circular '(a b) 2"
854 (let ((lst (circular-list 'a)))
858 (pass-if "circular '(a b) 5"
859 (let ((lst (circular-list 'a)))
863 (pass-if "'(a . b) 1"
867 (pass-if "'(a b . c) 1"
869 (drop '(a b . c) 2))))
875 (with-test-prefix "drop-right"
877 (pass-if-exception "() -1" exception:out-of-range
879 (pass-if (equal? '() (drop-right '() 0)))
880 (pass-if-exception "() 1" exception:wrong-type-arg
883 (pass-if-exception "(1) -1" exception:out-of-range
884 (drop-right '(1) -1))
885 (pass-if (equal? '(1) (drop-right '(1) 0)))
886 (pass-if (equal? '() (drop-right '(1) 1)))
887 (pass-if-exception "(1) 2" exception:wrong-type-arg
890 (pass-if-exception "(4 5) -1" exception:out-of-range
891 (drop-right '(4 5) -1))
892 (pass-if (equal? '(4 5) (drop-right '(4 5) 0)))
893 (pass-if (equal? '(4) (drop-right '(4 5) 1)))
894 (pass-if (equal? '() (drop-right '(4 5) 2)))
895 (pass-if-exception "(4 5) 3" exception:wrong-type-arg
896 (drop-right '(4 5) 3))
898 (pass-if-exception "(4 5 6) -1" exception:out-of-range
899 (drop-right '(4 5 6) -1))
900 (pass-if (equal? '(4 5 6) (drop-right '(4 5 6) 0)))
901 (pass-if (equal? '(4 5) (drop-right '(4 5 6) 1)))
902 (pass-if (equal? '(4) (drop-right '(4 5 6) 2)))
903 (pass-if (equal? '() (drop-right '(4 5 6) 3)))
904 (pass-if-exception "(4 5 6) 4" exception:wrong-type-arg
905 (drop-right '(4 5 6) 4))
907 (pass-if "(a b . c) 0"
908 (equal? (drop-right '(a b . c) 0) '(a b)))
909 (pass-if "(a b . c) 1"
910 (equal? (drop-right '(a b . c) 1) '(a))))
916 (with-test-prefix "drop-right!"
918 (pass-if-exception "() -1" exception:out-of-range
919 (drop-right! '() -1))
920 (pass-if (equal? '() (drop-right! '() 0)))
921 (pass-if-exception "() 1" exception:wrong-type-arg
924 (pass-if-exception "(1) -1" exception:out-of-range
925 (drop-right! (list 1) -1))
926 (pass-if (equal? '(1) (drop-right! (list 1) 0)))
927 (pass-if (equal? '() (drop-right! (list 1) 1)))
928 (pass-if-exception "(1) 2" exception:wrong-type-arg
929 (drop-right! (list 1) 2))
931 (pass-if-exception "(4 5) -1" exception:out-of-range
932 (drop-right! (list 4 5) -1))
933 (pass-if (equal? '(4 5) (drop-right! (list 4 5) 0)))
934 (pass-if (equal? '(4) (drop-right! (list 4 5) 1)))
935 (pass-if (equal? '() (drop-right! (list 4 5) 2)))
936 (pass-if-exception "(4 5) 3" exception:wrong-type-arg
937 (drop-right! (list 4 5) 3))
939 (pass-if-exception "(4 5 6) -1" exception:out-of-range
940 (drop-right! (list 4 5 6) -1))
941 (pass-if (equal? '(4 5 6) (drop-right! (list 4 5 6) 0)))
942 (pass-if (equal? '(4 5) (drop-right! (list 4 5 6) 1)))
943 (pass-if (equal? '(4) (drop-right! (list 4 5 6) 2)))
944 (pass-if (equal? '() (drop-right! (list 4 5 6) 3)))
945 (pass-if-exception "(4 5 6) 4" exception:wrong-type-arg
946 (drop-right! (list 4 5 6) 4)))
952 (with-test-prefix "drop-while"
954 (pass-if (equal? '() (drop-while odd? '())))
955 (pass-if (equal? '() (drop-while odd? '(1))))
956 (pass-if (equal? '() (drop-while odd? '(1 3))))
957 (pass-if (equal? '() (drop-while odd? '(1 3 5))))
959 (pass-if (equal? '(2) (drop-while odd? '(2))))
960 (pass-if (equal? '(2) (drop-while odd? '(1 2))))
961 (pass-if (equal? '(4) (drop-while odd? '(1 3 4))))
963 (pass-if (equal? '(2 1) (drop-while odd? '(2 1))))
964 (pass-if (equal? '(4 3) (drop-while odd? '(1 4 3))))
965 (pass-if (equal? '(4 1 3) (drop-while odd? '(4 1 3)))))
971 (with-test-prefix "eighth"
972 (pass-if-exception "() -1" exception:wrong-type-arg
973 (eighth '(a b c d e f g)))
974 (pass-if (eq? 'h (eighth '(a b c d e f g h))))
975 (pass-if (eq? 'h (eighth '(a b c d e f g h i)))))
981 (with-test-prefix "fifth"
982 (pass-if-exception "() -1" exception:wrong-type-arg
984 (pass-if (eq? 'e (fifth '(a b c d e))))
985 (pass-if (eq? 'e (fifth '(a b c d e f)))))
991 (with-test-prefix "filter-map"
993 (with-test-prefix "one list"
994 (pass-if-exception "'x" exception:wrong-type-arg
995 (filter-map noop 'x))
997 (pass-if-exception "'(1 . x)" exception:wrong-type-arg
998 (filter-map noop '(1 . x)))
1001 (equal? '(1) (filter-map noop '(1))))
1004 (equal? '() (filter-map noop '(#f))))
1007 (equal? '(1 2) (filter-map noop '(1 2))))
1010 (equal? '(2) (filter-map noop '(#f 2))))
1013 (equal? '() (filter-map noop '(#f #f))))
1016 (equal? '(1 2 3) (filter-map noop '(1 2 3))))
1019 (equal? '(2 3) (filter-map noop '(#f 2 3))))
1022 (equal? '(1 3) (filter-map noop '(1 #f 3))))
1025 (equal? '(1 2) (filter-map noop '(1 2 #f)))))
1027 (with-test-prefix "two lists"
1028 (pass-if-exception "'x '(1 2 3)" exception:wrong-type-arg
1029 (filter-map noop 'x '(1 2 3)))
1031 (pass-if-exception "'(1 2 3) 'x" exception:wrong-type-arg
1032 (filter-map noop '(1 2 3) 'x))
1034 (pass-if-exception "'(1 . x) '(1 2 3)" exception:wrong-type-arg
1035 (filter-map noop '(1 . x) '(1 2 3)))
1037 (pass-if-exception "'(1 2 3) '(1 . x)" exception:wrong-type-arg
1038 (filter-map noop '(1 2 3) '(1 . x)))
1040 (pass-if "(1 2 3) (4 5 6)"
1041 (equal? '(5 7 9) (filter-map + '(1 2 3) '(4 5 6))))
1043 (pass-if "(#f 2 3) (4 5)"
1044 (equal? '(2) (filter-map noop '(#f 2 3) '(4 5))))
1046 (pass-if "(4 #f) (1 2 3)"
1047 (equal? '(4) (filter-map noop '(4 #f) '(1 2 3))))
1049 (pass-if "() (1 2 3)"
1050 (equal? '() (filter-map noop '() '(1 2 3))))
1052 (pass-if "(1 2 3) ()"
1053 (equal? '() (filter-map noop '(1 2 3) '()))))
1055 (with-test-prefix "three lists"
1056 (pass-if-exception "'x '(1 2 3) '(1 2 3)" exception:wrong-type-arg
1057 (filter-map noop 'x '(1 2 3) '(1 2 3)))
1059 (pass-if-exception "'(1 2 3) 'x '(1 2 3)" exception:wrong-type-arg
1060 (filter-map noop '(1 2 3) 'x '(1 2 3)))
1062 (pass-if-exception "'(1 2 3) '(1 2 3) 'x" exception:wrong-type-arg
1063 (filter-map noop '(1 2 3) '(1 2 3) 'x))
1065 (pass-if-exception "'(1 . x) '(1 2 3) '(1 2 3)" exception:wrong-type-arg
1066 (filter-map noop '(1 . x) '(1 2 3) '(1 2 3)))
1068 (pass-if-exception "'(1 2 3) '(1 . x) '(1 2 3)" exception:wrong-type-arg
1069 (filter-map noop '(1 2 3) '(1 . x) '(1 2 3)))
1071 (pass-if-exception "'(1 2 3) '(1 2 3) '(1 . x)" exception:wrong-type-arg
1072 (filter-map noop '(1 2 3) '(1 2 3) '(1 . x)))
1074 (pass-if "(1 2 3) (4 5 6) (7 8 9)"
1075 (equal? '(12 15 18) (filter-map + '(1 2 3) '(4 5 6) '(7 8 9))))
1077 (pass-if "(#f 2 3) (4 5) (7 8 9)"
1078 (equal? '(2) (filter-map noop '(#f 2 3) '(4 5) '(7 8 9))))
1080 (pass-if "(#f 2 3) (7 8 9) (4 5)"
1081 (equal? '(2) (filter-map noop '(#f 2 3) '(7 8 9) '(4 5))))
1083 (pass-if "(4 #f) (1 2 3) (7 8 9)"
1084 (equal? '(4) (filter-map noop '(4 #f) '(1 2 3) '(7 8 9))))
1086 (pass-if "apply list unchanged"
1087 (let ((lst (list (list 1 #f 2) (list 3 4 5) (list 6 7 8))))
1088 (and (equal? '(1 2) (apply filter-map noop lst))
1090 (equal? lst '((1 #f 2) (3 4 5) (6 7 8))))))))
1096 (with-test-prefix "find"
1097 (pass-if (eqv? #f (find odd? '())))
1098 (pass-if (eqv? #f (find odd? '(0))))
1099 (pass-if (eqv? #f (find odd? '(0 2))))
1100 (pass-if (eqv? 1 (find odd? '(1))))
1101 (pass-if (eqv? 1 (find odd? '(0 1))))
1102 (pass-if (eqv? 1 (find odd? '(0 1 2))))
1103 (pass-if (eqv? 1 (find odd? '(2 0 1))))
1104 (pass-if (eqv? 1 (find (lambda (x) (= 1 x)) '(2 0 1)))))
1110 (with-test-prefix "find-tail"
1111 (pass-if (let ((lst '()))
1112 (eq? #f (find-tail odd? lst))))
1113 (pass-if (let ((lst '(0)))
1114 (eq? #f (find-tail odd? lst))))
1115 (pass-if (let ((lst '(0 2)))
1116 (eq? #f (find-tail odd? lst))))
1117 (pass-if (let ((lst '(1)))
1118 (eq? lst (find-tail odd? lst))))
1119 (pass-if (let ((lst '(1 2)))
1120 (eq? lst (find-tail odd? lst))))
1121 (pass-if (let ((lst '(2 1)))
1122 (eq? (cdr lst) (find-tail odd? lst))))
1123 (pass-if (let ((lst '(2 1 0)))
1124 (eq? (cdr lst) (find-tail odd? lst))))
1125 (pass-if (let ((lst '(2 0 1)))
1126 (eq? (cddr lst) (find-tail odd? lst))))
1127 (pass-if (let ((lst '(2 0 1)))
1128 (eq? (cddr lst) (find-tail (lambda (x) (= 1 x)) lst)))))
1134 (with-test-prefix "fold"
1135 (pass-if-exception "no args" exception:wrong-num-args
1138 (pass-if-exception "one arg" exception:wrong-num-args
1141 (pass-if-exception "two args" exception:wrong-num-args
1144 (with-test-prefix "one list"
1146 (pass-if "arg order"
1147 (eq? #t (fold (lambda (x prev)
1152 (pass-if "empty list" (= 123 (fold + 123 '())))
1154 (pass-if-exception "proc arg count 0" exception:wrong-num-args
1155 (fold (lambda () x) 123 '(1 2 3)))
1156 (pass-if-exception "proc arg count 1" exception:wrong-num-args
1157 (fold (lambda (x) x) 123 '(1 2 3)))
1158 (pass-if-exception "proc arg count 3" exception:wrong-num-args
1159 (fold (lambda (x y z) x) 123 '(1 2 3)))
1161 (pass-if-exception "improper 1" exception:wrong-type-arg
1163 (pass-if-exception "improper 2" exception:wrong-type-arg
1164 (fold + 123 '(1 . 2)))
1165 (pass-if-exception "improper 3" exception:wrong-type-arg
1166 (fold + 123 '(1 2 . 3)))
1168 (pass-if (= 3 (fold + 1 '(2))))
1169 (pass-if (= 6 (fold + 1 '(2 3))))
1170 (pass-if (= 10 (fold + 1 '(2 3 4)))))
1172 (with-test-prefix "two lists"
1174 (pass-if "arg order"
1175 (eq? #t (fold (lambda (x y prev)
1181 (pass-if "empty lists" (= 1 (fold + 1 '() '())))
1183 ;; currently bad proc argument gives wrong-num-args when 2 or more
1184 ;; lists, as opposed to wrong-type-arg for 1 list
1185 (pass-if-exception "proc arg count 2" exception:wrong-num-args
1186 (fold (lambda (x prev) x) 1 '(1 2 3) '(1 2 3)))
1187 (pass-if-exception "proc arg count 4" exception:wrong-num-args
1188 (fold (lambda (x y z prev) x) 1 '(1 2 3) '(1 2 3)))
1190 (pass-if-exception "improper first 1" exception:wrong-type-arg
1191 (fold + 1 1 '(1 2 3)))
1192 (pass-if-exception "improper first 2" exception:wrong-type-arg
1193 (fold + 1 '(1 . 2) '(1 2 3)))
1194 (pass-if-exception "improper first 3" exception:wrong-type-arg
1195 (fold + 1 '(1 2 . 3) '(1 2 3)))
1197 (pass-if-exception "improper second 1" exception:wrong-type-arg
1198 (fold + 1 '(1 2 3) 1))
1199 (pass-if-exception "improper second 2" exception:wrong-type-arg
1200 (fold + 1 '(1 2 3) '(1 . 2)))
1201 (pass-if-exception "improper second 3" exception:wrong-type-arg
1202 (fold + 1 '(1 2 3) '(1 2 . 3)))
1204 (pass-if (= 6 (fold + 1 '(2) '(3))))
1205 (pass-if (= 15 (fold + 1 '(2 3) '(4 5))))
1206 (pass-if (= 28 (fold + 1 '(2 3 4) '(5 6 7))))
1208 (with-test-prefix "stop shortest"
1209 (pass-if (= 13 (fold + 1 '(1 2 3) '(4 5))))
1210 (pass-if (= 13 (fold + 1 '(4 5) '(1 2 3))))
1211 (pass-if (= 11 (fold + 1 '(3 4) '(1 2 9 9))))
1212 (pass-if (= 11 (fold + 1 '(1 2 9 9) '(3 4)))))
1214 (pass-if "apply list unchanged"
1215 (let ((lst (list (list 1 2) (list 3 4))))
1216 (and (equal? 11 (apply fold + 1 lst))
1218 (equal? '((1 2) (3 4)) lst)))))
1220 (with-test-prefix "three lists"
1222 (pass-if "arg order"
1223 (eq? #t (fold (lambda (x y z prev)
1230 (pass-if "empty lists" (= 1 (fold + 1 '() '() '())))
1232 (pass-if-exception "proc arg count 3" exception:wrong-num-args
1233 (fold (lambda (x y prev) x) 1 '(1 2 3) '(1 2 3)'(1 2 3) ))
1234 (pass-if-exception "proc arg count 5" exception:wrong-num-args
1235 (fold (lambda (w x y z prev) x) 1 '(1 2 3) '(1 2 3) '(1 2 3)))
1237 (pass-if-exception "improper first 1" exception:wrong-type-arg
1238 (fold + 1 1 '(1 2 3) '(1 2 3)))
1239 (pass-if-exception "improper first 2" exception:wrong-type-arg
1240 (fold + 1 '(1 . 2) '(1 2 3) '(1 2 3)))
1241 (pass-if-exception "improper first 3" exception:wrong-type-arg
1242 (fold + 1 '(1 2 . 3) '(1 2 3) '(1 2 3)))
1244 (pass-if-exception "improper second 1" exception:wrong-type-arg
1245 (fold + 1 '(1 2 3) 1 '(1 2 3)))
1246 (pass-if-exception "improper second 2" exception:wrong-type-arg
1247 (fold + 1 '(1 2 3) '(1 . 2) '(1 2 3)))
1248 (pass-if-exception "improper second 3" exception:wrong-type-arg
1249 (fold + 1 '(1 2 3) '(1 2 . 3) '(1 2 3)))
1251 (pass-if-exception "improper third 1" exception:wrong-type-arg
1252 (fold + 1 '(1 2 3) '(1 2 3) 1))
1253 (pass-if-exception "improper third 2" exception:wrong-type-arg
1254 (fold + 1 '(1 2 3) '(1 2 3) '(1 . 2)))
1255 (pass-if-exception "improper third 3" exception:wrong-type-arg
1256 (fold + 1 '(1 2 3) '(1 2 3) '(1 2 . 3)))
1258 (pass-if (= 10 (fold + 1 '(2) '(3) '(4))))
1259 (pass-if (= 28 (fold + 1 '(2 5) '(3 6) '(4 7))))
1260 (pass-if (= 55 (fold + 1 '(2 5 8) '(3 6 9) '(4 7 10))))
1262 (with-test-prefix "stop shortest"
1263 (pass-if (= 28 (fold + 1 '(2 5 9) '(3 6) '(4 7))))
1264 (pass-if (= 28 (fold + 1 '(2 5) '(3 6 9) '(4 7))))
1265 (pass-if (= 28 (fold + 1 '(2 5) '(3 6) '(4 7 9)))))
1267 (pass-if "apply list unchanged"
1268 (let ((lst (list (list 1 2) (list 3 4) (list 5 6))))
1269 (and (equal? 22 (apply fold + 1 lst))
1271 (equal? '((1 2) (3 4) (5 6)) lst))))))
1277 (with-test-prefix "fold-right"
1281 (fold-right cons '() (iota 10))))
1283 (pass-if "two lists"
1284 (equal? (zip (iota 10) (map integer->char (iota 10)))
1285 (fold-right (lambda (x y z)
1286 (cons (list x y) z))
1289 (map integer->char (iota 10)))))
1291 (pass-if "tail-recursive"
1292 (= 1e6 (fold-right (lambda (x y) (+ 1 y))
1299 (with-test-prefix "unfold"
1303 (unfold (lambda (x) (>= x 10))
1309 (equal? (append (iota 10) '(tail 10))
1310 (unfold (lambda (x) (>= x 10))
1314 (lambda (seed) (list 'tail seed)))))
1316 (pass-if "tail-recursive"
1318 (pair? (unfold (lambda (x) (>= x 1e6))
1327 (with-test-prefix "length+"
1328 (pass-if-exception "too few args" exception:wrong-num-args
1330 (pass-if-exception "too many args" exception:wrong-num-args
1332 (pass-if-exception "not a pair" exception:wrong-type-arg
1334 (pass-if-exception "improper list" exception:wrong-type-arg
1335 (length+ '(x y . z)))
1336 (pass-if (= 0 (length+ '())))
1337 (pass-if (= 1 (length+ '(x))))
1338 (pass-if (= 2 (length+ '(x y))))
1339 (pass-if (= 3 (length+ '(x y z))))
1340 (pass-if (not (length+ (circular-list 1))))
1341 (pass-if (not (length+ (circular-list 1 2))))
1342 (pass-if (not (length+ (circular-list 1 2 3)))))
1348 (with-test-prefix "last"
1350 (pass-if-exception "empty" exception:wrong-type-arg
1353 (eqv? 1 (last '(1))))
1354 (pass-if "two elems"
1355 (eqv? 2 (last '(1 2))))
1356 (pass-if "three elems"
1357 (eqv? 3 (last '(1 2 3))))
1358 (pass-if "four elems"
1359 (eqv? 4 (last '(1 2 3 4)))))
1365 (with-test-prefix "list="
1368 (eq? #t (list= eqv?)))
1370 (with-test-prefix "one list"
1373 (eq? #t (list= eqv? '())))
1375 (eq? #t (list= eqv? '(1))))
1376 (pass-if "two elems"
1377 (eq? #t (list= eqv? '(2)))))
1379 (with-test-prefix "two lists"
1381 (pass-if "empty / empty"
1382 (eq? #t (list= eqv? '() '())))
1384 (pass-if "one / empty"
1385 (eq? #f (list= eqv? '(1) '())))
1387 (pass-if "empty / one"
1388 (eq? #f (list= eqv? '() '(1))))
1390 (pass-if "one / one same"
1391 (eq? #t (list= eqv? '(1) '(1))))
1393 (pass-if "one / one diff"
1394 (eq? #f (list= eqv? '(1) '(2))))
1396 (pass-if "called arg order"
1398 (list= (lambda (x y)
1399 (set! good (and good (= (1+ x) y)))
1404 (with-test-prefix "three lists"
1406 (pass-if "empty / empty / empty"
1407 (eq? #t (list= eqv? '() '() '())))
1409 (pass-if "one / empty / empty"
1410 (eq? #f (list= eqv? '(1) '() '())))
1412 (pass-if "one / one / empty"
1413 (eq? #f (list= eqv? '(1) '(1) '())))
1415 (pass-if "one / diff / empty"
1416 (eq? #f (list= eqv? '(1) '(2) '())))
1418 (pass-if "one / one / one"
1419 (eq? #t (list= eqv? '(1) '(1) '(1))))
1421 (pass-if "two / two / diff"
1422 (eq? #f (list= eqv? '(1 2) '(1 2) '(1 99))))
1424 (pass-if "two / two / two"
1425 (eq? #t (list= eqv? '(1 2) '(1 2) '(1 2))))
1427 (pass-if "called arg order"
1429 (list= (lambda (x y)
1430 (set! good (and good (= (1+ x) y)))
1432 '(1 4) '(2 5) '(3 6))
1439 (with-test-prefix "list-copy"
1440 (pass-if (equal? '() (list-copy '())))
1441 (pass-if (equal? '(1 2) (list-copy '(1 2))))
1442 (pass-if (equal? '(1 2 3) (list-copy '(1 2 3))))
1443 (pass-if (equal? '(1 2 3 4) (list-copy '(1 2 3 4))))
1444 (pass-if (equal? '(1 2 3 4 5) (list-copy '(1 2 3 4 5))))
1446 ;; improper lists can be copied
1447 (pass-if (equal? 1 (list-copy 1)))
1448 (pass-if (equal? '(1 . 2) (list-copy '(1 . 2))))
1449 (pass-if (equal? '(1 2 . 3) (list-copy '(1 2 . 3))))
1450 (pass-if (equal? '(1 2 3 . 4) (list-copy '(1 2 3 . 4))))
1451 (pass-if (equal? '(1 2 3 4 . 5) (list-copy '(1 2 3 4 . 5)))))
1457 (with-test-prefix "list-index"
1458 (pass-if-exception "no args" exception:wrong-num-args
1461 (pass-if-exception "one arg" exception:wrong-num-args
1464 (with-test-prefix "one list"
1466 (pass-if "empty list" (eq? #f (list-index symbol? '())))
1468 (pass-if-exception "pred arg count 0" exception:wrong-num-args
1469 (list-index (lambda () x) '(1 2 3)))
1470 (pass-if-exception "pred arg count 2" exception:wrong-num-args
1471 (list-index (lambda (x y) x) '(1 2 3)))
1473 (pass-if-exception "improper 1" exception:wrong-type-arg
1474 (list-index symbol? 1))
1475 (pass-if-exception "improper 2" exception:wrong-type-arg
1476 (list-index symbol? '(1 . 2)))
1477 (pass-if-exception "improper 3" exception:wrong-type-arg
1478 (list-index symbol? '(1 2 . 3)))
1480 (pass-if (eqv? #f (list-index symbol? '(1))))
1481 (pass-if (eqv? 0 (list-index symbol? '(x))))
1483 (pass-if (eqv? #f (list-index symbol? '(1 2))))
1484 (pass-if (eqv? 0 (list-index symbol? '(x 1))))
1485 (pass-if (eqv? 1 (list-index symbol? '(1 x))))
1487 (pass-if (eqv? #f (list-index symbol? '(1 2 3))))
1488 (pass-if (eqv? 0 (list-index symbol? '(x 1 2))))
1489 (pass-if (eqv? 1 (list-index symbol? '(1 x 2))))
1490 (pass-if (eqv? 2 (list-index symbol? '(1 2 x)))))
1492 (with-test-prefix "two lists"
1498 (pass-if "arg order"
1499 (eqv? 0 (list-index (lambda (x y)
1504 (pass-if "empty lists" (eqv? #f (list-index sym2 '() '())))
1506 (pass-if-exception "pred arg count 0" exception:wrong-num-args
1507 (list-index (lambda () #t) '(1 2 3) '(1 2 3)))
1508 (pass-if-exception "pred arg count 1" exception:wrong-num-args
1509 (list-index (lambda (x) x) '(1 2 3) '(1 2 3)))
1510 (pass-if-exception "pred arg count 3" exception:wrong-num-args
1511 (list-index (lambda (x y z) x) '(1 2 3) '(1 2 3)))
1513 (pass-if-exception "improper first 1" exception:wrong-type-arg
1514 (list-index sym2 1 '(1 2 3)))
1515 (pass-if-exception "improper first 2" exception:wrong-type-arg
1516 (list-index sym2 '(1 . 2) '(1 2 3)))
1517 (pass-if-exception "improper first 3" exception:wrong-type-arg
1518 (list-index sym2 '(1 2 . 3) '(1 2 3)))
1520 (pass-if-exception "improper second 1" exception:wrong-type-arg
1521 (list-index sym2 '(1 2 3) 1))
1522 (pass-if-exception "improper second 2" exception:wrong-type-arg
1523 (list-index sym2 '(1 2 3) '(1 . 2)))
1524 (pass-if-exception "improper second 3" exception:wrong-type-arg
1525 (list-index sym2 '(1 2 3) '(1 2 . 3)))
1527 (pass-if (eqv? #f (list-index sym2 '(1) '(2))))
1528 (pass-if (eqv? 0 (list-index sym2 '(1) '(x))))
1530 (pass-if (eqv? #f (list-index sym2 '(1 2) '(3 4))))
1531 (pass-if (eqv? 0 (list-index sym2 '(1 2) '(x 3))))
1532 (pass-if (eqv? 1 (list-index sym2 '(1 2) '(3 x))))
1534 (pass-if (eqv? #f (list-index sym2 '(1 2 3) '(3 4 5))))
1535 (pass-if (eqv? 0 (list-index sym2 '(1 2 3) '(x 3 4))))
1536 (pass-if (eqv? 1 (list-index sym2 '(1 2 3) '(3 x 4))))
1537 (pass-if (eqv? 2 (list-index sym2 '(1 2 3) '(3 4 x))))
1539 (with-test-prefix "stop shortest"
1540 (pass-if (eqv? #f (list-index sym1 '(1 2 x) '(4 5))))
1541 (pass-if (eqv? #f (list-index sym2 '(4 5) '(1 2 x))))
1542 (pass-if (eqv? #f (list-index sym1 '(3 4) '(1 2 x y))))
1543 (pass-if (eqv? #f (list-index sym2 '(1 2 x y) '(3 4))))))
1545 (with-test-prefix "three lists"
1546 (define (sym1 x y z)
1548 (define (sym2 x y z)
1550 (define (sym3 x y z)
1553 (pass-if "arg order"
1554 (eqv? 0 (list-index (lambda (x y z)
1560 (pass-if "empty lists" (eqv? #f (list-index sym3 '() '() '())))
1562 ;; currently bad pred argument gives wrong-num-args when 3 or more
1563 ;; lists, as opposed to wrong-type-arg for 1 or 2 lists
1564 (pass-if-exception "pred arg count 0" exception:wrong-num-args
1565 (list-index (lambda () #t) '(1 2 3) '(1 2 3) '(1 2 3)))
1566 (pass-if-exception "pred arg count 2" exception:wrong-num-args
1567 (list-index (lambda (x y) x) '(1 2 3) '(1 2 3)'(1 2 3) ))
1568 (pass-if-exception "pred arg count 4" exception:wrong-num-args
1569 (list-index (lambda (w x y z) x) '(1 2 3) '(1 2 3) '(1 2 3)))
1571 (pass-if-exception "improper first 1" exception:wrong-type-arg
1572 (list-index sym3 1 '(1 2 3) '(1 2 3)))
1573 (pass-if-exception "improper first 2" exception:wrong-type-arg
1574 (list-index sym3 '(1 . 2) '(1 2 3) '(1 2 3)))
1575 (pass-if-exception "improper first 3" exception:wrong-type-arg
1576 (list-index sym3 '(1 2 . 3) '(1 2 3) '(1 2 3)))
1578 (pass-if-exception "improper second 1" exception:wrong-type-arg
1579 (list-index sym3 '(1 2 3) 1 '(1 2 3)))
1580 (pass-if-exception "improper second 2" exception:wrong-type-arg
1581 (list-index sym3 '(1 2 3) '(1 . 2) '(1 2 3)))
1582 (pass-if-exception "improper second 3" exception:wrong-type-arg
1583 (list-index sym3 '(1 2 3) '(1 2 . 3) '(1 2 3)))
1585 (pass-if-exception "improper third 1" exception:wrong-type-arg
1586 (list-index sym3 '(1 2 3) '(1 2 3) 1))
1587 (pass-if-exception "improper third 2" exception:wrong-type-arg
1588 (list-index sym3 '(1 2 3) '(1 2 3) '(1 . 2)))
1589 (pass-if-exception "improper third 3" exception:wrong-type-arg
1590 (list-index sym3 '(1 2 3) '(1 2 3) '(1 2 . 3)))
1592 (pass-if (eqv? #f (list-index sym3 '(#f) '(#f) '(#f))))
1593 (pass-if (eqv? 0 (list-index sym3 '(#f) '(#f) '(x))))
1595 (pass-if (eqv? #f (list-index sym3 '(#f #f) '(#f #f) '(#f #f))))
1596 (pass-if (eqv? 0 (list-index sym3 '(#f #f) '(#f #f) '(x #f))))
1597 (pass-if (eqv? 1 (list-index sym3 '(#f #f) '(#f #f) '(#f x))))
1599 (pass-if (eqv? #f (list-index sym3 '(#f #f #f) '(#f #f #f) '(#f #f #f))))
1600 (pass-if (eqv? 0 (list-index sym3 '(#f #f #f) '(#f #f #f) '(x #f #f))))
1601 (pass-if (eqv? 1 (list-index sym3 '(#f #f #f) '(#f #f #f) '(#f x #f))))
1602 (pass-if (eqv? 2 (list-index sym3 '(#f #f #f) '(#f #f #f) '(#f #f x))))
1604 (with-test-prefix "stop shortest"
1605 (pass-if (eqv? #f (list-index sym2 '() '(x x x) '(x x))))
1606 (pass-if (eqv? #f (list-index sym1 '(x x x) '() '(x x))))
1607 (pass-if (eqv? #f (list-index sym2 '(x x x) '(x x) '())))
1609 (pass-if (eqv? #f (list-index sym2 '(#t) '(#t x x) '(#t x))))
1610 (pass-if (eqv? #f (list-index sym1 '(#t x x) '(#t) '(#t x))))
1611 (pass-if (eqv? #f (list-index sym1 '(#t x x) '(#t x) '(#t)))))
1613 (pass-if "apply list unchanged"
1614 (let ((lst (list (list 1 2) (list 3 4) (list 5 6))))
1615 (and (equal? #f (apply list-index sym3 lst))
1617 (equal? '((1 2) (3 4) (5 6)) lst))))))
1623 (with-test-prefix "list-tabulate"
1625 (pass-if-exception "-1" exception:wrong-type-arg
1626 (list-tabulate -1 identity))
1628 (equal? '() (list-tabulate 0 identity)))
1630 (equal? '(0) (list-tabulate 1 identity)))
1632 (equal? '(0 1) (list-tabulate 2 identity)))
1634 (equal? '(0 1 2) (list-tabulate 3 identity)))
1636 (equal? '(0 1 2 3) (list-tabulate 4 identity)))
1637 (pass-if "string ref proc"
1638 (equal? '(#\a #\b #\c #\d) (list-tabulate 4
1640 (string-ref "abcd" i))))))
1646 (with-test-prefix "lset="
1648 ;; in guile 1.6.7 and earlier, lset= incorrectly demanded at least one
1651 (eq? #t (lset= eq?)))
1653 (with-test-prefix "one arg"
1656 (eq? #t (lset= eqv? '())))
1659 (eq? #t (lset= eqv? '(1))))
1662 (eq? #t (lset= eqv? '(1 2)))))
1664 (with-test-prefix "two args"
1667 (eq? #t (lset= eqv? '() '())))
1670 (eq? #t (lset= eqv? '(1) '(1))))
1673 (eq? #f (lset= eqv? '(1) '(2))))
1675 (pass-if "(1) (1 2)"
1676 (eq? #f (lset= eqv? '(1) '(1 2))))
1678 (pass-if "(1 2) (2 1)"
1679 (eq? #t (lset= eqv? '(1 2) '(2 1))))
1681 (pass-if "called arg order"
1683 (lset= (lambda (x y)
1684 (if (not (= x (1- y)))
1690 (with-test-prefix "three args"
1693 (eq? #t (lset= eqv? '() '() '())))
1695 (pass-if "(1) (1) (1)"
1696 (eq? #t (lset= eqv? '(1) '(1) '(1))))
1698 (pass-if "(1) (1) (2)"
1699 (eq? #f (lset= eqv? '(1) '(1) '(2))))
1701 (pass-if "(1) (1) (1 2)"
1702 (eq? #f (lset= eqv? '(1) '(1) '(1 2))))
1704 (pass-if "(1 2 3) (3 2 1) (1 3 2)"
1705 (eq? #t (lset= eqv? '(1 2 3) '(3 2 1) '(1 3 2))))
1707 (pass-if "called arg order"
1709 (lset= (lambda (x y)
1710 (if (not (= x (1- y)))
1713 '(1 1) '(2 2) '(3 3))
1720 (with-test-prefix "lset-adjoin"
1722 ;; in guile 1.6.7 and earlier, lset-adjoin didn't actually use the given
1723 ;; `=' procedure, all comparisons were just with `equal?
1725 (with-test-prefix "case-insensitive ="
1727 (pass-if "(\"x\") \"X\""
1728 (equal? '("x") (lset-adjoin string-ci=? '("x") "X"))))
1730 (pass-if "called arg order"
1732 (lset-adjoin (lambda (x y)
1733 (set! good (and (= x 1) (= y 2)))
1738 (pass-if (equal? '() (lset-adjoin = '())))
1740 (pass-if (equal? '(1) (lset-adjoin = '() 1)))
1742 (pass-if (equal? '(1) (lset-adjoin = '() 1 1)))
1744 (pass-if (equal? '(2 1) (lset-adjoin = '() 1 2)))
1746 (pass-if (equal? '(3 1 2) (lset-adjoin = '(1 2) 1 2 3 2 1)))
1748 (pass-if "apply list unchanged"
1749 (let ((lst (list 1 2)))
1750 (and (equal? '(2 1 3) (apply lset-adjoin = '(3) lst))
1752 (equal? '(1 2) lst))))
1754 (pass-if "(1 1) 1 1"
1755 (equal? '(1 1) (lset-adjoin = '(1 1) 1 1)))
1757 ;; duplicates among args are cast out
1759 (equal? '(1 2) (lset-adjoin = '(2) 1 1))))
1765 (with-test-prefix "lset-difference"
1767 (pass-if "called arg order"
1769 (lset-difference (lambda (x y)
1770 (set! good (and (= x 1) (= y 2)))
1779 (with-test-prefix "lset-difference!"
1781 (pass-if-exception "proc - num" exception:wrong-type-arg
1782 (lset-difference! 123 '(4)))
1783 (pass-if-exception "proc - list" exception:wrong-type-arg
1784 (lset-difference! (list 1 2 3) '(4)))
1786 (pass-if "called arg order"
1788 (lset-difference! (lambda (x y)
1789 (set! good (and (= x 1) (= y 2)))
1794 (pass-if (equal? '() (lset-difference! = '())))
1795 (pass-if (equal? '(1) (lset-difference! = (list 1))))
1796 (pass-if (equal? '(1 2) (lset-difference! = (list 1 2))))
1798 (pass-if (equal? '() (lset-difference! = (list ) '(3))))
1799 (pass-if (equal? '() (lset-difference! = (list 3) '(3))))
1800 (pass-if (equal? '(1) (lset-difference! = (list 1 3) '(3))))
1801 (pass-if (equal? '(1) (lset-difference! = (list 3 1) '(3))))
1802 (pass-if (equal? '(1) (lset-difference! = (list 1 3 3) '(3))))
1803 (pass-if (equal? '(1) (lset-difference! = (list 3 1 3) '(3))))
1804 (pass-if (equal? '(1) (lset-difference! = (list 3 3 1) '(3))))
1806 (pass-if (equal? '(1) (lset-difference! = (list 1 2 3) '(2 3))))
1807 (pass-if (equal? '(1) (lset-difference! = (list 1 2 3) '(3 2))))
1808 (pass-if (equal? '(1) (lset-difference! = (list 1 2 3) '(3) '(2))))
1809 (pass-if (equal? '(1) (lset-difference! = (list 1 2 3) '(2) '(3))))
1810 (pass-if (equal? '(1) (lset-difference! = (list 1 2 3) '(2) '(2 3))))
1811 (pass-if (equal? '(1) (lset-difference! = (list 1 2 3) '(2) '(3 2))))
1813 (pass-if (equal? '(1 2) (lset-difference! = (list 1 2 3) '(3) '(3))))
1814 (pass-if (equal? '(1 2) (lset-difference! = (list 1 3 2) '(3) '(3))))
1815 (pass-if (equal? '(1 2) (lset-difference! = (list 3 1 2) '(3) '(3))))
1817 (pass-if (equal? '(1 2 3) (lset-difference! = (list 1 2 3 4) '(4))))
1818 (pass-if (equal? '(1 2 3) (lset-difference! = (list 1 2 4 3) '(4))))
1819 (pass-if (equal? '(1 2 3) (lset-difference! = (list 1 4 2 3) '(4))))
1820 (pass-if (equal? '(1 2 3) (lset-difference! = (list 4 1 2 3) '(4))))
1822 (pass-if (equal? '(1 2) (lset-difference! = (list 1 2 3 4) '(4) '(3))))
1823 (pass-if (equal? '(1 2) (lset-difference! = (list 1 3 2 4) '(4) '(3))))
1824 (pass-if (equal? '(1 2) (lset-difference! = (list 3 1 2 4) '(4) '(3))))
1825 (pass-if (equal? '(1 2) (lset-difference! = (list 1 3 4 2) '(4) '(3))))
1826 (pass-if (equal? '(1 2) (lset-difference! = (list 3 1 4 2) '(4) '(3))))
1827 (pass-if (equal? '(1 2) (lset-difference! = (list 3 4 1 2) '(4) '(3)))))
1830 ;; lset-diff+intersection
1833 (with-test-prefix "lset-diff+intersection"
1835 (pass-if "called arg order"
1837 (lset-diff+intersection (lambda (x y)
1838 (set! good (and (= x 1) (= y 2)))
1844 ;; lset-diff+intersection!
1847 (with-test-prefix "lset-diff+intersection"
1849 (pass-if "called arg order"
1851 (lset-diff+intersection (lambda (x y)
1852 (set! good (and (= x 1) (= y 2)))
1858 ;; lset-intersection
1861 (with-test-prefix "lset-intersection"
1863 (pass-if "called arg order"
1865 (lset-intersection (lambda (x y)
1866 (set! good (and (= x 1) (= y 2)))
1872 ;; lset-intersection!
1875 (with-test-prefix "lset-intersection"
1877 (pass-if "called arg order"
1879 (lset-intersection (lambda (x y)
1880 (set! good (and (= x 1) (= y 2)))
1889 (with-test-prefix "lset-union"
1892 (eq? '() (lset-union eq?)))
1895 (equal? '(1 2 3) (lset-union eq? '(1 2 3))))
1898 (equal? '() (lset-union eq? '() '())))
1900 (pass-if "'() '(1 2 3)"
1901 (equal? '(1 2 3) (lset-union eq? '() '(1 2 3))))
1903 (pass-if "'(1 2 3) '()"
1904 (equal? '(1 2 3) (lset-union eq? '(1 2 3) '())))
1906 (pass-if "'(1 2 3) '(4 3 5)"
1907 (equal? '(5 4 1 2 3) (lset-union eq? '(1 2 3) '(4 3 5))))
1909 (pass-if "'(1 2 3) '(4) '(3 5))"
1910 (equal? '(5 4 1 2 3) (lset-union eq? '(1 2 3) '(4) '(3 5))))
1912 ;; in guile 1.6.7 and earlier, `=' was called with the arguments the wrong
1914 (pass-if "called arg order"
1916 (lset-union (lambda (x y)
1917 (set! good (and (= x 1) (= y 2)))
1926 (with-test-prefix "member"
1928 (pass-if-exception "no args" exception:wrong-num-args
1931 (pass-if-exception "one arg" exception:wrong-num-args
1934 (pass-if "1 (1 2 3)"
1935 (let ((lst '(1 2 3)))
1936 (eq? lst (member 1 lst))))
1938 (pass-if "2 (1 2 3)"
1939 (let ((lst '(1 2 3)))
1940 (eq? (cdr lst) (member 2 lst))))
1942 (pass-if "3 (1 2 3)"
1943 (let ((lst '(1 2 3)))
1944 (eq? (cddr lst) (member 3 lst))))
1946 (pass-if "4 (1 2 3)"
1947 (let ((lst '(1 2 3)))
1948 (eq? #f (member 4 lst))))
1950 (pass-if "called arg order"
1952 (member 1 '(2) (lambda (x y)
1953 (set! good (and (eqv? 1 x)
1961 (with-test-prefix "ninth"
1962 (pass-if-exception "() -1" exception:wrong-type-arg
1963 (ninth '(a b c d e f g h)))
1964 (pass-if (eq? 'i (ninth '(a b c d e f g h i))))
1965 (pass-if (eq? 'i (ninth '(a b c d e f g h i j)))))
1972 (with-test-prefix "not-pair?"
1974 (eq? #t (not-pair? 123)))
1976 (eq? #f (not-pair? '(x . y))))
1978 (eq? #t (not-pair? 'x))))
1984 (with-test-prefix "take"
1987 (null? (take '() 0)))
1990 (null? (take '(a) 0)))
1993 (null? (take '() 0)))
1995 (pass-if "'(a b c) 0"
1996 (null? (take '() 0)))
2001 (and (equal? '(a) got)
2002 (not (eq? lst got)))))
2008 (pass-if "'(a b c) 1"
2015 (and (equal? '(a b) got)
2016 (not (eq? lst got)))))
2018 (pass-if "'(a b c) 2"
2022 (pass-if "circular '(a) 0"
2024 (take (circular-list 'a) 0)))
2026 (pass-if "circular '(a) 1"
2028 (take (circular-list 'a) 1)))
2030 (pass-if "circular '(a) 2"
2032 (take (circular-list 'a) 2)))
2034 (pass-if "circular '(a b) 5"
2035 (equal? '(a b a b a)
2036 (take (circular-list 'a 'b) 5)))
2038 (pass-if "'(a . b) 1"
2042 (pass-if "'(a b . c) 1"
2044 (take '(a b . c) 1)))
2046 (pass-if "'(a b . c) 2"
2048 (take '(a b . c) 2))))
2054 (with-test-prefix "take-while"
2056 (pass-if (equal? '() (take-while odd? '())))
2057 (pass-if (equal? '(1) (take-while odd? '(1))))
2058 (pass-if (equal? '(1 3) (take-while odd? '(1 3))))
2059 (pass-if (equal? '(1 3 5) (take-while odd? '(1 3 5))))
2061 (pass-if (equal? '() (take-while odd? '(2))))
2062 (pass-if (equal? '(1) (take-while odd? '(1 2))))
2063 (pass-if (equal? '(1 3) (take-while odd? '(1 3 4))))
2065 (pass-if (equal? '() (take-while odd? '(2 1))))
2066 (pass-if (equal? '(1) (take-while odd? '(1 4 3))))
2067 (pass-if (equal? '() (take-while odd? '(4 1 3)))))
2073 (with-test-prefix "take-while!"
2075 (pass-if (equal? '() (take-while! odd? '())))
2076 (pass-if (equal? '(1) (take-while! odd? (list 1))))
2077 (pass-if (equal? '(1 3) (take-while! odd? (list 1 3))))
2078 (pass-if (equal? '(1 3 5) (take-while! odd? (list 1 3 5))))
2080 (pass-if (equal? '() (take-while! odd? (list 2))))
2081 (pass-if (equal? '(1) (take-while! odd? (list 1 2))))
2082 (pass-if (equal? '(1 3) (take-while! odd? (list 1 3 4))))
2084 (pass-if (equal? '() (take-while! odd? (list 2 1))))
2085 (pass-if (equal? '(1) (take-while! odd? (list 1 4 3))))
2086 (pass-if (equal? '() (take-while! odd? (list 4 1 3)))))
2092 (define (test-partition pred list kept-good dropped-good)
2093 (call-with-values (lambda ()
2094 (partition pred list))
2095 (lambda (kept dropped)
2096 (and (equal? kept kept-good)
2097 (equal? dropped dropped-good)))))
2099 (with-test-prefix "partition"
2101 (pass-if "with dropped tail"
2102 (test-partition even? '(1 2 3 4 5 6 7)
2103 '(2 4 6) '(1 3 5 7)))
2105 (pass-if "with kept tail"
2106 (test-partition even? '(1 2 3 4 5 6)
2109 (pass-if "with everything dropped"
2110 (test-partition even? '(1 3 5 7)
2113 (pass-if "with everything kept"
2114 (test-partition even? '(2 4 6)
2117 (pass-if "with empty list"
2118 (test-partition even? '()
2121 (pass-if "with reasonably long list"
2122 ;; the old implementation from SRFI-1 reference implementation
2123 ;; would signal a stack-overflow for a list of only 500 elements!
2124 (call-with-values (lambda ()
2126 (make-list 10000 1)))
2128 (and (= (length odd) 10000)
2129 (= (length even) 0)))))
2131 (pass-if-exception "with improper list"
2132 exception:wrong-type-arg
2133 (partition symbol? '(a b . c))))
2139 (define (test-partition! pred list kept-good dropped-good)
2140 (call-with-values (lambda ()
2141 (partition! pred list))
2142 (lambda (kept dropped)
2143 (and (equal? kept kept-good)
2144 (equal? dropped dropped-good)))))
2146 (with-test-prefix "partition!"
2148 (pass-if "with dropped tail"
2149 (test-partition! even? (list 1 2 3 4 5 6 7)
2150 '(2 4 6) '(1 3 5 7)))
2152 (pass-if "with kept tail"
2153 (test-partition! even? (list 1 2 3 4 5 6)
2156 (pass-if "with everything dropped"
2157 (test-partition! even? (list 1 3 5 7)
2160 (pass-if "with everything kept"
2161 (test-partition! even? (list 2 4 6)
2164 (pass-if "with empty list"
2165 (test-partition! even? '()
2168 (pass-if "with reasonably long list"
2169 ;; the old implementation from SRFI-1 reference implementation
2170 ;; would signal a stack-overflow for a list of only 500 elements!
2171 (call-with-values (lambda ()
2173 (make-list 10000 1)))
2175 (and (= (length odd) 10000)
2176 (= (length even) 0)))))
2178 (pass-if-exception "with improper list"
2179 exception:wrong-type-arg
2180 (partition! symbol? (cons* 'a 'b 'c))))
2186 (with-test-prefix "reduce"
2190 (ret (reduce (lambda (x prev)
2191 (set! calls (cons (list x prev) calls))
2194 (and (equal? calls '())
2199 (ret (reduce (lambda (x prev)
2200 (set! calls (cons (list x prev) calls))
2203 (and (equal? calls '())
2206 (pass-if "two elems"
2208 (ret (reduce (lambda (x prev)
2209 (set! calls (cons (list x prev) calls))
2212 (and (equal? calls '((3 2)))
2215 (pass-if "three elems"
2217 (ret (reduce (lambda (x prev)
2218 (set! calls (cons (list x prev) calls))
2221 (and (equal? calls '((4 3)
2225 (pass-if "four elems"
2227 (ret (reduce (lambda (x prev)
2228 (set! calls (cons (list x prev) calls))
2231 (and (equal? calls '((5 4)
2240 (with-test-prefix "reduce-right"
2244 (ret (reduce-right (lambda (x prev)
2245 (set! calls (cons (list x prev) calls))
2248 (and (equal? calls '())
2253 (ret (reduce-right (lambda (x prev)
2254 (set! calls (cons (list x prev) calls))
2257 (and (equal? calls '())
2260 (pass-if "two elems"
2262 (ret (reduce-right (lambda (x prev)
2263 (set! calls (cons (list x prev) calls))
2266 (and (equal? calls '((2 3)))
2269 (pass-if "three elems"
2271 (ret (reduce-right (lambda (x prev)
2272 (set! calls (cons (list x prev) calls))
2275 (and (equal? calls '((2 3)
2279 (pass-if "four elems"
2281 (ret (reduce-right (lambda (x prev)
2282 (set! calls (cons (list x prev) calls))
2285 (and (equal? calls '((2 3)
2294 (with-test-prefix "remove"
2296 (pass-if (equal? '() (remove odd? '())))
2297 (pass-if (equal? '() (remove odd? '(1))))
2298 (pass-if (equal? '(2) (remove odd? '(2))))
2300 (pass-if (equal? '() (remove odd? '(1 3))))
2301 (pass-if (equal? '(2) (remove odd? '(2 3))))
2302 (pass-if (equal? '(2) (remove odd? '(1 2))))
2303 (pass-if (equal? '(2 4) (remove odd? '(2 4))))
2305 (pass-if (equal? '() (remove odd? '(1 3 5))))
2306 (pass-if (equal? '(2) (remove odd? '(2 3 5))))
2307 (pass-if (equal? '(2) (remove odd? '(1 2 5))))
2308 (pass-if (equal? '(2 4) (remove odd? '(2 4 5))))
2310 (pass-if (equal? '(6) (remove odd? '(1 3 6))))
2311 (pass-if (equal? '(2 6) (remove odd? '(2 3 6))))
2312 (pass-if (equal? '(2 6) (remove odd? '(1 2 6))))
2313 (pass-if (equal? '(2 4 6) (remove odd? '(2 4 6)))))
2319 (with-test-prefix "remove!"
2321 (pass-if (equal? '() (remove! odd? '())))
2322 (pass-if (equal? '() (remove! odd? (list 1))))
2323 (pass-if (equal? '(2) (remove! odd? (list 2))))
2325 (pass-if (equal? '() (remove! odd? (list 1 3))))
2326 (pass-if (equal? '(2) (remove! odd? (list 2 3))))
2327 (pass-if (equal? '(2) (remove! odd? (list 1 2))))
2328 (pass-if (equal? '(2 4) (remove! odd? (list 2 4))))
2330 (pass-if (equal? '() (remove! odd? (list 1 3 5))))
2331 (pass-if (equal? '(2) (remove! odd? (list 2 3 5))))
2332 (pass-if (equal? '(2) (remove! odd? (list 1 2 5))))
2333 (pass-if (equal? '(2 4) (remove! odd? (list 2 4 5))))
2335 (pass-if (equal? '(6) (remove! odd? (list 1 3 6))))
2336 (pass-if (equal? '(2 6) (remove! odd? (list 2 3 6))))
2337 (pass-if (equal? '(2 6) (remove! odd? (list 1 2 6))))
2338 (pass-if (equal? '(2 4 6) (remove! odd? (list 2 4 6)))))
2344 (with-test-prefix "seventh"
2345 (pass-if-exception "() -1" exception:wrong-type-arg
2346 (seventh '(a b c d e f)))
2347 (pass-if (eq? 'g (seventh '(a b c d e f g))))
2348 (pass-if (eq? 'g (seventh '(a b c d e f g h)))))
2354 (with-test-prefix "sixth"
2355 (pass-if-exception "() -1" exception:wrong-type-arg
2356 (sixth '(a b c d e)))
2357 (pass-if (eq? 'f (sixth '(a b c d e f))))
2358 (pass-if (eq? 'f (sixth '(a b c d e f g)))))
2364 (with-test-prefix "split-at"
2366 (define (equal-values? lst thunk)
2367 (call-with-values thunk
2371 (pass-if-exception "() -1" exception:out-of-range
2373 (pass-if (equal-values? '(() ())
2374 (lambda () (split-at '() 0))))
2375 (pass-if-exception "() 1" exception:wrong-type-arg
2378 (pass-if-exception "(1) -1" exception:out-of-range
2380 (pass-if (equal-values? '(() (1)) (lambda () (split-at '(1) 0))))
2381 (pass-if (equal-values? '((1) ()) (lambda () (split-at '(1) 1))))
2382 (pass-if-exception "(1) 2" exception:wrong-type-arg
2385 (pass-if-exception "(4 5) -1" exception:out-of-range
2386 (split-at '(4 5) -1))
2387 (pass-if (equal-values? '(() (4 5)) (lambda () (split-at '(4 5) 0))))
2388 (pass-if (equal-values? '((4) (5)) (lambda () (split-at '(4 5) 1))))
2389 (pass-if (equal-values? '((4 5) ()) (lambda () (split-at '(4 5) 2))))
2390 (pass-if-exception "(4 5) 3" exception:wrong-type-arg
2391 (split-at '(4 5) 3))
2393 (pass-if-exception "(4 5 6) -1" exception:out-of-range
2394 (split-at '(4 5 6) -1))
2395 (pass-if (equal-values? '(() (4 5 6)) (lambda () (split-at '(4 5 6) 0))))
2396 (pass-if (equal-values? '((4) (5 6)) (lambda () (split-at '(4 5 6) 1))))
2397 (pass-if (equal-values? '((4 5) (6)) (lambda () (split-at '(4 5 6) 2))))
2398 (pass-if (equal-values? '((4 5 6) ()) (lambda () (split-at '(4 5 6) 3))))
2399 (pass-if-exception "(4 5 6) 4" exception:wrong-type-arg
2400 (split-at '(4 5 6) 4)))
2406 (with-test-prefix "split-at!"
2408 (define (equal-values? lst thunk)
2409 (call-with-values thunk
2413 (pass-if-exception "() -1" exception:out-of-range
2415 (pass-if (equal-values? '(() ())
2416 (lambda () (split-at! '() 0))))
2417 (pass-if-exception "() 1" exception:wrong-type-arg
2420 (pass-if-exception "(1) -1" exception:out-of-range
2421 (split-at! (list 1) -1))
2422 (pass-if (equal-values? '(() (1)) (lambda () (split-at! (list 1) 0))))
2423 (pass-if (equal-values? '((1) ()) (lambda () (split-at! (list 1) 1))))
2424 (pass-if-exception "(1) 2" exception:wrong-type-arg
2425 (split-at! (list 1) 2))
2427 (pass-if-exception "(4 5) -1" exception:out-of-range
2428 (split-at! (list 4 5) -1))
2429 (pass-if (equal-values? '(() (4 5)) (lambda () (split-at! (list 4 5) 0))))
2430 (pass-if (equal-values? '((4) (5)) (lambda () (split-at! (list 4 5) 1))))
2431 (pass-if (equal-values? '((4 5) ()) (lambda () (split-at! (list 4 5) 2))))
2432 (pass-if-exception "(4 5) 3" exception:wrong-type-arg
2433 (split-at! (list 4 5) 3))
2435 (pass-if-exception "(4 5 6) -1" exception:out-of-range
2436 (split-at! (list 4 5 6) -1))
2437 (pass-if (equal-values? '(() (4 5 6)) (lambda () (split-at! (list 4 5 6) 0))))
2438 (pass-if (equal-values? '((4) (5 6)) (lambda () (split-at! (list 4 5 6) 1))))
2439 (pass-if (equal-values? '((4 5) (6)) (lambda () (split-at! (list 4 5 6) 2))))
2440 (pass-if (equal-values? '((4 5 6) ()) (lambda () (split-at! (list 4 5 6) 3))))
2441 (pass-if-exception "(4 5 6) 4" exception:wrong-type-arg
2442 (split-at! (list 4 5 6) 4)))
2448 (with-test-prefix "span"
2450 (define (test-span lst want-v1 want-v2)
2453 (span positive? lst))
2454 (lambda (got-v1 got-v2)
2455 (and (equal? got-v1 want-v1)
2456 (equal? got-v2 want-v2)))))
2459 (test-span '() '() '()))
2462 (test-span '(1) '(1) '()))
2465 (test-span '(-1) '() '(-1)))
2468 (test-span '(1 2) '(1 2) '()))
2471 (test-span '(-1 1) '() '(-1 1)))
2474 (test-span '(1 -1) '(1) '(-1)))
2477 (test-span '(-1 -2) '() '(-1 -2)))
2480 (test-span '(1 2 3) '(1 2 3) '()))
2483 (test-span '(-1 1 2) '() '(-1 1 2)))
2486 (test-span '(1 -1 2) '(1) '(-1 2)))
2489 (test-span '(-1 -2 1) '() '(-1 -2 1)))
2492 (test-span '(1 2 -1) '(1 2) '(-1)))
2495 (test-span '(-1 1 -2) '() '(-1 1 -2)))
2498 (test-span '(1 -1 -2) '(1) '(-1 -2)))
2501 (test-span '(-1 -2 -3) '() '(-1 -2 -3))))
2507 (with-test-prefix "span!"
2509 (define (test-span! lst want-v1 want-v2)
2512 (span! positive? lst))
2513 (lambda (got-v1 got-v2)
2514 (and (equal? got-v1 want-v1)
2515 (equal? got-v2 want-v2)))))
2518 (test-span! '() '() '()))
2521 (test-span! (list 1) '(1) '()))
2524 (test-span! (list -1) '() '(-1)))
2527 (test-span! (list 1 2) '(1 2) '()))
2530 (test-span! (list -1 1) '() '(-1 1)))
2533 (test-span! (list 1 -1) '(1) '(-1)))
2536 (test-span! (list -1 -2) '() '(-1 -2)))
2539 (test-span! (list 1 2 3) '(1 2 3) '()))
2542 (test-span! (list -1 1 2) '() '(-1 1 2)))
2545 (test-span! (list 1 -1 2) '(1) '(-1 2)))
2548 (test-span! (list -1 -2 1) '() '(-1 -2 1)))
2551 (test-span! (list 1 2 -1) '(1 2) '(-1)))
2554 (test-span! (list -1 1 -2) '() '(-1 1 -2)))
2557 (test-span! (list 1 -1 -2) '(1) '(-1 -2)))
2560 (test-span! (list -1 -2 -3) '() '(-1 -2 -3))))
2566 (with-test-prefix "take!"
2568 (pass-if-exception "() -1" exception:out-of-range
2570 (pass-if (equal? '() (take! '() 0)))
2571 (pass-if-exception "() 1" exception:wrong-type-arg
2574 (pass-if-exception "(1) -1" exception:out-of-range
2576 (pass-if (equal? '() (take! '(1) 0)))
2577 (pass-if (equal? '(1) (take! '(1) 1)))
2578 (pass-if-exception "(1) 2" exception:wrong-type-arg
2581 (pass-if-exception "(4 5) -1" exception:out-of-range
2583 (pass-if (equal? '() (take! '(4 5) 0)))
2584 (pass-if (equal? '(4) (take! '(4 5) 1)))
2585 (pass-if (equal? '(4 5) (take! '(4 5) 2)))
2586 (pass-if-exception "(4 5) 3" exception:wrong-type-arg
2589 (pass-if-exception "(4 5 6) -1" exception:out-of-range
2590 (take! '(4 5 6) -1))
2591 (pass-if (equal? '() (take! '(4 5 6) 0)))
2592 (pass-if (equal? '(4) (take! '(4 5 6) 1)))
2593 (pass-if (equal? '(4 5) (take! '(4 5 6) 2)))
2594 (pass-if (equal? '(4 5 6) (take! '(4 5 6) 3)))
2595 (pass-if-exception "(4 5 6) 4" exception:wrong-type-arg
2596 (take! '(4 5 6) 4)))
2603 (with-test-prefix "take-right"
2605 (pass-if-exception "() -1" exception:out-of-range
2606 (take-right '() -1))
2607 (pass-if (equal? '() (take-right '() 0)))
2608 (pass-if-exception "() 1" exception:wrong-type-arg
2611 (pass-if-exception "(1) -1" exception:out-of-range
2612 (take-right '(1) -1))
2613 (pass-if (equal? '() (take-right '(1) 0)))
2614 (pass-if (equal? '(1) (take-right '(1) 1)))
2615 (pass-if-exception "(1) 2" exception:wrong-type-arg
2616 (take-right '(1) 2))
2618 (pass-if-exception "(4 5) -1" exception:out-of-range
2619 (take-right '(4 5) -1))
2620 (pass-if (equal? '() (take-right '(4 5) 0)))
2621 (pass-if (equal? '(5) (take-right '(4 5) 1)))
2622 (pass-if (equal? '(4 5) (take-right '(4 5) 2)))
2623 (pass-if-exception "(4 5) 3" exception:wrong-type-arg
2624 (take-right '(4 5) 3))
2626 (pass-if-exception "(4 5 6) -1" exception:out-of-range
2627 (take-right '(4 5 6) -1))
2628 (pass-if (equal? '() (take-right '(4 5 6) 0)))
2629 (pass-if (equal? '(6) (take-right '(4 5 6) 1)))
2630 (pass-if (equal? '(5 6) (take-right '(4 5 6) 2)))
2631 (pass-if (equal? '(4 5 6) (take-right '(4 5 6) 3)))
2632 (pass-if-exception "(4 5 6) 4" exception:wrong-type-arg
2633 (take-right '(4 5 6) 4))
2635 (pass-if "(a b . c) 0"
2636 (equal? (take-right '(a b . c) 0) 'c))
2637 (pass-if "(a b . c) 1"
2638 (equal? (take-right '(a b . c) 1) '(b . c))))
2644 (with-test-prefix "tenth"
2645 (pass-if-exception "() -1" exception:wrong-type-arg
2646 (tenth '(a b c d e f g h i)))
2647 (pass-if (eq? 'j (tenth '(a b c d e f g h i j))))
2648 (pass-if (eq? 'j (tenth '(a b c d e f g h i j k)))))
2654 (with-test-prefix "xcons"
2655 (pass-if (equal? '(y . x) (xcons 'x 'y))))