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