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

Last change on this file since 38814 was 38814, checked in by juergen, 10 months ago

bindings 4.1 with bugfix

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