1 ;;; ECMAScript for Guile
3 ;; Copyright (C) 2009, 2011 Free Software Foundation, Inc.
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.
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.
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
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))
36 (-> (@ '(language ecmascript impl) 'sym)))))
41 (-> (call (@implv sym) arg ...)))))
43 (define (empty-lexical-environment)
46 (define (econs name gensym env)
47 (acons name (-> (lexical name gensym)) env))
49 (define (lookup name env)
50 (or (assq-ref env name)
51 (-> (toplevel name))))
53 (define (compile-tree-il exp env opts)
56 (-> (begin (@impl js-init)
57 (comp exp (empty-lexical-environment)))))
63 (let ((props (source-properties x)))
64 (and (not (null? props))
68 ;; (put 'pmatch/source 'scheme-indent-function 1)
70 (define-syntax pmatch/source
76 (let ((loc (location x)))
78 (set-source-properties! res (location x))))
82 (let ((l (location x)))
83 (define (let1 what proc)
85 (-> (let (list sym) (list sym) (list what)
87 (define (begin1 what proc)
88 (let1 what (lambda (v)
90 (-> (lexical v v)))))))
93 ;; FIXME, null doesn't have much relation to EOL...
106 (-> (call (-> (primitive '+))
107 (@impl ->number (comp a e))
110 (-> (call (-> (primitive '-)) (-> (const 0)) (comp a e))))
112 (@impl bitwise-not (comp a e)))
114 (@impl logical-not (comp a e)))
116 (-> (call (-> (primitive '+)) (comp a e) (comp b e))))
118 (-> (call (-> (primitive '-)) (comp a e) (comp b e))))
120 (-> (call (-> (primitive '/)) (comp a e) (comp b e))))
122 (-> (call (-> (primitive '*)) (comp a e) (comp b e))))
124 (@impl mod (comp a e) (comp b e)))
126 (@impl shift (comp a e) (comp b e)))
128 (@impl shift (comp a e) (comp `(- ,b) e)))
130 (-> (call (-> (primitive '<)) (comp a e) (comp b e))))
132 (-> (call (-> (primitive '<=)) (comp a e) (comp b e))))
134 (-> (call (-> (primitive '>)) (comp a e) (comp b e))))
136 (-> (call (-> (primitive '>=)) (comp a e) (comp b e))))
138 (@impl has-property? (comp a e) (comp b e)))
140 (-> (call (-> (primitive 'equal?)) (comp a e) (comp b e))))
142 (-> (call (-> (primitive 'not))
143 (-> (call (-> (primitive 'equal?))
144 (comp a e) (comp b e))))))
146 (-> (call (-> (primitive 'eqv?)) (comp a e) (comp b e))))
148 (-> (call (-> (primitive 'not))
149 (-> (call (-> (primitive 'eqv?))
150 (comp a e) (comp b e))))))
152 (@impl band (comp a e) (comp b e)))
154 (@impl bxor (comp a e) (comp b e)))
156 (@impl bior (comp a e) (comp b e)))
158 (-> (if (@impl ->boolean (comp a e))
164 (-> (if (@impl ->boolean (-> (lexical v v)))
167 ((if ,test ,then ,else)
168 (-> (if (@impl ->boolean (comp test e))
172 (-> (if (@impl ->boolean (comp test e))
174 (@implv *undefined*))))
175 ((postinc (ref ,foo))
176 (begin1 (comp `(ref ,foo) e)
178 (-> (set! (lookup foo e)
179 (-> (call (-> (primitive '+))
180 (-> (lexical var var))
181 (-> (const 1)))))))))
182 ((postinc (pref ,obj ,prop))
186 (-> (lexical objvar objvar))
190 (-> (lexical objvar objvar))
192 (-> (call (-> (primitive '+))
193 (-> (lexical tmpvar tmpvar))
194 (-> (const 1))))))))))
195 ((postinc (aref ,obj ,prop))
201 (-> (lexical objvar objvar))
202 (-> (lexical propvar propvar)))
205 (-> (lexical objvar objvar))
206 (-> (lexical propvar propvar))
207 (-> (call (-> (primitive '+))
208 (-> (lexical tmpvar tmpvar))
209 (-> (const 1))))))))))))
210 ((postdec (ref ,foo))
211 (begin1 (comp `(ref ,foo) e)
213 (-> (set (lookup foo e)
214 (-> (call (-> (primitive '-))
215 (-> (lexical var var))
216 (-> (const 1)))))))))
217 ((postdec (pref ,obj ,prop))
221 (-> (lexical objvar objvar))
225 (-> (lexical objvar objvar))
227 (-> (call (-> (primitive '-))
228 (-> (lexical tmpvar tmpvar))
229 (-> (const 1))))))))))
230 ((postdec (aref ,obj ,prop))
236 (-> (lexical objvar objvar))
237 (-> (lexical propvar propvar)))
240 (-> (lexical objvar objvar))
241 (-> (lexical propvar propvar))
243 '- (-> (lexical tmpvar tmpvar))
244 (-> (const 1))))))))))))
246 (let ((v (lookup foo e)))
249 (-> (call (-> (primitive '+))
253 ((preinc (pref ,obj ,prop))
256 (begin1 (-> (call (-> (primitive '+))
258 (-> (lexical objvar objvar))
262 (@impl pput (-> (lexical objvar objvar))
264 (-> (lexical tmpvar tmpvar))))))))
265 ((preinc (aref ,obj ,prop))
270 (begin1 (-> (call (-> (primitive '+))
272 (-> (lexical objvar objvar))
273 (-> (lexical propvar propvar)))
277 (-> (lexical objvar objvar))
278 (-> (lexical propvar propvar))
279 (-> (lexical tmpvar tmpvar))))))))))
281 (let ((v (lookup foo e)))
284 (-> (call (-> (primitive '-))
288 ((predec (pref ,obj ,prop))
291 (begin1 (-> (call (-> (primitive '-))
293 (-> (lexical objvar objvar))
298 (-> (lexical objvar objvar))
300 (-> (lexical tmpvar tmpvar))))))))
301 ((predec (aref ,obj ,prop))
306 (begin1 (-> (call (-> (primitive '-))
308 (-> (lexical objvar objvar))
309 (-> (lexical propvar propvar)))
313 (-> (lexical objvar objvar))
314 (-> (lexical propvar propvar))
315 (-> (lexical tmpvar tmpvar))))))))))
320 ,@(map (lambda (form)
323 (-> (define x (comp y e))))
325 (-> (define x (@implv *undefined*))))
326 (else (error "bad var form" form))))
333 `(begin ,@(map (lambda (x) (comp x e)) forms)))
334 ((lambda ,formals ,body)
335 (let ((syms (map (lambda (x)
336 (gensym (string-append (symbol->string x) " ")))
340 ((() ,formals #f #f ,(map (lambda (x) (@implv *undefined*)) formals) ,syms)
341 ,(comp-body e body formals syms))))))
342 ((call/this ,obj ,prop . ,args)
348 (call ,(@impl pget obj prop) ,@args)))))))
349 ((call (pref ,obj ,prop) ,args)
350 (comp `(call/this ,(comp obj e)
352 ,@(map (lambda (x) (comp x e)) args))
354 ((call (aref ,obj ,prop) ,args)
355 (comp `(call/this ,(comp obj e)
357 ,@(map (lambda (x) (comp x e)) args))
360 `(call ,(comp proc e)
361 ,@(map (lambda (x) (comp x e)) args)))
363 (-> (call (-> (primitive 'return))
366 `(call ,(@implv new-array)
367 ,@(map (lambda (x) (comp x e)) args)))
369 `(call ,(@implv new-object)
373 (-> (call (-> (primitive 'cons))
377 (error "bad prop-val pair" x))))
387 ((= (ref ,name) ,val)
388 (let ((v (lookup name e)))
390 (-> (set! v (comp val e)))
392 ((= (pref ,obj ,prop) ,val)
397 ((= (aref ,obj ,prop) ,val)
403 (comp `(= ,what (+ ,what ,val)) e))
405 (comp `(= ,what (- ,what ,val)) e))
407 (comp `(= ,what (/ ,what ,val)) e))
409 (comp `(= ,what (* ,what ,val)) e))
411 (comp `(= ,what (% ,what ,val)) e))
413 (comp `(= ,what (>> ,what ,val)) e))
415 (comp `(= ,what (<< ,what ,val)) e))
417 (comp `(= ,what (>>> ,what ,val)) e))
419 (comp `(= ,what (& ,what ,val)) e))
421 (comp `(= ,what (bor ,what ,val)) e))
423 (comp `(= ,what (^ ,what ,val)) e))
426 (map (lambda (x) (comp x e))
428 ((delete (pref ,obj ,prop))
432 ((delete (aref ,obj ,prop))
439 (@implv *undefined*))))
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)
448 (list (-> (lambda '()
450 `((() #f #f #f () ())
453 (-> (call (-> (lexical '%continue %continue)))))))))))
456 `((() #f #f #f () ())
457 ,(-> (if (@impl ->boolean (comp test e))
458 (-> (call (-> (lexical '%loop %loop))))
459 (@implv *undefined*)))))))))
460 (-> (call (-> (lexical '%loop %loop)))))))))
461 ((while ,test ,statement)
462 (let ((%continue (gensym "%continue ")))
463 (let ((e (econs '%continue %continue e)))
464 (-> (letrec '(%continue) (list %continue)
465 (list (-> (lambda '()
467 `((() #f #f #f () ())
468 ,(-> (if (@impl ->boolean (comp test e))
469 (-> (begin (comp statement e)
470 (-> (call (-> (lexical '%continue %continue))))))
471 (@implv *undefined*)))))))))
472 (-> (call (-> (lexical '%continue %continue)))))))))
474 ((for ,init ,test ,inc ,statement)
475 (let ((%continue (gensym "%continue ")))
476 (let ((e (econs '%continue %continue e)))
477 (-> (letrec '(%continue) (list %continue)
478 (list (-> (lambda '()
480 `((() #f #f #f () ())
482 (@impl ->boolean (comp test e))
484 (-> (begin (comp statement e)
485 (comp (or inc '(begin)) e)
486 (-> (call (-> (lexical '%continue %continue))))))
487 (@implv *undefined*)))))))))
488 (-> (begin (comp (or init '(begin)) e)
489 (-> (call (-> (lexical '%continue %continue)))))))))))
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))
499 `((() #f #f #f () ())
500 (-> (if (@impl ->boolean
502 (-> (lexical '%enum %enum))
503 (-> (const 'length))))
505 (comp `(= ,var (call/this ,(-> (lexical '%enum %enum))
509 (-> (call (-> (lexical '%continue %continue))))))
510 (@implv *undefined*)))))))))
511 (-> (call (-> (lexical '%continue %continue)))))))))
516 (error "compilation not yet implemented:" x)))))
518 (define (comp-body e body formals formal-syms)
520 (let lp ((in body) (out '()) (rvars '()))
522 (((var (,x) . ,morevars) . ,rest)
523 (lp `((var . ,morevars) . ,rest)
525 (if (or (memq x rvars) (memq x formals))
528 (((var (,x ,y) . ,morevars) . ,rest)
529 (lp `((var . ,morevars) . ,rest)
530 `((= (ref ,x) ,y) . ,out)
531 (if (or (memq x rvars) (memq x formals))
536 ((,x . ,rest) (guard (and (pair? x) (eq? (car x) 'lambda)))
540 ((,x . ,rest) (guard (pair? x))
541 (receive (sub-out rvars)
551 (values (reverse! out)
555 (let* ((names (reverse rvars))
556 (syms (map (lambda (x)
557 (gensym (string-append (symbol->string x) " ")))
559 (e (fold econs (fold econs e formals formal-syms) names syms)))
560 (-> (let names syms (map (lambda (x) (@implv *undefined*)) names)