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