blob: a9f499a229c6ea96a10a97e6fedfd0015c974f9f (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
|
;;; 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
#: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))))))
|