mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-24 13:30:21 +02:00
Code Activity

(s_scm_array_map_x): update documentation; rename ra0 to

Browse source 
dest, and lra to sources; don't allow (and segfault on) calls
without source arrays, i.e. don't allow (array-map! x proc).
(ramap_1): minor code reformatting.
This commit is contained in:
Rob Browning 2004-08-29 23:02:53 +00:00
parent e01ebf2451
commit 2c9656e8c7
1 changed files with 58 additions and 47 deletions
Download patch file Download diff file Expand all files Collapse all files

103
libguile/ramap.c
View file

@ -1415,21 +1415,27 @@ ramap_rp (SCM ra0,SCM proc,SCM ras)
static int static int
ramap_1 (SCM ra0,SCM proc,SCM ras) ramap_1 (SCM ra0, SCM proc, SCM ras)
{ {
SCM ra1 = SCM_CAR (ras); SCM ra1 = SCM_CAR (ras);
SCM e1 = SCM_UNDEFINED; SCM e1 = SCM_UNDEFINED;
long n = SCM_ARRAY_DIMS (ra0)->ubnd - SCM_ARRAY_DIMS (ra0)->lbnd + 1; long n = SCM_ARRAY_DIMS (ra0)->ubnd - SCM_ARRAY_DIMS (ra0)->lbnd + 1;
unsigned long i0 = SCM_ARRAY_BASE (ra0), i1 = SCM_ARRAY_BASE (ra1); unsigned long i0 = SCM_ARRAY_BASE (ra0);
long inc0 = SCM_ARRAY_DIMS (ra0)->inc, inc1 = SCM_ARRAY_DIMS (ra1)->inc; unsigned long i1 = SCM_ARRAY_BASE (ra1);
long inc0 = SCM_ARRAY_DIMS (ra0)->inc;
long inc1 = SCM_ARRAY_DIMS (ra1)->inc;
ra0 = SCM_ARRAY_V (ra0); ra0 = SCM_ARRAY_V (ra0);
ra1 = SCM_ARRAY_V (ra1); ra1 = SCM_ARRAY_V (ra1);
if (scm_tc7_vector == SCM_TYP7 (ra0) || scm_tc7_wvect == SCM_TYP7 (ra0)) if (scm_tc7_vector == SCM_TYP7 (ra0) || scm_tc7_wvect == SCM_TYP7 (ra0))
for (; n-- > 0; i0 += inc0, i1 += inc1) for (; n-- > 0; i0 += inc0, i1 += inc1)
scm_array_set_x (ra0, SCM_SUBRF (proc) (scm_cvref (ra1, i1, SCM_UNDEFINED)), SCM_MAKINUM (i0)); scm_array_set_x (ra0,
SCM_SUBRF (proc) (scm_cvref (ra1, i1, SCM_UNDEFINED)),
SCM_MAKINUM (i0));
else else
for (; n-- > 0; i0 += inc0, i1 += inc1) for (; n-- > 0; i0 += inc0, i1 += inc1)
scm_array_set_x (ra0, SCM_SUBRF (proc) (RVREF (ra1, i1, e1)), SCM_MAKINUM (i0)); scm_array_set_x (ra0,
SCM_SUBRF (proc) (RVREF (ra1, i1, e1)),
SCM_MAKINUM (i0));
return 1; return 1;
} }
@ -1511,86 +1517,91 @@ SCM_REGISTER_PROC(s_array_map_in_order_x, "array-map-in-order!", 2, 0, 1, scm_ar
SCM_DEFINE (scm_array_map_x, "array-map!", 2, 0, 1, SCM_DEFINE (scm_array_map_x, "array-map!", 2, 0, 1,
(SCM ra0, SCM proc, SCM lra), (SCM dest, SCM proc, SCM sources),
"@deffnx {Scheme Procedure} array-map-in-order! ra0 proc . lra\n" "@var{dest} must be an array, and @var{sources} must be a non-empty list\n"
"@var{array1}, @dots{} must have the same number of dimensions as\n" "of arrays where each element must have the same number of dimensions as\n"
"@var{array0} and have a range for each index which includes the range\n" "@var{dest} and must have a range for each index which includes the range\n"
"for the corresponding index in @var{array0}. @var{proc} is applied to\n" "for the corresponding index in @var{dest}. @var{proc} is applied to\n"
"each tuple of elements of @var{array1} @dots{} and the result is stored\n" "each tuple of elements of @var{sources} and the result is stored as the\n"
"as the corresponding element in @var{array0}. The value returned is\n" "corresponding element in @var{dest}. The value returned is unspecified, and\n"
"unspecified. The order of application is unspecified.") "the order of application is unspecified.\n")
#define FUNC_NAME s_scm_array_map_x #define FUNC_NAME s_scm_array_map_x
{ {
SCM_VALIDATE_PROC (2,proc); SCM_VALIDATE_PROC (2,proc);
SCM_VALIDATE_REST_ARGUMENT (lra);
if (!(SCM_CONSP (sources) && SCM_CONSP (SCM_CDR (sources))))
{
SCM_MISC_ERROR ("At least one source array is required.", SCM_EOL);
}
switch (SCM_TYP7 (proc)) switch (SCM_TYP7 (proc))
{ {
default: default:
gencase: gencase:
scm_ramapc (ramap, proc, ra0, lra, FUNC_NAME); scm_ramapc (ramap, proc, dest, sources, FUNC_NAME);
return SCM_UNSPECIFIED; return SCM_UNSPECIFIED;
case scm_tc7_subr_1: case scm_tc7_subr_1:
scm_ramapc (ramap_1, proc, ra0, lra, FUNC_NAME); scm_ramapc (ramap_1, proc, dest, sources, FUNC_NAME);
return SCM_UNSPECIFIED; return SCM_UNSPECIFIED;
case scm_tc7_subr_2: case scm_tc7_subr_2:
case scm_tc7_subr_2o: case scm_tc7_subr_2o:
scm_ramapc (ramap_2o, proc, ra0, lra, FUNC_NAME); scm_ramapc (ramap_2o, proc, dest, sources, FUNC_NAME);
return SCM_UNSPECIFIED; return SCM_UNSPECIFIED;
case scm_tc7_cxr: case scm_tc7_cxr:
if (!SCM_SUBRF (proc)) if (!SCM_SUBRF (proc))
goto gencase; goto gencase;
scm_ramapc (ramap_cxr, proc, ra0, lra, FUNC_NAME); scm_ramapc (ramap_cxr, proc, dest, sources, FUNC_NAME);
return SCM_UNSPECIFIED; return SCM_UNSPECIFIED;
case scm_tc7_rpsubr: case scm_tc7_rpsubr:
{ {
ra_iproc *p; ra_iproc *p;
if (SCM_FALSEP (scm_array_p (ra0, SCM_BOOL_T))) if (SCM_FALSEP (scm_array_p (dest, SCM_BOOL_T)))
goto gencase; goto gencase;
scm_array_fill_x (ra0, SCM_BOOL_T); scm_array_fill_x (dest, SCM_BOOL_T);
for (p = ra_rpsubrs; p->name; p++) for (p = ra_rpsubrs; p->name; p++)
if (SCM_EQ_P (proc, p->sproc)) if (SCM_EQ_P (proc, p->sproc))
{ {
while (SCM_NNULLP (lra) && SCM_NNULLP (SCM_CDR (lra))) while (SCM_NNULLP (sources) && SCM_NNULLP (SCM_CDR (sources)))
{ {
scm_ramapc (p->vproc, SCM_UNDEFINED, ra0, lra, FUNC_NAME); scm_ramapc (p->vproc, SCM_UNDEFINED, dest, sources, FUNC_NAME);
lra = SCM_CDR (lra); sources = SCM_CDR (sources);
} }
return SCM_UNSPECIFIED; return SCM_UNSPECIFIED;
} }
while (SCM_NNULLP (lra) && SCM_NNULLP (SCM_CDR (lra))) while (SCM_NNULLP (sources) && SCM_NNULLP (SCM_CDR (sources)))
{ {
scm_ramapc (ramap_rp, proc, ra0, lra, FUNC_NAME); scm_ramapc (ramap_rp, proc, dest, sources, FUNC_NAME);
lra = SCM_CDR (lra); sources = SCM_CDR (sources);
} }
return SCM_UNSPECIFIED; return SCM_UNSPECIFIED;
} }
case scm_tc7_asubr: case scm_tc7_asubr:
if (SCM_NULLP (lra)) if (SCM_NULLP (sources))
{ {
SCM prot, fill = SCM_SUBRF (proc) (SCM_UNDEFINED, SCM_UNDEFINED); SCM prot, fill = SCM_SUBRF (proc) (SCM_UNDEFINED, SCM_UNDEFINED);
if (SCM_INUMP(fill)) if (SCM_INUMP(fill))
{ {
prot = scm_array_prototype (ra0); prot = scm_array_prototype (dest);
if (SCM_INEXACTP (prot)) if (SCM_INEXACTP (prot))
fill = scm_make_real ((double) SCM_INUM (fill)); fill = scm_make_real ((double) SCM_INUM (fill));
} }
scm_array_fill_x (ra0, fill); scm_array_fill_x (dest, fill);
} }
else else
{ {
SCM tail, ra1 = SCM_CAR (lra); SCM tail, ra1 = SCM_CAR (sources);
SCM v0 = (SCM_ARRAYP (ra0) ? SCM_ARRAY_V (ra0) : ra0); SCM v0 = (SCM_ARRAYP (dest) ? SCM_ARRAY_V (dest) : dest);
ra_iproc *p; ra_iproc *p;
/* Check to see if order might matter. /* Check to see if order might matter.
This might be an argument for a separate This might be an argument for a separate
SERIAL-ARRAY-MAP! */ SERIAL-ARRAY-MAP! */
if (SCM_EQ_P (v0, ra1) if (SCM_EQ_P (v0, ra1)
|| (SCM_ARRAYP (ra1) && SCM_EQ_P (v0, SCM_ARRAY_V (ra1)))) || (SCM_ARRAYP (ra1) && SCM_EQ_P (v0, SCM_ARRAY_V (ra1))))
if (!SCM_EQ_P (ra0, ra1) if (!SCM_EQ_P (dest, ra1)
|| (SCM_ARRAYP(ra0) && !SCM_ARRAY_CONTP(ra0))) || (SCM_ARRAYP(dest) && !SCM_ARRAY_CONTP(dest)))
goto gencase; goto gencase;
for (tail = SCM_CDR (lra); SCM_NNULLP (tail); tail = SCM_CDR (tail)) for (tail = SCM_CDR (sources); SCM_NNULLP (tail); tail = SCM_CDR (tail))
{ {
ra1 = SCM_CAR (tail); ra1 = SCM_CAR (tail);
if (SCM_EQ_P (v0, ra1) if (SCM_EQ_P (v0, ra1)
@ -1600,22 +1611,22 @@ SCM_DEFINE (scm_array_map_x, "array-map!", 2, 0, 1,
for (p = ra_asubrs; p->name; p++) for (p = ra_asubrs; p->name; p++)
if (SCM_EQ_P (proc, p->sproc)) if (SCM_EQ_P (proc, p->sproc))
{ {
if (!SCM_EQ_P (ra0, SCM_CAR (lra))) if (!SCM_EQ_P (dest, SCM_CAR (sources)))
scm_ramapc (scm_array_identity, SCM_UNDEFINED, ra0, scm_cons (SCM_CAR (lra), SCM_EOL), FUNC_NAME); scm_ramapc (scm_array_identity, SCM_UNDEFINED, dest, scm_cons (SCM_CAR (sources), SCM_EOL), FUNC_NAME);
lra = SCM_CDR (lra); sources = SCM_CDR (sources);
while (1) while (1)
{ {
scm_ramapc (p->vproc, SCM_UNDEFINED, ra0, lra, FUNC_NAME); scm_ramapc (p->vproc, SCM_UNDEFINED, dest, sources, FUNC_NAME);
if (SCM_IMP (lra) || SCM_IMP (SCM_CDR (lra))) if (SCM_IMP (sources) || SCM_IMP (SCM_CDR (sources)))
return SCM_UNSPECIFIED; return SCM_UNSPECIFIED;
lra = SCM_CDR (lra); sources = SCM_CDR (sources);
} }
} }
scm_ramapc (ramap_2o, proc, ra0, lra, FUNC_NAME); scm_ramapc (ramap_2o, proc, dest, sources, FUNC_NAME);
lra = SCM_CDR (lra); sources = SCM_CDR (sources);
if (SCM_NIMP (lra)) if (SCM_NIMP (sources))
for (lra = SCM_CDR (lra); SCM_NIMP (lra); lra = SCM_CDR (lra)) for (sources = SCM_CDR (sources); SCM_NIMP (sources); sources = SCM_CDR (sources))
scm_ramapc (ramap_a, proc, ra0, lra, FUNC_NAME); scm_ramapc (ramap_a, proc, dest, sources, FUNC_NAME);
} }
return SCM_UNSPECIFIED; return SCM_UNSPECIFIED;
} }