summaryrefslogtreecommitdiff
path: root/module/language/ecmascript/compile-ghil.scm
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2009-08-12 00:14:44 +0200
committerAndy Wingo <wingo@pobox.com>2009-08-12 00:14:44 +0200
commiteb1482ac464433be51716cf9a2e0516810bda571 (patch)
treecdbd8f3a8c36405d6dcc908d6fd22b84a3c8dd43 /module/language/ecmascript/compile-ghil.scm
parent6e5c02b8a3d8783e6093e8147bec169e844c4d99 (diff)
downloadguile-eb1482ac464433be51716cf9a2e0516810bda571.tar.gz
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.
Diffstat (limited to 'module/language/ecmascript/compile-ghil.scm')
-rw-r--r--module/language/ecmascript/compile-ghil.scm561
1 files changed, 0 insertions, 561 deletions
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)))))))))