From a5bb9da6ea3f69a0e03329b94dcb3bf1c3315ed5 Mon Sep 17 00:00:00 2001
From: Daniel Llorens <daniel.llorens@bluewin.ch>
Date: Tue, 8 Sep 2015 16:57:30 +0200
Subject: New functions (array-for-each-cell, array-for-each-cell-in-order)

* libguile/array-map.c (scm_i_array_rebase, scm_array_for_each_cell):
  New functions. Export scm_array_for_each_cell() as
  (array-for-each-cell).

  (array-for-each-cell-in-order): Define additional export.

* libguile/array-map.h (scm_i_array_rebase, scm_array_for_each_cell):
  Add prototypes.

* doc/ref/api-compound.texi: New section 'Arrays as arrays of
  arrays'. Move the documentation for (array-from), (array-from*) and
  (array-amend!) in here. Add documentation for (array-for-each-cell).

* test-suite/tests/array-map.test: Renamed from
  test-suite/tests/ramap.test, fix module name. Add tests for
  (array-for-each-cell).

* test-suite/Makefile.am: Apply rename array-map.test -> ramap.test.

* doc/ref/api-compound.texi: Minor documentation fixes.
---
 doc/ref/api-compound.texi       | 169 +++++++++----
 libguile/array-map.c            | 260 ++++++++++++++++++-
 libguile/array-map.h            |   4 +
 libguile/arrays.c               |   5 +-
 test-suite/Makefile.am          |   2 +-
 test-suite/tests/array-map.test | 540 ++++++++++++++++++++++++++++++++++++++++
 test-suite/tests/ramap.test     | 509 -------------------------------------
 7 files changed, 923 insertions(+), 566 deletions(-)
 create mode 100644 test-suite/tests/array-map.test
 delete mode 100644 test-suite/tests/ramap.test

diff --git a/doc/ref/api-compound.texi b/doc/ref/api-compound.texi
index 6d1e118b6..936b4956c 100644
--- a/doc/ref/api-compound.texi
+++ b/doc/ref/api-compound.texi
@@ -1203,6 +1203,7 @@ dimensional arrays.
 * Array Syntax::                
 * Array Procedures::            
 * Shared Arrays::               
+* Arrays as arrays of arrays::
 * Accessing Arrays from C::     
 @end menu
 
@@ -1682,24 +1683,91 @@ sample points are enough because @var{mapfunc} is linear.
 Return the element at @code{(idx @dots{})} in @var{array}.
 @end deffn
 
+
+@deffn {Scheme Procedure} shared-array-increments array
+@deffnx {C Function} scm_shared_array_increments (array)
+For each dimension, return the distance between elements in the root vector.
+@end deffn
+
+@deffn {Scheme Procedure} shared-array-offset array
+@deffnx {C Function} scm_shared_array_offset (array)
+Return the root vector index of the first element in the array.
+@end deffn
+
+@deffn {Scheme Procedure} shared-array-root array
+@deffnx {C Function} scm_shared_array_root (array)
+Return the root vector of a shared array.
+@end deffn
+
+@deffn {Scheme Procedure} array-contents array [strict]
+@deffnx {C Function} scm_array_contents (array, strict)
+If @var{array} may be @dfn{unrolled} into a one dimensional shared array
+without changing their order (last subscript changing fastest), then
+@code{array-contents} returns that shared array, otherwise it returns
+@code{#f}.  All arrays made by @code{make-array} and
+@code{make-typed-array} may be unrolled, some arrays made by
+@code{make-shared-array} may not be.
+
+If the optional argument @var{strict} is provided, a shared array will
+be returned only if its elements are stored internally contiguous in
+memory.
+@end deffn
+
+@deffn {Scheme Procedure} transpose-array array dim1 dim2 @dots{}
+@deffnx {C Function} scm_transpose_array (array, dimlist)
+Return an array sharing contents with @var{array}, but with
+dimensions arranged in a different order.  There must be one
+@var{dim} argument for each dimension of @var{array}.
+@var{dim1}, @var{dim2}, @dots{} should be integers between 0
+and the rank of the array to be returned.  Each integer in that
+range must appear at least once in the argument list.
+
+The values of @var{dim1}, @var{dim2}, @dots{} correspond to
+dimensions in the array to be returned, and their positions in the
+argument list to dimensions of @var{array}.  Several @var{dim}s
+may have the same value, in which case the returned array will
+have smaller rank than @var{array}.
+
+@lisp
+(transpose-array '#2((a b) (c d)) 1 0) @result{} #2((a c) (b d))
+(transpose-array '#2((a b) (c d)) 0 0) @result{} #1(a d)
+(transpose-array '#3(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1 1 0) @result{}
+                #2((a 4) (b 5) (c 6))
+@end lisp
+@end deffn
+
+@node Arrays as arrays of arrays
+@subsubsection Arrays as arrays of arrays
+
+The functions in this section allow you to treat an array of rank
+@math{n} as an array of lower rank @math{n-k} where the elements are
+themselves arrays (`cells') of rank @math{k}. This replicates some of
+the functionality of `enclosed arrays', a feature of old Guile that was
+removed before @w{version 2.0}. However, these functions do not require
+a special type and operate on any array.
+
+When we operate on an array in this way, we speak of the first @math{k}
+dimensions of the array as the @math{k}-`frame' of the array, while the
+last @math{n-k} dimensions are the dimensions of the
+@math{n-k}-`cell'. For example, a 2D-array (a matrix) can be seen as a
+1D array of rows. In this case, the rows are the 1-cells of the array.
+
 @deffn {Scheme Procedure} array-from array idx @dots{}
 @deffnx {C Function} scm_array_from (array, idxlist)
 If the length of @var{idxlist} equals the rank @math{n} of
 @var{array}, return the element at @code{(idx @dots{})}, just like
 @code{(array-ref array idx @dots{})}. If, however, the length @math{k}
 of @var{idxlist} is shorter than @math{n}, then return the shared
-@math{(n-k)}-rank prefix cell of @var{array} given by @var{idxlist}.
+@math{(n-k)}-rank cell of @var{array} given by @var{idxlist}.
 
 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
 
@@ -1719,12 +1787,11 @@ The name `from' comes from the J language.
 @deffnx {C Function} scm_array_from_s (array, idxlist)
 Like @code{(array-from array idx @dots{})}, but return a 0-rank shared
 array if the length of @var{idxlist} matches the rank of
-@var{array}. This can be useful when using @var{ARRAY} as destination
-of copies.
+@var{array}. This can be useful when using @var{ARRAY} as a place to
+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)
@@ -1733,7 +1800,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
 
@@ -1752,7 +1818,7 @@ If the length of @var{idxlist} equals the rank @math{n} of
 @var{x}, just like @code{(array-set! array x idx @dots{})}. If,
 however, the length @math{k} of @var{idxlist} is shorter than
 @math{n}, then copy the @math{(n-k)}-rank array @var{x}
-into @math{(n-k)}-rank prefix cell of @var{array} given by
+into the @math{(n-k)}-cell of @var{array} given by
 @var{idxlist}. In this case, the last @math{(n-k)} dimensions of
 @var{array} and the dimensions of @var{x} must match exactly.
 
@@ -1760,12 +1826,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
 
@@ -1781,58 +1854,52 @@ The name `amend' comes from the J language.
 @end deffn
 
 
-@deffn {Scheme Procedure} shared-array-increments array
-@deffnx {C Function} scm_shared_array_increments (array)
-For each dimension, return the distance between elements in the root vector.
-@end deffn
+@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 ≥ @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
+(rank(@var{x}) - @var{frame-rank})-cells from @var{x}, in unspecified order.
 
-@deffn {Scheme Procedure} shared-array-offset array
-@deffnx {C Function} scm_shared_array_offset (array)
-Return the root vector index of the first element in the array.
-@end deffn
+@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
+cells passed to @var{op} are shared arrays of @var{X} so it is possible
+to write to them.
 
-@deffn {Scheme Procedure} shared-array-root array
-@deffnx {C Function} scm_shared_array_root (array)
-Return the root vector of a shared array.
-@end deffn
+This function returns an unspecified value.
 
-@deffn {Scheme Procedure} array-contents array [strict]
-@deffnx {C Function} scm_array_contents (array, strict)
-If @var{array} may be @dfn{unrolled} into a one dimensional shared array
-without changing their order (last subscript changing fastest), then
-@code{array-contents} returns that shared array, otherwise it returns
-@code{#f}.  All arrays made by @code{make-array} and
-@code{make-typed-array} may be unrolled, some arrays made by
-@code{make-shared-array} may not be.
+For example, to sort the rows of rank-2 array @code{a}:
 
-If the optional argument @var{strict} is provided, a shared array will
-be returned only if its elements are stored internally contiguous in
-memory.
-@end deffn
+@lisp
+(array-for-each-cell 1 (lambda (x) (sort! x <)) a)
+@end lisp
 
-@deffn {Scheme Procedure} transpose-array array dim1 dim2 @dots{}
-@deffnx {C Function} scm_transpose_array (array, dimlist)
-Return an array sharing contents with @var{array}, but with
-dimensions arranged in a different order.  There must be one
-@var{dim} argument for each dimension of @var{array}.
-@var{dim1}, @var{dim2}, @dots{} should be integers between 0
-and the rank of the array to be returned.  Each integer in that
-range must appear at least once in the argument list.
+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 (atan (array-ref a 1) (array-ref a 0))))
+  a b)
+@end lisp
 
-The values of @var{dim1}, @var{dim2}, @dots{} correspond to
-dimensions in the array to be returned, and their positions in the
-argument list to dimensions of @var{array}.  Several @var{dim}s
-may have the same value, in which case the returned array will
-have smaller rank than @var{array}.
+@code{(apply array-for-each-cell frame-rank op x)} is functionally
+equivalent to
 
 @lisp
-(transpose-array '#2((a b) (c d)) 1 0) @result{} #2((a c) (b d))
-(transpose-array '#2((a b) (c d)) 0 0) @result{} #1(a d)
-(transpose-array '#3(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1 1 0) @result{}
-                #2((a 4) (b 5) (c 6))
+(let ((frame (take (array-dimensions (car x)) frank)))
+  (unless (every (lambda (x)
+                   (equal? frame (take (array-dimensions x) frank)))
+                 (cdr x))
+    (error))
+  (array-index-map!
+    (apply make-shared-array (make-array #t) (const '()) frame)
+    (lambda i (apply op (map (lambda (x) (apply array-from* x i)) x)))))
 @end lisp
+
 @end deffn
 
+
 @node Accessing Arrays from C
 @subsubsection Accessing Arrays from C
 
diff --git a/libguile/array-map.c b/libguile/array-map.c
index 01bebb83e..f907786fd 100644
--- a/libguile/array-map.c
+++ b/libguile/array-map.c
@@ -42,7 +42,7 @@
 
 #include "libguile/validate.h"
 #include "libguile/array-map.h"
-
+#include <assert.h>
 
 /* The WHAT argument for `scm_gc_malloc ()' et al.  */
 static const char vi_gc_hint[] = "array-indices";
@@ -629,7 +629,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);
@@ -640,6 +641,261 @@ 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;
+}
+
+static inline size_t padtoptr(size_t d) { return (d + (sizeof (void *) - 1)) & ~(sizeof (void *) - 1); }
+
+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);
+  int ocd;
+  ssize_t step;
+  SCM dargs_ = SCM_EOL;
+  char const * msg;
+  scm_t_array_dim * ais;
+  int n, k;
+  ssize_t z;
+
+  /* to be allocated inside the pool */
+  scm_t_array_handle * ah;
+  SCM * args_;
+  scm_t_array_dim ** as;
+  int * rank;
+
+  ssize_t * s;
+  SCM * ai;
+  SCM ** dargs;
+  ssize_t * i;
+
+  int * order;
+  size_t * base;
+
+  /* size the pool */
+  char * pool;
+  char * pool0;
+  size_t pool_size = 0;
+  pool_size += padtoptr(N*sizeof (scm_t_array_handle));
+  pool_size += padtoptr(N*sizeof (SCM));
+  pool_size += padtoptr(N*sizeof (scm_t_array_dim *));
+  pool_size += padtoptr(N*sizeof (int));
+
+  pool_size += padtoptr(frank*sizeof (ssize_t));
+  pool_size += padtoptr(N*sizeof (SCM));
+  pool_size += padtoptr(N*sizeof (SCM *));
+  pool_size += padtoptr(frank*sizeof (ssize_t));
+
+  pool_size += padtoptr(frank*sizeof (int));
+  pool_size += padtoptr(N*sizeof (size_t));
+  pool = scm_gc_malloc (pool_size, "pool");
+
+  /* place the items in the pool */
+#define AFIC_ALLOC_ADVANCE(pool, count, type, name)    \
+  name = (void *)pool;                                 \
+  pool += padtoptr(count*sizeof (type));
+
+  pool0 = pool;
+  AFIC_ALLOC_ADVANCE (pool, N, scm_t_array_handle, ah);
+  AFIC_ALLOC_ADVANCE (pool, N, SCM, args_);
+  AFIC_ALLOC_ADVANCE (pool, N, scm_t_array_dim *, as);
+  AFIC_ALLOC_ADVANCE (pool, N, int, rank);
+
+  AFIC_ALLOC_ADVANCE (pool, frank, ssize_t, s);
+  AFIC_ALLOC_ADVANCE (pool, N, SCM, ai);
+  AFIC_ALLOC_ADVANCE (pool, N, SCM *, dargs);
+  AFIC_ALLOC_ADVANCE (pool, frank, ssize_t, i);
+
+  AFIC_ALLOC_ADVANCE (pool, frank, int, order);
+  AFIC_ALLOC_ADVANCE (pool, N, size_t, base);
+  assert((pool0+pool_size==pool) && "internal error");
+#undef AFIC_ALLOC_ADVANCE
+
+  for (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 */
+  msg = NULL;
+  if (frank<0)
+    msg = "bad frame rank";
+  else
+    {
+      for (n=0; n!=N; ++n)
+        {
+          if (rank[n]<frank)
+            {
+              msg = "frame too large for arguments";
+              goto check_msg;
+            }
+          for (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;
+
+              /* this check is needed if the array cannot be entirely */
+              /* unrolled, because the unrolled subloop will be run before */
+              /* checking the dimensions of the frame. */
+              if (s[k]==0)
+                goto end;
+            }
+        }
+    }
+ check_msg: ;
+  if (msg!=NULL)
+    {
+      for (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. */
+  for (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 = SCM_I_ARRAY_DIMS(ai[n]);
+      for (k=frank; k!=rank[n]; ++k)
+        {
+          ais[k-frank] = as[n][k];
+        }
+    }
+  /* prepare rest list for callee. */
+  {
+    SCM *p = &dargs_;
+    for (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 (n=0; n<N; ++n)
+        *dargs[n] = ai[n];
+      scm_apply_0(op, dargs_);
+      for (n=0; n<N; ++n)
+        scm_array_handle_release(ah+n);
+      return SCM_UNSPECIFIED;
+    }
+  /* FIXME determine best looping order. */
+  for (k=0; k!=frank; ++k)
+    {
+      i[k] = 0;
+      order[k] = frank-1-k;
+    }
+  /* find outermost compact dim. */
+  step = s[order[0]];
+  ocd = 1;
+  for (; ocd<frank; step *= s[order[ocd]], ++ocd)
+    for (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 (n=0; n!=N; ++n)
+    base[n] = SCM_I_ARRAY_BASE(ai[n]);
+  for (;;)
+    {
+      /* unrolled loop. */
+      for (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 (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 (n=0; n<N; ++n)
+        base[n] -= step*as[n][order[0]].inc;
+      for (k=ocd; ; ++k)
+        {
+          if (k==frank)
+            goto end;
+          else if (i[order[k]]<s[order[k]]-1)
+            {
+              ++i[order[k]];
+              for (n=0; n<N; ++n)
+                base[n] += as[n][order[k]].inc;
+              break;
+            }
+          else
+            {
+              i[order[k]] = 0;
+              for (n=0; n<N; ++n)
+                base[n] += as[n][order[k]].inc*(1-s[order[k]]);
+            }
+        }
+    }
+ end:;
+  for (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)
 {
diff --git a/libguile/array-map.h b/libguile/array-map.h
index cb18a628a..acfdd5e24 100644
--- a/libguile/array-map.h
+++ b/libguile/array-map.h
@@ -37,6 +37,10 @@ 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 SCM scm_i_array_rebase (SCM a, size_t base);
 SCM_INTERNAL void scm_init_array_map (void);
 
 #endif  /* SCM_ARRAY_MAP_H */
diff --git a/libguile/arrays.c b/libguile/arrays.c
index 273c48b73..7622ea8ca 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"
 
@@ -551,7 +550,7 @@ SCM_DEFINE (scm_array_amend_x, "array-amend!", 2, 0, 1,
         { ARRAY_FROM_GET_O }
       scm_array_handle_release(&handle);
       /* an error is still possible here if o and b don't match. */
-      /* TODO copying like this wastes the handle, and the bounds matching
+      /* FIXME copying like this wastes the handle, and the bounds matching
          behavior of array-copy! is not strict. */
       scm_array_copy_x(b, o);
     }
@@ -569,7 +568,6 @@ SCM_DEFINE (scm_array_amend_x, "array-amend!", 2, 0, 1,
 }
 #undef FUNC_NAME
 
-
 #undef ARRAY_FROM_POS
 #undef ARRAY_FROM_GET_O
 
@@ -948,6 +946,7 @@ scm_i_print_array (SCM array, SCM port, scm_print_state *pstate)
     return scm_i_print_array_dimension (&h, 0, 0, port, pstate);
 }
 
+
 void
 scm_init_arrays ()
 {
diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am
index f940d78c7..98cc5f026 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/array-map.test b/test-suite/tests/array-map.test
new file mode 100644
index 000000000..3095b78f4
--- /dev/null
+++ b/test-suite/tests/array-map.test
@@ -0,0 +1,540 @@
+;;;; array-map.test --- test array mapping functions -*- scheme -*-
+;;;; 
+;;;; Copyright (C) 2004, 2005, 2006, 2009, 2013 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 as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;; 
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;;; Lesser General Public License for more details.
+;;;; 
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; 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-array-map)
+  #:use-module (test-suite lib))
+
+(define exception:shape-mismatch
+  (cons 'misc-error ".*shape mismatch.*"))
+
+(define (array-row a i)
+  (make-shared-array a (lambda (j) (list i j))
+                       (cadr (array-dimensions a))))
+
+(define (array-col a j)
+  (make-shared-array a (lambda (i) (list i j))
+                       (car (array-dimensions a))))
+
+;;;
+;;; array-index-map!
+;;;
+
+(with-test-prefix "array-index-map!"
+
+  (pass-if "basic test"
+    (let ((nlst '()))
+      (array-index-map! (make-array #f '(1 1))
+                        (lambda (n)
+                          (set! nlst (cons n nlst))))
+      (equal? nlst '(1))))
+
+  (with-test-prefix "empty arrays"
+
+    (pass-if "all axes empty"
+      (array-index-map! (make-typed-array 'f64 0 0 0) (const 0))
+      (array-index-map! (make-typed-array 'b #t 0 0) (const #t))
+      (array-index-map! (make-typed-array #t 0 0 0) (const 0))
+      #t)
+
+    (pass-if "last axis empty"
+      (array-index-map! (make-typed-array 'f64 0 2 0) (const 0))
+      (array-index-map! (make-typed-array 'b #t 2 0) (const #t))
+      (array-index-map! (make-typed-array #t 0 2 0) (const 0))
+      #t)
+
+    ; the 'f64 cases fail in 2.0.9 with out-of-range.
+    (pass-if "axis empty, other than last"
+      (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))
+
+  (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!
+;;;
+
+(with-test-prefix "array-copy!"
+
+  (with-test-prefix "empty arrays"
+
+    (pass-if "empty other than last, #t"
+      (let* ((b (make-array 0 2 2))
+             (c (make-shared-array b (lambda (i j) (list i j)) 0 2)))
+        (array-copy! #2:0:2() c)
+        (array-equal? #2:0:2() c)))
+
+    (pass-if "empty other than last, 'f64"
+      (let* ((b (make-typed-array 'f64 0 2 2))
+             (c (make-shared-array b (lambda (i j) (list i j)) 0 2)))
+        (array-copy! #2:0:2() c)
+        (array-equal? #2f64:0:2() c)))
+
+  ;; FIXME add empty, type 'b cases.
+
+    )
+
+  ;; note that it is the opposite of array-map!. This is, unfortunately,
+  ;; documented in the manual.
+
+  (pass-if "matching behavior I"
+    (let ((a #(1 2))
+          (b (make-array 0 3)))
+      (array-copy! a b)
+      (equal? b #(1 2 0))))
+
+  (pass-if-exception "matching behavior II" exception:shape-mismatch
+    (let ((a #(1 2 3))
+          (b (make-array 0 2)))
+      (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))
+          (c (make-array 0 2 2))
+          (d (make-array 0 2 2))
+          (e (make-array 0 2 2)))
+      (array-copy! a b)
+      (array-copy! a (transpose-array c 1 0))
+      (array-copy! (transpose-array a 1 0) d)
+      (array-copy! (transpose-array a 1 0) (transpose-array e 1 0))
+      (and (equal? a #2((1 2) (3 4)))
+           (equal? b #2((1 2) (3 4)))
+           (equal? c #2((1 3) (2 4)))
+           (equal? d #2((1 3) (2 4)))
+           (equal? e #2((1 2) (3 4))))))
+
+  (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!
+;;;
+
+(with-test-prefix "array-map!"
+
+  (pass-if-exception "no args" exception:wrong-num-args
+    (array-map!))
+
+  (pass-if-exception "one arg" exception:wrong-num-args
+    (array-map! (make-array #f 5)))
+
+  (with-test-prefix "no sources"
+
+    (pass-if "closure 0"
+      (array-map! (make-array #f 5) (lambda () #f))
+      #t)
+
+    (pass-if-exception "closure 1" exception:wrong-num-args
+      (array-map! (make-array #f 5) (lambda (x) #f)))
+
+    (pass-if-exception "closure 2" exception:wrong-num-args
+      (array-map! (make-array #f 5) (lambda (x y) #f)))
+
+    (pass-if-exception "subr_1" exception:wrong-num-args
+      (array-map! (make-array #f 5) length))
+
+    (pass-if-exception "subr_2" exception:wrong-num-args
+      (array-map! (make-array #f 5) logtest))
+
+    (pass-if-exception "subr_2o" exception:wrong-num-args
+      (array-map! (make-array #f 5) number->string))
+
+    (pass-if-exception "dsubr" exception:wrong-num-args
+      (array-map! (make-array #f 5) sqrt))
+
+    (pass-if "rpsubr"
+      (let ((a (make-array 'foo 5)))
+	(array-map! a =)
+	(equal? a (make-array #t 5))))
+
+    (pass-if "asubr"
+      (let ((a (make-array 'foo 5)))
+	(array-map! a +)
+	(equal? a (make-array 0 5))))
+
+    ;; in Guile 1.6.4 and earlier this resulted in a segv
+    (pass-if "noop"
+      (array-map! (make-array #f 5) noop)
+      #t))
+
+  (with-test-prefix "one source"
+
+    (pass-if-exception "closure 0" exception:wrong-num-args
+      (array-map! (make-array #f 5) (lambda () #f)
+                  (make-array #f 5)))
+
+    (pass-if "closure 1"
+      (let ((a (make-array #f 5)))
+	(array-map! a (lambda (x) 'foo) (make-array #f 5))
+	(equal? a (make-array 'foo 5))))
+
+    (pass-if-exception "closure 2" exception:wrong-num-args
+      (array-map! (make-array #f 5) (lambda (x y) #f)
+                  (make-array #f 5)))
+
+    (pass-if "subr_1"
+      (let ((a (make-array #f 5)))
+        (array-map! a length (make-array '(x y z) 5))
+        (equal? a (make-array 3 5))))
+
+    (pass-if-exception "subr_2" exception:wrong-num-args
+      (array-map! (make-array #f 5) logtest
+                  (make-array 999 5)))
+
+    (pass-if "subr_2o"
+      (let ((a (make-array #f 5)))
+	(array-map! a number->string (make-array 99 5))
+	(equal? a (make-array "99" 5))))
+
+    (pass-if "dsubr"
+      (let ((a (make-array #f 5)))
+	(array-map! a sqrt (make-array 16.0 5))
+	(equal? a (make-array 4.0 5))))
+
+    (pass-if "rpsubr"
+      (let ((a (make-array 'foo 5)))
+	(array-map! a = (make-array 0 5))
+	(equal? a (make-array #t 5))))
+
+    (pass-if "asubr"
+      (let ((a (make-array 'foo 5)))
+	(array-map! a - (make-array 99 5))
+	(equal? a (make-array -99 5))))
+
+    ;; in Guile 1.6.5 and 1.6.6 this was an error
+    (pass-if "1+"
+      (let ((a (make-array #f 5)))
+	(array-map! a 1+ (make-array 123 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"
+
+    (pass-if-exception "closure 0" exception:wrong-num-args
+      (array-map! (make-array #f 5) (lambda () #f)
+                  (make-array #f 5) (make-array #f 5)))
+
+    (pass-if-exception "closure 1" exception:wrong-num-args
+      (array-map! (make-array #f 5) (lambda (x) #f)
+                  (make-array #f 5) (make-array #f 5)))
+
+    (pass-if "closure 2"
+      (let ((a (make-array #f 5)))
+        (array-map! a (lambda (x y) 'foo)
+                    (make-array #f 5) (make-array #f 5))
+        (equal? a (make-array 'foo 5))))
+
+    (pass-if-exception "subr_1" exception:wrong-num-args
+      (array-map! (make-array #f 5) length
+		  (make-array #f 5) (make-array #f 5)))
+
+    (pass-if "subr_2"
+      (let ((a (make-array 'foo 5)))
+	(array-map! a logtest
+		    (make-array 999 5) (make-array 999 5))
+	(equal? a (make-array #t 5))))
+
+    (pass-if "subr_2o"
+      (let ((a (make-array #f 5)))
+	(array-map! a number->string
+		    (make-array 32 5) (make-array 16 5))
+	(equal? a (make-array "20" 5))))
+
+    (pass-if-exception "dsubr" exception:wrong-num-args
+      (let ((a (make-array #f 5)))
+	(array-map! a sqrt
+		    (make-array 16.0 5) (make-array 16.0 5))
+	(equal? a (make-array 4.0 5))))
+
+    (pass-if "rpsubr"
+      (let ((a (make-array 'foo 5)))
+	(array-map! a = (make-array 99 5) (make-array 77 5))
+	(equal? a (make-array #f 5))))
+
+    (pass-if "asubr"
+      (let ((a (make-array 'foo 5)))
+	(array-map! a - (make-array 99 5) (make-array 11 5))
+	(equal? a (make-array 88 5))))
+
+    (pass-if "+"
+      (let ((a (make-array #f 4)))
+	(array-map! a + #(1 2 3 4) #(5 6 7 8))
+	(equal? a #(6 8 10 12))))
+
+    (pass-if "noncompact arrays 1"
+      (let ((a #2((0 1) (2 3)))
+            (c (make-array 0 2)))
+        (begin
+          (array-map! c + (array-row a 1) (array-row a 1))
+          (array-equal? c #(4 6)))))
+
+    (pass-if "noncompact arrays 2"
+      (let ((a #2((0 1) (2 3)))
+            (c (make-array 0 2)))
+        (begin
+          (array-map! c + (array-col a 1) (array-col a 1))
+          (array-equal? c #(2 6)))))
+
+    (pass-if "noncompact arrays 3"
+      (let ((a #2((0 1) (2 3)))
+            (c (make-array 0 2)))
+        (begin
+          (array-map! c + (array-col a 1) (array-row a 1))
+          (array-equal? c #(3 6)))))
+
+    (pass-if "noncompact arrays 4"
+      (let ((a #2((0 1) (2 3)))
+            (c (make-array 0 2)))
+        (begin
+          (array-map! c + (array-col a 1) (array-row a 1))
+          (array-equal? c #(3 6)))))
+
+    (pass-if "offset arrays 1"
+      (let ((a #2@1@-3((0 1) (2 3)))
+            (c (make-array 0 '(1 2) '(-3 -2))))
+        (begin
+          (array-map! c + a a)
+          (array-equal? c #2@1@-3((0 2) (4 6)))))))
+
+  ;; note that array-copy! has the opposite behavior.
+
+  (pass-if-exception "matching behavior I" exception:shape-mismatch
+    (let ((a #(1 2))
+          (b (make-array 0 3)))
+      (array-map! b values a)
+      (equal? b #(1 2 0))))
+
+  (pass-if "matching behavior II"
+    (let ((a #(1 2 3))
+          (b (make-array 0 2)))
+      (array-map! b values a)
+      (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
+;;;
+
+(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)))
+             (l '())
+             (p (lambda (x) (set! l (cons x l)))))
+        (array-for-each p a)
+        l))
+
+    (pass-if-equal "vector"
+        '(3 2 1 0)
+      (let* ((a #(0 1 2 3))
+             (l '())
+             (p (lambda (x) (set! l (cons x l)))))
+        (array-for-each p a)
+        l))
+
+    (pass-if-equal "shared array"
+        '(3 2 1 0)
+      (let* ((a  #2((0 1) (2 3)))
+             (a' (make-shared-array a
+                                    (lambda (x)
+                                      (list (quotient x 4)
+                                            (modulo x 4)))
+                                    4))
+             (l  '())
+             (p  (lambda (x) (set! l (cons x l)))))
+        (array-for-each p a')
+        l)))
+
+  (with-test-prefix "3 sources"
+    (pass-if-equal "noncompact arrays 1"
+        '((3 1 3) (2 0 2))
+      (let* ((a #2((0 1) (2 3)))
+             (l '())
+             (rec (lambda args (set! l (cons args l)))))
+        (array-for-each rec (array-row a 1) (array-row a 0) (array-row a 1))
+        l))
+
+    (pass-if-equal "noncompact arrays 2"
+        '((3 3 3) (2 2 1))
+      (let* ((a #2((0 1) (2 3)))
+             (l '())
+             (rec (lambda args (set! l (cons args l)))))
+        (array-for-each rec (array-row a 1) (array-row a 1) (array-col a 1))
+        l))
+
+    (pass-if-equal "noncompact arrays 3"
+        '((3 3 3) (2 1 1))
+      (let* ((a #2((0 1) (2 3)))
+             (l '())
+             (rec (lambda args (set! l (cons args l)))))
+        (array-for-each rec (array-row a 1) (array-col a 1) (array-col a 1))
+        l))
+
+    (pass-if-equal "noncompact arrays 4"
+        '((3 2 3) (1 0 2))
+      (let* ((a #2((0 1) (2 3)))
+             (l '())
+             (rec (lambda args (set! l (cons args l)))))
+        (array-for-each rec (array-col a 1) (array-col a 0) (array-row a 1))
+        l)))
+
+  (with-test-prefix "empty arrays"
+
+    (pass-if "empty other than last, #t" ; fails in 2.0.9 with bad a.
+      (let* ((a (list))
+             (b (make-array 0 2 2))
+             (c (make-shared-array b (lambda (i j) (list i j)) 0 2)))
+        (array-for-each (lambda (c) (set! a (cons c a))) c)
+        (equal? a '())))
+
+    (pass-if "empty other than last, f64" ; fails in 2.0.9 with out of range.
+      (let* ((a (list))
+             (b (make-typed-array 'f64 0 2 2))
+             (c (make-shared-array b (lambda (i j) (list i j)) 0 2)))
+        (array-for-each (lambda (c) (set! a (cons c a))) c)
+        (equal? a '())))
+
+    ;; FIXME add type 'b cases.
+
+    (pass-if-exception "empty arrays shape check" exception:shape-mismatch
+      (let* ((a (list))
+             (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))
+
+  (pass-if-equal "regression: zero-sized frame loop without unrolling"
+      99
+    (let* ((x 99)
+           (o (make-array 0. 0 3 2)))
+      (array-for-each-cell 2
+        (lambda (o a0 a1)
+          (set! x 0))
+        o
+        (make-shared-array (make-array 1. 0 1) (const '(0 0)) 0 3)
+        (make-array 2. 0 3))
+      x)))
diff --git a/test-suite/tests/ramap.test b/test-suite/tests/ramap.test
deleted file mode 100644
index bd8a434bd..000000000
--- a/test-suite/tests/ramap.test
+++ /dev/null
@@ -1,509 +0,0 @@
-;;;; ramap.test --- test array mapping functions -*- scheme -*-
-;;;; 
-;;;; Copyright (C) 2004, 2005, 2006, 2009, 2013 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 as published by the Free Software Foundation; either
-;;;; version 3 of the License, or (at your option) any later version.
-;;;; 
-;;;; This library is distributed in the hope that it will be useful,
-;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
-;;;; Lesser General Public License for more details.
-;;;; 
-;;;; You should have received a copy of the GNU Lesser General Public
-;;;; 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)
-  #:use-module (test-suite lib))
-
-(define exception:shape-mismatch
-  (cons 'misc-error ".*shape mismatch.*"))
-
-(define (array-row a i)
-  (make-shared-array a (lambda (j) (list i j))
-                       (cadr (array-dimensions a))))
-
-(define (array-col a j)
-  (make-shared-array a (lambda (i) (list i j))
-                       (car (array-dimensions a))))
-
-;;;
-;;; array-index-map!
-;;;
-
-(with-test-prefix "array-index-map!"
-
-  (pass-if "basic test"
-    (let ((nlst '()))
-      (array-index-map! (make-array #f '(1 1))
-                        (lambda (n)
-                          (set! nlst (cons n nlst))))
-      (equal? nlst '(1))))
-
-  (with-test-prefix "empty arrays"
-
-    (pass-if "all axes empty"
-      (array-index-map! (make-typed-array 'f64 0 0 0) (const 0))
-      (array-index-map! (make-typed-array 'b #t 0 0) (const #t))
-      (array-index-map! (make-typed-array #t 0 0 0) (const 0))
-      #t)
-
-    (pass-if "last axis empty"
-      (array-index-map! (make-typed-array 'f64 0 2 0) (const 0))
-      (array-index-map! (make-typed-array 'b #t 2 0) (const #t))
-      (array-index-map! (make-typed-array #t 0 2 0) (const 0))
-      #t)
-
-    ; the 'f64 cases fail in 2.0.9 with out-of-range.
-    (pass-if "axis empty, other than last"
-      (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))
-
-  (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!
-;;;
-
-(with-test-prefix "array-copy!"
-
-  (with-test-prefix "empty arrays"
-
-    (pass-if "empty other than last, #t"
-      (let* ((b (make-array 0 2 2))
-             (c (make-shared-array b (lambda (i j) (list i j)) 0 2)))
-        (array-copy! #2:0:2() c)
-        (array-equal? #2:0:2() c)))
-
-    (pass-if "empty other than last, 'f64"
-      (let* ((b (make-typed-array 'f64 0 2 2))
-             (c (make-shared-array b (lambda (i j) (list i j)) 0 2)))
-        (array-copy! #2:0:2() c)
-        (array-equal? #2f64:0:2() c)))
-
-  ;; FIXME add empty, type 'b cases.
-
-    )
-
-  ;; note that it is the opposite of array-map!. This is, unfortunately,
-  ;; documented in the manual.
-
-  (pass-if "matching behavior I"
-    (let ((a #(1 2))
-          (b (make-array 0 3)))
-      (array-copy! a b)
-      (equal? b #(1 2 0))))
-
-  (pass-if-exception "matching behavior II" exception:shape-mismatch
-    (let ((a #(1 2 3))
-          (b (make-array 0 2)))
-      (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))
-          (c (make-array 0 2 2))
-          (d (make-array 0 2 2))
-          (e (make-array 0 2 2)))
-      (array-copy! a b)
-      (array-copy! a (transpose-array c 1 0))
-      (array-copy! (transpose-array a 1 0) d)
-      (array-copy! (transpose-array a 1 0) (transpose-array e 1 0))
-      (and (equal? a #2((1 2) (3 4)))
-           (equal? b #2((1 2) (3 4)))
-           (equal? c #2((1 3) (2 4)))
-           (equal? d #2((1 3) (2 4)))
-           (equal? e #2((1 2) (3 4))))))
-
-  (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!
-;;;
-
-(with-test-prefix "array-map!"
-
-  (pass-if-exception "no args" exception:wrong-num-args
-    (array-map!))
-
-  (pass-if-exception "one arg" exception:wrong-num-args
-    (array-map! (make-array #f 5)))
-
-  (with-test-prefix "no sources"
-
-    (pass-if "closure 0"
-      (array-map! (make-array #f 5) (lambda () #f))
-      #t)
-
-    (pass-if-exception "closure 1" exception:wrong-num-args
-      (array-map! (make-array #f 5) (lambda (x) #f)))
-
-    (pass-if-exception "closure 2" exception:wrong-num-args
-      (array-map! (make-array #f 5) (lambda (x y) #f)))
-
-    (pass-if-exception "subr_1" exception:wrong-num-args
-      (array-map! (make-array #f 5) length))
-
-    (pass-if-exception "subr_2" exception:wrong-num-args
-      (array-map! (make-array #f 5) logtest))
-
-    (pass-if-exception "subr_2o" exception:wrong-num-args
-      (array-map! (make-array #f 5) number->string))
-
-    (pass-if-exception "dsubr" exception:wrong-num-args
-      (array-map! (make-array #f 5) sqrt))
-
-    (pass-if "rpsubr"
-      (let ((a (make-array 'foo 5)))
-	(array-map! a =)
-	(equal? a (make-array #t 5))))
-
-    (pass-if "asubr"
-      (let ((a (make-array 'foo 5)))
-	(array-map! a +)
-	(equal? a (make-array 0 5))))
-
-    ;; in Guile 1.6.4 and earlier this resulted in a segv
-    (pass-if "noop"
-      (array-map! (make-array #f 5) noop)
-      #t))
-
-  (with-test-prefix "one source"
-
-    (pass-if-exception "closure 0" exception:wrong-num-args
-      (array-map! (make-array #f 5) (lambda () #f)
-                  (make-array #f 5)))
-
-    (pass-if "closure 1"
-      (let ((a (make-array #f 5)))
-	(array-map! a (lambda (x) 'foo) (make-array #f 5))
-	(equal? a (make-array 'foo 5))))
-
-    (pass-if-exception "closure 2" exception:wrong-num-args
-      (array-map! (make-array #f 5) (lambda (x y) #f)
-                  (make-array #f 5)))
-
-    (pass-if "subr_1"
-      (let ((a (make-array #f 5)))
-        (array-map! a length (make-array '(x y z) 5))
-        (equal? a (make-array 3 5))))
-
-    (pass-if-exception "subr_2" exception:wrong-num-args
-      (array-map! (make-array #f 5) logtest
-                  (make-array 999 5)))
-
-    (pass-if "subr_2o"
-      (let ((a (make-array #f 5)))
-	(array-map! a number->string (make-array 99 5))
-	(equal? a (make-array "99" 5))))
-
-    (pass-if "dsubr"
-      (let ((a (make-array #f 5)))
-	(array-map! a sqrt (make-array 16.0 5))
-	(equal? a (make-array 4.0 5))))
-
-    (pass-if "rpsubr"
-      (let ((a (make-array 'foo 5)))
-	(array-map! a = (make-array 0 5))
-	(equal? a (make-array #t 5))))
-
-    (pass-if "asubr"
-      (let ((a (make-array 'foo 5)))
-	(array-map! a - (make-array 99 5))
-	(equal? a (make-array -99 5))))
-
-    ;; in Guile 1.6.5 and 1.6.6 this was an error
-    (pass-if "1+"
-      (let ((a (make-array #f 5)))
-	(array-map! a 1+ (make-array 123 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"
-
-    (pass-if-exception "closure 0" exception:wrong-num-args
-      (array-map! (make-array #f 5) (lambda () #f)
-                  (make-array #f 5) (make-array #f 5)))
-
-    (pass-if-exception "closure 1" exception:wrong-num-args
-      (array-map! (make-array #f 5) (lambda (x) #f)
-                  (make-array #f 5) (make-array #f 5)))
-
-    (pass-if "closure 2"
-      (let ((a (make-array #f 5)))
-        (array-map! a (lambda (x y) 'foo)
-                    (make-array #f 5) (make-array #f 5))
-        (equal? a (make-array 'foo 5))))
-
-    (pass-if-exception "subr_1" exception:wrong-num-args
-      (array-map! (make-array #f 5) length
-		  (make-array #f 5) (make-array #f 5)))
-
-    (pass-if "subr_2"
-      (let ((a (make-array 'foo 5)))
-	(array-map! a logtest
-		    (make-array 999 5) (make-array 999 5))
-	(equal? a (make-array #t 5))))
-
-    (pass-if "subr_2o"
-      (let ((a (make-array #f 5)))
-	(array-map! a number->string
-		    (make-array 32 5) (make-array 16 5))
-	(equal? a (make-array "20" 5))))
-
-    (pass-if-exception "dsubr" exception:wrong-num-args
-      (let ((a (make-array #f 5)))
-	(array-map! a sqrt
-		    (make-array 16.0 5) (make-array 16.0 5))
-	(equal? a (make-array 4.0 5))))
-
-    (pass-if "rpsubr"
-      (let ((a (make-array 'foo 5)))
-	(array-map! a = (make-array 99 5) (make-array 77 5))
-	(equal? a (make-array #f 5))))
-
-    (pass-if "asubr"
-      (let ((a (make-array 'foo 5)))
-	(array-map! a - (make-array 99 5) (make-array 11 5))
-	(equal? a (make-array 88 5))))
-
-    (pass-if "+"
-      (let ((a (make-array #f 4)))
-	(array-map! a + #(1 2 3 4) #(5 6 7 8))
-	(equal? a #(6 8 10 12))))
-
-    (pass-if "noncompact arrays 1"
-      (let ((a #2((0 1) (2 3)))
-            (c (make-array 0 2)))
-        (begin
-          (array-map! c + (array-row a 1) (array-row a 1))
-          (array-equal? c #(4 6)))))
-
-    (pass-if "noncompact arrays 2"
-      (let ((a #2((0 1) (2 3)))
-            (c (make-array 0 2)))
-        (begin
-          (array-map! c + (array-col a 1) (array-col a 1))
-          (array-equal? c #(2 6)))))
-
-    (pass-if "noncompact arrays 3"
-      (let ((a #2((0 1) (2 3)))
-            (c (make-array 0 2)))
-        (begin
-          (array-map! c + (array-col a 1) (array-row a 1))
-          (array-equal? c #(3 6)))))
-
-    (pass-if "noncompact arrays 4"
-      (let ((a #2((0 1) (2 3)))
-            (c (make-array 0 2)))
-        (begin
-          (array-map! c + (array-col a 1) (array-row a 1))
-          (array-equal? c #(3 6)))))
-
-    (pass-if "offset arrays 1"
-      (let ((a #2@1@-3((0 1) (2 3)))
-            (c (make-array 0 '(1 2) '(-3 -2))))
-        (begin
-          (array-map! c + a a)
-          (array-equal? c #2@1@-3((0 2) (4 6)))))))
-
-  ;; note that array-copy! has the opposite behavior.
-
-  (pass-if-exception "matching behavior I" exception:shape-mismatch
-    (let ((a #(1 2))
-          (b (make-array 0 3)))
-      (array-map! b values a)
-      (equal? b #(1 2 0))))
-
-  (pass-if "matching behavior II"
-    (let ((a #(1 2 3))
-          (b (make-array 0 2)))
-      (array-map! b values a)
-      (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
-;;;
-
-(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)))
-             (l '())
-             (p (lambda (x) (set! l (cons x l)))))
-        (array-for-each p a)
-        l))
-
-    (pass-if-equal "vector"
-        '(3 2 1 0)
-      (let* ((a #(0 1 2 3))
-             (l '())
-             (p (lambda (x) (set! l (cons x l)))))
-        (array-for-each p a)
-        l))
-
-    (pass-if-equal "shared array"
-        '(3 2 1 0)
-      (let* ((a  #2((0 1) (2 3)))
-             (a' (make-shared-array a
-                                    (lambda (x)
-                                      (list (quotient x 4)
-                                            (modulo x 4)))
-                                    4))
-             (l  '())
-             (p  (lambda (x) (set! l (cons x l)))))
-        (array-for-each p a')
-        l)))
-
-  (with-test-prefix "3 sources"
-    (pass-if-equal "noncompact arrays 1"
-        '((3 1 3) (2 0 2))
-      (let* ((a #2((0 1) (2 3)))
-             (l '())
-             (rec (lambda args (set! l (cons args l)))))
-        (array-for-each rec (array-row a 1) (array-row a 0) (array-row a 1))
-        l))
-
-    (pass-if-equal "noncompact arrays 2"
-        '((3 3 3) (2 2 1))
-      (let* ((a #2((0 1) (2 3)))
-             (l '())
-             (rec (lambda args (set! l (cons args l)))))
-        (array-for-each rec (array-row a 1) (array-row a 1) (array-col a 1))
-        l))
-
-    (pass-if-equal "noncompact arrays 3"
-        '((3 3 3) (2 1 1))
-      (let* ((a #2((0 1) (2 3)))
-             (l '())
-             (rec (lambda args (set! l (cons args l)))))
-        (array-for-each rec (array-row a 1) (array-col a 1) (array-col a 1))
-        l))
-
-    (pass-if-equal "noncompact arrays 4"
-        '((3 2 3) (1 0 2))
-      (let* ((a #2((0 1) (2 3)))
-             (l '())
-             (rec (lambda args (set! l (cons args l)))))
-        (array-for-each rec (array-col a 1) (array-col a 0) (array-row a 1))
-        l)))
-
-  (with-test-prefix "empty arrays"
-
-    (pass-if "empty other than last, #t" ; fails in 2.0.9 with bad a.
-      (let* ((a (list))
-             (b (make-array 0 2 2))
-             (c (make-shared-array b (lambda (i j) (list i j)) 0 2)))
-        (array-for-each (lambda (c) (set! a (cons c a))) c)
-        (equal? a '())))
-
-    (pass-if "empty other than last, f64" ; fails in 2.0.9 with out of range.
-      (let* ((a (list))
-             (b (make-typed-array 'f64 0 2 2))
-             (c (make-shared-array b (lambda (i j) (list i j)) 0 2)))
-        (array-for-each (lambda (c) (set! a (cons c a))) c)
-        (equal? a '())))
-
-    ;; FIXME add type 'b cases.
-
-    (pass-if-exception "empty arrays shape check" exception:shape-mismatch
-      (let* ((a (list))
-             (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)))))
-- 
cgit v1.2.1