Commit | Line | Data |
---|---|---|
9ddacf86 KN |
1 | ;;;"scmactst.scm" test syntactic closures macros |
2 | ;;; From "sc-macro.doc", A Syntactic Closures Macro Facility by Chris Hanson | |
3 | ||
4 | (define errs '()) | |
5 | (define test | |
6 | (lambda (expect fun . args) | |
7 | (write (cons fun args)) | |
8 | (display " ==> ") | |
9 | ((lambda (res) | |
10 | (write res) | |
11 | (newline) | |
12 | (cond ((not (equal? expect res)) | |
13 | (set! errs (cons (list res expect (cons fun args)) errs)) | |
14 | (display " BUT EXPECTED ") | |
15 | (write expect) | |
16 | (newline) | |
17 | #f) | |
18 | (else #t))) | |
19 | (if (procedure? fun) (apply fun args) (car args))))) | |
20 | ||
21 | (require 'syntactic-closures) | |
22 | ||
23 | (macro:expand | |
24 | '(define-syntax push | |
25 | (syntax-rules () | |
26 | ((push item list) | |
27 | (set! list (cons item list)))))) | |
28 | ||
29 | (test '(set! foo (cons bar foo)) 'push (macro:expand '(push bar foo))) | |
30 | ||
31 | (macro:expand | |
32 | '(define-syntax push1 | |
33 | (transformer | |
34 | (lambda (exp env) | |
35 | (let ((item | |
36 | (make-syntactic-closure env '() (cadr exp))) | |
37 | (list | |
38 | (make-syntactic-closure env '() (caddr exp)))) | |
39 | `(set! ,list (cons ,item ,list))))))) | |
40 | ||
41 | (test '(set! foo (cons bar foo)) 'push1 (macro:expand '(push1 bar foo))) | |
42 | ||
43 | (macro:expand | |
44 | '(define-syntax loop | |
45 | (transformer | |
46 | (lambda (exp env) | |
47 | (let ((body (cdr exp))) | |
48 | `(call-with-current-continuation | |
49 | (lambda (exit) | |
50 | (let f () | |
51 | ,@(map (lambda (exp) | |
52 | (make-syntactic-closure env '(exit) | |
53 | exp)) | |
54 | body) | |
55 | (f))))))))) | |
56 | ||
57 | (macro:expand | |
58 | '(define-syntax let1 | |
59 | (transformer | |
60 | (lambda (exp env) | |
61 | (let ((id (cadr exp)) | |
62 | (init (caddr exp)) | |
63 | (exp (cadddr exp))) | |
64 | `((lambda (,id) | |
65 | ,(make-syntactic-closure env (list id) exp)) | |
66 | ,(make-syntactic-closure env '() init))))))) | |
67 | ||
68 | (test 93 'let1 (macro:eval '(let1 a 90 (+ a 3)))) | |
69 | ||
70 | (macro:expand | |
71 | '(define-syntax loop-until | |
72 | (syntax-rules | |
73 | () | |
74 | ((loop-until id init test return step) | |
75 | (letrec ((loop | |
76 | (lambda (id) | |
77 | (if test return (loop step))))) | |
78 | (loop init)))))) | |
79 | ||
80 | (test (macro:expand '(letrec ((loop (lambda (foo) (if #t 12 (loop 33))))) | |
81 | (loop 3))) | |
82 | 'loop | |
83 | (macro:expand '(loop-until foo 3 #t 12 33))) | |
84 | ||
85 | (macro:expand | |
86 | '(define-syntax loop-until1 | |
87 | (transformer | |
88 | (lambda (exp env) | |
89 | (let ((id (cadr exp)) | |
90 | (init (caddr exp)) | |
91 | (test (cadddr exp)) | |
92 | (return (cadddr (cdr exp))) | |
93 | (step (cadddr (cddr exp))) | |
94 | (close | |
95 | (lambda (exp free) | |
96 | (make-syntactic-closure env free exp)))) | |
97 | `(letrec ((loop | |
98 | ,(capture-syntactic-environment | |
99 | (lambda (env) | |
100 | `(lambda (,id) | |
101 | (,(make-syntactic-closure env '() `if) | |
102 | ,(close test (list id)) | |
103 | ,(close return (list id)) | |
104 | (,(make-syntactic-closure env '() | |
105 | `loop) | |
106 | ,(close step (list id))))))))) | |
107 | (loop ,(close init '())))))))) | |
108 | ||
109 | (test (macro:expand '(letrec ((loop (lambda (foo) (if #t 12 (loop 33))))) | |
110 | (loop 3))) | |
111 | 'loop1 | |
112 | (macro:expand '(loop-until1 foo 3 #t 12 33))) | |
113 | ||
114 | (test '#t 'identifier (identifier? 'a)) | |
115 | ;;; this needs to setup ENV. | |
116 | ;;;(test '#t 'identifier | |
117 | ;;; (identifier? (macro:expand (make-syntactic-closure env '() 'a)))) | |
118 | (test #f 'identifier (identifier? "a")) | |
119 | (test #f 'identifier (identifier? #\a)) | |
120 | (test #f 'identifier (identifier? 97)) | |
121 | (test #f 'identifier (identifier? #f)) | |
122 | (test #f 'identifier (identifier? '(a))) | |
123 | (test #f 'identifier (identifier? '#(a))) | |
124 | ||
125 | (test '(#t #f) | |
126 | 'syntax | |
127 | (macro:eval | |
128 | '(let-syntax | |
129 | ((foo | |
130 | (transformer | |
131 | (lambda (form env) | |
132 | (capture-syntactic-environment | |
133 | (lambda (transformer-env) | |
134 | (identifier=? transformer-env 'x env 'x))))))) | |
135 | (list (foo) | |
136 | (let ((x 3)) | |
137 | (foo)))))) | |
138 | ||
139 | ||
140 | (test '(#f #t) | |
141 | 'syntax | |
142 | (macro:eval | |
143 | '(let-syntax ((bar foo)) | |
144 | (let-syntax | |
145 | ((foo | |
146 | (transformer | |
147 | (lambda (form env) | |
148 | (capture-syntactic-environment | |
149 | (lambda (transformer-env) | |
150 | (identifier=? transformer-env 'foo | |
151 | env (cadr form)))))))) | |
152 | (list (foo foo) | |
153 | (foo bar)))))) | |
154 | ||
155 | (newline) | |
156 | (cond ((null? errs) (display "Passed all tests")) | |
157 | (else (display "errors were:") (newline) | |
158 | (display "(got expected (call))") (newline) | |
159 | (for-each (lambda (l) (write l) (newline)) errs))) | |
160 | (newline) |