X-Git-Url: http://git.hcoop.net/bpt/guile.git/blobdiff_plain/f301dbf34a32e982f671b7b86ac39f3a880cac7b..fbb857a472eb4e69c1cba05e86646b7004f32df6:/libguile/srfi-4.c diff --git a/libguile/srfi-4.c b/libguile/srfi-4.c index 32b1b23d2..b45d4029b 100644 --- a/libguile/srfi-4.c +++ b/libguile/srfi-4.c @@ -1,23 +1,24 @@ -/* srfi-4.c --- Homogeneous numeric vector datatypes. +/* srfi-4.c --- Uniform numeric vector datatypes. * - * Copyright (C) 2001, 2004 Free Software Foundation, Inc. + * Copyright (C) 2001, 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 - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ -#if HAVE_CONFIG_H +#ifdef HAVE_CONFIG_H # include #endif @@ -28,6 +29,7 @@ #include "libguile/_scm.h" #include "libguile/__scm.h" #include "libguile/srfi-4.h" +#include "libguile/bytevectors.h" #include "libguile/error.h" #include "libguile/read.h" #include "libguile/ports.h" @@ -35,7 +37,9 @@ #include "libguile/vectors.h" #include "libguile/unif.h" #include "libguile/strings.h" +#include "libguile/strports.h" #include "libguile/dynwind.h" +#include "libguile/deprecation.h" #ifdef HAVE_UNISTD_H #include @@ -45,11 +49,12 @@ #include #endif -/* Smob type code for homogeneous numeric vectors. */ +/* Smob type code for uniform numeric vectors. */ int scm_tc16_uvec = 0; +#define SCM_IS_UVEC(obj) SCM_SMOB_PREDICATE (scm_tc16_uvec, (obj)) -/* Accessor macros for the three components of a homogeneous numeric +/* Accessor macros for the three components of a uniform numeric vector: - The type tag (one of the symbolic constants below). - The vector's length (counted in elements). @@ -60,7 +65,7 @@ int scm_tc16_uvec = 0; #define SCM_UVEC_BASE(u) ((void *)SCM_CELL_WORD_3(u)) -/* Symbolic constants encoding the various types of homogeneous +/* Symbolic constants encoding the various types of uniform numeric vectors. */ #define SCM_UVEC_U8 0 #define SCM_UVEC_S8 1 @@ -81,7 +86,11 @@ static const int uvec_sizes[12] = { 1, 1, 2, 2, 4, 4, +#if SCM_HAVE_T_INT64 8, 8, +#else + sizeof (SCM), sizeof (SCM), +#endif sizeof(float), sizeof(double), 2*sizeof(float), 2*sizeof(double) }; @@ -109,7 +118,7 @@ static const char *uvec_names[12] = { /* ================================================================ */ -/* Smob print hook for homogeneous vectors. */ +/* Smob print hook for uniform vectors. */ static int uvec_print (SCM uvec, SCM port, scm_print_state *pstate) { @@ -126,6 +135,7 @@ uvec_print (SCM uvec, SCM port, scm_print_state *pstate) #endif float *f32; double *f64; + SCM *fake_64; } np; size_t i = 0; @@ -143,7 +153,10 @@ uvec_print (SCM uvec, SCM port, scm_print_state *pstate) #if SCM_HAVE_T_INT64 case SCM_UVEC_U64: np.u64 = (scm_t_uint64 *) uptr; break; case SCM_UVEC_S64: np.s64 = (scm_t_int64 *) uptr; break; -#endif +#else + case SCM_UVEC_U64: + case SCM_UVEC_S64: np.fake_64 = (SCM *) uptr; break; +#endif case SCM_UVEC_F32: np.f32 = (float *) uptr; break; case SCM_UVEC_F64: np.f64 = (double *) uptr; break; case SCM_UVEC_C32: np.f32 = (float *) uptr; break; @@ -171,6 +184,10 @@ uvec_print (SCM uvec, SCM port, scm_print_state *pstate) #if SCM_HAVE_T_INT64 case SCM_UVEC_U64: scm_uintprint (*np.u64, 10, port); np.u64++; break; case SCM_UVEC_S64: scm_intprint (*np.s64, 10, port); np.s64++; break; +#else + case SCM_UVEC_U64: + case SCM_UVEC_S64: scm_iprin1 (*np.fake_64, port, pstate); + np.fake_64++; break; #endif case SCM_UVEC_F32: scm_i_print_double (*np.f32, port); np.f32++; break; case SCM_UVEC_F64: scm_i_print_double (*np.f64, port); np.f64++; break; @@ -207,6 +224,20 @@ uvec_equalp (SCM a, SCM b) result = SCM_BOOL_F; else if (SCM_UVEC_LENGTH (a) != SCM_UVEC_LENGTH (b)) result = SCM_BOOL_F; +#if SCM_HAVE_T_INT64 == 0 + else if (SCM_UVEC_TYPE (a) == SCM_UVEC_U64 + || SCM_UVEC_TYPE (a) == SCM_UVEC_S64) + { + SCM *aptr = (SCM *)SCM_UVEC_BASE (a), *bptr = (SCM *)SCM_UVEC_BASE (b); + size_t len = SCM_UVEC_LENGTH (a), i; + for (i = 0; i < len; i++) + if (scm_is_false (scm_num_eq_p (*aptr++, *bptr++))) + { + result = SCM_BOOL_F; + break; + } + } +#endif else if (memcmp (SCM_UVEC_BASE (a), SCM_UVEC_BASE (b), SCM_UVEC_LENGTH (a) * uvec_sizes[SCM_UVEC_TYPE(a)]) != 0) result = SCM_BOOL_F; @@ -215,35 +246,31 @@ uvec_equalp (SCM a, SCM b) return result; } -/* Smob free hook for homogeneous numeric vectors. */ -static size_t -uvec_free (SCM uvec) -{ - int type = SCM_UVEC_TYPE (uvec); - scm_gc_free (SCM_UVEC_BASE (uvec), - SCM_UVEC_LENGTH (uvec) * uvec_sizes[type], - uvec_names[type]); - return 0; -} /* ================================================================ */ /* Utility procedures. */ /* ================================================================ */ -static SCM_C_INLINE int +static SCM_C_INLINE_KEYWORD int is_uvec (int type, SCM obj) { - return (SCM_SMOB_PREDICATE (scm_tc16_uvec, obj) - && SCM_UVEC_TYPE (obj) == type); + if (SCM_IS_UVEC (obj)) + return SCM_UVEC_TYPE (obj) == type; + if (SCM_I_ARRAYP (obj) && SCM_I_ARRAY_NDIM (obj) == 1) + { + SCM v = SCM_I_ARRAY_V (obj); + return SCM_IS_UVEC (v) && SCM_UVEC_TYPE (v) == type; + } + return 0; } -static SCM_C_INLINE SCM +static SCM_C_INLINE_KEYWORD SCM uvec_p (int type, SCM obj) { return scm_from_bool (is_uvec (type, obj)); } -static SCM_C_INLINE void +static SCM_C_INLINE_KEYWORD void uvec_assert (int type, SCM obj) { if (!is_uvec (type, obj)) @@ -251,12 +278,12 @@ uvec_assert (int type, SCM obj) } static SCM -take_uvec (int type, const void *base, size_t len) +take_uvec (int type, void *base, size_t len) { SCM_RETURN_NEWSMOB3 (scm_tc16_uvec, type, len, (scm_t_bits) base); } -/* Create a new, uninitialized homogeneous numeric vector of type TYPE +/* Create a new, uninitialized uniform numeric vector of type TYPE with space for LEN elements. */ static SCM alloc_uvec (int type, size_t len) @@ -265,6 +292,15 @@ alloc_uvec (int type, size_t len) if (len > SCM_I_SIZE_MAX / uvec_sizes[type]) scm_out_of_range (NULL, scm_from_size_t (len)); base = scm_gc_malloc (len * uvec_sizes[type], uvec_names[type]); +#if SCM_HAVE_T_INT64 == 0 + if (type == SCM_UVEC_U64 || type == SCM_UVEC_S64) + { + SCM *ptr = (SCM *)base; + size_t i; + for (i = 0; i < len; i++) + *ptr++ = SCM_UNSPECIFIED; + } +#endif return take_uvec (type, base, len); } @@ -272,8 +308,8 @@ alloc_uvec (int type, size_t len) so we use a big 'if' in the next two functions. */ -static SCM_C_INLINE SCM -uvec_fast_ref (int type, void *base, size_t c_idx) +static SCM_C_INLINE_KEYWORD SCM +uvec_fast_ref (int type, const void *base, size_t c_idx) { if (type == SCM_UVEC_U8) return scm_from_uint8 (((scm_t_uint8*)base)[c_idx]); @@ -292,6 +328,11 @@ uvec_fast_ref (int type, void *base, size_t c_idx) return scm_from_uint64 (((scm_t_uint64*)base)[c_idx]); else if (type == SCM_UVEC_S64) return scm_from_int64 (((scm_t_int64*)base)[c_idx]); +#else + else if (type == SCM_UVEC_U64) + return ((SCM *)base)[c_idx]; + else if (type == SCM_UVEC_S64) + return ((SCM *)base)[c_idx]; #endif else if (type == SCM_UVEC_F32) return scm_from_double (((float*)base)[c_idx]); @@ -307,7 +348,23 @@ uvec_fast_ref (int type, void *base, size_t c_idx) return SCM_BOOL_F; } -static SCM_C_INLINE void +#if SCM_HAVE_T_INT64 == 0 +static SCM scm_uint64_min, scm_uint64_max; +static SCM scm_int64_min, scm_int64_max; + +static void +assert_exact_integer_range (SCM val, SCM min, SCM max) +{ + if (!scm_is_integer (val) + || scm_is_false (scm_exact_p (val))) + scm_wrong_type_arg_msg (NULL, 0, val, "exact integer"); + if (scm_is_true (scm_less_p (val, min)) + || scm_is_true (scm_gr_p (val, max))) + scm_out_of_range (NULL, val); +} +#endif + +static SCM_C_INLINE_KEYWORD void uvec_fast_set_x (int type, void *base, size_t c_idx, SCM val) { if (type == SCM_UVEC_U8) @@ -327,6 +384,17 @@ uvec_fast_set_x (int type, void *base, size_t c_idx, SCM val) (((scm_t_uint64*)base)[c_idx]) = scm_to_uint64 (val); else if (type == SCM_UVEC_S64) (((scm_t_int64*)base)[c_idx]) = scm_to_int64 (val); +#else + else if (type == SCM_UVEC_U64) + { + assert_exact_integer_range (val, scm_uint64_min, scm_uint64_max); + ((SCM *)base)[c_idx] = val; + } + else if (type == SCM_UVEC_S64) + { + assert_exact_integer_range (val, scm_int64_min, scm_int64_max); + ((SCM *)base)[c_idx] = val; + } #endif else if (type == SCM_UVEC_F32) (((float*)base)[c_idx]) = scm_to_double (val); @@ -344,7 +412,7 @@ uvec_fast_set_x (int type, void *base, size_t c_idx, SCM val) } } -static SCM_C_INLINE SCM +static SCM_C_INLINE_KEYWORD SCM make_uvec (int type, SCM len, SCM fill) { size_t c_len = scm_to_size_t (len); @@ -359,55 +427,103 @@ make_uvec (int type, SCM len, SCM fill) return uvec; } -static SCM_C_INLINE SCM -uvec_length (int type, SCM uvec) +static SCM_C_INLINE_KEYWORD void * +uvec_writable_elements (int type, SCM uvec, scm_t_array_handle *handle, + size_t *lenp, ssize_t *incp) { - uvec_assert (type, uvec); - return scm_from_size_t (SCM_UVEC_LENGTH (uvec)); + if (type >= 0) + { + SCM v = uvec; + if (SCM_I_ARRAYP (v)) + v = SCM_I_ARRAY_V (v); + uvec_assert (type, v); + } + + return scm_uniform_vector_writable_elements (uvec, handle, lenp, incp); } -static SCM_C_INLINE SCM -uvec_ref (int type, SCM uvec, SCM idx) +static SCM_C_INLINE_KEYWORD const void * +uvec_elements (int type, SCM uvec, scm_t_array_handle *handle, + size_t *lenp, ssize_t *incp) { - size_t c_idx; - SCM res; - - uvec_assert (type, uvec); - c_idx = scm_to_unsigned_integer (idx, 0, SCM_UVEC_LENGTH (uvec)-1); - res = uvec_fast_ref (type, SCM_UVEC_BASE(uvec), c_idx); - scm_remember_upto_here_1 (uvec); - return res; + return uvec_writable_elements (type, uvec, handle, lenp, incp); } -static SCM_C_INLINE SCM -uvec_set_x (int type, SCM uvec, SCM idx, SCM val) +static int +uvec_type (scm_t_array_handle *h) { - size_t c_idx; - - uvec_assert (type, uvec); - c_idx = scm_to_unsigned_integer (idx, 0, SCM_UVEC_LENGTH (uvec)-1); - uvec_fast_set_x (type, SCM_UVEC_BASE(uvec), c_idx, val); - scm_remember_upto_here_1 (uvec); - return SCM_UNSPECIFIED; + SCM v = h->array; + if (SCM_I_ARRAYP (v)) + v = SCM_I_ARRAY_V (v); + return SCM_UVEC_TYPE (v); } -static SCM_C_INLINE SCM +static SCM uvec_to_list (int type, SCM uvec) { - size_t c_idx; - void *base; + scm_t_array_handle handle; + size_t len; + ssize_t i, inc; + const void *elts; SCM res = SCM_EOL; - uvec_assert (type, uvec); - c_idx = SCM_UVEC_LENGTH (uvec); - base = SCM_UVEC_BASE (uvec); - while (c_idx-- > 0) - res = scm_cons (uvec_fast_ref (type, base, c_idx), res); - scm_remember_upto_here_1 (uvec); + 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); + } + scm_array_handle_release (&handle); return res; } -static SCM_C_INLINE SCM +static SCM_C_INLINE_KEYWORD SCM +uvec_length (int type, SCM uvec) +{ + scm_t_array_handle handle; + size_t len; + ssize_t inc; + uvec_elements (type, uvec, &handle, &len, &inc); + scm_array_handle_release (&handle); + return scm_from_size_t (len); +} + +static SCM_C_INLINE_KEYWORD SCM +uvec_ref (int type, SCM uvec, SCM idx) +{ + scm_t_array_handle handle; + size_t i, len; + ssize_t inc; + const void *elts; + SCM res; + + elts = uvec_elements (type, uvec, &handle, &len, &inc); + if (type < 0) + type = uvec_type (&handle); + i = scm_to_unsigned_integer (idx, 0, len-1); + res = uvec_fast_ref (type, elts, i*inc); + scm_array_handle_release (&handle); + return res; +} + +static SCM_C_INLINE_KEYWORD SCM +uvec_set_x (int type, SCM uvec, SCM idx, SCM val) +{ + scm_t_array_handle handle; + size_t i, len; + ssize_t inc; + void *elts; + + elts = uvec_writable_elements (type, uvec, &handle, &len, &inc); + if (type < 0) + type = uvec_type (&handle); + i = scm_to_unsigned_integer (idx, 0, len-1); + uvec_fast_set_x (type, elts, i*inc, val); + scm_array_handle_release (&handle); + return SCM_UNSPECIFIED; +} + +static SCM_C_INLINE_KEYWORD SCM list_to_uvec (int type, SCM list) { SCM uvec; @@ -438,11 +554,14 @@ coerce_to_uvec (int type, SCM obj) return list_to_uvec (type, obj); else if (scm_is_generalized_vector (obj)) { + scm_t_array_handle handle; size_t len = scm_c_generalized_vector_length (obj), i; SCM uvec = alloc_uvec (type, len); - void *base = SCM_UVEC_BASE (uvec); + scm_array_get_handle (uvec, &handle); for (i = 0; i < len; i++) - uvec_fast_set_x (type, base, i, scm_c_generalized_vector_ref (obj, i)); + scm_array_handle_set (&handle, i, + scm_c_generalized_vector_ref (obj, i)); + scm_array_handle_release (&handle); return uvec; } else @@ -463,6 +582,8 @@ scm_i_generalized_vector_type (SCM v) return scm_sym_b; else if (scm_is_uniform_vector (v)) return scm_from_locale_symbol (uvec_tags[SCM_UVEC_TYPE(v)]); + else if (scm_is_bytevector (v)) + return scm_from_locale_symbol ("vu8"); else return SCM_BOOL_F; } @@ -470,25 +591,35 @@ scm_i_generalized_vector_type (SCM v) int scm_is_uniform_vector (SCM obj) { - return SCM_SMOB_PREDICATE (scm_tc16_uvec, obj); + if (SCM_IS_UVEC (obj)) + return 1; + if (SCM_I_ARRAYP (obj) && SCM_I_ARRAY_NDIM (obj) == 1) + { + SCM v = SCM_I_ARRAY_V (obj); + return SCM_IS_UVEC (v); + } + return 0; } size_t -scm_c_uniform_vector_length (SCM v) +scm_c_uniform_vector_length (SCM uvec) { - if (scm_is_uniform_vector (v)) - return SCM_UVEC_LENGTH (v); - else - scm_wrong_type_arg_msg (NULL, 0, v, "uniform vector"); -} + /* scm_generalized_vector_get_handle will ultimately call us to get + the length of uniform vectors, so we can't use uvec_elements for + naked vectors. + */ -size_t -scm_c_uniform_vector_size (SCM v) -{ - if (scm_is_uniform_vector (v)) - return SCM_UVEC_LENGTH (v) * uvec_sizes[SCM_UVEC_TYPE (v)]; + if (SCM_IS_UVEC (uvec)) + return SCM_UVEC_LENGTH (uvec); else - scm_wrong_type_arg_msg (NULL, 0, v, "uniform vector"); + { + scm_t_array_handle handle; + size_t len; + ssize_t inc; + uvec_elements (-1, uvec, &handle, &len, &inc); + scm_array_handle_release (&handle); + return len; + } } SCM_DEFINE (scm_uniform_vector_p, "uniform-vector?", 1, 0, 0, @@ -500,40 +631,57 @@ SCM_DEFINE (scm_uniform_vector_p, "uniform-vector?", 1, 0, 0, } #undef FUNC_NAME +SCM +scm_c_uniform_vector_ref (SCM v, size_t idx) +{ + scm_t_array_handle handle; + size_t len; + ssize_t inc; + SCM res; + + uvec_elements (-1, v, &handle, &len, &inc); + if (idx >= len) + scm_out_of_range (NULL, scm_from_size_t (idx)); + res = scm_array_handle_ref (&handle, idx*inc); + scm_array_handle_release (&handle); + return res; +} + SCM_DEFINE (scm_uniform_vector_ref, "uniform-vector-ref", 2, 0, 0, (SCM v, SCM idx), "Return the element at index @var{idx} of the\n" "homogenous numeric vector @var{v}.") #define FUNC_NAME s_scm_uniform_vector_ref { +#if SCM_ENABLE_DEPRECATED /* Support old argument convention. */ if (scm_is_pair (idx)) { + scm_c_issue_deprecation_warning + ("Using a list as the index to uniform-vector-ref is deprecated."); if (!scm_is_null (SCM_CDR (idx))) scm_wrong_num_args (NULL); idx = SCM_CAR (idx); } +#endif - if (scm_is_uniform_vector (v)) - return uvec_ref (SCM_UVEC_TYPE (v), v, idx); - else - scm_wrong_type_arg_msg (NULL, 0, v, "uniform vector"); + return scm_c_uniform_vector_ref (v, scm_to_size_t (idx)); } #undef FUNC_NAME -SCM -scm_c_uniform_vector_ref (SCM v, size_t idx) +void +scm_c_uniform_vector_set_x (SCM v, size_t idx, SCM val) { - if (scm_is_uniform_vector (v)) - { - if (idx < SCM_UVEC_LENGTH (v)) - return uvec_fast_ref (SCM_UVEC_TYPE (v), SCM_UVEC_BASE (v), idx); - else - scm_out_of_range (NULL, scm_from_size_t (idx)); - } - else - scm_wrong_type_arg_msg (NULL, 0, v, "uniform vector"); + scm_t_array_handle handle; + size_t len; + ssize_t inc; + + uvec_writable_elements (-1, v, &handle, &len, &inc); + if (idx >= len) + scm_out_of_range (NULL, scm_from_size_t (idx)); + scm_array_handle_set (&handle, idx*inc, val); + scm_array_handle_release (&handle); } SCM_DEFINE (scm_uniform_vector_set_x, "uniform-vector-set!", 3, 0, 0, @@ -542,127 +690,109 @@ SCM_DEFINE (scm_uniform_vector_set_x, "uniform-vector-set!", 3, 0, 0, "homogenous numeric vector @var{v} to @var{val}.") #define FUNC_NAME s_scm_uniform_vector_set_x { +#if SCM_ENABLE_DEPRECATED /* Support old argument convention. */ if (scm_is_pair (idx)) { + scm_c_issue_deprecation_warning + ("Using a list as the index to uniform-vector-set! is deprecated."); if (!scm_is_null (SCM_CDR (idx))) scm_wrong_num_args (NULL); idx = SCM_CAR (idx); } +#endif - if (scm_is_uniform_vector (v)) - return uvec_set_x (SCM_UVEC_TYPE (v), v, idx, val); - else - scm_wrong_type_arg_msg (NULL, 0, v, "uniform vector"); + scm_c_uniform_vector_set_x (v, scm_to_size_t (idx), val); + return SCM_UNSPECIFIED; } #undef FUNC_NAME -void -scm_c_uniform_vector_set_x (SCM v, size_t idx, SCM val) -{ - if (scm_is_uniform_vector (v)) - { - if (idx < SCM_UVEC_LENGTH (v)) - uvec_fast_set_x (SCM_UVEC_TYPE (v), SCM_UVEC_BASE (v), idx, val); - else - scm_out_of_range (NULL, scm_from_size_t (idx)); - } - else - scm_wrong_type_arg_msg (NULL, 0, v, "uniform vector"); -} - SCM_DEFINE (scm_uniform_vector_to_list, "uniform-vector->list", 1, 0, 0, (SCM uvec), - "Convert the homogeneous numeric vector @var{uvec} to a list.") + "Convert the uniform numeric vector @var{uvec} to a list.") #define FUNC_NAME s_scm_uniform_vector_to_list { - if (scm_is_uniform_vector (uvec)) - return uvec_to_list (SCM_UVEC_TYPE (uvec), uvec); - else - scm_wrong_type_arg_msg (NULL, 0, uvec, "uniform vector"); + return uvec_to_list (-1, uvec); } #undef FUNC_NAME -const void * -scm_uniform_vector_elements (SCM uvec) +size_t +scm_array_handle_uniform_element_size (scm_t_array_handle *h) { - if (scm_is_uniform_vector (uvec)) - return SCM_UVEC_BASE (uvec); - else - scm_wrong_type_arg_msg (NULL, 0, uvec, "uniform vector"); + SCM vec = h->array; + if (SCM_I_ARRAYP (vec)) + vec = SCM_I_ARRAY_V (vec); + if (scm_is_uniform_vector (vec)) + return uvec_sizes[SCM_UVEC_TYPE(vec)]; + if (scm_is_bytevector (vec)) + return 1U; + scm_wrong_type_arg_msg (NULL, 0, h->array, "uniform array"); } -void -scm_uniform_vector_release_elements (SCM uvec) -{ - /* Nothing to do right now, but this function might come in handy - when uniform vectors need to be locked when giving away a pointer - to their elements. - - Also, a call to scm_uniform_vector_release acts like - scm_remember_upto_here, which is needed in any case. - */ - - scm_remember_upto_here_1 (uvec); -} - -void -scm_frame_uniform_vector_release_elements (SCM uvec) +#if SCM_ENABLE_DEPRECATED + +/* return the size of an element in a uniform array or 0 if type not + found. */ +size_t +scm_uniform_element_size (SCM obj) { - scm_frame_unwind_handler_with_scm (scm_uniform_vector_release_elements, uvec, - SCM_F_WIND_EXPLICITLY); -} + scm_c_issue_deprecation_warning + ("scm_uniform_element_size is deprecated. " + "Use scm_array_handle_uniform_element_size instead."); -void * -scm_uniform_vector_writable_elements (SCM uvec) -{ - if (scm_is_uniform_vector (uvec)) - return SCM_UVEC_BASE (uvec); + if (SCM_IS_UVEC (obj)) + return uvec_sizes[SCM_UVEC_TYPE(obj)]; else - scm_wrong_type_arg_msg (NULL, 0, uvec, "uniform vector"); + return 0; } -void -scm_uniform_vector_release_writable_elements (SCM uvec) -{ - /* Nothing to do right now, but this function might come in handy - when uniform vectors need to be locked when giving away a pointer - to their elements. - - Also, a call to scm_uniform_vector_release acts like - scm_remember_upto_here, which is needed in any case. - */ +#endif - scm_remember_upto_here_1 (uvec); +const void * +scm_array_handle_uniform_elements (scm_t_array_handle *h) +{ + return scm_array_handle_uniform_writable_elements (h); } -void -scm_frame_uniform_vector_release_writable_elements (SCM uvec) +void * +scm_array_handle_uniform_writable_elements (scm_t_array_handle *h) { - scm_frame_unwind_handler_with_scm - (scm_uniform_vector_release_writable_elements, uvec, - SCM_F_WIND_EXPLICITLY); + SCM vec = h->array; + if (SCM_I_ARRAYP (vec)) + vec = SCM_I_ARRAY_V (vec); + if (SCM_IS_UVEC (vec)) + { + size_t size = uvec_sizes[SCM_UVEC_TYPE(vec)]; + char *elts = SCM_UVEC_BASE (vec); + return (void *) (elts + size*h->base); + } + if (scm_is_bytevector (vec)) + return SCM_BYTEVECTOR_CONTENTS (vec); + scm_wrong_type_arg_msg (NULL, 0, h->array, "uniform array"); } -size_t -scm_uniform_vector_element_size (SCM uvec) +const void * +scm_uniform_vector_elements (SCM uvec, + scm_t_array_handle *h, + size_t *lenp, ssize_t *incp) { - if (scm_is_uniform_vector (uvec)) - return uvec_sizes[SCM_UVEC_TYPE (uvec)]; - else - scm_wrong_type_arg_msg (NULL, 0, uvec, "uniform vector"); + return scm_uniform_vector_writable_elements (uvec, h, lenp, incp); } - -/* return the size of an element in a uniform array or 0 if type not - found. */ -size_t -scm_uniform_element_size (SCM obj) + +void * +scm_uniform_vector_writable_elements (SCM uvec, + scm_t_array_handle *h, + size_t *lenp, ssize_t *incp) { - if (scm_is_uniform_vector (obj)) - return scm_uniform_vector_element_size (obj); - else - return 0; + scm_generalized_vector_get_handle (uvec, h); + if (lenp) + { + scm_t_array_dim *dim = scm_array_handle_dims (h); + *lenp = dim->ubnd - dim->lbnd + 1; + *incp = dim->inc; + } + return scm_array_handle_uniform_writable_elements (h); } SCM_DEFINE (scm_uniform_vector_length, "uniform-vector-length", 1, 0, 0, @@ -670,7 +800,7 @@ SCM_DEFINE (scm_uniform_vector_length, "uniform-vector-length", 1, 0, 0, "Return the number of elements in the uniform vector @var{v}.") #define FUNC_NAME s_scm_uniform_vector_length { - return scm_from_size_t (scm_c_uniform_vector_length (v)); + return uvec_length (-1, v); } #undef FUNC_NAME @@ -689,30 +819,38 @@ SCM_DEFINE (scm_uniform_vector_read_x, "uniform-vector-read!", 1, 3, 0, "An error is signalled when the last element has only\n" "been partially filled before reaching end-of-file or in\n" "the single call to read(2).\n\n" - "@code{uniform-array-read!} returns the number of elements read.\n" + "@code{uniform-vector-read!} returns the number of elements\n" + "read.\n\n" "@var{port-or-fdes} may be omitted, in which case it defaults\n" "to the value returned by @code{(current-input-port)}.") #define FUNC_NAME s_scm_uniform_vector_read_x { + scm_t_array_handle handle; size_t vlen, sz, ans; + ssize_t inc; size_t cstart, cend; size_t remaining, off; - void *base; + char *base; if (SCM_UNBNDP (port_or_fd)) - port_or_fd = scm_cur_inp; + port_or_fd = scm_current_input_port (); else SCM_ASSERT (scm_is_integer (port_or_fd) || (SCM_OPINPORTP (port_or_fd)), port_or_fd, SCM_ARG2, FUNC_NAME); - - scm_frame_begin (0); + if (!scm_is_uniform_vector (uvec)) + scm_wrong_type_arg_msg (NULL, 0, uvec, "uniform vector"); - vlen = scm_c_uniform_vector_length (uvec); - sz = scm_uniform_vector_element_size (uvec); - base = scm_uniform_vector_writable_elements (uvec); - scm_frame_uniform_vector_release_writable_elements (uvec); + base = scm_uniform_vector_writable_elements (uvec, &handle, &vlen, &inc); + sz = scm_array_handle_uniform_element_size (&handle); + + if (inc != 1) + { + /* XXX - we should of course support non contiguous vectors. */ + scm_misc_error (NULL, "only contiguous vectors are supported: ~a", + scm_list_1 (uvec)); + } cstart = 0; cend = vlen; @@ -728,38 +866,11 @@ SCM_DEFINE (scm_uniform_vector_read_x, "uniform-vector-read!", 1, 3, 0, if (SCM_NIMP (port_or_fd)) { - scm_t_port *pt = SCM_PTAB_ENTRY (port_or_fd); - - if (pt->rw_active == SCM_PORT_WRITE) - scm_flush (port_or_fd); - ans = cend - cstart; - while (remaining > 0) - { - if (pt->read_pos < pt->read_end) - { - size_t to_copy = min (pt->read_end - pt->read_pos, - remaining); - - memcpy (base + off, pt->read_pos, to_copy); - pt->read_pos += to_copy; - remaining -= to_copy; - off += to_copy; - } - else - { - if (scm_fill_input (port_or_fd) == EOF) - { - if (remaining % sz != 0) - SCM_MISC_ERROR ("unexpected EOF", SCM_EOL); - ans -= remaining / sz; - break; - } - } - } - - if (pt->rw_random) - pt->rw_active = SCM_PORT_READ; + remaining -= scm_c_read (port_or_fd, base + off, remaining); + if (remaining % sz != 0) + SCM_MISC_ERROR ("unexpected EOF", SCM_EOL); + ans -= remaining / sz; } else /* file descriptor. */ { @@ -774,7 +885,7 @@ SCM_DEFINE (scm_uniform_vector_read_x, "uniform-vector-read!", 1, 3, 0, ans = n / sz; } - scm_frame_end (); + scm_array_handle_release (&handle); return scm_from_size_t (ans); } @@ -800,26 +911,31 @@ SCM_DEFINE (scm_uniform_vector_write, "uniform-vector-write", 1, 3, 0, "@code{(current-output-port)}.") #define FUNC_NAME s_scm_uniform_vector_write { + scm_t_array_handle handle; size_t vlen, sz, ans; + ssize_t inc; size_t cstart, cend; size_t amount, off; - const void *base; + const char *base; port_or_fd = SCM_COERCE_OUTPORT (port_or_fd); if (SCM_UNBNDP (port_or_fd)) - port_or_fd = scm_cur_outp; + port_or_fd = scm_current_output_port (); else SCM_ASSERT (scm_is_integer (port_or_fd) || (SCM_OPOUTPORTP (port_or_fd)), port_or_fd, SCM_ARG2, FUNC_NAME); - scm_frame_begin (0); + base = scm_uniform_vector_elements (uvec, &handle, &vlen, &inc); + sz = scm_array_handle_uniform_element_size (&handle); - vlen = scm_c_generalized_vector_length (uvec); - sz = scm_uniform_vector_element_size (uvec); - base = scm_uniform_vector_elements (uvec); - scm_frame_uniform_vector_release_elements (uvec); + if (inc != 1) + { + /* XXX - we should of course support non contiguous vectors. */ + scm_misc_error (NULL, "only contiguous vectors are supported: ~a", + scm_list_1 (uvec)); + } cstart = 0; cend = vlen; @@ -849,7 +965,7 @@ SCM_DEFINE (scm_uniform_vector_write, "uniform-vector-write", 1, 3, 0, ans = n / sz; } - scm_frame_end (); + scm_array_handle_release (&handle); return scm_from_size_t (ans); } @@ -891,12 +1007,16 @@ SCM_DEFINE (scm_uniform_vector_write, "uniform-vector-write", 1, 3, 0, #define TYPE SCM_UVEC_U64 #define TAG u64 +#if SCM_HAVE_T_UINT64 #define CTYPE scm_t_uint64 +#endif #include "libguile/srfi-4.i.c" #define TYPE SCM_UVEC_S64 #define TAG s64 +#if SCM_HAVE_T_INT64 #define CTYPE scm_t_int64 +#endif #include "libguile/srfi-4.i.c" #define TYPE SCM_UVEC_F32 @@ -919,14 +1039,54 @@ SCM_DEFINE (scm_uniform_vector_write, "uniform-vector-write", 1, 3, 0, #define CTYPE double #include "libguile/srfi-4.i.c" +static scm_i_t_array_ref uvec_reffers[12] = { + u8ref, s8ref, + u16ref, s16ref, + u32ref, s32ref, + u64ref, s64ref, + f32ref, f64ref, + c32ref, c64ref +}; + +static scm_i_t_array_set uvec_setters[12] = { + u8set, s8set, + u16set, s16set, + u32set, s32set, + u64set, s64set, + f32set, f64set, + c32set, c64set +}; + +scm_i_t_array_ref +scm_i_uniform_vector_ref_proc (SCM uvec) +{ + return uvec_reffers[SCM_UVEC_TYPE(uvec)]; +} + +scm_i_t_array_set +scm_i_uniform_vector_set_proc (SCM uvec) +{ + return uvec_setters[SCM_UVEC_TYPE(uvec)]; +} + void scm_init_srfi_4 (void) { scm_tc16_uvec = scm_make_smob_type ("uvec", 0); scm_set_smob_equalp (scm_tc16_uvec, uvec_equalp); - scm_set_smob_free (scm_tc16_uvec, uvec_free); scm_set_smob_print (scm_tc16_uvec, uvec_print); +#if SCM_HAVE_T_INT64 == 0 + scm_uint64_min = + scm_permanent_object (scm_from_int (0)); + scm_uint64_max = + scm_permanent_object (scm_c_read_string ("18446744073709551615")); + scm_int64_min = + scm_permanent_object (scm_c_read_string ("-9223372036854775808")); + scm_int64_max = + scm_permanent_object (scm_c_read_string ("9223372036854775807")); +#endif + #include "libguile/srfi-4.x" }