source: project/release/4/list-bindings/trunk/tests/run.scm @ 29858

Last change on this file since 29858 was 29858, checked in by juergen, 8 years ago

bind-lambda and bind-case-lambda added

File size: 4.4 KB
Line 
1;;;; File: list-bindings-run.scm
2;;;; Author: Juergen Lorenz
3;;;; ju (at) jugilo (dot) de
4
5(require-library simple-tests list-bindings)
6(import simple-tests list-bindings)
7
8(compound-test ("LIST-BINDINGS")
9  (simple-test ("BINDING MACROS")
10    (= (bind a 1 a) 1)
11    (equal? (bind (a b) '(1 2)  (list a b)) '(1 2))
12    (equal?
13      (bind (x y z w) '(1 2 3 4) (list x y z w))
14      '(1 2 3 4))
15    (equal? (bind (x (y (z . u) . v) . w)
16              '(1 (2 (3 4) 5) 6)
17              (list x y z u v w))
18            '(1 2 3 (4) (5) (6)))
19    (equal? (bind (a (b . c) (d (e f))) '(1 (2 3) (4 (5 6)))
20              (list a b c d e f))
21            '(1 2 (3) 4 5 6))
22    (equal? ((bind-lambda (a (b . c) . d) (list a b c d))
23             '(1 (20 30 40) 2 3))
24            '(1 20 (30 40) (2 3)))
25    (equal? (bind-case '(1 (2 3))
26              ((x (y z)) (list x y z))
27              ((x (y . z)) (list x y z))
28              ((x y) (list x y)))
29            '(1 2 3))
30    (equal? (bind-case '(1 (2 3))
31              ((x (y . z)) (list x y z))
32              ((x y) (list x y))
33              ((x (y z)) (list x y z)))
34            '(1 2 (3)))
35    (equal? (bind-case '(1 (2 3))
36              ((x y) (list x y))
37              ((x (y . z)) (list x y z))
38              ((x (y z)) (list x y z)))
39            '(1 (2 3)))
40    (equal? (bind-case '(1 (2 . 3))
41              ((x y) (list x y))
42              ((x (y . z)) (list x y z))
43              ((x (y z)) (list x y z)))
44            '(1 (2 . 3)))
45    (equal? ((bind-case-lambda
46               ((a (b . c) . d) (list a b c d))
47               ((e . f) (list e f)))
48             '(1 2 3 4 5))
49            '(1 (2 3 4 5)))
50
51    (equal?
52      (letrec ((my-map
53                 (lambda (fn lst)
54                   (bind-case lst
55                     (() '())
56                     ((x . xs) (cons (fn x) (my-map fn xs)))))))
57        (my-map add1 '(0 1 2 3))) '(1 2 3 4))
58    ((bindable? (a b)) '(1 2)) 
59    (not ((bindable? (x)) '(name 1)))
60    ((bindable? (_ x)) '(name 1))
61    (not ((bindable? (_ x)) '(name 1 2)))
62    (equal? (bind-let* (((a b) '(1 2)) ((x . y) '(3))) (list a b x y))
63            '(1 2 3 ()))
64    (equal? (bind-let* (((a b) '(1 2)) ((x . y) (list a))) (list a b x y))
65            '(1 2 1 ()))
66    (equal? (bind-let (((a b) '(1 2)) ((x . y) '(3 4 4))) (list a b x y))
67            '(1 2 3 (4 4)))
68    )
69  (simple-test ("DEFINE AND SET!")
70    (bind-define (a (b c) (d (e f))) '(1 (2 3) (4 (5 6))))
71    (= f 6)
72    (bind-define (push top pop)
73      (let ((state '()))
74        (list (lambda (arg) (set! state (cons arg state)))
75              (lambda () (car state))
76              (lambda () (set! state (cdr state))))))
77    (push 3)
78    (push 5)
79    (= (top) 5)
80    (pop)
81    (= (top) 3)
82    (bind-set! (a (b c) (d (e f))) '(10 (20 30) (40 (50 60))))
83    (= f 60)
84    (bind-define (x (y . z)) '(1 (2 3 4 5)))
85    (equal? z '(3 4 5))
86    (bind-set! (x (y . z)) '(10 (20 . 30)))
87    (= z 30)
88    )
89  (simple-test ("TEST LOW-LEVEL MACROS")
90    (define-macro (efreeze xpr)
91      (renaming (% %lambda)
92        `(,%lambda () ,xpr)))
93    (= ((efreeze 3)) 3)
94    (define-macro (ifreeze xpr)
95      `(lambda () ,xpr))
96    (= ((ifreeze 5)) 5)
97    (define-macro (alambda args xpr . xprs)
98      (injecting (self)
99        `(letrec ((,self (lambda ,args ,xpr ,@xprs)))
100           ,self)))
101    (define ! (alambda (n) (if (zero? n) 1 (* n (self (- n 1))))))
102    (= (! 5) 120)
103    (define-macro (foo pair)
104      (comparing (? bar?) `(if ,(bar? (car pair)) ,@(cdr pair) 'unchecked)))
105    (eq? (foo (bar 'checked)) 'checked)
106    (eq? (foo (baz 'checked)) 'unchecked)
107    (define-macro (baz pair)
108      (renaming (% %if)
109        (comparing (? bar?)
110          `(,%if ,(bar? (car pair)) ,@(cdr pair) 'unchecked))))
111    (eq? (baz (bar 'checked)) 'checked)
112    (eq? (baz (foo 'checked)) 'unchecked)
113    (define-macro (swap! x y)
114      `(let ((tmp ,x)) (set! ,x ,y) (set! ,y tmp)))
115    (equal? (let ((x 'x) (y 'y)) (swap! x y) (list x y))
116            '(y x))
117    (= (letrec-macro (((ifreeze xpr) `(lambda () ,xpr))
118                      ((efreeze xpr)
119                       (renaming (% %lambda)
120                         `(,%lambda () ,xpr))))
121         ((efreeze ((ifreeze 3)))))
122       3)
123    (equal? (let-macro (((ifreeze xpr) `(lambda () ,xpr))
124                        ((efreeze xpr)
125                         (renaming (% %lambda)
126                           `(,%lambda () ,xpr))))
127              (list ((efreeze 3)) ((ifreeze 5))))
128            '(3 5))
129    (define-syntax-rule (freeze x) (lambda () x))
130    (= ((freeze 25)) 25)
131    ))
Note: See TracBrowser for help on using the repository browser.