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 | 41 | lambda-case-req lambda-case-opt lambda-case-rest lambda-case-kw |
93f63467 | 42 | lambda-case-inits lambda-case-gensyms |
3a88cb3b | 43 | lambda-case-body lambda-case-alternate |
93f63467 | 44 | <let> let? make-let let-src let-names let-gensyms let-vals let-body |
fb6e61ca | 45 | <letrec> letrec? make-letrec letrec-src letrec-in-order? letrec-names letrec-gensyms letrec-vals letrec-body |
93f63467 | 46 | <fix> fix? make-fix fix-src fix-names fix-gensyms 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 |
706a705e AW |
50 | <dynref> dynref? make-dynref dynref-src dynref-fluid |
51 | <dynset> dynset? make-dynset dynset-src dynset-fluid dynset-exp | |
07a0c7d5 | 52 | <prompt> prompt? make-prompt prompt-src prompt-tag prompt-body prompt-handler |
2d026f04 | 53 | <abort> abort? make-abort abort-src abort-tag abort-args abort-tail |
f4aa0f10 | 54 | |
9efc833d AW |
55 | parse-tree-il |
56 | unparse-tree-il | |
cb28c085 AW |
57 | tree-il->scheme |
58 | ||
f4aa0f10 | 59 | tree-il-fold |
4dcd8499 | 60 | make-tree-il-folder |
cb28c085 AW |
61 | post-order! |
62 | pre-order!)) | |
811d10f5 | 63 | |
4ffa8275 AW |
64 | (define (print-tree-il exp port) |
65 | (format port "#<tree-il ~a>" (unparse-tree-il exp))) | |
66 | ||
f7b61b39 AW |
67 | (define-syntax borrow-core-vtables |
68 | (lambda (x) | |
69 | (syntax-case x () | |
70 | ((_) | |
71 | (let lp ((n 0) (out '())) | |
72 | (if (< n (vector-length %expanded-vtables)) | |
73 | (lp (1+ n) | |
74 | (let* ((vtable (vector-ref %expanded-vtables n)) | |
75 | (stem (struct-ref vtable (+ vtable-offset-user 0))) | |
76 | (fields (struct-ref vtable (+ vtable-offset-user 2))) | |
77 | (sfields (map | |
78 | (lambda (f) (datum->syntax x f)) | |
79 | fields)) | |
80 | (type (datum->syntax x (symbol-append '< stem '>))) | |
81 | (ctor (datum->syntax x (symbol-append 'make- stem))) | |
82 | (pred (datum->syntax x (symbol-append stem '?)))) | |
83 | (let lp ((n 0) (fields fields) | |
84 | (out (cons* | |
85 | #`(define (#,ctor #,@sfields) | |
86 | (make-struct #,type 0 #,@sfields)) | |
87 | #`(define (#,pred x) | |
88 | (and (struct? x) | |
89 | (eq? (struct-vtable x) #,type))) | |
4ffa8275 AW |
90 | #`(struct-set! #,type vtable-index-printer |
91 | print-tree-il) | |
f7b61b39 AW |
92 | #`(define #,type |
93 | (vector-ref %expanded-vtables #,n)) | |
94 | out))) | |
95 | (if (null? fields) | |
96 | out | |
97 | (lp (1+ n) | |
98 | (cdr fields) | |
99 | (let ((acc (datum->syntax | |
100 | x (symbol-append stem '- (car fields))))) | |
101 | (cons #`(define #,acc | |
102 | (make-procedure-with-setter | |
103 | (lambda (x) (struct-ref x #,n)) | |
104 | (lambda (x v) (struct-set! x #,n v)))) | |
105 | out))))))) | |
106 | #`(begin #,@(reverse out)))))))) | |
107 | ||
108 | (borrow-core-vtables) | |
109 | ||
110 | ;; (<void>) | |
111 | ;; (<const> exp) | |
112 | ;; (<primitive-ref> name) | |
113 | ;; (<lexical-ref> name gensym) | |
114 | ;; (<lexical-set> name gensym exp) | |
115 | ;; (<module-ref> mod name public?) | |
116 | ;; (<module-set> mod name public? exp) | |
117 | ;; (<toplevel-ref> name) | |
118 | ;; (<toplevel-set> name exp) | |
119 | ;; (<toplevel-define> name exp) | |
120 | ;; (<conditional> test consequent alternate) | |
121 | ;; (<application> proc args) | |
122 | ;; (<sequence> exps) | |
123 | ;; (<lambda> meta body) | |
124 | ;; (<lambda-case> req opt rest kw inits gensyms body alternate) | |
125 | ;; (<let> names gensyms vals body) | |
fb6e61ca | 126 | ;; (<letrec> in-order? names gensyms vals body) |
f7b61b39 AW |
127 | ;; (<dynlet> fluids vals body) |
128 | ||
4ffa8275 | 129 | (define-type (<tree-il> #:common-slots (src) #:printer print-tree-il) |
93f63467 | 130 | (<fix> names gensyms vals body) |
1c297a38 | 131 | (<let-values> exp body) |
8da6ab34 | 132 | (<dynwind> winder body unwinder) |
706a705e AW |
133 | (<dynref> fluid) |
134 | (<dynset> fluid exp) | |
07a0c7d5 | 135 | (<prompt> tag body handler) |
2d026f04 | 136 | (<abort> tag args tail)) |
811d10f5 | 137 | |
811d10f5 AW |
138 | \f |
139 | ||
811d10f5 AW |
140 | (define (location x) |
141 | (and (pair? x) | |
142 | (let ((props (source-properties x))) | |
81fd3152 | 143 | (and (pair? props) props)))) |
811d10f5 | 144 | |
ce09ee19 | 145 | (define (parse-tree-il exp) |
811d10f5 | 146 | (let ((loc (location exp)) |
ce09ee19 | 147 | (retrans (lambda (x) (parse-tree-il x)))) |
811d10f5 | 148 | (pmatch exp |
cf10678f AW |
149 | ((void) |
150 | (make-void loc)) | |
151 | ||
ce09ee19 AW |
152 | ((apply ,proc . ,args) |
153 | (make-application loc (retrans proc) (map retrans args))) | |
811d10f5 | 154 | |
b6d93b11 AW |
155 | ((if ,test ,consequent ,alternate) |
156 | (make-conditional loc (retrans test) (retrans consequent) (retrans alternate))) | |
811d10f5 AW |
157 | |
158 | ((primitive ,name) (guard (symbol? name)) | |
159 | (make-primitive-ref loc name)) | |
160 | ||
161 | ((lexical ,name) (guard (symbol? name)) | |
162 | (make-lexical-ref loc name name)) | |
163 | ||
164 | ((lexical ,name ,sym) (guard (symbol? name) (symbol? sym)) | |
165 | (make-lexical-ref loc name sym)) | |
166 | ||
5c27902e AW |
167 | ((set! (lexical ,name) ,exp) (guard (symbol? name)) |
168 | (make-lexical-set loc name name (retrans exp))) | |
169 | ||
811d10f5 AW |
170 | ((set! (lexical ,name ,sym) ,exp) (guard (symbol? name) (symbol? sym)) |
171 | (make-lexical-set loc name sym (retrans exp))) | |
172 | ||
173 | ((@ ,mod ,name) (guard (and-map symbol? mod) (symbol? name)) | |
174 | (make-module-ref loc mod name #t)) | |
175 | ||
176 | ((set! (@ ,mod ,name) ,exp) (guard (and-map symbol? mod) (symbol? name)) | |
177 | (make-module-set loc mod name #t (retrans exp))) | |
178 | ||
179 | ((@@ ,mod ,name) (guard (and-map symbol? mod) (symbol? name)) | |
180 | (make-module-ref loc mod name #f)) | |
181 | ||
ce09ee19 | 182 | ((set! (@@ ,mod ,name) ,exp) (guard (and-map symbol? mod) (symbol? name)) |
811d10f5 AW |
183 | (make-module-set loc mod name #f (retrans exp))) |
184 | ||
185 | ((toplevel ,name) (guard (symbol? name)) | |
186 | (make-toplevel-ref loc name)) | |
187 | ||
ce09ee19 | 188 | ((set! (toplevel ,name) ,exp) (guard (symbol? name)) |
811d10f5 AW |
189 | (make-toplevel-set loc name (retrans exp))) |
190 | ||
ce09ee19 | 191 | ((define ,name ,exp) (guard (symbol? name)) |
811d10f5 AW |
192 | (make-toplevel-define loc name (retrans exp))) |
193 | ||
8a4ca0ea AW |
194 | ((lambda ,meta ,body) |
195 | (make-lambda loc meta (retrans body))) | |
811d10f5 | 196 | |
93f63467 | 197 | ((lambda-case ((,req ,opt ,rest ,kw ,inits ,gensyms) ,body) ,alternate) |
b0c8c187 | 198 | (make-lambda-case loc req opt rest kw |
93f63467 | 199 | (map retrans inits) gensyms |
8a4ca0ea | 200 | (retrans body) |
3a88cb3b | 201 | (and=> alternate retrans))) |
811d10f5 | 202 | |
93f63467 | 203 | ((lambda-case ((,req ,opt ,rest ,kw ,inits ,gensyms) ,body)) |
b0c8c187 | 204 | (make-lambda-case loc req opt rest kw |
93f63467 | 205 | (map retrans inits) gensyms |
7e01997e AW |
206 | (retrans body) |
207 | #f)) | |
208 | ||
811d10f5 AW |
209 | ((const ,exp) |
210 | (make-const loc exp)) | |
211 | ||
212 | ((begin . ,exps) | |
213 | (make-sequence loc (map retrans exps))) | |
214 | ||
93f63467 AW |
215 | ((let ,names ,gensyms ,vals ,body) |
216 | (make-let loc names gensyms (map retrans vals) (retrans body))) | |
f4aa8d53 | 217 | |
93f63467 | 218 | ((letrec ,names ,gensyms ,vals ,body) |
fb6e61ca AW |
219 | (make-letrec loc #f names gensyms (map retrans vals) (retrans body))) |
220 | ||
221 | ((letrec* ,names ,gensyms ,vals ,body) | |
222 | (make-letrec loc #t names gensyms (map retrans vals) (retrans body))) | |
811d10f5 | 223 | |
93f63467 AW |
224 | ((fix ,names ,gensyms ,vals ,body) |
225 | (make-fix loc names gensyms (map retrans vals) (retrans body))) | |
c21c89b1 | 226 | |
8a4ca0ea AW |
227 | ((let-values ,exp ,body) |
228 | (make-let-values loc (retrans exp) (retrans body))) | |
811d10f5 | 229 | |
8da6ab34 AW |
230 | ((dynwind ,winder ,body ,unwinder) |
231 | (make-dynwind loc (retrans winder) (retrans body) (retrans unwinder))) | |
1c297a38 | 232 | |
d7c53a86 AW |
233 | ((dynlet ,fluids ,vals ,body) |
234 | (make-dynlet loc (map retrans fluids) (map retrans vals) (retrans body))) | |
235 | ||
706a705e AW |
236 | ((dynref ,fluid) |
237 | (make-dynref loc (retrans fluid))) | |
238 | ||
239 | ((dynset ,fluid ,exp) | |
240 | (make-dynset loc (retrans fluid) (retrans exp))) | |
241 | ||
07a0c7d5 AW |
242 | ((prompt ,tag ,body ,handler) |
243 | (make-prompt loc (retrans tag) (retrans body) (retrans handler))) | |
1c297a38 | 244 | |
2d026f04 AW |
245 | ((abort ,tag ,args ,tail) |
246 | (make-abort loc (retrans tag) (map retrans args) (retrans tail))) | |
1c297a38 | 247 | |
811d10f5 AW |
248 | (else |
249 | (error "unrecognized tree-il" exp))))) | |
250 | ||
251 | (define (unparse-tree-il tree-il) | |
252 | (record-case tree-il | |
cf10678f AW |
253 | ((<void>) |
254 | '(void)) | |
255 | ||
811d10f5 | 256 | ((<application> proc args) |
ce09ee19 | 257 | `(apply ,(unparse-tree-il proc) ,@(map unparse-tree-il args))) |
811d10f5 | 258 | |
b6d93b11 AW |
259 | ((<conditional> test consequent alternate) |
260 | `(if ,(unparse-tree-il test) ,(unparse-tree-il consequent) ,(unparse-tree-il alternate))) | |
811d10f5 AW |
261 | |
262 | ((<primitive-ref> name) | |
263 | `(primitive ,name)) | |
264 | ||
265 | ((<lexical-ref> name gensym) | |
266 | `(lexical ,name ,gensym)) | |
267 | ||
268 | ((<lexical-set> name gensym exp) | |
269 | `(set! (lexical ,name ,gensym) ,(unparse-tree-il exp))) | |
270 | ||
271 | ((<module-ref> mod name public?) | |
272 | `(,(if public? '@ '@@) ,mod ,name)) | |
273 | ||
274 | ((<module-set> mod name public? exp) | |
275 | `(set! (,(if public? '@ '@@) ,mod ,name) ,(unparse-tree-il exp))) | |
276 | ||
277 | ((<toplevel-ref> name) | |
278 | `(toplevel ,name)) | |
279 | ||
280 | ((<toplevel-set> name exp) | |
281 | `(set! (toplevel ,name) ,(unparse-tree-il exp))) | |
282 | ||
283 | ((<toplevel-define> name exp) | |
284 | `(define ,name ,(unparse-tree-il exp))) | |
285 | ||
8a4ca0ea AW |
286 | ((<lambda> meta body) |
287 | `(lambda ,meta ,(unparse-tree-il body))) | |
288 | ||
93f63467 AW |
289 | ((<lambda-case> req opt rest kw inits gensyms body alternate) |
290 | `(lambda-case ((,req ,opt ,rest ,kw ,(map unparse-tree-il inits) ,gensyms) | |
8a4ca0ea | 291 | ,(unparse-tree-il body)) |
3a88cb3b | 292 | . ,(if alternate (list (unparse-tree-il alternate)) '()))) |
811d10f5 AW |
293 | |
294 | ((<const> exp) | |
295 | `(const ,exp)) | |
296 | ||
297 | ((<sequence> exps) | |
298 | `(begin ,@(map unparse-tree-il exps))) | |
299 | ||
93f63467 AW |
300 | ((<let> names gensyms vals body) |
301 | `(let ,names ,gensyms ,(map unparse-tree-il vals) ,(unparse-tree-il body))) | |
811d10f5 | 302 | |
fb6e61ca AW |
303 | ((<letrec> in-order? names gensyms vals body) |
304 | `(,(if in-order? 'letrec* 'letrec) ,names ,gensyms | |
305 | ,(map unparse-tree-il vals) ,(unparse-tree-il body))) | |
f4aa8d53 | 306 | |
93f63467 AW |
307 | ((<fix> names gensyms vals body) |
308 | `(fix ,names ,gensyms ,(map unparse-tree-il vals) ,(unparse-tree-il body))) | |
c21c89b1 | 309 | |
8a4ca0ea | 310 | ((<let-values> exp body) |
1c297a38 AW |
311 | `(let-values ,(unparse-tree-il exp) ,(unparse-tree-il body))) |
312 | ||
8da6ab34 AW |
313 | ((<dynwind> body winder unwinder) |
314 | `(dynwind ,(unparse-tree-il body) | |
1c297a38 AW |
315 | ,(unparse-tree-il winder) ,(unparse-tree-il unwinder))) |
316 | ||
d7c53a86 AW |
317 | ((<dynlet> fluids vals body) |
318 | `(dynlet ,(map unparse-tree-il fluids) ,(map unparse-tree-il vals) | |
319 | ,(unparse-tree-il body))) | |
320 | ||
706a705e AW |
321 | ((<dynref> fluid) |
322 | `(dynref ,(unparse-tree-il fluid))) | |
323 | ||
324 | ((<dynset> fluid exp) | |
325 | `(dynref ,(unparse-tree-il fluid) ,(unparse-tree-il exp))) | |
326 | ||
07a0c7d5 | 327 | ((<prompt> tag body handler) |
2bcf97a6 | 328 | `(prompt ,(unparse-tree-il tag) ,(unparse-tree-il body) ,(unparse-tree-il handler))) |
1c297a38 | 329 | |
2d026f04 AW |
330 | ((<abort> tag args tail) |
331 | `(abort ,(unparse-tree-il tag) ,(map unparse-tree-il args) | |
332 | ,(unparse-tree-il tail))))) | |
811d10f5 AW |
333 | |
334 | (define (tree-il->scheme e) | |
f4aa8d53 AW |
335 | (record-case e |
336 | ((<void>) | |
337 | '(if #f #f)) | |
338 | ||
339 | ((<application> proc args) | |
340 | `(,(tree-il->scheme proc) ,@(map tree-il->scheme args))) | |
341 | ||
b6d93b11 AW |
342 | ((<conditional> test consequent alternate) |
343 | (if (void? alternate) | |
344 | `(if ,(tree-il->scheme test) ,(tree-il->scheme consequent)) | |
345 | `(if ,(tree-il->scheme test) ,(tree-il->scheme consequent) ,(tree-il->scheme alternate)))) | |
f4aa8d53 AW |
346 | |
347 | ((<primitive-ref> name) | |
348 | name) | |
349 | ||
e5f5113c | 350 | ((<lexical-ref> gensym) |
f4aa8d53 AW |
351 | gensym) |
352 | ||
e5f5113c | 353 | ((<lexical-set> gensym exp) |
f4aa8d53 AW |
354 | `(set! ,gensym ,(tree-il->scheme exp))) |
355 | ||
356 | ((<module-ref> mod name public?) | |
357 | `(,(if public? '@ '@@) ,mod ,name)) | |
358 | ||
359 | ((<module-set> mod name public? exp) | |
360 | `(set! (,(if public? '@ '@@) ,mod ,name) ,(tree-il->scheme exp))) | |
361 | ||
362 | ((<toplevel-ref> name) | |
363 | name) | |
364 | ||
365 | ((<toplevel-set> name exp) | |
366 | `(set! ,name ,(tree-il->scheme exp))) | |
367 | ||
368 | ((<toplevel-define> name exp) | |
369 | `(define ,name ,(tree-il->scheme exp))) | |
370 | ||
8a4ca0ea AW |
371 | ((<lambda> meta body) |
372 | ;; fixme: put in docstring | |
cc63545b | 373 | (tree-il->scheme body)) |
8a4ca0ea | 374 | |
93f63467 | 375 | ((<lambda-case> req opt rest kw inits gensyms body alternate) |
cc63545b AW |
376 | (cond |
377 | ((and (not opt) (not kw) (not alternate)) | |
378 | `(lambda ,(if rest (apply cons* gensyms) gensyms) | |
379 | ,(tree-il->scheme body))) | |
380 | ((and (not opt) (not kw)) | |
381 | (let ((alt-expansion (tree-il->scheme alternate)) | |
382 | (formals (if rest (apply cons* gensyms) gensyms))) | |
383 | (case (car alt-expansion) | |
384 | ((lambda) | |
385 | `(case-lambda (,formals ,(tree-il->scheme body)) | |
386 | ,@(cdr alt-expansion))) | |
387 | ((lambda*) | |
388 | `(case-lambda* (,formals ,(tree-il->scheme body)) | |
389 | ,(cdr alt-expansion))) | |
390 | ((case-lambda) | |
391 | `(case-lambda (,formals ,(tree-il->scheme body)) | |
392 | ,@(cdr alt-expansion))) | |
393 | ((case-lambda*) | |
394 | `(case-lambda* (,formals ,(tree-il->scheme body)) | |
395 | ,@(cdr alt-expansion)))))) | |
396 | (else | |
397 | (let* ((alt-expansion (and alternate (tree-il->scheme alternate))) | |
398 | (nreq (length req)) | |
399 | (nopt (if opt (length opt) 0)) | |
400 | (restargs (if rest (list-ref gensyms (+ nreq nopt)) '())) | |
401 | (reqargs (list-head gensyms nreq)) | |
402 | (optargs (if opt | |
403 | `(#:optional | |
404 | ,@(map list | |
405 | (list-head (list-tail gensyms nreq) nopt) | |
406 | (map tree-il->scheme | |
407 | (list-head inits nopt)))) | |
408 | '())) | |
409 | (kwargs (if kw | |
410 | `(#:key | |
411 | ,@(map list | |
412 | (map caddr (cdr kw)) | |
413 | (map tree-il->scheme | |
414 | (list-tail inits nopt)) | |
415 | (map car (cdr kw))) | |
416 | ,@(if (car kw) | |
417 | '(#:allow-other-keys) | |
418 | '())) | |
419 | '())) | |
420 | (formals `(,@reqargs ,@optargs ,@kwargs . ,restargs))) | |
421 | (if (not alt-expansion) | |
422 | `(lambda* ,formals ,(tree-il->scheme body)) | |
423 | (case (car alt-expansion) | |
424 | ((lambda lambda*) | |
425 | `(case-lambda* (,formals ,(tree-il->scheme body)) | |
426 | ,(cdr alt-expansion))) | |
427 | ((case-lambda case-lambda*) | |
428 | `(case-lambda* (,formals ,(tree-il->scheme body)) | |
429 | ,@(cdr alt-expansion))))))))) | |
430 | ||
f4aa8d53 AW |
431 | ((<const> exp) |
432 | (if (and (self-evaluating? exp) (not (vector? exp))) | |
433 | exp | |
434 | (list 'quote exp))) | |
435 | ||
436 | ((<sequence> exps) | |
437 | `(begin ,@(map tree-il->scheme exps))) | |
438 | ||
93f63467 AW |
439 | ((<let> gensyms vals body) |
440 | `(let ,(map list gensyms (map tree-il->scheme vals)) ,(tree-il->scheme body))) | |
f4aa8d53 | 441 | |
fb6e61ca AW |
442 | ((<letrec> in-order? gensyms vals body) |
443 | `(,(if in-order? 'letrec* 'letrec) | |
444 | ,(map list gensyms (map tree-il->scheme vals)) ,(tree-il->scheme body))) | |
f4aa8d53 | 445 | |
93f63467 | 446 | ((<fix> gensyms vals body) |
c21c89b1 | 447 | ;; not a typo, we really do translate back to letrec |
93f63467 | 448 | `(letrec ,(map list gensyms (map tree-il->scheme vals)) ,(tree-il->scheme body))) |
c21c89b1 | 449 | |
1e2a8edb | 450 | ((<let-values> exp body) |
f4aa8d53 | 451 | `(call-with-values (lambda () ,(tree-il->scheme exp)) |
1c297a38 AW |
452 | ,(tree-il->scheme (make-lambda #f '() body)))) |
453 | ||
8da6ab34 | 454 | ((<dynwind> body winder unwinder) |
d69531e2 AW |
455 | `(dynamic-wind ,(tree-il->scheme winder) |
456 | (lambda () ,(tree-il->scheme body)) | |
457 | ,(tree-il->scheme unwinder))) | |
1c297a38 | 458 | |
d7c53a86 AW |
459 | ((<dynlet> fluids vals body) |
460 | `(with-fluids ,(map list | |
461 | (map tree-il->scheme fluids) | |
462 | (map tree-il->scheme vals)) | |
67a78ddd | 463 | ,(tree-il->scheme body))) |
d7c53a86 | 464 | |
706a705e AW |
465 | ((<dynref> fluid) |
466 | `(fluid-ref ,(tree-il->scheme fluid))) | |
467 | ||
468 | ((<dynset> fluid exp) | |
469 | `(fluid-set! ,(tree-il->scheme fluid) ,(tree-il->scheme exp))) | |
470 | ||
07a0c7d5 | 471 | ((<prompt> tag body handler) |
1c297a38 AW |
472 | `((@ (ice-9 control) prompt) |
473 | ,(tree-il->scheme tag) (lambda () ,(tree-il->scheme body)) | |
07a0c7d5 | 474 | ,(tree-il->scheme handler))) |
1c297a38 AW |
475 | |
476 | ||
2d026f04 AW |
477 | ((<abort> tag args tail) |
478 | `(apply abort ,(tree-il->scheme tag) ,@(map tree-il->scheme args) | |
479 | ,(tree-il->scheme tail))))) | |
cb28c085 | 480 | |
f4aa0f10 LC |
481 | \f |
482 | (define (tree-il-fold leaf down up seed tree) | |
483 | "Traverse TREE, calling LEAF on each leaf encountered, DOWN upon descent | |
484 | into a sub-tree, and UP when leaving a sub-tree. Each of these procedures is | |
485 | invoked as `(PROC TREE SEED)', where TREE is the sub-tree or leaf considered | |
486 | and SEED is the current result, intially seeded with SEED. | |
487 | ||
488 | This is an implementation of `foldts' as described by Andy Wingo in | |
489 | ``Applications of fold to XML transformation''." | |
490 | (let loop ((tree tree) | |
491 | (result seed)) | |
492 | (if (or (null? tree) (pair? tree)) | |
493 | (fold loop result tree) | |
494 | (record-case tree | |
495 | ((<lexical-set> exp) | |
496 | (up tree (loop exp (down tree result)))) | |
497 | ((<module-set> exp) | |
498 | (up tree (loop exp (down tree result)))) | |
499 | ((<toplevel-set> exp) | |
500 | (up tree (loop exp (down tree result)))) | |
501 | ((<toplevel-define> exp) | |
502 | (up tree (loop exp (down tree result)))) | |
b6d93b11 AW |
503 | ((<conditional> test consequent alternate) |
504 | (up tree (loop alternate | |
505 | (loop consequent | |
f4aa0f10 LC |
506 | (loop test (down tree result)))))) |
507 | ((<application> proc args) | |
508 | (up tree (loop (cons proc args) (down tree result)))) | |
509 | ((<sequence> exps) | |
510 | (up tree (loop exps (down tree result)))) | |
511 | ((<lambda> body) | |
512 | (up tree (loop body (down tree result)))) | |
3a88cb3b AW |
513 | ((<lambda-case> inits body alternate) |
514 | (up tree (if alternate | |
515 | (loop alternate | |
1e2a8edb AW |
516 | (loop body (loop inits (down tree result)))) |
517 | (loop body (loop inits (down tree result)))))) | |
f4aa0f10 LC |
518 | ((<let> vals body) |
519 | (up tree (loop body | |
520 | (loop vals | |
521 | (down tree result))))) | |
522 | ((<letrec> vals body) | |
523 | (up tree (loop body | |
524 | (loop vals | |
525 | (down tree result))))) | |
c21c89b1 AW |
526 | ((<fix> vals body) |
527 | (up tree (loop body | |
528 | (loop vals | |
529 | (down tree result))))) | |
4dcd8499 AW |
530 | ((<let-values> exp body) |
531 | (up tree (loop body (loop exp (down tree result))))) | |
8da6ab34 | 532 | ((<dynwind> body winder unwinder) |
1c297a38 AW |
533 | (up tree (loop unwinder |
534 | (loop winder | |
535 | (loop body (down tree result)))))) | |
d7c53a86 AW |
536 | ((<dynlet> fluids vals body) |
537 | (up tree (loop body | |
538 | (loop vals | |
539 | (loop fluids (down tree result)))))) | |
706a705e AW |
540 | ((<dynref> fluid) |
541 | (up tree (loop fluid (down tree result)))) | |
542 | ((<dynset> fluid exp) | |
543 | (up tree (loop exp (loop fluid (down tree result))))) | |
07a0c7d5 AW |
544 | ((<prompt> tag body handler) |
545 | (up tree | |
546 | (loop tag (loop body (loop handler | |
547 | (down tree result)))))) | |
2d026f04 AW |
548 | ((<abort> tag args tail) |
549 | (up tree (loop tail (loop args (loop tag (down tree result)))))) | |
f4aa0f10 LC |
550 | (else |
551 | (leaf tree result)))))) | |
552 | ||
4dcd8499 AW |
553 | |
554 | (define-syntax make-tree-il-folder | |
555 | (syntax-rules () | |
556 | ((_ seed ...) | |
80af1168 | 557 | (lambda (tree down up seed ...) |
4dcd8499 AW |
558 | (define (fold-values proc exps seed ...) |
559 | (if (null? exps) | |
560 | (values seed ...) | |
561 | (let-values (((seed ...) (proc (car exps) seed ...))) | |
562 | (fold-values proc (cdr exps) seed ...)))) | |
563 | (let foldts ((tree tree) (seed seed) ...) | |
80af1168 AW |
564 | (let*-values |
565 | (((seed ...) (down tree seed ...)) | |
566 | ((seed ...) | |
567 | (record-case tree | |
568 | ((<lexical-set> exp) | |
569 | (foldts exp seed ...)) | |
570 | ((<module-set> exp) | |
571 | (foldts exp seed ...)) | |
572 | ((<toplevel-set> exp) | |
573 | (foldts exp seed ...)) | |
574 | ((<toplevel-define> exp) | |
575 | (foldts exp seed ...)) | |
b6d93b11 | 576 | ((<conditional> test consequent alternate) |
80af1168 | 577 | (let*-values (((seed ...) (foldts test seed ...)) |
b6d93b11 AW |
578 | ((seed ...) (foldts consequent seed ...))) |
579 | (foldts alternate seed ...))) | |
80af1168 AW |
580 | ((<application> proc args) |
581 | (let-values (((seed ...) (foldts proc seed ...))) | |
582 | (fold-values foldts args seed ...))) | |
583 | ((<sequence> exps) | |
584 | (fold-values foldts exps seed ...)) | |
585 | ((<lambda> body) | |
586 | (foldts body seed ...)) | |
3a88cb3b | 587 | ((<lambda-case> inits body alternate) |
b0c8c187 | 588 | (let-values (((seed ...) (fold-values foldts inits seed ...))) |
3a88cb3b | 589 | (if alternate |
1e2a8edb | 590 | (let-values (((seed ...) (foldts body seed ...))) |
3a88cb3b | 591 | (foldts alternate seed ...)) |
1e2a8edb | 592 | (foldts body seed ...)))) |
80af1168 AW |
593 | ((<let> vals body) |
594 | (let*-values (((seed ...) (fold-values foldts vals seed ...))) | |
595 | (foldts body seed ...))) | |
596 | ((<letrec> vals body) | |
597 | (let*-values (((seed ...) (fold-values foldts vals seed ...))) | |
598 | (foldts body seed ...))) | |
599 | ((<fix> vals body) | |
600 | (let*-values (((seed ...) (fold-values foldts vals seed ...))) | |
601 | (foldts body seed ...))) | |
602 | ((<let-values> exp body) | |
603 | (let*-values (((seed ...) (foldts exp seed ...))) | |
604 | (foldts body seed ...))) | |
8da6ab34 | 605 | ((<dynwind> body winder unwinder) |
1c297a38 AW |
606 | (let*-values (((seed ...) (foldts body seed ...)) |
607 | ((seed ...) (foldts winder seed ...))) | |
608 | (foldts unwinder seed ...))) | |
d7c53a86 AW |
609 | ((<dynlet> fluids vals body) |
610 | (let*-values (((seed ...) (fold-values foldts fluids seed ...)) | |
611 | ((seed ...) (fold-values foldts vals seed ...))) | |
612 | (foldts body seed ...))) | |
706a705e AW |
613 | ((<dynref> fluid) |
614 | (foldts fluid seed ...)) | |
615 | ((<dynset> fluid exp) | |
616 | (let*-values (((seed ...) (foldts fluid seed ...))) | |
617 | (foldts exp seed ...))) | |
07a0c7d5 | 618 | ((<prompt> tag body handler) |
1c297a38 | 619 | (let*-values (((seed ...) (foldts tag seed ...)) |
07a0c7d5 AW |
620 | ((seed ...) (foldts body seed ...))) |
621 | (foldts handler seed ...))) | |
2d026f04 AW |
622 | ((<abort> tag args tail) |
623 | (let*-values (((seed ...) (foldts tag seed ...)) | |
624 | ((seed ...) (fold-values foldts args seed ...))) | |
625 | (foldts tail seed ...))) | |
80af1168 AW |
626 | (else |
627 | (values seed ...))))) | |
628 | (up tree seed ...))))))) | |
4dcd8499 | 629 | |
cb28c085 AW |
630 | (define (post-order! f x) |
631 | (let lp ((x x)) | |
632 | (record-case x | |
633 | ((<application> proc args) | |
634 | (set! (application-proc x) (lp proc)) | |
f4aa8d53 | 635 | (set! (application-args x) (map lp args))) |
cb28c085 | 636 | |
b6d93b11 | 637 | ((<conditional> test consequent alternate) |
cb28c085 | 638 | (set! (conditional-test x) (lp test)) |
b6d93b11 AW |
639 | (set! (conditional-consequent x) (lp consequent)) |
640 | (set! (conditional-alternate x) (lp alternate))) | |
f4aa8d53 | 641 | |
cb28c085 | 642 | ((<lexical-set> name gensym exp) |
f4aa8d53 AW |
643 | (set! (lexical-set-exp x) (lp exp))) |
644 | ||
cb28c085 | 645 | ((<module-set> mod name public? exp) |
f4aa8d53 AW |
646 | (set! (module-set-exp x) (lp exp))) |
647 | ||
cb28c085 | 648 | ((<toplevel-set> name exp) |
f4aa8d53 AW |
649 | (set! (toplevel-set-exp x) (lp exp))) |
650 | ||
cb28c085 | 651 | ((<toplevel-define> name exp) |
f4aa8d53 AW |
652 | (set! (toplevel-define-exp x) (lp exp))) |
653 | ||
8a4ca0ea | 654 | ((<lambda> body) |
f4aa8d53 AW |
655 | (set! (lambda-body x) (lp body))) |
656 | ||
3a88cb3b | 657 | ((<lambda-case> inits body alternate) |
b0c8c187 | 658 | (set! inits (map lp inits)) |
8a4ca0ea | 659 | (set! (lambda-case-body x) (lp body)) |
3a88cb3b AW |
660 | (if alternate |
661 | (set! (lambda-case-alternate x) (lp alternate)))) | |
8a4ca0ea | 662 | |
cb28c085 | 663 | ((<sequence> exps) |
f4aa8d53 AW |
664 | (set! (sequence-exps x) (map lp exps))) |
665 | ||
93f63467 | 666 | ((<let> gensyms vals body) |
cb28c085 | 667 | (set! (let-vals x) (map lp vals)) |
f4aa8d53 AW |
668 | (set! (let-body x) (lp body))) |
669 | ||
93f63467 | 670 | ((<letrec> gensyms vals body) |
cb28c085 | 671 | (set! (letrec-vals x) (map lp vals)) |
f4aa8d53 AW |
672 | (set! (letrec-body x) (lp body))) |
673 | ||
93f63467 | 674 | ((<fix> gensyms vals body) |
c21c89b1 AW |
675 | (set! (fix-vals x) (map lp vals)) |
676 | (set! (fix-body x) (lp body))) | |
677 | ||
8a4ca0ea | 678 | ((<let-values> exp body) |
f4aa8d53 AW |
679 | (set! (let-values-exp x) (lp exp)) |
680 | (set! (let-values-body x) (lp body))) | |
681 | ||
8da6ab34 AW |
682 | ((<dynwind> body winder unwinder) |
683 | (set! (dynwind-body x) (lp body)) | |
684 | (set! (dynwind-winder x) (lp winder)) | |
685 | (set! (dynwind-unwinder x) (lp unwinder))) | |
1c297a38 | 686 | |
d7c53a86 AW |
687 | ((<dynlet> fluids vals body) |
688 | (set! (dynlet-fluids x) (map lp fluids)) | |
689 | (set! (dynlet-vals x) (map lp vals)) | |
690 | (set! (dynlet-body x) (lp body))) | |
691 | ||
706a705e AW |
692 | ((<dynref> fluid) |
693 | (set! (dynref-fluid x) (lp fluid))) | |
694 | ||
695 | ((<dynset> fluid exp) | |
696 | (set! (dynset-fluid x) (lp fluid)) | |
697 | (set! (dynset-exp x) (lp exp))) | |
698 | ||
07a0c7d5 | 699 | ((<prompt> tag body handler) |
1c297a38 AW |
700 | (set! (prompt-tag x) (lp tag)) |
701 | (set! (prompt-body x) (lp body)) | |
07a0c7d5 | 702 | (set! (prompt-handler x) (lp handler))) |
1c297a38 | 703 | |
2d026f04 | 704 | ((<abort> tag args tail) |
6e84cb95 | 705 | (set! (abort-tag x) (lp tag)) |
2d026f04 AW |
706 | (set! (abort-args x) (map lp args)) |
707 | (set! (abort-tail x) (lp tail))) | |
1c297a38 | 708 | |
f4aa8d53 AW |
709 | (else #f)) |
710 | ||
711 | (or (f x) x))) | |
cb28c085 AW |
712 | |
713 | (define (pre-order! f x) | |
714 | (let lp ((x x)) | |
715 | (let ((x (or (f x) x))) | |
716 | (record-case x | |
717 | ((<application> proc args) | |
718 | (set! (application-proc x) (lp proc)) | |
719 | (set! (application-args x) (map lp args))) | |
720 | ||
b6d93b11 | 721 | ((<conditional> test consequent alternate) |
cb28c085 | 722 | (set! (conditional-test x) (lp test)) |
b6d93b11 AW |
723 | (set! (conditional-consequent x) (lp consequent)) |
724 | (set! (conditional-alternate x) (lp alternate))) | |
cb28c085 | 725 | |
e5f5113c | 726 | ((<lexical-set> exp) |
cb28c085 AW |
727 | (set! (lexical-set-exp x) (lp exp))) |
728 | ||
e5f5113c | 729 | ((<module-set> exp) |
cb28c085 AW |
730 | (set! (module-set-exp x) (lp exp))) |
731 | ||
e5f5113c | 732 | ((<toplevel-set> exp) |
cb28c085 AW |
733 | (set! (toplevel-set-exp x) (lp exp))) |
734 | ||
e5f5113c | 735 | ((<toplevel-define> exp) |
cb28c085 AW |
736 | (set! (toplevel-define-exp x) (lp exp))) |
737 | ||
e5f5113c | 738 | ((<lambda> body) |
cb28c085 AW |
739 | (set! (lambda-body x) (lp body))) |
740 | ||
3a88cb3b | 741 | ((<lambda-case> inits body alternate) |
b0c8c187 | 742 | (set! inits (map lp inits)) |
8a4ca0ea | 743 | (set! (lambda-case-body x) (lp body)) |
3a88cb3b | 744 | (if alternate (set! (lambda-case-alternate x) (lp alternate)))) |
8a4ca0ea | 745 | |
cb28c085 AW |
746 | ((<sequence> exps) |
747 | (set! (sequence-exps x) (map lp exps))) | |
748 | ||
e5f5113c | 749 | ((<let> vals body) |
cb28c085 | 750 | (set! (let-vals x) (map lp vals)) |
f4aa8d53 | 751 | (set! (let-body x) (lp body))) |
cb28c085 | 752 | |
e5f5113c | 753 | ((<letrec> vals body) |
cb28c085 | 754 | (set! (letrec-vals x) (map lp vals)) |
f4aa8d53 AW |
755 | (set! (letrec-body x) (lp body))) |
756 | ||
e5f5113c | 757 | ((<fix> vals body) |
c21c89b1 AW |
758 | (set! (fix-vals x) (map lp vals)) |
759 | (set! (fix-body x) (lp body))) | |
760 | ||
e5f5113c | 761 | ((<let-values> exp body) |
f4aa8d53 AW |
762 | (set! (let-values-exp x) (lp exp)) |
763 | (set! (let-values-body x) (lp body))) | |
cb28c085 | 764 | |
8da6ab34 AW |
765 | ((<dynwind> body winder unwinder) |
766 | (set! (dynwind-body x) (lp body)) | |
767 | (set! (dynwind-winder x) (lp winder)) | |
768 | (set! (dynwind-unwinder x) (lp unwinder))) | |
1c297a38 | 769 | |
d7c53a86 AW |
770 | ((<dynlet> fluids vals body) |
771 | (set! (dynlet-fluids x) (map lp fluids)) | |
772 | (set! (dynlet-vals x) (map lp vals)) | |
773 | (set! (dynlet-body x) (lp body))) | |
774 | ||
706a705e AW |
775 | ((<dynref> fluid) |
776 | (set! (dynref-fluid x) (lp fluid))) | |
777 | ||
778 | ((<dynset> fluid exp) | |
779 | (set! (dynset-fluid x) (lp fluid)) | |
780 | (set! (dynset-exp x) (lp exp))) | |
781 | ||
07a0c7d5 | 782 | ((<prompt> tag body handler) |
1c297a38 AW |
783 | (set! (prompt-tag x) (lp tag)) |
784 | (set! (prompt-body x) (lp body)) | |
07a0c7d5 | 785 | (set! (prompt-handler x) (lp handler))) |
1c297a38 | 786 | |
2d026f04 | 787 | ((<abort> tag args tail) |
6e84cb95 | 788 | (set! (abort-tag x) (lp tag)) |
2d026f04 AW |
789 | (set! (abort-args x) (map lp args)) |
790 | (set! (abort-tail x) (lp tail))) | |
1c297a38 | 791 | |
cb28c085 AW |
792 | (else #f)) |
793 | x))) |