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 ;; concatenate and concatenate!
 324 ;;
 325
 326 (let ()
 327   (define (common-tests concatenate-proc unmodified?)
 328     (define (try lstlst want)
 329       (let ((lstlst-copy (copy-tree lstlst))
 330             (got         (concatenate-proc lstlst)))
 331         (if unmodified?
 332             (if (not (equal? lstlst lstlst-copy))
 333                 (error "input lists modified")))
 334         (equal? got want)))
 335
 336     (pass-if-exception "too few args" exception:wrong-num-args
 337       (concatenate-proc))
 338
 339     (pass-if-exception "too many args" exception:wrong-num-args
 340       (concatenate-proc '() '()))
 341
 342     (pass-if-exception "number" exception:wrong-type-arg
 343       (concatenate-proc 123))
 344
 345     (pass-if-exception "vector" exception:wrong-type-arg
 346       (concatenate-proc #(1 2 3)))
 347
 348     (pass-if "no lists"
 349       (try '() '()))
 350
 351     (pass-if (try '((1))       '(1)))
 352     (pass-if (try '((1 2))     '(1 2)))
 353     (pass-if (try '(() (1))    '(1)))
 354     (pass-if (try '(() () (1)) '(1)))
 355
 356     (pass-if (try '((1) (2)) '(1 2)))
 357     (pass-if (try '(() (1 2)) '(1 2)))
 358
 359     (pass-if (try '((1) 2)           '(1 . 2)))
 360     (pass-if (try '((1) (2) 3)       '(1 2 . 3)))
 361     (pass-if (try '((1) (2) (3 . 4)) '(1 2 3 . 4)))
 362     )
 363
 364   (with-test-prefix "concatenate"
 365     (common-tests concatenate #t))
 366
 367   (with-test-prefix "concatenate!"
 368     (common-tests concatenate! #f)))
 369
 370 ;;
 371 ;; count
 372 ;;
 373
 374 (with-test-prefix "count"
 375   (pass-if-exception "no args" exception:wrong-num-args
 376     (count))
 377
 378   (pass-if-exception "one arg" exception:wrong-num-args
 379     (count noop))
 380
 381   (with-test-prefix "one list"
 382     (define (or1 x)
 383       x)
 384
 385     (pass-if "empty list" (= 0 (count or1 '())))
 386
 387     (pass-if-exception "pred arg count 0" exception:wrong-type-arg
 388       (count (lambda () x) '(1 2 3)))
 389     (pass-if-exception "pred arg count 2" exception:wrong-type-arg
 390       (count (lambda (x y) x) '(1 2 3)))
 391
 392     (pass-if-exception "improper 1" exception:wrong-type-arg
 393       (count or1 1))
 394     (pass-if-exception "improper 2" exception:wrong-type-arg
 395       (count or1 '(1 . 2)))
 396     (pass-if-exception "improper 3" exception:wrong-type-arg
 397       (count or1 '(1 2 . 3)))
 398
 399     (pass-if (= 0 (count or1 '(#f))))
 400     (pass-if (= 1 (count or1 '(#t))))
 401
 402     (pass-if (= 0 (count or1 '(#f #f))))
 403     (pass-if (= 1 (count or1 '(#f #t))))
 404     (pass-if (= 1 (count or1 '(#t #f))))
 405     (pass-if (= 2 (count or1 '(#t #t))))
 406
 407     (pass-if (= 0 (count or1 '(#f #f #f))))
 408     (pass-if (= 1 (count or1 '(#f #f #t))))
 409     (pass-if (= 1 (count or1 '(#t #f #f))))
 410     (pass-if (= 2 (count or1 '(#t #f #t))))
 411     (pass-if (= 3 (count or1 '(#t #t #t)))))
 412
 413   (with-test-prefix "two lists"
 414     (define (or2 x y)
 415       (or x y))
 416
 417     (pass-if "arg order"
 418       (= 1 (count (lambda (x y)
 419                     (and (= 1 x)
 420                          (= 2 y)))
 421                   '(1) '(2))))
 422
 423     (pass-if "empty lists" (= 0 (count or2 '() '())))
 424
 425     (pass-if-exception "pred arg count 0" exception:wrong-type-arg
 426       (count (lambda () #t) '(1 2 3) '(1 2 3)))
 427     (pass-if-exception "pred arg count 1" exception:wrong-type-arg
 428       (count (lambda (x) x) '(1 2 3) '(1 2 3)))
 429     (pass-if-exception "pred arg count 3" exception:wrong-type-arg
 430       (count (lambda (x y z) x) '(1 2 3) '(1 2 3)))
 431
 432     (pass-if-exception "improper first 1" exception:wrong-type-arg
 433       (count or2 1 '(1 2 3)))
 434     (pass-if-exception "improper first 2" exception:wrong-type-arg
 435       (count or2 '(1 . 2) '(1 2 3)))
 436     (pass-if-exception "improper first 3" exception:wrong-type-arg
 437       (count or2 '(1 2 . 3) '(1 2 3)))
 438
 439     (pass-if-exception "improper second 1" exception:wrong-type-arg
 440       (count or2 '(1 2 3) 1))
 441     (pass-if-exception "improper second 2" exception:wrong-type-arg
 442       (count or2 '(1 2 3) '(1 . 2)))
 443     (pass-if-exception "improper second 3" exception:wrong-type-arg
 444       (count or2 '(1 2 3) '(1 2 . 3)))
 445
 446     (pass-if (= 0 (count or2 '(#f) '(#f))))
 447     (pass-if (= 1 (count or2 '(#t) '(#f))))
 448     (pass-if (= 1 (count or2 '(#f) '(#t))))
 449
 450     (pass-if (= 0 (count or2 '(#f #f) '(#f #f))))
 451     (pass-if (= 1 (count or2 '(#t #f) '(#t #f))))
 452     (pass-if (= 2 (count or2 '(#t #t) '(#f #f))))
 453     (pass-if (= 2 (count or2 '(#t #f) '(#f #t))))
 454
 455     (with-test-prefix "stop shortest"
 456       (pass-if (= 2 (count or2 '(#t #f #t) '(#f #t))))
 457       (pass-if (= 2 (count or2 '(#t #f #t #t) '(#f #t))))
 458       (pass-if (= 2 (count or2 '(#t #f) '(#f #t #t))))
 459       (pass-if (= 2 (count or2 '(#t #f) '(#f #t #t #t))))))
 460
 461   (with-test-prefix "three lists"
 462     (define (or3 x y z)
 463       (or x y z))
 464
 465     (pass-if "arg order"
 466       (= 1 (count (lambda (x y z)
 467                     (and (= 1 x)
 468                          (= 2 y)
 469                          (= 3 z)))
 470                   '(1) '(2) '(3))))
 471
 472     (pass-if "empty lists" (= 0 (count or3 '() '() '())))
 473
 474     ;; currently bad pred argument gives wrong-num-args when 3 or more
 475     ;; lists, as opposed to wrong-type-arg for 1 or 2 lists
 476     (pass-if-exception "pred arg count 0" exception:wrong-num-args
 477       (count (lambda () #t) '(1 2 3) '(1 2 3) '(1 2 3)))
 478     (pass-if-exception "pred arg count 2" exception:wrong-num-args
 479       (count (lambda (x y) x) '(1 2 3) '(1 2 3)'(1 2 3) ))
 480     (pass-if-exception "pred arg count 4" exception:wrong-num-args
 481       (count (lambda (w x y z) x) '(1 2 3) '(1 2 3) '(1 2 3)))
 482
 483     (pass-if-exception "improper first 1" exception:wrong-type-arg
 484       (count or3 1 '(1 2 3) '(1 2 3)))
 485     (pass-if-exception "improper first 2" exception:wrong-type-arg
 486       (count or3 '(1 . 2) '(1 2 3) '(1 2 3)))
 487     (pass-if-exception "improper first 3" exception:wrong-type-arg
 488       (count or3 '(1 2 . 3) '(1 2 3) '(1 2 3)))
 489
 490     (pass-if-exception "improper second 1" exception:wrong-type-arg
 491       (count or3 '(1 2 3) 1 '(1 2 3)))
 492     (pass-if-exception "improper second 2" exception:wrong-type-arg
 493       (count or3 '(1 2 3) '(1 . 2) '(1 2 3)))
 494     (pass-if-exception "improper second 3" exception:wrong-type-arg
 495       (count or3 '(1 2 3) '(1 2 . 3) '(1 2 3)))
 496
 497     (pass-if-exception "improper third 1" exception:wrong-type-arg
 498       (count or3 '(1 2 3) '(1 2 3) 1))
 499     (pass-if-exception "improper third 2" exception:wrong-type-arg
 500       (count or3 '(1 2 3) '(1 2 3) '(1 . 2)))
 501     (pass-if-exception "improper third 3" exception:wrong-type-arg
 502       (count or3 '(1 2 3) '(1 2 3) '(1 2 . 3)))
 503
 504     (pass-if (= 0 (count or3 '(#f) '(#f) '(#f))))
 505     (pass-if (= 1 (count or3 '(#t) '(#f) '(#f))))
 506     (pass-if (= 1 (count or3 '(#f) '(#t) '(#f))))
 507     (pass-if (= 1 (count or3 '(#f) '(#f) '(#t))))
 508
 509     (pass-if (= 0 (count or3 '(#f #f) '(#f #f) '(#f #f))))
 510
 511     (pass-if (= 1 (count or3 '(#t #f) '(#f #f) '(#f #f))))
 512     (pass-if (= 1 (count or3 '(#f #t) '(#f #f) '(#f #f))))
 513     (pass-if (= 1 (count or3 '(#f #f) '(#t #f) '(#f #f))))
 514     (pass-if (= 1 (count or3 '(#f #f) '(#f #t) '(#f #f))))
 515     (pass-if (= 1 (count or3 '(#f #f) '(#f #f) '(#t #f))))
 516     (pass-if (= 1 (count or3 '(#f #f) '(#f #f) '(#f #t))))
 517
 518     (pass-if (= 2 (count or3 '(#t #t) '(#f #f) '(#f #f))))
 519     (pass-if (= 2 (count or3 '(#f #f) '(#t #t) '(#f #f))))
 520     (pass-if (= 2 (count or3 '(#f #f) '(#f #f) '(#t #t))))
 521     (pass-if (= 2 (count or3 '(#f #f) '(#t #f) '(#f #t))))
 522
 523     (with-test-prefix "stop shortest"
 524       (pass-if (= 0 (count or3 '() '(#t #t #t) '(#t #t))))
 525       (pass-if (= 0 (count or3 '(#t #t #t) '() '(#t #t))))
 526       (pass-if (= 0 (count or3 '(#t #t #t) '(#t #t) '())))
 527
 528       (pass-if (= 1 (count or3 '(#t) '(#t #t #t) '(#t #t))))
 529       (pass-if (= 1 (count or3 '(#t #t #t) '(#t) '(#t #t))))
 530       (pass-if (= 1 (count or3 '(#t #t #t) '(#t #t) '(#t)))))
 531
 532     (pass-if "apply list unchanged"
 533       (let ((lst (list (list 1 2) (list 3 4) (list 5 6))))
 534         (and (equal? 2 (apply count or3 lst))
 535              ;; lst unmodified
 536              (equal? '((1 2) (3 4) (5 6)) lst))))))
 537
 538 ;;
 539 ;; delete and delete!
 540 ;;
 541
 542 (let ()
 543   ;; Call (PROC lst) for all lists of length up to 6, with all combinations
 544   ;; of elements to be retained or deleted.  Elements to retain are numbers,
 545   ;; 0 upwards.  Elements to be deleted are #f.
 546   (define (test-lists proc)
 547     (do ((n 0 (1+ n)))
 548         ((>= n 6))
 549       (do ((limit (ash 1 n))
 550            (i 0 (1+ i)))
 551           ((>= i limit))
 552         (let ((lst '()))
 553           (do ((bit 0 (1+ bit)))
 554               ((>= bit n))
 555             (set! lst  (cons (if (logbit? bit i) bit #f) lst)))
 556           (proc lst)))))
 557
 558   (define (common-tests delete-proc)
 559     (pass-if-exception "too few args" exception:wrong-num-args
 560       (delete-proc 0))
 561
 562     (pass-if-exception "too many args" exception:wrong-num-args
 563       (delete-proc 0 '() equal? 99))
 564
 565     (pass-if "empty"
 566       (eq? '() (delete-proc 0 '())))
 567
 568     (pass-if "equal? (the default)"
 569       (equal? '((1) (3))
 570               (delete-proc '(2) '((1) (2) (3)))))
 571
 572     (pass-if "eq?"
 573       (equal? '((1) (2) (3))
 574               (delete-proc '(2) '((1) (2) (3)) eq?)))
 575
 576     (pass-if "called arg order"
 577       (equal? '(1 2 3)
 578               (delete-proc 3 '(1 2 3 4 5) <))))
 579
 580   (with-test-prefix "delete"
 581     (common-tests delete)
 582
 583     (test-lists
 584      (lambda (lst)
 585        (let ((lst-copy (list-copy lst)))
 586          (with-test-prefix lst-copy
 587            (pass-if "result"
 588              (equal? (delete     #f lst)
 589                      (ref-delete #f lst)))
 590            (pass-if "non-destructive"
 591              (equal? lst-copy lst)))))))
 592
 593   (with-test-prefix "delete!"
 594     (common-tests delete!)
 595
 596     (test-lists
 597      (lambda (lst)
 598        (pass-if lst
 599          (equal? (delete!    #f lst)
 600                  (ref-delete #f lst)))))))
 601
 602 ;;
 603 ;; delete-duplicates and delete-duplicates!
 604 ;;
 605
 606 (let ()
 607   ;; Call (PROC lst) for all lists of length 1 <= n <= 4, with all
 608   ;; combinations of numbers 1 to n in the elements
 609   (define (test-lists proc)
 610     (do ((n 1 (1+ n)))
 611         ((> n 4))
 612       (do ((limit (integer-expt n n))
 613            (i 0 (1+ i)))
 614           ((>= i limit))
 615         (let ((lst '()))
 616           (do ((j 0 (1+ j))
 617                (rem i (quotient rem n)))
 618               ((>= j n))
 619             (set! lst (cons (remainder rem n) lst)))
 620           (proc lst)))))
 621
 622   (define (common-tests delete-duplicates-proc)
 623     (pass-if-exception "too few args" exception:wrong-num-args
 624       (delete-duplicates-proc))
 625
 626     (pass-if-exception "too many args" exception:wrong-num-args
 627       (delete-duplicates-proc '() equal? 99))
 628
 629     (pass-if "empty"
 630       (eq? '() (delete-duplicates-proc '())))
 631
 632     (pass-if "equal? (the default)"
 633       (equal? '((2))
 634               (delete-duplicates-proc '((2) (2) (2)))))
 635
 636     (pass-if "eq?"
 637       (equal? '((2) (2) (2))
 638               (delete-duplicates-proc '((2) (2) (2)) eq?)))
 639
 640     (pass-if "called arg order"
 641       (let ((ok #t))
 642         (delete-duplicates-proc '(1 2 3 4 5)
 643                                 (lambda (x y)
 644                                   (if (> x y)
 645                                       (set! ok #f))
 646                                   #f))
 647         ok)))
 648
 649   (with-test-prefix "delete-duplicates"
 650     (common-tests delete-duplicates)
 651
 652     (test-lists
 653      (lambda (lst)
 654        (let ((lst-copy (list-copy lst)))
 655          (with-test-prefix lst-copy
 656            (pass-if "result"
 657              (equal? (delete-duplicates     lst)
 658                      (ref-delete-duplicates lst)))
 659            (pass-if "non-destructive"
 660              (equal? lst-copy lst)))))))
 661
 662   (with-test-prefix "delete-duplicates!"
 663     (common-tests delete-duplicates!)
 664
 665     (test-lists
 666      (lambda (lst)
 667        (pass-if lst
 668          (equal? (delete-duplicates!    lst)
 669                  (ref-delete-duplicates lst)))))))
 670
 671 ;;
 672 ;; drop
 673 ;;
 674
 675 (with-test-prefix "drop"
 676
 677   (pass-if "'() 0"
 678     (null? (drop '() 0)))
 679
 680   (pass-if "'(a) 0"
 681     (let ((lst '(a)))
 682       (eq? lst
 683            (drop lst 0))))
 684
 685   (pass-if "'(a b) 0"
 686     (let ((lst '(a b)))
 687       (eq? lst
 688            (drop lst 0))))
 689
 690   (pass-if "'(a) 1"
 691     (let ((lst '(a)))
 692       (eq? (cdr lst)
 693            (drop lst 1))))
 694
 695   (pass-if "'(a b) 1"
 696     (let ((lst '(a b)))
 697       (eq? (cdr lst)
 698            (drop lst 1))))
 699
 700   (pass-if "'(a b) 2"
 701     (let ((lst '(a b)))
 702       (eq? (cddr lst)
 703            (drop lst 2))))
 704
 705   (pass-if "'(a b c) 1"
 706     (let ((lst '(a b c)))
 707       (eq? (cddr lst)
 708            (drop lst 2))))
 709
 710   (pass-if "circular '(a) 0"
 711     (let ((lst (circular-list 'a)))
 712       (eq? lst
 713            (drop lst 0))))
 714
 715   (pass-if "circular '(a) 1"
 716     (let ((lst (circular-list 'a)))
 717       (eq? lst
 718            (drop lst 1))))
 719
 720   (pass-if "circular '(a) 2"
 721     (let ((lst (circular-list 'a)))
 722       (eq? lst
 723            (drop lst 1))))
 724
 725   (pass-if "circular '(a b) 1"
 726     (let ((lst (circular-list 'a)))
 727       (eq? (cdr lst)
 728            (drop lst 0))))
 729
 730   (pass-if "circular '(a b) 2"
 731     (let ((lst (circular-list 'a)))
 732       (eq? lst
 733            (drop lst 1))))
 734
 735   (pass-if "circular '(a b) 5"
 736     (let ((lst (circular-list 'a)))
 737       (eq? (cdr lst)
 738            (drop lst 5))))
 739
 740   (pass-if "'(a . b) 1"
 741     (eq? 'b
 742          (drop '(a . b) 1)))
 743
 744   (pass-if "'(a b . c) 1"
 745     (equal? 'c
 746             (drop '(a b . c) 2))))
 747
 748 ;;
 749 ;; drop-right
 750 ;;
 751
 752 (with-test-prefix "drop-right"
 753
 754   (pass-if-exception "() -1" exception:out-of-range
 755     (drop-right '() -1))
 756   (pass-if (equal? '() (drop-right '() 0)))
 757   (pass-if-exception "() 1" exception:wrong-type-arg
 758     (drop-right '() 1))
 759
 760   (pass-if-exception "(1) -1" exception:out-of-range
 761     (drop-right '(1) -1))
 762   (pass-if (equal? '(1) (drop-right '(1) 0)))
 763   (pass-if (equal? '() (drop-right '(1) 1)))
 764   (pass-if-exception "(1) 2" exception:wrong-type-arg
 765     (drop-right '(1) 2))
 766
 767   (pass-if-exception "(4 5) -1" exception:out-of-range
 768     (drop-right '(4 5) -1))
 769   (pass-if (equal? '(4 5) (drop-right '(4 5) 0)))
 770   (pass-if (equal? '(4) (drop-right '(4 5) 1)))
 771   (pass-if (equal? '() (drop-right '(4 5) 2)))
 772   (pass-if-exception "(4 5) 3" exception:wrong-type-arg
 773     (drop-right '(4 5) 3))
 774
 775   (pass-if-exception "(4 5 6) -1" exception:out-of-range
 776     (drop-right '(4 5 6) -1))
 777   (pass-if (equal? '(4 5 6) (drop-right '(4 5 6) 0)))
 778   (pass-if (equal? '(4 5) (drop-right '(4 5 6) 1)))
 779   (pass-if (equal? '(4) (drop-right '(4 5 6) 2)))
 780   (pass-if (equal? '() (drop-right '(4 5 6) 3)))
 781   (pass-if-exception "(4 5 6) 4" exception:wrong-type-arg
 782     (drop-right '(4 5 6) 4)))
 783
 784 ;;
 785 ;; drop-right!
 786 ;;
 787
 788 (with-test-prefix "drop-right!"
 789
 790   (pass-if-exception "() -1" exception:out-of-range
 791     (drop-right! '() -1))
 792   (pass-if (equal? '() (drop-right! '() 0)))
 793   (pass-if-exception "() 1" exception:wrong-type-arg
 794     (drop-right! '() 1))
 795
 796   (pass-if-exception "(1) -1" exception:out-of-range
 797     (drop-right! (list 1) -1))
 798   (pass-if (equal? '(1) (drop-right! (list 1) 0)))
 799   (pass-if (equal? '() (drop-right! (list 1) 1)))
 800   (pass-if-exception "(1) 2" exception:wrong-type-arg
 801     (drop-right! (list 1) 2))
 802
 803   (pass-if-exception "(4 5) -1" exception:out-of-range
 804     (drop-right! (list 4 5) -1))
 805   (pass-if (equal? '(4 5) (drop-right! (list 4 5) 0)))
 806   (pass-if (equal? '(4) (drop-right! (list 4 5) 1)))
 807   (pass-if (equal? '() (drop-right! (list 4 5) 2)))
 808   (pass-if-exception "(4 5) 3" exception:wrong-type-arg
 809     (drop-right! (list 4 5) 3))
 810
 811   (pass-if-exception "(4 5 6) -1" exception:out-of-range
 812     (drop-right! (list 4 5 6) -1))
 813   (pass-if (equal? '(4 5 6) (drop-right! (list 4 5 6) 0)))
 814   (pass-if (equal? '(4 5) (drop-right! (list 4 5 6) 1)))
 815   (pass-if (equal? '(4) (drop-right! (list 4 5 6) 2)))
 816   (pass-if (equal? '() (drop-right! (list 4 5 6) 3)))
 817   (pass-if-exception "(4 5 6) 4" exception:wrong-type-arg
 818     (drop-right! (list 4 5 6) 4)))
 819
 820 ;;
 821 ;; drop-while
 822 ;;
 823
 824 (with-test-prefix "drop-while"
 825
 826   (pass-if (equal? '()      (drop-while odd? '())))
 827   (pass-if (equal? '()      (drop-while odd? '(1))))
 828   (pass-if (equal? '()      (drop-while odd? '(1 3))))
 829   (pass-if (equal? '()      (drop-while odd? '(1 3 5))))
 830
 831   (pass-if (equal? '(2)     (drop-while odd? '(2))))
 832   (pass-if (equal? '(2)     (drop-while odd? '(1 2))))
 833   (pass-if (equal? '(4)     (drop-while odd? '(1 3 4))))
 834
 835   (pass-if (equal? '(2 1)   (drop-while odd? '(2 1))))
 836   (pass-if (equal? '(4 3)   (drop-while odd? '(1 4 3))))
 837   (pass-if (equal? '(4 1 3) (drop-while odd? '(4 1 3)))))
 838
 839 ;;
 840 ;; filter-map
 841 ;;
 842
 843 (with-test-prefix "filter-map"
 844
 845   (with-test-prefix "one list"
 846     (pass-if-exception "'x" exception:wrong-type-arg
 847       (filter-map noop 'x))
 848
 849     (pass-if-exception "'(1 . x)" exception:wrong-type-arg
 850       (filter-map noop '(1 . x)))
 851
 852     (pass-if "(1)"
 853       (equal? '(1) (filter-map noop '(1))))
 854
 855     (pass-if "(#f)"
 856       (equal? '() (filter-map noop '(#f))))
 857
 858     (pass-if "(1 2)"
 859       (equal? '(1 2) (filter-map noop '(1 2))))
 860
 861     (pass-if "(#f 2)"
 862       (equal? '(2) (filter-map noop '(#f 2))))
 863
 864     (pass-if "(#f #f)"
 865       (equal? '() (filter-map noop '(#f #f))))
 866
 867     (pass-if "(1 2 3)"
 868       (equal? '(1 2 3) (filter-map noop '(1 2 3))))
 869
 870     (pass-if "(#f 2 3)"
 871       (equal? '(2 3) (filter-map noop '(#f 2 3))))
 872
 873     (pass-if "(1 #f 3)"
 874       (equal? '(1 3) (filter-map noop '(1 #f 3))))
 875
 876     (pass-if "(1 2 #f)"
 877       (equal? '(1 2) (filter-map noop '(1 2 #f)))))
 878
 879   (with-test-prefix "two lists"
 880     (pass-if-exception "'x '(1 2 3)" exception:wrong-type-arg
 881       (filter-map noop 'x '(1 2 3)))
 882
 883     (pass-if-exception "'(1 2 3) 'x" exception:wrong-type-arg
 884       (filter-map noop '(1 2 3) 'x))
 885
 886     (pass-if-exception "'(1 . x) '(1 2 3)" exception:wrong-type-arg
 887       (filter-map noop '(1 . x) '(1 2 3)))
 888
 889     (pass-if-exception "'(1 2 3) '(1 . x)" exception:wrong-type-arg
 890       (filter-map noop '(1 2 3) '(1 . x)))
 891
 892     (pass-if "(1 2 3) (4 5 6)"
 893       (equal? '(5 7 9) (filter-map + '(1 2 3) '(4 5 6))))
 894
 895     (pass-if "(#f 2 3) (4 5)"
 896       (equal? '(2) (filter-map noop '(#f 2 3) '(4 5))))
 897
 898     (pass-if "(4 #f) (1 2 3)"
 899       (equal? '(4) (filter-map noop '(4 #f) '(1 2 3))))
 900
 901     (pass-if "() (1 2 3)"
 902       (equal? '() (filter-map noop '() '(1 2 3))))
 903
 904     (pass-if "(1 2 3) ()"
 905       (equal? '() (filter-map noop '(1 2 3) '()))))
 906
 907   (with-test-prefix "three lists"
 908     (pass-if-exception "'x '(1 2 3) '(1 2 3)" exception:wrong-type-arg
 909       (filter-map noop 'x '(1 2 3) '(1 2 3)))
 910
 911     (pass-if-exception "'(1 2 3) 'x '(1 2 3)" exception:wrong-type-arg
 912       (filter-map noop '(1 2 3) 'x '(1 2 3)))
 913
 914     (pass-if-exception "'(1 2 3) '(1 2 3) 'x" exception:wrong-type-arg
 915       (filter-map noop '(1 2 3) '(1 2 3) 'x))
 916
 917     (pass-if-exception "'(1 . x) '(1 2 3) '(1 2 3)" exception:wrong-type-arg
 918       (filter-map noop '(1 . x) '(1 2 3) '(1 2 3)))
 919
 920     (pass-if-exception "'(1 2 3) '(1 . x) '(1 2 3)" exception:wrong-type-arg
 921       (filter-map noop '(1 2 3) '(1 . x) '(1 2 3)))
 922
 923     (pass-if-exception "'(1 2 3) '(1 2 3) '(1 . x)" exception:wrong-type-arg
 924       (filter-map noop '(1 2 3) '(1 2 3) '(1 . x)))
 925
 926     (pass-if "(1 2 3) (4 5 6) (7 8 9)"
 927       (equal? '(12 15 18) (filter-map + '(1 2 3) '(4 5 6) '(7 8 9))))
 928
 929     (pass-if "(#f 2 3) (4 5) (7 8 9)"
 930       (equal? '(2) (filter-map noop '(#f 2 3) '(4 5) '(7 8 9))))
 931
 932     (pass-if "(#f 2 3) (7 8 9) (4 5)"
 933       (equal? '(2) (filter-map noop '(#f 2 3) '(7 8 9) '(4 5))))
 934
 935     (pass-if "(4 #f) (1 2 3) (7 8 9)"
 936       (equal? '(4) (filter-map noop '(4 #f) '(1 2 3) '(7 8 9))))
 937
 938     (pass-if "apply list unchanged"
 939       (let ((lst (list (list 1 #f 2) (list 3 4 5) (list 6 7 8))))
 940         (and (equal? '(1 2) (apply filter-map noop lst))
 941              ;; lst unmodified
 942              (equal? lst '((1 #f 2) (3 4 5) (6 7 8))))))))
 943
 944 ;;
 945 ;; find
 946 ;;
 947
 948 (with-test-prefix "find"
 949   (pass-if (eqv? #f (find odd? '())))
 950   (pass-if (eqv? #f (find odd? '(0))))
 951   (pass-if (eqv? #f (find odd? '(0 2))))
 952   (pass-if (eqv? 1 (find odd? '(1))))
 953   (pass-if (eqv? 1 (find odd? '(0 1))))
 954   (pass-if (eqv? 1 (find odd? '(0 1 2))))
 955   (pass-if (eqv? 1 (find odd? '(2 0 1))))
 956   (pass-if (eqv? 1 (find (lambda (x) (= 1 x)) '(2 0 1)))))
 957
 958 ;;
 959 ;; find-tail
 960 ;;
 961
 962 (with-test-prefix "find-tail"
 963   (pass-if (let ((lst '()))
 964              (eq? #f (find-tail odd? lst))))
 965   (pass-if (let ((lst '(0)))
 966              (eq? #f (find-tail odd? lst))))
 967   (pass-if (let ((lst '(0 2)))
 968              (eq? #f (find-tail odd? lst))))
 969   (pass-if (let ((lst '(1)))
 970              (eq? lst (find-tail odd? lst))))
 971   (pass-if (let ((lst '(1 2)))
 972              (eq? lst (find-tail odd? lst))))
 973   (pass-if (let ((lst '(2 1)))
 974              (eq? (cdr lst) (find-tail odd? lst))))
 975   (pass-if (let ((lst '(2 1 0)))
 976              (eq? (cdr lst) (find-tail odd? lst))))
 977   (pass-if (let ((lst '(2 0 1)))
 978              (eq? (cddr lst) (find-tail odd? lst))))
 979   (pass-if (let ((lst '(2 0 1)))
 980              (eq? (cddr lst) (find-tail (lambda (x) (= 1 x)) lst)))))
 981
 982 ;;
 983 ;; length+
 984 ;;
 985
 986 (with-test-prefix "length+"
 987   (pass-if-exception "too few args" exception:wrong-num-args
 988     (length+))
 989   (pass-if-exception "too many args" exception:wrong-num-args
 990     (length+ 123 456))
 991   (pass-if (= 0 (length+ '())))
 992   (pass-if (= 1 (length+ '(x))))
 993   (pass-if (= 2 (length+ '(x y))))
 994   (pass-if (= 3 (length+ '(x y z))))
 995   (pass-if (not (length+ (circular-list 1))))
 996   (pass-if (not (length+ (circular-list 1 2))))
 997   (pass-if (not (length+ (circular-list 1 2 3)))))
 998
 999 ;;
1000 ;; list=
1001 ;;
1002
1003 (with-test-prefix "list="
1004
1005   (pass-if "no lists"
1006     (eq? #t (list= eqv?)))
1007
1008   (with-test-prefix "one list"
1009
1010     (pass-if "empty"
1011       (eq? #t (list= eqv? '())))
1012     (pass-if "one elem"
1013       (eq? #t (list= eqv? '(1))))
1014     (pass-if "two elems"
1015       (eq? #t (list= eqv? '(2)))))
1016
1017   (with-test-prefix "two lists"
1018
1019     (pass-if "empty / empty"
1020       (eq? #t (list= eqv? '() '())))
1021
1022     (pass-if "one / empty"
1023       (eq? #f (list= eqv? '(1) '())))
1024
1025     (pass-if "empty / one"
1026       (eq? #f (list= eqv? '() '(1))))
1027
1028     (pass-if "one / one same"
1029       (eq? #t (list= eqv? '(1) '(1))))
1030
1031     (pass-if "one / one diff"
1032       (eq? #f (list= eqv? '(1) '(2))))
1033
1034     (pass-if "called arg order"
1035       (let ((good #t))
1036         (list= (lambda (x y)
1037                  (set! good (and good (= (1+ x) y)))
1038                  #t)
1039                '(1 3) '(2 4))
1040         good)))
1041
1042   (with-test-prefix "three lists"
1043
1044     (pass-if "empty / empty / empty"
1045       (eq? #t (list= eqv? '() '() '())))
1046
1047     (pass-if "one / empty / empty"
1048       (eq? #f (list= eqv? '(1) '() '())))
1049
1050     (pass-if "one / one / empty"
1051       (eq? #f (list= eqv? '(1) '(1) '())))
1052
1053     (pass-if "one / diff / empty"
1054       (eq? #f (list= eqv? '(1) '(2) '())))
1055
1056     (pass-if "one / one / one"
1057       (eq? #t (list= eqv? '(1) '(1) '(1))))
1058
1059     (pass-if "two / two / diff"
1060       (eq? #f (list= eqv? '(1 2) '(1 2) '(1 99))))
1061
1062     (pass-if "two / two / two"
1063       (eq? #t (list= eqv? '(1 2) '(1 2) '(1 2))))
1064
1065     (pass-if "called arg order"
1066       (let ((good #t))
1067         (list= (lambda (x y)
1068                  (set! good (and good (= (1+ x) y)))
1069                  #t)
1070                '(1 4) '(2 5) '(3 6))
1071         good))))
1072
1073 ;;
1074 ;; list-copy
1075 ;;
1076
1077 (with-test-prefix "list-copy"
1078   (pass-if (equal? '()          (list-copy '())))
1079   (pass-if (equal? '(1 2)       (list-copy '(1 2))))
1080   (pass-if (equal? '(1 2 3)     (list-copy '(1 2 3))))
1081   (pass-if (equal? '(1 2 3 4)   (list-copy '(1 2 3 4))))
1082   (pass-if (equal? '(1 2 3 4 5) (list-copy '(1 2 3 4 5))))
1083
1084   ;; improper lists can be copied
1085   (pass-if (equal? 1              (list-copy 1)))
1086   (pass-if (equal? '(1 . 2)       (list-copy '(1 . 2))))
1087   (pass-if (equal? '(1 2 . 3)     (list-copy '(1 2 . 3))))
1088   (pass-if (equal? '(1 2 3 . 4)   (list-copy '(1 2 3 . 4))))
1089   (pass-if (equal? '(1 2 3 4 . 5) (list-copy '(1 2 3 4 . 5)))))
1090
1091 ;;
1092 ;; lset=
1093 ;;
1094
1095 (with-test-prefix "lset="
1096
1097   ;; in guile 1.6.7 and earlier, lset= incorrectly demanded at least one
1098   ;; list arg
1099   (pass-if "no args"
1100     (eq? #t (lset= eq?)))
1101
1102   (with-test-prefix "one arg"
1103
1104     (pass-if "()"
1105       (eq? #t (lset= eqv? '())))
1106
1107     (pass-if "(1)"
1108       (eq? #t (lset= eqv? '(1))))
1109
1110     (pass-if "(1 2)"
1111       (eq? #t (lset= eqv? '(1 2)))))
1112
1113   (with-test-prefix "two args"
1114
1115     (pass-if "() ()"
1116       (eq? #t (lset= eqv? '() '())))
1117
1118     (pass-if "(1) (1)"
1119       (eq? #t (lset= eqv? '(1) '(1))))
1120
1121     (pass-if "(1) (2)"
1122       (eq? #f (lset= eqv? '(1) '(2))))
1123
1124     (pass-if "(1) (1 2)"
1125       (eq? #f (lset= eqv? '(1) '(1 2))))
1126
1127     (pass-if "(1 2) (2 1)"
1128       (eq? #t (lset= eqv? '(1 2) '(2 1))))
1129
1130     (pass-if "called arg order"
1131       (let ((good #t))
1132         (lset= (lambda (x y)
1133                  (if (not (= x (1- y)))
1134                      (set! good #f))
1135                  #t)
1136                '(1 1) '(2 2))
1137         good)))
1138
1139   (with-test-prefix "three args"
1140
1141     (pass-if "() () ()"
1142       (eq? #t (lset= eqv? '() '() '())))
1143
1144     (pass-if "(1) (1) (1)"
1145       (eq? #t (lset= eqv? '(1) '(1) '(1))))
1146
1147     (pass-if "(1) (1) (2)"
1148       (eq? #f (lset= eqv? '(1) '(1) '(2))))
1149
1150     (pass-if "(1) (1) (1 2)"
1151       (eq? #f (lset= eqv? '(1) '(1) '(1 2))))
1152
1153     (pass-if "(1 2 3) (3 2 1) (1 3 2)"
1154       (eq? #t (lset= eqv? '(1 2 3) '(3 2 1) '(1 3 2))))
1155
1156     (pass-if "called arg order"
1157       (let ((good #t))
1158         (lset= (lambda (x y)
1159                  (if (not (= x (1- y)))
1160                      (set! good #f))
1161                  #t)
1162                '(1 1) '(2 2) '(3 3))
1163         good))))
1164
1165 ;;
1166 ;; lset-adjoin
1167 ;;
1168
1169 (with-test-prefix "lset-adjoin"
1170
1171   ;; in guile 1.6.7 and earlier, lset-adjoin didn't actually use the given
1172   ;; `=' procedure, all comparisons were just with `equal?
1173   ;;
1174   (with-test-prefix "case-insensitive ="
1175
1176     (pass-if "(\"x\") \"X\""
1177       (equal? '("x") (lset-adjoin string-ci=? '("x") "X"))))
1178
1179   (pass-if "called arg order"
1180     (let ((good #f))
1181       (lset-adjoin (lambda (x y)
1182                      (set! good (and (= x 1) (= y 2)))
1183                      (= x y))
1184                    '(1) 2)
1185       good))
1186
1187   (pass-if (equal? '() (lset-adjoin = '())))
1188
1189   (pass-if (equal? '(1) (lset-adjoin = '() 1)))
1190
1191   (pass-if (equal? '(1) (lset-adjoin = '() 1 1)))
1192
1193   (pass-if (equal? '(2 1) (lset-adjoin = '() 1 2)))
1194
1195   (pass-if (equal? '(3 1 2) (lset-adjoin = '(1 2) 1 2 3 2 1)))
1196
1197   (pass-if "apply list unchanged"
1198     (let ((lst (list 1 2)))
1199       (and (equal? '(2 1 3) (apply lset-adjoin = '(3) lst))
1200            ;; lst unmodified
1201            (equal? '(1 2) lst))))
1202
1203   (pass-if "(1 1) 1 1"
1204     (equal? '(1 1) (lset-adjoin = '(1 1) 1 1)))
1205
1206   ;; duplicates among args are cast out
1207   (pass-if "(2) 1 1"
1208     (equal? '(1 2) (lset-adjoin = '(2) 1 1))))
1209
1210 ;;
1211 ;; lset-union
1212 ;;
1213
1214 (with-test-prefix "lset-union"
1215
1216   (pass-if "no args"
1217     (eq? '() (lset-union eq?)))
1218
1219   (pass-if "one arg"
1220     (equal? '(1 2 3) (lset-union eq? '(1 2 3))))
1221
1222   (pass-if "'() '()"
1223     (equal? '() (lset-union eq? '() '())))
1224
1225   (pass-if "'() '(1 2 3)"
1226     (equal? '(1 2 3) (lset-union eq? '() '(1 2 3))))
1227
1228   (pass-if "'(1 2 3) '()"
1229     (equal? '(1 2 3) (lset-union eq? '(1 2 3) '())))
1230
1231   (pass-if "'(1 2 3) '(4 3 5)"
1232     (equal? '(5 4 1 2 3) (lset-union eq? '(1 2 3) '(4 3 5))))
1233
1234   (pass-if "'(1 2 3) '(4) '(3 5))"
1235     (equal? '(5 4 1 2 3) (lset-union eq? '(1 2 3) '(4) '(3 5))))
1236
1237   ;; in guile 1.6.7 and earlier, `=' was called with the arguments the wrong
1238   ;; way around
1239   (pass-if "called arg order"
1240     (let ((good #f))
1241       (lset-union (lambda (x y)
1242                     (set! good (and (= x 1) (= y 2)))
1243                     (= x y))
1244                   '(1) '(2))
1245       good)))
1246
1247 ;;
1248 ;; member
1249 ;;
1250
1251 (with-test-prefix "member"
1252
1253   (pass-if-exception "no args" exception:wrong-num-args
1254     (member))
1255
1256   (pass-if-exception "one arg" exception:wrong-num-args
1257     (member 1))
1258
1259   (pass-if "1 (1 2 3)"
1260     (let ((lst '(1 2 3)))
1261       (eq? lst (member 1 lst))))
1262
1263   (pass-if "2 (1 2 3)"
1264     (let ((lst '(1 2 3)))
1265       (eq? (cdr lst) (member 2 lst))))
1266
1267   (pass-if "3 (1 2 3)"
1268     (let ((lst '(1 2 3)))
1269       (eq? (cddr lst) (member 3 lst))))
1270
1271   (pass-if "4 (1 2 3)"
1272     (let ((lst '(1 2 3)))
1273       (eq? #f (member 4 lst))))
1274
1275   (pass-if "called arg order"
1276     (let ((good #f))
1277       (member 1 '(2) (lambda (x y)
1278                        (set! good (and (eqv? 1 x)
1279                                        (eqv? 2 y)))))
1280       good)))
1281
1282 ;;
1283 ;; take
1284 ;;
1285
1286 (with-test-prefix "take"
1287
1288   (pass-if "'() 0"
1289     (null? (take '() 0)))
1290
1291   (pass-if "'(a) 0"
1292     (null? (take '(a) 0)))
1293
1294   (pass-if "'(a b) 0"
1295     (null? (take '() 0)))
1296
1297   (pass-if "'(a b c) 0"
1298     (null? (take '() 0)))
1299
1300   (pass-if "'(a) 1"
1301     (let* ((lst '(a))
1302            (got (take lst 1)))
1303       (and (equal? '(a) got)
1304            (not (eq? lst got)))))
1305
1306   (pass-if "'(a b) 1"
1307     (equal? '(a)
1308             (take '(a b) 1)))
1309
1310   (pass-if "'(a b c) 1"
1311     (equal? '(a)
1312             (take '(a b c) 1)))
1313
1314   (pass-if "'(a b) 2"
1315     (let* ((lst '(a b))
1316            (got (take lst 2)))
1317       (and (equal? '(a b) got)
1318            (not (eq? lst got)))))
1319
1320   (pass-if "'(a b c) 2"
1321     (equal? '(a b)
1322             (take '(a b c) 2)))
1323
1324   (pass-if "circular '(a) 0"
1325     (equal? '()
1326             (take (circular-list 'a) 0)))
1327
1328   (pass-if "circular '(a) 1"
1329     (equal? '(a)
1330             (take (circular-list 'a) 1)))
1331
1332   (pass-if "circular '(a) 2"
1333     (equal? '(a a)
1334             (take (circular-list 'a) 2)))
1335
1336   (pass-if "circular '(a b) 5"
1337     (equal? '(a b a b a)
1338             (take (circular-list 'a 'b) 5)))
1339
1340   (pass-if "'(a . b) 1"
1341     (equal? '(a)
1342             (take '(a . b) 1)))
1343
1344   (pass-if "'(a b . c) 1"
1345     (equal? '(a)
1346             (take '(a b . c) 1)))
1347
1348   (pass-if "'(a b . c) 2"
1349     (equal? '(a b)
1350             (take '(a b . c) 2))))
1351
1352 ;;
1353 ;; take-while
1354 ;;
1355
1356 (with-test-prefix "take-while"
1357
1358   (pass-if (equal? '()      (take-while odd? '())))
1359   (pass-if (equal? '(1)     (take-while odd? '(1))))
1360   (pass-if (equal? '(1 3)   (take-while odd? '(1 3))))
1361   (pass-if (equal? '(1 3 5) (take-while odd? '(1 3 5))))
1362
1363   (pass-if (equal? '()      (take-while odd? '(2))))
1364   (pass-if (equal? '(1)     (take-while odd? '(1 2))))
1365   (pass-if (equal? '(1 3)   (take-while odd? '(1 3 4))))
1366
1367   (pass-if (equal? '()      (take-while odd? '(2 1))))
1368   (pass-if (equal? '(1)     (take-while odd? '(1 4 3))))
1369   (pass-if (equal? '()      (take-while odd? '(4 1 3)))))
1370
1371 ;;
1372 ;; take-while!
1373 ;;
1374
1375 (with-test-prefix "take-while!"
1376
1377   (pass-if (equal? '()      (take-while! odd? '())))
1378   (pass-if (equal? '(1)     (take-while! odd? (list 1))))
1379   (pass-if (equal? '(1 3)   (take-while! odd? (list 1 3))))
1380   (pass-if (equal? '(1 3 5) (take-while! odd? (list 1 3 5))))
1381
1382   (pass-if (equal? '()      (take-while! odd? (list 2))))
1383   (pass-if (equal? '(1)     (take-while! odd? (list 1 2))))
1384   (pass-if (equal? '(1 3)   (take-while! odd? (list 1 3 4))))
1385
1386   (pass-if (equal? '()      (take-while! odd? (list 2 1))))
1387   (pass-if (equal? '(1)     (take-while! odd? (list 1 4 3))))
1388   (pass-if (equal? '()      (take-while! odd? (list 4 1 3)))))
1389
1390 ;;
1391 ;; partition
1392 ;;
1393
1394 (define (test-partition pred list kept-good dropped-good)
1395   (call-with-values (lambda ()
1396                         (partition pred list))
1397       (lambda (kept dropped)
1398         (and (equal? kept kept-good)
1399              (equal? dropped dropped-good)))))
1400
1401 (with-test-prefix "partition"
1402
1403   (pass-if "with dropped tail"
1404     (test-partition even? '(1 2 3 4 5 6 7)
1405                     '(2 4 6) '(1 3 5 7)))
1406
1407   (pass-if "with kept tail"
1408     (test-partition even? '(1 2 3 4 5 6)
1409                     '(2 4 6) '(1 3 5)))
1410
1411   (pass-if "with everything dropped"
1412     (test-partition even? '(1 3 5 7)
1413                     '() '(1 3 5 7)))
1414
1415   (pass-if "with everything kept"
1416     (test-partition even? '(2 4 6)
1417                     '(2 4 6) '()))
1418
1419   (pass-if "with empty list"
1420     (test-partition even? '()
1421                     '() '()))
1422
1423   (pass-if "with reasonably long list"
1424     ;; the old implementation from SRFI-1 reference implementation
1425     ;; would signal a stack-overflow for a list of only 500 elements!
1426     (call-with-values (lambda ()
1427                         (partition even?
1428                                    (make-list 10000 1)))
1429       (lambda (even odd)
1430         (and (= (length odd) 10000)
1431              (= (length even) 0))))))
1432
1433 ;;
1434 ;; partition!
1435 ;;
1436
1437 (define (test-partition! pred list kept-good dropped-good)
1438   (call-with-values (lambda ()
1439                         (partition! pred list))
1440       (lambda (kept dropped)
1441         (and (equal? kept kept-good)
1442              (equal? dropped dropped-good)))))
1443
1444 (with-test-prefix "partition!"
1445
1446   (pass-if "with dropped tail"
1447     (test-partition! even? (list 1 2 3 4 5 6 7)
1448                      '(2 4 6) '(1 3 5 7)))
1449
1450   (pass-if "with kept tail"
1451     (test-partition! even? (list 1 2 3 4 5 6)
1452                      '(2 4 6) '(1 3 5)))
1453
1454   (pass-if "with everything dropped"
1455     (test-partition! even? (list 1 3 5 7)
1456                      '() '(1 3 5 7)))
1457
1458   (pass-if "with everything kept"
1459     (test-partition! even? (list 2 4 6)
1460                      '(2 4 6) '()))
1461
1462   (pass-if "with empty list"
1463     (test-partition! even? '()
1464                      '() '()))
1465
1466   (pass-if "with reasonably long list"
1467     ;; the old implementation from SRFI-1 reference implementation
1468     ;; would signal a stack-overflow for a list of only 500 elements!
1469     (call-with-values (lambda ()
1470                         (partition! even?
1471                                     (make-list 10000 1)))
1472       (lambda (even odd)
1473         (and (= (length odd) 10000)
1474              (= (length even) 0))))))
1475
1476 ;;
1477 ;; reduce
1478 ;;
1479
1480 (with-test-prefix "reduce"
1481
1482   (pass-if "empty"
1483     (let* ((calls '())
1484            (ret   (reduce (lambda (x prev)
1485                             (set! calls (cons (list x prev) calls))
1486                             x)
1487                           1 '())))
1488       (and (equal? calls '())
1489            (equal? ret   1))))
1490
1491   (pass-if "one elem"
1492     (let* ((calls '())
1493            (ret   (reduce (lambda (x prev)
1494                             (set! calls (cons (list x prev) calls))
1495                             x)
1496                           1 '(2))))
1497       (and (equal? calls '())
1498            (equal? ret   2))))
1499
1500   (pass-if "two elems"
1501     (let* ((calls '())
1502            (ret   (reduce (lambda (x prev)
1503                             (set! calls (cons (list x prev) calls))
1504                             x)
1505                           1 '(2 3))))
1506       (and (equal? calls '((3 2)))
1507            (equal? ret   3))))
1508
1509   (pass-if "three elems"
1510     (let* ((calls '())
1511            (ret   (reduce (lambda (x prev)
1512                             (set! calls (cons (list x prev) calls))
1513                             x)
1514                           1 '(2 3 4))))
1515       (and (equal? calls '((4 3)
1516                            (3 2)))
1517            (equal? ret   4))))
1518
1519   (pass-if "four elems"
1520     (let* ((calls '())
1521            (ret   (reduce (lambda (x prev)
1522                             (set! calls (cons (list x prev) calls))
1523                             x)
1524                           1 '(2 3 4 5))))
1525       (and (equal? calls '((5 4)
1526                            (4 3)
1527                            (3 2)))
1528            (equal? ret   5)))))
1529
1530 ;;
1531 ;; reduce-right
1532 ;;
1533
1534 (with-test-prefix "reduce-right"
1535
1536   (pass-if "empty"
1537     (let* ((calls '())
1538            (ret   (reduce-right (lambda (x prev)
1539                                   (set! calls (cons (list x prev) calls))
1540                                   x)
1541                                 1 '())))
1542       (and (equal? calls '())
1543            (equal? ret   1))))
1544
1545   (pass-if "one elem"
1546     (let* ((calls '())
1547            (ret   (reduce-right (lambda (x prev)
1548                                   (set! calls (cons (list x prev) calls))
1549                                   x)
1550                                 1 '(2))))
1551       (and (equal? calls '())
1552            (equal? ret   2))))
1553
1554   (pass-if "two elems"
1555     (let* ((calls '())
1556            (ret   (reduce-right (lambda (x prev)
1557                                   (set! calls (cons (list x prev) calls))
1558                                   x)
1559                                 1 '(2 3))))
1560       (and (equal? calls '((2 3)))
1561            (equal? ret   2))))
1562
1563   (pass-if "three elems"
1564     (let* ((calls '())
1565            (ret   (reduce-right (lambda (x prev)
1566                                   (set! calls (cons (list x prev) calls))
1567                                   x)
1568                                 1 '(2 3 4))))
1569       (and (equal? calls '((2 3)
1570                            (3 4)))
1571            (equal? ret   2))))
1572
1573   (pass-if "four elems"
1574     (let* ((calls '())
1575            (ret   (reduce-right (lambda (x prev)
1576                                   (set! calls (cons (list x prev) calls))
1577                                   x)
1578                                 1 '(2 3 4 5))))
1579       (and (equal? calls '((2 3)
1580                            (3 4)
1581                            (4 5)))
1582            (equal? ret   2)))))
1583
1584 ;;
1585 ;; remove
1586 ;;
1587
1588 (with-test-prefix "remove"
1589
1590   (pass-if (equal? '() (remove odd? '())))
1591   (pass-if (equal? '() (remove odd? '(1))))
1592   (pass-if (equal? '(2) (remove odd? '(2))))
1593
1594   (pass-if (equal? '() (remove odd? '(1 3))))
1595   (pass-if (equal? '(2) (remove odd? '(2 3))))
1596   (pass-if (equal? '(2) (remove odd? '(1 2))))
1597   (pass-if (equal? '(2 4) (remove odd? '(2 4))))
1598
1599   (pass-if (equal? '() (remove odd? '(1 3 5))))
1600   (pass-if (equal? '(2) (remove odd? '(2 3 5))))
1601   (pass-if (equal? '(2) (remove odd? '(1 2 5))))
1602   (pass-if (equal? '(2 4) (remove odd? '(2 4 5))))
1603
1604   (pass-if (equal? '(6) (remove odd? '(1 3 6))))
1605   (pass-if (equal? '(2 6) (remove odd? '(2 3 6))))
1606   (pass-if (equal? '(2 6) (remove odd? '(1 2 6))))
1607   (pass-if (equal? '(2 4 6) (remove odd? '(2 4 6)))))
1608
1609 ;;
1610 ;; remove!
1611 ;;
1612
1613 (with-test-prefix "remove!"
1614
1615   (pass-if (equal? '() (remove! odd? '())))
1616   (pass-if (equal? '() (remove! odd? (list 1))))
1617   (pass-if (equal? '(2) (remove! odd? (list 2))))
1618
1619   (pass-if (equal? '() (remove! odd? (list 1 3))))
1620   (pass-if (equal? '(2) (remove! odd? (list 2 3))))
1621   (pass-if (equal? '(2) (remove! odd? (list 1 2))))
1622   (pass-if (equal? '(2 4) (remove! odd? (list 2 4))))
1623
1624   (pass-if (equal? '() (remove! odd? (list 1 3 5))))
1625   (pass-if (equal? '(2) (remove! odd? (list 2 3 5))))
1626   (pass-if (equal? '(2) (remove! odd? (list 1 2 5))))
1627   (pass-if (equal? '(2 4) (remove! odd? (list 2 4 5))))
1628
1629   (pass-if (equal? '(6) (remove! odd? (list 1 3 6))))
1630   (pass-if (equal? '(2 6) (remove! odd? (list 2 3 6))))
1631   (pass-if (equal? '(2 6) (remove! odd? (list 1 2 6))))
1632   (pass-if (equal? '(2 4 6) (remove! odd? (list 2 4 6)))))
1633
1634 ;;
1635 ;; split-at
1636 ;;
1637
1638 (with-test-prefix "split-at"
1639
1640   (define (equal-values? lst thunk)
1641     (call-with-values thunk
1642       (lambda got
1643         (equal? lst got))))
1644
1645   (pass-if-exception "() -1" exception:out-of-range
1646     (split-at '() -1))
1647   (pass-if (equal-values? '(() ())
1648                           (lambda () (split-at '() 0))))
1649   (pass-if-exception "() 1" exception:wrong-type-arg
1650     (split-at '() 1))
1651
1652   (pass-if-exception "(1) -1" exception:out-of-range
1653     (split-at '(1) -1))
1654   (pass-if (equal-values? '(() (1)) (lambda () (split-at '(1) 0))))
1655   (pass-if (equal-values? '((1) ()) (lambda () (split-at '(1) 1))))
1656   (pass-if-exception "(1) 2" exception:wrong-type-arg
1657     (split-at '(1) 2))
1658
1659   (pass-if-exception "(4 5) -1" exception:out-of-range
1660     (split-at '(4 5) -1))
1661   (pass-if (equal-values? '(() (4 5)) (lambda () (split-at '(4 5) 0))))
1662   (pass-if (equal-values? '((4) (5)) (lambda () (split-at '(4 5) 1))))
1663   (pass-if (equal-values? '((4 5) ()) (lambda () (split-at '(4 5) 2))))
1664   (pass-if-exception "(4 5) 3" exception:wrong-type-arg
1665     (split-at '(4 5) 3))
1666
1667   (pass-if-exception "(4 5 6) -1" exception:out-of-range
1668     (split-at '(4 5 6) -1))
1669   (pass-if (equal-values? '(() (4 5 6)) (lambda () (split-at '(4 5 6) 0))))
1670   (pass-if (equal-values? '((4) (5 6)) (lambda () (split-at '(4 5 6) 1))))
1671   (pass-if (equal-values? '((4 5) (6)) (lambda () (split-at '(4 5 6) 2))))
1672   (pass-if (equal-values? '((4 5 6) ()) (lambda () (split-at '(4 5 6) 3))))
1673   (pass-if-exception "(4 5 6) 4" exception:wrong-type-arg
1674     (split-at '(4 5 6) 4)))
1675
1676 ;;
1677 ;; split-at!
1678 ;;
1679
1680 (with-test-prefix "split-at!"
1681
1682   (define (equal-values? lst thunk)
1683     (call-with-values thunk
1684       (lambda got
1685         (equal? lst got))))
1686
1687   (pass-if-exception "() -1" exception:out-of-range
1688     (split-at! '() -1))
1689   (pass-if (equal-values? '(() ())
1690                           (lambda () (split-at! '() 0))))
1691   (pass-if-exception "() 1" exception:wrong-type-arg
1692     (split-at! '() 1))
1693
1694   (pass-if-exception "(1) -1" exception:out-of-range
1695     (split-at! (list 1) -1))
1696   (pass-if (equal-values? '(() (1)) (lambda () (split-at! (list 1) 0))))
1697   (pass-if (equal-values? '((1) ()) (lambda () (split-at! (list 1) 1))))
1698   (pass-if-exception "(1) 2" exception:wrong-type-arg
1699     (split-at! (list 1) 2))
1700
1701   (pass-if-exception "(4 5) -1" exception:out-of-range
1702     (split-at! (list 4 5) -1))
1703   (pass-if (equal-values? '(() (4 5)) (lambda () (split-at! (list 4 5) 0))))
1704   (pass-if (equal-values? '((4) (5))  (lambda () (split-at! (list 4 5) 1))))
1705   (pass-if (equal-values? '((4 5) ()) (lambda () (split-at! (list 4 5) 2))))
1706   (pass-if-exception "(4 5) 3" exception:wrong-type-arg
1707     (split-at! (list 4 5) 3))
1708
1709   (pass-if-exception "(4 5 6) -1" exception:out-of-range
1710     (split-at! (list 4 5 6) -1))
1711   (pass-if (equal-values? '(() (4 5 6)) (lambda () (split-at! (list 4 5 6) 0))))
1712   (pass-if (equal-values? '((4) (5 6))  (lambda () (split-at! (list 4 5 6) 1))))
1713   (pass-if (equal-values? '((4 5) (6))  (lambda () (split-at! (list 4 5 6) 2))))
1714   (pass-if (equal-values? '((4 5 6) ()) (lambda () (split-at! (list 4 5 6) 3))))
1715   (pass-if-exception "(4 5 6) 4" exception:wrong-type-arg
1716     (split-at! (list 4 5 6) 4)))
1717
1718 ;;
1719 ;; span
1720 ;;
1721
1722 (with-test-prefix "span"
1723
1724   (define (test-span lst want-v1 want-v2)
1725     (call-with-values
1726         (lambda ()
1727           (span positive? lst))
1728       (lambda (got-v1 got-v2)
1729         (and (equal? got-v1 want-v1)
1730              (equal? got-v2 want-v2)))))
1731
1732   (pass-if "empty"
1733     (test-span '() '() '()))
1734
1735   (pass-if "y"
1736     (test-span '(1) '(1) '()))
1737
1738   (pass-if "n"
1739     (test-span '(-1) '() '(-1)))
1740
1741   (pass-if "yy"
1742     (test-span '(1 2) '(1 2) '()))
1743
1744   (pass-if "ny"
1745     (test-span '(-1 1) '() '(-1 1)))
1746
1747   (pass-if "yn"
1748     (test-span '(1 -1) '(1) '(-1)))
1749
1750   (pass-if "nn"
1751     (test-span '(-1 -2) '() '(-1 -2)))
1752
1753   (pass-if "yyy"
1754     (test-span '(1 2 3) '(1 2 3) '()))
1755
1756   (pass-if "nyy"
1757     (test-span '(-1 1 2) '() '(-1 1 2)))
1758
1759   (pass-if "yny"
1760     (test-span '(1 -1 2) '(1) '(-1 2)))
1761
1762   (pass-if "nny"
1763     (test-span '(-1 -2 1) '() '(-1 -2 1)))
1764
1765   (pass-if "yyn"
1766     (test-span '(1 2 -1) '(1 2) '(-1)))
1767
1768   (pass-if "nyn"
1769     (test-span '(-1 1 -2) '() '(-1 1 -2)))
1770
1771   (pass-if "ynn"
1772     (test-span '(1 -1 -2) '(1) '(-1 -2)))
1773
1774   (pass-if "nnn"
1775     (test-span '(-1 -2 -3) '() '(-1 -2 -3))))
1776
1777 ;;
1778 ;; span!
1779 ;;
1780
1781 (with-test-prefix "span!"
1782
1783   (define (test-span! lst want-v1 want-v2)
1784     (call-with-values
1785         (lambda ()
1786           (span! positive? lst))
1787       (lambda (got-v1 got-v2)
1788         (and (equal? got-v1 want-v1)
1789              (equal? got-v2 want-v2)))))
1790
1791   (pass-if "empty"
1792     (test-span! '() '() '()))
1793
1794   (pass-if "y"
1795     (test-span! (list 1) '(1) '()))
1796
1797   (pass-if "n"
1798     (test-span! (list -1) '() '(-1)))
1799
1800   (pass-if "yy"
1801     (test-span! (list 1 2) '(1 2) '()))
1802
1803   (pass-if "ny"
1804     (test-span! (list -1 1) '() '(-1 1)))
1805
1806   (pass-if "yn"
1807     (test-span! (list 1 -1) '(1) '(-1)))
1808
1809   (pass-if "nn"
1810     (test-span! (list -1 -2) '() '(-1 -2)))
1811
1812   (pass-if "yyy"
1813     (test-span! (list 1 2 3) '(1 2 3) '()))
1814
1815   (pass-if "nyy"
1816     (test-span! (list -1 1 2) '() '(-1 1 2)))
1817
1818   (pass-if "yny"
1819     (test-span! (list 1 -1 2) '(1) '(-1 2)))
1820
1821   (pass-if "nny"
1822     (test-span! (list -1 -2 1) '() '(-1 -2 1)))
1823
1824   (pass-if "yyn"
1825     (test-span! (list 1 2 -1) '(1 2) '(-1)))
1826
1827   (pass-if "nyn"
1828     (test-span! (list -1 1 -2) '() '(-1 1 -2)))
1829
1830   (pass-if "ynn"
1831     (test-span! (list 1 -1 -2) '(1) '(-1 -2)))
1832
1833   (pass-if "nnn"
1834     (test-span! (list -1 -2 -3) '() '(-1 -2 -3))))
1835
1836 ;;
1837 ;; take!
1838 ;;
1839
1840 (with-test-prefix "take!"
1841
1842   (pass-if-exception "() -1" exception:out-of-range
1843     (take! '() -1))
1844   (pass-if (equal? '() (take! '() 0)))
1845   (pass-if-exception "() 1" exception:wrong-type-arg
1846     (take! '() 1))
1847
1848   (pass-if-exception "(1) -1" exception:out-of-range
1849     (take! '(1) -1))
1850   (pass-if (equal? '() (take! '(1) 0)))
1851   (pass-if (equal? '(1) (take! '(1) 1)))
1852   (pass-if-exception "(1) 2" exception:wrong-type-arg
1853     (take! '(1) 2))
1854
1855   (pass-if-exception "(4 5) -1" exception:out-of-range
1856     (take! '(4 5) -1))
1857   (pass-if (equal? '() (take! '(4 5) 0)))
1858   (pass-if (equal? '(4) (take! '(4 5) 1)))
1859   (pass-if (equal? '(4 5) (take! '(4 5) 2)))
1860   (pass-if-exception "(4 5) 3" exception:wrong-type-arg
1861     (take! '(4 5) 3))
1862
1863   (pass-if-exception "(4 5 6) -1" exception:out-of-range
1864     (take! '(4 5 6) -1))
1865   (pass-if (equal? '() (take! '(4 5 6) 0)))
1866   (pass-if (equal? '(4) (take! '(4 5 6) 1)))
1867   (pass-if (equal? '(4 5) (take! '(4 5 6) 2)))
1868   (pass-if (equal? '(4 5 6) (take! '(4 5 6) 3)))
1869   (pass-if-exception "(4 5 6) 4" exception:wrong-type-arg
1870     (take! '(4 5 6) 4)))
1871
1872
1873 ;;
1874 ;; take-right
1875 ;;
1876
1877 (with-test-prefix "take-right"
1878
1879   (pass-if-exception "() -1" exception:out-of-range
1880     (take-right '() -1))
1881   (pass-if (equal? '() (take-right '() 0)))
1882   (pass-if-exception "() 1" exception:wrong-type-arg
1883     (take-right '() 1))
1884
1885   (pass-if-exception "(1) -1" exception:out-of-range
1886     (take-right '(1) -1))
1887   (pass-if (equal? '() (take-right '(1) 0)))
1888   (pass-if (equal? '(1) (take-right '(1) 1)))
1889   (pass-if-exception "(1) 2" exception:wrong-type-arg
1890     (take-right '(1) 2))
1891
1892   (pass-if-exception "(4 5) -1" exception:out-of-range
1893     (take-right '(4 5) -1))
1894   (pass-if (equal? '() (take-right '(4 5) 0)))
1895   (pass-if (equal? '(5) (take-right '(4 5) 1)))
1896   (pass-if (equal? '(4 5) (take-right '(4 5) 2)))
1897   (pass-if-exception "(4 5) 3" exception:wrong-type-arg
1898     (take-right '(4 5) 3))
1899
1900   (pass-if-exception "(4 5 6) -1" exception:out-of-range
1901     (take-right '(4 5 6) -1))
1902   (pass-if (equal? '() (take-right '(4 5 6) 0)))
1903   (pass-if (equal? '(6) (take-right '(4 5 6) 1)))
1904   (pass-if (equal? '(5 6) (take-right '(4 5 6) 2)))
1905   (pass-if (equal? '(4 5 6) (take-right '(4 5 6) 3)))
1906   (pass-if-exception "(4 5 6) 4" exception:wrong-type-arg
1907     (take-right '(4 5 6) 4)))
1908
1909