From: Chris Hanson <org/chris-hanson/cph>
Date: Mon, 10 Dec 2018 07:00:55 +0000 (-0800)
Subject: Fix bug in string-copy!.
X-Git-Tag: mit-scheme-pucked-10.1.7~3^2~5
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=e3e8ca0cb0ea3f7261fdc85e0bcec3b87e0fa973;p=mit-scheme.git

Fix bug in string-copy!.
---

diff --git a/src/runtime/string.scm b/src/runtime/string.scm
index 734ece894..862f9396b 100644
--- a/src/runtime/string.scm
+++ b/src/runtime/string.scm
@@ -450,74 +450,106 @@ USA.
   (define-integrable (zero! j o)
     (primitive-byte-set! to (fix:+ j o) 0))
 
-  (case (ustring-cp-size from)
-    ((1)
-     (let ((start (cp1-index start))
-	   (end (cp1-index end)))
-       (case (ustring-cp-size to)
-	 ((1)
-	  (do ((i start (fix:+ i 1))
-	       (j (cp1-index at) (fix:+ j 1)))
-	      ((not (fix:< i end)))
-	    (copy! j i 0)))
-	 ((2)
-	  (do ((i start (fix:+ i 1))
-	       (j (cp2-index at) (fix:+ j 2)))
-	      ((not (fix:< i end)))
-	    (copy! j i 0)
-	    (zero! j 1)))
-	 (else
-	  (do ((i start (fix:+ i 1))
-	       (j (cp3-index at) (fix:+ j 3)))
-	      ((not (fix:< i end)))
-	    (copy! j i 0)
-	    (zero! j 1)
-	    (zero! j 2))))))
-    ((2)
-     (let ((start (cp2-index start))
-	   (end (cp2-index end)))
-       (case (ustring-cp-size to)
-	 ((1)
-	  (do ((i start (fix:+ i 2))
-	       (j (cp1-index at) (fix:+ j 1)))
-	      ((not (fix:< i end)))
-	    (copy! j i 0)))
-	 ((2)
-	  (do ((i start (fix:+ i 2))
-	       (j (cp2-index at) (fix:+ j 2)))
-	      ((not (fix:< i end)))
-	    (copy! j i 0)
-	    (copy! j i 1)))
-	 (else
-	  (do ((i start (fix:+ i 2))
-	       (j (cp3-index at) (fix:+ j 3)))
-	      ((not (fix:< i end)))
-	    (copy! j i 0)
-	    (copy! j i 1)
-	    (zero! j 2))))))
-    (else
-     (let ((start (cp3-index start))
-	   (end (cp3-index end)))
-       (case (ustring-cp-size to)
-	 ((1)
-	  (do ((i start (fix:+ i 3))
-	       (j (cp1-index at) (fix:+ j 1)))
-	      ((not (fix:< i end)))
-	    (copy! j i 0)))
-	 ((2)
-	  (do ((i start (fix:+ i 3))
-	       (j (cp2-index at) (fix:+ j 2)))
-	      ((not (fix:< i end)))
-	    (copy! j i 0)
-	    (copy! j i 1)))
-	 (else
-	  (do ((i start (fix:+ i 3))
-	       (j (cp3-index at) (fix:+ j 3)))
-	      ((not (fix:< i end)))
-	    (copy! j i 0)
-	    (copy! j i 1)
-	    (copy! j i 2))))))))
+  (if (eq? to from)
+      (%general-shift! to at start end)
+      (case (ustring-cp-size from)
+	((1)
+	 (let ((start (cp1-index start))
+	       (end (cp1-index end)))
+	   (case (ustring-cp-size to)
+	     ((1)
+	      (do ((i start (fix:+ i 1))
+		   (j (cp1-index at) (fix:+ j 1)))
+		  ((not (fix:< i end)))
+		(copy! j i 0)))
+	     ((2)
+	      (do ((i start (fix:+ i 1))
+		   (j (cp2-index at) (fix:+ j 2)))
+		  ((not (fix:< i end)))
+		(copy! j i 0)
+		(zero! j 1)))
+	     (else
+	      (do ((i start (fix:+ i 1))
+		   (j (cp3-index at) (fix:+ j 3)))
+		  ((not (fix:< i end)))
+		(copy! j i 0)
+		(zero! j 1)
+		(zero! j 2))))))
+	((2)
+	 (let ((start (cp2-index start))
+	       (end (cp2-index end)))
+	   (case (ustring-cp-size to)
+	     ((1)
+	      (do ((i start (fix:+ i 2))
+		   (j (cp1-index at) (fix:+ j 1)))
+		  ((not (fix:< i end)))
+		(copy! j i 0)))
+	     ((2)
+	      (do ((i start (fix:+ i 2))
+		   (j (cp2-index at) (fix:+ j 2)))
+		  ((not (fix:< i end)))
+		(copy! j i 0)
+		(copy! j i 1)))
+	     (else
+	      (do ((i start (fix:+ i 2))
+		   (j (cp3-index at) (fix:+ j 3)))
+		  ((not (fix:< i end)))
+		(copy! j i 0)
+		(copy! j i 1)
+		(zero! j 2))))))
+	(else
+	 (let ((start (cp3-index start))
+	       (end (cp3-index end)))
+	   (case (ustring-cp-size to)
+	     ((1)
+	      (do ((i start (fix:+ i 3))
+		   (j (cp1-index at) (fix:+ j 1)))
+		  ((not (fix:< i end)))
+		(copy! j i 0)))
+	     ((2)
+	      (do ((i start (fix:+ i 3))
+		   (j (cp2-index at) (fix:+ j 2)))
+		  ((not (fix:< i end)))
+		(copy! j i 0)
+		(copy! j i 1)))
+	     (else
+	      (do ((i start (fix:+ i 3))
+		   (j (cp3-index at) (fix:+ j 3)))
+		  ((not (fix:< i end)))
+		(copy! j i 0)
+		(copy! j i 1)
+		(copy! j i 2)))))))))
 
+(define (%general-shift! ustring to start end)
+  (cond ((fix:< to start) (%shift-left! ustring to start end))
+	((fix:> to start) (%shift-right! ustring to start end))))
+
+(define (%shift-left! ustring to start end)
+
+  (define (do-shift! to start end)
+    (do ((i start (fix:+ i 1))
+	 (j to (fix:+ j 1)))
+	((not (fix:< i end)))
+      (primitive-byte-set! ustring j (primitive-byte-ref ustring i))))
+
+  (case (ustring-cp-size ustring)
+    ((1) (do-shift! (cp1-index to) (cp1-index start) (cp1-index end)))
+    ((2) (do-shift! (cp2-index to) (cp2-index start) (cp2-index end)))
+    (else (do-shift! (cp3-index to) (cp3-index start) (cp3-index end)))))
+
+(define (%shift-right! ustring to start end)
+
+  (define (do-shift! to start end)
+    (do ((i (fix:- end 1) (fix:- i 1))
+	 (j (fix:- (fix:+ to (fix:- end start)) 1) (fix:- j 1)))
+	((not (fix:>= i start)))
+      (primitive-byte-set! ustring j (primitive-byte-ref ustring i))))
+
+  (case (ustring-cp-size ustring)
+    ((1) (do-shift! (cp1-index to) (cp1-index start) (cp1-index end)))
+    ((2) (do-shift! (cp2-index to) (cp2-index start) (cp2-index end)))
+    (else (do-shift! (cp3-index to) (cp3-index start) (cp3-index end)))))
+
 (define (%general-max-cp string start end)
 
   (define-integrable (max-loop cp-ref)
diff --git a/tests/runtime/test-string.scm b/tests/runtime/test-string.scm
index 06afec51b..cce837f41 100644
--- a/tests/runtime/test-string.scm
+++ b/tests/runtime/test-string.scm
@@ -3133,10 +3133,7 @@ USA.
 		   (string-copy! sut at sut start end)
 		   (assert-string= sut
 				   (string-copy!:predict s1 at s1 start end)
-				   'expression expr
-				   'expect-failure?
-				   (and (> at start)
-					(< at end))))))))
+				   'expression expr))))))
 	 (string-copy!:all-indices s1 s1))))
 
 (define (maybe-expect-failure expect-failure? body)
diff --git a/tests/unit-testing.scm b/tests/unit-testing.scm
index 567700fac..03033fc64 100644
--- a/tests/unit-testing.scm
+++ b/tests/unit-testing.scm
@@ -409,8 +409,8 @@ USA.
 (define (%assert predicate value description properties)
   (apply maybe-fail
 	 (predicate value)
-	     'result-object value
-	     'expectation-description description
+	 'result-object value
+	 'expectation-description description
 	 properties)
   (assertion-index (+ (assertion-index) 1)))
 
@@ -428,12 +428,12 @@ USA.
 			     (list condition-type:error)
 			     condition-types)))
     (let ((result
-    (call-with-current-continuation
-     (lambda (k)
+	   (call-with-current-continuation
+	     (lambda (k)
 	       (cons #f
-	      (bind-condition-handler
-		  condition-types
-		  (lambda (condition)
+		     (bind-condition-handler
+			 condition-types
+			 (lambda (condition)
 			   (k (cons #t condition)))
 		       thunk))))))
       (apply maybe-fail