summaryrefslogtreecommitdiff
path: root/module/language/ecmascript/array.scm
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2009-09-02 00:07:27 +0200
committerLudovic Courtès <ludo@gnu.org>2009-09-02 01:37:37 +0200
commit5f236208d0d864546e59afa0f5a11c9b3ba14b10 (patch)
treeeed5d9203a2633c8efb85c1b36425eab87574299 /module/language/ecmascript/array.scm
parentf0eb5ae6c173aed35965b0561897fda1d8ff0db1 (diff)
parentd7e7a02a6251c8ed4f76933d9d30baeee3f599c0 (diff)
downloadguile-5f236208d0d864546e59afa0f5a11c9b3ba14b10.tar.gz
Merge branch 'boehm-demers-weiser-gc' into bdw-gc-static-alloc
Conflicts: acinclude.m4 libguile/strings.c
Diffstat (limited to 'module/language/ecmascript/array.scm')
-rw-r--r--module/language/ecmascript/array.scm121
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..e9fc3c6f4
--- /dev/null
+++ b/module/language/ecmascript/array.scm
@@ -0,0 +1,121 @@
+;;; ECMAScript for Guile
+
+;; Copyright (C) 2009 Free Software Foundation, Inc.
+
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library 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
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 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
+ #:constructor 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))))))