mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-01 04:10:18 +02:00
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.
This commit is contained in:
Andy Wingo
parent
8fa6886d7a
commit
131f7d6c71
8 changed files with 271 additions and 18 deletions
|
|
@ -64,7 +64,7 @@ VM_DEFINE_INSTRUCTION (2, break, "break", 0, 0, 0)
|
|||
NEXT;
|
||||
}
|
||||
|
||||
VM_DEFINE_INSTRUCTION (3, drop, "drop", 0, 0, 0)
|
||||
VM_DEFINE_INSTRUCTION (3, drop, "drop", 0, 1, 0)
|
||||
{
|
||||
DROP ();
|
||||
NEXT;
|
||||
|
|
@ -971,7 +971,7 @@ VM_DEFINE_INSTRUCTION (47, goto_cc, "goto/cc", 0, 1, 1)
|
|||
}
|
||||
}
|
||||
|
||||
VM_DEFINE_INSTRUCTION (48, return, "return", 0, 0, 1)
|
||||
VM_DEFINE_INSTRUCTION (48, return, "return", 0, 1, 1)
|
||||
{
|
||||
vm_return:
|
||||
EXIT_HOOK ();
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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))))))))
|
||||
|
|
|
|||
184
module/language/ecmascript/impl.scm
Normal file
184
module/language/ecmascript/impl.scm
Normal file
|
|
@ -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)))
|
||||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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))))))
|
||||
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue