summaryrefslogtreecommitdiff
path: root/libguile/unif.c
diff options
context:
space:
mode:
authorMarius Vollmer <mvo@zagadka.de>2005-01-02 20:06:08 +0000
committerMarius Vollmer <mvo@zagadka.de>2005-01-02 20:06:08 +0000
commit6e708ef2b1897c3ea4d5ac47720974078d50e9e4 (patch)
tree3dde367b768213b4693cc586b2adf23074f15667 /libguile/unif.c
parent9c6e33c62acc203792053b6d5a579bdc22827eec (diff)
downloadguile-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.c176
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