Commit | Line | Data |
---|---|---|
e80ce73d AW |
1 | ;;; ECMAScript for Guile |
2 | ||
ed7c4a5d | 3 | ;; Copyright (C) 2009, 2013 Free Software Foundation, Inc. |
e80ce73d | 4 | |
53befeb7 NJ |
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 | |
e80ce73d AW |
18 | |
19 | ;;; Code: | |
20 | ||
21 | (define-module (language ecmascript base) | |
22 | #:use-module (oop goops) | |
23 | #:export (*undefined* *this* | |
24 | <js-object> *object-prototype* | |
785fb107 | 25 | js-prototype js-props js-prop-attrs js-value js-constructor js-class |
e05320fa | 26 | pget prop-keys prop-attrs prop-has-attr? pput has-property? pdel |
e80ce73d AW |
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 | ||
785fb107 | 34 | call/this* call/this lambda/this define-js-method |
e80ce73d | 35 | |
8c306808 | 36 | new-object new)) |
e80ce73d AW |
37 | |
38 | (define *undefined* ((@@ (oop goops) make-unbound))) | |
39 | (define *this* (make-fluid)) | |
40 | ||
41 | (define-class <js-object> () | |
42 | (prototype #:getter js-prototype #:init-keyword #:prototype | |
43 | #:init-thunk (lambda () *object-prototype*)) | |
44 | (props #:getter js-props #:init-form (make-hash-table 7)) | |
45 | (prop-attrs #:getter js-prop-attrs #:init-value #f) | |
46 | (value #:getter js-value #:init-value #f #:init-keyword #:value) | |
47 | (constructor #:getter js-constructor #:init-value #f #:init-keyword #:constructor) | |
48 | (class #:getter js-class #:init-value "Object" #:init-keyword #:class)) | |
49 | ||
e05320fa AW |
50 | (define-method (prop-keys (o <js-object>)) |
51 | (hash-map->list (lambda (k v) k) (js-props o))) | |
52 | ||
b358fe65 AW |
53 | (define-method (pget (o <js-object>) (p <string>)) |
54 | (pget o (string->symbol p))) | |
55 | ||
e80ce73d | 56 | (define-method (pget (o <js-object>) p) |
b358fe65 AW |
57 | (let ((h (hashq-get-handle (js-props o) p))) |
58 | (if h | |
59 | (cdr h) | |
60 | (let ((proto (js-prototype o))) | |
61 | (if proto | |
62 | (pget proto p) | |
63 | *undefined*))))) | |
e80ce73d AW |
64 | |
65 | (define-method (prop-attrs (o <js-object>) p) | |
66 | (or (let ((attrs (js-prop-attrs o))) | |
67 | (and attrs (hashq-ref (js-prop-attrs o) p))) | |
68 | (let ((proto (js-prototype o))) | |
69 | (if proto | |
70 | (prop-attrs proto p) | |
71 | '())))) | |
72 | ||
73 | (define-method (prop-has-attr? (o <js-object>) p attr) | |
74 | (memq attr (prop-attrs o p))) | |
75 | ||
76 | (define-method (pput (o <js-object>) p v) | |
8c306808 AW |
77 | (if (prop-has-attr? o p 'ReadOnly) |
78 | (throw 'ReferenceError o p) | |
79 | (hashq-set! (js-props o) p v))) | |
e80ce73d | 80 | |
b358fe65 AW |
81 | (define-method (pput (o <js-object>) (p <string>) v) |
82 | (pput o (string->symbol p) v)) | |
83 | ||
e80ce73d | 84 | (define-method (pdel (o <js-object>) p) |
8c306808 AW |
85 | (if (prop-has-attr? o p 'DontDelete) |
86 | #f | |
87 | (begin | |
88 | (pput o p *undefined*) | |
89 | #t))) | |
e80ce73d | 90 | |
b358fe65 AW |
91 | (define-method (pdel (o <js-object>) (p <string>) v) |
92 | (pdel o (string->symbol p))) | |
93 | ||
94 | (define-method (has-property? (o <js-object>) p) | |
6b5e918e | 95 | (if (hashq-get-handle (js-props o) p) |
b358fe65 AW |
96 | #t |
97 | (let ((proto (js-prototype o))) | |
98 | (if proto | |
99 | (has-property? proto p) | |
100 | #f)))) | |
101 | ||
785fb107 AW |
102 | (define (call/this* this f) |
103 | (with-fluid* *this* this f)) | |
104 | ||
e80ce73d | 105 | (define-macro (call/this this f . args) |
785fb107 | 106 | `(with-fluid* *this* ,this (lambda () (,f . ,args)))) |
e80ce73d AW |
107 | (define-macro (lambda/this formals . body) |
108 | `(lambda ,formals (let ((this (fluid-ref *this*))) . ,body))) | |
109 | (define-macro (define-js-method object name-and-args . body) | |
110 | `(pput ,object ',(car name-and-args) (lambda/this ,(cdr name-and-args) . ,body))) | |
111 | ||
112 | (define *object-prototype* #f) | |
113 | (set! *object-prototype* (make <js-object>)) | |
114 | ||
115 | (define-js-method *object-prototype* (toString) | |
116 | (format #f "[object ~A]" (js-class this))) | |
117 | (define-js-method *object-prototype* (toLocaleString . args) | |
118 | ((pget *object-prototype* 'toString))) | |
119 | (define-js-method *object-prototype* (valueOf) | |
120 | this) | |
121 | (define-js-method *object-prototype* (hasOwnProperty p) | |
122 | (and (hashq-get-handle (js-props this) p) #t)) | |
123 | (define-js-method *object-prototype* (isPrototypeOf v) | |
124 | (eq? this (js-prototype v))) | |
125 | (define-js-method *object-prototype* (propertyIsEnumerable p) | |
126 | (and (hashq-get-handle (js-props this) p) | |
127 | (not (prop-has-attr? this p 'DontEnum)))) | |
128 | ||
129 | (define (object->string o error?) | |
130 | (let ((toString (pget o 'toString))) | |
131 | (if (procedure? toString) | |
132 | (let ((x (call/this o toString))) | |
133 | (if (and error? (is-a? x <js-object>)) | |
134 | (throw 'TypeError o 'default-value) | |
135 | x)) | |
136 | (if error? | |
137 | (throw 'TypeError o 'default-value) | |
138 | o)))) | |
139 | ||
140 | (define (object->number o error?) | |
141 | (let ((valueOf (pget o 'valueOf))) | |
142 | (if (procedure? valueOf) | |
143 | (let ((x (call/this o valueOf))) | |
144 | (if (and error? (is-a? x <js-object>)) | |
145 | (throw 'TypeError o 'default-value) | |
146 | x)) | |
147 | (if error? | |
148 | (throw 'TypeError o 'default-value) | |
149 | o)))) | |
150 | ||
151 | (define (object->value/string o) | |
84012ef4 | 152 | (if (is-a? o <js-object>) |
e5f5113c | 153 | (object->number o #t) |
84012ef4 | 154 | o)) |
e5f5113c | 155 | |
e80ce73d | 156 | (define (object->value/number o) |
84012ef4 | 157 | (if (is-a? o <js-object>) |
e5f5113c | 158 | (object->string o #t) |
84012ef4 | 159 | o)) |
e5f5113c | 160 | |
e80ce73d AW |
161 | (define (object->value o) |
162 | ;; FIXME: if it's a date, we should try numbers first | |
163 | (object->value/string o)) | |
164 | ||
165 | (define (->primitive x) | |
166 | (if (is-a? x <js-object>) | |
167 | (object->value x) | |
168 | x)) | |
169 | ||
170 | (define (->boolean x) | |
ed7c4a5d LC |
171 | (not (or (not x) (null? x) (eq? x *undefined*) |
172 | (and (number? x) (or (zero? x) (nan? x))) | |
e80ce73d AW |
173 | (and (string? x) (= (string-length x) 0))))) |
174 | ||
175 | (define (->number x) | |
176 | (cond ((number? x) x) | |
177 | ((boolean? x) (if x 1 0)) | |
178 | ((null? x) 0) | |
179 | ((eq? x *undefined*) +nan.0) | |
6b5e918e | 180 | ((is-a? x <js-object>) (object->number x #t)) |
e80ce73d | 181 | ((string? x) (string->number x)) |
6b5e918e | 182 | (else (throw 'TypeError x '->number)))) |
e80ce73d AW |
183 | |
184 | (define (->integer x) | |
185 | (let ((n (->number x))) | |
186 | (cond ((nan? n) 0) | |
187 | ((zero? n) n) | |
188 | ((inf? n) n) | |
189 | (else (inexact->exact (round n)))))) | |
190 | ||
191 | (define (->int32 x) | |
192 | (let ((n (->number x))) | |
193 | (if (or (nan? n) (zero? n) (inf? n)) | |
194 | 0 | |
195 | (let ((m (logand (1- (ash 1 32)) (inexact->exact (round n))))) | |
196 | (if (negative? n) | |
197 | (- m (ash 1 32)) | |
198 | m))))) | |
199 | ||
200 | (define (->uint32 x) | |
201 | (let ((n (->number x))) | |
202 | (if (or (nan? n) (zero? n) (inf? n)) | |
203 | 0 | |
204 | (logand (1- (ash 1 32)) (inexact->exact (round n)))))) | |
205 | ||
206 | (define (->uint16 x) | |
207 | (let ((n (->number x))) | |
208 | (if (or (nan? n) (zero? n) (inf? n)) | |
209 | 0 | |
210 | (logand (1- (ash 1 16)) (inexact->exact (round n)))))) | |
211 | ||
212 | (define (->string x) | |
213 | (cond ((eq? x *undefined*) "undefined") | |
214 | ((null? x) "null") | |
215 | ((boolean? x) (if x "true" "false")) | |
216 | ((string? x) x) | |
217 | ((number? x) | |
218 | (cond ((nan? x) "NaN") | |
219 | ((zero? x) "0") | |
220 | ((inf? x) "Infinity") | |
221 | (else (number->string x)))) | |
222 | (else (->string (object->value/string x))))) | |
223 | ||
224 | (define (->object x) | |
225 | (cond ((eq? x *undefined*) (throw 'TypeError x '->object)) | |
226 | ((null? x) (throw 'TypeError x '->object)) | |
227 | ((boolean? x) (make <js-object> #:prototype Boolean #:value x)) | |
228 | ((number? x) (make <js-object> #:prototype String #:value x)) | |
229 | ((string? x) (make <js-object> #:prototype Number #:value x)) | |
230 | (else x))) | |
231 | ||
232 | (define (new-object . pairs) | |
233 | (let ((o (make <js-object>))) | |
234 | (map (lambda (pair) | |
235 | (pput o (car pair) (cdr pair))) | |
236 | pairs) | |
237 | o)) | |
8c306808 AW |
238 | (slot-set! *object-prototype* 'constructor new-object) |
239 | ||
240 | (define-method (new o . initargs) | |
241 | (let ((ctor (js-constructor o))) | |
242 | (if (not ctor) | |
243 | (throw 'TypeError 'new o) | |
244 | (let ((o (make <js-object> | |
245 | #:prototype (or (js-prototype o) *object-prototype*)))) | |
246 | (let ((new-o (call/this o apply ctor initargs))) | |
247 | (if (is-a? new-o <js-object>) | |
248 | new-o | |
249 | o)))))) |