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

Last change on this file since 36467 was 36467, checked in by juergen, 2 years ago

bindings 1.2 fixes null pattern bug

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