summaryrefslogtreecommitdiff
path: root/libguile/arrays.c
diff options
context:
space:
mode:
authorDaniel Llorens <daniel.llorens@bluewin.ch>2015-02-11 16:44:21 +0100
committerDaniel Llorens <daniel.llorens@bluewin.ch>2016-11-18 12:03:30 +0100
commit1945cdf491c669ce54f94b90fd083f71642d1b2e (patch)
treed12ac60c676635c19f5b2258f2c1627fc3cfaf75 /libguile/arrays.c
parent5d4b2c9c7a213ef3b7b511c4840978cf587a488f (diff)
downloadguile-1945cdf491c669ce54f94b90fd083f71642d1b2e.tar.gz
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!.
Diffstat (limited to 'libguile/arrays.c')
-rw-r--r--libguile/arrays.c158
1 files changed, 158 insertions, 0 deletions
diff --git a/libguile/arrays.c b/libguile/arrays.c
index fb522e1d5..273c48b73 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 @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;
+ 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 @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;
+ 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 @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;
+ 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),