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 AW |
72 | |
73 | (define (comp x e) | |
74 | (let ((l (location x))) | |
75 | (define (let1 what proc) | |
76 | (let ((sym (gensym))) | |
77 | (-> (let (list sym) (list sym) (list what) | |
78 | (proc sym))))) | |
79 | (define (begin1 what proc) | |
80 | (let1 what (lambda (v) | |
81 | (-> (begin (proc v) | |
82 | (-> (lexical v v))))))) | |
83 | (pmatch/source x | |
84 | (null | |
85 | ;; FIXME, null doesn't have much relation to EOL... | |
86 | (-> (const '()))) | |
87 | (true | |
88 | (-> (const #t))) | |
89 | (false | |
90 | (-> (const #f))) | |
91 | ((number ,num) | |
92 | (-> (const num))) | |
93 | ((string ,str) | |
94 | (-> (const str))) | |
95 | (this | |
d61e866c | 96 | (@impl get-this)) |
eb1482ac | 97 | ((+ ,a) |
7081d4f9 AW |
98 | (-> (call (-> (primitive '+)) |
99 | (@impl ->number (comp a e)) | |
100 | (-> (const 0))))) | |
eb1482ac | 101 | ((- ,a) |
7081d4f9 | 102 | (-> (call (-> (primitive '-)) (-> (const 0)) (comp a e)))) |
eb1482ac AW |
103 | ((~ ,a) |
104 | (@impl bitwise-not (comp a e))) | |
105 | ((! ,a) | |
106 | (@impl logical-not (comp a e))) | |
107 | ((+ ,a ,b) | |
7081d4f9 | 108 | (-> (call (-> (primitive '+)) (comp a e) (comp b e)))) |
eb1482ac | 109 | ((- ,a ,b) |
7081d4f9 | 110 | (-> (call (-> (primitive '-)) (comp a e) (comp b e)))) |
eb1482ac | 111 | ((/ ,a ,b) |
7081d4f9 | 112 | (-> (call (-> (primitive '/)) (comp a e) (comp b e)))) |
eb1482ac | 113 | ((* ,a ,b) |
7081d4f9 | 114 | (-> (call (-> (primitive '*)) (comp a e) (comp b e)))) |
eb1482ac AW |
115 | ((% ,a ,b) |
116 | (@impl mod (comp a e) (comp b e))) | |
117 | ((<< ,a ,b) | |
118 | (@impl shift (comp a e) (comp b e))) | |
119 | ((>> ,a ,b) | |
120 | (@impl shift (comp a e) (comp `(- ,b) e))) | |
121 | ((< ,a ,b) | |
7081d4f9 | 122 | (-> (call (-> (primitive '<)) (comp a e) (comp b e)))) |
eb1482ac | 123 | ((<= ,a ,b) |
7081d4f9 | 124 | (-> (call (-> (primitive '<=)) (comp a e) (comp b e)))) |
eb1482ac | 125 | ((> ,a ,b) |
7081d4f9 | 126 | (-> (call (-> (primitive '>)) (comp a e) (comp b e)))) |
eb1482ac | 127 | ((>= ,a ,b) |
7081d4f9 | 128 | (-> (call (-> (primitive '>=)) (comp a e) (comp b e)))) |
eb1482ac AW |
129 | ((in ,a ,b) |
130 | (@impl has-property? (comp a e) (comp b e))) | |
131 | ((== ,a ,b) | |
7081d4f9 | 132 | (-> (call (-> (primitive 'equal?)) (comp a e) (comp b e)))) |
eb1482ac | 133 | ((!= ,a ,b) |
7081d4f9 AW |
134 | (-> (call (-> (primitive 'not)) |
135 | (-> (call (-> (primitive 'equal?)) | |
136 | (comp a e) (comp b e)))))) | |
eb1482ac | 137 | ((=== ,a ,b) |
7081d4f9 | 138 | (-> (call (-> (primitive 'eqv?)) (comp a e) (comp b e)))) |
eb1482ac | 139 | ((!== ,a ,b) |
7081d4f9 AW |
140 | (-> (call (-> (primitive 'not)) |
141 | (-> (call (-> (primitive 'eqv?)) | |
142 | (comp a e) (comp b e)))))) | |
eb1482ac AW |
143 | ((& ,a ,b) |
144 | (@impl band (comp a e) (comp b e))) | |
145 | ((^ ,a ,b) | |
146 | (@impl bxor (comp a e) (comp b e))) | |
147 | ((bor ,a ,b) | |
148 | (@impl bior (comp a e) (comp b e))) | |
149 | ((and ,a ,b) | |
150 | (-> (if (@impl ->boolean (comp a e)) | |
151 | (comp b e) | |
152 | (-> (const #f))))) | |
153 | ((or ,a ,b) | |
154 | (let1 (comp a e) | |
155 | (lambda (v) | |
156 | (-> (if (@impl ->boolean (-> (lexical v v))) | |
157 | (-> (lexical v v)) | |
158 | (comp b e)))))) | |
159 | ((if ,test ,then ,else) | |
160 | (-> (if (@impl ->boolean (comp test e)) | |
161 | (comp then e) | |
162 | (comp else e)))) | |
d61e866c | 163 | ((if ,test ,then) |
eb1482ac AW |
164 | (-> (if (@impl ->boolean (comp test e)) |
165 | (comp then e) | |
166 | (@implv *undefined*)))) | |
167 | ((postinc (ref ,foo)) | |
168 | (begin1 (comp `(ref ,foo) e) | |
169 | (lambda (var) | |
170 | (-> (set! (lookup foo e) | |
7081d4f9 AW |
171 | (-> (call (-> (primitive '+)) |
172 | (-> (lexical var var)) | |
173 | (-> (const 1))))))))) | |
eb1482ac AW |
174 | ((postinc (pref ,obj ,prop)) |
175 | (let1 (comp obj e) | |
176 | (lambda (objvar) | |
177 | (begin1 (@impl pget | |
178 | (-> (lexical objvar objvar)) | |
179 | (-> (const prop))) | |
180 | (lambda (tmpvar) | |
181 | (@impl pput | |
182 | (-> (lexical objvar objvar)) | |
183 | (-> (const prop)) | |
7081d4f9 AW |
184 | (-> (call (-> (primitive '+)) |
185 | (-> (lexical tmpvar tmpvar)) | |
186 | (-> (const 1)))))))))) | |
eb1482ac AW |
187 | ((postinc (aref ,obj ,prop)) |
188 | (let1 (comp obj e) | |
189 | (lambda (objvar) | |
190 | (let1 (comp prop e) | |
191 | (lambda (propvar) | |
192 | (begin1 (@impl pget | |
193 | (-> (lexical objvar objvar)) | |
194 | (-> (lexical propvar propvar))) | |
195 | (lambda (tmpvar) | |
196 | (@impl pput | |
197 | (-> (lexical objvar objvar)) | |
198 | (-> (lexical propvar propvar)) | |
7081d4f9 AW |
199 | (-> (call (-> (primitive '+)) |
200 | (-> (lexical tmpvar tmpvar)) | |
201 | (-> (const 1)))))))))))) | |
eb1482ac AW |
202 | ((postdec (ref ,foo)) |
203 | (begin1 (comp `(ref ,foo) e) | |
204 | (lambda (var) | |
205 | (-> (set (lookup foo e) | |
7081d4f9 AW |
206 | (-> (call (-> (primitive '-)) |
207 | (-> (lexical var var)) | |
208 | (-> (const 1))))))))) | |
eb1482ac AW |
209 | ((postdec (pref ,obj ,prop)) |
210 | (let1 (comp obj e) | |
211 | (lambda (objvar) | |
212 | (begin1 (@impl pget | |
213 | (-> (lexical objvar objvar)) | |
214 | (-> (const prop))) | |
215 | (lambda (tmpvar) | |
216 | (@impl pput | |
217 | (-> (lexical objvar objvar)) | |
218 | (-> (const prop)) | |
7081d4f9 AW |
219 | (-> (call (-> (primitive '-)) |
220 | (-> (lexical tmpvar tmpvar)) | |
221 | (-> (const 1)))))))))) | |
eb1482ac AW |
222 | ((postdec (aref ,obj ,prop)) |
223 | (let1 (comp obj e) | |
224 | (lambda (objvar) | |
225 | (let1 (comp prop e) | |
226 | (lambda (propvar) | |
227 | (begin1 (@impl pget | |
228 | (-> (lexical objvar objvar)) | |
229 | (-> (lexical propvar propvar))) | |
230 | (lambda (tmpvar) | |
231 | (@impl pput | |
232 | (-> (lexical objvar objvar)) | |
233 | (-> (lexical propvar propvar)) | |
234 | (-> (inline | |
235 | '- (-> (lexical tmpvar tmpvar)) | |
236 | (-> (const 1)))))))))))) | |
237 | ((preinc (ref ,foo)) | |
238 | (let ((v (lookup foo e))) | |
239 | (-> (begin | |
240 | (-> (set! v | |
7081d4f9 AW |
241 | (-> (call (-> (primitive '+)) |
242 | v | |
243 | (-> (const 1)))))) | |
eb1482ac AW |
244 | v)))) |
245 | ((preinc (pref ,obj ,prop)) | |
246 | (let1 (comp obj e) | |
247 | (lambda (objvar) | |
7081d4f9 AW |
248 | (begin1 (-> (call (-> (primitive '+)) |
249 | (@impl pget | |
250 | (-> (lexical objvar objvar)) | |
251 | (-> (const prop))) | |
252 | (-> (const 1)))) | |
eb1482ac AW |
253 | (lambda (tmpvar) |
254 | (@impl pput (-> (lexical objvar objvar)) | |
255 | (-> (const prop)) | |
256 | (-> (lexical tmpvar tmpvar)))))))) | |
257 | ((preinc (aref ,obj ,prop)) | |
258 | (let1 (comp obj e) | |
259 | (lambda (objvar) | |
260 | (let1 (comp prop e) | |
261 | (lambda (propvar) | |
7081d4f9 AW |
262 | (begin1 (-> (call (-> (primitive '+)) |
263 | (@impl pget | |
264 | (-> (lexical objvar objvar)) | |
265 | (-> (lexical propvar propvar))) | |
266 | (-> (const 1)))) | |
eb1482ac AW |
267 | (lambda (tmpvar) |
268 | (@impl pput | |
269 | (-> (lexical objvar objvar)) | |
270 | (-> (lexical propvar propvar)) | |
271 | (-> (lexical tmpvar tmpvar)))))))))) | |
272 | ((predec (ref ,foo)) | |
273 | (let ((v (lookup foo e))) | |
274 | (-> (begin | |
275 | (-> (set! v | |
7081d4f9 | 276 | (-> (call (-> (primitive '-)) |
eb1482ac AW |
277 | v |
278 | (-> (const 1)))))) | |
279 | v)))) | |
280 | ((predec (pref ,obj ,prop)) | |
281 | (let1 (comp obj e) | |
282 | (lambda (objvar) | |
7081d4f9 AW |
283 | (begin1 (-> (call (-> (primitive '-)) |
284 | (@impl pget | |
285 | (-> (lexical objvar objvar)) | |
286 | (-> (const prop))) | |
287 | (-> (const 1)))) | |
eb1482ac AW |
288 | (lambda (tmpvar) |
289 | (@impl pput | |
290 | (-> (lexical objvar objvar)) | |
291 | (-> (const prop)) | |
292 | (-> (lexical tmpvar tmpvar)))))))) | |
293 | ((predec (aref ,obj ,prop)) | |
294 | (let1 (comp obj e) | |
295 | (lambda (objvar) | |
296 | (let1 (comp prop e) | |
297 | (lambda (propvar) | |
7081d4f9 AW |
298 | (begin1 (-> (call (-> (primitive '-)) |
299 | (@impl pget | |
300 | (-> (lexical objvar objvar)) | |
301 | (-> (lexical propvar propvar))) | |
302 | (-> (const 1)))) | |
eb1482ac AW |
303 | (lambda (tmpvar) |
304 | (@impl pput | |
305 | (-> (lexical objvar objvar)) | |
306 | (-> (lexical propvar propvar)) | |
307 | (-> (lexical tmpvar tmpvar)))))))))) | |
308 | ((ref ,id) | |
309 | (lookup id e)) | |
310 | ((var . ,forms) | |
d61e866c AW |
311 | `(begin |
312 | ,@(map (lambda (form) | |
313 | (pmatch form | |
314 | ((,x ,y) | |
315 | (-> (define x (comp y e)))) | |
316 | ((,x) | |
317 | (-> (define x (@implv *undefined*)))) | |
318 | (else (error "bad var form" form)))) | |
319 | forms))) | |
320 | ((begin) | |
321 | (-> (void))) | |
322 | ((begin ,form) | |
323 | (comp form e)) | |
eb1482ac AW |
324 | ((begin . ,forms) |
325 | `(begin ,@(map (lambda (x) (comp x e)) forms))) | |
326 | ((lambda ,formals ,body) | |
7e01997e AW |
327 | (let ((syms (map (lambda (x) |
328 | (gensym (string-append (symbol->string x) " "))) | |
329 | formals))) | |
d61e866c AW |
330 | `(lambda () |
331 | (lambda-case | |
1e2a8edb | 332 | ((() ,formals #f #f ,(map (lambda (x) (@implv *undefined*)) formals) ,syms) |
d61e866c | 333 | ,(comp-body e body formals syms)))))) |
eb1482ac AW |
334 | ((call/this ,obj ,prop . ,args) |
335 | (@impl call/this* | |
336 | obj | |
7e01997e | 337 | (-> (lambda '() |
d61e866c | 338 | `(lambda-case |
1e2a8edb | 339 | ((() #f #f #f () ()) |
7081d4f9 | 340 | (call ,(@impl pget obj prop) ,@args))))))) |
eb1482ac AW |
341 | ((call (pref ,obj ,prop) ,args) |
342 | (comp `(call/this ,(comp obj e) | |
343 | ,(-> (const prop)) | |
344 | ,@(map (lambda (x) (comp x e)) args)) | |
345 | e)) | |
346 | ((call (aref ,obj ,prop) ,args) | |
347 | (comp `(call/this ,(comp obj e) | |
348 | ,(comp prop e) | |
349 | ,@(map (lambda (x) (comp x e)) args)) | |
350 | e)) | |
351 | ((call ,proc ,args) | |
7081d4f9 AW |
352 | `(call ,(comp proc e) |
353 | ,@(map (lambda (x) (comp x e)) args))) | |
eb1482ac | 354 | ((return ,expr) |
7081d4f9 AW |
355 | (-> (call (-> (primitive 'return)) |
356 | (comp expr e)))) | |
eb1482ac | 357 | ((array . ,args) |
7081d4f9 AW |
358 | `(call ,(@implv new-array) |
359 | ,@(map (lambda (x) (comp x e)) args))) | |
eb1482ac | 360 | ((object . ,args) |
7081d4f9 AW |
361 | `(call ,(@implv new-object) |
362 | ,@(map (lambda (x) | |
363 | (pmatch x | |
364 | ((,prop ,val) | |
365 | (-> (call (-> (primitive 'cons)) | |
366 | (-> (const prop)) | |
367 | (comp val e)))) | |
368 | (else | |
369 | (error "bad prop-val pair" x)))) | |
370 | args))) | |
eb1482ac AW |
371 | ((pref ,obj ,prop) |
372 | (@impl pget | |
373 | (comp obj e) | |
374 | (-> (const prop)))) | |
375 | ((aref ,obj ,index) | |
376 | (@impl pget | |
377 | (comp obj e) | |
378 | (comp index e))) | |
379 | ((= (ref ,name) ,val) | |
380 | (let ((v (lookup name e))) | |
381 | (-> (begin | |
382 | (-> (set! v (comp val e))) | |
383 | v)))) | |
384 | ((= (pref ,obj ,prop) ,val) | |
385 | (@impl pput | |
386 | (comp obj e) | |
387 | (-> (const prop)) | |
388 | (comp val e))) | |
389 | ((= (aref ,obj ,prop) ,val) | |
390 | (@impl pput | |
391 | (comp obj e) | |
392 | (comp prop e) | |
393 | (comp val e))) | |
394 | ((+= ,what ,val) | |
395 | (comp `(= ,what (+ ,what ,val)) e)) | |
396 | ((-= ,what ,val) | |
397 | (comp `(= ,what (- ,what ,val)) e)) | |
398 | ((/= ,what ,val) | |
399 | (comp `(= ,what (/ ,what ,val)) e)) | |
400 | ((*= ,what ,val) | |
401 | (comp `(= ,what (* ,what ,val)) e)) | |
402 | ((%= ,what ,val) | |
403 | (comp `(= ,what (% ,what ,val)) e)) | |
404 | ((>>= ,what ,val) | |
405 | (comp `(= ,what (>> ,what ,val)) e)) | |
406 | ((<<= ,what ,val) | |
407 | (comp `(= ,what (<< ,what ,val)) e)) | |
408 | ((>>>= ,what ,val) | |
409 | (comp `(= ,what (>>> ,what ,val)) e)) | |
410 | ((&= ,what ,val) | |
411 | (comp `(= ,what (& ,what ,val)) e)) | |
412 | ((bor= ,what ,val) | |
413 | (comp `(= ,what (bor ,what ,val)) e)) | |
414 | ((^= ,what ,val) | |
415 | (comp `(= ,what (^ ,what ,val)) e)) | |
416 | ((new ,what ,args) | |
417 | (@impl new | |
418 | (map (lambda (x) (comp x e)) | |
419 | (cons what args)))) | |
420 | ((delete (pref ,obj ,prop)) | |
421 | (@impl pdel | |
422 | (comp obj e) | |
423 | (-> (const prop)))) | |
424 | ((delete (aref ,obj ,prop)) | |
425 | (@impl pdel | |
426 | (comp obj e) | |
427 | (comp prop e))) | |
428 | ((void ,expr) | |
429 | (-> (begin | |
430 | (comp expr e) | |
431 | (@implv *undefined*)))) | |
432 | ((typeof ,expr) | |
433 | (@impl typeof | |
434 | (comp expr e))) | |
435 | ((do ,statement ,test) | |
436 | (let ((%loop (gensym "%loop ")) | |
437 | (%continue (gensym "%continue "))) | |
438 | (let ((e (econs '%loop %loop (econs '%continue %continue e)))) | |
439 | (-> (letrec '(%loop %continue) (list %loop %continue) | |
7e01997e AW |
440 | (list (-> (lambda '() |
441 | (-> (lambda-case | |
1e2a8edb | 442 | `((() #f #f #f () ()) |
7e01997e AW |
443 | ,(-> (begin |
444 | (comp statement e) | |
7081d4f9 | 445 | (-> (call (-> (lexical '%continue %continue))))))))))) |
7e01997e AW |
446 | (-> (lambda '() |
447 | (-> (lambda-case | |
1e2a8edb | 448 | `((() #f #f #f () ()) |
7e01997e | 449 | ,(-> (if (@impl ->boolean (comp test e)) |
7081d4f9 | 450 | (-> (call (-> (lexical '%loop %loop)))) |
7e01997e | 451 | (@implv *undefined*))))))))) |
7081d4f9 | 452 | (-> (call (-> (lexical '%loop %loop))))))))) |
eb1482ac AW |
453 | ((while ,test ,statement) |
454 | (let ((%continue (gensym "%continue "))) | |
455 | (let ((e (econs '%continue %continue e))) | |
456 | (-> (letrec '(%continue) (list %continue) | |
7e01997e AW |
457 | (list (-> (lambda '() |
458 | (-> (lambda-case | |
1e2a8edb | 459 | `((() #f #f #f () ()) |
7e01997e AW |
460 | ,(-> (if (@impl ->boolean (comp test e)) |
461 | (-> (begin (comp statement e) | |
7081d4f9 | 462 | (-> (call (-> (lexical '%continue %continue)))))) |
7e01997e | 463 | (@implv *undefined*))))))))) |
7081d4f9 | 464 | (-> (call (-> (lexical '%continue %continue))))))))) |
eb1482ac AW |
465 | |
466 | ((for ,init ,test ,inc ,statement) | |
467 | (let ((%continue (gensym "%continue "))) | |
468 | (let ((e (econs '%continue %continue e))) | |
469 | (-> (letrec '(%continue) (list %continue) | |
7e01997e AW |
470 | (list (-> (lambda '() |
471 | (-> (lambda-case | |
1e2a8edb | 472 | `((() #f #f #f () ()) |
7e01997e AW |
473 | ,(-> (if (if test |
474 | (@impl ->boolean (comp test e)) | |
475 | (comp 'true e)) | |
476 | (-> (begin (comp statement e) | |
477 | (comp (or inc '(begin)) e) | |
7081d4f9 | 478 | (-> (call (-> (lexical '%continue %continue)))))) |
7e01997e | 479 | (@implv *undefined*))))))))) |
eb1482ac | 480 | (-> (begin (comp (or init '(begin)) e) |
7081d4f9 | 481 | (-> (call (-> (lexical '%continue %continue))))))))))) |
eb1482ac AW |
482 | |
483 | ((for-in ,var ,object ,statement) | |
484 | (let ((%enum (gensym "%enum ")) | |
485 | (%continue (gensym "%continue "))) | |
486 | (let ((e (econs '%enum %enum (econs '%continue %continue e)))) | |
487 | (-> (letrec '(%enum %continue) (list %enum %continue) | |
488 | (list (@impl make-enumerator (comp object e)) | |
7e01997e AW |
489 | (-> (lambda '() |
490 | (-> (lambda-case | |
1e2a8edb | 491 | `((() #f #f #f () ()) |
7e01997e AW |
492 | (-> (if (@impl ->boolean |
493 | (@impl pget | |
494 | (-> (lexical '%enum %enum)) | |
495 | (-> (const 'length)))) | |
496 | (-> (begin | |
497 | (comp `(= ,var (call/this ,(-> (lexical '%enum %enum)) | |
498 | ,(-> (const 'pop)))) | |
499 | e) | |
500 | (comp statement e) | |
7081d4f9 | 501 | (-> (call (-> (lexical '%continue %continue)))))) |
7e01997e | 502 | (@implv *undefined*))))))))) |
7081d4f9 | 503 | (-> (call (-> (lexical '%continue %continue))))))))) |
eb1482ac AW |
504 | |
505 | ((block ,x) | |
506 | (comp x e)) | |
507 | (else | |
508 | (error "compilation not yet implemented:" x))))) | |
509 | ||
7e01997e | 510 | (define (comp-body e body formals formal-syms) |
eb1482ac | 511 | (define (process) |
7e01997e | 512 | (let lp ((in body) (out '()) (rvars '())) |
eb1482ac AW |
513 | (pmatch in |
514 | (((var (,x) . ,morevars) . ,rest) | |
515 | (lp `((var . ,morevars) . ,rest) | |
516 | out | |
7e01997e AW |
517 | (if (or (memq x rvars) (memq x formals)) |
518 | rvars | |
519 | (cons x rvars)))) | |
eb1482ac AW |
520 | (((var (,x ,y) . ,morevars) . ,rest) |
521 | (lp `((var . ,morevars) . ,rest) | |
522 | `((= (ref ,x) ,y) . ,out) | |
7e01997e AW |
523 | (if (or (memq x rvars) (memq x formals)) |
524 | rvars | |
525 | (cons x rvars)))) | |
eb1482ac AW |
526 | (((var) . ,rest) |
527 | (lp rest out rvars)) | |
528 | ((,x . ,rest) (guard (and (pair? x) (eq? (car x) 'lambda))) | |
529 | (lp rest | |
530 | (cons x out) | |
531 | rvars)) | |
532 | ((,x . ,rest) (guard (pair? x)) | |
533 | (receive (sub-out rvars) | |
534 | (lp x '() rvars) | |
535 | (lp rest | |
536 | (cons sub-out out) | |
537 | rvars))) | |
538 | ((,x . ,rest) | |
539 | (lp rest | |
540 | (cons x out) | |
541 | rvars)) | |
542 | (() | |
543 | (values (reverse! out) | |
544 | rvars))))) | |
545 | (receive (out rvars) | |
546 | (process) | |
547 | (let* ((names (reverse rvars)) | |
548 | (syms (map (lambda (x) | |
549 | (gensym (string-append (symbol->string x) " "))) | |
550 | names)) | |
7e01997e | 551 | (e (fold econs (fold econs e formals formal-syms) names syms))) |
d61e866c | 552 | (-> (let names syms (map (lambda (x) (@implv *undefined*)) names) |
7e01997e | 553 | (comp out e)))))) |