From 3278b75942bdbe706f7a0fba87729bb1e935b68b Mon Sep 17 00:00:00 2001 From: Bryan Newbold Date: Mon, 20 Feb 2017 00:05:25 -0800 Subject: Import Upstream version 5d2 --- ramap.c | 383 ++++++++++++++++++++++++++++++++-------------------------------- 1 file changed, 189 insertions(+), 194 deletions(-) (limited to 'ramap.c') 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\ +"); } -- cgit v1.2.3