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 | |
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')
-rw-r--r-- | module/language/ecmascript/compile-ghil.scm | 561 | ||||
-rw-r--r-- | module/language/ecmascript/compile-tree-il.scm | 549 | ||||
-rw-r--r-- | module/language/ecmascript/spec.scm | 4 | ||||
-rw-r--r-- | module/language/ecmascript/tokenize.scm | 2 |
4 files changed, 552 insertions, 564 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))))))))) 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)) |