mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-16 08:40:19 +02:00
Code Activity

add generic array implementation facility

Browse source 
* 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 2009-07-19 15:04:40 +02:00
parent 2fa901a51f
commit 2a610be594
12 changed files with 365 additions and 265 deletions
Download patch file Download diff file Expand all files Collapse all files

305
libguile/array-handle.c
View file

@ -27,206 +27,82 @@
#include "libguile/__scm.h" #include "libguile/__scm.h"
#include "libguile/array-handle.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 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 void
scm_array_get_handle (SCM array, scm_t_array_handle *h) 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"); 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 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 * const SCM *
scm_array_handle_elements (scm_t_array_handle *h) 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)) scm_wrong_type_arg_msg (NULL, 0, h->array, "non-uniform array");
vec = SCM_I_ARRAY_V (vec); return ((const SCM*)h->elements) + h->base;
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 *
scm_array_handle_writable_elements (scm_t_array_handle *h) 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)) scm_wrong_type_arg_msg (NULL, 0, h->array, "non-uniform array");
vec = SCM_I_ARRAY_V (vec); return ((SCM*)h->elements) + h->base;
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 void
scm_init_array_handle (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" #include "libguile/array-handle.x"
} }

75
libguile/array-handle.h
View file

@ -25,6 +25,36 @@
#include "libguile/__scm.h" #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 typedef struct scm_t_array_dim
@ -34,29 +64,56 @@ typedef struct scm_t_array_dim
ssize_t inc; ssize_t inc;
} scm_t_array_dim; } 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 { typedef struct scm_t_array_handle {
SCM array; 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 base;
size_t ndims; /* ndims == the rank of the array */
scm_t_array_dim *dims; scm_t_array_dim *dims;
scm_t_array_dim dim0; 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; const void *elements;
void *writable_elements; void *writable_elements;
} scm_t_array_handle; } 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 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 ssize_t scm_array_handle_pos (scm_t_array_handle *h, SCM indices);
SCM_API const SCM *scm_array_handle_elements (scm_t_array_handle *h); SCM_API SCM scm_array_handle_element_type (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); 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);
/* See inline.h for scm_array_handle_ref and scm_array_handle_set */ /* See inline.h for scm_array_handle_ref and scm_array_handle_set */

53
libguile/arrays.c
View file

@ -306,27 +306,6 @@ SCM_DEFINE (scm_shared_array_increments, "shared-array-increments", 1, 0, 0,
} }
#undef FUNC_NAME #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
scm_i_make_array (int ndim, int enclosed) scm_i_make_array (int ndim, int enclosed)
{ {
@ -1604,6 +1583,38 @@ array_free (SCM ptr)
return 0; 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 void
scm_init_arrays () scm_init_arrays ()
{ {

30
libguile/bitvectors.c
View file

@ -861,6 +861,36 @@ scm_istr2bve (SCM str)
return res; 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 void
scm_init_bitvectors () scm_init_bitvectors ()
{ {

39
libguile/bytevectors.c
View file

@ -32,6 +32,7 @@
#include "libguile/validate.h" #include "libguile/validate.h"
#include "libguile/ieee-754.h" #include "libguile/ieee-754.h"
#include "libguile/arrays.h" #include "libguile/arrays.h"
#include "libguile/array-handle.h"
#include "libguile/srfi-4.h" #include "libguile/srfi-4.h"
#include <byteswap.h> #include <byteswap.h>
@ -2058,6 +2059,34 @@ SCM_DEFINE (scm_utf32_to_string, "utf32->string",
#undef FUNC_NAME #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. */ /* Initialization. */
@ -2084,6 +2113,16 @@ scm_bootstrap_bytevectors (void)
scm_c_register_extension ("libguile", "scm_init_bytevectors", scm_c_register_extension ("libguile", "scm_init_bytevectors",
(scm_t_extension_init_func) scm_init_bytevectors, (scm_t_extension_init_func) scm_init_bytevectors,
NULL); 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 void

3
libguile/deprecated.h
View file

@ -5,7 +5,7 @@
#ifndef SCM_DEPRECATED_H #ifndef SCM_DEPRECATED_H
#define 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 * This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License * modify it under the terms of the GNU Lesser General Public License
@ -24,6 +24,7 @@
*/ */
#include "libguile/__scm.h" #include "libguile/__scm.h"
#include "libguile/arrays.h"
#include "libguile/strings.h" #include "libguile/strings.h"
#if (SCM_ENABLE_DEPRECATED == 1) #if (SCM_ENABLE_DEPRECATED == 1)

15
libguile/inline.h
View file

@ -34,8 +34,9 @@
#include "libguile/pairs.h" #include "libguile/pairs.h"
#include "libguile/gc.h" #include "libguile/gc.h"
#include "libguile/threads.h" #include "libguile/threads.h"
#include "libguile/arrays.h" #include "libguile/array-handle.h"
#include "libguile/ports.h" #include "libguile/ports.h"
#include "libguile/numbers.h"
#include "libguile/error.h" #include "libguile/error.h"
@ -241,7 +242,11 @@ SCM_C_EXTERN_INLINE
SCM SCM
scm_array_handle_ref (scm_t_array_handle *h, ssize_t p) 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 #ifndef SCM_INLINE_C_INCLUDING_INLINE_H
@ -250,7 +255,11 @@ SCM_C_EXTERN_INLINE
void void
scm_array_handle_set (scm_t_array_handle *h, ssize_t p, SCM v) 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 #ifndef SCM_INLINE_C_INCLUDING_INLINE_H

36
libguile/srfi-4.c
View file

@ -497,11 +497,8 @@ uvec_to_list (int type, SCM uvec)
SCM res = SCM_EOL; SCM res = SCM_EOL;
elts = uvec_elements (type, uvec, &handle, &len, &inc); 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); scm_array_handle_release (&handle);
return res; return res;
} }
@ -1086,18 +1083,35 @@ static scm_i_t_array_set uvec_setters[12] = {
c32set, c64set 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 void
scm_init_srfi_4 (void) scm_init_srfi_4 (void)
{ {

4
libguile/srfi-4.i.c
View file

@ -187,13 +187,13 @@ F(scm_,TAG,vector_writable_elements) (SCM uvec,
#endif #endif
static SCM 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); return uvec_fast_ref (TYPE, handle->elements, pos);
} }
static void 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); uvec_fast_set_x (TYPE, handle->writable_elements, pos, val);
} }

31
libguile/strings.c
View file

@ -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 * This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License * modify it under the terms of the GNU Lesser General Public License
@ -1096,6 +1096,35 @@ scm_i_deprecated_string_length (SCM str)
#endif #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 void
scm_init_strings () scm_init_strings ()
{ {

35
libguile/vectors.c
View file

@ -656,6 +656,41 @@ SCM_DEFINE (scm_generalized_vector_to_list, "generalized-vector->list", 1, 0, 0,
} }
#undef FUNC_NAME #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 void
scm_init_vectors () scm_init_vectors ()

4
test-suite/tests/unif.test
View file

@ -1,6 +1,6 @@
;;;; unif.test --- tests guile's uniform arrays -*- scheme -*- ;;;; 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 ;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public ;;;; modify it under the terms of the GNU Lesser General Public
@ -17,7 +17,7 @@
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
(define-module (test-suite test-unif) (define-module (test-suite test-unif)
#:use-module (test-suite lib)) #:use-module (test-suite lib))
;;; ;;;
;;; array? ;;; array?