module/language/ecmascript/base.scm

   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*
  26             js-prototype js-props js-prop-attrs js-value js-constructor js-class
  27             pget prop-keys prop-attrs prop-has-attr? pput has-property? pdel
  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
  35             call/this* call/this lambda/this define-js-method
  36
  37             new-object new))
  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
  51 (define-method (prop-keys (o <js-object>))
  52   (hash-map->list (lambda (k v) k) (js-props o)))
  53
  54 (define-method (pget (o <js-object>) (p <string>))
  55   (pget o (string->symbol p)))
  56
  57 (define-method (pget (o <js-object>) p)
  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*)))))
  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)
  78   (if (prop-has-attr? o p 'ReadOnly)
  79       (throw 'ReferenceError o p)
  80       (hashq-set! (js-props o) p v)))
  81
  82 (define-method (pput (o <js-object>) (p <string>) v)
  83   (pput o (string->symbol p) v))
  84
  85 (define-method (pdel (o <js-object>) p)
  86   (if (prop-has-attr? o p 'DontDelete)
  87       #f
  88       (begin
  89         (pput o p *undefined*)
  90         #t)))
  91
  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
 103 (define (call/this* this f)
 104   (with-fluid* *this* this f))
 105
 106 (define-macro (call/this this f . args)
 107   `(with-fluid* *this* ,this (lambda () (,f . ,args))))
 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))
 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))))))