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

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

bindings-3.2 improved

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