From: Marius Vollmer Date: Sun, 2 Jan 2005 20:06:08 +0000 (+0000) Subject: * weaks.c: Use new vector elements API or simple vector X-Git-Url: http://git.hcoop.net/bpt/guile.git/commitdiff_plain/6e708ef2b1897c3ea4d5ac47720974078d50e9e4 * weaks.c: Use new vector elements API or simple vector API, as appropriate. * srfi-4.h, srfi-4.c, srfi-4.i.c (scm_array_handle_uniform_elements, scm_array_handle_uniform_writable_elements, scm_uniform_vector_elements, scm_uniform_vector_writable_elements): (scm_vector_elements, scm_vector_writable_elements): Use scm_t_array_handle, deliver length and increment. (scm_array_handle__elements, scm_array_handle__writable_elements): New. * unif.h, unif.c (scm_t_array_handle, scm_array_get_handle, scm_array_handle_rank, scm_array_handle_dims, scm_array_handle_ref scm_array_handle_set, scm_array_handle_elements scm_array_handle_writable_elements, scm_vector_get_handle): New. (scm_make_uve, scm_array_prototype, scm_list_to_uniform_array, scm_dimensions_to_uniform_array): Deprecated for real. (scm_array_p, scm_i_array_p): Use latter for SCM_DEFINE since snarfing wont allow a mismatch between C and Scheme arglists. (scm_make_shared_array, scm_enclose_array): Correctly use scm_c_generalized_vector_length instead of scm_uniform_vector_length. * weaks.h, weaks.c: Use new internal weak vector API from vectors.h. * Makefile.am (libguile_la_SOURCES, DOT_X_FILES, DOT_DOC_FILES, EXTRA_libguile_la_SOURCES): Changed ramap.c and unif.c from being 'extra' to being regular sources. (noinst_HEADERS): Added quicksort.i.c. * quicksort.i.c: New file. * vectors.h, vector.c (SCM_VECTORP, SCM_VECTOR_LENGTH, SCM_VELTS, SCM_WRITABLE_VELTS, SCM_VECTOR_REF, SCM_VECTOR_SET): Deprecated and reimplemented. Replaced all uses with scm_vector_elements, scm_vector_writable_elements, or SCM_SIMPLE_VECTOR_*, as appropriate. (scm_is_simple_vector, SCM_SIMPLE_VECTOR_LENGTH, SCM_SIMPLE_VECTOR_REF, SCM_SIMPLE_VECTOR_SET, SCM_SIMPLE_VECTOR_LOC): New. (SCM_VECTOR_BASE, SCM_SET_VECTOR_BASE, SCM_VECTOR_MAX_LENGTH, SCM_MAKE_VECTOR_TAG, SCM_SET_VECTOR_LENGTH, SCM_VELTS_AS_STACKITEMS, SCM_SETVELTS, SCM_GC_WRITABLE_VELTS): Removed. (scm_vector_copy): New. (scm_vector_elements, scm_vector_writable_elements): Use scm_t_array_handle, deliver length and increment. Moved to unif.h. Changed all uses. (scm_vector_release_elements, scm_vector_release_writable_elements, (scm_frame_vector_release_elements, scm_frame_vector_release_writable_elements): Removed. (SCM_I_IS_VECTOR, SCM_I_VECTOR_ELTS, SCM_I_VECTOR_WELTS, SCM_I_VECTOR_LENGTH, scm_i_vector_free): New internal API. (SCM_I_WVECTP SCM_I_WVECT_LENGTH SCM_I_WVECT_VELTS SCM_I_WVECT_GC_WVELTS SCM_I_WVECT_TYPE SCM_I_WVECT_GC_CHAIN SCM_I_SET_WVECT_GC_CHAIN, scm_i_allocate_weak_vector): New, for weak vectors. --- diff --git a/libguile/srfi-4.c b/libguile/srfi-4.c index 32b1b23d2..61995c662 100644 --- a/libguile/srfi-4.c +++ b/libguile/srfi-4.c @@ -584,85 +584,68 @@ SCM_DEFINE (scm_uniform_vector_to_list, "uniform-vector->list", 1, 0, 0, } #undef FUNC_NAME -const void * -scm_uniform_vector_elements (SCM uvec) +size_t +scm_uniform_vector_element_size (SCM uvec) { if (scm_is_uniform_vector (uvec)) - return SCM_UVEC_BASE (uvec); + return uvec_sizes[SCM_UVEC_TYPE (uvec)]; else scm_wrong_type_arg_msg (NULL, 0, uvec, "uniform vector"); } - -void -scm_uniform_vector_release_elements (SCM uvec) + +/* return the size of an element in a uniform array or 0 if type not + found. */ +size_t +scm_uniform_element_size (SCM obj) { - /* 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); + if (scm_is_uniform_vector (obj)) + return scm_uniform_vector_element_size (obj); + else + return 0; } -void -scm_frame_uniform_vector_release_elements (SCM uvec) +const void * +scm_array_handle_uniform_elements (scm_t_array_handle *h) { - scm_frame_unwind_handler_with_scm (scm_uniform_vector_release_elements, uvec, - SCM_F_WIND_EXPLICITLY); + return scm_array_handle_uniform_writable_elements (h); } void * -scm_uniform_vector_writable_elements (SCM uvec) -{ - if (scm_is_uniform_vector (uvec)) - return SCM_UVEC_BASE (uvec); - else - scm_wrong_type_arg_msg (NULL, 0, uvec, "uniform vector"); -} - -void -scm_uniform_vector_release_writable_elements (SCM uvec) +scm_array_handle_uniform_writable_elements (scm_t_array_handle *h) { - /* 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); + SCM vec = h->array; + if (SCM_ARRAYP (vec)) + vec = SCM_ARRAY_V (vec); + if (scm_is_uniform_vector (vec)) + { + size_t size = uvec_sizes[SCM_UVEC_TYPE(vec)]; + char *elts = SCM_UVEC_BASE (vec); + return (void *) (elts + size*h->base); + } + scm_wrong_type_arg_msg (NULL, 0, h->array, "uniform array"); } -void -scm_frame_uniform_vector_release_writable_elements (SCM uvec) +const void * +scm_uniform_vector_elements (SCM uvec, + scm_t_array_handle *h, + size_t *lenp, ssize_t *incp) { - scm_frame_unwind_handler_with_scm - (scm_uniform_vector_release_writable_elements, uvec, - SCM_F_WIND_EXPLICITLY); + return scm_uniform_vector_writable_elements (uvec, h, lenp, incp); } -size_t -scm_uniform_vector_element_size (SCM uvec) -{ - 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 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_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, @@ -689,12 +672,15 @@ 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; @@ -706,13 +692,18 @@ SCM_DEFINE (scm_uniform_vector_read_x, "uniform-vector-read!", 1, 3, 0, || (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); + base = scm_uniform_vector_writable_elements (uvec, &handle, &vlen, &inc); sz = scm_uniform_vector_element_size (uvec); - base = scm_uniform_vector_writable_elements (uvec); - scm_frame_uniform_vector_release_writable_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; @@ -740,7 +731,7 @@ SCM_DEFINE (scm_uniform_vector_read_x, "uniform-vector-read!", 1, 3, 0, { 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; @@ -774,8 +765,6 @@ SCM_DEFINE (scm_uniform_vector_read_x, "uniform-vector-read!", 1, 3, 0, ans = n / sz; } - scm_frame_end (); - return scm_from_size_t (ans); } #undef FUNC_NAME @@ -800,7 +789,9 @@ 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; @@ -814,12 +805,15 @@ SCM_DEFINE (scm_uniform_vector_write, "uniform-vector-write", 1, 3, 0, || (SCM_OPOUTPORTP (port_or_fd)), port_or_fd, SCM_ARG2, FUNC_NAME); - scm_frame_begin (0); - - vlen = scm_c_generalized_vector_length (uvec); + base = scm_uniform_vector_elements (uvec, &handle, &vlen, &inc); 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,8 +843,6 @@ SCM_DEFINE (scm_uniform_vector_write, "uniform-vector-write", 1, 3, 0, ans = n / sz; } - scm_frame_end (); - return scm_from_size_t (ans); } #undef FUNC_NAME diff --git a/libguile/srfi-4.h b/libguile/srfi-4.h index 1733a7f5c..a04148dac 100644 --- a/libguile/srfi-4.h +++ b/libguile/srfi-4.h @@ -21,6 +21,7 @@ #include "libguile/__scm.h" +#include "libguile/unif.h" /* Generic procedures. */ @@ -40,14 +41,16 @@ SCM_API size_t scm_c_uniform_vector_length (SCM v); SCM_API size_t scm_c_uniform_vector_size (SCM v); SCM_API SCM scm_c_uniform_vector_ref (SCM v, size_t idx); SCM_API void scm_c_uniform_vector_set_x (SCM v, size_t idx, SCM val); - -SCM_API size_t scm_uniform_vector_element_size (SCM uvec); -SCM_API const void *scm_uniform_vector_elements (SCM uvec); -SCM_API void scm_uniform_vector_release_elements (SCM uvec); -SCM_API void scm_frame_uniform_vector_release_elements (SCM uvec); -SCM_API void *scm_uniform_vector_writable_elements (SCM uvec); -SCM_API void scm_uniform_vector_release_writable_elements (SCM uvec); -SCM_API void scm_frame_uniform_vector_release_writable_elements (SCM uvec); +SCM_API size_t scm_uniform_vector_element_size (SCM v); +SCM_API const void *scm_array_handle_uniform_elements (scm_t_array_handle *h); +SCM_API void *scm_array_handle_uniform_writable_elements (scm_t_array_handle *h); +SCM_API const void *scm_uniform_vector_elements (SCM uvec, + scm_t_array_handle *h, + size_t *lenp, ssize_t *incp); +SCM_API void *scm_uniform_vector_writable_elements (SCM uvec, + scm_t_array_handle *h, + size_t *lenp, + ssize_t *incp); /* Specific procedures. */ @@ -62,8 +65,15 @@ SCM_API SCM scm_u8vector_set_x (SCM uvec, SCM index, SCM value); SCM_API SCM scm_u8vector_to_list (SCM uvec); SCM_API SCM scm_list_to_u8vector (SCM l); SCM_API SCM scm_any_to_u8vector (SCM obj); -SCM_API const scm_t_uint8 *scm_u8vector_elements (SCM uvec); -SCM_API scm_t_uint8 *scm_u8vector_writable_elements (SCM uvec); +SCM_API const scm_t_uint8 *scm_array_handle_u8_elements (scm_t_array_handle *h); +SCM_API scm_t_uint8 *scm_array_handle_u8_writable_elements (scm_t_array_handle *h); +SCM_API const scm_t_uint8 *scm_u8vector_elements (SCM uvec, + scm_t_array_handle *h, + size_t *lenp, ssize_t *incp); +SCM_API scm_t_uint8 *scm_u8vector_writable_elements (SCM uvec, + scm_t_array_handle *h, + size_t *lenp, + ssize_t *incp); SCM_API SCM scm_s8vector_p (SCM obj); SCM_API SCM scm_make_s8vector (SCM n, SCM fill); @@ -75,8 +85,15 @@ SCM_API SCM scm_s8vector_set_x (SCM uvec, SCM index, SCM value); SCM_API SCM scm_s8vector_to_list (SCM uvec); SCM_API SCM scm_list_to_s8vector (SCM l); SCM_API SCM scm_any_to_s8vector (SCM obj); -SCM_API const scm_t_int8 *scm_s8vector_elements (SCM uvec); -SCM_API scm_t_int8 *scm_s8vector_writable_elements (SCM uvec); +SCM_API const scm_t_int8 *scm_array_handle_s8_elements (scm_t_array_handle *h); +SCM_API scm_t_int8 *scm_array_handle_s8_writable_elements (scm_t_array_handle *h); +SCM_API const scm_t_int8 *scm_s8vector_elements (SCM uvec, + scm_t_array_handle *h, + size_t *lenp, ssize_t *incp); +SCM_API scm_t_int8 *scm_s8vector_writable_elements (SCM uvec, + scm_t_array_handle *h, + size_t *lenp, + ssize_t *incp); SCM_API SCM scm_u16vector_p (SCM obj); SCM_API SCM scm_make_u16vector (SCM n, SCM fill); @@ -88,8 +105,16 @@ SCM_API SCM scm_u16vector_set_x (SCM uvec, SCM index, SCM value); SCM_API SCM scm_u16vector_to_list (SCM uvec); SCM_API SCM scm_list_to_u16vector (SCM l); SCM_API SCM scm_any_to_u16vector (SCM obj); -SCM_API const scm_t_uint16 *scm_u16vector_elements (SCM uvec); -SCM_API scm_t_uint16 *scm_u16vector_writable_elements (SCM uvec); +SCM_API const scm_t_uint16 *scm_array_handle_u16_elements (scm_t_array_handle *h); +SCM_API scm_t_uint16 *scm_array_handle_u16_writable_elements (scm_t_array_handle *h); +SCM_API const scm_t_uint16 *scm_u16vector_elements (SCM uvec, + scm_t_array_handle *h, + size_t *lenp, + ssize_t *incp); +SCM_API scm_t_uint16 *scm_u16vector_writable_elements (SCM uvec, + scm_t_array_handle *h, + size_t *lenp, + ssize_t *incp); SCM_API SCM scm_s16vector_p (SCM obj); SCM_API SCM scm_make_s16vector (SCM n, SCM fill); @@ -101,8 +126,15 @@ SCM_API SCM scm_s16vector_set_x (SCM uvec, SCM index, SCM value); SCM_API SCM scm_s16vector_to_list (SCM uvec); SCM_API SCM scm_list_to_s16vector (SCM l); SCM_API SCM scm_any_to_s16vector (SCM obj); -SCM_API const scm_t_int16 *scm_s16vector_elements (SCM uvec); -SCM_API scm_t_int16 *scm_s16vector_writable_elements (SCM uvec); +SCM_API const scm_t_int16 *scm_array_handle_s16_elements (scm_t_array_handle *h); +SCM_API scm_t_int16 *scm_array_handle_s16_writable_elements (scm_t_array_handle *h); +SCM_API const scm_t_int16 *scm_s16vector_elements (SCM uvec, + scm_t_array_handle *h, + size_t *lenp, ssize_t *incp); +SCM_API scm_t_int16 *scm_s16vector_writable_elements (SCM uvec, + scm_t_array_handle *h, + size_t *lenp, + ssize_t *incp); SCM_API SCM scm_u32vector_p (SCM obj); SCM_API SCM scm_make_u32vector (SCM n, SCM fill); @@ -114,8 +146,16 @@ SCM_API SCM scm_u32vector_set_x (SCM uvec, SCM index, SCM value); SCM_API SCM scm_u32vector_to_list (SCM uvec); SCM_API SCM scm_list_to_u32vector (SCM l); SCM_API SCM scm_any_to_u32vector (SCM obj); -SCM_API const scm_t_uint32 *scm_u32vector_elements (SCM uvec); -SCM_API scm_t_uint32 *scm_u32vector_writable_elements (SCM uvec); +SCM_API const scm_t_uint32 *scm_array_handle_u32_elements (scm_t_array_handle *h); +SCM_API scm_t_uint32 *scm_array_handle_u32_writable_elements (scm_t_array_handle *h); +SCM_API const scm_t_uint32 *scm_u32vector_elements (SCM uvec, + scm_t_array_handle *h, + size_t *lenp, + ssize_t *incp); +SCM_API scm_t_uint32 *scm_u32vector_writable_elements (SCM uvec, + scm_t_array_handle *h, + size_t *lenp, + ssize_t *incp); SCM_API SCM scm_s32vector_p (SCM obj); SCM_API SCM scm_make_s32vector (SCM n, SCM fill); @@ -127,8 +167,15 @@ SCM_API SCM scm_s32vector_set_x (SCM uvec, SCM index, SCM value); SCM_API SCM scm_s32vector_to_list (SCM uvec); SCM_API SCM scm_list_to_s32vector (SCM l); SCM_API SCM scm_any_to_s32vector (SCM obj); -SCM_API const scm_t_int32 *scm_s32vector_elements (SCM uvec); -SCM_API scm_t_int32 *scm_s32vector_writable_elements (SCM uvec); +SCM_API const scm_t_int32 *scm_array_handle_s32_elements (scm_t_array_handle *h); +SCM_API scm_t_int32 *scm_array_handle_s32_writable_elements (scm_t_array_handle *h); +SCM_API const scm_t_int32 *scm_s32vector_elements (SCM uvec, + scm_t_array_handle *h, + size_t *lenp, ssize_t *incp); +SCM_API scm_t_int32 *scm_s32vector_writable_elements (SCM uvec, + scm_t_array_handle *h, + size_t *lenp, + ssize_t *incp); SCM_API SCM scm_u64vector_p (SCM obj); SCM_API SCM scm_make_u64vector (SCM n, SCM fill); @@ -140,8 +187,16 @@ SCM_API SCM scm_u64vector_set_x (SCM uvec, SCM index, SCM value); SCM_API SCM scm_u64vector_to_list (SCM uvec); SCM_API SCM scm_list_to_u64vector (SCM l); SCM_API SCM scm_any_to_u64vector (SCM obj); -SCM_API const scm_t_uint64 *scm_u64vector_elements (SCM uvec); -SCM_API scm_t_uint64 *scm_u64vector_writable_elements (SCM uvec); +SCM_API const scm_t_uint64 *scm_array_handle_u64_elements (scm_t_array_handle *h); +SCM_API scm_t_uint64 *scm_array_handle_u64_writable_elements (scm_t_array_handle *h); +SCM_API const scm_t_uint64 *scm_u64vector_elements (SCM uvec, + scm_t_array_handle *h, + size_t *lenp, + ssize_t *incp); +SCM_API scm_t_uint64 *scm_u64vector_writable_elements (SCM uvec, + scm_t_array_handle *h, + size_t *lenp, + ssize_t *incp); SCM_API SCM scm_s64vector_p (SCM obj); SCM_API SCM scm_make_s64vector (SCM n, SCM fill); @@ -153,8 +208,15 @@ SCM_API SCM scm_s64vector_set_x (SCM uvec, SCM index, SCM value); SCM_API SCM scm_s64vector_to_list (SCM uvec); SCM_API SCM scm_list_to_s64vector (SCM l); SCM_API SCM scm_any_to_s64vector (SCM obj); -SCM_API const scm_t_int64 *scm_s64vector_elements (SCM uvec); -SCM_API scm_t_int64 *scm_s64vector_writable_elements (SCM uvec); +SCM_API const scm_t_int64 *scm_array_handle_s64_elements (scm_t_array_handle *h); +SCM_API scm_t_int64 *scm_array_handle_s64_writable_elements (scm_t_array_handle *h); +SCM_API const scm_t_int64 *scm_s64vector_elements (SCM uvec, + scm_t_array_handle *h, + size_t *lenp, ssize_t *incp); +SCM_API scm_t_int64 *scm_s64vector_writable_elements (SCM uvec, + scm_t_array_handle *h, + size_t *lenp, + ssize_t *incp); SCM_API SCM scm_f32vector_p (SCM obj); SCM_API SCM scm_make_f32vector (SCM n, SCM fill); @@ -166,8 +228,15 @@ SCM_API SCM scm_f32vector_set_x (SCM uvec, SCM index, SCM value); SCM_API SCM scm_f32vector_to_list (SCM uvec); SCM_API SCM scm_list_to_f32vector (SCM l); SCM_API SCM scm_any_to_f32vector (SCM obj); -SCM_API const float *scm_f32vector_elements (SCM uvec); -SCM_API float *scm_f32vector_writable_elements (SCM uvec); +SCM_API const float *scm_array_handle_f32_elements (scm_t_array_handle *h); +SCM_API float *scm_array_handle_f32_writable_elements (scm_t_array_handle *h); +SCM_API const float *scm_f32vector_elements (SCM uvec, + scm_t_array_handle *h, + size_t *lenp, ssize_t *incp); +SCM_API float *scm_f32vector_writable_elements (SCM uvec, + scm_t_array_handle *h, + size_t *lenp, + ssize_t *incp); SCM_API SCM scm_f64vector_p (SCM obj); SCM_API SCM scm_make_f64vector (SCM n, SCM fill); @@ -179,8 +248,15 @@ SCM_API SCM scm_f64vector_set_x (SCM uvec, SCM index, SCM value); SCM_API SCM scm_f64vector_to_list (SCM uvec); SCM_API SCM scm_list_to_f64vector (SCM l); SCM_API SCM scm_any_to_f64vector (SCM obj); -SCM_API const double *scm_f64vector_elements (SCM uvec); -SCM_API double *scm_f64vector_writable_elements (SCM uvec); +SCM_API const double *scm_array_handle_f64_elements (scm_t_array_handle *h); +SCM_API double *scm_array_handle_f64_writable_elements (scm_t_array_handle *h); +SCM_API const double *scm_f64vector_elements (SCM uvec, + scm_t_array_handle *h, + size_t *lenp, ssize_t *incp); +SCM_API double *scm_f64vector_writable_elements (SCM uvec, + scm_t_array_handle *h, + size_t *lenp, + ssize_t *incp); SCM_API SCM scm_c32vector_p (SCM obj); SCM_API SCM scm_make_c32vector (SCM n, SCM fill); @@ -192,8 +268,15 @@ SCM_API SCM scm_c32vector_set_x (SCM uvec, SCM index, SCM value); SCM_API SCM scm_c32vector_to_list (SCM uvec); SCM_API SCM scm_list_to_c32vector (SCM l); SCM_API SCM scm_any_to_c32vector (SCM obj); -SCM_API const float *scm_c32vector_elements (SCM uvec); -SCM_API float *scm_c32vector_writable_elements (SCM uvec); +SCM_API const float *scm_array_handle_c32_elements (scm_t_array_handle *h); +SCM_API float *scm_array_handle_c32_writable_elements (scm_t_array_handle *h); +SCM_API const float *scm_c32vector_elements (SCM uvec, + scm_t_array_handle *h, + size_t *lenp, ssize_t *incp); +SCM_API float *scm_c32vector_writable_elements (SCM uvec, + scm_t_array_handle *h, + size_t *lenp, + ssize_t *incp); SCM_API SCM scm_c64vector_p (SCM obj); SCM_API SCM scm_make_c64vector (SCM n, SCM fill); @@ -205,8 +288,15 @@ SCM_API SCM scm_c64vector_set_x (SCM uvec, SCM index, SCM value); SCM_API SCM scm_c64vector_to_list (SCM uvec); SCM_API SCM scm_list_to_c64vector (SCM l); SCM_API SCM scm_any_to_c64vector (SCM obj); -SCM_API const double *scm_c64vector_elements (SCM uvec); -SCM_API double *scm_c64vector_writable_elements (SCM uvec); +SCM_API const double *scm_array_handle_c64_elements (scm_t_array_handle *h); +SCM_API double *scm_array_handle_c64_writable_elements (scm_t_array_handle *h); +SCM_API const double *scm_c64vector_elements (SCM uvec, + scm_t_array_handle *h, + size_t *lenp, ssize_t *incp); +SCM_API double *scm_c64vector_writable_elements (SCM uvec, + scm_t_array_handle *h, + size_t *lenp, + ssize_t *incp); SCM_API SCM scm_i_generalized_vector_type (SCM vec); SCM_API const char *scm_i_uniform_vector_tag (SCM uvec); diff --git a/libguile/srfi-4.i.c b/libguile/srfi-4.i.c index 21c0895ee..8f3865315 100644 --- a/libguile/srfi-4.i.c +++ b/libguile/srfi-4.i.c @@ -1,4 +1,4 @@ -/* This file defines the procedures related to one type of homogenous +/* This file defines the procedures related to one type of uniform numeric vector. It is included multiple time in srfi-4.c, once for each type. @@ -45,7 +45,7 @@ SCM_DEFINE (F(scm_,TAG,vector_p), S(TAG)"vector?", 1, 0, 0, SCM_DEFINE (F(scm_make_,TAG,vector), "make-"S(TAG)"vector", 1, 1, 0, (SCM len, SCM fill), - "Return a newly allocated homogeneous numeric vector which can\n" + "Return a newly allocated uniform numeric vector which can\n" "hold @var{len} elements. If @var{fill} is given, it is used to\n" "initialize the elements, otherwise the contents of the vector\n" "is unspecified.") @@ -65,7 +65,7 @@ F(scm_take_,TAG,vector) (const CTYPE *data, size_t n) SCM_DEFINE (F(scm_,TAG,vector), S(TAG)"vector", 0, 0, 1, (SCM l), - "Return a newly allocated homogeneous numeric vector containing\n" + "Return a newly allocated uniform numeric vector containing\n" "all argument values.") #define FUNC_NAME s_F(scm_,TAG,vector) { @@ -76,7 +76,7 @@ SCM_DEFINE (F(scm_,TAG,vector), S(TAG)"vector", 0, 0, 1, SCM_DEFINE (F(scm_,TAG,vector_length), S(TAG)"vector-length", 1, 0, 0, (SCM uvec), - "Return the number of elements in the homogeneous numeric vector\n" + "Return the number of elements in the uniform numeric vector\n" "@var{uvec}.") #define FUNC_NAME s_F(scm_,TAG,vector_length) { @@ -87,7 +87,7 @@ SCM_DEFINE (F(scm_,TAG,vector_length), S(TAG)"vector-length", 1, 0, 0, SCM_DEFINE (F(scm_,TAG,vector_ref), S(TAG)"vector-ref", 2, 0, 0, (SCM uvec, SCM index), - "Return the element at @var{index} in the homogeneous numeric\n" + "Return the element at @var{index} in the uniform numeric\n" "vector @var{uvec}.") #define FUNC_NAME s_F(scm_,TAG,vector_ref) { @@ -98,7 +98,7 @@ SCM_DEFINE (F(scm_,TAG,vector_ref), S(TAG)"vector-ref", 2, 0, 0, SCM_DEFINE (F(scm_,TAG,vector_set_x), S(TAG)"vector-set!", 3, 0, 0, (SCM uvec, SCM index, SCM value), - "Set the element at @var{index} in the homogeneous numeric\n" + "Set the element at @var{index} in the uniform numeric\n" "vector @var{uvec} to @var{value}. The return value is not\n" "specified.") #define FUNC_NAME s_F(scm_,TAG,vector_set_x) @@ -110,7 +110,7 @@ SCM_DEFINE (F(scm_,TAG,vector_set_x), S(TAG)"vector-set!", 3, 0, 0, SCM_DEFINE (F(scm_,TAG,vector_to_list), S(TAG)"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_F(scm_,TAG,vector_to_list) { return uvec_to_list (TYPE, uvec); @@ -120,7 +120,7 @@ SCM_DEFINE (F(scm_,TAG,vector_to_list), S(TAG)"vector->list", 1, 0, 0, SCM_DEFINE (F(scm_list_to_,TAG,vector), "list->"S(TAG)"vector", 1, 0, 0, (SCM l), - "Convert the list @var{l} to a numeric homogeneous vector.") + "Convert the list @var{l} to a numeric uniform vector.") #define FUNC_NAME s_F(scm_list_to_,TAG,vector) { return list_to_uvec (TYPE, l); @@ -130,7 +130,7 @@ SCM_DEFINE (F(scm_list_to_,TAG,vector), "list->"S(TAG)"vector", 1, 0, 0, SCM_DEFINE (F(scm_any_to_,TAG,vector), "any->"S(TAG)"vector", 1, 0, 0, (SCM obj), "Convert @var{obj}, which can be a list, vector, or\n" - "homogenous vector, to a numeric homogenous vector of\n" + "uniform vector, to a numeric uniform vector of\n" "type " S(TAG)".") #define FUNC_NAME s_F(scm_any_to_,TAG,vector) { @@ -139,17 +139,45 @@ SCM_DEFINE (F(scm_any_to_,TAG,vector), "any->"S(TAG)"vector", 1, 0, 0, #undef FUNC_NAME const CTYPE * -F(scm_,TAG,vector_elements) (SCM obj) +F(scm_array_handle_,TAG,_elements) (scm_t_array_handle *h) { - uvec_assert (TYPE, obj); - return (const CTYPE *)SCM_UVEC_BASE (obj); + return F(scm_array_handle_,TAG,_writable_elements) (h); } CTYPE * -F(scm_,TAG,vector_writable_elements) (SCM obj) +F(scm_array_handle_,TAG,_writable_elements) (scm_t_array_handle *h) { - uvec_assert (TYPE, obj); - return (CTYPE *)SCM_UVEC_BASE (obj); + SCM vec = h->array; + if (SCM_ARRAYP (vec)) + vec = SCM_ARRAY_V (vec); + uvec_assert (TYPE, vec); + if (TYPE == SCM_UVEC_C32 || TYPE == SCM_UVEC_C64) + return ((CTYPE *)SCM_UVEC_BASE (vec)) + 2*h->base; + else + return ((CTYPE *)SCM_UVEC_BASE (vec)) + h->base; +} + +const CTYPE * +F(scm_,TAG,vector_elements) (SCM uvec, + scm_t_array_handle *h, + size_t *lenp, ssize_t *incp) +{ + return F(scm_,TAG,vector_writable_elements) (uvec, h, lenp, incp); +} + +CTYPE * +F(scm_,TAG,vector_writable_elements) (SCM uvec, + scm_t_array_handle *h, + size_t *lenp, ssize_t *incp) +{ + scm_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 F(scm_array_handle_,TAG,_writable_elements) (h); } #undef paste diff --git a/libguile/unif.c b/libguile/unif.c index 4de949c02..a546cdba9 100644 --- a/libguile/unif.c +++ b/libguile/unif.c @@ -253,6 +253,122 @@ scm_is_typed_array (SCM obj, SCM type) return scm_is_eq (type, scm_i_generalized_vector_type (obj)); } +void +scm_array_get_handle (SCM array, scm_t_array_handle *h) +{ + h->array = array; + if (SCM_ARRAYP (array) || SCM_ENCLOSED_ARRAYP (array)) + { + h->dims = SCM_ARRAY_DIMS (array); + h->base = SCM_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"); +} + +size_t +scm_array_handle_rank (scm_t_array_handle *h) +{ + if (SCM_ARRAYP (h->array) || SCM_ENCLOSED_ARRAYP (h->array)) + return SCM_ARRAY_NDIM (h->array); + else + return 1; +} + +scm_t_array_dim * +scm_array_handle_dims (scm_t_array_handle *h) +{ + return h->dims; +} + +SCM +scm_array_handle_ref (scm_t_array_handle *h, size_t pos) +{ + pos += h->base; + if (SCM_ARRAYP (h->array)) + return scm_i_cvref (SCM_ARRAY_V (h->array), pos, 0); + if (SCM_ENCLOSED_ARRAYP (h->array)) + return scm_i_cvref (SCM_ARRAY_V (h->array), pos, 1); + return scm_c_generalized_vector_ref (h->array, pos); +} + +void +scm_array_handle_set (scm_t_array_handle *h, size_t pos, SCM val) +{ + pos += h->base; + if (SCM_ARRAYP (h->array)) + scm_c_generalized_vector_set_x (SCM_ARRAY_V (h->array), pos, val); + if (SCM_ENCLOSED_ARRAYP (h->array)) + scm_wrong_type_arg_msg (NULL, 0, h->array, "non-enclosed array"); + scm_c_generalized_vector_set_x (h->array, pos, val); +} + +const SCM * +scm_array_handle_elements (scm_t_array_handle *h) +{ + SCM vec = h->array; + if (SCM_ARRAYP (vec)) + vec = SCM_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"); +} + +SCM * +scm_array_handle_writable_elements (scm_t_array_handle *h) +{ + SCM vec = h->array; + if (SCM_ARRAYP (vec)) + vec = SCM_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"); +} + +void +scm_vector_get_handle (SCM vec, scm_t_array_handle *h) +{ + scm_array_get_handle (vec, h); + if (scm_array_handle_rank (h) != 1) + scm_wrong_type_arg_msg (NULL, 0, vec, "vector"); +} + +const SCM * +scm_vector_elements (SCM vec, scm_t_array_handle *h, + size_t *lenp, ssize_t *incp) +{ + scm_vector_get_handle (vec, 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_elements (h); +} + +SCM * +scm_vector_writable_elements (SCM vec, scm_t_array_handle *h, + size_t *lenp, ssize_t *incp) +{ + scm_vector_get_handle (vec, 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_writable_elements (h); +} + #if SCM_ENABLE_DEPRECATED SCM_DEFINE (scm_array_p, "array?", 1, 1, 0, @@ -281,16 +397,24 @@ SCM_DEFINE (scm_array_p, "array?", 1, 1, 0, scm_is_array or scm_is_typed_array anyway. */ -SCM_DEFINE (scm_array_p, "array?", 1, 0, 0, - (SCM obj, SCM unused), +static SCM scm_i_array_p (SCM obj); + +SCM_DEFINE (scm_i_array_p, "array?", 1, 0, 0, + (SCM obj), "Return @code{#t} if the @var{obj} is an array, and @code{#f} if\n" "not.") -#define FUNC_NAME s_scm_array_p +#define FUNC_NAME s_scm_i_array_p { return scm_from_bool (scm_is_array (obj)); } #undef FUNC_NAME +SCM +scm_array_p (SCM obj, SCM prot) +{ + return scm_from_bool (scm_is_array (obj)); +} + #endif /* !SCM_ENABLE_DEPRECATED */ @@ -708,7 +832,7 @@ SCM_DEFINE (scm_make_shared_array, "make-shared-array", 2, 0, 1, if (1 == SCM_ARRAY_NDIM (ra) && 0 == SCM_ARRAY_BASE (ra)) { SCM v = SCM_ARRAY_V (ra); - unsigned long int length = scm_to_ulong (scm_uniform_vector_length (v)); + size_t length = scm_c_generalized_vector_length (v); if (1 == s->inc && 0 == s->lbnd && length == 1 + s->ubnd) return v; if (s->ubnd < s->lbnd) @@ -745,7 +869,6 @@ SCM_DEFINE (scm_transpose_array, "transpose-array", 1, 0, 1, #define FUNC_NAME s_scm_transpose_array { SCM res, vargs; - SCM const *ve = &vargs; scm_t_array_dim *s, *r; int ndim, i, k; @@ -767,13 +890,13 @@ SCM_DEFINE (scm_transpose_array, "transpose-array", 1, 0, 1, if (SCM_ARRAYP (ra) || SCM_ENCLOSED_ARRAYP (ra)) { vargs = scm_vector (args); - if (SCM_VECTOR_LENGTH (vargs) != SCM_ARRAY_NDIM (ra)) + if (SCM_SIMPLE_VECTOR_LENGTH (vargs) != SCM_ARRAY_NDIM (ra)) SCM_WRONG_NUM_ARGS (); - ve = SCM_VELTS (vargs); ndim = 0; for (k = 0; k < SCM_ARRAY_NDIM (ra); k++) { - i = scm_to_signed_integer (ve[k], 0, SCM_ARRAY_NDIM(ra)); + i = scm_to_signed_integer (SCM_SIMPLE_VECTOR_REF (vargs, k), + 0, SCM_ARRAY_NDIM(ra)); if (ndim < i) ndim = i; } @@ -788,7 +911,7 @@ SCM_DEFINE (scm_transpose_array, "transpose-array", 1, 0, 1, } for (k = SCM_ARRAY_NDIM (ra); k--;) { - i = scm_to_int (ve[k]); + i = scm_to_int (SCM_SIMPLE_VECTOR_REF (vargs, k)); s = &(SCM_ARRAY_DIMS (ra)[k]); r = &(SCM_ARRAY_DIMS (res)[i]); if (r->ubnd < r->lbnd) @@ -859,7 +982,7 @@ SCM_DEFINE (scm_enclose_array, "enclose-array", 1, 0, 1, if (scm_is_generalized_vector (ra)) { s->lbnd = 0; - s->ubnd = scm_to_long (scm_uniform_vector_length (ra)) - 1; + s->ubnd = scm_c_generalized_vector_length (ra) - 1; s->inc = 1; SCM_ARRAY_V (ra_inr) = ra; SCM_ARRAY_BASE (ra_inr) = 0; @@ -1755,23 +1878,19 @@ SCM_DEFINE (scm_bit_set_star_x, "bit-set*!", 3, 0, 0, } else if (scm_is_true (scm_u32vector_p (kv))) { - size_t ulen, i; + scm_t_array_handle handle; + size_t i, len; + ssize_t inc; const scm_t_uint32 *indices; /* assert that obj is a boolean. */ scm_to_bool (obj); - scm_frame_begin (0); - - ulen = scm_c_uniform_vector_length (kv); - indices = scm_u32vector_elements (kv); - scm_frame_uniform_vector_release_elements (kv); + indices = scm_u32vector_elements (kv, &handle, &len, &inc); + for (i = 0; i < len; i++, indices += inc) + scm_c_bitvector_set_x (v, (size_t) *indices, obj); - for (i = 0; i < ulen; i++) - scm_c_bitvector_set_x (v, (size_t)indices[i], obj); - - scm_frame_end (); } else scm_wrong_type_arg_msg (NULL, 0, kv, "bitvector or u32vector"); @@ -1833,23 +1952,20 @@ SCM_DEFINE (scm_bit_count_star, "bit-count*", 3, 0, 0, } else if (scm_is_true (scm_u32vector_p (kv))) { - size_t count = 0, ulen, i; + size_t count = 0; + scm_t_array_handle handle; + size_t i, len; + ssize_t inc; const scm_t_uint32 *indices; int bit = scm_to_bool (obj); - scm_frame_begin (0); - - ulen = scm_c_uniform_vector_length (kv); - indices = scm_u32vector_elements (kv); - scm_frame_uniform_vector_release_elements (kv); + indices = scm_u32vector_elements (kv, &handle, &len, &inc); - for (i = 0; i < ulen; i++) - if ((scm_is_true (scm_c_bitvector_ref (v, (size_t)indices[i])) != 0) + for (i = 0; i < len; i++, indices += inc) + if ((scm_is_true (scm_c_bitvector_ref (v, (size_t) *indices)) != 0) == (bit != 0)) count++; - scm_frame_end (); - return scm_from_size_t (count); } else diff --git a/libguile/unif.h b/libguile/unif.h index 83325f7d6..1a0073f21 100644 --- a/libguile/unif.h +++ b/libguile/unif.h @@ -105,6 +105,29 @@ SCM_API int scm_is_typed_array (SCM obj, SCM type); SCM_API SCM scm_i_read_array (SCM port, int c); +typedef struct { + SCM array; + size_t base; + scm_t_array_dim *dims; + scm_t_array_dim dim0; +} scm_t_array_handle; + +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 SCM scm_array_handle_ref (scm_t_array_handle *h, size_t pos); +SCM_API void scm_array_handle_set (scm_t_array_handle *h, size_t pos, SCM val); +SCM_API const SCM *scm_array_handle_elements (scm_t_array_handle *h); +SCM_API SCM *scm_array_handle_writable_elements (scm_t_array_handle *h); + +SCM_API void scm_vector_get_handle (SCM vec, scm_t_array_handle *h); +SCM_API const SCM *scm_vector_elements (SCM vec, + scm_t_array_handle *h, + size_t *lenp, ssize_t *incp); +SCM_API SCM *scm_vector_writable_elements (SCM vec, + scm_t_array_handle *h, + size_t *lenp, ssize_t *incp); + /** Bit vectors */ @@ -138,17 +161,22 @@ SCM_API void scm_frame_bitvector_release_writable_elements (SCM vec); /* deprecated. */ +#if SCM_ENABLE_DEPRECATED + SCM_API SCM scm_make_uve (long k, SCM prot); +SCM_API SCM scm_array_prototype (SCM ra); +SCM_API SCM scm_list_to_uniform_array (SCM ndim, SCM prot, SCM lst); +SCM_API SCM scm_dimensions_to_uniform_array (SCM dims, SCM prot, SCM fill); + +#endif + SCM_API SCM scm_make_ra (int ndim); SCM_API void scm_ra_set_contp (SCM ra); SCM_API SCM scm_cvref (SCM v, unsigned long pos, SCM last); SCM_API SCM scm_istr2bve (SCM str); SCM_API int scm_raprin1 (SCM exp, SCM port, scm_print_state *pstate); -SCM_API SCM scm_array_prototype (SCM ra); -SCM_API SCM scm_list_to_uniform_array (SCM ndim, SCM prot, SCM lst); SCM_API long scm_aind (SCM ra, SCM args, const char *what); SCM_API SCM scm_shap2ra (SCM args, const char *what); -SCM_API SCM scm_dimensions_to_uniform_array (SCM dims, SCM prot, SCM fill); SCM_API SCM scm_ra2contig (SCM ra, int copy); SCM_API SCM scm_i_cvref (SCM v, size_t p, int enclosed); diff --git a/libguile/vectors.c b/libguile/vectors.c index 852749af1..0375e5882 100644 --- a/libguile/vectors.c +++ b/libguile/vectors.c @@ -32,60 +32,84 @@ #include "libguile/strings.h" #include "libguile/srfi-13.h" #include "libguile/dynwind.h" +#include "libguile/deprecation.h" +#define VECTOR_MAX_LENGTH (SCM_T_BITS_MAX >> 8) + +#if SCM_ENABLE_DEPRECATED + int -scm_is_vector (SCM obj) +SCM_VECTORP (SCM x) { - return (SCM_VECTORP (obj) - || (SCM_ARRAYP (obj) && SCM_ARRAY_NDIM (obj) == 1)); + scm_c_issue_deprecation_warning + ("SCM_VECTORP is deprecated. Use scm_is_vector instead."); + return SCM_I_IS_VECTOR (x); } -SCM * -scm_vector_writable_elements (SCM vec) +unsigned long +SCM_VECTOR_LENGTH (SCM x) { - if (SCM_VECTORP (vec)) - return SCM_WRITABLE_VELTS (vec); - else - scm_wrong_type_arg_msg (NULL, 0, vec, "simple vector"); + scm_c_issue_deprecation_warning + ("SCM_VECTOR_LENGTH is deprecated. Use scm_c_vector_length instead."); + return SCM_I_VECTOR_LENGTH (x); } const SCM * -scm_vector_elements (SCM vec) +SCM_VELTS (SCM x) { - if (SCM_VECTORP (vec)) - return SCM_VELTS (vec); - else - scm_wrong_type_arg_msg (NULL, 0, vec, "simple vector"); + scm_c_issue_deprecation_warning + ("SCM_VELTS is deprecated. Use scm_vector_elements instead."); + return SCM_I_VECTOR_ELTS (x); } -void -scm_vector_release_writable_elements (SCM vec) +SCM * +SCM_WRITABLE_VELTS (SCM x) { - scm_remember_upto_here_1 (vec); + scm_c_issue_deprecation_warning + ("SCM_WRITABLE_VELTS is deprecated. " + "Use scm_vector_writable_elements instead."); + return SCM_I_VECTOR_WELTS (x); } -void -scm_vector_release_elements (SCM vec) +SCM +SCM_VECTOR_REF (SCM x, size_t idx) { - scm_remember_upto_here_1 (vec); + scm_c_issue_deprecation_warning + ("SCM_VECTOR_REF is deprecated. " + "Use scm_c_vector_ref or scm_vector_elements instead."); + return scm_c_vector_ref (x, idx); } void -scm_frame_vector_release_writable_elements (SCM vec) +SCM_VECTOR_SET (SCM x, size_t idx, SCM val) { - scm_frame_unwind_handler_with_scm - (scm_vector_release_writable_elements, vec, - SCM_F_WIND_EXPLICITLY); + scm_c_issue_deprecation_warning + ("SCM_VECTOR_SET is deprecated. " + "Use scm_c_vector_set_x or scm_vector_writable_elements instead."); + scm_c_vector_set_x (x, idx, val); } -void -scm_frame_vector_release_elements (SCM vec) +#endif + +int +scm_is_vector (SCM obj) +{ + if (SCM_I_IS_VECTOR (obj)) + return 1; + if (SCM_ARRAYP (obj) && SCM_ARRAY_NDIM (obj) == 1) + { + SCM v = SCM_ARRAY_V (obj); + return SCM_I_IS_VECTOR (v); + } + return 0; +} + +int +scm_is_simple_vector (SCM obj) { - scm_frame_unwind_handler_with_scm - (scm_vector_release_elements, vec, - SCM_F_WIND_EXPLICITLY); + return SCM_I_IS_VECTOR (obj); } SCM_DEFINE (scm_vector_p, "vector?", 1, 0, 0, @@ -103,8 +127,8 @@ SCM_GPROC (s_vector_length, "vector-length", 1, 0, 0, scm_vector_length, g_vecto SCM scm_vector_length (SCM v) { - if (SCM_VECTORP (v)) - return scm_from_size_t (SCM_VECTOR_LENGTH (v)); + if (SCM_I_IS_VECTOR (v)) + return scm_from_size_t (SCM_I_VECTOR_LENGTH (v)); else if (SCM_ARRAYP (v) && SCM_ARRAY_NDIM (v) == 1) { scm_t_array_dim *dim = SCM_ARRAY_DIMS (v); @@ -117,8 +141,8 @@ scm_vector_length (SCM v) size_t scm_c_vector_length (SCM v) { - if (SCM_VECTORP (v)) - return SCM_VECTOR_LENGTH (v); + if (SCM_I_IS_VECTOR (v)) + return SCM_I_VECTOR_LENGTH (v); else return scm_to_size_t (scm_vector_length (v)); } @@ -146,19 +170,19 @@ SCM_DEFINE (scm_vector, "vector", 0, 0, 1, SCM res; SCM *data; long i, len; + scm_t_array_handle handle; SCM_VALIDATE_LIST_COPYLEN (1, l, len); - res = scm_c_make_vector (len, SCM_UNSPECIFIED); - data = scm_vector_writable_elements (res); + res = scm_c_make_vector (len, SCM_UNSPECIFIED); + data = scm_vector_writable_elements (res, &handle, NULL, NULL); i = 0; while (!SCM_NULL_OR_NIL_P (l) && i < len) { data[i] = SCM_CAR (l); l = SCM_CDR (l); - i++; + i += 1; } - scm_vector_release_writable_elements (res); return res; } @@ -191,19 +215,24 @@ scm_vector_ref (SCM v, SCM k) SCM scm_c_vector_ref (SCM v, size_t k) { - if (SCM_VECTORP (v)) + if (SCM_I_IS_VECTOR (v)) { - if (k >= SCM_VECTOR_LENGTH (v)) + if (k >= SCM_I_VECTOR_LENGTH (v)) scm_out_of_range (NULL, scm_from_size_t (k)); - return SCM_VECTOR_REF (v, k); + return (SCM_I_VECTOR_ELTS(v))[k]; } else if (SCM_ARRAYP (v) && SCM_ARRAY_NDIM (v) == 1) { scm_t_array_dim *dim = SCM_ARRAY_DIMS (v); - if (k >= dim->ubnd - dim->lbnd + 1) - scm_out_of_range (NULL, scm_from_size_t (k)); - k = SCM_ARRAY_BASE (v) + k*dim->inc; - return scm_c_generalized_vector_ref (SCM_ARRAY_V (v), k); + SCM vv = SCM_ARRAY_V (v); + if (SCM_I_IS_VECTOR (vv)) + { + if (k >= dim->ubnd - dim->lbnd + 1) + scm_out_of_range (NULL, scm_from_size_t (k)); + k = SCM_ARRAY_BASE (v) + k*dim->inc; + return (SCM_I_VECTOR_ELTS (vv))[k]; + } + scm_wrong_type_arg_msg (NULL, 0, v, "non-uniform vector"); } else SCM_WTA_DISPATCH_2 (g_vector_ref, v, scm_from_size_t (k), 2, NULL); @@ -234,19 +263,25 @@ scm_vector_set_x (SCM v, SCM k, SCM obj) void scm_c_vector_set_x (SCM v, size_t k, SCM obj) { - if (SCM_VECTORP (v)) + if (SCM_I_IS_VECTOR (v)) { - if (k >= SCM_VECTOR_LENGTH (v)) + if (k >= SCM_I_VECTOR_LENGTH (v)) scm_out_of_range (NULL, scm_from_size_t (k)); - SCM_VECTOR_SET (v, k, obj); + (SCM_I_VECTOR_WELTS(v))[k] = obj; } else if (SCM_ARRAYP (v) && SCM_ARRAY_NDIM (v) == 1) { scm_t_array_dim *dim = SCM_ARRAY_DIMS (v); - if (k >= dim->ubnd - dim->lbnd + 1) - scm_out_of_range (NULL, scm_from_size_t (k)); - k = SCM_ARRAY_BASE (v) + k*dim->inc; - scm_c_generalized_vector_set_x (SCM_ARRAY_V (v), k, obj); + SCM vv = SCM_ARRAY_V (v); + if (SCM_I_IS_VECTOR (vv)) + { + if (k >= dim->ubnd - dim->lbnd + 1) + scm_out_of_range (NULL, scm_from_size_t (k)); + k = SCM_ARRAY_BASE (v) + k*dim->inc; + (SCM_I_VECTOR_WELTS (vv))[k] = obj; + } + else + scm_wrong_type_arg_msg (NULL, 0, v, "non-uniform vector"); } else { @@ -266,7 +301,7 @@ SCM_DEFINE (scm_make_vector, "make-vector", 1, 1, 0, "unspecified.") #define FUNC_NAME s_scm_make_vector { - size_t l = scm_to_unsigned_integer (k, 0, SCM_VECTOR_MAX_LENGTH); + size_t l = scm_to_unsigned_integer (k, 0, VECTOR_MAX_LENGTH); if (SCM_UNBNDP (fill)) fill = SCM_UNSPECIFIED; @@ -281,28 +316,92 @@ scm_c_make_vector (size_t k, SCM fill) #define FUNC_NAME s_scm_make_vector { SCM v; - scm_t_bits *base; + SCM *base; if (k > 0) { unsigned long int j; - SCM_ASSERT_RANGE (1, scm_from_ulong (k), k <= SCM_VECTOR_MAX_LENGTH); + SCM_ASSERT_RANGE (1, scm_from_ulong (k), k <= VECTOR_MAX_LENGTH); - base = scm_gc_malloc (k * sizeof (scm_t_bits), "vector"); + base = scm_gc_malloc (k * sizeof (SCM), "vector"); for (j = 0; j != k; ++j) - base[j] = SCM_UNPACK (fill); + base[j] = fill; } else base = NULL; - v = scm_cell (SCM_MAKE_VECTOR_TAG (k, scm_tc7_vector), (scm_t_bits) base); + v = scm_cell ((k << 8) | scm_tc7_vector, (scm_t_bits) base); scm_remember_upto_here_1 (fill); return v; } #undef FUNC_NAME +SCM_DEFINE (scm_vector_copy, "vector-copy", 1, 0, 0, + (SCM vec), + "Return a copy of @var{vec}.") +#define FUNC_NAME s_scm_vector_copy +{ + scm_t_array_handle handle; + size_t i, len; + ssize_t inc; + const SCM *src; + SCM *dst; + + src = scm_vector_elements (vec, &handle, &len, &inc); + dst = scm_gc_malloc (len * sizeof (SCM), "vector"); + for (i = 0; i < len; i++, src += inc) + dst[i] = *src; + + return scm_cell ((len << 8) | scm_tc7_vector, (scm_t_bits) dst); +} +#undef FUNC_NAME + +void +scm_i_vector_free (SCM vec) +{ + scm_gc_free (SCM_I_VECTOR_WELTS (vec), + SCM_I_VECTOR_LENGTH (vec) * sizeof(SCM), + "vector"); +} + +/* Allocate memory for a weak vector on behalf of the caller. The allocated + * vector will be of the given weak vector subtype. It will contain size + * elements which are initialized with the 'fill' object, or, if 'fill' is + * undefined, with an unspecified object. + */ +SCM +scm_i_allocate_weak_vector (scm_t_bits type, SCM size, SCM fill) +{ + size_t c_size; + SCM *base; + SCM v; + + c_size = scm_to_unsigned_integer (size, 0, VECTOR_MAX_LENGTH); + + if (c_size > 0) + { + size_t j; + + if (SCM_UNBNDP (fill)) + fill = SCM_UNSPECIFIED; + + base = scm_gc_malloc (c_size * sizeof (SCM), "weak vector"); + for (j = 0; j != c_size; ++j) + base[j] = fill; + } + else + base = NULL; + + v = scm_double_cell ((c_size << 8) | scm_tc7_wvect, + (scm_t_bits) base, + type, + SCM_UNPACK (SCM_EOL)); + scm_remember_upto_here_1 (fill); + + return v; +} SCM_DEFINE (scm_vector_to_list, "vector->list", 1, 0, 0, (SCM v), @@ -314,21 +413,19 @@ SCM_DEFINE (scm_vector_to_list, "vector->list", 1, 0, 0, "@end lisp") #define FUNC_NAME s_scm_vector_to_list { - if (SCM_VECTORP (v)) + SCM res = SCM_EOL; + const SCM *data; + scm_t_array_handle handle; + size_t i, len; + ssize_t inc; + + data = scm_vector_elements (v, &handle, &len, &inc); + for (i = len*inc; i > 0;) { - SCM res = SCM_EOL; - long i; - const SCM *data; - data = scm_vector_elements (v); - for(i = SCM_VECTOR_LENGTH(v)-1; i >= 0; i--) - res = scm_cons (data[i], res); - scm_vector_release_elements (v); - return res; + i -= inc; + res = scm_cons (data[i], res); } - else if (SCM_ARRAYP (v) && SCM_ARRAY_NDIM (v) == 1) - return scm_array_to_list (v); - else - scm_wrong_type_arg_msg (NULL, 0, v, "vector"); + return res; } #undef FUNC_NAME @@ -339,18 +436,15 @@ SCM_DEFINE (scm_vector_fill_x, "vector-fill!", 2, 0, 0, "returned by @code{vector-fill!} is unspecified.") #define FUNC_NAME s_scm_vector_fill_x { - if (SCM_VECTORP (v)) - { - size_t i, len; - SCM *elts = scm_vector_writable_elements (v); - for (i = 0, len = SCM_VECTOR_LENGTH (v); i < len; i++) - elts[i] = fill; - return SCM_UNSPECIFIED; - } - else if (SCM_ARRAYP (v) && SCM_ARRAY_NDIM (v) == 1) - return scm_array_fill_x (v, fill); - else - scm_wrong_type_arg_msg (NULL, 0, v, "vector"); + scm_t_array_handle handle; + SCM *data; + size_t i, len; + ssize_t inc; + + data = scm_vector_writable_elements (v, &handle, &len, &inc); + for (i = 0; i < len; i += inc) + data[i] = fill; + return SCM_UNSPECIFIED; } #undef FUNC_NAME @@ -359,8 +453,9 @@ SCM scm_vector_equal_p (SCM x, SCM y) { long i; - for (i = SCM_VECTOR_LENGTH (x) - 1; i >= 0; i--) - if (scm_is_false (scm_equal_p (SCM_VELTS (x)[i], SCM_VELTS (y)[i]))) + for (i = SCM_I_VECTOR_LENGTH (x) - 1; i >= 0; i--) + if (scm_is_false (scm_equal_p (SCM_I_VECTOR_ELTS (x)[i], + SCM_I_VECTOR_ELTS (y)[i]))) return SCM_BOOL_F; return SCM_BOOL_T; } @@ -377,32 +472,26 @@ SCM_DEFINE (scm_vector_move_left_x, "vector-move-left!", 5, 0, 0, "@var{start1} is greater than @var{start2}.") #define FUNC_NAME s_scm_vector_move_left_x { + scm_t_array_handle handle1, handle2; + const SCM *elts1; + SCM *elts2; size_t len1, len2; + ssize_t inc1, inc2; size_t i, j, e; + + elts1 = scm_vector_elements (vec1, &handle1, &len1, &inc1); + elts2 = scm_vector_writable_elements (vec2, &handle2, &len2, &inc2); - len1 = scm_c_vector_length (vec1); - len2 = scm_c_vector_length (vec2); i = scm_to_unsigned_integer (start1, 0, len1); e = scm_to_unsigned_integer (end1, i, len1); j = scm_to_unsigned_integer (start2, 0, len2 - (i-e)); - /* Optimize common case of two simple vectors. - */ - if (SCM_VECTORP (vec1) && SCM_VECTORP (vec2)) - { - const SCM *elts1 = scm_vector_elements (vec1); - SCM *elts2 = scm_vector_writable_elements (vec2); - for (; i < e; i++, j++) - elts2[j] = elts1[i]; - scm_vector_release_elements (vec1); - scm_vector_release_writable_elements (vec2); - } - else - { - for (; i < e; i++, j++) - scm_c_vector_set_x (vec2, j, scm_c_vector_ref (vec1, i)); - } - + i *= inc1; + e *= inc1; + j *= inc2; + for (; i < e; i += inc1, j += inc2) + elts2[j] = elts1[i]; + return SCM_UNSPECIFIED; } #undef FUNC_NAME @@ -418,39 +507,30 @@ SCM_DEFINE (scm_vector_move_right_x, "vector-move-right!", 5, 0, 0, "@var{start1} is less than @var{start2}.") #define FUNC_NAME s_scm_vector_move_right_x { + scm_t_array_handle handle1, handle2; + const SCM *elts1; + SCM *elts2; size_t len1, len2; + ssize_t inc1, inc2; size_t i, j, e; + + elts1 = scm_vector_elements (vec1, &handle1, &len1, &inc1); + elts2 = scm_vector_writable_elements (vec2, &handle2, &len2, &inc2); - len1 = scm_c_vector_length (vec1); - len2 = scm_c_vector_length (vec2); i = scm_to_unsigned_integer (start1, 0, len1); e = scm_to_unsigned_integer (end1, i, len1); j = scm_to_unsigned_integer (start2, 0, len2 - (i-e)); - /* Optimize common case of two regular vectors. - */ - j += e - i; - if (SCM_VECTORP (vec1) && SCM_VECTORP (vec2)) - { - const SCM *elts1 = scm_vector_elements (vec1); - SCM *elts2 = scm_vector_writable_elements (vec2); - while (i < e) - { - e--, j--; - elts2[j] = elts1[e]; - } - scm_vector_release_elements (vec1); - scm_vector_release_writable_elements (vec2); - } - else + i *= inc1; + e *= inc1; + j *= inc2; + while (i < e) { - while (i < e) - { - e--, j--; - scm_c_vector_set_x (vec2, j, scm_c_vector_ref (vec1, e)); - } + e -= inc1; + j -= inc2; + elts2[j] = elts1[e]; } - + return SCM_UNSPECIFIED; } #undef FUNC_NAME diff --git a/libguile/vectors.h b/libguile/vectors.h index cf19ea624..0cb98fab8 100644 --- a/libguile/vectors.h +++ b/libguile/vectors.h @@ -23,31 +23,10 @@ #include "libguile/__scm.h" +#include "libguile/unif.h" -#define SCM_VECTORP(x) (!SCM_IMP (x) && (SCM_TYP7S (x) == scm_tc7_vector)) -#define SCM_VECTOR_BASE(x) ((scm_t_bits *) SCM_CELL_WORD_1 (x)) -#define SCM_SET_VECTOR_BASE(v, b) (SCM_SET_CELL_WORD_1 ((v), (b))) -#define SCM_VECTOR_MAX_LENGTH ((1L << 24) - 1) -#define SCM_VECTOR_LENGTH(x) (((unsigned long) SCM_CELL_WORD_0 (x)) >> 8) -#define SCM_MAKE_VECTOR_TAG(l, t) (((l) << 8) + (t)) -#define SCM_SET_VECTOR_LENGTH(v, l, t) (SCM_SET_CELL_WORD_0 ((v), SCM_MAKE_VECTOR_TAG(l, t))) - -#define SCM_VELTS(x) ((const SCM *) SCM_CELL_WORD_1 (x)) -#define SCM_VELTS_AS_STACKITEMS(x) ((SCM_STACKITEM *) SCM_CELL_WORD_1 (x)) -#define SCM_SETVELTS(x, v) (SCM_SET_CELL_WORD_1 ((x), (v))) -#define SCM_VECTOR_REF(x, idx) (((const SCM *) SCM_CELL_WORD_1 (x))[(idx)]) -#define SCM_VECTOR_SET(x, idx, val) (((SCM*)SCM_CELL_WORD_1 (x))[(idx)] = (val)) - -#define SCM_GC_WRITABLE_VELTS(x) ((SCM*) SCM_VELTS(x)) - -/* - no WB yet. - */ -#define SCM_WRITABLE_VELTS(x) ((SCM*) SCM_VELTS(x)) - - /* bit vectors */ @@ -55,6 +34,8 @@ #define SCM_BITVEC_SET(a, i) SCM_BITVECTOR_BASE (a) [(i) / SCM_LONG_BIT] |= (1L << ((i) % SCM_LONG_BIT)) #define SCM_BITVEC_CLR(a, i) SCM_BITVECTOR_BASE (a) [(i) / SCM_LONG_BIT] &= ~(1L << ((i) % SCM_LONG_BIT)) + + @@ -70,18 +51,21 @@ SCM_API SCM scm_vector_move_left_x (SCM vec1, SCM start1, SCM end1, SCM vec2, SCM start2); SCM_API SCM scm_vector_move_right_x (SCM vec1, SCM start1, SCM end1, SCM vec2, SCM start2); +SCM_API SCM scm_vector_copy (SCM vec); SCM_API int scm_is_vector (SCM obj); +SCM_API int scm_is_simple_vector (SCM obj); SCM_API SCM scm_c_make_vector (size_t len, SCM fill); SCM_API size_t scm_c_vector_length (SCM vec); SCM_API SCM scm_c_vector_ref (SCM vec, size_t k); SCM_API void scm_c_vector_set_x (SCM vec, size_t k, SCM obj); -SCM_API const SCM *scm_vector_elements (SCM vec); -SCM_API void scm_vector_release_elements (SCM vec); -SCM_API void scm_frame_vector_release_elements (SCM vec); -SCM_API SCM *scm_vector_writable_elements (SCM vec); -SCM_API void scm_vector_release_writable_elements (SCM vec); -SCM_API void scm_frame_vector_release_writable_elements (SCM vec); + +/* Fast, non-checking accessors for simple vectors. + */ +#define SCM_SIMPLE_VECTOR_LENGTH(x) SCM_I_VECTOR_LENGTH(x) +#define SCM_SIMPLE_VECTOR_REF(x,idx) ((SCM_I_VECTOR_ELTS(x))[idx]) +#define SCM_SIMPLE_VECTOR_SET(x,idx,val) ((SCM_I_VECTOR_WELTS(x))[idx]=(val)) +#define SCM_SIMPLE_VECTOR_LOC(x,idx) (&((SCM_I_VECTOR_WELTS(x))[idx])) /* Generalized vectors */ @@ -98,8 +82,46 @@ SCM_API void scm_c_generalized_vector_set_x (SCM v, size_t idx, SCM val); /* Deprecated */ +#if SCM_ENABLE_DEPRECATED + +#define SCM_VECTOR_MAX_LENGTH ((1L << 24) - 1) + +SCM_API int SCM_VECTORP (SCM x); +SCM_API unsigned long SCM_VECTOR_LENGTH (SCM x); +SCM_API const SCM *SCM_VELTS (SCM x); +SCM_API SCM *SCM_WRITABLE_VELTS (SCM x); +SCM_API SCM SCM_VECTOR_REF (SCM x, size_t idx); +SCM_API void SCM_VECTOR_SET (SCM x, size_t idx, SCM val); + +#endif + SCM_API SCM scm_vector_equal_p (SCM x, SCM y); +/* Internals */ + +#define SCM_I_IS_VECTOR(x) (!SCM_IMP(x) && (SCM_TYP7S(x)==scm_tc7_vector)) +#define SCM_I_VECTOR_ELTS(x) ((const SCM *) SCM_CELL_WORD_1 (x)) +#define SCM_I_VECTOR_WELTS(x) ((SCM *) SCM_CELL_WORD_1 (x)) +#define SCM_I_VECTOR_LENGTH(x) (((size_t) SCM_CELL_WORD_0 (x)) >> 8) + +SCM_API void scm_i_vector_free (SCM vec); + +/* Weak vectors share implementation details with ordinary vectors, + but no one else should. Weak vectors need to be cleaned up as + well. + */ + +#define SCM_I_WVECTP(x) (!SCM_IMP (x) && \ + SCM_TYP7 (x) == scm_tc7_wvect) +#define SCM_I_WVECT_LENGTH SCM_I_VECTOR_LENGTH +#define SCM_I_WVECT_VELTS SCM_I_VECTOR_ELTS +#define SCM_I_WVECT_GC_WVELTS SCM_I_VECTOR_WELTS +#define SCM_I_WVECT_TYPE(x) (SCM_CELL_WORD_2 (x)) +#define SCM_I_WVECT_GC_CHAIN(X) (SCM_CELL_OBJECT_3 (X)) +#define SCM_I_SET_WVECT_GC_CHAIN(X, o) (SCM_SET_CELL_OBJECT_3 ((X), (o))) + +SCM_API SCM scm_i_allocate_weak_vector (scm_t_bits type, SCM size, SCM fill); + SCM_API void scm_init_vectors (void); #endif /* SCM_VECTORS_H */ diff --git a/libguile/weaks.c b/libguile/weaks.c index 250a4cf7d..6eeebcada 100644 --- a/libguile/weaks.c +++ b/libguile/weaks.c @@ -66,49 +66,6 @@ */ -/* Allocate memory for a weak vector on behalf of the caller. The allocated - * vector will be of the given weak vector subtype. It will contain size - * elements which are initialized with the 'fill' object, or, if 'fill' is - * undefined, with an unspecified object. - */ -SCM -scm_i_allocate_weak_vector (scm_t_bits type, SCM size, SCM fill, const char* caller) -#define FUNC_NAME caller -{ - size_t c_size; - SCM v; - - c_size = scm_to_unsigned_integer (size, 0, SCM_VECTOR_MAX_LENGTH); - - if (c_size > 0) - { - scm_t_bits *base; - size_t j; - - if (SCM_UNBNDP (fill)) - fill = SCM_UNSPECIFIED; - - base = scm_gc_malloc (c_size * sizeof (scm_t_bits), "weak vector"); - for (j = 0; j != c_size; ++j) - base[j] = SCM_UNPACK (fill); - v = scm_double_cell (SCM_MAKE_VECTOR_TAG (c_size, scm_tc7_wvect), - (scm_t_bits) base, - type, - SCM_UNPACK (SCM_EOL)); - scm_remember_upto_here_1 (fill); - } - else - { - v = scm_double_cell (SCM_MAKE_VECTOR_TAG (0, scm_tc7_wvect), - (scm_t_bits) NULL, - type, - SCM_UNPACK (SCM_EOL)); - } - - return v; -} -#undef FUNC_NAME - SCM_DEFINE (scm_make_weak_vector, "make-weak-vector", 1, 1, 0, (SCM size, SCM fill), "Return a weak vector with @var{size} elements. If the optional\n" @@ -117,7 +74,7 @@ SCM_DEFINE (scm_make_weak_vector, "make-weak-vector", 1, 1, 0, "empty list.") #define FUNC_NAME s_scm_make_weak_vector { - return scm_i_allocate_weak_vector (0, size, fill, FUNC_NAME); + return scm_i_allocate_weak_vector (0, size, fill); } #undef FUNC_NAME @@ -133,24 +90,21 @@ SCM_DEFINE (scm_weak_vector, "weak-vector", 0, 0, 1, "the same way @code{list->vector} would.") #define FUNC_NAME s_scm_weak_vector { - SCM res; - SCM *data; + scm_t_array_handle handle; + SCM res, *data; long i; - /* Dirk:FIXME:: In case of multiple threads, the list might get corrupted - while the vector is being created. */ i = scm_ilength (l); SCM_ASSERT (i >= 0, l, SCM_ARG1, FUNC_NAME); + res = scm_make_weak_vector (scm_from_int (i), SCM_UNSPECIFIED); + data = scm_vector_writable_elements (res, &handle, NULL, NULL); - /* - no alloc, so this loop is safe. - */ - data = SCM_WRITABLE_VELTS (res); - while (!SCM_NULL_OR_NIL_P (l)) + while (scm_is_pair (l) && i > 0) { *data++ = SCM_CAR (l); l = SCM_CDR (l); + i--; } return res; @@ -164,7 +118,7 @@ SCM_DEFINE (scm_weak_vector_p, "weak-vector?", 1, 0, 0, "weak hashes are also weak vectors.") #define FUNC_NAME s_scm_weak_vector_p { - return scm_from_bool (SCM_WVECTP (obj) && !SCM_IS_WHVEC (obj)); + return scm_from_bool (SCM_I_WVECTP (obj) && !SCM_IS_WHVEC (obj)); } #undef FUNC_NAME @@ -183,7 +137,7 @@ SCM_DEFINE (scm_make_weak_key_alist_vector, "make-weak-key-alist-vector", 0, 1, #define FUNC_NAME s_scm_make_weak_key_alist_vector { return scm_i_allocate_weak_vector - (1, SCM_UNBNDP (size) ? scm_from_int (31) : size, SCM_EOL, FUNC_NAME); + (1, SCM_UNBNDP (size) ? scm_from_int (31) : size, SCM_EOL); } #undef FUNC_NAME @@ -195,7 +149,7 @@ SCM_DEFINE (scm_make_weak_value_alist_vector, "make-weak-value-alist-vector", 0, #define FUNC_NAME s_scm_make_weak_value_alist_vector { return scm_i_allocate_weak_vector - (2, SCM_UNBNDP (size) ? scm_from_int (31) : size, SCM_EOL, FUNC_NAME); + (2, SCM_UNBNDP (size) ? scm_from_int (31) : size, SCM_EOL); } #undef FUNC_NAME @@ -207,7 +161,7 @@ SCM_DEFINE (scm_make_doubly_weak_alist_vector, "make-doubly-weak-alist-vector", #define FUNC_NAME s_scm_make_doubly_weak_alist_vector { return scm_i_allocate_weak_vector - (3, SCM_UNBNDP (size) ? scm_from_int (31) : size, SCM_EOL, FUNC_NAME); + (3, SCM_UNBNDP (size) ? scm_from_int (31) : size, SCM_EOL); } #undef FUNC_NAME @@ -221,7 +175,7 @@ SCM_DEFINE (scm_weak_key_alist_vector_p, "weak-key-alist-vector?", 1, 0, 0, "nor a weak value hash table.") #define FUNC_NAME s_scm_weak_key_alist_vector_p { - return scm_from_bool (SCM_WVECTP (obj) && SCM_IS_WHVEC (obj)); + return scm_from_bool (SCM_I_WVECTP (obj) && SCM_IS_WHVEC (obj)); } #undef FUNC_NAME @@ -231,7 +185,7 @@ SCM_DEFINE (scm_weak_value_alist_vector_p, "weak-value-alist-vector?", 1, 0, 0, "Return @code{#t} if @var{obj} is a weak value hash table.") #define FUNC_NAME s_scm_weak_value_alist_vector_p { - return scm_from_bool (SCM_WVECTP (obj) && SCM_IS_WHVEC_V (obj)); + return scm_from_bool (SCM_I_WVECTP (obj) && SCM_IS_WHVEC_V (obj)); } #undef FUNC_NAME @@ -241,7 +195,7 @@ SCM_DEFINE (scm_doubly_weak_alist_vector_p, "doubly-weak-alist-vector?", 1, 0, 0 "Return @code{#t} if @var{obj} is a doubly weak hash table.") #define FUNC_NAME s_scm_doubly_weak_alist_vector_p { - return scm_from_bool (SCM_WVECTP (obj) && SCM_IS_WHVEC_B (obj)); + return scm_from_bool (SCM_I_WVECTP (obj) && SCM_IS_WHVEC_B (obj)); } #undef FUNC_NAME @@ -264,7 +218,7 @@ scm_mark_weak_vector_spines (void *dummy1 SCM_UNUSED, { SCM w; - for (w = scm_weak_vectors; !scm_is_null (w); w = SCM_WVECT_GC_CHAIN (w)) + for (w = scm_weak_vectors; !scm_is_null (w); w = SCM_I_WVECT_GC_CHAIN (w)) { if (SCM_IS_WHVEC_ANY (w)) { @@ -274,8 +228,8 @@ scm_mark_weak_vector_spines (void *dummy1 SCM_UNUSED, long n; obj = w; - ptr = SCM_VELTS (w); - n = SCM_VECTOR_LENGTH (w); + ptr = SCM_I_WVECT_GC_WVELTS (w); + n = SCM_I_WVECT_LENGTH (w); for (j = 0; j < n; ++j) { SCM alist; @@ -304,14 +258,14 @@ scm_scan_weak_vectors (void *dummy1 SCM_UNUSED, void *dummy3 SCM_UNUSED) { SCM *ptr, w; - for (w = scm_weak_vectors; !scm_is_null (w); w = SCM_WVECT_GC_CHAIN (w)) + for (w = scm_weak_vectors; !scm_is_null (w); w = SCM_I_WVECT_GC_CHAIN (w)) { if (!SCM_IS_WHVEC_ANY (w)) { register long j, n; - ptr = SCM_GC_WRITABLE_VELTS (w); - n = SCM_VECTOR_LENGTH (w); + ptr = SCM_I_WVECT_GC_WVELTS (w); + n = SCM_I_WVECT_LENGTH (w); for (j = 0; j < n; ++j) if (UNMARKED_CELL_P (ptr[j])) ptr[j] = SCM_BOOL_F; @@ -321,12 +275,12 @@ scm_scan_weak_vectors (void *dummy1 SCM_UNUSED, else if (!SCM_WVECT_NOSCAN_P (w)) { SCM obj = w; - register long n = SCM_VECTOR_LENGTH (w); + register long n = SCM_I_WVECT_LENGTH (w); register long j; int weak_keys = SCM_IS_WHVEC (obj) || SCM_IS_WHVEC_B (obj); int weak_values = SCM_IS_WHVEC_V (obj) || SCM_IS_WHVEC_B (obj); - ptr = SCM_GC_WRITABLE_VELTS (w); + ptr = SCM_I_WVECT_GC_WVELTS (w); for (j = 0; j < n; ++j) { diff --git a/libguile/weaks.h b/libguile/weaks.h index afbc3eff1..1796fbbe6 100644 --- a/libguile/weaks.h +++ b/libguile/weaks.h @@ -30,24 +30,18 @@ #define SCM_WVECTF_WEAK_VALUE 2 #define SCM_WVECTF_NOSCAN 4 -#define SCM_WVECTP(x) (!SCM_IMP (x) && SCM_TYP7 (x) == scm_tc7_wvect) -#define SCM_WVECT_TYPE(x) (SCM_CELL_WORD_2 (x)) -#define SCM_SET_WVECT_TYPE(x, t) (SCM_SET_CELL_WORD_2 ((x), (t))) -#define SCM_WVECT_WEAK_KEY_P(x) (SCM_WVECT_TYPE (x) & SCM_WVECTF_WEAK_KEY) -#define SCM_WVECT_WEAK_VALUE_P(x) (SCM_WVECT_TYPE (x) & SCM_WVECTF_WEAK_VALUE) -#define SCM_WVECT_NOSCAN_P(x) (SCM_WVECT_TYPE (x) & SCM_WVECTF_NOSCAN) -#define SCM_IS_WHVEC(X) (SCM_WVECT_TYPE (X) == 1) -#define SCM_IS_WHVEC_V(X) (SCM_WVECT_TYPE (X) == 2) -#define SCM_IS_WHVEC_B(X) (SCM_WVECT_TYPE (X) == 3) -#define SCM_IS_WHVEC_ANY(X) (SCM_WVECT_TYPE (X) != 0) -#define SCM_WVECT_GC_CHAIN(X) (SCM_CELL_OBJECT_3 (X)) -#define SCM_SET_WVECT_GC_CHAIN(X, o) (SCM_SET_CELL_OBJECT_3 ((X), (o))) +#define SCM_WVECT_WEAK_KEY_P(x) (SCM_I_WVECT_TYPE(x) & SCM_WVECTF_WEAK_KEY) +#define SCM_WVECT_WEAK_VALUE_P(x) (SCM_I_WVECT_TYPE(x) & SCM_WVECTF_WEAK_VALUE) +#define SCM_WVECT_NOSCAN_P(x) (SCM_I_WVECT_TYPE (x) & SCM_WVECTF_NOSCAN) +#define SCM_IS_WHVEC(X) (SCM_I_WVECT_TYPE (X) == 1) +#define SCM_IS_WHVEC_V(X) (SCM_I_WVECT_TYPE (X) == 2) +#define SCM_IS_WHVEC_B(X) (SCM_I_WVECT_TYPE (X) == 3) +#define SCM_IS_WHVEC_ANY(X) (SCM_I_WVECT_TYPE (X) != 0) SCM_API SCM scm_weak_vectors; -SCM_API SCM scm_i_allocate_weak_vector (scm_t_bits type, SCM size, SCM fill, const char* caller); SCM_API SCM scm_make_weak_vector (SCM k, SCM fill); SCM_API SCM scm_weak_vector (SCM l); SCM_API SCM scm_weak_vector_p (SCM x);