From d9701cddf91f2fd34a58753d983d6242e375a0e5 Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
Date: Thu, 13 Apr 2000 20:11:32 +0000
Subject: [PATCH] Implement STRING-MOVE! and SUBSTRING-MOVE!.

---
 v7/src/runtime/runtime.pkg |  4 +++-
 v7/src/runtime/string.scm  | 43 +++++++++++++++++++++++++++++++++++---
 2 files changed, 43 insertions(+), 4 deletions(-)

diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg
index 7d18004d3..13fd2c34c 100644
--- 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 0703aa712..2d60d3e0b 100644
--- 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))
 
 (define (burst-string string delimiter allow-runs?)
   (guarantee-string string 'BURST-STRING)
-- 
2.25.1