mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-07-05 09:10:18 +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;
|
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?.
|
/* array mapper: apply cproc to each dimension of the given arrays?.
|
||||||
int (*cproc) (); procedure to call on unrolled arrays?
|
int (*cproc) (); procedure to call on unrolled arrays?
|
||||||
cproc (dest, source list) or
|
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_ramapc (void *cproc_ptr, SCM data, SCM ra0, SCM lra, const char *what)
|
||||||
{
|
{
|
||||||
SCM z;
|
SCM z;
|
||||||
SCM vra0, ra1, vra1;
|
SCM vra0;
|
||||||
SCM lvra, *plvra;
|
SCM lvra, *plvra;
|
||||||
long *vinds;
|
long *vinds;
|
||||||
int k, kmax;
|
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))
|
if (scm_is_false (vra0))
|
||||||
goto gencase;
|
goto gencase;
|
||||||
if (!SCM_I_ARRAYP (vra0))
|
if (!SCM_I_ARRAYP (vra0))
|
||||||
{
|
vra0 = make1array (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;
|
|
||||||
}
|
|
||||||
lvra = SCM_EOL;
|
lvra = SCM_EOL;
|
||||||
plvra = &lvra;
|
plvra = &lvra;
|
||||||
for (z = lra; scm_is_pair (z); z = SCM_CDR (z))
|
for (z = lra; scm_is_pair (z); z = SCM_CDR (z))
|
||||||
{
|
{
|
||||||
ra1 = SCM_CAR (z);
|
SCM ra1 = SCM_CAR (z);
|
||||||
vra1 = scm_i_make_array (1);
|
SCM vra1 = scm_i_make_array (1);
|
||||||
SCM_I_ARRAY_DIMS (vra1)->lbnd = SCM_I_ARRAY_DIMS (vra0)->lbnd;
|
SCM_I_ARRAY_DIMS (vra1)->lbnd = SCM_I_ARRAY_DIMS (vra0)->lbnd;
|
||||||
SCM_I_ARRAY_DIMS (vra1)->ubnd = SCM_I_ARRAY_DIMS (vra0)->ubnd;
|
SCM_I_ARRAY_DIMS (vra1)->ubnd = SCM_I_ARRAY_DIMS (vra0)->ubnd;
|
||||||
if (!SCM_I_ARRAYP (ra1))
|
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:
|
case 1:
|
||||||
gencase: /* Have to loop over all dimensions. */
|
gencase: /* Have to loop over all dimensions. */
|
||||||
vra0 = scm_i_make_array (1);
|
vra0 = scm_i_make_array (1);
|
||||||
if (SCM_I_ARRAYP (ra0))
|
if (SCM_I_ARRAYP (ra0))
|
||||||
{
|
{
|
||||||
kmax = SCM_I_ARRAY_NDIM (ra0) - 1;
|
kmax = SCM_I_ARRAY_NDIM (ra0) - 1;
|
||||||
if (kmax < 0)
|
if (kmax < 0)
|
||||||
{
|
{
|
||||||
SCM_I_ARRAY_DIMS (vra0)->lbnd = 0;
|
SCM_I_ARRAY_DIMS (vra0)->lbnd = 0;
|
||||||
SCM_I_ARRAY_DIMS (vra0)->ubnd = 0;
|
SCM_I_ARRAY_DIMS (vra0)->ubnd = 0;
|
||||||
SCM_I_ARRAY_DIMS (vra0)->inc = 1;
|
SCM_I_ARRAY_DIMS (vra0)->inc = 1;
|
||||||
}
|
}
|
||||||
else
|
else
|
||||||
{
|
{
|
||||||
SCM_I_ARRAY_DIMS (vra0)->lbnd = SCM_I_ARRAY_DIMS (ra0)[kmax].lbnd;
|
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)->ubnd = SCM_I_ARRAY_DIMS (ra0)[kmax].ubnd;
|
||||||
SCM_I_ARRAY_DIMS (vra0)->inc = SCM_I_ARRAY_DIMS (ra0)[kmax].inc;
|
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_BASE (vra0) = SCM_I_ARRAY_BASE (ra0);
|
||||||
SCM_I_ARRAY_V (vra0) = SCM_I_ARRAY_V (ra0);
|
SCM_I_ARRAY_V (vra0) = SCM_I_ARRAY_V (ra0);
|
||||||
}
|
}
|
||||||
else
|
else
|
||||||
{
|
{
|
||||||
size_t length = scm_c_array_length (ra0);
|
kmax = 0;
|
||||||
kmax = 0;
|
ra0 = vra0 = make1array(ra0);
|
||||||
SCM_I_ARRAY_DIMS (vra0)->lbnd = 0;
|
}
|
||||||
SCM_I_ARRAY_DIMS (vra0)->ubnd = length - 1;
|
lvra = SCM_EOL;
|
||||||
SCM_I_ARRAY_DIMS (vra0)->inc = 1;
|
plvra = &lvra;
|
||||||
SCM_I_ARRAY_BASE (vra0) = 0;
|
for (z = lra; !scm_is_null (z); z = SCM_CDR (z))
|
||||||
SCM_I_ARRAY_V (vra0) = ra0;
|
{
|
||||||
ra0 = vra0;
|
SCM ra1 = SCM_CAR (z);
|
||||||
}
|
SCM vra1 = scm_i_make_array (1);
|
||||||
lvra = SCM_EOL;
|
SCM_I_ARRAY_DIMS (vra1)->lbnd = SCM_I_ARRAY_DIMS (vra0)->lbnd;
|
||||||
plvra = &lvra;
|
SCM_I_ARRAY_DIMS (vra1)->ubnd = SCM_I_ARRAY_DIMS (vra0)->ubnd;
|
||||||
for (z = lra; scm_is_pair (z); z = SCM_CDR (z))
|
if (SCM_I_ARRAYP (ra1))
|
||||||
{
|
{
|
||||||
ra1 = SCM_CAR (z);
|
if (kmax >= 0)
|
||||||
vra1 = scm_i_make_array (1);
|
SCM_I_ARRAY_DIMS (vra1)->inc = SCM_I_ARRAY_DIMS (ra1)[kmax].inc;
|
||||||
SCM_I_ARRAY_DIMS (vra1)->lbnd = SCM_I_ARRAY_DIMS (vra0)->lbnd;
|
SCM_I_ARRAY_V (vra1) = SCM_I_ARRAY_V (ra1);
|
||||||
SCM_I_ARRAY_DIMS (vra1)->ubnd = SCM_I_ARRAY_DIMS (vra0)->ubnd;
|
}
|
||||||
if (SCM_I_ARRAYP (ra1))
|
else
|
||||||
{
|
{
|
||||||
if (kmax >= 0)
|
SCM_I_ARRAY_DIMS (vra1)->inc = 1;
|
||||||
SCM_I_ARRAY_DIMS (vra1)->inc = SCM_I_ARRAY_DIMS (ra1)[kmax].inc;
|
SCM_I_ARRAY_V (vra1) = ra1;
|
||||||
SCM_I_ARRAY_V (vra1) = SCM_I_ARRAY_V (ra1);
|
}
|
||||||
}
|
*plvra = scm_cons (vra1, SCM_EOL);
|
||||||
else
|
plvra = SCM_CDRLOC (*plvra);
|
||||||
{
|
}
|
||||||
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),
|
vinds = scm_gc_malloc_pointerless (sizeof(long) * SCM_I_ARRAY_NDIM (ra0),
|
||||||
indices_gc_hint);
|
indices_gc_hint);
|
||||||
|
|
||||||
for (k = 0; k <= kmax; k++)
|
for (k = 0; k <= kmax; k++)
|
||||||
vinds[k] = SCM_I_ARRAY_DIMS (ra0)[k].lbnd;
|
vinds[k] = SCM_I_ARRAY_DIMS (ra0)[k].lbnd;
|
||||||
k = kmax;
|
k = kmax;
|
||||||
do
|
do
|
||||||
{
|
{
|
||||||
if (k == kmax)
|
if (k == kmax)
|
||||||
{
|
{
|
||||||
SCM y = lra;
|
SCM y = lra;
|
||||||
SCM_I_ARRAY_BASE (vra0) = cind (ra0, vinds);
|
SCM_I_ARRAY_BASE (vra0) = cind (ra0, vinds);
|
||||||
for (z = lvra; scm_is_pair (z); z = SCM_CDR (z), y = SCM_CDR (y))
|
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);
|
SCM_I_ARRAY_BASE (SCM_CAR (z)) = cind (SCM_CAR (y), vinds);
|
||||||
if (0 == (SCM_UNBNDP (data) ? cproc(vra0, lvra) : cproc(vra0, data, lvra)))
|
if (0 == (SCM_UNBNDP (data) ? cproc(vra0, lvra) : cproc(vra0, data, lvra)))
|
||||||
return 0;
|
return 0;
|
||||||
k--;
|
k--;
|
||||||
continue;
|
continue;
|
||||||
}
|
}
|
||||||
if (vinds[k] < SCM_I_ARRAY_DIMS (ra0)[k].ubnd)
|
if (vinds[k] < SCM_I_ARRAY_DIMS (ra0)[k].ubnd)
|
||||||
{
|
{
|
||||||
vinds[k]++;
|
vinds[k]++;
|
||||||
k++;
|
k++;
|
||||||
continue;
|
continue;
|
||||||
}
|
}
|
||||||
vinds[k] = SCM_I_ARRAY_DIMS (ra0)[k].lbnd - 1;
|
vinds[k] = SCM_I_ARRAY_DIMS (ra0)[k].lbnd - 1;
|
||||||
k--;
|
k--;
|
||||||
}
|
}
|
||||||
while (k >= 0);
|
while (k >= 0);
|
||||||
|
|
||||||
case 5:
|
return 1;
|
||||||
return 1;
|
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
|
||||||
|
|
|
||||||
Loading…
Add table
Add a link
Reference in a new issue