mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-30 03:40:34 +02:00
add generic array implementation facility
* libguile/array-handle.c (scm_i_register_array_implementation): (scm_i_array_implementation_for_obj): Add generic array facility, which will (in a few commits) detangle the array code. (scm_array_get_handle): Use the generic array facility. Note that scm_t_array_handle no longer has ref and set function pointers; instead it has a pointer to the array implementation. It is unlikely that code out there used these functions, however, as the supported way was through scm_array_handle_ref/set_x. (scm_array_handle_pos): Move this function here from arrays.c. (scm_array_handle_element_type): New function, returns a Scheme value representing the type of element stored in this array. * libguile/array-handle.h (scm_t_array_element_type): New enum, for generically determining the type of an array. (scm_array_handle_rank): (scm_array_handle_dims): These are now just #defines. * libguile/arrays.c: * libguile/bitvectors.c: * libguile/bytevectors.c: * libguile/srfi-4.c: * libguile/strings.c: * libguile/vectors.c: Register array implementations for all of these. * libguile/inline.h: Update for array_handle_ref/set change. * libguile/deprecated.h: Need to include arrays.h now.
This commit is contained in:
Andy Wingo
parent
2fa901a51f
commit
2a610be594
12 changed files with 365 additions and 265 deletions
|
|
@ -27,206 +27,82 @@
|
|||
#include "libguile/__scm.h"
|
||||
|
||||
#include "libguile/array-handle.h"
|
||||
#include "libguile/arrays.h"
|
||||
#include "libguile/strings.h"
|
||||
#include "libguile/vectors.h"
|
||||
#include "libguile/srfi-4.h"
|
||||
#include "libguile/bitvectors.h"
|
||||
#include "libguile/bytevectors.h"
|
||||
|
||||
|
||||
static SCM
|
||||
enclosed_ref (scm_t_array_handle *h, ssize_t pos)
|
||||
SCM scm_i_array_element_types[SCM_ARRAY_ELEMENT_TYPE_LAST + 1];
|
||||
|
||||
|
||||
#define ARRAY_IMPLS_N_STATIC_ALLOC 7
|
||||
static scm_t_array_implementation array_impls[ARRAY_IMPLS_N_STATIC_ALLOC];
|
||||
static int num_array_impls_registered = 0;
|
||||
|
||||
|
||||
void
|
||||
scm_i_register_array_implementation (scm_t_array_implementation *impl)
|
||||
{
|
||||
return scm_i_cvref (SCM_I_ARRAY_V (h->array), pos + h->base, 1);
|
||||
}
|
||||
|
||||
static SCM
|
||||
vector_ref (scm_t_array_handle *h, ssize_t pos)
|
||||
{
|
||||
return ((const SCM *)h->elements)[pos];
|
||||
}
|
||||
|
||||
static SCM
|
||||
string_ref (scm_t_array_handle *h, ssize_t pos)
|
||||
{
|
||||
pos += h->base;
|
||||
if (SCM_I_ARRAYP (h->array))
|
||||
return scm_c_string_ref (SCM_I_ARRAY_V (h->array), pos);
|
||||
if (num_array_impls_registered >= ARRAY_IMPLS_N_STATIC_ALLOC)
|
||||
/* need to increase ARRAY_IMPLS_N_STATIC_ALLOC, buster */
|
||||
abort ();
|
||||
else
|
||||
return scm_c_string_ref (h->array, pos);
|
||||
array_impls[num_array_impls_registered++] = *impl;
|
||||
}
|
||||
|
||||
static SCM
|
||||
bitvector_ref (scm_t_array_handle *h, ssize_t pos)
|
||||
scm_t_array_implementation*
|
||||
scm_i_array_implementation_for_obj (SCM obj)
|
||||
{
|
||||
pos += scm_array_handle_bit_elements_offset (h);
|
||||
return
|
||||
scm_from_bool (((scm_t_uint32 *)h->elements)[pos/32] & (1l << (pos % 32)));
|
||||
}
|
||||
|
||||
static SCM
|
||||
bytevector_ref (scm_t_array_handle *h, ssize_t pos)
|
||||
{
|
||||
return scm_from_uint8 (((scm_t_uint8 *) h->elements)[pos]);
|
||||
}
|
||||
|
||||
static SCM
|
||||
memoize_ref (scm_t_array_handle *h, ssize_t pos)
|
||||
{
|
||||
SCM v = h->array;
|
||||
|
||||
if (SCM_I_ENCLOSED_ARRAYP (v))
|
||||
{
|
||||
h->ref = enclosed_ref;
|
||||
return enclosed_ref (h, pos);
|
||||
}
|
||||
|
||||
if (SCM_I_ARRAYP (v))
|
||||
v = SCM_I_ARRAY_V (v);
|
||||
|
||||
if (scm_is_vector (v))
|
||||
{
|
||||
h->elements = scm_array_handle_elements (h);
|
||||
h->ref = vector_ref;
|
||||
}
|
||||
else if (scm_is_uniform_vector (v))
|
||||
{
|
||||
h->elements = scm_array_handle_uniform_elements (h);
|
||||
h->ref = scm_i_uniform_vector_ref_proc (v);
|
||||
}
|
||||
else if (scm_is_string (v))
|
||||
{
|
||||
h->ref = string_ref;
|
||||
}
|
||||
else if (scm_is_bitvector (v))
|
||||
{
|
||||
h->elements = scm_array_handle_bit_elements (h);
|
||||
h->ref = bitvector_ref;
|
||||
}
|
||||
else if (scm_is_bytevector (v))
|
||||
{
|
||||
h->elements = scm_array_handle_uniform_elements (h);
|
||||
h->ref = bytevector_ref;
|
||||
}
|
||||
else
|
||||
scm_misc_error (NULL, "unknown array type: ~a", scm_list_1 (h->array));
|
||||
|
||||
return h->ref (h, pos);
|
||||
}
|
||||
|
||||
static void
|
||||
enclosed_set (scm_t_array_handle *h, ssize_t pos, SCM val)
|
||||
{
|
||||
scm_wrong_type_arg_msg (NULL, 0, h->array, "non-enclosed array");
|
||||
}
|
||||
|
||||
static void
|
||||
vector_set (scm_t_array_handle *h, ssize_t pos, SCM val)
|
||||
{
|
||||
((SCM *)h->writable_elements)[pos] = val;
|
||||
}
|
||||
|
||||
static void
|
||||
string_set (scm_t_array_handle *h, ssize_t pos, SCM val)
|
||||
{
|
||||
pos += h->base;
|
||||
if (SCM_I_ARRAYP (h->array))
|
||||
scm_c_string_set_x (SCM_I_ARRAY_V (h->array), pos, val);
|
||||
else
|
||||
scm_c_string_set_x (h->array, pos, val);
|
||||
}
|
||||
|
||||
static void
|
||||
bitvector_set (scm_t_array_handle *h, ssize_t pos, SCM val)
|
||||
{
|
||||
scm_t_uint32 mask;
|
||||
pos += scm_array_handle_bit_elements_offset (h);
|
||||
mask = 1l << (pos % 32);
|
||||
if (scm_to_bool (val))
|
||||
((scm_t_uint32 *)h->writable_elements)[pos/32] |= mask;
|
||||
else
|
||||
((scm_t_uint32 *)h->writable_elements)[pos/32] &= ~mask;
|
||||
}
|
||||
|
||||
static void
|
||||
bytevector_set (scm_t_array_handle *h, ssize_t pos, SCM val)
|
||||
{
|
||||
scm_t_uint8 c_value;
|
||||
scm_t_uint8 *elements;
|
||||
|
||||
c_value = scm_to_uint8 (val);
|
||||
elements = (scm_t_uint8 *) h->elements;
|
||||
elements[pos] = (scm_t_uint8) c_value;
|
||||
}
|
||||
|
||||
static void
|
||||
memoize_set (scm_t_array_handle *h, ssize_t pos, SCM val)
|
||||
{
|
||||
SCM v = h->array;
|
||||
|
||||
if (SCM_I_ENCLOSED_ARRAYP (v))
|
||||
{
|
||||
h->set = enclosed_set;
|
||||
enclosed_set (h, pos, val);
|
||||
return;
|
||||
}
|
||||
|
||||
if (SCM_I_ARRAYP (v))
|
||||
v = SCM_I_ARRAY_V (v);
|
||||
|
||||
if (scm_is_vector (v))
|
||||
{
|
||||
h->writable_elements = scm_array_handle_writable_elements (h);
|
||||
h->set = vector_set;
|
||||
}
|
||||
else if (scm_is_uniform_vector (v))
|
||||
{
|
||||
h->writable_elements = scm_array_handle_uniform_writable_elements (h);
|
||||
h->set = scm_i_uniform_vector_set_proc (v);
|
||||
}
|
||||
else if (scm_is_string (v))
|
||||
{
|
||||
h->set = string_set;
|
||||
}
|
||||
else if (scm_is_bitvector (v))
|
||||
{
|
||||
h->writable_elements = scm_array_handle_bit_writable_elements (h);
|
||||
h->set = bitvector_set;
|
||||
}
|
||||
else if (scm_is_bytevector (v))
|
||||
{
|
||||
h->elements = scm_array_handle_uniform_writable_elements (h);
|
||||
h->set = bytevector_set;
|
||||
}
|
||||
else
|
||||
scm_misc_error (NULL, "unknown array type: ~a", scm_list_1 (h->array));
|
||||
|
||||
h->set (h, pos, val);
|
||||
int i;
|
||||
for (i = 0; i < num_array_impls_registered; i++)
|
||||
if (SCM_NIMP (obj)
|
||||
&& (SCM_CELL_TYPE (obj) & array_impls[i].mask) == array_impls[i].tag)
|
||||
return &array_impls[i];
|
||||
return NULL;
|
||||
}
|
||||
|
||||
void
|
||||
scm_array_get_handle (SCM array, scm_t_array_handle *h)
|
||||
{
|
||||
h->array = array;
|
||||
h->ref = memoize_ref;
|
||||
h->set = memoize_set;
|
||||
|
||||
if (SCM_I_ARRAYP (array) || SCM_I_ENCLOSED_ARRAYP (array))
|
||||
{
|
||||
h->dims = SCM_I_ARRAY_DIMS (array);
|
||||
h->base = SCM_I_ARRAY_BASE (array);
|
||||
}
|
||||
else if (scm_is_generalized_vector (array))
|
||||
{
|
||||
h->dim0.lbnd = 0;
|
||||
h->dim0.ubnd = scm_c_generalized_vector_length (array) - 1;
|
||||
h->dim0.inc = 1;
|
||||
h->dims = &h->dim0;
|
||||
h->base = 0;
|
||||
}
|
||||
else
|
||||
scm_t_array_implementation *impl = scm_i_array_implementation_for_obj (array);
|
||||
if (!impl)
|
||||
scm_wrong_type_arg_msg (NULL, 0, array, "array");
|
||||
h->array = array;
|
||||
h->impl = impl;
|
||||
h->base = 0;
|
||||
h->ndims = 0;
|
||||
h->dims = NULL;
|
||||
h->element_type = SCM_ARRAY_ELEMENT_TYPE_SCM; /* have to default to
|
||||
something... */
|
||||
h->elements = NULL;
|
||||
h->writable_elements = NULL;
|
||||
h->impl->get_handle (array, h);
|
||||
}
|
||||
|
||||
ssize_t
|
||||
scm_array_handle_pos (scm_t_array_handle *h, SCM indices)
|
||||
{
|
||||
scm_t_array_dim *s = scm_array_handle_dims (h);
|
||||
ssize_t pos = 0, i;
|
||||
size_t k = scm_array_handle_rank (h);
|
||||
|
||||
while (k > 0 && scm_is_pair (indices))
|
||||
{
|
||||
i = scm_to_signed_integer (SCM_CAR (indices), s->lbnd, s->ubnd);
|
||||
pos += (i - s->lbnd) * s->inc;
|
||||
k--;
|
||||
s++;
|
||||
indices = SCM_CDR (indices);
|
||||
}
|
||||
if (k > 0 || !scm_is_null (indices))
|
||||
scm_misc_error (NULL, "wrong number of indices, expecting ~a",
|
||||
scm_list_1 (scm_from_size_t (scm_array_handle_rank (h))));
|
||||
return pos;
|
||||
}
|
||||
|
||||
SCM
|
||||
scm_array_handle_element_type (scm_t_array_handle *h)
|
||||
{
|
||||
if (h->element_type < 0 || h->element_type > SCM_ARRAY_ELEMENT_TYPE_LAST)
|
||||
abort (); /* guile programming error */
|
||||
return scm_i_array_element_types[h->element_type];
|
||||
}
|
||||
|
||||
void
|
||||
|
|
@ -236,47 +112,46 @@ scm_array_handle_release (scm_t_array_handle *h)
|
|||
*/
|
||||
}
|
||||
|
||||
size_t
|
||||
scm_array_handle_rank (scm_t_array_handle *h)
|
||||
{
|
||||
if (SCM_I_ARRAYP (h->array) || SCM_I_ENCLOSED_ARRAYP (h->array))
|
||||
return SCM_I_ARRAY_NDIM (h->array);
|
||||
else
|
||||
return 1;
|
||||
}
|
||||
|
||||
scm_t_array_dim *
|
||||
scm_array_handle_dims (scm_t_array_handle *h)
|
||||
{
|
||||
return h->dims;
|
||||
}
|
||||
|
||||
const SCM *
|
||||
scm_array_handle_elements (scm_t_array_handle *h)
|
||||
{
|
||||
SCM vec = h->array;
|
||||
if (SCM_I_ARRAYP (vec))
|
||||
vec = SCM_I_ARRAY_V (vec);
|
||||
if (SCM_I_IS_VECTOR (vec))
|
||||
return SCM_I_VECTOR_ELTS (vec) + h->base;
|
||||
scm_wrong_type_arg_msg (NULL, 0, h->array, "non-uniform array");
|
||||
if (h->element_type != SCM_ARRAY_ELEMENT_TYPE_SCM)
|
||||
scm_wrong_type_arg_msg (NULL, 0, h->array, "non-uniform array");
|
||||
return ((const SCM*)h->elements) + h->base;
|
||||
}
|
||||
|
||||
SCM *
|
||||
scm_array_handle_writable_elements (scm_t_array_handle *h)
|
||||
{
|
||||
SCM vec = h->array;
|
||||
if (SCM_I_ARRAYP (vec))
|
||||
vec = SCM_I_ARRAY_V (vec);
|
||||
if (SCM_I_IS_VECTOR (vec))
|
||||
return SCM_I_VECTOR_WELTS (vec) + h->base;
|
||||
scm_wrong_type_arg_msg (NULL, 0, h->array, "non-uniform array");
|
||||
if (h->element_type != SCM_ARRAY_ELEMENT_TYPE_SCM)
|
||||
scm_wrong_type_arg_msg (NULL, 0, h->array, "non-uniform array");
|
||||
return ((SCM*)h->elements) + h->base;
|
||||
}
|
||||
|
||||
|
||||
void
|
||||
scm_init_array_handle (void)
|
||||
{
|
||||
#define DEFINE_ARRAY_TYPE(tag, TAG) \
|
||||
scm_i_array_element_types[SCM_ARRAY_ELEMENT_TYPE_##TAG] \
|
||||
= (scm_permanent_object (scm_from_locale_symbol (#tag)))
|
||||
|
||||
scm_i_array_element_types[SCM_ARRAY_ELEMENT_TYPE_SCM] = SCM_BOOL_T;
|
||||
DEFINE_ARRAY_TYPE (a, CHAR);
|
||||
DEFINE_ARRAY_TYPE (b, BIT);
|
||||
DEFINE_ARRAY_TYPE (vu8, VU8);
|
||||
DEFINE_ARRAY_TYPE (u8, U8);
|
||||
DEFINE_ARRAY_TYPE (s8, S8);
|
||||
DEFINE_ARRAY_TYPE (u16, U16);
|
||||
DEFINE_ARRAY_TYPE (s16, S16);
|
||||
DEFINE_ARRAY_TYPE (u32, U32);
|
||||
DEFINE_ARRAY_TYPE (s32, S32);
|
||||
DEFINE_ARRAY_TYPE (u64, U64);
|
||||
DEFINE_ARRAY_TYPE (s64, S64);
|
||||
DEFINE_ARRAY_TYPE (f32, F32);
|
||||
DEFINE_ARRAY_TYPE (f64, F64);
|
||||
DEFINE_ARRAY_TYPE (c32, C32);
|
||||
DEFINE_ARRAY_TYPE (c64, C64);
|
||||
|
||||
#include "libguile/array-handle.x"
|
||||
}
|
||||
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue