Commit | Line | Data |
---|---|---|
811d10f5 AW |
1 | ;;;; Copyright (C) 2009 Free Software Foundation, Inc. |
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 | |
81fd3152 AW |
36 | <conditional> conditional? make-conditional conditional-src conditional-test conditional-then conditional-else |
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 |
f4aa0f10 | 48 | |
9efc833d AW |
49 | parse-tree-il |
50 | unparse-tree-il | |
cb28c085 AW |
51 | tree-il->scheme |
52 | ||
f4aa0f10 | 53 | tree-il-fold |
4dcd8499 | 54 | make-tree-il-folder |
cb28c085 AW |
55 | post-order! |
56 | pre-order!)) | |
811d10f5 AW |
57 | |
58 | (define-type (<tree-il> #:common-slots (src)) | |
cf10678f | 59 | (<void>) |
81fd3152 | 60 | (<const> exp) |
811d10f5 AW |
61 | (<primitive-ref> name) |
62 | (<lexical-ref> name gensym) | |
63 | (<lexical-set> name gensym exp) | |
64 | (<module-ref> mod name public?) | |
65 | (<module-set> mod name public? exp) | |
66 | (<toplevel-ref> name) | |
67 | (<toplevel-set> name exp) | |
68 | (<toplevel-define> name exp) | |
81fd3152 AW |
69 | (<conditional> test then else) |
70 | (<application> proc args) | |
811d10f5 | 71 | (<sequence> exps) |
8a4ca0ea | 72 | (<lambda> meta body) |
3a88cb3b | 73 | (<lambda-case> req opt rest kw inits vars body alternate) |
f4aa8d53 AW |
74 | (<let> names vars vals body) |
75 | (<letrec> names vars vals body) | |
c21c89b1 | 76 | (<fix> names vars vals body) |
8a4ca0ea | 77 | (<let-values> exp body)) |
811d10f5 | 78 | |
811d10f5 AW |
79 | \f |
80 | ||
811d10f5 AW |
81 | (define (location x) |
82 | (and (pair? x) | |
83 | (let ((props (source-properties x))) | |
81fd3152 | 84 | (and (pair? props) props)))) |
811d10f5 | 85 | |
ce09ee19 | 86 | (define (parse-tree-il exp) |
811d10f5 | 87 | (let ((loc (location exp)) |
ce09ee19 | 88 | (retrans (lambda (x) (parse-tree-il x)))) |
811d10f5 | 89 | (pmatch exp |
cf10678f AW |
90 | ((void) |
91 | (make-void loc)) | |
92 | ||
ce09ee19 AW |
93 | ((apply ,proc . ,args) |
94 | (make-application loc (retrans proc) (map retrans args))) | |
811d10f5 AW |
95 | |
96 | ((if ,test ,then ,else) | |
97 | (make-conditional loc (retrans test) (retrans then) (retrans else))) | |
98 | ||
99 | ((primitive ,name) (guard (symbol? name)) | |
100 | (make-primitive-ref loc name)) | |
101 | ||
102 | ((lexical ,name) (guard (symbol? name)) | |
103 | (make-lexical-ref loc name name)) | |
104 | ||
105 | ((lexical ,name ,sym) (guard (symbol? name) (symbol? sym)) | |
106 | (make-lexical-ref loc name sym)) | |
107 | ||
5c27902e AW |
108 | ((set! (lexical ,name) ,exp) (guard (symbol? name)) |
109 | (make-lexical-set loc name name (retrans exp))) | |
110 | ||
811d10f5 AW |
111 | ((set! (lexical ,name ,sym) ,exp) (guard (symbol? name) (symbol? sym)) |
112 | (make-lexical-set loc name sym (retrans exp))) | |
113 | ||
114 | ((@ ,mod ,name) (guard (and-map symbol? mod) (symbol? name)) | |
115 | (make-module-ref loc mod name #t)) | |
116 | ||
117 | ((set! (@ ,mod ,name) ,exp) (guard (and-map symbol? mod) (symbol? name)) | |
118 | (make-module-set loc mod name #t (retrans exp))) | |
119 | ||
120 | ((@@ ,mod ,name) (guard (and-map symbol? mod) (symbol? name)) | |
121 | (make-module-ref loc mod name #f)) | |
122 | ||
ce09ee19 | 123 | ((set! (@@ ,mod ,name) ,exp) (guard (and-map symbol? mod) (symbol? name)) |
811d10f5 AW |
124 | (make-module-set loc mod name #f (retrans exp))) |
125 | ||
126 | ((toplevel ,name) (guard (symbol? name)) | |
127 | (make-toplevel-ref loc name)) | |
128 | ||
ce09ee19 | 129 | ((set! (toplevel ,name) ,exp) (guard (symbol? name)) |
811d10f5 AW |
130 | (make-toplevel-set loc name (retrans exp))) |
131 | ||
ce09ee19 | 132 | ((define ,name ,exp) (guard (symbol? name)) |
811d10f5 AW |
133 | (make-toplevel-define loc name (retrans exp))) |
134 | ||
8a4ca0ea AW |
135 | ((lambda ,meta ,body) |
136 | (make-lambda loc meta (retrans body))) | |
811d10f5 | 137 | |
3a88cb3b | 138 | ((lambda-case ((,req ,opt ,rest ,kw ,inits ,vars) ,body) ,alternate) |
b0c8c187 AW |
139 | (make-lambda-case loc req opt rest kw |
140 | (map retrans inits) vars | |
8a4ca0ea | 141 | (retrans body) |
3a88cb3b | 142 | (and=> alternate retrans))) |
811d10f5 | 143 | |
1e2a8edb | 144 | ((lambda-case ((,req ,opt ,rest ,kw ,inits ,vars) ,body)) |
b0c8c187 AW |
145 | (make-lambda-case loc req opt rest kw |
146 | (map retrans inits) vars | |
7e01997e AW |
147 | (retrans body) |
148 | #f)) | |
149 | ||
811d10f5 AW |
150 | ((const ,exp) |
151 | (make-const loc exp)) | |
152 | ||
153 | ((begin . ,exps) | |
154 | (make-sequence loc (map retrans exps))) | |
155 | ||
f4aa8d53 AW |
156 | ((let ,names ,vars ,vals ,body) |
157 | (make-let loc names vars (map retrans vals) (retrans body))) | |
158 | ||
159 | ((letrec ,names ,vars ,vals ,body) | |
160 | (make-letrec loc names vars (map retrans vals) (retrans body))) | |
811d10f5 | 161 | |
c21c89b1 AW |
162 | ((fix ,names ,vars ,vals ,body) |
163 | (make-fix loc names vars (map retrans vals) (retrans body))) | |
164 | ||
8a4ca0ea AW |
165 | ((let-values ,exp ,body) |
166 | (make-let-values loc (retrans exp) (retrans body))) | |
811d10f5 AW |
167 | |
168 | (else | |
169 | (error "unrecognized tree-il" exp))))) | |
170 | ||
171 | (define (unparse-tree-il tree-il) | |
172 | (record-case tree-il | |
cf10678f AW |
173 | ((<void>) |
174 | '(void)) | |
175 | ||
811d10f5 | 176 | ((<application> proc args) |
ce09ee19 | 177 | `(apply ,(unparse-tree-il proc) ,@(map unparse-tree-il args))) |
811d10f5 AW |
178 | |
179 | ((<conditional> test then else) | |
180 | `(if ,(unparse-tree-il test) ,(unparse-tree-il then) ,(unparse-tree-il else))) | |
181 | ||
182 | ((<primitive-ref> name) | |
183 | `(primitive ,name)) | |
184 | ||
185 | ((<lexical-ref> name gensym) | |
186 | `(lexical ,name ,gensym)) | |
187 | ||
188 | ((<lexical-set> name gensym exp) | |
189 | `(set! (lexical ,name ,gensym) ,(unparse-tree-il exp))) | |
190 | ||
191 | ((<module-ref> mod name public?) | |
192 | `(,(if public? '@ '@@) ,mod ,name)) | |
193 | ||
194 | ((<module-set> mod name public? exp) | |
195 | `(set! (,(if public? '@ '@@) ,mod ,name) ,(unparse-tree-il exp))) | |
196 | ||
197 | ((<toplevel-ref> name) | |
198 | `(toplevel ,name)) | |
199 | ||
200 | ((<toplevel-set> name exp) | |
201 | `(set! (toplevel ,name) ,(unparse-tree-il exp))) | |
202 | ||
203 | ((<toplevel-define> name exp) | |
204 | `(define ,name ,(unparse-tree-il exp))) | |
205 | ||
8a4ca0ea AW |
206 | ((<lambda> meta body) |
207 | `(lambda ,meta ,(unparse-tree-il body))) | |
208 | ||
3a88cb3b | 209 | ((<lambda-case> req opt rest kw inits vars body alternate) |
1e2a8edb | 210 | `(lambda-case ((,req ,opt ,rest ,kw ,(map unparse-tree-il inits) ,vars) |
8a4ca0ea | 211 | ,(unparse-tree-il body)) |
3a88cb3b | 212 | . ,(if alternate (list (unparse-tree-il alternate)) '()))) |
811d10f5 AW |
213 | |
214 | ((<const> exp) | |
215 | `(const ,exp)) | |
216 | ||
217 | ((<sequence> exps) | |
218 | `(begin ,@(map unparse-tree-il exps))) | |
219 | ||
f4aa8d53 AW |
220 | ((<let> names vars vals body) |
221 | `(let ,names ,vars ,(map unparse-tree-il vals) ,(unparse-tree-il body))) | |
811d10f5 | 222 | |
f4aa8d53 AW |
223 | ((<letrec> names vars vals body) |
224 | `(letrec ,names ,vars ,(map unparse-tree-il vals) ,(unparse-tree-il body))) | |
225 | ||
c21c89b1 AW |
226 | ((<fix> names vars vals body) |
227 | `(fix ,names ,vars ,(map unparse-tree-il vals) ,(unparse-tree-il body))) | |
228 | ||
8a4ca0ea AW |
229 | ((<let-values> exp body) |
230 | `(let-values ,(unparse-tree-il exp) ,(unparse-tree-il body))))) | |
811d10f5 AW |
231 | |
232 | (define (tree-il->scheme e) | |
f4aa8d53 AW |
233 | (record-case e |
234 | ((<void>) | |
235 | '(if #f #f)) | |
236 | ||
237 | ((<application> proc args) | |
238 | `(,(tree-il->scheme proc) ,@(map tree-il->scheme args))) | |
239 | ||
240 | ((<conditional> test then else) | |
241 | (if (void? else) | |
242 | `(if ,(tree-il->scheme test) ,(tree-il->scheme then)) | |
243 | `(if ,(tree-il->scheme test) ,(tree-il->scheme then) ,(tree-il->scheme else)))) | |
244 | ||
245 | ((<primitive-ref> name) | |
246 | name) | |
247 | ||
e5f5113c | 248 | ((<lexical-ref> gensym) |
f4aa8d53 AW |
249 | gensym) |
250 | ||
e5f5113c | 251 | ((<lexical-set> gensym exp) |
f4aa8d53 AW |
252 | `(set! ,gensym ,(tree-il->scheme exp))) |
253 | ||
254 | ((<module-ref> mod name public?) | |
255 | `(,(if public? '@ '@@) ,mod ,name)) | |
256 | ||
257 | ((<module-set> mod name public? exp) | |
258 | `(set! (,(if public? '@ '@@) ,mod ,name) ,(tree-il->scheme exp))) | |
259 | ||
260 | ((<toplevel-ref> name) | |
261 | name) | |
262 | ||
263 | ((<toplevel-set> name exp) | |
264 | `(set! ,name ,(tree-il->scheme exp))) | |
265 | ||
266 | ((<toplevel-define> name exp) | |
267 | `(define ,name ,(tree-il->scheme exp))) | |
268 | ||
8a4ca0ea AW |
269 | ((<lambda> meta body) |
270 | ;; fixme: put in docstring | |
271 | (if (and (lambda-case? body) | |
3a88cb3b | 272 | (not (lambda-case-alternate body))) |
8a4ca0ea AW |
273 | `(lambda ,@(car (tree-il->scheme body))) |
274 | `(case-lambda ,@(tree-il->scheme body)))) | |
275 | ||
3a88cb3b | 276 | ((<lambda-case> req opt rest kw inits vars body alternate) |
b0c8c187 | 277 | ;; FIXME! use parse-lambda-case? |
8a4ca0ea AW |
278 | `((,(if rest (apply cons* vars) vars) |
279 | ,(tree-il->scheme body)) | |
3a88cb3b | 280 | ,@(if alternate (tree-il->scheme alternate) '()))) |
f4aa8d53 AW |
281 | |
282 | ((<const> exp) | |
283 | (if (and (self-evaluating? exp) (not (vector? exp))) | |
284 | exp | |
285 | (list 'quote exp))) | |
286 | ||
287 | ((<sequence> exps) | |
288 | `(begin ,@(map tree-il->scheme exps))) | |
289 | ||
290 | ((<let> vars vals body) | |
291 | `(let ,(map list vars (map tree-il->scheme vals)) ,(tree-il->scheme body))) | |
292 | ||
293 | ((<letrec> vars vals body) | |
294 | `(letrec ,(map list vars (map tree-il->scheme vals)) ,(tree-il->scheme body))) | |
295 | ||
c21c89b1 AW |
296 | ((<fix> vars vals body) |
297 | ;; not a typo, we really do translate back to letrec | |
298 | `(letrec ,(map list vars (map tree-il->scheme vals)) ,(tree-il->scheme body))) | |
299 | ||
1e2a8edb | 300 | ((<let-values> exp body) |
f4aa8d53 | 301 | `(call-with-values (lambda () ,(tree-il->scheme exp)) |
8a4ca0ea | 302 | ,(tree-il->scheme (make-lambda #f '() body)))))) |
cb28c085 | 303 | |
f4aa0f10 LC |
304 | \f |
305 | (define (tree-il-fold leaf down up seed tree) | |
306 | "Traverse TREE, calling LEAF on each leaf encountered, DOWN upon descent | |
307 | into a sub-tree, and UP when leaving a sub-tree. Each of these procedures is | |
308 | invoked as `(PROC TREE SEED)', where TREE is the sub-tree or leaf considered | |
309 | and SEED is the current result, intially seeded with SEED. | |
310 | ||
311 | This is an implementation of `foldts' as described by Andy Wingo in | |
312 | ``Applications of fold to XML transformation''." | |
313 | (let loop ((tree tree) | |
314 | (result seed)) | |
315 | (if (or (null? tree) (pair? tree)) | |
316 | (fold loop result tree) | |
317 | (record-case tree | |
318 | ((<lexical-set> exp) | |
319 | (up tree (loop exp (down tree result)))) | |
320 | ((<module-set> exp) | |
321 | (up tree (loop exp (down tree result)))) | |
322 | ((<toplevel-set> exp) | |
323 | (up tree (loop exp (down tree result)))) | |
324 | ((<toplevel-define> exp) | |
325 | (up tree (loop exp (down tree result)))) | |
326 | ((<conditional> test then else) | |
327 | (up tree (loop else | |
328 | (loop then | |
329 | (loop test (down tree result)))))) | |
330 | ((<application> proc args) | |
331 | (up tree (loop (cons proc args) (down tree result)))) | |
332 | ((<sequence> exps) | |
333 | (up tree (loop exps (down tree result)))) | |
334 | ((<lambda> body) | |
335 | (up tree (loop body (down tree result)))) | |
3a88cb3b AW |
336 | ((<lambda-case> inits body alternate) |
337 | (up tree (if alternate | |
338 | (loop alternate | |
1e2a8edb AW |
339 | (loop body (loop inits (down tree result)))) |
340 | (loop body (loop inits (down tree result)))))) | |
f4aa0f10 LC |
341 | ((<let> vals body) |
342 | (up tree (loop body | |
343 | (loop vals | |
344 | (down tree result))))) | |
345 | ((<letrec> vals body) | |
346 | (up tree (loop body | |
347 | (loop vals | |
348 | (down tree result))))) | |
c21c89b1 AW |
349 | ((<fix> vals body) |
350 | (up tree (loop body | |
351 | (loop vals | |
352 | (down tree result))))) | |
4dcd8499 AW |
353 | ((<let-values> exp body) |
354 | (up tree (loop body (loop exp (down tree result))))) | |
f4aa0f10 LC |
355 | (else |
356 | (leaf tree result)))))) | |
357 | ||
4dcd8499 AW |
358 | |
359 | (define-syntax make-tree-il-folder | |
360 | (syntax-rules () | |
361 | ((_ seed ...) | |
80af1168 | 362 | (lambda (tree down up seed ...) |
4dcd8499 AW |
363 | (define (fold-values proc exps seed ...) |
364 | (if (null? exps) | |
365 | (values seed ...) | |
366 | (let-values (((seed ...) (proc (car exps) seed ...))) | |
367 | (fold-values proc (cdr exps) seed ...)))) | |
368 | (let foldts ((tree tree) (seed seed) ...) | |
80af1168 AW |
369 | (let*-values |
370 | (((seed ...) (down tree seed ...)) | |
371 | ((seed ...) | |
372 | (record-case tree | |
373 | ((<lexical-set> exp) | |
374 | (foldts exp seed ...)) | |
375 | ((<module-set> exp) | |
376 | (foldts exp seed ...)) | |
377 | ((<toplevel-set> exp) | |
378 | (foldts exp seed ...)) | |
379 | ((<toplevel-define> exp) | |
380 | (foldts exp seed ...)) | |
381 | ((<conditional> test then else) | |
382 | (let*-values (((seed ...) (foldts test seed ...)) | |
383 | ((seed ...) (foldts then seed ...))) | |
384 | (foldts else seed ...))) | |
385 | ((<application> proc args) | |
386 | (let-values (((seed ...) (foldts proc seed ...))) | |
387 | (fold-values foldts args seed ...))) | |
388 | ((<sequence> exps) | |
389 | (fold-values foldts exps seed ...)) | |
390 | ((<lambda> body) | |
391 | (foldts body seed ...)) | |
3a88cb3b | 392 | ((<lambda-case> inits body alternate) |
b0c8c187 | 393 | (let-values (((seed ...) (fold-values foldts inits seed ...))) |
3a88cb3b | 394 | (if alternate |
1e2a8edb | 395 | (let-values (((seed ...) (foldts body seed ...))) |
3a88cb3b | 396 | (foldts alternate seed ...)) |
1e2a8edb | 397 | (foldts body seed ...)))) |
80af1168 AW |
398 | ((<let> vals body) |
399 | (let*-values (((seed ...) (fold-values foldts vals seed ...))) | |
400 | (foldts body seed ...))) | |
401 | ((<letrec> vals body) | |
402 | (let*-values (((seed ...) (fold-values foldts vals seed ...))) | |
403 | (foldts body seed ...))) | |
404 | ((<fix> vals body) | |
405 | (let*-values (((seed ...) (fold-values foldts vals seed ...))) | |
406 | (foldts body seed ...))) | |
407 | ((<let-values> exp body) | |
408 | (let*-values (((seed ...) (foldts exp seed ...))) | |
409 | (foldts body seed ...))) | |
410 | (else | |
411 | (values seed ...))))) | |
412 | (up tree seed ...))))))) | |
4dcd8499 | 413 | |
cb28c085 AW |
414 | (define (post-order! f x) |
415 | (let lp ((x x)) | |
416 | (record-case x | |
417 | ((<application> proc args) | |
418 | (set! (application-proc x) (lp proc)) | |
f4aa8d53 | 419 | (set! (application-args x) (map lp args))) |
cb28c085 AW |
420 | |
421 | ((<conditional> test then else) | |
422 | (set! (conditional-test x) (lp test)) | |
423 | (set! (conditional-then x) (lp then)) | |
f4aa8d53 AW |
424 | (set! (conditional-else x) (lp else))) |
425 | ||
cb28c085 | 426 | ((<lexical-set> name gensym exp) |
f4aa8d53 AW |
427 | (set! (lexical-set-exp x) (lp exp))) |
428 | ||
cb28c085 | 429 | ((<module-set> mod name public? exp) |
f4aa8d53 AW |
430 | (set! (module-set-exp x) (lp exp))) |
431 | ||
cb28c085 | 432 | ((<toplevel-set> name exp) |
f4aa8d53 AW |
433 | (set! (toplevel-set-exp x) (lp exp))) |
434 | ||
cb28c085 | 435 | ((<toplevel-define> name exp) |
f4aa8d53 AW |
436 | (set! (toplevel-define-exp x) (lp exp))) |
437 | ||
8a4ca0ea | 438 | ((<lambda> body) |
f4aa8d53 AW |
439 | (set! (lambda-body x) (lp body))) |
440 | ||
3a88cb3b | 441 | ((<lambda-case> inits body alternate) |
b0c8c187 | 442 | (set! inits (map lp inits)) |
8a4ca0ea | 443 | (set! (lambda-case-body x) (lp body)) |
3a88cb3b AW |
444 | (if alternate |
445 | (set! (lambda-case-alternate x) (lp alternate)))) | |
8a4ca0ea | 446 | |
cb28c085 | 447 | ((<sequence> exps) |
f4aa8d53 AW |
448 | (set! (sequence-exps x) (map lp exps))) |
449 | ||
450 | ((<let> vars vals body) | |
cb28c085 | 451 | (set! (let-vals x) (map lp vals)) |
f4aa8d53 AW |
452 | (set! (let-body x) (lp body))) |
453 | ||
454 | ((<letrec> vars vals body) | |
cb28c085 | 455 | (set! (letrec-vals x) (map lp vals)) |
f4aa8d53 AW |
456 | (set! (letrec-body x) (lp body))) |
457 | ||
c21c89b1 AW |
458 | ((<fix> vars vals body) |
459 | (set! (fix-vals x) (map lp vals)) | |
460 | (set! (fix-body x) (lp body))) | |
461 | ||
8a4ca0ea | 462 | ((<let-values> exp body) |
f4aa8d53 AW |
463 | (set! (let-values-exp x) (lp exp)) |
464 | (set! (let-values-body x) (lp body))) | |
465 | ||
466 | (else #f)) | |
467 | ||
468 | (or (f x) x))) | |
cb28c085 AW |
469 | |
470 | (define (pre-order! f x) | |
471 | (let lp ((x x)) | |
472 | (let ((x (or (f x) x))) | |
473 | (record-case x | |
474 | ((<application> proc args) | |
475 | (set! (application-proc x) (lp proc)) | |
476 | (set! (application-args x) (map lp args))) | |
477 | ||
478 | ((<conditional> test then else) | |
479 | (set! (conditional-test x) (lp test)) | |
480 | (set! (conditional-then x) (lp then)) | |
481 | (set! (conditional-else x) (lp else))) | |
482 | ||
e5f5113c | 483 | ((<lexical-set> exp) |
cb28c085 AW |
484 | (set! (lexical-set-exp x) (lp exp))) |
485 | ||
e5f5113c | 486 | ((<module-set> exp) |
cb28c085 AW |
487 | (set! (module-set-exp x) (lp exp))) |
488 | ||
e5f5113c | 489 | ((<toplevel-set> exp) |
cb28c085 AW |
490 | (set! (toplevel-set-exp x) (lp exp))) |
491 | ||
e5f5113c | 492 | ((<toplevel-define> exp) |
cb28c085 AW |
493 | (set! (toplevel-define-exp x) (lp exp))) |
494 | ||
e5f5113c | 495 | ((<lambda> body) |
cb28c085 AW |
496 | (set! (lambda-body x) (lp body))) |
497 | ||
3a88cb3b | 498 | ((<lambda-case> inits body alternate) |
b0c8c187 | 499 | (set! inits (map lp inits)) |
8a4ca0ea | 500 | (set! (lambda-case-body x) (lp body)) |
3a88cb3b | 501 | (if alternate (set! (lambda-case-alternate x) (lp alternate)))) |
8a4ca0ea | 502 | |
cb28c085 AW |
503 | ((<sequence> exps) |
504 | (set! (sequence-exps x) (map lp exps))) | |
505 | ||
e5f5113c | 506 | ((<let> vals body) |
cb28c085 | 507 | (set! (let-vals x) (map lp vals)) |
f4aa8d53 | 508 | (set! (let-body x) (lp body))) |
cb28c085 | 509 | |
e5f5113c | 510 | ((<letrec> vals body) |
cb28c085 | 511 | (set! (letrec-vals x) (map lp vals)) |
f4aa8d53 AW |
512 | (set! (letrec-body x) (lp body))) |
513 | ||
e5f5113c | 514 | ((<fix> vals body) |
c21c89b1 AW |
515 | (set! (fix-vals x) (map lp vals)) |
516 | (set! (fix-body x) (lp body))) | |
517 | ||
e5f5113c | 518 | ((<let-values> exp body) |
f4aa8d53 AW |
519 | (set! (let-values-exp x) (lp exp)) |
520 | (set! (let-values-body x) (lp body))) | |
cb28c085 AW |
521 | |
522 | (else #f)) | |
523 | x))) |