mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 11:50:28 +02:00
Code Activity

Fix corner cases of scm_ramapc

Browse source 
* 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!.
This commit is contained in:
Daniel Llorens 2013-04-25 15:18:05 +02:00 • committed by Andy Wingo
parent 4cde4f63ee
commit f26eae9a9a
2 changed files with 240 additions and 226 deletions
Download patch file Download diff file Expand all files Collapse all files

276
libguile/array-map.c
View file

@ -59,72 +59,6 @@ ASET (SCM v, size_t pos, SCM val)
scm_c_array_set_1_x (v, val, pos); scm_c_array_set_1_x (v, val, pos);
} }
/* Checker for scm_array mapping functions, returns:
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.
*/
int
scm_ra_matchp (SCM ra0, SCM ras)
{
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))
{
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);
}
scm_array_handle_release (&h0);
return empty ? 5 : exact;
}
static SCM static SCM
make1array (SCM v, ssize_t inc) make1array (SCM v, ssize_t inc)
{ {
@ -137,46 +71,11 @@ make1array (SCM v, ssize_t inc)
return a; return a;
} }
/* Find down to which rank the array is unrollable. 0 means fully /* Linear index of not-unrolled index set. */
unrollable, which all rank-0 and rank-1 arrays are. */
static int
find_unrollk (SCM ra, int k)
{
if (k <= 0)
return 0;
else
{
ssize_t inc;
inc = SCM_I_ARRAY_DIMS (ra)[k].inc;
do {
size_t lenk = (SCM_I_ARRAY_DIMS (ra)[k].ubnd
- SCM_I_ARRAY_DIMS (ra)[k].lbnd + 1);
inc *= lenk;
--k;
} while (k >= 0 && inc == SCM_I_ARRAY_DIMS (ra)[k].inc);
return k+1;
}
}
/* Length of the unrolled index set. */
static size_t
klen (SCM ra, int kbegin, int kend)
{
size_t len = 1;
int k;
for (k = kbegin; k < kend; ++k)
len *= (SCM_I_ARRAY_DIMS (ra)[k].ubnd
- SCM_I_ARRAY_DIMS (ra)[k].lbnd + 1);
return len;
}
/* Linear index of the NOT unrolled index set. */
static size_t static size_t
cindk (SCM ra, ssize_t *ve, int kend) cindk (SCM ra, ssize_t *ve, int kend)
{ {
if (!SCM_I_ARRAYP (ra)) if (SCM_I_ARRAYP (ra))
return 0; /* this is BASE */
else
{ {
int k; int k;
size_t i = SCM_I_ARRAY_BASE (ra); size_t i = SCM_I_ARRAY_BASE (ra);
@ -184,6 +83,8 @@ cindk (SCM ra, ssize_t *ve, int kend)
i += (ve[k] - SCM_I_ARRAY_DIMS (ra)[k].lbnd) * SCM_I_ARRAY_DIMS (ra)[k].inc; i += (ve[k] - SCM_I_ARRAY_DIMS (ra)[k].lbnd) * SCM_I_ARRAY_DIMS (ra)[k].inc;
return i; return i;
} }
else
return 0; /* this is BASE */
} }
/* array mapper: apply cproc to each dimension of the given arrays?. /* array mapper: apply cproc to each dimension of the given arrays?.
@ -194,40 +95,52 @@ cindk (SCM ra, ssize_t *ve, int kend)
SCM ra0; destination array. SCM ra0; destination array.
SCM lra; list of source arrays. SCM lra; list of source arrays.
const char *what; caller, for error reporting. */ 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 int
scm_ramapc (void *cproc_ptr, SCM data, SCM ra0, SCM lra, const char *what) scm_ramapc (void *cproc_ptr, SCM data, SCM ra0, SCM lra, const char *what)
{ {
SCM z; SCM z, vra0, lvra, *plvra;
SCM vra0;
SCM lvra, *plvra;
ssize_t *vi; ssize_t *vi;
int k, kmax, unrollk; int k, kmax, kroll;
int (*cproc) () = cproc_ptr; int (*cproc) () = cproc_ptr;
size_t unrolled_len; int empty = 0;
switch (scm_ra_matchp (ra0, lra)) /* Prepare reference argument. */
{
default:
case 0:
scm_misc_error (what, "array shape mismatch: ~S", scm_list_1 (ra0));
case 1:
case 2:
case 3:
case 4:
/* Prepare reference argument */
if (SCM_I_ARRAYP (ra0)) if (SCM_I_ARRAYP (ra0))
{ {
kmax = SCM_I_ARRAY_NDIM (ra0)-1; k = kmax = SCM_I_ARRAY_NDIM (ra0)-1;
vra0 = make1array (SCM_I_ARRAY_V (ra0), SCM_I_ARRAY_DIMS (ra0)[kmax].inc); vra0 = make1array (SCM_I_ARRAY_V (ra0), SCM_I_ARRAY_DIMS (ra0)[kmax].inc);
/* Find unroll depth */
if (k > 0)
{
ssize_t inc = SCM_I_ARRAY_DIMS (ra0)[k].inc;
do {
ssize_t dim = (UBND (ra0, k) - LBND (ra0, k) + 1);
empty = empty || (0 == dim);
inc *= dim;
--k;
} while (k >= 0 && inc == SCM_I_ARRAY_DIMS (ra0)[k].inc);
kroll = k+1;
}
else
kroll = 0;
/* Check emptiness of not-unrolled axes. */
for (; k>=0; --k)
empty = empty || (0 == (UBND (ra0, k) - LBND (ra0, k) + 1));
} }
else else
{ {
kmax = 0; kroll = kmax = 0;
vra0 = ra0 = make1array(ra0, 1); vra0 = ra0 = make1array (ra0, 1);
empty = (0 == (UBND (ra0, 0) - LBND (ra0, 0) + 1));
} }
/* Linear addressing for rest arguments */ /* Prepare rest arguments. */
lvra = SCM_EOL; lvra = SCM_EOL;
plvra = &lvra; plvra = &lvra;
for (z = lra; !scm_is_null (z); z = SCM_CDR (z)) for (z = lra; !scm_is_null (z); z = SCM_CDR (z))
@ -235,43 +148,73 @@ scm_ramapc (void *cproc_ptr, SCM data, SCM ra0, SCM lra, const char *what)
SCM ra1 = SCM_CAR (z); SCM ra1 = SCM_CAR (z);
SCM vra1; SCM vra1;
if (SCM_I_ARRAYP (ra1)) 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));
vra1 = make1array (SCM_I_ARRAY_V (ra1), SCM_I_ARRAY_DIMS (ra1)[kmax].inc); vra1 = make1array (SCM_I_ARRAY_V (ra1), SCM_I_ARRAY_DIMS (ra1)[kmax].inc);
/* Check unroll depth. */
k = kmax;
if (k > kroll)
{
ssize_t inc = SCM_I_ARRAY_DIMS (ra1)[k].inc;
do {
ssize_t l0 = LBND (ra0, k), u0 = UBND (ra0, k);
ssize_t l1 = LBND (ra1, k), u1 = UBND (ra1, k);
--k;
if (l0 == l1 && u0 == u1)
inc *= (u1 - l1 + 1);
else if (l0 >= l1 && u0 <= u1)
break;
else else
scm_misc_error (what, "array shape mismatch: ~S", scm_list_1 (ra0));
} while (k >= kroll && inc == SCM_I_ARRAY_DIMS (ra1)[k].inc);
kroll = k + 1;
}
/* 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
{
if (kmax != 0)
scm_misc_error (what, "array shape mismatch: ~S", scm_list_1 (ra0));
vra1 = make1array (ra1, 1); vra1 = make1array (ra1, 1);
if (LBND (ra0, 0) < LBND (vra1, 0) || UBND (ra0, 0) > UBND (vra1, 0))
scm_misc_error (what, "array shape mismatch: ~S", scm_list_1 (ra0));
}
*plvra = scm_cons (vra1, SCM_EOL); *plvra = scm_cons (vra1, SCM_EOL);
plvra = SCM_CDRLOC (*plvra); plvra = SCM_CDRLOC (*plvra);
} }
/* Find common unroll depth */ /* Set unrolled size. */
unrollk = find_unrollk (ra0, kmax); if (empty)
for (z = lra; !scm_is_null (z); z = SCM_CDR (z)) return 1;
else
{ {
SCM ra1 = SCM_CAR (z); size_t len = 1;
unrollk = max(unrollk, find_unrollk (ra1, kmax)); for (k = kroll; k <= kmax; ++k)
} len *= (UBND (ra0, k) - LBND (ra0, k) + 1);
unrolled_len = klen (ra0, unrollk, kmax+1); UBND (vra0, 0) = len - 1;
/* Set inner loop size */
SCM_I_ARRAY_DIMS (vra0)->lbnd = 0;
SCM_I_ARRAY_DIMS (vra0)->ubnd = unrolled_len - 1;
for (z = lvra; !scm_is_null (z); z = SCM_CDR (z)) for (z = lvra; !scm_is_null (z); z = SCM_CDR (z))
{ UBND (SCM_CAR (z), 0) = len - 1;
SCM_I_ARRAY_DIMS (SCM_CAR (z))->lbnd = 0;
SCM_I_ARRAY_DIMS (SCM_CAR (z))->ubnd = unrolled_len - 1;
} }
/* Set starting indices and go */ /* Set starting indices and go. */
vi = scm_gc_malloc_pointerless (sizeof(ssize_t) * unrollk, vi_gc_hint); vi = scm_gc_malloc_pointerless (sizeof(ssize_t) * kroll, vi_gc_hint);
for (k = 0; k < unrollk; ++k) for (k = 0; k < kroll; ++k)
vi[k] = SCM_I_ARRAY_DIMS (ra0)[k].lbnd; vi[k] = LBND (ra0, k);
do do
{ {
if (k == unrollk) if (k == kroll)
{ {
SCM y = lra; SCM y = lra;
SCM_I_ARRAY_BASE (vra0) = cindk (ra0, vi, unrollk); SCM_I_ARRAY_BASE (vra0) = cindk (ra0, vi, kroll);
for (z = lvra; !scm_is_null (z); z = SCM_CDR (z), y = SCM_CDR (y)) for (z = lvra; !scm_is_null (z); z = SCM_CDR (z), y = SCM_CDR (y))
SCM_I_ARRAY_BASE (SCM_CAR (z)) = cindk (SCM_CAR (y), vi, unrollk); SCM_I_ARRAY_BASE (SCM_CAR (z)) = cindk (SCM_CAR (y), vi, kroll);
if (SCM_UNBNDP (data)) if (SCM_UNBNDP (data))
cproc (vra0, lvra); cproc (vra0, lvra);
else else
@ -291,21 +234,23 @@ scm_ramapc (void *cproc_ptr, SCM data, SCM ra0, SCM lra, const char *what)
} }
while (k >= 0); while (k >= 0);
case 5:
return 1; return 1;
}
} }
#undef UBND
#undef LBND
static int static int
rafill (SCM dst, SCM fill) 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; scm_t_array_handle h;
size_t i; size_t n, i;
ssize_t inc; ssize_t inc;
scm_array_get_handle (SCM_I_ARRAY_V (dst), &h); scm_array_get_handle (SCM_I_ARRAY_V (dst), &h);
i = SCM_I_ARRAY_BASE (dst); i = SCM_I_ARRAY_BASE (dst);
inc = SCM_I_ARRAY_DIMS (dst)->inc; 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) for (; n-- > 0; i += inc)
h.vset (h.vector, i, fill); h.vset (h.vector, i, fill);
@ -329,9 +274,8 @@ SCM_DEFINE (scm_array_fill_x, "array-fill!", 2, 0, 0,
static int static int
racp (SCM src, SCM dst) racp (SCM src, SCM dst)
{ {
ssize_t n = (SCM_I_ARRAY_DIMS (src)->ubnd - SCM_I_ARRAY_DIMS (src)->lbnd + 1);
scm_t_array_handle h_s, h_d; 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; ssize_t inc_s, inc_d;
dst = SCM_CAR (dst); dst = SCM_CAR (dst);
@ -339,9 +283,12 @@ racp (SCM src, SCM dst)
i_d = SCM_I_ARRAY_BASE (dst); i_d = SCM_I_ARRAY_BASE (dst);
inc_s = SCM_I_ARRAY_DIMS (src)->inc; inc_s = SCM_I_ARRAY_DIMS (src)->inc;
inc_d = SCM_I_ARRAY_DIMS (dst)->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 (src, &h_s);
scm_array_get_handle (SCM_I_ARRAY_V (dst), &h_d); scm_array_get_handle (dst, &h_d);
if (h_s.element_type == SCM_ARRAY_ELEMENT_TYPE_SCM if (h_s.element_type == SCM_ARRAY_ELEMENT_TYPE_SCM
&& h_d.element_type == SCM_ARRAY_ELEMENT_TYPE_SCM) && h_d.element_type == SCM_ARRAY_ELEMENT_TYPE_SCM)
@ -643,18 +590,17 @@ scm_array_identity (SCM dst, SCM src)
static int static int
ramap (SCM ra0, SCM proc, SCM ras) 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; scm_t_array_handle h0;
size_t i0, i0end; size_t n, i0;
ssize_t inc0; ssize_t i, inc0;
scm_array_get_handle (SCM_I_ARRAY_V (ra0), &h0); scm_array_get_handle (SCM_I_ARRAY_V (ra0), &h0);
i0 = SCM_I_ARRAY_BASE (ra0); i0 = SCM_I_ARRAY_BASE (ra0);
inc0 = SCM_I_ARRAY_DIMS (ra0)->inc; 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);
if (scm_is_null (ras)) if (scm_is_null (ras))
for (; i0 < i0end; i0 += inc0) for (; n--; i0 += inc0)
h0.vset (h0.vector, i0, scm_call_0 (proc)); h0.vset (h0.vector, i0, scm_call_0 (proc));
else else
{ {
@ -666,13 +612,14 @@ ramap (SCM ra0, SCM proc, SCM ras)
i1 = SCM_I_ARRAY_BASE (ra1); i1 = SCM_I_ARRAY_BASE (ra1);
inc1 = SCM_I_ARRAY_DIMS (ra1)->inc; inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
ras = SCM_CDR (ras); ras = SCM_CDR (ras);
ra1 = SCM_I_ARRAY_V (ra1);
if (scm_is_null (ras)) if (scm_is_null (ras))
for (; i0 < i0end; i0 += inc0, i1 += inc1) for (; n--; i0 += inc0, i1 += inc1)
h0.vset (h0.vector, i0, scm_call_1 (proc, h1.vref (h1.vector, i1))); h0.vset (h0.vector, i0, scm_call_1 (proc, h1.vref (h1.vector, i1)));
else else
{ {
ras = scm_vector (ras); ras = scm_vector (ras);
for (; i0 < i0end; i0 += inc0, i1 += inc1, ++i) for (; n--; i0 += inc0, i1 += inc1, ++i)
{ {
SCM args = SCM_EOL; SCM args = SCM_EOL;
unsigned long k; unsigned long k;
@ -721,19 +668,18 @@ rafe (SCM ra0, SCM proc, SCM ras)
size_t n = SCM_I_ARRAY_DIMS (ra0)->ubnd - i + 1; size_t n = SCM_I_ARRAY_DIMS (ra0)->ubnd - i + 1;
scm_t_array_handle h0; scm_t_array_handle h0;
size_t i0, i0end; size_t i0;
ssize_t inc0; ssize_t inc0;
scm_array_get_handle (SCM_I_ARRAY_V (ra0), &h0); scm_array_get_handle (SCM_I_ARRAY_V (ra0), &h0);
i0 = SCM_I_ARRAY_BASE (ra0); i0 = SCM_I_ARRAY_BASE (ra0);
inc0 = SCM_I_ARRAY_DIMS (ra0)->inc; inc0 = SCM_I_ARRAY_DIMS (ra0)->inc;
i0end = i0 + n*inc0;
if (scm_is_null (ras)) if (scm_is_null (ras))
for (; i0 < i0end; i0 += inc0) for (; n--; i0 += inc0)
scm_call_1 (proc, h0.vref (h0.vector, i0)); scm_call_1 (proc, h0.vref (h0.vector, i0));
else else
{ {
ras = scm_vector (ras); ras = scm_vector (ras);
for (; i0 < i0end; i0 += inc0, ++i) for (; n--; i0 += inc0, ++i)
{ {
SCM args = SCM_EOL; SCM args = SCM_EOL;
unsigned long k; unsigned long k;

102
test-suite/tests/ramap.test
View file

@ -103,6 +103,32 @@
(array-copy! a b) (array-copy! a b)
(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))))
(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" (pass-if "rank 2"
(let ((a #2((1 2) (3 4))) (let ((a #2((1 2) (3 4)))
(b (make-array 0 2 2)) (b (make-array 0 2 2))
@ -119,22 +145,23 @@
(equal? d #2((1 3) (2 4))) (equal? d #2((1 3) (2 4)))
(equal? e #2((1 2) (3 4)))))) (equal? e #2((1 2) (3 4))))))
(pass-if "rank 1" (pass-if "rank 2, discontinuous"
(let* ((a #2((1 2) (3 4))) (let ((A #2((0 1) (2 3) (4 5)))
(b (make-shared-array a (lambda (j) (list 1 j)) 2)) (B #2((10 11) (12 13) (14 15)))
(c (make-shared-array a (lambda (i) (list (- 1 i) 1)) 2)) (C #2((20) (21) (22)))
(d (make-array 0 2)) (X (make-array 0 3 5))
(e (make-array 0 2))) (piece (lambda (X w s)
(array-copy! b d) (make-shared-array
(array-copy! c e) X (lambda (i j) (list i (+ j s))) 3 w))))
(and (equal? d #(3 4)) (array-copy! A (piece X 2 0))
(equal? e #(4 2))))) (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 "rank 0" (pass-if "null increments, not empty"
(let ((a #0(99)) (let ((a (make-array 0 2 2)))
(b (make-array 0))) (array-copy! (make-shared-array #0(1) (lambda x '()) 2 2) a)
(array-copy! a b) (array-equal? #2((1 1) (1 1))))))
(equal? b #0(99)))))
;;; ;;;
;;; array-map! ;;; array-map!
@ -235,7 +262,31 @@
(pass-if "1+" (pass-if "1+"
(let ((a (make-array #f 5))) (let ((a (make-array #f 5)))
(array-map! a 1+ (make-array 123 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" (with-test-prefix "two sources"
@ -337,7 +388,16 @@
(let ((a #(1 2 3)) (let ((a #(1 2 3))
(b (make-array 0 2))) (b (make-array 0 2)))
(array-map! b values a) (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 ;;; array-for-each
@ -346,6 +406,14 @@
(with-test-prefix "array-for-each" (with-test-prefix "array-for-each"
(with-test-prefix "1 source" (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" (pass-if-equal "noncompact array"
'(3 2 1 0) '(3 2 1 0)
(let* ((a #2((0 1) (2 3))) (let* ((a #2((0 1) (2 3)))