>From e08baa6fb140269063b106ad09f675488043fb8a Mon Sep 17 00:00:00 2001
From: Peter Bex <address@hidden>
Date: Sun, 13 Jul 2014 13:52:51 +0200
Subject: [PATCH] Fix bug in move-memory! for overlapping memory regions
 (#1136).

Also fix its specialization to use C_bytes instead of C_w2b() which
is defined locally to lolevel.scm and isn't available in programs.
---
 NEWS                    |    2 ++
 lolevel.scm             |    3 +--
 tests/lolevel-tests.scm |   22 ++++++++++++++++++++++
 tests/runtests.sh       |    2 +-
 types.db                |    2 +-
 5 files changed, 27 insertions(+), 4 deletions(-)

diff --git a/NEWS b/NEWS
index a9c7732..0b2750b 100644
--- a/NEWS
+++ b/NEWS
@@ -8,6 +8,8 @@
      require extras but use procedures from it.
   - SRFI-13: fix string-copy! in cases source and destination strings'
     memory areas overlap (#1135).
+  - Fixed another, similar bug in move-memory! for overlapping memory.
+  - Fixed broken specialisation for move-memory! on pointer types.
   - Fixed bug in make-kmp-restart-vector from SRFI-13.
   - Removed deprecated implicit expansion of $VAR- and ~ in pathnames.
      The ~-expansion functionality is now available in the
diff --git a/lolevel.scm b/lolevel.scm
index 86ae299..f847917 100644
--- a/lolevel.scm
+++ b/lolevel.scm
@@ -40,7 +40,6 @@
 # include <sys/mman.h>
 #endif
 
-#define C_w2b(x)                   C_fix(C_wordstobytes(C_unfix(x)))
 #define C_memmove_o(to, from, n, toff, foff) C_memmove((char *)(to) + (toff), (char *)(from) + (foff), (n))
 EOF
 ) )
@@ -424,7 +423,7 @@ EOF
 	[(##core#inline "C_byteblockp" x)
 	 (##sys#size x)]
 	[else
-	 (##core#inline "C_w2b" (##sys#size x))] ) )
+	 (##core#inline "C_bytes" (##sys#size x))] ) )
 
 
 ;;; Record objects:
diff --git a/tests/lolevel-tests.scm b/tests/lolevel-tests.scm
index 886a07a..d0398fa 100644
--- a/tests/lolevel-tests.scm
+++ b/tests/lolevel-tests.scm
@@ -12,6 +12,28 @@
 (let ((s "..."))
   (assert-error (move-memory! "abc" s 3 -1)))
 
+; overlapping src and dest, moving "right" (from SRFI-13 tests)
+(assert (string=?
+	 "aabce"
+	 (let ((str (string-copy "abcde")))
+	   (move-memory! str str 3 0 1) str)))
+;; Specialisation rewrite from types.db
+(assert (string=?
+	 "aabce"
+	 (let ((str (string-copy "abcde")))
+	   (move-memory! (make-locative str) (make-locative str) 3 0 1) str)))
+
+; overlapping src and dest, moving "left" (from SRFI-13 tests)
+(assert (string=?
+	 "bcdde"
+	 (let ((str (string-copy "abcde")))
+	   (move-memory! str str 3 1) str)))
+;; Specialisation rewrite from types.db
+(assert (string=?
+	 "bcdde"
+	 (let ((str (string-copy "abcde")))
+	   (move-memory! (make-locative str) (make-locative str) 3 1) str)))
+
 ; object-copy
 
 ; allocate
diff --git a/tests/runtests.sh b/tests/runtests.sh
index 5007f8a..5b6f83c 100755
--- a/tests/runtests.sh
+++ b/tests/runtests.sh
@@ -165,7 +165,7 @@ echo "*** Skipping \"feeley-dynwind\" for now ***"
 
 echo "======================================== lolevel tests ..."
 $interpret -s lolevel-tests.scm
-$compile lolevel-tests.scm
+$compile -specialize lolevel-tests.scm
 ./a.out
 
 echo "======================================== arithmetic tests ..."
diff --git a/types.db b/types.db
index bb9bb8e..ac63782 100644
--- a/types.db
+++ b/types.db
@@ -1501,7 +1501,7 @@
 		 (((or port procedure symbol pair vector locative float pointer-vector))
 		  ;; would be applicable to all structure types, but we can't specify
 		  ;; "(struct *)" (yet)
-		  (##core#inline "C_w2b" (##sys#size #(1)))))
+		  (##core#inline "C_bytes" (##sys#size #(1)))))
 
 (number-of-slots (#(procedure #:clean) number-of-slots (*) fixnum)
 		 (((or vector symbol pair)) (##sys#size #(1))))
-- 
1.7.10.4