diff options
Diffstat (limited to 'libguile/arrays.c')
-rw-r--r-- | libguile/arrays.c | 228 |
1 files changed, 0 insertions, 228 deletions
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), |