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

Last change on this file since 38613 was 38613, checked in by juergen, 5 months ago

generics 2.0 with restructured code and enhanced helpers

File size: 13.3 KB
Line 
1(import scheme (chicken base) (chicken fixnum) 
2        generic-functions generic-helpers simple-tests)
3
4(define-checks (List-helpers verbose?
5                             xs '(0 1 2 3 4)
6                             xss '(0 1 2 (3 4)))
7  (map* add1 '(0 (1 (2 . 3)))) 
8  '(1 (2 (3 . 4)))
9  ((map* add1) '(0 (1 (2) 3) 4)) 
10  '(1 (2 (3) 4) 5)
11  ((map* add1) '(0 1 2))
12  '(1 2 3)
13  (map* add1 0)
14  1
15  ((repeat 3 add1) 0)
16  3
17  xs
18  '(0 1 2 3 4)
19  ((repeat 2 cdr) xs)
20  '(2 3 4)
21  (receive (yes no)
22    ((filter odd?) xs)
23    (list yes no))
24  '((1 3) (0 2 4))
25  (adjoin = 3 xs)
26  xs
27  ((adjoin = 5) xs)
28  '(0 1 2 3 4 5)
29  (insert-before = 20 60 xs)
30  '(0 1 2 3 4 20)
31  ((insert-before = 20 2) xs)
32  '(0 1 20 2 3 4)
33  (memp odd? xs)
34  '(1 2 3 4)
35  ((memp odd?) '(0 2 4))
36  #f
37  (assp odd? '((0 0) (1 10)))
38  '(1 10)
39  (assp odd? '((0 0) (2 20)))
40  #f
41  (condition-case (assp odd? '((0 0) 2 (1 10)))
42    ((exn) #f))
43  #f
44  (let ((n (random-choice 0 1 2 3)))
45    (if (memv n '(0 1 2 3)) #t #f))
46  #t
47  )
48
49(define-checks (Splitting verbose? xs '(0 1 2 3 4))
50  (receive (rhead tail)
51    (rsplit-with odd? '(1 3 5 2 4 6))
52    (list rhead tail))
53  '(() (1 3 5 2 4 6))
54  (receive (rhead tail)
55    ((rsplit-with even?) '(1 3 5 2 4 6))
56    (list rhead tail))
57  '((5 3 1) (2 4 6))
58  (receive (rhead tail)
59    (rsplit-at 3 '(0 1 2 3 4 5 6))
60    (list rhead tail))
61  '((2 1 0) (3 4 5 6))
62  (reverse* '(10 20 30) '(1 2 3 4 5))
63  '(30 20 10 1 2 3 4 5)
64  (reverse* '(10 20 30) '(1 2 3 4 5) list)
65  '(30 (20 (10 (1 2 3 4 5))))
66  (reverse* '(10 20 30) '0 list)
67  '(30 (20 (10 . 0)))
68  (reverse* '(10 20 30) '(0 . 1) list)
69  '(30 (20 (10 (0 . 1))))
70  (reverse* '(10 20 30) '((0 . 1) (0 . 2)) list)
71  '(30 (20 (10 (0 . 1) (0 . 2))))
72  xs
73  '(0 1 2 3 4)
74  (receive (head tail)
75    (split-at 2 xs)
76    (list head tail))
77  '((0 1) (2 3 4))
78  (receive (head tail)
79    ((split-with odd?) xs)
80    (list head tail))
81  '((0) (1 2 3 4))
82  (receive (head tail)
83    (split-along '(a b . c) xs)
84    (list head tail))
85  '((0 1) (2 3 4))
86  (receive (head tail)
87    ((split-along '(a . b)) xs)
88    (list head tail))
89  '((0) (1 2 3 4))
90  )
91       
92(define-checks (Predicates verbose?
93                           xs '(0 1 2 3))
94  (any? 5)
95  #t
96  (none? 5)
97  #f
98  ((all? number?) xs)
99  #t
100  ((all? odd?) xs)
101  #f
102  ((some? odd?) xs)
103  #t
104  (apply (always #t) xs)
105  #t
106  (for-all symbol? '(a b c))
107  #t
108  (for-all = '(1 2 3) '(1.0 2.0 3.0))
109  #t
110  (exists memq '(a b c) '((A a) (b B) (C c)))
111  '(a)
112  (exists memq '(a b c) '((A B) (b B) (C c)))
113  '(b B)
114  (exists symbol? '(#f #\a "b" 5))
115  #f
116  (in? = 2 0 1 2 3)
117  #t
118  (in? = 5 0 1 2 3)
119  #f
120  )
121
122(mdefine* ys yss)
123
124(define-checks (Accessors verbose?
125                          xs '(0 1 2 3 4)
126                          xss '(0 1 2 (3 4)))
127  xs
128  '(0 1 2 3 4)
129  (cxr 'ad xs)
130  1
131  (cxr 'dd xs)
132  '(2 3 4)
133  ((cxr 'add) xs)
134  2
135  ((cxr 'addd) xs)
136  3
137  (cxr '(1 a 3 d) xs)
138  3
139  xss
140  '(0 1 2 (3 4))
141  (cxr '(1 a 3 d) xss)
142  '(3 4)
143  (cxr '(2 a 3 d) xss)
144  3
145  ((cxr '(1 a 1 a 3 d)) xss)
146  3
147  (cxr '(1 a 1 d 1 a 3 d) xss)
148  4
149  xss
150  '(0 1 2 (3 4))
151  (cxr 'addd xss)
152  '(3 4)
153  (cxr 'daddd xss)
154  '(4)
155
156  ys
157  'ys
158  yss
159  'yss
160  (mset! ys 1 yss 2)
161  (void)
162  ys
163  1
164  yss
165  2
166  )
167
168(define-checks (Destructuring-lambda verbose?
169                 count-test
170                 (let ((count 0))
171                   (dlambda
172                     (reset () (set! count 0) count)
173                     (inc   (n) (set! count (+ count n)) count)
174                     (dec   (n) (set! count (- count n)) count)
175                     (bound (lo hi)
176                            (set! count
177                              (min hi (max lo count))) count)
178                     (else () #f)
179                     ))
180                 fac-test
181                 (dlambda (fac (n) (if (zero? n)
182                                     1
183                                     (* n (fac (- n 1))))))
184                 )
185  (count-test 'reset)
186  0
187  (count-test 'inc 2)
188  2
189  (count-test 'inc 2)
190  4
191  (count-test 'dec 2)
192  2
193  (count-test 'bound 3 5)
194  3
195  (count-test 'inc 2)
196  5
197  (count-test 'bound 4 6)
198  5
199  (count-test 'bound 2 3)
200  3
201  (count-test 'reset)
202  0
203  (count-test)
204  #f
205  (fac-test 'fac 5)
206  120
207  )
208
209(define-checks (Selectors verbose?)
210  (selector? fixnum??)
211  #t
212  (map selector-name (selector-parents fixnum??))
213  '(integer? number? any?)
214  (selector-parent index??)
215  any??
216  ;; not eq? since different pointers:
217  ;(selector-predicate index??)
218  ;index?
219  (selector-name number??)
220  'number?
221  ((selector-predicate number??) 5)
222  (number? 5)
223  ((selector-predicate number??) 'foo)
224  (number? 'foo)
225  )
226
227(define item (method-tree-item (method +) number??))
228(define tree
229        (list (method-tree-item (method append) list?? list??)))
230(define (fn+ x y) (+ x y))
231(define (nf+ x y) (+ x y))
232(define (nn+ x y) (+ x y))
233(define-values (fff+ ffn+ fnf+ fnn+ nff+ nfn+ nnf+ nnn+)
234  (values mfx+ + + + + + + +))
235(define otree `((,fixnum?? (,fixnum?? (,fixnum?? . ,(method fff+))
236                                      (,number?? . ,(method ffn+)))
237                           (,number?? (,fixnum?? . ,(method fnf+))
238                                      (,number?? . ,(method fnn+))))
239                (,number?? (,fixnum?? (,fixnum?? . ,(method nff+))
240                                      (,number?? . ,(method nfn+)))
241                           (,number?? (,fixnum?? . ,(method nnf+))
242                                      (,number?? . ,(method nnn+))))))
243
244(define-checks (Trees verbose?)
245  (method-tree-item? item)
246  #t
247  item
248  `(,number?? . ,(method +))
249  (method-tree? (list item))
250  #t
251  (method-tree-depth (list item))
252  1
253
254  (set! item (method-tree-item (method string-append) string?? string??))
255  (void)
256  (method-tree-item? item)
257  #t
258  item
259  `(,string?? (,string?? . ,(method string-append)))
260  (method-tree? (list item))
261  #t
262  (method-tree-depth (list item))
263  2
264  (cadr item)
265  `(,string?? . ,(method string-append))
266  (method-name (cdadr item))
267  'string-append
268
269  (set! tree
270        (method-tree-insert tree
271                            (method-tree-item (method string-append)
272                                              string??
273                                              string??)))
274  (void)
275  (set! tree
276        (method-tree-insert tree 
277                            (method-tree-item (method +) number??  number??)))
278  (void)
279  (method-tree? tree)
280  #t
281  (method-tree-depth tree)
282  2
283  (method-tree-show tree)
284  '((list? (list? . append))
285    (string? (string? . string-append))
286    (number? (number? . +)))
287  (method-name (method-tree-dispatch tree '() '()))
288  'append
289  (method-tree-dispatch tree #t #t)
290  #f
291  (method-name (method-tree-dispatch tree 0 0))
292  '+
293  (method-name (method-tree-dispatch tree "" ""))
294  'string-append
295  (method-tree-dispatch tree '() 0)
296  #f
297  (method-tree-dispatch tree 0 '())
298  #f
299  (method-tree-dispatch tree 0 "")
300  #f
301
302  (set! tree
303        (list (method-tree-item (method fx+) fixnum?? fixnum??)))
304  (void)
305  (set! tree
306        (method-tree-insert tree
307                            (method-tree-item (method fn+) fixnum?? number??)))
308  (void)
309  (set! tree
310        (method-tree-insert tree
311                            (method-tree-item (method nf+) number?? fixnum??)))
312  (void)
313  (set! tree
314        (method-tree-insert tree
315                            (method-tree-item (method nn+) number?? number??)))
316  (void)
317  (method-tree? tree)
318  #t
319  (method-tree-depth tree)
320  2
321  (method-tree-show tree)
322  '((fixnum? (fixnum? . fx+)
323              (number? . fn+))
324    (number? (fixnum? . nf+)
325              (number? . nn+)))
326  (method-name (method-tree-dispatch tree 0.0 0.0))
327  'nn+
328  (method-name (method-tree-dispatch tree 0 0.0))
329  'fn+
330  (method-name (method-tree-dispatch tree 0.0 0))
331  'nf+
332  (method-name (method-tree-dispatch tree 0 0))
333  'fx+
334  (method-tree-dispatch tree #f 0)
335  #f
336  (method-tree-dispatch tree 0 #f)
337  #f
338  (method-tree-dispatch tree #f #f)
339  #f
340
341  (set! tree
342        (list (method-tree-item (method nnn+) number?? number?? number??)))
343  (void)
344  (set! tree
345        (method-tree-insert tree
346                            (method-tree-item (method fff+)
347                                              fixnum??
348                                              fixnum??
349                                              fixnum??)))
350  (void)
351  (set! tree
352        (method-tree-insert tree
353                            (method-tree-item (method ffn+)
354                                              fixnum??
355                                              fixnum??
356                                              number??)))
357  (void)
358  (set! tree
359        (method-tree-insert tree
360                            (method-tree-item (method fnf+)
361                                              fixnum??
362                                              number??
363                                              fixnum??)))
364  (void)
365  (set! tree
366        (method-tree-insert tree
367                            (method-tree-item (method fnn+)
368                                              fixnum??
369                                              number??
370                                              number??)))
371  (void)
372  (set! tree
373        (method-tree-insert tree
374                            (method-tree-item (method nff+)
375                                              number?? 
376                                              fixnum??
377                                              fixnum??)))
378  (void)
379  (set! tree
380        (method-tree-insert tree
381                            (method-tree-item (method nfn+)
382                                              number??
383                                              fixnum??
384                                              number??)))
385  (void)
386  (set! tree
387        (method-tree-insert tree
388                            (method-tree-item (method nnf+)
389                                              number??
390                                              number??
391                                              fixnum??)))
392  (void)
393  (method-tree? tree)
394  #t
395  (method-tree-depth tree)
396  3
397  (method-tree? otree)
398  #t
399  (method-tree-show tree)
400  (method-tree-show otree)
401  (method-name (method-tree-dispatch tree 0 0 0))
402  'fff+
403  (method-name (method-tree-dispatch tree 0.0 0 0))
404  'nff+
405  (method-name (method-tree-dispatch tree 0 0 0.0))
406  'ffn+
407  (method-name (method-tree-dispatch tree 0 0.0 0.0))
408  'fnn+
409  (method-name (method-tree-dispatch tree 0 0.0 0))
410  'fnf+
411  (method-name (method-tree-dispatch tree 0.0 0.0 0.0))
412  'nnn+
413
414  ;; override nnn+ with +
415  (set! tree
416        (method-tree-insert tree
417                            (method-tree-item (method +)
418                                              number??
419                                              number??
420                                              number??)))
421  (void)
422  (method-name (method-tree-dispatch tree 0.0 0.0 0.0))
423  '+
424  (method-tree-dispatch tree 0 0 #f)
425  #f
426  (method-tree-dispatch tree 0 #f #f)
427  #f
428  (method-tree-dispatch tree #f 0 0)
429  #f
430  (method-tree-dispatch tree 0.0 0.0 #f)
431  #f
432  (method-tree-dispatch tree 0.0 0 #f)
433  #f
434  (method-tree-dispatch tree 0.0 #f 0.0)
435  #f
436  )
437
438(define-generic (Add x y) (error 'Add "no method found"))
439(define-method (Add (x number??) (y number??)) (+ x y))
440(define-generic (At k seq) (error 'At "no method found"))
441(define-method (At (k index??) (seq list??)) (list-ref seq k))
442(define-generic (Drop k seq) (error 'Drop "no method found"))
443(define-method (Drop (k index??) (seq list??)) (list-tail seq k))
444(define-generic (Take k seq) (error 'Take "no method found"))
445(define-method (Take (k index??) (seq list??))
446                ;(compress (make-list k #t) seq))
447                (let loop ((n 0) (lst seq) (result '()))
448                  (if (fx= n k)
449                    (reverse result)
450                    (loop (1+ n)
451                          (cdr lst)
452                          (cons (car lst) result)))))
453(define-generic (Add* . xs) (error 'Add* "no method found"))
454(define-method (Add* xs number??) (apply + xs))
455
456(define-checks (Generic-functions verbose? seq '(0 1 2 3 4))
457  (define-method  (Add (x fixnum??) (y fixnum??)) (fx+ x y))
458  (void)
459  (generic? Add)
460  #t
461  (generic-variadic? Add)
462  #f
463  (generic-arity Add)
464  2
465  (Add 1 2.0)
466  3.0
467  (Add 1 2)
468  3
469  (condition-case (Add 1) ((exn) #f))
470  #f
471  (condition-case (Add 1 #f) ((exn) #f))
472  #f
473
474  (At 2 seq)
475  2
476  (Drop 2 seq)
477  '(2 3 4)
478  (Take 2 seq)
479  '(0 1)
480  (generic? At)
481  #t
482  (generic-variadic? At)
483  #f
484  (generic-arity At)
485  2
486  (define-method (At (k index??) (seq vector??)) (vector-ref seq k))
487  (void)
488  (define-method (Drop (k index??) (seq vector??)) (subvector seq k))
489  (void)
490  (define-method (Take (k index??) (seq vector??)) (subvector seq 0 k))
491  (void)
492  (define-method (At (k index??) (seq string??)) (string-ref seq k))
493  (void)
494  (define-method (Drop (k index??) (seq string??)) (substring seq k))
495  (void)
496  (define-method (Take (k index??) (seq string??)) (substring seq 0 k))
497  (void)
498  (generic-variadic? At)
499  #f
500  (generic-arity Take)
501  2
502  (Drop 2 "abcde")
503  "cde"
504  (At 2 seq)
505  2
506  (Take 2 #(0 1 2 3 4))
507  #(0 1)
508
509  (define-method (Add* xs list??) (apply append xs))
510  (void)
511  (Add* 1 2 3)
512  6
513  (Add* '(1) '(2) '(3))
514  '(1 2 3)
515  (define-method (Add* xs string??) (apply string-append xs))
516  (void)
517  (Add* "1" "2" "3")
518  "123"
519  (condition-case (Add* 1 #f 3) ((exn) #f))
520  #f
521  (generic? Add*)
522  #t
523  (generic-variadic? Add*)
524  #t
525  (generic-arity Add*)
526  1
527  )
528
529(check-all GENERICS
530  (List-helpers)
531  (Splitting)
532  (Predicates)
533  (Accessors)
534  (Destructuring-lambda)
535  (Selectors)
536  (Trees)
537  (Generic-functions)
538  )
539
Note: See TracBrowser for help on using the repository browser.