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., 51 Franklin Street, Fifth Floor,
  18 ;;;; Boston, MA 02110-1301 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-difference
1595 ;;
1596
1597 (with-test-prefix "lset-difference"
1598
1599   (pass-if "called arg order"
1600     (let ((good #f))
1601       (lset-difference (lambda (x y)
1602                          (set! good (and (= x 1) (= y 2)))
1603                          (= x y))
1604                        '(1) '(2))
1605       good)))
1606
1607 ;;
1608 ;; lset-difference!
1609 ;;
1610
1611 (with-test-prefix "lset-difference!"
1612
1613   (pass-if-exception "proc - num" exception:wrong-type-arg
1614     (lset-difference! 123 '(4)))
1615   (pass-if-exception "proc - list" exception:wrong-type-arg
1616     (lset-difference! (list 1 2 3) '(4)))
1617
1618   (pass-if "called arg order"
1619     (let ((good #f))
1620       (lset-difference! (lambda (x y)
1621                           (set! good (and (= x 1) (= y 2)))
1622                           (= x y))
1623                         (list 1) (list 2))
1624       good))
1625
1626   (pass-if (equal? '() (lset-difference! = '())))
1627   (pass-if (equal? '(1) (lset-difference! = (list 1))))
1628   (pass-if (equal? '(1 2) (lset-difference! = (list 1 2))))
1629
1630   (pass-if (equal? '() (lset-difference! = (list ) '(3))))
1631   (pass-if (equal? '() (lset-difference! = (list 3) '(3))))
1632   (pass-if (equal? '(1) (lset-difference! = (list 1 3) '(3))))
1633   (pass-if (equal? '(1) (lset-difference! = (list 3 1) '(3))))
1634   (pass-if (equal? '(1) (lset-difference! = (list 1 3 3) '(3))))
1635   (pass-if (equal? '(1) (lset-difference! = (list 3 1 3) '(3))))
1636   (pass-if (equal? '(1) (lset-difference! = (list 3 3 1) '(3))))
1637
1638   (pass-if (equal? '(1) (lset-difference! = (list 1 2 3) '(2 3))))
1639   (pass-if (equal? '(1) (lset-difference! = (list 1 2 3) '(3 2))))
1640   (pass-if (equal? '(1) (lset-difference! = (list 1 2 3) '(3) '(2))))
1641   (pass-if (equal? '(1) (lset-difference! = (list 1 2 3) '(2) '(3))))
1642   (pass-if (equal? '(1) (lset-difference! = (list 1 2 3) '(2) '(2 3))))
1643   (pass-if (equal? '(1) (lset-difference! = (list 1 2 3) '(2) '(3 2))))
1644
1645   (pass-if (equal? '(1 2) (lset-difference! = (list 1 2 3) '(3) '(3))))
1646   (pass-if (equal? '(1 2) (lset-difference! = (list 1 3 2) '(3) '(3))))
1647   (pass-if (equal? '(1 2) (lset-difference! = (list 3 1 2) '(3) '(3))))
1648
1649   (pass-if (equal? '(1 2 3) (lset-difference! = (list 1 2 3 4) '(4))))
1650   (pass-if (equal? '(1 2 3) (lset-difference! = (list 1 2 4 3) '(4))))
1651   (pass-if (equal? '(1 2 3) (lset-difference! = (list 1 4 2 3) '(4))))
1652   (pass-if (equal? '(1 2 3) (lset-difference! = (list 4 1 2 3) '(4))))
1653
1654   (pass-if (equal? '(1 2) (lset-difference! = (list 1 2 3 4) '(4) '(3))))
1655   (pass-if (equal? '(1 2) (lset-difference! = (list 1 3 2 4) '(4) '(3))))
1656   (pass-if (equal? '(1 2) (lset-difference! = (list 3 1 2 4) '(4) '(3))))
1657   (pass-if (equal? '(1 2) (lset-difference! = (list 1 3 4 2) '(4) '(3))))
1658   (pass-if (equal? '(1 2) (lset-difference! = (list 3 1 4 2) '(4) '(3))))
1659   (pass-if (equal? '(1 2) (lset-difference! = (list 3 4 1 2) '(4) '(3)))))
1660
1661 ;;
1662 ;; lset-diff+intersection
1663 ;;
1664
1665 (with-test-prefix "lset-diff+intersection"
1666
1667   (pass-if "called arg order"
1668     (let ((good #f))
1669       (lset-diff+intersection (lambda (x y)
1670                                 (set! good (and (= x 1) (= y 2)))
1671                                 (= x y))
1672                               '(1) '(2))
1673       good)))
1674
1675 ;;
1676 ;; lset-diff+intersection!
1677 ;;
1678
1679 (with-test-prefix "lset-diff+intersection"
1680
1681   (pass-if "called arg order"
1682     (let ((good #f))
1683       (lset-diff+intersection (lambda (x y)
1684                                 (set! good (and (= x 1) (= y 2)))
1685                                 (= x y))
1686                               (list 1) (list 2))
1687       good)))
1688
1689 ;;
1690 ;; lset-intersection
1691 ;;
1692
1693 (with-test-prefix "lset-intersection"
1694
1695   (pass-if "called arg order"
1696     (let ((good #f))
1697       (lset-intersection (lambda (x y)
1698                            (set! good (and (= x 1) (= y 2)))
1699                            (= x y))
1700                          '(1) '(2))
1701       good)))
1702
1703 ;;
1704 ;; lset-intersection!
1705 ;;
1706
1707 (with-test-prefix "lset-intersection"
1708
1709   (pass-if "called arg order"
1710     (let ((good #f))
1711       (lset-intersection (lambda (x y)
1712                            (set! good (and (= x 1) (= y 2)))
1713                            (= x y))
1714                          (list 1) (list 2))
1715       good)))
1716
1717 ;;
1718 ;; lset-union
1719 ;;
1720
1721 (with-test-prefix "lset-union"
1722
1723   (pass-if "no args"
1724     (eq? '() (lset-union eq?)))
1725
1726   (pass-if "one arg"
1727     (equal? '(1 2 3) (lset-union eq? '(1 2 3))))
1728
1729   (pass-if "'() '()"
1730     (equal? '() (lset-union eq? '() '())))
1731
1732   (pass-if "'() '(1 2 3)"
1733     (equal? '(1 2 3) (lset-union eq? '() '(1 2 3))))
1734
1735   (pass-if "'(1 2 3) '()"
1736     (equal? '(1 2 3) (lset-union eq? '(1 2 3) '())))
1737
1738   (pass-if "'(1 2 3) '(4 3 5)"
1739     (equal? '(5 4 1 2 3) (lset-union eq? '(1 2 3) '(4 3 5))))
1740
1741   (pass-if "'(1 2 3) '(4) '(3 5))"
1742     (equal? '(5 4 1 2 3) (lset-union eq? '(1 2 3) '(4) '(3 5))))
1743
1744   ;; in guile 1.6.7 and earlier, `=' was called with the arguments the wrong
1745   ;; way around
1746   (pass-if "called arg order"
1747     (let ((good #f))
1748       (lset-union (lambda (x y)
1749                     (set! good (and (= x 1) (= y 2)))
1750                     (= x y))
1751                   '(1) '(2))
1752       good)))
1753
1754 ;;
1755 ;; member
1756 ;;
1757
1758 (with-test-prefix "member"
1759
1760   (pass-if-exception "no args" exception:wrong-num-args
1761     (member))
1762
1763   (pass-if-exception "one arg" exception:wrong-num-args
1764     (member 1))
1765
1766   (pass-if "1 (1 2 3)"
1767     (let ((lst '(1 2 3)))
1768       (eq? lst (member 1 lst))))
1769
1770   (pass-if "2 (1 2 3)"
1771     (let ((lst '(1 2 3)))
1772       (eq? (cdr lst) (member 2 lst))))
1773
1774   (pass-if "3 (1 2 3)"
1775     (let ((lst '(1 2 3)))
1776       (eq? (cddr lst) (member 3 lst))))
1777
1778   (pass-if "4 (1 2 3)"
1779     (let ((lst '(1 2 3)))
1780       (eq? #f (member 4 lst))))
1781
1782   (pass-if "called arg order"
1783     (let ((good #f))
1784       (member 1 '(2) (lambda (x y)
1785                        (set! good (and (eqv? 1 x)
1786                                        (eqv? 2 y)))))
1787       good)))
1788
1789 ;;
1790 ;; ninth
1791 ;;
1792
1793 (with-test-prefix "ninth"
1794   (pass-if-exception "() -1" exception:out-of-range
1795     (ninth '(a b c d e f g h)))
1796   (pass-if (eq? 'i (ninth '(a b c d e f g h i))))
1797   (pass-if (eq? 'i (ninth '(a b c d e f g h i j)))))
1798
1799
1800 ;;
1801 ;; not-pair?
1802 ;;
1803
1804 (with-test-prefix "not-pair?"
1805   (pass-if "inum"
1806     (eq? #t (not-pair? 123)))
1807   (pass-if "pair"
1808     (eq? #f (not-pair? '(x . y))))
1809   (pass-if "symbol"
1810     (eq? #t (not-pair? 'x))))
1811
1812 ;;
1813 ;; take
1814 ;;
1815
1816 (with-test-prefix "take"
1817
1818   (pass-if "'() 0"
1819     (null? (take '() 0)))
1820
1821   (pass-if "'(a) 0"
1822     (null? (take '(a) 0)))
1823
1824   (pass-if "'(a b) 0"
1825     (null? (take '() 0)))
1826
1827   (pass-if "'(a b c) 0"
1828     (null? (take '() 0)))
1829
1830   (pass-if "'(a) 1"
1831     (let* ((lst '(a))
1832            (got (take lst 1)))
1833       (and (equal? '(a) got)
1834            (not (eq? lst got)))))
1835
1836   (pass-if "'(a b) 1"
1837     (equal? '(a)
1838             (take '(a b) 1)))
1839
1840   (pass-if "'(a b c) 1"
1841     (equal? '(a)
1842             (take '(a b c) 1)))
1843
1844   (pass-if "'(a b) 2"
1845     (let* ((lst '(a b))
1846            (got (take lst 2)))
1847       (and (equal? '(a b) got)
1848            (not (eq? lst got)))))
1849
1850   (pass-if "'(a b c) 2"
1851     (equal? '(a b)
1852             (take '(a b c) 2)))
1853
1854   (pass-if "circular '(a) 0"
1855     (equal? '()
1856             (take (circular-list 'a) 0)))
1857
1858   (pass-if "circular '(a) 1"
1859     (equal? '(a)
1860             (take (circular-list 'a) 1)))
1861
1862   (pass-if "circular '(a) 2"
1863     (equal? '(a a)
1864             (take (circular-list 'a) 2)))
1865
1866   (pass-if "circular '(a b) 5"
1867     (equal? '(a b a b a)
1868             (take (circular-list 'a 'b) 5)))
1869
1870   (pass-if "'(a . b) 1"
1871     (equal? '(a)
1872             (take '(a . b) 1)))
1873
1874   (pass-if "'(a b . c) 1"
1875     (equal? '(a)
1876             (take '(a b . c) 1)))
1877
1878   (pass-if "'(a b . c) 2"
1879     (equal? '(a b)
1880             (take '(a b . c) 2))))
1881
1882 ;;
1883 ;; take-while
1884 ;;
1885
1886 (with-test-prefix "take-while"
1887
1888   (pass-if (equal? '()      (take-while odd? '())))
1889   (pass-if (equal? '(1)     (take-while odd? '(1))))
1890   (pass-if (equal? '(1 3)   (take-while odd? '(1 3))))
1891   (pass-if (equal? '(1 3 5) (take-while odd? '(1 3 5))))
1892
1893   (pass-if (equal? '()      (take-while odd? '(2))))
1894   (pass-if (equal? '(1)     (take-while odd? '(1 2))))
1895   (pass-if (equal? '(1 3)   (take-while odd? '(1 3 4))))
1896
1897   (pass-if (equal? '()      (take-while odd? '(2 1))))
1898   (pass-if (equal? '(1)     (take-while odd? '(1 4 3))))
1899   (pass-if (equal? '()      (take-while odd? '(4 1 3)))))
1900
1901 ;;
1902 ;; take-while!
1903 ;;
1904
1905 (with-test-prefix "take-while!"
1906
1907   (pass-if (equal? '()      (take-while! odd? '())))
1908   (pass-if (equal? '(1)     (take-while! odd? (list 1))))
1909   (pass-if (equal? '(1 3)   (take-while! odd? (list 1 3))))
1910   (pass-if (equal? '(1 3 5) (take-while! odd? (list 1 3 5))))
1911
1912   (pass-if (equal? '()      (take-while! odd? (list 2))))
1913   (pass-if (equal? '(1)     (take-while! odd? (list 1 2))))
1914   (pass-if (equal? '(1 3)   (take-while! odd? (list 1 3 4))))
1915
1916   (pass-if (equal? '()      (take-while! odd? (list 2 1))))
1917   (pass-if (equal? '(1)     (take-while! odd? (list 1 4 3))))
1918   (pass-if (equal? '()      (take-while! odd? (list 4 1 3)))))
1919
1920 ;;
1921 ;; partition
1922 ;;
1923
1924 (define (test-partition pred list kept-good dropped-good)
1925   (call-with-values (lambda ()
1926                         (partition pred list))
1927       (lambda (kept dropped)
1928         (and (equal? kept kept-good)
1929              (equal? dropped dropped-good)))))
1930
1931 (with-test-prefix "partition"
1932
1933   (pass-if "with dropped tail"
1934     (test-partition even? '(1 2 3 4 5 6 7)
1935                     '(2 4 6) '(1 3 5 7)))
1936
1937   (pass-if "with kept tail"
1938     (test-partition even? '(1 2 3 4 5 6)
1939                     '(2 4 6) '(1 3 5)))
1940
1941   (pass-if "with everything dropped"
1942     (test-partition even? '(1 3 5 7)
1943                     '() '(1 3 5 7)))
1944
1945   (pass-if "with everything kept"
1946     (test-partition even? '(2 4 6)
1947                     '(2 4 6) '()))
1948
1949   (pass-if "with empty list"
1950     (test-partition even? '()
1951                     '() '()))
1952
1953   (pass-if "with reasonably long list"
1954     ;; the old implementation from SRFI-1 reference implementation
1955     ;; would signal a stack-overflow for a list of only 500 elements!
1956     (call-with-values (lambda ()
1957                         (partition even?
1958                                    (make-list 10000 1)))
1959       (lambda (even odd)
1960         (and (= (length odd) 10000)
1961              (= (length even) 0))))))
1962
1963 ;;
1964 ;; partition!
1965 ;;
1966
1967 (define (test-partition! pred list kept-good dropped-good)
1968   (call-with-values (lambda ()
1969                         (partition! pred list))
1970       (lambda (kept dropped)
1971         (and (equal? kept kept-good)
1972              (equal? dropped dropped-good)))))
1973
1974 (with-test-prefix "partition!"
1975
1976   (pass-if "with dropped tail"
1977     (test-partition! even? (list 1 2 3 4 5 6 7)
1978                      '(2 4 6) '(1 3 5 7)))
1979
1980   (pass-if "with kept tail"
1981     (test-partition! even? (list 1 2 3 4 5 6)
1982                      '(2 4 6) '(1 3 5)))
1983
1984   (pass-if "with everything dropped"
1985     (test-partition! even? (list 1 3 5 7)
1986                      '() '(1 3 5 7)))
1987
1988   (pass-if "with everything kept"
1989     (test-partition! even? (list 2 4 6)
1990                      '(2 4 6) '()))
1991
1992   (pass-if "with empty list"
1993     (test-partition! even? '()
1994                      '() '()))
1995
1996   (pass-if "with reasonably long list"
1997     ;; the old implementation from SRFI-1 reference implementation
1998     ;; would signal a stack-overflow for a list of only 500 elements!
1999     (call-with-values (lambda ()
2000                         (partition! even?
2001                                     (make-list 10000 1)))
2002       (lambda (even odd)
2003         (and (= (length odd) 10000)
2004              (= (length even) 0))))))
2005
2006 ;;
2007 ;; reduce
2008 ;;
2009
2010 (with-test-prefix "reduce"
2011
2012   (pass-if "empty"
2013     (let* ((calls '())
2014            (ret   (reduce (lambda (x prev)
2015                             (set! calls (cons (list x prev) calls))
2016                             x)
2017                           1 '())))
2018       (and (equal? calls '())
2019            (equal? ret   1))))
2020
2021   (pass-if "one elem"
2022     (let* ((calls '())
2023            (ret   (reduce (lambda (x prev)
2024                             (set! calls (cons (list x prev) calls))
2025                             x)
2026                           1 '(2))))
2027       (and (equal? calls '())
2028            (equal? ret   2))))
2029
2030   (pass-if "two elems"
2031     (let* ((calls '())
2032            (ret   (reduce (lambda (x prev)
2033                             (set! calls (cons (list x prev) calls))
2034                             x)
2035                           1 '(2 3))))
2036       (and (equal? calls '((3 2)))
2037            (equal? ret   3))))
2038
2039   (pass-if "three elems"
2040     (let* ((calls '())
2041            (ret   (reduce (lambda (x prev)
2042                             (set! calls (cons (list x prev) calls))
2043                             x)
2044                           1 '(2 3 4))))
2045       (and (equal? calls '((4 3)
2046                            (3 2)))
2047            (equal? ret   4))))
2048
2049   (pass-if "four elems"
2050     (let* ((calls '())
2051            (ret   (reduce (lambda (x prev)
2052                             (set! calls (cons (list x prev) calls))
2053                             x)
2054                           1 '(2 3 4 5))))
2055       (and (equal? calls '((5 4)
2056                            (4 3)
2057                            (3 2)))
2058            (equal? ret   5)))))
2059
2060 ;;
2061 ;; reduce-right
2062 ;;
2063
2064 (with-test-prefix "reduce-right"
2065
2066   (pass-if "empty"
2067     (let* ((calls '())
2068            (ret   (reduce-right (lambda (x prev)
2069                                   (set! calls (cons (list x prev) calls))
2070                                   x)
2071                                 1 '())))
2072       (and (equal? calls '())
2073            (equal? ret   1))))
2074
2075   (pass-if "one elem"
2076     (let* ((calls '())
2077            (ret   (reduce-right (lambda (x prev)
2078                                   (set! calls (cons (list x prev) calls))
2079                                   x)
2080                                 1 '(2))))
2081       (and (equal? calls '())
2082            (equal? ret   2))))
2083
2084   (pass-if "two elems"
2085     (let* ((calls '())
2086            (ret   (reduce-right (lambda (x prev)
2087                                   (set! calls (cons (list x prev) calls))
2088                                   x)
2089                                 1 '(2 3))))
2090       (and (equal? calls '((2 3)))
2091            (equal? ret   2))))
2092
2093   (pass-if "three elems"
2094     (let* ((calls '())
2095            (ret   (reduce-right (lambda (x prev)
2096                                   (set! calls (cons (list x prev) calls))
2097                                   x)
2098                                 1 '(2 3 4))))
2099       (and (equal? calls '((2 3)
2100                            (3 4)))
2101            (equal? ret   2))))
2102
2103   (pass-if "four elems"
2104     (let* ((calls '())
2105            (ret   (reduce-right (lambda (x prev)
2106                                   (set! calls (cons (list x prev) calls))
2107                                   x)
2108                                 1 '(2 3 4 5))))
2109       (and (equal? calls '((2 3)
2110                            (3 4)
2111                            (4 5)))
2112            (equal? ret   2)))))
2113
2114 ;;
2115 ;; remove
2116 ;;
2117
2118 (with-test-prefix "remove"
2119
2120   (pass-if (equal? '() (remove odd? '())))
2121   (pass-if (equal? '() (remove odd? '(1))))
2122   (pass-if (equal? '(2) (remove odd? '(2))))
2123
2124   (pass-if (equal? '() (remove odd? '(1 3))))
2125   (pass-if (equal? '(2) (remove odd? '(2 3))))
2126   (pass-if (equal? '(2) (remove odd? '(1 2))))
2127   (pass-if (equal? '(2 4) (remove odd? '(2 4))))
2128
2129   (pass-if (equal? '() (remove odd? '(1 3 5))))
2130   (pass-if (equal? '(2) (remove odd? '(2 3 5))))
2131   (pass-if (equal? '(2) (remove odd? '(1 2 5))))
2132   (pass-if (equal? '(2 4) (remove odd? '(2 4 5))))
2133
2134   (pass-if (equal? '(6) (remove odd? '(1 3 6))))
2135   (pass-if (equal? '(2 6) (remove odd? '(2 3 6))))
2136   (pass-if (equal? '(2 6) (remove odd? '(1 2 6))))
2137   (pass-if (equal? '(2 4 6) (remove odd? '(2 4 6)))))
2138
2139 ;;
2140 ;; remove!
2141 ;;
2142
2143 (with-test-prefix "remove!"
2144
2145   (pass-if (equal? '() (remove! odd? '())))
2146   (pass-if (equal? '() (remove! odd? (list 1))))
2147   (pass-if (equal? '(2) (remove! odd? (list 2))))
2148
2149   (pass-if (equal? '() (remove! odd? (list 1 3))))
2150   (pass-if (equal? '(2) (remove! odd? (list 2 3))))
2151   (pass-if (equal? '(2) (remove! odd? (list 1 2))))
2152   (pass-if (equal? '(2 4) (remove! odd? (list 2 4))))
2153
2154   (pass-if (equal? '() (remove! odd? (list 1 3 5))))
2155   (pass-if (equal? '(2) (remove! odd? (list 2 3 5))))
2156   (pass-if (equal? '(2) (remove! odd? (list 1 2 5))))
2157   (pass-if (equal? '(2 4) (remove! odd? (list 2 4 5))))
2158
2159   (pass-if (equal? '(6) (remove! odd? (list 1 3 6))))
2160   (pass-if (equal? '(2 6) (remove! odd? (list 2 3 6))))
2161   (pass-if (equal? '(2 6) (remove! odd? (list 1 2 6))))
2162   (pass-if (equal? '(2 4 6) (remove! odd? (list 2 4 6)))))
2163
2164 ;;
2165 ;; seventh
2166 ;;
2167
2168 (with-test-prefix "seventh"
2169   (pass-if-exception "() -1" exception:out-of-range
2170     (seventh '(a b c d e f)))
2171   (pass-if (eq? 'g (seventh '(a b c d e f g))))
2172   (pass-if (eq? 'g (seventh '(a b c d e f g h)))))
2173
2174 ;;
2175 ;; sixth
2176 ;;
2177
2178 (with-test-prefix "sixth"
2179   (pass-if-exception "() -1" exception:out-of-range
2180     (sixth '(a b c d e)))
2181   (pass-if (eq? 'f (sixth '(a b c d e f))))
2182   (pass-if (eq? 'f (sixth '(a b c d e f g)))))
2183
2184 ;;
2185 ;; split-at
2186 ;;
2187
2188 (with-test-prefix "split-at"
2189
2190   (define (equal-values? lst thunk)
2191     (call-with-values thunk
2192       (lambda got
2193         (equal? lst got))))
2194
2195   (pass-if-exception "() -1" exception:out-of-range
2196     (split-at '() -1))
2197   (pass-if (equal-values? '(() ())
2198                           (lambda () (split-at '() 0))))
2199   (pass-if-exception "() 1" exception:wrong-type-arg
2200     (split-at '() 1))
2201
2202   (pass-if-exception "(1) -1" exception:out-of-range
2203     (split-at '(1) -1))
2204   (pass-if (equal-values? '(() (1)) (lambda () (split-at '(1) 0))))
2205   (pass-if (equal-values? '((1) ()) (lambda () (split-at '(1) 1))))
2206   (pass-if-exception "(1) 2" exception:wrong-type-arg
2207     (split-at '(1) 2))
2208
2209   (pass-if-exception "(4 5) -1" exception:out-of-range
2210     (split-at '(4 5) -1))
2211   (pass-if (equal-values? '(() (4 5)) (lambda () (split-at '(4 5) 0))))
2212   (pass-if (equal-values? '((4) (5)) (lambda () (split-at '(4 5) 1))))
2213   (pass-if (equal-values? '((4 5) ()) (lambda () (split-at '(4 5) 2))))
2214   (pass-if-exception "(4 5) 3" exception:wrong-type-arg
2215     (split-at '(4 5) 3))
2216
2217   (pass-if-exception "(4 5 6) -1" exception:out-of-range
2218     (split-at '(4 5 6) -1))
2219   (pass-if (equal-values? '(() (4 5 6)) (lambda () (split-at '(4 5 6) 0))))
2220   (pass-if (equal-values? '((4) (5 6)) (lambda () (split-at '(4 5 6) 1))))
2221   (pass-if (equal-values? '((4 5) (6)) (lambda () (split-at '(4 5 6) 2))))
2222   (pass-if (equal-values? '((4 5 6) ()) (lambda () (split-at '(4 5 6) 3))))
2223   (pass-if-exception "(4 5 6) 4" exception:wrong-type-arg
2224     (split-at '(4 5 6) 4)))
2225
2226 ;;
2227 ;; split-at!
2228 ;;
2229
2230 (with-test-prefix "split-at!"
2231
2232   (define (equal-values? lst thunk)
2233     (call-with-values thunk
2234       (lambda got
2235         (equal? lst got))))
2236
2237   (pass-if-exception "() -1" exception:out-of-range
2238     (split-at! '() -1))
2239   (pass-if (equal-values? '(() ())
2240                           (lambda () (split-at! '() 0))))
2241   (pass-if-exception "() 1" exception:wrong-type-arg
2242     (split-at! '() 1))
2243
2244   (pass-if-exception "(1) -1" exception:out-of-range
2245     (split-at! (list 1) -1))
2246   (pass-if (equal-values? '(() (1)) (lambda () (split-at! (list 1) 0))))
2247   (pass-if (equal-values? '((1) ()) (lambda () (split-at! (list 1) 1))))
2248   (pass-if-exception "(1) 2" exception:wrong-type-arg
2249     (split-at! (list 1) 2))
2250
2251   (pass-if-exception "(4 5) -1" exception:out-of-range
2252     (split-at! (list 4 5) -1))
2253   (pass-if (equal-values? '(() (4 5)) (lambda () (split-at! (list 4 5) 0))))
2254   (pass-if (equal-values? '((4) (5))  (lambda () (split-at! (list 4 5) 1))))
2255   (pass-if (equal-values? '((4 5) ()) (lambda () (split-at! (list 4 5) 2))))
2256   (pass-if-exception "(4 5) 3" exception:wrong-type-arg
2257     (split-at! (list 4 5) 3))
2258
2259   (pass-if-exception "(4 5 6) -1" exception:out-of-range
2260     (split-at! (list 4 5 6) -1))
2261   (pass-if (equal-values? '(() (4 5 6)) (lambda () (split-at! (list 4 5 6) 0))))
2262   (pass-if (equal-values? '((4) (5 6))  (lambda () (split-at! (list 4 5 6) 1))))
2263   (pass-if (equal-values? '((4 5) (6))  (lambda () (split-at! (list 4 5 6) 2))))
2264   (pass-if (equal-values? '((4 5 6) ()) (lambda () (split-at! (list 4 5 6) 3))))
2265   (pass-if-exception "(4 5 6) 4" exception:wrong-type-arg
2266     (split-at! (list 4 5 6) 4)))
2267
2268 ;;
2269 ;; span
2270 ;;
2271
2272 (with-test-prefix "span"
2273
2274   (define (test-span lst want-v1 want-v2)
2275     (call-with-values
2276         (lambda ()
2277           (span positive? lst))
2278       (lambda (got-v1 got-v2)
2279         (and (equal? got-v1 want-v1)
2280              (equal? got-v2 want-v2)))))
2281
2282   (pass-if "empty"
2283     (test-span '() '() '()))
2284
2285   (pass-if "y"
2286     (test-span '(1) '(1) '()))
2287
2288   (pass-if "n"
2289     (test-span '(-1) '() '(-1)))
2290
2291   (pass-if "yy"
2292     (test-span '(1 2) '(1 2) '()))
2293
2294   (pass-if "ny"
2295     (test-span '(-1 1) '() '(-1 1)))
2296
2297   (pass-if "yn"
2298     (test-span '(1 -1) '(1) '(-1)))
2299
2300   (pass-if "nn"
2301     (test-span '(-1 -2) '() '(-1 -2)))
2302
2303   (pass-if "yyy"
2304     (test-span '(1 2 3) '(1 2 3) '()))
2305
2306   (pass-if "nyy"
2307     (test-span '(-1 1 2) '() '(-1 1 2)))
2308
2309   (pass-if "yny"
2310     (test-span '(1 -1 2) '(1) '(-1 2)))
2311
2312   (pass-if "nny"
2313     (test-span '(-1 -2 1) '() '(-1 -2 1)))
2314
2315   (pass-if "yyn"
2316     (test-span '(1 2 -1) '(1 2) '(-1)))
2317
2318   (pass-if "nyn"
2319     (test-span '(-1 1 -2) '() '(-1 1 -2)))
2320
2321   (pass-if "ynn"
2322     (test-span '(1 -1 -2) '(1) '(-1 -2)))
2323
2324   (pass-if "nnn"
2325     (test-span '(-1 -2 -3) '() '(-1 -2 -3))))
2326
2327 ;;
2328 ;; span!
2329 ;;
2330
2331 (with-test-prefix "span!"
2332
2333   (define (test-span! lst want-v1 want-v2)
2334     (call-with-values
2335         (lambda ()
2336           (span! positive? lst))
2337       (lambda (got-v1 got-v2)
2338         (and (equal? got-v1 want-v1)
2339              (equal? got-v2 want-v2)))))
2340
2341   (pass-if "empty"
2342     (test-span! '() '() '()))
2343
2344   (pass-if "y"
2345     (test-span! (list 1) '(1) '()))
2346
2347   (pass-if "n"
2348     (test-span! (list -1) '() '(-1)))
2349
2350   (pass-if "yy"
2351     (test-span! (list 1 2) '(1 2) '()))
2352
2353   (pass-if "ny"
2354     (test-span! (list -1 1) '() '(-1 1)))
2355
2356   (pass-if "yn"
2357     (test-span! (list 1 -1) '(1) '(-1)))
2358
2359   (pass-if "nn"
2360     (test-span! (list -1 -2) '() '(-1 -2)))
2361
2362   (pass-if "yyy"
2363     (test-span! (list 1 2 3) '(1 2 3) '()))
2364
2365   (pass-if "nyy"
2366     (test-span! (list -1 1 2) '() '(-1 1 2)))
2367
2368   (pass-if "yny"
2369     (test-span! (list 1 -1 2) '(1) '(-1 2)))
2370
2371   (pass-if "nny"
2372     (test-span! (list -1 -2 1) '() '(-1 -2 1)))
2373
2374   (pass-if "yyn"
2375     (test-span! (list 1 2 -1) '(1 2) '(-1)))
2376
2377   (pass-if "nyn"
2378     (test-span! (list -1 1 -2) '() '(-1 1 -2)))
2379
2380   (pass-if "ynn"
2381     (test-span! (list 1 -1 -2) '(1) '(-1 -2)))
2382
2383   (pass-if "nnn"
2384     (test-span! (list -1 -2 -3) '() '(-1 -2 -3))))
2385
2386 ;;
2387 ;; take!
2388 ;;
2389
2390 (with-test-prefix "take!"
2391
2392   (pass-if-exception "() -1" exception:out-of-range
2393     (take! '() -1))
2394   (pass-if (equal? '() (take! '() 0)))
2395   (pass-if-exception "() 1" exception:wrong-type-arg
2396     (take! '() 1))
2397
2398   (pass-if-exception "(1) -1" exception:out-of-range
2399     (take! '(1) -1))
2400   (pass-if (equal? '() (take! '(1) 0)))
2401   (pass-if (equal? '(1) (take! '(1) 1)))
2402   (pass-if-exception "(1) 2" exception:wrong-type-arg
2403     (take! '(1) 2))
2404
2405   (pass-if-exception "(4 5) -1" exception:out-of-range
2406     (take! '(4 5) -1))
2407   (pass-if (equal? '() (take! '(4 5) 0)))
2408   (pass-if (equal? '(4) (take! '(4 5) 1)))
2409   (pass-if (equal? '(4 5) (take! '(4 5) 2)))
2410   (pass-if-exception "(4 5) 3" exception:wrong-type-arg
2411     (take! '(4 5) 3))
2412
2413   (pass-if-exception "(4 5 6) -1" exception:out-of-range
2414     (take! '(4 5 6) -1))
2415   (pass-if (equal? '() (take! '(4 5 6) 0)))
2416   (pass-if (equal? '(4) (take! '(4 5 6) 1)))
2417   (pass-if (equal? '(4 5) (take! '(4 5 6) 2)))
2418   (pass-if (equal? '(4 5 6) (take! '(4 5 6) 3)))
2419   (pass-if-exception "(4 5 6) 4" exception:wrong-type-arg
2420     (take! '(4 5 6) 4)))
2421
2422
2423 ;;
2424 ;; take-right
2425 ;;
2426
2427 (with-test-prefix "take-right"
2428
2429   (pass-if-exception "() -1" exception:out-of-range
2430     (take-right '() -1))
2431   (pass-if (equal? '() (take-right '() 0)))
2432   (pass-if-exception "() 1" exception:wrong-type-arg
2433     (take-right '() 1))
2434
2435   (pass-if-exception "(1) -1" exception:out-of-range
2436     (take-right '(1) -1))
2437   (pass-if (equal? '() (take-right '(1) 0)))
2438   (pass-if (equal? '(1) (take-right '(1) 1)))
2439   (pass-if-exception "(1) 2" exception:wrong-type-arg
2440     (take-right '(1) 2))
2441
2442   (pass-if-exception "(4 5) -1" exception:out-of-range
2443     (take-right '(4 5) -1))
2444   (pass-if (equal? '() (take-right '(4 5) 0)))
2445   (pass-if (equal? '(5) (take-right '(4 5) 1)))
2446   (pass-if (equal? '(4 5) (take-right '(4 5) 2)))
2447   (pass-if-exception "(4 5) 3" exception:wrong-type-arg
2448     (take-right '(4 5) 3))
2449
2450   (pass-if-exception "(4 5 6) -1" exception:out-of-range
2451     (take-right '(4 5 6) -1))
2452   (pass-if (equal? '() (take-right '(4 5 6) 0)))
2453   (pass-if (equal? '(6) (take-right '(4 5 6) 1)))
2454   (pass-if (equal? '(5 6) (take-right '(4 5 6) 2)))
2455   (pass-if (equal? '(4 5 6) (take-right '(4 5 6) 3)))
2456   (pass-if-exception "(4 5 6) 4" exception:wrong-type-arg
2457     (take-right '(4 5 6) 4)))
2458
2459 ;;
2460 ;; tenth
2461 ;;
2462
2463 (with-test-prefix "tenth"
2464   (pass-if-exception "() -1" exception:out-of-range
2465     (tenth '(a b c d e f g h i)))
2466   (pass-if (eq? 'j (tenth '(a b c d e f g h i j))))
2467   (pass-if (eq? 'j (tenth '(a b c d e f g h i j k)))))
2468
2469 ;;
2470 ;; xcons
2471 ;;
2472
2473 (with-test-prefix "xcons"
2474   (pass-if (equal? '(y . x) (xcons 'x 'y))))