From 7ef9d0ac2bd7af119212d659e94906ae9aa93a8f Mon Sep 17 00:00:00 2001 From: Daniel Llorens Date: Tue, 8 Sep 2015 16:57:30 +0200 Subject: 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. * 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. --- libguile/array-map.c | 260 ++++++++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 258 insertions(+), 2 deletions(-) (limited to 'libguile/array-map.c') diff --git a/libguile/array-map.c b/libguile/array-map.c index 1f00c92fa..19e85c369 100644 --- a/libguile/array-map.c +++ b/libguile/array-map.c @@ -41,7 +41,7 @@ #include "libguile/validate.h" #include "libguile/array-map.h" - +#include /* The WHAT argument for `scm_gc_malloc ()' et al. */ static const char vi_gc_hint[] = "array-indices"; @@ -628,7 +628,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); @@ -639,6 +640,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]