diff options
-rw-r--r-- | libguile/array-handle.c | 293 | ||||
-rw-r--r-- | libguile/array-handle.h | 75 | ||||
-rw-r--r-- | libguile/arrays.c | 53 | ||||
-rw-r--r-- | libguile/bitvectors.c | 30 | ||||
-rw-r--r-- | libguile/bytevectors.c | 39 | ||||
-rw-r--r-- | libguile/deprecated.h | 3 | ||||
-rw-r--r-- | libguile/inline.h | 15 | ||||
-rw-r--r-- | libguile/srfi-4.c | 36 | ||||
-rw-r--r-- | libguile/srfi-4.i.c | 4 | ||||
-rw-r--r-- | libguile/strings.c | 31 | ||||
-rw-r--r-- | libguile/vectors.c | 35 | ||||
-rw-r--r-- | test-suite/tests/unif.test | 4 |
12 files changed, 359 insertions, 259 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" } diff --git a/libguile/array-handle.h b/libguile/array-handle.h index 21e1f8436..caf9cefbf 100644 --- a/libguile/array-handle.h +++ b/libguile/array-handle.h @@ -27,6 +27,36 @@ +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 { ssize_t lbnd; @@ -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_i_t_array_set set; + scm_t_array_element_type element_type; 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 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 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); /* See inline.h for scm_array_handle_ref and scm_array_handle_set */ diff --git a/libguile/arrays.c b/libguile/arrays.c index c70d24772..ff6c9516b 100644 --- a/libguile/arrays.c +++ b/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 () { diff --git a/libguile/bitvectors.c b/libguile/bitvectors.c index a5da47c42..f0bb5c6c8 100644 --- a/libguile/bitvectors.c +++ b/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 () { diff --git a/libguile/bytevectors.c b/libguile/bytevectors.c index f50102d30..c44db47f2 100644 --- a/libguile/bytevectors.c +++ b/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> @@ -2059,6 +2060,34 @@ SCM_DEFINE (scm_utf32_to_string, "utf32->string", +/* 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. */ void @@ -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 diff --git a/libguile/deprecated.h b/libguile/deprecated.h index 5b443c761..ad62a2bad 100644 --- a/libguile/deprecated.h +++ b/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) diff --git a/libguile/inline.h b/libguile/inline.h index 0adc92caf..f7a216d7d 100644 --- a/libguile/inline.h +++ b/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 diff --git a/libguile/srfi-4.c b/libguile/srfi-4.c index 14ce84069..408355d38 100644 --- a/libguile/srfi-4.c +++ b/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;) - { - i -= inc; - res = scm_cons (scm_array_handle_ref (&handle, i), res); - } + for (i = len - 1; i >= 0; i--) + res = scm_cons (scm_array_handle_ref (&handle, i*inc), 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 -scm_i_uniform_vector_ref_proc (SCM uvec) +static SCM +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 -scm_i_uniform_vector_set_proc (SCM uvec) +static void +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) { diff --git a/libguile/srfi-4.i.c b/libguile/srfi-4.i.c index 58a52c1d8..84553c804 100644 --- a/libguile/srfi-4.i.c +++ b/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); } diff --git a/libguile/strings.c b/libguile/strings.c index 4e21f3e28..a35b7bfdf 100644 --- a/libguile/strings.c +++ b/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 () { diff --git a/libguile/vectors.c b/libguile/vectors.c index 93f110a21..2d77f158b 100644 --- a/libguile/vectors.c +++ b/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 () diff --git a/test-suite/tests/unif.test b/test-suite/tests/unif.test index 61dbeb89e..5d584e86e 100644 --- a/test-suite/tests/unif.test +++ b/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 @@ -17,7 +17,7 @@ ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA (define-module (test-suite test-unif) - #:use-module (test-suite lib)) + #:use-module (test-suite lib)) ;;; ;;; array? |