source: project/release/5/generics/trunk/tests/run.scm @ 37460

Last change on this file since 37460 was 37460, checked in by juergen, 18 months ago

generics ported to chicken-5

File size: 9.7 KB
Line 
1(import scheme (chicken base) (chicken fixnum) 
2        generics generic-helpers simple-tests)
3
4(define-test (Generic-helpers)
5  (equal?
6    (receive (rhead tail)
7      (rsplit-with odd? '(1 3 5 2 4 6))
8      (list rhead tail))
9    '(() (1 3 5 2 4 6)))
10  (equal?
11    (receive (rhead tail)
12      (rsplit-with even? '(1 3 5 2 4 6))
13      (list rhead tail))
14    '((5 3 1) (2 4 6)))
15  (equal?
16    (receive (rhead tail)
17      (rsplit-at 3 '(0 1 2 3 4 5 6))
18      (list rhead tail))
19    '((2 1 0) (3 4 5 6)))
20  (equal?
21    (reverse* '(10 20 30) '(1 2 3 4 5))
22    '(30 20 10 1 2 3 4 5))
23  (equal?
24    (reverse* '(10 20 30) '(1 2 3 4 5) list)
25    '(30 (20 (10 (1 2 3 4 5)))))
26  (equal?
27    (reverse* '(10 20 30) '0 list)
28    '(30 (20 (10 . 0))))
29  (equal?
30    (reverse* '(10 20 30) '(0 . 1) list)
31    '(30 (20 (10 (0 . 1)))))
32  (equal?
33    (reverse* '(10 20 30) '((0 . 1) (0 . 2)) list)
34    '(30 (20 (10 (0 . 1) (0 . 2)))))
35  (equal?
36    (map* add1 '(0 (1 (2 . 3)))) 
37    '(1 (2 (3 . 4))))
38  (equal?
39    (map* add1 '(0 (1 (2) 3) 4)) 
40    '(1 (2 (3) 4) 5))
41  (equal? (map* add1 '(0 1 2)) '(1 2 3))
42  (= (map* add1 0) 1)
43  (= ((repeat 3 add1) 0) 3)
44  (equal? ((repeat 2 cdr) '(0 1 2 3)) '(2 3))
45  (equal? (substring
46             (symbol->string
47               (proc-name (named-lambda (! n)
48                            (if (zero? n) 1 (* n (! (- n 1)))))))
49             0 1)
50           "!")
51  (equal? (map (named-lambda (! n) (if (zero? n) 1 (* n (! (- n 1)))))
52               '(1 2 3 4 5))
53          '(1 2 6 24 120))
54  (eq? (proc-name number?) 'scheme#number?)
55  (eq? (proc-name +) 'C_plus)
56)
57
58(define-test (Selectors)
59  (selector? fixnum??)
60  (equal? (selector-parents fixnum??)
61          `(,integer?? ,number?? ,any??))
62  (eq? (index??) any??)
63  )
64
65(define item (method-tree-item + number??))
66(define tree
67        (list (method-tree-item append list?? list??)))
68(define (fn+ x y) (+ x y))
69(define (nf+ x y) (+ x y))
70(define (nn+ x y) (+ x y))
71(define-values (fff+ ffn+ fnf+ fnn+ nff+ nfn+ nnf+ nnn+)
72  (values mfx+ + + + + + + +))
73(define otree `((,fixnum?? (,fixnum?? (,fixnum?? . ,fff+)
74                                      (,number?? . ,ffn+))
75                           (,number?? (,fixnum?? . ,fnf+)
76                                      (,number?? . ,fnn+)))
77                (,number?? (,fixnum?? (,fixnum?? . ,nff+)
78                                      (,number?? . ,nfn+))
79                           (,number?? (,fixnum?? . ,nnf+)
80                                      (,number?? . ,nnn+)))))
81
82(define-test (Trees)
83  (method-tree-item? item)
84  (equal? item `(,number?? . ,+))
85  (method-tree? (list item))
86  (fx= (method-tree-depth (list item)) 1)
87
88  (set! item (method-tree-item string-append string?? string??))
89  (method-tree-item? item)
90  (equal? item `(,string?? (,string?? . ,string-append)))
91  (method-tree? (list item))
92  (fx= (method-tree-depth (list item)) 2)
93  (equal? (cadr item) `(,string?? . ,string-append))
94  (eq? (cdadr item) string-append)
95
96  (set! tree
97        (method-tree-insert tree
98                            (method-tree-item string-append
99                                              string??
100                                              string??)))
101  (set! tree
102        (method-tree-insert tree 
103                            (method-tree-item + number??  number??)))
104  (method-tree? tree)
105  (fx= (method-tree-depth tree) 2)
106  (equal? (method-tree-show tree)
107    '((generics#list?? (generics#list?? . scheme#append))
108      (generics#string?? (generics#string?? . scheme#string-append))
109      (generics#number?? (generics#number?? . C_plus))
110      ))
111  (eq? (method-tree-dispatch tree '() '()) append)
112  (eq? (method-tree-dispatch tree #t #t) #f)
113  (eq? (method-tree-dispatch tree 0 0) +)
114  (eq? (method-tree-dispatch tree "" "") string-append)
115  (eq? (method-tree-dispatch tree '() 0) #f)
116  (eq? (method-tree-dispatch tree 0 '()) #f)
117  (eq? (method-tree-dispatch tree 0 "") #f)
118
119  (set! tree
120        (list (method-tree-item fx+ fixnum?? fixnum??)))
121  (set! tree
122        (method-tree-insert tree
123                            (method-tree-item fn+ fixnum?? number??)))
124  (set! tree
125        (method-tree-insert tree
126                            (method-tree-item nf+ number?? fixnum??)))
127  (set! tree
128        (method-tree-insert tree
129                            (method-tree-item nn+ number?? number??)))
130  (method-tree? tree)
131  (fx= (method-tree-depth tree) 2)
132  (equal? (method-tree-show tree)
133    '((generics#fixnum?? (generics#fixnum?? . chicken.fixnum#fx+)
134                         (generics#number?? . fn+))
135      (generics#number?? (generics#fixnum?? . nf+) (generics#number?? . nn+))))
136  (eq? (method-tree-dispatch tree 0.0 0.0) nn+)
137  (eq? (method-tree-dispatch tree 0 0.0) fn+)
138  (eq? (method-tree-dispatch tree 0.0 0) nf+)
139  (eq? (method-tree-dispatch tree 0 0) fx+)
140  (not (method-tree-dispatch tree #f 0))
141  (not (method-tree-dispatch tree 0 #f))
142  (not (method-tree-dispatch tree #f #f))
143
144  (set! tree
145        (list (method-tree-item nnn+ number?? number?? number??)))
146  ;(set! tree
147  ;      (list (method-tree-item fff+ fixnum?? fixnum??  fixnum??)))
148  (set! tree
149        (method-tree-insert tree
150                            (method-tree-item fff+
151                                              fixnum??
152                                              fixnum??
153                                              fixnum??)))
154  (set! tree
155        (method-tree-insert tree
156                            (method-tree-item ffn+
157                                              fixnum??
158                                              fixnum??
159                                              number??)))
160  (set! tree
161        (method-tree-insert tree
162                            (method-tree-item fnf+
163                                              fixnum??
164                                              number??
165                                              fixnum??)))
166  (set! tree
167        (method-tree-insert tree
168                            (method-tree-item fnn+
169                                              fixnum??
170                                              number??
171                                              number??)))
172  (set! tree
173        (method-tree-insert tree
174                            (method-tree-item nff+
175                                              number?? 
176                                              fixnum??
177                                              fixnum??)))
178  (set! tree
179        (method-tree-insert tree
180                            (method-tree-item nfn+
181                                              number??
182                                              fixnum??
183                                              number??)))
184  (set! tree
185        (method-tree-insert tree
186                            (method-tree-item nnf+
187                                              number??
188                                              number??
189                                              fixnum??)))
190  (method-tree? tree)
191  (fx= (method-tree-depth tree) 3)
192  (equal? tree otree)
193  (eq? (method-tree-dispatch tree 0 0 0) fff+)
194  (eq? (method-tree-dispatch tree 0.0 0 0) nff+)
195  (eq? (method-tree-dispatch tree 0 0 0.0) ffn+)
196  (eq? (method-tree-dispatch tree 0 0.0 0.0) fnn+)
197  (eq? (method-tree-dispatch tree 0 0.0 0) fnf+)
198  (eq? (method-tree-dispatch tree 0.0 0.0 0.0) nnn+)
199  ;; override nnn+ with +
200  (set! tree
201        (method-tree-insert tree
202                            (method-tree-item + number?? number??
203                                         number??)))
204  (eq? (method-tree-dispatch tree 0.0 0.0 0.0) +)
205  (not (method-tree-dispatch tree 0 0 #f))
206  (not (method-tree-dispatch tree 0 #f #f))
207  (not (method-tree-dispatch tree #f 0 0))
208  (not (method-tree-dispatch tree 0.0 0.0 #f))
209  (not (method-tree-dispatch tree 0.0 0 #f))
210  (not (method-tree-dispatch tree 0.0 #f 0.0))
211  )
212
213(define-generic (Add (x number??) (y number??)) (+ x y))
214(define-generic (At (k index??) (seq list??)) (list-ref seq k))
215(define-generic (Drop (k index??) (seq list??)) (list-tail seq k))
216(define-generic (Take (k index??) (seq list??))
217                ;(compress (make-list k #t) seq))
218                (let loop ((n 0) (lst seq) (result '()))
219                  (if (fx= n k)
220                    (reverse result)
221                    (loop (1+ n)
222                          (cdr lst)
223                          (cons (car lst) result)))))
224(define seq '(0 1 2 3 4))
225(define-generic (Add* xs number??) (apply + xs))
226
227(define-test (Generics)
228  (define-method  (Add (x fixnum??) (y fixnum??)) (fx+ x y))
229  (generic? Add)
230  (not (generic-variadic? Add))
231  (fx= (generic-arity Add) 2)
232  (= (Add 1 2.0) 3.0)
233  (fx= (Add 1 2) 3)
234  (not (condition-case (Add 1) ((exn) #f)))
235  (not (condition-case (Add 1 #f) ((exn) #f)))
236
237  (= (At 2 seq) 2)
238  (equal? (Drop 2 seq) '(2 3 4))
239  (equal? (Take 2 seq) '(0 1))
240  (generic? At)
241  (not (generic-variadic? At))
242  (= (generic-arity At) 2)
243  (define-method (At (k index??) (seq vector??)) (vector-ref seq k))
244  (define-method (Drop (k index??) (seq vector??)) (subvector seq k))
245  (define-method (Take (k index??) (seq vector??)) (subvector seq 0 k))
246  (define-method (At (k index??) (seq string??)) (string-ref seq k))
247  (define-method (Drop (k index??) (seq string??)) (substring seq k))
248  (define-method (Take (k index??) (seq string??)) (substring seq 0 k))
249  (not (generic-variadic? At))
250  (fx= (generic-arity Take) 2)
251  (string=? (Drop 2 "abcde") "cde")
252  (fx= (At 2 seq) 2)
253  (equal? (Take 2 #(0 1 2 3 4)) #(0 1))
254
255  (define-method (Add* xs list??) (apply append xs))
256  (fx= (Add* 1 2 3) 6)
257  (equal? (Add* '(1) '(2) '(3)) '(1 2 3))
258  (define-method (Add* xs string??) (apply string-append xs))
259  (string=? (Add* "1" "2" "3") "123")
260  (not (condition-case (Add* 1 #f 3) ((exn) #f)))
261  (generic? Add*)
262  (generic-variadic? Add*)
263  (fx= (generic-arity Add*) 1)
264  )
265
266(compound-test (GENERICS)
267  (Generic-helpers)
268  (Selectors)
269  (Trees)
270  (Generics)
271  )
272
Note: See TracBrowser for help on using the repository browser.