Commit | Line | Data |
---|---|---|
eb1482ac AW |
1 | ;;; ECMAScript for Guile |
2 | ||
8a41c56a | 3 | ;; Copyright (C) 2009, 2011 Free Software Foundation, Inc. |
eb1482ac AW |
4 | |
5 | ;;;; This library is free software; you can redistribute it and/or | |
6 | ;;;; modify it under the terms of the GNU Lesser General Public | |
7 | ;;;; License as published by the Free Software Foundation; either | |
8 | ;;;; version 3 of the License, or (at your option) any later version. | |
9 | ;;;; | |
10 | ;;;; This library is distributed in the hope that it will be useful, | |
11 | ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
12 | ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU | |
13 | ;;;; Lesser General Public License for more details. | |
14 | ;;;; | |
15 | ;;;; You should have received a copy of the GNU Lesser General Public | |
16 | ;;;; License along with this library; if not, write to the Free Software | |
17 | ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA | |
18 | ||
19 | ;;; Code: | |
20 | ||
21 | (define-module (language ecmascript compile-tree-il) | |
22 | #:use-module (language tree-il) | |
23 | #:use-module (ice-9 receive) | |
24 | #:use-module (system base pmatch) | |
25 | #:use-module (srfi srfi-1) | |
26 | #:export (compile-tree-il)) | |
27 | ||
0c65f52c AW |
28 | (define-syntax-rule (-> (type arg ...)) |
29 | `(type ,arg ...)) | |
eb1482ac | 30 | |
0c65f52c AW |
31 | (define-syntax-rule (@implv sym) |
32 | (-> (@ '(language ecmascript impl) 'sym))) | |
eb1482ac | 33 | |
0c65f52c | 34 | (define-syntax-rule (@impl sym arg ...) |
ca128245 | 35 | (-> (call (@implv sym) arg ...))) |
eb1482ac AW |
36 | |
37 | (define (empty-lexical-environment) | |
38 | '()) | |
39 | ||
40 | (define (econs name gensym env) | |
d61e866c | 41 | (acons name (-> (lexical name gensym)) env)) |
eb1482ac AW |
42 | |
43 | (define (lookup name env) | |
44 | (or (assq-ref env name) | |
45 | (-> (toplevel name)))) | |
46 | ||
47 | (define (compile-tree-il exp env opts) | |
48 | (values | |
d61e866c AW |
49 | (parse-tree-il |
50 | (-> (begin (@impl js-init) | |
51 | (comp exp (empty-lexical-environment))))) | |
eb1482ac AW |
52 | env |
53 | env)) | |
54 | ||
55 | (define (location x) | |
56 | (and (pair? x) | |
57 | (let ((props (source-properties x))) | |
58 | (and (not (null? props)) | |
59 | props)))) | |
60 | ||
61 | ;; for emacs: | |
62 | ;; (put 'pmatch/source 'scheme-indent-function 1) | |
63 | ||
0c65f52c AW |
64 | (define-syntax-rule (pmatch/source x clause ...) |
65 | (let ((x x)) | |
66 | (let ((res (pmatch x | |
67 | clause ...))) | |
68 | (let ((loc (location x))) | |
69 | (if loc | |
70 | (set-source-properties! res (location x)))) | |
71 | res))) | |
eb1482ac | 72 | |
c0cfa9ef AW |
73 | (define current-return-tag (make-parameter #f)) |
74 | ||
75 | (define (return expr) | |
76 | (-> (abort (or (current-return-tag) (error "return outside function")) | |
77 | (list expr) | |
78 | (-> (const '()))))) | |
79 | ||
80 | (define (with-return-prompt body-thunk) | |
81 | (let ((tag (gensym "return"))) | |
82 | (parameterize ((current-return-tag | |
83 | (-> (lexical 'return tag)))) | |
84 | (-> (let '(return) (list tag) | |
2aed2667 | 85 | (list (-> (primcall 'make-prompt-tag))) |
5270bb5b MW |
86 | (-> (prompt #t |
87 | (current-return-tag) | |
1e5c3205 | 88 | (body-thunk) |
c0cfa9ef | 89 | (let ((val (gensym "val"))) |
5270bb5b MW |
90 | (-> (lambda '() |
91 | (-> (lambda-case | |
92 | `(((k val) #f #f #f () (,(gensym) ,val)) | |
93 | ,(-> (lexical 'val val))))))))))))))) | |
c0cfa9ef | 94 | |
eb1482ac AW |
95 | (define (comp x e) |
96 | (let ((l (location x))) | |
97 | (define (let1 what proc) | |
98 | (let ((sym (gensym))) | |
99 | (-> (let (list sym) (list sym) (list what) | |
100 | (proc sym))))) | |
101 | (define (begin1 what proc) | |
102 | (let1 what (lambda (v) | |
103 | (-> (begin (proc v) | |
104 | (-> (lexical v v))))))) | |
105 | (pmatch/source x | |
106 | (null | |
107 | ;; FIXME, null doesn't have much relation to EOL... | |
108 | (-> (const '()))) | |
109 | (true | |
110 | (-> (const #t))) | |
111 | (false | |
112 | (-> (const #f))) | |
113 | ((number ,num) | |
114 | (-> (const num))) | |
115 | ((string ,str) | |
116 | (-> (const str))) | |
117 | (this | |
d61e866c | 118 | (@impl get-this)) |
eb1482ac | 119 | ((+ ,a) |
7081d4f9 AW |
120 | (-> (call (-> (primitive '+)) |
121 | (@impl ->number (comp a e)) | |
122 | (-> (const 0))))) | |
eb1482ac | 123 | ((- ,a) |
7081d4f9 | 124 | (-> (call (-> (primitive '-)) (-> (const 0)) (comp a e)))) |
eb1482ac AW |
125 | ((~ ,a) |
126 | (@impl bitwise-not (comp a e))) | |
127 | ((! ,a) | |
128 | (@impl logical-not (comp a e))) | |
129 | ((+ ,a ,b) | |
7081d4f9 | 130 | (-> (call (-> (primitive '+)) (comp a e) (comp b e)))) |
eb1482ac | 131 | ((- ,a ,b) |
7081d4f9 | 132 | (-> (call (-> (primitive '-)) (comp a e) (comp b e)))) |
eb1482ac | 133 | ((/ ,a ,b) |
7081d4f9 | 134 | (-> (call (-> (primitive '/)) (comp a e) (comp b e)))) |
eb1482ac | 135 | ((* ,a ,b) |
7081d4f9 | 136 | (-> (call (-> (primitive '*)) (comp a e) (comp b e)))) |
eb1482ac AW |
137 | ((% ,a ,b) |
138 | (@impl mod (comp a e) (comp b e))) | |
139 | ((<< ,a ,b) | |
140 | (@impl shift (comp a e) (comp b e))) | |
141 | ((>> ,a ,b) | |
142 | (@impl shift (comp a e) (comp `(- ,b) e))) | |
143 | ((< ,a ,b) | |
7081d4f9 | 144 | (-> (call (-> (primitive '<)) (comp a e) (comp b e)))) |
eb1482ac | 145 | ((<= ,a ,b) |
7081d4f9 | 146 | (-> (call (-> (primitive '<=)) (comp a e) (comp b e)))) |
eb1482ac | 147 | ((> ,a ,b) |
7081d4f9 | 148 | (-> (call (-> (primitive '>)) (comp a e) (comp b e)))) |
eb1482ac | 149 | ((>= ,a ,b) |
7081d4f9 | 150 | (-> (call (-> (primitive '>=)) (comp a e) (comp b e)))) |
eb1482ac AW |
151 | ((in ,a ,b) |
152 | (@impl has-property? (comp a e) (comp b e))) | |
153 | ((== ,a ,b) | |
7081d4f9 | 154 | (-> (call (-> (primitive 'equal?)) (comp a e) (comp b e)))) |
eb1482ac | 155 | ((!= ,a ,b) |
7081d4f9 AW |
156 | (-> (call (-> (primitive 'not)) |
157 | (-> (call (-> (primitive 'equal?)) | |
158 | (comp a e) (comp b e)))))) | |
eb1482ac | 159 | ((=== ,a ,b) |
7081d4f9 | 160 | (-> (call (-> (primitive 'eqv?)) (comp a e) (comp b e)))) |
eb1482ac | 161 | ((!== ,a ,b) |
7081d4f9 AW |
162 | (-> (call (-> (primitive 'not)) |
163 | (-> (call (-> (primitive 'eqv?)) | |
164 | (comp a e) (comp b e)))))) | |
eb1482ac AW |
165 | ((& ,a ,b) |
166 | (@impl band (comp a e) (comp b e))) | |
167 | ((^ ,a ,b) | |
168 | (@impl bxor (comp a e) (comp b e))) | |
169 | ((bor ,a ,b) | |
170 | (@impl bior (comp a e) (comp b e))) | |
171 | ((and ,a ,b) | |
172 | (-> (if (@impl ->boolean (comp a e)) | |
173 | (comp b e) | |
174 | (-> (const #f))))) | |
175 | ((or ,a ,b) | |
176 | (let1 (comp a e) | |
177 | (lambda (v) | |
178 | (-> (if (@impl ->boolean (-> (lexical v v))) | |
179 | (-> (lexical v v)) | |
180 | (comp b e)))))) | |
181 | ((if ,test ,then ,else) | |
182 | (-> (if (@impl ->boolean (comp test e)) | |
183 | (comp then e) | |
184 | (comp else e)))) | |
d61e866c | 185 | ((if ,test ,then) |
eb1482ac AW |
186 | (-> (if (@impl ->boolean (comp test e)) |
187 | (comp then e) | |
188 | (@implv *undefined*)))) | |
189 | ((postinc (ref ,foo)) | |
190 | (begin1 (comp `(ref ,foo) e) | |
191 | (lambda (var) | |
192 | (-> (set! (lookup foo e) | |
7081d4f9 AW |
193 | (-> (call (-> (primitive '+)) |
194 | (-> (lexical var var)) | |
195 | (-> (const 1))))))))) | |
eb1482ac AW |
196 | ((postinc (pref ,obj ,prop)) |
197 | (let1 (comp obj e) | |
198 | (lambda (objvar) | |
199 | (begin1 (@impl pget | |
200 | (-> (lexical objvar objvar)) | |
201 | (-> (const prop))) | |
202 | (lambda (tmpvar) | |
203 | (@impl pput | |
204 | (-> (lexical objvar objvar)) | |
205 | (-> (const prop)) | |
7081d4f9 AW |
206 | (-> (call (-> (primitive '+)) |
207 | (-> (lexical tmpvar tmpvar)) | |
208 | (-> (const 1)))))))))) | |
eb1482ac AW |
209 | ((postinc (aref ,obj ,prop)) |
210 | (let1 (comp obj e) | |
211 | (lambda (objvar) | |
212 | (let1 (comp prop e) | |
213 | (lambda (propvar) | |
214 | (begin1 (@impl pget | |
215 | (-> (lexical objvar objvar)) | |
216 | (-> (lexical propvar propvar))) | |
217 | (lambda (tmpvar) | |
218 | (@impl pput | |
219 | (-> (lexical objvar objvar)) | |
220 | (-> (lexical propvar propvar)) | |
7081d4f9 AW |
221 | (-> (call (-> (primitive '+)) |
222 | (-> (lexical tmpvar tmpvar)) | |
223 | (-> (const 1)))))))))))) | |
eb1482ac AW |
224 | ((postdec (ref ,foo)) |
225 | (begin1 (comp `(ref ,foo) e) | |
226 | (lambda (var) | |
227 | (-> (set (lookup foo e) | |
7081d4f9 AW |
228 | (-> (call (-> (primitive '-)) |
229 | (-> (lexical var var)) | |
230 | (-> (const 1))))))))) | |
eb1482ac AW |
231 | ((postdec (pref ,obj ,prop)) |
232 | (let1 (comp obj e) | |
233 | (lambda (objvar) | |
234 | (begin1 (@impl pget | |
235 | (-> (lexical objvar objvar)) | |
236 | (-> (const prop))) | |
237 | (lambda (tmpvar) | |
238 | (@impl pput | |
239 | (-> (lexical objvar objvar)) | |
240 | (-> (const prop)) | |
7081d4f9 AW |
241 | (-> (call (-> (primitive '-)) |
242 | (-> (lexical tmpvar tmpvar)) | |
243 | (-> (const 1)))))))))) | |
eb1482ac AW |
244 | ((postdec (aref ,obj ,prop)) |
245 | (let1 (comp obj e) | |
246 | (lambda (objvar) | |
247 | (let1 (comp prop e) | |
248 | (lambda (propvar) | |
249 | (begin1 (@impl pget | |
250 | (-> (lexical objvar objvar)) | |
251 | (-> (lexical propvar propvar))) | |
252 | (lambda (tmpvar) | |
253 | (@impl pput | |
254 | (-> (lexical objvar objvar)) | |
255 | (-> (lexical propvar propvar)) | |
256 | (-> (inline | |
257 | '- (-> (lexical tmpvar tmpvar)) | |
258 | (-> (const 1)))))))))))) | |
259 | ((preinc (ref ,foo)) | |
260 | (let ((v (lookup foo e))) | |
261 | (-> (begin | |
262 | (-> (set! v | |
7081d4f9 AW |
263 | (-> (call (-> (primitive '+)) |
264 | v | |
265 | (-> (const 1)))))) | |
eb1482ac AW |
266 | v)))) |
267 | ((preinc (pref ,obj ,prop)) | |
268 | (let1 (comp obj e) | |
269 | (lambda (objvar) | |
7081d4f9 AW |
270 | (begin1 (-> (call (-> (primitive '+)) |
271 | (@impl pget | |
272 | (-> (lexical objvar objvar)) | |
273 | (-> (const prop))) | |
274 | (-> (const 1)))) | |
eb1482ac AW |
275 | (lambda (tmpvar) |
276 | (@impl pput (-> (lexical objvar objvar)) | |
277 | (-> (const prop)) | |
278 | (-> (lexical tmpvar tmpvar)))))))) | |
279 | ((preinc (aref ,obj ,prop)) | |
280 | (let1 (comp obj e) | |
281 | (lambda (objvar) | |
282 | (let1 (comp prop e) | |
283 | (lambda (propvar) | |
7081d4f9 AW |
284 | (begin1 (-> (call (-> (primitive '+)) |
285 | (@impl pget | |
286 | (-> (lexical objvar objvar)) | |
287 | (-> (lexical propvar propvar))) | |
288 | (-> (const 1)))) | |
eb1482ac AW |
289 | (lambda (tmpvar) |
290 | (@impl pput | |
291 | (-> (lexical objvar objvar)) | |
292 | (-> (lexical propvar propvar)) | |
293 | (-> (lexical tmpvar tmpvar)))))))))) | |
294 | ((predec (ref ,foo)) | |
295 | (let ((v (lookup foo e))) | |
296 | (-> (begin | |
297 | (-> (set! v | |
7081d4f9 | 298 | (-> (call (-> (primitive '-)) |
eb1482ac AW |
299 | v |
300 | (-> (const 1)))))) | |
301 | v)))) | |
302 | ((predec (pref ,obj ,prop)) | |
303 | (let1 (comp obj e) | |
304 | (lambda (objvar) | |
7081d4f9 AW |
305 | (begin1 (-> (call (-> (primitive '-)) |
306 | (@impl pget | |
307 | (-> (lexical objvar objvar)) | |
308 | (-> (const prop))) | |
309 | (-> (const 1)))) | |
eb1482ac AW |
310 | (lambda (tmpvar) |
311 | (@impl pput | |
312 | (-> (lexical objvar objvar)) | |
313 | (-> (const prop)) | |
314 | (-> (lexical tmpvar tmpvar)))))))) | |
315 | ((predec (aref ,obj ,prop)) | |
316 | (let1 (comp obj e) | |
317 | (lambda (objvar) | |
318 | (let1 (comp prop e) | |
319 | (lambda (propvar) | |
7081d4f9 AW |
320 | (begin1 (-> (call (-> (primitive '-)) |
321 | (@impl pget | |
322 | (-> (lexical objvar objvar)) | |
323 | (-> (lexical propvar propvar))) | |
324 | (-> (const 1)))) | |
eb1482ac AW |
325 | (lambda (tmpvar) |
326 | (@impl pput | |
327 | (-> (lexical objvar objvar)) | |
328 | (-> (lexical propvar propvar)) | |
329 | (-> (lexical tmpvar tmpvar)))))))))) | |
330 | ((ref ,id) | |
331 | (lookup id e)) | |
332 | ((var . ,forms) | |
d61e866c AW |
333 | `(begin |
334 | ,@(map (lambda (form) | |
335 | (pmatch form | |
336 | ((,x ,y) | |
337 | (-> (define x (comp y e)))) | |
338 | ((,x) | |
339 | (-> (define x (@implv *undefined*)))) | |
340 | (else (error "bad var form" form)))) | |
341 | forms))) | |
342 | ((begin) | |
343 | (-> (void))) | |
344 | ((begin ,form) | |
345 | (comp form e)) | |
eb1482ac AW |
346 | ((begin . ,forms) |
347 | `(begin ,@(map (lambda (x) (comp x e)) forms))) | |
348 | ((lambda ,formals ,body) | |
7e01997e AW |
349 | (let ((syms (map (lambda (x) |
350 | (gensym (string-append (symbol->string x) " "))) | |
351 | formals))) | |
d61e866c AW |
352 | `(lambda () |
353 | (lambda-case | |
1e2a8edb | 354 | ((() ,formals #f #f ,(map (lambda (x) (@implv *undefined*)) formals) ,syms) |
c0cfa9ef AW |
355 | ,(with-return-prompt |
356 | (lambda () | |
357 | (comp-body e body formals syms)))))))) | |
eb1482ac AW |
358 | ((call/this ,obj ,prop . ,args) |
359 | (@impl call/this* | |
360 | obj | |
7e01997e | 361 | (-> (lambda '() |
d61e866c | 362 | `(lambda-case |
1e2a8edb | 363 | ((() #f #f #f () ()) |
7081d4f9 | 364 | (call ,(@impl pget obj prop) ,@args))))))) |
eb1482ac AW |
365 | ((call (pref ,obj ,prop) ,args) |
366 | (comp `(call/this ,(comp obj e) | |
367 | ,(-> (const prop)) | |
368 | ,@(map (lambda (x) (comp x e)) args)) | |
369 | e)) | |
370 | ((call (aref ,obj ,prop) ,args) | |
371 | (comp `(call/this ,(comp obj e) | |
372 | ,(comp prop e) | |
373 | ,@(map (lambda (x) (comp x e)) args)) | |
374 | e)) | |
375 | ((call ,proc ,args) | |
7081d4f9 AW |
376 | `(call ,(comp proc e) |
377 | ,@(map (lambda (x) (comp x e)) args))) | |
eb1482ac | 378 | ((return ,expr) |
c0cfa9ef | 379 | (return (comp expr e))) |
eb1482ac | 380 | ((array . ,args) |
7081d4f9 AW |
381 | `(call ,(@implv new-array) |
382 | ,@(map (lambda (x) (comp x e)) args))) | |
eb1482ac | 383 | ((object . ,args) |
7081d4f9 AW |
384 | `(call ,(@implv new-object) |
385 | ,@(map (lambda (x) | |
386 | (pmatch x | |
387 | ((,prop ,val) | |
388 | (-> (call (-> (primitive 'cons)) | |
389 | (-> (const prop)) | |
390 | (comp val e)))) | |
391 | (else | |
392 | (error "bad prop-val pair" x)))) | |
393 | args))) | |
eb1482ac AW |
394 | ((pref ,obj ,prop) |
395 | (@impl pget | |
396 | (comp obj e) | |
397 | (-> (const prop)))) | |
398 | ((aref ,obj ,index) | |
399 | (@impl pget | |
400 | (comp obj e) | |
401 | (comp index e))) | |
402 | ((= (ref ,name) ,val) | |
403 | (let ((v (lookup name e))) | |
404 | (-> (begin | |
405 | (-> (set! v (comp val e))) | |
406 | v)))) | |
407 | ((= (pref ,obj ,prop) ,val) | |
408 | (@impl pput | |
409 | (comp obj e) | |
410 | (-> (const prop)) | |
411 | (comp val e))) | |
412 | ((= (aref ,obj ,prop) ,val) | |
413 | (@impl pput | |
414 | (comp obj e) | |
415 | (comp prop e) | |
416 | (comp val e))) | |
417 | ((+= ,what ,val) | |
418 | (comp `(= ,what (+ ,what ,val)) e)) | |
419 | ((-= ,what ,val) | |
420 | (comp `(= ,what (- ,what ,val)) e)) | |
421 | ((/= ,what ,val) | |
422 | (comp `(= ,what (/ ,what ,val)) e)) | |
423 | ((*= ,what ,val) | |
424 | (comp `(= ,what (* ,what ,val)) e)) | |
425 | ((%= ,what ,val) | |
426 | (comp `(= ,what (% ,what ,val)) e)) | |
427 | ((>>= ,what ,val) | |
428 | (comp `(= ,what (>> ,what ,val)) e)) | |
429 | ((<<= ,what ,val) | |
430 | (comp `(= ,what (<< ,what ,val)) e)) | |
431 | ((>>>= ,what ,val) | |
432 | (comp `(= ,what (>>> ,what ,val)) e)) | |
433 | ((&= ,what ,val) | |
434 | (comp `(= ,what (& ,what ,val)) e)) | |
435 | ((bor= ,what ,val) | |
436 | (comp `(= ,what (bor ,what ,val)) e)) | |
437 | ((^= ,what ,val) | |
438 | (comp `(= ,what (^ ,what ,val)) e)) | |
439 | ((new ,what ,args) | |
440 | (@impl new | |
441 | (map (lambda (x) (comp x e)) | |
442 | (cons what args)))) | |
443 | ((delete (pref ,obj ,prop)) | |
444 | (@impl pdel | |
445 | (comp obj e) | |
446 | (-> (const prop)))) | |
447 | ((delete (aref ,obj ,prop)) | |
448 | (@impl pdel | |
449 | (comp obj e) | |
450 | (comp prop e))) | |
451 | ((void ,expr) | |
452 | (-> (begin | |
453 | (comp expr e) | |
454 | (@implv *undefined*)))) | |
455 | ((typeof ,expr) | |
456 | (@impl typeof | |
457 | (comp expr e))) | |
458 | ((do ,statement ,test) | |
459 | (let ((%loop (gensym "%loop ")) | |
460 | (%continue (gensym "%continue "))) | |
461 | (let ((e (econs '%loop %loop (econs '%continue %continue e)))) | |
462 | (-> (letrec '(%loop %continue) (list %loop %continue) | |
7e01997e AW |
463 | (list (-> (lambda '() |
464 | (-> (lambda-case | |
1e2a8edb | 465 | `((() #f #f #f () ()) |
7e01997e AW |
466 | ,(-> (begin |
467 | (comp statement e) | |
7081d4f9 | 468 | (-> (call (-> (lexical '%continue %continue))))))))))) |
7e01997e AW |
469 | (-> (lambda '() |
470 | (-> (lambda-case | |
1e2a8edb | 471 | `((() #f #f #f () ()) |
7e01997e | 472 | ,(-> (if (@impl ->boolean (comp test e)) |
7081d4f9 | 473 | (-> (call (-> (lexical '%loop %loop)))) |
7e01997e | 474 | (@implv *undefined*))))))))) |
7081d4f9 | 475 | (-> (call (-> (lexical '%loop %loop))))))))) |
eb1482ac AW |
476 | ((while ,test ,statement) |
477 | (let ((%continue (gensym "%continue "))) | |
478 | (let ((e (econs '%continue %continue e))) | |
479 | (-> (letrec '(%continue) (list %continue) | |
7e01997e AW |
480 | (list (-> (lambda '() |
481 | (-> (lambda-case | |
1e2a8edb | 482 | `((() #f #f #f () ()) |
7e01997e AW |
483 | ,(-> (if (@impl ->boolean (comp test e)) |
484 | (-> (begin (comp statement e) | |
7081d4f9 | 485 | (-> (call (-> (lexical '%continue %continue)))))) |
7e01997e | 486 | (@implv *undefined*))))))))) |
7081d4f9 | 487 | (-> (call (-> (lexical '%continue %continue))))))))) |
eb1482ac AW |
488 | |
489 | ((for ,init ,test ,inc ,statement) | |
490 | (let ((%continue (gensym "%continue "))) | |
491 | (let ((e (econs '%continue %continue e))) | |
492 | (-> (letrec '(%continue) (list %continue) | |
7e01997e AW |
493 | (list (-> (lambda '() |
494 | (-> (lambda-case | |
1e2a8edb | 495 | `((() #f #f #f () ()) |
7e01997e AW |
496 | ,(-> (if (if test |
497 | (@impl ->boolean (comp test e)) | |
498 | (comp 'true e)) | |
499 | (-> (begin (comp statement e) | |
500 | (comp (or inc '(begin)) e) | |
7081d4f9 | 501 | (-> (call (-> (lexical '%continue %continue)))))) |
7e01997e | 502 | (@implv *undefined*))))))))) |
eb1482ac | 503 | (-> (begin (comp (or init '(begin)) e) |
7081d4f9 | 504 | (-> (call (-> (lexical '%continue %continue))))))))))) |
eb1482ac AW |
505 | |
506 | ((for-in ,var ,object ,statement) | |
507 | (let ((%enum (gensym "%enum ")) | |
508 | (%continue (gensym "%continue "))) | |
509 | (let ((e (econs '%enum %enum (econs '%continue %continue e)))) | |
510 | (-> (letrec '(%enum %continue) (list %enum %continue) | |
511 | (list (@impl make-enumerator (comp object e)) | |
7e01997e AW |
512 | (-> (lambda '() |
513 | (-> (lambda-case | |
1e2a8edb | 514 | `((() #f #f #f () ()) |
7e01997e AW |
515 | (-> (if (@impl ->boolean |
516 | (@impl pget | |
517 | (-> (lexical '%enum %enum)) | |
518 | (-> (const 'length)))) | |
519 | (-> (begin | |
520 | (comp `(= ,var (call/this ,(-> (lexical '%enum %enum)) | |
521 | ,(-> (const 'pop)))) | |
522 | e) | |
523 | (comp statement e) | |
7081d4f9 | 524 | (-> (call (-> (lexical '%continue %continue)))))) |
7e01997e | 525 | (@implv *undefined*))))))))) |
7081d4f9 | 526 | (-> (call (-> (lexical '%continue %continue))))))))) |
eb1482ac AW |
527 | |
528 | ((block ,x) | |
529 | (comp x e)) | |
530 | (else | |
531 | (error "compilation not yet implemented:" x))))) | |
532 | ||
7e01997e | 533 | (define (comp-body e body formals formal-syms) |
eb1482ac | 534 | (define (process) |
7e01997e | 535 | (let lp ((in body) (out '()) (rvars '())) |
eb1482ac AW |
536 | (pmatch in |
537 | (((var (,x) . ,morevars) . ,rest) | |
538 | (lp `((var . ,morevars) . ,rest) | |
539 | out | |
7e01997e AW |
540 | (if (or (memq x rvars) (memq x formals)) |
541 | rvars | |
542 | (cons x rvars)))) | |
eb1482ac AW |
543 | (((var (,x ,y) . ,morevars) . ,rest) |
544 | (lp `((var . ,morevars) . ,rest) | |
545 | `((= (ref ,x) ,y) . ,out) | |
7e01997e AW |
546 | (if (or (memq x rvars) (memq x formals)) |
547 | rvars | |
548 | (cons x rvars)))) | |
eb1482ac AW |
549 | (((var) . ,rest) |
550 | (lp rest out rvars)) | |
551 | ((,x . ,rest) (guard (and (pair? x) (eq? (car x) 'lambda))) | |
552 | (lp rest | |
553 | (cons x out) | |
554 | rvars)) | |
555 | ((,x . ,rest) (guard (pair? x)) | |
556 | (receive (sub-out rvars) | |
557 | (lp x '() rvars) | |
558 | (lp rest | |
559 | (cons sub-out out) | |
560 | rvars))) | |
561 | ((,x . ,rest) | |
562 | (lp rest | |
563 | (cons x out) | |
564 | rvars)) | |
565 | (() | |
566 | (values (reverse! out) | |
567 | rvars))))) | |
568 | (receive (out rvars) | |
569 | (process) | |
570 | (let* ((names (reverse rvars)) | |
571 | (syms (map (lambda (x) | |
572 | (gensym (string-append (symbol->string x) " "))) | |
573 | names)) | |
7e01997e | 574 | (e (fold econs (fold econs e formals formal-syms) names syms))) |
d61e866c | 575 | (-> (let names syms (map (lambda (x) (@implv *undefined*)) names) |
7e01997e | 576 | (comp out e)))))) |