Add vectors.

1 files changed, 156 insertions, 0 deletions

diff --git a/lib/scheme/base/70-vector.csc b/lib/scheme/base/70-vector.csc
new file mode 100644
index 0000000..9f2fbc4
--- /dev/null
+++ b/lib/scheme/base/70-vector.csc
@@ -0,0 +1,156 @@
+(export
+  list->vector
+  make-vector
+  vector
+  vector->list
+  vector-append
+  vector-copy
+  vector-copy!
+  vector-fill!
+  vector-for-each
+  vector-length
+  vector-map
+  vector-ref
+  vector-set!
+  vector?)
+(import (only (csc builtins)
+          call-builtin))
+(begin
+
+
+  (define (vector? obj)
+    (zero? (call-builtin peek obj 0)))
+
+
+  (define (vector-length v)
+    (unless (vector? v)
+      (error "unexpected type in vector-length" v))
+    (call-builtin peek v 1))
+
+
+  (define (vector-set! v k obj)
+    (unless (< k (vector-length v))
+      (error "index out of range in vector-set!" k v))
+    (call-builtin poke obj v (+ 2 k)))
+
+
+  (define vector-fill!
+    (case-lambda
+      ((v fill)
+        (vector-fill! v 0 (vector-length v)))
+      ((v fill start)
+        (vector-fill! v start (vector-length v)))
+      ((v fill start end)
+        (let loop ((i start))
+          (when (< i end)
+            (vector-set! v i fill)
+            (loop (+ 1 i)))))))
+
+
+  (define make-vector
+    (case-lambda
+      ((k)
+        (define v (call-builtin alloc (+ 2 k)))
+        (call-builtin poke 0 v 0)
+        (call-builtin poke k v 1)
+        v)
+      ((k fill)
+        (define n (+ 2 k))
+        (define v (call-builtin alloc n))
+        (call-builtin poke 0 v 0)
+        (call-builtin poke k v 1)
+        (vector-fill! v fill)
+        v)))
+
+
+  (define (list->vector l)
+    (define n (length l))
+    (define v (make-vector n))
+    (let loop ((i 0)
+               (l l))
+      (when (< i n)
+        (vector-set! v i (car l))
+        (loop (+ 1 i) (cdr l))))
+    v)
+
+
+  (define (vector . objs)
+    (list->vector objs))
+
+
+  (define (vector-ref v k)
+    (unless (< k (vector-length v))
+      (error "index out of range in vector-set!" k v))
+    (call-builtin peek v (+ 2 k)))
+
+
+  (define vector->list
+    (case-lambda
+      ((v)
+        (vector->list v 0 (vector-length v)))
+      ((v start)
+        (vector->list v start (vector-length v)))
+      ((v start end)
+        (let loop ((i (- end 1))
+                   (acc '()))
+          (when (>= i start)
+            (loop (- i 1)
+                  (cons (vector-ref v i) acc)))))))
+
+
+  (define vector-copy!
+    (case-lambda
+      ((to at from)
+        (vector-copy! to at from 0 (vector-length from)))
+      ((to at from start)
+        (vector-copy! to at from start (vector-length from)))
+      ((to at from start end)
+        (let loop ((i start)
+                   (j at))
+          (when (< i end)
+            (vector-set! to j (vector-ref from i))
+            (loop (+ 1 i) (+ 1 j)))))))
+
+
+  (define vector-copy
+    (case-lambda
+      ((v)
+        (vector-copy v 0 (vector-length v)))
+      ((v start)
+        (vector-copy v start (vector-length v)))
+      ((v start end)
+        (define v* (make-vector (- end start)))
+        (vector-copy! v* 0 v)
+        v*)))
+
+
+  (define (vector-append . vectors)
+    (define v (make-vector (apply + (map vector-length vectors))))
+    (let loop ((vs vectors)
+               (i 0))
+      (unless (null? vs)
+        (vector-copy! v i (car vs))
+        (loop (cdr vs)
+              (+ i (vector-length (car vs))))))
+    v)
+
+
+  (define (vector-map proc v1 . vs)
+    (define vs* (cons v1 vs))
+    (define n (apply min (map vector-length vs*)))
+    (define out (make-vector n))
+    (let loop ((i 0))
+      (when (< i n)
+        (vector-set! out i
+          (apply proc (map (lambda (v) (vector-ref v i)) vs*)))
+        (loop (+ 1 i))))
+    out)
+
+
+  (define (vector-for-each proc v1 . vs)
+    (define vs* (cons v1 vs))
+    (define n (apply min (map vector-length vs*)))
+    (let loop ((i 0))
+      (when (< i n)
+        (apply proc (map (lambda (v) (vector-ref v i)) vs*))
+        (loop (+ 1 i))))))