-/* 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
- */
-
-
-\f
-
-#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/bitvectors.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:
-*/
+/* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004, 2005,
+ * 2006, 2009, 2011, 2013 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
+ */
+
+
+\f
+
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include "libguile/_scm.h"
+#include "libguile/__scm.h"
+
+#include "libguile/array-handle.h"
+
+
+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)
+{
+ if (num_array_impls_registered >= ARRAY_IMPLS_N_STATIC_ALLOC)
+ /* need to increase ARRAY_IMPLS_N_STATIC_ALLOC, buster */
+ abort ();
+ else
+ array_impls[num_array_impls_registered++] = *impl;
+}
+
+scm_t_array_implementation*
+scm_i_array_implementation_for_obj (SCM obj)
+{
+ 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)
+{
+ 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;
+}
+
+static void
+check_array_index_bounds (scm_t_array_dim *dim, ssize_t idx)
+{
+ if (idx < dim->lbnd || idx > dim->ubnd)
+ scm_error (scm_out_of_range_key, NULL, "Value out of range ~S to ~S: ~S",
+ scm_list_3 (scm_from_ssize_t (dim->lbnd),
+ scm_from_ssize_t (dim->ubnd),
+ scm_from_ssize_t (idx)),
+ scm_list_1 (scm_from_ssize_t (idx)));
+}
+
+ssize_t
+scm_array_handle_pos_1 (scm_t_array_handle *h, ssize_t idx0)
+{
+ scm_t_array_dim *dim = scm_array_handle_dims (h);
+
+ if (scm_array_handle_rank (h) != 1)
+ scm_misc_error (NULL, "wrong number of indices, expecting ~A",
+ scm_list_1 (scm_from_size_t (scm_array_handle_rank (h))));
+
+ check_array_index_bounds (&dim[0], idx0);
+
+ return (idx0 - dim[0].lbnd) * dim[0].inc;
+}
+
+ssize_t
+scm_array_handle_pos_2 (scm_t_array_handle *h, ssize_t idx0, ssize_t idx1)
+{
+ scm_t_array_dim *dim = scm_array_handle_dims (h);
+
+ if (scm_array_handle_rank (h) != 2)
+ scm_misc_error (NULL, "wrong number of indices, expecting ~A",
+ scm_list_1 (scm_from_size_t (scm_array_handle_rank (h))));
+
+ check_array_index_bounds (&dim[0], idx0);
+ check_array_index_bounds (&dim[1], idx1);
+
+ return ((idx0 - dim[0].lbnd) * dim[0].inc
+ + (idx1 - dim[1].lbnd) * dim[1].inc);
+}
+
+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
+scm_array_handle_release (scm_t_array_handle *h)
+{
+ /* Nothing to do here until arrays need to be reserved for real.
+ */
+}
+
+const SCM *
+scm_array_handle_elements (scm_t_array_handle *h)
+{
+ 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)
+{
+ 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_from_utf8_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"
+}
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
HCoop / bpt / guile.git / blobdiff