diff options
-rw-r--r-- | module/language/ecmascript/array.scm | 3 | ||||
-rw-r--r-- | module/language/ecmascript/base.scm | 32 | ||||
-rw-r--r-- | module/language/ecmascript/compile-ghil.scm | 27 | ||||
-rw-r--r-- | module/language/ecmascript/function.scm | 14 | ||||
-rw-r--r-- | module/language/ecmascript/impl.scm | 52 | ||||
-rw-r--r-- | module/language/ecmascript/parse.scm | 2 |
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) |