debitrot the ecmascript compiler

* module/Makefile.am (ECMASCRIPT_LANG_SOURCES):
* module/language/ecmascript/compile-ghil.scm:
* module/language/ecmascript/compile-tree-il.scm: SOURCES): Replace the
  GHIL compiler with a ->tree-il compiler. Not fully functional, but the
  basics work.

* module/language/ecmascript/spec.scm: Only include the tree-il compiler.

* module/language/ecmascript/tokenize.scm (read-punctuation): Avoid
  mutating a constant.

5 files changed, 553 insertions, 565 deletions

diff --git a/module/Makefile.am b/module/Makefile.am
index 5eec063c2..5ef00be37 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -114,7 +114,7 @@ ECMASCRIPT_LANG_SOURCES =			\
   language/ecmascript/base.scm			\
   language/ecmascript/function.scm		\
   language/ecmascript/array.scm			\
-  language/ecmascript/compile-ghil.scm		\
+  language/ecmascript/compile-tree-il.scm	\
   language/ecmascript/spec.scm
 
 BRAINFUCK_LANG_SOURCES =			\
diff --git a/module/language/ecmascript/compile-ghil.scm b/module/language/ecmascript/compile-ghil.scm
deleted file mode 100644
index ab04ba80c..000000000
--- a/module/language/ecmascript/compile-ghil.scm
+++ /dev/null
@@ -1,561 +0,0 @@
-;;; ECMAScript for Guile
-
-;; Copyright (C) 2009 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-ghil)
-  #:use-module (language ghil)
-  #:use-module (ice-9 receive)
-  #:use-module (system base pmatch)
-  #:export (compile-ghil))
-
-(define-macro (-> form)
-  `(,(symbol-append 'make-ghil- (car form)) e l . ,(cdr form)))
-
-(define-macro (@implv sym)
-  `(-> (ref (ghil-var-at-module! e '(language ecmascript impl) ',sym #t))))
-(define-macro (@impl sym args)
-  `(-> (call (@implv ,sym) ,args)))
-
-(define (compile-ghil exp env opts)
-  (values
-   (call-with-ghil-environment (make-ghil-toplevel-env) '()
-     (lambda (e vars)
-       (let ((l #f))
-         (-> (lambda vars #f '()
-                     (-> (begin (list (@impl js-init '())
-                                      (comp exp e)))))))))
-   env
-   env))
-
-(define (location x)
-  (and (pair? x)
-       (let ((props (source-properties x)))
-	 (and (not (null? props))
-              props))))
-
-(define (comp x e)
-  (let ((l (location x)))
-    (define (let1 what proc)
-      (call-with-ghil-bindings e '(%tmp)
-        (lambda (vars)
-          (-> (bind vars (list what)
-                    (proc (car vars)))))))
-    (define (begin1 what proc)
-      (call-with-ghil-bindings e '(%tmp)
-        (lambda (vars)
-          (-> (bind vars (list what)
-                    (-> (begin (list (proc (car vars))
-                                     (-> (ref (car vars)))))))))))
-    (pmatch x
-      (null
-       ;; FIXME, null doesn't have much relation to EOL...
-       (-> (quote '())))
-      (true
-       (-> (quote #t)))
-      (false
-       (-> (quote #f)))
-      ((number ,num)
-       (-> (quote num)))
-      ((string ,str)
-       (-> (quote str)))
-      (this
-       (@impl get-this '()))
-      ((+ ,a)
-       (-> (inline 'add
-                   (list (@impl ->number (list (comp a e)))
-                         (-> (quote 0))))))
-      ((- ,a)
-       (-> (inline 'sub (list (-> (quote 0)) (comp a e)))))
-      ((~ ,a)
-       (@impl bitwise-not (list (comp a e))))
-      ((! ,a)
-       (@impl logical-not (list (comp a e))))
-      ((+ ,a ,b)
-       (-> (inline 'add (list (comp a e) (comp b e)))))
-      ((- ,a ,b)
-       (-> (inline 'sub (list (comp a e) (comp b e)))))
-      ((/ ,a ,b)
-       (-> (inline 'div (list (comp a e) (comp b e)))))
-      ((* ,a ,b)
-       (-> (inline 'mul (list (comp a e) (comp b e)))))
-      ((% ,a ,b)
-       (@impl mod (list (comp a e) (comp b e))))
-      ((<< ,a ,b)
-       (@impl shift (list (comp a e) (comp b e))))
-      ((>> ,a ,b)
-       (@impl shift (list (comp a e) (comp `(- ,b) e))))
-      ((< ,a ,b)
-       (-> (inline 'lt? (list (comp a e) (comp b e)))))
-      ((<= ,a ,b)
-       (-> (inline 'le? (list (comp a e) (comp b e)))))
-      ((> ,a ,b)
-       (-> (inline 'gt? (list (comp a e) (comp b e)))))
-      ((>= ,a ,b)
-       (-> (inline 'ge? (list (comp a e) (comp b e)))))
-      ((in ,a ,b)
-       (@impl has-property? (list (comp a e) (comp b e))))
-      ((== ,a ,b)
-       (-> (inline 'equal? (list (comp a e) (comp b e)))))
-      ((!= ,a ,b)
-       (-> (inline 'not
-                   (list (-> (inline 'equal?
-                                     (list (comp a e) (comp b e))))))))
-      ((=== ,a ,b)
-       (-> (inline 'eqv? (list (comp a e) (comp b e)))))
-      ((!== ,a ,b)
-       (-> (inline 'not
-                   (list (-> (inline 'eqv?
-                                     (list (comp a e) (comp b e))))))))
-      ((& ,a ,b)
-       (@impl band (list (comp a e) (comp b e))))
-      ((^ ,a ,b)
-       (@impl bxor (list (comp a e) (comp b e))))
-      ((bor ,a ,b)
-       (@impl bior (list (comp a e) (comp b e))))
-      ((and ,a ,b)
-       (-> (and (list (comp a e) (comp b e)))))
-      ((or ,a ,b)
-       (-> (or (list (comp a e) (comp b e)))))
-      ((if ,test ,then ,else)
-       (-> (if (@impl ->boolean (list (comp test e)))
-               (comp then e)
-               (comp else e))))
-      ((if ,test ,then ,else)
-       (-> (if (@impl ->boolean (list (comp test e)))
-               (comp then e)
-               (@implv *undefined*))))
-      ((postinc (ref ,foo))
-       (begin1 (comp `(ref ,foo) e)
-               (lambda (var)
-                 (-> (set (ghil-var-for-set! e foo)
-                          (-> (inline 'add
-                                      (list (-> (ref var))
-                                            (-> (quote 1))))))))))
-      ((postinc (pref ,obj ,prop))
-       (let1 (comp obj e)
-             (lambda (objvar)
-               (begin1 (@impl pget
-                              (list (-> (ref objvar))
-                                    (-> (quote prop))))
-                       (lambda (tmpvar)
-                         (@impl pput
-                                (list (-> (ref objvar))
-                                      (-> (quote prop))
-                                      (-> (inline 'add
-                                                  (list (-> (ref tmpvar))
-                                                        (-> (quote 1))))))))))))
-      ((postinc (aref ,obj ,prop))
-       (let1 (comp obj e)
-             (lambda (objvar)
-               (let1 (comp prop e)
-                     (lambda (propvar)
-                       (begin1 (@impl pget
-                                      (list (-> (ref objvar))
-                                            (-> (ref propvar))))
-                               (lambda (tmpvar)
-                                 (@impl pput
-                                        (list (-> (ref objvar))
-                                              (-> (ref propvar))
-                                              (-> (inline 'add
-                                                          (list (-> (ref tmpvar))
-                                                                (-> (quote 1))))))))))))))
-      ((postdec (ref ,foo))
-       (begin1 (comp `(ref ,foo) e)
-               (lambda (var)
-                 (-> (set (ghil-var-for-set! e foo)
-                          (-> (inline 'sub
-                                      (list (-> (ref var))
-                                            (-> (quote 1))))))))))
-      ((postdec (pref ,obj ,prop))
-       (let1 (comp obj e)
-             (lambda (objvar)
-               (begin1 (@impl pget
-                              (list (-> (ref objvar))
-                                    (-> (quote prop))))
-                       (lambda (tmpvar)
-                         (@impl pput
-                                (list (-> (ref objvar))
-                                      (-> (quote prop))
-                                      (-> (inline 'sub
-                                                  (list (-> (ref tmpvar))
-                                                        (-> (quote 1))))))))))))
-      ((postdec (aref ,obj ,prop))
-       (let1 (comp obj e)
-             (lambda (objvar)
-               (let1 (comp prop e)
-                     (lambda (propvar)
-                       (begin1 (@impl pget
-                                      (list (-> (ref objvar))
-                                            (-> (ref propvar))))
-                               (lambda (tmpvar)
-                                 (@impl pput
-                                        (list (-> (ref objvar))
-                                              (-> (ref propvar))
-                                              (-> (inline
-                                                   'sub (list (-> (ref tmpvar))
-                                                              (-> (quote 1))))))))))))))
-      ((preinc (ref ,foo))
-       (let ((v (ghil-var-for-set! e foo)))
-         (-> (begin
-               (list
-                (-> (set v
-                         (-> (inline 'add
-                                     (list (-> (ref v))
-                                           (-> (quote 1)))))))
-                (-> (ref v)))))))
-      ((preinc (pref ,obj ,prop))
-       (let1 (comp obj e)
-             (lambda (objvar)
-               (begin1 (-> (inline 'add
-                                   (list (@impl pget
-                                                (list (-> (ref objvar))
-                                                      (-> (quote prop))))
-                                         (-> (quote 1)))))
-                       (lambda (tmpvar)
-                         (@impl pput (list (-> (ref objvar))
-                                           (-> (quote prop))
-                                           (-> (ref tmpvar)))))))))
-      ((preinc (aref ,obj ,prop))
-       (let1 (comp obj e)
-             (lambda (objvar)
-               (let1 (comp prop e)
-                     (lambda (propvar)
-                       (begin1 (-> (inline 'add
-                                           (list (@impl pget
-                                                        (list (-> (ref objvar))
-                                                              (-> (ref propvar))))
-                                                 (-> (quote 1)))))
-                               (lambda (tmpvar)
-                                 (@impl pput
-                                        (list (-> (ref objvar))
-                                              (-> (ref propvar))
-                                              (-> (ref tmpvar)))))))))))
-      ((predec (ref ,foo))
-       (let ((v (ghil-var-for-set! e foo)))
-         (-> (begin
-               (list
-                (-> (set v
-                         (-> (inline 'sub
-                                     (list (-> (ref v))
-                                           (-> (quote 1)))))))
-                (-> (ref v)))))))
-      ((predec (pref ,obj ,prop))
-       (let1 (comp obj e)
-             (lambda (objvar)
-               (begin1 (-> (inline 'sub
-                                   (list (@impl pget
-                                                (list (-> (ref objvar))
-                                                      (-> (quote prop))))
-                                         (-> (quote 1)))))
-                       (lambda (tmpvar)
-                         (@impl pput
-                                (list (-> (ref objvar))
-                                      (-> (quote prop))
-                                      (-> (ref tmpvar)))))))))
-      ((predec (aref ,obj ,prop))
-       (let1 (comp obj e)
-             (lambda (objvar)
-               (let1 (comp prop e)
-                     (lambda (propvar)
-                       (begin1 (-> (inline 'sub
-                                           (list (@impl pget
-                                                        (list (-> (ref objvar))
-                                                              (-> (ref propvar))))
-                                                 (-> (quote 1)))))
-                               (lambda (tmpvar)
-                                 (@impl pput
-                                        (list (-> (ref objvar))
-                                              (-> (ref propvar))
-                                              (-> (ref tmpvar)))))))))))
-      ((ref ,id)
-       (-> (ref (ghil-var-for-ref! e id))))
-      ((var . ,forms)
-       (-> (begin
-             (map (lambda (form)
-                    (pmatch form
-                      ((,x ,y)
-                       (-> (define (ghil-var-define! (ghil-env-parent e) x)
-                                   (comp y e))))
-                      ((,x)
-                       (-> (define (ghil-var-define! (ghil-env-parent e) x)
-                                   (@implv *undefined*))))
-                      (else (error "bad var form" form))))
-                  forms))))
-      ((begin . ,forms)
-       (-> (begin
-             (map (lambda (x) (comp x e)) forms))))
-      ((lambda ,formals ,body)
-       (call-with-ghil-environment e '(%args)
-         (lambda (e vars)
-           (-> (lambda vars #t '()
-                       (comp-body env l body formals '%args))))))
-      ((call/this ,obj ,prop ,args)
-       (@impl call/this*
-              (list obj
-                    (-> (lambda '() #f '()
-                                (-> (call (@impl pget (list obj prop))
-                                          args)))))))
-      ((call (pref ,obj ,prop) ,args)
-       (comp `(call/this ,(comp obj e)
-                         ,(-> (quote 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)
-       (-> (inline 'return
-                   (list (comp expr e)))))
-      ((array . ,args)
-       (@impl new-array
-              (map (lambda (x) (comp x e)) args)))
-      ((object . ,args)
-       (@impl new-object
-              (map (lambda (x)
-                     (pmatch x
-                       ((,prop ,val)
-                        (-> (inline 'cons
-                                    (list (-> (quote prop))
-                                          (comp val e)))))
-                       (else
-                        (error "bad prop-val pair" x))))
-                   args)))
-      ((pref ,obj ,prop)
-       (@impl pget
-              (list (comp obj e)
-                    (-> (quote prop)))))
-      ((aref ,obj ,index)
-       (@impl pget
-              (list (comp obj e)
-                    (comp index e))))
-      ((= (ref ,name) ,val)
-       (let ((v (ghil-var-for-set! e name)))
-         (-> (begin
-               (list (-> (set v (comp val e)))
-                     (-> (ref v)))))))
-      ((= (pref ,obj ,prop) ,val)
-       (@impl pput
-              (list (comp obj e)
-                    (-> (quote prop))
-                    (comp val e))))
-      ((= (aref ,obj ,prop) ,val)
-       (@impl pput
-              (list (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
-              (list (comp obj e)
-                    (-> (quote prop)))))
-      ((delete (aref ,obj ,prop))
-       (@impl pdel
-              (list (comp obj e)
-                    (comp prop e))))
-      ((void ,expr)
-       (-> (begin
-             (list (comp expr e)
-                   (@implv *undefined*)))))
-      ((typeof ,expr)
-       (@impl typeof
-              (list (comp expr e))))
-      ((do ,statement ,test)
-       (call-with-ghil-bindings e '(%loop %continue)
-         (lambda (vars)
-           (-> (bind vars
-                     (list (call-with-ghil-environment e '()
-                             (lambda (e _)
-                               (-> (lambda '() #f '()
-                                     (-> (begin
-                                           (list (comp statement e)
-                                                 (-> (call
-                                                      (-> (ref (ghil-var-for-ref! e '%continue)))
-                                                      '())))))))))
-                           (call-with-ghil-environment e '()
-                             (lambda (e _)
-                               (-> (lambda '() #f '()
-                                     (-> (if (@impl ->boolean (list (comp test e)))
-                                             (-> (call
-                                                  (-> (ref (ghil-var-for-ref! e '%loop)))
-                                                  '()))
-                                             (@implv *undefined*))))))))
-                     (-> (call (-> (ref (car vars))) '())))))))
-      ((while ,test ,statement)
-       (call-with-ghil-bindings e '(%continue)
-         (lambda (vars)
-           (-> (begin
-                 (list
-                  (-> (set (car vars)
-                           (call-with-ghil-environment e '()
-                             (lambda (e _)
-                               (-> (lambda '() #f '()
-                                     (-> (if (@impl ->boolean (list (comp test e)))
-                                             (-> (begin
-                                                   (list (comp statement e)
-                                                         (-> (call
-                                                              (-> (ref (ghil-var-for-ref! e '%continue)))
-                                                              '())))))
-                                             (@implv *undefined*)))))))))
-                  (-> (call (-> (ref (car vars))) '()))))))))
-      ((for ,init ,test ,inc ,statement)
-       (call-with-ghil-bindings e '(%continue)
-         (lambda (vars)
-           (-> (begin
-                 (list
-                  (comp (or init '(begin)) e)
-                  (-> (set (car vars)
-                           (call-with-ghil-environment e '()
-                             (lambda (e _)
-                               (-> (lambda '() #f '()
-                                     (-> (if (if test
-                                                 (@impl ->boolean (list (comp test e)))
-                                                 (comp 'true e))
-                                             (-> (begin
-                                                   (list (comp statement e)
-                                                         (comp (or inc '(begin)) e)
-                                                         (-> (call
-                                                              (-> (ref (ghil-var-for-ref! e '%continue)))
-                                                              '())))))
-                                             (@implv *undefined*)))))))))
-                  (-> (call (-> (ref (car vars))) '()))))))))
-      ((for-in ,var ,object ,statement)
-       (call-with-ghil-bindings e '(%continue %enum)
-         (lambda (vars)
-           (-> (begin
-                 (list
-                  (-> (set (car vars)
-                           (call-with-ghil-environment e '()
-                             (lambda (e _)
-                               (-> (lambda '() #f '()
-                                     (-> (if (@impl ->boolean
-                                                    (list (@impl pget
-                                                                 (list (-> (ref (ghil-var-for-ref! e '%enum)))
-                                                                       (-> (quote 'length))))))
-                                             (-> (begin
-                                                   (list
-                                                    (comp `(= ,var (call/this ,(-> (ref (ghil-var-for-ref! e '%enum)))
-                                                                              ,(-> (quote 'pop))
-                                                                              ()))
-                                                          e)
-                                                    (comp statement e)
-                                                    (-> (call (-> (ref (ghil-var-for-ref! e '%continue)))
-                                                              '())))))
-                                             (@implv *undefined*)))))))))
-                  (-> (set (cadr vars)
-                           (@impl make-enumerator (list (comp object e)))))
-                  (-> (call (-> (ref (car vars))) '()))))))))
-      ((break)
-       (let ((var (ghil-var-for-ref! e '%continue)))
-         (if (and (ghil-env? (ghil-var-env var))
-                  (eq? (ghil-var-env var) (ghil-env-parent e)))
-             (-> (inline 'return (@implv *undefined*)))
-             (error "bad break, yo"))))
-      ((continue)
-       (let ((var (ghil-var-for-ref! e '%continue)))
-         (if (and (ghil-env? (ghil-var-env var))
-                  (eq? (ghil-var-env var) (ghil-env-parent e)))
-             (-> (inline 'goto/args (list (-> (ref var)))))
-             (error "bad continue, yo"))))
-      ((block ,x)
-       (comp x e))
-      (else
-       (error "compilation not yet implemented:" x)))))
-
-(define (comp-body e l body formals %args)
-  (define (process)
-    (let lp ((in body) (out '()) (rvars (reverse formals)))
-      (pmatch in
-        (((var (,x) . ,morevars) . ,rest)
-         (lp `((var . ,morevars) . ,rest)
-             out
-             (if (memq x rvars) rvars (cons x rvars))))
-        (((var (,x ,y) . ,morevars) . ,rest)
-         (lp `((var . ,morevars) . ,rest)
-             `((= (ref ,x) ,y) . ,out)
-             (if (memq x rvars) 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)
-    (call-with-ghil-bindings e (reverse rvars)
-      (lambda (vars)
-        (let ((%argv (assq-ref (ghil-env-table e) %args)))
-          (-> (begin
-                `(,@(map
-                     (lambda (f)
-                       (-> (if (-> (inline 'null?
-                                           (list (-> (ref %argv)))))
-                               (-> (begin '()))
-                               (-> (begin
-                                     (list (-> (set (ghil-var-for-ref! e f)
-                                                    (-> (inline 'car
-                                                                (list (-> (ref %argv)))))))
-                                           (-> (set %argv
-                                                    (-> (inline 'cdr
-                                                                (list (-> (ref %argv)))))))))))))
-                     formals)
-                  ;; fixme: here check for too many args
-                  ,(comp out e)))))))))
diff --git a/module/language/ecmascript/compile-tree-il.scm b/module/language/ecmascript/compile-tree-il.scm
new file mode 100644
index 000000000..88f3db76f
--- /dev/null
+++ b/module/language/ecmascript/compile-tree-il.scm
@@ -0,0 +1,549 @@
+;;; ECMAScript for Guile
+
+;; Copyright (C) 2009 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 ->
+  (syntax-rules ()
+    ((_ (type arg ...))
+     `(type ,arg ...))))
+
+(define-syntax @implv
+  (syntax-rules ()
+    ((_ sym)
+     (-> (module-ref '(language ecmascript impl) 'sym #t)))))
+
+(define-syntax @impl
+  (syntax-rules ()
+    ((_ sym arg ...)
+     (-> (apply (@implv sym) arg ...)))))
+
+(define (empty-lexical-environment)
+  '())
+
+(define (econs name gensym env)
+  (acons 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 (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 pmatch/source
+  (syntax-rules ()
+    ((_ x clause ...)
+     (let ((x x))
+       (let ((res (pmatch x
+                    clause ...)))
+         (let ((loc (location x)))
+           (if loc
+               (set-source-properties! res (location x))))
+         res)))))
+
+(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)
+       (-> (apply (-> (primitive '+))
+                  (@impl ->number (comp a e))
+                  (-> (const 0)))))
+      ((- ,a)
+       (-> (apply (-> (primitive '-)) (-> (const 0)) (comp a e))))
+      ((~ ,a)
+       (@impl bitwise-not (comp a e)))
+      ((! ,a)
+       (@impl logical-not (comp a e)))
+      ((+ ,a ,b)
+       (-> (apply (-> (primitive '+)) (comp a e) (comp b e))))
+      ((- ,a ,b)
+       (-> (apply (-> (primitive '-)) (comp a e) (comp b e))))
+      ((/ ,a ,b)
+       (-> (apply (-> (primitive '/)) (comp a e) (comp b e))))
+      ((* ,a ,b)
+       (-> (apply (-> (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)
+       (-> (apply (-> (primitive '<)) (comp a e) (comp b e))))
+      ((<= ,a ,b)
+       (-> (apply (-> (primitive '<=)) (comp a e) (comp b e))))
+      ((> ,a ,b)
+       (-> (apply (-> (primitive '>)) (comp a e) (comp b e))))
+      ((>= ,a ,b)
+       (-> (apply (-> (primitive '>=)) (comp a e) (comp b e))))
+      ((in ,a ,b)
+       (@impl has-property? (comp a e) (comp b e)))
+      ((== ,a ,b)
+       (-> (apply (-> (primitive 'equal?)) (comp a e) (comp b e))))
+      ((!= ,a ,b)
+       (-> (apply (-> (primitive 'not))
+                  (-> (apply (-> (primitive 'equal?))
+                             (comp a e) (comp b e))))))
+      ((=== ,a ,b)
+       (-> (apply (-> (primitive 'eqv?)) (comp a e) (comp b e))))
+      ((!== ,a ,b)
+       (-> (apply (-> (primitive 'not))
+                  (-> (apply (-> (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 ,else)
+       (-> (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)
+                           (-> (apply (-> (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))
+                                (-> (apply (-> (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))
+                                        (-> (apply (-> (primitive '+))
+                                                   (-> (lexical tmpvar tmpvar))
+                                                   (-> (const 1))))))))))))
+      ((postdec (ref ,foo))
+       (begin1 (comp `(ref ,foo) e)
+               (lambda (var)
+                 (-> (set (lookup foo e)
+                          (-> (apply (-> (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))
+                                (-> (apply (-> (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
+                         (-> (apply (-> (primitive '+))
+                                    v
+                                    (-> (const 1))))))
+               v))))
+      ((preinc (pref ,obj ,prop))
+       (let1 (comp obj e)
+             (lambda (objvar)
+               (begin1 (-> (apply (-> (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 (-> (apply (-> (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
+                        (-> (apply (-> (primitive '-))
+                                   v
+                                   (-> (const 1))))))
+               v))))
+      ((predec (pref ,obj ,prop))
+       (let1 (comp obj e)
+             (lambda (objvar)
+               (begin1 (-> (apply (-> (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 (-> (apply (-> (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 . ,forms)
+       `(begin ,@(map (lambda (x) (comp x e)) forms)))
+      ((lambda ,formals ,body)
+       (let ((%args (gensym "%args ")))
+         (-> (lambda '%args %args '()
+                     (comp-body (econs '%args %args e) body formals '%args)))))
+      ((call/this ,obj ,prop . ,args)
+       (@impl call/this*
+              obj
+              (-> (lambda '() '() '()
+                          `(apply ,(@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)
+       `(apply ,(comp proc e)                
+               ,@(map (lambda (x) (comp x e)) args)))
+      ((return ,expr)
+       (-> (apply (-> (primitive 'return))
+                  (comp expr e))))
+      ((array . ,args)
+       `(apply ,(@implv new-array)
+               ,@(map (lambda (x) (comp x e)) args)))
+      ((object . ,args)
+       (@impl new-object
+              (map (lambda (x)
+                     (pmatch x
+                       ((,prop ,val)
+                        (-> (apply (-> (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 '() '() '()
+                                         (-> (begin
+                                               (comp statement e)
+                                               (-> (apply (-> (lexical '%continue %continue)))
+                                                   )))))
+                             
+                             (-> (lambda '() '() '()
+                                         (-> (if (@impl ->boolean (comp test e))
+                                                 (-> (apply (-> (lexical '%loop %loop))))
+                                                 (@implv *undefined*))))))
+                       (-> (apply (-> (lexical '%loop %loop)))))))))
+      ((while ,test ,statement)
+       (let ((%continue (gensym "%continue ")))
+         (let ((e (econs '%continue %continue e)))
+           (-> (letrec '(%continue) (list %continue)
+                       (list (-> (lambda '() '() '()
+                                         (-> (if (@impl ->boolean (comp test e))
+                                                 (-> (begin (comp statement e)
+                                                            (-> (apply (-> (lexical '%continue %continue))))))
+                                                 (@implv *undefined*))))))
+                       (-> (apply (-> (lexical '%continue %continue)))))))))
+      
+      ((for ,init ,test ,inc ,statement)
+       (let ((%continue (gensym "%continue ")))
+         (let ((e (econs '%continue %continue e)))
+           (-> (letrec '(%continue) (list %continue)
+                       (list (-> (lambda '() '() '()
+                                         (-> (if (if test
+                                                     (@impl ->boolean (comp test e))
+                                                     (comp 'true e))
+                                                 (-> (begin (comp statement e)
+                                                            (comp (or inc '(begin)) e)
+                                                            (-> (apply (-> (lexical '%continue %continue))))))
+                                                 (@implv *undefined*))))))
+                       (-> (begin (comp (or init '(begin)) e)
+                                  (-> (apply (-> (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 '() '() '()
+                                         (-> (if (@impl ->boolean
+                                                        (@impl pget
+                                                               (-> (lexical '%enum %enum))
+                                                               (-> (const 'length))))
+                                                 (-> (begin
+                                                       (comp `(= ,var (call/this ,(-> (lexical '%enum %enum))
+                                                                                 ,(-> (const 'pop))))
+                                                             e)
+                                                       (comp statement e)
+                                                       (-> (apply (-> (lexical '%continue %continue))))))
+                                                 (@implv *undefined*))))))
+                       (-> (apply (-> (lexical '%continue %continue)))))))))
+      
+      ((block ,x)
+       (comp x e))
+      (else
+       (error "compilation not yet implemented:" x)))))
+
+(define (comp-body e body formals %args)
+  (define (process)
+    (let lp ((in body) (out '()) (rvars (reverse formals)))
+      (pmatch in
+        (((var (,x) . ,morevars) . ,rest)
+         (lp `((var . ,morevars) . ,rest)
+             out
+             (if (memq x rvars) rvars (cons x rvars))))
+        (((var (,x ,y) . ,morevars) . ,rest)
+         (lp `((var . ,morevars) . ,rest)
+             `((= (ref ,x) ,y) . ,out)
+             (if (memq x rvars) 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 acons e names syms)))
+      (let ((%argv (lookup %args e)))
+        (let lp ((names names) (syms syms))
+          (if (null? names)
+              ;; fixme: here check for too many args
+              (comp out e)
+              (-> (let (list (car names)) (list (car syms))
+                       (list (-> (if (-> (apply (-> (primitive 'null?)) %argv))
+                                     (-> (@implv *undefined*))
+                                     (-> (let1 (-> (apply (-> (primitive 'car)) %argv))
+                                               (lambda (v)
+                                                 (-> (set! %argv
+                                                     (-> (apply (-> (primitive 'cdr)) %argv))))
+                                                 (-> (lexical v v))))))))
+                       (lp (cdr names) (cdr syms))))))))))
diff --git a/module/language/ecmascript/spec.scm b/module/language/ecmascript/spec.scm
index 6e9470f38..7a1ea465c 100644
--- a/module/language/ecmascript/spec.scm
+++ b/module/language/ecmascript/spec.scm
@@ -21,7 +21,7 @@
 (define-module (language ecmascript spec)
   #:use-module (system base language)
   #:use-module (language ecmascript parse)
-  #:use-module (language ecmascript compile-ghil)
+  #:use-module (language ecmascript compile-tree-il)
   #:export (ecmascript))
 
 ;;;
@@ -32,7 +32,7 @@
   #:title	"Guile ECMAScript"
   #:version	"3.0"
   #:reader	(lambda () (read-ecmascript/1 (current-input-port)))
-  #:compilers   `((ghil . ,compile-ghil))
+  #:compilers   `((tree-il . ,compile-tree-il))
   ;; a pretty-printer would be interesting.
   #:printer	write
   )
diff --git a/module/language/ecmascript/tokenize.scm b/module/language/ecmascript/tokenize.scm
index 63f180b14..1b6a7eeaf 100644
--- a/module/language/ecmascript/tokenize.scm
+++ b/module/language/ecmascript/tokenize.scm
@@ -365,7 +365,7 @@
                                                       . ,(cdar puncs))))))
                                  (lp nodes (cdr puncs))))
                            (else
-                            (lp (cons `(,(string-ref (caar puncs) 0) #f) nodes)
+                            (lp (cons (list (string-ref (caar puncs) 0) #f) nodes)
                                 puncs))))))
     (lambda (port)
       (let lp ((c (peek-char port)) (tree punc-tree) (candidate #f))