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