[Guile-commits] branch main updated: New function bitvector-copy (scm_bitvector_copy)

[Daniel Llorens]

This is an automated email from the git hooks/post-receive script.

lloda pushed a commit to branch main
in repository guile.

The following commit(s) were added to refs/heads/main by this push:
     new d70c1dbeb New function bitvector-copy (scm_bitvector_copy)
d70c1dbeb is described below

commit d70c1dbebf9ac0fd45af4578c23983ec4a7da535
Author: Daniel Llorens <lloda@sarc.name>
AuthorDate: Tue Jan 4 12:15:45 2022 +0100

    New function bitvector-copy (scm_bitvector_copy)
    
    * libguile/bitvectors.h:
    * libguile/bitvectors.c: As stated.
    * test-suite/tests/bitvectors.test: Tests.
    * doc/ref/api-data.texi: Update "Bit vectors" section.
    * NEWS: Update.
---
 NEWS                             |  4 ++++
 doc/ref/api-data.texi            |  7 ++++++
 libguile/bitvectors.c            | 47 ++++++++++++++++++++++++++++++++++++++++
 libguile/bitvectors.h            |  1 +
 test-suite/tests/bitvectors.test | 23 ++++++++++++++++++--
 5 files changed, 80 insertions(+), 2 deletions(-)

diff --git a/NEWS b/NEWS
index a92a9f85d..0a8b771f7 100644
--- a/NEWS
+++ b/NEWS
@@ -53,6 +53,10 @@ Bytevectors" in the manual.
 Compared to the previous versions, these accept range arguments. See
 "Accessing and Modifying Vector Contents" in the manual.
 
+** New function bitvector-copy
+
+See "Bit vectors" in the manual.
+
 ** (system foreign) supports C99 complex types
 
 The types `complex-float' and `complex-double' stand for C99 `float
diff --git a/doc/ref/api-data.texi b/doc/ref/api-data.texi
index 1df88e755..b6c2c4d61 100644
--- a/doc/ref/api-data.texi
+++ b/doc/ref/api-data.texi
@@ -6612,6 +6612,13 @@ Return a new list initialized with the elements
 of the bitvector @var{vec}.
 @end deffn
 
+@deffn {Scheme Procedure} bitvector-copy bitvector [start [end]]
+@deffnx {C Function} scm_bitvector_copy (bitvector, start, end)
+Returns a freshly allocated bitvector containing the elements of 
@var{bitvector}
+in the range [@var{start} ... @var{end}). @var{start} defaults to 0 and
+@var{end} defaults to the length of @var{bitvector}.
+@end deffn
+
 @deffn {Scheme Procedure} bitvector-count bitvector
 Return a count of how many entries in @var{bitvector} are set.
 
diff --git a/libguile/bitvectors.c b/libguile/bitvectors.c
index 3a279e401..41b91a51b 100644
--- a/libguile/bitvectors.c
+++ b/libguile/bitvectors.c
@@ -685,6 +685,53 @@ SCM_DEFINE_STATIC (scm_bitvector_clear_bits_x, 
"bitvector-clear-bits!", 2, 0, 0,
 }
 #undef FUNC_NAME
 
+SCM_DEFINE (scm_bitvector_copy, "bitvector-copy", 1, 2, 0,
+           (SCM bv, SCM start, SCM end),
+            "Returns a freshly allocated bitvector containing the elements\n"
+            "of bitvector @var{bv} between @var{start} and @var{end}.\n\n"
+            "@var{start} defaults to 0 and @var{end} defaults to the\n"
+            "length of @var{bv}.")
+#define FUNC_NAME s_scm_bitvector_copy
+{
+  VALIDATE_BITVECTOR (1, bv);
+
+  /* cf scm_vector_copy */
+
+  size_t cstart = 0, cend = BITVECTOR_LENGTH (bv);
+  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;
+  SCM result = scm_c_make_bitvector (len, SCM_BOOL_F);
+  const uint32_t *kv_bits = BITVECTOR_BITS (bv);
+  uint32_t *v_bits = BITVECTOR_BITS (result);
+
+  if (len > 0)
+    {
+      size_t wlen = (len + 31u) / 32u;
+      size_t wshift = cstart / 32u;
+      size_t bshift = cstart % 32u;
+      if (0 == bshift)
+        memcpy (v_bits, kv_bits + wshift, wlen*sizeof(uint32_t));
+      else
+        for (size_t i = 0; i < wlen; ++i)
+          v_bits[i] = (kv_bits[i + wshift] >> bshift) | (kv_bits[i + wshift + 
1] << (32-bshift));
+    }
+
+  return result;
+}
+#undef FUNC_NAME
+
 size_t
 scm_c_bitvector_count_bits (SCM bv, SCM bits)
 #define FUNC_NAME "bitvector-count-bits"
diff --git a/libguile/bitvectors.h b/libguile/bitvectors.h
index fe3f487a7..0ed96c356 100644
--- a/libguile/bitvectors.h
+++ b/libguile/bitvectors.h
@@ -34,6 +34,7 @@
 
 SCM_API SCM scm_list_to_bitvector (SCM list);
 SCM_API SCM scm_bitvector_to_list (SCM vec);
+SCM_API SCM scm_bitvector_copy (SCM vec, SCM start, SCM end);
 
 SCM_API SCM scm_bitvector_position (SCM v, SCM item, SCM start);
 
diff --git a/test-suite/tests/bitvectors.test b/test-suite/tests/bitvectors.test
index 557a68e08..ad45bde69 100644
--- a/test-suite/tests/bitvectors.test
+++ b/test-suite/tests/bitvectors.test
@@ -17,8 +17,9 @@
 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 
USA
 
 (define-module (test-suite test-bitvectors)
-  #:use-module (test-suite lib))
-
+  #:use-module (test-suite lib)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-26))
 
 (with-test-prefix "predicates"
   (pass-if (bitvector? #*1010101010))
@@ -103,3 +104,21 @@
 
 (with-test-prefix "bitvector-count-bits"
   (pass-if-equal 3 (bitvector-count-bits #*01110111 #*11001101)))
+
+(with-test-prefix "bitector-copy"
+  (define bv 
#*100110001011001100011001010010101100000110010000100111101110101111000011101001101100110100100010011101110001001000101010010101111000100001010000101001110100001101001110001101001000010111101111100111011100111010011101100011010111111101110100011100011100)
+
+  (define* (test bv #:optional start end)
+    (equal? (drop (take (bitvector->list bv) (or end (bitvector-length bv))) 
(or start 0))
+            (bitvector->list (cond (end (bitvector-copy bv start end))
+                                   (start (bitvector-copy bv start))
+                                   (else (bitvector-copy bv))))))
+  
+  (pass-if "def args 0" (test bv))
+  (pass-if "def args 1" (test bv 0))
+  (pass-if "def args 2" (test bv 0 (bitvector-length bv)))
+  (pass-if "start" (every (cut test bv <>) '(1 4 15 16 31 32 33 64 65 130 250 
252)))
+  (pass-if "end-3" (every (cut test bv 3 <>) '(4 15 16 31 32 33 64 65 130 250 
252)))
+  (pass-if "end-16" (every (cut test bv 16 <>) '(16 31 32 33 64 65 130 250 
252)))
+  (pass-if "empty def args 1" (test bv 252))
+  (pass-if "empty def args 2" (test bv 252 252)))