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.

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
+SCM scm_i_array_element_types[SCM_ARRAY_ELEMENT_TYPE_LAST + 1];
-enclosed_ref (scm_t_array_handle *h, ssize_t 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;
+
+
+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);
+  if (num_array_impls_registered >= ARRAY_IMPLS_N_STATIC_ALLOC)
-}
+    /* need to increase ARRAY_IMPLS_N_STATIC_ALLOC, buster */
-
+    abort ();
-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);
+    array_impls[num_array_impls_registered++] = *impl;
 }
 
-static SCM
+scm_t_array_implementation*
-bitvector_ref (scm_t_array_handle *h, ssize_t pos)
+scm_i_array_implementation_for_obj (SCM obj)
 {
-  pos += scm_array_handle_bit_elements_offset (h);
+  int i;
-  return
+  for (i = 0; i < num_array_impls_registered; i++)
-    scm_from_bool (((scm_t_uint32 *)h->elements)[pos/32] & (1l << (pos % 32)));
+    if (SCM_NIMP (obj)
-}
+        && (SCM_CELL_TYPE (obj) & array_impls[i].mask) == array_impls[i].tag)
-
+      return &array_impls[i];
-static SCM
+  return NULL;
-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;
+  scm_t_array_implementation *impl = scm_i_array_implementation_for_obj (array);
-  h->ref = memoize_ref;
+  if (!impl)
-  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");
+  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 (h->element_type != SCM_ARRAY_ELEMENT_TYPE_SCM)
-  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");
+  return ((const SCM*)h->elements) + h->base;
 }
 
 SCM *
 scm_array_handle_writable_elements (scm_t_array_handle *h)
 {
-  SCM vec = h->array;
+  if (h->element_type != SCM_ARRAY_ELEMENT_TYPE_SCM)
-  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");
+  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"
 }
 

libguile/array-handle.h

@@ -25,6 +25,36 @@
 
 #include "libguile/__scm.h"
 
+
+
+struct scm_t_array_handle;
+
+typedef SCM (*scm_i_t_array_ref) (struct scm_t_array_handle *, size_t);
+typedef void (*scm_i_t_array_set) (struct scm_t_array_handle *, size_t, SCM);
+
+typedef struct
+{
+  scm_t_bits tag;
+  scm_t_bits mask;
+  scm_i_t_array_ref vref;
+  scm_i_t_array_set vset;
+  void (*get_handle)(SCM, struct scm_t_array_handle*);
+} scm_t_array_implementation;
+  
+#define SCM_ARRAY_IMPLEMENTATION(tag_,mask_,vref_,vset_,handle_) \
+  SCM_SNARF_INIT ({                                                     \
+      scm_t_array_implementation impl;                                  \
+      impl.tag = tag_; impl.mask = mask_;                               \
+      impl.vref = vref_; impl.vset = vset_;                             \
+      impl.get_handle = handle_;                                        \
+      scm_i_register_array_implementation (&impl);                      \
+  })
+  
+
+SCM_INTERNAL void scm_i_register_array_implementation (scm_t_array_implementation *impl);
+SCM_INTERNAL scm_t_array_implementation* scm_i_array_implementation_for_obj (SCM obj);
+
+
 
 
 typedef struct scm_t_array_dim
@@ -34,29 +64,56 @@ typedef struct scm_t_array_dim
   ssize_t inc;
 } scm_t_array_dim;
 
-struct scm_t_array_handle;
+typedef enum {    
+  SCM_ARRAY_ELEMENT_TYPE_SCM = 0, /* SCM values */
+  SCM_ARRAY_ELEMENT_TYPE_CHAR = 1, /* characters */
+  SCM_ARRAY_ELEMENT_TYPE_BIT = 2, /* packed numeric values */
+  SCM_ARRAY_ELEMENT_TYPE_VU8 = 3,
+  SCM_ARRAY_ELEMENT_TYPE_U8 = 4,
+  SCM_ARRAY_ELEMENT_TYPE_S8 = 5,
+  SCM_ARRAY_ELEMENT_TYPE_U16 = 6,
+  SCM_ARRAY_ELEMENT_TYPE_S16 = 7,
+  SCM_ARRAY_ELEMENT_TYPE_U32 = 8,
+  SCM_ARRAY_ELEMENT_TYPE_S32 = 9,
+  SCM_ARRAY_ELEMENT_TYPE_U64 = 10,
+  SCM_ARRAY_ELEMENT_TYPE_S64 = 11,
+  SCM_ARRAY_ELEMENT_TYPE_F32 = 12,
+  SCM_ARRAY_ELEMENT_TYPE_F64 = 13,
+  SCM_ARRAY_ELEMENT_TYPE_C32 = 14,
+  SCM_ARRAY_ELEMENT_TYPE_C64 = 15,
+  SCM_ARRAY_ELEMENT_TYPE_LAST = 15,
+} scm_t_array_element_type;
+
+SCM_INTERNAL SCM scm_i_array_element_types[];
 
-typedef SCM (*scm_i_t_array_ref) (struct scm_t_array_handle *, ssize_t);
-typedef void (*scm_i_t_array_set) (struct scm_t_array_handle *, ssize_t, SCM);
 
 typedef struct scm_t_array_handle {
   SCM array;
+  scm_t_array_implementation *impl;
+  /* `Base' is an offset into elements or writable_elements, corresponding to
+     the first element in the array. It would be nicer just to adjust the
+     elements/writable_elements pointer, but we can't because that element might
+     not even be byte-addressable, as is the case with bitvectors. A nicer
+     solution would be, well, nice.
+   */
   size_t base;
+  size_t ndims; /* ndims == the rank of the array */
   scm_t_array_dim *dims;
   scm_t_array_dim dim0;
-  scm_i_t_array_ref ref;
+  scm_t_array_element_type element_type;
-  scm_i_t_array_set set;
   const void *elements;
   void *writable_elements;
 } scm_t_array_handle;
 
+#define scm_array_handle_rank(h) ((h)->ndims)
+#define scm_array_handle_dims(h) ((h)->dims)
+
 SCM_API void scm_array_get_handle (SCM array, scm_t_array_handle *h);
-SCM_API size_t scm_array_handle_rank (scm_t_array_handle *h);
-SCM_API scm_t_array_dim *scm_array_handle_dims (scm_t_array_handle *h);
 SCM_API ssize_t scm_array_handle_pos (scm_t_array_handle *h, SCM indices);
+SCM_API SCM scm_array_handle_element_type (scm_t_array_handle *h);
+SCM_API void scm_array_handle_release (scm_t_array_handle *h);
 SCM_API const SCM* scm_array_handle_elements (scm_t_array_handle *h);
 SCM_API SCM* scm_array_handle_writable_elements (scm_t_array_handle *h);
-SCM_API void scm_array_handle_release (scm_t_array_handle *h);
 
 /* See inline.h for scm_array_handle_ref and scm_array_handle_set */
 

libguile/arrays.c

@@ -306,27 +306,6 @@ SCM_DEFINE (scm_shared_array_increments, "shared-array-increments", 1, 0, 0,
 }
 #undef FUNC_NAME
 
-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_i_make_array (int ndim, int enclosed)
 {
@@ -1604,6 +1583,38 @@ array_free (SCM ptr)
   return 0;
 }
 
+static SCM
+array_handle_ref (scm_t_array_handle *h, size_t pos)
+{
+  return scm_c_generalized_vector_ref (SCM_I_ARRAY_V (h->array), pos);
+}
+
+static void
+array_handle_set (scm_t_array_handle *h, size_t pos, SCM val)
+{
+  scm_c_generalized_vector_set_x (SCM_I_ARRAY_V (h->array), pos, val);
+}
+
+/* FIXME: should be handle for vect? maybe not, because of dims */
+static void
+array_get_handle (SCM array, scm_t_array_handle *h)
+{
+  scm_t_array_handle vh;
+  scm_array_get_handle (SCM_I_ARRAY_V (array), &vh);
+  h->element_type = vh.element_type;
+  h->elements = vh.elements;
+  h->writable_elements = vh.writable_elements;
+  scm_array_handle_release (&vh);
+
+  h->dims = SCM_I_ARRAY_DIMS (array);
+  h->ndims = SCM_I_ARRAY_NDIM (array);
+  h->base = SCM_I_ARRAY_BASE (array);
+}
+
+SCM_ARRAY_IMPLEMENTATION (scm_i_tc16_array, 0xffff,
+                          array_handle_ref, array_handle_set,
+                          array_get_handle);
+
 void
 scm_init_arrays ()
 {

libguile/bitvectors.c

@@ -861,6 +861,36 @@ scm_istr2bve (SCM str)
   return res;
 }
 
+/* FIXME: h->array should be h->vector */
+static SCM
+bitvector_handle_ref (scm_t_array_handle *h, size_t pos)
+{
+  return scm_c_bitvector_ref (h->array, pos);
+}
+
+static void
+bitvector_handle_set (scm_t_array_handle *h, size_t pos, SCM val)
+{
+  scm_c_bitvector_set_x (h->array, pos, val);
+}
+
+static void
+bitvector_get_handle (SCM bv, scm_t_array_handle *h)
+{
+  h->array = bv;
+  h->ndims = 1;
+  h->dims = &h->dim0;
+  h->dim0.lbnd = 0;
+  h->dim0.ubnd = BITVECTOR_LENGTH (bv) - 1;
+  h->dim0.inc = 1;
+  h->element_type = SCM_ARRAY_ELEMENT_TYPE_BIT;
+  h->elements = h->writable_elements = BITVECTOR_BITS (bv);
+}
+
+SCM_ARRAY_IMPLEMENTATION (scm_tc16_bitvector, 0xffff,
+                          bitvector_handle_ref, bitvector_handle_set,
+                          bitvector_get_handle);
+
 void
 scm_init_bitvectors ()
 {

libguile/bytevectors.c

@@ -32,6 +32,7 @@
 #include "libguile/validate.h"
 #include "libguile/ieee-754.h"
 #include "libguile/arrays.h"
+#include "libguile/array-handle.h"
 #include "libguile/srfi-4.h"
 
 #include <byteswap.h>
@@ -2058,6 +2059,34 @@ SCM_DEFINE (scm_utf32_to_string, "utf32->string",
 #undef FUNC_NAME
 
 
+
+/* Bytevectors as generalized vectors & arrays.  */
+
+static SCM
+bv_handle_ref (scm_t_array_handle *h, size_t index)
+{
+  return SCM_I_MAKINUM (scm_c_bytevector_ref (h->array, index));
+}
+
+static void
+bv_handle_set_x (scm_t_array_handle *h, size_t index, SCM val)
+{
+  scm_c_bytevector_set_x (h->array, index, scm_to_uint8 (val));
+}
+
+static void
+bytevector_get_handle (SCM v, scm_t_array_handle *h)
+{
+  h->array = v;
+  h->ndims = 1;
+  h->dims = &h->dim0;
+  h->dim0.lbnd = 0;
+  h->dim0.ubnd = SCM_BYTEVECTOR_LENGTH (v) - 1;
+  h->dim0.inc = 1;
+  h->element_type = SCM_ARRAY_ELEMENT_TYPE_VU8;
+  h->elements = h->writable_elements = SCM_BYTEVECTOR_CONTENTS (v);
+}
+
 
 /* Initialization.  */
 
@@ -2084,6 +2113,16 @@ scm_bootstrap_bytevectors (void)
   scm_c_register_extension ("libguile", "scm_init_bytevectors",
 			    (scm_t_extension_init_func) scm_init_bytevectors,
 			    NULL);
+
+  {
+    scm_t_array_implementation impl;
+    impl.tag = scm_tc16_bytevector;
+    impl.mask = 0xffff;
+    impl.vref = bv_handle_ref;
+    impl.vset = bv_handle_set_x;
+    impl.get_handle = bytevector_get_handle;
+    scm_i_register_array_implementation (&impl);
+  }
 }
 
 void

libguile/deprecated.h

@@ -5,7 +5,7 @@
 #ifndef SCM_DEPRECATED_H
 #define SCM_DEPRECATED_H
 
-/* Copyright (C) 2003,2004, 2005, 2006, 2007 Free Software Foundation, Inc.
+/* Copyright (C) 2003,2004, 2005, 2006, 2007, 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
@@ -24,6 +24,7 @@
  */
 
 #include "libguile/__scm.h"
+#include "libguile/arrays.h"
 #include "libguile/strings.h"
 
 #if (SCM_ENABLE_DEPRECATED == 1)

libguile/inline.h

@@ -34,8 +34,9 @@
 #include "libguile/pairs.h"
 #include "libguile/gc.h"
 #include "libguile/threads.h"
-#include "libguile/arrays.h"
+#include "libguile/array-handle.h"
 #include "libguile/ports.h"
+#include "libguile/numbers.h"
 #include "libguile/error.h"
 
 
@@ -241,7 +242,11 @@ SCM_C_EXTERN_INLINE
 SCM
 scm_array_handle_ref (scm_t_array_handle *h, ssize_t p)
 {
-  return h->ref (h, p);
+  if (SCM_UNLIKELY (p < 0 && -p > h->base))
+    /* catch overflow */
+    scm_out_of_range (NULL, scm_from_ssize_t (p));
+  /* perhaps should catch overflow here too */
+  return h->impl->vref (h, h->base + p);
 }
 
 #ifndef SCM_INLINE_C_INCLUDING_INLINE_H
@@ -250,7 +255,11 @@ SCM_C_EXTERN_INLINE
 void
 scm_array_handle_set (scm_t_array_handle *h, ssize_t p, SCM v)
 {
-  h->set (h, p, v);
+  if (SCM_UNLIKELY (p < 0 && -p > h->base))
+    /* catch overflow */
+    scm_out_of_range (NULL, scm_from_ssize_t (p));
+  /* perhaps should catch overflow here too */
+  h->impl->vset (h, h->base + p, v);
 }
 
 #ifndef SCM_INLINE_C_INCLUDING_INLINE_H

libguile/srfi-4.c

@@ -497,11 +497,8 @@ uvec_to_list (int type, SCM uvec)
   SCM res = SCM_EOL;
 
   elts = uvec_elements (type, uvec, &handle, &len, &inc);
-  for (i = len*inc; i > 0;)
+  for (i = len - 1; i >= 0; i--)
-    {
+    res = scm_cons (scm_array_handle_ref (&handle, i*inc), res);
-      i -= inc;
-      res = scm_cons (scm_array_handle_ref (&handle, i), res);
-    }
   scm_array_handle_release (&handle);
   return res;
 }
@@ -1086,18 +1083,35 @@ static scm_i_t_array_set uvec_setters[12] = {
   c32set, c64set
 };
 
-scm_i_t_array_ref
+static SCM
-scm_i_uniform_vector_ref_proc (SCM uvec)
+uvec_handle_ref (scm_t_array_handle *h, size_t index)
 {
-  return uvec_reffers[SCM_UVEC_TYPE(uvec)];
+  return uvec_reffers [SCM_UVEC_TYPE(h->array)] (h, index);
 }
 
-scm_i_t_array_set
+static void
-scm_i_uniform_vector_set_proc (SCM uvec)
+uvec_handle_set (scm_t_array_handle *h, size_t index, SCM val)
 {
-  return uvec_setters[SCM_UVEC_TYPE(uvec)];
+  uvec_setters [SCM_UVEC_TYPE(h->array)] (h, index, val);
 }
 
+static void
+uvec_get_handle (SCM v, scm_t_array_handle *h)
+{
+  h->array = v;
+  h->ndims = 1;
+  h->dims = &h->dim0;
+  h->dim0.lbnd = 0;
+  h->dim0.ubnd = SCM_UVEC_LENGTH (v) - 1;
+  h->dim0.inc = 1;
+  h->element_type = SCM_UVEC_TYPE (v) + SCM_ARRAY_ELEMENT_TYPE_U8;
+  h->elements = h->writable_elements = SCM_UVEC_BASE (v);
+}
+
+SCM_ARRAY_IMPLEMENTATION (scm_tc16_uvec, 0xffff,
+                          uvec_handle_ref, uvec_handle_set,
+                          uvec_get_handle);
+
 void
 scm_init_srfi_4 (void)
 {

libguile/srfi-4.i.c

@@ -187,13 +187,13 @@ F(scm_,TAG,vector_writable_elements) (SCM uvec,
 #endif
 
 static SCM
-F(,TAG,ref) (scm_t_array_handle *handle, ssize_t pos)
+F(,TAG,ref) (scm_t_array_handle *handle, size_t pos)
 {
   return uvec_fast_ref (TYPE, handle->elements, pos);
 }
 
 static void
-F(,TAG,set) (scm_t_array_handle *handle, ssize_t pos, SCM val)
+F(,TAG,set) (scm_t_array_handle *handle, size_t pos, SCM val)
 {
   uvec_fast_set_x (TYPE, handle->writable_elements, pos, val);
 }

libguile/strings.c

@@ -1,4 +1,4 @@
-/* Copyright (C) 1995,1996,1998,2000,2001, 2004, 2006, 2008 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1998,2000,2001, 2004, 2006, 2008, 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
@@ -1096,6 +1096,35 @@ scm_i_deprecated_string_length (SCM str)
 
 #endif
 
+static SCM
+string_handle_ref (scm_t_array_handle *h, size_t index)
+{
+  return scm_c_string_ref (h->array, index);
+}
+
+static void
+string_handle_set (scm_t_array_handle *h, size_t index, SCM val)
+{
+  scm_c_string_set_x (h->array, index, val);
+}
+
+static void
+string_get_handle (SCM v, scm_t_array_handle *h)
+{
+  h->array = v;
+  h->ndims = 1;
+  h->dims = &h->dim0;
+  h->dim0.lbnd = 0;
+  h->dim0.ubnd = scm_c_string_length (v) - 1;
+  h->dim0.inc = 1;
+  h->element_type = SCM_ARRAY_ELEMENT_TYPE_CHAR;
+  h->elements = h->writable_elements = NULL;
+}
+
+SCM_ARRAY_IMPLEMENTATION (scm_tc7_string, 0x7f & ~2,
+                          string_handle_ref, string_handle_set,
+                          string_get_handle);
+
 void
 scm_init_strings ()
 {

libguile/vectors.c

@@ -656,6 +656,41 @@ SCM_DEFINE (scm_generalized_vector_to_list, "generalized-vector->list", 1, 0, 0,
 }
 #undef FUNC_NAME
 
+static SCM
+vector_handle_ref (scm_t_array_handle *h, size_t idx)
+{
+  if (idx > h->dims[0].ubnd)
+    scm_out_of_range ("vector-handle-ref", scm_from_size_t (idx));
+  return ((SCM*)h->elements)[idx];
+}
+
+static void
+vector_handle_set (scm_t_array_handle *h, size_t idx, SCM val)
+{
+  if (idx > h->dims[0].ubnd)
+    scm_out_of_range ("vector-handle-set!", scm_from_size_t (idx));
+  ((SCM*)h->writable_elements)[idx] = val;
+}
+
+static void
+vector_get_handle (SCM v, scm_t_array_handle *h)
+{
+  h->array = v;
+  h->ndims = 1;
+  h->dims = &h->dim0;
+  h->dim0.lbnd = 0;
+  h->dim0.ubnd = SCM_I_VECTOR_LENGTH (v) - 1;
+  h->dim0.inc = 1;
+  h->element_type = SCM_ARRAY_ELEMENT_TYPE_SCM;
+  h->elements = h->writable_elements = SCM_I_VECTOR_WELTS (v);
+}
+
+SCM_ARRAY_IMPLEMENTATION (scm_tc7_vector, 0x7f & ~2,
+                          vector_handle_ref, vector_handle_set,
+                          vector_get_handle);
+SCM_ARRAY_IMPLEMENTATION (scm_tc7_wvect, 0x7f & ~2,
+                          vector_handle_ref, vector_handle_set,
+                          vector_get_handle);
 
 void
 scm_init_vectors ()

test-suite/tests/unif.test

@@ -1,6 +1,6 @@
 ;;;; unif.test --- tests guile's uniform arrays     -*- scheme -*-
 ;;;;
-;;;; Copyright 2004, 2006 Free Software Foundation, Inc.
+;;;; Copyright 2004, 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