Implement more R7RS string and vector procedures.

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 4740682c96e2ada696d02da0477bec8f63dab22f..5337ebc2943da8308241ee8793865a5493599cb0 100644 (file)
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -805,9 +805,11 @@ USA.
          subvector-uniform?
          vector
          vector->list
+         vector->string
          vector-append
          vector-binary-search
          vector-copy
+         vector-copy!
          vector-eighth
          vector-fifth
          vector-fill!
@@ -998,6 +1000,7 @@ USA.
          set-string-length!
          string
          string->list
+         string->vector
          string-allocate
          string-append
          string-capitalize

diff --git a/src/runtime/string.scm b/src/runtime/string.scm
index 4ef861ae7505a5ed8818dfdcbc289cb202529064..1912d956a9bccc8f675d671ea652ce8f09c29616 100644 (file)
--- a/src/runtime/string.scm
+++ b/src/runtime/string.scm
@@ -226,6 +226,18 @@ USA.
                   to
                   at))
 
+(define (string->vector string #!optional start end)
+  (let ((start (if (default-object? start) 0 start))
+       (end (if (default-object? end) (string-length string) end)))
+    (guarantee-substring string start end 'SUBSTRING)
+    (let ((result (make-vector (fix:- end start))))
+      (do ((i start (fix:+ i 1)))
+         ((not (fix:< i end)))
+       (vector-set! result
+                    (fix:- i start)
+                    (string-ref string i)))
+      result)))
+
 (define (string-map procedure string . strings)
   (if (pair? strings)
       (let ((n

diff --git a/src/runtime/vector.scm b/src/runtime/vector.scm
index 9f944329903d3bf15dfe19832dabd1360d59720c..75baafbf1e210cfa863e0619f58d1729831276b2 100644 (file)
--- a/src/runtime/vector.scm
+++ b/src/runtime/vector.scm
@@ -63,13 +63,16 @@ USA.
       (error:wrong-type-argument size "vector index" 'MAKE-VECTOR))
   ((ucode-primitive vector-cons) size (if (default-object? fill) #f fill)))
 
-(define (vector->list vector)
-  (guarantee-vector vector 'VECTOR->LIST)
-  (subvector->list vector 0 (vector-length vector)))
+(define (vector->list vector #!optional start end)
+  (subvector->list vector
+                  (if (default-object? start) 0 start)
+                  (if (default-object? end) (vector-length vector) end)))
 
-(define (vector-fill! vector value)
-  (guarantee-vector vector 'VECTOR-FILL!)
-  (subvector-fill! vector 0 (vector-length vector) value))
+(define (vector-fill! vector value #!optional start)
+  (subvector-fill! vector
+                  (if (default-object? start) 0 start)
+                  (if (default-object? end) (vector-length vector) end)
+                  value))
 
 (define (subvector vector start end)
   (guarantee-subvector vector start end 'SUBVECTOR)
@@ -92,12 +95,13 @@ USA.
   (guarantee-vector vector 'VECTOR-TAIL)
   (subvector vector start (vector-length vector)))
 
-(define (vector-copy vector)
-  (guarantee-vector vector 'VECTOR-COPY)
-  (let ((length (vector-length vector)))
-    (let ((new-vector (make-vector length)))
-      (subvector-move-right! vector 0 length new-vector 0)
-      new-vector)))
+(define (vector-copy vector #!optional start end)
+  (let ((start (if (default-object? start) 0 start))
+       (end (if (default-object? end) (vector-length vector) end)))
+    (guarantee-subvector vector start end 'VECTOR-COPY)
+    (let ((result (make-vector (fix:- end start))))
+      (subvector-move-right! vector start end result 0)
+      result)))
 \f
 (define (vector-append . vectors)
   (let ((result
@@ -239,8 +243,27 @@ USA.
   (iref vector-eighth 7))
 \f
 (define (vector-move! v1 v2)
-  (guarantee-vector v1 'VECTOR-MOVE!)
-  (subvector-move-left! v1 0 (vector-length v1) v2 0))
+  (vector-copy! v2 0 v1))
+
+(define (vector-copy! to at from #!optional start end)
+  (let ((start (if (default-object? start) 0 start))
+       (end (if (default-object? end) (vector-length from) end)))
+    (cond ((or (not (eq? to from)) (fix:< to start))
+          (subvector-move-left! from start end to at))
+         ((fix:> to start)
+          (subvector-move-right! from start end to at)))))
+
+(define (vector->string vector #!optional start end)
+  (let ((start (if (default-object? start) 0 start))
+       (end (if (default-object? end) (vector-length vector) end)))
+    (guarantee-subvector vector start end 'vector->string)
+    (let ((result (make-string (fix:- end start))))
+      (do ((i start (fix:+ i 1)))
+         ((not (fix:< i end)))
+       (string-set! result
+                    (fix:- i start)
+                    (vector-ref vector i)))
+      result)))
 
 (define (subvector-filled? vector start end element)
   (guarantee-subvector vector start end 'SUBVECTOR-FILLED?)