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

Last change on this file since 38205 was 38205, checked in by juergen, 7 months ago

bindings 3.1 with bind-loop to replace bind*

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