Commit | Line | Data |
---|---|---|
e80ce73d AW |
1 | ;;; ECMAScript for Guile |
2 | ||
92d33877 | 3 | ;; Copyright (C) 2009, 2010 Free Software Foundation, Inc. |
e80ce73d | 4 | |
53befeb7 NJ |
5 | ;;;; This library is free software; you can redistribute it and/or |
6 | ;;;; modify it under the terms of the GNU Lesser General Public | |
7 | ;;;; License as published by the Free Software Foundation; either | |
8 | ;;;; version 3 of the License, or (at your option) any later version. | |
9 | ;;;; | |
10 | ;;;; This library 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 GNU | |
13 | ;;;; Lesser General Public License for more details. | |
14 | ;;;; | |
15 | ;;;; You should have received a copy of the GNU Lesser General Public | |
16 | ;;;; License along with this library; if not, write to the Free Software | |
17 | ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA | |
e80ce73d AW |
18 | |
19 | ;;; Code: | |
20 | ||
21 | (define-module (language ecmascript array) | |
22 | #:use-module (oop goops) | |
23 | #:use-module (language ecmascript base) | |
24 | #:use-module (language ecmascript function) | |
25 | #:export (*array-prototype* new-array)) | |
26 | ||
27 | ||
28 | (define-class <js-array-object> (<js-object>) | |
29 | (vector #:init-value #() #:accessor js-array-vector #:init-keyword #:vector)) | |
30 | ||
31 | (define (new-array . vals) | |
32 | (let ((o (make <js-array-object> #:class "Array" | |
33 | #:prototype *array-prototype*))) | |
34 | (pput o 'length (length vals)) | |
35 | (let ((vect (js-array-vector o))) | |
36 | (let lp ((i 0) (vals vals)) | |
37 | (cond ((not (null? vals)) | |
38 | (vector-set! vect i (car vals)) | |
39 | (lp (1+ i) (cdr vals))) | |
40 | (else o)))))) | |
41 | ||
42 | (define *array-prototype* (make <js-object> #:class "Array" | |
8c306808 AW |
43 | #:value new-array |
44 | #:constructor new-array)) | |
e80ce73d AW |
45 | |
46 | (hashq-set! *program-wrappers* new-array *array-prototype*) | |
47 | ||
48 | (pput *array-prototype* 'prototype *array-prototype*) | |
49 | (pput *array-prototype* 'constructor new-array) | |
50 | ||
51 | (define-method (pget (o <js-array-object>) p) | |
52 | (cond ((and (integer? p) (exact? p) (>= p 0)) | |
53 | (let ((v (js-array-vector o))) | |
54 | (if (< p (vector-length v)) | |
55 | (vector-ref v p) | |
56 | (next-method)))) | |
57 | ((or (and (symbol? p) (eq? p 'length)) | |
58 | (and (string? p) (string=? p "length"))) | |
59 | (vector-length (js-array-vector o))) | |
60 | (else (next-method)))) | |
61 | ||
62 | (define-method (pput (o <js-array-object>) p v) | |
63 | (cond ((and (integer? p) (exact? p) (>= 0 p)) | |
64 | (let ((vect (js-array-vector o))) | |
65 | (if (< p (vector-length vect)) | |
92d33877 | 66 | (vector-set! vect p v) |
e80ce73d AW |
67 | ;; Fixme: round up to powers of 2? |
68 | (let ((new (make-vector (1+ p) 0))) | |
69 | (vector-move-left! vect 0 (vector-length vect) new 0) | |
70 | (set! (js-array-vector o) new) | |
92d33877 | 71 | (vector-set! new p v))))) |
e80ce73d AW |
72 | ((or (and (symbol? p) (eq? p 'length)) |
73 | (and (string? p) (string=? p "length"))) | |
74 | (let ((vect (js-array-vector o))) | |
75 | (let ((new (make-vector (->uint32 v) 0))) | |
76 | (vector-move-left! vect 0 (min (vector-length vect) (->uint32 v)) | |
77 | new 0) | |
78 | (set! (js-array-vector o) new)))) | |
79 | (else (next-method)))) | |
80 | ||
81 | (define-js-method *array-prototype* (toString) | |
82 | (format #f "~A" (js-array-vector this))) | |
83 | ||
84 | (define-js-method *array-prototype* (concat . rest) | |
85 | (let* ((len (apply + (->uint32 (pget this 'length)) | |
86 | (map (lambda (x) (->uint32 (pget x 'length))) | |
87 | rest))) | |
88 | (rv (make-vector len 0))) | |
89 | (let lp ((objs (cons this rest)) (i 0)) | |
90 | (cond ((null? objs) (make <js-array-object> #:class "Array" | |
91 | #:prototype *array-prototype* | |
92 | #:vector rv)) | |
93 | ((is-a? (car objs) <js-array-object>) | |
94 | (let ((v (js-array-vector (car objs)))) | |
95 | (vector-move-left! v 0 (vector-length v) | |
92d33877 | 96 | rv i) |
e80ce73d AW |
97 | (lp (cdr objs) (+ i (vector-length v))))) |
98 | (else | |
99 | (error "generic array concats not yet implemented")))))) | |
100 | ||
101 | (define-js-method *array-prototype* (join . separator) | |
102 | (let lp ((i (1- (->uint32 (pget this 'length)))) (l '())) | |
103 | (if (< i 0) | |
104 | (string-join l (if separator (->string (car separator)) ",")) | |
105 | (lp (1+ i) | |
106 | (cons (->string (pget this i)) l))))) | |
107 | ||
108 | (define-js-method *array-prototype* (pop) | |
109 | (let ((len (->uint32 (pget this 'length)))) | |
110 | (if (zero? len) | |
111 | *undefined* | |
112 | (let ((ret (pget this (1- len)))) | |
113 | (pput this 'length (1- len)) | |
114 | ret)))) | |
115 | ||
116 | (define-js-method *array-prototype* (push . args) | |
117 | (let lp ((args args)) | |
118 | (if (null? args) | |
119 | (->uint32 (pget this 'length)) | |
120 | (begin (pput this (->uint32 (pget this 'length)) (car args)) | |
121 | (lp (cdr args)))))) |