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-tree-il.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-tree-il.scm')
-rw-r--r-- | module/language/ecmascript/compile-tree-il.scm | 549 |
1 files changed, 549 insertions, 0 deletions
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)))))))))) |