summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--module/language/ecmascript/array.scm3
-rw-r--r--module/language/ecmascript/base.scm32
-rw-r--r--module/language/ecmascript/compile-ghil.scm27
-rw-r--r--module/language/ecmascript/function.scm14
-rw-r--r--module/language/ecmascript/impl.scm52
-rw-r--r--module/language/ecmascript/parse.scm2
6 files changed, 96 insertions, 34 deletions
diff --git a/module/language/ecmascript/array.scm b/module/language/ecmascript/array.scm
index 8863b7fa4..a9f499a22 100644
--- a/module/language/ecmascript/array.scm
+++ b/module/language/ecmascript/array.scm
@@ -41,7 +41,8 @@
(else o))))))
(define *array-prototype* (make <js-object> #:class "Array"
- #:value new-array))
+ #:value new-array
+ #:constructor new-array))
(hashq-set! *program-wrappers* new-array *array-prototype*)
diff --git a/module/language/ecmascript/base.scm b/module/language/ecmascript/base.scm
index 7e22bbec4..b799067df 100644
--- a/module/language/ecmascript/base.scm
+++ b/module/language/ecmascript/base.scm
@@ -34,7 +34,7 @@
call/this* call/this lambda/this define-js-method
- new-object))
+ new-object new))
(define *undefined* ((@@ (oop goops) make-unbound)))
(define *this* (make-fluid))
@@ -72,21 +72,19 @@
(memq attr (prop-attrs o p)))
(define-method (pput (o <js-object>) p v)
- (let ((p (if (string? p) (string->symbol p) p)))
- (if (prop-has-attr? o p 'ReadOnly)
- (throw 'ReferenceError o p)
- (hashq-set! (js-props o) p v))))
+ (if (prop-has-attr? o p 'ReadOnly)
+ (throw 'ReferenceError o p)
+ (hashq-set! (js-props o) p v)))
(define-method (pput (o <js-object>) (p <string>) v)
(pput o (string->symbol p) v))
(define-method (pdel (o <js-object>) p)
- (let ((p (if (string? p) (string->symbol p) p)))
- (if (prop-has-attr? o p 'DontDelete)
- #f
- (begin
- (pput o p *undefined*)
- #t))))
+ (if (prop-has-attr? o p 'DontDelete)
+ #f
+ (begin
+ (pput o p *undefined*)
+ #t)))
(define-method (pdel (o <js-object>) (p <string>) v)
(pdel o (string->symbol p)))
@@ -236,3 +234,15 @@
(pput o (car pair) (cdr pair)))
pairs)
o))
+(slot-set! *object-prototype* 'constructor new-object)
+
+(define-method (new o . initargs)
+ (let ((ctor (js-constructor o)))
+ (if (not ctor)
+ (throw 'TypeError 'new o)
+ (let ((o (make <js-object>
+ #:prototype (or (js-prototype o) *object-prototype*))))
+ (let ((new-o (call/this o apply ctor initargs)))
+ (if (is-a? new-o <js-object>)
+ new-o
+ o))))))
diff --git a/module/language/ecmascript/compile-ghil.scm b/module/language/ecmascript/compile-ghil.scm
index a1aa11a68..1d1a94c69 100644
--- a/module/language/ecmascript/compile-ghil.scm
+++ b/module/language/ecmascript/compile-ghil.scm
@@ -25,12 +25,23 @@
#:use-module (system base pmatch)
#:export (compile-ghil))
+(define-macro (@implv e l sym)
+ `(make-ghil-ref ,e ,l
+ (ghil-var-at-module! ,e '(language ecmascript impl) ',sym #t)))
+(define-macro (@impl e l sym args)
+ `(make-ghil-call ,e ,l
+ (@implv ,e ,l ,sym)
+ ,args))
+
(define (compile-ghil exp env opts)
(values
- (call-with-ghil-environment (make-ghil-toplevel-env) '()
- (lambda (env vars)
- (make-ghil-lambda env #f vars #f '() (comp exp env))))
- env))
+ (call-with-ghil-environment (make-ghil-toplevel-env) '()
+ (lambda (env vars)
+ (make-ghil-lambda env #f vars #f '()
+ (make-ghil-begin env #f
+ (list (@impl env #f js-init '())
+ (comp exp env))))))
+ env))
(define (location x)
(and (pair? x)
@@ -38,14 +49,6 @@
(and (not (null? props))
props))))
-(define-macro (@implv e l sym)
- `(make-ghil-ref ,e ,l
- (ghil-var-at-module! ,e '(language ecmascript impl) ',sym #t)))
-(define-macro (@impl e l sym args)
- `(make-ghil-call ,e ,l
- (@implv ,e ,l ,sym)
- ,args))
-
;; The purpose, you ask? To avoid non-tail recursion when expanding a
;; long pmatch sequence.
(define-macro (ormatch x . clauses)
diff --git a/module/language/ecmascript/function.scm b/module/language/ecmascript/function.scm
index cb85ef60d..1e2d726ca 100644
--- a/module/language/ecmascript/function.scm
+++ b/module/language/ecmascript/function.scm
@@ -22,7 +22,7 @@
(define-module (language ecmascript function)
#:use-module (oop goops)
#:use-module (language ecmascript base)
- #:export (*function-prototype* *program-wrappers* new))
+ #:export (*function-prototype* *program-wrappers*))
(define-class <js-program-wrapper> (<js-object>))
@@ -72,10 +72,8 @@
(js-prototype wrapper)
#f)))
-(define-method (new (f <applicable>) . initargs)
- (let ((o (make <js-object>
- #:prototype (or (js-prototype f) *object-prototype*))))
- (let ((new-o (with-fluid *this* o (lambda () (apply f initargs)))))
- (if (is-a? new-o <js-object>)
- new-o
- o))))
+(define-method (js-constructor (o <applicable>))
+ (let ((wrapper (hashq-ref *program-wrappers* o)))
+ (if wrapper
+ (js-constructor wrapper)
+ #f)))
diff --git a/module/language/ecmascript/impl.scm b/module/language/ecmascript/impl.scm
index d4b936c6c..737639fd4 100644
--- a/module/language/ecmascript/impl.scm
+++ b/module/language/ecmascript/impl.scm
@@ -28,7 +28,7 @@
pget pput pdel has-property?
->boolean
new-object new new-array)
- #:export (get-this
+ #:export (js-init get-this
typeof
bitwise-not logical-not
shift
@@ -36,6 +36,44 @@
band bxor bior))
+(define-class <js-global-object> (<js-object>))
+(define-method (pget (o <js-global-object>) (p <string>))
+ (pget o (string->symbol p)))
+(define-method (pget (o <js-global-object>) (p <symbol>))
+ (let ((v (module-variable (current-module) p)))
+ (if v
+ (variable-ref v)
+ (next-method))))
+(define-method (pput (o <js-global-object>) (p <string>) v)
+ (pput o (string->symbol p) v))
+(define-method (pput (o <js-global-object>) (p <symbol>) v)
+ (module-define! (current-module) p v))
+(define-method (prop-attrs (o <js-global-object>) (p <symbol>))
+ (cond ((module-local-variable (current-module) p)
+ '())
+ ((module-variable (current-module) p)
+ '(DontDelete ReadOnly))
+ (else (next-method))))
+(define-method (prop-attrs (o <js-global-object>) (p <string>))
+ (prop-attrs o (string->symbol p)))
+
+(define (init-js-bindings! mod)
+ (module-define! mod 'NaN +nan.0)
+ (module-define! mod 'Infinity +inf.0)
+ (module-define! mod 'undefined *undefined*)
+ ;; isNAN, isFinite, parseFloat, parseInt, eval
+ ;; decodeURI, decodeURIComponent, encodeURI, encodeURIComponent
+ ;; Object Function Array String Boolean Number Date RegExp Error EvalError
+ ;; RangeError ReferenceError SyntaxError TypeError URIError
+ (module-define! mod 'Object *object-prototype*)
+ (module-define! mod 'Array *array-prototype*))
+
+(define (js-init)
+ (cond ((get-this))
+ (else
+ (fluid-set! *this* (make <js-global-object>))
+ (init-js-bindings! (current-module)))))
+
(define (get-this)
(fluid-ref *this*))
@@ -60,3 +98,15 @@
(define bior logior)
(define mod modulo)
+
+(define-method (+ (a <string>) (b <string>))
+ (string-append a b))
+
+(define-method (+ (a <string>) b)
+ (string-append a (->string b)))
+
+(define-method (+ a (b <string>))
+ (string-append (->string a) b))
+
+(define-method (+ a b)
+ (+ (->number a) (->number b)))
diff --git a/module/language/ecmascript/parse.scm b/module/language/ecmascript/parse.scm
index 4603f6235..86b7176fc 100644
--- a/module/language/ecmascript/parse.scm
+++ b/module/language/ecmascript/parse.scm
@@ -212,7 +212,7 @@
(new MemberExpression Arguments) -> `(new ,$2 ,$3))
(NewExpression (MemberExpression) -> $1
- (new NewExpression) -> `(new ,$2))
+ (new NewExpression) -> `(new ,$2 ()))
(CallExpression (MemberExpression Arguments) -> `(call ,$1 ,$2)
(CallExpression Arguments) -> `(call ,$1 ,$2)