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 ;; length+
 301 ;;
 302
 303 (with-test-prefix "length+"
 304   (pass-if-exception "too few args" exception:wrong-num-args
 305     (length+))
 306   (pass-if-exception "too many args" exception:wrong-num-args
 307     (length+ 123 456))
 308   (pass-if (= 0 (length+ '())))
 309   (pass-if (= 1 (length+ '(x))))
 310   (pass-if (= 2 (length+ '(x y))))
 311   (pass-if (= 3 (length+ '(x y z))))
 312   (pass-if (not (length+ (circular-list 1))))
 313   (pass-if (not (length+ (circular-list 1 2))))
 314   (pass-if (not (length+ (circular-list 1 2 3)))))
 315
 316 ;;
 317 ;; take
 318 ;;
 319
 320 (with-test-prefix "take"
 321
 322   (pass-if "'() 0"
 323     (null? (take '() 0)))
 324
 325   (pass-if "'(a) 0"
 326     (null? (take '(a) 0)))
 327
 328   (pass-if "'(a b) 0"
 329     (null? (take '() 0)))
 330
 331   (pass-if "'(a b c) 0"
 332     (null? (take '() 0)))
 333
 334   (pass-if "'(a) 1"
 335     (let* ((lst '(a))
 336            (got (take lst 1)))
 337       (and (equal? '(a) got)
 338            (not (eq? lst got)))))
 339
 340   (pass-if "'(a b) 1"
 341     (equal? '(a)
 342             (take '(a b) 1)))
 343
 344   (pass-if "'(a b c) 1"
 345     (equal? '(a)
 346             (take '(a b c) 1)))
 347
 348   (pass-if "'(a b) 2"
 349     (let* ((lst '(a b))
 350            (got (take lst 2)))
 351       (and (equal? '(a b) got)
 352            (not (eq? lst got)))))
 353
 354   (pass-if "'(a b c) 2"
 355     (equal? '(a b)
 356             (take '(a b c) 2)))
 357
 358   (pass-if "circular '(a) 0"
 359     (equal? '()
 360             (take (circular-list 'a) 0)))
 361
 362   (pass-if "circular '(a) 1"
 363     (equal? '(a)
 364             (take (circular-list 'a) 1)))
 365
 366   (pass-if "circular '(a) 2"
 367     (equal? '(a a)
 368             (take (circular-list 'a) 2)))
 369
 370   (pass-if "circular '(a b) 5"
 371     (equal? '(a b a b a)
 372             (take (circular-list 'a 'b) 5)))
 373
 374   (pass-if "'(a . b) 1"
 375     (equal? '(a)
 376             (take '(a . b) 1)))
 377
 378   (pass-if "'(a b . c) 1"
 379     (equal? '(a)
 380             (take '(a b . c) 1)))
 381
 382   (pass-if "'(a b . c) 2"
 383     (equal? '(a b)
 384             (take '(a b . c) 2))))
 385
 386 ;;
 387 ;; partition
 388 ;;
 389
 390 (define (test-partition pred list kept-good dropped-good)
 391   (call-with-values (lambda ()
 392                         (partition pred list))
 393       (lambda (kept dropped)
 394         (and (equal? kept kept-good)
 395              (equal? dropped dropped-good)))))
 396
 397 (with-test-prefix "partition"
 398
 399   (pass-if "with dropped tail"
 400     (test-partition even? '(1 2 3 4 5 6 7)
 401                     '(2 4 6) '(1 3 5 7)))
 402
 403   (pass-if "with kept tail"
 404     (test-partition even? '(1 2 3 4 5 6)
 405                     '(2 4 6) '(1 3 5)))
 406
 407   (pass-if "with everything dropped"
 408     (test-partition even? '(1 3 5 7)
 409                     '() '(1 3 5 7)))
 410
 411   (pass-if "with everything kept"
 412     (test-partition even? '(2 4 6)
 413                     '(2 4 6) '()))
 414
 415   (pass-if "with empty list"
 416     (test-partition even? '()
 417                     '() '()))
 418
 419   (pass-if "with reasonably long list"
 420     ;; the old implementation from SRFI-1 reference implementation
 421     ;; would signal a stack-overflow for a list of only 500 elements!
 422     (call-with-values (lambda ()
 423                         (partition even?
 424                                    (make-list 10000 1)))
 425       (lambda (even odd)
 426         (and (= (length odd) 10000)
 427              (= (length even) 0))))))
 428