summaryrefslogtreecommitdiffstats
path: root/ramap.c
diff options
context:
space:
mode:
Diffstat (limited to 'ramap.c')
-rw-r--r--ramap.c383
1 files changed, 189 insertions, 194 deletions
diff --git a/ramap.c b/ramap.c
index d00e400..caf220f 100644
--- a/ramap.c
+++ b/ramap.c
@@ -1,18 +1,18 @@
/* Copyright (C) 1994, 1995 Free Software Foundation, Inc.
- *
+ *
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2, or (at your option)
* any later version.
- *
+ *
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
- *
+ *
* You should have received a copy of the GNU General Public License
* along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+ * the Free Software Foundation, 59 Temple Place, Suite 330, Boston, MA 02111, USA.
*
* As a special exception, the Free Software Foundation gives permission
* for additional uses of the text contained in its release of GUILE.
@@ -36,7 +36,7 @@
*
* If you write modifications of your own for GUILE, it is your choice
* whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice.
+ * If you do not wish that, delete this exception notice.
*/
/* "ramap.c" Array mapping functions for APL-Scheme.
@@ -65,18 +65,16 @@ typedef struct {
# define IVDEP(test, line) line
# endif
- /* inds must be a uvect or ivect, no check. */
static sizet cind(ra, inds)
- SCM ra, inds;
+ SCM ra;
+ long *inds;
{
sizet i;
int k;
- long *ve = VELTS(inds);
- if (!ARRAYP(ra))
- return *ve;
+ if (!ARRAYP(ra)) return *inds;
i = ARRAY_BASE(ra);
for (k = 0; k < ARRAY_NDIM(ra); k++)
- i += (ve[k] - ARRAY_DIMS(ra)[k].lbnd)*ARRAY_DIMS(ra)[k].inc;
+ i += (inds[k] - ARRAY_DIMS(ra)[k].lbnd)*ARRAY_DIMS(ra)[k].inc;
return i;
}
@@ -100,8 +98,8 @@ int ra_matchp(ra0, ras)
if IMP(ra0) return 0;
switch TYP7(ra0) {
default: return 0;
- case tc7_vector: case tc7_string: case tc7_bvect: case tc7_uvect:
- case tc7_ivect: case tc7_fvect: case tc7_dvect: case tc7_cvect:
+ case tc7_vector:
+ case tcs_uves:
s0->lbnd = 0;
s0->inc = 1;
s0->ubnd = (long)LENGTH(ra0) - 1;
@@ -118,8 +116,8 @@ int ra_matchp(ra0, ras)
switch (IMP(ra1) ? 0 : TYP7(ra1)) {
default: scalar:
CAR(ras) = sc2array(ra1,ra0,EOL); break;
- case tc7_vector: case tc7_string: case tc7_bvect: case tc7_uvect:
- case tc7_ivect: case tc7_fvect: case tc7_dvect: case tc7_cvect:
+ case tc7_vector:
+ case tcs_uves:
if (1 != ndim) return 0;
switch (exact) {
case 4: if (0 != bas0) exact = 3;
@@ -132,8 +130,8 @@ int ra_matchp(ra0, ras)
break;
case tc7_smob:
if (!ARRAYP(ra1)) goto scalar;
- if (ndim != ARRAY_NDIM(ra1))
- if (0==ARRAY_NDIM(ra1))
+ if (ndim != ARRAY_NDIM(ra1))
+ if (0==ARRAY_NDIM(ra1))
goto scalar;
else
return 0;
@@ -165,10 +163,8 @@ int ramapc(cproc, data, ra0, lra, what)
SCM data, ra0, lra;
char *what;
{
- SCM inds, z;
- SCM vra0, ra1, vra1;
+ SCM z, vra0, ra1, vra1;
SCM lvra, *plvra;
- long *vinds;
int k, kmax = (ARRAYP(ra0) ? ARRAY_NDIM(ra0) - 1 : 0);
switch (ra_matchp(ra0, lra)) {
default:
@@ -204,73 +200,81 @@ int ramapc(cproc, data, ra0, lra, what)
}
return (UNBNDP(data) ? cproc(vra0, lvra) : cproc(vra0, data, lvra));
case 1: gencase: /* Have to loop over all dimensions. */
- vra0 = make_ra(1);
- if ARRAYP(ra0) {
- if (kmax < 0) {
- ARRAY_DIMS(vra0)->lbnd = 0;
- ARRAY_DIMS(vra0)->ubnd = 0;
- ARRAY_DIMS(vra0)->inc = 1;
- }
- else {
- ARRAY_DIMS(vra0)->lbnd = ARRAY_DIMS(ra0)[kmax].lbnd;
- ARRAY_DIMS(vra0)->ubnd = ARRAY_DIMS(ra0)[kmax].ubnd;
- ARRAY_DIMS(vra0)->inc = ARRAY_DIMS(ra0)[kmax].inc;
+ {
+ SCM hp_indv;
+ long auto_indv[5];
+ long *indv = &auto_indv[0];
+ if (ARRAY_NDIM(ra0) >= 5) {
+ scm_protect_temp(&hp_indv);
+ hp_indv = make_uve(ARRAY_NDIM(ra0)+0L, MAKINUM(-1L));
+ indv = (long *)VELTS(hp_indv);
}
- ARRAY_BASE(vra0) = ARRAY_BASE(ra0);
- ARRAY_V(vra0) = ARRAY_V(ra0);
- }
- else {
- ARRAY_DIMS(vra0)->lbnd = 0;
- ARRAY_DIMS(vra0)->ubnd = LENGTH(ra0) - 1;
- ARRAY_DIMS(vra0)->inc = 1;
- ARRAY_BASE(vra0) = 0;
- ARRAY_V(vra0) = ra0;
- ra0 = vra0;
- }
- lvra = EOL;
- plvra = &lvra;
- for (z = lra; NIMP(z); z = CDR(z)) {
- ra1 = CAR(z);
- vra1 = make_ra(1);
- ARRAY_DIMS(vra1)->lbnd = ARRAY_DIMS(vra0)->lbnd;
- ARRAY_DIMS(vra1)->ubnd = ARRAY_DIMS(vra0)->ubnd;
- if ARRAYP(ra1) {
- if (kmax >= 0)
- ARRAY_DIMS(vra1)->inc = ARRAY_DIMS(ra1)[kmax].inc;
- ARRAY_V(vra1) = ARRAY_V(ra1);
+ vra0 = make_ra(1);
+ if ARRAYP(ra0) {
+ if (kmax < 0) {
+ ARRAY_DIMS(vra0)->lbnd = 0;
+ ARRAY_DIMS(vra0)->ubnd = 0;
+ ARRAY_DIMS(vra0)->inc = 1;
+ }
+ else {
+ ARRAY_DIMS(vra0)->lbnd = ARRAY_DIMS(ra0)[kmax].lbnd;
+ ARRAY_DIMS(vra0)->ubnd = ARRAY_DIMS(ra0)[kmax].ubnd;
+ ARRAY_DIMS(vra0)->inc = ARRAY_DIMS(ra0)[kmax].inc;
+ }
+ ARRAY_BASE(vra0) = ARRAY_BASE(ra0);
+ ARRAY_V(vra0) = ARRAY_V(ra0);
}
else {
- ARRAY_DIMS(vra1)->inc = 1;
- ARRAY_V(vra1) = ra1;
- }
- *plvra = cons(vra1, EOL);
- plvra = &CDR(*plvra);
- }
- inds = make_uve(ARRAY_NDIM(ra0)+0L, MAKINUM(-1L));
- vinds = (long *)VELTS(inds);
- for (k = 0; k <= kmax; k++)
- vinds[k] = ARRAY_DIMS(ra0)[k].lbnd;
- k = kmax;
- do {
- if (k==kmax) {
- SCM y = lra;
- ARRAY_BASE(vra0) = cind(ra0, inds);
- for (z = lvra; NIMP(z); z = CDR(z), y = CDR(y))
- ARRAY_BASE(CAR(z)) = cind(CAR(y), inds);
- if (0==(UNBNDP(data) ? cproc(vra0, lvra) : cproc(vra0, data, lvra)))
- return 0;
- k--;
- continue;
+ ARRAY_DIMS(vra0)->lbnd = 0;
+ ARRAY_DIMS(vra0)->ubnd = LENGTH(ra0) - 1;
+ ARRAY_DIMS(vra0)->inc = 1;
+ ARRAY_BASE(vra0) = 0;
+ ARRAY_V(vra0) = ra0;
+ ra0 = vra0;
}
- if (vinds[k] < ARRAY_DIMS(ra0)[k].ubnd) {
- vinds[k]++;
- k++;
- continue;
+ lvra = EOL;
+ plvra = &lvra;
+ for (z = lra; NIMP(z); z = CDR(z)) {
+ ra1 = CAR(z);
+ vra1 = make_ra(1);
+ ARRAY_DIMS(vra1)->lbnd = ARRAY_DIMS(vra0)->lbnd;
+ ARRAY_DIMS(vra1)->ubnd = ARRAY_DIMS(vra0)->ubnd;
+ if ARRAYP(ra1) {
+ if (kmax >= 0)
+ ARRAY_DIMS(vra1)->inc = ARRAY_DIMS(ra1)[kmax].inc;
+ ARRAY_V(vra1) = ARRAY_V(ra1);
+ }
+ else {
+ ARRAY_DIMS(vra1)->inc = 1;
+ ARRAY_V(vra1) = ra1;
+ }
+ *plvra = cons(vra1, EOL);
+ plvra = &CDR(*plvra);
}
- vinds[k] = ARRAY_DIMS(ra0)[k].lbnd - 1;
- k--;
- } while (k >= 0);
- return 1;
+ for (k = 0; k <= kmax; k++)
+ indv[k] = ARRAY_DIMS(ra0)[k].lbnd;
+ k = kmax;
+ do {
+ if (k==kmax) {
+ SCM y = lra;
+ ARRAY_BASE(vra0) = cind(ra0, indv);
+ for (z = lvra; NIMP(z); z = CDR(z), y = CDR(y))
+ ARRAY_BASE(CAR(z)) = cind(CAR(y), indv);
+ if (0==(UNBNDP(data) ? cproc(vra0, lvra) : cproc(vra0, data, lvra)))
+ return 0;
+ k--;
+ continue;
+ }
+ if (indv[k] < ARRAY_DIMS(ra0)[k].ubnd) {
+ indv[k]++;
+ k++;
+ continue;
+ }
+ indv[k] = ARRAY_DIMS(ra0)[k].lbnd - 1;
+ k--;
+ } while (k >= 0);
+ return 1;
+ }
}
}
@@ -349,7 +353,6 @@ static int racp(src, dst)
break;
}
# ifdef FLOATS
-# ifdef SINGLES
case tc7_fvect: {
float *d = (float *)VELTS(dst);
float *s = (float *)VELTS(src);
@@ -373,7 +376,6 @@ static int racp(src, dst)
}
break;
}
-# endif /* SINGLES */
case tc7_dvect: {
double *d = (double *)VELTS(dst);
double *s = (double *)VELTS(src);
@@ -544,7 +546,7 @@ SCM sc2array(s, ra, prot)
case tc7_string:
if ICHRP(s) break;
goto mismatch;
- case tc7_uvect:
+ case tc7_uvect:
if (INUMP(s) && INUM(s)>=0) break;
#ifdef BIGDIG
if (NIMP(s) && tc16_bigpos==TYP16(s) && NUMDIGS(s)<=DIGSPERLONG) break;
@@ -557,9 +559,7 @@ SCM sc2array(s, ra, prot)
#endif
goto mismatch;
#ifdef FLOATS
-#ifdef SINGLES
case tc7_fvect:
-#endif
case tc7_dvect:
if (NUMBERP(s) && !(NIMP(s) && CPLXP(s))) break;
goto mismatch;
@@ -603,14 +603,12 @@ int ra_eqp(ra0, ras)
if (VELTS(ra1)[i1] != VELTS(ra2)[i2]) BVE_CLR(ra0, i0);
break;
# ifdef FLOATS
-# ifdef SINGLES
case tc7_fvect:
for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
if BVE_REF(ra0, i0)
if (((float *)VELTS(ra1))[i1] != ((float *)VELTS(ra2))[i2])
BVE_CLR(ra0, i0);
break;
-# endif /*SINGLES*/
case tc7_dvect:
for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
if BVE_REF(ra0, i0)
@@ -671,7 +669,6 @@ static int ra_compare(ra0, ra1, ra2, opt)
}
break;
# ifdef FLOATS
-# ifdef SINGLES
case tc7_fvect:
for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
if BVE_REF(ra0, i0)
@@ -680,7 +677,6 @@ static int ra_compare(ra0, ra1, ra2, opt)
((float *)VELTS(ra1))[i1] >= ((float *)VELTS(ra2))[i2])
BVE_CLR(ra0, i0);
break;
-# endif /*SINGLES*/
case tc7_dvect:
for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
if BVE_REF(ra0, i0)
@@ -758,7 +754,6 @@ int ra_sum(ra0, ras)
break;
}
# ifdef FLOATS
-# ifdef SINGLES
case tc7_fvect: {
float *v0 = (float *)VELTS(ra0);
float *v1 = (float *)VELTS(ra1);
@@ -767,7 +762,6 @@ int ra_sum(ra0, ras)
v0[i0] += v1[i1]);
break;
}
-# endif /* SINGLES */
case tc7_dvect: {
double *v0 = (double *)VELTS(ra0);
double *v1 = (double *)VELTS(ra1);
@@ -814,14 +808,12 @@ int ra_difference(ra0, ras)
break;
}
# ifdef FLOATS
-# ifdef SINGLES
case tc7_fvect: {
float *v0 = (float *)VELTS(ra0);
for (; n-- > 0; i0 += inc0)
v0[i0] = -v0[i0];
break;
}
-# endif /* SINGLES */
case tc7_dvect: {
double *v0 = (double *)VELTS(ra0);
for (; n-- > 0; i0 += inc0)
@@ -875,7 +867,6 @@ int ra_difference(ra0, ras)
break;
}
# ifdef FLOATS
-# ifdef SINGLES
case tc7_fvect: {
float *v0 = (float *)VELTS(ra0);
float *v1 = (float *)VELTS(ra1);
@@ -884,7 +875,6 @@ int ra_difference(ra0, ras)
v0[i0] -= v1[i1]);
break;
}
-# endif /* SINGLES */
case tc7_dvect: {
double *v0 = (double *)VELTS(ra0);
double *v1 = (double *)VELTS(ra1);
@@ -953,7 +943,6 @@ int ra_product(ra0, ras)
break;
}
# ifdef FLOATS
-# ifdef SINGLES
case tc7_fvect: {
float *v0 = (float *)VELTS(ra0);
float *v1 = (float *)VELTS(ra1);
@@ -962,7 +951,6 @@ int ra_product(ra0, ras)
v0[i0] *= v1[i1]);
break;
}
-# endif /* SINGLES */
case tc7_dvect: {
double *v0 = (double *)VELTS(ra0);
double *v1 = (double *)VELTS(ra1);
@@ -1004,14 +992,12 @@ int ra_divide(ra0, ras)
break;
}
# ifdef FLOATS
-# ifdef SINGLES
case tc7_fvect: {
float *v0 = (float *)VELTS(ra0);
for (; n-- > 0; i0 += inc0)
v0[i0] = 1.0/v0[i0];
break;
}
-# endif /* SINGLES */
case tc7_dvect: {
double *v0 = (double *)VELTS(ra0);
for (; n-- > 0; i0 += inc0)
@@ -1044,7 +1030,6 @@ int ra_divide(ra0, ras)
break;
}
# ifdef FLOATS
-# ifdef SINGLES
case tc7_fvect: {
float *v0 = (float *)VELTS(ra0);
float *v1 = (float *)VELTS(ra1);
@@ -1053,7 +1038,6 @@ int ra_divide(ra0, ras)
v0[i0] /= v1[i1]);
break;
}
-# endif /* SINGLES */
case tc7_dvect: {
double *v0 = (double *)VELTS(ra0);
double *v1 = (double *)VELTS(ra1);
@@ -1089,34 +1073,29 @@ static int ra_identity(dst, src)
static int ramap(ra0, proc, ras)
SCM ra0, proc, ras;
{
- long i = ARRAY_DIMS(ra0)->lbnd;
- long inc = ARRAY_DIMS(ra0)->inc;
- long n = ARRAY_DIMS(ra0)->ubnd;
- long base = ARRAY_BASE(ra0) - i*inc;
- ra0 = ARRAY_V(ra0);
- if NULLP(ras)
- for (; i <= n; i++)
- aset(ra0, apply(proc, EOL, EOL), MAKINUM(i*inc + base));
- else {
- SCM ra1 = CAR(ras);
- SCM args, *ve = &ras;
- sizet k, i1 = ARRAY_BASE(ra1);
- long inc1 = ARRAY_DIMS(ra1)->inc;
- ra1 = ARRAY_V(ra1);
+ SCM heap_ve, auto_rav[5], auto_argv[5];
+ SCM *rav = &auto_rav[0], *argv = &auto_argv[0];
+ long argc = ilength(ras);
+ long i, k, inc, n, base;
+ scm_protect_temp(&heap_ve);
+ if (argc >= 5) {
+ heap_ve = make_vector(MAKINUM(2*argc), BOOL_F);
+ rav = VELTS(heap_ve);
+ argv = &(rav[n]);
+ }
+ for (k = 0; k < argc; k++) {
+ rav[k] = CAR(ras);
ras = CDR(ras);
- if NULLP(ras)
- ras = nullvect;
- else {
- ras = vector(ras);
- ve = VELTS(ras);
- }
- for (; i <= n; i++, i1 += inc1) {
- args = EOL;
- for (k = LENGTH(ras); k--;)
- args = cons(aref(ve[k], MAKINUM(i)), args);
- args = cons(cvref(ra1, i1, UNDEFINED), args);
- aset(ra0, apply(proc, args, EOL), MAKINUM(i*inc + base));
- }
+ }
+ i = ARRAY_DIMS(ra0)->lbnd;
+ inc = ARRAY_DIMS(ra0)->inc;
+ n = ARRAY_DIMS(ra0)->ubnd;
+ base = ARRAY_BASE(ra0) - i*inc;
+ ra0 = ARRAY_V(ra0);
+ for (; i <= n; i++) {
+ for (k = 0; k < argc; k++)
+ argv[k] = aref(rav[k], MAKINUM(i));
+ aset(ra0, scm_cvapply(proc, argc, argv), MAKINUM(i*inc + base));
}
return 1;
}
@@ -1132,11 +1111,12 @@ static int ramap_cxr(ra0, proc, ras)
ra1 = ARRAY_V(ra1);
switch TYP7(ra0) {
default: gencase:
- for (; n-- > 0; i0 += inc0, i1 += inc1)
- aset(ra0, apply(proc, RVREF(ra1, i1, e1), listofnull), MAKINUM(i0));
+ for (; n-- > 0; i0 += inc0, i1 += inc1) {
+ e1 = cvref(ra1, i1, e1);
+ aset(ra0, scm_cvapply(proc, 1L, &e1), MAKINUM(i0));
+ }
break;
# ifdef FLOATS
-# ifdef SINGLES
case tc7_fvect: {
float *dst = (float *)VELTS(ra0);
switch TYP7(ra1) {
@@ -1153,7 +1133,6 @@ static int ramap_cxr(ra0, proc, ras)
}
break;
}
-# endif /* SINGLES */
case tc7_dvect: {
double *dst = (double *)VELTS(ra0);
switch TYP7(ra1) {
@@ -1296,12 +1275,13 @@ static char s_sarray_map[] = "serial-array-map!";
SCM array_map(ra0, proc, lra)
SCM ra0, proc, lra;
{
- int narg = ilength(lra);
+ long narg = ilength(lra);
ASSERT(BOOL_T==procedurep(proc), proc, ARG2, s_array_map);
tail:
switch TYP7(proc) {
wna: wta(UNDEFINED, (char *)WNA, s_array_map);
default: gencase:
+ ASRTGO(scm_arity_check(proc, narg, s_array_map), wna);
ramapc(ramap, proc, ra0, lra, s_array_map);
return UNSPECIFIED;
case tc7_subr_1: ASRTGO(1==narg, wna);
@@ -1393,34 +1373,27 @@ SCM array_map(ra0, proc, lra)
static int rafe(ra0, proc, ras)
SCM ra0, proc, ras;
{
- long i = ARRAY_DIMS(ra0)->lbnd;
- sizet i0 = ARRAY_BASE(ra0);
- long inc0 = ARRAY_DIMS(ra0)->inc;
- long n = ARRAY_DIMS(ra0)->ubnd;
- ra0 = ARRAY_V(ra0);
- if NULLP(ras)
- for (; i <= n; i++, i0 += inc0)
- apply(proc, cvref(ra0, i0, UNDEFINED), listofnull);
- else {
- SCM ra1 = CAR(ras);
- SCM args, *ve = &ras;
- sizet k, i1 = ARRAY_BASE(ra1);
- long inc1 = ARRAY_DIMS(ra1)->inc;
- ra1 = ARRAY_V(ra1);
+ SCM heap_ve, auto_rav[5], auto_argv[5];
+ SCM *rav = &auto_rav[0], *argv = &auto_argv[0];
+ long argc = ilength(ras) + 1;
+ long i, k, inc, n, base;
+ scm_protect_temp(&heap_ve);
+ if (argc >= 5) {
+ heap_ve = make_vector(MAKINUM(2*argc), BOOL_F);
+ rav = VELTS(heap_ve);
+ argv = &(rav[n]);
+ }
+ rav[0] = ra0;
+ for (k = 1; k < argc; k++) {
+ rav[k] = CAR(ras);
ras = CDR(ras);
- if NULLP(ras)
- ras = nullvect;
- else {
- ras = vector(ras);
- ve = VELTS(ras);
- }
- for (; i <= n; i++, i0 += inc0, i1 += inc1) {
- args = EOL;
- for (k = LENGTH(ras); k--;)
- args = cons(aref(ve[k], MAKINUM(i)), args);
- args = cons2(cvref(ra0, i0, UNDEFINED), cvref(ra1, i1, UNDEFINED), args);
- apply(proc, args, EOL);
- }
+ }
+ i = ARRAY_DIMS(ra0)->lbnd;
+ n = ARRAY_DIMS(ra0)->ubnd;
+ for (; i <= n; i++) {
+ for (k = 0; k < argc; k++)
+ argv[k] = aref(rav[k], MAKINUM(i));
+ scm_cvapply(proc, argc, argv);
}
return 1;
}
@@ -1428,8 +1401,12 @@ static char s_array_for_each[] = "array-for-each";
SCM array_for_each(proc, ra0, lra)
SCM proc, ra0, lra;
{
+ long narg = ilength(lra) + 1;
ASSERT(BOOL_T==procedurep(proc), proc, ARG1, s_array_for_each);
tail:
+#ifndef RECKLESS
+ scm_arity_check(proc, narg, s_array_for_each);
+#endif
switch TYP7(proc) {
default: gencase:
ramapc(rafe, proc, ra0, lra, s_array_for_each);
@@ -1440,6 +1417,7 @@ SCM array_for_each(proc, ra0, lra)
lra = cons(ra0, lra);
ra0 = sc2array(proc, ra0, EOL);
proc = CCLO_SUBR(proc);
+ narg++;
goto tail;
}
goto gencase;
@@ -1451,53 +1429,68 @@ static char s_array_imap[] = "array-index-map!";
SCM array_imap(ra, proc)
SCM ra, proc;
{
+ SCM hp_av, hp_indv, auto_av[5];
+ SCM *av = &auto_av[0];
+ long auto_indv[5];
+ long *indv = &auto_indv[0];
sizet i;
ASSERT(NIMP(ra), ra, ARG1, s_array_imap);
ASSERT(BOOL_T==procedurep(proc), proc, ARG2, s_array_imap);
+ i = INUM(array_rank(ra));
+#ifndef RECKLESS
+ scm_arity_check(proc, i+0L, s_array_imap);
+#endif
+ if (i >= 5) {
+ scm_protect_temp(&hp_av);
+ scm_protect_temp(&hp_indv);
+ hp_av = make_vector(MAKINUM(i), BOOL_F);
+ av = VELTS(hp_av);
+ hp_indv = make_uve(i+0L, MAKINUM(-1L));
+ indv = (long *)VELTS(hp_indv);
+ }
switch TYP7(ra) {
default: badarg: wta(ra, (char *)ARG1, s_array_imap);
- case tc7_vector:
- {
- SCM *ve = VELTS(ra);
- for (i = 0; i < LENGTH(ra); i++)
- ve[i] = apply(proc, MAKINUM(i), listofnull);
- return UNSPECIFIED;
+ case tc7_vector: {
+ SCM *ve = VELTS(ra);
+ for (i = 0; i < LENGTH(ra); i++) {
+ av[0] = MAKINUM(i);
+ ve[i] = scm_cvapply(proc, 1L, av);
+ }
+ return UNSPECIFIED;
+ }
+ case tcs_uves:
+ for (i = 0; i < LENGTH(ra); i++) {
+ av[0] = MAKINUM(i);
+ aset(ra, scm_cvapply(proc, 1L, auto_av), MAKINUM(i));
}
- case tc7_string: case tc7_bvect: case tc7_uvect: case tc7_ivect:
- case tc7_fvect: case tc7_dvect: case tc7_cvect:
- for (i = 0; i < LENGTH(ra); i++)
- aset(ra, apply(proc, MAKINUM(i), listofnull), MAKINUM(i));
return UNSPECIFIED;
case tc7_smob: ASRTGO(ARRAYP(ra), badarg);
{
- SCM args = EOL;
- SCM inds = make_uve(ARRAY_NDIM(ra)+0L, MAKINUM(-1L));
- long *vinds = VELTS(inds);
int j, k, kmax = ARRAY_NDIM(ra) - 1;
if (kmax < 0)
return aset(ra, apply(proc, EOL, EOL), EOL);
for (k = 0; k <= kmax; k++)
- vinds[k] = ARRAY_DIMS(ra)[k].lbnd;
+ indv[k] = ARRAY_DIMS(ra)[k].lbnd;
k = kmax;
do {
if (k==kmax) {
- vinds[k] = ARRAY_DIMS(ra)[k].lbnd;
- i = cind(ra, inds);
- for (; vinds[k] <= ARRAY_DIMS(ra)[k].ubnd; vinds[k]++) {
- for (j = kmax+1, args = EOL; j--;)
- args = cons(MAKINUM(vinds[j]), args);
- aset(ARRAY_V(ra), apply(proc, args, EOL), MAKINUM(i));
+ indv[k] = ARRAY_DIMS(ra)[k].lbnd;
+ i = cind(ra, indv);
+ for (; indv[k] <= ARRAY_DIMS(ra)[k].ubnd; indv[k]++) {
+ for (j = kmax+1; j--;)
+ av[j] = MAKINUM(indv[j]);
+ aset(ARRAY_V(ra), scm_cvapply(proc, kmax+1L, av), MAKINUM(i));
i += ARRAY_DIMS(ra)[k].inc;
}
k--;
continue;
}
- if (vinds[k] < ARRAY_DIMS(ra)[k].ubnd) {
- vinds[k]++;
+ if (indv[k] < ARRAY_DIMS(ra)[k].ubnd) {
+ indv[k]++;
k++;
continue;
}
- vinds[k] = ARRAY_DIMS(ra)[k].lbnd - 1;
+ indv[k] = ARRAY_DIMS(ra)[k].lbnd - 1;
k--;
} while (k >= 0);
return UNSPECIFIED;
@@ -1556,7 +1549,6 @@ static int raeql_1(ra0, as_equal, ra1)
return 1;
}
# ifdef FLOATS
-# ifdef SINGLES
case tc7_fvect: {
float *v0 = (float *)VELTS(ra0) + i0;
float *v1 = (float *)VELTS(ra1) + i1;
@@ -1564,7 +1556,6 @@ static int raeql_1(ra0, as_equal, ra1)
if (*v0 != *v1) return 0;
return 1;
}
-# endif /* SINGLES */
case tc7_dvect: {
double *v0 = (double *)VELTS(ra0) + i0;
double *v1 = (double *)VELTS(ra1) + i1;
@@ -1634,16 +1625,14 @@ SCM array_equal(ra0, ra1)
callequal: return equal(ra0, ra1);
switch TYP7(ra0) {
default: goto callequal;
- case tc7_bvect: case tc7_string: case tc7_uvect: case tc7_ivect:
- case tc7_fvect: case tc7_dvect: case tc7_cvect: case tc7_vector:
- break;
+ case tc7_vector:
+ case tcs_uves: break;
case tc7_smob: if (!ARRAYP(ra0)) goto callequal;
}
switch TYP7(ra1) {
default: goto callequal;
- case tc7_bvect: case tc7_string: case tc7_uvect: case tc7_ivect:
- case tc7_fvect: case tc7_dvect: case tc7_cvect: case tc7_vector:
- break;
+ case tc7_vector:
+ case tcs_uves: break;
case tc7_smob: if (!ARRAYP(ra1)) goto callequal;
}
return (raeql(ra0, BOOL_F, ra1) ? BOOL_T : BOOL_F);
@@ -1672,7 +1661,7 @@ static void init_raprocs(subra)
ra_iproc *subra;
{
for(; subra->name; subra++)
- subra->sproc = CDR(intern(subra->name, strlen(subra->name)));
+ subra->sproc = CDR(sysintern(subra->name, UNDEFINED));
}
void init_ramap()
@@ -1685,4 +1674,10 @@ void init_ramap()
make_subr(s_array_equalp, tc7_rpsubr, array_equal);
smobs[0x0ff & (tc16_array>>8)].equalp = raequal;
add_feature(s_array_for_each);
+scm_ldstr("\n\
+(define (array-indexes ra)\n\
+ (let ((ra0 (apply make-array '() (array-shape ra))))\n\
+ (array-index-map! ra0 list)\n\
+ ra0))\n\
+");
}
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-21 22:25:56 +0000