mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-02 21:10:27 +02:00
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.
This commit is contained in:
parent
8f4e84855e
commit
e80ce73d20
5 changed files with 435 additions and 216 deletions
|
@ -1,10 +1,13 @@
|
||||||
SUBDIRS=scheme ghil glil assembly bytecode objcode value
|
SUBDIRS=scheme ghil glil assembly bytecode objcode value
|
||||||
SOURCES=ghil.scm glil.scm assembly.scm \
|
SOURCES=ghil.scm glil.scm assembly.scm \
|
||||||
ecmascript/parse-lalr.scm \
|
ecmascript/parse-lalr.scm \
|
||||||
ecmascript/tokenize.scm
|
ecmascript/tokenize.scm \
|
||||||
ecmascript/spec.scm
|
ecmascript/spec.scm \
|
||||||
ecmascript/compile-ghil.scm
|
ecmascript/compile-ghil.scm \
|
||||||
ecmascript/impl.scm
|
ecmascript/impl.scm \
|
||||||
|
ecmascript/base.scm \
|
||||||
|
ecmascript/function.scm \
|
||||||
|
ecmascript/array.scm
|
||||||
# unfortunately, the one that we want to compile can't yet be compiled
|
# unfortunately, the one that we want to compile can't yet be compiled
|
||||||
# -- too many local vars, or something.
|
# -- too many local vars, or something.
|
||||||
NOCOMP_SOURCES = ecmascript/parse.scm
|
NOCOMP_SOURCES = ecmascript/parse.scm
|
||||||
|
|
121
module/language/ecmascript/array.scm
Normal file
121
module/language/ecmascript/array.scm
Normal file
|
@ -0,0 +1,121 @@
|
||||||
|
;;; 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 array)
|
||||||
|
#:use-module (oop goops)
|
||||||
|
#:use-module (language ecmascript base)
|
||||||
|
#:use-module (language ecmascript function)
|
||||||
|
#:export (*array-prototype* new-array))
|
||||||
|
|
||||||
|
|
||||||
|
(define-class <js-array-object> (<js-object>)
|
||||||
|
(vector #:init-value #() #:accessor js-array-vector #:init-keyword #:vector))
|
||||||
|
|
||||||
|
(define (new-array . vals)
|
||||||
|
(let ((o (make <js-array-object> #:class "Array"
|
||||||
|
#:prototype *array-prototype*)))
|
||||||
|
(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 *array-prototype* (make <js-object> #:class "Array"
|
||||||
|
#:value new-array))
|
||||||
|
|
||||||
|
(hashq-set! *program-wrappers* new-array *array-prototype*)
|
||||||
|
|
||||||
|
(pput *array-prototype* 'prototype *array-prototype*)
|
||||||
|
(pput *array-prototype* 'constructor new-array)
|
||||||
|
|
||||||
|
(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-js-method *array-prototype* (toString)
|
||||||
|
(format #f "~A" (js-array-vector this)))
|
||||||
|
|
||||||
|
(define-js-method *array-prototype* (concat . rest)
|
||||||
|
(let* ((len (apply + (->uint32 (pget this 'length))
|
||||||
|
(map (lambda (x) (->uint32 (pget x 'length)))
|
||||||
|
rest)))
|
||||||
|
(rv (make-vector len 0)))
|
||||||
|
(let lp ((objs (cons this rest)) (i 0))
|
||||||
|
(cond ((null? objs) (make <js-array-object> #:class "Array"
|
||||||
|
#:prototype *array-prototype*
|
||||||
|
#:vector rv))
|
||||||
|
((is-a? (car objs) <js-array-object>)
|
||||||
|
(let ((v (js-array-vector (car objs))))
|
||||||
|
(vector-move-left! v 0 (vector-length v)
|
||||||
|
rv i (+ i (vector-length v)))
|
||||||
|
(lp (cdr objs) (+ i (vector-length v)))))
|
||||||
|
(else
|
||||||
|
(error "generic array concats not yet implemented"))))))
|
||||||
|
|
||||||
|
(define-js-method *array-prototype* (join . separator)
|
||||||
|
(let lp ((i (1- (->uint32 (pget this 'length)))) (l '()))
|
||||||
|
(if (< i 0)
|
||||||
|
(string-join l (if separator (->string (car separator)) ","))
|
||||||
|
(lp (1+ i)
|
||||||
|
(cons (->string (pget this i)) l)))))
|
||||||
|
|
||||||
|
(define-js-method *array-prototype* (pop)
|
||||||
|
(let ((len (->uint32 (pget this 'length))))
|
||||||
|
(if (zero? len)
|
||||||
|
*undefined*
|
||||||
|
(let ((ret (pget this (1- len))))
|
||||||
|
(pput this 'length (1- len))
|
||||||
|
ret))))
|
||||||
|
|
||||||
|
(define-js-method *array-prototype* (push . args)
|
||||||
|
(let lp ((args args))
|
||||||
|
(if (null? args)
|
||||||
|
(->uint32 (pget this 'length))
|
||||||
|
(begin (pput this (->uint32 (pget this 'length)) (car args))
|
||||||
|
(lp (cdr args))))))
|
218
module/language/ecmascript/base.scm
Normal file
218
module/language/ecmascript/base.scm
Normal file
|
@ -0,0 +1,218 @@
|
||||||
|
;;; 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 base)
|
||||||
|
#:use-module (oop goops)
|
||||||
|
#:export (*undefined* *this*
|
||||||
|
<js-object> *object-prototype*
|
||||||
|
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
|
||||||
|
|
||||||
|
call/this lambda/this define-js-method
|
||||||
|
|
||||||
|
new-object))
|
||||||
|
|
||||||
|
(define *undefined* ((@@ (oop goops) make-unbound)))
|
||||||
|
(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 (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-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)
|
||||||
|
(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 (new-object . pairs)
|
||||||
|
(let ((o (make <js-object>)))
|
||||||
|
(map (lambda (pair)
|
||||||
|
(pput o (car pair) (cdr pair)))
|
||||||
|
pairs)
|
||||||
|
o))
|
81
module/language/ecmascript/function.scm
Normal file
81
module/language/ecmascript/function.scm
Normal file
|
@ -0,0 +1,81 @@
|
||||||
|
;;; 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 function)
|
||||||
|
#:use-module (oop goops)
|
||||||
|
#:use-module (language ecmascript base)
|
||||||
|
#:export (*function-prototype* *program-wrappers* new))
|
||||||
|
|
||||||
|
|
||||||
|
(define-class <js-program-wrapper> (<js-object>))
|
||||||
|
|
||||||
|
(define *program-wrappers* (make-doubly-weak-hash-table 31))
|
||||||
|
|
||||||
|
(define *function-prototype* (make <js-object> #:class "Function"
|
||||||
|
#:value (lambda args *undefined*)))
|
||||||
|
|
||||||
|
(define-js-method *function-prototype* (toString)
|
||||||
|
(format #f "~A" (js-value this)))
|
||||||
|
|
||||||
|
(define-js-method *function-prototype* (apply this-arg array)
|
||||||
|
(cond ((or (null? array) (eq? array *undefined*))
|
||||||
|
(call/this this-arg (js-value this)))
|
||||||
|
((is-a? array <js-array-object>)
|
||||||
|
(call/this this-arg
|
||||||
|
(lambda ()
|
||||||
|
(apply (js-value this)
|
||||||
|
(vector->list (js-array-vector array))))))
|
||||||
|
(else
|
||||||
|
(throw 'TypeError 'apply array))))
|
||||||
|
|
||||||
|
(define-js-method *function-prototype* (call this-arg . args)
|
||||||
|
(call/this this-arg
|
||||||
|
(lambda ()
|
||||||
|
(apply (js-value this) args))))
|
||||||
|
|
||||||
|
(define-method (pget (o <applicable>) p)
|
||||||
|
(let ((wrapper (hashq-ref *program-wrappers* o)))
|
||||||
|
(if wrapper
|
||||||
|
(pget wrapper p)
|
||||||
|
(pget *function-prototype* p))))
|
||||||
|
|
||||||
|
(define-method (pput (o <applicable>) p v)
|
||||||
|
(let ((wrapper (hashq-ref *program-wrappers* o)))
|
||||||
|
(if wrapper
|
||||||
|
(pput wrapper p v)
|
||||||
|
(let ((wrapper (make <js-program-wrapper> #:value o #:class "Function"
|
||||||
|
#:prototype *function-prototype*)))
|
||||||
|
(hashq-set! *program-wrappers* o wrapper)
|
||||||
|
(pput wrapper p v)))))
|
||||||
|
|
||||||
|
(define-method (js-prototype (o <applicable>))
|
||||||
|
(let ((wrapper (hashq-ref *program-wrappers* o)))
|
||||||
|
(if wrapper
|
||||||
|
(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))))
|
|
@ -21,216 +21,12 @@
|
||||||
|
|
||||||
(define-module (language ecmascript impl)
|
(define-module (language ecmascript impl)
|
||||||
#:use-module (oop goops)
|
#:use-module (oop goops)
|
||||||
#:export (*undefined*
|
#:use-module (language ecmascript base)
|
||||||
<js-object>
|
#:use-module (language ecmascript function)
|
||||||
pget prop-attrs prop-has-attr? pput has-property? pdel
|
#: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))
|
|
||||||
|
|
Loading…
Add table
Add a link
Reference in a new issue