diff options
author | Andy Wingo <wingo@pobox.com> | 2009-02-20 12:50:15 +0100 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2009-02-21 00:33:03 +0100 |
commit | e80ce73d209892bae3bea80853d9e0e16cd82ed1 (patch) | |
tree | e26c629b2b05091853793542180f79e66cde3a5c /module/language/ecmascript/impl.scm | |
parent | 8f4e84855e3d88b1dbe929683c5c4d9312986ed8 (diff) | |
download | guile-e80ce73d209892bae3bea80853d9e0e16cd82ed1.tar.gz |
implement more of the standard runtime
* module/language/Makefile.am:
* module/language/ecmascript/impl.scm:
* module/language/ecmascript/array.scm:
* module/language/ecmascript/base.scm:
* module/language/ecmascript/function.scm: Split out the runtime into
different files. Implement more of the spec's runtime.
Diffstat (limited to 'module/language/ecmascript/impl.scm')
-rw-r--r-- | module/language/ecmascript/impl.scm | 220 |
1 files changed, 8 insertions, 212 deletions
diff --git a/module/language/ecmascript/impl.scm b/module/language/ecmascript/impl.scm index b770ea668..f38a4450b 100644 --- a/module/language/ecmascript/impl.scm +++ b/module/language/ecmascript/impl.scm @@ -21,216 +21,12 @@ (define-module (language ecmascript impl) #:use-module (oop goops) - #:export (*undefined* - <js-object> - pget prop-attrs prop-has-attr? pput has-property? pdel + #:use-module (language ecmascript base) + #:use-module (language ecmascript function) + #:use-module (language ecmascript array) + #:re-export (*undefined* *this* + pget pput pdel + new-object + new + new-array)) - object->string object->number object->value/string - object->value/number object->value - - ->primitive ->boolean ->number ->integer ->int32 ->uint32 - ->uint16 ->string ->object - - new-array - new-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 ((p (if (string? p) (string->symbol p) 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 (let ((attrs (js-prop-attrs o))) - (and attrs (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) - (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)))) - -(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)))) - -(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))) - -(define-class <js-array-object> (<js-object>) - (vector #:init-value #() #:accessor js-array-vector)) - -(define-method (pget (o <js-array-object>) p) - (cond ((and (integer? p) (exact? p) (>= p 0)) - (let ((v (js-array-vector o))) - (if (< p (vector-length v)) - (vector-ref v p) - (next-method)))) - ((or (and (symbol? p) (eq? p 'length)) - (and (string? p) (string=? p "length"))) - (vector-length (js-array-vector o))) - (else (next-method)))) - -(define-method (pput (o <js-array-object>) p v) - (cond ((and (integer? p) (exact? p) (>= 0 p)) - (let ((vect (js-array-vector o))) - (if (< p (vector-length vect)) - (vector-set! vect p) - ;; Fixme: round up to powers of 2? - (let ((new (make-vector (1+ p) 0))) - (vector-move-left! vect 0 (vector-length vect) new 0) - (set! (js-array-vector o) new) - (vector-set! new p))))) - ((or (and (symbol? p) (eq? p 'length)) - (and (string? p) (string=? p "length"))) - (let ((vect (js-array-vector o))) - (let ((new (make-vector (->uint32 v) 0))) - (vector-move-left! vect 0 (min (vector-length vect) (->uint32 v)) - new 0) - (set! (js-array-vector o) new)))) - (else (next-method)))) - -(define (new-array . vals) - (let ((o (make <js-array-object>))) - (pput o 'length (length vals)) - (let ((vect (js-array-vector o))) - (let lp ((i 0) (vals vals)) - (cond ((not (null? vals)) - (vector-set! vect i (car vals)) - (lp (1+ i) (cdr vals))) - (else o)))))) - -(define (new-object . pairs) - (let ((o (make <js-object>))) - (map (lambda (pair) - (pput o (car pair) (cdr pair))) - pairs) - o)) |