test-suite/tests/srfi-1.test

   1 ;;;; srfi-1.test --- Test suite for Guile's SRFI-1 functions. -*- scheme -*-
   2 ;;;;
   3 ;;;; Copyright 2003-2006, 2008-2011, 2014 Free Software Foundation, Inc.
   4 ;;;;
   5 ;;;; This library is free software; you can redistribute it and/or
   6 ;;;; modify it under the terms of the GNU Lesser General Public
   7 ;;;; License as published by the Free Software Foundation; either
   8 ;;;; version 3 of the License, or (at your option) any later version.
   9 ;;;;
  10 ;;;; This library is distributed in the hope that it will be useful,
  11 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  13 ;;;; Lesser General Public License for more details.
  14 ;;;;
  15 ;;;; You should have received a copy of the GNU Lesser General Public
  16 ;;;; License along with this library; if not, write to the Free Software
  17 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  18
  19 (define-module (test-srfi-1)
  20   #:use-module (test-suite lib)
  21   #:use-module (srfi srfi-1))
  22
  23
  24 (define (ref-delete x lst . proc)
  25   "Reference implemenation of srfi-1 `delete'."
  26   (set! proc (if (null? proc) equal? (car proc)))
  27   (do ((ret '())
  28        (lst lst (cdr lst)))
  29       ((null? lst)
  30        (reverse! ret))
  31     (if (not (proc x (car lst)))
  32         (set! ret (cons (car lst) ret)))))
  33
  34 (define (ref-delete-duplicates lst . proc)
  35   "Reference implemenation of srfi-1 `delete-duplicates'."
  36   (set! proc (if (null? proc) equal? (car proc)))
  37   (if (null? lst)
  38       '()
  39       (do ((keep '()))
  40           ((null? lst)
  41            (reverse! keep))
  42         (let ((elem (car lst)))
  43           (set! keep (cons elem keep))
  44           (set! lst  (ref-delete elem lst proc))))))
  45
  46
  47 ;;
  48 ;; alist-copy
  49 ;;
  50
  51 (with-test-prefix "alist-copy"
  52
  53   ;; return a list which is the pairs making up alist A, the spine and cells
  54   (define (alist-pairs a)
  55     (let more ((a a)
  56                (result a))
  57       (if (pair? a)
  58           (more (cdr a) (cons a result))
  59           result)))
  60
  61   ;; return a list of the elements common to lists X and Y, compared with eq?
  62   (define (common-elements x y)
  63     (if (null? x)
  64         '()
  65         (if (memq (car x) y)
  66             (cons (car x) (common-elements (cdr x) y))
  67             (common-elements (cdr x) y))))
  68
  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)
  72     (and (equal? old new)
  73          (null? (common-elements old new))))
  74
  75   (pass-if-exception "too few args" exception:wrong-num-args
  76     (alist-copy))
  77
  78   (pass-if-exception "too many args" exception:wrong-num-args
  79     (alist-copy '() '()))
  80
  81   (let ((old '()))
  82     (pass-if old (valid-alist-copy? old (alist-copy old))))
  83
  84   (let ((old '((1 . 2))))
  85     (pass-if old (valid-alist-copy? old (alist-copy old))))
  86
  87   (let ((old '((1 . 2) (3 . 4))))
  88     (pass-if old (valid-alist-copy? old (alist-copy old))))
  89
  90   (let ((old '((1 . 2) (3 . 4) (5 . 6))))
  91     (pass-if old (valid-alist-copy? old (alist-copy old)))))
  92
  93 ;;
  94 ;; alist-delete
  95 ;;
  96
  97 (with-test-prefix "alist-delete"
  98
  99   (pass-if "equality call arg order"
 100     (let ((good #f))
 101       (alist-delete 'k '((ak . 123))
 102                     (lambda (k ak)
 103                       (if (and (eq? k 'k) (eq? ak 'ak))
 104                           (set! good #t))))
 105       good))
 106
 107   (pass-if "delete keys greater than 5"
 108     (equal? '((4 . x) (5 . y))
 109             (alist-delete 5 '((4 . x) (5 . y) (6 . z)) <)))
 110
 111   (pass-if "empty"
 112     (equal? '() (alist-delete 'x '())))
 113
 114   (pass-if "(y)"
 115     (equal? '() (alist-delete 'y '((y . 1)))))
 116
 117   (pass-if "(n)"
 118     (equal? '((n . 1)) (alist-delete 'y '((n . 1)))))
 119
 120   (pass-if "(y y)"
 121     (equal? '() (alist-delete 'y '((y . 1) (y . 2)))))
 122
 123   (pass-if "(n y)"
 124     (equal? '((n . 1)) (alist-delete 'y '((n . 1) (y . 2)))))
 125
 126   (pass-if "(y n)"
 127     (equal? '((n . 2)) (alist-delete 'y '((y . 1) (n . 2)))))
 128
 129   (pass-if "(n n)"
 130     (equal? '((n . 1) (n . 2)) (alist-delete 'y '((n . 1) (n . 2)))))
 131
 132   (pass-if "(y y y)"
 133     (equal? '() (alist-delete 'y '((y . 1) (y . 2) (y . 3)))))
 134
 135   (pass-if "(n y y)"
 136     (equal? '((n . 1)) (alist-delete 'y '((n . 1) (y . 2) (y . 3)))))
 137
 138   (pass-if "(y n y)"
 139     (equal? '((n . 2)) (alist-delete 'y '((y . 1) (n . 2) (y . 3)))))
 140
 141   (pass-if "(n n y)"
 142     (equal? '((n . 1) (n . 2)) (alist-delete 'y '((n . 1) (n . 2) (y . 3)))))
 143
 144   (pass-if "(y y n)"
 145     (equal? '( (n . 3)) (alist-delete 'y '((y . 1) (y . 2) (n . 3)))))
 146
 147   (pass-if "(n y n)"
 148     (equal? '((n . 1) (n . 3)) (alist-delete 'y '((n . 1) (y . 2) (n . 3)))))
 149
 150   (pass-if "(y n n)"
 151     (equal? '((n . 2) (n . 3)) (alist-delete 'y '((y . 1) (n . 2) (n . 3)))))
 152
 153   (pass-if "(n n n)"
 154     (equal? '((n . 1) (n . 2) (n . 3)) (alist-delete 'y '((n . 1) (n . 2) (n . 3))))))
 155
 156 ;;
 157 ;; append-map
 158 ;;
 159
 160 (with-test-prefix "append-map"
 161
 162   (with-test-prefix "one list"
 163
 164     (pass-if "()"
 165       (equal? '() (append-map noop '(()))))
 166
 167     (pass-if "(1)"
 168       (equal? '(1) (append-map noop '((1)))))
 169
 170     (pass-if "(1 2)"
 171       (equal? '(1 2) (append-map noop '((1 2)))))
 172
 173     (pass-if "() ()"
 174       (equal? '() (append-map noop '(() ()))))
 175
 176     (pass-if "() (1)"
 177       (equal? '(1) (append-map noop '(() (1)))))
 178
 179     (pass-if "() (1 2)"
 180       (equal? '(1 2) (append-map noop '(() (1 2)))))
 181
 182     (pass-if "(1) (2)"
 183       (equal? '(1 2) (append-map noop '((1) (2)))))
 184
 185     (pass-if "(1 2) ()"
 186       (equal? '(1 2) (append-map noop '(() (1 2))))))
 187
 188   (with-test-prefix "two lists"
 189
 190     (pass-if "() / 9"
 191       (equal? '() (append-map noop '(()) '(9))))
 192
 193     (pass-if "(1) / 9"
 194       (equal? '(1) (append-map noop '((1)) '(9))))
 195
 196     (pass-if "() () / 9 9"
 197       (equal? '() (append-map noop '(() ()) '(9 9))))
 198
 199     (pass-if "(1) (2) / 9"
 200       (equal? '(1) (append-map noop '((1) (2)) '(9))))
 201
 202     (pass-if "(1) (2) / 9 9"
 203       (equal? '(1 2) (append-map noop '((1) (2)) '(9 9))))))
 204
 205 ;;
 206 ;; append-reverse
 207 ;;
 208
 209 (with-test-prefix "append-reverse"
 210
 211   ;; return a list which is the cars and cdrs of LST
 212   (define (list-contents lst)
 213     (if (null? lst)
 214         '()
 215         (cons* (car lst) (cdr lst) (list-contents (cdr lst)))))
 216
 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)
 221            ;; revhead unchanged
 222            (equal? revhead-contents (list-contents revhead)))))
 223
 224   (pass-if-exception "too few args (0)" exception:wrong-num-args
 225     (append-reverse))
 226
 227   (pass-if-exception "too few args (1)" exception:wrong-num-args
 228     (append-reverse '(x)))
 229
 230   (pass-if-exception "too many args (3)" exception:wrong-num-args
 231     (append-reverse '() '() #f))
 232
 233   (pass-if (valid-append-reverse '() '()      '()))
 234   (pass-if (valid-append-reverse '() '(1 2 3) '(1 2 3)))
 235
 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)))
 239
 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)))
 243
 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))))
 247
 248 ;;
 249 ;; append-reverse!
 250 ;;
 251
 252 (with-test-prefix "append-reverse!"
 253
 254   (pass-if-exception "too few args (0)" exception:wrong-num-args
 255     (append-reverse!))
 256
 257   (pass-if-exception "too few args (1)" exception:wrong-num-args
 258     (append-reverse! '(x)))
 259
 260   (pass-if-exception "too many args (3)" exception:wrong-num-args
 261     (append-reverse! '() '() #f))
 262
 263   (pass-if (equal? '()      (append-reverse! '() '())))
 264   (pass-if (equal? '(1 2 3) (append-reverse! '() '(1 2 3))))
 265
 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))))
 269
 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))))
 273
 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)))))
 277
 278 ;;
 279 ;; assoc
 280 ;;
 281
 282 (with-test-prefix "assoc"
 283
 284   (pass-if "not found"
 285     (let ((alist '((a . 1)
 286                    (b . 2)
 287                    (c . 3))))
 288       (eqv? #f (assoc 'z alist))))
 289
 290   (pass-if "found"
 291     (let ((alist '((a . 1)
 292                    (b . 2)
 293                    (c . 3))))
 294       (eqv? (second alist) (assoc 'b alist))))
 295
 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)))
 300           (good  #f))
 301       (assoc 'a alist (lambda (x y)
 302                         (set! good (and (eq? x 'a)
 303                                         (eq? y 'b)))))
 304       good))
 305
 306   ;; likewise this one bad in guile 1.8.0
 307   (pass-if "srfi-1 example <"
 308     (let ((alist '((1 . a)
 309                    (5 . b)
 310                    (6 . c))))
 311       (eq? (third alist) (assoc 5 alist <)))))
 312
 313 ;;
 314 ;; break
 315 ;;
 316
 317 (with-test-prefix "break"
 318
 319   (define (test-break lst want-v1 want-v2)
 320     (call-with-values
 321         (lambda ()
 322           (break negative? lst))
 323       (lambda (got-v1 got-v2)
 324         (and (equal? got-v1 want-v1)
 325              (equal? got-v2 want-v2)))))
 326
 327   (pass-if "empty"
 328     (test-break '() '() '()))
 329
 330   (pass-if "y"
 331     (test-break '(1) '(1) '()))
 332
 333   (pass-if "n"
 334     (test-break '(-1) '() '(-1)))
 335
 336   (pass-if "yy"
 337     (test-break '(1 2) '(1 2) '()))
 338
 339   (pass-if "ny"
 340     (test-break '(-1 1) '() '(-1 1)))
 341
 342   (pass-if "yn"
 343     (test-break '(1 -1) '(1) '(-1)))
 344
 345   (pass-if "nn"
 346     (test-break '(-1 -2) '() '(-1 -2)))
 347
 348   (pass-if "yyy"
 349     (test-break '(1 2 3) '(1 2 3) '()))
 350
 351   (pass-if "nyy"
 352     (test-break '(-1 1 2) '() '(-1 1 2)))
 353
 354   (pass-if "yny"
 355     (test-break '(1 -1 2) '(1) '(-1 2)))
 356
 357   (pass-if "nny"
 358     (test-break '(-1 -2 1) '() '(-1 -2 1)))
 359
 360   (pass-if "yyn"
 361     (test-break '(1 2 -1) '(1 2) '(-1)))
 362
 363   (pass-if "nyn"
 364     (test-break '(-1 1 -2) '() '(-1 1 -2)))
 365
 366   (pass-if "ynn"
 367     (test-break '(1 -1 -2) '(1) '(-1 -2)))
 368
 369   (pass-if "nnn"
 370     (test-break '(-1 -2 -3) '() '(-1 -2 -3))))
 371
 372 ;;
 373 ;; break!
 374 ;;
 375
 376 (with-test-prefix "break!"
 377
 378   (define (test-break! lst want-v1 want-v2)
 379     (call-with-values
 380         (lambda ()
 381           (break! negative? lst))
 382       (lambda (got-v1 got-v2)
 383         (and (equal? got-v1 want-v1)
 384              (equal? got-v2 want-v2)))))
 385
 386   (pass-if "empty"
 387     (test-break! '() '() '()))
 388
 389   (pass-if "y"
 390     (test-break! (list 1) '(1) '()))
 391
 392   (pass-if "n"
 393     (test-break! (list -1) '() '(-1)))
 394
 395   (pass-if "yy"
 396     (test-break! (list 1 2) '(1 2) '()))
 397
 398   (pass-if "ny"
 399     (test-break! (list -1 1) '() '(-1 1)))
 400
 401   (pass-if "yn"
 402     (test-break! (list 1 -1) '(1) '(-1)))
 403
 404   (pass-if "nn"
 405     (test-break! (list -1 -2) '() '(-1 -2)))
 406
 407   (pass-if "yyy"
 408     (test-break! (list 1 2 3) '(1 2 3) '()))
 409
 410   (pass-if "nyy"
 411     (test-break! (list -1 1 2) '() '(-1 1 2)))
 412
 413   (pass-if "yny"
 414     (test-break! (list 1 -1 2) '(1) '(-1 2)))
 415
 416   (pass-if "nny"
 417     (test-break! (list -1 -2 1) '() '(-1 -2 1)))
 418
 419   (pass-if "yyn"
 420     (test-break! (list 1 2 -1) '(1 2) '(-1)))
 421
 422   (pass-if "nyn"
 423     (test-break! (list -1 1 -2) '() '(-1 1 -2)))
 424
 425   (pass-if "ynn"
 426     (test-break! (list 1 -1 -2) '(1) '(-1 -2)))
 427
 428   (pass-if "nnn"
 429     (test-break! (list -1 -2 -3) '() '(-1 -2 -3))))
 430
 431 ;;
 432 ;; car+cdr
 433 ;;
 434
 435 (with-test-prefix "car+cdr"
 436
 437   (pass-if "(1 . 2)"
 438     (call-with-values
 439         (lambda ()
 440           (car+cdr '(1 . 2)))
 441       (lambda (x y)
 442         (and (eqv? x 1)
 443              (eqv? y 2))))))
 444
 445 ;;
 446 ;; concatenate and concatenate!
 447 ;;
 448
 449 (let ()
 450   (define (common-tests concatenate-proc unmodified?)
 451     (define (try lstlst want)
 452       (let ((lstlst-copy (copy-tree lstlst))
 453             (got         (concatenate-proc lstlst)))
 454         (if unmodified?
 455             (if (not (equal? lstlst lstlst-copy))
 456                 (error "input lists modified")))
 457         (equal? got want)))
 458
 459     (pass-if-exception "too few args" exception:wrong-num-args
 460       (concatenate-proc))
 461
 462     (pass-if-exception "too many args" exception:wrong-num-args
 463       (concatenate-proc '() '()))
 464
 465     (pass-if-exception "number" exception:wrong-type-arg
 466       (concatenate-proc 123))
 467
 468     (pass-if-exception "vector" exception:wrong-type-arg
 469       (concatenate-proc #(1 2 3)))
 470
 471     (pass-if "no lists"
 472       (try '() '()))
 473
 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)))
 478
 479     (pass-if (try '((1) (2)) '(1 2)))
 480     (pass-if (try '(() (1 2)) '(1 2)))
 481
 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)))
 485     )
 486
 487   (with-test-prefix "concatenate"
 488     (common-tests concatenate #t))
 489
 490   (with-test-prefix "concatenate!"
 491     (common-tests concatenate! #f)))
 492
 493 ;;
 494 ;; count
 495 ;;
 496
 497 (with-test-prefix "count"
 498   (pass-if-exception "no args" exception:wrong-num-args
 499     (count))
 500
 501   (pass-if-exception "one arg" exception:wrong-num-args
 502     (count noop))
 503
 504   (with-test-prefix "one list"
 505     (define (or1 x)
 506       x)
 507
 508     (pass-if "empty list" (= 0 (count or1 '())))
 509
 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)))
 514
 515     (pass-if-exception "improper 1" exception:wrong-type-arg
 516       (count or1 1))
 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)))
 521
 522     (pass-if (= 0 (count or1 '(#f))))
 523     (pass-if (= 1 (count or1 '(#t))))
 524
 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))))
 529
 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)))))
 535
 536   (with-test-prefix "two lists"
 537     (define (or2 x y)
 538       (or x y))
 539
 540     (pass-if "arg order"
 541       (= 1 (count (lambda (x y)
 542                     (and (= 1 x)
 543                          (= 2 y)))
 544                   '(1) '(2))))
 545
 546     (pass-if "empty lists" (= 0 (count or2 '() '())))
 547
 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)))
 554
 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)))
 561
 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)))
 568
 569     (pass-if (= 0 (count or2 '(#f) '(#f))))
 570     (pass-if (= 1 (count or2 '(#t) '(#f))))
 571     (pass-if (= 1 (count or2 '(#f) '(#t))))
 572
 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))))
 577
 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))))))
 583
 584   (with-test-prefix "three lists"
 585     (define (or3 x y z)
 586       (or x y z))
 587
 588     (pass-if "arg order"
 589       (= 1 (count (lambda (x y z)
 590                     (and (= 1 x)
 591                          (= 2 y)
 592                          (= 3 z)))
 593                   '(1) '(2) '(3))))
 594
 595     (pass-if "empty lists" (= 0 (count or3 '() '() '())))
 596
 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)))
 605
 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)))
 612
 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)))
 619
 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)))
 626
 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))))
 631
 632     (pass-if (= 0 (count or3 '(#f #f) '(#f #f) '(#f #f))))
 633
 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))))
 640
 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))))
 645
 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) '())))
 650
 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)))))
 654
 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))
 658              ;; lst unmodified
 659              (equal? '((1 2) (3 4) (5 6)) lst))))))
 660
 661 ;;
 662 ;; delete and delete!
 663 ;;
 664
 665 (let ()
 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)
 670     (do ((n 0 (1+ n)))
 671         ((>= n 6))
 672       (do ((limit (ash 1 n))
 673            (i 0 (1+ i)))
 674           ((>= i limit))
 675         (let ((lst '()))
 676           (do ((bit 0 (1+ bit)))
 677               ((>= bit n))
 678             (set! lst  (cons (if (logbit? bit i) bit #f) lst)))
 679           (proc lst)))))
 680
 681   (define (common-tests delete-proc)
 682     (pass-if-exception "too few args" exception:wrong-num-args
 683       (delete-proc 0))
 684
 685     (pass-if-exception "too many args" exception:wrong-num-args
 686       (delete-proc 0 '() equal? 99))
 687
 688     (pass-if "empty"
 689       (eq? '() (delete-proc 0 '() equal?)))
 690
 691     (pass-if "equal?"
 692       (equal? '((1) (3))
 693               (delete-proc '(2) '((1) (2) (3)) equal?)))
 694
 695     (pass-if "eq?"
 696       (equal? '((1) (2) (3))
 697               (delete-proc '(2) '((1) (2) (3)) eq?)))
 698
 699     (pass-if "called arg order"
 700       (equal? '(1 2 3)
 701               (delete-proc 3 '(1 2 3 4 5) <))))
 702
 703   (with-test-prefix "delete"
 704     (common-tests delete)
 705
 706     (test-lists
 707      (lambda (lst)
 708        (let ((lst-copy (list-copy lst)))
 709          (with-test-prefix lst-copy
 710            (pass-if "result"
 711              (equal? (delete     #f lst equal?)
 712                      (ref-delete #f lst equal?)))
 713            (pass-if "non-destructive"
 714              (equal? lst-copy lst)))))))
 715
 716   (with-test-prefix "delete!"
 717     (common-tests delete!)
 718
 719     (test-lists
 720      (lambda (lst)
 721        (pass-if lst
 722          (equal? (delete!    #f lst)
 723                  (ref-delete #f lst)))))))
 724
 725 ;;
 726 ;; delete-duplicates and delete-duplicates!
 727 ;;
 728
 729 (let ()
 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)
 733     (do ((n 1 (1+ n)))
 734         ((> n 4))
 735       (do ((limit (integer-expt n n))
 736            (i 0 (1+ i)))
 737           ((>= i limit))
 738         (let ((lst '()))
 739           (do ((j 0 (1+ j))
 740                (rem i (quotient rem n)))
 741               ((>= j n))
 742             (set! lst (cons (remainder rem n) lst)))
 743           (proc lst)))))
 744
 745   (define (common-tests delete-duplicates-proc)
 746     (pass-if-exception "too few args" exception:wrong-num-args
 747       (delete-duplicates-proc))
 748
 749     (pass-if-exception "too many args" exception:wrong-num-args
 750       (delete-duplicates-proc '() equal? 99))
 751
 752     (pass-if "empty"
 753       (eq? '() (delete-duplicates-proc '())))
 754
 755     (pass-if "equal? (the default)"
 756       (equal? '((2))
 757               (delete-duplicates-proc '((2) (2) (2)))))
 758
 759     (pass-if "eq?"
 760       (equal? '((2) (2) (2))
 761               (delete-duplicates-proc '((2) (2) (2)) eq?)))
 762
 763     (pass-if "called arg order"
 764       (let ((ok #t))
 765         (delete-duplicates-proc '(1 2 3 4 5)
 766                                 (lambda (x y)
 767                                   (if (> x y)
 768                                       (set! ok #f))
 769                                   #f))
 770         ok)))
 771
 772   (with-test-prefix "delete-duplicates"
 773     (common-tests delete-duplicates)
 774
 775     (test-lists
 776      (lambda (lst)
 777        (let ((lst-copy (list-copy lst)))
 778          (with-test-prefix lst-copy
 779            (pass-if "result"
 780              (equal? (delete-duplicates     lst)
 781                      (ref-delete-duplicates lst)))
 782            (pass-if "non-destructive"
 783              (equal? lst-copy lst)))))))
 784
 785   (with-test-prefix "delete-duplicates!"
 786     (common-tests delete-duplicates!)
 787
 788     (test-lists
 789      (lambda (lst)
 790        (pass-if lst
 791          (equal? (delete-duplicates!    lst)
 792                  (ref-delete-duplicates lst)))))))
 793
 794 ;;
 795 ;; drop
 796 ;;
 797
 798 (with-test-prefix "drop"
 799
 800   (pass-if "'() 0"
 801     (null? (drop '() 0)))
 802
 803   (pass-if "'(a) 0"
 804     (let ((lst '(a)))
 805       (eq? lst
 806            (drop lst 0))))
 807
 808   (pass-if "'(a b) 0"
 809     (let ((lst '(a b)))
 810       (eq? lst
 811            (drop lst 0))))
 812
 813   (pass-if "'(a) 1"
 814     (let ((lst '(a)))
 815       (eq? (cdr lst)
 816            (drop lst 1))))
 817
 818   (pass-if "'(a b) 1"
 819     (let ((lst '(a b)))
 820       (eq? (cdr lst)
 821            (drop lst 1))))
 822
 823   (pass-if "'(a b) 2"
 824     (let ((lst '(a b)))
 825       (eq? (cddr lst)
 826            (drop lst 2))))
 827
 828   (pass-if "'(a b c) 1"
 829     (let ((lst '(a b c)))
 830       (eq? (cddr lst)
 831            (drop lst 2))))
 832
 833   (pass-if "circular '(a) 0"
 834     (let ((lst (circular-list 'a)))
 835       (eq? lst
 836            (drop lst 0))))
 837
 838   (pass-if "circular '(a) 1"
 839     (let ((lst (circular-list 'a)))
 840       (eq? lst
 841            (drop lst 1))))
 842
 843   (pass-if "circular '(a) 2"
 844     (let ((lst (circular-list 'a)))
 845       (eq? lst
 846            (drop lst 1))))
 847
 848   (pass-if "circular '(a b) 1"
 849     (let ((lst (circular-list 'a)))
 850       (eq? (cdr lst)
 851            (drop lst 0))))
 852
 853   (pass-if "circular '(a b) 2"
 854     (let ((lst (circular-list 'a)))
 855       (eq? lst
 856            (drop lst 1))))
 857
 858   (pass-if "circular '(a b) 5"
 859     (let ((lst (circular-list 'a)))
 860       (eq? (cdr lst)
 861            (drop lst 5))))
 862
 863   (pass-if "'(a . b) 1"
 864     (eq? 'b
 865          (drop '(a . b) 1)))
 866
 867   (pass-if "'(a b . c) 1"
 868     (equal? 'c
 869             (drop '(a b . c) 2))))
 870
 871 ;;
 872 ;; drop-right
 873 ;;
 874
 875 (with-test-prefix "drop-right"
 876
 877   (pass-if-exception "() -1" exception:out-of-range
 878     (drop-right '() -1))
 879   (pass-if (equal? '() (drop-right '() 0)))
 880   (pass-if-exception "() 1" exception:wrong-type-arg
 881     (drop-right '() 1))
 882
 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
 888     (drop-right '(1) 2))
 889
 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))
 897
 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))
 906
 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))))
 911
 912 ;;
 913 ;; drop-right!
 914 ;;
 915
 916 (with-test-prefix "drop-right!"
 917
 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
 922     (drop-right! '() 1))
 923
 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))
 930
 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))
 938
 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)))
 947
 948 ;;
 949 ;; drop-while
 950 ;;
 951
 952 (with-test-prefix "drop-while"
 953
 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))))
 958
 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))))
 962
 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)))))
 966
 967 ;;
 968 ;; eighth
 969 ;;
 970
 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)))))
 976
 977 ;;
 978 ;; fifth
 979 ;;
 980
 981 (with-test-prefix "fifth"
 982   (pass-if-exception "() -1" exception:wrong-type-arg
 983     (fifth '(a b c d)))
 984   (pass-if (eq? 'e (fifth '(a b c d e))))
 985   (pass-if (eq? 'e (fifth '(a b c d e f)))))
 986
 987 ;;
 988 ;; filter-map
 989 ;;
 990
 991 (with-test-prefix "filter-map"
 992
 993   (with-test-prefix "one list"
 994     (pass-if-exception "'x" exception:wrong-type-arg
 995       (filter-map noop 'x))
 996
 997     (pass-if-exception "'(1 . x)" exception:wrong-type-arg
 998       (filter-map noop '(1 . x)))
 999
1000     (pass-if "(1)"
1001       (equal? '(1) (filter-map noop '(1))))
1002
1003     (pass-if "(#f)"
1004       (equal? '() (filter-map noop '(#f))))
1005
1006     (pass-if "(1 2)"
1007       (equal? '(1 2) (filter-map noop '(1 2))))
1008
1009     (pass-if "(#f 2)"
1010       (equal? '(2) (filter-map noop '(#f 2))))
1011
1012     (pass-if "(#f #f)"
1013       (equal? '() (filter-map noop '(#f #f))))
1014
1015     (pass-if "(1 2 3)"
1016       (equal? '(1 2 3) (filter-map noop '(1 2 3))))
1017
1018     (pass-if "(#f 2 3)"
1019       (equal? '(2 3) (filter-map noop '(#f 2 3))))
1020
1021     (pass-if "(1 #f 3)"
1022       (equal? '(1 3) (filter-map noop '(1 #f 3))))
1023
1024     (pass-if "(1 2 #f)"
1025       (equal? '(1 2) (filter-map noop '(1 2 #f)))))
1026
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)))
1030
1031     (pass-if-exception "'(1 2 3) 'x" exception:wrong-type-arg
1032       (filter-map noop '(1 2 3) 'x))
1033
1034     (pass-if-exception "'(1 . x) '(1 2 3)" exception:wrong-type-arg
1035       (filter-map noop '(1 . x) '(1 2 3)))
1036
1037     (pass-if-exception "'(1 2 3) '(1 . x)" exception:wrong-type-arg
1038       (filter-map noop '(1 2 3) '(1 . x)))
1039
1040     (pass-if "(1 2 3) (4 5 6)"
1041       (equal? '(5 7 9) (filter-map + '(1 2 3) '(4 5 6))))
1042
1043     (pass-if "(#f 2 3) (4 5)"
1044       (equal? '(2) (filter-map noop '(#f 2 3) '(4 5))))
1045
1046     (pass-if "(4 #f) (1 2 3)"
1047       (equal? '(4) (filter-map noop '(4 #f) '(1 2 3))))
1048
1049     (pass-if "() (1 2 3)"
1050       (equal? '() (filter-map noop '() '(1 2 3))))
1051
1052     (pass-if "(1 2 3) ()"
1053       (equal? '() (filter-map noop '(1 2 3) '()))))
1054
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)))
1058
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)))
1061
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))
1064
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)))
1067
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)))
1070
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)))
1073
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))))
1076
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))))
1079
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))))
1082
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))))
1085
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))
1089              ;; lst unmodified
1090              (equal? lst '((1 #f 2) (3 4 5) (6 7 8))))))))
1091
1092 ;;
1093 ;; find
1094 ;;
1095
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)))))
1105
1106 ;;
1107 ;; find-tail
1108 ;;
1109
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)))))
1129
1130 ;;
1131 ;; fold
1132 ;;
1133
1134 (with-test-prefix "fold"
1135   (pass-if-exception "no args" exception:wrong-num-args
1136     (fold))
1137
1138   (pass-if-exception "one arg" exception:wrong-num-args
1139     (fold 123))
1140
1141   (pass-if-exception "two args" exception:wrong-num-args
1142     (fold 123 noop))
1143
1144   (with-test-prefix "one list"
1145
1146     (pass-if "arg order"
1147       (eq? #t (fold (lambda (x prev)
1148                       (and (= 1 x)
1149                            (= 2 prev)))
1150                     2 '(1))))
1151
1152     (pass-if "empty list" (= 123 (fold + 123 '())))
1153
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)))
1160
1161     (pass-if-exception "improper 1" exception:wrong-type-arg
1162       (fold + 123 1))
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)))
1167
1168     (pass-if (= 3 (fold + 1 '(2))))
1169     (pass-if (= 6 (fold + 1 '(2 3))))
1170     (pass-if (= 10 (fold + 1 '(2 3 4)))))
1171
1172   (with-test-prefix "two lists"
1173
1174     (pass-if "arg order"
1175       (eq? #t (fold (lambda (x y prev)
1176                       (and (= 1 x)
1177                            (= 2 y)
1178                            (= 3 prev)))
1179                     3 '(1) '(2))))
1180
1181     (pass-if "empty lists" (= 1 (fold + 1 '() '())))
1182
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)))
1189
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)))
1196
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)))
1203
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))))
1207
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)))))
1213
1214     (pass-if "apply list unchanged"
1215       (let ((lst (list (list 1 2) (list 3 4))))
1216         (and (equal? 11 (apply fold + 1 lst))
1217              ;; lst unmodified
1218              (equal? '((1 2) (3 4)) lst)))))
1219
1220   (with-test-prefix "three lists"
1221
1222     (pass-if "arg order"
1223       (eq? #t (fold (lambda (x y z prev)
1224                       (and (= 1 x)
1225                            (= 2 y)
1226                            (= 3 z)
1227                            (= 4 prev)))
1228                     4 '(1) '(2) '(3))))
1229
1230     (pass-if "empty lists" (= 1 (fold + 1 '() '() '())))
1231
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)))
1236
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)))
1243
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)))
1250
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)))
1257
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))))
1261
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)))))
1266
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))
1270              ;; lst unmodified
1271              (equal? '((1 2) (3 4) (5 6)) lst))))))
1272
1273 ;;
1274 ;; fold-right
1275 ;;
1276
1277 (with-test-prefix "fold-right"
1278
1279   (pass-if "one list"
1280     (equal? (iota 10)
1281             (fold-right cons '() (iota 10))))
1282
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))
1287                         '()
1288                         (iota 10)
1289                         (map integer->char (iota 10)))))
1290
1291   (pass-if "tail-recursive"
1292     (= 1e6 (fold-right (lambda (x y) (+ 1 y))
1293                        0
1294                        (iota 1e6)))))
1295 ;;
1296 ;; unfold
1297 ;;
1298
1299 (with-test-prefix "unfold"
1300
1301   (pass-if "basic"
1302     (equal? (iota 10)
1303             (unfold (lambda (x) (>= x 10))
1304                     identity
1305                     1+
1306                     0)))
1307
1308   (pass-if "tail-gen"
1309     (equal? (append (iota 10) '(tail 10))
1310             (unfold (lambda (x) (>= x 10))
1311                     identity
1312                     1+
1313                     0
1314                     (lambda (seed) (list 'tail seed)))))
1315
1316   (pass-if "tail-recursive"
1317     ;; Bug #30071.
1318     (pair? (unfold (lambda (x) (>= x 1e6))
1319                    identity
1320                    1+
1321                    0))))
1322
1323 ;;
1324 ;; length+
1325 ;;
1326
1327 (with-test-prefix "length+"
1328   (pass-if-exception "too few args" exception:wrong-num-args
1329     (length+))
1330   (pass-if-exception "too many args" exception:wrong-num-args
1331     (length+ 123 456))
1332   (pass-if-exception "not a pair" exception:wrong-type-arg
1333     (length+ 'x))
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)))))
1343
1344 ;;
1345 ;; last
1346 ;;
1347
1348 (with-test-prefix "last"
1349
1350   (pass-if-exception "empty" exception:wrong-type-arg
1351     (last '()))
1352   (pass-if "one elem"
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)))))
1360
1361 ;;
1362 ;; list=
1363 ;;
1364
1365 (with-test-prefix "list="
1366
1367   (pass-if "no lists"
1368     (eq? #t (list= eqv?)))
1369
1370   (with-test-prefix "one list"
1371
1372     (pass-if "empty"
1373       (eq? #t (list= eqv? '())))
1374     (pass-if "one elem"
1375       (eq? #t (list= eqv? '(1))))
1376     (pass-if "two elems"
1377       (eq? #t (list= eqv? '(2)))))
1378
1379   (with-test-prefix "two lists"
1380
1381     (pass-if "empty / empty"
1382       (eq? #t (list= eqv? '() '())))
1383
1384     (pass-if "one / empty"
1385       (eq? #f (list= eqv? '(1) '())))
1386
1387     (pass-if "empty / one"
1388       (eq? #f (list= eqv? '() '(1))))
1389
1390     (pass-if "one / one same"
1391       (eq? #t (list= eqv? '(1) '(1))))
1392
1393     (pass-if "one / one diff"
1394       (eq? #f (list= eqv? '(1) '(2))))
1395
1396     (pass-if "called arg order"
1397       (let ((good #t))
1398         (list= (lambda (x y)
1399                  (set! good (and good (= (1+ x) y)))
1400                  #t)
1401                '(1 3) '(2 4))
1402         good)))
1403
1404   (with-test-prefix "three lists"
1405
1406     (pass-if "empty / empty / empty"
1407       (eq? #t (list= eqv? '() '() '())))
1408
1409     (pass-if "one / empty / empty"
1410       (eq? #f (list= eqv? '(1) '() '())))
1411
1412     (pass-if "one / one / empty"
1413       (eq? #f (list= eqv? '(1) '(1) '())))
1414
1415     (pass-if "one / diff / empty"
1416       (eq? #f (list= eqv? '(1) '(2) '())))
1417
1418     (pass-if "one / one / one"
1419       (eq? #t (list= eqv? '(1) '(1) '(1))))
1420
1421     (pass-if "two / two / diff"
1422       (eq? #f (list= eqv? '(1 2) '(1 2) '(1 99))))
1423
1424     (pass-if "two / two / two"
1425       (eq? #t (list= eqv? '(1 2) '(1 2) '(1 2))))
1426
1427     (pass-if "called arg order"
1428       (let ((good #t))
1429         (list= (lambda (x y)
1430                  (set! good (and good (= (1+ x) y)))
1431                  #t)
1432                '(1 4) '(2 5) '(3 6))
1433         good))))
1434
1435 ;;
1436 ;; list-copy
1437 ;;
1438
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))))
1445
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)))))
1452
1453 ;;
1454 ;; list-index
1455 ;;
1456
1457 (with-test-prefix "list-index"
1458   (pass-if-exception "no args" exception:wrong-num-args
1459     (list-index))
1460
1461   (pass-if-exception "one arg" exception:wrong-num-args
1462     (list-index noop))
1463
1464   (with-test-prefix "one list"
1465
1466     (pass-if "empty list" (eq? #f (list-index symbol? '())))
1467
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)))
1472
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)))
1479
1480     (pass-if (eqv? #f (list-index symbol? '(1))))
1481     (pass-if (eqv? 0 (list-index symbol? '(x))))
1482
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))))
1486
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)))))
1491
1492   (with-test-prefix "two lists"
1493     (define (sym1 x y)
1494       (symbol? x))
1495     (define (sym2 x y)
1496       (symbol? y))
1497
1498     (pass-if "arg order"
1499       (eqv? 0 (list-index (lambda (x y)
1500                             (and (= 1 x)
1501                                  (= 2 y)))
1502                           '(1) '(2))))
1503
1504     (pass-if "empty lists" (eqv? #f (list-index sym2 '() '())))
1505
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)))
1512
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)))
1519
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)))
1526
1527     (pass-if (eqv? #f (list-index sym2 '(1) '(2))))
1528     (pass-if (eqv? 0  (list-index sym2 '(1) '(x))))
1529
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))))
1533
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))))
1538
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))))))
1544
1545   (with-test-prefix "three lists"
1546     (define (sym1 x y z)
1547       (symbol? x))
1548     (define (sym2 x y z)
1549       (symbol? y))
1550     (define (sym3 x y z)
1551       (symbol? z))
1552
1553     (pass-if "arg order"
1554       (eqv? 0 (list-index (lambda (x y z)
1555                             (and (= 1 x)
1556                                  (= 2 y)
1557                                  (= 3 z)))
1558                           '(1) '(2) '(3))))
1559
1560     (pass-if "empty lists" (eqv? #f (list-index sym3 '() '() '())))
1561
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)))
1570
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)))
1577
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)))
1584
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)))
1591
1592     (pass-if (eqv? #f (list-index sym3 '(#f) '(#f) '(#f))))
1593     (pass-if (eqv? 0  (list-index sym3 '(#f) '(#f) '(x))))
1594
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))))
1598
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))))
1603
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) '())))
1608
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)))))
1612
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))
1616              ;; lst unmodified
1617              (equal? '((1 2) (3 4) (5 6)) lst))))))
1618
1619 ;;
1620 ;; list-tabulate
1621 ;;
1622
1623 (with-test-prefix "list-tabulate"
1624
1625   (pass-if-exception "-1" exception:wrong-type-arg
1626     (list-tabulate -1 identity))
1627   (pass-if "0"
1628     (equal? '() (list-tabulate 0 identity)))
1629   (pass-if "1"
1630     (equal? '(0) (list-tabulate 1 identity)))
1631   (pass-if "2"
1632     (equal? '(0 1) (list-tabulate 2 identity)))
1633   (pass-if "3"
1634     (equal? '(0 1 2) (list-tabulate 3 identity)))
1635   (pass-if "4"
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
1639                                               (lambda (i)
1640                                                 (string-ref "abcd" i))))))
1641
1642 ;;
1643 ;; lset=
1644 ;;
1645
1646 (with-test-prefix "lset="
1647
1648   ;; in guile 1.6.7 and earlier, lset= incorrectly demanded at least one
1649   ;; list arg
1650   (pass-if "no args"
1651     (eq? #t (lset= eq?)))
1652
1653   (with-test-prefix "one arg"
1654
1655     (pass-if "()"
1656       (eq? #t (lset= eqv? '())))
1657
1658     (pass-if "(1)"
1659       (eq? #t (lset= eqv? '(1))))
1660
1661     (pass-if "(1 2)"
1662       (eq? #t (lset= eqv? '(1 2)))))
1663
1664   (with-test-prefix "two args"
1665
1666     (pass-if "() ()"
1667       (eq? #t (lset= eqv? '() '())))
1668
1669     (pass-if "(1) (1)"
1670       (eq? #t (lset= eqv? '(1) '(1))))
1671
1672     (pass-if "(1) (2)"
1673       (eq? #f (lset= eqv? '(1) '(2))))
1674
1675     (pass-if "(1) (1 2)"
1676       (eq? #f (lset= eqv? '(1) '(1 2))))
1677
1678     (pass-if "(1 2) (2 1)"
1679       (eq? #t (lset= eqv? '(1 2) '(2 1))))
1680
1681     (pass-if "called arg order"
1682       (let ((good #t))
1683         (lset= (lambda (x y)
1684                  (if (not (= x (1- y)))
1685                      (set! good #f))
1686                  #t)
1687                '(1 1) '(2 2))
1688         good)))
1689
1690   (with-test-prefix "three args"
1691
1692     (pass-if "() () ()"
1693       (eq? #t (lset= eqv? '() '() '())))
1694
1695     (pass-if "(1) (1) (1)"
1696       (eq? #t (lset= eqv? '(1) '(1) '(1))))
1697
1698     (pass-if "(1) (1) (2)"
1699       (eq? #f (lset= eqv? '(1) '(1) '(2))))
1700
1701     (pass-if "(1) (1) (1 2)"
1702       (eq? #f (lset= eqv? '(1) '(1) '(1 2))))
1703
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))))
1706
1707     (pass-if "called arg order"
1708       (let ((good #t))
1709         (lset= (lambda (x y)
1710                  (if (not (= x (1- y)))
1711                      (set! good #f))
1712                  #t)
1713                '(1 1) '(2 2) '(3 3))
1714         good))))
1715
1716 ;;
1717 ;; lset-adjoin
1718 ;;
1719
1720 (with-test-prefix "lset-adjoin"
1721
1722   ;; in guile 1.6.7 and earlier, lset-adjoin didn't actually use the given
1723   ;; `=' procedure, all comparisons were just with `equal?
1724   ;;
1725   (with-test-prefix "case-insensitive ="
1726
1727     (pass-if "(\"x\") \"X\""
1728       (equal? '("x") (lset-adjoin string-ci=? '("x") "X"))))
1729
1730   (pass-if "called arg order"
1731     (let ((good #f))
1732       (lset-adjoin (lambda (x y)
1733                      (set! good (and (= x 1) (= y 2)))
1734                      (= x y))
1735                    '(1) 2)
1736       good))
1737
1738   (pass-if (equal? '() (lset-adjoin = '())))
1739
1740   (pass-if (equal? '(1) (lset-adjoin = '() 1)))
1741
1742   (pass-if (equal? '(1) (lset-adjoin = '() 1 1)))
1743
1744   (pass-if (equal? '(2 1) (lset-adjoin = '() 1 2)))
1745
1746   (pass-if (equal? '(3 1 2) (lset-adjoin = '(1 2) 1 2 3 2 1)))
1747
1748   (pass-if "apply list unchanged"
1749     (let ((lst (list 1 2)))
1750       (and (equal? '(2 1 3) (apply lset-adjoin = '(3) lst))
1751            ;; lst unmodified
1752            (equal? '(1 2) lst))))
1753
1754   (pass-if "(1 1) 1 1"
1755     (equal? '(1 1) (lset-adjoin = '(1 1) 1 1)))
1756
1757   ;; duplicates among args are cast out
1758   (pass-if "(2) 1 1"
1759     (equal? '(1 2) (lset-adjoin = '(2) 1 1))))
1760
1761 ;;
1762 ;; lset-difference
1763 ;;
1764
1765 (with-test-prefix "lset-difference"
1766
1767   (pass-if "called arg order"
1768     (let ((good #f))
1769       (lset-difference (lambda (x y)
1770                          (set! good (and (= x 1) (= y 2)))
1771                          (= x y))
1772                        '(1) '(2))
1773       good)))
1774
1775 ;;
1776 ;; lset-difference!
1777 ;;
1778
1779 (with-test-prefix "lset-difference!"
1780
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)))
1785
1786   (pass-if "called arg order"
1787     (let ((good #f))
1788       (lset-difference! (lambda (x y)
1789                           (set! good (and (= x 1) (= y 2)))
1790                           (= x y))
1791                         (list 1) (list 2))
1792       good))
1793
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))))
1797
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))))
1805
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))))
1812
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))))
1816
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))))
1821
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)))))
1828
1829 ;;
1830 ;; lset-diff+intersection
1831 ;;
1832
1833 (with-test-prefix "lset-diff+intersection"
1834
1835   (pass-if "called arg order"
1836     (let ((good #f))
1837       (lset-diff+intersection (lambda (x y)
1838                                 (set! good (and (= x 1) (= y 2)))
1839                                 (= x y))
1840                               '(1) '(2))
1841       good)))
1842
1843 ;;
1844 ;; lset-diff+intersection!
1845 ;;
1846
1847 (with-test-prefix "lset-diff+intersection"
1848
1849   (pass-if "called arg order"
1850     (let ((good #f))
1851       (lset-diff+intersection (lambda (x y)
1852                                 (set! good (and (= x 1) (= y 2)))
1853                                 (= x y))
1854                               (list 1) (list 2))
1855       good)))
1856
1857 ;;
1858 ;; lset-intersection
1859 ;;
1860
1861 (with-test-prefix "lset-intersection"
1862
1863   (pass-if "called arg order"
1864     (let ((good #f))
1865       (lset-intersection (lambda (x y)
1866                            (set! good (and (= x 1) (= y 2)))
1867                            (= x y))
1868                          '(1) '(2))
1869       good)))
1870
1871 ;;
1872 ;; lset-intersection!
1873 ;;
1874
1875 (with-test-prefix "lset-intersection"
1876
1877   (pass-if "called arg order"
1878     (let ((good #f))
1879       (lset-intersection (lambda (x y)
1880                            (set! good (and (= x 1) (= y 2)))
1881                            (= x y))
1882                          (list 1) (list 2))
1883       good)))
1884
1885 ;;
1886 ;; lset-union
1887 ;;
1888
1889 (with-test-prefix "lset-union"
1890
1891   (pass-if "no args"
1892     (eq? '() (lset-union eq?)))
1893
1894   (pass-if "one arg"
1895     (equal? '(1 2 3) (lset-union eq? '(1 2 3))))
1896
1897   (pass-if "'() '()"
1898     (equal? '() (lset-union eq? '() '())))
1899
1900   (pass-if "'() '(1 2 3)"
1901     (equal? '(1 2 3) (lset-union eq? '() '(1 2 3))))
1902
1903   (pass-if "'(1 2 3) '()"
1904     (equal? '(1 2 3) (lset-union eq? '(1 2 3) '())))
1905
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))))
1908
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))))
1911
1912   ;; in guile 1.6.7 and earlier, `=' was called with the arguments the wrong
1913   ;; way around
1914   (pass-if "called arg order"
1915     (let ((good #f))
1916       (lset-union (lambda (x y)
1917                     (set! good (and (= x 1) (= y 2)))
1918                     (= x y))
1919                   '(1) '(2))
1920       good)))
1921
1922 ;;
1923 ;; member
1924 ;;
1925
1926 (with-test-prefix "member"
1927
1928   (pass-if-exception "no args" exception:wrong-num-args
1929     (member))
1930
1931   (pass-if-exception "one arg" exception:wrong-num-args
1932     (member 1))
1933
1934   (pass-if "1 (1 2 3)"
1935     (let ((lst '(1 2 3)))
1936       (eq? lst (member 1 lst))))
1937
1938   (pass-if "2 (1 2 3)"
1939     (let ((lst '(1 2 3)))
1940       (eq? (cdr lst) (member 2 lst))))
1941
1942   (pass-if "3 (1 2 3)"
1943     (let ((lst '(1 2 3)))
1944       (eq? (cddr lst) (member 3 lst))))
1945
1946   (pass-if "4 (1 2 3)"
1947     (let ((lst '(1 2 3)))
1948       (eq? #f (member 4 lst))))
1949
1950   (pass-if "called arg order"
1951     (let ((good #f))
1952       (member 1 '(2) (lambda (x y)
1953                        (set! good (and (eqv? 1 x)
1954                                        (eqv? 2 y)))))
1955       good)))
1956
1957 ;;
1958 ;; ninth
1959 ;;
1960
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)))))
1966
1967
1968 ;;
1969 ;; not-pair?
1970 ;;
1971
1972 (with-test-prefix "not-pair?"
1973   (pass-if "inum"
1974     (eq? #t (not-pair? 123)))
1975   (pass-if "pair"
1976     (eq? #f (not-pair? '(x . y))))
1977   (pass-if "symbol"
1978     (eq? #t (not-pair? 'x))))
1979
1980 ;;
1981 ;; take
1982 ;;
1983
1984 (with-test-prefix "take"
1985
1986   (pass-if "'() 0"
1987     (null? (take '() 0)))
1988
1989   (pass-if "'(a) 0"
1990     (null? (take '(a) 0)))
1991
1992   (pass-if "'(a b) 0"
1993     (null? (take '() 0)))
1994
1995   (pass-if "'(a b c) 0"
1996     (null? (take '() 0)))
1997
1998   (pass-if "'(a) 1"
1999     (let* ((lst '(a))
2000            (got (take lst 1)))
2001       (and (equal? '(a) got)
2002            (not (eq? lst got)))))
2003
2004   (pass-if "'(a b) 1"
2005     (equal? '(a)
2006             (take '(a b) 1)))
2007
2008   (pass-if "'(a b c) 1"
2009     (equal? '(a)
2010             (take '(a b c) 1)))
2011
2012   (pass-if "'(a b) 2"
2013     (let* ((lst '(a b))
2014            (got (take lst 2)))
2015       (and (equal? '(a b) got)
2016            (not (eq? lst got)))))
2017
2018   (pass-if "'(a b c) 2"
2019     (equal? '(a b)
2020             (take '(a b c) 2)))
2021
2022   (pass-if "circular '(a) 0"
2023     (equal? '()
2024             (take (circular-list 'a) 0)))
2025
2026   (pass-if "circular '(a) 1"
2027     (equal? '(a)
2028             (take (circular-list 'a) 1)))
2029
2030   (pass-if "circular '(a) 2"
2031     (equal? '(a a)
2032             (take (circular-list 'a) 2)))
2033
2034   (pass-if "circular '(a b) 5"
2035     (equal? '(a b a b a)
2036             (take (circular-list 'a 'b) 5)))
2037
2038   (pass-if "'(a . b) 1"
2039     (equal? '(a)
2040             (take '(a . b) 1)))
2041
2042   (pass-if "'(a b . c) 1"
2043     (equal? '(a)
2044             (take '(a b . c) 1)))
2045
2046   (pass-if "'(a b . c) 2"
2047     (equal? '(a b)
2048             (take '(a b . c) 2))))
2049
2050 ;;
2051 ;; take-while
2052 ;;
2053
2054 (with-test-prefix "take-while"
2055
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))))
2060
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))))
2064
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)))))
2068
2069 ;;
2070 ;; take-while!
2071 ;;
2072
2073 (with-test-prefix "take-while!"
2074
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))))
2079
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))))
2083
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)))))
2087
2088 ;;
2089 ;; partition
2090 ;;
2091
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)))))
2098
2099 (with-test-prefix "partition"
2100
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)))
2104
2105   (pass-if "with kept tail"
2106     (test-partition even? '(1 2 3 4 5 6)
2107                     '(2 4 6) '(1 3 5)))
2108
2109   (pass-if "with everything dropped"
2110     (test-partition even? '(1 3 5 7)
2111                     '() '(1 3 5 7)))
2112
2113   (pass-if "with everything kept"
2114     (test-partition even? '(2 4 6)
2115                     '(2 4 6) '()))
2116
2117   (pass-if "with empty list"
2118     (test-partition even? '()
2119                     '() '()))
2120
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 ()
2125                         (partition even?
2126                                    (make-list 10000 1)))
2127       (lambda (even odd)
2128         (and (= (length odd) 10000)
2129              (= (length even) 0)))))
2130
2131   (pass-if-exception "with improper list"
2132     exception:wrong-type-arg
2133     (partition symbol? '(a b . c))))
2134
2135 ;;
2136 ;; partition!
2137 ;;
2138
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)))))
2145
2146 (with-test-prefix "partition!"
2147
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)))
2151
2152   (pass-if "with kept tail"
2153     (test-partition! even? (list 1 2 3 4 5 6)
2154                      '(2 4 6) '(1 3 5)))
2155
2156   (pass-if "with everything dropped"
2157     (test-partition! even? (list 1 3 5 7)
2158                      '() '(1 3 5 7)))
2159
2160   (pass-if "with everything kept"
2161     (test-partition! even? (list 2 4 6)
2162                      '(2 4 6) '()))
2163
2164   (pass-if "with empty list"
2165     (test-partition! even? '()
2166                      '() '()))
2167
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 ()
2172                         (partition! even?
2173                                     (make-list 10000 1)))
2174       (lambda (even odd)
2175         (and (= (length odd) 10000)
2176              (= (length even) 0)))))
2177
2178   (pass-if-exception "with improper list"
2179     exception:wrong-type-arg
2180     (partition! symbol? (cons* 'a 'b 'c))))
2181
2182 ;;
2183 ;; reduce
2184 ;;
2185
2186 (with-test-prefix "reduce"
2187
2188   (pass-if "empty"
2189     (let* ((calls '())
2190            (ret   (reduce (lambda (x prev)
2191                             (set! calls (cons (list x prev) calls))
2192                             x)
2193                           1 '())))
2194       (and (equal? calls '())
2195            (equal? ret   1))))
2196
2197   (pass-if "one elem"
2198     (let* ((calls '())
2199            (ret   (reduce (lambda (x prev)
2200                             (set! calls (cons (list x prev) calls))
2201                             x)
2202                           1 '(2))))
2203       (and (equal? calls '())
2204            (equal? ret   2))))
2205
2206   (pass-if "two elems"
2207     (let* ((calls '())
2208            (ret   (reduce (lambda (x prev)
2209                             (set! calls (cons (list x prev) calls))
2210                             x)
2211                           1 '(2 3))))
2212       (and (equal? calls '((3 2)))
2213            (equal? ret   3))))
2214
2215   (pass-if "three elems"
2216     (let* ((calls '())
2217            (ret   (reduce (lambda (x prev)
2218                             (set! calls (cons (list x prev) calls))
2219                             x)
2220                           1 '(2 3 4))))
2221       (and (equal? calls '((4 3)
2222                            (3 2)))
2223            (equal? ret   4))))
2224
2225   (pass-if "four elems"
2226     (let* ((calls '())
2227            (ret   (reduce (lambda (x prev)
2228                             (set! calls (cons (list x prev) calls))
2229                             x)
2230                           1 '(2 3 4 5))))
2231       (and (equal? calls '((5 4)
2232                            (4 3)
2233                            (3 2)))
2234            (equal? ret   5)))))
2235
2236 ;;
2237 ;; reduce-right
2238 ;;
2239
2240 (with-test-prefix "reduce-right"
2241
2242   (pass-if "empty"
2243     (let* ((calls '())
2244            (ret   (reduce-right (lambda (x prev)
2245                                   (set! calls (cons (list x prev) calls))
2246                                   x)
2247                                 1 '())))
2248       (and (equal? calls '())
2249            (equal? ret   1))))
2250
2251   (pass-if "one elem"
2252     (let* ((calls '())
2253            (ret   (reduce-right (lambda (x prev)
2254                                   (set! calls (cons (list x prev) calls))
2255                                   x)
2256                                 1 '(2))))
2257       (and (equal? calls '())
2258            (equal? ret   2))))
2259
2260   (pass-if "two elems"
2261     (let* ((calls '())
2262            (ret   (reduce-right (lambda (x prev)
2263                                   (set! calls (cons (list x prev) calls))
2264                                   x)
2265                                 1 '(2 3))))
2266       (and (equal? calls '((2 3)))
2267            (equal? ret   2))))
2268
2269   (pass-if "three elems"
2270     (let* ((calls '())
2271            (ret   (reduce-right (lambda (x prev)
2272                                   (set! calls (cons (list x prev) calls))
2273                                   x)
2274                                 1 '(2 3 4))))
2275       (and (equal? calls '((2 3)
2276                            (3 4)))
2277            (equal? ret   2))))
2278
2279   (pass-if "four elems"
2280     (let* ((calls '())
2281            (ret   (reduce-right (lambda (x prev)
2282                                   (set! calls (cons (list x prev) calls))
2283                                   x)
2284                                 1 '(2 3 4 5))))
2285       (and (equal? calls '((2 3)
2286                            (3 4)
2287                            (4 5)))
2288            (equal? ret   2)))))
2289
2290 ;;
2291 ;; remove
2292 ;;
2293
2294 (with-test-prefix "remove"
2295
2296   (pass-if (equal? '() (remove odd? '())))
2297   (pass-if (equal? '() (remove odd? '(1))))
2298   (pass-if (equal? '(2) (remove odd? '(2))))
2299
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))))
2304
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))))
2309
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)))))
2314
2315 ;;
2316 ;; remove!
2317 ;;
2318
2319 (with-test-prefix "remove!"
2320
2321   (pass-if (equal? '() (remove! odd? '())))
2322   (pass-if (equal? '() (remove! odd? (list 1))))
2323   (pass-if (equal? '(2) (remove! odd? (list 2))))
2324
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))))
2329
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))))
2334
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)))))
2339
2340 ;;
2341 ;; seventh
2342 ;;
2343
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)))))
2349
2350 ;;
2351 ;; sixth
2352 ;;
2353
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)))))
2359
2360 ;;
2361 ;; split-at
2362 ;;
2363
2364 (with-test-prefix "split-at"
2365
2366   (define (equal-values? lst thunk)
2367     (call-with-values thunk
2368       (lambda got
2369         (equal? lst got))))
2370
2371   (pass-if-exception "() -1" exception:out-of-range
2372     (split-at '() -1))
2373   (pass-if (equal-values? '(() ())
2374                           (lambda () (split-at '() 0))))
2375   (pass-if-exception "() 1" exception:wrong-type-arg
2376     (split-at '() 1))
2377
2378   (pass-if-exception "(1) -1" exception:out-of-range
2379     (split-at '(1) -1))
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
2383     (split-at '(1) 2))
2384
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))
2392
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)))
2401
2402 ;;
2403 ;; split-at!
2404 ;;
2405
2406 (with-test-prefix "split-at!"
2407
2408   (define (equal-values? lst thunk)
2409     (call-with-values thunk
2410       (lambda got
2411         (equal? lst got))))
2412
2413   (pass-if-exception "() -1" exception:out-of-range
2414     (split-at! '() -1))
2415   (pass-if (equal-values? '(() ())
2416                           (lambda () (split-at! '() 0))))
2417   (pass-if-exception "() 1" exception:wrong-type-arg
2418     (split-at! '() 1))
2419
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))
2426
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))
2434
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)))
2443
2444 ;;
2445 ;; span
2446 ;;
2447
2448 (with-test-prefix "span"
2449
2450   (define (test-span lst want-v1 want-v2)
2451     (call-with-values
2452         (lambda ()
2453           (span positive? lst))
2454       (lambda (got-v1 got-v2)
2455         (and (equal? got-v1 want-v1)
2456              (equal? got-v2 want-v2)))))
2457
2458   (pass-if "empty"
2459     (test-span '() '() '()))
2460
2461   (pass-if "y"
2462     (test-span '(1) '(1) '()))
2463
2464   (pass-if "n"
2465     (test-span '(-1) '() '(-1)))
2466
2467   (pass-if "yy"
2468     (test-span '(1 2) '(1 2) '()))
2469
2470   (pass-if "ny"
2471     (test-span '(-1 1) '() '(-1 1)))
2472
2473   (pass-if "yn"
2474     (test-span '(1 -1) '(1) '(-1)))
2475
2476   (pass-if "nn"
2477     (test-span '(-1 -2) '() '(-1 -2)))
2478
2479   (pass-if "yyy"
2480     (test-span '(1 2 3) '(1 2 3) '()))
2481
2482   (pass-if "nyy"
2483     (test-span '(-1 1 2) '() '(-1 1 2)))
2484
2485   (pass-if "yny"
2486     (test-span '(1 -1 2) '(1) '(-1 2)))
2487
2488   (pass-if "nny"
2489     (test-span '(-1 -2 1) '() '(-1 -2 1)))
2490
2491   (pass-if "yyn"
2492     (test-span '(1 2 -1) '(1 2) '(-1)))
2493
2494   (pass-if "nyn"
2495     (test-span '(-1 1 -2) '() '(-1 1 -2)))
2496
2497   (pass-if "ynn"
2498     (test-span '(1 -1 -2) '(1) '(-1 -2)))
2499
2500   (pass-if "nnn"
2501     (test-span '(-1 -2 -3) '() '(-1 -2 -3))))
2502
2503 ;;
2504 ;; span!
2505 ;;
2506
2507 (with-test-prefix "span!"
2508
2509   (define (test-span! lst want-v1 want-v2)
2510     (call-with-values
2511         (lambda ()
2512           (span! positive? lst))
2513       (lambda (got-v1 got-v2)
2514         (and (equal? got-v1 want-v1)
2515              (equal? got-v2 want-v2)))))
2516
2517   (pass-if "empty"
2518     (test-span! '() '() '()))
2519
2520   (pass-if "y"
2521     (test-span! (list 1) '(1) '()))
2522
2523   (pass-if "n"
2524     (test-span! (list -1) '() '(-1)))
2525
2526   (pass-if "yy"
2527     (test-span! (list 1 2) '(1 2) '()))
2528
2529   (pass-if "ny"
2530     (test-span! (list -1 1) '() '(-1 1)))
2531
2532   (pass-if "yn"
2533     (test-span! (list 1 -1) '(1) '(-1)))
2534
2535   (pass-if "nn"
2536     (test-span! (list -1 -2) '() '(-1 -2)))
2537
2538   (pass-if "yyy"
2539     (test-span! (list 1 2 3) '(1 2 3) '()))
2540
2541   (pass-if "nyy"
2542     (test-span! (list -1 1 2) '() '(-1 1 2)))
2543
2544   (pass-if "yny"
2545     (test-span! (list 1 -1 2) '(1) '(-1 2)))
2546
2547   (pass-if "nny"
2548     (test-span! (list -1 -2 1) '() '(-1 -2 1)))
2549
2550   (pass-if "yyn"
2551     (test-span! (list 1 2 -1) '(1 2) '(-1)))
2552
2553   (pass-if "nyn"
2554     (test-span! (list -1 1 -2) '() '(-1 1 -2)))
2555
2556   (pass-if "ynn"
2557     (test-span! (list 1 -1 -2) '(1) '(-1 -2)))
2558
2559   (pass-if "nnn"
2560     (test-span! (list -1 -2 -3) '() '(-1 -2 -3))))
2561
2562 ;;
2563 ;; take!
2564 ;;
2565
2566 (with-test-prefix "take!"
2567
2568   (pass-if-exception "() -1" exception:out-of-range
2569     (take! '() -1))
2570   (pass-if (equal? '() (take! '() 0)))
2571   (pass-if-exception "() 1" exception:wrong-type-arg
2572     (take! '() 1))
2573
2574   (pass-if-exception "(1) -1" exception:out-of-range
2575     (take! '(1) -1))
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
2579     (take! '(1) 2))
2580
2581   (pass-if-exception "(4 5) -1" exception:out-of-range
2582     (take! '(4 5) -1))
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
2587     (take! '(4 5) 3))
2588
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)))
2597
2598
2599 ;;
2600 ;; take-right
2601 ;;
2602
2603 (with-test-prefix "take-right"
2604
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
2609     (take-right '() 1))
2610
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))
2617
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))
2625
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))
2634
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))))
2639
2640 ;;
2641 ;; tenth
2642 ;;
2643
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)))))
2649
2650 ;;
2651 ;; xcons
2652 ;;
2653
2654 (with-test-prefix "xcons"
2655   (pass-if (equal? '(y . x) (xcons 'x 'y))))