module/language/ecmascript/base.scm

   1 ;;; ECMAScript for Guile
   2
   3 ;; Copyright (C) 2009 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 *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
  50 (define-method (prop-keys (o <js-object>))
  51   (hash-map->list (lambda (k v) k) (js-props o)))
  52
  53 (define-method (pget (o <js-object>) (p <string>))
  54   (pget o (string->symbol p)))
  55
  56 (define-method (pget (o <js-object>) p)
  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*)))))
  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)
  77   (if (prop-has-attr? o p 'ReadOnly)
  78       (throw 'ReferenceError o p)
  79       (hashq-set! (js-props o) p v)))
  80
  81 (define-method (pput (o <js-object>) (p <string>) v)
  82   (pput o (string->symbol p) v))
  83
  84 (define-method (pdel (o <js-object>) p)
  85   (if (prop-has-attr? o p 'DontDelete)
  86       #f
  87       (begin
  88         (pput o p *undefined*)
  89         #t)))
  90
  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)
  95   (if (hashq-get-handle (js-props o) v)
  96       #t
  97       (let ((proto (js-prototype o)))
  98         (if proto
  99             (has-property? proto p)
 100             #f))))
 101
 102 (define (call/this* this f)
 103   (with-fluid* *this* this f))
 104
 105 (define-macro (call/this this f . args)
 106   `(with-fluid* *this* ,this (lambda () (,f . ,args))))
 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)
 152   (if (is-a? o <js-object>)
 153       (object->number o #t)
 154       o))
 155
 156 (define (object->value/number o)
 157   (if (is-a? o <js-object>)
 158       (object->string o #t)
 159       o))
 160
 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)
 171   (not (or (not x) (null? x) (eq? x *undefined*) (zero? x) (nan? x)
 172            (and (string? x) (= (string-length x) 0)))))
 173
 174 (define (->number x)
 175   (cond ((number? x) x)
 176         ((boolean? x) (if x 1 0))
 177         ((null? x) 0)
 178         ((eq? x *undefined*) +nan.0)
 179         ((is-a? x <js-object>) (object->number x))
 180         ((string? x) (string->number x))
 181         (else (throw 'TypeError o '->number))))
 182
 183 (define (->integer x)
 184   (let ((n (->number x)))
 185     (cond ((nan? n) 0)
 186           ((zero? n) n)
 187           ((inf? n) n)
 188           (else (inexact->exact (round n))))))
 189
 190 (define (->int32 x)
 191   (let ((n (->number x)))
 192     (if (or (nan? n) (zero? n) (inf? n))
 193         0
 194         (let ((m (logand (1- (ash 1 32)) (inexact->exact (round n)))))
 195           (if (negative? n)
 196               (- m (ash 1 32))
 197               m)))))
 198
 199 (define (->uint32 x)
 200   (let ((n (->number x)))
 201     (if (or (nan? n) (zero? n) (inf? n))
 202         0
 203         (logand (1- (ash 1 32)) (inexact->exact (round n))))))
 204
 205 (define (->uint16 x)
 206   (let ((n (->number x)))
 207     (if (or (nan? n) (zero? n) (inf? n))
 208         0
 209         (logand (1- (ash 1 16)) (inexact->exact (round n))))))
 210
 211 (define (->string x)
 212   (cond ((eq? x *undefined*) "undefined")
 213         ((null? x) "null")
 214         ((boolean? x) (if x "true" "false"))
 215         ((string? x) x)
 216         ((number? x)
 217          (cond ((nan? x) "NaN")
 218                ((zero? x) "0")
 219                ((inf? x) "Infinity")
 220                (else (number->string x))))
 221         (else (->string (object->value/string x)))))
 222
 223 (define (->object x)
 224   (cond ((eq? x *undefined*) (throw 'TypeError x '->object))
 225         ((null? x) (throw 'TypeError x '->object))
 226         ((boolean? x) (make <js-object> #:prototype Boolean #:value x))
 227         ((number? x) (make <js-object> #:prototype String #:value x))
 228         ((string? x) (make <js-object> #:prototype Number #:value x))
 229         (else x)))
 230
 231 (define (new-object . pairs)
 232   (let ((o (make <js-object>)))
 233     (map (lambda (pair)
 234            (pput o (car pair) (cdr pair)))
 235          pairs)
 236     o))
 237 (slot-set! *object-prototype* 'constructor new-object)
 238
 239 (define-method (new o . initargs)
 240   (let ((ctor (js-constructor o)))
 241     (if (not ctor)
 242         (throw 'TypeError 'new o)
 243         (let ((o (make <js-object>
 244                    #:prototype (or (js-prototype o) *object-prototype*))))
 245           (let ((new-o (call/this o apply ctor initargs)))
 246             (if (is-a? new-o <js-object>)
 247                 new-o
 248                 o))))))