source: project/release/4/bindings/tags/7.2/tests/run.scm @ 36471

Last change on this file since 36471 was 36471, checked in by juergen, 18 months ago

bindings 7.2 fixes bug with null subpatterns

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