source: project/release/5/bindings/trunk/tests/run.scm @ 39398

Last change on this file since 39398 was 39398, checked in by juergen, 6 months ago

bindings 5.0 with new implementation

File size: 13.4 KB
Line 
1;;; File: tests/run.scm
2;;; Author: Juergen Lorenz
3;;; ju (at) jugilo (dot) de
4
5(import simple-tests
6        bindings
7        (chicken base)
8        (chicken condition)
9        biglists
10        )
11
12(define stack #f) (define push! #f) (define pop! #f)
13
14(define-checks (defines? verbose?)
15  (let ((x #f) (y #f) (z #f))
16    (bind! (x (y . z))
17      '(1 #(2 3 3)))
18    (list x y z))
19  '(1 2 #(3 3))
20  (let ((x #f) (y #f) (z #f))
21    (bind! (x #f _ (y _ . z))
22      '(1 #f 10 #(2 30 3 3)))
23    (list x y z))
24  '(1 2 #(3 3))
25  (let ((x #f) (y #f) (z #f))
26    (bind! x 1)
27    (bind! y 2)
28    (bind! z 3)
29    (list x y z))
30  '(1 2 3)
31  (let ((x #f) (y #f) (z #f) (u #f) (v #f))
32    (bind! (x (y . z)) '(1 #(2 3 3)))
33    (bind! (u (v)) '(10 (20)))
34    (list x y z u v))
35  '(1 2 #(3 3) 10 20)
36  (let ((x #f) (y #f) (z #f))
37    (bind! (x (y . z))
38      '(1 #(2 3 3)))
39    (list x y z))
40  '(1 2 #(3 3))
41  (let ((state #f) (push! #f) (pop! #f))
42    (bind! (state (push! pop!))
43      (list '()
44            (vector
45              (lambda (xpr) (set! state (cons xpr state)))
46              (lambda () (set! state (cdr state))))))
47    (push! 1)
48    (push! 0)
49    state)
50  '(0 1)
51  (begin
52    (bind! (plus5 times5)
53      (let ((a 5))
54        (list
55          (lambda (x) (+ x a))
56          (lambda (x) (* x a)))))
57    (list (plus5 6) (times5 6)))
58  '(11 30)
59  (begin
60    (bind! (x . y) '(1 . 2))
61    (list x y))
62  '(1 2)
63  (begin
64    (bind! (x _ . y) '(1 10 . 2))
65    (list x y))
66  '(1 2)
67  (begin
68    (bind! (x #f . y) '(1 #f . 2))
69    (list x y))
70  '(1 2)
71  (begin
72    (let ((lst '()))
73      (bind! (push top pop)
74        (vector
75          (lambda (xpr) (set! lst (cons xpr lst)))
76          (lambda () (car lst))
77          (lambda () (set! lst (cdr lst))))))
78    (push 0)
79    (push 1)
80    (pop)
81    (top))
82  0
83  (begin
84    (bind! (x (_ y (z _))) '(1 #(2 3 (4 5))))
85    (list x y z))
86  '(1 3 4)
87  (begin
88    (bind! (x (#f y (z #t)))
89      (list 1 (vector (odd? 2) 3 (list 4 (odd?  5)))))
90    (list x y z))
91  '(1 3 4)
92  (let ()
93    (bind! (a _ (b #f . bs) c))
94    (and (eq? a 'a) (eq? b 'b) (eq? bs 'bs) (eq? c 'c)))
95  #t
96  )
97;(defines?) ; ok
98
99(define-checks (binds? verbose?)
100  (bind a 1 a)
101  1
102  (bind (a #f) '(1 #f) a)
103  1
104  (bind (a b) '(1 2) (list a b))
105  '(1 2)
106  (bind (x . y) #(1 2 3 4) (list x y))
107  '(1 #(2 3 4))
108  (bind (_ . y) #(1 2 3 4) y)
109  '#(2 3 4)
110  (bind (x (y (z u . v)) w) '(1 #(2 "foo") 4)
111    (list x y z u v w))
112  '(1 2 #\f #\o "o" 4)
113  (bind (x (y (z u . _)) w) '(1 #(2 "foo") 4)
114    (list x y z u w))
115  '(1 2 #\f #\o 4)
116  (bind (x (y . _) . _) '(1 #(2 3 4) 5 6) (list x y))
117  '(1 2)
118  (bind (x (y _ . _) . _) '(1 #(2 3 4) 5 6) (list x y))
119  '(1 2)
120  (bind (x (y (z . u)) v . w) (vector 1 (list 2 (cons #f #f)) 5 6)
121    (list x y z u v w))
122  '(1 2 #f #f 5 #(6))
123  (bind (x (y (#f . u)) v . w)
124    (vector 1 (list 2 (cons (odd? 4) #f)) 5 6)
125    (list x y u v w))
126  '(1 2 #f 5 #(6))
127  (bind (x (y (z . u)) v . w) '#(1 (2 (3 . 4)) 5 6)
128    (list x y z u v w))
129  '(1 2 3 4 5 #(6))
130
131  (bind (as ...) '(1 2 3) (list as))
132  '((1 2 3))
133  (bind (x y as ...) '(-1 0 1 2 3) (list x y as))
134  '(-1 0 (1 2 3))
135  (bind (x y as ..) '(-1 0)  (list x y as))
136  '(-1 0 ())
137  (bind ((as (bs cs)) ...)
138        '((1 (2 3)) (10 (20 30)))
139        (list as bs cs))
140  '((1 10) (2 20) (3 30))
141  (bind ((as (bs cs)) ...)
142        '((1 (2 3)) #(10 (20 30)))
143        (list as bs cs))
144  '((1 10) (2 20) (3 30))
145
146  (bind-loop (x (a . b) y) '(5 #(1) 0)
147    (if (zero? x)
148      (list x a b y)
149      (loop (list (- x 1) (cons a (cons a b)) (+ y 1)))))
150  '(0 1 (1 1 1 1 1 . #()) 5)
151  (bind* loop (x (a . b) y) '(5 #(1) 0)
152    (if (zero? x)
153      (list x a b y)
154      (loop (list (- x 1) (cons a (cons a b)) (+ y 1)))))
155  '(0 1 (1 1 1 1 1 . #()) 5)
156  (bind-loop (x y) #(5 0)
157    (if (zero? x)
158      (vector x y)
159      (loop (vector (- x 1) (+ y 1)))))
160  '#(0 5)
161  (bind* loop (x y) #(5 0)
162    (if (zero? x)
163      (vector x y)
164      (loop (vector (- x 1) (+ y 1)))))
165  '#(0 5)
166  ;LITERALS
167  (bind (#f . ys) '(#f 2 3) ys)
168  '(2 3)
169  (condition-case
170    (bind (#f . ys) '(#t 2 3) ys)
171    ((exn) #f))
172  #f
173  (bind #f #f #t)
174  #t
175  (condition-case
176    (bind #f #t #t)
177    ((exn) #f))
178  #f
179  (condition-case
180    (bind (x . #f) '(1 . #t) x)
181    ((exn) #f))
182  #f
183  (bind (x (y . #f)) '(1 (2 . #f)) (list x y))
184  '(1 2)
185  (condition-case
186    (bind (x (y . #f)) '(1 (2 . #t)) (list x y))
187    ((exn) #f))
188  #f
189  (bind ((x . #f) y . #f) '((1 . #f) 2 . #f) (list x y))
190  '(1 2)
191  (condition-case
192    (bind ((x . #f) y . #f) '((1 . #f) 2 . #t) (list x y))
193    ((exn) #f))
194  #f
195  (condition-case
196    (bind ((x . #f) y . #f) '((1 . #t) 2 . #f) (list x y))
197    ((exn) #f))
198  #f
199  (bind ((x . z) y . #f) '((1 . 3) 2 . #f) (list x y z))
200  '(1 2 3)
201  (bind (a: ()) #(a: #()) #f)
202  #f
203  )
204;(binds?) ; ok
205
206(define-checks (predicates? verbose?)
207  ((bindable? (x)) '(name 1))
208  #f
209  ((bindable? (_ x)) '(name 1 2))
210  #f
211  ((bindable? (a b)) '#(1 2))
212  #t
213  ((bindable? (x (y z))) '(1 "23"))
214  #t
215  ((bindable? (x (y . z))) '(1 "23"))
216  #t
217  ((bindable? (x y)) '(1 "23"))
218  #t
219  ((bindable? (a (b . c) . d)) '(1 2 3 4 5))
220  #f
221  ((bindable? (a)) 1)
222  #f
223  (bindable? (a b) (where (even? a) (odd? b)) '(2 2))
224  #f
225  (bindable? (a (b cs .. d)) '(1 (2 3)))
226  #t
227  )
228;(predicates?) ; ok
229
230(define my-map #f)
231(define vector-map #f)
232(define vector-revrerse #f)
233
234(define-checks (cases? verbose?)
235  (bind-case #() (() #f))
236  #f
237  (bind-case #(2 2)
238    ((a b) (where (even? a) (odd? b)) (print 'even-odd a b))
239    ((a b) (where (odd? a) (even? b)) (print 'odd-even a b))
240    ((a b) (list a b)))
241  '(2 2)
242  (bind-case '(1 "2 3")
243    ((x (y z)) #f)
244    ((x (y . z)) (list x y z))
245    ((x y) #t))
246  '(1 #\2 " 3")
247  (bind-case '(1 "23")
248    ((x (y z)) (where (char-alphabetic? y)) #f)
249    ((x (y . z)) (list x y z))
250    ((x y) #t))
251  '(1 #\2 "3")
252  (bind-case '(1 "23")
253    ((x (y z)) (where (char-alphabetic? y)) #f)
254    ((x (y . _)) (list x y))
255    ((x y) #t))
256  '(1 #\2)
257  (bind-case '(1 "23")
258    ((x (y z)) (where (char-numeric? y)) (list x y z))
259    ((x (y . z)) #t)
260    ((x y) #t))
261  '(1 #\2 #\3)
262  (bind-case '(1 "23")
263    ((x (y z)) (list x y z))
264    ((x (y . z)) #t)
265    ((x y) #t))
266  '(1 #\2 #\3)
267  (bind-case '(1 "2 3") ;
268    ((x (y . z)) (list x y z))
269    ((x (y z)) #f)
270    ((x y) #t))
271  '(1 #\2 " 3")
272  (bind-case '(1 #(2 3))
273    ((x y) (where (list? y)) #f)
274    ((x (y . z)) (list x y z))
275    ((x (y z)) #t))
276  '(1 2 #(3))
277  (bind-case '(1 (2 3))
278    ((x y) (list x y))
279    ((x (y . z)) #t)
280    ((x (y z)) #t))
281  '(1 (2 3))
282  (bind-case '(1 (2 . 3))
283    ((x y) (list x y))
284    ((x (y . z)) #t)
285    ((x (y z)) #f))
286  '(1 (2 . 3))
287  (bind-case '#(1 2)
288    ;(() #f)  ;;;;;;;
289    ((a) #f)
290    ((a b) (list a b))
291    ((a b c) #f))
292  '(1 2)
293
294  (bind-case '(0 4)
295    ((a bs ....) #f)
296    ((a bs ...) (list a bs)))
297  #f
298  (bind-case '(0 1 2 3 4)
299    ((a bs ..) #f)
300    ((a bs ...) (list a bs)))
301  '(0 (1 2 3 4))
302  (bind-case '(0 #(1 (2 3)))
303    ((a (bs (cs (ds))) ..) #f)
304    ((a (bs (cs ds)) ..) (list a bs cs ds))) 
305  '(0 (1) (2) (3))
306  (bind-case '(0)
307    ((a (bs (cs (ds))) ..) (list a bs cs ds))
308    ((a (bs (cs ds)) ..) #t))
309  '(0 () () ())
310  (bind-case '((0 1 2 3) (10 #(20 30)))
311    (((a bs ...) (x (ys zs) ..)) (list a bs x ys zs)))
312  '(0 (1 2 3) 10 (20) (30)) 
313
314  ;LOCAL VARIABLES IN ALL RULES
315  (set! my-map
316    (lambda (fn lst)
317      (let loop ((lst lst) (result '()))
318        (bind-case lst
319          (() (reverse result))  ;;;;;
320          ((x . xs)
321           (loop xs (cons (fn x) result)))))))
322  (void)
323  (my-map add1 '(0 1 2 3))
324  '(1 2 3 4)
325  (set! vector-map
326    (lambda (fn vec)
327      (let* ((len (vector-length vec))
328             (result (make-vector len #f)))
329        (let loop ((vec vec))
330          (bind-case vec
331            (() result)  ;;;;;;;
332            ((x . xs)
333             (vector-set! result
334                          (- len (vector-length xs) 1)
335                          (fn x))
336             (loop (subvector vec 1))))))))
337  (void)
338  (vector-map add1 #(0 1 2 3))
339  #(1 2 3 4)
340  (set! vector-reverse
341    (lambda (vec)
342    (let ((result (make-vector (vector-length vec) #f)))
343      (let loop ((vec vec))
344        (bind-case vec
345          (() result)
346          ((x . xs)
347           (vector-set! result
348                        (vector-length xs)
349                        x)
350           (loop (subvector vec 1))))))))
351  (void)
352  (vector-reverse #(0 1 2 3))
353  #(3 2 1 0)
354
355  ;NON-SYMBOL LITERALS
356  (bind-case #("a")
357    ((#f) #f)
358    (("a") #t))
359  #t
360  (bind-case (vector 1 (list (odd? 2) 3))
361    ((x y) (where (number? y)) #f)
362    ((x ("y" . z)) #f)
363    ((x (#f z)) (list x z)))
364  '(1 3)
365  (bind-case '(1 (#f 3))
366    ((x y) (list x y))
367    ((x ("y" . z)) #f)
368    ((x (#f z)) (list x z)))
369  '(1 (#f 3))
370  (bind-case #(1 ("y" 3))
371    ((x ("y" . z)) (list x z))
372    ((x (#f z)) #f))
373  '(1 (3))
374  (bind-case '((0 1 2 3) ("" #(20 30)))
375    (((a bs ...) ("x" (ys zs) ..)) #f)
376    (((a bs ...) ("" (ys zs) ..)) (list a bs ys zs)))
377  '(0 (1 2 3) (20) (30)) 
378
379  (bind-case '((0 1 2 3) (10 #(20 30)))
380    (((_ bs ...) (_ (ys zs) ..)) (list bs ys zs)))
381  '((1 2 3) (20) (30)) 
382  )
383;(cases?)
384
385(define-checks (lambdas? verbose?)
386  ((bind-lambda (a (b cs ...) ds ...)
387     (list a b cs ds))
388   '(1 #(20 30 40) 2 3))
389  '(1 20 #(30 40) (2 3))
390  ((bind-lambda (a (b (cs ds) ...) . es)
391     (list a b cs ds es))
392   '(1 (20 (30 40)) 2 3))
393   ;'(1 #(20 (30 40)) 2 3))
394  '(1 20 (30) (40) (2 3))
395  ((bind-lambda (a (b . cs) . ds)
396     (list a b cs ds))
397   '(1 #(20 30 40) 2 3))
398  '(1 20 #(30 40) (2 3))
399  ((bind-lambda* ((a (b . c) . d) (e . f))
400     (list a b c d e f))
401   '(1 #(20 30 40) 2 3) '#(4 5 6))
402  '(1 20 #(30 40) (2 3) 4 #(5 6))
403  ((bind-case-lambda
404     ((e . f) (where (zero? e)) f)
405     ((e . f) (list e f)))
406   '#(0 2 3 4 5))
407  '#(2 3 4 5)
408  ((bind-case-lambda
409     ((e . f) (where (zero? e)) #f)
410     ((a (b . #f) . d) (list a b d))
411     ((e . f) #f))
412   '(1 (2 . #f) 4 5))
413  '(1 2 (4 5))
414  ((bind-case-lambda
415     ((e . f) (where (zero? e)) #f)
416     ((a (b . #f) (ds es) ...) (list a b ds es))
417     ((e . f) #f))
418   '(1 (2 . #f) (4 5) (40 50)))
419  '(1 2 (4 40) (5 50))
420  ((bind-case-lambda
421     ((e . f) (where (zero? e)) #f)
422     ((a (b . #f) . d) #f)
423     ((e . f) (list e f)))
424   '(1 (2 . #t) 4 5))
425  '(1 ((2 . #t) 4 5))
426  (condition-case
427    ((bind-case-lambda
428       ((e . f) (where (zero? e)) #f)
429       ((a (b . #f) . d) #f))
430     '(1 (2 . #t) 4 5))
431    ((exn) #f))
432    #f
433  ((bind-case-lambda
434     ((e . f) (where (zero? e)) #f)
435     ((a (b "c") . d) (list a b d))
436     ((e . f) #f))
437   '(1 (2 "c") 4 5))
438  '(1 2 (4 5))
439  ((bind-case-lambda
440     ((a (b . c) . d) (where (integer? a)) (list a b c d))
441     ((e . f) (list e f)))
442   '(1 #(2 3 4) 5 6))
443  '(1 2 #(3 4) (5 6))
444  ((bind-case-lambda
445     ((a (b . c) . d) (where (string? a)) #f)
446     ((e . f) (list e f)))
447   '(1 #(2 3 4) 5 6))
448  '(1 (#(2 3 4) 5 6))
449  ((bind-case-lambda*
450     (((a b c . d) (e . f))
451      (list a b c d e f)))
452   '(1 2 3) #(4 5 6))
453  '(1 2 3 () 4 #(5 6))
454  ((bind-case-lambda*
455     (((a (b . c) . d) (e . f))
456      (list a b c d e f)))
457   '(1 #(20 30 40) 2 3) '(4 5 6))
458  '(1 20 #(30 40) (2 3) 4 (5 6))
459  )
460;(lambdas?)
461
462(define-checks (lets? verbose?)
463  (bind-let ((((x y) z) '(#(1 2) 3))
464             (u (+ 2 2))
465             ((v w) #(5 6)))
466    (list x y z u v w))
467  '(1 2 3 4 5 6)
468  (bind-let ((((x y) (zs ..)) '(#(1 2) ()))
469             (u (+ 2 2))
470             ((v w) #(5 6)))
471    (list x y zs u v w))
472  '(1 2 () 4 5 6)
473  (bind-let ((((x y) (zs ..)) '(#(1 2) ()))
474             (((us vs) ...) '((3 4) (30 40) (300 400))))
475    (list x y zs us vs))
476  '(1 2 () (3 30 300) (4 40 400))
477  (bind* loop (a b) '(5 0)
478    (if (zero? a)
479      (list a b)
480      (loop (list (- a 1) (+ b 1)))))
481  '(0 5)
482  (bind-let loop (((a b) '(5 0)))
483    (if (zero? a)
484      (list a b)
485      (loop (list (- a 1) (+ b 1)))))
486  '(0 5)
487  (bind-let loop (((x . y) '(1 2 3))
488                  ((z) #(10)))
489    (if (zero? z)
490      (list x y z)
491      (loop (cons (+ x 1) (map add1 y)) (list (- z 1)))))
492  '(11 (12 13) 0)
493  (bind-let* ((((x y) z) '(#(1 2) 3))
494              (u (+ 1 2 x))
495              ((v w) (list (+ z 2) 6)))
496    (list x y z u v w))
497  '(1 2 3 4 5 6)
498  (bindrec ((o?) e?)
499    (vector
500      (list (lambda (m) (if (zero? m) #f (e? (- m 1)))))
501      (lambda (n) (if (zero? n) #t (o? (- n 1)))))
502    (list (o? 95) (e? 95)))
503  '(#t #f)
504  (bind-letrec ((o? (lambda (m) (if (zero? m) #f (e? (- m 1)))))
505                ((e?)
506                 (vector (lambda (n) (if (zero? n) #t (o? (- n 1)))))))
507    (list (o? 95) (e? 95)))
508  '(#t #f)
509  )
510;(lets?)
511
512(define (integers-from n)
513  (Cons n (integers-from (+ n 1)) #f))
514(define integers (integers-from 0))
515(define 5integers (Take 5 integers))
516(define standard-checkers (sequence-db))
517(define checkers
518  ;; add finite lazy list handlers at the front
519  (sequence-db List?
520               Length 
521               (lambda (xs k) (At k xs))
522               (lambda (xs k) (Drop k xs))
523               List
524               list?))
525
526(define-checks (biglists? verbose?)
527  (if (memq List? standard-checkers) #t #f)
528  #f
529  (if (memq List? checkers) #t #f)
530  #t
531  (car checkers)
532  List?
533  (List? 5integers)
534  #t
535  (bind (x y . zs) 5integers (At 0 zs))
536  2
537  (bind (_ _ . zs) 5integers (At 0 zs))
538  2
539  (bind (x #f (_ (b . cs) . zs))
540        (vector 1 #f (List 10 5integers 2 3))
541        (list x b (At 0 cs) (At 0 zs) (At 1 zs)))
542  '(1 0 1 2 3)
543  )
544;(biglists?)
545
546;(define-checks (dots? verbose?)
547;  (resolve-dots '(1 2 3) ...)
548;  '(1 2 3)
549;  (resolve-dots 1 2 '(30 40) .. 5)
550;  '(1 2 30 40 5)
551;  (resolve-dots 1 2 '() .. 5)
552;  '(1 2 5)
553;  (resolve-dots 1 '(20 30) ... 4 '(40 50 60) .... 7)
554;  '(1 20 30 4 40 50 60 7)
555;)
556;;(dots?)
557
558(check-all BINDINGS
559  (defines?)
560  (binds?)
561  (predicates?)
562  (cases?)
563  (lambdas?)
564  (lets?)
565  (biglists?)
566  )
567
Note: See TracBrowser for help on using the repository browser.