mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-29 19:30:36 +02:00
1234bb1850
Update to newest recommended license notices from the FSF. Everything stays LGPLv3+ except guile-readline which is GPLv3+.
410 lines
10 KiB
C
410 lines
10 KiB
C
/* Copyright 1995-1998,2000-2006,2009-2010,2013-2014,2018
|
||
Free Software Foundation, Inc.
|
||
|
||
This file is part of Guile.
|
||
|
||
Guile is free software: you can redistribute it and/or modify it
|
||
under the terms of the GNU Lesser General Public License as published
|
||
by the Free Software Foundation, either version 3 of the License, or
|
||
(at your option) any later version.
|
||
|
||
Guile is distributed in the hope that it will be useful, but WITHOUT
|
||
ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
|
||
FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public
|
||
License for more details.
|
||
|
||
You should have received a copy of the GNU Lesser General Public
|
||
License along with Guile. If not, see
|
||
<https://www.gnu.org/licenses/>. */
|
||
|
||
|
||
|
||
|
||
#ifdef HAVE_CONFIG_H
|
||
# include <config.h>
|
||
#endif
|
||
|
||
#include <errno.h>
|
||
#include <stdio.h>
|
||
#include <string.h>
|
||
|
||
#include "array-handle.h"
|
||
#include "gsubr.h"
|
||
#include "list.h"
|
||
#include "numbers.h"
|
||
#include "pairs.h"
|
||
|
||
#include "generalized-arrays.h"
|
||
|
||
|
||
SCM_INTERNAL SCM scm_i_array_ref (SCM v,
|
||
SCM idx0, SCM idx1, SCM idxN);
|
||
SCM_INTERNAL SCM scm_i_array_set_x (SCM v, SCM obj,
|
||
SCM idx0, SCM idx1, SCM idxN);
|
||
|
||
|
||
int
|
||
scm_is_array (SCM obj)
|
||
{
|
||
if (!SCM_HEAP_OBJECT_P (obj))
|
||
return 0;
|
||
|
||
switch (SCM_TYP7 (obj))
|
||
{
|
||
case scm_tc7_string:
|
||
case scm_tc7_vector:
|
||
case scm_tc7_bitvector:
|
||
case scm_tc7_bytevector:
|
||
case scm_tc7_array:
|
||
return 1;
|
||
default:
|
||
return 0;
|
||
}
|
||
}
|
||
|
||
SCM_DEFINE (scm_array_p_2, "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_2
|
||
{
|
||
return scm_from_bool (scm_is_array (obj));
|
||
}
|
||
#undef FUNC_NAME
|
||
|
||
/* The array type predicate, with an extra argument kept for backward
|
||
compatibility. Note that we can't use `SCM_DEFINE' directly because there
|
||
would be an argument count mismatch that would be caught by
|
||
`snarf-check-and-output-texi.scm'. */
|
||
SCM
|
||
scm_array_p (SCM obj, SCM unused)
|
||
{
|
||
return scm_array_p_2 (obj);
|
||
}
|
||
|
||
int
|
||
scm_is_typed_array (SCM obj, SCM type)
|
||
{
|
||
int ret = 0;
|
||
if (scm_is_array (obj))
|
||
{
|
||
scm_t_array_handle h;
|
||
|
||
scm_array_get_handle (obj, &h);
|
||
ret = scm_is_eq (scm_array_handle_element_type (&h), type);
|
||
scm_array_handle_release (&h);
|
||
}
|
||
|
||
return ret;
|
||
}
|
||
|
||
SCM_DEFINE (scm_typed_array_p, "typed-array?", 2, 0, 0,
|
||
(SCM obj, SCM type),
|
||
"Return @code{#t} if the @var{obj} is an array of type\n"
|
||
"@var{type}, and @code{#f} if not.")
|
||
#define FUNC_NAME s_scm_typed_array_p
|
||
{
|
||
return scm_from_bool (scm_is_typed_array (obj, type));
|
||
}
|
||
#undef FUNC_NAME
|
||
|
||
|
||
size_t
|
||
scm_c_array_length (SCM array)
|
||
{
|
||
scm_t_array_handle handle;
|
||
size_t res;
|
||
|
||
scm_array_get_handle (array, &handle);
|
||
if (scm_array_handle_rank (&handle) < 1)
|
||
{
|
||
scm_array_handle_release (&handle);
|
||
scm_wrong_type_arg_msg (NULL, 0, array, "array of nonzero rank");
|
||
}
|
||
res = handle.dims[0].ubnd - handle.dims[0].lbnd + 1;
|
||
scm_array_handle_release (&handle);
|
||
|
||
return res;
|
||
}
|
||
|
||
SCM_DEFINE (scm_array_length, "array-length", 1, 0, 0,
|
||
(SCM array),
|
||
"Return the length of an array: its first dimension.\n"
|
||
"It is an error to ask for the length of an array of rank 0.")
|
||
#define FUNC_NAME s_scm_array_length
|
||
{
|
||
return scm_from_size_t (scm_c_array_length (array));
|
||
}
|
||
#undef FUNC_NAME
|
||
|
||
|
||
SCM_DEFINE (scm_array_dimensions, "array-dimensions", 1, 0, 0,
|
||
(SCM ra),
|
||
"@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"
|
||
"@lisp\n"
|
||
"(array-dimensions (make-array 'foo '(-1 3) 5)) @result{} ((-1 3) 5)\n"
|
||
"@end lisp")
|
||
#define FUNC_NAME s_scm_array_dimensions
|
||
{
|
||
scm_t_array_handle handle;
|
||
scm_t_array_dim *s;
|
||
SCM res = SCM_EOL;
|
||
size_t k;
|
||
|
||
scm_array_get_handle (ra, &handle);
|
||
s = scm_array_handle_dims (&handle);
|
||
k = scm_array_handle_rank (&handle);
|
||
|
||
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
|
||
|
||
SCM_DEFINE (scm_array_type, "array-type", 1, 0, 0,
|
||
(SCM ra),
|
||
"")
|
||
#define FUNC_NAME s_scm_array_type
|
||
{
|
||
scm_t_array_handle h;
|
||
SCM type;
|
||
|
||
scm_array_get_handle (ra, &h);
|
||
type = scm_array_handle_element_type (&h);
|
||
scm_array_handle_release (&h);
|
||
|
||
return type;
|
||
}
|
||
#undef FUNC_NAME
|
||
|
||
SCM_DEFINE (scm_array_type_code,
|
||
"array-type-code", 1, 0, 0,
|
||
(SCM array),
|
||
"Return the type of the elements in @var{array},\n"
|
||
"as an integer code.")
|
||
#define FUNC_NAME s_scm_array_type_code
|
||
{
|
||
scm_t_array_handle h;
|
||
scm_t_array_element_type element_type;
|
||
|
||
scm_array_get_handle (array, &h);
|
||
element_type = h.element_type;
|
||
scm_array_handle_release (&h);
|
||
|
||
return scm_from_uint16 (element_type);
|
||
}
|
||
#undef FUNC_NAME
|
||
|
||
SCM_DEFINE (scm_array_in_bounds_p, "array-in-bounds?", 1, 0, 1,
|
||
(SCM ra, SCM args),
|
||
"Return @code{#t} if its arguments would be acceptable to\n"
|
||
"@code{array-ref}.")
|
||
#define FUNC_NAME s_scm_array_in_bounds_p
|
||
{
|
||
SCM res = SCM_BOOL_T;
|
||
size_t k, ndim;
|
||
scm_t_array_dim *s;
|
||
scm_t_array_handle handle;
|
||
|
||
SCM_VALIDATE_REST_ARGUMENT (args);
|
||
|
||
scm_array_get_handle (ra, &handle);
|
||
s = scm_array_handle_dims (&handle);
|
||
ndim = scm_array_handle_rank (&handle);
|
||
|
||
for (k = 0; k < ndim; k++)
|
||
{
|
||
long ind;
|
||
|
||
if (!scm_is_pair (args))
|
||
SCM_WRONG_NUM_ARGS ();
|
||
ind = scm_to_long (SCM_CAR (args));
|
||
args = SCM_CDR (args);
|
||
|
||
if (ind < s[k].lbnd || ind > s[k].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.
|
||
*/
|
||
}
|
||
}
|
||
|
||
scm_array_handle_release (&handle);
|
||
return res;
|
||
}
|
||
#undef FUNC_NAME
|
||
|
||
|
||
SCM
|
||
scm_c_array_ref_1 (SCM array, ssize_t idx0)
|
||
{
|
||
scm_t_array_handle handle;
|
||
SCM res;
|
||
|
||
scm_array_get_handle (array, &handle);
|
||
res = scm_array_handle_ref (&handle, scm_array_handle_pos_1 (&handle, idx0));
|
||
scm_array_handle_release (&handle);
|
||
return res;
|
||
}
|
||
|
||
|
||
SCM
|
||
scm_c_array_ref_2 (SCM array, ssize_t idx0, ssize_t idx1)
|
||
{
|
||
scm_t_array_handle handle;
|
||
SCM res;
|
||
|
||
scm_array_get_handle (array, &handle);
|
||
res = scm_array_handle_ref (&handle, scm_array_handle_pos_2 (&handle, idx0, idx1));
|
||
scm_array_handle_release (&handle);
|
||
return res;
|
||
}
|
||
|
||
|
||
SCM
|
||
scm_array_ref (SCM v, SCM args)
|
||
{
|
||
scm_t_array_handle handle;
|
||
SCM res;
|
||
|
||
scm_array_get_handle (v, &handle);
|
||
res = scm_array_handle_ref (&handle, scm_array_handle_pos (&handle, args));
|
||
scm_array_handle_release (&handle);
|
||
return res;
|
||
}
|
||
|
||
|
||
void
|
||
scm_c_array_set_1_x (SCM array, SCM obj, ssize_t idx0)
|
||
{
|
||
scm_t_array_handle handle;
|
||
|
||
scm_array_get_handle (array, &handle);
|
||
scm_array_handle_set (&handle, scm_array_handle_pos_1 (&handle, idx0),
|
||
obj);
|
||
scm_array_handle_release (&handle);
|
||
}
|
||
|
||
|
||
void
|
||
scm_c_array_set_2_x (SCM array, SCM obj, ssize_t idx0, ssize_t idx1)
|
||
{
|
||
scm_t_array_handle handle;
|
||
|
||
scm_array_get_handle (array, &handle);
|
||
scm_array_handle_set (&handle, scm_array_handle_pos_2 (&handle, idx0, idx1),
|
||
obj);
|
||
scm_array_handle_release (&handle);
|
||
}
|
||
|
||
|
||
SCM
|
||
scm_array_set_x (SCM v, SCM obj, SCM args)
|
||
{
|
||
scm_t_array_handle handle;
|
||
|
||
scm_array_get_handle (v, &handle);
|
||
scm_array_handle_set (&handle, scm_array_handle_pos (&handle, args), obj);
|
||
scm_array_handle_release (&handle);
|
||
return SCM_UNSPECIFIED;
|
||
}
|
||
|
||
|
||
SCM_DEFINE (scm_i_array_ref, "array-ref", 1, 2, 1,
|
||
(SCM v, SCM idx0, SCM idx1, SCM idxN),
|
||
"Return the element at the @code{(idx0, idx1, idxN...)}\n"
|
||
"position in array @var{v}.")
|
||
#define FUNC_NAME s_scm_i_array_ref
|
||
{
|
||
if (SCM_UNBNDP (idx0))
|
||
return scm_array_ref (v, SCM_EOL);
|
||
else if (SCM_UNBNDP (idx1))
|
||
return scm_c_array_ref_1 (v, scm_to_ssize_t (idx0));
|
||
else if (scm_is_null (idxN))
|
||
return scm_c_array_ref_2 (v, scm_to_ssize_t (idx0), scm_to_ssize_t (idx1));
|
||
else
|
||
return scm_array_ref (v, scm_cons (idx0, scm_cons (idx1, idxN)));
|
||
}
|
||
#undef FUNC_NAME
|
||
|
||
|
||
SCM_DEFINE (scm_i_array_set_x, "array-set!", 2, 2, 1,
|
||
(SCM v, SCM obj, SCM idx0, SCM idx1, SCM idxN),
|
||
"Set the element at the @code{(idx0, idx1, idxN...)} position\n"
|
||
"in the array @var{v} to @var{obj}. The value returned by\n"
|
||
"@code{array-set!} is unspecified.")
|
||
#define FUNC_NAME s_scm_i_array_set_x
|
||
{
|
||
if (SCM_UNBNDP (idx0))
|
||
scm_array_set_x (v, obj, SCM_EOL);
|
||
else if (SCM_UNBNDP (idx1))
|
||
scm_c_array_set_1_x (v, obj, scm_to_ssize_t (idx0));
|
||
else if (scm_is_null (idxN))
|
||
scm_c_array_set_2_x (v, obj, scm_to_ssize_t (idx0), scm_to_ssize_t (idx1));
|
||
else
|
||
scm_array_set_x (v, obj, scm_cons (idx0, scm_cons (idx1, idxN)));
|
||
|
||
return SCM_UNSPECIFIED;
|
||
}
|
||
#undef FUNC_NAME
|
||
|
||
|
||
static SCM
|
||
array_to_list (scm_t_array_handle *h, size_t dim, unsigned long pos)
|
||
{
|
||
if (dim == scm_array_handle_rank (h))
|
||
return scm_array_handle_ref (h, pos);
|
||
else
|
||
{
|
||
SCM res = SCM_EOL;
|
||
long inc;
|
||
size_t i;
|
||
|
||
i = h->dims[dim].ubnd - h->dims[dim].lbnd + 1;
|
||
inc = h->dims[dim].inc;
|
||
pos += (i - 1) * inc;
|
||
|
||
for (; i > 0; i--, pos -= inc)
|
||
res = scm_cons (array_to_list (h, dim + 1, pos), res);
|
||
return res;
|
||
}
|
||
}
|
||
|
||
SCM_DEFINE (scm_array_to_list, "array->list", 1, 0, 0,
|
||
(SCM array),
|
||
"Return a list representation of @var{array}.\n\n"
|
||
"It is easiest to specify the behavior of this function by\n"
|
||
"example:\n"
|
||
"@example\n"
|
||
"(array->list #0(a)) @result{} 1\n"
|
||
"(array->list #1(a b)) @result{} (a b)\n"
|
||
"(array->list #2((aa ab) (ba bb)) @result{} ((aa ab) (ba bb))\n"
|
||
"@end example\n")
|
||
#define FUNC_NAME s_scm_array_to_list
|
||
{
|
||
scm_t_array_handle h;
|
||
SCM res;
|
||
|
||
scm_array_get_handle (array, &h);
|
||
res = array_to_list (&h, 0, 0);
|
||
scm_array_handle_release (&h);
|
||
|
||
return res;
|
||
}
|
||
#undef FUNC_NAME
|
||
|
||
void
|
||
scm_init_generalized_arrays ()
|
||
{
|
||
#include "generalized-arrays.x"
|
||
}
|