[bpt/guile.git] / module / language / ecmascript / compile-tree-il.scm

;;; ECMAScript for Guile

;; Copyright (C) 2009, 2011 Free Software Foundation, Inc.

;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;; 
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;;; Lesser General Public License for more details.
;;;; 
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA

;;; Code:

(define-module (language ecmascript compile-tree-il)
  #:use-module (language tree-il)
  #:use-module (ice-9 receive)
  #:use-module (system base pmatch)
  #:use-module (srfi srfi-1)
  #:export (compile-tree-il))

(define-syntax-rule (-> (type arg ...))
  `(type ,arg ...))

(define-syntax-rule (@implv sym)
  (-> (@ '(language ecmascript impl) 'sym)))

(define-syntax-rule (@impl sym arg ...)
  (-> (call (@implv sym) arg ...)))

(define (empty-lexical-environment)
  '())

(define (econs name gensym env)
  (acons name (-> (lexical name gensym)) env))

(define (lookup name env)
  (or (assq-ref env name)
      (-> (toplevel name))))

(define (compile-tree-il exp env opts)
  (values
   (parse-tree-il
    (-> (begin (@impl js-init)
               (comp exp (empty-lexical-environment)))))
   env
   env))

(define (location x)
  (and (pair? x)
       (let ((props (source-properties x)))
	 (and (not (null? props))
              props))))

;; for emacs:
;; (put 'pmatch/source 'scheme-indent-function 1)

(define-syntax-rule (pmatch/source x clause ...)
  (let ((x x))
    (let ((res (pmatch x
                 clause ...)))
      (let ((loc (location x)))
        (if loc
            (set-source-properties! res (location x))))
      res)))

(define current-return-tag (make-parameter #f))

(define (return expr)
  (-> (abort (or (current-return-tag) (error "return outside function"))
             (list expr)
             (-> (const '())))))

(define (with-return-prompt body-thunk)
  (let ((tag (gensym "return")))
    (parameterize ((current-return-tag
                    (-> (lexical 'return tag))))
      (-> (let '(return) (list tag)
               (list (-> (primcall 'make-prompt-tag)))
               (-> (prompt #t
                           (current-return-tag)
                           (-> (lambda '()
                                 (-> (lambda-case
                                      `((() #f #f #f () ())
                                        ,(body-thunk))))))
                           (let ((val (gensym "val")))
                             (-> (lambda '()
                                   (-> (lambda-case
                                        `(((k val) #f #f #f () (,(gensym) ,val))
                                          ,(-> (lexical 'val val)))))))))))))))

(define (comp x e)
  (let ((l (location x)))
    (define (let1 what proc)
      (let ((sym (gensym))) 
        (-> (let (list sym) (list sym) (list what)
                 (proc sym)))))
    (define (begin1 what proc)
      (let1 what (lambda (v)
                   (-> (begin (proc v)
                              (-> (lexical v v)))))))
    (pmatch/source x
      (null
       ;; FIXME, null doesn't have much relation to EOL...
       (-> (const '())))
      (true
       (-> (const #t)))
      (false
       (-> (const #f)))
      ((number ,num)
       (-> (const num)))
      ((string ,str)
       (-> (const str)))
      (this
       (@impl get-this))
      ((+ ,a)
       (-> (call (-> (primitive '+))
                 (@impl ->number (comp a e))
                 (-> (const 0)))))
      ((- ,a)
       (-> (call (-> (primitive '-)) (-> (const 0)) (comp a e))))
      ((~ ,a)
       (@impl bitwise-not (comp a e)))
      ((! ,a)
       (@impl logical-not (comp a e)))
      ((+ ,a ,b)
       (-> (call (-> (primitive '+)) (comp a e) (comp b e))))
      ((- ,a ,b)
       (-> (call (-> (primitive '-)) (comp a e) (comp b e))))
      ((/ ,a ,b)
       (-> (call (-> (primitive '/)) (comp a e) (comp b e))))
      ((* ,a ,b)
       (-> (call (-> (primitive '*)) (comp a e) (comp b e))))
      ((% ,a ,b)
       (@impl mod (comp a e) (comp b e)))
      ((<< ,a ,b)
       (@impl shift (comp a e) (comp b e)))
      ((>> ,a ,b)
       (@impl shift (comp a e) (comp `(- ,b) e)))
      ((< ,a ,b)
       (-> (call (-> (primitive '<)) (comp a e) (comp b e))))
      ((<= ,a ,b)
       (-> (call (-> (primitive '<=)) (comp a e) (comp b e))))
      ((> ,a ,b)
       (-> (call (-> (primitive '>)) (comp a e) (comp b e))))
      ((>= ,a ,b)
       (-> (call (-> (primitive '>=)) (comp a e) (comp b e))))
      ((in ,a ,b)
       (@impl has-property? (comp a e) (comp b e)))
      ((== ,a ,b)
       (-> (call (-> (primitive 'equal?)) (comp a e) (comp b e))))
      ((!= ,a ,b)
       (-> (call (-> (primitive 'not))
                 (-> (call (-> (primitive 'equal?))
                           (comp a e) (comp b e))))))
      ((=== ,a ,b)
       (-> (call (-> (primitive 'eqv?)) (comp a e) (comp b e))))
      ((!== ,a ,b)
       (-> (call (-> (primitive 'not))
                 (-> (call (-> (primitive 'eqv?))
                           (comp a e) (comp b e))))))
      ((& ,a ,b)
       (@impl band (comp a e) (comp b e)))
      ((^ ,a ,b)
       (@impl bxor (comp a e) (comp b e)))
      ((bor ,a ,b)
       (@impl bior (comp a e) (comp b e)))
      ((and ,a ,b)
       (-> (if (@impl ->boolean (comp a e))
               (comp b e)
               (-> (const #f)))))
      ((or ,a ,b)
       (let1 (comp a e)
             (lambda (v)
               (-> (if (@impl ->boolean (-> (lexical v v)))
                       (-> (lexical v v))
                       (comp b e))))))
      ((if ,test ,then ,else)
       (-> (if (@impl ->boolean (comp test e))
               (comp then e)
               (comp else e))))
      ((if ,test ,then)
       (-> (if (@impl ->boolean (comp test e))
               (comp then e)
               (@implv *undefined*))))
      ((postinc (ref ,foo))
       (begin1 (comp `(ref ,foo) e)
               (lambda (var)
                 (-> (set! (lookup foo e)
                           (-> (call (-> (primitive '+))
                                     (-> (lexical var var))
                                     (-> (const 1)))))))))
      ((postinc (pref ,obj ,prop))
       (let1 (comp obj e)
             (lambda (objvar)
               (begin1 (@impl pget
                              (-> (lexical objvar objvar))
                              (-> (const prop)))
                       (lambda (tmpvar)
                         (@impl pput
                                (-> (lexical objvar objvar))
                                (-> (const prop))
                                (-> (call (-> (primitive '+))
                                          (-> (lexical tmpvar tmpvar))
                                          (-> (const 1))))))))))
      ((postinc (aref ,obj ,prop))
       (let1 (comp obj e)
             (lambda (objvar)
               (let1 (comp prop e)
                     (lambda (propvar)
                       (begin1 (@impl pget
                                      (-> (lexical objvar objvar))
                                      (-> (lexical propvar propvar)))
                               (lambda (tmpvar)
                                 (@impl pput
                                        (-> (lexical objvar objvar))
                                        (-> (lexical propvar propvar))
                                        (-> (call (-> (primitive '+))
                                                  (-> (lexical tmpvar tmpvar))
                                                  (-> (const 1))))))))))))
      ((postdec (ref ,foo))
       (begin1 (comp `(ref ,foo) e)
               (lambda (var)
                 (-> (set (lookup foo e)
                          (-> (call (-> (primitive '-))
                                    (-> (lexical var var))
                                    (-> (const 1)))))))))
      ((postdec (pref ,obj ,prop))
       (let1 (comp obj e)
             (lambda (objvar)
               (begin1 (@impl pget
                              (-> (lexical objvar objvar))
                              (-> (const prop)))
                       (lambda (tmpvar)
                         (@impl pput
                                (-> (lexical objvar objvar))
                                (-> (const prop))
                                (-> (call (-> (primitive '-))
                                          (-> (lexical tmpvar tmpvar))
                                          (-> (const 1))))))))))
      ((postdec (aref ,obj ,prop))
       (let1 (comp obj e)
             (lambda (objvar)
               (let1 (comp prop e)
                     (lambda (propvar)
                       (begin1 (@impl pget
                                      (-> (lexical objvar objvar))
                                      (-> (lexical propvar propvar)))
                               (lambda (tmpvar)
                                 (@impl pput
                                        (-> (lexical objvar objvar))
                                        (-> (lexical propvar propvar))
                                        (-> (inline
                                             '- (-> (lexical tmpvar tmpvar))
                                             (-> (const 1))))))))))))
      ((preinc (ref ,foo))
       (let ((v (lookup foo e)))
         (-> (begin
               (-> (set! v
                         (-> (call (-> (primitive '+))
                                   v
                                   (-> (const 1))))))
               v))))
      ((preinc (pref ,obj ,prop))
       (let1 (comp obj e)
             (lambda (objvar)
               (begin1 (-> (call (-> (primitive '+))
                                 (@impl pget
                                        (-> (lexical objvar objvar))
                                        (-> (const prop)))
                                 (-> (const 1))))
                       (lambda (tmpvar)
                         (@impl pput (-> (lexical objvar objvar))
                                (-> (const prop))
                                (-> (lexical tmpvar tmpvar))))))))
      ((preinc (aref ,obj ,prop))
       (let1 (comp obj e)
             (lambda (objvar)
               (let1 (comp prop e)
                     (lambda (propvar)
                       (begin1 (-> (call (-> (primitive '+))
                                         (@impl pget
                                                (-> (lexical objvar objvar))
                                                (-> (lexical propvar propvar)))
                                         (-> (const 1))))
                               (lambda (tmpvar)
                                 (@impl pput
                                        (-> (lexical objvar objvar))
                                        (-> (lexical propvar propvar))
                                        (-> (lexical tmpvar tmpvar))))))))))
      ((predec (ref ,foo))
       (let ((v (lookup foo e)))
         (-> (begin
               (-> (set! v
                         (-> (call (-> (primitive '-))
                                   v
                                   (-> (const 1))))))
               v))))
      ((predec (pref ,obj ,prop))
       (let1 (comp obj e)
             (lambda (objvar)
               (begin1 (-> (call (-> (primitive '-))
                                 (@impl pget
                                        (-> (lexical objvar objvar))
                                        (-> (const prop)))
                                 (-> (const 1))))
                       (lambda (tmpvar)
                         (@impl pput
                                (-> (lexical objvar objvar))
                                (-> (const prop))
                                (-> (lexical tmpvar tmpvar))))))))
      ((predec (aref ,obj ,prop))
       (let1 (comp obj e)
             (lambda (objvar)
               (let1 (comp prop e)
                     (lambda (propvar)
                       (begin1 (-> (call (-> (primitive '-))
                                         (@impl pget
                                                (-> (lexical objvar objvar))
                                                (-> (lexical propvar propvar)))
                                         (-> (const 1))))
                               (lambda (tmpvar)
                                 (@impl pput
                                        (-> (lexical objvar objvar))
                                        (-> (lexical propvar propvar))
                                        (-> (lexical tmpvar tmpvar))))))))))
      ((ref ,id)
       (lookup id e))
      ((var . ,forms)
       `(begin
          ,@(map (lambda (form)
                   (pmatch form
                     ((,x ,y)
                      (-> (define x (comp y e))))
                     ((,x)
                      (-> (define x (@implv *undefined*))))
                     (else (error "bad var form" form))))
                 forms)))
      ((begin)
       (-> (void)))
      ((begin ,form)
       (comp form e))
      ((begin . ,forms)
       `(begin ,@(map (lambda (x) (comp x e)) forms)))
      ((lambda ,formals ,body)
       (let ((syms (map (lambda (x)
                          (gensym (string-append (symbol->string x) " ")))
                        formals)))
         `(lambda ()
            (lambda-case
             ((() ,formals #f #f ,(map (lambda (x) (@implv *undefined*)) formals) ,syms)
              ,(with-return-prompt
                (lambda ()
                  (comp-body e body formals syms))))))))
      ((call/this ,obj ,prop . ,args)
       (@impl call/this*
              obj
              (-> (lambda '() 
                    `(lambda-case
                      ((() #f #f #f () ())
                       (call ,(@impl pget obj prop) ,@args)))))))
      ((call (pref ,obj ,prop) ,args)
       (comp `(call/this ,(comp obj e)
                         ,(-> (const prop))
                         ,@(map (lambda (x) (comp x e)) args))
             e))
      ((call (aref ,obj ,prop) ,args)
       (comp `(call/this ,(comp obj e)
                         ,(comp prop e)
                         ,@(map (lambda (x) (comp x e)) args))
             e))
      ((call ,proc ,args)
       `(call ,(comp proc e)                
              ,@(map (lambda (x) (comp x e)) args)))
      ((return ,expr)
       (return (comp expr e)))
      ((array . ,args)
       `(call ,(@implv new-array)
              ,@(map (lambda (x) (comp x e)) args)))
      ((object . ,args)
       `(call ,(@implv new-object)
              ,@(map (lambda (x)
                       (pmatch x
                         ((,prop ,val)
                          (-> (call (-> (primitive 'cons))
                                    (-> (const prop))
                                    (comp val e))))
                         (else
                          (error "bad prop-val pair" x))))
                     args)))
      ((pref ,obj ,prop)
       (@impl pget
              (comp obj e)
              (-> (const prop))))
      ((aref ,obj ,index)
       (@impl pget
              (comp obj e)
              (comp index e)))
      ((= (ref ,name) ,val)
       (let ((v (lookup name e)))
         (-> (begin
               (-> (set! v (comp val e)))
               v))))
      ((= (pref ,obj ,prop) ,val)
       (@impl pput
              (comp obj e)
              (-> (const prop))
              (comp val e)))
      ((= (aref ,obj ,prop) ,val)
       (@impl pput
              (comp obj e)
              (comp prop e)
              (comp val e)))
      ((+= ,what ,val)
       (comp `(= ,what (+ ,what ,val)) e))
      ((-= ,what ,val)
       (comp `(= ,what (- ,what ,val)) e))
      ((/= ,what ,val)
       (comp `(= ,what (/ ,what ,val)) e))
      ((*= ,what ,val)
       (comp `(= ,what (* ,what ,val)) e))
      ((%= ,what ,val)
       (comp `(= ,what (% ,what ,val)) e))
      ((>>= ,what ,val)
       (comp `(= ,what (>> ,what ,val)) e))
      ((<<= ,what ,val)
       (comp `(= ,what (<< ,what ,val)) e))
      ((>>>= ,what ,val)
       (comp `(= ,what (>>> ,what ,val)) e))
      ((&= ,what ,val)
       (comp `(= ,what (& ,what ,val)) e))
      ((bor= ,what ,val)
       (comp `(= ,what (bor ,what ,val)) e))
      ((^= ,what ,val)
       (comp `(= ,what (^ ,what ,val)) e))
      ((new ,what ,args)
       (@impl new
              (map (lambda (x) (comp x e))
                   (cons what args))))
      ((delete (pref ,obj ,prop))
       (@impl pdel
              (comp obj e)
              (-> (const prop))))
      ((delete (aref ,obj ,prop))
       (@impl pdel
              (comp obj e)
              (comp prop e)))
      ((void ,expr)
       (-> (begin
             (comp expr e)
             (@implv *undefined*))))
      ((typeof ,expr)
       (@impl typeof
              (comp expr e)))
      ((do ,statement ,test)
       (let ((%loop (gensym "%loop "))
             (%continue (gensym "%continue ")))
         (let ((e (econs '%loop %loop (econs '%continue %continue e))))
           (-> (letrec '(%loop %continue) (list %loop %continue)
                       (list (-> (lambda '()
                                   (-> (lambda-case
                                        `((() #f #f #f () ())
                                          ,(-> (begin
                                                 (comp statement e)
                                                 (-> (call (-> (lexical '%continue %continue)))))))))))
                             (-> (lambda '()
                                   (-> (lambda-case
                                        `((() #f #f #f () ())
                                          ,(-> (if (@impl ->boolean (comp test e))
                                                   (-> (call (-> (lexical '%loop %loop))))
                                                   (@implv *undefined*)))))))))
                       (-> (call (-> (lexical '%loop %loop)))))))))
      ((while ,test ,statement)
       (let ((%continue (gensym "%continue ")))
         (let ((e (econs '%continue %continue e)))
           (-> (letrec '(%continue) (list %continue)
                       (list (-> (lambda '()
                                   (-> (lambda-case
                                        `((() #f #f #f () ())
                                          ,(-> (if (@impl ->boolean (comp test e))
                                                   (-> (begin (comp statement e)
                                                              (-> (call (-> (lexical '%continue %continue))))))
                                                   (@implv *undefined*)))))))))
                       (-> (call (-> (lexical '%continue %continue)))))))))
      
      ((for ,init ,test ,inc ,statement)
       (let ((%continue (gensym "%continue ")))
         (let ((e (econs '%continue %continue e)))
           (-> (letrec '(%continue) (list %continue)
                       (list (-> (lambda '()
                                   (-> (lambda-case
                                        `((() #f #f #f () ())
                                          ,(-> (if (if test
                                                       (@impl ->boolean (comp test e))
                                                       (comp 'true e))
                                                   (-> (begin (comp statement e)
                                                              (comp (or inc '(begin)) e)
                                                              (-> (call (-> (lexical '%continue %continue))))))
                                                   (@implv *undefined*)))))))))
                       (-> (begin (comp (or init '(begin)) e)
                                  (-> (call (-> (lexical '%continue %continue)))))))))))
      
      ((for-in ,var ,object ,statement)
       (let ((%enum (gensym "%enum "))
             (%continue (gensym "%continue ")))
         (let ((e (econs '%enum %enum (econs '%continue %continue e))))
           (-> (letrec '(%enum %continue) (list %enum %continue)
                       (list (@impl make-enumerator (comp object e))
                             (-> (lambda '()
                                   (-> (lambda-case
                                        `((() #f #f #f () ())
                                          (-> (if (@impl ->boolean
                                                         (@impl pget
                                                                (-> (lexical '%enum %enum))
                                                                (-> (const 'length))))
                                                  (-> (begin
                                                        (comp `(= ,var (call/this ,(-> (lexical '%enum %enum))
                                                                                  ,(-> (const 'pop))))
                                                              e)
                                                        (comp statement e)
                                                        (-> (call (-> (lexical '%continue %continue))))))
                                                  (@implv *undefined*)))))))))
                       (-> (call (-> (lexical '%continue %continue)))))))))
      
      ((block ,x)
       (comp x e))
      (else
       (error "compilation not yet implemented:" x)))))

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