diff options
Diffstat (limited to 'module/language/ecmascript/array.scm')
-rw-r--r-- | module/language/ecmascript/array.scm | 121 |
1 files changed, 121 insertions, 0 deletions
diff --git a/module/language/ecmascript/array.scm b/module/language/ecmascript/array.scm new file mode 100644 index 000000000..8863b7fa4 --- /dev/null +++ b/module/language/ecmascript/array.scm @@ -0,0 +1,121 @@ +;;; ECMAScript for Guile + +;; Copyright (C) 2009 Free Software Foundation, Inc. + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. +;; +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Code: + +(define-module (language ecmascript array) + #:use-module (oop goops) + #:use-module (language ecmascript base) + #:use-module (language ecmascript function) + #:export (*array-prototype* new-array)) + + +(define-class <js-array-object> (<js-object>) + (vector #:init-value #() #:accessor js-array-vector #:init-keyword #:vector)) + +(define (new-array . vals) + (let ((o (make <js-array-object> #:class "Array" + #:prototype *array-prototype*))) + (pput o 'length (length vals)) + (let ((vect (js-array-vector o))) + (let lp ((i 0) (vals vals)) + (cond ((not (null? vals)) + (vector-set! vect i (car vals)) + (lp (1+ i) (cdr vals))) + (else o)))))) + +(define *array-prototype* (make <js-object> #:class "Array" + #:value new-array)) + +(hashq-set! *program-wrappers* new-array *array-prototype*) + +(pput *array-prototype* 'prototype *array-prototype*) +(pput *array-prototype* 'constructor new-array) + +(define-method (pget (o <js-array-object>) p) + (cond ((and (integer? p) (exact? p) (>= p 0)) + (let ((v (js-array-vector o))) + (if (< p (vector-length v)) + (vector-ref v p) + (next-method)))) + ((or (and (symbol? p) (eq? p 'length)) + (and (string? p) (string=? p "length"))) + (vector-length (js-array-vector o))) + (else (next-method)))) + +(define-method (pput (o <js-array-object>) p v) + (cond ((and (integer? p) (exact? p) (>= 0 p)) + (let ((vect (js-array-vector o))) + (if (< p (vector-length vect)) + (vector-set! vect p) + ;; Fixme: round up to powers of 2? + (let ((new (make-vector (1+ p) 0))) + (vector-move-left! vect 0 (vector-length vect) new 0) + (set! (js-array-vector o) new) + (vector-set! new p))))) + ((or (and (symbol? p) (eq? p 'length)) + (and (string? p) (string=? p "length"))) + (let ((vect (js-array-vector o))) + (let ((new (make-vector (->uint32 v) 0))) + (vector-move-left! vect 0 (min (vector-length vect) (->uint32 v)) + new 0) + (set! (js-array-vector o) new)))) + (else (next-method)))) + +(define-js-method *array-prototype* (toString) + (format #f "~A" (js-array-vector this))) + +(define-js-method *array-prototype* (concat . rest) + (let* ((len (apply + (->uint32 (pget this 'length)) + (map (lambda (x) (->uint32 (pget x 'length))) + rest))) + (rv (make-vector len 0))) + (let lp ((objs (cons this rest)) (i 0)) + (cond ((null? objs) (make <js-array-object> #:class "Array" + #:prototype *array-prototype* + #:vector rv)) + ((is-a? (car objs) <js-array-object>) + (let ((v (js-array-vector (car objs)))) + (vector-move-left! v 0 (vector-length v) + rv i (+ i (vector-length v))) + (lp (cdr objs) (+ i (vector-length v))))) + (else + (error "generic array concats not yet implemented")))))) + +(define-js-method *array-prototype* (join . separator) + (let lp ((i (1- (->uint32 (pget this 'length)))) (l '())) + (if (< i 0) + (string-join l (if separator (->string (car separator)) ",")) + (lp (1+ i) + (cons (->string (pget this i)) l))))) + +(define-js-method *array-prototype* (pop) + (let ((len (->uint32 (pget this 'length)))) + (if (zero? len) + *undefined* + (let ((ret (pget this (1- len)))) + (pput this 'length (1- len)) + ret)))) + +(define-js-method *array-prototype* (push . args) + (let lp ((args args)) + (if (null? args) + (->uint32 (pget this 'length)) + (begin (pput this (->uint32 (pget this 'length)) (car args)) + (lp (cdr args)))))) |