Import Upstream version 5d2upstream/5d2

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\
+");
 }