Implement some R7RS string procedures.

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 760215ab2763777d78797f8b3aa25fedd6a731cc..4740682c96e2ada696d02da0477bec8f63dab22f 100644 (file)
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -1012,6 +1012,7 @@ USA.
          string-compare
          string-compare-ci
          string-copy
+         string-copy!
          string-downcase
          string-downcase!
          string-fill!
@@ -1021,12 +1022,14 @@ USA.
          string-find-previous-char
          string-find-previous-char-ci
          string-find-previous-char-in-set
+         string-for-each
          string-hash
          string-hash-mod
          string-head
          string-head!
          string-length
          string-lower-case?
+         string-map
          string-match-backward
          string-match-backward-ci
          string-match-forward

diff --git a/src/runtime/string.scm b/src/runtime/string.scm
index c044359247380cabe48dc461a3ae2e399fc9755f..4ef861ae7505a5ed8818dfdcbc289cb202529064 100644 (file)
--- a/src/runtime/string.scm
+++ b/src/runtime/string.scm
@@ -99,10 +99,11 @@ USA.
 (define (make-vector-8b length #!optional ascii)
   (make-string length (if (default-object? ascii) ascii (ascii->char ascii))))
 
-(define (string-fill! string char)
-  (guarantee-string string 'STRING-FILL!)
-  (guarantee-char char 'STRING-FILL!)
-  (%substring-fill! string 0 (string-length string) char))
+(define (string-fill! string char #!optional start end)
+  (substring-fill! string
+                  (if (default-object? start) 0 start)
+                  (if (default-object? end) (string-length string) end)
+                  char))
 
 (define (substring-fill! string start end char)
   (guarantee-substring string start end 'SUBSTRING-FILL)
@@ -144,15 +145,10 @@ USA.
   (guarantee-substring-start-index start (string-length string) 'STRING-TAIL)
   (%substring string start (string-length string)))
 
-(define (string-copy string)
-  (guarantee-string string 'STRING-COPY)
-  (%string-copy string))
-
-(define (%string-copy string)
-  (let ((size (string-length string)))
-    (let ((result (string-allocate size)))
-      (%substring-move! string 0 size result 0)
-      result)))
+(define (string-copy string #!optional start end)
+  (substring string
+            (if (default-object? start) 0 start)
+            (if (default-object? end) (string-length string) end)))
 
 (define (ascii-string-copy string)
   (guarantee-string string 'ASCII-STRING-COPY)
@@ -163,7 +159,6 @@ USA.
     (let ((result (string-allocate size)))
       (and (%ascii-substring-move! string 0 size result 0)
           result))))
-
 \f
 (define (string-head! string end)
   (declare (no-type-checks) (no-range-checks))
@@ -218,6 +213,60 @@ USA.
 (define %words->octets-shift
   (- %octets->words-shift))
 \f
+(define (%string-copy string)
+  (let ((size (string-length string)))
+    (let ((result (string-allocate size)))
+      (%substring-move! string 0 size result 0)
+      result)))
+
+(define (string-copy! to at from #!optional start end)
+  (substring-move! from
+                  (if (default-object? start) 0 start)
+                  (if (default-object? end) (string-length from) end)
+                  to
+                  at))
+
+(define (string-map procedure string . strings)
+  (if (pair? strings)
+      (let ((n
+            (apply min
+                   (string-length string)
+                   (map string-length strings))))
+       (let ((result (make-string n)))
+         (do ((i 0 (fix:+ i 1)))
+             ((not (fix:< i n)))
+           (string-set! result i
+                        (apply procedure
+                               (string-ref string i)
+                               (map (lambda (string)
+                                      (string-ref string i))
+                                    strings))))
+         result))
+      (let ((n (string-length string)))
+       (let ((result (make-string n)))
+         (do ((i 0 (fix:+ i 1)))
+             ((not (fix:< i n)))
+           (string-set! result i (procedure (string-ref string i))))
+         result))))
+
+(define (string-for-each procedure string . strings)
+  (if (pair? strings)
+      (let ((n
+            (apply min
+                   (string-length string)
+                   (map string-length strings))))
+       (do ((i 0 (fix:+ i 1)))
+           ((not (fix:< i n)) unspecific)
+         (apply procedure
+                (string-ref string i)
+                (map (lambda (string)
+                       (string-ref string i))
+                     strings))))
+      (let ((n (string-length string)))
+       (do ((i 0 (fix:+ i 1)))
+           ((not (fix:< i n)) unspecific)
+         (procedure (string-ref string i))))))
+\f
 (define (string . objects)
   (%string-append (map ->string objects)))
 
@@ -261,9 +310,10 @@ USA.
            (loop (cdr chars) (fix:+ index 1)))
          result))))
 
-(define (string->list string)
-  (guarantee-string string 'STRING->LIST)
-  (%substring->list string 0 (string-length string)))
+(define (string->list string #!optional start end)
+  (substring->list string
+                  (if (default-object? start) 0 start)
+                  (if (default-object? end) (string-length string) end)))
 
 (define (substring->list string start end)
   (guarantee-substring string start end 'SUBSTRING->LIST)