mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-29 19:30:36 +02:00
New functions (array-for-each-cell, array-for-each-cell-in-order)
* libguile/array-map.c (scm_i_array_rebase, scm_array_for_each_cell): New functions. Export scm_array_for_each_cell() as (array-for-each-cell). (array-for-each-cell-in-order): Define additional export. * libguile/array-map.h (scm_i_array_rebase, scm_array_for_each_cell): Add prototypes. * doc/ref/api-compound.texi: New section 'Arrays as arrays of arrays'. Move the documentation for (array-from), (array-from*) and (array-amend!) in here. Add documentation for (array-for-each-cell). * test-suite/tests/array-map.test: Renamed from test-suite/tests/ramap.test, fix module name. Add tests for (array-for-each-cell). * test-suite/Makefile.am: Apply rename array-map.test -> ramap.test. * doc/ref/api-compound.texi: Minor documentation fixes.
This commit is contained in:
Daniel Llorens
parent
1945cdf491
commit
a5bb9da6ea
6 changed files with 463 additions and 106 deletions
|
|
@ -1203,6 +1203,7 @@ dimensional arrays.
|
|||
* Array Syntax::
|
||||
* Array Procedures::
|
||||
* Shared Arrays::
|
||||
* Arrays as arrays of arrays::
|
||||
* Accessing Arrays from C::
|
||||
@end menu
|
||||
|
||||
|
|
@ -1682,104 +1683,6 @@ sample points are enough because @var{mapfunc} is linear.
|
|||
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)
|
||||
|
|
@ -1833,6 +1736,170 @@ have smaller rank than @var{array}.
|
|||
@end lisp
|
||||
@end deffn
|
||||
|
||||
@node Arrays as arrays of arrays
|
||||
@subsubsection Arrays as arrays of arrays
|
||||
|
||||
The functions in this section allow you to treat an array of rank
|
||||
@math{n} as an array of lower rank @math{n-k} where the elements are
|
||||
themselves arrays (`cells') of rank @math{k}. This replicates some of
|
||||
the functionality of `enclosed arrays', a feature of old Guile that was
|
||||
removed before @w{version 2.0}. However, these functions do not require
|
||||
a special type and operate on any array.
|
||||
|
||||
When we operate on an array in this way, we speak of the first @math{k}
|
||||
dimensions of the array as the @math{k}-`frame' of the array, while the
|
||||
last @math{n-k} dimensions are the dimensions of the
|
||||
@math{n-k}-`cell'. For example, a 2D-array (a matrix) can be seen as a
|
||||
1D array of rows. In this case, the rows are the 1-cells of the array.
|
||||
|
||||
@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 cell of @var{array} given by @var{idxlist}.
|
||||
|
||||
For 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
|
||||
|
||||
@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 a place to
|
||||
write into.
|
||||
|
||||
Compare:
|
||||
|
||||
@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
|
||||
|
||||
@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 the @math{(n-k)}-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:
|
||||
|
||||
@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
|
||||
|
||||
Note that @code{array-amend!} will expect elements, not arrays, when the
|
||||
destination has rank 0. One can work around this using
|
||||
@code{array-from*} instead.
|
||||
|
||||
@lisp
|
||||
(array-amend! (make-array 'a 2 2) #0(b) 1 1) @result{} #2((a a) (a #0(b)))
|
||||
(let ((a (make-array 'a 2 2))) (array-copy! #0(b) (array-from* a 1 1)) a) @result{} #2((a a) (a b))
|
||||
@end lisp
|
||||
|
||||
@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} array-for-each-cell frame-rank op x @dots{}
|
||||
@deffnx {C Function} scm_array_for_each_cell (array, frame_rank, op, xlist)
|
||||
Each @var{x} must be an array of rank ≥ @var{frame-rank}, and
|
||||
the first @var{frame-rank} dimensions of each @var{x} must all be the
|
||||
same. @var{array-for-each-cell} calls @var{op} with each set of
|
||||
(rank(@var{x}) - @var{frame-rank})-cells from @var{x}, in unspecified order.
|
||||
|
||||
@var{array-for-each-cell} allows you to loop over cells of any rank
|
||||
without having to carry an index list or construct slices manually. The
|
||||
cells passed to @var{op} are shared arrays of @var{X} so it is possible
|
||||
to write to them.
|
||||
|
||||
This function returns an unspecified value.
|
||||
|
||||
For example, to sort the rows of rank-2 array @code{a}:
|
||||
|
||||
@lisp
|
||||
(array-for-each-cell 1 (lambda (x) (sort! x <)) a)
|
||||
@end lisp
|
||||
|
||||
As another example, let @code{a} be a rank-2 array where each row is a 2-vector @math{(x,y)}.
|
||||
Let's compute the arguments of these vectors and store them in rank-1 array @code{b}.
|
||||
@lisp
|
||||
(array-for-each-cell 1
|
||||
(lambda (a b)
|
||||
(array-set! b (atan (array-ref a 1) (array-ref a 0))))
|
||||
a b)
|
||||
@end lisp
|
||||
|
||||
@code{(apply array-for-each-cell frame-rank op x)} is functionally
|
||||
equivalent to
|
||||
|
||||
@lisp
|
||||
(let ((frame (take (array-dimensions (car x)) frank)))
|
||||
(unless (every (lambda (x)
|
||||
(equal? frame (take (array-dimensions x) frank)))
|
||||
(cdr x))
|
||||
(error))
|
||||
(array-index-map!
|
||||
(apply make-shared-array (make-array #t) (const '()) frame)
|
||||
(lambda i (apply op (map (lambda (x) (apply array-from* x i)) x)))))
|
||||
@end lisp
|
||||
|
||||
@end deffn
|
||||
|
||||
|
||||
@node Accessing Arrays from C
|
||||
@subsubsection Accessing Arrays from C
|
||||
|
||||
|
|
|
|||
|
|
@ -42,7 +42,7 @@
|
|||
|
||||
#include "libguile/validate.h"
|
||||
#include "libguile/array-map.h"
|
||||
|
||||
#include <assert.h>
|
||||
|
||||
/* The WHAT argument for `scm_gc_malloc ()' et al. */
|
||||
static const char vi_gc_hint[] = "array-indices";
|
||||
|
|
@ -629,7 +629,8 @@ SCM_DEFINE (scm_i_array_equal_p, "array-equal?", 0, 2, 1,
|
|||
return SCM_BOOL_T;
|
||||
|
||||
while (!scm_is_null (rest))
|
||||
{ if (scm_is_false (scm_array_equal_p (ra0, ra1)))
|
||||
{
|
||||
if (scm_is_false (scm_array_equal_p (ra0, ra1)))
|
||||
return SCM_BOOL_F;
|
||||
ra0 = ra1;
|
||||
ra1 = scm_car (rest);
|
||||
|
|
@ -640,6 +641,261 @@ SCM_DEFINE (scm_i_array_equal_p, "array-equal?", 0, 2, 1,
|
|||
#undef FUNC_NAME
|
||||
|
||||
|
||||
/* Copy array descriptor with different base. */
|
||||
SCM
|
||||
scm_i_array_rebase (SCM a, size_t base)
|
||||
{
|
||||
size_t ndim = SCM_I_ARRAY_NDIM (a);
|
||||
SCM b = scm_words (((scm_t_bits) ndim << 17) + scm_tc7_array, 3 + ndim*3);
|
||||
SCM_I_ARRAY_SET_V (b, SCM_I_ARRAY_V (a));
|
||||
/* FIXME do check base */
|
||||
SCM_I_ARRAY_SET_BASE (b, base);
|
||||
memcpy (SCM_I_ARRAY_DIMS (b), SCM_I_ARRAY_DIMS (a), sizeof (scm_t_array_dim)*ndim);
|
||||
return b;
|
||||
}
|
||||
|
||||
static inline size_t padtoptr(size_t d) { return (d + (sizeof (void *) - 1)) & ~(sizeof (void *) - 1); }
|
||||
|
||||
SCM_DEFINE (scm_array_for_each_cell, "array-for-each-cell", 2, 0, 1,
|
||||
(SCM frame_rank, SCM op, SCM args),
|
||||
"Apply @var{op} to each of the cells of rank rank(@var{arg})-@var{frame_rank}\n"
|
||||
"of the arrays @var{args}, in unspecified order. The first\n"
|
||||
"@var{frame_rank} dimensions of each @var{arg} must match.\n"
|
||||
"Rank-0 cells are passed as rank-0 arrays.\n\n"
|
||||
"The value returned is unspecified.\n\n"
|
||||
"For example:\n"
|
||||
"@lisp\n"
|
||||
";; Sort the rows of rank-2 array A.\n\n"
|
||||
"(array-for-each-cell 1 (lambda (x) (sort! x <)) a)\n"
|
||||
"\n"
|
||||
";; Compute the arguments of the (x y) vectors in the rows of rank-2\n"
|
||||
";; array XYS and store them in rank-1 array ANGLES. Inside OP,\n"
|
||||
";; XY is a rank-1 (2-1) array, and ANGLE is a rank-0 (1-1) array.\n\n"
|
||||
"(array-for-each-cell 1 \n"
|
||||
" (lambda (xy angle)\n"
|
||||
" (array-set! angle (atan (array-ref xy 1) (array-ref xy 0))))\n"
|
||||
" xys angles)\n"
|
||||
"@end lisp")
|
||||
#define FUNC_NAME s_scm_array_for_each_cell
|
||||
{
|
||||
int const N = scm_ilength (args);
|
||||
int const frank = scm_to_int (frame_rank);
|
||||
int ocd;
|
||||
ssize_t step;
|
||||
SCM dargs_ = SCM_EOL;
|
||||
char const * msg;
|
||||
scm_t_array_dim * ais;
|
||||
int n, k;
|
||||
ssize_t z;
|
||||
|
||||
/* to be allocated inside the pool */
|
||||
scm_t_array_handle * ah;
|
||||
SCM * args_;
|
||||
scm_t_array_dim ** as;
|
||||
int * rank;
|
||||
|
||||
ssize_t * s;
|
||||
SCM * ai;
|
||||
SCM ** dargs;
|
||||
ssize_t * i;
|
||||
|
||||
int * order;
|
||||
size_t * base;
|
||||
|
||||
/* size the pool */
|
||||
char * pool;
|
||||
char * pool0;
|
||||
size_t pool_size = 0;
|
||||
pool_size += padtoptr(N*sizeof (scm_t_array_handle));
|
||||
pool_size += padtoptr(N*sizeof (SCM));
|
||||
pool_size += padtoptr(N*sizeof (scm_t_array_dim *));
|
||||
pool_size += padtoptr(N*sizeof (int));
|
||||
|
||||
pool_size += padtoptr(frank*sizeof (ssize_t));
|
||||
pool_size += padtoptr(N*sizeof (SCM));
|
||||
pool_size += padtoptr(N*sizeof (SCM *));
|
||||
pool_size += padtoptr(frank*sizeof (ssize_t));
|
||||
|
||||
pool_size += padtoptr(frank*sizeof (int));
|
||||
pool_size += padtoptr(N*sizeof (size_t));
|
||||
pool = scm_gc_malloc (pool_size, "pool");
|
||||
|
||||
/* place the items in the pool */
|
||||
#define AFIC_ALLOC_ADVANCE(pool, count, type, name) \
|
||||
name = (void *)pool; \
|
||||
pool += padtoptr(count*sizeof (type));
|
||||
|
||||
pool0 = pool;
|
||||
AFIC_ALLOC_ADVANCE (pool, N, scm_t_array_handle, ah);
|
||||
AFIC_ALLOC_ADVANCE (pool, N, SCM, args_);
|
||||
AFIC_ALLOC_ADVANCE (pool, N, scm_t_array_dim *, as);
|
||||
AFIC_ALLOC_ADVANCE (pool, N, int, rank);
|
||||
|
||||
AFIC_ALLOC_ADVANCE (pool, frank, ssize_t, s);
|
||||
AFIC_ALLOC_ADVANCE (pool, N, SCM, ai);
|
||||
AFIC_ALLOC_ADVANCE (pool, N, SCM *, dargs);
|
||||
AFIC_ALLOC_ADVANCE (pool, frank, ssize_t, i);
|
||||
|
||||
AFIC_ALLOC_ADVANCE (pool, frank, int, order);
|
||||
AFIC_ALLOC_ADVANCE (pool, N, size_t, base);
|
||||
assert((pool0+pool_size==pool) && "internal error");
|
||||
#undef AFIC_ALLOC_ADVANCE
|
||||
|
||||
for (n=0; scm_is_pair(args); args=scm_cdr(args), ++n)
|
||||
{
|
||||
args_[n] = scm_car(args);
|
||||
scm_array_get_handle(args_[n], ah+n);
|
||||
as[n] = scm_array_handle_dims(ah+n);
|
||||
rank[n] = scm_array_handle_rank(ah+n);
|
||||
}
|
||||
/* checks */
|
||||
msg = NULL;
|
||||
if (frank<0)
|
||||
msg = "bad frame rank";
|
||||
else
|
||||
{
|
||||
for (n=0; n!=N; ++n)
|
||||
{
|
||||
if (rank[n]<frank)
|
||||
{
|
||||
msg = "frame too large for arguments";
|
||||
goto check_msg;
|
||||
}
|
||||
for (k=0; k!=frank; ++k)
|
||||
{
|
||||
if (as[n][k].lbnd!=0)
|
||||
{
|
||||
msg = "non-zero base index is not supported";
|
||||
goto check_msg;
|
||||
}
|
||||
if (as[0][k].ubnd!=as[n][k].ubnd)
|
||||
{
|
||||
msg = "mismatched frames";
|
||||
goto check_msg;
|
||||
}
|
||||
s[k] = as[n][k].ubnd + 1;
|
||||
|
||||
/* this check is needed if the array cannot be entirely */
|
||||
/* unrolled, because the unrolled subloop will be run before */
|
||||
/* checking the dimensions of the frame. */
|
||||
if (s[k]==0)
|
||||
goto end;
|
||||
}
|
||||
}
|
||||
}
|
||||
check_msg: ;
|
||||
if (msg!=NULL)
|
||||
{
|
||||
for (n=0; n!=N; ++n)
|
||||
scm_array_handle_release(ah+n);
|
||||
scm_misc_error("array-for-each-cell", msg, scm_cons_star(frame_rank, args));
|
||||
}
|
||||
/* prepare moving cells. */
|
||||
for (n=0; n!=N; ++n)
|
||||
{
|
||||
ai[n] = scm_i_make_array(rank[n]-frank);
|
||||
SCM_I_ARRAY_SET_V (ai[n], scm_shared_array_root(args_[n]));
|
||||
/* FIXME scm_array_handle_base (ah+n) should be in Guile */
|
||||
SCM_I_ARRAY_SET_BASE (ai[n], ah[n].base);
|
||||
ais = SCM_I_ARRAY_DIMS(ai[n]);
|
||||
for (k=frank; k!=rank[n]; ++k)
|
||||
{
|
||||
ais[k-frank] = as[n][k];
|
||||
}
|
||||
}
|
||||
/* prepare rest list for callee. */
|
||||
{
|
||||
SCM *p = &dargs_;
|
||||
for (n=0; n<N; ++n)
|
||||
{
|
||||
*p = scm_cons (SCM_UNSPECIFIED, SCM_EOL);
|
||||
dargs[n] = SCM_CARLOC (*p);
|
||||
p = SCM_CDRLOC (*p);
|
||||
}
|
||||
}
|
||||
/* special case for rank 0. */
|
||||
if (frank==0)
|
||||
{
|
||||
for (n=0; n<N; ++n)
|
||||
*dargs[n] = ai[n];
|
||||
scm_apply_0(op, dargs_);
|
||||
for (n=0; n<N; ++n)
|
||||
scm_array_handle_release(ah+n);
|
||||
return SCM_UNSPECIFIED;
|
||||
}
|
||||
/* FIXME determine best looping order. */
|
||||
for (k=0; k!=frank; ++k)
|
||||
{
|
||||
i[k] = 0;
|
||||
order[k] = frank-1-k;
|
||||
}
|
||||
/* find outermost compact dim. */
|
||||
step = s[order[0]];
|
||||
ocd = 1;
|
||||
for (; ocd<frank; step *= s[order[ocd]], ++ocd)
|
||||
for (n=0; n!=N; ++n)
|
||||
if (step*as[n][order[0]].inc!=as[n][order[ocd]].inc)
|
||||
goto ocd_reached;
|
||||
ocd_reached: ;
|
||||
/* rank loop. */
|
||||
for (n=0; n!=N; ++n)
|
||||
base[n] = SCM_I_ARRAY_BASE(ai[n]);
|
||||
for (;;)
|
||||
{
|
||||
/* unrolled loop. */
|
||||
for (z=0; z!=step; ++z)
|
||||
{
|
||||
/* we are forced to create fresh array descriptors for each */
|
||||
/* call since we don't know whether the callee will keep them, */
|
||||
/* and Guile offers no way to copy the descriptor (since */
|
||||
/* descriptors are immutable). Yet another reason why this */
|
||||
/* should be in Scheme. */
|
||||
for (n=0; n<N; ++n)
|
||||
{
|
||||
*dargs[n] = scm_i_array_rebase(ai[n], base[n]);
|
||||
base[n] += as[n][order[0]].inc;
|
||||
}
|
||||
scm_apply_0(op, dargs_);
|
||||
}
|
||||
for (n=0; n<N; ++n)
|
||||
base[n] -= step*as[n][order[0]].inc;
|
||||
for (k=ocd; ; ++k)
|
||||
{
|
||||
if (k==frank)
|
||||
goto end;
|
||||
else if (i[order[k]]<s[order[k]]-1)
|
||||
{
|
||||
++i[order[k]];
|
||||
for (n=0; n<N; ++n)
|
||||
base[n] += as[n][order[k]].inc;
|
||||
break;
|
||||
}
|
||||
else
|
||||
{
|
||||
i[order[k]] = 0;
|
||||
for (n=0; n<N; ++n)
|
||||
base[n] += as[n][order[k]].inc*(1-s[order[k]]);
|
||||
}
|
||||
}
|
||||
}
|
||||
end:;
|
||||
for (n=0; n<N; ++n)
|
||||
scm_array_handle_release(ah+n);
|
||||
return SCM_UNSPECIFIED;
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
SCM_DEFINE (scm_array_for_each_cell_in_order, "array-for-each-cell-in-order", 2, 0, 1,
|
||||
(SCM frank, SCM op, SCM a),
|
||||
"Same as array-for-each-cell, but visit the cells sequentially\n"
|
||||
"and in row-major order.\n")
|
||||
#define FUNC_NAME s_scm_array_for_each_cell_in_order
|
||||
{
|
||||
return scm_array_for_each_cell (frank, op, a);
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
|
||||
void
|
||||
scm_init_array_map (void)
|
||||
{
|
||||
|
|
|
|||
|
|
@ -37,6 +37,10 @@ SCM_API SCM scm_array_map_x (SCM ra0, SCM proc, SCM lra);
|
|||
SCM_API SCM scm_array_for_each (SCM proc, SCM ra0, SCM lra);
|
||||
SCM_API SCM scm_array_index_map_x (SCM ra, SCM proc);
|
||||
SCM_API SCM scm_array_equal_p (SCM ra0, SCM ra1);
|
||||
SCM_API SCM scm_array_for_each_cell (SCM frank, SCM op, SCM args);
|
||||
SCM_API SCM scm_array_for_each_cell_in_order (SCM frank, SCM op, SCM args);
|
||||
|
||||
SCM_INTERNAL SCM scm_i_array_rebase (SCM a, size_t base);
|
||||
SCM_INTERNAL void scm_init_array_map (void);
|
||||
|
||||
#endif /* SCM_ARRAY_MAP_H */
|
||||
|
|
|
|||
|
|
@ -28,7 +28,6 @@
|
|||
#include <stdio.h>
|
||||
#include <errno.h>
|
||||
#include <string.h>
|
||||
#include <assert.h>
|
||||
|
||||
#include "verify.h"
|
||||
|
||||
|
|
@ -551,7 +550,7 @@ SCM_DEFINE (scm_array_amend_x, "array-amend!", 2, 0, 1,
|
|||
{ 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
|
||||
/* FIXME copying like this wastes the handle, and the bounds matching
|
||||
behavior of array-copy! is not strict. */
|
||||
scm_array_copy_x(b, o);
|
||||
}
|
||||
|
|
@ -569,7 +568,6 @@ SCM_DEFINE (scm_array_amend_x, "array-amend!", 2, 0, 1,
|
|||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
|
||||
#undef ARRAY_FROM_POS
|
||||
#undef ARRAY_FROM_GET_O
|
||||
|
||||
|
|
@ -948,6 +946,7 @@ scm_i_print_array (SCM array, SCM port, scm_print_state *pstate)
|
|||
return scm_i_print_array_dimension (&h, 0, 0, port, pstate);
|
||||
}
|
||||
|
||||
|
||||
void
|
||||
scm_init_arrays ()
|
||||
{
|
||||
|
|
|
|||
|
|
@ -115,7 +115,7 @@ SCM_TESTS = tests/00-initial-env.test \
|
|||
tests/r6rs-records-syntactic.test \
|
||||
tests/r6rs-unicode.test \
|
||||
tests/rnrs-libraries.test \
|
||||
tests/ramap.test \
|
||||
tests/array-map.test \
|
||||
tests/random.test \
|
||||
tests/rdelim.test \
|
||||
tests/reader.test \
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
;;;; ramap.test --- test array mapping functions -*- scheme -*-
|
||||
;;;; array-map.test --- test array mapping functions -*- scheme -*-
|
||||
;;;;
|
||||
;;;; Copyright (C) 2004, 2005, 2006, 2009, 2013 Free Software Foundation, Inc.
|
||||
;;;;
|
||||
|
|
@ -16,7 +16,7 @@
|
|||
;;;; License along with this library; if not, write to the Free Software
|
||||
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
|
||||
|
||||
(define-module (test-suite test-ramap)
|
||||
(define-module (test-suite test-array-map)
|
||||
#:use-module (test-suite lib))
|
||||
|
||||
(define exception:shape-mismatch
|
||||
|
|
@ -507,3 +507,34 @@
|
|||
(b (make-typed-array 'f64 0 0 2))
|
||||
(c (make-typed-array 'f64 0 2 0)))
|
||||
(array-for-each (lambda (b c) (set! a (cons* b c a))) b c)))))
|
||||
|
||||
;;;
|
||||
;;; array-for-each-cell
|
||||
;;;
|
||||
|
||||
(with-test-prefix "array-for-each-cell"
|
||||
|
||||
(pass-if-equal "1 argument frame rank 1"
|
||||
#2((1 3 9) (2 7 8))
|
||||
(let* ((a (list->array 2 '((9 1 3) (7 8 2)))))
|
||||
(array-for-each-cell 1 (lambda (a) (sort! a <)) a)
|
||||
a))
|
||||
|
||||
(pass-if-equal "2 arguments frame rank 1"
|
||||
#f64(8 -1)
|
||||
(let* ((x (list->typed-array 'f64 2 '((9 1) (7 8))))
|
||||
(y (f64vector 99 99)))
|
||||
(array-for-each-cell 1 (lambda (y x) (array-set! y (- (array-ref x 0) (array-ref x 1)))) y x)
|
||||
y))
|
||||
|
||||
(pass-if-equal "regression: zero-sized frame loop without unrolling"
|
||||
99
|
||||
(let* ((x 99)
|
||||
(o (make-array 0. 0 3 2)))
|
||||
(array-for-each-cell 2
|
||||
(lambda (o a0 a1)
|
||||
(set! x 0))
|
||||
o
|
||||
(make-shared-array (make-array 1. 0 1) (const '(0 0)) 0 3)
|
||||
(make-array 2. 0 3))
|
||||
x)))
|
||||
Loading…
Add table
Add a link
Reference in a new issue