summaryrefslogtreecommitdiff
path: root/libguile
diff options
context:
space:
mode:
authorDaniel Llorens <daniel.llorens@bluewin.ch>2016-04-01 12:46:37 +0200
committerDaniel Llorens <daniel.llorens@bluewin.ch>2016-07-11 09:11:50 +0200
commitf6003e88812c33e24e7038937e76e1292774ee98 (patch)
tree36df54ed8b2cdebd7d354522c8886f92ad4a9d4c /libguile
parent2ce48a3f4610228b8b4d8f65a1c501ebfff2b3f9 (diff)
downloadguile-f6003e88812c33e24e7038937e76e1292774ee98.tar.gz
Clean up (array-for-each-cell)
* libguile/array-map.c (array-for-each-cell, array-for-each-cell-in-order): Moved from libguile/arrays.c. Fix argument names. Complete docstring. * libguile/array-map.h (array-for-each-cell, array-for-each-cell-in-order): Declarations moved from libguile/arrays.h. * 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.
Diffstat (limited to 'libguile')
-rw-r--r--libguile/array-map.c244
-rw-r--r--libguile/array-map.h3
-rw-r--r--libguile/arrays.c228
-rw-r--r--libguile/arrays.h2
4 files changed, 246 insertions, 231 deletions
diff --git a/libguile/array-map.c b/libguile/array-map.c
index f07fd0060..0bbc095d5 100644
--- a/libguile/array-map.c
+++ b/libguile/array-map.c
@@ -42,6 +42,8 @@
#include "libguile/validate.h"
#include "libguile/array-map.h"
+
+#include <assert.h>
/* The WHAT argument for `scm_gc_malloc ()' et al. */
@@ -624,7 +626,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);
@@ -635,6 +638,244 @@ 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;
+}
+
+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);
+
+ // wish C had better stack support
+
+ size_t stack_size = 0;
+ stack_size += N*sizeof (scm_t_array_handle);
+ stack_size += N*sizeof (SCM);
+ stack_size += N*sizeof (scm_t_array_dim *);
+ stack_size += N*sizeof (int);
+ stack_size += frank*sizeof (ssize_t);
+
+ stack_size += N*sizeof (SCM);
+ stack_size += N*sizeof (SCM *);
+ stack_size += frank*sizeof (ssize_t);
+ stack_size += frank*sizeof (int);
+
+ stack_size += N*sizeof (size_t);
+ char * stack = scm_gc_malloc_pointerless (stack_size, "stack");
+
+#define AFIC_ALLOC_ADVANCE(stack, count, type, name) \
+ type * name = (void *)stack; \
+ stack += count*sizeof (type);
+
+ char * stack0 = stack;
+ AFIC_ALLOC_ADVANCE (stack, N, scm_t_array_handle, ah);
+ AFIC_ALLOC_ADVANCE (stack, N, SCM, args_);
+ AFIC_ALLOC_ADVANCE (stack, N, scm_t_array_dim *, as);
+ AFIC_ALLOC_ADVANCE (stack, N, int, rank);
+ AFIC_ALLOC_ADVANCE (stack, frank, ssize_t, s);
+
+ AFIC_ALLOC_ADVANCE (stack, N, SCM, ai);
+ AFIC_ALLOC_ADVANCE (stack, N, SCM *, dargs);
+ AFIC_ALLOC_ADVANCE (stack, frank, ssize_t, i);
+ AFIC_ALLOC_ADVANCE (stack, frank, int, order);
+
+ AFIC_ALLOC_ADVANCE(stack, N, size_t, base);
+ assert((stack0+stack_size==stack) && "internal error");
+#undef AFIC_ALLOC_ADVANCE
+
+ for (int 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.
+ char const * msg = NULL;
+ if (frank<0)
+ {
+ msg = "bad frame rank";
+ } else
+ {
+ for (int n=0; n!=N; ++n) {
+ if (rank[n]<frank) {
+ msg = "frame too large for arguments";
+ goto check_msg;
+ }
+ for (int 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;
+ }
+ }
+ }
+ check_msg: ;
+ if (msg!=NULL)
+ {
+ for (int 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.
+ scm_t_array_dim * ais[N];
+ for (int 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[n] = SCM_I_ARRAY_DIMS(ai[n]);
+ for (int k=frank; k!=rank[n]; ++k) {
+ ais[n][k-frank] = as[n][k];
+ }
+ }
+ // prepare rest list for callee.
+ SCM dargs_ = SCM_EOL;
+ {
+ SCM *p = &dargs_;
+ for (int 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 (int n=0; n<N; ++n)
+ {
+ *dargs[n] = ai[n];
+ }
+ scm_apply_0(op, dargs_);
+ for (int n=0; n<N; ++n)
+ {
+ scm_array_handle_release(ah+n);
+ }
+ return SCM_UNSPECIFIED;
+ }
+ // FIXME determine best looping order.
+ for (int k=0; k!=frank; ++k)
+ {
+ i[k] = 0;
+ order[k] = frank-1-k;
+ }
+ // find outermost compact dim.
+ ssize_t step = s[order[0]];
+ int ocd = 1;
+ for (; ocd<frank; step *= s[order[ocd]], ++ocd)
+ {
+ for (int 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 (int n=0; n!=N; ++n)
+ {
+ base[n] = SCM_I_ARRAY_BASE(ai[n]);
+ }
+ for (;;)
+ {
+ for (ssize_t 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 (int 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 (int n=0; n<N; ++n)
+ {
+ base[n] -= step*as[n][order[0]].inc;
+ }
+ for (int k=ocd; ; ++k)
+ {
+ if (k==frank)
+ {
+ goto end;
+ } else if (i[order[k]]<s[order[k]]-1)
+ {
+ ++i[order[k]];
+ for (int n=0; n<N; ++n)
+ {
+ base[n] += as[n][order[k]].inc;
+ }
+ break;
+ } else {
+ i[order[k]] = 0;
+ for (int n=0; n<N; ++n)
+ {
+ base[n] += as[n][order[k]].inc*(1-s[order[k]]);
+ }
+ }
+ }
+ }
+ end:;
+ for (int 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)
{
@@ -642,6 +883,7 @@ scm_init_array_map (void)
scm_add_feature (s_scm_array_for_each);
}
+
/*
Local Variables:
c-file-style: "gnu"
diff --git a/libguile/array-map.h b/libguile/array-map.h
index cb18a628a..8f2458995 100644
--- a/libguile/array-map.h
+++ b/libguile/array-map.h
@@ -37,6 +37,9 @@ 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 void scm_init_array_map (void);
#endif /* SCM_ARRAY_MAP_H */
diff --git a/libguile/arrays.c b/libguile/arrays.c
index 292d80ef6..d360cda3c 100644
--- a/libguile/arrays.c
+++ b/libguile/arrays.c
@@ -28,7 +28,6 @@
#include <stdio.h>
#include <errno.h>
#include <string.h>
-#include <assert.h>
#include "verify.h"
@@ -568,233 +567,6 @@ SCM_DEFINE (scm_array_amend_x, "array-amend!", 2, 0, 1,
#undef ARRAY_FROM_GET_O
-// 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;
-}
-
-SCM_DEFINE (scm_array_for_each_cell, "array-for-each-cell", 2, 0, 1,
- (SCM frank_, SCM op, SCM a_),
- "Apply op to each of the rank (-frank) cells of the arguments,\n"
- "in unspecified order. The first frank dimensions of the\n"
- "arguments must match. Rank-0 cells are passed as such.\n\n"
- "The value returned is unspecified.\n\n"
- "For example:\n"
- "@lisp\n"
- "@end lisp")
-#define FUNC_NAME s_scm_array_for_each_cell
-{
- int const N = scm_ilength (a_);
- int const frank = scm_to_int (frank_);
-
- // wish C had better stack support
-
- size_t stack_size = 0;
- stack_size += N*sizeof (scm_t_array_handle);
- stack_size += N*sizeof (SCM);
- stack_size += N*sizeof (scm_t_array_dim *);
- stack_size += N*sizeof (int);
- stack_size += frank*sizeof (ssize_t);
-
- stack_size += N*sizeof (SCM);
- stack_size += N*sizeof (SCM *);
- stack_size += frank*sizeof (ssize_t);
- stack_size += frank*sizeof (int);
-
- stack_size += N*sizeof(size_t);
- char * stack = scm_gc_malloc_pointerless (stack_size, "stack");
-
-#define AFIC_ALLOC_ADVANCE(stack, count, type, name) \
- type * name = (void *)stack; \
- stack += count*sizeof(type);
-
- char * stack0 = stack;
- AFIC_ALLOC_ADVANCE (stack, N, scm_t_array_handle, ah);
- AFIC_ALLOC_ADVANCE (stack, N, SCM, a);
- AFIC_ALLOC_ADVANCE (stack, N, scm_t_array_dim *, as);
- AFIC_ALLOC_ADVANCE (stack, N, int, rank);
- AFIC_ALLOC_ADVANCE (stack, frank, ssize_t, s);
-
- AFIC_ALLOC_ADVANCE (stack, N, SCM, ai);
- AFIC_ALLOC_ADVANCE (stack, N, SCM *, dargs);
- AFIC_ALLOC_ADVANCE (stack, frank, ssize_t, i);
- AFIC_ALLOC_ADVANCE (stack, frank, int, order);
-
- AFIC_ALLOC_ADVANCE(stack, N, size_t, base);
- assert((stack0+stack_size==stack) && "internal error");
-#undef AFIC_ALLOC_ADVANCE
-
- for (int n=0; scm_is_pair(a_); a_=scm_cdr(a_), ++n)
- {
- a[n] = scm_car(a_);
- scm_array_get_handle(a[n], ah+n);
- as[n] = scm_array_handle_dims(ah+n);
- rank[n] = scm_array_handle_rank(ah+n);
- }
- // checks.
- char const * msg = NULL;
- if (frank<0)
- {
- msg = "bad frame rank";
- } else
- {
- for (int n=0; n!=N; ++n) {
- if (rank[n]<frank) {
- msg = "frame too large for arguments";
- goto check_msg;
- }
- for (int 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;
- }
- }
- }
- check_msg: ;
- if (msg!=NULL)
- {
- for (int n=0; n!=N; ++n) {
- scm_array_handle_release(ah+n);
- }
- scm_misc_error("array-for-each-cell", msg, scm_cons_star(frank_, a_));
- }
- // prepare moving cells.
- scm_t_array_dim * ais[N];
- for (int 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(a[n]));
- // FIXME scm_array_handle_base (ah+n) should be in Guile
- SCM_I_ARRAY_SET_BASE (ai[n], ah[n].base);
- ais[n] = SCM_I_ARRAY_DIMS(ai[n]);
- for (int k=frank; k!=rank[n]; ++k) {
- ais[n][k-frank] = as[n][k];
- }
- }
- // prepare rest list for callee.
- SCM dargs_ = SCM_EOL;
- {
- SCM *p = &dargs_;
- for (int 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 (int n=0; n<N; ++n)
- {
- *dargs[n] = ai[n];
- }
- scm_apply_0(op, dargs_);
- for (int n=0; n<N; ++n)
- {
- scm_array_handle_release(ah+n);
- }
- return SCM_UNSPECIFIED;
- }
- // FIXME determine best looping order.
- for (int k=0; k!=frank; ++k)
- {
- i[k] = 0;
- order[k] = frank-1-k;
- }
- // find outermost compact dim.
- ssize_t step = s[order[0]];
- int ocd = 1;
- for (; ocd<frank; step *= s[order[ocd]], ++ocd)
- {
- for (int 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 (int n=0; n!=N; ++n)
- {
- base[n] = SCM_I_ARRAY_BASE(ai[n]);
- }
- for (;;)
- {
- for (ssize_t 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 (int 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 (int n=0; n<N; ++n)
- {
- base[n] -= step*as[n][order[0]].inc;
- }
- for (int k=ocd; ; ++k)
- {
- if (k==frank)
- {
- goto end;
- } else if (i[order[k]]<s[order[k]]-1)
- {
- ++i[order[k]];
- for (int n=0; n<N; ++n)
- {
- base[n] += as[n][order[k]].inc;
- }
- break;
- } else {
- i[order[k]] = 0;
- for (int n=0; n<N; ++n)
- {
- base[n] += as[n][order[k]].inc*(1-s[order[k]]);
- }
- }
- }
- }
- end:;
- for (int 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
-
-
/* 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 b43e93c29..890a902fe 100644
--- a/libguile/arrays.h
+++ b/libguile/arrays.h
@@ -52,8 +52,6 @@ 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_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_API SCM scm_list_to_array (SCM ndim, SCM lst);
SCM_API SCM scm_list_to_typed_array (SCM type, SCM ndim, SCM lst);