diff options
-rw-r--r-- | doc/ref/api-compound.texi | 34 | ||||
-rw-r--r-- | libguile/array-map.c | 244 | ||||
-rw-r--r-- | libguile/array-map.h | 3 | ||||
-rw-r--r-- | libguile/arrays.c | 228 | ||||
-rw-r--r-- | libguile/arrays.h | 2 | ||||
-rw-r--r-- | test-suite/Makefile.am | 2 | ||||
-rw-r--r-- | test-suite/tests/array-map.test (renamed from test-suite/tests/ramap.test) | 23 |
7 files changed, 283 insertions, 253 deletions
diff --git a/doc/ref/api-compound.texi b/doc/ref/api-compound.texi index 34a832fa1..ef4869cc1 100644 --- a/doc/ref/api-compound.texi +++ b/doc/ref/api-compound.texi @@ -1795,14 +1795,12 @@ of @var{idxlist} is shorter than @math{n}, then return the shared For example: -@example @lisp (array-from #2((a b) (c d)) 0) @result{} #(a b) (array-from #2((a b) (c d)) 1) @result{} #(c d) (array-from #2((a b) (c d)) 1 1) @result{} d (array-from #2((a b) (c d))) @result{} #2((a b) (c d)) @end lisp -@end example @code{(apply array-from array indices)} is equivalent to @@ -1827,7 +1825,6 @@ write into. Compare: -@example @lisp (array-from #2((a b) (c d)) 1 1) @result{} d (array-from* #2((a b) (c d)) 1) @result{} #0(d) @@ -1836,7 +1833,6 @@ Compare: a @result{} #2((a a) (a b)). (array-fill! (array-from a 1 1) 'b) @result{} error: not an array @end lisp -@end example @code{(apply array-from* array indices)} is equivalent to @@ -1863,12 +1859,19 @@ This function returns the modified @var{array}. For example: -@example @lisp (array-amend! (make-array 'a 2 2) b 1 1) @result{} #2((a a) (a b)) (array-amend! (make-array 'a 2 2) #(x y) 1) @result{} #2((a a) (x y)) @end lisp -@end example + +Note that @code{array-amend!} will expect elements, not arrays, when the +destination has rank 0. One can work around this using +@code{array-from*} instead. + +@lisp +(array-amend! (make-array 'a 2 2) #0(b) 1 1) @result{} #2((a a) (a #0(b))) +(let ((a (make-array 'a 2 2))) (array-copy! #0(b) (array-from* a 1 1)) a) @result{} #2((a a) (a b)) +@end lisp @code{(apply array-amend! array x indices)} is equivalent to @@ -1886,10 +1889,10 @@ The name `amend' comes from the J language. @deffn {Scheme Procedure} array-for-each-cell frame-rank op x @dots{} @deffnx {C Function} scm_array_for_each_cell (array, frame_rank, op, xlist) -Each @var{x} must be an array of rank @math{n_x} ≥ @var{frame-rank}, and +Each @var{x} must be an array of rank ≥ @var{frame-rank}, and the first @var{frame-rank} dimensions of each @var{x} must all be the same. @var{array-for-each-cell} calls @var{op} with each set of -(@math{n_x} - @var{frame-rank})-cells from @var{x}, in unspecified order. +(rank(@var{x}) - @var{frame-rank})-cells from @var{x}, in unspecified order. @var{array-for-each-cell} allows you to loop over cells of any rank without having to carry an index list or construct slices manually. The @@ -1898,26 +1901,20 @@ to write to them. This function returns an unspecified value. -For example: +For example, to sort the rows of rank-2 array @code{a}: -@example -Sort the rows of rank-2 array @code{a}: @lisp (array-for-each-cell 1 (lambda (x) (sort! x <)) a) @end lisp -@end example -@example -Let @code{a} be a rank-2 array where each row is a 2-vector @math{x, -y}. Compute the norms of these vectors and store them in rank-1 array -@code{b}: +As another example, let @code{a} be a rank-2 array where each row is a 2-vector @math{(x,y)}. +Let's compute the arguments of these vectors and store them in rank-1 array @code{b}. @lisp (array-for-each-cell 1 (lambda (a b) - (array-set! b (hypot (array-ref a 0) (array-ref a 1)))) + (array-set! b (atan (array-ref a 1) (array-ref a 0)))) a b) @end lisp -@end example @code{(apply array-for-each-cell frame-rank op x)} is functionally equivalent to @@ -1933,7 +1930,6 @@ equivalent to (lambda i (apply op (map (lambda (x) (apply array-from* x i)) x))))) @end lisp -The name `amend' comes from the J language. @end deffn diff --git a/libguile/array-map.c b/libguile/array-map.c index f07fd0060..0bbc095d5 100644 --- a/libguile/array-map.c +++ b/libguile/array-map.c @@ -42,6 +42,8 @@ #include "libguile/validate.h" #include "libguile/array-map.h" + +#include <assert.h> /* The WHAT argument for `scm_gc_malloc ()' et al. */ @@ -624,7 +626,8 @@ SCM_DEFINE (scm_i_array_equal_p, "array-equal?", 0, 2, 1, return SCM_BOOL_T; while (!scm_is_null (rest)) - { if (scm_is_false (scm_array_equal_p (ra0, ra1))) + { + if (scm_is_false (scm_array_equal_p (ra0, ra1))) return SCM_BOOL_F; ra0 = ra1; ra1 = scm_car (rest); @@ -635,6 +638,244 @@ SCM_DEFINE (scm_i_array_equal_p, "array-equal?", 0, 2, 1, #undef FUNC_NAME +// Copy array descriptor with different base. +SCM +scm_i_array_rebase (SCM a, size_t base) +{ + size_t ndim = SCM_I_ARRAY_NDIM (a); + SCM b = scm_words (((scm_t_bits) ndim << 17) + scm_tc7_array, 3 + ndim*3); + SCM_I_ARRAY_SET_V (b, SCM_I_ARRAY_V (a)); +// FIXME do check base + SCM_I_ARRAY_SET_BASE (b, base); + memcpy (SCM_I_ARRAY_DIMS (b), SCM_I_ARRAY_DIMS (a), sizeof (scm_t_array_dim)*ndim); + return b; +} + +SCM_DEFINE (scm_array_for_each_cell, "array-for-each-cell", 2, 0, 1, + (SCM frame_rank, SCM op, SCM args), + "Apply @var{op} to each of the cells of rank rank(@var{arg})-@var{frame_rank}\n" + "of the arrays @var{args}, in unspecified order. The first\n" + "@var{frame_rank} dimensions of each @var{arg} must match.\n" + "Rank-0 cells are passed as rank-0 arrays.\n\n" + "The value returned is unspecified.\n\n" + "For example:\n" + "@lisp\n" + ";; Sort the rows of rank-2 array A.\n\n" + "(array-for-each-cell 1 (lambda (x) (sort! x <)) a)\n" + "\n" + ";; Compute the arguments of the (x y) vectors in the rows of rank-2\n" + ";; array XYS and store them in rank-1 array ANGLES. Inside OP,\n" + ";; XY is a rank-1 (2-1) array, and ANGLE is a rank-0 (1-1) array.\n\n" + "(array-for-each-cell 1 \n" + " (lambda (xy angle)\n" + " (array-set! angle (atan (array-ref xy 1) (array-ref xy 0))))\n" + " xys angles)\n" + "@end lisp") +#define FUNC_NAME s_scm_array_for_each_cell +{ + int const N = scm_ilength (args); + int const frank = scm_to_int (frame_rank); + + // wish C had better stack support + + size_t stack_size = 0; + stack_size += N*sizeof (scm_t_array_handle); + stack_size += N*sizeof (SCM); + stack_size += N*sizeof (scm_t_array_dim *); + stack_size += N*sizeof (int); + stack_size += frank*sizeof (ssize_t); + + stack_size += N*sizeof (SCM); + stack_size += N*sizeof (SCM *); + stack_size += frank*sizeof (ssize_t); + stack_size += frank*sizeof (int); + + stack_size += N*sizeof (size_t); + char * stack = scm_gc_malloc_pointerless (stack_size, "stack"); + +#define AFIC_ALLOC_ADVANCE(stack, count, type, name) \ + type * name = (void *)stack; \ + stack += count*sizeof (type); + + char * stack0 = stack; + AFIC_ALLOC_ADVANCE (stack, N, scm_t_array_handle, ah); + AFIC_ALLOC_ADVANCE (stack, N, SCM, args_); + AFIC_ALLOC_ADVANCE (stack, N, scm_t_array_dim *, as); + AFIC_ALLOC_ADVANCE (stack, N, int, rank); + AFIC_ALLOC_ADVANCE (stack, frank, ssize_t, s); + + AFIC_ALLOC_ADVANCE (stack, N, SCM, ai); + AFIC_ALLOC_ADVANCE (stack, N, SCM *, dargs); + AFIC_ALLOC_ADVANCE (stack, frank, ssize_t, i); + AFIC_ALLOC_ADVANCE (stack, frank, int, order); + + AFIC_ALLOC_ADVANCE(stack, N, size_t, base); + assert((stack0+stack_size==stack) && "internal error"); +#undef AFIC_ALLOC_ADVANCE + + for (int n=0; scm_is_pair(args); args=scm_cdr(args), ++n) + { + args_[n] = scm_car(args); + scm_array_get_handle(args_[n], ah+n); + as[n] = scm_array_handle_dims(ah+n); + rank[n] = scm_array_handle_rank(ah+n); + } + // checks. + char const * msg = NULL; + if (frank<0) + { + msg = "bad frame rank"; + } else + { + for (int n=0; n!=N; ++n) { + if (rank[n]<frank) { + msg = "frame too large for arguments"; + goto check_msg; + } + for (int k=0; k!=frank; ++k) { + if (as[n][k].lbnd!=0) { + msg = "non-zero base index is not supported"; + goto check_msg; + } + if (as[0][k].ubnd!=as[n][k].ubnd) { + msg = "mismatched frames"; + goto check_msg; + } + s[k] = as[n][k].ubnd + 1; + } + } + } + check_msg: ; + if (msg!=NULL) + { + for (int n=0; n!=N; ++n) { + scm_array_handle_release(ah+n); + } + scm_misc_error("array-for-each-cell", msg, scm_cons_star(frame_rank, args)); + } + // prepare moving cells. + scm_t_array_dim * ais[N]; + for (int n=0; n!=N; ++n) + { + ai[n] = scm_i_make_array(rank[n]-frank); + SCM_I_ARRAY_SET_V (ai[n], scm_shared_array_root(args_[n])); + // FIXME scm_array_handle_base (ah+n) should be in Guile + SCM_I_ARRAY_SET_BASE (ai[n], ah[n].base); + ais[n] = SCM_I_ARRAY_DIMS(ai[n]); + for (int k=frank; k!=rank[n]; ++k) { + ais[n][k-frank] = as[n][k]; + } + } + // prepare rest list for callee. + SCM dargs_ = SCM_EOL; + { + SCM *p = &dargs_; + for (int n=0; n<N; ++n) { + *p = scm_cons (SCM_UNSPECIFIED, SCM_EOL); + dargs[n] = SCM_CARLOC (*p); + p = SCM_CDRLOC (*p); + } + } + // special case for rank 0. + if (frank==0) + { + for (int n=0; n<N; ++n) + { + *dargs[n] = ai[n]; + } + scm_apply_0(op, dargs_); + for (int n=0; n<N; ++n) + { + scm_array_handle_release(ah+n); + } + return SCM_UNSPECIFIED; + } + // FIXME determine best looping order. + for (int k=0; k!=frank; ++k) + { + i[k] = 0; + order[k] = frank-1-k; + } + // find outermost compact dim. + ssize_t step = s[order[0]]; + int ocd = 1; + for (; ocd<frank; step *= s[order[ocd]], ++ocd) + { + for (int n=0; n!=N; ++n) { + if (step*as[n][order[0]].inc!=as[n][order[ocd]].inc) { + goto ocd_reached; + } + } + } + ocd_reached: ; + // rank loop. + for (int n=0; n!=N; ++n) + { + base[n] = SCM_I_ARRAY_BASE(ai[n]); + } + for (;;) + { + for (ssize_t z=0; z!=step; ++z) + { + // we are forced to create fresh array descriptors for each + // call since we don't know whether the callee will keep them, + // and Guile offers no way to copy the descriptor (since + // descriptors are immutable). Yet another reason why this + // should be in Scheme. + for (int n=0; n<N; ++n) + { + *dargs[n] = scm_i_array_rebase(ai[n], base[n]); + base[n] += as[n][order[0]].inc; + } + scm_apply_0(op, dargs_); + } + for (int n=0; n<N; ++n) + { + base[n] -= step*as[n][order[0]].inc; + } + for (int k=ocd; ; ++k) + { + if (k==frank) + { + goto end; + } else if (i[order[k]]<s[order[k]]-1) + { + ++i[order[k]]; + for (int n=0; n<N; ++n) + { + base[n] += as[n][order[k]].inc; + } + break; + } else { + i[order[k]] = 0; + for (int n=0; n<N; ++n) + { + base[n] += as[n][order[k]].inc*(1-s[order[k]]); + } + } + } + } + end:; + for (int n=0; n<N; ++n) + { + scm_array_handle_release(ah+n); + } + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_array_for_each_cell_in_order, "array-for-each-cell-in-order", 2, 0, 1, + (SCM frank, SCM op, SCM a), + "Same as array-for-each-cell, but visit the cells sequentially\n" + "and in row-major order.\n") +#define FUNC_NAME s_scm_array_for_each_cell_in_order +{ + return scm_array_for_each_cell (frank, op, a); +} +#undef FUNC_NAME + + void scm_init_array_map (void) { @@ -642,6 +883,7 @@ scm_init_array_map (void) scm_add_feature (s_scm_array_for_each); } + /* Local Variables: c-file-style: "gnu" diff --git a/libguile/array-map.h b/libguile/array-map.h index cb18a628a..8f2458995 100644 --- a/libguile/array-map.h +++ b/libguile/array-map.h @@ -37,6 +37,9 @@ SCM_API SCM scm_array_map_x (SCM ra0, SCM proc, SCM lra); SCM_API SCM scm_array_for_each (SCM proc, SCM ra0, SCM lra); SCM_API SCM scm_array_index_map_x (SCM ra, SCM proc); SCM_API SCM scm_array_equal_p (SCM ra0, SCM ra1); +SCM_API SCM scm_array_for_each_cell (SCM frank, SCM op, SCM args); +SCM_API SCM scm_array_for_each_cell_in_order (SCM frank, SCM op, SCM args); + SCM_INTERNAL void scm_init_array_map (void); #endif /* SCM_ARRAY_MAP_H */ diff --git a/libguile/arrays.c b/libguile/arrays.c index 292d80ef6..d360cda3c 100644 --- a/libguile/arrays.c +++ b/libguile/arrays.c @@ -28,7 +28,6 @@ #include <stdio.h> #include <errno.h> #include <string.h> -#include <assert.h> #include "verify.h" @@ -568,233 +567,6 @@ SCM_DEFINE (scm_array_amend_x, "array-amend!", 2, 0, 1, #undef ARRAY_FROM_GET_O -// Copy array descriptor with different base. -SCM -scm_i_array_rebase (SCM a, size_t base) -{ - size_t ndim = SCM_I_ARRAY_NDIM(a); - SCM b = scm_words (((scm_t_bits) ndim << 17) + scm_tc7_array, 3 + ndim*3); - SCM_I_ARRAY_SET_V (b, SCM_I_ARRAY_V (a)); -// FIXME do check base - SCM_I_ARRAY_SET_BASE (b, base); - memcpy(SCM_I_ARRAY_DIMS(b), SCM_I_ARRAY_DIMS(a), sizeof(scm_t_array_dim)*ndim); - return b; -} - -SCM_DEFINE (scm_array_for_each_cell, "array-for-each-cell", 2, 0, 1, - (SCM frank_, SCM op, SCM a_), - "Apply op to each of the rank (-frank) cells of the arguments,\n" - "in unspecified order. The first frank dimensions of the\n" - "arguments must match. Rank-0 cells are passed as such.\n\n" - "The value returned is unspecified.\n\n" - "For example:\n" - "@lisp\n" - "@end lisp") -#define FUNC_NAME s_scm_array_for_each_cell -{ - int const N = scm_ilength (a_); - int const frank = scm_to_int (frank_); - - // wish C had better stack support - - size_t stack_size = 0; - stack_size += N*sizeof (scm_t_array_handle); - stack_size += N*sizeof (SCM); - stack_size += N*sizeof (scm_t_array_dim *); - stack_size += N*sizeof (int); - stack_size += frank*sizeof (ssize_t); - - stack_size += N*sizeof (SCM); - stack_size += N*sizeof (SCM *); - stack_size += frank*sizeof (ssize_t); - stack_size += frank*sizeof (int); - - stack_size += N*sizeof(size_t); - char * stack = scm_gc_malloc_pointerless (stack_size, "stack"); - -#define AFIC_ALLOC_ADVANCE(stack, count, type, name) \ - type * name = (void *)stack; \ - stack += count*sizeof(type); - - char * stack0 = stack; - AFIC_ALLOC_ADVANCE (stack, N, scm_t_array_handle, ah); - AFIC_ALLOC_ADVANCE (stack, N, SCM, a); - AFIC_ALLOC_ADVANCE (stack, N, scm_t_array_dim *, as); - AFIC_ALLOC_ADVANCE (stack, N, int, rank); - AFIC_ALLOC_ADVANCE (stack, frank, ssize_t, s); - - AFIC_ALLOC_ADVANCE (stack, N, SCM, ai); - AFIC_ALLOC_ADVANCE (stack, N, SCM *, dargs); - AFIC_ALLOC_ADVANCE (stack, frank, ssize_t, i); - AFIC_ALLOC_ADVANCE (stack, frank, int, order); - - AFIC_ALLOC_ADVANCE(stack, N, size_t, base); - assert((stack0+stack_size==stack) && "internal error"); -#undef AFIC_ALLOC_ADVANCE - - for (int n=0; scm_is_pair(a_); a_=scm_cdr(a_), ++n) - { - a[n] = scm_car(a_); - scm_array_get_handle(a[n], ah+n); - as[n] = scm_array_handle_dims(ah+n); - rank[n] = scm_array_handle_rank(ah+n); - } - // checks. - char const * msg = NULL; - if (frank<0) - { - msg = "bad frame rank"; - } else - { - for (int n=0; n!=N; ++n) { - if (rank[n]<frank) { - msg = "frame too large for arguments"; - goto check_msg; - } - for (int k=0; k!=frank; ++k) { - if (as[n][k].lbnd!=0) { - msg = "non-zero base index is not supported"; - goto check_msg; - } - if (as[0][k].ubnd!=as[n][k].ubnd) { - msg = "mismatched frames"; - goto check_msg; - } - s[k] = as[n][k].ubnd + 1; - } - } - } - check_msg: ; - if (msg!=NULL) - { - for (int n=0; n!=N; ++n) { - scm_array_handle_release(ah+n); - } - scm_misc_error("array-for-each-cell", msg, scm_cons_star(frank_, a_)); - } - // prepare moving cells. - scm_t_array_dim * ais[N]; - for (int n=0; n!=N; ++n) - { - ai[n] = scm_i_make_array(rank[n]-frank); - SCM_I_ARRAY_SET_V (ai[n], scm_shared_array_root(a[n])); - // FIXME scm_array_handle_base (ah+n) should be in Guile - SCM_I_ARRAY_SET_BASE (ai[n], ah[n].base); - ais[n] = SCM_I_ARRAY_DIMS(ai[n]); - for (int k=frank; k!=rank[n]; ++k) { - ais[n][k-frank] = as[n][k]; - } - } - // prepare rest list for callee. - SCM dargs_ = SCM_EOL; - { - SCM *p = &dargs_; - for (int n=0; n<N; ++n) { - *p = scm_cons (SCM_UNSPECIFIED, SCM_EOL); - dargs[n] = SCM_CARLOC (*p); - p = SCM_CDRLOC (*p); - } - } - // special case for rank 0. - if (frank==0) - { - for (int n=0; n<N; ++n) - { - *dargs[n] = ai[n]; - } - scm_apply_0(op, dargs_); - for (int n=0; n<N; ++n) - { - scm_array_handle_release(ah+n); - } - return SCM_UNSPECIFIED; - } - // FIXME determine best looping order. - for (int k=0; k!=frank; ++k) - { - i[k] = 0; - order[k] = frank-1-k; - } - // find outermost compact dim. - ssize_t step = s[order[0]]; - int ocd = 1; - for (; ocd<frank; step *= s[order[ocd]], ++ocd) - { - for (int n=0; n!=N; ++n) { - if (step*as[n][order[0]].inc!=as[n][order[ocd]].inc) { - goto ocd_reached; - } - } - } - ocd_reached: ; - // rank loop. - for (int n=0; n!=N; ++n) - { - base[n] = SCM_I_ARRAY_BASE(ai[n]); - } - for (;;) - { - for (ssize_t z=0; z!=step; ++z) - { - // we are forced to create fresh array descriptors for each - // call since we don't know whether the callee will keep them, - // and Guile offers no way to copy the descriptor (since - // descriptors are immutable). Yet another reason why this - // should be in Scheme. - for (int n=0; n<N; ++n) - { - *dargs[n] = scm_i_array_rebase(ai[n], base[n]); - base[n] += as[n][order[0]].inc; - } - scm_apply_0(op, dargs_); - } - for (int n=0; n<N; ++n) - { - base[n] -= step*as[n][order[0]].inc; - } - for (int k=ocd; ; ++k) - { - if (k==frank) - { - goto end; - } else if (i[order[k]]<s[order[k]]-1) - { - ++i[order[k]]; - for (int n=0; n<N; ++n) - { - base[n] += as[n][order[k]].inc; - } - break; - } else { - i[order[k]] = 0; - for (int n=0; n<N; ++n) - { - base[n] += as[n][order[k]].inc*(1-s[order[k]]); - } - } - } - } - end:; - for (int n=0; n<N; ++n) - { - scm_array_handle_release(ah+n); - } - return SCM_UNSPECIFIED; -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_array_for_each_cell_in_order, "array-for-each-cell-in-order", 2, 0, 1, - (SCM frank_, SCM op, SCM a_), - "Same as array-for-each-cell, but visit the cells sequentially\n" - "and in row-major order.\n") -#define FUNC_NAME s_scm_array_for_each_cell_in_order -{ - return scm_array_for_each_cell (frank_, op, a_); -} -#undef FUNC_NAME - - /* args are RA . DIMS */ SCM_DEFINE (scm_transpose_array, "transpose-array", 1, 0, 1, (SCM ra, SCM args), diff --git a/libguile/arrays.h b/libguile/arrays.h index b43e93c29..890a902fe 100644 --- a/libguile/arrays.h +++ b/libguile/arrays.h @@ -52,8 +52,6 @@ SCM_API SCM scm_array_contents (SCM ra, SCM strict); SCM_API SCM scm_array_from_s (SCM ra, SCM indices); SCM_API SCM scm_array_from (SCM ra, SCM indices); SCM_API SCM scm_array_amend_x (SCM ra, SCM b, SCM indices); -SCM_API SCM scm_array_for_each_cell (SCM frank, SCM op, SCM args); -SCM_API SCM scm_array_for_each_cell_in_order (SCM frank, SCM op, SCM args); SCM_API SCM scm_list_to_array (SCM ndim, SCM lst); SCM_API SCM scm_list_to_typed_array (SCM type, SCM ndim, SCM lst); diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am index 473501ee2..49584b957 100644 --- a/test-suite/Makefile.am +++ b/test-suite/Makefile.am @@ -115,7 +115,7 @@ SCM_TESTS = tests/00-initial-env.test \ tests/r6rs-records-syntactic.test \ tests/r6rs-unicode.test \ tests/rnrs-libraries.test \ - tests/ramap.test \ + tests/array-map.test \ tests/random.test \ tests/rdelim.test \ tests/reader.test \ diff --git a/test-suite/tests/ramap.test b/test-suite/tests/array-map.test index d8241ef17..f5487babc 100644 --- a/test-suite/tests/ramap.test +++ b/test-suite/tests/array-map.test @@ -1,4 +1,4 @@ -;;;; ramap.test --- test array mapping functions -*- scheme -*- +;;;; array-map.test --- test array mapping functions -*- scheme -*- ;;;; ;;;; Copyright (C) 2004, 2005, 2006, 2009, 2013 Free Software Foundation, Inc. ;;;; @@ -16,7 +16,7 @@ ;;;; License along with this library; if not, write to the Free Software ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA -(define-module (test-suite test-ramap) +(define-module (test-suite test-array-map) #:use-module (test-suite lib)) (define exception:shape-mismatch @@ -507,3 +507,22 @@ (b (make-typed-array 'f64 0 0 2)) (c (make-typed-array 'f64 0 2 0))) (array-for-each (lambda (b c) (set! a (cons* b c a))) b c))))) + +;;; +;;; array-for-each-cell +;;; + +(with-test-prefix "array-for-each-cell" + + (pass-if-equal "1 argument frame rank 1" + #2((1 3 9) (2 7 8)) + (let* ((a (list->array 2 '((9 1 3) (7 8 2))))) + (array-for-each-cell 1 (lambda (a) (sort! a <)) a) + a)) + + (pass-if-equal "2 arguments frame rank 1" + #f64(8 -1) + (let* ((x (list->typed-array 'f64 2 '((9 1) (7 8)))) + (y (f64vector 99 99))) + (array-for-each-cell 1 (lambda (y x) (array-set! y (- (array-ref x 0) (array-ref x 1)))) y x) + y))) |