diff options
author | Marius Vollmer <mvo@zagadka.de> | 2005-01-02 20:06:08 +0000 |
---|---|---|
committer | Marius Vollmer <mvo@zagadka.de> | 2005-01-02 20:06:08 +0000 |
commit | 6e708ef2b1897c3ea4d5ac47720974078d50e9e4 (patch) | |
tree | 3dde367b768213b4693cc586b2adf23074f15667 /libguile/unif.c | |
parent | 9c6e33c62acc203792053b6d5a579bdc22827eec (diff) | |
download | guile-6e708ef2b1897c3ea4d5ac47720974078d50e9e4.tar.gz |
* 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_<foo>vector_elements, scm_<foo>vector_writable_elements): Use
scm_t_array_handle, deliver length and increment.
(scm_array_handle_<foo>_elements,
scm_array_handle_<foo>_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.
Diffstat (limited to 'libguile/unif.c')
-rw-r--r-- | libguile/unif.c | 176 |
1 files changed, 146 insertions, 30 deletions
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 |