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