test-suite/tests/srfi-1.test

   1 ;;;; srfi-1.test --- Test suite for Guile's SRFI-1 functions. -*- scheme -*-
   2 ;;;;
   3 ;;;; Copyright 2003, 2004, 2005, 2006, 2008 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-type-arg
 511       (count (lambda () x) '(1 2 3)))
 512     (pass-if-exception "pred arg count 2" exception:wrong-type-arg
 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-type-arg
 549       (count (lambda () #t) '(1 2 3) '(1 2 3)))
 550     (pass-if-exception "pred arg count 1" exception:wrong-type-arg
 551       (count (lambda (x) x) '(1 2 3) '(1 2 3)))
 552     (pass-if-exception "pred arg count 3" exception:wrong-type-arg
 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 ;;
 908 ;; drop-right!
 909 ;;
 910
 911 (with-test-prefix "drop-right!"
 912
 913   (pass-if-exception "() -1" exception:out-of-range
 914     (drop-right! '() -1))
 915   (pass-if (equal? '() (drop-right! '() 0)))
 916   (pass-if-exception "() 1" exception:wrong-type-arg
 917     (drop-right! '() 1))
 918
 919   (pass-if-exception "(1) -1" exception:out-of-range
 920     (drop-right! (list 1) -1))
 921   (pass-if (equal? '(1) (drop-right! (list 1) 0)))
 922   (pass-if (equal? '() (drop-right! (list 1) 1)))
 923   (pass-if-exception "(1) 2" exception:wrong-type-arg
 924     (drop-right! (list 1) 2))
 925
 926   (pass-if-exception "(4 5) -1" exception:out-of-range
 927     (drop-right! (list 4 5) -1))
 928   (pass-if (equal? '(4 5) (drop-right! (list 4 5) 0)))
 929   (pass-if (equal? '(4) (drop-right! (list 4 5) 1)))
 930   (pass-if (equal? '() (drop-right! (list 4 5) 2)))
 931   (pass-if-exception "(4 5) 3" exception:wrong-type-arg
 932     (drop-right! (list 4 5) 3))
 933
 934   (pass-if-exception "(4 5 6) -1" exception:out-of-range
 935     (drop-right! (list 4 5 6) -1))
 936   (pass-if (equal? '(4 5 6) (drop-right! (list 4 5 6) 0)))
 937   (pass-if (equal? '(4 5) (drop-right! (list 4 5 6) 1)))
 938   (pass-if (equal? '(4) (drop-right! (list 4 5 6) 2)))
 939   (pass-if (equal? '() (drop-right! (list 4 5 6) 3)))
 940   (pass-if-exception "(4 5 6) 4" exception:wrong-type-arg
 941     (drop-right! (list 4 5 6) 4)))
 942
 943 ;;
 944 ;; drop-while
 945 ;;
 946
 947 (with-test-prefix "drop-while"
 948
 949   (pass-if (equal? '()      (drop-while odd? '())))
 950   (pass-if (equal? '()      (drop-while odd? '(1))))
 951   (pass-if (equal? '()      (drop-while odd? '(1 3))))
 952   (pass-if (equal? '()      (drop-while odd? '(1 3 5))))
 953
 954   (pass-if (equal? '(2)     (drop-while odd? '(2))))
 955   (pass-if (equal? '(2)     (drop-while odd? '(1 2))))
 956   (pass-if (equal? '(4)     (drop-while odd? '(1 3 4))))
 957
 958   (pass-if (equal? '(2 1)   (drop-while odd? '(2 1))))
 959   (pass-if (equal? '(4 3)   (drop-while odd? '(1 4 3))))
 960   (pass-if (equal? '(4 1 3) (drop-while odd? '(4 1 3)))))
 961
 962 ;;
 963 ;; eighth
 964 ;;
 965
 966 (with-test-prefix "eighth"
 967   (pass-if-exception "() -1" exception:out-of-range
 968     (eighth '(a b c d e f g)))
 969   (pass-if (eq? 'h (eighth '(a b c d e f g h))))
 970   (pass-if (eq? 'h (eighth '(a b c d e f g h i)))))
 971
 972 ;;
 973 ;; fifth
 974 ;;
 975
 976 (with-test-prefix "fifth"
 977   (pass-if-exception "() -1" exception:out-of-range
 978     (fifth '(a b c d)))
 979   (pass-if (eq? 'e (fifth '(a b c d e))))
 980   (pass-if (eq? 'e (fifth '(a b c d e f)))))
 981
 982 ;;
 983 ;; filter-map
 984 ;;
 985
 986 (with-test-prefix "filter-map"
 987
 988   (with-test-prefix "one list"
 989     (pass-if-exception "'x" exception:wrong-type-arg
 990       (filter-map noop 'x))
 991
 992     (pass-if-exception "'(1 . x)" exception:wrong-type-arg
 993       (filter-map noop '(1 . x)))
 994
 995     (pass-if "(1)"
 996       (equal? '(1) (filter-map noop '(1))))
 997
 998     (pass-if "(#f)"
 999       (equal? '() (filter-map noop '(#f))))
1000
1001     (pass-if "(1 2)"
1002       (equal? '(1 2) (filter-map noop '(1 2))))
1003
1004     (pass-if "(#f 2)"
1005       (equal? '(2) (filter-map noop '(#f 2))))
1006
1007     (pass-if "(#f #f)"
1008       (equal? '() (filter-map noop '(#f #f))))
1009
1010     (pass-if "(1 2 3)"
1011       (equal? '(1 2 3) (filter-map noop '(1 2 3))))
1012
1013     (pass-if "(#f 2 3)"
1014       (equal? '(2 3) (filter-map noop '(#f 2 3))))
1015
1016     (pass-if "(1 #f 3)"
1017       (equal? '(1 3) (filter-map noop '(1 #f 3))))
1018
1019     (pass-if "(1 2 #f)"
1020       (equal? '(1 2) (filter-map noop '(1 2 #f)))))
1021
1022   (with-test-prefix "two lists"
1023     (pass-if-exception "'x '(1 2 3)" exception:wrong-type-arg
1024       (filter-map noop 'x '(1 2 3)))
1025
1026     (pass-if-exception "'(1 2 3) 'x" exception:wrong-type-arg
1027       (filter-map noop '(1 2 3) 'x))
1028
1029     (pass-if-exception "'(1 . x) '(1 2 3)" exception:wrong-type-arg
1030       (filter-map noop '(1 . x) '(1 2 3)))
1031
1032     (pass-if-exception "'(1 2 3) '(1 . x)" exception:wrong-type-arg
1033       (filter-map noop '(1 2 3) '(1 . x)))
1034
1035     (pass-if "(1 2 3) (4 5 6)"
1036       (equal? '(5 7 9) (filter-map + '(1 2 3) '(4 5 6))))
1037
1038     (pass-if "(#f 2 3) (4 5)"
1039       (equal? '(2) (filter-map noop '(#f 2 3) '(4 5))))
1040
1041     (pass-if "(4 #f) (1 2 3)"
1042       (equal? '(4) (filter-map noop '(4 #f) '(1 2 3))))
1043
1044     (pass-if "() (1 2 3)"
1045       (equal? '() (filter-map noop '() '(1 2 3))))
1046
1047     (pass-if "(1 2 3) ()"
1048       (equal? '() (filter-map noop '(1 2 3) '()))))
1049
1050   (with-test-prefix "three lists"
1051     (pass-if-exception "'x '(1 2 3) '(1 2 3)" exception:wrong-type-arg
1052       (filter-map noop 'x '(1 2 3) '(1 2 3)))
1053
1054     (pass-if-exception "'(1 2 3) 'x '(1 2 3)" exception:wrong-type-arg
1055       (filter-map noop '(1 2 3) 'x '(1 2 3)))
1056
1057     (pass-if-exception "'(1 2 3) '(1 2 3) 'x" exception:wrong-type-arg
1058       (filter-map noop '(1 2 3) '(1 2 3) 'x))
1059
1060     (pass-if-exception "'(1 . x) '(1 2 3) '(1 2 3)" exception:wrong-type-arg
1061       (filter-map noop '(1 . x) '(1 2 3) '(1 2 3)))
1062
1063     (pass-if-exception "'(1 2 3) '(1 . x) '(1 2 3)" exception:wrong-type-arg
1064       (filter-map noop '(1 2 3) '(1 . x) '(1 2 3)))
1065
1066     (pass-if-exception "'(1 2 3) '(1 2 3) '(1 . x)" exception:wrong-type-arg
1067       (filter-map noop '(1 2 3) '(1 2 3) '(1 . x)))
1068
1069     (pass-if "(1 2 3) (4 5 6) (7 8 9)"
1070       (equal? '(12 15 18) (filter-map + '(1 2 3) '(4 5 6) '(7 8 9))))
1071
1072     (pass-if "(#f 2 3) (4 5) (7 8 9)"
1073       (equal? '(2) (filter-map noop '(#f 2 3) '(4 5) '(7 8 9))))
1074
1075     (pass-if "(#f 2 3) (7 8 9) (4 5)"
1076       (equal? '(2) (filter-map noop '(#f 2 3) '(7 8 9) '(4 5))))
1077
1078     (pass-if "(4 #f) (1 2 3) (7 8 9)"
1079       (equal? '(4) (filter-map noop '(4 #f) '(1 2 3) '(7 8 9))))
1080
1081     (pass-if "apply list unchanged"
1082       (let ((lst (list (list 1 #f 2) (list 3 4 5) (list 6 7 8))))
1083         (and (equal? '(1 2) (apply filter-map noop lst))
1084              ;; lst unmodified
1085              (equal? lst '((1 #f 2) (3 4 5) (6 7 8))))))))
1086
1087 ;;
1088 ;; find
1089 ;;
1090
1091 (with-test-prefix "find"
1092   (pass-if (eqv? #f (find odd? '())))
1093   (pass-if (eqv? #f (find odd? '(0))))
1094   (pass-if (eqv? #f (find odd? '(0 2))))
1095   (pass-if (eqv? 1 (find odd? '(1))))
1096   (pass-if (eqv? 1 (find odd? '(0 1))))
1097   (pass-if (eqv? 1 (find odd? '(0 1 2))))
1098   (pass-if (eqv? 1 (find odd? '(2 0 1))))
1099   (pass-if (eqv? 1 (find (lambda (x) (= 1 x)) '(2 0 1)))))
1100
1101 ;;
1102 ;; find-tail
1103 ;;
1104
1105 (with-test-prefix "find-tail"
1106   (pass-if (let ((lst '()))
1107              (eq? #f (find-tail odd? lst))))
1108   (pass-if (let ((lst '(0)))
1109              (eq? #f (find-tail odd? lst))))
1110   (pass-if (let ((lst '(0 2)))
1111              (eq? #f (find-tail odd? lst))))
1112   (pass-if (let ((lst '(1)))
1113              (eq? lst (find-tail odd? lst))))
1114   (pass-if (let ((lst '(1 2)))
1115              (eq? lst (find-tail odd? lst))))
1116   (pass-if (let ((lst '(2 1)))
1117              (eq? (cdr lst) (find-tail odd? lst))))
1118   (pass-if (let ((lst '(2 1 0)))
1119              (eq? (cdr lst) (find-tail odd? lst))))
1120   (pass-if (let ((lst '(2 0 1)))
1121              (eq? (cddr lst) (find-tail odd? lst))))
1122   (pass-if (let ((lst '(2 0 1)))
1123              (eq? (cddr lst) (find-tail (lambda (x) (= 1 x)) lst)))))
1124
1125 ;;
1126 ;; fold
1127 ;;
1128
1129 (with-test-prefix "fold"
1130   (pass-if-exception "no args" exception:wrong-num-args
1131     (fold))
1132
1133   (pass-if-exception "one arg" exception:wrong-num-args
1134     (fold 123))
1135
1136   (pass-if-exception "two args" exception:wrong-num-args
1137     (fold 123 noop))
1138
1139   (with-test-prefix "one list"
1140
1141     (pass-if "arg order"
1142       (eq? #t (fold (lambda (x prev)
1143                       (and (= 1 x)
1144                            (= 2 prev)))
1145                     2 '(1))))
1146
1147     (pass-if "empty list" (= 123 (fold + 123 '())))
1148
1149     (pass-if-exception "proc arg count 0" exception:wrong-type-arg
1150       (fold (lambda () x) 123 '(1 2 3)))
1151     (pass-if-exception "proc arg count 1" exception:wrong-type-arg
1152       (fold (lambda (x) x) 123 '(1 2 3)))
1153     (pass-if-exception "proc arg count 3" exception:wrong-type-arg
1154       (fold (lambda (x y z) x) 123 '(1 2 3)))
1155
1156     (pass-if-exception "improper 1" exception:wrong-type-arg
1157       (fold + 123 1))
1158     (pass-if-exception "improper 2" exception:wrong-type-arg
1159       (fold + 123 '(1 . 2)))
1160     (pass-if-exception "improper 3" exception:wrong-type-arg
1161       (fold + 123 '(1 2 . 3)))
1162
1163     (pass-if (= 3 (fold + 1 '(2))))
1164     (pass-if (= 6 (fold + 1 '(2 3))))
1165     (pass-if (= 10 (fold + 1 '(2 3 4)))))
1166
1167   (with-test-prefix "two lists"
1168
1169     (pass-if "arg order"
1170       (eq? #t (fold (lambda (x y prev)
1171                       (and (= 1 x)
1172                            (= 2 y)
1173                            (= 3 prev)))
1174                     3 '(1) '(2))))
1175
1176     (pass-if "empty lists" (= 1 (fold + 1 '() '())))
1177
1178     ;; currently bad proc argument gives wrong-num-args when 2 or more
1179     ;; lists, as opposed to wrong-type-arg for 1 list
1180     (pass-if-exception "proc arg count 2" exception:wrong-num-args
1181       (fold (lambda (x prev) x) 1 '(1 2 3) '(1 2 3)))
1182     (pass-if-exception "proc arg count 4" exception:wrong-num-args
1183       (fold (lambda (x y z prev) x) 1 '(1 2 3) '(1 2 3)))
1184
1185     (pass-if-exception "improper first 1" exception:wrong-type-arg
1186       (fold + 1 1 '(1 2 3)))
1187     (pass-if-exception "improper first 2" exception:wrong-type-arg
1188       (fold + 1 '(1 . 2) '(1 2 3)))
1189     (pass-if-exception "improper first 3" exception:wrong-type-arg
1190       (fold + 1 '(1 2 . 3) '(1 2 3)))
1191
1192     (pass-if-exception "improper second 1" exception:wrong-type-arg
1193       (fold + 1 '(1 2 3) 1))
1194     (pass-if-exception "improper second 2" exception:wrong-type-arg
1195       (fold + 1 '(1 2 3) '(1 . 2)))
1196     (pass-if-exception "improper second 3" exception:wrong-type-arg
1197       (fold + 1 '(1 2 3) '(1 2 . 3)))
1198
1199     (pass-if (= 6 (fold + 1 '(2) '(3))))
1200     (pass-if (= 15 (fold + 1 '(2 3) '(4 5))))
1201     (pass-if (= 28 (fold + 1 '(2 3 4) '(5 6 7))))
1202
1203     (with-test-prefix "stop shortest"
1204       (pass-if (= 13 (fold + 1 '(1 2 3) '(4 5))))
1205       (pass-if (= 13 (fold + 1 '(4 5) '(1 2 3))))
1206       (pass-if (= 11 (fold + 1 '(3 4) '(1 2 9 9))))
1207       (pass-if (= 11 (fold + 1 '(1 2 9 9) '(3 4)))))
1208
1209     (pass-if "apply list unchanged"
1210       (let ((lst (list (list 1 2) (list 3 4))))
1211         (and (equal? 11 (apply fold + 1 lst))
1212              ;; lst unmodified
1213              (equal? '((1 2) (3 4)) lst)))))
1214
1215   (with-test-prefix "three lists"
1216
1217     (pass-if "arg order"
1218       (eq? #t (fold (lambda (x y z prev)
1219                       (and (= 1 x)
1220                            (= 2 y)
1221                            (= 3 z)
1222                            (= 4 prev)))
1223                     4 '(1) '(2) '(3))))
1224
1225     (pass-if "empty lists" (= 1 (fold + 1 '() '() '())))
1226
1227     (pass-if-exception "proc arg count 3" exception:wrong-num-args
1228       (fold (lambda (x y prev) x) 1 '(1 2 3) '(1 2 3)'(1 2 3) ))
1229     (pass-if-exception "proc arg count 5" exception:wrong-num-args
1230       (fold (lambda (w x y z prev) x) 1 '(1 2 3) '(1 2 3) '(1 2 3)))
1231
1232     (pass-if-exception "improper first 1" exception:wrong-type-arg
1233       (fold + 1 1 '(1 2 3) '(1 2 3)))
1234     (pass-if-exception "improper first 2" exception:wrong-type-arg
1235       (fold + 1 '(1 . 2) '(1 2 3) '(1 2 3)))
1236     (pass-if-exception "improper first 3" exception:wrong-type-arg
1237       (fold + 1 '(1 2 . 3) '(1 2 3) '(1 2 3)))
1238
1239     (pass-if-exception "improper second 1" exception:wrong-type-arg
1240       (fold + 1 '(1 2 3) 1 '(1 2 3)))
1241     (pass-if-exception "improper second 2" exception:wrong-type-arg
1242       (fold + 1 '(1 2 3) '(1 . 2) '(1 2 3)))
1243     (pass-if-exception "improper second 3" exception:wrong-type-arg
1244       (fold + 1 '(1 2 3) '(1 2 . 3) '(1 2 3)))
1245
1246     (pass-if-exception "improper third 1" exception:wrong-type-arg
1247       (fold + 1 '(1 2 3) '(1 2 3) 1))
1248     (pass-if-exception "improper third 2" exception:wrong-type-arg
1249       (fold + 1 '(1 2 3) '(1 2 3) '(1 . 2)))
1250     (pass-if-exception "improper third 3" exception:wrong-type-arg
1251       (fold + 1 '(1 2 3) '(1 2 3) '(1 2 . 3)))
1252
1253     (pass-if (= 10 (fold + 1 '(2) '(3) '(4))))
1254     (pass-if (= 28 (fold + 1 '(2 5) '(3 6) '(4 7))))
1255     (pass-if (= 55 (fold + 1 '(2 5 8) '(3 6 9) '(4 7 10))))
1256
1257     (with-test-prefix "stop shortest"
1258       (pass-if (= 28 (fold + 1 '(2 5 9) '(3 6) '(4 7))))
1259       (pass-if (= 28 (fold + 1 '(2 5) '(3 6 9) '(4 7))))
1260       (pass-if (= 28 (fold + 1 '(2 5) '(3 6) '(4 7 9)))))
1261
1262     (pass-if "apply list unchanged"
1263       (let ((lst (list (list 1 2) (list 3 4) (list 5 6))))
1264         (and (equal? 22 (apply fold + 1 lst))
1265              ;; lst unmodified
1266              (equal? '((1 2) (3 4) (5 6)) lst))))))
1267
1268 ;;
1269 ;; length+
1270 ;;
1271
1272 (with-test-prefix "length+"
1273   (pass-if-exception "too few args" exception:wrong-num-args
1274     (length+))
1275   (pass-if-exception "too many args" exception:wrong-num-args
1276     (length+ 123 456))
1277   (pass-if (= 0 (length+ '())))
1278   (pass-if (= 1 (length+ '(x))))
1279   (pass-if (= 2 (length+ '(x y))))
1280   (pass-if (= 3 (length+ '(x y z))))
1281   (pass-if (not (length+ (circular-list 1))))
1282   (pass-if (not (length+ (circular-list 1 2))))
1283   (pass-if (not (length+ (circular-list 1 2 3)))))
1284
1285 ;;
1286 ;; last
1287 ;;
1288
1289 (with-test-prefix "last"
1290
1291   (pass-if-exception "empty" exception:wrong-type-arg
1292     (last '()))
1293   (pass-if "one elem"
1294     (eqv? 1 (last '(1))))
1295   (pass-if "two elems"
1296     (eqv? 2 (last '(1 2))))
1297   (pass-if "three elems"
1298     (eqv? 3 (last '(1 2 3))))
1299   (pass-if "four elems"
1300     (eqv? 4 (last '(1 2 3 4)))))
1301
1302 ;;
1303 ;; list=
1304 ;;
1305
1306 (with-test-prefix "list="
1307
1308   (pass-if "no lists"
1309     (eq? #t (list= eqv?)))
1310
1311   (with-test-prefix "one list"
1312
1313     (pass-if "empty"
1314       (eq? #t (list= eqv? '())))
1315     (pass-if "one elem"
1316       (eq? #t (list= eqv? '(1))))
1317     (pass-if "two elems"
1318       (eq? #t (list= eqv? '(2)))))
1319
1320   (with-test-prefix "two lists"
1321
1322     (pass-if "empty / empty"
1323       (eq? #t (list= eqv? '() '())))
1324
1325     (pass-if "one / empty"
1326       (eq? #f (list= eqv? '(1) '())))
1327
1328     (pass-if "empty / one"
1329       (eq? #f (list= eqv? '() '(1))))
1330
1331     (pass-if "one / one same"
1332       (eq? #t (list= eqv? '(1) '(1))))
1333
1334     (pass-if "one / one diff"
1335       (eq? #f (list= eqv? '(1) '(2))))
1336
1337     (pass-if "called arg order"
1338       (let ((good #t))
1339         (list= (lambda (x y)
1340                  (set! good (and good (= (1+ x) y)))
1341                  #t)
1342                '(1 3) '(2 4))
1343         good)))
1344
1345   (with-test-prefix "three lists"
1346
1347     (pass-if "empty / empty / empty"
1348       (eq? #t (list= eqv? '() '() '())))
1349
1350     (pass-if "one / empty / empty"
1351       (eq? #f (list= eqv? '(1) '() '())))
1352
1353     (pass-if "one / one / empty"
1354       (eq? #f (list= eqv? '(1) '(1) '())))
1355
1356     (pass-if "one / diff / empty"
1357       (eq? #f (list= eqv? '(1) '(2) '())))
1358
1359     (pass-if "one / one / one"
1360       (eq? #t (list= eqv? '(1) '(1) '(1))))
1361
1362     (pass-if "two / two / diff"
1363       (eq? #f (list= eqv? '(1 2) '(1 2) '(1 99))))
1364
1365     (pass-if "two / two / two"
1366       (eq? #t (list= eqv? '(1 2) '(1 2) '(1 2))))
1367
1368     (pass-if "called arg order"
1369       (let ((good #t))
1370         (list= (lambda (x y)
1371                  (set! good (and good (= (1+ x) y)))
1372                  #t)
1373                '(1 4) '(2 5) '(3 6))
1374         good))))
1375
1376 ;;
1377 ;; list-copy
1378 ;;
1379
1380 (with-test-prefix "list-copy"
1381   (pass-if (equal? '()          (list-copy '())))
1382   (pass-if (equal? '(1 2)       (list-copy '(1 2))))
1383   (pass-if (equal? '(1 2 3)     (list-copy '(1 2 3))))
1384   (pass-if (equal? '(1 2 3 4)   (list-copy '(1 2 3 4))))
1385   (pass-if (equal? '(1 2 3 4 5) (list-copy '(1 2 3 4 5))))
1386
1387   ;; improper lists can be copied
1388   (pass-if (equal? 1              (list-copy 1)))
1389   (pass-if (equal? '(1 . 2)       (list-copy '(1 . 2))))
1390   (pass-if (equal? '(1 2 . 3)     (list-copy '(1 2 . 3))))
1391   (pass-if (equal? '(1 2 3 . 4)   (list-copy '(1 2 3 . 4))))
1392   (pass-if (equal? '(1 2 3 4 . 5) (list-copy '(1 2 3 4 . 5)))))
1393
1394 ;;
1395 ;; list-index
1396 ;;
1397
1398 (with-test-prefix "list-index"
1399   (pass-if-exception "no args" exception:wrong-num-args
1400     (list-index))
1401
1402   (pass-if-exception "one arg" exception:wrong-num-args
1403     (list-index noop))
1404
1405   (with-test-prefix "one list"
1406
1407     (pass-if "empty list" (eq? #f (list-index symbol? '())))
1408
1409     (pass-if-exception "pred arg count 0" exception:wrong-type-arg
1410       (list-index (lambda () x) '(1 2 3)))
1411     (pass-if-exception "pred arg count 2" exception:wrong-type-arg
1412       (list-index (lambda (x y) x) '(1 2 3)))
1413
1414     (pass-if-exception "improper 1" exception:wrong-type-arg
1415       (list-index symbol? 1))
1416     (pass-if-exception "improper 2" exception:wrong-type-arg
1417       (list-index symbol? '(1 . 2)))
1418     (pass-if-exception "improper 3" exception:wrong-type-arg
1419       (list-index symbol? '(1 2 . 3)))
1420
1421     (pass-if (eqv? #f (list-index symbol? '(1))))
1422     (pass-if (eqv? 0 (list-index symbol? '(x))))
1423
1424     (pass-if (eqv? #f (list-index symbol? '(1 2))))
1425     (pass-if (eqv? 0 (list-index symbol? '(x 1))))
1426     (pass-if (eqv? 1 (list-index symbol? '(1 x))))
1427
1428     (pass-if (eqv? #f (list-index symbol? '(1 2 3))))
1429     (pass-if (eqv? 0 (list-index symbol? '(x 1 2))))
1430     (pass-if (eqv? 1 (list-index symbol? '(1 x 2))))
1431     (pass-if (eqv? 2 (list-index symbol? '(1 2 x)))))
1432
1433   (with-test-prefix "two lists"
1434     (define (sym1 x y)
1435       (symbol? x))
1436     (define (sym2 x y)
1437       (symbol? y))
1438
1439     (pass-if "arg order"
1440       (eqv? 0 (list-index (lambda (x y)
1441                             (and (= 1 x)
1442                                  (= 2 y)))
1443                           '(1) '(2))))
1444
1445     (pass-if "empty lists" (eqv? #f (list-index sym2 '() '())))
1446
1447     (pass-if-exception "pred arg count 0" exception:wrong-type-arg
1448       (list-index (lambda () #t) '(1 2 3) '(1 2 3)))
1449     (pass-if-exception "pred arg count 1" exception:wrong-type-arg
1450       (list-index (lambda (x) x) '(1 2 3) '(1 2 3)))
1451     (pass-if-exception "pred arg count 3" exception:wrong-type-arg
1452       (list-index (lambda (x y z) x) '(1 2 3) '(1 2 3)))
1453
1454     (pass-if-exception "improper first 1" exception:wrong-type-arg
1455       (list-index sym2 1 '(1 2 3)))
1456     (pass-if-exception "improper first 2" exception:wrong-type-arg
1457       (list-index sym2 '(1 . 2) '(1 2 3)))
1458     (pass-if-exception "improper first 3" exception:wrong-type-arg
1459       (list-index sym2 '(1 2 . 3) '(1 2 3)))
1460
1461     (pass-if-exception "improper second 1" exception:wrong-type-arg
1462       (list-index sym2 '(1 2 3) 1))
1463     (pass-if-exception "improper second 2" exception:wrong-type-arg
1464       (list-index sym2 '(1 2 3) '(1 . 2)))
1465     (pass-if-exception "improper second 3" exception:wrong-type-arg
1466       (list-index sym2 '(1 2 3) '(1 2 . 3)))
1467
1468     (pass-if (eqv? #f (list-index sym2 '(1) '(2))))
1469     (pass-if (eqv? 0  (list-index sym2 '(1) '(x))))
1470
1471     (pass-if (eqv? #f (list-index sym2 '(1 2) '(3 4))))
1472     (pass-if (eqv? 0  (list-index sym2 '(1 2) '(x 3))))
1473     (pass-if (eqv? 1  (list-index sym2 '(1 2) '(3 x))))
1474
1475     (pass-if (eqv? #f (list-index sym2 '(1 2 3) '(3 4 5))))
1476     (pass-if (eqv? 0  (list-index sym2 '(1 2 3) '(x 3 4))))
1477     (pass-if (eqv? 1  (list-index sym2 '(1 2 3) '(3 x 4))))
1478     (pass-if (eqv? 2  (list-index sym2 '(1 2 3) '(3 4 x))))
1479
1480     (with-test-prefix "stop shortest"
1481       (pass-if (eqv? #f (list-index sym1 '(1 2 x) '(4 5))))
1482       (pass-if (eqv? #f (list-index sym2 '(4 5) '(1 2 x))))
1483       (pass-if (eqv? #f (list-index sym1 '(3 4) '(1 2 x y))))
1484       (pass-if (eqv? #f (list-index sym2 '(1 2 x y) '(3 4))))))
1485
1486   (with-test-prefix "three lists"
1487     (define (sym1 x y z)
1488       (symbol? x))
1489     (define (sym2 x y z)
1490       (symbol? y))
1491     (define (sym3 x y z)
1492       (symbol? z))
1493
1494     (pass-if "arg order"
1495       (eqv? 0 (list-index (lambda (x y z)
1496                             (and (= 1 x)
1497                                  (= 2 y)
1498                                  (= 3 z)))
1499                           '(1) '(2) '(3))))
1500
1501     (pass-if "empty lists" (eqv? #f (list-index sym3 '() '() '())))
1502
1503     ;; currently bad pred argument gives wrong-num-args when 3 or more
1504     ;; lists, as opposed to wrong-type-arg for 1 or 2 lists
1505     (pass-if-exception "pred arg count 0" exception:wrong-num-args
1506       (list-index (lambda () #t) '(1 2 3) '(1 2 3) '(1 2 3)))
1507     (pass-if-exception "pred arg count 2" exception:wrong-num-args
1508       (list-index (lambda (x y) x) '(1 2 3) '(1 2 3)'(1 2 3) ))
1509     (pass-if-exception "pred arg count 4" exception:wrong-num-args
1510       (list-index (lambda (w x y z) x) '(1 2 3) '(1 2 3) '(1 2 3)))
1511
1512     (pass-if-exception "improper first 1" exception:wrong-type-arg
1513       (list-index sym3 1 '(1 2 3) '(1 2 3)))
1514     (pass-if-exception "improper first 2" exception:wrong-type-arg
1515       (list-index sym3 '(1 . 2) '(1 2 3) '(1 2 3)))
1516     (pass-if-exception "improper first 3" exception:wrong-type-arg
1517       (list-index sym3 '(1 2 . 3) '(1 2 3) '(1 2 3)))
1518
1519     (pass-if-exception "improper second 1" exception:wrong-type-arg
1520       (list-index sym3 '(1 2 3) 1 '(1 2 3)))
1521     (pass-if-exception "improper second 2" exception:wrong-type-arg
1522       (list-index sym3 '(1 2 3) '(1 . 2) '(1 2 3)))
1523     (pass-if-exception "improper second 3" exception:wrong-type-arg
1524       (list-index sym3 '(1 2 3) '(1 2 . 3) '(1 2 3)))
1525
1526     (pass-if-exception "improper third 1" exception:wrong-type-arg
1527       (list-index sym3 '(1 2 3) '(1 2 3) 1))
1528     (pass-if-exception "improper third 2" exception:wrong-type-arg
1529       (list-index sym3 '(1 2 3) '(1 2 3) '(1 . 2)))
1530     (pass-if-exception "improper third 3" exception:wrong-type-arg
1531       (list-index sym3 '(1 2 3) '(1 2 3) '(1 2 . 3)))
1532
1533     (pass-if (eqv? #f (list-index sym3 '(#f) '(#f) '(#f))))
1534     (pass-if (eqv? 0  (list-index sym3 '(#f) '(#f) '(x))))
1535
1536     (pass-if (eqv? #f (list-index sym3 '(#f #f) '(#f #f) '(#f #f))))
1537     (pass-if (eqv? 0  (list-index sym3 '(#f #f) '(#f #f) '(x #f))))
1538     (pass-if (eqv? 1  (list-index sym3 '(#f #f) '(#f #f) '(#f x))))
1539
1540     (pass-if (eqv? #f (list-index sym3 '(#f #f #f) '(#f #f #f) '(#f #f #f))))
1541     (pass-if (eqv? 0  (list-index sym3 '(#f #f #f) '(#f #f #f) '(x #f #f))))
1542     (pass-if (eqv? 1  (list-index sym3 '(#f #f #f) '(#f #f #f) '(#f x #f))))
1543     (pass-if (eqv? 2  (list-index sym3 '(#f #f #f) '(#f #f #f) '(#f #f x))))
1544
1545     (with-test-prefix "stop shortest"
1546       (pass-if (eqv? #f (list-index sym2 '() '(x x x) '(x x))))
1547       (pass-if (eqv? #f (list-index sym1 '(x x x) '() '(x x))))
1548       (pass-if (eqv? #f (list-index sym2 '(x x x) '(x x) '())))
1549
1550       (pass-if (eqv? #f (list-index sym2 '(#t) '(#t x x) '(#t x))))
1551       (pass-if (eqv? #f (list-index sym1 '(#t x x) '(#t) '(#t x))))
1552       (pass-if (eqv? #f (list-index sym1 '(#t x x) '(#t x) '(#t)))))
1553
1554     (pass-if "apply list unchanged"
1555       (let ((lst (list (list 1 2) (list 3 4) (list 5 6))))
1556         (and (equal? #f (apply list-index sym3 lst))
1557              ;; lst unmodified
1558              (equal? '((1 2) (3 4) (5 6)) lst))))))
1559
1560 ;;
1561 ;; list-tabulate
1562 ;;
1563
1564 (with-test-prefix "list-tabulate"
1565
1566   (pass-if-exception "-1" exception:out-of-range
1567     (list-tabulate -1 identity))
1568   (pass-if "0"
1569     (equal? '() (list-tabulate 0 identity)))
1570   (pass-if "1"
1571     (equal? '(0) (list-tabulate 1 identity)))
1572   (pass-if "2"
1573     (equal? '(0 1) (list-tabulate 2 identity)))
1574   (pass-if "3"
1575     (equal? '(0 1 2) (list-tabulate 3 identity)))
1576   (pass-if "4"
1577     (equal? '(0 1 2 3) (list-tabulate 4 identity)))
1578   (pass-if "string ref proc"
1579     (equal? '(#\a #\b #\c #\d) (list-tabulate 4
1580                                               (lambda (i)
1581                                                 (string-ref "abcd" i))))))
1582
1583 ;;
1584 ;; lset=
1585 ;;
1586
1587 (with-test-prefix "lset="
1588
1589   ;; in guile 1.6.7 and earlier, lset= incorrectly demanded at least one
1590   ;; list arg
1591   (pass-if "no args"
1592     (eq? #t (lset= eq?)))
1593
1594   (with-test-prefix "one arg"
1595
1596     (pass-if "()"
1597       (eq? #t (lset= eqv? '())))
1598
1599     (pass-if "(1)"
1600       (eq? #t (lset= eqv? '(1))))
1601
1602     (pass-if "(1 2)"
1603       (eq? #t (lset= eqv? '(1 2)))))
1604
1605   (with-test-prefix "two args"
1606
1607     (pass-if "() ()"
1608       (eq? #t (lset= eqv? '() '())))
1609
1610     (pass-if "(1) (1)"
1611       (eq? #t (lset= eqv? '(1) '(1))))
1612
1613     (pass-if "(1) (2)"
1614       (eq? #f (lset= eqv? '(1) '(2))))
1615
1616     (pass-if "(1) (1 2)"
1617       (eq? #f (lset= eqv? '(1) '(1 2))))
1618
1619     (pass-if "(1 2) (2 1)"
1620       (eq? #t (lset= eqv? '(1 2) '(2 1))))
1621
1622     (pass-if "called arg order"
1623       (let ((good #t))
1624         (lset= (lambda (x y)
1625                  (if (not (= x (1- y)))
1626                      (set! good #f))
1627                  #t)
1628                '(1 1) '(2 2))
1629         good)))
1630
1631   (with-test-prefix "three args"
1632
1633     (pass-if "() () ()"
1634       (eq? #t (lset= eqv? '() '() '())))
1635
1636     (pass-if "(1) (1) (1)"
1637       (eq? #t (lset= eqv? '(1) '(1) '(1))))
1638
1639     (pass-if "(1) (1) (2)"
1640       (eq? #f (lset= eqv? '(1) '(1) '(2))))
1641
1642     (pass-if "(1) (1) (1 2)"
1643       (eq? #f (lset= eqv? '(1) '(1) '(1 2))))
1644
1645     (pass-if "(1 2 3) (3 2 1) (1 3 2)"
1646       (eq? #t (lset= eqv? '(1 2 3) '(3 2 1) '(1 3 2))))
1647
1648     (pass-if "called arg order"
1649       (let ((good #t))
1650         (lset= (lambda (x y)
1651                  (if (not (= x (1- y)))
1652                      (set! good #f))
1653                  #t)
1654                '(1 1) '(2 2) '(3 3))
1655         good))))
1656
1657 ;;
1658 ;; lset-adjoin
1659 ;;
1660
1661 (with-test-prefix "lset-adjoin"
1662
1663   ;; in guile 1.6.7 and earlier, lset-adjoin didn't actually use the given
1664   ;; `=' procedure, all comparisons were just with `equal?
1665   ;;
1666   (with-test-prefix "case-insensitive ="
1667
1668     (pass-if "(\"x\") \"X\""
1669       (equal? '("x") (lset-adjoin string-ci=? '("x") "X"))))
1670
1671   (pass-if "called arg order"
1672     (let ((good #f))
1673       (lset-adjoin (lambda (x y)
1674                      (set! good (and (= x 1) (= y 2)))
1675                      (= x y))
1676                    '(1) 2)
1677       good))
1678
1679   (pass-if (equal? '() (lset-adjoin = '())))
1680
1681   (pass-if (equal? '(1) (lset-adjoin = '() 1)))
1682
1683   (pass-if (equal? '(1) (lset-adjoin = '() 1 1)))
1684
1685   (pass-if (equal? '(2 1) (lset-adjoin = '() 1 2)))
1686
1687   (pass-if (equal? '(3 1 2) (lset-adjoin = '(1 2) 1 2 3 2 1)))
1688
1689   (pass-if "apply list unchanged"
1690     (let ((lst (list 1 2)))
1691       (and (equal? '(2 1 3) (apply lset-adjoin = '(3) lst))
1692            ;; lst unmodified
1693            (equal? '(1 2) lst))))
1694
1695   (pass-if "(1 1) 1 1"
1696     (equal? '(1 1) (lset-adjoin = '(1 1) 1 1)))
1697
1698   ;; duplicates among args are cast out
1699   (pass-if "(2) 1 1"
1700     (equal? '(1 2) (lset-adjoin = '(2) 1 1))))
1701
1702 ;;
1703 ;; lset-difference
1704 ;;
1705
1706 (with-test-prefix "lset-difference"
1707
1708   (pass-if "called arg order"
1709     (let ((good #f))
1710       (lset-difference (lambda (x y)
1711                          (set! good (and (= x 1) (= y 2)))
1712                          (= x y))
1713                        '(1) '(2))
1714       good)))
1715
1716 ;;
1717 ;; lset-difference!
1718 ;;
1719
1720 (with-test-prefix "lset-difference!"
1721
1722   (pass-if-exception "proc - num" exception:wrong-type-arg
1723     (lset-difference! 123 '(4)))
1724   (pass-if-exception "proc - list" exception:wrong-type-arg
1725     (lset-difference! (list 1 2 3) '(4)))
1726
1727   (pass-if "called arg order"
1728     (let ((good #f))
1729       (lset-difference! (lambda (x y)
1730                           (set! good (and (= x 1) (= y 2)))
1731                           (= x y))
1732                         (list 1) (list 2))
1733       good))
1734
1735   (pass-if (equal? '() (lset-difference! = '())))
1736   (pass-if (equal? '(1) (lset-difference! = (list 1))))
1737   (pass-if (equal? '(1 2) (lset-difference! = (list 1 2))))
1738
1739   (pass-if (equal? '() (lset-difference! = (list ) '(3))))
1740   (pass-if (equal? '() (lset-difference! = (list 3) '(3))))
1741   (pass-if (equal? '(1) (lset-difference! = (list 1 3) '(3))))
1742   (pass-if (equal? '(1) (lset-difference! = (list 3 1) '(3))))
1743   (pass-if (equal? '(1) (lset-difference! = (list 1 3 3) '(3))))
1744   (pass-if (equal? '(1) (lset-difference! = (list 3 1 3) '(3))))
1745   (pass-if (equal? '(1) (lset-difference! = (list 3 3 1) '(3))))
1746
1747   (pass-if (equal? '(1) (lset-difference! = (list 1 2 3) '(2 3))))
1748   (pass-if (equal? '(1) (lset-difference! = (list 1 2 3) '(3 2))))
1749   (pass-if (equal? '(1) (lset-difference! = (list 1 2 3) '(3) '(2))))
1750   (pass-if (equal? '(1) (lset-difference! = (list 1 2 3) '(2) '(3))))
1751   (pass-if (equal? '(1) (lset-difference! = (list 1 2 3) '(2) '(2 3))))
1752   (pass-if (equal? '(1) (lset-difference! = (list 1 2 3) '(2) '(3 2))))
1753
1754   (pass-if (equal? '(1 2) (lset-difference! = (list 1 2 3) '(3) '(3))))
1755   (pass-if (equal? '(1 2) (lset-difference! = (list 1 3 2) '(3) '(3))))
1756   (pass-if (equal? '(1 2) (lset-difference! = (list 3 1 2) '(3) '(3))))
1757
1758   (pass-if (equal? '(1 2 3) (lset-difference! = (list 1 2 3 4) '(4))))
1759   (pass-if (equal? '(1 2 3) (lset-difference! = (list 1 2 4 3) '(4))))
1760   (pass-if (equal? '(1 2 3) (lset-difference! = (list 1 4 2 3) '(4))))
1761   (pass-if (equal? '(1 2 3) (lset-difference! = (list 4 1 2 3) '(4))))
1762
1763   (pass-if (equal? '(1 2) (lset-difference! = (list 1 2 3 4) '(4) '(3))))
1764   (pass-if (equal? '(1 2) (lset-difference! = (list 1 3 2 4) '(4) '(3))))
1765   (pass-if (equal? '(1 2) (lset-difference! = (list 3 1 2 4) '(4) '(3))))
1766   (pass-if (equal? '(1 2) (lset-difference! = (list 1 3 4 2) '(4) '(3))))
1767   (pass-if (equal? '(1 2) (lset-difference! = (list 3 1 4 2) '(4) '(3))))
1768   (pass-if (equal? '(1 2) (lset-difference! = (list 3 4 1 2) '(4) '(3)))))
1769
1770 ;;
1771 ;; lset-diff+intersection
1772 ;;
1773
1774 (with-test-prefix "lset-diff+intersection"
1775
1776   (pass-if "called arg order"
1777     (let ((good #f))
1778       (lset-diff+intersection (lambda (x y)
1779                                 (set! good (and (= x 1) (= y 2)))
1780                                 (= x y))
1781                               '(1) '(2))
1782       good)))
1783
1784 ;;
1785 ;; lset-diff+intersection!
1786 ;;
1787
1788 (with-test-prefix "lset-diff+intersection"
1789
1790   (pass-if "called arg order"
1791     (let ((good #f))
1792       (lset-diff+intersection (lambda (x y)
1793                                 (set! good (and (= x 1) (= y 2)))
1794                                 (= x y))
1795                               (list 1) (list 2))
1796       good)))
1797
1798 ;;
1799 ;; lset-intersection
1800 ;;
1801
1802 (with-test-prefix "lset-intersection"
1803
1804   (pass-if "called arg order"
1805     (let ((good #f))
1806       (lset-intersection (lambda (x y)
1807                            (set! good (and (= x 1) (= y 2)))
1808                            (= x y))
1809                          '(1) '(2))
1810       good)))
1811
1812 ;;
1813 ;; lset-intersection!
1814 ;;
1815
1816 (with-test-prefix "lset-intersection"
1817
1818   (pass-if "called arg order"
1819     (let ((good #f))
1820       (lset-intersection (lambda (x y)
1821                            (set! good (and (= x 1) (= y 2)))
1822                            (= x y))
1823                          (list 1) (list 2))
1824       good)))
1825
1826 ;;
1827 ;; lset-union
1828 ;;
1829
1830 (with-test-prefix "lset-union"
1831
1832   (pass-if "no args"
1833     (eq? '() (lset-union eq?)))
1834
1835   (pass-if "one arg"
1836     (equal? '(1 2 3) (lset-union eq? '(1 2 3))))
1837
1838   (pass-if "'() '()"
1839     (equal? '() (lset-union eq? '() '())))
1840
1841   (pass-if "'() '(1 2 3)"
1842     (equal? '(1 2 3) (lset-union eq? '() '(1 2 3))))
1843
1844   (pass-if "'(1 2 3) '()"
1845     (equal? '(1 2 3) (lset-union eq? '(1 2 3) '())))
1846
1847   (pass-if "'(1 2 3) '(4 3 5)"
1848     (equal? '(5 4 1 2 3) (lset-union eq? '(1 2 3) '(4 3 5))))
1849
1850   (pass-if "'(1 2 3) '(4) '(3 5))"
1851     (equal? '(5 4 1 2 3) (lset-union eq? '(1 2 3) '(4) '(3 5))))
1852
1853   ;; in guile 1.6.7 and earlier, `=' was called with the arguments the wrong
1854   ;; way around
1855   (pass-if "called arg order"
1856     (let ((good #f))
1857       (lset-union (lambda (x y)
1858                     (set! good (and (= x 1) (= y 2)))
1859                     (= x y))
1860                   '(1) '(2))
1861       good)))
1862
1863 ;;
1864 ;; member
1865 ;;
1866
1867 (with-test-prefix "member"
1868
1869   (pass-if-exception "no args" exception:wrong-num-args
1870     (member))
1871
1872   (pass-if-exception "one arg" exception:wrong-num-args
1873     (member 1))
1874
1875   (pass-if "1 (1 2 3)"
1876     (let ((lst '(1 2 3)))
1877       (eq? lst (member 1 lst))))
1878
1879   (pass-if "2 (1 2 3)"
1880     (let ((lst '(1 2 3)))
1881       (eq? (cdr lst) (member 2 lst))))
1882
1883   (pass-if "3 (1 2 3)"
1884     (let ((lst '(1 2 3)))
1885       (eq? (cddr lst) (member 3 lst))))
1886
1887   (pass-if "4 (1 2 3)"
1888     (let ((lst '(1 2 3)))
1889       (eq? #f (member 4 lst))))
1890
1891   (pass-if "called arg order"
1892     (let ((good #f))
1893       (member 1 '(2) (lambda (x y)
1894                        (set! good (and (eqv? 1 x)
1895                                        (eqv? 2 y)))))
1896       good)))
1897
1898 ;;
1899 ;; ninth
1900 ;;
1901
1902 (with-test-prefix "ninth"
1903   (pass-if-exception "() -1" exception:out-of-range
1904     (ninth '(a b c d e f g h)))
1905   (pass-if (eq? 'i (ninth '(a b c d e f g h i))))
1906   (pass-if (eq? 'i (ninth '(a b c d e f g h i j)))))
1907
1908
1909 ;;
1910 ;; not-pair?
1911 ;;
1912
1913 (with-test-prefix "not-pair?"
1914   (pass-if "inum"
1915     (eq? #t (not-pair? 123)))
1916   (pass-if "pair"
1917     (eq? #f (not-pair? '(x . y))))
1918   (pass-if "symbol"
1919     (eq? #t (not-pair? 'x))))
1920
1921 ;;
1922 ;; take
1923 ;;
1924
1925 (with-test-prefix "take"
1926
1927   (pass-if "'() 0"
1928     (null? (take '() 0)))
1929
1930   (pass-if "'(a) 0"
1931     (null? (take '(a) 0)))
1932
1933   (pass-if "'(a b) 0"
1934     (null? (take '() 0)))
1935
1936   (pass-if "'(a b c) 0"
1937     (null? (take '() 0)))
1938
1939   (pass-if "'(a) 1"
1940     (let* ((lst '(a))
1941            (got (take lst 1)))
1942       (and (equal? '(a) got)
1943            (not (eq? lst got)))))
1944
1945   (pass-if "'(a b) 1"
1946     (equal? '(a)
1947             (take '(a b) 1)))
1948
1949   (pass-if "'(a b c) 1"
1950     (equal? '(a)
1951             (take '(a b c) 1)))
1952
1953   (pass-if "'(a b) 2"
1954     (let* ((lst '(a b))
1955            (got (take lst 2)))
1956       (and (equal? '(a b) got)
1957            (not (eq? lst got)))))
1958
1959   (pass-if "'(a b c) 2"
1960     (equal? '(a b)
1961             (take '(a b c) 2)))
1962
1963   (pass-if "circular '(a) 0"
1964     (equal? '()
1965             (take (circular-list 'a) 0)))
1966
1967   (pass-if "circular '(a) 1"
1968     (equal? '(a)
1969             (take (circular-list 'a) 1)))
1970
1971   (pass-if "circular '(a) 2"
1972     (equal? '(a a)
1973             (take (circular-list 'a) 2)))
1974
1975   (pass-if "circular '(a b) 5"
1976     (equal? '(a b a b a)
1977             (take (circular-list 'a 'b) 5)))
1978
1979   (pass-if "'(a . b) 1"
1980     (equal? '(a)
1981             (take '(a . b) 1)))
1982
1983   (pass-if "'(a b . c) 1"
1984     (equal? '(a)
1985             (take '(a b . c) 1)))
1986
1987   (pass-if "'(a b . c) 2"
1988     (equal? '(a b)
1989             (take '(a b . c) 2))))
1990
1991 ;;
1992 ;; take-while
1993 ;;
1994
1995 (with-test-prefix "take-while"
1996
1997   (pass-if (equal? '()      (take-while odd? '())))
1998   (pass-if (equal? '(1)     (take-while odd? '(1))))
1999   (pass-if (equal? '(1 3)   (take-while odd? '(1 3))))
2000   (pass-if (equal? '(1 3 5) (take-while odd? '(1 3 5))))
2001
2002   (pass-if (equal? '()      (take-while odd? '(2))))
2003   (pass-if (equal? '(1)     (take-while odd? '(1 2))))
2004   (pass-if (equal? '(1 3)   (take-while odd? '(1 3 4))))
2005
2006   (pass-if (equal? '()      (take-while odd? '(2 1))))
2007   (pass-if (equal? '(1)     (take-while odd? '(1 4 3))))
2008   (pass-if (equal? '()      (take-while odd? '(4 1 3)))))
2009
2010 ;;
2011 ;; take-while!
2012 ;;
2013
2014 (with-test-prefix "take-while!"
2015
2016   (pass-if (equal? '()      (take-while! odd? '())))
2017   (pass-if (equal? '(1)     (take-while! odd? (list 1))))
2018   (pass-if (equal? '(1 3)   (take-while! odd? (list 1 3))))
2019   (pass-if (equal? '(1 3 5) (take-while! odd? (list 1 3 5))))
2020
2021   (pass-if (equal? '()      (take-while! odd? (list 2))))
2022   (pass-if (equal? '(1)     (take-while! odd? (list 1 2))))
2023   (pass-if (equal? '(1 3)   (take-while! odd? (list 1 3 4))))
2024
2025   (pass-if (equal? '()      (take-while! odd? (list 2 1))))
2026   (pass-if (equal? '(1)     (take-while! odd? (list 1 4 3))))
2027   (pass-if (equal? '()      (take-while! odd? (list 4 1 3)))))
2028
2029 ;;
2030 ;; partition
2031 ;;
2032
2033 (define (test-partition pred list kept-good dropped-good)
2034   (call-with-values (lambda ()
2035                         (partition pred list))
2036       (lambda (kept dropped)
2037         (and (equal? kept kept-good)
2038              (equal? dropped dropped-good)))))
2039
2040 (with-test-prefix "partition"
2041
2042   (pass-if "with dropped tail"
2043     (test-partition even? '(1 2 3 4 5 6 7)
2044                     '(2 4 6) '(1 3 5 7)))
2045
2046   (pass-if "with kept tail"
2047     (test-partition even? '(1 2 3 4 5 6)
2048                     '(2 4 6) '(1 3 5)))
2049
2050   (pass-if "with everything dropped"
2051     (test-partition even? '(1 3 5 7)
2052                     '() '(1 3 5 7)))
2053
2054   (pass-if "with everything kept"
2055     (test-partition even? '(2 4 6)
2056                     '(2 4 6) '()))
2057
2058   (pass-if "with empty list"
2059     (test-partition even? '()
2060                     '() '()))
2061
2062   (pass-if "with reasonably long list"
2063     ;; the old implementation from SRFI-1 reference implementation
2064     ;; would signal a stack-overflow for a list of only 500 elements!
2065     (call-with-values (lambda ()
2066                         (partition even?
2067                                    (make-list 10000 1)))
2068       (lambda (even odd)
2069         (and (= (length odd) 10000)
2070              (= (length even) 0)))))
2071
2072   (pass-if-exception "with improper list"
2073     exception:wrong-type-arg
2074     (partition symbol? '(a b . c))))
2075
2076 ;;
2077 ;; partition!
2078 ;;
2079
2080 (define (test-partition! pred list kept-good dropped-good)
2081   (call-with-values (lambda ()
2082                         (partition! pred list))
2083       (lambda (kept dropped)
2084         (and (equal? kept kept-good)
2085              (equal? dropped dropped-good)))))
2086
2087 (with-test-prefix "partition!"
2088
2089   (pass-if "with dropped tail"
2090     (test-partition! even? (list 1 2 3 4 5 6 7)
2091                      '(2 4 6) '(1 3 5 7)))
2092
2093   (pass-if "with kept tail"
2094     (test-partition! even? (list 1 2 3 4 5 6)
2095                      '(2 4 6) '(1 3 5)))
2096
2097   (pass-if "with everything dropped"
2098     (test-partition! even? (list 1 3 5 7)
2099                      '() '(1 3 5 7)))
2100
2101   (pass-if "with everything kept"
2102     (test-partition! even? (list 2 4 6)
2103                      '(2 4 6) '()))
2104
2105   (pass-if "with empty list"
2106     (test-partition! even? '()
2107                      '() '()))
2108
2109   (pass-if "with reasonably long list"
2110     ;; the old implementation from SRFI-1 reference implementation
2111     ;; would signal a stack-overflow for a list of only 500 elements!
2112     (call-with-values (lambda ()
2113                         (partition! even?
2114                                     (make-list 10000 1)))
2115       (lambda (even odd)
2116         (and (= (length odd) 10000)
2117              (= (length even) 0)))))
2118
2119   (pass-if-exception "with improper list"
2120     exception:wrong-type-arg
2121     (partition! symbol? (cons* 'a 'b 'c))))
2122
2123 ;;
2124 ;; reduce
2125 ;;
2126
2127 (with-test-prefix "reduce"
2128
2129   (pass-if "empty"
2130     (let* ((calls '())
2131            (ret   (reduce (lambda (x prev)
2132                             (set! calls (cons (list x prev) calls))
2133                             x)
2134                           1 '())))
2135       (and (equal? calls '())
2136            (equal? ret   1))))
2137
2138   (pass-if "one elem"
2139     (let* ((calls '())
2140            (ret   (reduce (lambda (x prev)
2141                             (set! calls (cons (list x prev) calls))
2142                             x)
2143                           1 '(2))))
2144       (and (equal? calls '())
2145            (equal? ret   2))))
2146
2147   (pass-if "two elems"
2148     (let* ((calls '())
2149            (ret   (reduce (lambda (x prev)
2150                             (set! calls (cons (list x prev) calls))
2151                             x)
2152                           1 '(2 3))))
2153       (and (equal? calls '((3 2)))
2154            (equal? ret   3))))
2155
2156   (pass-if "three elems"
2157     (let* ((calls '())
2158            (ret   (reduce (lambda (x prev)
2159                             (set! calls (cons (list x prev) calls))
2160                             x)
2161                           1 '(2 3 4))))
2162       (and (equal? calls '((4 3)
2163                            (3 2)))
2164            (equal? ret   4))))
2165
2166   (pass-if "four elems"
2167     (let* ((calls '())
2168            (ret   (reduce (lambda (x prev)
2169                             (set! calls (cons (list x prev) calls))
2170                             x)
2171                           1 '(2 3 4 5))))
2172       (and (equal? calls '((5 4)
2173                            (4 3)
2174                            (3 2)))
2175            (equal? ret   5)))))
2176
2177 ;;
2178 ;; reduce-right
2179 ;;
2180
2181 (with-test-prefix "reduce-right"
2182
2183   (pass-if "empty"
2184     (let* ((calls '())
2185            (ret   (reduce-right (lambda (x prev)
2186                                   (set! calls (cons (list x prev) calls))
2187                                   x)
2188                                 1 '())))
2189       (and (equal? calls '())
2190            (equal? ret   1))))
2191
2192   (pass-if "one elem"
2193     (let* ((calls '())
2194            (ret   (reduce-right (lambda (x prev)
2195                                   (set! calls (cons (list x prev) calls))
2196                                   x)
2197                                 1 '(2))))
2198       (and (equal? calls '())
2199            (equal? ret   2))))
2200
2201   (pass-if "two elems"
2202     (let* ((calls '())
2203            (ret   (reduce-right (lambda (x prev)
2204                                   (set! calls (cons (list x prev) calls))
2205                                   x)
2206                                 1 '(2 3))))
2207       (and (equal? calls '((2 3)))
2208            (equal? ret   2))))
2209
2210   (pass-if "three elems"
2211     (let* ((calls '())
2212            (ret   (reduce-right (lambda (x prev)
2213                                   (set! calls (cons (list x prev) calls))
2214                                   x)
2215                                 1 '(2 3 4))))
2216       (and (equal? calls '((2 3)
2217                            (3 4)))
2218            (equal? ret   2))))
2219
2220   (pass-if "four elems"
2221     (let* ((calls '())
2222            (ret   (reduce-right (lambda (x prev)
2223                                   (set! calls (cons (list x prev) calls))
2224                                   x)
2225                                 1 '(2 3 4 5))))
2226       (and (equal? calls '((2 3)
2227                            (3 4)
2228                            (4 5)))
2229            (equal? ret   2)))))
2230
2231 ;;
2232 ;; remove
2233 ;;
2234
2235 (with-test-prefix "remove"
2236
2237   (pass-if (equal? '() (remove odd? '())))
2238   (pass-if (equal? '() (remove odd? '(1))))
2239   (pass-if (equal? '(2) (remove odd? '(2))))
2240
2241   (pass-if (equal? '() (remove odd? '(1 3))))
2242   (pass-if (equal? '(2) (remove odd? '(2 3))))
2243   (pass-if (equal? '(2) (remove odd? '(1 2))))
2244   (pass-if (equal? '(2 4) (remove odd? '(2 4))))
2245
2246   (pass-if (equal? '() (remove odd? '(1 3 5))))
2247   (pass-if (equal? '(2) (remove odd? '(2 3 5))))
2248   (pass-if (equal? '(2) (remove odd? '(1 2 5))))
2249   (pass-if (equal? '(2 4) (remove odd? '(2 4 5))))
2250
2251   (pass-if (equal? '(6) (remove odd? '(1 3 6))))
2252   (pass-if (equal? '(2 6) (remove odd? '(2 3 6))))
2253   (pass-if (equal? '(2 6) (remove odd? '(1 2 6))))
2254   (pass-if (equal? '(2 4 6) (remove odd? '(2 4 6)))))
2255
2256 ;;
2257 ;; remove!
2258 ;;
2259
2260 (with-test-prefix "remove!"
2261
2262   (pass-if (equal? '() (remove! odd? '())))
2263   (pass-if (equal? '() (remove! odd? (list 1))))
2264   (pass-if (equal? '(2) (remove! odd? (list 2))))
2265
2266   (pass-if (equal? '() (remove! odd? (list 1 3))))
2267   (pass-if (equal? '(2) (remove! odd? (list 2 3))))
2268   (pass-if (equal? '(2) (remove! odd? (list 1 2))))
2269   (pass-if (equal? '(2 4) (remove! odd? (list 2 4))))
2270
2271   (pass-if (equal? '() (remove! odd? (list 1 3 5))))
2272   (pass-if (equal? '(2) (remove! odd? (list 2 3 5))))
2273   (pass-if (equal? '(2) (remove! odd? (list 1 2 5))))
2274   (pass-if (equal? '(2 4) (remove! odd? (list 2 4 5))))
2275
2276   (pass-if (equal? '(6) (remove! odd? (list 1 3 6))))
2277   (pass-if (equal? '(2 6) (remove! odd? (list 2 3 6))))
2278   (pass-if (equal? '(2 6) (remove! odd? (list 1 2 6))))
2279   (pass-if (equal? '(2 4 6) (remove! odd? (list 2 4 6)))))
2280
2281 ;;
2282 ;; seventh
2283 ;;
2284
2285 (with-test-prefix "seventh"
2286   (pass-if-exception "() -1" exception:out-of-range
2287     (seventh '(a b c d e f)))
2288   (pass-if (eq? 'g (seventh '(a b c d e f g))))
2289   (pass-if (eq? 'g (seventh '(a b c d e f g h)))))
2290
2291 ;;
2292 ;; sixth
2293 ;;
2294
2295 (with-test-prefix "sixth"
2296   (pass-if-exception "() -1" exception:out-of-range
2297     (sixth '(a b c d e)))
2298   (pass-if (eq? 'f (sixth '(a b c d e f))))
2299   (pass-if (eq? 'f (sixth '(a b c d e f g)))))
2300
2301 ;;
2302 ;; split-at
2303 ;;
2304
2305 (with-test-prefix "split-at"
2306
2307   (define (equal-values? lst thunk)
2308     (call-with-values thunk
2309       (lambda got
2310         (equal? lst got))))
2311
2312   (pass-if-exception "() -1" exception:out-of-range
2313     (split-at '() -1))
2314   (pass-if (equal-values? '(() ())
2315                           (lambda () (split-at '() 0))))
2316   (pass-if-exception "() 1" exception:wrong-type-arg
2317     (split-at '() 1))
2318
2319   (pass-if-exception "(1) -1" exception:out-of-range
2320     (split-at '(1) -1))
2321   (pass-if (equal-values? '(() (1)) (lambda () (split-at '(1) 0))))
2322   (pass-if (equal-values? '((1) ()) (lambda () (split-at '(1) 1))))
2323   (pass-if-exception "(1) 2" exception:wrong-type-arg
2324     (split-at '(1) 2))
2325
2326   (pass-if-exception "(4 5) -1" exception:out-of-range
2327     (split-at '(4 5) -1))
2328   (pass-if (equal-values? '(() (4 5)) (lambda () (split-at '(4 5) 0))))
2329   (pass-if (equal-values? '((4) (5)) (lambda () (split-at '(4 5) 1))))
2330   (pass-if (equal-values? '((4 5) ()) (lambda () (split-at '(4 5) 2))))
2331   (pass-if-exception "(4 5) 3" exception:wrong-type-arg
2332     (split-at '(4 5) 3))
2333
2334   (pass-if-exception "(4 5 6) -1" exception:out-of-range
2335     (split-at '(4 5 6) -1))
2336   (pass-if (equal-values? '(() (4 5 6)) (lambda () (split-at '(4 5 6) 0))))
2337   (pass-if (equal-values? '((4) (5 6)) (lambda () (split-at '(4 5 6) 1))))
2338   (pass-if (equal-values? '((4 5) (6)) (lambda () (split-at '(4 5 6) 2))))
2339   (pass-if (equal-values? '((4 5 6) ()) (lambda () (split-at '(4 5 6) 3))))
2340   (pass-if-exception "(4 5 6) 4" exception:wrong-type-arg
2341     (split-at '(4 5 6) 4)))
2342
2343 ;;
2344 ;; split-at!
2345 ;;
2346
2347 (with-test-prefix "split-at!"
2348
2349   (define (equal-values? lst thunk)
2350     (call-with-values thunk
2351       (lambda got
2352         (equal? lst got))))
2353
2354   (pass-if-exception "() -1" exception:out-of-range
2355     (split-at! '() -1))
2356   (pass-if (equal-values? '(() ())
2357                           (lambda () (split-at! '() 0))))
2358   (pass-if-exception "() 1" exception:wrong-type-arg
2359     (split-at! '() 1))
2360
2361   (pass-if-exception "(1) -1" exception:out-of-range
2362     (split-at! (list 1) -1))
2363   (pass-if (equal-values? '(() (1)) (lambda () (split-at! (list 1) 0))))
2364   (pass-if (equal-values? '((1) ()) (lambda () (split-at! (list 1) 1))))
2365   (pass-if-exception "(1) 2" exception:wrong-type-arg
2366     (split-at! (list 1) 2))
2367
2368   (pass-if-exception "(4 5) -1" exception:out-of-range
2369     (split-at! (list 4 5) -1))
2370   (pass-if (equal-values? '(() (4 5)) (lambda () (split-at! (list 4 5) 0))))
2371   (pass-if (equal-values? '((4) (5))  (lambda () (split-at! (list 4 5) 1))))
2372   (pass-if (equal-values? '((4 5) ()) (lambda () (split-at! (list 4 5) 2))))
2373   (pass-if-exception "(4 5) 3" exception:wrong-type-arg
2374     (split-at! (list 4 5) 3))
2375
2376   (pass-if-exception "(4 5 6) -1" exception:out-of-range
2377     (split-at! (list 4 5 6) -1))
2378   (pass-if (equal-values? '(() (4 5 6)) (lambda () (split-at! (list 4 5 6) 0))))
2379   (pass-if (equal-values? '((4) (5 6))  (lambda () (split-at! (list 4 5 6) 1))))
2380   (pass-if (equal-values? '((4 5) (6))  (lambda () (split-at! (list 4 5 6) 2))))
2381   (pass-if (equal-values? '((4 5 6) ()) (lambda () (split-at! (list 4 5 6) 3))))
2382   (pass-if-exception "(4 5 6) 4" exception:wrong-type-arg
2383     (split-at! (list 4 5 6) 4)))
2384
2385 ;;
2386 ;; span
2387 ;;
2388
2389 (with-test-prefix "span"
2390
2391   (define (test-span lst want-v1 want-v2)
2392     (call-with-values
2393         (lambda ()
2394           (span positive? lst))
2395       (lambda (got-v1 got-v2)
2396         (and (equal? got-v1 want-v1)
2397              (equal? got-v2 want-v2)))))
2398
2399   (pass-if "empty"
2400     (test-span '() '() '()))
2401
2402   (pass-if "y"
2403     (test-span '(1) '(1) '()))
2404
2405   (pass-if "n"
2406     (test-span '(-1) '() '(-1)))
2407
2408   (pass-if "yy"
2409     (test-span '(1 2) '(1 2) '()))
2410
2411   (pass-if "ny"
2412     (test-span '(-1 1) '() '(-1 1)))
2413
2414   (pass-if "yn"
2415     (test-span '(1 -1) '(1) '(-1)))
2416
2417   (pass-if "nn"
2418     (test-span '(-1 -2) '() '(-1 -2)))
2419
2420   (pass-if "yyy"
2421     (test-span '(1 2 3) '(1 2 3) '()))
2422
2423   (pass-if "nyy"
2424     (test-span '(-1 1 2) '() '(-1 1 2)))
2425
2426   (pass-if "yny"
2427     (test-span '(1 -1 2) '(1) '(-1 2)))
2428
2429   (pass-if "nny"
2430     (test-span '(-1 -2 1) '() '(-1 -2 1)))
2431
2432   (pass-if "yyn"
2433     (test-span '(1 2 -1) '(1 2) '(-1)))
2434
2435   (pass-if "nyn"
2436     (test-span '(-1 1 -2) '() '(-1 1 -2)))
2437
2438   (pass-if "ynn"
2439     (test-span '(1 -1 -2) '(1) '(-1 -2)))
2440
2441   (pass-if "nnn"
2442     (test-span '(-1 -2 -3) '() '(-1 -2 -3))))
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! (list 1) '(1) '()))
2463
2464   (pass-if "n"
2465     (test-span! (list -1) '() '(-1)))
2466
2467   (pass-if "yy"
2468     (test-span! (list 1 2) '(1 2) '()))
2469
2470   (pass-if "ny"
2471     (test-span! (list -1 1) '() '(-1 1)))
2472
2473   (pass-if "yn"
2474     (test-span! (list 1 -1) '(1) '(-1)))
2475
2476   (pass-if "nn"
2477     (test-span! (list -1 -2) '() '(-1 -2)))
2478
2479   (pass-if "yyy"
2480     (test-span! (list 1 2 3) '(1 2 3) '()))
2481
2482   (pass-if "nyy"
2483     (test-span! (list -1 1 2) '() '(-1 1 2)))
2484
2485   (pass-if "yny"
2486     (test-span! (list 1 -1 2) '(1) '(-1 2)))
2487
2488   (pass-if "nny"
2489     (test-span! (list -1 -2 1) '() '(-1 -2 1)))
2490
2491   (pass-if "yyn"
2492     (test-span! (list 1 2 -1) '(1 2) '(-1)))
2493
2494   (pass-if "nyn"
2495     (test-span! (list -1 1 -2) '() '(-1 1 -2)))
2496
2497   (pass-if "ynn"
2498     (test-span! (list 1 -1 -2) '(1) '(-1 -2)))
2499
2500   (pass-if "nnn"
2501     (test-span! (list -1 -2 -3) '() '(-1 -2 -3))))
2502
2503 ;;
2504 ;; take!
2505 ;;
2506
2507 (with-test-prefix "take!"
2508
2509   (pass-if-exception "() -1" exception:out-of-range
2510     (take! '() -1))
2511   (pass-if (equal? '() (take! '() 0)))
2512   (pass-if-exception "() 1" exception:wrong-type-arg
2513     (take! '() 1))
2514
2515   (pass-if-exception "(1) -1" exception:out-of-range
2516     (take! '(1) -1))
2517   (pass-if (equal? '() (take! '(1) 0)))
2518   (pass-if (equal? '(1) (take! '(1) 1)))
2519   (pass-if-exception "(1) 2" exception:wrong-type-arg
2520     (take! '(1) 2))
2521
2522   (pass-if-exception "(4 5) -1" exception:out-of-range
2523     (take! '(4 5) -1))
2524   (pass-if (equal? '() (take! '(4 5) 0)))
2525   (pass-if (equal? '(4) (take! '(4 5) 1)))
2526   (pass-if (equal? '(4 5) (take! '(4 5) 2)))
2527   (pass-if-exception "(4 5) 3" exception:wrong-type-arg
2528     (take! '(4 5) 3))
2529
2530   (pass-if-exception "(4 5 6) -1" exception:out-of-range
2531     (take! '(4 5 6) -1))
2532   (pass-if (equal? '() (take! '(4 5 6) 0)))
2533   (pass-if (equal? '(4) (take! '(4 5 6) 1)))
2534   (pass-if (equal? '(4 5) (take! '(4 5 6) 2)))
2535   (pass-if (equal? '(4 5 6) (take! '(4 5 6) 3)))
2536   (pass-if-exception "(4 5 6) 4" exception:wrong-type-arg
2537     (take! '(4 5 6) 4)))
2538
2539
2540 ;;
2541 ;; take-right
2542 ;;
2543
2544 (with-test-prefix "take-right"
2545
2546   (pass-if-exception "() -1" exception:out-of-range
2547     (take-right '() -1))
2548   (pass-if (equal? '() (take-right '() 0)))
2549   (pass-if-exception "() 1" exception:wrong-type-arg
2550     (take-right '() 1))
2551
2552   (pass-if-exception "(1) -1" exception:out-of-range
2553     (take-right '(1) -1))
2554   (pass-if (equal? '() (take-right '(1) 0)))
2555   (pass-if (equal? '(1) (take-right '(1) 1)))
2556   (pass-if-exception "(1) 2" exception:wrong-type-arg
2557     (take-right '(1) 2))
2558
2559   (pass-if-exception "(4 5) -1" exception:out-of-range
2560     (take-right '(4 5) -1))
2561   (pass-if (equal? '() (take-right '(4 5) 0)))
2562   (pass-if (equal? '(5) (take-right '(4 5) 1)))
2563   (pass-if (equal? '(4 5) (take-right '(4 5) 2)))
2564   (pass-if-exception "(4 5) 3" exception:wrong-type-arg
2565     (take-right '(4 5) 3))
2566
2567   (pass-if-exception "(4 5 6) -1" exception:out-of-range
2568     (take-right '(4 5 6) -1))
2569   (pass-if (equal? '() (take-right '(4 5 6) 0)))
2570   (pass-if (equal? '(6) (take-right '(4 5 6) 1)))
2571   (pass-if (equal? '(5 6) (take-right '(4 5 6) 2)))
2572   (pass-if (equal? '(4 5 6) (take-right '(4 5 6) 3)))
2573   (pass-if-exception "(4 5 6) 4" exception:wrong-type-arg
2574     (take-right '(4 5 6) 4)))
2575
2576 ;;
2577 ;; tenth
2578 ;;
2579
2580 (with-test-prefix "tenth"
2581   (pass-if-exception "() -1" exception:out-of-range
2582     (tenth '(a b c d e f g h i)))
2583   (pass-if (eq? 'j (tenth '(a b c d e f g h i j))))
2584   (pass-if (eq? 'j (tenth '(a b c d e f g h i j k)))))
2585
2586 ;;
2587 ;; xcons
2588 ;;
2589
2590 (with-test-prefix "xcons"
2591   (pass-if (equal? '(y . x) (xcons 'x 'y))))