New functions array-from, array-from*, array-amend!

* libguile/arrays.h (scm_array_from, scm_array_from_s,
  scm_array_amend_x): New declarations.

* libguile/arrays.c (scm_array_from, scm_array_from_s,
  scm_array_amend_x): New functions, export as array-from, array-from*,
  array-amend!.

* test-suite/tests/arrays.test: Tests for array-from, array-from*,
  array-amend!. Replace with-test-prefix/c&e with with-test-prefix where
  the array read syntax isn't used.

1 files changed, 172 insertions, 1 deletions

diff --git a/libguile/arrays.c b/libguile/arrays.c
index b8307d528..395bb6723 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"
 
@@ -474,6 +473,178 @@ SCM_DEFINE (scm_make_shared_array, "make-shared-array", 2, 0, 1,
 #undef FUNC_NAME
 
 
+static void
+array_from_pos (scm_t_array_handle *handle, size_t *ndim, size_t *k, SCM *i, ssize_t *pos,
+                scm_t_array_dim **s, char const * FUNC_NAME, SCM error_args)
+{
+  *s = scm_array_handle_dims (handle);
+  *k = *ndim = scm_array_handle_rank (handle);
+  for (; *k>0 && scm_is_pair (*i); --*k, ++*s, *i=scm_cdr (*i))
+    {
+      ssize_t ik = scm_to_ssize_t (scm_car (*i));
+      if (ik<(*s)->lbnd || ik>(*s)->ubnd)
+        {
+          scm_array_handle_release (handle);
+          scm_misc_error (FUNC_NAME, "indices out of range", error_args);
+        }
+      *pos += (ik-(*s)->lbnd) * (*s)->inc;
+    }
+}
+
+static void
+array_from_get_o (scm_t_array_handle *handle, size_t k, scm_t_array_dim *s, ssize_t pos,
+                  SCM *o)
+{
+  scm_t_array_dim * os;
+  *o = scm_i_make_array (k);
+  SCM_I_ARRAY_SET_V (*o, handle->vector);
+  SCM_I_ARRAY_SET_BASE (*o, pos + handle->base);
+  os = SCM_I_ARRAY_DIMS (*o);
+  for (; k>0; --k, ++s, ++os)
+    {
+      os->ubnd = s->ubnd;
+      os->lbnd = s->lbnd;
+      os->inc = s->inc;
+    }
+}
+
+SCM_DEFINE (scm_array_from_s, "array-from*", 1, 0, 1,
+           (SCM ra, SCM indices),
+            "Return the array slice @var{ra}[@var{indices} ..., ...]\n"
+            "The rank of @var{ra} must equal to the number of indices or larger.\n\n"
+            "See also @code{array-ref}, @code{array-from}, @code{array-amend!}.\n\n"
+            "@code{array-from*} may return a rank-0 array. For example:\n"
+            "@lisp\n"
+            "(array-from* #2((1 2 3) (4 5 6)) 1 1) @result{} #0(5)\n"
+            "(array-from* #2((1 2 3) (4 5 6)) 1) @result{} #(4 5 6)\n"
+            "(array-from* #2((1 2 3) (4 5 6))) @result{} #2((1 2 3) (4 5 6))\n"
+            "(array-from* #0(5) @result{} #0(5).\n"
+            "@end lisp")
+#define FUNC_NAME s_scm_array_from_s
+{
+  SCM o, i = indices;
+  size_t ndim, k;
+  ssize_t pos = 0;
+  scm_t_array_handle handle;
+  scm_t_array_dim *s;
+  scm_array_get_handle (ra, &handle);
+  array_from_pos (&handle, &ndim, &k, &i, &pos, &s, FUNC_NAME, scm_list_2 (ra, indices));
+  if (k==ndim)
+    o = ra;
+  else if (scm_is_null (i))
+    {
+      array_from_get_o(&handle, k, s, pos, &o);
+    }
+  else
+    {
+      scm_array_handle_release (&handle);
+      scm_misc_error(FUNC_NAME, "too many indices", scm_list_2 (ra, indices));
+    }
+  scm_array_handle_release (&handle);
+  return o;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_array_from, "array-from", 1, 0, 1,
+           (SCM ra, SCM indices),
+            "Return the element at the @code{(@var{indices} ...)} position\n"
+            "in array @var{ra}, or the array slice @var{ra}[@var{indices} ..., ...]\n"
+            "if the rank of @var{ra} is larger than the number of indices.\n\n"
+            "See also @code{array-ref}, @code{array-from*}, @code{array-amend!}.\n\n"
+            "@code{array-from} never returns a rank 0 array. For example:\n"
+            "@lisp\n"
+            "(array-from #2((1 2 3) (4 5 6)) 1 1) @result{} 5\n"
+            "(array-from #2((1 2 3) (4 5 6)) 1) @result{} #(4 5 6)\n"
+            "(array-from #2((1 2 3) (4 5 6))) @result{} #2((1 2 3) (4 5 6))\n"
+            "(array-from #0(5) @result{} 5.\n"
+            "@end lisp")
+#define FUNC_NAME s_scm_array_from
+{
+  SCM o, i = indices;
+  size_t ndim, k;
+  ssize_t pos = 0;
+  scm_t_array_handle handle;
+  scm_t_array_dim *s;
+  scm_array_get_handle (ra, &handle);
+  array_from_pos (&handle, &ndim, &k, &i, &pos, &s, FUNC_NAME, scm_list_2 (ra, indices));
+  if (k>0)
+    {
+      if (k==ndim)
+        o = ra;
+      else
+        array_from_get_o(&handle, k, s, pos, &o);
+    }
+  else if (scm_is_null(i))
+    o = scm_array_handle_ref (&handle, pos);
+  else
+    {
+      scm_array_handle_release (&handle);
+      scm_misc_error(FUNC_NAME, "too many indices", scm_list_2 (ra, indices));
+    }
+  scm_array_handle_release (&handle);
+  return o;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_array_amend_x, "array-amend!", 2, 0, 1,
+            (SCM ra, SCM b, SCM indices),
+            "Set the array slice @var{ra}[@var{indices} ..., ...] to @var{b}\n."
+            "Equivalent to @code{(array-copy! @var{b} (apply array-from @var{ra} @var{indices}))}\n"
+            "if the number of indices is smaller than the rank of @var{ra}; otherwise\n"
+            "equivalent to @code{(apply array-set! @var{ra} @var{b} @var{indices})}.\n"
+            "This function returns the modified array @var{ra}.\n\n"
+            "See also @code{array-ref}, @code{array-from}, @code{array-from*}.\n\n"
+            "For example:\n"
+            "@lisp\n"
+            "(define A (list->array 2 '((1 2 3) (4 5 6))))\n"
+            "(array-amend! A #0(99) 1 1) @result{} #2((1 2 3) (4 #0(99) 6))\n"
+            "(array-amend! A 99 1 1) @result{} #2((1 2 3) (4 99 6))\n"
+            "(array-amend! A #(a b c) 0) @result{} #2((a b c) (4 99 6))\n"
+            "(array-amend! A #2((x y z) (9 8 7))) @result{} #2((x y z) (9 8 7))\n\n"
+            "(define B (make-array 0))\n"
+            "(array-amend! B 15) @result{} #0(15)\n"
+            "@end lisp")
+#define FUNC_NAME s_scm_array_amend_x
+{
+  SCM o, i = indices;
+  size_t ndim, k;
+  ssize_t pos = 0;
+  scm_t_array_handle handle;
+  scm_t_array_dim *s;
+  scm_array_get_handle (ra, &handle);
+  array_from_pos (&handle, &ndim, &k, &i, &pos, &s, FUNC_NAME, scm_list_3 (ra, b, indices));
+  if (k>0)
+    {
+      if (k==ndim)
+        o = ra;
+      else
+        array_from_get_o(&handle, k, s, pos, &o);
+      scm_array_handle_release(&handle);
+      /* an error is still possible here if o and b don't match. */
+      /* FIXME copying like this wastes the handle, and the bounds matching
+         behavior of array-copy! is not strict. */
+      scm_array_copy_x(b, o);
+    }
+  else if (scm_is_null(i))
+    {
+      scm_array_handle_set (&handle, pos, b);  /* ra may be non-ARRAYP */
+      scm_array_handle_release (&handle);
+    }
+  else
+    {
+      scm_array_handle_release (&handle);
+      scm_misc_error(FUNC_NAME, "too many indices", scm_list_3 (ra, b, indices));
+    }
+  return ra;
+}
+#undef FUNC_NAME
+
+
+#undef ARRAY_FROM_GET_O
+
+
 /* args are RA . DIMS */
 SCM_DEFINE (scm_transpose_array, "transpose-array", 1, 0, 1,
            (SCM ra, SCM args),