1;;; ECMAScript for Guile 2 3;; Copyright (C) 2009, 2013, 2015 Free Software Foundation, Inc. 4 5;;;; This library is free software; you can redistribute it and/or 6;;;; modify it under the terms of the GNU Lesser General Public 7;;;; License as published by the Free Software Foundation; either 8;;;; version 3 of the License, or (at your option) any later version. 9;;;; 10;;;; This library is distributed in the hope that it will be useful, 11;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 12;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 13;;;; Lesser General Public License for more details. 14;;;; 15;;;; You should have received a copy of the GNU Lesser General Public 16;;;; License along with this library; if not, write to the Free Software 17;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA 18 19;;; Code: 20 21(define-module (language ecmascript base) 22 #:use-module (oop goops) 23 #:export (*undefined* *this* 24 <js-object> *object-prototype* 25 js-prototype js-props js-prop-attrs js-value js-constructor js-class 26 pget prop-keys prop-attrs prop-has-attr? pput has-property? pdel 27 28 object->string object->number object->value/string 29 object->value/number object->value 30 31 ->primitive ->boolean ->number ->integer ->int32 ->uint32 32 ->uint16 ->string ->object 33 34 call/this* call/this lambda/this define-js-method 35 36 new-object new)) 37 38(define-class <undefined> ()) 39 40(define *undefined* (make <undefined>)) 41(define *this* (make-fluid)) 42 43(define-class <js-object> () 44 (prototype #:getter js-prototype #:init-keyword #:prototype 45 #:init-thunk (lambda () *object-prototype*)) 46 (props #:getter js-props #:init-form (make-hash-table 7)) 47 (prop-attrs #:getter js-prop-attrs #:init-value #f) 48 (value #:getter js-value #:init-value #f #:init-keyword #:value) 49 (constructor #:getter js-constructor #:init-value #f #:init-keyword #:constructor) 50 (class #:getter js-class #:init-value "Object" #:init-keyword #:class)) 51 52(define-method (prop-keys (o <js-object>)) 53 (hash-map->list (lambda (k v) k) (js-props o))) 54 55(define-method (pget (o <js-object>) (p <string>)) 56 (pget o (string->symbol p))) 57 58(define-method (pget (o <js-object>) p) 59 (let ((h (hashq-get-handle (js-props o) p))) 60 (if h 61 (cdr h) 62 (let ((proto (js-prototype o))) 63 (if proto 64 (pget proto p) 65 *undefined*))))) 66 67(define-method (prop-attrs (o <js-object>) p) 68 (or (let ((attrs (js-prop-attrs o))) 69 (and attrs (hashq-ref (js-prop-attrs o) p))) 70 (let ((proto (js-prototype o))) 71 (if proto 72 (prop-attrs proto p) 73 '())))) 74 75(define-method (prop-has-attr? (o <js-object>) p attr) 76 (memq attr (prop-attrs o p))) 77 78(define-method (pput (o <js-object>) p v) 79 (if (prop-has-attr? o p 'ReadOnly) 80 (throw 'ReferenceError o p) 81 (hashq-set! (js-props o) p v))) 82 83(define-method (pput (o <js-object>) (p <string>) v) 84 (pput o (string->symbol p) v)) 85 86(define-method (pdel (o <js-object>) p) 87 (if (prop-has-attr? o p 'DontDelete) 88 #f 89 (begin 90 (pput o p *undefined*) 91 #t))) 92 93(define-method (pdel (o <js-object>) (p <string>) v) 94 (pdel o (string->symbol p))) 95 96(define-method (has-property? (o <js-object>) p) 97 (if (hashq-get-handle (js-props o) p) 98 #t 99 (let ((proto (js-prototype o))) 100 (if proto 101 (has-property? proto p) 102 #f)))) 103 104(define (call/this* this f) 105 (with-fluid* *this* this f)) 106 107(define-macro (call/this this f . args) 108 `(with-fluid* *this* ,this (lambda () (,f . ,args)))) 109(define-macro (lambda/this formals . body) 110 `(lambda ,formals (let ((this (fluid-ref *this*))) . ,body))) 111(define-macro (define-js-method object name-and-args . body) 112 `(pput ,object ',(car name-and-args) (lambda/this ,(cdr name-and-args) . ,body))) 113 114(define *object-prototype* #f) 115(set! *object-prototype* (make <js-object>)) 116 117(define-js-method *object-prototype* (toString) 118 (format #f "[object ~A]" (js-class this))) 119(define-js-method *object-prototype* (toLocaleString . args) 120 ((pget *object-prototype* 'toString))) 121(define-js-method *object-prototype* (valueOf) 122 this) 123(define-js-method *object-prototype* (hasOwnProperty p) 124 (and (hashq-get-handle (js-props this) p) #t)) 125(define-js-method *object-prototype* (isPrototypeOf v) 126 (eq? this (js-prototype v))) 127(define-js-method *object-prototype* (propertyIsEnumerable p) 128 (and (hashq-get-handle (js-props this) p) 129 (not (prop-has-attr? this p 'DontEnum)))) 130 131(define (object->string o error?) 132 (let ((toString (pget o 'toString))) 133 (if (procedure? toString) 134 (let ((x (call/this o toString))) 135 (if (and error? (is-a? x <js-object>)) 136 (throw 'TypeError o 'default-value) 137 x)) 138 (if error? 139 (throw 'TypeError o 'default-value) 140 o)))) 141 142(define (object->number o error?) 143 (let ((valueOf (pget o 'valueOf))) 144 (if (procedure? valueOf) 145 (let ((x (call/this o valueOf))) 146 (if (and error? (is-a? x <js-object>)) 147 (throw 'TypeError o 'default-value) 148 x)) 149 (if error? 150 (throw 'TypeError o 'default-value) 151 o)))) 152 153(define (object->value/string o) 154 (if (is-a? o <js-object>) 155 (object->number o #t) 156 o)) 157 158(define (object->value/number o) 159 (if (is-a? o <js-object>) 160 (object->string o #t) 161 o)) 162 163(define (object->value o) 164 ;; FIXME: if it's a date, we should try numbers first 165 (object->value/string o)) 166 167(define (->primitive x) 168 (if (is-a? x <js-object>) 169 (object->value x) 170 x)) 171 172(define (->boolean x) 173 (not (or (not x) (null? x) (eq? x *undefined*) 174 (and (number? x) (or (zero? x) (nan? x))) 175 (and (string? x) (= (string-length x) 0))))) 176 177(define (->number x) 178 (cond ((number? x) x) 179 ((boolean? x) (if x 1 0)) 180 ((null? x) 0) 181 ((eq? x *undefined*) +nan.0) 182 ((is-a? x <js-object>) (object->number x #t)) 183 ((string? x) (string->number x)) 184 (else (throw 'TypeError x '->number)))) 185 186(define (->integer x) 187 (let ((n (->number x))) 188 (cond ((nan? n) 0) 189 ((zero? n) n) 190 ((inf? n) n) 191 (else (inexact->exact (round n)))))) 192 193(define (->int32 x) 194 (let ((n (->number x))) 195 (if (or (nan? n) (zero? n) (inf? n)) 196 0 197 (let ((m (logand (1- (ash 1 32)) (inexact->exact (round n))))) 198 (if (negative? n) 199 (- m (ash 1 32)) 200 m))))) 201 202(define (->uint32 x) 203 (let ((n (->number x))) 204 (if (or (nan? n) (zero? n) (inf? n)) 205 0 206 (logand (1- (ash 1 32)) (inexact->exact (round n)))))) 207 208(define (->uint16 x) 209 (let ((n (->number x))) 210 (if (or (nan? n) (zero? n) (inf? n)) 211 0 212 (logand (1- (ash 1 16)) (inexact->exact (round n)))))) 213 214(define (->string x) 215 (cond ((eq? x *undefined*) "undefined") 216 ((null? x) "null") 217 ((boolean? x) (if x "true" "false")) 218 ((string? x) x) 219 ((number? x) 220 (cond ((nan? x) "NaN") 221 ((zero? x) "0") 222 ((inf? x) "Infinity") 223 (else (number->string x)))) 224 (else (->string (object->value/string x))))) 225 226(define (->object x) 227 (cond ((eq? x *undefined*) (throw 'TypeError x '->object)) 228 ((null? x) (throw 'TypeError x '->object)) 229 ((boolean? x) (make <js-object> #:prototype Boolean #:value x)) 230 ((number? x) (make <js-object> #:prototype String #:value x)) 231 ((string? x) (make <js-object> #:prototype Number #:value x)) 232 (else x))) 233 234(define (new-object . pairs) 235 (let ((o (make <js-object>))) 236 (map (lambda (pair) 237 (pput o (car pair) (cdr pair))) 238 pairs) 239 o)) 240(slot-set! *object-prototype* 'constructor new-object) 241 242(define-method (new o . initargs) 243 (let ((ctor (js-constructor o))) 244 (if (not ctor) 245 (throw 'TypeError 'new o) 246 (let ((o (make <js-object> 247 #:prototype (or (js-prototype o) *object-prototype*)))) 248 (let ((new-o (call/this o apply ctor initargs))) 249 (if (is-a? new-o <js-object>) 250 new-o 251 o)))))) 252