[Guile-commits] 15/27: Rewrite vector-copy! using memmove

[Daniel Llorens]

lloda pushed a commit to branch wip-vector-cleanup
in repository guile.

commit 93afe6b7f78e918bb322ad384d660e7da85ccc31
Author: Daniel Llorens <address@hidden>
AuthorDate: Thu Feb 6 13:19:59 2020 +0100

    Rewrite vector-copy! using memmove
    
    * libguile/vectors.c (vector-copy!): As stated. Provide C binding
      scm_vector_copy_x.
    * module/srfi/srfi-43.scm: Re-export vector-copy! from core.
      (vector-reverse-copy!): Remove definer macro, simplify.
    * doc/ref/api-data.texi: Document vector-copy!.
---
 NEWS-wip-vector-cleanup.txt |  5 +++
 doc/ref/api-data.texi       | 13 ++++++++
 libguile/vectors.c          | 31 +++++++++++++++++--
 libguile/vectors.h          |  4 ++-
 module/srfi/srfi-43.scm     | 75 ++++++++++++---------------------------------
 5 files changed, 69 insertions(+), 59 deletions(-)

diff --git a/NEWS-wip-vector-cleanup.txt b/NEWS-wip-vector-cleanup.txt
index b8770e1..c45e643 100644
--- a/NEWS-wip-vector-cleanup.txt
+++ b/NEWS-wip-vector-cleanup.txt
@@ -56,6 +56,11 @@ These functions weren't advertised to work on non-vector 
arrays. They did try to
 instead of the correct result #1@1(0 1 2 0 0). This buggy support has been 
removed.
 
 
+* Compatible changes
+
+** vector-copy! from (srfi :43) is provided in core.
+
+
 * Rationale / TODO
 
 The ultimate goal of this patch set is to have arrays be strictly layered 
above typed vectors so they can be replaced by a different implementation 
without affecting the latter.
diff --git a/doc/ref/api-data.texi b/doc/ref/api-data.texi
index 010d4c8..5c49272 100644
--- a/doc/ref/api-data.texi
+++ b/doc/ref/api-data.texi
@@ -6390,6 +6390,19 @@ returned by @code{vector-fill!} is unspecified.
 Return a copy of @var{vec}.
 @end deffn
 
+@deffn {Scheme Procedure} vector-copy! target tstart source [sstart [send]]
+@deffnx {C Function} scm_vector_copy_x (target tstart source, sstart, send)
+Copy a block of elements from @var{source} to @var{target}, both of
+which must be vectors, starting in @var{target} at @var{tstart} and
+starting in @var{source} at @var{sstart}, ending when (@var{send} -
+@var{sstart}) elements have been copied.  It is an error for
+@var{target} to have a length less than (@var{tstart} + @var{send} -
+@var{sstart}).  @var{sstart} defaults to 0 and @var{send} defaults to
+the length of @var{source}.
+
+This function is also provided as part of @ref{SRFI-43}.
+@end deffn
+
 @deffn {Scheme Procedure} vector-move-left! vec1 start1 end1 vec2 start2
 @deffnx {C Function} scm_vector_move_left_x (vec1, start1, end1, vec2, start2)
 Copy elements from @var{vec1}, positions @var{start1} to @var{end1},
diff --git a/libguile/vectors.c b/libguile/vectors.c
index 4b35259..dc483c4 100644
--- a/libguile/vectors.c
+++ b/libguile/vectors.c
@@ -331,8 +331,35 @@ scm_i_vector_equal_p (SCM x, SCM y)
   return SCM_BOOL_T;
 }
 
-// These functions are used by vector-copy!
-// FIXME split into vector- and array- (?)
+SCM_DEFINE (scm_vector_copy_x, "vector-copy!", 3, 2, 0,
+            (SCM target, SCM tstart, SCM source, SCM sstart, SCM send),
+            "Copy a block of elements from @var{source} to @var{target}, "
+            "both of which must be vectors, starting in @var{target} at "
+            "@var{tstart} and starting in @var{source} at @var{sstart}, ending 
"
+            "when @var{send} - @var{sstart} elements have been copied.\n\n"
+            "It is an error for @var{target} to have a length less than "
+            "@var{tstart} + (@var{send} - @var{sstart}).  @var{sstart} 
defaults "
+            "to 0 and @var{send} defaults to the length of @var{source}.\n\n"
+            "If @var{target} and @var{source} are the same vector, then 
copying takes "
+            "place as though the elements in @var{source} are first copied 
into a "
+            "temporary vector, and that temporary vector is then copied to 
@var{target}.")
+#define FUNC_NAME s_scm_vector_copy_x
+{
+  size_t slen, tlen;
+  const SCM *s = scm_vector_elements (source, &slen);
+  SCM *t = scm_vector_writable_elements (target, &tlen);
+
+  size_t t0, s0, len;
+  t0 = scm_to_unsigned_integer (tstart, 0, tlen);
+  s0 = (SCM_UNBNDP (sstart)) ? 0 : scm_to_unsigned_integer (sstart, 0, slen);
+  len = ((SCM_UNBNDP (send)) ? slen : scm_to_unsigned_integer (send, s0, 
slen)) - s0;
+  SCM_ASSERT_RANGE (SCM_ARG3, source, t0+len <= tlen);
+
+  memmove(t + t0, s + s0, len * sizeof(SCM));
+
+  return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
 
 SCM_DEFINE (scm_vector_move_left_x, "vector-move-left!", 5, 0, 0, 
             (SCM vec1, SCM start1, SCM end1, SCM vec2, SCM start2),
diff --git a/libguile/vectors.h b/libguile/vectors.h
index fe5f927..a6f569d 100644
--- a/libguile/vectors.h
+++ b/libguile/vectors.h
@@ -36,11 +36,13 @@ SCM_API SCM scm_vector_set_x (SCM v, SCM k, SCM obj);
 SCM_API SCM scm_make_vector (SCM k, SCM fill);
 SCM_API SCM scm_vector_to_list (SCM v);
 SCM_API SCM scm_vector_fill_x (SCM v, SCM fill_x);
+SCM_API SCM scm_vector_copy (SCM vec);
+SCM_API SCM scm_vector_copy_x (SCM target, SCM tstart,
+                               SCM source, SCM sstart, SCM send);
 SCM_API SCM scm_vector_move_left_x (SCM vec1, SCM start1, SCM end1,
                                    SCM vec2, SCM start2);
 SCM_API SCM scm_vector_move_right_x (SCM vec1, SCM start1, SCM end1, 
                                     SCM vec2, SCM start2);
-SCM_API SCM scm_vector_copy (SCM vec);
 
 SCM_API int scm_is_vector (SCM obj);
 SCM_API SCM scm_c_make_vector (size_t len, SCM fill);
diff --git a/module/srfi/srfi-43.scm b/module/srfi/srfi-43.scm
index eb6d8c3..2d042ed 100644
--- a/module/srfi/srfi-43.scm
+++ b/module/srfi/srfi-43.scm
@@ -22,7 +22,7 @@
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-8)
   #:re-export (make-vector vector vector? vector-ref vector-set!
-                           vector-length vector-fill!)
+                           vector-length vector-fill! vector-copy!)
   #:replace (vector-copy list->vector vector->list)
   #:export (vector-empty? vector= vector-unfold vector-unfold-right
                           vector-reverse-copy
@@ -35,7 +35,7 @@
                           vector-binary-search
                           vector-any vector-every
                           vector-swap! vector-reverse!
-                          vector-copy! vector-reverse-copy!
+                          vector-reverse-copy!
                           reverse-vector->list
                           reverse-list->vector))
 
@@ -900,57 +900,8 @@ START defaults to 0 and END defaults to the length of VEC."
        (assert-valid-range start end len 'vector-reverse!)
        (%vector-reverse! vec start end)))))
 
-(define-syntax-rule (define-vector-copier! copy! docstring inner-proc)
-  (define copy!
-    (let ((%copy! inner-proc))
-      (case-lambda
-        docstring
-        ((target tstart source)
-         (assert-vector target 'copy!)
-         (assert-vector source 'copy!)
-         (let ((tlen (vector-length target))
-               (slen (vector-length source)))
-           (assert-valid-start tstart tlen 'copy!)
-           (unless (>= tlen (+ tstart slen))
-             (error-from 'copy! "would write past end of target"))
-           (%copy! target tstart source 0 slen)))
-
-        ((target tstart source sstart)
-         (assert-vector target 'copy!)
-         (assert-vector source 'copy!)
-         (let ((tlen (vector-length target))
-               (slen (vector-length source)))
-           (assert-valid-start tstart tlen 'copy!)
-           (assert-valid-start sstart slen 'copy!)
-           (unless (>= tlen (+ tstart (- slen sstart)))
-             (error-from 'copy! "would write past end of target"))
-           (%copy! target tstart source sstart slen)))
-
-        ((target tstart source sstart send)
-         (assert-vector target 'copy!)
-         (assert-vector source 'copy!)
-         (let ((tlen (vector-length target))
-               (slen (vector-length source)))
-           (assert-valid-start tstart tlen 'copy!)
-           (assert-valid-range sstart send slen 'copy!)
-           (unless (>= tlen (+ tstart (- send sstart)))
-             (error-from 'copy! "would write past end of target"))
-           (%copy! target tstart source sstart send)))))))
-
-(define-vector-copier! vector-copy!
-  "(vector-copy! target tstart source [sstart [send]]) -> unspecified
-
-Copy a block of elements from SOURCE to TARGET, both of which must be
-vectors, starting in TARGET at TSTART and starting in SOURCE at
-SSTART, ending when SEND - SSTART elements have been copied.  It is an
-error for TARGET to have a length less than TSTART + (SEND - SSTART).
-SSTART defaults to 0 and SEND defaults to the length of SOURCE."
-  (lambda (target tstart source sstart send)
-    (if (< tstart sstart)
-        (vector-move-left!  source sstart send target tstart)
-        (vector-move-right! source sstart send target tstart))))
-
-(define-vector-copier! vector-reverse-copy!
+(define vector-reverse-copy!
+  (case-lambda
   "(vector-reverse-copy! target tstart source [sstart [send]]) -> unspecified
 
 Like vector-copy!, but copy the elements in the reverse order.  It is
@@ -958,13 +909,25 @@ an error if TARGET and SOURCE are identical vectors and 
the TARGET and
 SOURCE ranges overlap; however, if TSTART = SSTART,
 vector-reverse-copy! behaves as (vector-reverse! TARGET TSTART SEND)
 would."
-  (lambda (target tstart source sstart send)
-    (if (and (eq? target source) (= tstart sstart))
+   ((target tstart source)
+    (vector-reverse-copy! target tstart source 0 (vector-length source)))
+   ((target tstart source sstart)
+    (vector-reverse-copy! target tstart source sstart (vector-length source)))
+   ((target tstart source sstart send)
+    (assert-vector target 'copy!)
+    (assert-vector source 'copy!)
+    (let ((tlen (vector-length target))
+          (slen (vector-length source)))
+      (assert-valid-start tstart tlen 'copy!)
+      (assert-valid-range sstart send slen 'copy!)
+      (unless (>= tlen (+ tstart (- send sstart)))
+        (error-from 'copy! "would write past end of target"))
+      (if (and (eq? target source) (= tstart sstart))
         (%vector-reverse! target sstart send)
         (let loop ((i tstart) (j (- send 1)))
           (when (>= j sstart)
             (vector-set! target i (vector-ref source j))
-            (loop (+ i 1) (- j 1)))))))
+            (loop (+ i 1) (- j 1)))))))))
 
 (define vector->list
   (let ()