lloda pushed a commit to branch lloda-squash0 in repository guile. commit afbb28b3b3508c791ec1219e54770cd8f4ddec09 Author: Daniel Llorens <daniel.llor...@bluewin.ch> 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 + +@deffn {Scheme Procedure} array-ref array idx @dots{} +@deffnx {C Function} scm_array_ref (array, idxlist) +Return the element at @code{(idx @dots{})} in @var{array}. +@end deffn + +@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}. + +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 + +@lisp +(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)))) +@end lisp + +The name `from' comes from the J language. +@end deffn + +@deffn {Scheme Procedure} array-from* array idx @dots{} +@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. + +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) +(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 +@end lisp +@end example + +@code{(apply array-from* array indices)} is equivalent to + +@lisp +(apply make-shared-array a + (lambda t (append indices t)) + (drop (array-dimensions a) (length indices))) +@end lisp +@end deffn + + +@deffn {Scheme Procedure} array-amend! array x idx @dots{} +@deffnx {C Function} scm_array_amend_x (array, x, idxlist) +If the length of @var{idxlist} equals the rank @math{n} of +@var{array}, set the element at @code{(idx @dots{})} of @var{array} to +@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 +@var{idxlist}. In this case, the last @math{(n-k)} dimensions of +@var{array} and the dimensions of @var{x} must match exactly. + +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 + +@code{(apply array-amend! array x indices)} is equivalent to + +@lisp +(let ((len (length indices))) + (if (= (array-rank array) len) + (apply array-set! array x indices) + (array-copy! x (apply array-from array indices))) + array) +@end lisp + +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. 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 @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), 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 ;;;