test-suite/tests/srfi-1.test

   1 ;;;; srfi-1.test --- Test suite for Guile's SRFI-1 functions. -*- scheme -*-
   2 ;;;;
   3 ;;;; Copyright 2003 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 ;; concatenate and concatenate!
  48 ;;
  49
  50 (let ()
  51   (define (common-tests concatenate-proc unmodified?)
  52     (define (try lstlst want)
  53       (let ((lstlst-copy (copy-tree lstlst))
  54             (got         (concatenate-proc lstlst)))
  55         (if unmodified?
  56             (if (not (equal? lstlst lstlst-copy))
  57                 (error "input lists modified")))
  58         (equal? got want)))
  59
  60     (pass-if-exception "too few args" exception:wrong-num-args
  61       (concatenate-proc))
  62
  63     (pass-if-exception "too many args" exception:wrong-num-args
  64       (concatenate-proc '() '()))
  65
  66     (pass-if "no lists"
  67       (try '() '()))
  68
  69     (pass-if (try '((1))       '(1)))
  70     (pass-if (try '((1 2))     '(1 2)))
  71     (pass-if (try '(() (1))    '(1)))
  72     (pass-if (try '(() () (1)) '(1)))
  73
  74     (pass-if (try '((1) (2)) '(1 2)))
  75     (pass-if (try '(() (1 2)) '(1 2)))
  76
  77     (pass-if (try '((1) 2)           '(1 . 2)))
  78     (pass-if (try '((1) (2) 3)       '(1 2 . 3)))
  79     (pass-if (try '((1) (2) (3 . 4)) '(1 2 3 . 4)))
  80     )
  81
  82   (with-test-prefix "concatenate"
  83     (common-tests concatenate #t))
  84
  85   (with-test-prefix "concatenate!"
  86     (common-tests concatenate! #f)))
  87
  88
  89 ;;
  90 ;; delete and delete!
  91 ;;
  92
  93 (let ()
  94   ;; Call (PROC lst) for all lists of length up to 6, with all combinations
  95   ;; of elements to be retained or deleted.  Elements to retain are numbers,
  96   ;; 0 upwards.  Elements to be deleted are #f.
  97   (define (test-lists proc)
  98     (do ((n 0 (1+ n)))
  99         ((>= n 6))
 100       (do ((limit (ash 1 n))
 101            (i 0 (1+ i)))
 102           ((>= i limit))
 103         (let ((lst '()))
 104           (do ((bit 0 (1+ bit)))
 105               ((>= bit n))
 106             (set! lst  (cons (if (logbit? bit i) bit #f) lst)))
 107           (proc lst)))))
 108
 109   (define (common-tests delete-proc)
 110     (pass-if-exception "too few args" exception:wrong-num-args
 111       (delete-proc 0))
 112
 113     (pass-if-exception "too many args" exception:wrong-num-args
 114       (delete-proc 0 '() equal? 99))
 115
 116     (pass-if "empty"
 117       (eq? '() (delete-proc 0 '())))
 118
 119     (pass-if "equal? (the default)"
 120       (equal? '((1) (3))
 121               (delete-proc '(2) '((1) (2) (3)))))
 122
 123     (pass-if "eq?"
 124       (equal? '((1) (2) (3))
 125               (delete-proc '(2) '((1) (2) (3)) eq?)))
 126
 127     (pass-if "called arg order"
 128       (equal? '(1 2 3)
 129               (delete-proc 3 '(1 2 3 4 5) <))))
 130
 131   (with-test-prefix "delete"
 132     (common-tests delete)
 133
 134     (test-lists
 135      (lambda (lst)
 136        (let ((lst-copy (list-copy lst)))
 137          (with-test-prefix lst-copy
 138            (pass-if "result"
 139              (equal? (delete     #f lst)
 140                      (ref-delete #f lst)))
 141            (pass-if "non-destructive"
 142              (equal? lst-copy lst)))))))
 143
 144   (with-test-prefix "delete!"
 145     (common-tests delete!)
 146
 147     (test-lists
 148      (lambda (lst)
 149        (pass-if lst
 150          (equal? (delete!    #f lst)
 151                  (ref-delete #f lst)))))))
 152
 153 ;;
 154 ;; delete-duplicates and delete-duplicates!
 155 ;;
 156
 157 (let ()
 158   ;; Call (PROC lst) for all lists of length 1 <= n <= 4, with all
 159   ;; combinations of numbers 1 to n in the elements
 160   (define (test-lists proc)
 161     (do ((n 1 (1+ n)))
 162         ((> n 4))
 163       (do ((limit (integer-expt n n))
 164            (i 0 (1+ i)))
 165           ((>= i limit))
 166         (let ((lst '()))
 167           (do ((j 0 (1+ j))
 168                (rem i (quotient rem n)))
 169               ((>= j n))
 170             (set! lst (cons (remainder rem n) lst)))
 171           (proc lst)))))
 172
 173   (define (common-tests delete-duplicates-proc)
 174     (pass-if-exception "too few args" exception:wrong-num-args
 175       (delete-duplicates-proc))
 176
 177     (pass-if-exception "too many args" exception:wrong-num-args
 178       (delete-duplicates-proc '() equal? 99))
 179
 180     (pass-if "empty"
 181       (eq? '() (delete-duplicates-proc '())))
 182
 183     (pass-if "equal? (the default)"
 184       (equal? '((2))
 185               (delete-duplicates-proc '((2) (2) (2)))))
 186
 187     (pass-if "eq?"
 188       (equal? '((2) (2) (2))
 189               (delete-duplicates-proc '((2) (2) (2)) eq?)))
 190
 191     (pass-if "called arg order"
 192       (let ((ok #t))
 193         (delete-duplicates-proc '(1 2 3 4 5)
 194                                 (lambda (x y)
 195                                   (if (> x y)
 196                                       (set! ok #f))
 197                                   #f))
 198         ok)))
 199
 200   (with-test-prefix "delete-duplicates"
 201     (common-tests delete-duplicates)
 202
 203     (test-lists
 204      (lambda (lst)
 205        (let ((lst-copy (list-copy lst)))
 206          (with-test-prefix lst-copy
 207            (pass-if "result"
 208              (equal? (delete-duplicates     lst)
 209                      (ref-delete-duplicates lst)))
 210            (pass-if "non-destructive"
 211              (equal? lst-copy lst)))))))
 212
 213   (with-test-prefix "delete-duplicates!"
 214     (common-tests delete-duplicates!)
 215
 216     (test-lists
 217      (lambda (lst)
 218        (pass-if lst
 219          (equal? (delete-duplicates!    lst)
 220                  (ref-delete-duplicates lst)))))))
 221
 222 ;;
 223 ;; drop
 224 ;;
 225
 226 (with-test-prefix "drop"
 227
 228   (pass-if "'() 0"
 229     (null? (drop '() 0)))
 230
 231   (pass-if "'(a) 0"
 232     (let ((lst '(a)))
 233       (eq? lst
 234            (drop lst 0))))
 235
 236   (pass-if "'(a b) 0"
 237     (let ((lst '(a b)))
 238       (eq? lst
 239            (drop lst 0))))
 240
 241   (pass-if "'(a) 1"
 242     (let ((lst '(a)))
 243       (eq? (cdr lst)
 244            (drop lst 1))))
 245
 246   (pass-if "'(a b) 1"
 247     (let ((lst '(a b)))
 248       (eq? (cdr lst)
 249            (drop lst 1))))
 250
 251   (pass-if "'(a b) 2"
 252     (let ((lst '(a b)))
 253       (eq? (cddr lst)
 254            (drop lst 2))))
 255
 256   (pass-if "'(a b c) 1"
 257     (let ((lst '(a b c)))
 258       (eq? (cddr lst)
 259            (drop lst 2))))
 260
 261   (pass-if "circular '(a) 0"
 262     (let ((lst (circular-list 'a)))
 263       (eq? lst
 264            (drop lst 0))))
 265
 266   (pass-if "circular '(a) 1"
 267     (let ((lst (circular-list 'a)))
 268       (eq? lst
 269            (drop lst 1))))
 270
 271   (pass-if "circular '(a) 2"
 272     (let ((lst (circular-list 'a)))
 273       (eq? lst
 274            (drop lst 1))))
 275
 276   (pass-if "circular '(a b) 1"
 277     (let ((lst (circular-list 'a)))
 278       (eq? (cdr lst)
 279            (drop lst 0))))
 280
 281   (pass-if "circular '(a b) 2"
 282     (let ((lst (circular-list 'a)))
 283       (eq? lst
 284            (drop lst 1))))
 285
 286   (pass-if "circular '(a b) 5"
 287     (let ((lst (circular-list 'a)))
 288       (eq? (cdr lst)
 289            (drop lst 5))))
 290
 291   (pass-if "'(a . b) 1"
 292     (eq? 'b
 293          (drop '(a . b) 1)))
 294
 295   (pass-if "'(a b . c) 1"
 296     (equal? 'c
 297             (drop '(a b . c) 2))))
 298
 299 ;;
 300 ;; take
 301 ;;
 302
 303 (with-test-prefix "take"
 304
 305   (pass-if "'() 0"
 306     (null? (take '() 0)))
 307
 308   (pass-if "'(a) 0"
 309     (null? (take '(a) 0)))
 310
 311   (pass-if "'(a b) 0"
 312     (null? (take '() 0)))
 313
 314   (pass-if "'(a b c) 0"
 315     (null? (take '() 0)))
 316
 317   (pass-if "'(a) 1"
 318     (let* ((lst '(a))
 319            (got (take lst 1)))
 320       (and (equal? '(a) got)
 321            (not (eq? lst got)))))
 322
 323   (pass-if "'(a b) 1"
 324     (equal? '(a)
 325             (take '(a b) 1)))
 326
 327   (pass-if "'(a b c) 1"
 328     (equal? '(a)
 329             (take '(a b c) 1)))
 330
 331   (pass-if "'(a b) 2"
 332     (let* ((lst '(a b))
 333            (got (take lst 2)))
 334       (and (equal? '(a b) got)
 335            (not (eq? lst got)))))
 336
 337   (pass-if "'(a b c) 2"
 338     (equal? '(a b)
 339             (take '(a b c) 2)))
 340
 341   (pass-if "circular '(a) 0"
 342     (equal? '()
 343             (take (circular-list 'a) 0)))
 344
 345   (pass-if "circular '(a) 1"
 346     (equal? '(a)
 347             (take (circular-list 'a) 1)))
 348
 349   (pass-if "circular '(a) 2"
 350     (equal? '(a a)
 351             (take (circular-list 'a) 2)))
 352
 353   (pass-if "circular '(a b) 5"
 354     (equal? '(a b a b a)
 355             (take (circular-list 'a 'b) 5)))
 356
 357   (pass-if "'(a . b) 1"
 358     (equal? '(a)
 359             (take '(a . b) 1)))
 360
 361   (pass-if "'(a b . c) 1"
 362     (equal? '(a)
 363             (take '(a b . c) 1)))
 364
 365   (pass-if "'(a b . c) 2"
 366     (equal? '(a b)
 367             (take '(a b . c) 2))))
 368
 369 ;;
 370 ;; partition
 371 ;;
 372
 373 (define (test-partition pred list kept-good dropped-good)
 374   (call-with-values (lambda ()
 375                         (partition pred list))
 376       (lambda (kept dropped)
 377         (and (equal? kept kept-good)
 378              (equal? dropped dropped-good)))))
 379
 380 (with-test-prefix "partition"
 381
 382   (pass-if "with dropped tail"
 383     (test-partition even? '(1 2 3 4 5 6 7)
 384                     '(2 4 6) '(1 3 5 7)))
 385
 386   (pass-if "with kept tail"
 387     (test-partition even? '(1 2 3 4 5 6)
 388                     '(2 4 6) '(1 3 5)))
 389
 390   (pass-if "with everything dropped"
 391     (test-partition even? '(1 3 5 7)
 392                     '() '(1 3 5 7)))
 393
 394   (pass-if "with everything kept"
 395     (test-partition even? '(2 4 6)
 396                     '(2 4 6) '()))
 397
 398   (pass-if "with empty list"
 399     (test-partition even? '()
 400                     '() '()))
 401
 402   (pass-if "with reasonably long list"
 403     ;; the old implementation from SRFI-1 reference implementation
 404     ;; would signal a stack-overflow for a list of only 500 elements!
 405     (call-with-values (lambda ()
 406                         (partition even?
 407                                    (make-list 10000 1)))
 408       (lambda (even odd)
 409         (and (= (length odd) 10000)
 410              (= (length even) 0))))))
 411