summaryrefslogtreecommitdiff
path: root/module
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2009-02-19 13:55:55 +0100
committerAndy Wingo <wingo@pobox.com>2009-02-19 13:55:55 +0100
commit131f7d6c71d0a0fe4f60b49a39efcd4f8ace6b0c (patch)
tree4ffdd807ccdcd05ad49d2da7190751fc30006bb3 /module
parent8fa6886d7af7c012c4cd17f793e5038931ffb4a0 (diff)
downloadguile-131f7d6c71d0a0fe4f60b49a39efcd4f8ace6b0c.tar.gz
further ecmascript work
* libguile/vm-i-system.c (drop, return): Declare drop and return as popping one arg from the stack. * module/language/ghil/compile-glil.scm: * module/language/glil/compile-assembly.scm (make-meta): Adjust so that we declare 'drop and 'return calls as popping one arg from the stack. * module/language/ecmascript/compile-ghil.scm (comp, comp-body): Flesh out a bit more. Most significantly, scoping within functions obeys javascript semantics better, modulo bits about with() forms. * module/language/ecmascript/impl.scm: Define some runtime helper routines. * module/language/Makefile.am (SOURCES): Add impl.scm. * module/language/ecmascript/parse.scm (parse-ecmascript): Minor tweaks. * module/language/ecmascript/tokenize.scm (read-identifier): Identifiers now read as symbols, not strings.
Diffstat (limited to 'module')
-rw-r--r--module/language/Makefile.am1
-rw-r--r--module/language/ecmascript/compile-ghil.scm81
-rw-r--r--module/language/ecmascript/impl.scm184
-rw-r--r--module/language/ecmascript/parse.scm9
-rw-r--r--module/language/ecmascript/tokenize.scm2
-rw-r--r--module/language/ghil/compile-glil.scm6
-rw-r--r--module/language/glil/compile-assembly.scm2
7 files changed, 269 insertions, 16 deletions
diff --git a/module/language/Makefile.am b/module/language/Makefile.am
index de813c59d..3ef6bec1c 100644
--- a/module/language/Makefile.am
+++ b/module/language/Makefile.am
@@ -4,6 +4,7 @@ SOURCES=ghil.scm glil.scm assembly.scm \
ecmascript/tokenize.scm
ecmascript/spec.scm
ecmascript/compile-ghil.scm
+ ecmascript/impl.scm
# unfortunately, the one that we want to compile can't yet be compiled
# -- too many local vars, or something.
NOCOMP_SOURCES = ecmascript/parse.scm
diff --git a/module/language/ecmascript/compile-ghil.scm b/module/language/ecmascript/compile-ghil.scm
index deaf70805..3bd6aee13 100644
--- a/module/language/ecmascript/compile-ghil.scm
+++ b/module/language/ecmascript/compile-ghil.scm
@@ -21,6 +21,7 @@
(define-module (language ecmascript compile-ghil)
#:use-module (language ghil)
+ #:use-module (ice-9 receive)
#:use-module (system base pmatch)
#:export (compile-ghil))
@@ -37,6 +38,11 @@
(and (not (null? props))
props))))
+(define-macro (@impl e l sym . args)
+ `(make-ghil-call ,e ,l
+ (ghil-var-at-module! ,e '(language ecmascript impl) ',sym #t)
+ (list ,@(map (lambda (x) `(comp x ,e)) ,args))))
+
(define (comp x e)
(let ((l (location x)))
(pmatch x
@@ -60,21 +66,80 @@
((* ,a ,b)
(make-ghil-inline e l 'mul (list (comp a e) (comp b e))))
((ref ,id)
- (make-ghil-ref e l (ghil-var-for-ref! e (string->symbol id))))
- ((define ,id ,val)
- (make-ghil-define e l (ghil-var-define! (ghil-env-parent e) (string->symbol id))
+ (make-ghil-ref e l (ghil-var-for-ref! e id)))
+ ((var ,id ,val)
+ (make-ghil-define e l (ghil-var-define! (ghil-env-parent e) id)
(comp val e)))
((begin . ,forms)
(make-ghil-begin e l (map (lambda (x) (comp x e)) forms)))
((lambda ,formals ,body)
- (call-with-ghil-environment e formals
+ (call-with-ghil-environment e '(%args)
(lambda (env vars)
- (make-ghil-lambda env l vars #f '() (comp body env)))))
+ (make-ghil-lambda env l vars #t '()
+ (comp-body env l body formals '%args)))))
((call ,proc ,args)
(make-ghil-call e l (comp proc e) (map (lambda (x) (comp x e)) args)))
+ ((return ,expr)
+ (make-ghil-inline e l 'return (list (comp expr e))))
(else
(error "compilation not yet implemented:" x)))))
-
-
-
+(define (comp-body env loc body formals %args)
+ (define (process)
+ (let lp ((in body) (out '()) (rvars (reverse formals)))
+ (pmatch in
+ (((var ,x) . ,rest)
+ (lp rest
+ out
+ (if (memq x rvars) rvars (cons x rvars))))
+ (((var ,x ,y) . ,rest)
+ (lp rest
+ `((= (ref ,x) ,y) . ,out)
+ (if (memq x rvars) rvars (cons x 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 env (reverse rvars)
+ (lambda (vars)
+ (let ((%argv (assq-ref (ghil-env-table env) %args)))
+ (make-ghil-begin
+ env loc
+ `(,@(map (lambda (f)
+ (make-ghil-if
+ env loc
+ (make-ghil-inline
+ env loc 'null?
+ (list (make-ghil-ref env loc %argv)))
+ (make-ghil-begin env loc '())
+ (make-ghil-begin
+ env loc
+ (list (make-ghil-set
+ env loc
+ (ghil-var-for-ref! env f)
+ (make-ghil-inline
+ env loc 'car
+ (list (make-ghil-ref env loc %argv))))
+ (make-ghil-set
+ env loc %argv
+ (make-ghil-inline
+ env loc 'cdr
+ (list (make-ghil-ref env loc %argv))))))))
+ formals)
+ ;; fixme: here check for too many args
+ ,(comp out env))))))))
diff --git a/module/language/ecmascript/impl.scm b/module/language/ecmascript/impl.scm
new file mode 100644
index 000000000..7823ad119
--- /dev/null
+++ b/module/language/ecmascript/impl.scm
@@ -0,0 +1,184 @@
+;;; ECMAScript for Guile
+
+;; Copyright (C) 2009 Free Software Foundation, Inc.
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;;
+;; This program 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 General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this program; see the file COPYING. If not, write to
+;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Code:
+
+(define-module (language ecmascript impl)
+ #:use-modules (oop goops)
+ #:export (*undefined*
+ <js-object>
+ pget prop-attrs prop-has-attr? pput has-property? pdel
+
+ object->string object->number object->value/string
+ object->value/number object->value
+
+ ->primitive ->boolean ->number ->integer ->int32 ->uint32
+ ->uint16 ->string ->object))
+
+(define *undefined* ((@@ (oop goops) make-unbound)))
+
+(define NaN +nan.0)
+(define Infinity +inf.0)
+
+(define-class <js-object> ()
+ (prototype #:getter js-prototype #:init-keyword #:prototype
+ #:init-value #f)
+ (props #:getter js-props #:init-form (make-hash-table 7))
+ (prop-attrs #:getter js-prop-attrs #:init-value #f)
+ (value #:getter js-value #:init-value #f #:init-keyword #:value))
+
+(define-method (pget (o <js-object>) p)
+ (let ((h (hashq-get-handle (js-props o) p)))
+ (if h
+ (cdr h)
+ (let ((proto (js-prototype o)))
+ (if proto
+ (pget proto p)
+ *undefined*)))))
+
+(define-method (prop-attrs (o <js-object>) p)
+ (or (hashq-ref (js-prop-attrs o) p)
+ (let ((proto (js-prototype o)))
+ (if proto
+ (prop-attrs proto p)
+ '()))))
+
+(define-method (prop-has-attr? (o <js-object>) p attr)
+ (memq attr (prop-attrs o p)))
+
+(define-method (pput (o <js-object>) p v)
+ (if (prop-has-attr? o p 'ReadOnly)
+ (throw 'ReferenceError o p)
+ (hashq-set! (js-props o) p v)))
+
+(define-method (has-property? (o <js-object>) p v)
+ (if (prop-has-attr? o p 'ReadOnly)
+ (throw 'ReferenceError o p)
+ (hashq-set! (js-props o) p v)))
+
+(define-method (pdel (o <js-object>) p)
+ (if (prop-has-attr? o p 'DontDelete)
+ #f
+ (begin
+ (pput o p *undefined*)
+ #t)))
+
+(define (object->string o error?)
+ (let ((toString (pget o 'toString)))
+ (if (procedure? toString)
+ (let ((x (toString o)))
+ (if (and error? (is-a? x <js-object>))
+ (throw 'TypeError o 'default-value)
+ x))
+ (if error?
+ (throw 'TypeError o 'default-value)
+ o))))
+
+(define (object->number o error?)
+ (let ((valueOf (pget o 'valueOf)))
+ (if (procedure? valueOf)
+ (let ((x (valueOf o)))
+ (if (and error? (is-a? x <js-object>))
+ (throw 'TypeError o 'default-value)
+ x))
+ (if error?
+ (throw 'TypeError o 'default-value)
+ o))))
+
+(define (object->value/string o)
+ (let ((v (object->string o #f)))
+ (if (is-a? x <js-object>)
+ (object->number o #t)
+ x)))
+
+(define (object->value/number o)
+ (let ((v (object->number o #f)))
+ (if (is-a? x <js-object>)
+ (object->string o #t)
+ x)))
+
+(define (object->value o)
+ ;; FIXME: if it's a date, we should try numbers first
+ (object->value/string o))
+
+(define (->primitive x)
+ (if (is-a? x <js-object>)
+ (object->value x)
+ x))
+
+(define (->boolean x)
+ (not (or (not x) (null? x) (eq? x *undefined*) (zero? x) (nan? x)
+ (and (string? x) (= (string-length x) 0)))))
+
+(define (->number x)
+ (cond ((number? x) x)
+ ((boolean? x) (if x 1 0))
+ ((null? x) 0)
+ ((eq? x *undefined*) +nan.0)
+ ((is-a? x <js-object>) (object->number o))
+ ((string? x) (string->number x))
+ (else (throw 'TypeError o '->number))))
+
+(define (->integer x)
+ (let ((n (->number x)))
+ (cond ((nan? n) 0)
+ ((zero? n) n)
+ ((inf? n) n)
+ (else (inexact->exact (round n))))))
+
+(define (->int32 x)
+ (let ((n (->number x)))
+ (if (or (nan? n) (zero? n) (inf? n))
+ 0
+ (let ((m (logand (1- (ash 1 32)) (inexact->exact (round n)))))
+ (if (negative? n)
+ (- m (ash 1 32))
+ m)))))
+
+(define (->uint32 x)
+ (let ((n (->number x)))
+ (if (or (nan? n) (zero? n) (inf? n))
+ 0
+ (logand (1- (ash 1 32)) (inexact->exact (round n))))))
+
+(define (->uint16 x)
+ (let ((n (->number x)))
+ (if (or (nan? n) (zero? n) (inf? n))
+ 0
+ (logand (1- (ash 1 16)) (inexact->exact (round n))))))
+
+(define (->string x)
+ (cond ((eq? x *undefined*) "undefined")
+ ((null? x) "null")
+ ((boolean? x) (if x "true" "false"))
+ ((string? x) x)
+ ((number? x)
+ (cond ((nan? x) "NaN")
+ ((zero? x) "0")
+ ((inf? x) "Infinity")
+ (else (number->string x))))
+ (else (->string (object->value/string x)))))
+
+(define (->object x)
+ (cond ((eq? x *undefined*) (throw 'TypeError x '->object))
+ ((null? x) (throw 'TypeError x '->object))
+ ((boolean? x) (make <js-object> #:prototype Boolean #:value x))
+ ((number? x) (make <js-object> #:prototype String #:value x))
+ ((string? x) (make <js-object> #:prototype Number #:value x))
+ (else x)))
diff --git a/module/language/ecmascript/parse.scm b/module/language/ecmascript/parse.scm
index 0632b6d87..b11de0e1d 100644
--- a/module/language/ecmascript/parse.scm
+++ b/module/language/ecmascript/parse.scm
@@ -30,6 +30,9 @@
(define (read-ecmascript/1 port)
(parse-ecmascript (make-tokenizer/1 port) pk))
+(define *eof-object*
+ (call-with-input-string "" read-char))
+
(define parse-ecmascript
(lalr-parser
;; terminal (i.e. input) token types
@@ -45,7 +48,7 @@
(Program (SourceElements) -> $1
- (*eoi*) -> (call-with-input-string "" read-char))
+ (*eoi*) -> *eof-object*)
;;
;; Verily, here we define statements. Expressions are defined
@@ -55,8 +58,8 @@
(SourceElement (Statement) -> $1
(FunctionDeclaration) -> $1)
- (FunctionDeclaration (function Identifier lparen rparen lbrace FunctionBody rbrace) -> `(define ,$2 (lambda () ,$6))
- (function Identifier lparen FormalParameterList rparen lbrace FunctionBody rbrace) -> `(define ,$2 (lambda ,$4 ,$7)))
+ (FunctionDeclaration (function Identifier lparen rparen lbrace FunctionBody rbrace) -> `(var ,$2 (lambda () ,$6))
+ (function Identifier lparen FormalParameterList rparen lbrace FunctionBody rbrace) -> `(var ,$2 (lambda ,$4 ,$7)))
(FunctionExpression (function lparen rparen lbrace FunctionBody rbrace) -> `(lambda () ,$5)
(function Identifier lparen rparen lbrace FunctionBody rbrace) -> `(lambda () ,$6)
(function lparen FormalParameterList rparen lbrace FunctionBody rbrace) -> `(lambda ,$3 ,$6)
diff --git a/module/language/ecmascript/tokenize.scm b/module/language/ecmascript/tokenize.scm
index 7a716e0d6..936b304d0 100644
--- a/module/language/ecmascript/tokenize.scm
+++ b/module/language/ecmascript/tokenize.scm
@@ -225,7 +225,7 @@
=> (lambda (x) `(,x . #f)))
((assoc-ref *future-reserved-words* word)
(error "word is reserved for the future, dude." word))
- (else `(Identifier . ,word))))
+ (else `(Identifier . ,(string->symbol word)))))
(begin (read-char port)
(lp (peek-char port) (cons c chars))))))
diff --git a/module/language/ghil/compile-glil.scm b/module/language/ghil/compile-glil.scm
index de8d27c07..3e589bad4 100644
--- a/module/language/ghil/compile-glil.scm
+++ b/module/language/ghil/compile-glil.scm
@@ -107,8 +107,8 @@
;;;
(define *ia-void* (make-glil-void))
-(define *ia-drop* (make-glil-call 'drop 0))
-(define *ia-return* (make-glil-call 'return 0))
+(define *ia-drop* (make-glil-call 'drop 1))
+(define *ia-return* (make-glil-call 'return 1))
(define (make-label) (gensym ":L"))
@@ -299,7 +299,7 @@
(push-call! #f 'dup '()))
(push-branch! #f 'br-if L1)
(if (not drop)
- (push-call! #f 'drop '()))
+ (push-code! loc (make-glil-call 'drop 1)))
(lp (cdr exps)))))))))
((<ghil-begin> env loc exps)
diff --git a/module/language/glil/compile-assembly.scm b/module/language/glil/compile-assembly.scm
index 1b1d2dfba..91e6519cb 100644
--- a/module/language/glil/compile-assembly.scm
+++ b/module/language/glil/compile-assembly.scm
@@ -75,7 +75,7 @@
(make-glil-program 0 0 0 0 '()
(list
(make-glil-const `(,bindings ,sources ,@tail))
- (make-glil-call 'return 0))))))
+ (make-glil-call 'return 1))))))
;; A functional stack of names of live variables.
(define (make-open-binding name ext? index)