[Guile-commits] 02/03: Extend core vector-copy to r7rs vector-copy

[Daniel Llorens]

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

commit 6a998e047a83c6e15c0fdc5c92b19a5c1f3061b7
Author: Daniel Llorens <lloda@sarc.name>
AuthorDate: Thu Aug 5 19:43:21 2021 +0200

    Extend core vector-copy to r7rs vector-copy
    
    * libguile/vectors.h: Declare scm_vector_copy_partial.
    * libguile/vectors.c (scm_vector_copy_partial): As stated.
      (scm_vector_copy): Reuse scm_vector_copy_partial.
    * module/scheme/base.scm: Reuse core vector-copy.
    * module/srfi/srfi-43: Reuse core vector-copy.
    * test-suite/tests/vectors.test: Test vector-copy.
---
 doc/ref/api-data.texi         |  1 +
 libguile/vectors.c            | 40 ++++++++++++++++++++++++++++++++++------
 libguile/vectors.h            |  2 +-
 module/scheme/base.scm        | 24 +++---------------------
 module/srfi/srfi-43.scm       | 26 +++++++++++---------------
 test-suite/tests/vectors.test |  9 +++++++++
 6 files changed, 59 insertions(+), 43 deletions(-)

diff --git a/doc/ref/api-data.texi b/doc/ref/api-data.texi
index 2ad13f5..eb3d910 100644
--- a/doc/ref/api-data.texi
+++ b/doc/ref/api-data.texi
@@ -6387,6 +6387,7 @@ Store @var{fill} in every position of @var{vec}.  The 
value
 returned by @code{vector-fill!} is unspecified.
 @end deffn
 
+@rnindex vector-copy
 @deffn {Scheme Procedure} vector-copy vec
 @deffnx {C Function} scm_vector_copy (vec)
 Return a copy of @var{vec}.
diff --git a/libguile/vectors.c b/libguile/vectors.c
index 9558d88..7e1068d 100644
--- a/libguile/vectors.c
+++ b/libguile/vectors.c
@@ -265,17 +265,36 @@ scm_c_make_vector (size_t k, SCM fill)
 }
 #undef FUNC_NAME
 
-SCM_DEFINE (scm_vector_copy, "vector-copy", 1, 0, 0,
-           (SCM vec),
-           "Return a copy of @var{vec}.")
-#define FUNC_NAME s_scm_vector_copy
+SCM_DEFINE (scm_vector_copy_partial, "vector-copy", 1, 2, 0,
+           (SCM vec, SCM start, SCM end),
+            "Returns a freshly allocated vector containing the elements\n"
+            "of @var{vec} between @var{start} and @var{end}.\n\n"
+            "@var{start} defaults to 0 and @var{end} defaults to the\n"
+            "length of @var{vec}.")
+#define FUNC_NAME s_scm_vector_copy_partial
 {
   SCM result;
   if (SCM_I_IS_VECTOR (vec))
     {
-      size_t len = SCM_I_VECTOR_LENGTH (vec);
+      size_t cstart = 0, cend = SCM_I_VECTOR_LENGTH (vec);
+      
+      if (!SCM_UNBNDP (start))
+        {
+          cstart = scm_to_size_t (start);
+          SCM_ASSERT_RANGE (SCM_ARG2, start, cstart<=cend);
+
+          if (!SCM_UNBNDP (end))
+            {
+              size_t e = scm_to_size_t (end);
+              SCM_ASSERT_RANGE (SCM_ARG3, end, e>=cstart && e<=cend);
+              cend = e;
+            }
+        }
+
+      size_t len = cend-cstart;
       result = make_vector (len);
-      memcpy (SCM_I_VECTOR_WELTS (result), SCM_I_VECTOR_ELTS (vec), len * 
sizeof(SCM));
+      memcpy (SCM_I_VECTOR_WELTS (result), SCM_I_VECTOR_ELTS (vec) + cstart,
+              len * sizeof(SCM));
     }
   else
     {
@@ -290,6 +309,9 @@ SCM_DEFINE (scm_vector_copy, "vector-copy", 1, 0, 0,
         ("Using vector-copy on arrays is deprecated.  "
          "Use array-copy instead.");
 
+      if (SCM_UNBNDP (start))
+        scm_misc_error (s_scm_vector_copy_partial, "Too many arguments", 
SCM_EOL);
+
       result = make_vector (len);
       dst = SCM_I_VECTOR_WELTS (result);
       for (i = 0; i < len; i++, src += inc)
@@ -301,6 +323,12 @@ SCM_DEFINE (scm_vector_copy, "vector-copy", 1, 0, 0,
 }
 #undef FUNC_NAME
 
+SCM
+scm_vector_copy (SCM vec)
+{
+  return scm_vector_copy_partial (vec, SCM_UNDEFINED, SCM_UNDEFINED);
+}
+
 
 SCM_DEFINE (scm_vector_to_list, "vector->list", 1, 0, 0, 
            (SCM vec),
diff --git a/libguile/vectors.h b/libguile/vectors.h
index 41e2c89..1c04f9a 100644
--- a/libguile/vectors.h
+++ b/libguile/vectors.h
@@ -88,7 +88,7 @@ SCM_API SCM *scm_vector_writable_elements (SCM vec,
 #define SCM_I_VECTOR_LENGTH(x) (((size_t) SCM_CELL_WORD_0 (x)) >> 8)
 
 SCM_INTERNAL SCM  scm_i_vector_equal_p (SCM x, SCM y);
-
+SCM_INTERNAL SCM scm_vector_copy_partial (SCM vec, SCM start, SCM end);
 
 SCM_INTERNAL void scm_init_vectors (void);
 
diff --git a/module/scheme/base.scm b/module/scheme/base.scm
index 20e2804..fcb1f49 100644
--- a/module/scheme/base.scm
+++ b/module/scheme/base.scm
@@ -56,7 +56,6 @@
             bytevector bytevector-append
             string->vector vector->string
             (r7:string->utf8 . string->utf8)
-            (r7:vector-copy . vector-copy)
             (r7:vector->list . vector->list)
             (r7:vector-fill! . vector-fill!)
             vector-copy! vector-append vector-for-each vector-map
@@ -116,7 +115,7 @@
    (char-ready? . u8-ready?)
    unless
    unquote unquote-splicing values
-   vector
+   vector vector-copy
    vector-length vector-ref vector-set! vector?
    when with-exception-handler write-char
    zero?))
@@ -433,23 +432,6 @@
 
 ;;; vector
 
-(define (%subvector v start end)
-  (define mlen (- end start))
-  (define out (make-vector (- end start)))
-  (define (itr r)
-    (if (= r mlen)
-      out
-      (begin
-        (vector-set! out r (vector-ref v (+ start r)))
-        (itr (+ r 1)))))
-  (itr 0))
-
-(define r7:vector-copy
-  (case-lambda*
-    ((v) (vector-copy v))
-    ((v start #:optional (end (vector-length v)))
-     (%subvector v start end))))
-
 (define* (vector-copy! target tstart source
                        #:optional (sstart 0) (send (vector-length source)))
   "Copy a block of elements from SOURCE to TARGET, both of which must be
@@ -467,7 +449,7 @@ defaults to 0 and SEND defaults to the length of SOURCE."
   (case-lambda*
     ((v) (vector->list v))
     ((v start #:optional (end (vector-length v)))
-     (vector->list (%subvector v start end)))))
+     (vector->list (vector-copy v start end)))))
 
 (define vector-map
   (case-lambda*
@@ -518,7 +500,7 @@ defaults to 0 and SEND defaults to the length of SOURCE."
   (case-lambda*
     ((v) (list->string (vector->list v)))
     ((v start #:optional (end (vector-length v)))
-     (vector->string (%subvector v start end)))))
+     (vector->string (vector-copy v start end)))))
 
 (define r7:vector-fill!
   (case-lambda*
diff --git a/module/srfi/srfi-43.scm b/module/srfi/srfi-43.scm
index eb6d8c3..f8e38e2 100644
--- a/module/srfi/srfi-43.scm
+++ b/module/srfi/srfi-43.scm
@@ -204,7 +204,6 @@ error for the number of seeds to vary between iterations."
 
 (define guile-vector-copy (@ (guile) vector-copy))
 
-;; TODO: Enhance Guile core 'vector-copy' to do this.
 (define vector-copy
   (case-lambda*
    "(vector-copy vec [start [end [fill]]]) -> vector
@@ -217,23 +216,20 @@ VEC, the slots in the new vector that obviously cannot be 
filled by
 elements from VEC are filled with FILL, whose default value is
 unspecified."
    ((v) (guile-vector-copy v))
-   ((v start)
-    (assert-vector v 'vector-copy)
-    (let ((len (vector-length v)))
-      (assert-valid-start start len 'vector-copy)
-      (let ((result (make-vector (- len start))))
-        (vector-move-left! v start len result 0)
-        result)))
+   ((v start) (guile-vector-copy v start))
    ((v start end #:optional (fill *unspecified*))
     (assert-vector v 'vector-copy)
     (let ((len (vector-length v)))
-      (unless (and (exact-integer? start)
-                   (exact-integer? end)
-                   (<= 0 start end))
-        (error-from 'vector-copy "invalid index range" start end))
-      (let ((result (make-vector (- end start) fill)))
-        (vector-move-left! v start (min end len) result 0)
-        result)))))
+      (if (<= end len)
+        (guile-vector-copy v start end)
+        (begin
+          (unless (and (exact-integer? start)
+                       (exact-integer? end)
+                       (<= 0 start end))
+            (error-from 'vector-copy "invalid index range" start end))
+          (let ((result (make-vector (- end start) fill)))
+            (vector-move-left! v start (min end len) result 0)
+            result)))))))
 
 (define vector-reverse-copy
   (let ()
diff --git a/test-suite/tests/vectors.test b/test-suite/tests/vectors.test
index 97b3f18..8bdbc89 100644
--- a/test-suite/tests/vectors.test
+++ b/test-suite/tests/vectors.test
@@ -31,6 +31,15 @@
     exception:immutable-vector
     (vector-set! '#(1 2 3) 0 4)))
 
+(with-test-prefix "vector-copy"
+
+  (pass-if "defaults"
+    (equal? #(1 2 3) (vector-copy #(1 2 3))))
+  (pass-if "default end"
+    (equal? #(2 3) (vector-copy #(1 2 3) 1)))
+  (pass-if "start end"
+    (equal? #(2) (vector-copy #(1 2 3) 1 2))))
+
 (with-test-prefix "vector->list"
 
   (pass-if "simple vector"