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.

1 files changed, 84 insertions, 209 deletions

diff --git a/libguile/array-handle.c b/libguile/array-handle.c
index 35fc1fc2f..cd5a46698 100644
--- a/libguile/array-handle.c
+++ b/libguile/array-handle.c
@@ -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)
-{
-  return scm_i_cvref (SCM_I_ARRAY_V (h->array), pos + h->base, 1);
-}
+SCM scm_i_array_element_types[SCM_ARRAY_ELEMENT_TYPE_LAST + 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);
-}
+#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;
 
-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)
+void
+scm_i_register_array_implementation (scm_t_array_implementation *impl)
 {
-  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;
+  if (num_array_impls_registered >= ARRAY_IMPLS_N_STATIC_ALLOC)
+    /* need to increase ARRAY_IMPLS_N_STATIC_ALLOC, buster */
+    abort ();
   else
-    ((scm_t_uint32 *)h->writable_elements)[pos/32] &= ~mask;
+    array_impls[num_array_impls_registered++] = *impl;
 }
 
-static void
-bytevector_set (scm_t_array_handle *h, ssize_t pos, SCM val)
+scm_t_array_implementation*
+scm_i_array_implementation_for_obj (SCM obj)
 {
-  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)
 {
+  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->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->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))
     {
-      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;
+      i = scm_to_signed_integer (SCM_CAR (indices), s->lbnd, s->ubnd);
+      pos += (i - s->lbnd) * s->inc;
+      k--;
+      s++;
+      indices = SCM_CDR (indices);
     }
-  else
-    scm_wrong_type_arg_msg (NULL, 0, array, "array");
+  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"
 }