summaryrefslogtreecommitdiff
path: root/libguile/arrays.c
diff options
context:
space:
mode:
Diffstat (limited to 'libguile/arrays.c')
-rw-r--r--libguile/arrays.c182
1 files changed, 76 insertions, 106 deletions
diff --git a/libguile/arrays.c b/libguile/arrays.c
index 1eb10b981..702faacbe 100644
--- a/libguile/arrays.c
+++ b/libguile/arrays.c
@@ -1,5 +1,5 @@
/* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004,2005,
- * 2006, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
+ * 2006, 2009, 2010, 2011, 2012, 2013, 2014 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@@ -27,6 +27,7 @@
#include <stdio.h>
#include <errno.h>
#include <string.h>
+#include <assert.h>
#include "libguile/_scm.h"
#include "libguile/__scm.h"
@@ -60,21 +61,22 @@
(SCM_SET_CELL_WORD_0 ((x), SCM_CELL_WORD_0 (x) & ~(SCM_I_ARRAY_FLAG_CONTIGUOUS << 16)))
-SCM_DEFINE (scm_shared_array_root, "shared-array-root", 1, 0, 0,
+SCM_DEFINE (scm_shared_array_root, "shared-array-root", 1, 0, 0,
(SCM ra),
"Return the root vector of a shared array.")
#define FUNC_NAME s_scm_shared_array_root
{
if (SCM_I_ARRAYP (ra))
return SCM_I_ARRAY_V (ra);
- else if (scm_is_generalized_vector (ra))
+ else if (!scm_is_array (ra))
+ scm_wrong_type_arg_msg (FUNC_NAME, SCM_ARG1, ra, "array");
+ else
return ra;
- scm_wrong_type_arg_msg (FUNC_NAME, SCM_ARG1, ra, "array");
}
#undef FUNC_NAME
-SCM_DEFINE (scm_shared_array_offset, "shared-array-offset", 1, 0, 0,
+SCM_DEFINE (scm_shared_array_offset, "shared-array-offset", 1, 0, 0,
(SCM ra),
"Return the root vector index of the first element in the array.")
#define FUNC_NAME s_scm_shared_array_offset
@@ -127,11 +129,11 @@ static char s_bad_spec[] = "Bad scm_array dimension";
/* Increments will still need to be set. */
-static SCM
+static SCM
scm_i_shap2ra (SCM args)
{
scm_t_array_dim *s;
- SCM ra, spec, sp;
+ SCM ra, spec;
int ndim = scm_ilength (args);
if (ndim < 0)
scm_misc_error (NULL, s_bad_spec, SCM_EOL);
@@ -144,25 +146,27 @@ scm_i_shap2ra (SCM args)
spec = SCM_CAR (args);
if (scm_is_integer (spec))
{
- if (scm_to_long (spec) < 0)
- scm_misc_error (NULL, s_bad_spec, SCM_EOL);
s->lbnd = 0;
- s->ubnd = scm_to_long (spec) - 1;
- s->inc = 1;
+ s->ubnd = scm_to_ssize_t (spec);
+ if (s->ubnd < 0)
+ scm_misc_error (NULL, s_bad_spec, SCM_EOL);
+ --s->ubnd;
}
else
{
if (!scm_is_pair (spec) || !scm_is_integer (SCM_CAR (spec)))
scm_misc_error (NULL, s_bad_spec, SCM_EOL);
- s->lbnd = scm_to_long (SCM_CAR (spec));
- sp = SCM_CDR (spec);
- if (!scm_is_pair (sp)
- || !scm_is_integer (SCM_CAR (sp))
- || !scm_is_null (SCM_CDR (sp)))
+ s->lbnd = scm_to_ssize_t (SCM_CAR (spec));
+ spec = SCM_CDR (spec);
+ if (!scm_is_pair (spec)
+ || !scm_is_integer (SCM_CAR (spec))
+ || !scm_is_null (SCM_CDR (spec)))
scm_misc_error (NULL, s_bad_spec, SCM_EOL);
- s->ubnd = scm_to_long (SCM_CAR (sp));
- s->inc = 1;
+ s->ubnd = scm_to_ssize_t (SCM_CAR (spec));
+ if (s->ubnd - s->lbnd < -1)
+ scm_misc_error (NULL, s_bad_spec, SCM_EOL);
}
+ s->inc = 1;
}
return ra;
}
@@ -195,8 +199,9 @@ SCM_DEFINE (scm_make_typed_array, "make-typed-array", 2, 0, 1,
scm_make_generalized_vector (type, scm_from_size_t (rlen), fill);
if (1 == SCM_I_ARRAY_NDIM (ra) && 0 == SCM_I_ARRAY_BASE (ra))
- if (s->ubnd < s->lbnd || (0 == s->lbnd && 1 == s->inc))
+ if (0 == s->lbnd)
return SCM_I_ARRAY_V (ra);
+
return ra;
}
#undef FUNC_NAME
@@ -242,8 +247,9 @@ scm_from_contiguous_typed_array (SCM type, SCM bounds, const void *bytes,
}
else if (sz < 8)
{
- /* byte_len ?= ceil (rlen * sz / 8) */
- if (byte_len != (rlen * sz + 7) / 8)
+ /* Elements of sub-byte size (bitvectors) are addressed in 32-bit
+ units. */
+ if (byte_len != ((rlen * sz + 31) / 32) * 4)
SCM_MISC_ERROR ("byte length and dimensions do not match", SCM_EOL);
}
else
@@ -253,7 +259,7 @@ scm_from_contiguous_typed_array (SCM type, SCM bounds, const void *bytes,
memcpy (elts, bytes, byte_len);
if (1 == SCM_I_ARRAY_NDIM (ra) && 0 == SCM_I_ARRAY_BASE (ra))
- if (s->ubnd < s->lbnd || (0 == s->lbnd && 1 == s->inc))
+ if (0 == s->lbnd)
return SCM_I_ARRAY_V (ra);
return ra;
}
@@ -288,7 +294,7 @@ scm_from_contiguous_array (SCM bounds, const SCM *elts, size_t len)
scm_array_handle_release (&h);
if (1 == SCM_I_ARRAY_NDIM (ra) && 0 == SCM_I_ARRAY_BASE (ra))
- if (s->ubnd < s->lbnd || (0 == s->lbnd && 1 == s->inc))
+ if (0 == s->lbnd)
return SCM_I_ARRAY_V (ra);
return ra;
}
@@ -303,13 +309,13 @@ SCM_DEFINE (scm_make_array, "make-array", 1, 0, 1,
}
#undef FUNC_NAME
-static void
+static void
scm_i_ra_set_contp (SCM ra)
{
size_t k = SCM_I_ARRAY_NDIM (ra);
if (k)
{
- long inc = SCM_I_ARRAY_DIMS (ra)[k - 1].inc;
+ ssize_t inc = SCM_I_ARRAY_DIMS (ra)[k - 1].inc;
while (k--)
{
if (inc != SCM_I_ARRAY_DIMS (ra)[k].inc)
@@ -378,14 +384,14 @@ SCM_DEFINE (scm_make_shared_array, "make-shared-array", 2, 0, 1,
{
SCM_I_ARRAY_V (ra) = oldra;
old_base = old_min = 0;
- old_max = scm_c_generalized_vector_length (oldra) - 1;
+ old_max = scm_c_array_length (oldra) - 1;
}
inds = SCM_EOL;
s = SCM_I_ARRAY_DIMS (ra);
for (k = 0; k < SCM_I_ARRAY_NDIM (ra); k++)
{
- inds = scm_cons (scm_from_long (s[k].lbnd), inds);
+ inds = scm_cons (scm_from_ssize_t (s[k].lbnd), inds);
if (s[k].ubnd < s[k].lbnd)
{
if (1 == SCM_I_ARRAY_NDIM (ra))
@@ -430,7 +436,7 @@ SCM_DEFINE (scm_make_shared_array, "make-shared-array", 2, 0, 1,
if (1 == SCM_I_ARRAY_NDIM (ra) && 0 == SCM_I_ARRAY_BASE (ra))
{
SCM v = SCM_I_ARRAY_V (ra);
- size_t length = scm_c_generalized_vector_length (v);
+ size_t length = scm_c_array_length (v);
if (1 == s->inc && 0 == s->lbnd && length == 1 + s->ubnd)
return v;
if (s->ubnd < s->lbnd)
@@ -472,22 +478,24 @@ SCM_DEFINE (scm_transpose_array, "transpose-array", 1, 0, 1,
int ndim, i, k;
SCM_VALIDATE_REST_ARGUMENT (args);
- SCM_ASSERT (SCM_NIMP (ra), ra, SCM_ARG1, FUNC_NAME);
+ SCM_ASSERT (SCM_HEAP_OBJECT_P (ra), ra, SCM_ARG1, FUNC_NAME);
- if (scm_is_generalized_vector (ra))
+ switch (scm_c_array_rank (ra))
{
+ case 0:
+ if (!scm_is_null (args))
+ SCM_WRONG_NUM_ARGS ();
+ return ra;
+ case 1:
/* Make sure that we are called with a single zero as
- arguments.
+ arguments.
*/
if (scm_is_null (args) || !scm_is_null (SCM_CDR (args)))
SCM_WRONG_NUM_ARGS ();
SCM_VALIDATE_INT_COPY (SCM_ARG2, SCM_CAR (args), i);
SCM_ASSERT_RANGE (SCM_ARG2, SCM_CAR (args), i == 0);
return ra;
- }
-
- if (SCM_I_ARRAYP (ra))
- {
+ default:
vargs = scm_vector (args);
if (SCM_SIMPLE_VECTOR_LENGTH (vargs) != SCM_I_ARRAY_NDIM (ra))
SCM_WRONG_NUM_ARGS ();
@@ -537,15 +545,13 @@ SCM_DEFINE (scm_transpose_array, "transpose-array", 1, 0, 1,
scm_i_ra_set_contp (res);
return res;
}
-
- scm_wrong_type_arg_msg (NULL, 0, ra, "array");
}
#undef FUNC_NAME
/* attempts to unroll an array into a one-dimensional array.
returns the unrolled array or #f if it can't be done. */
- /* if strict is not SCM_UNDEFINED, return #f if returned array
- wouldn't have contiguous elements. */
+/* if strict is true, return #f if returned array
+ wouldn't have contiguous elements. */
SCM_DEFINE (scm_array_contents, "array-contents", 1, 1, 0,
(SCM ra, SCM strict),
"If @var{ra} may be @dfn{unrolled} into a one dimensional shared\n"
@@ -559,15 +565,13 @@ SCM_DEFINE (scm_array_contents, "array-contents", 1, 1, 0,
"contiguous in memory.")
#define FUNC_NAME s_scm_array_contents
{
- SCM sra;
-
- if (scm_is_generalized_vector (ra))
- return ra;
-
- if (SCM_I_ARRAYP (ra))
+ if (!scm_is_array (ra))
+ scm_wrong_type_arg_msg (NULL, 0, ra, "array");
+ else if (SCM_I_ARRAYP (ra))
{
+ SCM v;
size_t k, ndim = SCM_I_ARRAY_NDIM (ra), len = 1;
- if (!SCM_I_ARRAYP (ra) || !SCM_I_ARRAY_CONTP (ra))
+ 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;
@@ -583,24 +587,23 @@ SCM_DEFINE (scm_array_contents, "array-contents", 1, 1, 0,
return SCM_BOOL_F;
}
}
-
- {
- SCM v = SCM_I_ARRAY_V (ra);
- size_t length = scm_c_generalized_vector_length (v);
- if ((len == length) && 0 == SCM_I_ARRAY_BASE (ra) && SCM_I_ARRAY_DIMS (ra)->inc)
- return v;
- }
-
- sra = scm_i_make_array (1);
- SCM_I_ARRAY_DIMS (sra)->lbnd = 0;
- SCM_I_ARRAY_DIMS (sra)->ubnd = len - 1;
- SCM_I_ARRAY_V (sra) = SCM_I_ARRAY_V (ra);
- SCM_I_ARRAY_BASE (sra) = SCM_I_ARRAY_BASE (ra);
- SCM_I_ARRAY_DIMS (sra)->inc = (ndim ? SCM_I_ARRAY_DIMS (ra)[ndim - 1].inc : 1);
- return sra;
+
+ v = SCM_I_ARRAY_V (ra);
+ if ((len == scm_c_array_length (v)) && (0 == SCM_I_ARRAY_BASE (ra)))
+ return v;
+ else
+ {
+ SCM sra = scm_i_make_array (1);
+ SCM_I_ARRAY_DIMS (sra)->lbnd = 0;
+ SCM_I_ARRAY_DIMS (sra)->ubnd = len - 1;
+ SCM_I_ARRAY_V (sra) = v;
+ SCM_I_ARRAY_BASE (sra) = SCM_I_ARRAY_BASE (ra);
+ SCM_I_ARRAY_DIMS (sra)->inc = (ndim ? SCM_I_ARRAY_DIMS (ra)[ndim - 1].inc : 1);
+ return sra;
+ }
}
else
- scm_wrong_type_arg_msg (NULL, 0, ra, "array");
+ return ra;
}
#undef FUNC_NAME
@@ -630,11 +633,11 @@ list_to_array (SCM lst, scm_t_array_handle *handle, ssize_t pos, size_t k)
if (!scm_is_null (lst))
errmsg = "too many elements for array dimension ~a, want ~a";
if (errmsg)
- scm_misc_error (NULL, errmsg, scm_list_2 (scm_from_ulong (k),
+ scm_misc_error (NULL, errmsg, scm_list_2 (scm_from_size_t (k),
scm_from_size_t (len)));
}
}
-
+
SCM_DEFINE (scm_list_to_typed_array, "list->typed-array", 3, 0, 0,
(SCM type, SCM shape, SCM lst),
@@ -727,15 +730,15 @@ scm_i_print_array_dimension (scm_t_array_handle *h, int dim, int pos,
else
{
ssize_t i;
- scm_putc ('(', port);
+ scm_putc_unlocked ('(', port);
for (i = h->dims[dim].lbnd; i <= h->dims[dim].ubnd;
i++, pos += h->dims[dim].inc)
{
scm_i_print_array_dimension (h, dim+1, pos, port, pstate);
if (i < h->dims[dim].ubnd)
- scm_putc (' ', port);
+ scm_putc_unlocked (' ', port);
}
- scm_putc (')', port);
+ scm_putc_unlocked (')', port);
}
return 1;
}
@@ -747,12 +750,12 @@ int
scm_i_print_array (SCM array, SCM port, scm_print_state *pstate)
{
scm_t_array_handle h;
- long i;
+ size_t i;
int print_lbnds = 0, zero_size = 0, print_lens = 0;
scm_array_get_handle (array, &h);
- scm_putc ('#', port);
+ scm_putc_unlocked ('#', port);
if (h.ndims != 1 || h.dims[0].lbnd != 0)
scm_intprint (h.ndims, 10, port);
if (h.element_type != SCM_ARRAY_ELEMENT_TYPE_SCM)
@@ -773,12 +776,12 @@ scm_i_print_array (SCM array, SCM port, scm_print_state *pstate)
{
if (print_lbnds)
{
- scm_putc ('@', port);
+ scm_putc_unlocked ('@', port);
scm_intprint (h.dims[i].lbnd, 10, port);
}
if (print_lens)
{
- scm_putc (':', port);
+ scm_putc_unlocked (':', port);
scm_intprint (h.dims[i].ubnd - h.dims[i].lbnd + 1,
10, port);
}
@@ -806,48 +809,15 @@ scm_i_print_array (SCM array, SCM port, scm_print_state *pstate)
not really the same as Scheme values since they are boxed and
can be modified with array-set!, say.
*/
- scm_putc ('(', port);
+ scm_putc_unlocked ('(', port);
scm_i_print_array_dimension (&h, 0, 0, port, pstate);
- scm_putc (')', port);
+ scm_putc_unlocked (')', port);
return 1;
}
else
return scm_i_print_array_dimension (&h, 0, 0, port, pstate);
}
-static SCM
-array_handle_ref (scm_t_array_handle *h, size_t pos)
-{
- return scm_c_generalized_vector_ref (SCM_I_ARRAY_V (h->array), pos);
-}
-
-static void
-array_handle_set (scm_t_array_handle *h, size_t pos, SCM val)
-{
- scm_c_generalized_vector_set_x (SCM_I_ARRAY_V (h->array), pos, val);
-}
-
-/* FIXME: should be handle for vect? maybe not, because of dims */
-static void
-array_get_handle (SCM array, scm_t_array_handle *h)
-{
- scm_t_array_handle vh;
- scm_array_get_handle (SCM_I_ARRAY_V (array), &vh);
- h->element_type = vh.element_type;
- h->elements = vh.elements;
- h->writable_elements = vh.writable_elements;
- scm_array_handle_release (&vh);
-
- h->dims = SCM_I_ARRAY_DIMS (array);
- h->ndims = SCM_I_ARRAY_NDIM (array);
- h->base = SCM_I_ARRAY_BASE (array);
-}
-
-SCM_ARRAY_IMPLEMENTATION (scm_tc7_array,
- 0x7f,
- array_handle_ref, array_handle_set,
- array_get_handle)
-
void
scm_init_arrays ()
{