summaryrefslogtreecommitdiff
path: root/libguile/arrays.c
diff options
context:
space:
mode:
Diffstat (limited to 'libguile/arrays.c')
-rw-r--r--libguile/arrays.c91
1 files changed, 30 insertions, 61 deletions
diff --git a/libguile/arrays.c b/libguile/arrays.c
index 395bb6723..b17c415c2 100644
--- a/libguile/arrays.c
+++ b/libguile/arrays.c
@@ -56,12 +56,6 @@
#include "libguile/uniform.h"
-#define SCM_SET_ARRAY_CONTIGUOUS_FLAG(x) \
- (SCM_SET_CELL_WORD_0 ((x), SCM_CELL_WORD_0 (x) | (SCM_I_ARRAY_FLAG_CONTIGUOUS << 16)))
-#define SCM_CLR_ARRAY_CONTIGUOUS_FLAG(x) \
- (SCM_SET_CELL_WORD_0 ((x), SCM_CELL_WORD_0 (x) & ~(SCM_I_ARRAY_FLAG_CONTIGUOUS << 16)))
-
-
size_t
scm_c_array_rank (SCM array)
{
@@ -155,7 +149,7 @@ static char s_bad_spec[] = "Bad scm_array dimension";
/* Increments will still need to be set. */
-static SCM
+SCM
scm_i_shap2ra (SCM args)
{
scm_t_array_dim *s;
@@ -289,41 +283,6 @@ scm_from_contiguous_typed_array (SCM type, SCM bounds, const void *bytes,
}
#undef FUNC_NAME
-SCM
-scm_from_contiguous_array (SCM bounds, const SCM *elts, size_t len)
-#define FUNC_NAME "scm_from_contiguous_array"
-{
- size_t k, rlen = 1;
- scm_t_array_dim *s;
- SCM ra;
- scm_t_array_handle h;
-
- ra = scm_i_shap2ra (bounds);
- SCM_SET_ARRAY_CONTIGUOUS_FLAG (ra);
- s = SCM_I_ARRAY_DIMS (ra);
- k = SCM_I_ARRAY_NDIM (ra);
-
- while (k--)
- {
- s[k].inc = rlen;
- SCM_ASSERT_RANGE (1, bounds, s[k].lbnd <= s[k].ubnd + 1);
- rlen = (s[k].ubnd - s[k].lbnd + 1) * s[k].inc;
- }
- if (rlen != len)
- SCM_MISC_ERROR ("element length and dimensions do not match", SCM_EOL);
-
- SCM_I_ARRAY_SET_V (ra, scm_c_make_vector (rlen, SCM_UNDEFINED));
- scm_array_get_handle (ra, &h);
- memcpy (h.writable_elements, elts, rlen * sizeof(SCM));
- scm_array_handle_release (&h);
-
- if (1 == SCM_I_ARRAY_NDIM (ra) && 0 == SCM_I_ARRAY_BASE (ra))
- if (0 == s->lbnd)
- return SCM_I_ARRAY_V (ra);
- return ra;
-}
-#undef FUNC_NAME
-
SCM_DEFINE (scm_make_array, "make-array", 1, 0, 1,
(SCM fill, SCM bounds),
"Create and return an array.")
@@ -333,6 +292,7 @@ SCM_DEFINE (scm_make_array, "make-array", 1, 0, 1,
}
#undef FUNC_NAME
+/* see scm_from_contiguous_array */
static void
scm_i_ra_set_contp (SCM ra)
{
@@ -757,31 +717,38 @@ SCM_DEFINE (scm_array_contents, "array-contents", 1, 1, 0,
"@code{make-array} and @code{make-uniform-array} may be unrolled,\n"
"some arrays made by @code{make-shared-array} may not be. If\n"
"the optional argument @var{strict} is provided, a shared array\n"
- "will be returned only if its elements are stored internally\n"
- "contiguous in memory.")
+ "will be returned only if its elements are stored contiguously\n"
+ "in memory.")
#define FUNC_NAME s_scm_array_contents
{
- if (!scm_is_array (ra))
- scm_wrong_type_arg_msg (NULL, 0, ra, "array");
- else if (SCM_I_ARRAYP (ra))
+ if (SCM_I_ARRAYP (ra))
{
SCM v;
- size_t k, ndim = SCM_I_ARRAY_NDIM (ra), len = 1;
- if (!SCM_I_ARRAY_CONTP (ra))
- return SCM_BOOL_F;
- for (k = 0; k < ndim; k++)
- len *= SCM_I_ARRAY_DIMS (ra)[k].ubnd - SCM_I_ARRAY_DIMS (ra)[k].lbnd + 1;
+ size_t ndim = SCM_I_ARRAY_NDIM (ra);
+ scm_t_array_dim *s = SCM_I_ARRAY_DIMS (ra);
+ size_t k = ndim;
+ size_t len = 1;
+
+ if (k)
+ {
+ ssize_t last_inc = s[k - 1].inc;
+ while (k--)
+ {
+ if (len*last_inc != s[k].inc)
+ return SCM_BOOL_F;
+ len *= (s[k].ubnd - s[k].lbnd + 1);
+ }
+ }
+
if (!SCM_UNBNDP (strict) && scm_is_true (strict))
{
- if (ndim && (1 != SCM_I_ARRAY_DIMS (ra)[ndim - 1].inc))
+ if (ndim && (1 != s[ndim - 1].inc))
return SCM_BOOL_F;
- if (scm_is_bitvector (SCM_I_ARRAY_V (ra)))
- {
- if (len != scm_c_bitvector_length (SCM_I_ARRAY_V (ra)) ||
- SCM_I_ARRAY_BASE (ra) % SCM_LONG_BIT ||
- len % SCM_LONG_BIT)
- return SCM_BOOL_F;
- }
+ if (scm_is_bitvector (SCM_I_ARRAY_V (ra))
+ && (len != scm_c_bitvector_length (SCM_I_ARRAY_V (ra)) ||
+ SCM_I_ARRAY_BASE (ra) % SCM_LONG_BIT ||
+ len % SCM_LONG_BIT))
+ return SCM_BOOL_F;
}
v = SCM_I_ARRAY_V (ra);
@@ -798,8 +765,10 @@ SCM_DEFINE (scm_array_contents, "array-contents", 1, 1, 0,
return sra;
}
}
- else
+ else if (scm_is_array (ra))
return ra;
+ else
+ scm_wrong_type_arg_msg (NULL, 0, ra, "array");
}
#undef FUNC_NAME