diff --git a/NEWS-wip-vector-cleanup.txt b/NEWS-wip-vector-cleanup.txt index e7e4ea169..d9c82ea5b 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 e6af6295e..81321e780 100644 --- a/libguile/arrays.c +++ b/libguile/arrays.c @@ -27,6 +27,7 @@ #include #include #include +#include #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 0d2eae2a0..3a3c8cced 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 fc9c02e2b..1c2b614ba 100644 --- a/libguile/bytevectors.c +++ b/libguile/bytevectors.c @@ -33,7 +33,6 @@ #include #include #include -#include #include @@ -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 980d6e267..1c9b8a163 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 f4ab970e3..c5db73e06 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 9744359f0..1ec2cfe7d 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 e913e30a2..70b661d29 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 5d4568d82..bf135163a 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"