diff options
author | Andy Wingo <wingo@pobox.com> | 2009-08-12 00:14:44 +0200 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2009-08-12 00:14:44 +0200 |
commit | eb1482ac464433be51716cf9a2e0516810bda571 (patch) | |
tree | cdbd8f3a8c36405d6dcc908d6fd22b84a3c8dd43 /module/language/ecmascript/compile-ghil.scm | |
parent | 6e5c02b8a3d8783e6093e8147bec169e844c4d99 (diff) | |
download | guile-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.scm | 561 |
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))))))))) |