diff options
-rw-r--r-- | libguile/array-handle.c | 233 | ||||
-rw-r--r-- | libguile/array-handle.h | 40 | ||||
-rw-r--r-- | libguile/array-map.c | 17 | ||||
-rw-r--r-- | libguile/arrays.c | 34 | ||||
-rw-r--r-- | libguile/bitvectors.c | 39 | ||||
-rw-r--r-- | libguile/bitvectors.h | 3 | ||||
-rw-r--r-- | libguile/bytevectors.c | 178 | ||||
-rw-r--r-- | libguile/srfi-4.h | 5 | ||||
-rw-r--r-- | libguile/strings.c | 30 | ||||
-rw-r--r-- | libguile/vectors.c | 34 |
10 files changed, 233 insertions, 380 deletions
diff --git a/libguile/array-handle.c b/libguile/array-handle.c index daa1fcbc7..84e9f88a1 100644 --- a/libguile/array-handle.c +++ b/libguile/array-handle.c @@ -33,50 +33,223 @@ 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; +/* Bytevectors as generalized vectors & arrays. */ +#define DEFINE_BYTEVECTOR_ACCESSORS(type, tag, infix) \ + static SCM \ + bytevector_##tag##_ref (SCM bv, size_t pos) \ + { \ + SCM idx = scm_from_size_t (pos * sizeof (type)); \ + return scm_bytevector_##infix##_ref (bv, idx); \ + } \ + static void \ + bytevector_##tag##_set (SCM bv, size_t pos, SCM val) \ + { \ + SCM idx = scm_from_size_t (pos * sizeof (type)); \ + scm_bytevector_##infix##_set_x (bv, idx, val); \ + } -void -scm_i_register_array_implementation (scm_t_array_implementation *impl) +DEFINE_BYTEVECTOR_ACCESSORS (uint8_t, u8, u8); +DEFINE_BYTEVECTOR_ACCESSORS (int8_t, s8, s8); +DEFINE_BYTEVECTOR_ACCESSORS (uint16_t, u16, u16_native); +DEFINE_BYTEVECTOR_ACCESSORS (int16_t, s16, s16_native); +DEFINE_BYTEVECTOR_ACCESSORS (uint32_t, u32, u32_native); +DEFINE_BYTEVECTOR_ACCESSORS (int32_t, s32, s32_native); +DEFINE_BYTEVECTOR_ACCESSORS (uint64_t, u64, u64_native); +DEFINE_BYTEVECTOR_ACCESSORS (int64_t, s64, s64_native); +DEFINE_BYTEVECTOR_ACCESSORS (float, f32, ieee_single_native); +DEFINE_BYTEVECTOR_ACCESSORS (double, f64, ieee_double_native); + +/* Since these functions are only called by Guile's C code, we can abort + instead of throwing if there is an error. */ +static SCM +bytevector_c32_ref (SCM bv, size_t pos) +{ + char *c_bv; + float real, imag; + + if (!SCM_BYTEVECTOR_P (bv)) + abort (); + c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (bv); + pos *= 2 * sizeof (float); + if (pos + 2 * sizeof (float) - 1 >= SCM_BYTEVECTOR_LENGTH (bv)) + abort (); + + memcpy (&real, &c_bv[pos], sizeof (float)); + memcpy (&imag, &c_bv[pos + sizeof (float)], sizeof (float)); + return scm_c_make_rectangular (real, imag); +} + +static SCM +bytevector_c64_ref (SCM bv, size_t pos) +{ + char *c_bv; + double real, imag; + + if (!SCM_BYTEVECTOR_P (bv)) + abort (); + c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (bv); + pos *= 2 * sizeof (double); + if (pos + 2 * sizeof (double) - 1 >= SCM_BYTEVECTOR_LENGTH (bv)) + abort (); + + memcpy (&real, &c_bv[pos], sizeof (double)); + memcpy (&imag, &c_bv[pos + sizeof (double)], sizeof (double)); + return scm_c_make_rectangular (real, imag); +} + +static void +bytevector_c32_set (SCM bv, size_t pos, SCM val) +{ + char *c_bv; + float real, imag; + + if (!SCM_BYTEVECTOR_P (bv)) + abort (); + c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (bv); + pos *= 2 * sizeof (float); + if (pos + 2 * sizeof (float) - 1 >= SCM_BYTEVECTOR_LENGTH (bv)) + abort (); + + real = scm_c_real_part (val); + imag = scm_c_imag_part (val); + memcpy (&c_bv[pos], &real, sizeof (float)); + memcpy (&c_bv[pos + sizeof (float)], &imag, sizeof (float)); +} + +static void +bytevector_c64_set (SCM bv, size_t pos, SCM val) { - if (num_array_impls_registered >= ARRAY_IMPLS_N_STATIC_ALLOC) - /* need to increase ARRAY_IMPLS_N_STATIC_ALLOC, buster */ + char *c_bv; + double real, imag; + + if (!SCM_BYTEVECTOR_P (bv)) + abort (); + c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (bv); + pos *= 2 * sizeof (double); + if (pos + 2 * sizeof (double) - 1 >= SCM_BYTEVECTOR_LENGTH (bv)) abort (); - else - array_impls[num_array_impls_registered++] = *impl; + + real = scm_c_real_part (val); + imag = scm_c_imag_part (val); + memcpy (&c_bv[pos], &real, sizeof (double)); + memcpy (&c_bv[pos + sizeof (double)], &imag, sizeof (double)); } -scm_t_array_implementation* -scm_i_array_implementation_for_obj (SCM obj) +static void +initialize_vector_handle (scm_t_array_handle *h, size_t len, + scm_t_array_element_type element_type, + scm_t_vector_ref vref, scm_t_vector_set vset, + void *writable_elements) { - 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; + h->base = 0; + h->ndims = 1; + h->dims = &h->dim0; + h->dim0.lbnd = 0; + h->dim0.ubnd = (ssize_t) (len - 1U); + h->dim0.inc = 1; + h->element_type = element_type; + h->elements = h->writable_elements = writable_elements; + h->vector = h->array; + h->vref = vref; + h->vset = vset; } 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) + if (!SCM_HEAP_OBJECT_P (array)) scm_wrong_type_arg_msg (NULL, 0, array, "array"); + h->array = array; - 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->vref = impl->vref; - h->vset = impl->vset; - h->vector = SCM_I_ARRAYP (array) ? SCM_I_ARRAY_V (array) : array; - impl->get_handle (array, h); + + switch (SCM_TYP7 (array)) + { + case scm_tc7_string: + initialize_vector_handle (h, scm_c_string_length (array), + SCM_ARRAY_ELEMENT_TYPE_CHAR, + scm_c_string_ref, scm_c_string_set_x, + NULL); + break; + case scm_tc7_vector: + initialize_vector_handle (h, scm_c_vector_length (array), + SCM_ARRAY_ELEMENT_TYPE_SCM, + scm_c_vector_ref, scm_c_vector_set_x, + SCM_I_VECTOR_WELTS (array)); + break; + case scm_tc7_bitvector: + initialize_vector_handle (h, scm_c_bitvector_length (array), + SCM_ARRAY_ELEMENT_TYPE_BIT, + scm_c_bitvector_ref, scm_c_bitvector_set_x, + scm_i_bitvector_bits (array)); + break; + case scm_tc7_bytevector: + { + size_t byte_length, length, element_byte_size; + scm_t_array_element_type element_type; + scm_t_vector_ref vref; + scm_t_vector_set vset; + + byte_length = scm_c_bytevector_length (array); + element_type = SCM_BYTEVECTOR_ELEMENT_TYPE (array); + element_byte_size = scm_i_array_element_type_sizes[element_type] / 8; + length = byte_length / element_byte_size; + + switch (element_type) + { +#define ACCESSOR_CASE(tag, TAG) \ + case SCM_ARRAY_ELEMENT_TYPE_##TAG: \ + vref = bytevector_##tag##_ref; \ + vset = bytevector_##tag##_set; \ + break + + case SCM_ARRAY_ELEMENT_TYPE_VU8: + ACCESSOR_CASE(u8, U8); + ACCESSOR_CASE(s8, S8); + ACCESSOR_CASE(u16, U16); + ACCESSOR_CASE(s16, S16); + ACCESSOR_CASE(u32, U32); + ACCESSOR_CASE(s32, S32); + ACCESSOR_CASE(u64, U64); + ACCESSOR_CASE(s64, S64); + ACCESSOR_CASE(f32, F32); + ACCESSOR_CASE(f64, F64); + ACCESSOR_CASE(c32, C32); + ACCESSOR_CASE(c64, C64); + + case SCM_ARRAY_ELEMENT_TYPE_SCM: + case SCM_ARRAY_ELEMENT_TYPE_BIT: + case SCM_ARRAY_ELEMENT_TYPE_CHAR: + default: + abort (); + +#undef ACCESSOR_CASE + } + + initialize_vector_handle (h, length, element_type, vref, vset, + SCM_BYTEVECTOR_CONTENTS (array)); + } + break; + case scm_tc7_array: + h->base = SCM_I_ARRAY_BASE (array); + h->ndims = SCM_I_ARRAY_NDIM (array); + h->dims = SCM_I_ARRAY_DIMS (array); + { + 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; + h->vector = vh.vector; + h->vref = vh.vref; + h->vset = vh.vset; + scm_array_handle_release (&vh); + } + break; + default: + scm_wrong_type_arg_msg (NULL, 0, array, "array"); + } } ssize_t diff --git a/libguile/array-handle.h b/libguile/array-handle.h index abe617ff5..a623b4e2e 100644 --- a/libguile/array-handle.h +++ b/libguile/array-handle.h @@ -30,35 +30,8 @@ -struct scm_t_array_handle; - -typedef SCM (*scm_t_array_ref) (struct scm_t_array_handle *, size_t); -typedef void (*scm_t_array_set) (struct scm_t_array_handle *, size_t, SCM); - -typedef struct -{ - scm_t_bits tag; - scm_t_bits mask; - scm_t_array_ref vref; - scm_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 SCM (*scm_t_vector_ref) (SCM, size_t); +typedef void (*scm_t_vector_set) (SCM, size_t, SCM); typedef struct scm_t_array_dim { @@ -93,6 +66,7 @@ SCM_INTERNAL SCM scm_i_array_element_types[]; typedef struct scm_t_array_handle { SCM array; + /* `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 @@ -109,8 +83,8 @@ typedef struct scm_t_array_handle { /* The backing store for the array, and its accessors. */ SCM vector; - scm_t_array_ref vref; - scm_t_array_set vset; + scm_t_vector_ref vref; + scm_t_vector_set vset; } scm_t_array_handle; #define scm_array_handle_rank(h) ((h)->ndims) @@ -139,7 +113,7 @@ scm_array_handle_ref (scm_t_array_handle *h, ssize_t p) /* catch overflow */ scm_out_of_range (NULL, scm_from_ssize_t (p)); /* perhaps should catch overflow here too */ - return h->vref (h, h->base + p); + return h->vref (h->vector, h->base + p); } SCM_INLINE_IMPLEMENTATION void @@ -149,7 +123,7 @@ scm_array_handle_set (scm_t_array_handle *h, ssize_t p, SCM v) /* catch overflow */ scm_out_of_range (NULL, scm_from_ssize_t (p)); /* perhaps should catch overflow here too */ - h->vset (h, h->base + p, v); + h->vset (h->vector, h->base + p, v); } #endif diff --git a/libguile/array-map.c b/libguile/array-map.c index f3d6e2d42..bef539dae 100644 --- a/libguile/array-map.c +++ b/libguile/array-map.c @@ -309,7 +309,7 @@ rafill (SCM dst, SCM fill) inc = SCM_I_ARRAY_DIMS (dst)->inc; for (; n-- > 0; i += inc) - h.vset (&h, i, fill); + h.vset (h.vector, i, fill); scm_array_handle_release (&h); return 1; @@ -345,7 +345,7 @@ racp (SCM src, SCM dst) inc_d = SCM_I_ARRAY_DIMS (dst)->inc; for (; n-- > 0; i_s += inc_s, i_d += inc_d) - h_d.vset (&h_d, i_d, h_s.vref (&h_s, i_s)); + h_d.vset (h_d.vector, i_d, h_s.vref (h_s.vector, i_s)); scm_array_handle_release (&h_d); scm_array_handle_release (&h_s); @@ -647,7 +647,7 @@ ramap (SCM ra0, SCM proc, SCM ras) i0end = i0 + n*inc0; if (scm_is_null (ras)) for (; i0 < i0end; i0 += inc0) - h0.vset (&h0, i0, scm_call_0 (proc)); + h0.vset (h0.vector, i0, scm_call_0 (proc)); else { SCM ra1 = SCM_CAR (ras); @@ -660,7 +660,7 @@ ramap (SCM ra0, SCM proc, SCM ras) ras = SCM_CDR (ras); if (scm_is_null (ras)) for (; i0 < i0end; i0 += inc0, i1 += inc1) - h0.vset (&h0, i0, scm_call_1 (proc, h1.vref (&h1, i1))); + h0.vset (h0.vector, i0, scm_call_1 (proc, h1.vref (h1.vector, i1))); else { ras = scm_vector (ras); @@ -670,7 +670,8 @@ ramap (SCM ra0, SCM proc, SCM ras) unsigned long k; for (k = scm_c_vector_length (ras); k--;) args = scm_cons (AREF (scm_c_vector_ref (ras, k), i), args); - h0.vset (&h0, i0, scm_apply_1 (proc, h1.vref (&h1, i1), args)); + h0.vset (h0.vector, i0, + scm_apply_1 (proc, h1.vref (h1.vector, i1), args)); } } scm_array_handle_release (&h1); @@ -720,7 +721,7 @@ rafe (SCM ra0, SCM proc, SCM ras) i0end = i0 + n*inc0; if (scm_is_null (ras)) for (; i0 < i0end; i0 += inc0) - scm_call_1 (proc, h0.vref (&h0, i0)); + scm_call_1 (proc, h0.vref (h0.vector, i0)); else { ras = scm_vector (ras); @@ -730,7 +731,7 @@ rafe (SCM ra0, SCM proc, SCM ras) unsigned long k; for (k = scm_c_vector_length (ras); k--;) args = scm_cons (AREF (scm_c_vector_ref (ras, k), i), args); - scm_apply_1 (proc, h0.vref (&h0, i0), args); + scm_apply_1 (proc, h0.vref (h0.vector, i0), args); } } scm_array_handle_release (&h0); @@ -759,7 +760,7 @@ array_index_map_1 (SCM ra, SCM proc) scm_array_get_handle (ra, &h); inc = h.dims[0].inc; for (i = h.dims[0].lbnd, p = h.base; i <= h.dims[0].ubnd; ++i, p += inc) - h.vset (&h, p, scm_call_1 (proc, scm_from_ulong (i))); + h.vset (h.vector, p, scm_call_1 (proc, scm_from_ulong (i))); scm_array_handle_release (&h); } diff --git a/libguile/arrays.c b/libguile/arrays.c index a771739ad..84d0f71fb 100644 --- a/libguile/arrays.c +++ b/libguile/arrays.c @@ -819,40 +819,6 @@ scm_i_print_array (SCM array, SCM port, scm_print_state *pstate) return scm_i_print_array_dimension (&h, 0, 0, port, pstate); } -static SCM -array_handle_ref (scm_t_array_handle *hh, size_t pos) -{ - return scm_c_array_ref_1 (SCM_I_ARRAY_V (hh->array), pos); -} - -static void -array_handle_set (scm_t_array_handle *hh, size_t pos, SCM val) -{ - scm_c_array_set_1_x (SCM_I_ARRAY_V (hh->array), val, pos); -} - -/* 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); - assert (vh.dims[0].inc == 1 && vh.dims[0].lbnd == 0 && vh.base == 0); - 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_tc7_array, - 0x7f, - array_handle_ref, array_handle_set, - array_get_handle) - void scm_init_arrays () { diff --git a/libguile/bitvectors.c b/libguile/bitvectors.c index 2eef1dc56..1611119ab 100644 --- a/libguile/bitvectors.c +++ b/libguile/bitvectors.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004, 2005, 2006, 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004, 2005, 2006, 2009, 2010, 2011, 2012, 2013, 2014 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 @@ -42,6 +42,13 @@ #define BITVECTOR_LENGTH(obj) ((size_t)SCM_CELL_WORD_1(obj)) #define BITVECTOR_BITS(obj) ((scm_t_uint32 *)SCM_CELL_WORD_2(obj)) +scm_t_uint32 *scm_i_bitvector_bits (SCM vec) +{ + if (!IS_BITVECTOR (vec)) + abort (); + return BITVECTOR_BITS (vec); +} + int scm_i_print_bitvector (SCM vec, SCM port, scm_print_state *pstate) { @@ -852,36 +859,6 @@ 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_tc7_bitvector, - 0x7f, - bitvector_handle_ref, bitvector_handle_set, - bitvector_get_handle) SCM_VECTOR_IMPLEMENTATION (SCM_ARRAY_ELEMENT_TYPE_BIT, scm_make_bitvector) void diff --git a/libguile/bitvectors.h b/libguile/bitvectors.h index 6b25327a8..6b2cb1e5c 100644 --- a/libguile/bitvectors.h +++ b/libguile/bitvectors.h @@ -3,7 +3,7 @@ #ifndef SCM_BITVECTORS_H #define SCM_BITVECTORS_H -/* Copyright (C) 1995,1996,1997,1999,2000,2001, 2004, 2006, 2008, 2009 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1997,1999,2000,2001, 2004, 2006, 2008, 2009, 2014 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 @@ -70,6 +70,7 @@ SCM_API scm_t_uint32 *scm_bitvector_writable_elements (SCM vec, size_t *lenp, ssize_t *incp); +SCM_INTERNAL scm_t_uint32 *scm_i_bitvector_bits (SCM vec); SCM_INTERNAL int scm_i_print_bitvector (SCM vec, SCM port, scm_print_state *pstate); SCM_INTERNAL SCM scm_i_bitvector_equal_p (SCM vec1, SCM vec2); SCM_INTERNAL void scm_init_bitvectors (void); diff --git a/libguile/bytevectors.c b/libguile/bytevectors.c index 064c427ed..c7908d75c 100644 --- a/libguile/bytevectors.c +++ b/libguile/bytevectors.c @@ -2081,168 +2081,6 @@ SCM_DEFINE (scm_utf32_to_string, "utf32->string", #undef FUNC_NAME -/* Bytevectors as generalized vectors & arrays. */ - -#define COMPLEX_ACCESSOR_PROLOGUE(_type) \ - size_t c_len, c_index; \ - char *c_bv; \ - \ - SCM_VALIDATE_BYTEVECTOR (1, bv); \ - c_index = scm_to_size_t (index); \ - \ - c_len = SCM_BYTEVECTOR_LENGTH (bv); \ - c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (bv); \ - \ - if (SCM_UNLIKELY (c_index + 2 * sizeof (_type) - 1 >= c_len)) \ - scm_out_of_range (FUNC_NAME, index); - -/* Template for native access to complex numbers of type TYPE. */ -#define COMPLEX_NATIVE_REF(_type) \ - SCM result; \ - \ - COMPLEX_ACCESSOR_PROLOGUE (_type); \ - \ - { \ - _type real, imag; \ - \ - memcpy (&real, &c_bv[c_index], sizeof (_type)); \ - memcpy (&imag, &c_bv[c_index + sizeof (_type)], sizeof (_type)); \ - \ - result = scm_c_make_rectangular (real, imag); \ - } \ - \ - return result; - -static SCM -bytevector_ref_c32 (SCM bv, SCM index) -#define FUNC_NAME "bytevector_ref_c32" -{ - COMPLEX_NATIVE_REF (float); -} -#undef FUNC_NAME - -static SCM -bytevector_ref_c64 (SCM bv, SCM index) -#define FUNC_NAME "bytevector_ref_c64" -{ - COMPLEX_NATIVE_REF (double); -} -#undef FUNC_NAME - -typedef SCM (*scm_t_bytevector_ref_fn)(SCM, SCM); - -static const scm_t_bytevector_ref_fn -bytevector_ref_fns[SCM_ARRAY_ELEMENT_TYPE_LAST + 1] = -{ - NULL, /* SCM */ - NULL, /* CHAR */ - NULL, /* BIT */ - scm_bytevector_u8_ref, /* VU8 */ - scm_bytevector_u8_ref, /* U8 */ - scm_bytevector_s8_ref, - scm_bytevector_u16_native_ref, - scm_bytevector_s16_native_ref, - scm_bytevector_u32_native_ref, - scm_bytevector_s32_native_ref, - scm_bytevector_u64_native_ref, - scm_bytevector_s64_native_ref, - scm_bytevector_ieee_single_native_ref, - scm_bytevector_ieee_double_native_ref, - bytevector_ref_c32, - bytevector_ref_c64 -}; - -static SCM -bv_handle_ref (scm_t_array_handle *h, size_t index) -{ - SCM byte_index; - scm_t_bytevector_ref_fn ref_fn; - - ref_fn = bytevector_ref_fns[h->element_type]; - byte_index = - scm_from_size_t (index * scm_array_handle_uniform_element_size (h)); - return ref_fn (h->array, byte_index); -} - -/* Template for native modification of complex numbers of type TYPE. */ -#define COMPLEX_NATIVE_SET(_type) \ - COMPLEX_ACCESSOR_PROLOGUE (_type); \ - \ - { \ - _type real, imag; \ - real = scm_c_real_part (value); \ - imag = scm_c_imag_part (value); \ - \ - memcpy (&c_bv[c_index], &real, sizeof (_type)); \ - memcpy (&c_bv[c_index + sizeof (_type)], &imag, sizeof (_type)); \ - } \ - \ - return SCM_UNSPECIFIED; - -static SCM -bytevector_set_c32 (SCM bv, SCM index, SCM value) -#define FUNC_NAME "bytevector_set_c32" -{ - COMPLEX_NATIVE_SET (float); -} -#undef FUNC_NAME - -static SCM -bytevector_set_c64 (SCM bv, SCM index, SCM value) -#define FUNC_NAME "bytevector_set_c64" -{ - COMPLEX_NATIVE_SET (double); -} -#undef FUNC_NAME - -typedef SCM (*scm_t_bytevector_set_fn)(SCM, SCM, SCM); - -const scm_t_bytevector_set_fn bytevector_set_fns[SCM_ARRAY_ELEMENT_TYPE_LAST + 1] = -{ - NULL, /* SCM */ - NULL, /* CHAR */ - NULL, /* BIT */ - scm_bytevector_u8_set_x, /* VU8 */ - scm_bytevector_u8_set_x, /* U8 */ - scm_bytevector_s8_set_x, - scm_bytevector_u16_native_set_x, - scm_bytevector_s16_native_set_x, - scm_bytevector_u32_native_set_x, - scm_bytevector_s32_native_set_x, - scm_bytevector_u64_native_set_x, - scm_bytevector_s64_native_set_x, - scm_bytevector_ieee_single_native_set_x, - scm_bytevector_ieee_double_native_set_x, - bytevector_set_c32, - bytevector_set_c64 -}; - -static void -bv_handle_set_x (scm_t_array_handle *h, size_t index, SCM val) -{ - SCM byte_index; - scm_t_bytevector_set_fn set_fn; - - set_fn = bytevector_set_fns[h->element_type]; - byte_index = - scm_from_size_t (index * scm_array_handle_uniform_element_size (h)); - set_fn (h->array, byte_index, 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_TYPED_LENGTH (v) - 1; - h->dim0.inc = 1; - h->element_type = SCM_BYTEVECTOR_ELEMENT_TYPE (v); - h->elements = h->writable_elements = SCM_BYTEVECTOR_CONTENTS (v); -} - - /* Initialization. */ void @@ -2264,19 +2102,9 @@ scm_bootstrap_bytevectors (void) (scm_t_extension_init_func) scm_init_bytevectors, NULL); - { - scm_t_array_implementation impl; - - impl.tag = scm_tc7_bytevector; - impl.mask = 0x7f; - impl.vref = bv_handle_ref; - impl.vset = bv_handle_set_x; - impl.get_handle = bytevector_get_handle; - scm_i_register_array_implementation (&impl); - scm_i_register_vector_constructor - (scm_i_array_element_types[SCM_ARRAY_ELEMENT_TYPE_VU8], - scm_make_bytevector); - } + scm_i_register_vector_constructor + (scm_i_array_element_types[SCM_ARRAY_ELEMENT_TYPE_VU8], + scm_make_bytevector); } void diff --git a/libguile/srfi-4.h b/libguile/srfi-4.h index a710a94fa..f56c3f35b 100644 --- a/libguile/srfi-4.h +++ b/libguile/srfi-4.h @@ -274,11 +274,6 @@ SCM_API double *scm_c64vector_writable_elements (SCM uvec, size_t *lenp, ssize_t *incp); -SCM_INTERNAL SCM scm_i_generalized_vector_type (SCM vec); -SCM_INTERNAL const char *scm_i_uniform_vector_tag (SCM uvec); -SCM_INTERNAL scm_t_array_ref scm_i_uniform_vector_ref_proc (SCM uvec); -SCM_INTERNAL scm_t_array_set scm_i_uniform_vector_set_proc (SCM uvec); - SCM_INTERNAL void scm_init_srfi_4 (void); #endif /* SCM_SRFI_4_H */ diff --git a/libguile/strings.c b/libguile/strings.c index e8eb91cbd..90dc83a66 100644 --- a/libguile/strings.c +++ b/libguile/strings.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995,1996,1998,2000,2001, 2004, 2006, 2008, 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1998,2000,2001, 2004, 2006, 2008, 2009, 2010, 2011, 2012, 2013, 2014 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 @@ -2465,34 +2465,6 @@ scm_i_get_substring_spec (size_t len, *cend = scm_to_unsigned_integer (end, *cstart, len); } -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, - string_handle_ref, string_handle_set, - string_get_handle) SCM_VECTOR_IMPLEMENTATION (SCM_ARRAY_ELEMENT_TYPE_CHAR, scm_make_string) void diff --git a/libguile/vectors.c b/libguile/vectors.c index bb42e00ba..5dab5454a 100644 --- a/libguile/vectors.c +++ b/libguile/vectors.c @@ -432,40 +432,6 @@ SCM_DEFINE (scm_vector_move_right_x, "vector-move-right!", 5, 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); -} - -/* the & ~2 allows catching scm_tc7_wvect as well. needs changing if you change - tags.h. */ -SCM_ARRAY_IMPLEMENTATION (scm_tc7_vector, 0x7f & ~2, - vector_handle_ref, vector_handle_set, - vector_get_handle) SCM_VECTOR_IMPLEMENTATION (SCM_ARRAY_ELEMENT_TYPE_SCM, scm_make_vector) |