Import Upstream version 4e6upstream/4e6

1 files changed, 1677 insertions, 0 deletions

diff --git a/ramap.c b/ramap.c
new file mode 100644
index 0000000..b869ff6
--- /dev/null
+++ b/ramap.c
@@ -0,0 +1,1677 @@
+/* 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.
+ *
+ * As a special exception, the Free Software Foundation gives permission
+ * for additional uses of the text contained in its release of GUILE.
+ *
+ * The exception is that, if you link the GUILE library with other files
+ * to produce an executable, this does not by itself cause the
+ * resulting executable to be covered by the GNU General Public License.
+ * Your use of that executable is in no way restricted on account of
+ * linking the GUILE library code into it.
+ *
+ * This exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * This exception applies only to the code released by the
+ * Free Software Foundation under the name GUILE.  If you copy
+ * code from other Free Software Foundation releases into a copy of
+ * GUILE, as the General Public License permits, the exception does
+ * not apply to the code that you add in this way.  To avoid misleading
+ * anyone as to the status of such modified files, you must delete
+ * this exception notice from them.
+ *
+ * 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.  
+ */
+
+/* "ramap.c" Array mapping functions for APL-Scheme.
+   Author: Radey Shouman */
+
+#include "scm.h"
+
+typedef struct {
+  char *name;
+  SCM sproc;
+  int (* vproc)();
+} ra_iproc;
+
+# define BVE_REF(a, i) ((VELTS(a)[(i)/LONG_BIT] & (1L<<((i)%LONG_BIT))) ? 1 : 0)
+# define BVE_SET(a, i) (VELTS(a)[(i)/LONG_BIT] |= (1L<<((i)%LONG_BIT)))
+# define BVE_CLR(a, i) (VELTS(a)[(i)/LONG_BIT] &= ~(1L<<((i)%LONG_BIT)))
+/* Fast, recycling vector ref */
+# define RVREF(ra, i, e) (e = cvref(ra, i, e))
+/* #define RVREF(ra, i, e) (cvref(ra, i, UNDEFINED)) to turn off */
+
+/* IVDEP means "ignore vector dependencies", meaning we guarantee that
+   elements of vector operands are not aliased */
+# ifdef _UNICOS
+#  define IVDEP(test, line) if (test) {_Pragma("ivdep"); line} else {line}
+# else
+#  define IVDEP(test, line) line
+# endif
+
+				/* inds must be a uvect or ivect, no check. */
+static sizet cind(ra, inds)
+     SCM ra, inds;
+{
+  sizet i;
+  int k;
+  long *ve = VELTS(inds);
+  if (!ARRAYP(ra))
+    return *ve;
+  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;
+  return i;
+}
+
+  /* Checker for array mapping functions:
+     return values: 4 --> shapes, increments, and bases are the same;
+		    3 --> shapes and increments are the same;
+		    2 --> shapes are the same;
+		    1 --> ras are at least as big as ra0;
+		    0 --> no match.
+   */
+int ra_matchp(ra0, ras)
+     SCM ra0, ras;
+{
+  SCM ra1;
+  array_dim dims;
+  array_dim *s0 = &dims;
+  array_dim *s1;
+  sizet bas0 = 0;
+  int i, ndim = 1;
+  int exact = 2    /* 4 */;	/* Don't care about values >2 (yet?) */
+  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:
+    s0->lbnd = 0;
+    s0->inc = 1;
+    s0->ubnd = (long)LENGTH(ra0) - 1;
+    break;
+  case tc7_smob:
+    if (!ARRAYP(ra0)) return 0;
+    ndim = ARRAY_NDIM(ra0);
+    s0 = ARRAY_DIMS(ra0);
+    bas0 = ARRAY_BASE(ra0);
+    break;
+  }
+  while NIMP(ras) {
+    ra1 = CAR(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:
+      if (1 != ndim) return 0;
+      switch (exact) {
+      case 4: if (0 != bas0) exact = 3;
+      case 3: if (1 != s0->inc) exact = 2;
+      case 2: if ((0==s0->lbnd) && (s0->ubnd==LENGTH(ra1) - 1)) break;
+	exact = 1;
+      case 1: if (s0->lbnd < 0 || s0->ubnd >= LENGTH(ra1))
+	if (s0->lbnd <= s0->ubnd) return 0;
+      }
+      break;
+    case tc7_smob:
+      if (!ARRAYP(ra1)) goto scalar;
+      if (ndim != ARRAY_NDIM(ra1)) 
+	if (0==ARRAY_NDIM(ra1)) 
+	  goto scalar;
+	else
+	  return 0;
+      s1 = ARRAY_DIMS(ra1);
+      if (bas0 != ARRAY_BASE(ra1)) exact = 3;
+      for (i = 0; i < ndim; i++)
+	switch (exact) {
+	case 4: case 3:
+	  if (s0[i].inc != s1[i].inc)
+	    exact = 2;
+	case 2:
+	  if (s0[i].lbnd==s1[i].lbnd && s0[i].ubnd==s1[i].ubnd)
+	    break;
+	  exact = 1;
+	default:
+	  if (s0[i].lbnd < s1[i].lbnd || s0[i].ubnd > s1[i].ubnd)
+	    if (s0[i].lbnd <= s0[i].ubnd) return 0;
+	}
+      break;
+    }
+    ras = CDR(ras);
+  }
+  return exact;
+}
+
+static char s_ra_mismatch[] = "array shape mismatch";
+int ramapc(cproc, data, ra0, lra, what)
+     int (*cproc)();
+     SCM data, ra0, lra;
+     char *what;
+{
+  SCM inds, z;
+  SCM vra0, ra1, vra1;
+  SCM lvra, *plvra;
+  long *vinds;
+  int k, kmax = (ARRAYP(ra0) ? ARRAY_NDIM(ra0) - 1 : 0);
+  switch (ra_matchp(ra0, lra)) {
+  default:
+  case 0: wta(ra0, s_ra_mismatch, what);
+  case 2: case 3: case 4:	/* Try unrolling arrays */
+    if (kmax < 0) goto gencase;
+    vra0 = (0==kmax ? ra0 : array_contents(ra0, UNDEFINED));
+    if IMP(vra0) goto gencase;
+    if (!ARRAYP(vra0)) {
+      vra1 = make_ra(1);
+      ARRAY_BASE(vra1) = 0;
+      ARRAY_DIMS(vra1)->lbnd = 0;
+      ARRAY_DIMS(vra1)->ubnd = LENGTH(vra0) - 1;
+      ARRAY_DIMS(vra1)->inc = 1;
+      ARRAY_V(vra1) = vra0;
+      vra0 = vra1;
+    }
+    lvra = EOL;
+    plvra = &lvra;
+    for (z = lra; NIMP(z); z = CDR(z)) {
+      vra1 = ra1 = (0==kmax ? CAR(z) : array_contents(CAR(z), UNDEFINED));
+      if FALSEP(ra1) goto gencase;
+      if (!ARRAYP(ra1)) {
+	vra1 = make_ra(1);
+	ARRAY_DIMS(vra1)->lbnd = ARRAY_DIMS(vra0)->lbnd;
+	ARRAY_DIMS(vra1)->ubnd = ARRAY_DIMS(vra0)->ubnd;
+	ARRAY_BASE(vra1) = 0;
+	ARRAY_DIMS(vra1)->inc = 1;
+	ARRAY_V(vra1) = ra1;
+      }
+      *plvra = cons(vra1, EOL);
+      plvra = &CDR(*plvra);
+    }
+    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;
+      }
+      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);
+      }
+      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;
+      }
+      if (vinds[k] < ARRAY_DIMS(ra0)[k].ubnd) {
+	vinds[k]++;
+	k++;
+	continue;
+      }
+      vinds[k] = ARRAY_DIMS(ra0)[k].lbnd - 1;
+      k--;
+    } while (k >= 0);
+    return 1;
+  }
+}
+
+static char s_array_fill[] = "array-fill!";
+SCM array_fill(ra, fill)
+     SCM ra, fill;
+{
+  ramapc(rafill, fill, ra, EOL, s_array_fill);
+  return UNSPECIFIED;
+}
+
+static char s_sarray_copy[] = "serial-array-copy!";
+# define s_array_copy  (s_sarray_copy + 7)
+static int racp(src, dst)
+     SCM dst, src;
+{
+  long n = (ARRAY_DIMS(src)->ubnd - ARRAY_DIMS(src)->lbnd + 1);
+  long inc_d, inc_s = ARRAY_DIMS(src)->inc;
+  sizet i_d, i_s = ARRAY_BASE(src);
+  dst = CAR(dst);
+  inc_d = ARRAY_DIMS(dst)->inc;
+  i_d = ARRAY_BASE(dst);
+  src = ARRAY_V(src);
+  dst = ARRAY_V(dst);
+  switch TYP7(dst) {
+  default: gencase: case tc7_vector:
+    for (; n-- > 0; i_s += inc_s, i_d += inc_d)
+      aset(dst, cvref(src, i_s, UNDEFINED), MAKINUM(i_d));
+    break;
+  case tc7_string: if (tc7_string != TYP7(dst)) goto gencase;
+    for (; n-- > 0; i_s += inc_s, i_d += inc_d)
+      CHARS(dst)[i_d] = CHARS(src)[i_s];
+    break;
+  case tc7_bvect: if (tc7_bvect != TYP7(dst)) goto gencase;
+    if (1==inc_d && 1==inc_s && i_s%LONG_BIT==i_d%LONG_BIT && n>=LONG_BIT) {
+      long *sv = (long *)VELTS(src);
+      long *dv = (long *)VELTS(dst);
+      sv += i_s/LONG_BIT;
+      dv += i_d/LONG_BIT;
+      if (i_s % LONG_BIT) {	/* leading partial word */
+	*dv = (*dv & ~(~0L<<(i_s%LONG_BIT))) | (*sv & (~0L<<(i_s%LONG_BIT)));
+	dv++;
+	sv++;
+	n -= LONG_BIT - (i_s % LONG_BIT);
+      }
+      IVDEP(src != dst,
+	    for (; n >= LONG_BIT; n -= LONG_BIT, sv++, dv++)
+	      *dv = *sv;)
+      if (n)			/* trailing partial word */
+	*dv = (*dv & (~0L<<n)) | (*sv & ~(~0L<<n));
+    }
+    else {
+      for (; n-- > 0; i_s += inc_s, i_d += inc_d)
+	if (VELTS(src)[i_s/LONG_BIT] & (1L << (i_s%LONG_BIT)))
+	  VELTS(dst)[i_d/LONG_BIT] |= (1L << (i_d%LONG_BIT));
+	else
+	  VELTS(dst)[i_d/LONG_BIT] &= ~(1L << (i_d%LONG_BIT));
+    }
+    break;
+  case tc7_uvect:
+  case tc7_ivect: {
+    long *d = (long *)VELTS(dst), *s = (long *)VELTS(src);
+    if (TYP7(src)==TYP7(dst)) {
+      IVDEP(src != dst,
+	    for (; n-- > 0; i_s += inc_s, i_d += inc_d)
+	      d[i_d] = s[i_s];)
+    }
+    else if (tc7_ivect==TYP7(dst))
+      for (; n-- > 0; i_s += inc_s, i_d += inc_d)
+	d[i_d] = num2long(cvref(src, i_s, UNDEFINED),
+			  (char *)ARG2, s_array_copy);
+    else
+      for (; n-- > 0; i_s += inc_s, i_d += inc_d)
+	d[i_d] = num2ulong(cvref(src, i_s, UNDEFINED),
+			   (char *)ARG2, s_array_copy);
+    break;
+  }
+# ifdef FLOATS
+#  ifdef SINGLES
+  case tc7_fvect: {
+    float *d = (float *)VELTS(dst);
+    float *s = (float *)VELTS(src);
+    switch TYP7(src) {
+    default: goto gencase;
+    case tc7_ivect: case tc7_uvect:
+      IVDEP(src != dst,
+	    for (; n-- > 0; i_s += inc_s, i_d += inc_d)
+	      d[i_d] = ((long *)s)[i_s]; )
+      break;
+    case tc7_fvect:
+      IVDEP(src != dst,
+	    for (; n-- > 0; i_s += inc_s, i_d += inc_d)
+	      d[i_d] = s[i_s]; )
+      break;
+    case tc7_dvect:
+      IVDEP(src != dst,
+	    for (; n-- > 0; i_s += inc_s, i_d += inc_d)
+	      d[i_d] = ((double *)s)[i_s]; )
+      break;
+    }
+    break;
+  }
+#  endif /* SINGLES */
+  case tc7_dvect: {
+    double *d = (double *)VELTS(dst);
+    double *s = (double *)VELTS(src);
+    switch TYP7(src) {
+    default: goto gencase;
+    case tc7_ivect: case tc7_uvect:
+      IVDEP(src != dst,
+	    for (; n-- > 0; i_s += inc_s, i_d += inc_d)
+	      d[i_d] = ((long *)s)[i_s]; )
+      break;
+    case tc7_fvect:
+      IVDEP(src != dst,
+	    for (; n-- > 0; i_s += inc_s, i_d += inc_d)
+	      d[i_d] = ((float *)s)[i_s];)
+      break;
+    case tc7_dvect:
+      IVDEP(src != dst,
+	    for (; n-- > 0; i_s += inc_s, i_d += inc_d)
+	      d[i_d] = s[i_s];)
+      break;
+    }
+    break;
+  }
+  case tc7_cvect: {
+    double (*d)[2] = (double (*)[2])VELTS(dst);
+    double (*s)[2] = (double (*)[2])VELTS(src);
+    switch TYP7(src) {
+    default: goto gencase;
+    case tc7_ivect: case tc7_uvect:
+      IVDEP(src != dst,
+	    for (; n-- > 0; i_s += inc_s, i_d += inc_d) {
+	      d[i_d][0] = ((long *)s)[i_s];
+	      d[i_d][1] = 0.0;
+	    })
+      break;
+    case tc7_fvect:
+      IVDEP(src != dst,
+	    for (; n-- > 0; i_s += inc_s, i_d += inc_d) {
+	      d[i_d][0] = ((float *)s)[i_s];
+	      d[i_d][1] = 0.0;
+	    })
+      break;
+    case tc7_dvect:
+      IVDEP(src != dst,
+	    for (; n-- > 0; i_s += inc_s, i_d += inc_d) {
+	      d[i_d][0] = ((double *)s)[i_s];
+	      d[i_d][1] = 0.0;
+	    })
+      break;
+    case tc7_cvect:
+      IVDEP(src != dst,
+	    for (; n-- > 0; i_s += inc_s, i_d += inc_d) {
+	      d[i_d][0] = s[i_s][0];
+	      d[i_d][1] = s[i_s][1];
+	    })
+    }
+    break;
+  }
+# endif /* FLOATS */
+  }
+  return 1;
+}
+SCM array_copy(src, dst)
+     SCM src;
+     SCM dst;
+{
+#ifndef RECKLESS
+  if (INUM0==array_rank(dst))
+    ASSERT(NIMP(dst) && ARRAYP(dst) && INUM0==array_rank(src),
+	   dst, ARG2, s_array_copy);
+#endif
+  ramapc(racp, UNDEFINED, src, cons(dst, EOL), s_array_copy);
+  return UNSPECIFIED;
+}
+
+SCM ra2contig(ra, copy)
+     SCM ra;
+     int copy;
+{
+  SCM ret;
+  long inc = 1;
+  sizet k, len = 1;
+  for (k = ARRAY_NDIM(ra); k--;)
+    len *= ARRAY_DIMS(ra)[k].ubnd - ARRAY_DIMS(ra)[k].lbnd + 1;
+  k = ARRAY_NDIM(ra);
+  if (ARRAY_CONTP(ra) && ((0==k) || (1==ARRAY_DIMS(ra)[k-1].inc))) {
+    if (tc7_bvect != TYP7(ARRAY_V(ra)))
+      return ra;
+    if ((len==LENGTH(ARRAY_V(ra)) &&
+	 0==ARRAY_BASE(ra) % LONG_BIT &&
+	 0==len % LONG_BIT))
+      return ra;
+  }
+  ret = make_ra(k);
+  ARRAY_BASE(ret) = 0;
+  while (k--) {
+    ARRAY_DIMS(ret)[k].lbnd = ARRAY_DIMS(ra)[k].lbnd;
+    ARRAY_DIMS(ret)[k].ubnd = ARRAY_DIMS(ra)[k].ubnd;
+    ARRAY_DIMS(ret)[k].inc = inc;
+    inc *= ARRAY_DIMS(ra)[k].ubnd - ARRAY_DIMS(ra)[k].lbnd + 1;
+  }
+  CAR(ret) |= ARRAY_CONTIGUOUS;
+  ARRAY_V(ret) = make_uve(inc+0L, array_prot(ra));
+  if (copy) array_copy(ra, ret);
+  return ret;
+}
+
+static char s_ura_rd[] = "uniform-array-read!";
+SCM ura_read(ra, port)
+     SCM ra, port;
+{
+  SCM ret, cra;
+  if (NIMP(ra) && ARRAYP(ra)) {
+    cra = ra2contig(ra, 0);
+    ret = uve_read(cra, port);
+    if (cra != ra) array_copy(cra, ra);
+    return ret;
+  }
+  else return uve_read(ra, port);
+}
+
+static char s_ura_wr[] = "uniform-array-write";
+SCM ura_write(ra, port)
+     SCM ra, port;
+{
+  if (NIMP(ra) && ARRAYP(ra))
+    return uve_write(ra2contig(ra,1), port);
+  else
+    return uve_write(ra, port);
+}
+
+static char s_sc2array[] = "scalar->array";
+SCM sc2array(s, ra, prot)
+     SCM s, ra, prot;
+{
+  SCM res;
+  ASSERT(NIMP(ra), ra, ARG2, s_sc2array);
+  if ARRAYP(ra) {
+    int k = ARRAY_NDIM(ra);
+    res = make_ra(k);
+    while (k--) {
+      ARRAY_DIMS(res)[k].ubnd = ARRAY_DIMS(ra)[k].ubnd;
+      ARRAY_DIMS(res)[k].lbnd = ARRAY_DIMS(ra)[k].lbnd;
+      ARRAY_DIMS(res)[k].inc = 0;
+    }
+    ra = ARRAY_V(ra);
+  }
+  else {
+    ASSERT(BOOL_T==arrayp(ra, UNDEFINED), ra, ARG2, s_sc2array);
+    res = make_ra(1);
+    ARRAY_DIMS(res)->ubnd = LENGTH(ra) - 1;
+    ARRAY_DIMS(res)->lbnd = 0;
+    ARRAY_DIMS(res)->inc = 0;
+  }
+  if (NIMP(s) && ARRAYP(s) && 0==ARRAY_NDIM(s)) {
+    ARRAY_BASE(res) = ARRAY_BASE(s);
+    ARRAY_V(res) = ARRAY_V(s);
+    return res;
+  }
+  ARRAY_BASE(res) = 0;
+  ARRAY_V(res) = make_uve(1L, NULLP(prot) ? array_prot(ra) : CAR(prot));
+  switch TYP7(ARRAY_V(res)) {
+  case tc7_vector:
+    break;
+  case tc7_string:
+    if ICHRP(s) break;
+    goto mismatch;
+  case tc7_uvect: 
+    if (INUMP(s) && INUM(s)>=0) break;
+#ifdef BIGDIG
+    if (NIMP(s) && tc16_bigpos==TYP16(s) && NUMDIGS(s)<=DIGSPERLONG) break;
+#endif
+    goto mismatch;
+  case tc7_ivect:
+    if INUMP(s) break;
+#ifdef BIGDIG
+    if (NIMP(s) && BIGP(s) && NUMDIGS(s)<=DIGSPERLONG) break;
+#endif
+    goto mismatch;
+#ifdef FLOATS
+#ifdef SINGLES
+  case tc7_fvect:
+#endif
+  case tc7_dvect:
+    if (NUMBERP(s) && !(NIMP(s) && CPLXP(s))) break;
+    goto mismatch;
+  case tc7_cvect:
+    if NUMBERP(s) break;
+    goto mismatch;
+#endif
+  mismatch: ARRAY_V(res) = make_vector(MAKINUM(1), s);
+    return res;
+  }
+  aset(ARRAY_V(res), s, INUM0);
+  return res;
+}
+
+/* Functions callable by ARRAY-MAP! */
+int ra_eqp(ra0, ras)
+     SCM ra0, ras;
+{
+  SCM ra1 = CAR(ras), ra2 = CAR(CDR(ras));
+  long n = ARRAY_DIMS(ra0)->ubnd - ARRAY_DIMS(ra0)->lbnd + 1;
+  sizet i0 = ARRAY_BASE(ra0), i1 = ARRAY_BASE(ra1), i2 = ARRAY_BASE(ra2);
+  long inc0 = ARRAY_DIMS(ra0)->inc;
+  long inc1 = ARRAY_DIMS(ra1)->inc;
+  long inc2 = ARRAY_DIMS(ra2)->inc;
+  ra0 = ARRAY_V(ra0);
+  ra1 = ARRAY_V(ra1);
+  ra2 = ARRAY_V(ra2);
+  switch (TYP7(ra1)==TYP7(ra2) ? TYP7(ra1) : 0) {
+  default: {
+    SCM e1 = UNDEFINED, e2 = UNDEFINED;
+    for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
+      if BVE_REF(ra0, i0)
+	if FALSEP(eqp(RVREF(ra1, i1, e1), RVREF(ra2, i2, e2)))
+	  BVE_CLR(ra0, i0);
+    break;
+  }
+  case tc7_uvect:
+  case tc7_ivect:
+    for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
+      if BVE_REF(ra0, i0)
+	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)
+	if (((double *)VELTS(ra1))[i1] != ((double *)VELTS(ra2))[i2])
+	  BVE_CLR(ra0, i0);
+    break;
+  case tc7_cvect:
+    for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
+      if BVE_REF(ra0, i0)
+	if (((double *)VELTS(ra1))[2*i1] != ((double *)VELTS(ra2))[2*i2] ||
+	    ((double *)VELTS(ra1))[2*i1+1] != ((double *)VELTS(ra2))[2*i2+1])
+	  BVE_CLR(ra0, i0);
+    break;
+# endif /*FLOATS*/
+  }
+  return 1;
+}
+/* opt 0 means <, nonzero means >= */
+static int ra_compare(ra0, ra1, ra2, opt)
+     SCM ra0, ra1, ra2;
+     int opt;
+{
+  long n = ARRAY_DIMS(ra0)->ubnd - ARRAY_DIMS(ra0)->lbnd + 1;
+  sizet i0 = ARRAY_BASE(ra0), i1 = ARRAY_BASE(ra1), i2 = ARRAY_BASE(ra2);
+  long inc0 = ARRAY_DIMS(ra0)->inc;
+  long inc1 = ARRAY_DIMS(ra1)->inc;
+  long inc2 = ARRAY_DIMS(ra2)->inc;
+  ra0 = ARRAY_V(ra0);
+  ra1 = ARRAY_V(ra1);
+  ra2 = ARRAY_V(ra2);
+  switch (TYP7(ra1)==TYP7(ra2) ? TYP7(ra1) : 0) {
+  default: {
+    SCM e1 = UNDEFINED, e2 = UNDEFINED;
+    for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
+      if BVE_REF(ra0, i0)
+	if (opt ?
+	    NFALSEP(lessp(RVREF(ra1, i1, e1), RVREF(ra2, i2, e2))) :
+	    FALSEP(lessp(RVREF(ra1, i1, e1), RVREF(ra2, i2, e2))) )
+	  BVE_CLR(ra0, i0);
+    break;
+  }
+  case tc7_uvect:
+    for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2) {
+      if BVE_REF(ra0, i0)
+	if (opt ?
+	    ((unsigned long*)VELTS(ra1))[i1] < ((unsigned long*)VELTS(ra2))[i2] :
+	    ((unsigned long*)VELTS(ra1))[i1] >= ((unsigned long*)VELTS(ra2))[i2])
+	  BVE_CLR(ra0, i0);
+    }
+    break;
+  case tc7_ivect:
+    for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2) {
+      if BVE_REF(ra0, i0)
+	if (opt ?
+	    VELTS(ra1)[i1] < VELTS(ra2)[i2] :
+	    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 (opt ?
+	    ((float *)VELTS(ra1))[i1] < ((float *)VELTS(ra2))[i2] :
+	    ((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)
+	if (opt ?
+	    ((double *)VELTS(ra1))[i1] < ((double *)VELTS(ra2))[i2] :
+	    ((double *)VELTS(ra1))[i1] >= ((double *)VELTS(ra2))[i2])
+	  BVE_CLR(ra0, i0);
+    break;
+# endif /*FLOATS*/
+  }
+  return 1;
+}
+int ra_lessp(ra0, ras)
+     SCM ra0, ras;
+{
+ return ra_compare(ra0, CAR(ras), CAR(CDR(ras)), 0);
+}
+int ra_leqp(ra0, ras)
+     SCM ra0, ras;
+{
+  return ra_compare(ra0, CAR(CDR(ras)), CAR(ras), 1);
+}
+int ra_grp(ra0, ras)
+     SCM ra0, ras;
+{
+  return ra_compare(ra0, CAR(CDR(ras)), CAR(ras), 0);
+}
+int ra_greqp(ra0, ras)
+     SCM ra0, ras;
+{
+  return ra_compare(ra0, CAR(ras), CAR(CDR(ras)), 1);
+}
+
+int ra_sum(ra0, ras)
+     SCM ra0, ras;
+{
+  long n = ARRAY_DIMS(ra0)->ubnd - ARRAY_DIMS(ra0)->lbnd + 1;
+  sizet i0 = ARRAY_BASE(ra0);
+  long inc0 = ARRAY_DIMS(ra0)->inc;
+  ra0 = ARRAY_V(ra0);
+  if NNULLP(ras) {
+    SCM ra1 = CAR(ras);
+    sizet i1 = ARRAY_BASE(ra1);
+    long inc1 = ARRAY_DIMS(ra1)->inc;
+    ra1 = ARRAY_V(ra1);
+    switch (TYP7(ra0)==TYP7(ra1) ? TYP7(ra0) : 0) {
+    ovflow: wta(ra0, (char *)OVFLOW, "+");
+    default: {
+      SCM e0 = UNDEFINED, e1 = UNDEFINED;
+      for (; n-- > 0; i0 += inc0, i1 += inc1)
+	aset(ra0, sum(RVREF(ra0, i0, e0), RVREF(ra1, i1, e1)),
+	     MAKINUM(i0));
+      break;
+    }
+    case tc7_uvect: {
+      unsigned long r;
+      unsigned long *v0 = (unsigned long *)VELTS(ra0);
+      unsigned long *v1 = (unsigned long *)VELTS(ra1);
+      IVDEP(ra0 != ra1,
+	    for (; n-- > 0; i0 += inc0, i1 += inc1) {
+	      r = v0[i0] + v1[i1];
+	      ASRTGO(r >= v0[i0], ovflow); /* Will prevent vectorization */
+	      v0[i0] = r;
+	    } );
+      break;
+    }
+    case tc7_ivect: {
+      long r, *v0 = (long *)VELTS(ra0), *v1 = (long *)VELTS(ra1);
+      IVDEP(ra0 != ra1,
+	    for (; n-- > 0; i0 += inc0, i1 += inc1) {
+	      r = v0[i0] + v1[i1];
+	      ASRTGO((v0[i0]>0 ? r>=0 || v1[i1]<0 : r<=0 || v1[i1]>0), ovflow);
+	      v0[i0] = r;
+	    } );
+      break;
+    }
+# ifdef FLOATS
+#  ifdef SINGLES
+    case tc7_fvect: {
+      float *v0 = (float *)VELTS(ra0);
+      float *v1 = (float *)VELTS(ra1);
+      IVDEP(ra0 != ra1,
+	    for (; n-- > 0; i0 += inc0, i1 += inc1)
+	      v0[i0] += v1[i1]);
+      break;
+    }
+#  endif /* SINGLES */
+    case tc7_dvect: {
+      double *v0 = (double *)VELTS(ra0);
+      double *v1 = (double *)VELTS(ra1);
+      IVDEP(ra0 != ra1,
+	    for (; n-- > 0; i0 += inc0, i1 += inc1)
+	      v0[i0] += v1[i1]);
+      break;
+    }
+    case tc7_cvect: {
+      double (*v0)[2] = (double (*)[2])VELTS(ra0);
+      double (*v1)[2] = (double (*)[2])VELTS(ra1);
+      IVDEP(ra0 != ra1,
+	    for (; n-- > 0; i0 += inc0, i1 += inc1) {
+	      v0[i0][0] += v1[i1][0];
+	      v0[i0][1] += v1[i1][1];
+	    });
+      break;
+    }
+# endif /* FLOATS */
+    }
+  }
+  return 1;
+}
+
+int ra_difference(ra0, ras)
+     SCM ra0, ras;
+{
+  long n = ARRAY_DIMS(ra0)->ubnd - ARRAY_DIMS(ra0)->lbnd + 1;
+  sizet i0 = ARRAY_BASE(ra0);
+  long inc0 = ARRAY_DIMS(ra0)->inc;
+  ra0 = ARRAY_V(ra0);
+  if NULLP(ras) {
+    switch TYP7(ra0) {
+    default: {
+      SCM e0 = UNDEFINED;
+      for (; n-- > 0; i0 += inc0)
+	aset(ra0, difference(RVREF(ra0, i0, e0), UNDEFINED), MAKINUM(i0));
+      break;
+    }
+    case tc7_ivect: {
+      long *v0 = VELTS(ra0);
+      for (; n-- > 0; i0 += inc0)
+	v0[i0] = -v0[i0];
+      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)
+	v0[i0] = -v0[i0];
+      break;
+    }
+    case tc7_cvect: {
+      double (*v0)[2] = (double (*)[2])VELTS(ra0);
+      for (; n-- > 0; i0 += inc0) {
+	v0[i0][0] = -v0[i0][0];
+	v0[i0][1] = -v0[i0][1];
+      }
+      break;
+    }
+# endif /* FLOATS */
+    }
+  }
+  else {
+    SCM ra1 = CAR(ras);
+    sizet i1 = ARRAY_BASE(ra1);
+    long inc1 = ARRAY_DIMS(ra1)->inc;
+    ra1 = ARRAY_V(ra1);
+    switch (TYP7(ra0)==TYP7(ra1) ? TYP7(ra0) : 0) {
+    ovflow: wta(ra0, (char *)OVFLOW, "-");
+    default: {
+      SCM e0 = UNDEFINED, e1 = UNDEFINED;
+      for (; n-- > 0; i0 += inc0, i1 += inc1)
+	aset(ra0, difference(RVREF(ra0, i0, e0), RVREF(ra1, i1, e1)), MAKINUM(i0));
+      break;
+    }
+    case tc7_uvect: {
+      unsigned long r;
+      unsigned long *v0 = (unsigned long *)VELTS(ra0);
+      unsigned long *v1 = (unsigned long*)VELTS(ra1);
+      IVDEP(ra0 != ra1,
+	    for (; n-- > 0; i0 += inc0, i1 += inc1) {
+	      r = v0[i0] - v1[i1];
+	      ASRTGO(r <= v0[i0], ovflow);
+	      v0[i0] = r;
+	    } );
+      break;
+    }
+    case tc7_ivect: {
+      long r, *v0 = VELTS(ra0), *v1 = VELTS(ra1);
+      IVDEP(ra0 != ra1,
+	    for (; n-- > 0; i0 += inc0, i1 += inc1) {
+	      r = v0[i0] - v1[i1];
+	      ASRTGO((v0[i0]>0 ? r>=0 || v1[i1]>0 : r<=0 || v1[i1]<0), ovflow);
+	      v0[i0] = r;
+	    } );
+      break;
+    }
+# ifdef FLOATS
+#  ifdef SINGLES
+    case tc7_fvect: {
+      float *v0 = (float *)VELTS(ra0);
+      float *v1 = (float *)VELTS(ra1);
+      IVDEP(ra0 != ra1,
+	    for (; n-- > 0; i0 += inc0, i1 += inc1)
+	      v0[i0] -= v1[i1]);
+      break;
+    }
+#  endif /* SINGLES */
+    case tc7_dvect: {
+      double *v0 = (double *)VELTS(ra0);
+      double *v1 = (double *)VELTS(ra1);
+      IVDEP(ra0 != ra1,
+	    for (; n-- > 0; i0 += inc0, i1 += inc1)
+	      v0[i0] -= v1[i1]);
+      break;
+    }
+    case tc7_cvect: {
+      double (*v0)[2] = (double (*)[2])VELTS(ra0);
+      double (*v1)[2] = (double (*)[2])VELTS(ra1);
+      IVDEP(ra0 != ra1,
+	    for (; n-- > 0; i0 += inc0, i1 += inc1) {
+	      v0[i0][0] -= v1[i1][0];
+	      v0[i0][1] -= v1[i1][1];
+	    })
+      break;
+    }
+# endif /* FLOATS */
+    }
+  }
+  return 1;
+}
+
+int ra_product(ra0, ras)
+     SCM ra0, ras;
+{
+  long n = ARRAY_DIMS(ra0)->ubnd - ARRAY_DIMS(ra0)->lbnd + 1;
+  sizet i0 = ARRAY_BASE(ra0);
+  long inc0 = ARRAY_DIMS(ra0)->inc;
+  ra0 = ARRAY_V(ra0);
+  if NNULLP(ras) {
+    SCM ra1 = CAR(ras);
+    sizet i1 = ARRAY_BASE(ra1);
+    long inc1 = ARRAY_DIMS(ra1)->inc;
+    ra1 = ARRAY_V(ra1);
+    switch (TYP7(ra0)==TYP7(ra1) ? TYP7(ra0) : 0) {
+    ovflow: wta(ra0, (char *)OVFLOW, "*");
+    default: {
+      SCM e0 = UNDEFINED, e1 = UNDEFINED;
+      for (; n-- > 0; i0 += inc0, i1 += inc1)
+	aset(ra0, product(RVREF(ra0, i0, e0), RVREF(ra1, i1, e1)),
+	     MAKINUM(i0));
+      break;
+    }
+    case tc7_uvect: {
+      unsigned long r;
+      unsigned long *v0 = (unsigned long *)VELTS(ra0);
+      unsigned long *v1 = (unsigned long *)VELTS(ra1);
+      IVDEP(ra0 != ra1,
+	    for (; n-- > 0; i0 += inc0, i1 += inc1) {
+	      r = v0[i0] * v1[i1];
+	      ASRTGO(0==v0[i0] || v1[i1]==r/v0[i0], ovflow);
+	      v0[i0] = r;
+	    } );
+      break;
+    }
+    case tc7_ivect: {
+      long r, *v0 = VELTS(ra0), *v1 =VELTS(ra1);
+      IVDEP(ra0 != ra1,
+	    for (; n-- > 0; i0 += inc0, i1 += inc1) {
+	      r = v0[i0] * v1[i1];
+	      ASRTGO(0==v0[i0] || v1[i1]==r/v0[i0], ovflow);
+	      v0[i0] = r;
+	    } );
+      break;
+    }
+# ifdef FLOATS
+#  ifdef SINGLES
+    case tc7_fvect: {
+      float *v0 = (float *)VELTS(ra0);
+      float *v1 = (float *)VELTS(ra1);
+      IVDEP(ra0 != ra1,
+	    for (; n-- > 0; i0 += inc0, i1 += inc1)
+	      v0[i0] *= v1[i1]);
+      break;
+    }
+#  endif /* SINGLES */
+    case tc7_dvect: {
+      double *v0 = (double *)VELTS(ra0);
+      double *v1 = (double *)VELTS(ra1);
+      IVDEP(ra0 != ra1,
+	    for (; n-- > 0; i0 += inc0, i1 += inc1)
+	      v0[i0] *= v1[i1]);
+      break;
+    }
+    case tc7_cvect: {
+      double (*v0)[2] = (double (*)[2])VELTS(ra0);
+      register double r;
+      double (*v1)[2] = (double (*)[2])VELTS(ra1);
+      IVDEP(ra0 != ra1,
+	    for (; n-- > 0; i0 += inc0, i1 += inc1) {
+	      r = v0[i0][0]*v1[i1][0] - v0[i0][1]*v1[i1][1];
+	      v0[i0][1] = v0[i0][0]*v1[i1][1] + v0[i0][1]*v1[i1][0];
+	      v0[i0][0] = r;
+	    });
+      break;
+    }
+# endif /* FLOATS */
+    }
+  }
+  return 1;
+}
+int ra_divide(ra0, ras)
+     SCM ra0, ras;
+{
+  long n = ARRAY_DIMS(ra0)->ubnd - ARRAY_DIMS(ra0)->lbnd + 1;
+  sizet i0 = ARRAY_BASE(ra0);
+  long inc0 = ARRAY_DIMS(ra0)->inc;
+  ra0 = ARRAY_V(ra0);
+  if NULLP(ras) {
+    switch TYP7(ra0) {
+    default: {
+      SCM e0 = UNDEFINED;
+      for (; n-- > 0; i0 += inc0)
+	aset(ra0, divide(RVREF(ra0, i0, e0), UNDEFINED), MAKINUM(i0));
+      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)
+	v0[i0] = 1.0/v0[i0];
+      break;
+    }
+    case tc7_cvect: {
+      register double d;
+      double (*v0)[2] = (double (*)[2])VELTS(ra0);
+      for (; n-- > 0; i0 += inc0) {
+	d = v0[i0][0]*v0[i0][0] + v0[i0][1]*v0[i0][1];
+	v0[i0][0] /= d;
+	v0[i0][1] /= -d;
+      }
+      break;
+    }
+# endif /* FLOATS */
+    }
+  }
+  else {
+    SCM ra1 = CAR(ras);
+    sizet i1 = ARRAY_BASE(ra1);
+    long inc1 = ARRAY_DIMS(ra1)->inc;
+    ra1 = ARRAY_V(ra1);
+    switch (TYP7(ra0)==TYP7(ra1) ? TYP7(ra0) : 0) {
+    default: {
+      SCM e0 = UNDEFINED, e1 = UNDEFINED;
+      for (; n-- > 0; i0 += inc0, i1 += inc1)
+	aset(ra0, divide(RVREF(ra0, i0, e0), RVREF(ra1, i1, e1)), MAKINUM(i0));
+      break;
+    }
+# ifdef FLOATS
+#  ifdef SINGLES
+    case tc7_fvect: {
+      float *v0 = (float *)VELTS(ra0);
+      float *v1 = (float *)VELTS(ra1);
+      IVDEP(ra0 != ra1,
+	    for (; n-- > 0; i0 += inc0, i1 += inc1)
+	      v0[i0] /= v1[i1]);
+      break;
+    }
+#  endif /* SINGLES */
+    case tc7_dvect: {
+      double *v0 = (double *)VELTS(ra0);
+      double *v1 = (double *)VELTS(ra1);
+      IVDEP(ra0 != ra1,
+	    for (; n-- > 0; i0 += inc0, i1 += inc1)
+	      v0[i0] /= v1[i1]);
+      break;
+    }
+    case tc7_cvect: {
+      register double d, r;
+      double (*v0)[2] = (double (*)[2])VELTS(ra0);
+      double (*v1)[2] = (double (*)[2])VELTS(ra1);
+      IVDEP(ra0 != ra1,
+	    for (; n-- > 0; i0 += inc0, i1 += inc1) {
+	      d = v1[i1][0]*v1[i1][0] + v1[i1][1]*v1[i1][1];
+	      r = (v0[i0][0]*v1[i1][0] + v0[i0][1]*v1[i1][1])/d;
+	      v0[i0][1] = (v0[i0][1]*v1[i1][0] - v0[i0][0]*v1[i1][1])/d;
+	      v0[i0][0] = r;
+	    })
+      break;
+    }
+# endif /* FLOATS */
+    }
+  }
+  return 1;
+}
+static int ra_identity(dst, src)
+     SCM src, dst;
+{
+  return racp(CAR(src), cons(dst, EOL));
+}
+
+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);
+    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));
+    }
+  }
+  return 1;
+}
+static int ramap_cxr(ra0, proc, ras)
+     SCM ra0, proc, ras;
+{
+  SCM ra1 = CAR(ras);
+  SCM e1 = UNDEFINED;
+  sizet i0 = ARRAY_BASE(ra0), i1 = ARRAY_BASE(ra1);
+  long inc0 = ARRAY_DIMS(ra0)->inc, inc1 = ARRAY_DIMS(ra1)->inc;
+  long n = ARRAY_DIMS(ra0)->ubnd - ARRAY_DIMS(ra1)->lbnd + 1;
+  ra0 = ARRAY_V(ra0);
+  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));
+    break;
+# ifdef FLOATS
+#  ifdef SINGLES
+  case tc7_fvect: {
+    float *dst = (float *)VELTS(ra0);
+    switch TYP7(ra1) {
+    default: goto gencase;
+    case tc7_fvect:
+      for (; n-- > 0; i0 += inc0, i1 += inc1)
+	dst[i0] = DSUBRF(proc)((double)((float *)VELTS(ra1))[i1]);
+      break;
+    case tc7_uvect:
+    case tc7_ivect:
+      for (; n-- > 0; i0 += inc0, i1 += inc1)
+	dst[i0] = DSUBRF(proc)((double)VELTS(ra1)[i1]);
+      break;
+    }
+    break;
+  }
+#  endif /* SINGLES */
+  case tc7_dvect: {
+    double *dst = (double *)VELTS(ra0);
+    switch TYP7(ra1) {
+    default: goto gencase;
+    case tc7_dvect:
+      for (; n-- > 0; i0 += inc0, i1 += inc1)
+	dst[i0] = DSUBRF(proc)(((double *)VELTS(ra1))[i1]);
+      break;
+    case tc7_uvect:
+    case tc7_ivect:
+      for (; n-- > 0; i0 += inc0, i1 += inc1)
+	dst[i0] = DSUBRF(proc)((double)VELTS(ra1)[i1]);
+      break;
+    }
+    break;
+  }
+# endif /* FLOATS */
+  }
+  return 1;
+}
+static int ramap_rp(ra0, proc, ras)
+     SCM ra0, proc, ras;
+{
+  SCM ra1 = CAR(ras), ra2 = CAR(CDR(ras));
+  SCM e1 = UNDEFINED, e2 = UNDEFINED;
+  long n = ARRAY_DIMS(ra0)->ubnd - ARRAY_DIMS(ra0)->lbnd + 1;
+  sizet i0 = ARRAY_BASE(ra0), i1 = ARRAY_BASE(ra1), i2 = ARRAY_BASE(ra2);
+  long inc0 = ARRAY_DIMS(ra0)->inc;
+  long inc1 = ARRAY_DIMS(ra1)->inc;
+  long inc2 = ARRAY_DIMS(ra2)->inc;
+  ra0 = ARRAY_V(ra0);
+  ra1 = ARRAY_V(ra1);
+  ra2 = ARRAY_V(ra2);
+  for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
+    if BVE_REF(ra0, i0)
+      if FALSEP(SUBRF(proc)(RVREF(ra1, i1, e1), RVREF(ra2, i2, e2)))
+	BVE_CLR(ra0, i0);
+  return 1;
+}
+static int ramap_1(ra0, proc, ras)
+     SCM ra0, proc, ras;
+{
+  SCM ra1 = CAR(ras);
+  SCM e1 = UNDEFINED;
+  long n = ARRAY_DIMS(ra0)->ubnd - ARRAY_DIMS(ra0)->lbnd + 1;
+  sizet i0 = ARRAY_BASE(ra0), i1 = ARRAY_BASE(ra1);
+  long inc0 = ARRAY_DIMS(ra0)->inc, inc1 = ARRAY_DIMS(ra1)->inc;
+  ra0 = ARRAY_V(ra0);
+  ra1 = ARRAY_V(ra1);
+  if (tc7_vector==TYP7(ra0))
+    for (; n-- > 0; i0 += inc0, i1 += inc1)
+      VELTS(ra0)[i0] = SUBRF(proc)(cvref(ra1, i1, UNDEFINED));
+  else
+    for (; n-- > 0; i0 += inc0, i1 += inc1)
+      aset(ra0, SUBRF(proc)(RVREF(ra1, i1, e1)), MAKINUM(i0));
+  return 1;
+}
+static int ramap_2o(ra0, proc, ras)
+     SCM ra0, proc, ras;
+{
+  SCM ra1 = CAR(ras);
+  SCM e1 = UNDEFINED;
+  long n = ARRAY_DIMS(ra0)->ubnd - ARRAY_DIMS(ra0)->lbnd + 1;
+  sizet i0 = ARRAY_BASE(ra0), i1 = ARRAY_BASE(ra1);
+  long inc0 = ARRAY_DIMS(ra0)->inc, inc1 = ARRAY_DIMS(ra1)->inc;
+  ra0 = ARRAY_V(ra0);
+  ra1 = ARRAY_V(ra1);
+  ras = CDR(ras);
+  if NULLP(ras) {
+    if (tc7_vector==TYP7(ra0))
+      for (; n-- > 0; i0 += inc0, i1 += inc1)
+	VELTS(ra0)[i0] = SUBRF(proc)(cvref(ra1, i1, UNDEFINED), UNDEFINED);
+    else
+      for (; n-- > 0; i0 += inc0, i1 += inc1)
+	aset(ra0, SUBRF(proc)(RVREF(ra1, i1, e1), UNDEFINED),
+	     MAKINUM(i0));
+  }
+  else {
+    SCM ra2 = CAR(ras);
+    SCM e2 = UNDEFINED;
+    sizet i2 = ARRAY_BASE(ra2);
+    long inc2 = ARRAY_DIMS(ra2)->inc;
+    ra2 = ARRAY_V(ra2);
+    if (tc7_vector==TYP7(ra0))
+      for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
+	VELTS(ra0)[i0] =
+	  SUBRF(proc)(cvref(ra1, i1, UNDEFINED), cvref(ra2, i2, UNDEFINED));
+    else
+      for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
+	aset(ra0,
+	     SUBRF(proc)(RVREF(ra1, i1, e1), RVREF(ra2, i2, e2)),
+	     MAKINUM(i0));
+  }
+  return 1;
+}
+static int ramap_a(ra0, proc, ras)
+     SCM ra0, proc, ras;
+{
+  SCM e0 = UNDEFINED, e1 = UNDEFINED;
+  long n = ARRAY_DIMS(ra0)->ubnd - ARRAY_DIMS(ra0)->lbnd + 1;
+  sizet i0 = ARRAY_BASE(ra0);
+  long inc0 = ARRAY_DIMS(ra0)->inc;
+  ra0 = ARRAY_V(ra0);
+  if NULLP(ras)
+    for (; n-- > 0; i0 += inc0)
+      aset(ra0, SUBRF(proc)(RVREF(ra0, i0, e0), UNDEFINED), MAKINUM(i0));
+  else {
+    SCM ra1 = CAR(ras);
+    sizet i1 = ARRAY_BASE(ra1);
+    long inc1 = ARRAY_DIMS(ra1)->inc;
+    ra1 = ARRAY_V(ra1);
+    for (; n-- > 0; i0 += inc0, i1 += inc1)
+      aset(ra0, SUBRF(proc)(RVREF(ra0, i0, e0), RVREF(ra1, i1, e1)),
+	   MAKINUM(i0));
+  }
+  return 1;
+}
+
+/* These tables are a kluge that will not scale well when more
+ vectorized subrs are added.  It is tempting to steal some bits from
+ the CAR of all subrs (like those selected by SMOBNUM) to hold an
+ offset into a table of vectorized subrs.  */
+
+static ra_iproc ra_rpsubrs[] = {
+  {"=", UNDEFINED, ra_eqp},
+  {"<", UNDEFINED, ra_lessp},
+  {"<=", UNDEFINED, ra_leqp},
+  {">", UNDEFINED, ra_grp},
+  {">=", UNDEFINED, ra_greqp},
+  {0, 0, 0}};
+static ra_iproc ra_asubrs[] = {
+  {"+", UNDEFINED, ra_sum},
+  {"-", UNDEFINED, ra_difference},
+  {"*", UNDEFINED, ra_product},
+  {"/", UNDEFINED, ra_divide},
+  {0, 0, 0}};
+
+static char s_sarray_map[] = "serial-array-map!";
+# define s_array_map  (s_sarray_map + 7)
+SCM array_map(ra0, proc, lra)
+     SCM ra0, proc, lra;
+{
+  int 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:
+    ramapc(ramap, proc, ra0, lra, s_array_map);
+    return UNSPECIFIED;
+  case tc7_subr_1: ASRTGO(1==narg, wna);
+    ramapc(ramap_1, proc, ra0, lra, s_array_map);
+    return UNSPECIFIED;
+  case tc7_subr_2: ASRTGO(2==narg, wna);
+  case tc7_subr_2o: ASRTGO(2>=narg, wna);
+    ramapc(ramap_2o, proc, ra0, lra, s_array_map);
+    return UNSPECIFIED;
+  case tc7_cxr: if (! SUBRF(proc)) goto gencase;
+    ASRTGO(1==narg, wna);
+    ramapc(ramap_cxr, proc, ra0, lra, s_array_map);
+    return UNSPECIFIED;
+  case tc7_rpsubr: {
+    ra_iproc *p;
+    if (FALSEP(arrayp(ra0, BOOL_T))) goto gencase;
+    array_fill(ra0, BOOL_T);
+    for (p = ra_rpsubrs; p->name; p++)
+      if (proc==p->sproc) {
+	while (NNULLP(lra) && NNULLP(CDR(lra))) {
+	  ramapc(p->vproc, UNDEFINED, ra0, lra, s_array_map);
+	  lra = CDR(lra);
+	}
+	return UNSPECIFIED;
+      }
+    while (NNULLP(lra) && NNULLP(CDR(lra))) {
+      ramapc(ramap_rp, proc, ra0, lra, s_array_map);
+      lra = CDR(lra);
+    }
+    return UNSPECIFIED;
+  }
+  case tc7_asubr:
+    if NULLP(lra) {
+      SCM prot, fill = SUBRF(proc)(UNDEFINED, UNDEFINED);
+      if INUMP(fill) {
+	prot = array_prot(ra0);
+# ifdef FLOATS
+	if (NIMP(prot) && INEXP(prot))
+	  fill = makdbl((double)INUM(fill), 0.0);
+# endif
+      }
+      array_fill(ra0, fill);
+    }
+    else {
+      SCM tail, ra1 = CAR(lra);
+      SCM v0 = (NIMP(ra0) && ARRAYP(ra0) ? ARRAY_V(ra0) : ra0);
+      ra_iproc *p;
+      /* Check to see if order might matter.
+	 This might be an argument for a separate
+	 SERIAL-ARRAY-MAP! */
+      if (v0==ra1 || (NIMP(ra1) && ARRAYP(ra1) && v0==ARRAY_V(ra1)))
+	if (ra0 != ra1 || (ARRAYP(ra0) && !ARRAY_CONTP(ra0)))
+	  goto gencase;
+      for (tail = CDR(lra); NNULLP(tail); tail = CDR(tail)) {
+	ra1 = CAR(tail);
+	if (v0==ra1 || (NIMP(ra1) && ARRAYP(ra1) && v0==ARRAY_V(ra1)))
+	  goto gencase;
+      }
+      for (p = ra_asubrs; p->name; p++)
+	if (proc==p->sproc) {
+	  if (ra0 != CAR(lra))
+	    ramapc(ra_identity, UNDEFINED, ra0, cons(CAR(lra), EOL), s_array_map);
+	  lra = CDR(lra);
+	  while (1) {
+	    ramapc(p->vproc, UNDEFINED, ra0, lra, s_array_map);
+	    if (IMP(lra) || IMP(CDR(lra))) return UNSPECIFIED;
+	    lra = CDR(lra);
+	  }
+	}
+      ramapc(ramap_2o, proc, ra0, lra, s_array_map);
+      lra = CDR(lra);
+      if NIMP(lra)
+	for (lra = CDR(lra); NIMP(lra); lra = CDR(lra))
+	  ramapc(ramap_a, proc, ra0, lra, s_array_map);
+    }
+    return UNSPECIFIED;
+#ifdef CCLO
+  case tc7_cclo:
+    lra = cons(sc2array(proc,ra0,EOL), lra);
+    proc = CCLO_SUBR(proc);
+    goto tail;
+#endif
+  }
+}
+
+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);
+    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);
+    }
+  }
+  return 1;
+}
+static char s_array_for_each[] = "array-for-each";
+SCM array_for_each(proc, ra0, lra)
+     SCM proc, ra0, lra;
+{
+  ASSERT(BOOL_T==procedurep(proc), proc, ARG1, s_array_for_each);
+ tail:
+  switch TYP7(proc) {
+  default:
+    ramapc(rafe, proc, ra0, lra, s_array_for_each);
+    return UNSPECIFIED;
+#ifdef CCLO
+  case tc7_cclo:
+    lra = cons(ra0, lra);
+    ra0 = sc2array(proc, ra0, EOL);
+    proc = CCLO_SUBR(proc);
+    goto tail;
+#endif
+  }
+}
+
+static char s_array_imap[] = "array-index-map!";
+SCM array_imap(ra, proc)
+     SCM ra, proc;
+{
+  sizet i;
+  ASSERT(NIMP(ra), ra, ARG1, s_array_imap);
+  ASSERT(BOOL_T==procedurep(proc), proc, ARG2, s_array_imap);
+  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_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;
+      for (k = 0; k <= kmax; k++)
+	vinds[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));
+	    i += ARRAY_DIMS(ra)[k].inc;
+	  }
+	  k--;
+	  continue;
+	}
+	if (vinds[k] < ARRAY_DIMS(ra)[k].ubnd) {
+	  vinds[k]++;
+	  k++;
+	  continue;
+	}
+	vinds[k] = ARRAY_DIMS(ra)[k].lbnd - 1;
+	k--;
+      } while (k >= 0);
+      return UNSPECIFIED;
+    }
+  }
+}
+
+SCM array_equal P((SCM ra0, SCM ra1));
+static int raeql_1(ra0, as_equal, ra1)
+     SCM ra0, as_equal, ra1;
+{
+  SCM e0 = UNDEFINED, e1 = UNDEFINED;
+  sizet i0 = 0, i1 = 0;
+  long inc0 = 1, inc1 = 1;
+  sizet n = LENGTH(ra0);
+  ra1 = CAR(ra1);
+  if ARRAYP(ra0) {
+    n = ARRAY_DIMS(ra0)->ubnd - ARRAY_DIMS(ra0)->lbnd + 1;
+    i0 = ARRAY_BASE(ra0);
+    inc0 = ARRAY_DIMS(ra0)->inc;
+    ra0 = ARRAY_V(ra0);
+  }
+  if ARRAYP(ra1) {
+    i1 = ARRAY_BASE(ra1);
+    inc1 = ARRAY_DIMS(ra1)->inc;
+    ra1 = ARRAY_V(ra1);
+  }
+  switch TYP7(ra0) {
+  case tc7_vector: default:
+    for (; n--; i0+=inc0, i1+=inc1) {
+      if FALSEP(as_equal) {
+	if FALSEP(array_equal(RVREF(ra0, i0, e0), RVREF(ra1, i1, e1)))
+	  return 0;
+      }
+      else
+	if FALSEP(equal(RVREF(ra0, i0, e0), RVREF(ra1, i1, e1)))
+	  return 0;
+    }
+    return 1;
+  case tc7_string: {
+    char *v0 = CHARS(ra0) + i0;
+    char *v1 = CHARS(ra1) + i1;
+    for (; n--; v0 += inc0, v1 += inc1)
+      if (*v0 != *v1) return 0;
+    return 1;
+  }
+  case tc7_bvect:
+    for (; n--; i0 += inc0, i1 += inc1)
+      if (BVE_REF(ra0, i0) != BVE_REF(ra1, i1)) return 0;
+    return 1;
+  case tc7_uvect: case tc7_ivect: {
+    long *v0 = (long *)VELTS(ra0) + i0;
+    long *v1 = (long *)VELTS(ra1) + i1;
+    for (; n--; v0 += inc0, v1 += inc1)
+      if (*v0 != *v1) return 0;
+    return 1;
+  }
+# ifdef FLOATS
+#  ifdef SINGLES
+  case tc7_fvect: {
+    float *v0 = (float *)VELTS(ra0) + i0;
+    float *v1 = (float *)VELTS(ra1) + i1;
+    for (; n--; v0 += inc0, v1 += inc1)
+      if (*v0 != *v1) return 0;
+    return 1;
+  }
+#  endif /* SINGLES */
+  case tc7_dvect: {
+    double *v0 = (double *)VELTS(ra0) + i0;
+    double *v1 = (double *)VELTS(ra1) + i1;
+    for (; n--; v0 += inc0, v1 += inc1)
+      if (*v0 != *v1) return 0;
+    return 1;
+  }
+  case tc7_cvect: {
+    double (*v0)[2]= (double (*)[2])VELTS(ra0) + i0;
+    double (*v1)[2] = (double (*)[2])VELTS(ra1) + i1;
+    for (; n--; v0 += inc0, v1 += inc1) {
+      if ((*v0)[0] != (*v1)[0]) return 0;
+      if ((*v0)[1] != (*v1)[1]) return 0;
+    }
+    return 1;
+  }
+# endif /* FLOATS */
+  }
+}
+static int raeql(ra0, as_equal, ra1)
+     SCM ra0, as_equal, ra1;
+{
+  SCM v0 = ra0, v1 = ra1;
+  array_dim dim0, dim1;
+  array_dim *s0 = &dim0, *s1 = &dim1;
+  sizet bas0 = 0, bas1 = 0;
+  int k, unroll = 1, ndim = 1;
+  if ARRAYP(ra0) {
+    ndim = ARRAY_NDIM(ra0);
+    s0 = ARRAY_DIMS(ra0);
+    bas0 = ARRAY_BASE(ra0);
+    v0 = ARRAY_V(ra0);
+  }
+  else {
+    s0->inc = 1; s0->lbnd = 0; s0->ubnd = LENGTH(v0) - 1;
+  }
+  if ARRAYP(ra1) {
+    if (ndim != ARRAY_NDIM(ra1)) return 0;
+    s1 = ARRAY_DIMS(ra1);
+    bas1 = ARRAY_BASE(ra1);
+    v1 = ARRAY_V(ra1);
+  }
+  else {
+    if (1 != ndim) return BOOL_F;
+    s1->inc = 1; s1->lbnd = 0; s1->ubnd = LENGTH(v1) - 1;
+  }
+  if (TYP7(v0) != TYP7(v1)) return 0;
+  unroll = (bas0==bas1);
+  for (k = ndim; k--;) {
+    if (s0[k].lbnd != s1[k].lbnd || s0[k].ubnd != s1[k].ubnd) return 0;
+    if (unroll) unroll = (s0[k].inc==s1[k].inc);
+  }
+  if (unroll && v0==v1) return BOOL_T;
+  return ramapc(raeql_1, as_equal, ra0, cons(ra1, EOL), "");
+}
+
+SCM raequal(ra0, ra1)
+     SCM ra0, ra1;
+{
+  return (raeql(ra0, BOOL_T, ra1) ? BOOL_T : BOOL_F);
+}
+static char s_array_equalp[] = "array-equal?";
+SCM array_equal(ra0, ra1)
+     SCM ra0, ra1;
+{
+  if (IMP(ra0) || IMP(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_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_smob: if (!ARRAYP(ra1)) goto callequal;
+  }
+  return (raeql(ra0, BOOL_F, ra1) ? BOOL_T : BOOL_F);
+}
+
+static iproc subr2os[] = {
+  {s_ura_rd, ura_read},
+  {s_ura_wr, ura_write},
+  {0, 0}};
+
+static iproc subr2s[] = {
+	{s_array_fill, array_fill},
+	{s_array_copy, array_copy},
+	{s_sarray_copy, array_copy},
+	{0, 0}};
+
+static iproc lsubr2s[] = {
+  {s_sc2array, sc2array},
+  {s_array_map, array_map},
+  {s_sarray_map, array_map},
+  {s_array_for_each, array_for_each},
+  {s_array_imap, array_imap},
+  {0, 0}};
+
+static void init_raprocs(subra)
+     ra_iproc *subra;
+{
+  for(; subra->name; subra++)
+    subra->sproc = CDR(intern(subra->name, strlen(subra->name)));
+}
+
+void init_ramap()
+{
+  init_raprocs(ra_rpsubrs);
+  init_raprocs(ra_asubrs);
+  init_iprocs(subr2os, tc7_subr_2o);
+  init_iprocs(subr2s, tc7_subr_2);
+  init_iprocs(lsubr2s, tc7_lsubr_2);
+  make_subr(s_array_equalp, tc7_rpsubr, array_equal);
+  smobs[0x0ff & (tc16_array>>8)].equalp = raequal;
+  add_feature(s_array_for_each);
+}