Commit | Line | Data |
---|---|---|
1c297a38 | 1 | ;;;; Copyright (C) 2009, 2010 Free Software Foundation, Inc. |
811d10f5 AW |
2 | ;;;; |
3 | ;;;; This library is free software; you can redistribute it and/or | |
4 | ;;;; modify it under the terms of the GNU Lesser General Public | |
5 | ;;;; License as published by the Free Software Foundation; either | |
53befeb7 | 6 | ;;;; version 3 of the License, or (at your option) any later version. |
811d10f5 AW |
7 | ;;;; |
8 | ;;;; This library is distributed in the hope that it will be useful, | |
9 | ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
10 | ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU | |
11 | ;;;; Lesser General Public License for more details. | |
12 | ;;;; | |
13 | ;;;; You should have received a copy of the GNU Lesser General Public | |
14 | ;;;; License along with this library; if not, write to the Free Software | |
15 | ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA | |
16 | ;;;; | |
17 | \f | |
18 | ||
19 | (define-module (language tree-il) | |
f4aa0f10 | 20 | #:use-module (srfi srfi-1) |
4dcd8499 | 21 | #:use-module (srfi srfi-11) |
811d10f5 AW |
22 | #:use-module (system base pmatch) |
23 | #:use-module (system base syntax) | |
9efc833d | 24 | #:export (tree-il-src |
811d10f5 | 25 | |
cf10678f | 26 | <void> void? make-void void-src |
81fd3152 | 27 | <const> const? make-const const-src const-exp |
cb28c085 AW |
28 | <primitive-ref> primitive-ref? make-primitive-ref primitive-ref-src primitive-ref-name |
29 | <lexical-ref> lexical-ref? make-lexical-ref lexical-ref-src lexical-ref-name lexical-ref-gensym | |
30 | <lexical-set> lexical-set? make-lexical-set lexical-set-src lexical-set-name lexical-set-gensym lexical-set-exp | |
31 | <module-ref> module-ref? make-module-ref module-ref-src module-ref-mod module-ref-name module-ref-public? | |
32 | <module-set> module-set? make-module-set module-set-src module-set-mod module-set-name module-set-public? module-set-exp | |
33 | <toplevel-ref> toplevel-ref? make-toplevel-ref toplevel-ref-src toplevel-ref-name | |
34 | <toplevel-set> toplevel-set? make-toplevel-set toplevel-set-src toplevel-set-name toplevel-set-exp | |
35 | <toplevel-define> toplevel-define? make-toplevel-define toplevel-define-src toplevel-define-name toplevel-define-exp | |
b6d93b11 | 36 | <conditional> conditional? make-conditional conditional-src conditional-test conditional-consequent conditional-alternate |
81fd3152 | 37 | <application> application? make-application application-src application-proc application-args |
cb28c085 | 38 | <sequence> sequence? make-sequence sequence-src sequence-exps |
8a4ca0ea AW |
39 | <lambda> lambda? make-lambda lambda-src lambda-meta lambda-body |
40 | <lambda-case> lambda-case? make-lambda-case lambda-case-src | |
b0c8c187 AW |
41 | lambda-case-req lambda-case-opt lambda-case-rest lambda-case-kw |
42 | lambda-case-inits lambda-case-vars | |
3a88cb3b | 43 | lambda-case-body lambda-case-alternate |
f4aa8d53 AW |
44 | <let> let? make-let let-src let-names let-vars let-vals let-body |
45 | <letrec> letrec? make-letrec letrec-src letrec-names letrec-vars letrec-vals letrec-body | |
c21c89b1 | 46 | <fix> fix? make-fix fix-src fix-names fix-vars fix-vals fix-body |
8a4ca0ea | 47 | <let-values> let-values? make-let-values let-values-src let-values-exp let-values-body |
8da6ab34 | 48 | <dynwind> dynwind? make-dynwind dynwind-src dynwind-winder dynwind-body dynwind-unwinder |
d7c53a86 | 49 | <dynlet> dynlet? make-dynlet dynlet-src dynlet-fluids dynlet-vals dynlet-body |
07a0c7d5 | 50 | <prompt> prompt? make-prompt prompt-src prompt-tag prompt-body prompt-handler |
6e84cb95 | 51 | <abort> abort? make-abort abort-src abort-tag abort-args |
f4aa0f10 | 52 | |
9efc833d AW |
53 | parse-tree-il |
54 | unparse-tree-il | |
cb28c085 AW |
55 | tree-il->scheme |
56 | ||
f4aa0f10 | 57 | tree-il-fold |
4dcd8499 | 58 | make-tree-il-folder |
cb28c085 AW |
59 | post-order! |
60 | pre-order!)) | |
811d10f5 AW |
61 | |
62 | (define-type (<tree-il> #:common-slots (src)) | |
cf10678f | 63 | (<void>) |
81fd3152 | 64 | (<const> exp) |
811d10f5 AW |
65 | (<primitive-ref> name) |
66 | (<lexical-ref> name gensym) | |
67 | (<lexical-set> name gensym exp) | |
68 | (<module-ref> mod name public?) | |
69 | (<module-set> mod name public? exp) | |
70 | (<toplevel-ref> name) | |
71 | (<toplevel-set> name exp) | |
72 | (<toplevel-define> name exp) | |
b6d93b11 | 73 | (<conditional> test consequent alternate) |
81fd3152 | 74 | (<application> proc args) |
811d10f5 | 75 | (<sequence> exps) |
8a4ca0ea | 76 | (<lambda> meta body) |
3a88cb3b | 77 | (<lambda-case> req opt rest kw inits vars body alternate) |
f4aa8d53 AW |
78 | (<let> names vars vals body) |
79 | (<letrec> names vars vals body) | |
c21c89b1 | 80 | (<fix> names vars vals body) |
1c297a38 | 81 | (<let-values> exp body) |
8da6ab34 | 82 | (<dynwind> winder body unwinder) |
d7c53a86 | 83 | (<dynlet> fluids vals body) |
07a0c7d5 | 84 | (<prompt> tag body handler) |
6e84cb95 | 85 | (<abort> tag args)) |
811d10f5 | 86 | |
811d10f5 AW |
87 | \f |
88 | ||
811d10f5 AW |
89 | (define (location x) |
90 | (and (pair? x) | |
91 | (let ((props (source-properties x))) | |
81fd3152 | 92 | (and (pair? props) props)))) |
811d10f5 | 93 | |
ce09ee19 | 94 | (define (parse-tree-il exp) |
811d10f5 | 95 | (let ((loc (location exp)) |
ce09ee19 | 96 | (retrans (lambda (x) (parse-tree-il x)))) |
811d10f5 | 97 | (pmatch exp |
cf10678f AW |
98 | ((void) |
99 | (make-void loc)) | |
100 | ||
ce09ee19 AW |
101 | ((apply ,proc . ,args) |
102 | (make-application loc (retrans proc) (map retrans args))) | |
811d10f5 | 103 | |
b6d93b11 AW |
104 | ((if ,test ,consequent ,alternate) |
105 | (make-conditional loc (retrans test) (retrans consequent) (retrans alternate))) | |
811d10f5 AW |
106 | |
107 | ((primitive ,name) (guard (symbol? name)) | |
108 | (make-primitive-ref loc name)) | |
109 | ||
110 | ((lexical ,name) (guard (symbol? name)) | |
111 | (make-lexical-ref loc name name)) | |
112 | ||
113 | ((lexical ,name ,sym) (guard (symbol? name) (symbol? sym)) | |
114 | (make-lexical-ref loc name sym)) | |
115 | ||
5c27902e AW |
116 | ((set! (lexical ,name) ,exp) (guard (symbol? name)) |
117 | (make-lexical-set loc name name (retrans exp))) | |
118 | ||
811d10f5 AW |
119 | ((set! (lexical ,name ,sym) ,exp) (guard (symbol? name) (symbol? sym)) |
120 | (make-lexical-set loc name sym (retrans exp))) | |
121 | ||
122 | ((@ ,mod ,name) (guard (and-map symbol? mod) (symbol? name)) | |
123 | (make-module-ref loc mod name #t)) | |
124 | ||
125 | ((set! (@ ,mod ,name) ,exp) (guard (and-map symbol? mod) (symbol? name)) | |
126 | (make-module-set loc mod name #t (retrans exp))) | |
127 | ||
128 | ((@@ ,mod ,name) (guard (and-map symbol? mod) (symbol? name)) | |
129 | (make-module-ref loc mod name #f)) | |
130 | ||
ce09ee19 | 131 | ((set! (@@ ,mod ,name) ,exp) (guard (and-map symbol? mod) (symbol? name)) |
811d10f5 AW |
132 | (make-module-set loc mod name #f (retrans exp))) |
133 | ||
134 | ((toplevel ,name) (guard (symbol? name)) | |
135 | (make-toplevel-ref loc name)) | |
136 | ||
ce09ee19 | 137 | ((set! (toplevel ,name) ,exp) (guard (symbol? name)) |
811d10f5 AW |
138 | (make-toplevel-set loc name (retrans exp))) |
139 | ||
ce09ee19 | 140 | ((define ,name ,exp) (guard (symbol? name)) |
811d10f5 AW |
141 | (make-toplevel-define loc name (retrans exp))) |
142 | ||
8a4ca0ea AW |
143 | ((lambda ,meta ,body) |
144 | (make-lambda loc meta (retrans body))) | |
811d10f5 | 145 | |
3a88cb3b | 146 | ((lambda-case ((,req ,opt ,rest ,kw ,inits ,vars) ,body) ,alternate) |
b0c8c187 AW |
147 | (make-lambda-case loc req opt rest kw |
148 | (map retrans inits) vars | |
8a4ca0ea | 149 | (retrans body) |
3a88cb3b | 150 | (and=> alternate retrans))) |
811d10f5 | 151 | |
1e2a8edb | 152 | ((lambda-case ((,req ,opt ,rest ,kw ,inits ,vars) ,body)) |
b0c8c187 AW |
153 | (make-lambda-case loc req opt rest kw |
154 | (map retrans inits) vars | |
7e01997e AW |
155 | (retrans body) |
156 | #f)) | |
157 | ||
811d10f5 AW |
158 | ((const ,exp) |
159 | (make-const loc exp)) | |
160 | ||
161 | ((begin . ,exps) | |
162 | (make-sequence loc (map retrans exps))) | |
163 | ||
f4aa8d53 AW |
164 | ((let ,names ,vars ,vals ,body) |
165 | (make-let loc names vars (map retrans vals) (retrans body))) | |
166 | ||
167 | ((letrec ,names ,vars ,vals ,body) | |
168 | (make-letrec loc names vars (map retrans vals) (retrans body))) | |
811d10f5 | 169 | |
c21c89b1 AW |
170 | ((fix ,names ,vars ,vals ,body) |
171 | (make-fix loc names vars (map retrans vals) (retrans body))) | |
172 | ||
8a4ca0ea AW |
173 | ((let-values ,exp ,body) |
174 | (make-let-values loc (retrans exp) (retrans body))) | |
811d10f5 | 175 | |
8da6ab34 AW |
176 | ((dynwind ,winder ,body ,unwinder) |
177 | (make-dynwind loc (retrans winder) (retrans body) (retrans unwinder))) | |
1c297a38 | 178 | |
d7c53a86 AW |
179 | ((dynlet ,fluids ,vals ,body) |
180 | (make-dynlet loc (map retrans fluids) (map retrans vals) (retrans body))) | |
181 | ||
07a0c7d5 AW |
182 | ((prompt ,tag ,body ,handler) |
183 | (make-prompt loc (retrans tag) (retrans body) (retrans handler))) | |
1c297a38 | 184 | |
6e84cb95 AW |
185 | ((abort ,tag ,type ,args) |
186 | (make-abort loc (retrans tag) type (map retrans args))) | |
1c297a38 | 187 | |
811d10f5 AW |
188 | (else |
189 | (error "unrecognized tree-il" exp))))) | |
190 | ||
191 | (define (unparse-tree-il tree-il) | |
192 | (record-case tree-il | |
cf10678f AW |
193 | ((<void>) |
194 | '(void)) | |
195 | ||
811d10f5 | 196 | ((<application> proc args) |
ce09ee19 | 197 | `(apply ,(unparse-tree-il proc) ,@(map unparse-tree-il args))) |
811d10f5 | 198 | |
b6d93b11 AW |
199 | ((<conditional> test consequent alternate) |
200 | `(if ,(unparse-tree-il test) ,(unparse-tree-il consequent) ,(unparse-tree-il alternate))) | |
811d10f5 AW |
201 | |
202 | ((<primitive-ref> name) | |
203 | `(primitive ,name)) | |
204 | ||
205 | ((<lexical-ref> name gensym) | |
206 | `(lexical ,name ,gensym)) | |
207 | ||
208 | ((<lexical-set> name gensym exp) | |
209 | `(set! (lexical ,name ,gensym) ,(unparse-tree-il exp))) | |
210 | ||
211 | ((<module-ref> mod name public?) | |
212 | `(,(if public? '@ '@@) ,mod ,name)) | |
213 | ||
214 | ((<module-set> mod name public? exp) | |
215 | `(set! (,(if public? '@ '@@) ,mod ,name) ,(unparse-tree-il exp))) | |
216 | ||
217 | ((<toplevel-ref> name) | |
218 | `(toplevel ,name)) | |
219 | ||
220 | ((<toplevel-set> name exp) | |
221 | `(set! (toplevel ,name) ,(unparse-tree-il exp))) | |
222 | ||
223 | ((<toplevel-define> name exp) | |
224 | `(define ,name ,(unparse-tree-il exp))) | |
225 | ||
8a4ca0ea AW |
226 | ((<lambda> meta body) |
227 | `(lambda ,meta ,(unparse-tree-il body))) | |
228 | ||
3a88cb3b | 229 | ((<lambda-case> req opt rest kw inits vars body alternate) |
1e2a8edb | 230 | `(lambda-case ((,req ,opt ,rest ,kw ,(map unparse-tree-il inits) ,vars) |
8a4ca0ea | 231 | ,(unparse-tree-il body)) |
3a88cb3b | 232 | . ,(if alternate (list (unparse-tree-il alternate)) '()))) |
811d10f5 AW |
233 | |
234 | ((<const> exp) | |
235 | `(const ,exp)) | |
236 | ||
237 | ((<sequence> exps) | |
238 | `(begin ,@(map unparse-tree-il exps))) | |
239 | ||
f4aa8d53 AW |
240 | ((<let> names vars vals body) |
241 | `(let ,names ,vars ,(map unparse-tree-il vals) ,(unparse-tree-il body))) | |
811d10f5 | 242 | |
f4aa8d53 AW |
243 | ((<letrec> names vars vals body) |
244 | `(letrec ,names ,vars ,(map unparse-tree-il vals) ,(unparse-tree-il body))) | |
245 | ||
c21c89b1 AW |
246 | ((<fix> names vars vals body) |
247 | `(fix ,names ,vars ,(map unparse-tree-il vals) ,(unparse-tree-il body))) | |
248 | ||
8a4ca0ea | 249 | ((<let-values> exp body) |
1c297a38 AW |
250 | `(let-values ,(unparse-tree-il exp) ,(unparse-tree-il body))) |
251 | ||
8da6ab34 AW |
252 | ((<dynwind> body winder unwinder) |
253 | `(dynwind ,(unparse-tree-il body) | |
1c297a38 AW |
254 | ,(unparse-tree-il winder) ,(unparse-tree-il unwinder))) |
255 | ||
d7c53a86 AW |
256 | ((<dynlet> fluids vals body) |
257 | `(dynlet ,(map unparse-tree-il fluids) ,(map unparse-tree-il vals) | |
258 | ,(unparse-tree-il body))) | |
259 | ||
07a0c7d5 AW |
260 | ((<prompt> tag body handler) |
261 | `(prompt ,tag ,(unparse-tree-il body) ,(unparse-tree-il handler))) | |
1c297a38 | 262 | |
6e84cb95 AW |
263 | ((<abort> tag args) |
264 | `(abort ,(unparse-tree-il tag) ,(map unparse-tree-il args))))) | |
811d10f5 AW |
265 | |
266 | (define (tree-il->scheme e) | |
f4aa8d53 AW |
267 | (record-case e |
268 | ((<void>) | |
269 | '(if #f #f)) | |
270 | ||
271 | ((<application> proc args) | |
272 | `(,(tree-il->scheme proc) ,@(map tree-il->scheme args))) | |
273 | ||
b6d93b11 AW |
274 | ((<conditional> test consequent alternate) |
275 | (if (void? alternate) | |
276 | `(if ,(tree-il->scheme test) ,(tree-il->scheme consequent)) | |
277 | `(if ,(tree-il->scheme test) ,(tree-il->scheme consequent) ,(tree-il->scheme alternate)))) | |
f4aa8d53 AW |
278 | |
279 | ((<primitive-ref> name) | |
280 | name) | |
281 | ||
e5f5113c | 282 | ((<lexical-ref> gensym) |
f4aa8d53 AW |
283 | gensym) |
284 | ||
e5f5113c | 285 | ((<lexical-set> gensym exp) |
f4aa8d53 AW |
286 | `(set! ,gensym ,(tree-il->scheme exp))) |
287 | ||
288 | ((<module-ref> mod name public?) | |
289 | `(,(if public? '@ '@@) ,mod ,name)) | |
290 | ||
291 | ((<module-set> mod name public? exp) | |
292 | `(set! (,(if public? '@ '@@) ,mod ,name) ,(tree-il->scheme exp))) | |
293 | ||
294 | ((<toplevel-ref> name) | |
295 | name) | |
296 | ||
297 | ((<toplevel-set> name exp) | |
298 | `(set! ,name ,(tree-il->scheme exp))) | |
299 | ||
300 | ((<toplevel-define> name exp) | |
301 | `(define ,name ,(tree-il->scheme exp))) | |
302 | ||
8a4ca0ea AW |
303 | ((<lambda> meta body) |
304 | ;; fixme: put in docstring | |
305 | (if (and (lambda-case? body) | |
3a88cb3b | 306 | (not (lambda-case-alternate body))) |
8a4ca0ea AW |
307 | `(lambda ,@(car (tree-il->scheme body))) |
308 | `(case-lambda ,@(tree-il->scheme body)))) | |
309 | ||
3a88cb3b | 310 | ((<lambda-case> req opt rest kw inits vars body alternate) |
b0c8c187 | 311 | ;; FIXME! use parse-lambda-case? |
8a4ca0ea AW |
312 | `((,(if rest (apply cons* vars) vars) |
313 | ,(tree-il->scheme body)) | |
3a88cb3b | 314 | ,@(if alternate (tree-il->scheme alternate) '()))) |
f4aa8d53 AW |
315 | |
316 | ((<const> exp) | |
317 | (if (and (self-evaluating? exp) (not (vector? exp))) | |
318 | exp | |
319 | (list 'quote exp))) | |
320 | ||
321 | ((<sequence> exps) | |
322 | `(begin ,@(map tree-il->scheme exps))) | |
323 | ||
324 | ((<let> vars vals body) | |
325 | `(let ,(map list vars (map tree-il->scheme vals)) ,(tree-il->scheme body))) | |
326 | ||
327 | ((<letrec> vars vals body) | |
328 | `(letrec ,(map list vars (map tree-il->scheme vals)) ,(tree-il->scheme body))) | |
329 | ||
c21c89b1 AW |
330 | ((<fix> vars vals body) |
331 | ;; not a typo, we really do translate back to letrec | |
332 | `(letrec ,(map list vars (map tree-il->scheme vals)) ,(tree-il->scheme body))) | |
333 | ||
1e2a8edb | 334 | ((<let-values> exp body) |
f4aa8d53 | 335 | `(call-with-values (lambda () ,(tree-il->scheme exp)) |
1c297a38 AW |
336 | ,(tree-il->scheme (make-lambda #f '() body)))) |
337 | ||
8da6ab34 | 338 | ((<dynwind> body winder unwinder) |
d69531e2 AW |
339 | `(dynamic-wind ,(tree-il->scheme winder) |
340 | (lambda () ,(tree-il->scheme body)) | |
341 | ,(tree-il->scheme unwinder))) | |
1c297a38 | 342 | |
d7c53a86 AW |
343 | ((<dynlet> fluids vals body) |
344 | `(with-fluids ,(map list | |
345 | (map tree-il->scheme fluids) | |
346 | (map tree-il->scheme vals)) | |
67a78ddd | 347 | ,(tree-il->scheme body))) |
d7c53a86 | 348 | |
07a0c7d5 | 349 | ((<prompt> tag body handler) |
1c297a38 AW |
350 | `((@ (ice-9 control) prompt) |
351 | ,(tree-il->scheme tag) (lambda () ,(tree-il->scheme body)) | |
07a0c7d5 | 352 | ,(tree-il->scheme handler))) |
1c297a38 AW |
353 | |
354 | ||
6e84cb95 AW |
355 | ((<abort> tag args) |
356 | `(@abort ,(tree-il->scheme tag) ,@(map tree-il->scheme args))))) | |
cb28c085 | 357 | |
f4aa0f10 LC |
358 | \f |
359 | (define (tree-il-fold leaf down up seed tree) | |
360 | "Traverse TREE, calling LEAF on each leaf encountered, DOWN upon descent | |
361 | into a sub-tree, and UP when leaving a sub-tree. Each of these procedures is | |
362 | invoked as `(PROC TREE SEED)', where TREE is the sub-tree or leaf considered | |
363 | and SEED is the current result, intially seeded with SEED. | |
364 | ||
365 | This is an implementation of `foldts' as described by Andy Wingo in | |
366 | ``Applications of fold to XML transformation''." | |
367 | (let loop ((tree tree) | |
368 | (result seed)) | |
369 | (if (or (null? tree) (pair? tree)) | |
370 | (fold loop result tree) | |
371 | (record-case tree | |
372 | ((<lexical-set> exp) | |
373 | (up tree (loop exp (down tree result)))) | |
374 | ((<module-set> exp) | |
375 | (up tree (loop exp (down tree result)))) | |
376 | ((<toplevel-set> exp) | |
377 | (up tree (loop exp (down tree result)))) | |
378 | ((<toplevel-define> exp) | |
379 | (up tree (loop exp (down tree result)))) | |
b6d93b11 AW |
380 | ((<conditional> test consequent alternate) |
381 | (up tree (loop alternate | |
382 | (loop consequent | |
f4aa0f10 LC |
383 | (loop test (down tree result)))))) |
384 | ((<application> proc args) | |
385 | (up tree (loop (cons proc args) (down tree result)))) | |
386 | ((<sequence> exps) | |
387 | (up tree (loop exps (down tree result)))) | |
388 | ((<lambda> body) | |
389 | (up tree (loop body (down tree result)))) | |
3a88cb3b AW |
390 | ((<lambda-case> inits body alternate) |
391 | (up tree (if alternate | |
392 | (loop alternate | |
1e2a8edb AW |
393 | (loop body (loop inits (down tree result)))) |
394 | (loop body (loop inits (down tree result)))))) | |
f4aa0f10 LC |
395 | ((<let> vals body) |
396 | (up tree (loop body | |
397 | (loop vals | |
398 | (down tree result))))) | |
399 | ((<letrec> vals body) | |
400 | (up tree (loop body | |
401 | (loop vals | |
402 | (down tree result))))) | |
c21c89b1 AW |
403 | ((<fix> vals body) |
404 | (up tree (loop body | |
405 | (loop vals | |
406 | (down tree result))))) | |
4dcd8499 AW |
407 | ((<let-values> exp body) |
408 | (up tree (loop body (loop exp (down tree result))))) | |
8da6ab34 | 409 | ((<dynwind> body winder unwinder) |
1c297a38 AW |
410 | (up tree (loop unwinder |
411 | (loop winder | |
412 | (loop body (down tree result)))))) | |
d7c53a86 AW |
413 | ((<dynlet> fluids vals body) |
414 | (up tree (loop body | |
415 | (loop vals | |
416 | (loop fluids (down tree result)))))) | |
07a0c7d5 AW |
417 | ((<prompt> tag body handler) |
418 | (up tree | |
419 | (loop tag (loop body (loop handler | |
420 | (down tree result)))))) | |
6e84cb95 | 421 | ((<abort> tag args) |
1c297a38 | 422 | (up tree (loop tag (loop args (down tree result))))) |
f4aa0f10 LC |
423 | (else |
424 | (leaf tree result)))))) | |
425 | ||
4dcd8499 AW |
426 | |
427 | (define-syntax make-tree-il-folder | |
428 | (syntax-rules () | |
429 | ((_ seed ...) | |
80af1168 | 430 | (lambda (tree down up seed ...) |
4dcd8499 AW |
431 | (define (fold-values proc exps seed ...) |
432 | (if (null? exps) | |
433 | (values seed ...) | |
434 | (let-values (((seed ...) (proc (car exps) seed ...))) | |
435 | (fold-values proc (cdr exps) seed ...)))) | |
436 | (let foldts ((tree tree) (seed seed) ...) | |
80af1168 AW |
437 | (let*-values |
438 | (((seed ...) (down tree seed ...)) | |
439 | ((seed ...) | |
440 | (record-case tree | |
441 | ((<lexical-set> exp) | |
442 | (foldts exp seed ...)) | |
443 | ((<module-set> exp) | |
444 | (foldts exp seed ...)) | |
445 | ((<toplevel-set> exp) | |
446 | (foldts exp seed ...)) | |
447 | ((<toplevel-define> exp) | |
448 | (foldts exp seed ...)) | |
b6d93b11 | 449 | ((<conditional> test consequent alternate) |
80af1168 | 450 | (let*-values (((seed ...) (foldts test seed ...)) |
b6d93b11 AW |
451 | ((seed ...) (foldts consequent seed ...))) |
452 | (foldts alternate seed ...))) | |
80af1168 AW |
453 | ((<application> proc args) |
454 | (let-values (((seed ...) (foldts proc seed ...))) | |
455 | (fold-values foldts args seed ...))) | |
456 | ((<sequence> exps) | |
457 | (fold-values foldts exps seed ...)) | |
458 | ((<lambda> body) | |
459 | (foldts body seed ...)) | |
3a88cb3b | 460 | ((<lambda-case> inits body alternate) |
b0c8c187 | 461 | (let-values (((seed ...) (fold-values foldts inits seed ...))) |
3a88cb3b | 462 | (if alternate |
1e2a8edb | 463 | (let-values (((seed ...) (foldts body seed ...))) |
3a88cb3b | 464 | (foldts alternate seed ...)) |
1e2a8edb | 465 | (foldts body seed ...)))) |
80af1168 AW |
466 | ((<let> vals body) |
467 | (let*-values (((seed ...) (fold-values foldts vals seed ...))) | |
468 | (foldts body seed ...))) | |
469 | ((<letrec> vals body) | |
470 | (let*-values (((seed ...) (fold-values foldts vals seed ...))) | |
471 | (foldts body seed ...))) | |
472 | ((<fix> vals body) | |
473 | (let*-values (((seed ...) (fold-values foldts vals seed ...))) | |
474 | (foldts body seed ...))) | |
475 | ((<let-values> exp body) | |
476 | (let*-values (((seed ...) (foldts exp seed ...))) | |
477 | (foldts body seed ...))) | |
8da6ab34 | 478 | ((<dynwind> body winder unwinder) |
1c297a38 AW |
479 | (let*-values (((seed ...) (foldts body seed ...)) |
480 | ((seed ...) (foldts winder seed ...))) | |
481 | (foldts unwinder seed ...))) | |
d7c53a86 AW |
482 | ((<dynlet> fluids vals body) |
483 | (let*-values (((seed ...) (fold-values foldts fluids seed ...)) | |
484 | ((seed ...) (fold-values foldts vals seed ...))) | |
485 | (foldts body seed ...))) | |
07a0c7d5 | 486 | ((<prompt> tag body handler) |
1c297a38 | 487 | (let*-values (((seed ...) (foldts tag seed ...)) |
07a0c7d5 AW |
488 | ((seed ...) (foldts body seed ...))) |
489 | (foldts handler seed ...))) | |
6e84cb95 | 490 | ((<abort> tag args) |
1c297a38 AW |
491 | (let*-values (((seed ...) (foldts tag seed ...))) |
492 | (fold-values foldts args seed ...))) | |
80af1168 AW |
493 | (else |
494 | (values seed ...))))) | |
495 | (up tree seed ...))))))) | |
4dcd8499 | 496 | |
cb28c085 AW |
497 | (define (post-order! f x) |
498 | (let lp ((x x)) | |
499 | (record-case x | |
500 | ((<application> proc args) | |
501 | (set! (application-proc x) (lp proc)) | |
f4aa8d53 | 502 | (set! (application-args x) (map lp args))) |
cb28c085 | 503 | |
b6d93b11 | 504 | ((<conditional> test consequent alternate) |
cb28c085 | 505 | (set! (conditional-test x) (lp test)) |
b6d93b11 AW |
506 | (set! (conditional-consequent x) (lp consequent)) |
507 | (set! (conditional-alternate x) (lp alternate))) | |
f4aa8d53 | 508 | |
cb28c085 | 509 | ((<lexical-set> name gensym exp) |
f4aa8d53 AW |
510 | (set! (lexical-set-exp x) (lp exp))) |
511 | ||
cb28c085 | 512 | ((<module-set> mod name public? exp) |
f4aa8d53 AW |
513 | (set! (module-set-exp x) (lp exp))) |
514 | ||
cb28c085 | 515 | ((<toplevel-set> name exp) |
f4aa8d53 AW |
516 | (set! (toplevel-set-exp x) (lp exp))) |
517 | ||
cb28c085 | 518 | ((<toplevel-define> name exp) |
f4aa8d53 AW |
519 | (set! (toplevel-define-exp x) (lp exp))) |
520 | ||
8a4ca0ea | 521 | ((<lambda> body) |
f4aa8d53 AW |
522 | (set! (lambda-body x) (lp body))) |
523 | ||
3a88cb3b | 524 | ((<lambda-case> inits body alternate) |
b0c8c187 | 525 | (set! inits (map lp inits)) |
8a4ca0ea | 526 | (set! (lambda-case-body x) (lp body)) |
3a88cb3b AW |
527 | (if alternate |
528 | (set! (lambda-case-alternate x) (lp alternate)))) | |
8a4ca0ea | 529 | |
cb28c085 | 530 | ((<sequence> exps) |
f4aa8d53 AW |
531 | (set! (sequence-exps x) (map lp exps))) |
532 | ||
533 | ((<let> vars vals body) | |
cb28c085 | 534 | (set! (let-vals x) (map lp vals)) |
f4aa8d53 AW |
535 | (set! (let-body x) (lp body))) |
536 | ||
537 | ((<letrec> vars vals body) | |
cb28c085 | 538 | (set! (letrec-vals x) (map lp vals)) |
f4aa8d53 AW |
539 | (set! (letrec-body x) (lp body))) |
540 | ||
c21c89b1 AW |
541 | ((<fix> vars vals body) |
542 | (set! (fix-vals x) (map lp vals)) | |
543 | (set! (fix-body x) (lp body))) | |
544 | ||
8a4ca0ea | 545 | ((<let-values> exp body) |
f4aa8d53 AW |
546 | (set! (let-values-exp x) (lp exp)) |
547 | (set! (let-values-body x) (lp body))) | |
548 | ||
8da6ab34 AW |
549 | ((<dynwind> body winder unwinder) |
550 | (set! (dynwind-body x) (lp body)) | |
551 | (set! (dynwind-winder x) (lp winder)) | |
552 | (set! (dynwind-unwinder x) (lp unwinder))) | |
1c297a38 | 553 | |
d7c53a86 AW |
554 | ((<dynlet> fluids vals body) |
555 | (set! (dynlet-fluids x) (map lp fluids)) | |
556 | (set! (dynlet-vals x) (map lp vals)) | |
557 | (set! (dynlet-body x) (lp body))) | |
558 | ||
07a0c7d5 | 559 | ((<prompt> tag body handler) |
1c297a38 AW |
560 | (set! (prompt-tag x) (lp tag)) |
561 | (set! (prompt-body x) (lp body)) | |
07a0c7d5 | 562 | (set! (prompt-handler x) (lp handler))) |
1c297a38 | 563 | |
6e84cb95 AW |
564 | ((<abort> tag args) |
565 | (set! (abort-tag x) (lp tag)) | |
566 | (set! (abort-args x) (map lp args))) | |
1c297a38 | 567 | |
f4aa8d53 AW |
568 | (else #f)) |
569 | ||
570 | (or (f x) x))) | |
cb28c085 AW |
571 | |
572 | (define (pre-order! f x) | |
573 | (let lp ((x x)) | |
574 | (let ((x (or (f x) x))) | |
575 | (record-case x | |
576 | ((<application> proc args) | |
577 | (set! (application-proc x) (lp proc)) | |
578 | (set! (application-args x) (map lp args))) | |
579 | ||
b6d93b11 | 580 | ((<conditional> test consequent alternate) |
cb28c085 | 581 | (set! (conditional-test x) (lp test)) |
b6d93b11 AW |
582 | (set! (conditional-consequent x) (lp consequent)) |
583 | (set! (conditional-alternate x) (lp alternate))) | |
cb28c085 | 584 | |
e5f5113c | 585 | ((<lexical-set> exp) |
cb28c085 AW |
586 | (set! (lexical-set-exp x) (lp exp))) |
587 | ||
e5f5113c | 588 | ((<module-set> exp) |
cb28c085 AW |
589 | (set! (module-set-exp x) (lp exp))) |
590 | ||
e5f5113c | 591 | ((<toplevel-set> exp) |
cb28c085 AW |
592 | (set! (toplevel-set-exp x) (lp exp))) |
593 | ||
e5f5113c | 594 | ((<toplevel-define> exp) |
cb28c085 AW |
595 | (set! (toplevel-define-exp x) (lp exp))) |
596 | ||
e5f5113c | 597 | ((<lambda> body) |
cb28c085 AW |
598 | (set! (lambda-body x) (lp body))) |
599 | ||
3a88cb3b | 600 | ((<lambda-case> inits body alternate) |
b0c8c187 | 601 | (set! inits (map lp inits)) |
8a4ca0ea | 602 | (set! (lambda-case-body x) (lp body)) |
3a88cb3b | 603 | (if alternate (set! (lambda-case-alternate x) (lp alternate)))) |
8a4ca0ea | 604 | |
cb28c085 AW |
605 | ((<sequence> exps) |
606 | (set! (sequence-exps x) (map lp exps))) | |
607 | ||
e5f5113c | 608 | ((<let> vals body) |
cb28c085 | 609 | (set! (let-vals x) (map lp vals)) |
f4aa8d53 | 610 | (set! (let-body x) (lp body))) |
cb28c085 | 611 | |
e5f5113c | 612 | ((<letrec> vals body) |
cb28c085 | 613 | (set! (letrec-vals x) (map lp vals)) |
f4aa8d53 AW |
614 | (set! (letrec-body x) (lp body))) |
615 | ||
e5f5113c | 616 | ((<fix> vals body) |
c21c89b1 AW |
617 | (set! (fix-vals x) (map lp vals)) |
618 | (set! (fix-body x) (lp body))) | |
619 | ||
e5f5113c | 620 | ((<let-values> exp body) |
f4aa8d53 AW |
621 | (set! (let-values-exp x) (lp exp)) |
622 | (set! (let-values-body x) (lp body))) | |
cb28c085 | 623 | |
8da6ab34 AW |
624 | ((<dynwind> body winder unwinder) |
625 | (set! (dynwind-body x) (lp body)) | |
626 | (set! (dynwind-winder x) (lp winder)) | |
627 | (set! (dynwind-unwinder x) (lp unwinder))) | |
1c297a38 | 628 | |
d7c53a86 AW |
629 | ((<dynlet> fluids vals body) |
630 | (set! (dynlet-fluids x) (map lp fluids)) | |
631 | (set! (dynlet-vals x) (map lp vals)) | |
632 | (set! (dynlet-body x) (lp body))) | |
633 | ||
07a0c7d5 | 634 | ((<prompt> tag body handler) |
1c297a38 AW |
635 | (set! (prompt-tag x) (lp tag)) |
636 | (set! (prompt-body x) (lp body)) | |
07a0c7d5 | 637 | (set! (prompt-handler x) (lp handler))) |
1c297a38 | 638 | |
6e84cb95 AW |
639 | ((<abort> tag args) |
640 | (set! (abort-tag x) (lp tag)) | |
641 | (set! (abort-args x) (map lp args))) | |
1c297a38 | 642 | |
cb28c085 AW |
643 | (else #f)) |
644 | x))) |