aboutsummaryrefslogtreecommitdiffstats
path: root/ramap.c
diff options
context:
space:
mode:
authorBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:23 -0800
committerBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:23 -0800
commit5ca6e8e6a4e5c022a6fb5d28f30219c22c99eda8 (patch)
tree9b744b9dbf39e716e56daa620e2f3041968caf19 /ramap.c
downloadscm-5ca6e8e6a4e5c022a6fb5d28f30219c22c99eda8.tar.gz
scm-5ca6e8e6a4e5c022a6fb5d28f30219c22c99eda8.zip
Import Upstream version 4e6upstream/4e6
Diffstat (limited to 'ramap.c')
-rw-r--r--ramap.c1677
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);
+}