source: project/release/4/list-bindings/tags/1.7/tests/run.scm @ 29964

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

macro-rules added

File size: 5.3 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(import-for-syntax (only list-bindings macro-rules))
8
9(compound-test ("LIST-BINDINGS")
10  (simple-test ("BINDING MACROS")
11    (= (bind a 1 a) 1)
12    (equal? (bind (a b) '(1 2)  (list a b)) '(1 2))
13    (equal?
14      (bind (x y z w) '(1 2 3 4) (list x y z w))
15      '(1 2 3 4))
16    (equal? (bind (x (y (z . u) . v) . w)
17              '(1 (2 (3 4) 5) 6)
18              (list x y z u v w))
19            '(1 2 3 (4) (5) (6)))
20    (equal? (bind (a (b . c) (d (e f))) '(1 (2 3) (4 (5 6)))
21              (list a b c d e f))
22            '(1 2 (3) 4 5 6))
23    (equal? ((bind-lambda (a (b . c) . d) (list a b c d))
24             '(1 (20 30 40) 2 3))
25            '(1 20 (30 40) (2 3)))
26    (equal? (bind-case '(1 (2 3))
27              ((x (y z)) (list x y z))
28              ((x (y . z)) (list x y z))
29              ((x y) (list x y)))
30            '(1 2 3))
31    (equal? (bind-case '(1 (2 3))
32              ((x (y . z)) (list x y z))
33              ((x y) (list x y))
34              ((x (y z)) (list x y z)))
35            '(1 2 (3)))
36    (equal? (bind-case '(1 (2 3))
37              ((x y) (list x y))
38              ((x (y . z)) (list x y z))
39              ((x (y z)) (list x y z)))
40            '(1 (2 3)))
41    (equal? (bind-case '(1 (2 . 3))
42              ((x y) (list x y))
43              ((x (y . z)) (list x y z))
44              ((x (y z)) (list x y z)))
45            '(1 (2 . 3)))
46    (equal?
47      (letrec ((my-map
48                 (lambda (fn lst)
49                   (bind-case lst
50                     (() '())
51                     ((x . xs) (cons (fn x) (my-map fn xs)))))))
52        (my-map add1 '(0 1 2 3))) '(1 2 3 4))
53    ((bindable? (a b)) '(1 2)) 
54    (not ((bindable? (x)) '(name 1)))
55    ((bindable? (_ x)) '(name 1))
56    (not ((bindable? (_ x)) '(name 1 2)))
57    (equal? (bind-let* (((a b) '(1 2)) ((x . y) '(3))) (list a b x y))
58            '(1 2 3 ()))
59    (equal? (bind-let* (((a b) '(1 2)) ((x . y) (list a))) (list a b x y))
60            '(1 2 1 ()))
61    (equal? (bind-let (((a b) '(1 2)) ((x . y) '(3 4 4))) (list a b x y))
62            '(1 2 3 (4 4)))
63    )
64  (simple-test ("DEFINE AND SET!")
65    (bind-define (a (b c) (d (e f))) '(1 (2 3) (4 (5 6))))
66    (= f 6)
67    (bind-define (push top pop)
68      (let ((state '()))
69        (list (lambda (arg) (set! state (cons arg state)))
70              (lambda () (car state))
71              (lambda () (set! state (cdr state))))))
72    (push 3)
73    (push 5)
74    (= (top) 5)
75    (pop)
76    (= (top) 3)
77    (bind-set! (a (b c) (d (e f))) '(10 (20 30) (40 (50 60))))
78    (= f 60)
79    (bind-define (x (y . z)) '(1 (2 3 4 5)))
80    (equal? z '(3 4 5))
81    (bind-set! (x (y . z)) '(10 (20 . 30)))
82    (= z 30)
83    )
84  (simple-test ("TEST LOW-LEVEL MACROS")
85    (define-macro (efreeze xpr)
86      (renaming (% %lambda)
87        `(,%lambda () ,xpr)))
88    (= ((efreeze 3)) 3)
89    (define-macro (ifreeze xpr)
90      `(lambda () ,xpr))
91    (= ((ifreeze 5)) 5)
92    (define-macro (alambda args xpr . xprs)
93      (injecting (self)
94        `(letrec ((,self (lambda ,args ,xpr ,@xprs)))
95           ,self)))
96    (define ! (alambda (n) (if (zero? n) 1 (* n (self (- n 1))))))
97    (= (! 5) 120)
98    (define-macro (foo pair)
99      (comparing (? bar?) `(if ,(bar? (car pair)) ,@(cdr pair) 'unchecked)))
100    (eq? (foo (bar 'checked)) 'checked)
101    (eq? (foo (baz 'checked)) 'unchecked)
102    (define-macro (baz pair)
103      (renaming (% %if)
104        (comparing (? bar?)
105          `(,%if ,(bar? (car pair)) ,@(cdr pair) 'unchecked))))
106    (eq? (baz (bar 'checked)) 'checked)
107    (eq? (baz (foo 'checked)) 'unchecked)
108    (define-macro (swap! x y)
109      `(let ((tmp ,x)) (set! ,x ,y) (set! ,y tmp)))
110    (equal? (let ((x 'x) (y 'y)) (swap! x y) (list x y))
111            '(y x))
112    (= (letrec-macro (((ifreeze xpr) `(lambda () ,xpr))
113                      ((efreeze xpr)
114                       (renaming (% %lambda)
115                         `(,%lambda () ,xpr))))
116         ((efreeze ((ifreeze 3)))))
117       3)
118    (equal? (let-macro (((ifreeze xpr) `(lambda () ,xpr))
119                        ((efreeze xpr)
120                         (renaming (% %lambda)
121                           `(,%lambda () ,xpr))))
122              (list ((efreeze 3)) ((ifreeze 5))))
123            '(3 5))
124    (define-syntax if-then-
125      (macro-rules (? then? else?)
126        ((_ test then-pair)
127         (if (and (pair? then-pair) (then? (car then-pair)))
128           `(if ,test
129              (begin ,@(cdr then-pair)))
130           `(error 'if-then- "syntax-error")))
131        ((_ test then-pair else-pair)
132         (if (and (pair? then-pair) (then? (car then-pair))
133                  (pair? else-pair) (else? (car else-pair)))
134           `(if ,test
135              (begin ,@(cdr then-pair))
136              (begin ,@(cdr else-pair)))
137           `(error 'if-then- "syntax-error")))))
138    (define (quux x)
139      (if-then- (odd? x) (then "odd") (else "even")))
140    (equal? (quux 3) "odd")
141    (equal? (quux 4) "even")
142    (define-syntax aif
143      (macro-rules it ()
144        ((_ test consequent . alternative)
145         (if (null? alternative)
146          `(let ((,it ,test))
147             (if ,it ,consequent))
148          `(let ((,it ,test))
149             (if ,it ,consequent ,(car alternative)))))))
150    (define (mist x) (aif (! x) it))
151    (= (mist 5) 120)
152    (define-syntax-rule (freeze x) (lambda () x))
153    (= ((freeze 25)) 25)
154    ))
Note: See TracBrowser for help on using the repository browser.