[Guile-commits] 24/27: Move uniform-array->bytevector from (rnrs bytevectors) to core

[Daniel Llorens]

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

commit 3b6a2f281aa1722b1c97933cf8fc979ff3f94e99
Author: Daniel Llorens <address@hidden>
AuthorDate: Tue Feb 11 12:40:21 2020 +0100

    Move uniform-array->bytevector from (rnrs bytevectors) to core
    
    This is to have arrays use bytevectors and not the other way
    around. Besides, it's not an RnRS function.
---
 NEWS-wip-vector-cleanup.txt       |  6 ++-
 libguile/arrays.c                 | 50 ++++++++++++++++++++
 libguile/arrays.h                 |  1 +
 libguile/bytevectors.c            | 45 ------------------
 libguile/bytevectors.h            |  2 -
 module/rnrs.scm                   |  2 +-
 module/rnrs/bytevectors.scm       |  1 -
 test-suite/tests/arrays.test      | 99 +++++++++++++++++++++++++++++++++++++++
 test-suite/tests/bytevectors.test | 97 --------------------------------------
 9 files changed, 156 insertions(+), 147 deletions(-)

diff --git a/NEWS-wip-vector-cleanup.txt b/NEWS-wip-vector-cleanup.txt
index e7e4ea1..d9c82ea 100644
--- a/NEWS-wip-vector-cleanup.txt
+++ b/NEWS-wip-vector-cleanup.txt
@@ -5,7 +5,7 @@ TBA to NEWS for this branch.
 * Forward incompatible changes
 
 Applying these changes will make your program work with this version of
-Guile and continue working with older versions, at least back to 2.2.
+Guile and continue working with older versions (at least back to 2.2).
 
 ** vector->list and vector-copy require a true vector argument.
 
@@ -24,6 +24,10 @@ If you were including these headers directly for any reason, 
just include libgui
 This function was undocumented. Instead, use scm_make_typed_array and
 the array handle functions to copy data to the new array.
 
+** uniform-array->bytevector has been moved from (rnrs bytevectors) / (rnrs) 
to core.
+
+This function is undocumented.
+
 
 * Backward incompatible changes
 
diff --git a/libguile/arrays.c b/libguile/arrays.c
index e6af629..81321e7 100644
--- a/libguile/arrays.c
+++ b/libguile/arrays.c
@@ -27,6 +27,7 @@
 #include <stdio.h>
 #include <errno.h>
 #include <string.h>
+#include <assert.h>
 
 #include "array-map.h"
 #include "bitvectors.h"
@@ -1272,6 +1273,55 @@ scm_i_print_array (SCM array, SCM port, scm_print_state 
*pstate)
   return d;
 }
 
+// -----------------------------------------------
+// other functions
+// -----------------------------------------------
+
+SCM_DEFINE (scm_uniform_array_to_bytevector, "uniform-array->bytevector",
+            1, 0, 0, (SCM array),
+           "Return a newly allocated bytevector whose contents\n"
+            "will be copied from the uniform array @var{array}.")
+#define FUNC_NAME s_scm_uniform_array_to_bytevector
+{
+  SCM contents, ret;
+  size_t len, sz, byte_len;
+  scm_t_array_handle h;
+  const void *elts;
+  
+  contents = scm_array_contents (array, SCM_BOOL_T);
+  if (scm_is_false (contents))
+    scm_wrong_type_arg_msg (FUNC_NAME, 0, array, "uniform contiguous array");
+
+  scm_array_get_handle (contents, &h);
+  assert (h.base == 0);
+
+  elts = h.elements;
+  len = h.dims->inc * (h.dims->ubnd - h.dims->lbnd + 1);
+  sz = scm_array_handle_uniform_element_bit_size (&h);
+  if (sz >= 8 && ((sz % 8) == 0))
+    byte_len = len * (sz / 8);
+  else if (sz < 8)
+    /* Elements of sub-byte size (bitvectors) are addressed in 32-bit
+       units.  */
+    byte_len = ((len * sz + 31) / 32) * 4;
+  else
+    /* an internal guile error, really */
+    SCM_MISC_ERROR ("uniform elements larger than 8 bits must fill whole 
bytes", SCM_EOL);
+
+  ret = scm_c_make_bytevector (byte_len);
+  if (byte_len != 0)
+    /* Empty arrays may have elements == NULL.  We must avoid passing
+       NULL to memcpy, even if the length is zero, to avoid undefined
+       behavior. */
+    memcpy (SCM_BYTEVECTOR_CONTENTS (ret), elts, byte_len);
+
+  scm_array_handle_release (&h);
+
+  return ret;
+}
+#undef FUNC_NAME
+
+
 
 /* ---------------------- */
 /* Init hook */
diff --git a/libguile/arrays.h b/libguile/arrays.h
index 0d2eae2..3a3c8cc 100644
--- a/libguile/arrays.h
+++ b/libguile/arrays.h
@@ -66,6 +66,7 @@ SCM_API void scm_c_array_set_2_x (SCM v, SCM obj, ssize_t 
idx0, ssize_t idx1);
 SCM_API SCM scm_array_ref (SCM v, SCM args);
 SCM_API SCM scm_array_set_x (SCM v, SCM obj, SCM args);
 SCM_API SCM scm_array_to_list (SCM v);
+SCM_API SCM scm_uniform_array_to_bytevector (SCM a);
 
 SCM_API SCM scm_make_array (SCM fill, SCM bounds);
 SCM_API SCM scm_make_typed_array (SCM type, SCM fill, SCM bounds);
diff --git a/libguile/bytevectors.c b/libguile/bytevectors.c
index fc9c02e..1c2b614 100644
--- a/libguile/bytevectors.c
+++ b/libguile/bytevectors.c
@@ -33,7 +33,6 @@
 #include <unistr.h>
 #include <string.h>
 #include <alloca.h>
-#include <assert.h>
 
 #include <gmp.h>
 
@@ -647,50 +646,6 @@ SCM_DEFINE (scm_bytevector_copy, "bytevector-copy", 1, 0, 
0,
 }
 #undef FUNC_NAME
 
-SCM_DEFINE (scm_uniform_array_to_bytevector, "uniform-array->bytevector",
-            1, 0, 0, (SCM array),
-           "Return a newly allocated bytevector whose contents\n"
-            "will be copied from the uniform array @var{array}.")
-#define FUNC_NAME s_scm_uniform_array_to_bytevector
-{
-  SCM contents, ret;
-  size_t len, sz, byte_len;
-  scm_t_array_handle h;
-  const void *elts;
-  
-  contents = scm_array_contents (array, SCM_BOOL_T);
-  if (scm_is_false (contents))
-    scm_wrong_type_arg_msg (FUNC_NAME, 0, array, "uniform contiguous array");
-
-  scm_array_get_handle (contents, &h);
-  assert (h.base == 0);
-
-  elts = h.elements;
-  len = h.dims->inc * (h.dims->ubnd - h.dims->lbnd + 1);
-  sz = scm_array_handle_uniform_element_bit_size (&h);
-  if (sz >= 8 && ((sz % 8) == 0))
-    byte_len = len * (sz / 8);
-  else if (sz < 8)
-    /* Elements of sub-byte size (bitvectors) are addressed in 32-bit
-       units.  */
-    byte_len = ((len * sz + 31) / 32) * 4;
-  else
-    /* an internal guile error, really */
-    SCM_MISC_ERROR ("uniform elements larger than 8 bits must fill whole 
bytes", SCM_EOL);
-
-  ret = make_bytevector (byte_len, SCM_ARRAY_ELEMENT_TYPE_VU8);
-  if (byte_len != 0)
-    /* Empty arrays may have elements == NULL.  We must avoid passing
-       NULL to memcpy, even if the length is zero, to avoid undefined
-       behavior. */
-    memcpy (SCM_BYTEVECTOR_CONTENTS (ret), elts, byte_len);
-
-  scm_array_handle_release (&h);
-
-  return ret;
-}
-#undef FUNC_NAME
-
 
 /* Operations on bytes and octets.  */
 
diff --git a/libguile/bytevectors.h b/libguile/bytevectors.h
index 980d6e2..1c9b8a1 100644
--- a/libguile/bytevectors.h
+++ b/libguile/bytevectors.h
@@ -60,8 +60,6 @@ SCM_API SCM scm_bytevector_fill_x (SCM, SCM);
 SCM_API SCM scm_bytevector_copy_x (SCM, SCM, SCM, SCM, SCM);
 SCM_API SCM scm_bytevector_copy (SCM);
 
-SCM_API SCM scm_uniform_array_to_bytevector (SCM);
-
 SCM_API SCM scm_bytevector_to_u8_list (SCM);
 SCM_API SCM scm_u8_list_to_bytevector (SCM);
 SCM_API SCM scm_uint_list_to_bytevector (SCM, SCM, SCM);
diff --git a/module/rnrs.scm b/module/rnrs.scm
index f4ab970..c5db73e 100644
--- a/module/rnrs.scm
+++ b/module/rnrs.scm
@@ -79,7 +79,7 @@
          
          endianness native-endianness bytevector? make-bytevector 
          bytevector-length bytevector=? bytevector-fill! bytevector-copy! 
-         bytevector-copy uniform-array->bytevector bytevector-u8-ref 
+         bytevector-copy bytevector-u8-ref 
          bytevector-s8-ref bytevector-u8-set! bytevector-s8-set! 
          bytevector->u8-list u8-list->bytevector bytevector-uint-ref 
          bytevector-uint-set! bytevector-sint-ref bytevector-sint-set!
diff --git a/module/rnrs/bytevectors.scm b/module/rnrs/bytevectors.scm
index 9744359..1ec2cfe 100644
--- a/module/rnrs/bytevectors.scm
+++ b/module/rnrs/bytevectors.scm
@@ -34,7 +34,6 @@
   #:export (native-endianness bytevector?
            make-bytevector bytevector-length bytevector=? bytevector-fill!
            bytevector-copy! bytevector-copy
-           uniform-array->bytevector
            bytevector-u8-ref bytevector-s8-ref
            bytevector-u8-set! bytevector-s8-set! bytevector->u8-list
            u8-list->bytevector
diff --git a/test-suite/tests/arrays.test b/test-suite/tests/arrays.test
index e913e30..70b661d 100644
--- a/test-suite/tests/arrays.test
+++ b/test-suite/tests/arrays.test
@@ -20,6 +20,7 @@
 (define-module (test-suite test-arrays)
   #:use-module ((system base compile) #:select (compile))
   #:use-module (test-suite lib)
+  #:use-module (rnrs bytevectors)
   #:use-module (srfi srfi-4)
   #:use-module (srfi srfi-4 gnu))
 
@@ -1053,3 +1054,101 @@
       "#3@1@-1@1(((1)) ((1)) ((1)))"
       (format #f "~a" (make-array 1 '(1 3) '(-1 -1) '(1 1)))))
 
+
+(with-test-prefix "Arrays over bytevectors"
+
+  (pass-if "array?"
+    (array? #vu8(1 2 3)))
+
+  (pass-if "array-length"
+    (equal? (iota 16)
+            (map array-length
+                 (map make-bytevector (iota 16)))))
+
+  (pass-if "array-ref"
+    (let ((bv #vu8(255 127)))
+      (and (= 255 (array-ref bv 0))
+           (= 127 (array-ref bv 1)))))
+
+  (pass-if-exception "array-ref [index out-of-range]"
+    exception:out-of-range
+    (let ((bv #vu8(1 2)))
+      (array-ref bv 2)))
+
+  (pass-if "array-set!"
+    (let ((bv (make-bytevector 2)))
+      (array-set! bv 255 0)
+      (array-set! bv 77 1)
+      (equal? '(255 77)
+              (bytevector->u8-list bv))))
+
+  (pass-if-exception "array-set! [index out-of-range]"
+    exception:out-of-range
+    (let ((bv (make-bytevector 2)))
+      (array-set! bv 0 2)))
+
+  (pass-if-exception "array-set! [value out-of-range]"
+    exception:out-of-range
+    (let ((bv (make-bytevector 2)))
+      (array-set! bv 256 0)))
+
+  (pass-if "array-type"
+    (eq? 'vu8 (array-type #vu8())))
+
+  (pass-if "array-contents"
+    (let ((bv (u8-list->bytevector (iota 10))))
+      (eq? bv (array-contents bv))))
+
+  (pass-if "array-ref"
+    (let ((bv (u8-list->bytevector (iota 10))))
+      (equal? (iota 10)
+              (map (lambda (i) (array-ref bv i))
+                   (iota 10)))))
+
+  (pass-if "array-set!"
+    (let ((bv (make-bytevector 10)))
+      (for-each (lambda (i)
+                  (array-set! bv i i))
+                (iota 10))
+      (equal? (iota 10)
+              (bytevector->u8-list bv))))
+
+  (pass-if "make-typed-array"
+    (let ((bv (make-typed-array 'vu8 77 33)))
+      (equal? bv (u8-list->bytevector (make-list 33 77)))))
+
+  (pass-if-exception "make-typed-array [out-of-range]"
+    exception:out-of-range
+    (make-typed-array 'vu8 256 77)))
+
+
+(with-test-prefix "uniform-array->bytevector"
+
+  (pass-if "bytevector"
+    (let ((bv #vu8(0 1 128 255)))
+      (equal? bv (uniform-array->bytevector bv))))
+
+  (pass-if "empty bitvector"
+    (let ((bv (uniform-array->bytevector (make-bitvector 0))))
+      (equal? bv #vu8())))
+
+  (pass-if "bitvector < 8"
+    (let ((bv (uniform-array->bytevector (make-bitvector 4 #t))))
+      (= (bytevector-length bv) 4)))
+
+  (pass-if "bitvector == 8"
+    (let ((bv (uniform-array->bytevector (make-bitvector 8 #t))))
+      (= (bytevector-length bv) 4)))
+
+  (pass-if "bitvector > 8"
+    (let ((bv (uniform-array->bytevector (make-bitvector 9 #t))))
+      (= (bytevector-length bv) 4)))
+
+  (pass-if "bitvector == 32"
+    (let ((bv (uniform-array->bytevector (make-bitvector 32 #t))))
+      (= (bytevector-length bv) 4)))
+
+  (pass-if "bitvector > 32"
+    (let ((bv (uniform-array->bytevector (make-bitvector 33 #t))))
+      (= (bytevector-length bv) 8))))
+
diff --git a/test-suite/tests/bytevectors.test 
b/test-suite/tests/bytevectors.test
index 5d4568d..bf13516 100644
--- a/test-suite/tests/bytevectors.test
+++ b/test-suite/tests/bytevectors.test
@@ -652,103 +652,6 @@
     exception:wrong-type-arg
     (with-input-from-string "#vu8(0 256)" read)))
 
-
-(with-test-prefix "Arrays"
-
-  (pass-if "array?"
-    (array? #vu8(1 2 3)))
-
-  (pass-if "array-length"
-    (equal? (iota 16)
-            (map array-length
-                 (map make-bytevector (iota 16)))))
-
-  (pass-if "array-ref"
-    (let ((bv #vu8(255 127)))
-      (and (= 255 (array-ref bv 0))
-           (= 127 (array-ref bv 1)))))
-
-  (pass-if-exception "array-ref [index out-of-range]"
-    exception:out-of-range
-    (let ((bv #vu8(1 2)))
-      (array-ref bv 2)))
-
-  (pass-if "array-set!"
-    (let ((bv (make-bytevector 2)))
-      (array-set! bv 255 0)
-      (array-set! bv 77 1)
-      (equal? '(255 77)
-              (bytevector->u8-list bv))))
-
-  (pass-if-exception "array-set! [index out-of-range]"
-    exception:out-of-range
-    (let ((bv (make-bytevector 2)))
-      (array-set! bv 0 2)))
-
-  (pass-if-exception "array-set! [value out-of-range]"
-    exception:out-of-range
-    (let ((bv (make-bytevector 2)))
-      (array-set! bv 256 0)))
-
-  (pass-if "array-type"
-    (eq? 'vu8 (array-type #vu8())))
-
-  (pass-if "array-contents"
-    (let ((bv (u8-list->bytevector (iota 10))))
-      (eq? bv (array-contents bv))))
-
-  (pass-if "array-ref"
-    (let ((bv (u8-list->bytevector (iota 10))))
-      (equal? (iota 10)
-              (map (lambda (i) (array-ref bv i))
-                   (iota 10)))))
-
-  (pass-if "array-set!"
-    (let ((bv (make-bytevector 10)))
-      (for-each (lambda (i)
-                  (array-set! bv i i))
-                (iota 10))
-      (equal? (iota 10)
-              (bytevector->u8-list bv))))
-
-  (pass-if "make-typed-array"
-    (let ((bv (make-typed-array 'vu8 77 33)))
-      (equal? bv (u8-list->bytevector (make-list 33 77)))))
-
-  (pass-if-exception "make-typed-array [out-of-range]"
-    exception:out-of-range
-    (make-typed-array 'vu8 256 77)))
-
-
-(with-test-prefix "uniform-array->bytevector"
-
-  (pass-if "bytevector"
-    (let ((bv #vu8(0 1 128 255)))
-      (equal? bv (uniform-array->bytevector bv))))
-
-  (pass-if "empty bitvector"
-    (let ((bv (uniform-array->bytevector (make-bitvector 0))))
-      (equal? bv #vu8())))
-
-  (pass-if "bitvector < 8"
-    (let ((bv (uniform-array->bytevector (make-bitvector 4 #t))))
-      (= (bytevector-length bv) 4)))
-
-  (pass-if "bitvector == 8"
-    (let ((bv (uniform-array->bytevector (make-bitvector 8 #t))))
-      (= (bytevector-length bv) 4)))
-
-  (pass-if "bitvector > 8"
-    (let ((bv (uniform-array->bytevector (make-bitvector 9 #t))))
-      (= (bytevector-length bv) 4)))
-
-  (pass-if "bitvector == 32"
-    (let ((bv (uniform-array->bytevector (make-bitvector 32 #t))))
-      (= (bytevector-length bv) 4)))
-
-  (pass-if "bitvector > 32"
-    (let ((bv (uniform-array->bytevector (make-bitvector 33 #t))))
-      (= (bytevector-length bv) 8))))
 
 
 (with-test-prefix "srfi-4 homogeneous numeric vectors as bytevectors"