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