diff --git a/module/language/Makefile.am b/module/language/Makefile.am index 3ef6bec1c..6e2bd92a9 100644 --- a/module/language/Makefile.am +++ b/module/language/Makefile.am @@ -1,10 +1,13 @@ SUBDIRS=scheme ghil glil assembly bytecode objcode value SOURCES=ghil.scm glil.scm assembly.scm \ ecmascript/parse-lalr.scm \ - ecmascript/tokenize.scm - ecmascript/spec.scm - ecmascript/compile-ghil.scm - ecmascript/impl.scm + ecmascript/tokenize.scm \ + ecmascript/spec.scm \ + ecmascript/compile-ghil.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 # -- too many local vars, or something. NOCOMP_SOURCES = ecmascript/parse.scm diff --git a/module/language/ecmascript/array.scm b/module/language/ecmascript/array.scm new file mode 100644 index 000000000..8863b7fa4 --- /dev/null +++ b/module/language/ecmascript/array.scm @@ -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 () + (vector #:init-value #() #:accessor js-array-vector #:init-keyword #:vector)) + +(define (new-array . vals) + (let ((o (make #: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 #: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 ) 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 ) 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 #:class "Array" + #:prototype *array-prototype* + #:vector rv)) + ((is-a? (car objs) ) + (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)))))) diff --git a/module/language/ecmascript/base.scm b/module/language/ecmascript/base.scm new file mode 100644 index 000000000..42a659895 --- /dev/null +++ b/module/language/ecmascript/base.scm @@ -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* + *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 () + (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 ) 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 ) 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 ) p attr) + (memq attr (prop-attrs o p))) + +(define-method (pput (o ) 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 ) 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 )) + +(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 )) + (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 )) + (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 ) + (object->number o #t) + x))) + +(define (object->value/number o) + (let ((v (object->number o #f))) + (if (is-a? x ) + (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 ) + (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 ) (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 #:prototype Boolean #:value x)) + ((number? x) (make #:prototype String #:value x)) + ((string? x) (make #:prototype Number #:value x)) + (else x))) + +(define (new-object . pairs) + (let ((o (make ))) + (map (lambda (pair) + (pput o (car pair) (cdr pair))) + pairs) + o)) diff --git a/module/language/ecmascript/function.scm b/module/language/ecmascript/function.scm new file mode 100644 index 000000000..cb85ef60d --- /dev/null +++ b/module/language/ecmascript/function.scm @@ -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 ()) + +(define *program-wrappers* (make-doubly-weak-hash-table 31)) + +(define *function-prototype* (make #: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 ) + (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 ) p) + (let ((wrapper (hashq-ref *program-wrappers* o))) + (if wrapper + (pget wrapper p) + (pget *function-prototype* p)))) + +(define-method (pput (o ) p v) + (let ((wrapper (hashq-ref *program-wrappers* o))) + (if wrapper + (pput wrapper p v) + (let ((wrapper (make #:value o #:class "Function" + #:prototype *function-prototype*))) + (hashq-set! *program-wrappers* o wrapper) + (pput wrapper p v))))) + +(define-method (js-prototype (o )) + (let ((wrapper (hashq-ref *program-wrappers* o))) + (if wrapper + (js-prototype wrapper) + #f))) + +(define-method (new (f ) . initargs) + (let ((o (make + #:prototype (or (js-prototype f) *object-prototype*)))) + (let ((new-o (with-fluid *this* o (lambda () (apply f initargs))))) + (if (is-a? new-o ) + new-o + o)))) 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* - - 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 () - (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 ) 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 ) 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 ) p attr) - (memq attr (prop-attrs o p))) - -(define-method (pput (o ) 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 ) 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 )) - (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 )) - (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 ) - (object->number o #t) - x))) - -(define (object->value/number o) - (let ((v (object->number o #f))) - (if (is-a? x ) - (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 ) - (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 ) (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 #:prototype Boolean #:value x)) - ((number? x) (make #:prototype String #:value x)) - ((string? x) (make #:prototype Number #:value x)) - (else x))) - -(define-class () - (vector #:init-value #() #:accessor js-array-vector)) - -(define-method (pget (o ) 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 ) 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 ))) - (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 ))) - (map (lambda (pair) - (pput o (car pair) (cdr pair))) - pairs) - o))