Commit | Line | Data |
---|---|---|
62f528e9 | 1 | ;;;; Copyright (C) 2009, 2010, 2011 Free Software Foundation, Inc. |
d26a26f6 | 2 | ;;;; |
811d10f5 AW |
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. |
d26a26f6 | 7 | ;;;; |
811d10f5 AW |
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. | |
d26a26f6 | 12 | ;;;; |
811d10f5 AW |
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 | |
d26a26f6 | 16 | ;;;; |
811d10f5 AW |
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 |
d26a26f6 | 50 | <dynref> dynref? make-dynref dynref-src dynref-fluid |
706a705e | 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 | 64 | (define (print-tree-il exp port) |
7cd6d77c | 65 | (format port "#<tree-il ~S>" (unparse-tree-il exp))) |
4ffa8275 | 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)) |
d26a26f6 | 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) |
d26a26f6 | 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))) | |
d26a26f6 | 232 | |
d7c53a86 AW |
233 | ((dynlet ,fluids ,vals ,body) |
234 | (make-dynlet loc (map retrans fluids) (map retrans vals) (retrans body))) | |
d26a26f6 | 235 | |
706a705e AW |
236 | ((dynref ,fluid) |
237 | (make-dynref loc (retrans fluid))) | |
d26a26f6 | 238 | |
706a705e AW |
239 | ((dynset ,fluid ,exp) |
240 | (make-dynset loc (retrans fluid) (retrans exp))) | |
d26a26f6 | 241 | |
07a0c7d5 AW |
242 | ((prompt ,tag ,body ,handler) |
243 | (make-prompt loc (retrans tag) (retrans body) (retrans handler))) | |
d26a26f6 | 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 | 315 | ,(unparse-tree-il winder) ,(unparse-tree-il unwinder))) |
d26a26f6 | 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))) | |
d26a26f6 | 320 | |
706a705e AW |
321 | ((<dynref> fluid) |
322 | `(dynref ,(unparse-tree-il fluid))) | |
d26a26f6 | 323 | |
706a705e AW |
324 | ((<dynset> fluid exp) |
325 | `(dynref ,(unparse-tree-il fluid) ,(unparse-tree-il exp))) | |
d26a26f6 | 326 | |
07a0c7d5 | 327 | ((<prompt> tag body handler) |
2bcf97a6 | 328 | `(prompt ,(unparse-tree-il tag) ,(unparse-tree-il body) ,(unparse-tree-il handler))) |
d26a26f6 | 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) | |
d26a26f6 | 349 | |
e5f5113c | 350 | ((<lexical-ref> gensym) |
f4aa8d53 | 351 | gensym) |
d26a26f6 | 352 | |
e5f5113c | 353 | ((<lexical-set> gensym exp) |
f4aa8d53 | 354 | `(set! ,gensym ,(tree-il->scheme exp))) |
d26a26f6 | 355 | |
f4aa8d53 AW |
356 | ((<module-ref> mod name public?) |
357 | `(,(if public? '@ '@@) ,mod ,name)) | |
d26a26f6 | 358 | |
f4aa8d53 AW |
359 | ((<module-set> mod name public? exp) |
360 | `(set! (,(if public? '@ '@@) ,mod ,name) ,(tree-il->scheme exp))) | |
d26a26f6 | 361 | |
f4aa8d53 AW |
362 | ((<toplevel-ref> name) |
363 | name) | |
d26a26f6 | 364 | |
f4aa8d53 AW |
365 | ((<toplevel-set> name exp) |
366 | `(set! ,name ,(tree-il->scheme exp))) | |
d26a26f6 | 367 | |
f4aa8d53 AW |
368 | ((<toplevel-define> name exp) |
369 | `(define ,name ,(tree-il->scheme exp))) | |
d26a26f6 | 370 | |
8a4ca0ea AW |
371 | ((<lambda> meta body) |
372 | ;; fixme: put in docstring | |
cc63545b | 373 | (tree-il->scheme body)) |
d26a26f6 | 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)) | |
335c8a89 | 386 | ,(cdr alt-expansion))) |
cc63545b AW |
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 | |
d26a26f6 | 403 | `(#:optional |
cc63545b AW |
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))) | |
d26a26f6 | 435 | |
f4aa8d53 AW |
436 | ((<sequence> exps) |
437 | `(begin ,@(map tree-il->scheme exps))) | |
d26a26f6 | 438 | |
93f63467 AW |
439 | ((<let> gensyms vals body) |
440 | `(let ,(map list gensyms (map tree-il->scheme vals)) ,(tree-il->scheme body))) | |
d26a26f6 | 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) |
57086a19 AW |
447 | ;; not a typo, we really do translate back to letrec. use letrec* since it |
448 | ;; doesn't matter, and the naive letrec* transformation does not require an | |
449 | ;; inner let. | |
450 | `(letrec* ,(map list gensyms (map tree-il->scheme vals)) ,(tree-il->scheme body))) | |
c21c89b1 | 451 | |
1e2a8edb | 452 | ((<let-values> exp body) |
f4aa8d53 | 453 | `(call-with-values (lambda () ,(tree-il->scheme exp)) |
1c297a38 AW |
454 | ,(tree-il->scheme (make-lambda #f '() body)))) |
455 | ||
8da6ab34 | 456 | ((<dynwind> body winder unwinder) |
d69531e2 AW |
457 | `(dynamic-wind ,(tree-il->scheme winder) |
458 | (lambda () ,(tree-il->scheme body)) | |
459 | ,(tree-il->scheme unwinder))) | |
d26a26f6 | 460 | |
d7c53a86 AW |
461 | ((<dynlet> fluids vals body) |
462 | `(with-fluids ,(map list | |
463 | (map tree-il->scheme fluids) | |
464 | (map tree-il->scheme vals)) | |
67a78ddd | 465 | ,(tree-il->scheme body))) |
d26a26f6 | 466 | |
706a705e AW |
467 | ((<dynref> fluid) |
468 | `(fluid-ref ,(tree-il->scheme fluid))) | |
d26a26f6 | 469 | |
706a705e AW |
470 | ((<dynset> fluid exp) |
471 | `(fluid-set! ,(tree-il->scheme fluid) ,(tree-il->scheme exp))) | |
d26a26f6 | 472 | |
07a0c7d5 | 473 | ((<prompt> tag body handler) |
62f528e9 AW |
474 | `(call-with-prompt |
475 | ,(tree-il->scheme tag) | |
476 | (lambda () ,(tree-il->scheme body)) | |
07a0c7d5 | 477 | ,(tree-il->scheme handler))) |
d26a26f6 | 478 | |
1c297a38 | 479 | |
2d026f04 AW |
480 | ((<abort> tag args tail) |
481 | `(apply abort ,(tree-il->scheme tag) ,@(map tree-il->scheme args) | |
482 | ,(tree-il->scheme tail))))) | |
cb28c085 | 483 | |
f4aa0f10 LC |
484 | \f |
485 | (define (tree-il-fold leaf down up seed tree) | |
486 | "Traverse TREE, calling LEAF on each leaf encountered, DOWN upon descent | |
487 | into a sub-tree, and UP when leaving a sub-tree. Each of these procedures is | |
488 | invoked as `(PROC TREE SEED)', where TREE is the sub-tree or leaf considered | |
489 | and SEED is the current result, intially seeded with SEED. | |
490 | ||
491 | This is an implementation of `foldts' as described by Andy Wingo in | |
492 | ``Applications of fold to XML transformation''." | |
493 | (let loop ((tree tree) | |
494 | (result seed)) | |
495 | (if (or (null? tree) (pair? tree)) | |
496 | (fold loop result tree) | |
497 | (record-case tree | |
498 | ((<lexical-set> exp) | |
499 | (up tree (loop exp (down tree result)))) | |
500 | ((<module-set> exp) | |
501 | (up tree (loop exp (down tree result)))) | |
502 | ((<toplevel-set> exp) | |
503 | (up tree (loop exp (down tree result)))) | |
504 | ((<toplevel-define> exp) | |
505 | (up tree (loop exp (down tree result)))) | |
b6d93b11 AW |
506 | ((<conditional> test consequent alternate) |
507 | (up tree (loop alternate | |
508 | (loop consequent | |
f4aa0f10 LC |
509 | (loop test (down tree result)))))) |
510 | ((<application> proc args) | |
511 | (up tree (loop (cons proc args) (down tree result)))) | |
512 | ((<sequence> exps) | |
513 | (up tree (loop exps (down tree result)))) | |
514 | ((<lambda> body) | |
515 | (up tree (loop body (down tree result)))) | |
3a88cb3b AW |
516 | ((<lambda-case> inits body alternate) |
517 | (up tree (if alternate | |
518 | (loop alternate | |
1e2a8edb AW |
519 | (loop body (loop inits (down tree result)))) |
520 | (loop body (loop inits (down tree result)))))) | |
f4aa0f10 LC |
521 | ((<let> vals body) |
522 | (up tree (loop body | |
523 | (loop vals | |
524 | (down tree result))))) | |
525 | ((<letrec> vals body) | |
526 | (up tree (loop body | |
527 | (loop vals | |
528 | (down tree result))))) | |
c21c89b1 AW |
529 | ((<fix> vals body) |
530 | (up tree (loop body | |
531 | (loop vals | |
532 | (down tree result))))) | |
4dcd8499 AW |
533 | ((<let-values> exp body) |
534 | (up tree (loop body (loop exp (down tree result))))) | |
8da6ab34 | 535 | ((<dynwind> body winder unwinder) |
1c297a38 AW |
536 | (up tree (loop unwinder |
537 | (loop winder | |
538 | (loop body (down tree result)))))) | |
d7c53a86 AW |
539 | ((<dynlet> fluids vals body) |
540 | (up tree (loop body | |
541 | (loop vals | |
542 | (loop fluids (down tree result)))))) | |
706a705e AW |
543 | ((<dynref> fluid) |
544 | (up tree (loop fluid (down tree result)))) | |
545 | ((<dynset> fluid exp) | |
546 | (up tree (loop exp (loop fluid (down tree result))))) | |
07a0c7d5 AW |
547 | ((<prompt> tag body handler) |
548 | (up tree | |
549 | (loop tag (loop body (loop handler | |
550 | (down tree result)))))) | |
2d026f04 AW |
551 | ((<abort> tag args tail) |
552 | (up tree (loop tail (loop args (loop tag (down tree result)))))) | |
f4aa0f10 LC |
553 | (else |
554 | (leaf tree result)))))) | |
555 | ||
4dcd8499 AW |
556 | |
557 | (define-syntax make-tree-il-folder | |
558 | (syntax-rules () | |
559 | ((_ seed ...) | |
80af1168 | 560 | (lambda (tree down up seed ...) |
4dcd8499 AW |
561 | (define (fold-values proc exps seed ...) |
562 | (if (null? exps) | |
563 | (values seed ...) | |
564 | (let-values (((seed ...) (proc (car exps) seed ...))) | |
565 | (fold-values proc (cdr exps) seed ...)))) | |
566 | (let foldts ((tree tree) (seed seed) ...) | |
80af1168 AW |
567 | (let*-values |
568 | (((seed ...) (down tree seed ...)) | |
569 | ((seed ...) | |
570 | (record-case tree | |
571 | ((<lexical-set> exp) | |
572 | (foldts exp seed ...)) | |
573 | ((<module-set> exp) | |
574 | (foldts exp seed ...)) | |
575 | ((<toplevel-set> exp) | |
576 | (foldts exp seed ...)) | |
577 | ((<toplevel-define> exp) | |
578 | (foldts exp seed ...)) | |
b6d93b11 | 579 | ((<conditional> test consequent alternate) |
80af1168 | 580 | (let*-values (((seed ...) (foldts test seed ...)) |
b6d93b11 AW |
581 | ((seed ...) (foldts consequent seed ...))) |
582 | (foldts alternate seed ...))) | |
80af1168 AW |
583 | ((<application> proc args) |
584 | (let-values (((seed ...) (foldts proc seed ...))) | |
585 | (fold-values foldts args seed ...))) | |
586 | ((<sequence> exps) | |
587 | (fold-values foldts exps seed ...)) | |
588 | ((<lambda> body) | |
589 | (foldts body seed ...)) | |
3a88cb3b | 590 | ((<lambda-case> inits body alternate) |
b0c8c187 | 591 | (let-values (((seed ...) (fold-values foldts inits seed ...))) |
3a88cb3b | 592 | (if alternate |
1e2a8edb | 593 | (let-values (((seed ...) (foldts body seed ...))) |
3a88cb3b | 594 | (foldts alternate seed ...)) |
1e2a8edb | 595 | (foldts body seed ...)))) |
80af1168 AW |
596 | ((<let> vals body) |
597 | (let*-values (((seed ...) (fold-values foldts vals seed ...))) | |
598 | (foldts body seed ...))) | |
599 | ((<letrec> vals body) | |
600 | (let*-values (((seed ...) (fold-values foldts vals seed ...))) | |
601 | (foldts body seed ...))) | |
602 | ((<fix> vals body) | |
603 | (let*-values (((seed ...) (fold-values foldts vals seed ...))) | |
604 | (foldts body seed ...))) | |
605 | ((<let-values> exp body) | |
606 | (let*-values (((seed ...) (foldts exp seed ...))) | |
607 | (foldts body seed ...))) | |
8da6ab34 | 608 | ((<dynwind> body winder unwinder) |
1c297a38 AW |
609 | (let*-values (((seed ...) (foldts body seed ...)) |
610 | ((seed ...) (foldts winder seed ...))) | |
611 | (foldts unwinder seed ...))) | |
d7c53a86 AW |
612 | ((<dynlet> fluids vals body) |
613 | (let*-values (((seed ...) (fold-values foldts fluids seed ...)) | |
614 | ((seed ...) (fold-values foldts vals seed ...))) | |
615 | (foldts body seed ...))) | |
706a705e AW |
616 | ((<dynref> fluid) |
617 | (foldts fluid seed ...)) | |
618 | ((<dynset> fluid exp) | |
619 | (let*-values (((seed ...) (foldts fluid seed ...))) | |
620 | (foldts exp seed ...))) | |
07a0c7d5 | 621 | ((<prompt> tag body handler) |
1c297a38 | 622 | (let*-values (((seed ...) (foldts tag seed ...)) |
07a0c7d5 AW |
623 | ((seed ...) (foldts body seed ...))) |
624 | (foldts handler seed ...))) | |
2d026f04 AW |
625 | ((<abort> tag args tail) |
626 | (let*-values (((seed ...) (foldts tag seed ...)) | |
627 | ((seed ...) (fold-values foldts args seed ...))) | |
628 | (foldts tail seed ...))) | |
80af1168 AW |
629 | (else |
630 | (values seed ...))))) | |
631 | (up tree seed ...))))))) | |
4dcd8499 | 632 | |
cb28c085 AW |
633 | (define (post-order! f x) |
634 | (let lp ((x x)) | |
635 | (record-case x | |
636 | ((<application> proc args) | |
637 | (set! (application-proc x) (lp proc)) | |
f4aa8d53 | 638 | (set! (application-args x) (map lp args))) |
cb28c085 | 639 | |
b6d93b11 | 640 | ((<conditional> test consequent alternate) |
cb28c085 | 641 | (set! (conditional-test x) (lp test)) |
b6d93b11 AW |
642 | (set! (conditional-consequent x) (lp consequent)) |
643 | (set! (conditional-alternate x) (lp alternate))) | |
d26a26f6 | 644 | |
cb28c085 | 645 | ((<lexical-set> name gensym exp) |
f4aa8d53 | 646 | (set! (lexical-set-exp x) (lp exp))) |
d26a26f6 | 647 | |
cb28c085 | 648 | ((<module-set> mod name public? exp) |
f4aa8d53 | 649 | (set! (module-set-exp x) (lp exp))) |
d26a26f6 | 650 | |
cb28c085 | 651 | ((<toplevel-set> name exp) |
f4aa8d53 | 652 | (set! (toplevel-set-exp x) (lp exp))) |
d26a26f6 | 653 | |
cb28c085 | 654 | ((<toplevel-define> name exp) |
f4aa8d53 | 655 | (set! (toplevel-define-exp x) (lp exp))) |
d26a26f6 | 656 | |
8a4ca0ea | 657 | ((<lambda> body) |
f4aa8d53 | 658 | (set! (lambda-body x) (lp body))) |
d26a26f6 | 659 | |
3a88cb3b | 660 | ((<lambda-case> inits body alternate) |
b0c8c187 | 661 | (set! inits (map lp inits)) |
8a4ca0ea | 662 | (set! (lambda-case-body x) (lp body)) |
3a88cb3b AW |
663 | (if alternate |
664 | (set! (lambda-case-alternate x) (lp alternate)))) | |
d26a26f6 | 665 | |
cb28c085 | 666 | ((<sequence> exps) |
f4aa8d53 | 667 | (set! (sequence-exps x) (map lp exps))) |
d26a26f6 | 668 | |
93f63467 | 669 | ((<let> gensyms vals body) |
cb28c085 | 670 | (set! (let-vals x) (map lp vals)) |
f4aa8d53 | 671 | (set! (let-body x) (lp body))) |
d26a26f6 | 672 | |
93f63467 | 673 | ((<letrec> gensyms vals body) |
cb28c085 | 674 | (set! (letrec-vals x) (map lp vals)) |
f4aa8d53 | 675 | (set! (letrec-body x) (lp body))) |
d26a26f6 | 676 | |
93f63467 | 677 | ((<fix> gensyms vals body) |
c21c89b1 AW |
678 | (set! (fix-vals x) (map lp vals)) |
679 | (set! (fix-body x) (lp body))) | |
d26a26f6 | 680 | |
8a4ca0ea | 681 | ((<let-values> exp body) |
f4aa8d53 AW |
682 | (set! (let-values-exp x) (lp exp)) |
683 | (set! (let-values-body x) (lp body))) | |
d26a26f6 | 684 | |
8da6ab34 AW |
685 | ((<dynwind> body winder unwinder) |
686 | (set! (dynwind-body x) (lp body)) | |
687 | (set! (dynwind-winder x) (lp winder)) | |
688 | (set! (dynwind-unwinder x) (lp unwinder))) | |
d26a26f6 | 689 | |
d7c53a86 AW |
690 | ((<dynlet> fluids vals body) |
691 | (set! (dynlet-fluids x) (map lp fluids)) | |
692 | (set! (dynlet-vals x) (map lp vals)) | |
693 | (set! (dynlet-body x) (lp body))) | |
d26a26f6 | 694 | |
706a705e AW |
695 | ((<dynref> fluid) |
696 | (set! (dynref-fluid x) (lp fluid))) | |
d26a26f6 | 697 | |
706a705e AW |
698 | ((<dynset> fluid exp) |
699 | (set! (dynset-fluid x) (lp fluid)) | |
700 | (set! (dynset-exp x) (lp exp))) | |
d26a26f6 | 701 | |
07a0c7d5 | 702 | ((<prompt> tag body handler) |
1c297a38 AW |
703 | (set! (prompt-tag x) (lp tag)) |
704 | (set! (prompt-body x) (lp body)) | |
07a0c7d5 | 705 | (set! (prompt-handler x) (lp handler))) |
d26a26f6 | 706 | |
2d026f04 | 707 | ((<abort> tag args tail) |
6e84cb95 | 708 | (set! (abort-tag x) (lp tag)) |
2d026f04 AW |
709 | (set! (abort-args x) (map lp args)) |
710 | (set! (abort-tail x) (lp tail))) | |
d26a26f6 | 711 | |
f4aa8d53 | 712 | (else #f)) |
d26a26f6 | 713 | |
f4aa8d53 | 714 | (or (f x) x))) |
cb28c085 AW |
715 | |
716 | (define (pre-order! f x) | |
717 | (let lp ((x x)) | |
718 | (let ((x (or (f x) x))) | |
719 | (record-case x | |
720 | ((<application> proc args) | |
721 | (set! (application-proc x) (lp proc)) | |
722 | (set! (application-args x) (map lp args))) | |
723 | ||
b6d93b11 | 724 | ((<conditional> test consequent alternate) |
cb28c085 | 725 | (set! (conditional-test x) (lp test)) |
b6d93b11 AW |
726 | (set! (conditional-consequent x) (lp consequent)) |
727 | (set! (conditional-alternate x) (lp alternate))) | |
cb28c085 | 728 | |
e5f5113c | 729 | ((<lexical-set> exp) |
cb28c085 | 730 | (set! (lexical-set-exp x) (lp exp))) |
d26a26f6 | 731 | |
e5f5113c | 732 | ((<module-set> exp) |
cb28c085 AW |
733 | (set! (module-set-exp x) (lp exp))) |
734 | ||
e5f5113c | 735 | ((<toplevel-set> exp) |
cb28c085 AW |
736 | (set! (toplevel-set-exp x) (lp exp))) |
737 | ||
e5f5113c | 738 | ((<toplevel-define> exp) |
cb28c085 AW |
739 | (set! (toplevel-define-exp x) (lp exp))) |
740 | ||
e5f5113c | 741 | ((<lambda> body) |
cb28c085 AW |
742 | (set! (lambda-body x) (lp body))) |
743 | ||
3a88cb3b | 744 | ((<lambda-case> inits body alternate) |
b0c8c187 | 745 | (set! inits (map lp inits)) |
8a4ca0ea | 746 | (set! (lambda-case-body x) (lp body)) |
3a88cb3b | 747 | (if alternate (set! (lambda-case-alternate x) (lp alternate)))) |
8a4ca0ea | 748 | |
cb28c085 AW |
749 | ((<sequence> exps) |
750 | (set! (sequence-exps x) (map lp exps))) | |
751 | ||
e5f5113c | 752 | ((<let> vals body) |
cb28c085 | 753 | (set! (let-vals x) (map lp vals)) |
f4aa8d53 | 754 | (set! (let-body x) (lp body))) |
cb28c085 | 755 | |
e5f5113c | 756 | ((<letrec> vals body) |
cb28c085 | 757 | (set! (letrec-vals x) (map lp vals)) |
f4aa8d53 AW |
758 | (set! (letrec-body x) (lp body))) |
759 | ||
e5f5113c | 760 | ((<fix> vals body) |
c21c89b1 AW |
761 | (set! (fix-vals x) (map lp vals)) |
762 | (set! (fix-body x) (lp body))) | |
763 | ||
e5f5113c | 764 | ((<let-values> exp body) |
f4aa8d53 AW |
765 | (set! (let-values-exp x) (lp exp)) |
766 | (set! (let-values-body x) (lp body))) | |
cb28c085 | 767 | |
8da6ab34 AW |
768 | ((<dynwind> body winder unwinder) |
769 | (set! (dynwind-body x) (lp body)) | |
770 | (set! (dynwind-winder x) (lp winder)) | |
771 | (set! (dynwind-unwinder x) (lp unwinder))) | |
d26a26f6 | 772 | |
d7c53a86 AW |
773 | ((<dynlet> fluids vals body) |
774 | (set! (dynlet-fluids x) (map lp fluids)) | |
775 | (set! (dynlet-vals x) (map lp vals)) | |
776 | (set! (dynlet-body x) (lp body))) | |
d26a26f6 | 777 | |
706a705e AW |
778 | ((<dynref> fluid) |
779 | (set! (dynref-fluid x) (lp fluid))) | |
d26a26f6 | 780 | |
706a705e AW |
781 | ((<dynset> fluid exp) |
782 | (set! (dynset-fluid x) (lp fluid)) | |
783 | (set! (dynset-exp x) (lp exp))) | |
d26a26f6 | 784 | |
07a0c7d5 | 785 | ((<prompt> tag body handler) |
1c297a38 AW |
786 | (set! (prompt-tag x) (lp tag)) |
787 | (set! (prompt-body x) (lp body)) | |
07a0c7d5 | 788 | (set! (prompt-handler x) (lp handler))) |
d26a26f6 | 789 | |
2d026f04 | 790 | ((<abort> tag args tail) |
6e84cb95 | 791 | (set! (abort-tag x) (lp tag)) |
2d026f04 AW |
792 | (set! (abort-args x) (map lp args)) |
793 | (set! (abort-tail x) (lp tail))) | |
d26a26f6 | 794 | |
cb28c085 AW |
795 | (else #f)) |
796 | x))) |