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 ;; concatenate and concatenate!
 206 ;;
 207
 208 (let ()
 209   (define (common-tests concatenate-proc unmodified?)
 210     (define (try lstlst want)
 211       (let ((lstlst-copy (copy-tree lstlst))
 212             (got         (concatenate-proc lstlst)))
 213         (if unmodified?
 214             (if (not (equal? lstlst lstlst-copy))
 215                 (error "input lists modified")))
 216         (equal? got want)))
 217
 218     (pass-if-exception "too few args" exception:wrong-num-args
 219       (concatenate-proc))
 220
 221     (pass-if-exception "too many args" exception:wrong-num-args
 222       (concatenate-proc '() '()))
 223
 224     (pass-if "no lists"
 225       (try '() '()))
 226
 227     (pass-if (try '((1))       '(1)))
 228     (pass-if (try '((1 2))     '(1 2)))
 229     (pass-if (try '(() (1))    '(1)))
 230     (pass-if (try '(() () (1)) '(1)))
 231
 232     (pass-if (try '((1) (2)) '(1 2)))
 233     (pass-if (try '(() (1 2)) '(1 2)))
 234
 235     (pass-if (try '((1) 2)           '(1 . 2)))
 236     (pass-if (try '((1) (2) 3)       '(1 2 . 3)))
 237     (pass-if (try '((1) (2) (3 . 4)) '(1 2 3 . 4)))
 238     )
 239
 240   (with-test-prefix "concatenate"
 241     (common-tests concatenate #t))
 242
 243   (with-test-prefix "concatenate!"
 244     (common-tests concatenate! #f)))
 245
 246 ;;
 247 ;; count
 248 ;;
 249
 250 (with-test-prefix "count"
 251   (pass-if-exception "no args" exception:wrong-num-args
 252     (count))
 253
 254   (pass-if-exception "one arg" exception:wrong-num-args
 255     (count noop))
 256
 257   (with-test-prefix "one list"
 258     (define (or1 x)
 259       x)
 260
 261     (pass-if "empty list" (= 0 (count or1 '())))
 262
 263     (pass-if-exception "pred arg count 0" exception:wrong-type-arg
 264       (count (lambda () x) '(1 2 3)))
 265     (pass-if-exception "pred arg count 2" exception:wrong-type-arg
 266       (count (lambda (x y) x) '(1 2 3)))
 267
 268     (pass-if-exception "improper 1" exception:wrong-type-arg
 269       (count or1 1))
 270     (pass-if-exception "improper 2" exception:wrong-type-arg
 271       (count or1 '(1 . 2)))
 272     (pass-if-exception "improper 3" exception:wrong-type-arg
 273       (count or1 '(1 2 . 3)))
 274
 275     (pass-if (= 0 (count or1 '(#f))))
 276     (pass-if (= 1 (count or1 '(#t))))
 277
 278     (pass-if (= 0 (count or1 '(#f #f))))
 279     (pass-if (= 1 (count or1 '(#f #t))))
 280     (pass-if (= 1 (count or1 '(#t #f))))
 281     (pass-if (= 2 (count or1 '(#t #t))))
 282
 283     (pass-if (= 0 (count or1 '(#f #f #f))))
 284     (pass-if (= 1 (count or1 '(#f #f #t))))
 285     (pass-if (= 1 (count or1 '(#t #f #f))))
 286     (pass-if (= 2 (count or1 '(#t #f #t))))
 287     (pass-if (= 3 (count or1 '(#t #t #t)))))
 288
 289   (with-test-prefix "two lists"
 290     (define (or2 x y)
 291       (or x y))
 292
 293     (pass-if "arg order"
 294       (= 1 (count (lambda (x y)
 295                     (and (= 1 x)
 296                          (= 2 y)))
 297                   '(1) '(2))))
 298
 299     (pass-if "empty lists" (= 0 (count or2 '() '())))
 300
 301     (pass-if-exception "pred arg count 0" exception:wrong-type-arg
 302       (count (lambda () #t) '(1 2 3) '(1 2 3)))
 303     (pass-if-exception "pred arg count 1" exception:wrong-type-arg
 304       (count (lambda (x) x) '(1 2 3) '(1 2 3)))
 305     (pass-if-exception "pred arg count 3" exception:wrong-type-arg
 306       (count (lambda (x y z) x) '(1 2 3) '(1 2 3)))
 307
 308     (pass-if-exception "improper first 1" exception:wrong-type-arg
 309       (count or2 1 '(1 2 3)))
 310     (pass-if-exception "improper first 2" exception:wrong-type-arg
 311       (count or2 '(1 . 2) '(1 2 3)))
 312     (pass-if-exception "improper first 3" exception:wrong-type-arg
 313       (count or2 '(1 2 . 3) '(1 2 3)))
 314
 315     (pass-if-exception "improper second 1" exception:wrong-type-arg
 316       (count or2 '(1 2 3) 1))
 317     (pass-if-exception "improper second 2" exception:wrong-type-arg
 318       (count or2 '(1 2 3) '(1 . 2)))
 319     (pass-if-exception "improper second 3" exception:wrong-type-arg
 320       (count or2 '(1 2 3) '(1 2 . 3)))
 321
 322     (pass-if (= 0 (count or2 '(#f) '(#f))))
 323     (pass-if (= 1 (count or2 '(#t) '(#f))))
 324     (pass-if (= 1 (count or2 '(#f) '(#t))))
 325
 326     (pass-if (= 0 (count or2 '(#f #f) '(#f #f))))
 327     (pass-if (= 1 (count or2 '(#t #f) '(#t #f))))
 328     (pass-if (= 2 (count or2 '(#t #t) '(#f #f))))
 329     (pass-if (= 2 (count or2 '(#t #f) '(#f #t))))
 330
 331     (with-test-prefix "stop shortest"
 332       (pass-if (= 2 (count or2 '(#t #f #t) '(#f #t))))
 333       (pass-if (= 2 (count or2 '(#t #f #t #t) '(#f #t))))
 334       (pass-if (= 2 (count or2 '(#t #f) '(#f #t #t))))
 335       (pass-if (= 2 (count or2 '(#t #f) '(#f #t #t #t))))))
 336
 337   (with-test-prefix "three lists"
 338     (define (or3 x y z)
 339       (or x y z))
 340
 341     (pass-if "arg order"
 342       (= 1 (count (lambda (x y z)
 343                     (and (= 1 x)
 344                          (= 2 y)
 345                          (= 3 z)))
 346                   '(1) '(2) '(3))))
 347
 348     (pass-if "empty lists" (= 0 (count or3 '() '() '())))
 349
 350     ;; currently bad pred argument gives wrong-num-args when 3 or more
 351     ;; lists, as opposed to wrong-type-arg for 1 or 2 lists
 352     (pass-if-exception "pred arg count 0" exception:wrong-num-args
 353       (count (lambda () #t) '(1 2 3) '(1 2 3) '(1 2 3)))
 354     (pass-if-exception "pred arg count 2" exception:wrong-num-args
 355       (count (lambda (x y) x) '(1 2 3) '(1 2 3)'(1 2 3) ))
 356     (pass-if-exception "pred arg count 4" exception:wrong-num-args
 357       (count (lambda (w x y z) x) '(1 2 3) '(1 2 3) '(1 2 3)))
 358
 359     (pass-if-exception "improper first 1" exception:wrong-type-arg
 360       (count or3 1 '(1 2 3) '(1 2 3)))
 361     (pass-if-exception "improper first 2" exception:wrong-type-arg
 362       (count or3 '(1 . 2) '(1 2 3) '(1 2 3)))
 363     (pass-if-exception "improper first 3" exception:wrong-type-arg
 364       (count or3 '(1 2 . 3) '(1 2 3) '(1 2 3)))
 365
 366     (pass-if-exception "improper second 1" exception:wrong-type-arg
 367       (count or3 '(1 2 3) 1 '(1 2 3)))
 368     (pass-if-exception "improper second 2" exception:wrong-type-arg
 369       (count or3 '(1 2 3) '(1 . 2) '(1 2 3)))
 370     (pass-if-exception "improper second 3" exception:wrong-type-arg
 371       (count or3 '(1 2 3) '(1 2 . 3) '(1 2 3)))
 372
 373     (pass-if-exception "improper third 1" exception:wrong-type-arg
 374       (count or3 '(1 2 3) '(1 2 3) 1))
 375     (pass-if-exception "improper third 2" exception:wrong-type-arg
 376       (count or3 '(1 2 3) '(1 2 3) '(1 . 2)))
 377     (pass-if-exception "improper third 3" exception:wrong-type-arg
 378       (count or3 '(1 2 3) '(1 2 3) '(1 2 . 3)))
 379
 380     (pass-if (= 0 (count or3 '(#f) '(#f) '(#f))))
 381     (pass-if (= 1 (count or3 '(#t) '(#f) '(#f))))
 382     (pass-if (= 1 (count or3 '(#f) '(#t) '(#f))))
 383     (pass-if (= 1 (count or3 '(#f) '(#f) '(#t))))
 384
 385     (pass-if (= 0 (count or3 '(#f #f) '(#f #f) '(#f #f))))
 386
 387     (pass-if (= 1 (count or3 '(#t #f) '(#f #f) '(#f #f))))
 388     (pass-if (= 1 (count or3 '(#f #t) '(#f #f) '(#f #f))))
 389     (pass-if (= 1 (count or3 '(#f #f) '(#t #f) '(#f #f))))
 390     (pass-if (= 1 (count or3 '(#f #f) '(#f #t) '(#f #f))))
 391     (pass-if (= 1 (count or3 '(#f #f) '(#f #f) '(#t #f))))
 392     (pass-if (= 1 (count or3 '(#f #f) '(#f #f) '(#f #t))))
 393
 394     (pass-if (= 2 (count or3 '(#t #t) '(#f #f) '(#f #f))))
 395     (pass-if (= 2 (count or3 '(#f #f) '(#t #t) '(#f #f))))
 396     (pass-if (= 2 (count or3 '(#f #f) '(#f #f) '(#t #t))))
 397     (pass-if (= 2 (count or3 '(#f #f) '(#t #f) '(#f #t))))
 398
 399     (with-test-prefix "stop shortest"
 400       (pass-if (= 0 (count or3 '() '(#t #t #t) '(#t #t))))
 401       (pass-if (= 0 (count or3 '(#t #t #t) '() '(#t #t))))
 402       (pass-if (= 0 (count or3 '(#t #t #t) '(#t #t) '())))
 403
 404       (pass-if (= 1 (count or3 '(#t) '(#t #t #t) '(#t #t))))
 405       (pass-if (= 1 (count or3 '(#t #t #t) '(#t) '(#t #t))))
 406       (pass-if (= 1 (count or3 '(#t #t #t) '(#t #t) '(#t)))))))
 407
 408 ;;
 409 ;; delete and delete!
 410 ;;
 411
 412 (let ()
 413   ;; Call (PROC lst) for all lists of length up to 6, with all combinations
 414   ;; of elements to be retained or deleted.  Elements to retain are numbers,
 415   ;; 0 upwards.  Elements to be deleted are #f.
 416   (define (test-lists proc)
 417     (do ((n 0 (1+ n)))
 418         ((>= n 6))
 419       (do ((limit (ash 1 n))
 420            (i 0 (1+ i)))
 421           ((>= i limit))
 422         (let ((lst '()))
 423           (do ((bit 0 (1+ bit)))
 424               ((>= bit n))
 425             (set! lst  (cons (if (logbit? bit i) bit #f) lst)))
 426           (proc lst)))))
 427
 428   (define (common-tests delete-proc)
 429     (pass-if-exception "too few args" exception:wrong-num-args
 430       (delete-proc 0))
 431
 432     (pass-if-exception "too many args" exception:wrong-num-args
 433       (delete-proc 0 '() equal? 99))
 434
 435     (pass-if "empty"
 436       (eq? '() (delete-proc 0 '())))
 437
 438     (pass-if "equal? (the default)"
 439       (equal? '((1) (3))
 440               (delete-proc '(2) '((1) (2) (3)))))
 441
 442     (pass-if "eq?"
 443       (equal? '((1) (2) (3))
 444               (delete-proc '(2) '((1) (2) (3)) eq?)))
 445
 446     (pass-if "called arg order"
 447       (equal? '(1 2 3)
 448               (delete-proc 3 '(1 2 3 4 5) <))))
 449
 450   (with-test-prefix "delete"
 451     (common-tests delete)
 452
 453     (test-lists
 454      (lambda (lst)
 455        (let ((lst-copy (list-copy lst)))
 456          (with-test-prefix lst-copy
 457            (pass-if "result"
 458              (equal? (delete     #f lst)
 459                      (ref-delete #f lst)))
 460            (pass-if "non-destructive"
 461              (equal? lst-copy lst)))))))
 462
 463   (with-test-prefix "delete!"
 464     (common-tests delete!)
 465
 466     (test-lists
 467      (lambda (lst)
 468        (pass-if lst
 469          (equal? (delete!    #f lst)
 470                  (ref-delete #f lst)))))))
 471
 472 ;;
 473 ;; delete-duplicates and delete-duplicates!
 474 ;;
 475
 476 (let ()
 477   ;; Call (PROC lst) for all lists of length 1 <= n <= 4, with all
 478   ;; combinations of numbers 1 to n in the elements
 479   (define (test-lists proc)
 480     (do ((n 1 (1+ n)))
 481         ((> n 4))
 482       (do ((limit (integer-expt n n))
 483            (i 0 (1+ i)))
 484           ((>= i limit))
 485         (let ((lst '()))
 486           (do ((j 0 (1+ j))
 487                (rem i (quotient rem n)))
 488               ((>= j n))
 489             (set! lst (cons (remainder rem n) lst)))
 490           (proc lst)))))
 491
 492   (define (common-tests delete-duplicates-proc)
 493     (pass-if-exception "too few args" exception:wrong-num-args
 494       (delete-duplicates-proc))
 495
 496     (pass-if-exception "too many args" exception:wrong-num-args
 497       (delete-duplicates-proc '() equal? 99))
 498
 499     (pass-if "empty"
 500       (eq? '() (delete-duplicates-proc '())))
 501
 502     (pass-if "equal? (the default)"
 503       (equal? '((2))
 504               (delete-duplicates-proc '((2) (2) (2)))))
 505
 506     (pass-if "eq?"
 507       (equal? '((2) (2) (2))
 508               (delete-duplicates-proc '((2) (2) (2)) eq?)))
 509
 510     (pass-if "called arg order"
 511       (let ((ok #t))
 512         (delete-duplicates-proc '(1 2 3 4 5)
 513                                 (lambda (x y)
 514                                   (if (> x y)
 515                                       (set! ok #f))
 516                                   #f))
 517         ok)))
 518
 519   (with-test-prefix "delete-duplicates"
 520     (common-tests delete-duplicates)
 521
 522     (test-lists
 523      (lambda (lst)
 524        (let ((lst-copy (list-copy lst)))
 525          (with-test-prefix lst-copy
 526            (pass-if "result"
 527              (equal? (delete-duplicates     lst)
 528                      (ref-delete-duplicates lst)))
 529            (pass-if "non-destructive"
 530              (equal? lst-copy lst)))))))
 531
 532   (with-test-prefix "delete-duplicates!"
 533     (common-tests delete-duplicates!)
 534
 535     (test-lists
 536      (lambda (lst)
 537        (pass-if lst
 538          (equal? (delete-duplicates!    lst)
 539                  (ref-delete-duplicates lst)))))))
 540
 541 ;;
 542 ;; drop
 543 ;;
 544
 545 (with-test-prefix "drop"
 546
 547   (pass-if "'() 0"
 548     (null? (drop '() 0)))
 549
 550   (pass-if "'(a) 0"
 551     (let ((lst '(a)))
 552       (eq? lst
 553            (drop lst 0))))
 554
 555   (pass-if "'(a b) 0"
 556     (let ((lst '(a b)))
 557       (eq? lst
 558            (drop lst 0))))
 559
 560   (pass-if "'(a) 1"
 561     (let ((lst '(a)))
 562       (eq? (cdr lst)
 563            (drop lst 1))))
 564
 565   (pass-if "'(a b) 1"
 566     (let ((lst '(a b)))
 567       (eq? (cdr lst)
 568            (drop lst 1))))
 569
 570   (pass-if "'(a b) 2"
 571     (let ((lst '(a b)))
 572       (eq? (cddr lst)
 573            (drop lst 2))))
 574
 575   (pass-if "'(a b c) 1"
 576     (let ((lst '(a b c)))
 577       (eq? (cddr lst)
 578            (drop lst 2))))
 579
 580   (pass-if "circular '(a) 0"
 581     (let ((lst (circular-list 'a)))
 582       (eq? lst
 583            (drop lst 0))))
 584
 585   (pass-if "circular '(a) 1"
 586     (let ((lst (circular-list 'a)))
 587       (eq? lst
 588            (drop lst 1))))
 589
 590   (pass-if "circular '(a) 2"
 591     (let ((lst (circular-list 'a)))
 592       (eq? lst
 593            (drop lst 1))))
 594
 595   (pass-if "circular '(a b) 1"
 596     (let ((lst (circular-list 'a)))
 597       (eq? (cdr lst)
 598            (drop lst 0))))
 599
 600   (pass-if "circular '(a b) 2"
 601     (let ((lst (circular-list 'a)))
 602       (eq? lst
 603            (drop lst 1))))
 604
 605   (pass-if "circular '(a b) 5"
 606     (let ((lst (circular-list 'a)))
 607       (eq? (cdr lst)
 608            (drop lst 5))))
 609
 610   (pass-if "'(a . b) 1"
 611     (eq? 'b
 612          (drop '(a . b) 1)))
 613
 614   (pass-if "'(a b . c) 1"
 615     (equal? 'c
 616             (drop '(a b . c) 2))))
 617
 618 ;;
 619 ;; filter-map
 620 ;;
 621
 622 (with-test-prefix "filter-map"
 623
 624   (with-test-prefix "one list"
 625     (pass-if "(1)"
 626       (equal? '(1) (filter-map noop '(1))))
 627
 628     (pass-if "(#f)"
 629       (equal? '() (filter-map noop '(#f))))
 630
 631     (pass-if "(1 2)"
 632       (equal? '(1 2) (filter-map noop '(1 2))))
 633
 634     (pass-if "(#f 2)"
 635       (equal? '(2) (filter-map noop '(#f 2))))
 636
 637     (pass-if "(#f #f)"
 638       (equal? '() (filter-map noop '(#f #f))))
 639
 640     (pass-if "(1 2 3)"
 641       (equal? '(1 2 3) (filter-map noop '(1 2 3))))
 642
 643     (pass-if "(#f 2 3)"
 644       (equal? '(2 3) (filter-map noop '(#f 2 3))))
 645
 646     (pass-if "(1 #f 3)"
 647       (equal? '(1 3) (filter-map noop '(1 #f 3))))
 648
 649     (pass-if "(1 2 #f)"
 650       (equal? '(1 2) (filter-map noop '(1 2 #f)))))
 651
 652   (with-test-prefix "two lists"
 653     (pass-if "(1 2 3) (4 5 6)"
 654       (equal? '(1 2 3) (filter-map noop '(1 2 3) '(4 5 6))))
 655
 656     (pass-if "(#f 2 3) (4 5)"
 657       (equal? '(2) (filter-map noop '(#f 2 3) '(4 5))))
 658
 659     (pass-if "(4 #f) (1 2 3)"
 660       (equal? '(4) (filter-map noop '(4 #f) '(1 2 3))))))
 661
 662 ;;
 663 ;; length+
 664 ;;
 665
 666 (with-test-prefix "length+"
 667   (pass-if-exception "too few args" exception:wrong-num-args
 668     (length+))
 669   (pass-if-exception "too many args" exception:wrong-num-args
 670     (length+ 123 456))
 671   (pass-if (= 0 (length+ '())))
 672   (pass-if (= 1 (length+ '(x))))
 673   (pass-if (= 2 (length+ '(x y))))
 674   (pass-if (= 3 (length+ '(x y z))))
 675   (pass-if (not (length+ (circular-list 1))))
 676   (pass-if (not (length+ (circular-list 1 2))))
 677   (pass-if (not (length+ (circular-list 1 2 3)))))
 678
 679 ;;
 680 ;; list-copy
 681 ;;
 682
 683 (with-test-prefix "list-copy"
 684   (pass-if (equal? '()          (list-copy '())))
 685   (pass-if (equal? '(1 2)       (list-copy '(1 2))))
 686   (pass-if (equal? '(1 2 3)     (list-copy '(1 2 3))))
 687   (pass-if (equal? '(1 2 3 4)   (list-copy '(1 2 3 4))))
 688   (pass-if (equal? '(1 2 3 4 5) (list-copy '(1 2 3 4 5))))
 689
 690   ;; improper lists can be copied
 691   (pass-if (equal? 1              (list-copy 1)))
 692   (pass-if (equal? '(1 . 2)       (list-copy '(1 . 2))))
 693   (pass-if (equal? '(1 2 . 3)     (list-copy '(1 2 . 3))))
 694   (pass-if (equal? '(1 2 3 . 4)   (list-copy '(1 2 3 . 4))))
 695   (pass-if (equal? '(1 2 3 4 . 5) (list-copy '(1 2 3 4 . 5)))))
 696
 697 ;;
 698 ;; take
 699 ;;
 700
 701 (with-test-prefix "take"
 702
 703   (pass-if "'() 0"
 704     (null? (take '() 0)))
 705
 706   (pass-if "'(a) 0"
 707     (null? (take '(a) 0)))
 708
 709   (pass-if "'(a b) 0"
 710     (null? (take '() 0)))
 711
 712   (pass-if "'(a b c) 0"
 713     (null? (take '() 0)))
 714
 715   (pass-if "'(a) 1"
 716     (let* ((lst '(a))
 717            (got (take lst 1)))
 718       (and (equal? '(a) got)
 719            (not (eq? lst got)))))
 720
 721   (pass-if "'(a b) 1"
 722     (equal? '(a)
 723             (take '(a b) 1)))
 724
 725   (pass-if "'(a b c) 1"
 726     (equal? '(a)
 727             (take '(a b c) 1)))
 728
 729   (pass-if "'(a b) 2"
 730     (let* ((lst '(a b))
 731            (got (take lst 2)))
 732       (and (equal? '(a b) got)
 733            (not (eq? lst got)))))
 734
 735   (pass-if "'(a b c) 2"
 736     (equal? '(a b)
 737             (take '(a b c) 2)))
 738
 739   (pass-if "circular '(a) 0"
 740     (equal? '()
 741             (take (circular-list 'a) 0)))
 742
 743   (pass-if "circular '(a) 1"
 744     (equal? '(a)
 745             (take (circular-list 'a) 1)))
 746
 747   (pass-if "circular '(a) 2"
 748     (equal? '(a a)
 749             (take (circular-list 'a) 2)))
 750
 751   (pass-if "circular '(a b) 5"
 752     (equal? '(a b a b a)
 753             (take (circular-list 'a 'b) 5)))
 754
 755   (pass-if "'(a . b) 1"
 756     (equal? '(a)
 757             (take '(a . b) 1)))
 758
 759   (pass-if "'(a b . c) 1"
 760     (equal? '(a)
 761             (take '(a b . c) 1)))
 762
 763   (pass-if "'(a b . c) 2"
 764     (equal? '(a b)
 765             (take '(a b . c) 2))))
 766
 767 ;;
 768 ;; partition
 769 ;;
 770
 771 (define (test-partition pred list kept-good dropped-good)
 772   (call-with-values (lambda ()
 773                         (partition pred list))
 774       (lambda (kept dropped)
 775         (and (equal? kept kept-good)
 776              (equal? dropped dropped-good)))))
 777
 778 (with-test-prefix "partition"
 779
 780   (pass-if "with dropped tail"
 781     (test-partition even? '(1 2 3 4 5 6 7)
 782                     '(2 4 6) '(1 3 5 7)))
 783
 784   (pass-if "with kept tail"
 785     (test-partition even? '(1 2 3 4 5 6)
 786                     '(2 4 6) '(1 3 5)))
 787
 788   (pass-if "with everything dropped"
 789     (test-partition even? '(1 3 5 7)
 790                     '() '(1 3 5 7)))
 791
 792   (pass-if "with everything kept"
 793     (test-partition even? '(2 4 6)
 794                     '(2 4 6) '()))
 795
 796   (pass-if "with empty list"
 797     (test-partition even? '()
 798                     '() '()))
 799
 800   (pass-if "with reasonably long list"
 801     ;; the old implementation from SRFI-1 reference implementation
 802     ;; would signal a stack-overflow for a list of only 500 elements!
 803     (call-with-values (lambda ()
 804                         (partition even?
 805                                    (make-list 10000 1)))
 806       (lambda (even odd)
 807         (and (= (length odd) 10000)
 808              (= (length even) 0))))))
 809