From e3e8ca0cb0ea3f7261fdc85e0bcec3b87e0fa973 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Sun, 9 Dec 2018 23:00:55 -0800 Subject: [PATCH] Fix bug in string-copy!. --- src/runtime/string.scm | 166 ++++++++++++++++++++-------------- tests/runtime/test-string.scm | 5 +- tests/unit-testing.scm | 14 +-- 3 files changed, 107 insertions(+), 78 deletions(-) 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 -- 2.25.1