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

Last change on this file since 36356 was 36356, checked in by juergen, 22 months ago

bindings 1.1 sequence routines prefixed

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