module/language/ecmascript/function.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 function)
  23   #:use-module (oop goops)
  24   #:use-module (language ecmascript base)
  25   #:export (*function-prototype* *program-wrappers*))
  26
  27
  28 (define-class <js-program-wrapper> (<js-object>))
  29
  30 (define *program-wrappers* (make-doubly-weak-hash-table 31))
  31
  32 (define *function-prototype* (make <js-object> #:class "Function"
  33                                    #:value (lambda args *undefined*)))
  34
  35 (define-js-method *function-prototype* (toString)
  36   (format #f "~A" (js-value this)))
  37
  38 (define-js-method *function-prototype* (apply this-arg array)
  39   (cond ((or (null? array) (eq? array *undefined*))
  40          (call/this this-arg (js-value this)))
  41         ((is-a? array <js-array-object>)
  42          (call/this this-arg
  43                     (lambda ()
  44                       (apply (js-value this)
  45                              (vector->list (js-array-vector array))))))
  46         (else
  47          (throw 'TypeError 'apply array))))
  48
  49 (define-js-method *function-prototype* (call this-arg . args)
  50   (call/this this-arg
  51              (lambda ()
  52                (apply (js-value this) args))))
  53
  54 (define-method (pget (o <applicable>) p)
  55   (let ((wrapper (hashq-ref *program-wrappers* o)))
  56     (if wrapper
  57         (pget wrapper p)
  58         (pget *function-prototype* p))))
  59
  60 (define-method (pput (o <applicable>) p v)
  61   (let ((wrapper (hashq-ref *program-wrappers* o)))
  62     (if wrapper
  63         (pput wrapper p v)
  64         (let ((wrapper (make <js-program-wrapper> #:value o #:class "Function"
  65                              #:prototype *function-prototype*)))
  66           (hashq-set! *program-wrappers* o wrapper)
  67           (pput wrapper p v)))))
  68
  69 (define-method (js-prototype (o <applicable>))
  70   (let ((wrapper (hashq-ref *program-wrappers* o)))
  71     (if wrapper
  72         (js-prototype wrapper)
  73         #f)))
  74
  75 (define-method (js-constructor (o <applicable>))
  76   (let ((wrapper (hashq-ref *program-wrappers* o)))
  77     (if wrapper
  78         (js-constructor wrapper)
  79         #f)))