mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-30 03:40:34 +02:00
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.
This commit is contained in:
Daniel Llorens
parent
edf9abb4a0
commit
3b6a2f281a
9 changed files with 156 additions and 147 deletions
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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 */
|
||||
|
|
|
|||
|
|
@ -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);
|
||||
|
|
|
|||
|
|
@ -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. */
|
||||
|
||||
|
|
|
|||
|
|
@ -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);
|
||||
|
|
|
|||
|
|
@ -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!
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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))))
|
||||
|
||||
|
|
|
|||
|
|
@ -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"
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue