[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, master, updated. v2.1.0-741-g2c1ccb0
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] GNU Guile branch, master, updated. v2.1.0-741-g2c1ccb0 |
|
Date: |
Mon, 10 Feb 2014 20:58:53 +0000 |
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".
http://git.savannah.gnu.org/cgit/guile.git/commit/?id=2c1ccb02c565aa364149e84547628f0eac460981
The branch, master has been updated
via 2c1ccb02c565aa364149e84547628f0eac460981 (commit)
via c6eaad9757e55bd9ee32464f35e86958cf7c8272 (commit)
via b98e2f47aa233609f90671315f854310e5e46cb8 (commit)
via 1e2a55e42a1181b1ec9e1ab2d3457458e05960de (commit)
via b7c8836b715f3dbbf89e3debb76dcf7b5c8d6ec1 (commit)
via 992904a8cabe66588f0fcc602ae16e59dcde8b12 (commit)
via f26eae9a9a48bad6c280795154df4913d12fabd3 (commit)
via 4cde4f63ee3f7357e332ec93bef2010d63836a6d (commit)
via 2a8688a9d19e5825109d4abe4530b48019d5926f (commit)
from 35f45ed6d0d4d8d73975cb1935faf32f82cb48b8 (commit)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit 2c1ccb02c565aa364149e84547628f0eac460981
Author: Daniel Llorens <address@hidden>
Date: Wed May 8 16:06:40 2013 +0200
array-contents returns root for empty arrays with empty root
This fixes a compiler issue where (uniform-array->bytevector #2f64())
failed because of the stricter definition of uniform-vector? on this branch.
Perhaps it would be better if uniform-array->bytevector didn't require
a contiguous argument.
* libguile/arrays.c: (scm_array_contents): return the root regardless of
the value of SCM_I_ARRAY_DIMS (ra)->inc.
* test-suite/tests/arrays.test: check.
commit c6eaad9757e55bd9ee32464f35e86958cf7c8272
Author: Daniel Llorens <address@hidden>
Date: Thu May 2 11:43:31 2013 +0200
Add tests for more kinds of typed arrays.
* test-suite/tests/arrays.test: Add more type array tests.
commit b98e2f47aa233609f90671315f854310e5e46cb8
Author: Daniel Llorens <address@hidden>
Date: Tue Apr 30 16:11:07 2013 +0200
Preallocate index list in scm_array_index_map_x
* libguile/array-map.c
- (scm_array_index_map_x): preallocate the index list instead of
constructing it on each rank-1 iteration.
- (ramap, rafe): use SCM_I_ARRAY_V just once.
commit 1e2a55e42a1181b1ec9e1ab2d3457458e05960de
Author: Daniel Llorens <address@hidden>
Date: Mon Apr 29 14:19:52 2013 +0200
Match types used in arrays.c to struct field types
* libguile/arrays.c
- scm_shared_array_root: check for SCM_I_ARRAYP first.
- scm_i_shap2ra:
* check valid bounds in the '(lbnd ubnd) case. This makes
(make-array 0 '(4 -3)) fail with a 'bad dimension' instead of
with a 'wrong index' error.
* use ssize_t for lbnd/ubnd/inc, not long.
- scm_make_shared_array: use ssize_t for indices, not long.
- scm_transpose_array: use size_t for ndim, not ulong.
- scm_i_print_array: idem.
commit b7c8836b715f3dbbf89e3debb76dcf7b5c8d6ec1
Author: Daniel Llorens <address@hidden>
Date: Fri Apr 26 13:02:38 2013 +0200
Don't use ASET in scm_array_index_map_x
* libguile/array-map.c: (scm_array_index_map_x): replace ASET by direct
use of handle->impl.
commit 992904a8cabe66588f0fcc602ae16e59dcde8b12
Author: Daniel Llorens <address@hidden>
Date: Fri Apr 26 02:05:22 2013 +0200
In scm_ramapc, only check unrolled axes for emptiness
* libguile/array-map.c: (scm_ramapc)
- Don't check emptiness while preparing ra0, but only after kroll is
known,
and only before kroll. len = 0 will be caught by the unrolled loop.
- Use ra0 axis length in unroll check depth for rest args, not ra1's.
- Recover early exit feature when cproc returns 0.
commit f26eae9a9a48bad6c280795154df4913d12fabd3
Author: Daniel Llorens <address@hidden>
Date: Thu Apr 25 15:18:05 2013 +0200
Fix corner cases of scm_ramapc
* libguile/array-map.c
- (scm_ramapc): mismatched axes limit unrollk (kroll). Reorganize
the function to do all checking as we go.
- (scm_ra_matchp): unused; remove.
- (find_unrollk): inlined in scm_ramapc; remove.
- (klen): inlined in scm_ramapc; remove.
- (rafill): n is size_t.
- (racp): n is size_t. Use n and not i0end to bound the loop.
- (ramap): Use n and not i0end to bound the loop. This is needed for the
rank
0 case to work with the new scm_ramapc, as inc may be set to 0 in that
case.
- (rafe): idem.
* test-suite/tests/ramap.test
- check that size mismatch prevents unrolling (matching behavior III) with
both array-copy! and array-map!.
- check that non-contiguous stride in non-ref args prevents unrolling
(rank 2, discontinuous) with both array-copy! and array-map!.
- check rank 0 cases with array-for-each, array-map!.
- Test the 0-inc, non empty case for both array-map! and array-copy!.
-----------------------------------------------------------------------
Summary of changes:
libguile/array-map.c | 425 ++++++++++++++++++------------------------
libguile/arrays.c | 51 +++---
test-suite/tests/arrays.test | 15 ++-
test-suite/tests/ramap.test | 123 ++++++++++--
4 files changed, 321 insertions(+), 293 deletions(-)
diff --git a/libguile/array-map.c b/libguile/array-map.c
index c297fe5..2d68f5f 100644
--- a/libguile/array-map.c
+++ b/libguile/array-map.c
@@ -45,7 +45,7 @@
/* The WHAT argument for `scm_gc_malloc ()' et al. */
-static const char indices_gc_hint[] = "array-indices";
+static const char vi_gc_hint[] = "array-indices";
static SCM
AREF (SCM v, size_t pos)
@@ -59,84 +59,32 @@ ASET (SCM v, size_t pos, SCM val)
scm_c_array_set_1_x (v, val, pos);
}
-static unsigned long
-cind (SCM ra, long *ve)
+static SCM
+make1array (SCM v, ssize_t inc)
{
- unsigned long i;
- int k;
- if (!SCM_I_ARRAYP (ra))
- return *ve;
- i = SCM_I_ARRAY_BASE (ra);
- for (k = 0; k < SCM_I_ARRAY_NDIM (ra); k++)
- i += (ve[k] - SCM_I_ARRAY_DIMS (ra)[k].lbnd) * SCM_I_ARRAY_DIMS
(ra)[k].inc;
- return i;
-}
-
-
-/* Checker for scm_array mapping functions:
- return values:
- 5 --> empty axes;
- 4 --> shapes, increments, and bases are the same;
- 3 --> shapes and increments are the same;
- 2 --> shapes are the same;
- 1 --> ras are at least as big as ra0;
- 0 --> no match.
- */
+ SCM a = scm_i_make_array (1);
+ SCM_I_ARRAY_BASE (a) = 0;
+ SCM_I_ARRAY_DIMS (a)->lbnd = 0;
+ SCM_I_ARRAY_DIMS (a)->ubnd = scm_c_array_length (v) - 1;
+ SCM_I_ARRAY_DIMS (a)->inc = inc;
+ SCM_I_ARRAY_V (a) = v;
+ return a;
+}
-int
-scm_ra_matchp (SCM ra0, SCM ras)
+/* Linear index of not-unrolled index set. */
+static size_t
+cindk (SCM ra, ssize_t *ve, int kend)
{
- int i, exact = 4, empty = 0;
- scm_t_array_handle h0;
-
- scm_array_get_handle (ra0, &h0);
- for (i = 0; i < h0.ndims; ++i)
- {
- empty = empty || (h0.dims[i].lbnd > h0.dims[i].ubnd);
- }
-
- while (scm_is_pair (ras))
+ if (SCM_I_ARRAYP (ra))
{
- scm_t_array_handle h1;
-
- scm_array_get_handle (SCM_CAR (ras), &h1);
-
- if (h0.ndims != h1.ndims)
- {
- scm_array_handle_release (&h0);
- scm_array_handle_release (&h1);
- return 0;
- }
- if (h0.base != h1.base)
- exact = min(3, exact);
-
- for (i = 0; i < h0.ndims; ++i)
- {
- empty = empty || (h1.dims[i].lbnd > h1.dims[i].ubnd);
- switch (exact)
- {
- case 4:
- case 3:
- if (h0.dims[i].inc != h1.dims[i].inc)
- exact = 2;
- case 2:
- if (h0.dims[i].lbnd == h1.dims[i].lbnd && h0.dims[i].ubnd ==
h1.dims[i].ubnd)
- break;
- exact = 1;
- default:
- if (h0.dims[i].lbnd < h1.dims[i].lbnd || h0.dims[i].ubnd >
h1.dims[i].ubnd)
- {
- scm_array_handle_release (&h0);
- scm_array_handle_release (&h1);
- return 0;
- }
- }
- }
- scm_array_handle_release (&h1);
- ras = SCM_CDR (ras);
+ int k;
+ size_t i = SCM_I_ARRAY_BASE (ra);
+ for (k = 0; k < kend; ++k)
+ i += (ve[k] - SCM_I_ARRAY_DIMS (ra)[k].lbnd) * SCM_I_ARRAY_DIMS
(ra)[k].inc;
+ return i;
}
- scm_array_handle_release (&h0);
- return empty ? 5 : exact;
+ else
+ return 0; /* this is BASE */
}
/* array mapper: apply cproc to each dimension of the given arrays?.
@@ -147,167 +95,143 @@ scm_ra_matchp (SCM ra0, SCM ras)
SCM ra0; destination array.
SCM lra; list of source arrays.
const char *what; caller, for error reporting. */
+
+#define LBND(ra, k) SCM_I_ARRAY_DIMS (ra)[k].lbnd
+#define UBND(ra, k) SCM_I_ARRAY_DIMS (ra)[k].ubnd
+
int
scm_ramapc (void *cproc_ptr, SCM data, SCM ra0, SCM lra, const char *what)
{
- SCM z;
- SCM vra0, ra1, vra1;
- SCM lvra, *plvra;
- long *vinds;
- int k, kmax;
int (*cproc) () = cproc_ptr;
+ SCM z, va0, lva, *plva;
+ int k, kmax, kroll;
+ ssize_t *vi, inc;
+ size_t len;
- switch (scm_ra_matchp (ra0, lra))
+ /* Prepare reference argument. */
+ if (SCM_I_ARRAYP (ra0))
{
- default:
- case 0:
- scm_misc_error (what, "array shape mismatch: ~S", scm_list_1 (ra0));
- case 2:
- case 3:
- case 4: /* Try unrolling arrays */
- kmax = (SCM_I_ARRAYP (ra0) ? SCM_I_ARRAY_NDIM (ra0) - 1 : 0);
- if (kmax < 0)
- goto gencase;
- vra0 = scm_array_contents (ra0, SCM_UNDEFINED);
- if (scm_is_false (vra0))
- goto gencase;
- if (!SCM_I_ARRAYP (vra0))
- {
- size_t length = scm_c_array_length (vra0);
- vra1 = scm_i_make_array (1);
- SCM_I_ARRAY_BASE (vra1) = 0;
- SCM_I_ARRAY_DIMS (vra1)->lbnd = 0;
- SCM_I_ARRAY_DIMS (vra1)->ubnd = length - 1;
- SCM_I_ARRAY_DIMS (vra1)->inc = 1;
- SCM_I_ARRAY_V (vra1) = vra0;
- vra0 = vra1;
- }
- lvra = SCM_EOL;
- plvra = &lvra;
- for (z = lra; scm_is_pair (z); z = SCM_CDR (z))
- {
- ra1 = SCM_CAR (z);
- vra1 = scm_i_make_array (1);
- SCM_I_ARRAY_DIMS (vra1)->lbnd = SCM_I_ARRAY_DIMS (vra0)->lbnd;
- SCM_I_ARRAY_DIMS (vra1)->ubnd = SCM_I_ARRAY_DIMS (vra0)->ubnd;
- if (!SCM_I_ARRAYP (ra1))
- {
- SCM_I_ARRAY_BASE (vra1) = 0;
- SCM_I_ARRAY_DIMS (vra1)->inc = 1;
- SCM_I_ARRAY_V (vra1) = ra1;
- }
- else if (!SCM_I_ARRAY_CONTP (ra1))
- goto gencase;
- else
- {
- SCM_I_ARRAY_BASE (vra1) = SCM_I_ARRAY_BASE (ra1);
- SCM_I_ARRAY_DIMS (vra1)->inc = SCM_I_ARRAY_DIMS (ra1)[kmax].inc;
- SCM_I_ARRAY_V (vra1) = SCM_I_ARRAY_V (ra1);
- }
- *plvra = scm_cons (vra1, SCM_EOL);
- plvra = SCM_CDRLOC (*plvra);
- }
- return (SCM_UNBNDP (data) ? cproc(vra0, lvra) : cproc(vra0, data, lvra));
- case 1:
- gencase: /* Have to loop over all dimensions. */
- vra0 = scm_i_make_array (1);
- if (SCM_I_ARRAYP (ra0))
+ kmax = SCM_I_ARRAY_NDIM (ra0)-1;
+ inc = kmax < 0 ? 0 : SCM_I_ARRAY_DIMS (ra0)[kmax].inc;
+ va0 = make1array (SCM_I_ARRAY_V (ra0), inc);
+
+ /* Find unroll depth */
+ for (kroll = max(0, kmax); kroll > 0; --kroll)
{
- kmax = SCM_I_ARRAY_NDIM (ra0) - 1;
- if (kmax < 0)
- {
- SCM_I_ARRAY_DIMS (vra0)->lbnd = 0;
- SCM_I_ARRAY_DIMS (vra0)->ubnd = 0;
- SCM_I_ARRAY_DIMS (vra0)->inc = 1;
- }
- else
+ inc *= (UBND (ra0, kroll) - LBND (ra0, kroll) + 1);
+ if (inc != SCM_I_ARRAY_DIMS (ra0)[kroll-1].inc)
+ break;
+ }
+ }
+ else
+ {
+ kroll = kmax = 0;
+ va0 = ra0 = make1array (ra0, 1);
+ }
+
+ /* Prepare rest arguments. */
+ lva = SCM_EOL;
+ plva = &lva;
+ for (z = lra; !scm_is_null (z); z = SCM_CDR (z))
+ {
+ SCM va1, ra1 = SCM_CAR (z);
+ if (SCM_I_ARRAYP (ra1))
+ {
+ if (kmax != SCM_I_ARRAY_NDIM (ra1) - 1)
+ scm_misc_error (what, "array shape mismatch: ~S", scm_list_1
(ra0));
+ inc = kmax < 0 ? 0 : SCM_I_ARRAY_DIMS (ra1)[kmax].inc;
+ va1 = make1array (SCM_I_ARRAY_V (ra1), inc);
+
+ /* Check unroll depth. */
+ for (k = kmax; k > kroll; --k)
{
- SCM_I_ARRAY_DIMS (vra0)->lbnd = SCM_I_ARRAY_DIMS
(ra0)[kmax].lbnd;
- SCM_I_ARRAY_DIMS (vra0)->ubnd = SCM_I_ARRAY_DIMS
(ra0)[kmax].ubnd;
- SCM_I_ARRAY_DIMS (vra0)->inc = SCM_I_ARRAY_DIMS (ra0)[kmax].inc;
+ ssize_t l0 = LBND (ra0, k), u0 = UBND (ra0, k);
+ if (l0 < LBND (ra1, k) || u0 > UBND (ra1, k))
+ scm_misc_error (what, "array shape mismatch: ~S", scm_list_1
(ra0));
+ inc *= (u0 - l0 + 1);
+ if (inc != SCM_I_ARRAY_DIMS (ra1)[k-1].inc)
+ {
+ kroll = k;
+ break;
+ }
}
- SCM_I_ARRAY_BASE (vra0) = SCM_I_ARRAY_BASE (ra0);
- SCM_I_ARRAY_V (vra0) = SCM_I_ARRAY_V (ra0);
+
+ /* Check matching of not-unrolled axes. */
+ for (; k>=0; --k)
+ if (LBND (ra0, k) < LBND (ra1, k) || UBND (ra0, k) > UBND (ra1, k))
+ scm_misc_error (what, "array shape mismatch: ~S", scm_list_1
(ra0));
}
else
{
- size_t length = scm_c_array_length (ra0);
- kmax = 0;
- SCM_I_ARRAY_DIMS (vra0)->lbnd = 0;
- SCM_I_ARRAY_DIMS (vra0)->ubnd = length - 1;
- SCM_I_ARRAY_DIMS (vra0)->inc = 1;
- SCM_I_ARRAY_BASE (vra0) = 0;
- SCM_I_ARRAY_V (vra0) = ra0;
- ra0 = vra0;
- }
- lvra = SCM_EOL;
- plvra = &lvra;
- for (z = lra; scm_is_pair (z); z = SCM_CDR (z))
- {
- ra1 = SCM_CAR (z);
- vra1 = scm_i_make_array (1);
- SCM_I_ARRAY_DIMS (vra1)->lbnd = SCM_I_ARRAY_DIMS (vra0)->lbnd;
- SCM_I_ARRAY_DIMS (vra1)->ubnd = SCM_I_ARRAY_DIMS (vra0)->ubnd;
- if (SCM_I_ARRAYP (ra1))
- {
- if (kmax >= 0)
- SCM_I_ARRAY_DIMS (vra1)->inc = SCM_I_ARRAY_DIMS
(ra1)[kmax].inc;
- SCM_I_ARRAY_V (vra1) = SCM_I_ARRAY_V (ra1);
- }
- else
- {
- SCM_I_ARRAY_DIMS (vra1)->inc = 1;
- SCM_I_ARRAY_V (vra1) = ra1;
- }
- *plvra = scm_cons (vra1, SCM_EOL);
- plvra = SCM_CDRLOC (*plvra);
+ if (kmax != 0)
+ scm_misc_error (what, "array shape mismatch: ~S", scm_list_1
(ra0));
+ va1 = make1array (ra1, 1);
+
+ if (LBND (ra0, 0) < LBND (va1, 0) || UBND (ra0, 0) > UBND (va1, 0))
+ scm_misc_error (what, "array shape mismatch: ~S", scm_list_1
(ra0));
}
+ *plva = scm_cons (va1, SCM_EOL);
+ plva = SCM_CDRLOC (*plva);
+ }
- vinds = scm_gc_malloc_pointerless (sizeof(long) * SCM_I_ARRAY_NDIM (ra0),
- indices_gc_hint);
+ /* Check emptiness of not-unrolled axes. */
+ for (k = 0; k < kroll; ++k)
+ if (0 == (UBND (ra0, k) - LBND (ra0, k) + 1))
+ return 1;
- for (k = 0; k <= kmax; k++)
- vinds[k] = SCM_I_ARRAY_DIMS (ra0)[k].lbnd;
- k = kmax;
- do
+ /* Set unrolled size. */
+ for (len = 1; k <= kmax; ++k)
+ len *= (UBND (ra0, k) - LBND (ra0, k) + 1);
+ UBND (va0, 0) = len - 1;
+ for (z = lva; !scm_is_null (z); z = SCM_CDR (z))
+ UBND (SCM_CAR (z), 0) = len - 1;
+
+ /* Set starting indices and go. */
+ vi = scm_gc_malloc_pointerless (sizeof(ssize_t) * kroll, vi_gc_hint);
+ for (k = 0; k < kroll; ++k)
+ vi[k] = LBND (ra0, k);
+ do
+ {
+ if (k == kroll)
{
- if (k == kmax)
- {
- SCM y = lra;
- SCM_I_ARRAY_BASE (vra0) = cind (ra0, vinds);
- for (z = lvra; scm_is_pair (z); z = SCM_CDR (z), y = SCM_CDR (y))
- SCM_I_ARRAY_BASE (SCM_CAR (z)) = cind (SCM_CAR (y), vinds);
- if (0 == (SCM_UNBNDP (data) ? cproc(vra0, lvra) : cproc(vra0,
data, lvra)))
- return 0;
- k--;
- continue;
- }
- if (vinds[k] < SCM_I_ARRAY_DIMS (ra0)[k].ubnd)
- {
- vinds[k]++;
- k++;
- continue;
- }
- vinds[k] = SCM_I_ARRAY_DIMS (ra0)[k].lbnd - 1;
- k--;
+ SCM y = lra;
+ SCM_I_ARRAY_BASE (va0) = cindk (ra0, vi, kroll);
+ for (z = lva; !scm_is_null (z); z = SCM_CDR (z), y = SCM_CDR (y))
+ SCM_I_ARRAY_BASE (SCM_CAR (z)) = cindk (SCM_CAR (y), vi, kroll);
+ if (! (SCM_UNBNDP (data) ? cproc (va0, lva) : cproc (va0, data,
lva)))
+ return 0;
+ --k;
+ }
+ else if (vi[k] < UBND (ra0, k))
+ {
+ ++vi[k];
+ ++k;
+ }
+ else
+ {
+ vi[k] = LBND (ra0, k) - 1;
+ --k;
}
- while (k >= 0);
-
- case 5:
- return 1;
}
+ while (k >= 0);
+
+ return 1;
}
+#undef UBND
+#undef LBND
+
static int
rafill (SCM dst, SCM fill)
{
- long n = (SCM_I_ARRAY_DIMS (dst)->ubnd - SCM_I_ARRAY_DIMS (dst)->lbnd + 1);
scm_t_array_handle h;
- size_t i;
+ size_t n, i;
ssize_t inc;
scm_array_get_handle (SCM_I_ARRAY_V (dst), &h);
i = SCM_I_ARRAY_BASE (dst);
inc = SCM_I_ARRAY_DIMS (dst)->inc;
+ n = (SCM_I_ARRAY_DIMS (dst)->ubnd - SCM_I_ARRAY_DIMS (dst)->lbnd + 1);
+ dst = SCM_I_ARRAY_V (dst);
for (; n-- > 0; i += inc)
h.vset (h.vector, i, fill);
@@ -328,15 +252,11 @@ SCM_DEFINE (scm_array_fill_x, "array-fill!", 2, 0, 0,
#undef FUNC_NAME
-/* FIXME src-dst is the wrong order for scm_ra_matchp, but scm_ramapc
- doesn't send SCM_I_ARRAYP for both src and dst, and this segfaults
- with the 'right' order. */
static int
racp (SCM src, SCM dst)
{
- long n = (SCM_I_ARRAY_DIMS (src)->ubnd - SCM_I_ARRAY_DIMS (src)->lbnd + 1);
scm_t_array_handle h_s, h_d;
- size_t i_s, i_d;
+ size_t n, i_s, i_d;
ssize_t inc_s, inc_d;
dst = SCM_CAR (dst);
@@ -344,9 +264,12 @@ racp (SCM src, SCM dst)
i_d = SCM_I_ARRAY_BASE (dst);
inc_s = SCM_I_ARRAY_DIMS (src)->inc;
inc_d = SCM_I_ARRAY_DIMS (dst)->inc;
+ n = (SCM_I_ARRAY_DIMS (src)->ubnd - SCM_I_ARRAY_DIMS (src)->lbnd + 1);
+ src = SCM_I_ARRAY_V (src);
+ dst = SCM_I_ARRAY_V (dst);
- scm_array_get_handle (SCM_I_ARRAY_V (src), &h_s);
- scm_array_get_handle (SCM_I_ARRAY_V (dst), &h_d);
+ scm_array_get_handle (src, &h_s);
+ scm_array_get_handle (dst, &h_d);
if (h_s.element_type == SCM_ARRAY_ELEMENT_TYPE_SCM
&& h_d.element_type == SCM_ARRAY_ELEMENT_TYPE_SCM)
@@ -648,18 +571,17 @@ scm_array_identity (SCM dst, SCM src)
static int
ramap (SCM ra0, SCM proc, SCM ras)
{
- ssize_t i = SCM_I_ARRAY_DIMS (ra0)->lbnd;
- size_t n = SCM_I_ARRAY_DIMS (ra0)->ubnd - i + 1;
-
scm_t_array_handle h0;
- size_t i0, i0end;
- ssize_t inc0;
- scm_array_get_handle (SCM_I_ARRAY_V (ra0), &h0);
+ size_t n, i0;
+ ssize_t i, inc0;
i0 = SCM_I_ARRAY_BASE (ra0);
inc0 = SCM_I_ARRAY_DIMS (ra0)->inc;
- i0end = i0 + n*inc0;
+ i = SCM_I_ARRAY_DIMS (ra0)->lbnd;
+ n = SCM_I_ARRAY_DIMS (ra0)->ubnd - i + 1;
+ ra0 = SCM_I_ARRAY_V (ra0);
+ scm_array_get_handle (ra0, &h0);
if (scm_is_null (ras))
- for (; i0 < i0end; i0 += inc0)
+ for (; n--; i0 += inc0)
h0.vset (h0.vector, i0, scm_call_0 (proc));
else
{
@@ -667,17 +589,18 @@ ramap (SCM ra0, SCM proc, SCM ras)
scm_t_array_handle h1;
size_t i1;
ssize_t inc1;
- scm_array_get_handle (SCM_I_ARRAY_V (ra1), &h1);
i1 = SCM_I_ARRAY_BASE (ra1);
inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
ras = SCM_CDR (ras);
+ ra1 = SCM_I_ARRAY_V (ra1);
+ scm_array_get_handle (ra1, &h1);
if (scm_is_null (ras))
- for (; i0 < i0end; i0 += inc0, i1 += inc1)
- h0.vset (h0.vector, i0, scm_call_1 (proc, h1.vref (h1.vector,
i1)));
+ for (; n--; i0 += inc0, i1 += inc1)
+ h0.vset (h0.vector, i0, scm_call_1 (proc, h1.vref (h1.vector, i1)));
else
{
ras = scm_vector (ras);
- for (; i0 < i0end; i0 += inc0, i1 += inc1, ++i)
+ for (; n--; i0 += inc0, i1 += inc1, ++i)
{
SCM args = SCM_EOL;
unsigned long k;
@@ -726,19 +649,19 @@ rafe (SCM ra0, SCM proc, SCM ras)
size_t n = SCM_I_ARRAY_DIMS (ra0)->ubnd - i + 1;
scm_t_array_handle h0;
- size_t i0, i0end;
+ size_t i0;
ssize_t inc0;
- scm_array_get_handle (SCM_I_ARRAY_V (ra0), &h0);
i0 = SCM_I_ARRAY_BASE (ra0);
inc0 = SCM_I_ARRAY_DIMS (ra0)->inc;
- i0end = i0 + n*inc0;
+ ra0 = SCM_I_ARRAY_V (ra0);
+ scm_array_get_handle (ra0, &h0);
if (scm_is_null (ras))
- for (; i0 < i0end; i0 += inc0)
+ for (; n--; i0 += inc0)
scm_call_1 (proc, h0.vref (h0.vector, i0));
else
{
ras = scm_vector (ras);
- for (; i0 < i0end; i0 += inc0, ++i)
+ for (; n--; i0 += inc0, ++i)
{
SCM args = SCM_EOL;
unsigned long k;
@@ -773,7 +696,7 @@ array_index_map_1 (SCM ra, SCM proc)
scm_array_get_handle (ra, &h);
inc = h.dims[0].inc;
for (i = h.dims[0].lbnd, p = h.base; i <= h.dims[0].ubnd; ++i, p += inc)
- h.vset (h.vector, p, scm_call_1 (proc, scm_from_ulong (i)));
+ h.vset (h.vector, p, scm_call_1 (proc, scm_from_ssize_t (i)));
scm_array_handle_release (&h);
}
@@ -782,48 +705,56 @@ array_index_map_1 (SCM ra, SCM proc)
static void
array_index_map_n (SCM ra, SCM proc)
{
+ scm_t_array_handle h;
size_t i;
+ int k, kmax = SCM_I_ARRAY_NDIM (ra) - 1;
+ ssize_t *vi;
+ SCM **si;
SCM args = SCM_EOL;
- int j, k, kmax = SCM_I_ARRAY_NDIM (ra) - 1;
- long *vinds;
+ SCM *p = &args;
- vinds = scm_gc_malloc_pointerless (sizeof(long) * SCM_I_ARRAY_NDIM (ra),
- indices_gc_hint);
+ vi = scm_gc_malloc_pointerless (sizeof(ssize_t) * (kmax + 1), vi_gc_hint);
+ si = scm_gc_malloc_pointerless (sizeof(SCM *) * (kmax + 1), vi_gc_hint);
for (k = 0; k <= kmax; k++)
{
- vinds[k] = SCM_I_ARRAY_DIMS (ra)[k].lbnd;
- if (vinds[k] > SCM_I_ARRAY_DIMS (ra)[k].ubnd)
+ vi[k] = SCM_I_ARRAY_DIMS (ra)[k].lbnd;
+ if (vi[k] > SCM_I_ARRAY_DIMS (ra)[k].ubnd)
return;
+ *p = scm_cons (scm_from_ssize_t (vi[k]), SCM_EOL);
+ si[k] = SCM_CARLOC (*p);
+ p = SCM_CDRLOC (*p);
}
+
+ scm_array_get_handle (ra, &h);
k = kmax;
do
{
if (k == kmax)
{
- vinds[k] = SCM_I_ARRAY_DIMS (ra)[k].lbnd;
- i = cind (ra, vinds);
- for (; vinds[k] <= SCM_I_ARRAY_DIMS (ra)[k].ubnd; vinds[k]++)
+ vi[kmax] = SCM_I_ARRAY_DIMS (ra)[kmax].lbnd;
+ i = cindk (ra, vi, kmax+1);
+ for (; vi[kmax] <= SCM_I_ARRAY_DIMS (ra)[kmax].ubnd; ++vi[kmax])
{
- for (j = kmax + 1, args = SCM_EOL; j--;)
- args = scm_cons (scm_from_long (vinds[j]), args);
- ASET (SCM_I_ARRAY_V (ra), i, scm_apply_0 (proc, args));
- i += SCM_I_ARRAY_DIMS (ra)[k].inc;
+ *(si[kmax]) = scm_from_ssize_t (vi[kmax]);
+ h.vset (h.vector, i, scm_apply_0 (proc, args));
+ i += SCM_I_ARRAY_DIMS (ra)[kmax].inc;
}
k--;
}
- else if (vinds[k] < SCM_I_ARRAY_DIMS (ra)[k].ubnd)
+ else if (vi[k] < SCM_I_ARRAY_DIMS (ra)[k].ubnd)
{
- vinds[k]++;
+ *(si[k]) = scm_from_ssize_t (++vi[k]);
k++;
}
else
{
- vinds[k] = SCM_I_ARRAY_DIMS (ra)[k].lbnd - 1;
+ vi[k] = SCM_I_ARRAY_DIMS (ra)[k].lbnd - 1;
k--;
}
}
while (k >= 0);
+ scm_array_handle_release (&h);
}
SCM_DEFINE (scm_array_index_map_x, "array-index-map!", 2, 0, 0,
diff --git a/libguile/arrays.c b/libguile/arrays.c
index a378585..702faac 100644
--- a/libguile/arrays.c
+++ b/libguile/arrays.c
@@ -66,10 +66,10 @@ SCM_DEFINE (scm_shared_array_root, "shared-array-root", 1,
0, 0,
"Return the root vector of a shared array.")
#define FUNC_NAME s_scm_shared_array_root
{
- if (!scm_is_array (ra))
- scm_wrong_type_arg_msg (FUNC_NAME, SCM_ARG1, ra, "array");
- else if (SCM_I_ARRAYP (ra))
+ if (SCM_I_ARRAYP (ra))
return SCM_I_ARRAY_V (ra);
+ else if (!scm_is_array (ra))
+ scm_wrong_type_arg_msg (FUNC_NAME, SCM_ARG1, ra, "array");
else
return ra;
}
@@ -129,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);
@@ -146,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;
}
@@ -307,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)
@@ -389,7 +391,7 @@ SCM_DEFINE (scm_make_shared_array, "make-shared-array", 2,
0, 1,
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))
@@ -587,9 +589,8 @@ SCM_DEFINE (scm_array_contents, "array-contents", 1, 1, 0,
}
v = SCM_I_ARRAY_V (ra);
- if ((len == scm_c_array_length (v)) && (0 == SCM_I_ARRAY_BASE (ra))
- && SCM_I_ARRAY_DIMS (ra)->inc)
- return v;
+ if ((len == scm_c_array_length (v)) && (0 == SCM_I_ARRAY_BASE (ra)))
+ return v;
else
{
SCM sra = scm_i_make_array (1);
@@ -632,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),
@@ -749,7 +750,7 @@ 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);
diff --git a/test-suite/tests/arrays.test b/test-suite/tests/arrays.test
index 4ef8360..415f183 100644
--- a/test-suite/tests/arrays.test
+++ b/test-suite/tests/arrays.test
@@ -325,6 +325,11 @@
(let* ((a (make-array 0 4 4)))
(not (array-contents (transpose-array a 1 0) #t))))
+ ;; This is a consequence of (array-contents? a #t) => #t.
+ (pass-if "empty array"
+ (let ((a (make-typed-array 'f64 2 0 0)))
+ (f64vector? (array-contents a))))
+
(pass-if "broadcast vector I"
(let* ((a (make-array 0 4))
(b (make-shared-array a (lambda (i j k) (list k)) 1 1 4)))
@@ -751,7 +756,15 @@
(with-input-from-string "'#1:-3(#t #t)" read))
(pass-if "bitvector is self-evaluating"
- (equal? (compile (bitvector)) (bitvector))))
+ (equal? (compile (bitvector)) (bitvector)))
+
+ ; this failed in 2.0.9.
+ (pass-if "typed arrays that are not uniform arrays"
+ (let ((a #2b((#t #f) (#f #t)))
+ (b (make-typed-array 'b #f 2 2)))
+ (array-set! b #t 0 0)
+ (array-set! b #t 1 1)
+ (array-equal? a b))))
;;;
;;; equal? with vector and one-dimensional array
diff --git a/test-suite/tests/ramap.test b/test-suite/tests/ramap.test
index acb0f22..c8eaf96 100644
--- a/test-suite/tests/ramap.test
+++ b/test-suite/tests/ramap.test
@@ -62,7 +62,15 @@
(array-index-map! (make-typed-array 'f64 0 0 2) (const 0))
(array-index-map! (make-typed-array 'b #t 0 2) (const #t))
(array-index-map! (make-typed-array #t 0 0 2) (const 0))
- #t)))
+ #t))
+
+ (pass-if "rank 2"
+ (let ((a (make-array 0 2 2))
+ (b (make-array 0 2 2)))
+ (array-index-map! a (lambda (i j) i))
+ (array-index-map! b (lambda (i j) j))
+ (and (array-equal? a #2((0 0) (1 1)))
+ (array-equal? b #2((0 1) (0 1)))))))
;;;
;;; array-copy!
@@ -103,6 +111,32 @@
(array-copy! a b)
(equal? b #(1 2))))
+ ;; here both a & b are are unrollable down to the first axis, but the
+ ;; size mismatch limits unrolling to the last axis only.
+
+ (pass-if "matching behavior III"
+ (let ((a #3(((1 2) (3 4)) ((5 6) (7 8))))
+ (b (make-array 0 2 3 2)))
+ (array-copy! a b)
+ (array-equal? b #3(((1 2) (3 4) (0 0)) ((5 6) (7 8) (0 0))))))
+
+ (pass-if "rank 0"
+ (let ((a #0(99))
+ (b (make-array 0)))
+ (array-copy! a b)
+ (equal? b #0(99))))
+
+ (pass-if "rank 1"
+ (let* ((a #2((1 2) (3 4)))
+ (b (make-shared-array a (lambda (j) (list 1 j)) 2))
+ (c (make-shared-array a (lambda (i) (list (- 1 i) 1)) 2))
+ (d (make-array 0 2))
+ (e (make-array 0 2)))
+ (array-copy! b d)
+ (array-copy! c e)
+ (and (equal? d #(3 4))
+ (equal? e #(4 2)))))
+
(pass-if "rank 2"
(let ((a #2((1 2) (3 4)))
(b (make-array 0 2 2))
@@ -119,22 +153,23 @@
(equal? d #2((1 3) (2 4)))
(equal? e #2((1 2) (3 4))))))
- (pass-if "rank 1"
- (let* ((a #2((1 2) (3 4)))
- (b (make-shared-array a (lambda (j) (list 1 j)) 2))
- (c (make-shared-array a (lambda (i) (list (- 1 i) 1)) 2))
- (d (make-array 0 2))
- (e (make-array 0 2)))
- (array-copy! b d)
- (array-copy! c e)
- (and (equal? d #(3 4))
- (equal? e #(4 2)))))
-
- (pass-if "rank 0"
- (let ((a #0(99))
- (b (make-array 0)))
- (array-copy! a b)
- (equal? b #0(99)))))
+ (pass-if "rank 2, discontinuous"
+ (let ((A #2((0 1) (2 3) (4 5)))
+ (B #2((10 11) (12 13) (14 15)))
+ (C #2((20) (21) (22)))
+ (X (make-array 0 3 5))
+ (piece (lambda (X w s)
+ (make-shared-array
+ X (lambda (i j) (list i (+ j s))) 3 w))))
+ (array-copy! A (piece X 2 0))
+ (array-copy! B (piece X 2 2))
+ (array-copy! C (piece X 1 4))
+ (and (array-equal? X #2((0 1 10 11 20) (2 3 12 13 21) (4 5 14 15 22))))))
+
+ (pass-if "null increments, not empty"
+ (let ((a (make-array 0 2 2)))
+ (array-copy! (make-shared-array #0(1) (lambda x '()) 2 2) a)
+ (array-equal? #2((1 1) (1 1))))))
;;;
;;; array-map!
@@ -235,7 +270,31 @@
(pass-if "1+"
(let ((a (make-array #f 5)))
(array-map! a 1+ (make-array 123 5))
- (equal? a (make-array 124 5)))))
+ (equal? a (make-array 124 5))))
+
+ (pass-if "rank 0"
+ (let ((a #0(99))
+ (b (make-array 0)))
+ (array-map! b values a)
+ (equal? b #0(99))))
+
+ (pass-if "rank 2, discontinuous"
+ (let ((A #2((0 1) (2 3) (4 5)))
+ (B #2((10 11) (12 13) (14 15)))
+ (C #2((20) (21) (22)))
+ (X (make-array 0 3 5))
+ (piece (lambda (X w s)
+ (make-shared-array
+ X (lambda (i j) (list i (+ j s))) 3 w))))
+ (array-map! (piece X 2 0) values A)
+ (array-map! (piece X 2 2) values B)
+ (array-map! (piece X 1 4) values C)
+ (and (array-equal? X #2((0 1 10 11 20) (2 3 12 13 21) (4 5 14 15
22))))))
+
+ (pass-if "null increments, not empty"
+ (let ((a (make-array 0 2 2)))
+ (array-map! a values (make-shared-array #0(1) (lambda x '()) 2 2))
+ (array-equal? a #2((1 1) (1 1))))))
(with-test-prefix "two sources"
@@ -316,7 +375,14 @@
(c (make-array 0 2)))
(begin
(array-map! c + (array-col a 1) (array-row a 1))
- (array-equal? c #(3 6))))))
+ (array-equal? c #(3 6)))))
+
+ (pass-if "offset arrays 1"
+ (let ((a address@hidden@-3((0 1) (2 3)))
+ (c (make-array 0 '(1 2) '(-3 -2))))
+ (begin
+ (array-map! c + a a)
+ (array-equal? c address@hidden@-3((0 2) (4 6)))))))
;; note that array-copy! has the opposite behavior.
@@ -330,7 +396,16 @@
(let ((a #(1 2 3))
(b (make-array 0 2)))
(array-map! b values a)
- (equal? b #(1 2)))))
+ (equal? b #(1 2))))
+
+ ;; here both a & b are are unrollable down to the first axis, but the
+ ;; size mismatch limits unrolling to the last axis only.
+
+ (pass-if "matching behavior III"
+ (let ((a #3(((1 2) (3 4) (5 6)) ((7 8) (9 10) (11 12))))
+ (b (make-array 0 2 2 2)))
+ (array-map! b values a)
+ (array-equal? b #3(((1 2) (3 4)) ((7 8) (9 10)))))))
;;;
;;; array-for-each
@@ -339,6 +414,14 @@
(with-test-prefix "array-for-each"
(with-test-prefix "1 source"
+ (pass-if-equal "rank 0"
+ '(99)
+ (let* ((a #0(99))
+ (l '())
+ (p (lambda (x) (set! l (cons x l)))))
+ (array-for-each p a)
+ l))
+
(pass-if-equal "noncompact array"
'(3 2 1 0)
(let* ((a #2((0 1) (2 3)))
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, master, updated. v2.1.0-741-g2c1ccb0,
Andy Wingo <=