mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 20:00:19 +02:00
Code Activity

Remove commented stack version of scm_array_for_each_cell()

Browse source 
* libguile/array-map.c: Ditto.
This commit is contained in:
Daniel Llorens 2016-06-22 14:55:27 +02:00
parent 4a361f2902
commit cbaa6cadcc
1 changed files with 0 additions and 214 deletions
Download patch file Download diff file Expand all files Collapse all files

214
libguile/array-map.c
View file

@ -886,220 +886,6 @@ SCM_DEFINE (scm_array_for_each_cell, "array-for-each-cell", 2, 0, 1,
}
#undef FUNC_NAME
/*
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
{
// FIXME replace stack by scm_gc_malloc_pointerless()
int const N = scm_ilength (args);
int const frank = scm_to_int (frame_rank);
SCM dargs_ = SCM_EOL;
scm_t_array_handle ah[N];
SCM args_[N];
scm_t_array_dim * as[N];
int rank[N];
ssize_t s[frank];
SCM ai[N];
SCM * dargs[N];
ssize_t i[frank];
int order[frank];
size_t base[N];
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;
// 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 (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.
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);
scm_t_array_dim * ais = SCM_I_ARRAY_DIMS(ai[n]);
for (int k=frank; k!=rank[n]; ++k)
{
ais[k-frank] = as[n][k];
}
}
// prepare rest list for callee.
{
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 (;;)
{
// unrolled loop.
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"