/[guile]/guile/guile-core/test-suite/tests/srfi-1.test
ViewVC logotype

Diff of /guile/guile-core/test-suite/tests/srfi-1.test

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.2 by kryde, Mon May 12 23:05:50 2003 UTC revision 1.3 by kryde, Tue Jul 8 00:13:06 2003 UTC
# Line 20  Line 20 
20  (use-modules (srfi srfi-1)  (use-modules (srfi srfi-1)
21               (test-suite lib))               (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!  ;; delete and delete!
48  ;;  ;;
49    
50  (let ()  (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)    (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"      (pass-if "called arg order"
85        (equal? '(1 2 3)        (equal? '(1 2 3)
86                (delete-proc 3 '(1 2 3 4 5) <))))                (delete-proc 3 '(1 2 3 4 5) <))))
87        
88    (with-test-prefix "delete"    (with-test-prefix "delete"
89      (common-tests delete))      (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!"    (with-test-prefix "delete!"
102      (common-tests delete!)))      (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  ;; drop

Legend:
Removed from v.1.2  
changed lines
  Added in v.1.3

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26