[Guile-commits] 10/11: New functions array-from, array-from*, array-amend!

[Daniel Llorens]

lloda pushed a commit to branch lloda-squash0
in repository guile.

commit 1945cdf491c669ce54f94b90fd083f71642d1b2e
Author: Daniel Llorens <address@hidden>
Date:   Wed Feb 11 16:44:21 2015 +0100

    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!.
    
    * doc/ref/api-compound.texi: Document array-from, array-from*,
      array-amend!.
---
 doc/ref/api-compound.texi    |  105 ++++++++++++++++++++++++++++
 libguile/arrays.c            |  158 ++++++++++++++++++++++++++++++++++++++++++
 libguile/arrays.h            |    6 ++
 test-suite/tests/arrays.test |  109 +++++++++++++++++++++++++++++
 4 files changed, 378 insertions(+)

diff --git a/doc/ref/api-compound.texi b/doc/ref/api-compound.texi
index 97aaba3..6d1e118 100644
--- a/doc/ref/api-compound.texi
+++ b/doc/ref/api-compound.texi
@@ -1676,6 +1676,111 @@ base and stride for new array indices in @var{oldarray} 
data.  A few
 sample points are enough because @var{mapfunc} is linear.
 @end deffn
 
+
address@hidden {Scheme Procedure} array-ref array idx @dots{}
address@hidden {C Function} scm_array_ref (array, idxlist)
+Return the element at @code{(idx @dots{})} in @var{array}.
address@hidden deffn
+
address@hidden {Scheme Procedure} array-from array idx @dots{}
address@hidden {C Function} scm_array_from (array, idxlist)
+If the length of @var{idxlist} equals the rank @math{n} of
address@hidden, return the element at @code{(idx @dots{})}, just like
address@hidden(array-ref array idx @dots{})}. If, however, the length @math{k}
+of @var{idxlist} is shorter than @math{n}, then return the shared
address@hidden(n-k)}-rank prefix cell of @var{array} given by @var{idxlist}.
+
+For example:
+
address@hidden
address@hidden
+(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))
address@hidden lisp
address@hidden example
+
address@hidden(apply array-from array indices)} is equivalent to
+
address@hidden
+(let ((len (length indices)))
+  (if (= (array-rank a) len)
+    (apply array-ref a indices)
+    (apply make-shared-array a
+           (lambda t (append indices t))
+           (drop (array-dimensions a) len))))
address@hidden lisp
+
+The name `from' comes from the J language.
address@hidden deffn
+
address@hidden {Scheme Procedure} array-from* array idx @dots{}
address@hidden {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
address@hidden This can be useful when using @var{ARRAY} as destination
+of copies.
+
+Compare:
+
address@hidden
address@hidden
+(array-from #2((a b) (c d)) 1 1) @result{} d
+(array-from* #2((a b) (c d)) 1) @result{} #0(d)
+(define a (make-array 'a 2 2))
+(array-fill! (array-from* a 1 1) 'b)
+a @result{} #2((a a) (a b)).
+(array-fill! (array-from a 1 1) 'b) @result{} error: not an array
address@hidden lisp
address@hidden example
+
address@hidden(apply array-from* array indices)} is equivalent to
+
address@hidden
+(apply make-shared-array a
+  (lambda t (append indices t))
+  (drop (array-dimensions a) (length indices)))
address@hidden lisp
address@hidden deffn
+
+
address@hidden {Scheme Procedure} array-amend! array x idx @dots{}
address@hidden {C Function} scm_array_amend_x (array, x, idxlist)
+If the length of @var{idxlist} equals the rank @math{n} of
address@hidden, set the element at @code{(idx @dots{})} of @var{array} to
address@hidden, just like @code{(array-set! array x idx @dots{})}. If,
+however, the length @math{k} of @var{idxlist} is shorter than
address@hidden, then copy the @math{(n-k)}-rank array @var{x}
+into @math{(n-k)}-rank prefix cell of @var{array} given by
address@hidden In this case, the last @math{(n-k)} dimensions of
address@hidden and the dimensions of @var{x} must match exactly.
+
+This function returns the modified @var{array}.
+
+For example:
+
address@hidden
address@hidden
+(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))
address@hidden lisp
address@hidden example
+
address@hidden(apply array-amend! array x indices)} is equivalent to
+
address@hidden
+(let ((len (length indices)))
+  (if (= (array-rank array) len)
+    (apply array-set! array x indices)
+    (array-copy! x (apply array-from array indices)))
+  array)
address@hidden lisp
+
+The name `amend' comes from the J language.
address@hidden 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.
diff --git a/libguile/arrays.c b/libguile/arrays.c
index fb522e1..273c48b 100644
--- a/libguile/arrays.c
+++ b/libguile/arrays.c
@@ -416,6 +416,164 @@ SCM_DEFINE (scm_make_shared_array, "make-shared-array", 
2, 0, 1,
 #undef FUNC_NAME
 
 
+#define ARRAY_FROM_POS(error_args)                                      \
+  scm_t_array_handle handle;                                            \
+  scm_t_array_dim * s;                                                  \
+  size_t ndim, k;                                                       \
+  ssize_t pos;                                                          \
+  SCM i;                                                                \
+  scm_array_get_handle (ra, &handle);                                   \
+  s = scm_array_handle_dims (&handle);                                  \
+  ndim = scm_array_handle_rank (&handle);                               \
+  k = ndim;                                                             \
+  pos = 0;                                                              \
+  i = indices;                                                          \
+  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;                                     \
+    }
+
+#define ARRAY_FROM_GET_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 @address@hidden ..., ...]\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;
+  ARRAY_FROM_POS(scm_list_2 (ra, indices))
+  if (k==ndim)
+    o = ra;
+  else if (scm_is_null (i))
+    { ARRAY_FROM_GET_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 @address@hidden ..., ...]\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;
+  ARRAY_FROM_POS(scm_list_2 (ra, indices))
+  if (k>0)
+    {
+      if (k==ndim)
+        o = ra;
+      else
+        { ARRAY_FROM_GET_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 @address@hidden ..., ...] 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;
+  ARRAY_FROM_POS(scm_list_3 (ra, b, indices))
+  if (k>0)
+    {
+      if (k==ndim)
+        o = ra;
+      else
+        { 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
+         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_POS
+#undef ARRAY_FROM_GET_O
+
+
 /* 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 d3e409f..9b7fd6c 100644
--- a/libguile/arrays.h
+++ b/libguile/arrays.h
@@ -41,12 +41,18 @@ SCM_API SCM scm_make_typed_array (SCM type, SCM fill, SCM 
bounds);
 SCM_API SCM scm_from_contiguous_typed_array (SCM type, SCM bounds,
                                              const void *bytes,
                                              size_t byte_len);
+
 SCM_API SCM scm_shared_array_root (SCM ra);
 SCM_API SCM scm_shared_array_offset (SCM ra);
 SCM_API SCM scm_shared_array_increments (SCM ra);
+
 SCM_API SCM scm_make_shared_array (SCM oldra, SCM mapfunc, SCM dims);
 SCM_API SCM scm_transpose_array (SCM ra, SCM args);
 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_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/tests/arrays.test b/test-suite/tests/arrays.test
index c40457b..9bd0676 100644
--- a/test-suite/tests/arrays.test
+++ b/test-suite/tests/arrays.test
@@ -296,6 +296,115 @@
       (and (eqv? 5 (array-ref s2 1))
           (eqv? 8 (array-ref s2 2))))))
 
+
+;;;
+;;; array-from*
+;;;
+
+(with-test-prefix/c&e "array-from*"
+
+  (pass-if "vector I"
+    (let ((v (vector 1 2 3)))
+      (array-fill! (array-from* v 1) 'a)
+      (array-equal? v #(1 a 3))))
+
+  (pass-if "vector II"
+    (let ((v (vector 1 2 3)))
+      (array-copy! #(a b c) (array-from* v))
+      (array-equal? v #(a b c))))
+
+  (pass-if "array I"
+    (let ((a (list->array 2 '((1 2 3) (4 5 6)))))
+      (array-fill! (array-from* a 1 1) 'a)
+      (array-equal? a #2((1 2 3) (4 a 6)))))
+
+  (pass-if "array II"
+    (let ((a (list->array 2 '((1 2 3) (4 5 6)))))
+      (array-copy! #(a b c) (array-from* a 1))
+      (array-equal? a #2((1 2 3) (a b c)))))
+
+  (pass-if "array III"
+    (let ((a (list->array 2 '((1 2 3) (4 5 6)))))
+      (array-copy! #2((a b c) (x y z)) (array-from* a))
+      (array-equal? a #2((a b c) (x y z)))))
+
+  (pass-if "rank 0 array"
+    (let ((a (make-array 77)))
+      (array-fill! (array-from* a) 'a)
+      (array-equal? a #0(a)))))
+
+
+;;;
+;;; array-from
+;;;
+
+(with-test-prefix/c&e "array-from"
+
+  (pass-if "vector I"
+    (let ((v (vector 1 2 3)))
+      (equal? 2 (array-from v 1))))
+
+  (pass-if "vector II"
+    (let ((v (vector 1 2 3)))
+      (array-copy! #(a b c) (array-from v))
+      (array-equal? v #(a b c))))
+
+  (pass-if "array I"
+    (let ((a (list->array 2 '((1 2 3) (4 5 6)))))
+      (equal? 5 (array-from a 1 1))))
+
+  (pass-if "array II"
+    (let ((a (list->array 2 '((1 2 3) (4 5 6)))))
+      (array-copy! #(a b c) (array-from a 1))
+      (array-equal? a #2((1 2 3) (a b c)))))
+
+  (pass-if "array III"
+    (let ((a (list->array 2 '((1 2 3) (4 5 6)))))
+      (array-copy! #2((a b c) (x y z)) (array-from a))
+      (array-equal? a #2((a b c) (x y z)))))
+
+  (pass-if "rank 0 array"
+    (let ((a (make-array 77)))
+      (equal? (array-from a) 77))))
+
+
+;;;
+;;; array-amend!
+;;;
+
+(with-test-prefix/c&e "array-amend!"
+
+  (pass-if "vector I"
+    (let ((v (vector 1 2 3)))
+      (and (eq? v (array-amend! v 'x 1))
+           (array-equal? v #(1 x 3)))))
+
+  (pass-if "vector II"
+    (let ((v (vector 1 2 3)))
+      (and (eq? v (array-amend! (array-from v) #(a b c)))
+           (array-equal? v #(a b c)))))
+
+  (pass-if "array I"
+    (let ((a (list->array 2 '((1 2 3) (4 5 6)))))
+      (and (eq? a (array-amend! a 'x 1 1))
+           (array-equal? a #2((1 2 3) (4 x 6))))))
+
+  (pass-if "array II"
+    (let ((a (list->array 2 '((1 2 3) (4 5 6)))))
+      (and (eq? a (array-amend! a #(a b c) 1))
+           (array-equal? a #2((1 2 3) (a b c))))))
+
+  (pass-if "array III"
+    (let ((a (list->array 2 '((1 2 3) (4 5 6)))))
+      (and (eq? a (array-amend! a #2((a b c) (x y z))))
+           (array-equal? a #2((a b c) (x y z))))))
+
+  (pass-if "rank 0 array"
+    (let ((a (make-array 77)))
+      (and (eq? a (array-amend! a 99))
+           (array-equal? a #0(99))))))
+
+
 ;;;
 ;;; array-contents
 ;;;