1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
|
; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
; The syntax-rules macro (new in R5RS)
; Example:
;
; (define-syntax or
; (syntax-rules ()
; ((or) #f)
; ((or e) e)
; ((or e1 e ...) (let ((temp e1))
; (if temp temp (or e ...))))))
(define-usual-macro 'syntax-rules
(lambda (exp r c)
(if (pair? (cdr exp))
(let ((subkeywords (cadr exp))
(rules (cddr exp)))
(if (and (list? subkeywords)
(every name? subkeywords))
;; Pair of the procedure and list of auxiliary names
`(,(r 'cons) ;should be 'transformer
,(process-rules rules subkeywords r c)
(,(r 'quote)
,(find-free-names-in-syntax-rules subkeywords rules)))
exp))
exp))
'(append and car cdr cond cons else eq? equal? lambda let let* map
pair? quote code-quote values))
(define (process-rules rules subkeywords r c)
(define %append (r 'append))
(define %apply (r 'apply))
(define %and (r 'and))
(define %car (r 'car))
(define %cdr (r 'cdr))
(define %compare (r 'compare))
(define %cond (r 'cond))
(define %cons (r 'cons))
(define %else (r 'else))
(define %eq? (r 'eq?))
(define %equal? (r 'equal?))
(define %input (r 'input))
(define %lambda (r 'lambda))
(define %let (r 'let))
(define %let* (r 'let*))
(define %map (r 'map))
(define %pair? (r 'pair?))
(define %quote (r 'quote))
(define %code-quote (r 'code-quote))
(define %rename (r 'rename))
(define %tail (r 'tail))
(define %temp (r 'temp))
(define (make-transformer rules)
`(,%lambda (,%input ,%rename ,%compare)
(,%let ((,%tail (,%cdr ,%input)))
(,%cond ,@(map process-rule rules)
(,%else ,%input))))) ;Error when left unchanged.
(define (process-rule rule)
(if (and (pair? rule)
(pair? (cdr rule))
(null? (cddr rule)))
(let ((pattern (cdar rule))
(template (cadr rule)))
`((,%and ,@(process-match %tail pattern))
(,%let* ,(process-pattern pattern
%tail
(lambda (x) x))
,(process-template template
0
(meta-variables pattern 0 '())))))
(syntax-error "ill-formed syntax rule" rule)))
; Generate code to test whether input expression matches pattern
(define (process-match input pattern)
(cond ((name? pattern)
(if (member pattern subkeywords)
`((,%compare ,input (,%rename (,%code-quote ,pattern))))
`()))
((segment-pattern? pattern)
(process-segment-match input (car pattern)))
((pair? pattern)
`((,%let ((,%temp ,input))
(,%and (,%pair? ,%temp)
,@(process-match `(,%car ,%temp) (car pattern))
,@(process-match `(,%cdr ,%temp) (cdr pattern))))))
((or (null? pattern) (boolean? pattern) (char? pattern))
`((,%eq? ,input ',pattern)))
(else
`((,%equal? ,input ',pattern)))))
(define (process-segment-match input pattern)
(let ((conjuncts (process-match '(car l) pattern)))
(if (null? conjuncts)
`((list? ,input)) ;+++
`((let loop ((l ,input))
(or (null? l)
(and (pair? l)
,@conjuncts
(loop (cdr l)))))))))
; Generate code to take apart the input expression
; This is pretty bad, but it seems to work (can't say why).
(define (process-pattern pattern path mapit)
(cond ((name? pattern)
(if (memq pattern subkeywords)
'()
(list (list pattern (mapit path)))))
((segment-pattern? pattern)
(process-pattern (car pattern)
%temp
(lambda (x) ;temp is free in x
(mapit (if (eq? %temp x)
path ;+++
`(,%map (,%lambda (,%temp) ,x)
,path))))))
((pair? pattern)
(append (process-pattern (car pattern) `(,%car ,path) mapit)
(process-pattern (cdr pattern) `(,%cdr ,path) mapit)))
(else '())))
; Generate code to compose the output expression according to template
(define (process-template template dim env)
(cond ((name? template)
(let ((probe (assq template env)))
(if probe
(if (<= (cdr probe) dim)
template
(syntax-error "template dimension error (too few ...'s?)"
template))
`(,%rename (,%code-quote ,template)))))
((segment-template? template)
(let* ((depth (segment-depth template))
(seg-dim (+ dim depth))
(vars
(free-meta-variables (car template) seg-dim env '())))
(if (null? vars)
(syntax-error "too many ...'s" template)
(let* ((x (process-template (car template)
seg-dim
env))
(gen (if (equal? (list x) vars)
x ;+++
`(,%map (,%lambda ,vars ,x)
,@vars)))
(gen (do ((d depth (- d 1))
(gen gen `(,%apply ,%append ,gen)))
((= d 1)
gen))))
(if (null? (segment-tail template))
gen ;+++
`(,%append ,gen ,(process-template (segment-tail template)
dim env)))))))
((pair? template)
`(,%cons ,(process-template (car template) dim env)
,(process-template (cdr template) dim env)))
(else
`(,%quote ,template))))
; Return an association list of (var . dim)
(define (meta-variables pattern dim vars)
(cond ((name? pattern)
(if (memq pattern subkeywords)
vars
(cons (cons pattern dim) vars)))
((segment-pattern? pattern)
(meta-variables (car pattern) (+ dim 1) vars))
((pair? pattern)
(meta-variables (car pattern) dim
(meta-variables (cdr pattern) dim vars)))
(else vars)))
; Return a list of meta-variables of given higher dim
(define (free-meta-variables template dim env free)
(cond ((name? template)
(if (and (not (memq template free))
(let ((probe (assq template env)))
(and probe (>= (cdr probe) dim))))
(cons template free)
free))
((segment-template? template)
(free-meta-variables (car template)
dim env
(free-meta-variables (cddr template)
dim env free)))
((pair? template)
(free-meta-variables (car template)
dim env
(free-meta-variables (cdr template)
dim env free)))
(else free)))
(make-transformer rules))
(define (segment-pattern? pattern)
(and (segment-template? pattern)
(or (null? (cddr pattern))
(syntax-error "segment matching not implemented" pattern))))
(define (segment-template? pattern)
(and (pair? pattern)
(pair? (cdr pattern))
(memq (cadr pattern) indicators-for-zero-or-more)))
; Count the number of `...'s in PATTERN.
(define (segment-depth pattern)
(if (segment-template? pattern)
(+ 1 (segment-depth (cdr pattern)))
0))
; Get whatever is after the `...'s in PATTERN.
(define (segment-tail pattern)
(let loop ((pattern (cdr pattern)))
(if (and (pair? pattern)
(memq (car pattern) indicators-for-zero-or-more))
(loop (cdr pattern))
pattern)))
(define indicators-for-zero-or-more (list (string->symbol "...")))
;(define (name? thing)
; (or (symbol? thing)
; (not (or (pair? thing) ;Kludge!
; (null? thing)
; (number? thing)
; (boolean? thing)
; (char? thing)
; (string? thing)))))
; The following is used by Scheme 48's static linker.
(define (find-free-names-in-syntax-rules subkeywords rules)
(define (meta-variables pattern vars)
(cond ((name? pattern)
(if (memq pattern subkeywords)
vars
(cons pattern vars)))
((segment-pattern? pattern)
(meta-variables (car pattern) ;vars
(meta-variables (cddr pattern) vars)))
((pair? pattern)
(meta-variables (car pattern)
(meta-variables (cdr pattern) vars)))
(else vars)))
(define (free-names template vars names)
(cond ((name? template)
(if (or (memq template vars)
(memq template names))
names
(cons template names)))
((segment-template? template)
(free-names (car template)
vars
(free-names (cddr template) vars names)))
((pair? template)
(free-names (car template)
vars
(free-names (cdr template) vars names)))
(else names)))
(do ((rules rules (cdr rules))
(names subkeywords
(let ((rule (car rules)))
(free-names (cadr rule)
(meta-variables (cdar rule) '())
names))))
((null? rules) names)))
|
