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