~ chicken-core (chicken-5) e29b85b242178e2b9b3317a3e8031af76dce2316

commit e29b85b242178e2b9b3317a3e8031af76dce2316
Author:     Peter Bex <peter.bex@xs4all.nl>
AuthorDate: Sun Jul 13 13:52:51 2014 +0200
Commit:     Christian Kellermann <ckeen@pestilenz.org>
CommitDate: Wed Jul 23 20:50:05 2014 +0200

    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.
    
    Signed-off-by: Christian Kellermann <ckeen@pestilenz.org>

diff --git a/NEWS b/NEWS
index 37800161..20ece383 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/chicken.h b/chicken.h
index 6473358a..fc40303b 100644
--- a/chicken.h
+++ b/chicken.h
@@ -1303,8 +1303,8 @@ extern double trunc(double);
 
 #define C_copy_memory(to, from, n)      (C_memcpy(C_data_pointer(to), C_data_pointer(from), C_unfix(n)), C_SCHEME_UNDEFINED)
 #define C_copy_ptr_memory(to, from, n, toff, foff) \
-  (C_memcpy(C_pointer_address(to) + C_unfix(toff), C_pointer_address(from) + C_unfix(foff), \
-	    C_unfix(n)), C_SCHEME_UNDEFINED)
+  (C_memmove(C_pointer_address(to) + C_unfix(toff), C_pointer_address(from) + C_unfix(foff), \
+	     C_unfix(n)), C_SCHEME_UNDEFINED)
 #define C_set_memory(to, c, n)          (C_memset(C_data_pointer(to), C_character_code(c), C_unfix(n)), C_SCHEME_UNDEFINED)
 #define C_string_compare(to, from, n)   C_fix(C_memcmp(C_c_string(to), C_c_string(from), C_unfix(n)))
 #define C_string_compare_case_insensitive(from, to, n) \
diff --git a/lolevel.scm b/lolevel.scm
index 4056ca8c..b8ed9952 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 886a07ae..d0398fac 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 5007f8a7..5b6f83c0 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 2ec7bfd1..2621686a 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))))