diff options
author | Andy Wingo <wingo@pobox.com> | 2009-02-19 13:55:55 +0100 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2009-02-19 13:55:55 +0100 |
commit | 131f7d6c71d0a0fe4f60b49a39efcd4f8ace6b0c (patch) | |
tree | 4ffdd807ccdcd05ad49d2da7190751fc30006bb3 /module | |
parent | 8fa6886d7af7c012c4cd17f793e5038931ffb4a0 (diff) | |
download | guile-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.am | 1 | ||||
-rw-r--r-- | module/language/ecmascript/compile-ghil.scm | 81 | ||||
-rw-r--r-- | module/language/ecmascript/impl.scm | 184 | ||||
-rw-r--r-- | module/language/ecmascript/parse.scm | 9 | ||||
-rw-r--r-- | module/language/ecmascript/tokenize.scm | 2 | ||||
-rw-r--r-- | module/language/ghil/compile-glil.scm | 6 | ||||
-rw-r--r-- | module/language/glil/compile-assembly.scm | 2 |
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) |