diff options
Diffstat (limited to 'libguile/array-handle.c')
-rw-r--r-- | libguile/array-handle.c | 286 |
1 files changed, 286 insertions, 0 deletions
diff --git a/libguile/array-handle.c b/libguile/array-handle.c new file mode 100644 index 000000000..e48938ea3 --- /dev/null +++ b/libguile/array-handle.c @@ -0,0 +1,286 @@ +/* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004, 2005, 2006, 2009 Free Software Foundation, Inc. + * + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. + * + * This library is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this library; if not, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA + */ + + + + +#ifdef HAVE_CONFIG_H +# include <config.h> +#endif + +#include "libguile/_scm.h" +#include "libguile/__scm.h" + +#include "libguile/array-handle.h" +#include "libguile/unif.h" +#include "libguile/strings.h" +#include "libguile/vectors.h" +#include "libguile/srfi-4.h" +#include "libguile/bytevectors.h" + + +static SCM +enclosed_ref (scm_t_array_handle *h, ssize_t pos) +{ + 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); + else + return scm_c_string_ref (h->array, pos); +} + +static SCM +bitvector_ref (scm_t_array_handle *h, ssize_t pos) +{ + 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); +} + +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_wrong_type_arg_msg (NULL, 0, array, "array"); +} + +void +scm_array_handle_release (scm_t_array_handle *h) +{ + /* Nothing to do here until arrays need to be reserved for real. + */ +} + +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"); +} + +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"); +} + + +void +scm_init_array_handle (void) +{ +#include "libguile/array-handle.x" +} + +/* + Local Variables: + c-file-style: "gnu" + End: +*/ |