mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-20 11:40:18 +02:00
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.
This commit is contained in:
Daniel Llorens
parent
7b6d854cf1
commit
d1435ea6bd
3 changed files with 290 additions and 4 deletions
|
|
@ -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),
|
||||
|
|
|
|||
|
|
@ -43,12 +43,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);
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
;;;
|
||||
|
|
@ -436,7 +545,7 @@
|
|||
;;; shared-array-increments
|
||||
;;;
|
||||
|
||||
(with-test-prefix/c&e "shared-array-increments"
|
||||
(with-test-prefix "shared-array-increments"
|
||||
|
||||
(pass-if "plain vector"
|
||||
(equal? '(1) (shared-array-increments (make-vector 4 0))))
|
||||
|
|
@ -595,7 +704,7 @@
|
|||
;;; array-in-bounds?
|
||||
;;;
|
||||
|
||||
(with-test-prefix/c&e "array-in-bounds?"
|
||||
(with-test-prefix "array-in-bounds?"
|
||||
|
||||
(pass-if (let ((a (make-array #f '(425 425))))
|
||||
(eq? #f (array-in-bounds? a 0)))))
|
||||
|
|
@ -606,7 +715,7 @@
|
|||
|
||||
(with-test-prefix "array-type"
|
||||
|
||||
(with-test-prefix/c&e "on make-foo-vector"
|
||||
(with-test-prefix "on make-foo-vector"
|
||||
|
||||
(pass-if "bool"
|
||||
(eq? 'b (array-type (make-bitvector 1))))
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue