From: Chris Hanson <org/chris-hanson/cph>
Date: Mon, 29 Feb 2016 06:34:32 +0000 (-0800)
Subject: Implement more R7RS string and vector procedures.
X-Git-Tag: mit-scheme-pucked-9.2.12~261^2~84
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=69e6107cbc6b55ea1563824322cce87c9c599f91;p=mit-scheme.git

Implement more R7RS string and vector procedures.
---

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 4740682c9..5337ebc29 100644
--- 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 4ef861ae7..1912d956a 100644
--- 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 9f9443299..75baafbf1 100644
--- 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)))
 
 (define (vector-append . vectors)
   (let ((result
@@ -239,8 +243,27 @@ USA.
   (iref vector-eighth 7))
 
 (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?)