summaryrefslogtreecommitdiff
path: root/module/language/ecmascript/base.scm
diff options
context:
space:
mode:
Diffstat (limited to 'module/language/ecmascript/base.scm')
-rw-r--r--module/language/ecmascript/base.scm251
1 files changed, 251 insertions, 0 deletions
diff --git a/module/language/ecmascript/base.scm b/module/language/ecmascript/base.scm
new file mode 100644
index 000000000..fa6c85a33
--- /dev/null
+++ b/module/language/ecmascript/base.scm
@@ -0,0 +1,251 @@
+;;; ECMAScript for Guile
+
+;; Copyright (C) 2009, 2013, 2015 Free Software Foundation, Inc.
+
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library 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
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Code:
+
+(define-module (language ecmascript base)
+ #:use-module (oop goops)
+ #:export (*undefined* *this*
+ <js-object> *object-prototype*
+ js-prototype js-props js-prop-attrs js-value js-constructor js-class
+ pget prop-keys 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
+
+ call/this* call/this lambda/this define-js-method
+
+ new-object new))
+
+(define-class <undefined> ())
+
+(define *undefined* (make <undefined>))
+(define *this* (make-fluid))
+
+(define-class <js-object> ()
+ (prototype #:getter js-prototype #:init-keyword #:prototype
+ #:init-thunk (lambda () *object-prototype*))
+ (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)
+ (constructor #:getter js-constructor #:init-value #f #:init-keyword #:constructor)
+ (class #:getter js-class #:init-value "Object" #:init-keyword #:class))
+
+(define-method (prop-keys (o <js-object>))
+ (hash-map->list (lambda (k v) k) (js-props o)))
+
+(define-method (pget (o <js-object>) (p <string>))
+ (pget o (string->symbol p)))
+
+(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 (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)
+ (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)
+ (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)))
+
+(define-method (has-property? (o <js-object>) p)
+ (if (hashq-get-handle (js-props o) p)
+ #t
+ (let ((proto (js-prototype o)))
+ (if proto
+ (has-property? proto p)
+ #f))))
+
+(define (call/this* this f)
+ (with-fluid* *this* this f))
+
+(define-macro (call/this this f . args)
+ `(with-fluid* *this* ,this (lambda () (,f . ,args))))
+(define-macro (lambda/this formals . body)
+ `(lambda ,formals (let ((this (fluid-ref *this*))) . ,body)))
+(define-macro (define-js-method object name-and-args . body)
+ `(pput ,object ',(car name-and-args) (lambda/this ,(cdr name-and-args) . ,body)))
+
+(define *object-prototype* #f)
+(set! *object-prototype* (make <js-object>))
+
+(define-js-method *object-prototype* (toString)
+ (format #f "[object ~A]" (js-class this)))
+(define-js-method *object-prototype* (toLocaleString . args)
+ ((pget *object-prototype* 'toString)))
+(define-js-method *object-prototype* (valueOf)
+ this)
+(define-js-method *object-prototype* (hasOwnProperty p)
+ (and (hashq-get-handle (js-props this) p) #t))
+(define-js-method *object-prototype* (isPrototypeOf v)
+ (eq? this (js-prototype v)))
+(define-js-method *object-prototype* (propertyIsEnumerable p)
+ (and (hashq-get-handle (js-props this) p)
+ (not (prop-has-attr? this p 'DontEnum))))
+
+(define (object->string o error?)
+ (let ((toString (pget o 'toString)))
+ (if (procedure? toString)
+ (let ((x (call/this o toString)))
+ (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 (call/this o valueOf)))
+ (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)
+ (if (is-a? o <js-object>)
+ (object->number o #t)
+ o))
+
+(define (object->value/number o)
+ (if (is-a? o <js-object>)
+ (object->string o #t)
+ o))
+
+(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*)
+ (and (number? x) (or (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 x #t))
+ ((string? x) (string->number x))
+ (else (throw 'TypeError x '->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 (new-object . pairs)
+ (let ((o (make <js-object>)))
+ (map (lambda (pair)
+ (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))))))