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