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 ;; delete and delete!
  48 ;;
  49
  50 (let ()
  51   ;; Call (PROC lst) for all lists of length up to 6, with all combinations
  52   ;; of elements to be retained or deleted.  Elements to retain are numbers,
  53   ;; 0 upwards.  Elements to be deleted are #f.
  54   (define (test-lists proc)
  55     (do ((n 0 (1+ n)))
  56         ((>= n 6))
  57       (do ((limit (ash 1 n))
  58            (i 0 (1+ i)))
  59           ((>= i limit))
  60         (let ((lst '()))
  61           (do ((bit 0 (1+ bit)))
  62               ((>= bit n))
  63             (set! lst  (cons (if (logbit? bit i) bit #f) lst)))
  64           (proc lst)))))
  65
  66   (define (common-tests delete-proc)
  67     (pass-if-exception "too few args" exception:wrong-num-args
  68       (delete-proc 0))
  69
  70     (pass-if-exception "too many args" exception:wrong-num-args
  71       (delete-proc 0 '() equal? 99))
  72
  73     (pass-if "empty"
  74       (eq? '() (delete-proc 0 '())))
  75
  76     (pass-if "equal? (the default)"
  77       (equal? '((1) (3))
  78               (delete-proc '(2) '((1) (2) (3)))))
  79
  80     (pass-if "eq?"
  81       (equal? '((1) (2) (3))
  82               (delete-proc '(2) '((1) (2) (3)) eq?)))
  83
  84     (pass-if "called arg order"
  85       (equal? '(1 2 3)
  86               (delete-proc 3 '(1 2 3 4 5) <))))
  87
  88   (with-test-prefix "delete"
  89     (common-tests delete)
  90
  91     (test-lists
  92      (lambda (lst)
  93        (let ((lst-copy (list-copy lst)))
  94          (with-test-prefix lst-copy
  95            (pass-if "result"
  96              (equal? (delete     #f lst)
  97                      (ref-delete #f lst)))
  98            (pass-if "non-destructive"
  99              (equal? lst-copy lst)))))))
 100
 101   (with-test-prefix "delete!"
 102     (common-tests delete!)
 103
 104     (test-lists
 105      (lambda (lst)
 106        (pass-if lst
 107          (equal? (delete!    #f lst)
 108                  (ref-delete #f lst)))))))
 109
 110 ;;
 111 ;; delete-duplicates and delete-duplicates!
 112 ;;
 113
 114 (let ()
 115   ;; Call (PROC lst) for all lists of length 1 <= n <= 4, with all
 116   ;; combinations of numbers 1 to n in the elements
 117   (define (test-lists proc)
 118     (do ((n 1 (1+ n)))
 119         ((> n 4))
 120       (do ((limit (integer-expt n n))
 121            (i 0 (1+ i)))
 122           ((>= i limit))
 123         (let ((lst '()))
 124           (do ((j 0 (1+ j))
 125                (rem i (quotient rem n)))
 126               ((>= j n))
 127             (set! lst (cons (remainder rem n) lst)))
 128           (proc lst)))))
 129
 130   (define (common-tests delete-duplicates-proc)
 131     (pass-if-exception "too few args" exception:wrong-num-args
 132       (delete-duplicates-proc))
 133
 134     (pass-if-exception "too many args" exception:wrong-num-args
 135       (delete-duplicates-proc '() equal? 99))
 136
 137     (pass-if "empty"
 138       (eq? '() (delete-duplicates-proc '())))
 139
 140     (pass-if "equal? (the default)"
 141       (equal? '((2))
 142               (delete-duplicates-proc '((2) (2) (2)))))
 143
 144     (pass-if "eq?"
 145       (equal? '((2) (2) (2))
 146               (delete-duplicates-proc '((2) (2) (2)) eq?)))
 147
 148     (pass-if "called arg order"
 149       (let ((ok #t))
 150         (delete-duplicates-proc '(1 2 3 4 5)
 151                                 (lambda (x y)
 152                                   (if (> x y)
 153                                       (set! ok #f))
 154                                   #f))
 155         ok)))
 156
 157   (with-test-prefix "delete-duplicates"
 158     (common-tests delete-duplicates)
 159
 160     (test-lists
 161      (lambda (lst)
 162        (let ((lst-copy (list-copy lst)))
 163          (with-test-prefix lst-copy
 164            (pass-if "result"
 165              (equal? (delete-duplicates     lst)
 166                      (ref-delete-duplicates lst)))
 167            (pass-if "non-destructive"
 168              (equal? lst-copy lst)))))))
 169
 170   (with-test-prefix "delete-duplicates!"
 171     (common-tests delete-duplicates!)
 172
 173     (test-lists
 174      (lambda (lst)
 175        (pass-if lst
 176          (equal? (delete-duplicates!    lst)
 177                  (ref-delete-duplicates lst)))))))
 178
 179 ;;
 180 ;; drop
 181 ;;
 182
 183 (with-test-prefix "drop"
 184
 185   (pass-if "'() 0"
 186     (null? (drop '() 0)))
 187
 188   (pass-if "'(a) 0"
 189     (let ((lst '(a)))
 190       (eq? lst
 191            (drop lst 0))))
 192
 193   (pass-if "'(a b) 0"
 194     (let ((lst '(a b)))
 195       (eq? lst
 196            (drop lst 0))))
 197
 198   (pass-if "'(a) 1"
 199     (let ((lst '(a)))
 200       (eq? (cdr lst)
 201            (drop lst 1))))
 202
 203   (pass-if "'(a b) 1"
 204     (let ((lst '(a b)))
 205       (eq? (cdr lst)
 206            (drop lst 1))))
 207
 208   (pass-if "'(a b) 2"
 209     (let ((lst '(a b)))
 210       (eq? (cddr lst)
 211            (drop lst 2))))
 212
 213   (pass-if "'(a b c) 1"
 214     (let ((lst '(a b c)))
 215       (eq? (cddr lst)
 216            (drop lst 2))))
 217
 218   (pass-if "circular '(a) 0"
 219     (let ((lst (circular-list 'a)))
 220       (eq? lst
 221            (drop lst 0))))
 222
 223   (pass-if "circular '(a) 1"
 224     (let ((lst (circular-list 'a)))
 225       (eq? lst
 226            (drop lst 1))))
 227
 228   (pass-if "circular '(a) 2"
 229     (let ((lst (circular-list 'a)))
 230       (eq? lst
 231            (drop lst 1))))
 232
 233   (pass-if "circular '(a b) 1"
 234     (let ((lst (circular-list 'a)))
 235       (eq? (cdr lst)
 236            (drop lst 0))))
 237
 238   (pass-if "circular '(a b) 2"
 239     (let ((lst (circular-list 'a)))
 240       (eq? lst
 241            (drop lst 1))))
 242
 243   (pass-if "circular '(a b) 5"
 244     (let ((lst (circular-list 'a)))
 245       (eq? (cdr lst)
 246            (drop lst 5))))
 247
 248   (pass-if "'(a . b) 1"
 249     (eq? 'b
 250          (drop '(a . b) 1)))
 251
 252   (pass-if "'(a b . c) 1"
 253     (equal? 'c
 254             (drop '(a b . c) 2))))
 255
 256 ;;
 257 ;; take
 258 ;;
 259
 260 (with-test-prefix "take"
 261
 262   (pass-if "'() 0"
 263     (null? (take '() 0)))
 264
 265   (pass-if "'(a) 0"
 266     (null? (take '(a) 0)))
 267
 268   (pass-if "'(a b) 0"
 269     (null? (take '() 0)))
 270
 271   (pass-if "'(a b c) 0"
 272     (null? (take '() 0)))
 273
 274   (pass-if "'(a) 1"
 275     (let* ((lst '(a))
 276            (got (take lst 1)))
 277       (and (equal? '(a) got)
 278            (not (eq? lst got)))))
 279
 280   (pass-if "'(a b) 1"
 281     (equal? '(a)
 282             (take '(a b) 1)))
 283
 284   (pass-if "'(a b c) 1"
 285     (equal? '(a)
 286             (take '(a b c) 1)))
 287
 288   (pass-if "'(a b) 2"
 289     (let* ((lst '(a b))
 290            (got (take lst 2)))
 291       (and (equal? '(a b) got)
 292            (not (eq? lst got)))))
 293
 294   (pass-if "'(a b c) 2"
 295     (equal? '(a b)
 296             (take '(a b c) 2)))
 297
 298   (pass-if "circular '(a) 0"
 299     (equal? '()
 300             (take (circular-list 'a) 0)))
 301
 302   (pass-if "circular '(a) 1"
 303     (equal? '(a)
 304             (take (circular-list 'a) 1)))
 305
 306   (pass-if "circular '(a) 2"
 307     (equal? '(a a)
 308             (take (circular-list 'a) 2)))
 309
 310   (pass-if "circular '(a b) 5"
 311     (equal? '(a b a b a)
 312             (take (circular-list 'a 'b) 5)))
 313
 314   (pass-if "'(a . b) 1"
 315     (equal? '(a)
 316             (take '(a . b) 1)))
 317
 318   (pass-if "'(a b . c) 1"
 319     (equal? '(a)
 320             (take '(a b . c) 1)))
 321
 322   (pass-if "'(a b . c) 2"
 323     (equal? '(a b)
 324             (take '(a b . c) 2))))