Ticket #1136: move-memory.patch

lolevel.scm

@@ -40 +40 @@
 # 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 +423 @@
         [(##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:

tests/lolevel-tests.scm

@@ -12 +12 @@
 (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

tests/runtests.sh

@@ -165 +165 @@
 
 echo "======================================== lolevel tests ..."
 $interpret -s lolevel-tests.scm
-$compile lolevel-tests.scm
+$compile -O3 lolevel-tests.scm
 ./a.out
 
 echo "======================================== arithmetic tests ..."

types.db

@@ -1501 +1501 @@
                  (((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))))