module/language/ecmascript/array.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 array)
  23   #:use-module (oop goops)
  24   #:use-module (language ecmascript base)
  25   #:use-module (language ecmascript function)
  26   #:export (*array-prototype* new-array))
  27
  28
  29 (define-class <js-array-object> (<js-object>)
  30   (vector #:init-value #() #:accessor js-array-vector #:init-keyword #:vector))
  31
  32 (define (new-array . vals)
  33   (let ((o (make <js-array-object> #:class "Array"
  34                  #:prototype *array-prototype*)))
  35     (pput o 'length (length vals))
  36     (let ((vect (js-array-vector o)))
  37       (let lp ((i 0) (vals vals))
  38         (cond ((not (null? vals))
  39                (vector-set! vect i (car vals))
  40                (lp (1+ i) (cdr vals)))
  41               (else o))))))
  42
  43 (define *array-prototype* (make <js-object> #:class "Array"
  44                                 #:value new-array
  45                                 #:constructor new-array))
  46
  47 (hashq-set! *program-wrappers* new-array *array-prototype*)
  48
  49 (pput *array-prototype* 'prototype *array-prototype*)
  50 (pput *array-prototype* 'constructor new-array)
  51
  52 (define-method (pget (o <js-array-object>) p)
  53   (cond ((and (integer? p) (exact? p) (>= p 0))
  54          (let ((v (js-array-vector o)))
  55            (if (< p (vector-length v))
  56                (vector-ref v p)
  57                (next-method))))
  58         ((or (and (symbol? p) (eq? p 'length))
  59              (and (string? p) (string=? p "length")))
  60          (vector-length (js-array-vector o)))
  61         (else (next-method))))
  62
  63 (define-method (pput (o <js-array-object>) p v)
  64   (cond ((and (integer? p) (exact? p) (>= 0 p))
  65          (let ((vect (js-array-vector o)))
  66            (if (< p (vector-length vect))
  67                (vector-set! vect p)
  68                ;; Fixme: round up to powers of 2?
  69                (let ((new (make-vector (1+ p) 0)))
  70                  (vector-move-left! vect 0 (vector-length vect) new 0)
  71                  (set! (js-array-vector o) new)
  72                  (vector-set! new p)))))
  73         ((or (and (symbol? p) (eq? p 'length))
  74              (and (string? p) (string=? p "length")))
  75          (let ((vect (js-array-vector o)))
  76            (let ((new (make-vector (->uint32 v) 0)))
  77              (vector-move-left! vect 0 (min (vector-length vect) (->uint32 v))
  78                                 new 0)
  79              (set! (js-array-vector o) new))))
  80         (else (next-method))))
  81
  82 (define-js-method *array-prototype* (toString)
  83   (format #f "~A" (js-array-vector this)))
  84
  85 (define-js-method *array-prototype* (concat . rest)
  86   (let* ((len (apply + (->uint32 (pget this 'length))
  87                      (map (lambda (x) (->uint32 (pget x 'length)))
  88                           rest)))
  89          (rv (make-vector len 0)))
  90     (let lp ((objs (cons this rest)) (i 0))
  91       (cond ((null? objs) (make <js-array-object> #:class "Array"
  92                                 #:prototype *array-prototype*
  93                                 #:vector rv))
  94             ((is-a? (car objs) <js-array-object>)
  95              (let ((v (js-array-vector (car objs))))
  96                (vector-move-left! v 0 (vector-length v)
  97                                   rv i (+ i (vector-length v)))
  98                (lp (cdr objs) (+ i (vector-length v)))))
  99             (else
 100              (error "generic array concats not yet implemented"))))))
 101
 102 (define-js-method *array-prototype* (join . separator)
 103   (let lp ((i (1- (->uint32 (pget this 'length)))) (l '()))
 104     (if (< i 0)
 105         (string-join l (if separator (->string (car separator)) ","))
 106         (lp (1+ i)
 107             (cons (->string (pget this i)) l)))))
 108
 109 (define-js-method *array-prototype* (pop)
 110   (let ((len (->uint32 (pget this 'length))))
 111     (if (zero? len)
 112         *undefined*
 113         (let ((ret (pget this (1- len))))
 114           (pput this 'length (1- len))
 115           ret))))
 116
 117 (define-js-method *array-prototype* (push . args)
 118   (let lp ((args args))
 119     (if (null? args)
 120         (->uint32 (pget this 'length))
 121         (begin (pput this (->uint32 (pget this 'length)) (car args))
 122                (lp (cdr args))))))