Implement STRING-MOVE! and SUBSTRING-MOVE!.

diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg
index 7d18004d31a396936a7665a30a8fdac739bf421b..13fd2c34c9ff654d39f5e9702e44911981b8f92e 100644 (file)
--- a/v7/src/runtime/runtime.pkg
+++ b/v7/src/runtime/runtime.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: runtime.pkg,v 14.345 2000/04/12 02:36:13 cph Exp $
+$Id: runtime.pkg,v 14.346 2000/04/13 20:11:32 cph Exp $
 
 Copyright (c) 1988-2000 Massachusetts Institute of Technology
 
@@ -121,6 +121,7 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
          string-match-forward
          string-match-forward-ci
          string-maximum-length
+         string-move!
          string-null?
          string-pad-left
          string-pad-right
@@ -167,6 +168,7 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
          substring-match-backward-ci
          substring-match-forward
          substring-match-forward-ci
+         substring-move!
          substring-move-left!
          substring-move-right!
          substring-prefix-ci?

diff --git a/v7/src/runtime/string.scm b/v7/src/runtime/string.scm
index 0703aa71256417d9ab03bfb77ee93c9694d05888..2d60d3e0b23756a2168513f5b89a8183fc553757 100644 (file)
--- a/v7/src/runtime/string.scm
+++ b/v7/src/runtime/string.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: string.scm,v 14.28 1999/12/31 04:44:46 cph Exp $
+$Id: string.scm,v 14.29 2000/04/13 20:11:29 cph Exp $
 
 Copyright (c) 1988-1999 Massachusetts Institute of Technology
 
@@ -259,6 +259,9 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
       (substring-move-right! string 0 size result 0)
       result)))
 
+(define (string-append . strings)
+  (%string-append strings))
+
 (define (%string-append strings)
   (let ((result
         (string-allocate
@@ -277,8 +280,42 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
            (substring-move-right! (car strings) 0 size result index)
            (loop (cdr strings) (fix:+ index size)))))))
 
-(define (string-append . strings)
-  (%string-append strings))
+(define (string-move! string1 string2 start2)
+  (guarantee-string string1 'STRING-MOVE!)
+  (%substring-move! string1 0 (string-length string1) string2 start2
+                   'STRING-MOVE!))
+
+(define (substring-move! string1 start1 end1 string2 start2)
+  (guarantee-substring string1 start1 end1 'SUBSTRING-MOVE!)
+  (%substring-move! string1 start1 end1 string2 start2
+                   'SUBSTRING-MOVE!))
+
+(define (%substring-move! string1 start1 end1 string2 start2 procedure)
+  (guarantee-string string2 procedure)
+  (guarantee-index/string start2 procedure)
+  (let* ((n (fix:- end1 start1))
+        (end2 (fix:+ start2 n)))
+    (if (not (fix:<= end2 (string-length string2)))
+       (error:bad-range-argument start2 procedure))
+    (if (fix:< n 32)
+       ;; When transferring less than 32 bytes, it's faster to do
+       ;; inline than to call the primitive.
+       (if (or (not (eq? string2 string1)) (fix:< start2 start1))
+           (let loop ((i1 start1) (i2 start2))
+             (if (fix:< i1 end1)
+                 (begin
+                   (string-set! string2 i2 (string-ref string1 i1))
+                   (loop (fix:+ i1 1) (fix:+ i2 1)))))
+           (let loop ((i1 end2) (i2 end2))
+             (if (fix:> i1 start1)
+                 (let ((i1 (fix:+ i1 1))
+                       (i2 (fix:+ i2 1)))
+                   (string-set! string2 i2 (string-ref string1 i1))
+                   (loop i1 i2)))))
+       (if (or (not (eq? string2 string1)) (fix:< start2 start1))
+           (substring-move-left! string1 start1 end1 string2 start2)
+           (substring-move-right! string1 start1 end1 string2 start2)))
+    end2))
 \f
 (define (burst-string string delimiter allow-runs?)
   (guarantee-string string 'BURST-STRING)