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 ;; list-copy
 318 ;;
 319
 320 (with-test-prefix "list-copy"
 321   (pass-if (equal? '()          (list-copy '())))
 322   (pass-if (equal? '(1 2)       (list-copy '(1 2))))
 323   (pass-if (equal? '(1 2 3)     (list-copy '(1 2 3))))
 324   (pass-if (equal? '(1 2 3 4)   (list-copy '(1 2 3 4))))
 325   (pass-if (equal? '(1 2 3 4 5) (list-copy '(1 2 3 4 5))))
 326
 327   ;; improper lists can be copied
 328   (pass-if (equal? 1              (list-copy 1)))
 329   (pass-if (equal? '(1 . 2)       (list-copy '(1 . 2))))
 330   (pass-if (equal? '(1 2 . 3)     (list-copy '(1 2 . 3))))
 331   (pass-if (equal? '(1 2 3 . 4)   (list-copy '(1 2 3 . 4))))
 332   (pass-if (equal? '(1 2 3 4 . 5) (list-copy '(1 2 3 4 . 5)))))
 333
 334 ;;
 335 ;; take
 336 ;;
 337
 338 (with-test-prefix "take"
 339
 340   (pass-if "'() 0"
 341     (null? (take '() 0)))
 342
 343   (pass-if "'(a) 0"
 344     (null? (take '(a) 0)))
 345
 346   (pass-if "'(a b) 0"
 347     (null? (take '() 0)))
 348
 349   (pass-if "'(a b c) 0"
 350     (null? (take '() 0)))
 351
 352   (pass-if "'(a) 1"
 353     (let* ((lst '(a))
 354            (got (take lst 1)))
 355       (and (equal? '(a) got)
 356            (not (eq? lst got)))))
 357
 358   (pass-if "'(a b) 1"
 359     (equal? '(a)
 360             (take '(a b) 1)))
 361
 362   (pass-if "'(a b c) 1"
 363     (equal? '(a)
 364             (take '(a b c) 1)))
 365
 366   (pass-if "'(a b) 2"
 367     (let* ((lst '(a b))
 368            (got (take lst 2)))
 369       (and (equal? '(a b) got)
 370            (not (eq? lst got)))))
 371
 372   (pass-if "'(a b c) 2"
 373     (equal? '(a b)
 374             (take '(a b c) 2)))
 375
 376   (pass-if "circular '(a) 0"
 377     (equal? '()
 378             (take (circular-list 'a) 0)))
 379
 380   (pass-if "circular '(a) 1"
 381     (equal? '(a)
 382             (take (circular-list 'a) 1)))
 383
 384   (pass-if "circular '(a) 2"
 385     (equal? '(a a)
 386             (take (circular-list 'a) 2)))
 387
 388   (pass-if "circular '(a b) 5"
 389     (equal? '(a b a b a)
 390             (take (circular-list 'a 'b) 5)))
 391
 392   (pass-if "'(a . b) 1"
 393     (equal? '(a)
 394             (take '(a . b) 1)))
 395
 396   (pass-if "'(a b . c) 1"
 397     (equal? '(a)
 398             (take '(a b . c) 1)))
 399
 400   (pass-if "'(a b . c) 2"
 401     (equal? '(a b)
 402             (take '(a b . c) 2))))
 403
 404 ;;
 405 ;; partition
 406 ;;
 407
 408 (define (test-partition pred list kept-good dropped-good)
 409   (call-with-values (lambda ()
 410                         (partition pred list))
 411       (lambda (kept dropped)
 412         (and (equal? kept kept-good)
 413              (equal? dropped dropped-good)))))
 414
 415 (with-test-prefix "partition"
 416
 417   (pass-if "with dropped tail"
 418     (test-partition even? '(1 2 3 4 5 6 7)
 419                     '(2 4 6) '(1 3 5 7)))
 420
 421   (pass-if "with kept tail"
 422     (test-partition even? '(1 2 3 4 5 6)
 423                     '(2 4 6) '(1 3 5)))
 424
 425   (pass-if "with everything dropped"
 426     (test-partition even? '(1 3 5 7)
 427                     '() '(1 3 5 7)))
 428
 429   (pass-if "with everything kept"
 430     (test-partition even? '(2 4 6)
 431                     '(2 4 6) '()))
 432
 433   (pass-if "with empty list"
 434     (test-partition even? '()
 435                     '() '()))
 436
 437   (pass-if "with reasonably long list"
 438     ;; the old implementation from SRFI-1 reference implementation
 439     ;; would signal a stack-overflow for a list of only 500 elements!
 440     (call-with-values (lambda ()
 441                         (partition even?
 442                                    (make-list 10000 1)))
 443       (lambda (even odd)
 444         (and (= (length odd) 10000)
 445              (= (length even) 0))))))
 446