Fix bug in string-copy!.

diff --git a/src/runtime/string.scm b/src/runtime/string.scm
index 734ece89450b55700e0332b020178c2183880a98..862f9396bfe6204883c63235764d752f4010d22c 100644 (file)
--- 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)))))))))
 \f
+(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 06afec51bc0bbfc8c9483d1d2513b0944076850c..cce837f41b76c98abd979d26a1f2f674e0052895 100644 (file)
--- 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 567700fac2fac700fbc82553f5af5533dbb2e92b..03033fc644cc8334e58c888a028c1671168ca778 100644 (file)
--- 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