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))
28 (define-syntax-rule (-> (type arg ...))
31 (define-syntax-rule (@implv sym)
32 (-> (@ '(language ecmascript impl) 'sym)))
34 (define-syntax-rule (@impl sym arg ...)
35 (-> (call (@implv sym) arg ...)))
37 (define (empty-lexical-environment)
40 (define (econs name gensym env)
41 (acons name (-> (lexical name gensym)) env))
43 (define (lookup name env)
44 (or (assq-ref env name)
45 (-> (toplevel name))))
47 (define (compile-tree-il exp env opts)
50 (-> (begin (@impl js-init)
51 (comp exp (empty-lexical-environment)))))
57 (let ((props (source-properties x)))
58 (and (not (null? props))
62 ;; (put 'pmatch/source 'scheme-indent-function 1)
64 (define-syntax-rule (pmatch/source x clause ...)
68 (let ((loc (location x)))
70 (set-source-properties! res (location x))))
74 (let ((l (location x)))
75 (define (let1 what proc)
77 (-> (let (list sym) (list sym) (list what)
79 (define (begin1 what proc)
80 (let1 what (lambda (v)
82 (-> (lexical v v)))))))
85 ;; FIXME, null doesn't have much relation to EOL...
98 (-> (call (-> (primitive '+))
99 (@impl ->number (comp a e))
102 (-> (call (-> (primitive '-)) (-> (const 0)) (comp a e))))
104 (@impl bitwise-not (comp a e)))
106 (@impl logical-not (comp a e)))
108 (-> (call (-> (primitive '+)) (comp a e) (comp b e))))
110 (-> (call (-> (primitive '-)) (comp a e) (comp b e))))
112 (-> (call (-> (primitive '/)) (comp a e) (comp b e))))
114 (-> (call (-> (primitive '*)) (comp a e) (comp b e))))
116 (@impl mod (comp a e) (comp b e)))
118 (@impl shift (comp a e) (comp b e)))
120 (@impl shift (comp a e) (comp `(- ,b) e)))
122 (-> (call (-> (primitive '<)) (comp a e) (comp b e))))
124 (-> (call (-> (primitive '<=)) (comp a e) (comp b e))))
126 (-> (call (-> (primitive '>)) (comp a e) (comp b e))))
128 (-> (call (-> (primitive '>=)) (comp a e) (comp b e))))
130 (@impl has-property? (comp a e) (comp b e)))
132 (-> (call (-> (primitive 'equal?)) (comp a e) (comp b e))))
134 (-> (call (-> (primitive 'not))
135 (-> (call (-> (primitive 'equal?))
136 (comp a e) (comp b e))))))
138 (-> (call (-> (primitive 'eqv?)) (comp a e) (comp b e))))
140 (-> (call (-> (primitive 'not))
141 (-> (call (-> (primitive 'eqv?))
142 (comp a e) (comp b e))))))
144 (@impl band (comp a e) (comp b e)))
146 (@impl bxor (comp a e) (comp b e)))
148 (@impl bior (comp a e) (comp b e)))
150 (-> (if (@impl ->boolean (comp a e))
156 (-> (if (@impl ->boolean (-> (lexical v v)))
159 ((if ,test ,then ,else)
160 (-> (if (@impl ->boolean (comp test e))
164 (-> (if (@impl ->boolean (comp test e))
166 (@implv *undefined*))))
167 ((postinc (ref ,foo))
168 (begin1 (comp `(ref ,foo) e)
170 (-> (set! (lookup foo e)
171 (-> (call (-> (primitive '+))
172 (-> (lexical var var))
173 (-> (const 1)))))))))
174 ((postinc (pref ,obj ,prop))
178 (-> (lexical objvar objvar))
182 (-> (lexical objvar objvar))
184 (-> (call (-> (primitive '+))
185 (-> (lexical tmpvar tmpvar))
186 (-> (const 1))))))))))
187 ((postinc (aref ,obj ,prop))
193 (-> (lexical objvar objvar))
194 (-> (lexical propvar propvar)))
197 (-> (lexical objvar objvar))
198 (-> (lexical propvar propvar))
199 (-> (call (-> (primitive '+))
200 (-> (lexical tmpvar tmpvar))
201 (-> (const 1))))))))))))
202 ((postdec (ref ,foo))
203 (begin1 (comp `(ref ,foo) e)
205 (-> (set (lookup foo e)
206 (-> (call (-> (primitive '-))
207 (-> (lexical var var))
208 (-> (const 1)))))))))
209 ((postdec (pref ,obj ,prop))
213 (-> (lexical objvar objvar))
217 (-> (lexical objvar objvar))
219 (-> (call (-> (primitive '-))
220 (-> (lexical tmpvar tmpvar))
221 (-> (const 1))))))))))
222 ((postdec (aref ,obj ,prop))
228 (-> (lexical objvar objvar))
229 (-> (lexical propvar propvar)))
232 (-> (lexical objvar objvar))
233 (-> (lexical propvar propvar))
235 '- (-> (lexical tmpvar tmpvar))
236 (-> (const 1))))))))))))
238 (let ((v (lookup foo e)))
241 (-> (call (-> (primitive '+))
245 ((preinc (pref ,obj ,prop))
248 (begin1 (-> (call (-> (primitive '+))
250 (-> (lexical objvar objvar))
254 (@impl pput (-> (lexical objvar objvar))
256 (-> (lexical tmpvar tmpvar))))))))
257 ((preinc (aref ,obj ,prop))
262 (begin1 (-> (call (-> (primitive '+))
264 (-> (lexical objvar objvar))
265 (-> (lexical propvar propvar)))
269 (-> (lexical objvar objvar))
270 (-> (lexical propvar propvar))
271 (-> (lexical tmpvar tmpvar))))))))))
273 (let ((v (lookup foo e)))
276 (-> (call (-> (primitive '-))
280 ((predec (pref ,obj ,prop))
283 (begin1 (-> (call (-> (primitive '-))
285 (-> (lexical objvar objvar))
290 (-> (lexical objvar objvar))
292 (-> (lexical tmpvar tmpvar))))))))
293 ((predec (aref ,obj ,prop))
298 (begin1 (-> (call (-> (primitive '-))
300 (-> (lexical objvar objvar))
301 (-> (lexical propvar propvar)))
305 (-> (lexical objvar objvar))
306 (-> (lexical propvar propvar))
307 (-> (lexical tmpvar tmpvar))))))))))
312 ,@(map (lambda (form)
315 (-> (define x (comp y e))))
317 (-> (define x (@implv *undefined*))))
318 (else (error "bad var form" form))))
325 `(begin ,@(map (lambda (x) (comp x e)) forms)))
326 ((lambda ,formals ,body)
327 (let ((syms (map (lambda (x)
328 (gensym (string-append (symbol->string x) " ")))
332 ((() ,formals #f #f ,(map (lambda (x) (@implv *undefined*)) formals) ,syms)
333 ,(comp-body e body formals syms))))))
334 ((call/this ,obj ,prop . ,args)
340 (call ,(@impl pget obj prop) ,@args)))))))
341 ((call (pref ,obj ,prop) ,args)
342 (comp `(call/this ,(comp obj e)
344 ,@(map (lambda (x) (comp x e)) args))
346 ((call (aref ,obj ,prop) ,args)
347 (comp `(call/this ,(comp obj e)
349 ,@(map (lambda (x) (comp x e)) args))
352 `(call ,(comp proc e)
353 ,@(map (lambda (x) (comp x e)) args)))
355 (-> (call (-> (primitive 'return))
358 `(call ,(@implv new-array)
359 ,@(map (lambda (x) (comp x e)) args)))
361 `(call ,(@implv new-object)
365 (-> (call (-> (primitive 'cons))
369 (error "bad prop-val pair" x))))
379 ((= (ref ,name) ,val)
380 (let ((v (lookup name e)))
382 (-> (set! v (comp val e)))
384 ((= (pref ,obj ,prop) ,val)
389 ((= (aref ,obj ,prop) ,val)
395 (comp `(= ,what (+ ,what ,val)) e))
397 (comp `(= ,what (- ,what ,val)) e))
399 (comp `(= ,what (/ ,what ,val)) e))
401 (comp `(= ,what (* ,what ,val)) e))
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 (bor ,what ,val)) e))
415 (comp `(= ,what (^ ,what ,val)) e))
418 (map (lambda (x) (comp x e))
420 ((delete (pref ,obj ,prop))
424 ((delete (aref ,obj ,prop))
431 (@implv *undefined*))))
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)
440 (list (-> (lambda '()
442 `((() #f #f #f () ())
445 (-> (call (-> (lexical '%continue %continue)))))))))))
448 `((() #f #f #f () ())
449 ,(-> (if (@impl ->boolean (comp test e))
450 (-> (call (-> (lexical '%loop %loop))))
451 (@implv *undefined*)))))))))
452 (-> (call (-> (lexical '%loop %loop)))))))))
453 ((while ,test ,statement)
454 (let ((%continue (gensym "%continue ")))
455 (let ((e (econs '%continue %continue e)))
456 (-> (letrec '(%continue) (list %continue)
457 (list (-> (lambda '()
459 `((() #f #f #f () ())
460 ,(-> (if (@impl ->boolean (comp test e))
461 (-> (begin (comp statement e)
462 (-> (call (-> (lexical '%continue %continue))))))
463 (@implv *undefined*)))))))))
464 (-> (call (-> (lexical '%continue %continue)))))))))
466 ((for ,init ,test ,inc ,statement)
467 (let ((%continue (gensym "%continue ")))
468 (let ((e (econs '%continue %continue e)))
469 (-> (letrec '(%continue) (list %continue)
470 (list (-> (lambda '()
472 `((() #f #f #f () ())
474 (@impl ->boolean (comp test e))
476 (-> (begin (comp statement e)
477 (comp (or inc '(begin)) e)
478 (-> (call (-> (lexical '%continue %continue))))))
479 (@implv *undefined*)))))))))
480 (-> (begin (comp (or init '(begin)) e)
481 (-> (call (-> (lexical '%continue %continue)))))))))))
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))
491 `((() #f #f #f () ())
492 (-> (if (@impl ->boolean
494 (-> (lexical '%enum %enum))
495 (-> (const 'length))))
497 (comp `(= ,var (call/this ,(-> (lexical '%enum %enum))
501 (-> (call (-> (lexical '%continue %continue))))))
502 (@implv *undefined*)))))))))
503 (-> (call (-> (lexical '%continue %continue)))))))))
508 (error "compilation not yet implemented:" x)))))
510 (define (comp-body e body formals formal-syms)
512 (let lp ((in body) (out '()) (rvars '()))
514 (((var (,x) . ,morevars) . ,rest)
515 (lp `((var . ,morevars) . ,rest)
517 (if (or (memq x rvars) (memq x formals))
520 (((var (,x ,y) . ,morevars) . ,rest)
521 (lp `((var . ,morevars) . ,rest)
522 `((= (ref ,x) ,y) . ,out)
523 (if (or (memq x rvars) (memq x formals))
528 ((,x . ,rest) (guard (and (pair? x) (eq? (car x) 'lambda)))
532 ((,x . ,rest) (guard (pair? x))
533 (receive (sub-out rvars)
543 (values (reverse! out)
547 (let* ((names (reverse rvars))
548 (syms (map (lambda (x)
549 (gensym (string-append (symbol->string x) " ")))
551 (e (fold econs (fold econs e formals formal-syms) names syms)))
552 (-> (let names syms (map (lambda (x) (@implv *undefined*)) names)