test-suite/tests/srfi-1.test

   1 ;;;; srfi-1.test --- Test suite for Guile's SRFI-1 functions. -*- scheme -*-
   2 ;;;;
   3 ;;;; Copyright 2003, 2004 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 ;; filter-map
 679 ;;
 680
 681 (with-test-prefix "filter-map"
 682
 683   (with-test-prefix "one list"
 684     (pass-if "(1)"
 685       (equal? '(1) (filter-map noop '(1))))
 686
 687     (pass-if "(#f)"
 688       (equal? '() (filter-map noop '(#f))))
 689
 690     (pass-if "(1 2)"
 691       (equal? '(1 2) (filter-map noop '(1 2))))
 692
 693     (pass-if "(#f 2)"
 694       (equal? '(2) (filter-map noop '(#f 2))))
 695
 696     (pass-if "(#f #f)"
 697       (equal? '() (filter-map noop '(#f #f))))
 698
 699     (pass-if "(1 2 3)"
 700       (equal? '(1 2 3) (filter-map noop '(1 2 3))))
 701
 702     (pass-if "(#f 2 3)"
 703       (equal? '(2 3) (filter-map noop '(#f 2 3))))
 704
 705     (pass-if "(1 #f 3)"
 706       (equal? '(1 3) (filter-map noop '(1 #f 3))))
 707
 708     (pass-if "(1 2 #f)"
 709       (equal? '(1 2) (filter-map noop '(1 2 #f)))))
 710
 711   (with-test-prefix "two lists"
 712     (pass-if "(1 2 3) (4 5 6)"
 713       (equal? '(1 2 3) (filter-map noop '(1 2 3) '(4 5 6))))
 714
 715     (pass-if "(#f 2 3) (4 5)"
 716       (equal? '(2) (filter-map noop '(#f 2 3) '(4 5))))
 717
 718     (pass-if "(4 #f) (1 2 3)"
 719       (equal? '(4) (filter-map noop '(4 #f) '(1 2 3))))))
 720
 721 ;;
 722 ;; length+
 723 ;;
 724
 725 (with-test-prefix "length+"
 726   (pass-if-exception "too few args" exception:wrong-num-args
 727     (length+))
 728   (pass-if-exception "too many args" exception:wrong-num-args
 729     (length+ 123 456))
 730   (pass-if (= 0 (length+ '())))
 731   (pass-if (= 1 (length+ '(x))))
 732   (pass-if (= 2 (length+ '(x y))))
 733   (pass-if (= 3 (length+ '(x y z))))
 734   (pass-if (not (length+ (circular-list 1))))
 735   (pass-if (not (length+ (circular-list 1 2))))
 736   (pass-if (not (length+ (circular-list 1 2 3)))))
 737
 738 ;;
 739 ;; list-copy
 740 ;;
 741
 742 (with-test-prefix "list-copy"
 743   (pass-if (equal? '()          (list-copy '())))
 744   (pass-if (equal? '(1 2)       (list-copy '(1 2))))
 745   (pass-if (equal? '(1 2 3)     (list-copy '(1 2 3))))
 746   (pass-if (equal? '(1 2 3 4)   (list-copy '(1 2 3 4))))
 747   (pass-if (equal? '(1 2 3 4 5) (list-copy '(1 2 3 4 5))))
 748
 749   ;; improper lists can be copied
 750   (pass-if (equal? 1              (list-copy 1)))
 751   (pass-if (equal? '(1 . 2)       (list-copy '(1 . 2))))
 752   (pass-if (equal? '(1 2 . 3)     (list-copy '(1 2 . 3))))
 753   (pass-if (equal? '(1 2 3 . 4)   (list-copy '(1 2 3 . 4))))
 754   (pass-if (equal? '(1 2 3 4 . 5) (list-copy '(1 2 3 4 . 5)))))
 755
 756 ;;
 757 ;; lset=
 758 ;;
 759
 760 (with-test-prefix "lset="
 761
 762   ;; in guile 1.6.7 and earlier, lset= incorrectly demanded at least one
 763   ;; list arg
 764   (pass-if "no args"
 765     (eq? #t (lset= eq?)))
 766
 767   (with-test-prefix "one arg"
 768
 769     (pass-if "()"
 770       (eq? #t (lset= eqv? '())))
 771
 772     (pass-if "(1)"
 773       (eq? #t (lset= eqv? '(1))))
 774
 775     (pass-if "(1 2)"
 776       (eq? #t (lset= eqv? '(1 2)))))
 777
 778   (with-test-prefix "two args"
 779
 780     (pass-if "() ()"
 781       (eq? #t (lset= eqv? '() '())))
 782
 783     (pass-if "(1) (1)"
 784       (eq? #t (lset= eqv? '(1) '(1))))
 785
 786     (pass-if "(1) (2)"
 787       (eq? #f (lset= eqv? '(1) '(2))))
 788
 789     (pass-if "(1) (1 2)"
 790       (eq? #f (lset= eqv? '(1) '(1 2))))
 791
 792     (pass-if "(1 2) (2 1)"
 793       (eq? #t (lset= eqv? '(1 2) '(2 1))))
 794
 795     (pass-if "called arg order"
 796       (let ((good #t))
 797         (lset= (lambda (x y)
 798                  (if (not (= x (1- y)))
 799                      (set! good #f))
 800                  #t)
 801                '(1 1) '(2 2))
 802         good)))
 803
 804   (with-test-prefix "three args"
 805
 806     (pass-if "() () ()"
 807       (eq? #t (lset= eqv? '() '() '())))
 808
 809     (pass-if "(1) (1) (1)"
 810       (eq? #t (lset= eqv? '(1) '(1) '(1))))
 811
 812     (pass-if "(1) (1) (2)"
 813       (eq? #f (lset= eqv? '(1) '(1) '(2))))
 814
 815     (pass-if "(1) (1) (1 2)"
 816       (eq? #f (lset= eqv? '(1) '(1) '(1 2))))
 817
 818     (pass-if "(1 2 3) (3 2 1) (1 3 2)"
 819       (eq? #t (lset= eqv? '(1 2 3) '(3 2 1) '(1 3 2))))
 820
 821     (pass-if "called arg order"
 822       (let ((good #t))
 823         (lset= (lambda (x y)
 824                  (if (not (= x (1- y)))
 825                      (set! good #f))
 826                  #t)
 827                '(1 1) '(2 2) '(3 3))
 828         good))))
 829
 830 ;;
 831 ;; lset-adjoin
 832 ;;
 833
 834 (with-test-prefix "lset-adjoin"
 835
 836   (pass-if "no args"
 837     (eq? #t (lset= eq?)))
 838
 839   ;; in guile 1.6.7 and earlier, lset-adjoin didn't actually use the given
 840   ;; `=' procedure, all comparisons were just with `equal?
 841   ;;
 842   (with-test-prefix "case-insensitive ="
 843
 844     (pass-if "(\"x\") \"X\""
 845       (equal? '("x") (lset-adjoin string-ci=? '("x") "X"))))
 846
 847   (pass-if "called arg order"
 848     (let ((good #f))
 849       (lset-adjoin (lambda (x y)
 850                      (set! good (and (= x 1) (= y 2))))
 851                    '(1) 2)
 852       good))
 853
 854   (pass-if "called against arg list only"
 855     (let ((good #t))
 856       (lset-adjoin (lambda (x y)
 857                      (set! good (and good
 858                                      (= x 1)
 859                                      (or (= y 2) (= y 3)))))
 860                    '(1) 2 3)
 861       good)))
 862
 863 ;;
 864 ;; member
 865 ;;
 866
 867 (with-test-prefix "member"
 868
 869   (pass-if-exception "no args" exception:wrong-num-args
 870     (member))
 871
 872   (pass-if-exception "one arg" exception:wrong-num-args
 873     (member 1))
 874
 875   (pass-if "1 (1 2 3)"
 876     (let ((lst '(1 2 3)))
 877       (eq? lst (member 1 lst))))
 878
 879   (pass-if "2 (1 2 3)"
 880     (let ((lst '(1 2 3)))
 881       (eq? (cdr lst) (member 2 lst))))
 882
 883   (pass-if "3 (1 2 3)"
 884     (let ((lst '(1 2 3)))
 885       (eq? (cddr lst) (member 3 lst))))
 886
 887   (pass-if "4 (1 2 3)"
 888     (let ((lst '(1 2 3)))
 889       (eq? #f (member 4 lst))))
 890
 891   (pass-if "called arg order"
 892     (let ((good #f))
 893       (member 1 '(2) (lambda (x y)
 894                        (set! good (and (eqv? 1 x)
 895                                        (eqv? 2 y)))))
 896       good)))
 897
 898 ;;
 899 ;; take
 900 ;;
 901
 902 (with-test-prefix "take"
 903
 904   (pass-if "'() 0"
 905     (null? (take '() 0)))
 906
 907   (pass-if "'(a) 0"
 908     (null? (take '(a) 0)))
 909
 910   (pass-if "'(a b) 0"
 911     (null? (take '() 0)))
 912
 913   (pass-if "'(a b c) 0"
 914     (null? (take '() 0)))
 915
 916   (pass-if "'(a) 1"
 917     (let* ((lst '(a))
 918            (got (take lst 1)))
 919       (and (equal? '(a) got)
 920            (not (eq? lst got)))))
 921
 922   (pass-if "'(a b) 1"
 923     (equal? '(a)
 924             (take '(a b) 1)))
 925
 926   (pass-if "'(a b c) 1"
 927     (equal? '(a)
 928             (take '(a b c) 1)))
 929
 930   (pass-if "'(a b) 2"
 931     (let* ((lst '(a b))
 932            (got (take lst 2)))
 933       (and (equal? '(a b) got)
 934            (not (eq? lst got)))))
 935
 936   (pass-if "'(a b c) 2"
 937     (equal? '(a b)
 938             (take '(a b c) 2)))
 939
 940   (pass-if "circular '(a) 0"
 941     (equal? '()
 942             (take (circular-list 'a) 0)))
 943
 944   (pass-if "circular '(a) 1"
 945     (equal? '(a)
 946             (take (circular-list 'a) 1)))
 947
 948   (pass-if "circular '(a) 2"
 949     (equal? '(a a)
 950             (take (circular-list 'a) 2)))
 951
 952   (pass-if "circular '(a b) 5"
 953     (equal? '(a b a b a)
 954             (take (circular-list 'a 'b) 5)))
 955
 956   (pass-if "'(a . b) 1"
 957     (equal? '(a)
 958             (take '(a . b) 1)))
 959
 960   (pass-if "'(a b . c) 1"
 961     (equal? '(a)
 962             (take '(a b . c) 1)))
 963
 964   (pass-if "'(a b . c) 2"
 965     (equal? '(a b)
 966             (take '(a b . c) 2))))
 967
 968 ;;
 969 ;; partition
 970 ;;
 971
 972 (define (test-partition pred list kept-good dropped-good)
 973   (call-with-values (lambda ()
 974                         (partition pred list))
 975       (lambda (kept dropped)
 976         (and (equal? kept kept-good)
 977              (equal? dropped dropped-good)))))
 978
 979 (with-test-prefix "partition"
 980
 981   (pass-if "with dropped tail"
 982     (test-partition even? '(1 2 3 4 5 6 7)
 983                     '(2 4 6) '(1 3 5 7)))
 984
 985   (pass-if "with kept tail"
 986     (test-partition even? '(1 2 3 4 5 6)
 987                     '(2 4 6) '(1 3 5)))
 988
 989   (pass-if "with everything dropped"
 990     (test-partition even? '(1 3 5 7)
 991                     '() '(1 3 5 7)))
 992
 993   (pass-if "with everything kept"
 994     (test-partition even? '(2 4 6)
 995                     '(2 4 6) '()))
 996
 997   (pass-if "with empty list"
 998     (test-partition even? '()
 999                     '() '()))
1000
1001   (pass-if "with reasonably long list"
1002     ;; the old implementation from SRFI-1 reference implementation
1003     ;; would signal a stack-overflow for a list of only 500 elements!
1004     (call-with-values (lambda ()
1005                         (partition even?
1006                                    (make-list 10000 1)))
1007       (lambda (even odd)
1008         (and (= (length odd) 10000)
1009              (= (length even) 0))))))
1010
1011 ;;
1012 ;; span
1013 ;;
1014
1015 (with-test-prefix "span"
1016
1017   (define (test-span lst want-v1 want-v2)
1018     (call-with-values
1019         (lambda ()
1020           (span positive? lst))
1021       (lambda (got-v1 got-v2)
1022         (and (equal? got-v1 want-v1)
1023              (equal? got-v2 want-v2)))))
1024
1025   (pass-if "empty"
1026     (test-span '() '() '()))
1027
1028   (pass-if "y"
1029     (test-span '(1) '(1) '()))
1030
1031   (pass-if "n"
1032     (test-span '(-1) '() '(-1)))
1033
1034   (pass-if "yy"
1035     (test-span '(1 2) '(1 2) '()))
1036
1037   (pass-if "ny"
1038     (test-span '(-1 1) '() '(-1 1)))
1039
1040   (pass-if "yn"
1041     (test-span '(1 -1) '(1) '(-1)))
1042
1043   (pass-if "nn"
1044     (test-span '(-1 -2) '() '(-1 -2)))
1045
1046   (pass-if "yyy"
1047     (test-span '(1 2 3) '(1 2 3) '()))
1048
1049   (pass-if "nyy"
1050     (test-span '(-1 1 2) '() '(-1 1 2)))
1051
1052   (pass-if "yny"
1053     (test-span '(1 -1 2) '(1) '(-1 2)))
1054
1055   (pass-if "nny"
1056     (test-span '(-1 -2 1) '() '(-1 -2 1)))
1057
1058   (pass-if "yyn"
1059     (test-span '(1 2 -1) '(1 2) '(-1)))
1060
1061   (pass-if "nyn"
1062     (test-span '(-1 1 -2) '() '(-1 1 -2)))
1063
1064   (pass-if "ynn"
1065     (test-span '(1 -1 -2) '(1) '(-1 -2)))
1066
1067   (pass-if "nnn"
1068     (test-span '(-1 -2 -3) '() '(-1 -2 -3))))