mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-07-03 16:20:39 +02:00
Factor out make1array() in scm_ramapc()
* libguile/array-map.c: (scm_ramapc): factor out vector->array conversion to aux function make1array.
This commit is contained in:
Daniel Llorens
Andy Wingo
parent
4552a0c406
commit
d4f63dacdd
1 changed files with 91 additions and 94 deletions
|
|
@ -152,6 +152,19 @@ scm_ra_matchp (SCM ra0, SCM ras)
|
|||
return empty ? 5 : exact;
|
||||
}
|
||||
|
||||
|
||||
static SCM
|
||||
make1array (SCM v)
|
||||
{
|
||||
SCM a = scm_i_make_array (1);
|
||||
SCM_I_ARRAY_BASE (a) = 0;
|
||||
SCM_I_ARRAY_DIMS (a)->lbnd = 0;
|
||||
SCM_I_ARRAY_DIMS (a)->ubnd = scm_c_array_length (v) - 1;
|
||||
SCM_I_ARRAY_DIMS (a)->inc = 1;
|
||||
SCM_I_ARRAY_V (a) = v;
|
||||
return a;
|
||||
}
|
||||
|
||||
/* array mapper: apply cproc to each dimension of the given arrays?.
|
||||
int (*cproc) (); procedure to call on unrolled arrays?
|
||||
cproc (dest, source list) or
|
||||
|
|
@ -164,7 +177,7 @@ int
|
|||
scm_ramapc (void *cproc_ptr, SCM data, SCM ra0, SCM lra, const char *what)
|
||||
{
|
||||
SCM z;
|
||||
SCM vra0, ra1, vra1;
|
||||
SCM vra0;
|
||||
SCM lvra, *plvra;
|
||||
long *vinds;
|
||||
int k, kmax;
|
||||
|
|
@ -185,22 +198,13 @@ scm_ramapc (void *cproc_ptr, SCM data, SCM ra0, SCM lra, const char *what)
|
|||
if (scm_is_false (vra0))
|
||||
goto gencase;
|
||||
if (!SCM_I_ARRAYP (vra0))
|
||||
{
|
||||
size_t length = scm_c_array_length (vra0);
|
||||
vra1 = scm_i_make_array (1);
|
||||
SCM_I_ARRAY_BASE (vra1) = 0;
|
||||
SCM_I_ARRAY_DIMS (vra1)->lbnd = 0;
|
||||
SCM_I_ARRAY_DIMS (vra1)->ubnd = length - 1;
|
||||
SCM_I_ARRAY_DIMS (vra1)->inc = 1;
|
||||
SCM_I_ARRAY_V (vra1) = vra0;
|
||||
vra0 = vra1;
|
||||
}
|
||||
vra0 = make1array (vra0);
|
||||
lvra = SCM_EOL;
|
||||
plvra = &lvra;
|
||||
for (z = lra; scm_is_pair (z); z = SCM_CDR (z))
|
||||
{
|
||||
ra1 = SCM_CAR (z);
|
||||
vra1 = scm_i_make_array (1);
|
||||
SCM ra1 = SCM_CAR (z);
|
||||
SCM vra1 = scm_i_make_array (1);
|
||||
SCM_I_ARRAY_DIMS (vra1)->lbnd = SCM_I_ARRAY_DIMS (vra0)->lbnd;
|
||||
SCM_I_ARRAY_DIMS (vra1)->ubnd = SCM_I_ARRAY_DIMS (vra0)->ubnd;
|
||||
if (!SCM_I_ARRAYP (ra1))
|
||||
|
|
@ -224,90 +228,83 @@ scm_ramapc (void *cproc_ptr, SCM data, SCM ra0, SCM lra, const char *what)
|
|||
case 1:
|
||||
gencase: /* Have to loop over all dimensions. */
|
||||
vra0 = scm_i_make_array (1);
|
||||
if (SCM_I_ARRAYP (ra0))
|
||||
{
|
||||
kmax = SCM_I_ARRAY_NDIM (ra0) - 1;
|
||||
if (kmax < 0)
|
||||
{
|
||||
SCM_I_ARRAY_DIMS (vra0)->lbnd = 0;
|
||||
SCM_I_ARRAY_DIMS (vra0)->ubnd = 0;
|
||||
SCM_I_ARRAY_DIMS (vra0)->inc = 1;
|
||||
}
|
||||
else
|
||||
{
|
||||
SCM_I_ARRAY_DIMS (vra0)->lbnd = SCM_I_ARRAY_DIMS (ra0)[kmax].lbnd;
|
||||
SCM_I_ARRAY_DIMS (vra0)->ubnd = SCM_I_ARRAY_DIMS (ra0)[kmax].ubnd;
|
||||
SCM_I_ARRAY_DIMS (vra0)->inc = SCM_I_ARRAY_DIMS (ra0)[kmax].inc;
|
||||
}
|
||||
SCM_I_ARRAY_BASE (vra0) = SCM_I_ARRAY_BASE (ra0);
|
||||
SCM_I_ARRAY_V (vra0) = SCM_I_ARRAY_V (ra0);
|
||||
}
|
||||
else
|
||||
{
|
||||
size_t length = scm_c_array_length (ra0);
|
||||
kmax = 0;
|
||||
SCM_I_ARRAY_DIMS (vra0)->lbnd = 0;
|
||||
SCM_I_ARRAY_DIMS (vra0)->ubnd = length - 1;
|
||||
SCM_I_ARRAY_DIMS (vra0)->inc = 1;
|
||||
SCM_I_ARRAY_BASE (vra0) = 0;
|
||||
SCM_I_ARRAY_V (vra0) = ra0;
|
||||
ra0 = vra0;
|
||||
}
|
||||
lvra = SCM_EOL;
|
||||
plvra = &lvra;
|
||||
for (z = lra; scm_is_pair (z); z = SCM_CDR (z))
|
||||
{
|
||||
ra1 = SCM_CAR (z);
|
||||
vra1 = scm_i_make_array (1);
|
||||
SCM_I_ARRAY_DIMS (vra1)->lbnd = SCM_I_ARRAY_DIMS (vra0)->lbnd;
|
||||
SCM_I_ARRAY_DIMS (vra1)->ubnd = SCM_I_ARRAY_DIMS (vra0)->ubnd;
|
||||
if (SCM_I_ARRAYP (ra1))
|
||||
{
|
||||
if (kmax >= 0)
|
||||
SCM_I_ARRAY_DIMS (vra1)->inc = SCM_I_ARRAY_DIMS (ra1)[kmax].inc;
|
||||
SCM_I_ARRAY_V (vra1) = SCM_I_ARRAY_V (ra1);
|
||||
}
|
||||
else
|
||||
{
|
||||
SCM_I_ARRAY_DIMS (vra1)->inc = 1;
|
||||
SCM_I_ARRAY_V (vra1) = ra1;
|
||||
}
|
||||
*plvra = scm_cons (vra1, SCM_EOL);
|
||||
plvra = SCM_CDRLOC (*plvra);
|
||||
}
|
||||
if (SCM_I_ARRAYP (ra0))
|
||||
{
|
||||
kmax = SCM_I_ARRAY_NDIM (ra0) - 1;
|
||||
if (kmax < 0)
|
||||
{
|
||||
SCM_I_ARRAY_DIMS (vra0)->lbnd = 0;
|
||||
SCM_I_ARRAY_DIMS (vra0)->ubnd = 0;
|
||||
SCM_I_ARRAY_DIMS (vra0)->inc = 1;
|
||||
}
|
||||
else
|
||||
{
|
||||
SCM_I_ARRAY_DIMS (vra0)->lbnd = SCM_I_ARRAY_DIMS (ra0)[kmax].lbnd;
|
||||
SCM_I_ARRAY_DIMS (vra0)->ubnd = SCM_I_ARRAY_DIMS (ra0)[kmax].ubnd;
|
||||
SCM_I_ARRAY_DIMS (vra0)->inc = SCM_I_ARRAY_DIMS (ra0)[kmax].inc;
|
||||
}
|
||||
SCM_I_ARRAY_BASE (vra0) = SCM_I_ARRAY_BASE (ra0);
|
||||
SCM_I_ARRAY_V (vra0) = SCM_I_ARRAY_V (ra0);
|
||||
}
|
||||
else
|
||||
{
|
||||
kmax = 0;
|
||||
ra0 = vra0 = make1array(ra0);
|
||||
}
|
||||
lvra = SCM_EOL;
|
||||
plvra = &lvra;
|
||||
for (z = lra; !scm_is_null (z); z = SCM_CDR (z))
|
||||
{
|
||||
SCM ra1 = SCM_CAR (z);
|
||||
SCM vra1 = scm_i_make_array (1);
|
||||
SCM_I_ARRAY_DIMS (vra1)->lbnd = SCM_I_ARRAY_DIMS (vra0)->lbnd;
|
||||
SCM_I_ARRAY_DIMS (vra1)->ubnd = SCM_I_ARRAY_DIMS (vra0)->ubnd;
|
||||
if (SCM_I_ARRAYP (ra1))
|
||||
{
|
||||
if (kmax >= 0)
|
||||
SCM_I_ARRAY_DIMS (vra1)->inc = SCM_I_ARRAY_DIMS (ra1)[kmax].inc;
|
||||
SCM_I_ARRAY_V (vra1) = SCM_I_ARRAY_V (ra1);
|
||||
}
|
||||
else
|
||||
{
|
||||
SCM_I_ARRAY_DIMS (vra1)->inc = 1;
|
||||
SCM_I_ARRAY_V (vra1) = ra1;
|
||||
}
|
||||
*plvra = scm_cons (vra1, SCM_EOL);
|
||||
plvra = SCM_CDRLOC (*plvra);
|
||||
}
|
||||
|
||||
vinds = scm_gc_malloc_pointerless (sizeof(long) * SCM_I_ARRAY_NDIM (ra0),
|
||||
indices_gc_hint);
|
||||
vinds = scm_gc_malloc_pointerless (sizeof(long) * SCM_I_ARRAY_NDIM (ra0),
|
||||
indices_gc_hint);
|
||||
|
||||
for (k = 0; k <= kmax; k++)
|
||||
vinds[k] = SCM_I_ARRAY_DIMS (ra0)[k].lbnd;
|
||||
k = kmax;
|
||||
do
|
||||
{
|
||||
if (k == kmax)
|
||||
{
|
||||
SCM y = lra;
|
||||
SCM_I_ARRAY_BASE (vra0) = cind (ra0, vinds);
|
||||
for (z = lvra; scm_is_pair (z); z = SCM_CDR (z), y = SCM_CDR (y))
|
||||
SCM_I_ARRAY_BASE (SCM_CAR (z)) = cind (SCM_CAR (y), vinds);
|
||||
if (0 == (SCM_UNBNDP (data) ? cproc(vra0, lvra) : cproc(vra0, data, lvra)))
|
||||
return 0;
|
||||
k--;
|
||||
continue;
|
||||
}
|
||||
if (vinds[k] < SCM_I_ARRAY_DIMS (ra0)[k].ubnd)
|
||||
{
|
||||
vinds[k]++;
|
||||
k++;
|
||||
continue;
|
||||
}
|
||||
vinds[k] = SCM_I_ARRAY_DIMS (ra0)[k].lbnd - 1;
|
||||
k--;
|
||||
}
|
||||
while (k >= 0);
|
||||
for (k = 0; k <= kmax; k++)
|
||||
vinds[k] = SCM_I_ARRAY_DIMS (ra0)[k].lbnd;
|
||||
k = kmax;
|
||||
do
|
||||
{
|
||||
if (k == kmax)
|
||||
{
|
||||
SCM y = lra;
|
||||
SCM_I_ARRAY_BASE (vra0) = cind (ra0, vinds);
|
||||
for (z = lvra; !scm_is_null (z); z = SCM_CDR (z), y = SCM_CDR (y))
|
||||
SCM_I_ARRAY_BASE (SCM_CAR (z)) = cind (SCM_CAR (y), vinds);
|
||||
if (0 == (SCM_UNBNDP (data) ? cproc(vra0, lvra) : cproc(vra0, data, lvra)))
|
||||
return 0;
|
||||
k--;
|
||||
continue;
|
||||
}
|
||||
if (vinds[k] < SCM_I_ARRAY_DIMS (ra0)[k].ubnd)
|
||||
{
|
||||
vinds[k]++;
|
||||
k++;
|
||||
continue;
|
||||
}
|
||||
vinds[k] = SCM_I_ARRAY_DIMS (ra0)[k].lbnd - 1;
|
||||
k--;
|
||||
}
|
||||
while (k >= 0);
|
||||
|
||||
case 5:
|
||||
return 1;
|
||||
return 1;
|
||||
}
|
||||
}
|
||||
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue