Commit | Line | Data |
---|---|---|
e80ce73d AW |
1 | ;;; ECMAScript for Guile |
2 | ||
3 | ;; Copyright (C) 2009 Free Software Foundation, Inc. | |
4 | ||
5 | ;; This program is free software; you can redistribute it and/or modify | |
6 | ;; it under the terms of the GNU General Public License as published by | |
7 | ;; the Free Software Foundation; either version 2, or (at your option) | |
8 | ;; any later version. | |
9 | ;; | |
10 | ;; This program 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 | |
13 | ;; GNU General Public License for more details. | |
14 | ;; | |
15 | ;; You should have received a copy of the GNU General Public License | |
16 | ;; along with this program; see the file COPYING. If not, write to | |
17 | ;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, | |
18 | ;; Boston, MA 02111-1307, USA. | |
19 | ||
20 | ;;; Code: | |
21 | ||
22 | (define-module (language ecmascript base) | |
23 | #:use-module (oop goops) | |
24 | #:export (*undefined* *this* | |
25 | <js-object> *object-prototype* | |
785fb107 | 26 | js-prototype js-props js-prop-attrs js-value js-constructor js-class |
e05320fa | 27 | pget prop-keys prop-attrs prop-has-attr? pput has-property? pdel |
e80ce73d AW |
28 | |
29 | object->string object->number object->value/string | |
30 | object->value/number object->value | |
31 | ||
32 | ->primitive ->boolean ->number ->integer ->int32 ->uint32 | |
33 | ->uint16 ->string ->object | |
34 | ||
785fb107 | 35 | call/this* call/this lambda/this define-js-method |
e80ce73d | 36 | |
8c306808 | 37 | new-object new)) |
e80ce73d AW |
38 | |
39 | (define *undefined* ((@@ (oop goops) make-unbound))) | |
40 | (define *this* (make-fluid)) | |
41 | ||
42 | (define-class <js-object> () | |
43 | (prototype #:getter js-prototype #:init-keyword #:prototype | |
44 | #:init-thunk (lambda () *object-prototype*)) | |
45 | (props #:getter js-props #:init-form (make-hash-table 7)) | |
46 | (prop-attrs #:getter js-prop-attrs #:init-value #f) | |
47 | (value #:getter js-value #:init-value #f #:init-keyword #:value) | |
48 | (constructor #:getter js-constructor #:init-value #f #:init-keyword #:constructor) | |
49 | (class #:getter js-class #:init-value "Object" #:init-keyword #:class)) | |
50 | ||
e05320fa AW |
51 | (define-method (prop-keys (o <js-object>)) |
52 | (hash-map->list (lambda (k v) k) (js-props o))) | |
53 | ||
b358fe65 AW |
54 | (define-method (pget (o <js-object>) (p <string>)) |
55 | (pget o (string->symbol p))) | |
56 | ||
e80ce73d | 57 | (define-method (pget (o <js-object>) p) |
b358fe65 AW |
58 | (let ((h (hashq-get-handle (js-props o) p))) |
59 | (if h | |
60 | (cdr h) | |
61 | (let ((proto (js-prototype o))) | |
62 | (if proto | |
63 | (pget proto p) | |
64 | *undefined*))))) | |
e80ce73d AW |
65 | |
66 | (define-method (prop-attrs (o <js-object>) p) | |
67 | (or (let ((attrs (js-prop-attrs o))) | |
68 | (and attrs (hashq-ref (js-prop-attrs o) p))) | |
69 | (let ((proto (js-prototype o))) | |
70 | (if proto | |
71 | (prop-attrs proto p) | |
72 | '())))) | |
73 | ||
74 | (define-method (prop-has-attr? (o <js-object>) p attr) | |
75 | (memq attr (prop-attrs o p))) | |
76 | ||
77 | (define-method (pput (o <js-object>) p v) | |
8c306808 AW |
78 | (if (prop-has-attr? o p 'ReadOnly) |
79 | (throw 'ReferenceError o p) | |
80 | (hashq-set! (js-props o) p v))) | |
e80ce73d | 81 | |
b358fe65 AW |
82 | (define-method (pput (o <js-object>) (p <string>) v) |
83 | (pput o (string->symbol p) v)) | |
84 | ||
e80ce73d | 85 | (define-method (pdel (o <js-object>) p) |
8c306808 AW |
86 | (if (prop-has-attr? o p 'DontDelete) |
87 | #f | |
88 | (begin | |
89 | (pput o p *undefined*) | |
90 | #t))) | |
e80ce73d | 91 | |
b358fe65 AW |
92 | (define-method (pdel (o <js-object>) (p <string>) v) |
93 | (pdel o (string->symbol p))) | |
94 | ||
95 | (define-method (has-property? (o <js-object>) p) | |
96 | (if (hashq-get-handle (js-props o) v) | |
97 | #t | |
98 | (let ((proto (js-prototype o))) | |
99 | (if proto | |
100 | (has-property? proto p) | |
101 | #f)))) | |
102 | ||
785fb107 AW |
103 | (define (call/this* this f) |
104 | (with-fluid* *this* this f)) | |
105 | ||
e80ce73d | 106 | (define-macro (call/this this f . args) |
785fb107 | 107 | `(with-fluid* *this* ,this (lambda () (,f . ,args)))) |
e80ce73d AW |
108 | (define-macro (lambda/this formals . body) |
109 | `(lambda ,formals (let ((this (fluid-ref *this*))) . ,body))) | |
110 | (define-macro (define-js-method object name-and-args . body) | |
111 | `(pput ,object ',(car name-and-args) (lambda/this ,(cdr name-and-args) . ,body))) | |
112 | ||
113 | (define *object-prototype* #f) | |
114 | (set! *object-prototype* (make <js-object>)) | |
115 | ||
116 | (define-js-method *object-prototype* (toString) | |
117 | (format #f "[object ~A]" (js-class this))) | |
118 | (define-js-method *object-prototype* (toLocaleString . args) | |
119 | ((pget *object-prototype* 'toString))) | |
120 | (define-js-method *object-prototype* (valueOf) | |
121 | this) | |
122 | (define-js-method *object-prototype* (hasOwnProperty p) | |
123 | (and (hashq-get-handle (js-props this) p) #t)) | |
124 | (define-js-method *object-prototype* (isPrototypeOf v) | |
125 | (eq? this (js-prototype v))) | |
126 | (define-js-method *object-prototype* (propertyIsEnumerable p) | |
127 | (and (hashq-get-handle (js-props this) p) | |
128 | (not (prop-has-attr? this p 'DontEnum)))) | |
129 | ||
130 | (define (object->string o error?) | |
131 | (let ((toString (pget o 'toString))) | |
132 | (if (procedure? toString) | |
133 | (let ((x (call/this o toString))) | |
134 | (if (and error? (is-a? x <js-object>)) | |
135 | (throw 'TypeError o 'default-value) | |
136 | x)) | |
137 | (if error? | |
138 | (throw 'TypeError o 'default-value) | |
139 | o)))) | |
140 | ||
141 | (define (object->number o error?) | |
142 | (let ((valueOf (pget o 'valueOf))) | |
143 | (if (procedure? valueOf) | |
144 | (let ((x (call/this o valueOf))) | |
145 | (if (and error? (is-a? x <js-object>)) | |
146 | (throw 'TypeError o 'default-value) | |
147 | x)) | |
148 | (if error? | |
149 | (throw 'TypeError o 'default-value) | |
150 | o)))) | |
151 | ||
152 | (define (object->value/string o) | |
153 | (let ((v (object->string o #f))) | |
154 | (if (is-a? x <js-object>) | |
155 | (object->number o #t) | |
156 | x))) | |
157 | ||
158 | (define (object->value/number o) | |
159 | (let ((v (object->number o #f))) | |
160 | (if (is-a? x <js-object>) | |
161 | (object->string o #t) | |
162 | x))) | |
163 | ||
164 | (define (object->value o) | |
165 | ;; FIXME: if it's a date, we should try numbers first | |
166 | (object->value/string o)) | |
167 | ||
168 | (define (->primitive x) | |
169 | (if (is-a? x <js-object>) | |
170 | (object->value x) | |
171 | x)) | |
172 | ||
173 | (define (->boolean x) | |
174 | (not (or (not x) (null? x) (eq? x *undefined*) (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 o)) | |
183 | ((string? x) (string->number x)) | |
184 | (else (throw 'TypeError o '->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)) | |
8c306808 AW |
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)))))) |