mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-11 14:21:10 +02:00
Code Activity

(scm_tc16_enclosed_array, SCM_ENCLOSED_ARRAYP):

Browse source 
New.
(exactly_one_third, singp): Removed.
(scm_array_p, scm_array_dimensions, scm_shared_array_root,
scm_shared_array_offset, scm_shared_array_increments): Handle
enclosed arrays explicitely.
(scm_array_rank): Likewise. Also, do not return zero for
non-arrays, signal an error instead since arrays with rank zero do
exist.
(scm_i_make_ra): New, for specifying the tag of the new array.
(scm_make_enclosed_array): Use it.
(scm_make_ra): Reimplemented in terms of scm_i_make_ra.
(scm_make_shared_array): Use scm_c_generalized_vector_length
instead of scm_uniform_vector_length.
(scm_array_in_bounds_p): Rewritten to be much cleaner.
(scm_i_cvref): New, doing the job of scm_cvref.
(scm_cvref): Use scm_i_cvref.
(scm_array_ref): Do not accept non-arrays when no indices are
given. Use scm_i_cvref to do the actual access.
("uniform-array-set1"): Do not register.
(scm_array_set_x, scm_uniform_array_read_x,
scm_uniform_array_write): Handle enclosed arrays explicitly.
(ra2l): Use scm_i_cvref instead of scm_uniform_vector_ref to also
handle enclosed arrays.
(scm_array_to_list): Handle enclosed arrays explicitly.
(rapr1): Removed.
(scm_i_print_array_dimension): Use scm_i_cvref to also handle
enclosed arrays.
(scm_i_print_enclosed_array): New.
(tag_proto_table, tag_creator_table): Renamed former to latter.
Added "a" and "b" for strings and bitvectors, resp.
(scm_i_tag_to_prototype, scm_i_tag_to_creator): Renamed former to
latter.  Tag "a" is in the table now, no need to handle it as a
legacy tag.
(scm_raprin1): Just call scm_iprin1.
(scm_array_creator, scm_array_prototype): Handle enclosed arrays
explicitly.
(scm_init_unif): Initialize scm_tc16_enclosed_array smob.
Use scm_i_print_array as printer for scm_tc16_array.
This commit is contained in:
Marius Vollmer 2004-11-12 18:55:25 +00:00
parent 4049959855
commit 02339e5b9b
2 changed files with 204 additions and 343 deletions
Download patch file Download diff file Expand all files Collapse all files

529
libguile/unif.c
View file

@ -80,25 +80,7 @@
*/ */
scm_t_bits scm_tc16_array; scm_t_bits scm_tc16_array;
static SCM exactly_one_third; scm_t_bits scm_tc16_enclosed_array;
#if 0
/* Silly function used not to modify the semantics of the silly
* prototype system in order to be backward compatible.
*/
static int
singp (SCM obj)
{
if (!SCM_REALP (obj))
return 0;
else
{
double x = SCM_REAL_VALUE (obj);
float fx = x;
return (- SCM_FLTMAX < x) && (x < SCM_FLTMAX) && (fx == x);
}
}
#endif
SCM scm_i_proc_make_vector; SCM scm_i_proc_make_vector;
SCM scm_i_proc_make_string; SCM scm_i_proc_make_string;
@ -205,26 +187,28 @@ SCM_DEFINE (scm_array_p, "array?", 1, 1, 0,
"and is described elsewhere.") "and is described elsewhere.")
#define FUNC_NAME s_scm_array_p #define FUNC_NAME s_scm_array_p
{ {
int nprot = SCM_UNBNDP (prot); if (SCM_ENCLOSED_ARRAYP (v))
int enclosed = 0; {
/* Enclosed arrays are arrays but are not created by any known
creator procedure.
*/
if (SCM_UNBNDP (prot))
return SCM_BOOL_T;
else
return SCM_BOOL_F;
}
/* Get storage vector. /* Get storage vector.
*/ */
while (SCM_ARRAYP (v)) if (SCM_ARRAYP (v))
{ v = SCM_ARRAY_V (v);
if (nprot)
return SCM_BOOL_T;
if (enclosed++)
return SCM_BOOL_F;
v = SCM_ARRAY_V (v);
}
/* It must be a generalized vector (which includes vectors, strings, etc). /* It must be a generalized vector (which includes vectors, strings, etc).
*/ */
if (!scm_is_generalized_vector (v)) if (!scm_is_generalized_vector (v))
return SCM_BOOL_F; return SCM_BOOL_F;
if (nprot) if (SCM_UNBNDP (prot))
return SCM_BOOL_T; return SCM_BOOL_T;
#if SCM_ENABLE_DEPRECATED #if SCM_ENABLE_DEPRECATED
@ -236,25 +220,24 @@ SCM_DEFINE (scm_array_p, "array?", 1, 1, 0,
SCM_DEFINE (scm_array_rank, "array-rank", 1, 0, 0, SCM_DEFINE (scm_array_rank, "array-rank", 1, 0, 0,
(SCM ra), (SCM array),
"Return the number of dimensions of @var{obj}. If @var{obj} is\n" "Return the number of dimensions of the array @var{array.}\n")
"not an array, @code{0} is returned.")
#define FUNC_NAME s_scm_array_rank #define FUNC_NAME s_scm_array_rank
{ {
if (scm_is_generalized_vector (ra)) if (scm_is_generalized_vector (array))
return scm_from_int (1); return scm_from_int (1);
if (SCM_ARRAYP (ra)) if (SCM_ARRAYP (array) || SCM_ENCLOSED_ARRAYP (array))
return scm_from_size_t (SCM_ARRAY_NDIM (ra)); return scm_from_size_t (SCM_ARRAY_NDIM (array));
return scm_from_int (0); scm_wrong_type_arg_msg (NULL, 0, array, "array");
} }
#undef FUNC_NAME #undef FUNC_NAME
SCM_DEFINE (scm_array_dimensions, "array-dimensions", 1, 0, 0, SCM_DEFINE (scm_array_dimensions, "array-dimensions", 1, 0, 0,
(SCM ra), (SCM ra),
"@code{Array-dimensions} is similar to @code{array-shape} but replaces\n" "@code{array-dimensions} is similar to @code{array-shape} but replaces\n"
"elements with a @code{0} minimum with one greater than the maximum. So:\n" "elements with a @code{0} minimum with one greater than the maximum. So:\n"
"@lisp\n" "@lisp\n"
"(array-dimensions (make-array 'foo '(-1 3) 5)) @result{} ((-1 3) 5)\n" "(array-dimensions (make-array 'foo '(-1 3) 5)) @result{} ((-1 3) 5)\n"
@ -264,7 +247,7 @@ SCM_DEFINE (scm_array_dimensions, "array-dimensions", 1, 0, 0,
if (scm_is_generalized_vector (ra)) if (scm_is_generalized_vector (ra))
return scm_cons (scm_generalized_vector_length (ra), SCM_EOL); return scm_cons (scm_generalized_vector_length (ra), SCM_EOL);
if (SCM_ARRAYP (ra)) if (SCM_ARRAYP (ra) || SCM_ENCLOSED_ARRAYP (ra))
{ {
SCM res = SCM_EOL; SCM res = SCM_EOL;
size_t k; size_t k;
@ -292,7 +275,8 @@ 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), ra, SCM_ARG1, FUNC_NAME); SCM_ASSERT (SCM_ARRAYP (ra) || SCM_ENCLOSED_ARRAYP (ra), ra,
SCM_ARG1, FUNC_NAME);
return SCM_ARRAY_V (ra); return SCM_ARRAY_V (ra);
} }
#undef FUNC_NAME #undef FUNC_NAME
@ -303,7 +287,8 @@ 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), ra, SCM_ARG1, FUNC_NAME); SCM_ASSERT (SCM_ARRAYP (ra) || SCM_ENCLOSED_ARRAYP (ra), ra,
SCM_ARG1, FUNC_NAME);
return scm_from_int (SCM_ARRAY_BASE (ra)); return scm_from_int (SCM_ARRAY_BASE (ra));
} }
#undef FUNC_NAME #undef FUNC_NAME
@ -317,7 +302,9 @@ SCM_DEFINE (scm_shared_array_increments, "shared-array-increments", 1, 0, 0,
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), ra, SCM_ARG1, FUNC_NAME);
SCM_ASSERT (SCM_ARRAYP (ra) || SCM_ENCLOSED_ARRAYP (ra), ra,
SCM_ARG1, FUNC_NAME);
k = SCM_ARRAY_NDIM (ra); k = SCM_ARRAY_NDIM (ra);
s = SCM_ARRAY_DIMS (ra); s = SCM_ARRAY_DIMS (ra);
while (k--) while (k--)
@ -332,13 +319,13 @@ static char s_bad_ind[] = "Bad scm_array index";
long long
scm_aind (SCM ra, SCM args, const char *what) scm_aind (SCM ra, SCM args, const char *what)
#define FUNC_NAME what
{ {
SCM ind; SCM ind;
register long j; register long j;
register unsigned long pos = SCM_ARRAY_BASE (ra); register unsigned long pos = SCM_ARRAY_BASE (ra);
register unsigned long k = SCM_ARRAY_NDIM (ra); register unsigned long k = SCM_ARRAY_NDIM (ra);
scm_t_array_dim *s = SCM_ARRAY_DIMS (ra); scm_t_array_dim *s = SCM_ARRAY_DIMS (ra);
if (scm_is_integer (args)) if (scm_is_integer (args))
{ {
if (k != 1) if (k != 1)
@ -363,26 +350,31 @@ scm_aind (SCM ra, SCM args, const char *what)
return pos; return pos;
} }
#undef FUNC_NAME
static SCM
scm_i_make_ra (int ndim, scm_t_bits tag)
{
SCM ra;
SCM_NEWSMOB(ra, ((scm_t_bits) ndim << 17) + tag,
scm_gc_malloc ((sizeof (scm_t_array) +
ndim * sizeof (scm_t_array_dim)),
"array"));
SCM_ARRAY_V (ra) = SCM_BOOL_F;
return ra;
}
SCM SCM
scm_make_ra (int ndim) scm_make_ra (int ndim)
{ {
SCM ra; return scm_i_make_ra (ndim, scm_tc16_array);
SCM_DEFER_INTS;
SCM_NEWSMOB(ra, ((scm_t_bits) ndim << 17) + scm_tc16_array,
scm_gc_malloc ((sizeof (scm_t_array) +
ndim * sizeof (scm_t_array_dim)),
"array"));
SCM_ARRAY_V (ra) = scm_nullvect;
SCM_ALLOW_INTS;
return ra;
} }
static char s_bad_spec[] = "Bad scm_array dimension";
/* Increments will still need to be set. */
static char s_bad_spec[] = "Bad scm_array dimension";
/* Increments will still need to be set. */
SCM SCM
scm_shap2ra (SCM args, const char *what) scm_shap2ra (SCM args, const char *what)
@ -484,6 +476,9 @@ 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)
{ {
@ -551,7 +546,7 @@ SCM_DEFINE (scm_make_shared_array, "make-shared-array", 2, 0, 1,
{ {
SCM_ARRAY_V (ra) = oldra; SCM_ARRAY_V (ra) = oldra;
old_min = 0; old_min = 0;
old_max = scm_to_long (scm_uniform_vector_length (oldra)) - 1; old_max = scm_c_generalized_vector_length (oldra) - 1;
} }
inds = SCM_EOL; inds = SCM_EOL;
s = SCM_ARRAY_DIMS (ra); s = SCM_ARRAY_DIMS (ra);
@ -673,7 +668,7 @@ SCM_DEFINE (scm_transpose_array, "transpose-array", 1, 0, 1,
return ra; return ra;
} }
if (SCM_ARRAYP (ra)) if (SCM_ARRAYP (ra) || SCM_ENCLOSED_ARRAYP (ra))
{ {
vargs = scm_vector (args); vargs = scm_vector (args);
if (SCM_VECTOR_LENGTH (vargs) != SCM_ARRAY_NDIM (ra)) if (SCM_VECTOR_LENGTH (vargs) != SCM_ARRAY_NDIM (ra))
@ -759,7 +754,7 @@ SCM_DEFINE (scm_enclose_array, "enclose-array", 1, 0, 1,
SCM_VALIDATE_REST_ARGUMENT (axes); SCM_VALIDATE_REST_ARGUMENT (axes);
if (scm_is_null (axes)) if (scm_is_null (axes))
axes = scm_cons ((SCM_ARRAYP (ra) ? scm_from_size_t (SCM_ARRAY_NDIM (ra) - 1) : SCM_INUM0), SCM_EOL); axes = scm_cons ((SCM_ARRAYP (ra) ? scm_from_size_t (SCM_ARRAY_NDIM (ra) - 1) : SCM_INUM0), SCM_EOL);
ninr = scm_ilength (axes); ninr = scm_ilength (axes);
if (ninr < 0) if (ninr < 0)
SCM_WRONG_NUM_ARGS (); SCM_WRONG_NUM_ARGS ();
@ -788,7 +783,7 @@ SCM_DEFINE (scm_enclose_array, "enclose-array", 1, 0, 1,
if (noutr < 0) if (noutr < 0)
SCM_WRONG_NUM_ARGS (); SCM_WRONG_NUM_ARGS ();
axv = scm_make_string (scm_from_int (ndim), SCM_MAKE_CHAR (0)); axv = scm_make_string (scm_from_int (ndim), SCM_MAKE_CHAR (0));
res = scm_make_ra (noutr); res = scm_i_make_ra (noutr, scm_tc16_enclosed_array);
SCM_ARRAY_BASE (res) = SCM_ARRAY_BASE (ra_inr); SCM_ARRAY_BASE (res) = SCM_ARRAY_BASE (ra_inr);
SCM_ARRAY_V (res) = ra_inr; SCM_ARRAY_V (res) = ra_inr;
for (k = 0; k < ninr; k++, axes = SCM_CDR (axes)) for (k = 0; k < ninr; k++, axes = SCM_CDR (axes))
@ -825,69 +820,82 @@ SCM_DEFINE (scm_array_in_bounds_p, "array-in-bounds?", 1, 0, 1,
"@code{array-ref}.") "@code{array-ref}.")
#define FUNC_NAME s_scm_array_in_bounds_p #define FUNC_NAME s_scm_array_in_bounds_p
{ {
SCM ind = SCM_EOL; SCM res = SCM_BOOL_T;
long pos = 0;
register size_t k;
register long j;
scm_t_array_dim *s;
SCM_VALIDATE_REST_ARGUMENT (args); SCM_VALIDATE_REST_ARGUMENT (args);
if (scm_is_pair (args))
{
ind = SCM_CAR (args);
args = SCM_CDR (args);
pos = scm_to_long (ind);
}
tail:
if (scm_is_generalized_vector (v)) if (scm_is_generalized_vector (v))
{ {
size_t length = scm_c_generalized_vector_length (v); long ind;
SCM_ASRTGO (scm_is_null (args) && scm_is_integer (ind), wna);
return scm_from_bool (pos >= 0 && pos < length); if (!scm_is_pair (args))
SCM_WRONG_NUM_ARGS ();
ind = scm_to_long (SCM_CAR (args));
args = SCM_CDR (args);
res = scm_from_bool (ind >= 0
&& ind < scm_c_generalized_vector_length (v));
} }
else if (SCM_ARRAYP (v) || SCM_ENCLOSED_ARRAYP (v))
if (SCM_ARRAYP (v))
{ {
k = SCM_ARRAY_NDIM (v); size_t k = SCM_ARRAY_NDIM (v);
s = SCM_ARRAY_DIMS (v); scm_t_array_dim *s = SCM_ARRAY_DIMS (v);
pos = SCM_ARRAY_BASE (v);
if (!k) while (k > 0)
{ {
SCM_ASRTGO (scm_is_null (ind), wna); long ind;
ind = SCM_INUM0;
if (!scm_is_pair (args))
SCM_WRONG_NUM_ARGS ();
ind = scm_to_long (SCM_CAR (args));
args = SCM_CDR (args);
k -= 1;
if (ind < s->lbnd || ind > s->ubnd)
{
res = SCM_BOOL_F;
/* We do not stop the checking after finding a violation
since we want to validate the type-correctness and
number of arguments in any case.
*/
}
} }
else
while (!0)
{
j = scm_to_long (ind);
if (!(j >= (s->lbnd) && j <= (s->ubnd)))
{
SCM_ASRTGO (--k == scm_ilength (args), wna);
return SCM_BOOL_F;
}
pos += (j - s->lbnd) * (s->inc);
if (!(--k && SCM_NIMP (args)))
break;
ind = SCM_CAR (args);
args = SCM_CDR (args);
s++;
if (!scm_is_integer (ind))
SCM_MISC_ERROR (s_bad_ind, SCM_EOL);
}
SCM_ASRTGO (0 == k, wna);
v = SCM_ARRAY_V (v);
goto tail;
wna:
SCM_WRONG_NUM_ARGS ();
} }
else
scm_wrong_type_arg_msg (NULL, 0, v, "array");
scm_wrong_type_arg_msg (NULL, 0, v, "array"); if (!scm_is_null (args))
SCM_WRONG_NUM_ARGS ();
return res;
} }
#undef FUNC_NAME #undef FUNC_NAME
static SCM
scm_i_cvref (SCM v, size_t pos, int enclosed)
{
if (enclosed)
{
int k = SCM_ARRAY_NDIM (v);
SCM res = scm_make_ra (k);
SCM_ARRAY_V (res) = SCM_ARRAY_V (v);
SCM_ARRAY_BASE (res) = pos;
while (k--)
{
SCM_ARRAY_DIMS (res)[k].ubnd = SCM_ARRAY_DIMS (v)[k].ubnd;
SCM_ARRAY_DIMS (res)[k].lbnd = SCM_ARRAY_DIMS (v)[k].lbnd;
SCM_ARRAY_DIMS (res)[k].inc = SCM_ARRAY_DIMS (v)[k].inc;
}
return res;
}
else
return scm_c_generalized_vector_ref (v, pos);
}
SCM
scm_cvref (SCM v, unsigned long pos, SCM last)
{
return scm_i_cvref (v, pos, 0);
}
SCM_DEFINE (scm_array_ref, "array-ref", 1, 0, 1, SCM_DEFINE (scm_array_ref, "array-ref", 1, 0, 1,
(SCM v, SCM args), (SCM v, SCM args),
@ -896,14 +904,11 @@ SCM_DEFINE (scm_array_ref, "array-ref", 1, 0, 1,
#define FUNC_NAME s_scm_array_ref #define FUNC_NAME s_scm_array_ref
{ {
long pos; long pos;
int enclosed = 0;
if (SCM_IMP (v)) if (SCM_ARRAYP (v) || SCM_ENCLOSED_ARRAYP (v))
{
SCM_ASRTGO (scm_is_null (args), badarg);
return v;
}
else if (SCM_ARRAYP (v))
{ {
enclosed = SCM_ENCLOSED_ARRAYP (v);
pos = scm_aind (v, args, FUNC_NAME); pos = scm_aind (v, args, FUNC_NAME);
v = SCM_ARRAY_V (v); v = SCM_ARRAY_V (v);
} }
@ -922,26 +927,8 @@ SCM_DEFINE (scm_array_ref, "array-ref", 1, 0, 1,
SCM_ASRTGO (pos >= 0 && pos < length, outrng); SCM_ASRTGO (pos >= 0 && pos < length, outrng);
} }
if (scm_is_generalized_vector (v)) return scm_i_cvref (v, pos, enclosed);
return scm_c_generalized_vector_ref (v, pos);
if (SCM_ARRAYP (v))
{ /* enclosed */
int k = SCM_ARRAY_NDIM (v);
SCM res = scm_make_ra (k);
SCM_ARRAY_V (res) = SCM_ARRAY_V (v);
SCM_ARRAY_BASE (res) = pos;
while (k--)
{
SCM_ARRAY_DIMS (res)[k].lbnd = SCM_ARRAY_DIMS (v)[k].lbnd;
SCM_ARRAY_DIMS (res)[k].ubnd = SCM_ARRAY_DIMS (v)[k].ubnd;
SCM_ARRAY_DIMS (res)[k].inc = SCM_ARRAY_DIMS (v)[k].inc;
}
return res;
}
badarg:
scm_wrong_type_arg_msg (NULL, 0, v, "array");
wna: wna:
scm_wrong_num_args (NULL); scm_wrong_num_args (NULL);
outrng: outrng:
@ -949,39 +936,7 @@ SCM_DEFINE (scm_array_ref, "array-ref", 1, 0, 1,
} }
#undef FUNC_NAME #undef FUNC_NAME
/* Internal version of scm_uniform_vector_ref for uves that does no error checking and
tries to recycle conses. (Make *sure* you want them recycled.) */
SCM
scm_cvref (SCM v, unsigned long pos, SCM last)
{
if (scm_is_generalized_vector (v))
return scm_c_generalized_vector_ref (v, pos);
if (SCM_ARRAYP (v))
{ /* enclosed scm_array */
int k = SCM_ARRAY_NDIM (v);
SCM res = scm_make_ra (k);
SCM_ARRAY_V (res) = SCM_ARRAY_V (v);
SCM_ARRAY_BASE (res) = pos;
while (k--)
{
SCM_ARRAY_DIMS (res)[k].ubnd = SCM_ARRAY_DIMS (v)[k].ubnd;
SCM_ARRAY_DIMS (res)[k].lbnd = SCM_ARRAY_DIMS (v)[k].lbnd;
SCM_ARRAY_DIMS (res)[k].inc = SCM_ARRAY_DIMS (v)[k].inc;
}
return res;
}
scm_wrong_type_arg_msg (NULL, 0, v, "array");
}
SCM_REGISTER_PROC(s_uniform_array_set1_x, "uniform-array-set1!", 3, 0, 0, scm_array_set_x);
/* Note that args may be a list or an immediate object, depending which
PROC is used (and it's called from C too). */
SCM_DEFINE (scm_array_set_x, "array-set!", 2, 0, 1, SCM_DEFINE (scm_array_set_x, "array-set!", 2, 0, 1,
(SCM v, SCM obj, SCM args), (SCM v, SCM obj, SCM args),
"Set the element at the @code{(index1, index2)} element in @var{array} to\n" "Set the element at the @code{(index1, index2)} element in @var{array} to\n"
@ -995,7 +950,9 @@ SCM_DEFINE (scm_array_set_x, "array-set!", 2, 0, 1,
pos = scm_aind (v, args, FUNC_NAME); pos = scm_aind (v, args, FUNC_NAME);
v = SCM_ARRAY_V (v); v = SCM_ARRAY_V (v);
} }
else 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; size_t length;
if (scm_is_pair (args)) if (scm_is_pair (args))
@ -1008,14 +965,11 @@ SCM_DEFINE (scm_array_set_x, "array-set!", 2, 0, 1,
length = scm_c_generalized_vector_length (v); length = scm_c_generalized_vector_length (v);
SCM_ASRTGO (pos >= 0 && pos < length, outrng); SCM_ASRTGO (pos >= 0 && pos < length, outrng);
} }
else
if (scm_is_generalized_vector (v)) scm_wrong_type_arg_msg (NULL, 0, v, "array");
{
scm_c_generalized_vector_set_x (v, pos, obj); scm_c_generalized_vector_set_x (v, pos, obj);
return SCM_UNSPECIFIED; return SCM_UNSPECIFIED;
}
scm_wrong_type_arg_msg (NULL, 0, v, "array");
outrng: outrng:
scm_out_of_range (NULL, scm_from_long (pos)); scm_out_of_range (NULL, scm_from_long (pos));
@ -1081,8 +1035,10 @@ SCM_DEFINE (scm_array_contents, "array-contents", 1, 1, 0,
SCM_ARRAY_DIMS (sra)->inc = (ndim ? SCM_ARRAY_DIMS (ra)[ndim - 1].inc : 1); SCM_ARRAY_DIMS (sra)->inc = (ndim ? SCM_ARRAY_DIMS (ra)[ndim - 1].inc : 1);
return sra; return sra;
} }
else if (SCM_ENCLOSED_ARRAYP (ra))
scm_wrong_type_arg_msg (NULL, 0, ra, "array"); scm_wrong_type_arg_msg (NULL, 0, ra, "non-enclosed array");
else
scm_wrong_type_arg_msg (NULL, 0, ra, "array");
} }
#undef FUNC_NAME #undef FUNC_NAME
@ -1173,6 +1129,8 @@ SCM_DEFINE (scm_uniform_array_read_x, "uniform-array-read!", 1, 3, 0,
scm_array_copy_x (cra, ura); scm_array_copy_x (cra, ura);
return ans; return ans;
} }
else if (SCM_ENCLOSED_ARRAYP (ura))
scm_wrong_type_arg_msg (NULL, 0, ura, "non-enclosed array");
else else
scm_wrong_type_arg_msg (NULL, 0, ura, "array"); scm_wrong_type_arg_msg (NULL, 0, ura, "array");
} }
@ -1223,6 +1181,8 @@ SCM_DEFINE (scm_uniform_array_write, "uniform-array-write", 1, 3, 0,
return ans; return ans;
} }
else if (SCM_ENCLOSED_ARRAYP (ura))
scm_wrong_type_arg_msg (NULL, 0, ura, "non-enclosed array");
else else
scm_wrong_type_arg_msg (NULL, 0, ura, "array"); scm_wrong_type_arg_msg (NULL, 0, ura, "array");
} }
@ -1841,9 +1801,11 @@ scm_istr2bve (SCM str)
static SCM static SCM
ra2l (SCM ra, unsigned long base, unsigned long k) ra2l (SCM ra, unsigned long base, unsigned long k)
{ {
register SCM res = SCM_EOL; SCM res = SCM_EOL;
register long inc = SCM_ARRAY_DIMS (ra)[k].inc; long inc = SCM_ARRAY_DIMS (ra)[k].inc;
register size_t i; size_t i;
int enclosed = SCM_ENCLOSED_ARRAYP (ra);
if (SCM_ARRAY_DIMS (ra)[k].ubnd < SCM_ARRAY_DIMS (ra)[k].lbnd) if (SCM_ARRAY_DIMS (ra)[k].ubnd < SCM_ARRAY_DIMS (ra)[k].lbnd)
return SCM_EOL; return SCM_EOL;
i = base + (1 + SCM_ARRAY_DIMS (ra)[k].ubnd - SCM_ARRAY_DIMS (ra)[k].lbnd) * inc; i = base + (1 + SCM_ARRAY_DIMS (ra)[k].ubnd - SCM_ARRAY_DIMS (ra)[k].lbnd) * inc;
@ -1860,7 +1822,8 @@ ra2l (SCM ra, unsigned long base, unsigned long k)
do do
{ {
i -= inc; i -= inc;
res = scm_cons (scm_uniform_vector_ref (SCM_ARRAY_V (ra), scm_from_size_t (i)), res); res = scm_cons (scm_i_cvref (SCM_ARRAY_V (ra), i, enclosed),
res);
} }
while (i != base); while (i != base);
return res; return res;
@ -1875,7 +1838,7 @@ SCM_DEFINE (scm_array_to_list, "array->list", 1, 0, 0,
{ {
if (scm_is_generalized_vector (v)) if (scm_is_generalized_vector (v))
return scm_generalized_vector_to_list (v); return scm_generalized_vector_to_list (v);
else if (SCM_ARRAYP (v)) else if (SCM_ARRAYP (v) || SCM_ENCLOSED_ARRAYP (v))
return ra2l (v, SCM_ARRAY_BASE (v), 0); return ra2l (v, SCM_ARRAY_BASE (v), 0);
scm_wrong_type_arg_msg (NULL, 0, v, "array"); scm_wrong_type_arg_msg (NULL, 0, v, "array");
@ -1995,96 +1958,11 @@ l2ra (SCM lst, SCM ra, unsigned long base, unsigned long k)
} }
static void
rapr1 (SCM ra, unsigned long j, unsigned long k, SCM port, scm_print_state *pstate)
{
long inc = 1;
long n = (SCM_TYP7 (ra) == scm_tc7_smob
? 0
: scm_to_long (scm_uniform_vector_length (ra)));
int enclosed = 0;
tail:
switch SCM_TYP7 (ra)
{
case scm_tc7_smob:
if (enclosed++)
{
SCM_ARRAY_BASE (ra) = j;
if (n-- > 0)
scm_iprin1 (ra, port, pstate);
for (j += inc; n-- > 0; j += inc)
{
scm_putc (' ', port);
SCM_ARRAY_BASE (ra) = j;
scm_iprin1 (ra, port, pstate);
}
break;
}
if (k + 1 < SCM_ARRAY_NDIM (ra))
{
long i;
inc = SCM_ARRAY_DIMS (ra)[k].inc;
for (i = SCM_ARRAY_DIMS (ra)[k].lbnd; i < SCM_ARRAY_DIMS (ra)[k].ubnd; i++)
{
scm_putc ('(', port);
rapr1 (ra, j, k + 1, port, pstate);
scm_puts (") ", port);
j += inc;
}
if (i == SCM_ARRAY_DIMS (ra)[k].ubnd)
{ /* could be zero size. */
scm_putc ('(', port);
rapr1 (ra, j, k + 1, port, pstate);
scm_putc (')', port);
}
break;
}
if (SCM_ARRAY_NDIM (ra) > 0)
{ /* Could be zero-dimensional */
inc = SCM_ARRAY_DIMS (ra)[k].inc;
n = (SCM_ARRAY_DIMS (ra)[k].ubnd - SCM_ARRAY_DIMS (ra)[k].lbnd + 1);
}
else
n = 1;
ra = SCM_ARRAY_V (ra);
goto tail;
default:
/* scm_tc7_bvect and scm_tc7_llvect only? */
if (n-- > 0)
scm_iprin1 (scm_cvref (ra, j, SCM_UNDEFINED), port, pstate);
for (j += inc; n-- > 0; j += inc)
{
scm_putc (' ', port);
scm_iprin1 (scm_cvref (ra, j, SCM_UNDEFINED), port, pstate);
}
break;
case scm_tc7_string:
{
const char *src;
src = scm_i_string_chars (ra);
if (n-- > 0)
scm_iprin1 (SCM_MAKE_CHAR (src[j]), port, pstate);
if (SCM_WRITINGP (pstate))
for (j += inc; n-- > 0; j += inc)
{
scm_putc (' ', port);
scm_iprin1 (SCM_MAKE_CHAR (src[j]), port, pstate);
}
else
for (j += inc; n-- > 0; j += inc)
scm_putc (src[j], port);
scm_remember_upto_here_1 (ra);
}
break;
}
}
/* Print dimension DIM of ARRAY. /* Print dimension DIM of ARRAY.
*/ */
static int static int
scm_i_print_array_dimension (SCM array, int dim, int base, scm_i_print_array_dimension (SCM array, int dim, int base, int enclosed,
SCM port, scm_print_state *pstate) SCM port, scm_print_state *pstate)
{ {
scm_t_array_dim *dim_spec = SCM_ARRAY_DIMS (array) + dim; scm_t_array_dim *dim_spec = SCM_ARRAY_DIMS (array) + dim;
@ -2092,22 +1970,13 @@ scm_i_print_array_dimension (SCM array, int dim, int base,
scm_putc ('(', port); scm_putc ('(', port);
#if 0
scm_putc ('{', port);
scm_intprint (dim_spec->lbnd, 10, port);
scm_putc (':', port);
scm_intprint (dim_spec->ubnd, 10, port);
scm_putc (':', port);
scm_intprint (dim_spec->inc, 10, port);
scm_putc ('}', port);
#endif
for (idx = dim_spec->lbnd; idx <= dim_spec->ubnd; idx++) for (idx = dim_spec->lbnd; idx <= dim_spec->ubnd; idx++)
{ {
if (dim < SCM_ARRAY_NDIM(array)-1) if (dim < SCM_ARRAY_NDIM(array)-1)
scm_i_print_array_dimension (array, dim+1, base, port, pstate); scm_i_print_array_dimension (array, dim+1, base, enclosed,
port, pstate);
else else
scm_iprin1 (scm_cvref (SCM_ARRAY_V (array), base, SCM_UNDEFINED), scm_iprin1 (scm_i_cvref (SCM_ARRAY_V (array), base, enclosed),
port, pstate); port, pstate);
if (idx < dim_spec->ubnd) if (idx < dim_spec->ubnd)
scm_putc (' ', port); scm_putc (' ', port);
@ -2190,7 +2059,20 @@ scm_i_print_array (SCM array, SCM port, scm_print_state *pstate)
break; break;
} }
return scm_i_print_array_dimension (array, 0, base, port, pstate); return scm_i_print_array_dimension (array, 0, base, 0, port, pstate);
}
static int
scm_i_print_enclosed_array (SCM array, SCM port, scm_print_state *pstate)
{
size_t base;
scm_putc ('#', port);
base = SCM_ARRAY_BASE (array);
scm_puts ("<enclosed-array ", port);
scm_i_print_array_dimension (array, 0, base, 1, port, pstate);
scm_putc ('>', port);
return 1;
} }
/* Read an array. This function can also read vectors and uniform /* Read an array. This function can also read vectors and uniform
@ -2202,11 +2084,13 @@ scm_i_print_array (SCM array, SCM port, scm_print_state *pstate)
typedef struct { typedef struct {
const char *tag; const char *tag;
SCM *proto_var; SCM *creator_var;
} tag_proto; } tag_creator;
static tag_proto tag_proto_table[] = { static tag_creator tag_creator_table[] = {
{ "", &scm_i_proc_make_vector }, { "", &scm_i_proc_make_vector },
{ "a", &scm_i_proc_make_string },
{ "b", &scm_i_proc_make_bitvector },
{ "u8", &scm_i_proc_make_u8vector }, { "u8", &scm_i_proc_make_u8vector },
{ "s8", &scm_i_proc_make_s8vector }, { "s8", &scm_i_proc_make_s8vector },
{ "u16", &scm_i_proc_make_u16vector }, { "u16", &scm_i_proc_make_u16vector },
@ -2217,17 +2101,19 @@ static tag_proto tag_proto_table[] = {
{ "s64", &scm_i_proc_make_s64vector }, { "s64", &scm_i_proc_make_s64vector },
{ "f32", &scm_i_proc_make_f32vector }, { "f32", &scm_i_proc_make_f32vector },
{ "f64", &scm_i_proc_make_f64vector }, { "f64", &scm_i_proc_make_f64vector },
{ "c32", &scm_i_proc_make_c32vector },
{ "c64", &scm_i_proc_make_c64vector },
{ NULL, NULL } { NULL, NULL }
}; };
static SCM static SCM
scm_i_tag_to_prototype (const char *tag, SCM port) scm_i_tag_to_creator (const char *tag, SCM port)
{ {
tag_proto *tp; tag_creator *tp;
for (tp = tag_proto_table; tp->tag; tp++) for (tp = tag_creator_table; tp->tag; tp++)
if (!strcmp (tp->tag, tag)) if (!strcmp (tp->tag, tag))
return *(tp->proto_var); return *(tp->creator_var);
#if SCM_ENABLE_DEPRECATED #if SCM_ENABLE_DEPRECATED
{ {
@ -2237,10 +2123,6 @@ scm_i_tag_to_prototype (const char *tag, SCM port)
const char *instead; const char *instead;
switch (tag[0]) switch (tag[0])
{ {
case 'a':
proto = SCM_MAKE_CHAR ('a');
instead = "???";
break;
case 'u': case 'u':
proto = scm_from_int (1); proto = scm_from_int (1);
instead = "u32"; instead = "u32";
@ -2400,56 +2282,32 @@ scm_i_read_array (SCM port, int c)
/* Construct array. */ /* Construct array. */
return scm_list_to_uniform_array (lower_bounds, return scm_list_to_uniform_array (lower_bounds,
scm_i_tag_to_prototype (tag, port), scm_i_tag_to_creator (tag, port),
elements); elements);
} }
int int
scm_raprin1 (SCM exp, SCM port, scm_print_state *pstate) scm_raprin1 (SCM exp, SCM port, scm_print_state *pstate)
{ {
SCM v = exp; scm_iprin1 (exp, port, pstate);
unsigned long base = 0;
long ndim;
if (SCM_ARRAYP (exp) && !SCM_ARRAYP (SCM_ARRAY_V (exp)))
return scm_i_print_array (exp, port, pstate);
scm_putc ('#', port);
ndim = SCM_ARRAY_NDIM (v);
base = SCM_ARRAY_BASE (v);
v = SCM_ARRAY_V (v);
scm_puts ("<enclosed-array ", port);
rapr1 (exp, base, 0, port, pstate);
scm_putc ('>', port);
return 1; return 1;
} }
SCM_DEFINE (scm_array_creator, "array-creator", 1, 0, 0, SCM_DEFINE (scm_array_creator, "array-creator", 1, 0, 0,
(SCM ra), (SCM ra),
"Return a procedure that would produce an array of the same type\n" "Return a procedure that would produce an array of the same type\n"
"as @var{array}, if used as the @var{creator} with\n" "as @var{array} if used as the @var{creator} with\n"
"@code{make-uniform-array}.") "@code{make-array*}.")
#define FUNC_NAME s_scm_array_creator #define FUNC_NAME s_scm_array_creator
{ {
int outer = 1;
SCM orig_ra = ra;
if (SCM_ARRAYP (ra)) if (SCM_ARRAYP (ra))
{ return scm_i_generalized_vector_creator (SCM_ARRAY_V (ra));
ra = SCM_ARRAY_V (ra); else if (scm_is_generalized_vector (ra))
outer = 0;
}
if (scm_is_generalized_vector (ra))
return scm_i_generalized_vector_creator (ra); return scm_i_generalized_vector_creator (ra);
else if (SCM_ARRAYP (ra)) else if (SCM_ENCLOSED_ARRAYP (ra))
scm_misc_error (NULL, "creator not known for enclosed array: ~a", scm_wrong_type_arg_msg (NULL, 0, ra, "non-enclosed array");
scm_list_1 (orig_ra));
else if (outer)
scm_wrong_type_arg_msg (NULL, 0, ra, "array");
else else
scm_misc_error (NULL, "creator not known for array content: ~a", scm_wrong_type_arg_msg (NULL, 0, ra, "array");
scm_list_1 (ra));
} }
#undef FUNC_NAME #undef FUNC_NAME
@ -2462,18 +2320,12 @@ SCM_DEFINE (scm_array_prototype, "array-prototype", 1, 0, 0,
"@code{make-uniform-array}.") "@code{make-uniform-array}.")
#define FUNC_NAME s_scm_array_prototype #define FUNC_NAME s_scm_array_prototype
{ {
int enclosed = 0;
loop:
if (SCM_ARRAYP (ra)) if (SCM_ARRAYP (ra))
{ return scm_i_get_old_prototype (SCM_ARRAY_V (ra));
if (enclosed++)
return SCM_UNSPECIFIED;
ra = SCM_ARRAY_V (ra);
goto loop;
}
else if (scm_is_generalized_vector (ra)) else if (scm_is_generalized_vector (ra))
return scm_i_get_old_prototype (ra); return scm_i_get_old_prototype (ra);
else if (SCM_ENCLOSED_ARRAYP (ra))
return SCM_UNSPECIFIED;
else else
scm_wrong_type_arg_msg (NULL, 0, ra, "array"); scm_wrong_type_arg_msg (NULL, 0, ra, "array");
} }
@ -2504,10 +2356,15 @@ scm_init_unif ()
scm_tc16_array = scm_make_smob_type ("array", 0); scm_tc16_array = scm_make_smob_type ("array", 0);
scm_set_smob_mark (scm_tc16_array, array_mark); scm_set_smob_mark (scm_tc16_array, array_mark);
scm_set_smob_free (scm_tc16_array, array_free); scm_set_smob_free (scm_tc16_array, array_free);
scm_set_smob_print (scm_tc16_array, scm_raprin1); scm_set_smob_print (scm_tc16_array, scm_i_print_array);
scm_set_smob_equalp (scm_tc16_array, scm_array_equal_p); scm_set_smob_equalp (scm_tc16_array, scm_array_equal_p);
exactly_one_third = scm_permanent_object (scm_divide (scm_from_int (1),
scm_from_int (3))); scm_tc16_enclosed_array = scm_make_smob_type ("enclosed-array", 0);
scm_set_smob_mark (scm_tc16_enclosed_array, array_mark);
scm_set_smob_free (scm_tc16_enclosed_array, array_free);
scm_set_smob_print (scm_tc16_enclosed_array, scm_i_print_enclosed_array);
scm_set_smob_equalp (scm_tc16_enclosed_array, scm_array_equal_p);
scm_add_feature ("array"); scm_add_feature ("array");
scm_tc16_bitvector = scm_make_smob_type ("bitvector", 0); scm_tc16_bitvector = scm_make_smob_type ("bitvector", 0);

18
libguile/unif.h
View file

@ -57,10 +57,12 @@ typedef struct scm_t_array_dim
} scm_t_array_dim; } scm_t_array_dim;
SCM_API scm_t_bits scm_tc16_array; SCM_API scm_t_bits scm_tc16_array;
SCM_API scm_t_bits scm_tc16_enclosed_array;
#define SCM_ARRAY_FLAG_CONTIGUOUS (1 << 16) #define SCM_ARRAY_FLAG_CONTIGUOUS (1 << 16)
#define SCM_ARRAYP(a) SCM_TYP16_PREDICATE (scm_tc16_array, a) #define SCM_ARRAYP(a) SCM_TYP16_PREDICATE (scm_tc16_array, a)
#define SCM_ENCLOSED_ARRAYP(a) SCM_TYP16_PREDICATE (scm_tc16_enclosed_array, a)
#define SCM_ARRAY_NDIM(x) ((size_t) (SCM_CELL_WORD_0 (x) >> 17)) #define SCM_ARRAY_NDIM(x) ((size_t) (SCM_CELL_WORD_0 (x) >> 17))
#define SCM_ARRAY_CONTP(x) (SCM_CELL_WORD_0 (x) & SCM_ARRAY_FLAG_CONTIGUOUS) #define SCM_ARRAY_CONTP(x) (SCM_CELL_WORD_0 (x) & SCM_ARRAY_FLAG_CONTIGUOUS)
#define SCM_SET_ARRAY_CONTIGUOUS_FLAG(x) \ #define SCM_SET_ARRAY_CONTIGUOUS_FLAG(x) \
@ -79,9 +81,6 @@ SCM_API SCM scm_array_dimensions (SCM ra);
SCM_API SCM scm_shared_array_root (SCM ra); SCM_API SCM scm_shared_array_root (SCM ra);
SCM_API SCM scm_shared_array_offset (SCM ra); SCM_API SCM scm_shared_array_offset (SCM ra);
SCM_API SCM scm_shared_array_increments (SCM ra); SCM_API SCM scm_shared_array_increments (SCM ra);
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_make_shared_array (SCM oldra, SCM mapfunc, SCM dims); SCM_API SCM scm_make_shared_array (SCM oldra, SCM mapfunc, SCM dims);
SCM_API SCM scm_transpose_array (SCM ra, SCM args); SCM_API SCM scm_transpose_array (SCM ra, SCM args);
SCM_API SCM scm_enclose_array (SCM ra, SCM axes); SCM_API SCM scm_enclose_array (SCM ra, SCM axes);
@ -89,11 +88,11 @@ SCM_API SCM scm_array_in_bounds_p (SCM v, SCM args);
SCM_API SCM scm_array_ref (SCM v, SCM args); SCM_API SCM scm_array_ref (SCM v, SCM args);
SCM_API SCM scm_array_set_x (SCM v, SCM obj, SCM args); SCM_API SCM scm_array_set_x (SCM v, SCM obj, SCM args);
SCM_API SCM scm_array_contents (SCM ra, SCM strict); SCM_API SCM scm_array_contents (SCM ra, SCM strict);
SCM_API SCM scm_ra2contig (SCM ra, int copy); SCM_API SCM scm_uniform_array_read_x (SCM ra, SCM port_or_fd,
SCM_API SCM scm_uniform_array_read_x (SCM ra, SCM port_or_fd, SCM start, SCM end); SCM start, SCM end);
SCM_API SCM scm_uniform_array_write (SCM v, SCM port_or_fd, SCM start, SCM end); SCM_API SCM scm_uniform_array_write (SCM v, SCM port_or_fd,
SCM start, SCM end);
SCM_API SCM scm_array_to_list (SCM v); SCM_API SCM scm_array_to_list (SCM v);
SCM_API SCM scm_list_to_uniform_array (SCM ndim, SCM prot, SCM lst);
SCM_API SCM scm_array_creator (SCM ra); SCM_API SCM scm_array_creator (SCM ra);
SCM_API SCM scm_i_read_array (SCM port, int c); SCM_API SCM scm_i_read_array (SCM port, int c);
@ -135,6 +134,11 @@ SCM_API SCM scm_cvref (SCM v, unsigned long pos, SCM last);
SCM_API SCM scm_istr2bve (SCM str); SCM_API SCM scm_istr2bve (SCM str);
SCM_API int scm_raprin1 (SCM exp, SCM port, scm_print_state *pstate); 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_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_proc_make_vector; SCM_API SCM scm_i_proc_make_vector;
SCM_API SCM scm_i_proc_make_string; SCM_API SCM scm_i_proc_make_string;