mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-06 15:40:29 +02:00
Code Activity

(scm_array_rank, scm_array_dimensions,

Browse source 
scm_shared_array_offset, scm_shared_array_increments,
scm_array_ref, scm_array_set_x): Use scm_t_array_handle operations
to simplify code and make it more general.
(scm_shared_array_root): Work with all kinds of arrays, including
naked vectors.
(indices_to_pos): New.
This commit is contained in:
Marius Vollmer 2005-01-10 00:15:48 +00:00
parent fa0198bfad
commit 523727193a
1 changed files with 71 additions and 99 deletions
Download patch file Download diff file Expand all files Collapse all files

170
libguile/unif.c
View file

@ -529,13 +529,13 @@ SCM_DEFINE (scm_array_rank, "array-rank", 1, 0, 0,
"Return the number of dimensions of the array @var{array.}\n") "Return the number of dimensions of the array @var{array.}\n")
#define FUNC_NAME s_scm_array_rank #define FUNC_NAME s_scm_array_rank
{ {
if (scm_is_generalized_vector (array)) scm_t_array_handle handle;
return scm_from_int (1); SCM res;
if (SCM_ARRAYP (array) || SCM_ENCLOSED_ARRAYP (array)) scm_array_get_handle (array, &handle);
return scm_from_size_t (SCM_ARRAY_NDIM (array)); res = scm_from_size_t (scm_array_handle_rank (&handle));
scm_array_handle_release (&handle);
scm_wrong_type_arg_msg (NULL, 0, array, "array"); return res;
} }
#undef FUNC_NAME #undef FUNC_NAME
@ -549,28 +549,25 @@ SCM_DEFINE (scm_array_dimensions, "array-dimensions", 1, 0, 0,
"@end lisp") "@end lisp")
#define FUNC_NAME s_scm_array_dimensions #define FUNC_NAME s_scm_array_dimensions
{ {
if (scm_is_generalized_vector (ra)) scm_t_array_handle handle;
return scm_list_1 (scm_generalized_vector_length (ra)); scm_t_array_dim *s;
SCM res = SCM_EOL;
if (SCM_ARRAYP (ra) || SCM_ENCLOSED_ARRAYP (ra)) size_t k;
{
SCM res = SCM_EOL;
size_t k;
scm_t_array_dim *s;
k = SCM_ARRAY_NDIM (ra); scm_array_get_handle (ra, &handle);
s = SCM_ARRAY_DIMS (ra); s = scm_array_handle_dims (&handle);
while (k--) k = scm_array_handle_rank (&handle);
res = scm_cons (s[k].lbnd
? scm_cons2 (scm_from_long (s[k].lbnd),
scm_from_long (s[k].ubnd),
SCM_EOL)
: scm_from_long (1 + s[k].ubnd),
res);
return res;
}
scm_wrong_type_arg_msg (NULL, 0, ra, "array"); while (k--)
res = scm_cons (s[k].lbnd
? scm_cons2 (scm_from_ssize_t (s[k].lbnd),
scm_from_ssize_t (s[k].ubnd),
SCM_EOL)
: scm_from_ssize_t (1 + s[k].ubnd),
res);
scm_array_handle_release (&handle);
return res;
} }
#undef FUNC_NAME #undef FUNC_NAME
@ -580,9 +577,11 @@ SCM_DEFINE (scm_shared_array_root, "shared-array-root", 1, 0, 0,
"Return the root vector of a shared array.") "Return the root vector of a shared array.")
#define FUNC_NAME s_scm_shared_array_root #define FUNC_NAME s_scm_shared_array_root
{ {
SCM_ASSERT (SCM_ARRAYP (ra) || SCM_ENCLOSED_ARRAYP (ra), ra, if (SCM_ARRAYP (ra) || SCM_ENCLOSED_ARRAYP (ra))
SCM_ARG1, FUNC_NAME); return SCM_ARRAY_V (ra);
return SCM_ARRAY_V (ra); else if (scm_is_generalized_vector (ra))
return ra;
scm_wrong_type_arg_msg (NULL, 0, ra, "array");
} }
#undef FUNC_NAME #undef FUNC_NAME
@ -592,9 +591,13 @@ SCM_DEFINE (scm_shared_array_offset, "shared-array-offset", 1, 0, 0,
"Return the root vector index of the first element in the array.") "Return the root vector index of the first element in the array.")
#define FUNC_NAME s_scm_shared_array_offset #define FUNC_NAME s_scm_shared_array_offset
{ {
SCM_ASSERT (SCM_ARRAYP (ra) || SCM_ENCLOSED_ARRAYP (ra), ra, scm_t_array_handle handle;
SCM_ARG1, FUNC_NAME); SCM res;
return scm_from_int (SCM_ARRAY_BASE (ra));
scm_array_get_handle (ra, &handle);
res = scm_from_size_t (handle.base);
scm_array_handle_release (&handle);
return res;
} }
#undef FUNC_NAME #undef FUNC_NAME
@ -604,16 +607,17 @@ SCM_DEFINE (scm_shared_array_increments, "shared-array-increments", 1, 0, 0,
"For each dimension, return the distance between elements in the root vector.") "For each dimension, return the distance between elements in the root vector.")
#define FUNC_NAME s_scm_shared_array_increments #define FUNC_NAME s_scm_shared_array_increments
{ {
scm_t_array_handle handle;
SCM res = SCM_EOL; SCM res = SCM_EOL;
size_t k; size_t k;
scm_t_array_dim *s; scm_t_array_dim *s;
SCM_ASSERT (SCM_ARRAYP (ra) || SCM_ENCLOSED_ARRAYP (ra), ra, scm_array_get_handle (ra, &handle);
SCM_ARG1, FUNC_NAME); k = scm_array_handle_rank (&handle);
k = SCM_ARRAY_NDIM (ra); s = scm_array_handle_dims (&handle);
s = SCM_ARRAY_DIMS (ra);
while (k--) while (k--)
res = scm_cons (scm_from_long (s[k].inc), res); res = scm_cons (scm_from_ssize_t (s[k].inc), res);
scm_array_handle_release (&handle);
return res; return res;
} }
#undef FUNC_NAME #undef FUNC_NAME
@ -656,6 +660,26 @@ scm_aind (SCM ra, SCM args, const char *what)
return pos; return pos;
} }
static ssize_t
indices_to_pos (scm_t_array_handle *h, SCM indices)
{
scm_t_array_dim *s = scm_array_handle_dims (h);
ssize_t pos = 0, i;
size_t k = scm_array_handle_rank (h);
while (k > 0 && scm_is_pair (indices))
{
i = scm_to_signed_integer (SCM_CAR (indices), s->lbnd, s->ubnd);
pos += (i - s->lbnd) * s->inc;
k--;
s++;
indices = SCM_CDR (indices);
}
if (k > 0 || !scm_is_null (indices))
scm_misc_error (NULL, "wrong number of indices, expecting ~a",
scm_list_1 (scm_from_size_t (scm_array_handle_rank (h))));
return pos;
}
static SCM static SCM
scm_i_make_ra (int ndim, scm_t_bits tag) scm_i_make_ra (int ndim, scm_t_bits tag)
@ -791,9 +815,6 @@ SCM_DEFINE (scm_dimensions_to_uniform_array, "dimensions->uniform-array", 2, 1,
void void
scm_ra_set_contp (SCM ra) scm_ra_set_contp (SCM ra)
{ {
/* XXX - correct? one-dimensional arrays are always 'contiguous',
is that right?
*/
size_t k = SCM_ARRAY_NDIM (ra); size_t k = SCM_ARRAY_NDIM (ra);
if (k) if (k)
{ {
@ -1217,36 +1238,13 @@ SCM_DEFINE (scm_array_ref, "array-ref", 1, 0, 1,
"@var{array}.") "@var{array}.")
#define FUNC_NAME s_scm_array_ref #define FUNC_NAME s_scm_array_ref
{ {
long pos; scm_t_array_handle handle;
int enclosed = 0; SCM res;
if (SCM_ARRAYP (v) || SCM_ENCLOSED_ARRAYP (v)) scm_array_get_handle (v, &handle);
{ res = scm_array_handle_ref (&handle, indices_to_pos (&handle, args));
enclosed = SCM_ENCLOSED_ARRAYP (v); scm_array_handle_release (&handle);
pos = scm_aind (v, args, FUNC_NAME); return res;
v = SCM_ARRAY_V (v);
}
else
{
size_t length;
if (SCM_NIMP (args))
{
SCM_ASSERT (scm_is_pair (args), args, SCM_ARG2, FUNC_NAME);
pos = scm_to_long (SCM_CAR (args));
SCM_ASRTGO (scm_is_null (SCM_CDR (args)), wna);
}
else
pos = scm_to_long (args);
length = scm_c_generalized_vector_length (v);
SCM_ASRTGO (pos >= 0 && pos < length, outrng);
}
return scm_i_cvref (v, pos, enclosed);
wna:
scm_wrong_num_args (NULL);
outrng:
scm_out_of_range (NULL, scm_from_long (pos));
} }
#undef FUNC_NAME #undef FUNC_NAME
@ -1257,38 +1255,12 @@ SCM_DEFINE (scm_array_set_x, "array-set!", 2, 0, 1,
"@var{new-value}. The value returned by array-set! is unspecified.") "@var{new-value}. The value returned by array-set! is unspecified.")
#define FUNC_NAME s_scm_array_set_x #define FUNC_NAME s_scm_array_set_x
{ {
long pos = 0; scm_t_array_handle handle;
if (SCM_ARRAYP (v)) scm_array_get_handle (v, &handle);
{ scm_array_handle_set (&handle, indices_to_pos (&handle, args), obj);
pos = scm_aind (v, args, FUNC_NAME); scm_array_handle_release (&handle);
v = SCM_ARRAY_V (v);
}
else if (SCM_ENCLOSED_ARRAYP (v))
scm_wrong_type_arg_msg (NULL, 0, v, "non-enclosed array");
else if (scm_is_generalized_vector (v))
{
size_t length;
if (scm_is_pair (args))
{
SCM_ASRTGO (scm_is_null (SCM_CDR (args)), wna);
pos = scm_to_long (SCM_CAR (args));
}
else
pos = scm_to_long (args);
length = scm_c_generalized_vector_length (v);
SCM_ASRTGO (pos >= 0 && pos < length, outrng);
}
else
scm_wrong_type_arg_msg (NULL, 0, v, "array");
scm_c_generalized_vector_set_x (v, pos, obj);
return SCM_UNSPECIFIED; return SCM_UNSPECIFIED;
outrng:
scm_out_of_range (NULL, scm_from_long (pos));
wna:
scm_wrong_num_args (NULL);
} }
#undef FUNC_NAME #undef FUNC_NAME