[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, master, updated. release_1-9-1-55-geb1
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] GNU Guile branch, master, updated. release_1-9-1-55-geb1482a |
|
Date: |
Tue, 11 Aug 2009 22:14:26 +0000 |
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".
http://git.savannah.gnu.org/cgit/guile.git/commit/?id=eb1482ac464433be51716cf9a2e0516810bda571
The branch, master has been updated
via eb1482ac464433be51716cf9a2e0516810bda571 (commit)
from 6e5c02b8a3d8783e6093e8147bec169e844c4d99 (commit)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit eb1482ac464433be51716cf9a2e0516810bda571
Author: Andy Wingo <address@hidden>
Date: Wed Aug 12 00:14:44 2009 +0200
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.
-----------------------------------------------------------------------
Summary of changes:
module/Makefile.am | 2 +-
module/language/ecmascript/compile-ghil.scm | 561 ------------------------
module/language/ecmascript/compile-tree-il.scm | 549 +++++++++++++++++++++++
module/language/ecmascript/spec.scm | 4 +-
module/language/ecmascript/tokenize.scm | 2 +-
5 files changed, 553 insertions(+), 565 deletions(-)
delete mode 100644 module/language/ecmascript/compile-ghil.scm
create mode 100644 module/language/ecmascript/compile-tree-il.scm
diff --git a/module/Makefile.am b/module/Makefile.am
index 5eec063..5ef00be 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 ab04ba8..0000000
--- 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 0000000..88f3db7
--- /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 6e9470f..7a1ea46 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 63f180b..1b6a7ee 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))
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, master, updated. release_1-9-1-55-geb1482a,
Andy Wingo <=