summaryrefslogtreecommitdiff
path: root/libguile/ramap.c
diff options
context:
space:
mode:
Diffstat (limited to 'libguile/ramap.c')
-rw-r--r--libguile/ramap.c2229
1 files changed, 2229 insertions, 0 deletions
diff --git a/libguile/ramap.c b/libguile/ramap.c
new file mode 100644
index 000000000..a913da0e6
--- /dev/null
+++ b/libguile/ramap.c
@@ -0,0 +1,2229 @@
+/* Copyright (C) 1996 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.
+ */
+
+
+
+
+
+#include <stdio.h>
+#include "_scm.h"
+
+
+
+#ifdef ARRAYS
+
+typedef struct
+{
+ char *name;
+ SCM sproc;
+ int (*vproc) ();
+} ra_iproc;
+
+static ra_iproc ra_rpsubrs[];
+static ra_iproc ra_asubrs[];
+
+#define BVE_REF(a, i) ((SCM_VELTS(a)[(i)/SCM_LONG_BIT] & (1L<<((i)%SCM_LONG_BIT))) ? 1 : 0)
+#define BVE_SET(a, i) (SCM_VELTS(a)[(i)/SCM_LONG_BIT] |= (1L<<((i)%SCM_LONG_BIT)))
+#define BVE_CLR(a, i) (SCM_VELTS(a)[(i)/SCM_LONG_BIT] &= ~(1L<<((i)%SCM_LONG_BIT)))
+
+/* Fast, recycling scm_vector ref */
+#define RVREF(ra, i, e) (e = scm_cvref(ra, i, e))
+
+/* #define RVREF(ra, i, e) (scm_cvref(ra, i, SCM_UNDEFINED)) to turn off */
+
+/* IVDEP means "ignore scm_vector dependencies", meaning we guarantee that
+ elements of scm_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. */
+
+#ifdef __STDC__
+static scm_sizet
+cind (SCM ra, SCM inds)
+#else
+static scm_sizet
+cind (ra, inds)
+ SCM ra;
+ SCM inds;
+#endif
+{
+ scm_sizet i;
+ int k;
+ long *ve = SCM_VELTS (inds);
+ if (!SCM_ARRAYP (ra))
+ return *ve;
+ i = SCM_ARRAY_BASE (ra);
+ for (k = 0; k < SCM_ARRAY_NDIM (ra); k++)
+ i += (ve[k] - SCM_ARRAY_DIMS (ra)[k].lbnd) * SCM_ARRAY_DIMS (ra)[k].inc;
+ return i;
+}
+
+
+/* Checker for scm_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.
+ */
+#ifdef __STDC__
+int
+scm_ra_matchp (SCM ra0, SCM ras)
+#else
+int
+scm_ra_matchp (ra0, ras)
+ SCM ra0;
+ SCM ras;
+#endif
+{
+ SCM ra1;
+ scm_array_dim dims;
+ scm_array_dim *s0 = &dims;
+ scm_array_dim *s1;
+ scm_sizet bas0 = 0;
+ int i, ndim = 1;
+ int exact = 2 /* 4 */ ; /* Don't care about values >2 (yet?) */
+ if SCM_IMP
+ (ra0) return 0;
+ switch (SCM_TYP7 (ra0))
+ {
+ default:
+ return 0;
+ case scm_tc7_vector:
+ case scm_tc7_string:
+ case scm_tc7_bvect:
+ case scm_tc7_uvect:
+ case scm_tc7_ivect:
+ case scm_tc7_fvect:
+ case scm_tc7_dvect:
+ case scm_tc7_cvect:
+ s0->lbnd = 0;
+ s0->inc = 1;
+ s0->ubnd = (long) SCM_LENGTH (ra0) - 1;
+ break;
+ case scm_tc7_smob:
+ if (!SCM_ARRAYP (ra0))
+ return 0;
+ ndim = SCM_ARRAY_NDIM (ra0);
+ s0 = SCM_ARRAY_DIMS (ra0);
+ bas0 = SCM_ARRAY_BASE (ra0);
+ break;
+ }
+ while SCM_NIMP
+ (ras)
+ {
+ ra1 = SCM_CAR (ras);
+ if SCM_IMP
+ (ra1) return 0;
+ switch SCM_TYP7
+ (ra1)
+ {
+ default:
+ return 0;
+ case scm_tc7_vector:
+ case scm_tc7_string:
+ case scm_tc7_bvect:
+ case scm_tc7_uvect:
+ case scm_tc7_ivect:
+ case scm_tc7_fvect:
+ case scm_tc7_dvect:
+ case scm_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 == SCM_LENGTH (ra1) - 1))
+ break;
+ exact = 1;
+ case 1:
+ if (s0->lbnd < 0 || s0->ubnd >= SCM_LENGTH (ra1))
+ return 0;
+ }
+ break;
+ case scm_tc7_smob:
+ if (!SCM_ARRAYP (ra1) || ndim != SCM_ARRAY_NDIM (ra1))
+ return 0;
+ s1 = SCM_ARRAY_DIMS (ra1);
+ if (bas0 != SCM_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)
+ return (s0[i].lbnd <= s0[i].ubnd ? 0 : 1);
+ }
+ break;
+ }
+ ras = SCM_CDR (ras);
+ }
+ return exact;
+}
+
+static char s_ra_mismatch[] = "array shape mismatch";
+
+#ifdef __STDC__
+int
+scm_ramapc (int (*cproc) (), SCM data, SCM ra0, SCM lra, char *what)
+#else
+int
+scm_ramapc (cproc, data, ra0, lra, what)
+ int (*cproc) ();
+ SCM data;
+ SCM ra0;
+ SCM lra;
+ char *what;
+#endif
+{
+ SCM inds, z;
+ SCM vra0, ra1, vra1;
+ SCM lvra, *plvra;
+ long *vinds;
+ int k, kmax;
+ switch (scm_ra_matchp (ra0, lra))
+ {
+ default:
+ case 0:
+ scm_wta (ra0, s_ra_mismatch, what);
+ case 2:
+ case 3:
+ case 4: /* Try unrolling arrays */
+ kmax = (SCM_ARRAYP (ra0) ? SCM_ARRAY_NDIM (ra0) - 1 : 0);
+ if (kmax < 0)
+ goto gencase;
+ vra0 = scm_array_contents (ra0, SCM_UNDEFINED);
+ if SCM_IMP
+ (vra0) goto gencase;
+ if (!SCM_ARRAYP (vra0))
+ {
+ vra1 = scm_make_ra (1);
+ SCM_ARRAY_BASE (vra1) = 0;
+ SCM_ARRAY_DIMS (vra1)->lbnd = 0;
+ SCM_ARRAY_DIMS (vra1)->ubnd = SCM_LENGTH (vra0) - 1;
+ SCM_ARRAY_DIMS (vra1)->inc = 1;
+ SCM_ARRAY_V (vra1) = vra0;
+ vra0 = vra1;
+ }
+ lvra = SCM_EOL;
+ plvra = &lvra;
+ for (z = lra; SCM_NIMP (z); z = SCM_CDR (z))
+ {
+ ra1 = SCM_CAR (z);
+ vra1 = scm_make_ra (1);
+ SCM_ARRAY_DIMS (vra1)->lbnd = SCM_ARRAY_DIMS (vra0)->lbnd;
+ SCM_ARRAY_DIMS (vra1)->ubnd = SCM_ARRAY_DIMS (vra0)->ubnd;
+ if (!SCM_ARRAYP (ra1))
+ {
+ SCM_ARRAY_BASE (vra1) = 0;
+ SCM_ARRAY_DIMS (vra1)->inc = 1;
+ SCM_ARRAY_V (vra1) = ra1;
+ }
+ else if (!SCM_ARRAY_CONTP (ra1))
+ goto gencase;
+ else
+ {
+ SCM_ARRAY_BASE (vra1) = SCM_ARRAY_BASE (ra1);
+ SCM_ARRAY_DIMS (vra1)->inc = SCM_ARRAY_DIMS (ra1)[kmax].inc;
+ SCM_ARRAY_V (vra1) = SCM_ARRAY_V (ra1);
+ }
+ *plvra = scm_cons (vra1, SCM_EOL);
+ plvra = &SCM_CDR (*plvra);
+ }
+ return (SCM_UNBNDP (data) ? cproc(vra0, lvra) : cproc(vra0, data, lvra));
+ case 1:
+ gencase: /* Have to loop over all dimensions. */
+ vra0 = scm_make_ra (1);
+ if SCM_ARRAYP
+ (ra0)
+ {
+ kmax = SCM_ARRAY_NDIM (ra0) - 1;
+ if (kmax < 0)
+ {
+ SCM_ARRAY_DIMS (vra0)->lbnd = 0;
+ SCM_ARRAY_DIMS (vra0)->ubnd = 0;
+ SCM_ARRAY_DIMS (vra0)->inc = 1;
+ }
+ else
+ {
+ SCM_ARRAY_DIMS (vra0)->lbnd = SCM_ARRAY_DIMS (ra0)[kmax].lbnd;
+ SCM_ARRAY_DIMS (vra0)->ubnd = SCM_ARRAY_DIMS (ra0)[kmax].ubnd;
+ SCM_ARRAY_DIMS (vra0)->inc = SCM_ARRAY_DIMS (ra0)[kmax].inc;
+ }
+ SCM_ARRAY_BASE (vra0) = SCM_ARRAY_BASE (ra0);
+ SCM_ARRAY_V (vra0) = SCM_ARRAY_V (ra0);
+ }
+ else
+ {
+ kmax = 0;
+ SCM_ARRAY_DIMS (vra0)->lbnd = 0;
+ SCM_ARRAY_DIMS (vra0)->ubnd = SCM_LENGTH (ra0) - 1;
+ SCM_ARRAY_DIMS (vra0)->inc = 1;
+ SCM_ARRAY_BASE (vra0) = 0;
+ SCM_ARRAY_V (vra0) = ra0;
+ ra0 = vra0;
+ }
+ lvra = SCM_EOL;
+ plvra = &lvra;
+ for (z = lra; SCM_NIMP (z); z = SCM_CDR (z))
+ {
+ ra1 = SCM_CAR (z);
+ vra1 = scm_make_ra (1);
+ SCM_ARRAY_DIMS (vra1)->lbnd = SCM_ARRAY_DIMS (vra0)->lbnd;
+ SCM_ARRAY_DIMS (vra1)->ubnd = SCM_ARRAY_DIMS (vra0)->ubnd;
+ if SCM_ARRAYP
+ (ra1)
+ {
+ if (kmax >= 0)
+ SCM_ARRAY_DIMS (vra1)->inc = SCM_ARRAY_DIMS (ra1)[kmax].inc;
+ SCM_ARRAY_V (vra1) = SCM_ARRAY_V (ra1);
+ }
+ else
+ {
+ SCM_ARRAY_DIMS (vra1)->inc = 1;
+ SCM_ARRAY_V (vra1) = ra1;
+ }
+ *plvra = scm_cons (vra1, SCM_EOL);
+ plvra = &SCM_CDR (*plvra);
+ }
+ inds = scm_make_uve (SCM_ARRAY_NDIM (ra0), SCM_MAKINUM (-1L));
+ vinds = (long *) SCM_VELTS (inds);
+ for (k = 0; k <= kmax; k++)
+ vinds[k] = SCM_ARRAY_DIMS (ra0)[k].lbnd;
+ k = kmax;
+ do
+ {
+ if (k == kmax)
+ {
+ SCM y = lra;
+ SCM_ARRAY_BASE (vra0) = cind (ra0, inds);
+ for (z = lvra; SCM_NIMP (z); z = SCM_CDR (z), y = SCM_CDR (y))
+ SCM_ARRAY_BASE (SCM_CAR (z)) = cind (SCM_CAR (y), inds);
+ if (0 == (SCM_UNBNDP (data) ? cproc(vra0, lvra) : cproc(vra0, data, lvra)))
+ return 0;
+ k--;
+ continue;
+ }
+ if (vinds[k] < SCM_ARRAY_DIMS (ra0)[k].ubnd)
+ {
+ vinds[k]++;
+ k++;
+ continue;
+ }
+ vinds[k] = SCM_ARRAY_DIMS (ra0)[k].lbnd - 1;
+ k--;
+ }
+ while (k >= 0);
+ return 1;
+ }
+}
+
+
+static char s_array_fill_x[];
+#ifdef __STDC__
+int
+scm_array_fill_int (SCM ra, SCM fill, SCM ignore)
+#else
+int
+scm_array_fill_int (ra, fill, ignore)
+ SCM ra;
+ SCM fill;
+ SCM ignore;
+#endif
+{
+ scm_sizet i, n = SCM_ARRAY_DIMS (ra)->ubnd - SCM_ARRAY_DIMS (ra)->lbnd + 1;
+ long inc = SCM_ARRAY_DIMS (ra)->inc;
+ scm_sizet base = SCM_ARRAY_BASE (ra);
+ ra = SCM_ARRAY_V (ra);
+ switch SCM_TYP7
+ (ra)
+ {
+ default:
+ for (i = base; n--; i += inc)
+ scm_array_set_x (ra, fill, SCM_MAKINUM (i));
+ break;
+ case scm_tc7_vector:
+ for (i = base; n--; i += inc)
+ SCM_VELTS (ra)[i] = fill;
+ break;
+ case scm_tc7_string:
+ SCM_ASRTGO (SCM_ICHRP (fill), badarg2);
+ for (i = base; n--; i += inc)
+ SCM_CHARS (ra)[i] = SCM_ICHR (fill);
+ break;
+ case scm_tc7_bvect:
+ {
+ long *ve = (long *) SCM_VELTS (ra);
+ if (1 == inc && (n >= SCM_LONG_BIT || n == SCM_LENGTH (ra)))
+ {
+ i = base / SCM_LONG_BIT;
+ if (SCM_BOOL_F == fill)
+ {
+ if (base % SCM_LONG_BIT) /* leading partial word */
+ ve[i++] &= ~(~0L << (base % SCM_LONG_BIT));
+ for (; i < (base + n) / SCM_LONG_BIT; i++)
+ ve[i] = 0L;
+ if ((base + n) % SCM_LONG_BIT) /* trailing partial word */
+ ve[i] &= (~0L << ((base + n) % SCM_LONG_BIT));
+ }
+ else if (SCM_BOOL_T == fill)
+ {
+ if (base % SCM_LONG_BIT)
+ ve[i++] |= ~0L << (base % SCM_LONG_BIT);
+ for (; i < (base + n) / SCM_LONG_BIT; i++)
+ ve[i] = ~0L;
+ if ((base + n) % SCM_LONG_BIT)
+ ve[i] |= ~(~0L << ((base + n) % SCM_LONG_BIT));
+ }
+ else
+ badarg2:scm_wta (fill, (char *) SCM_ARG2, s_array_fill_x);
+ }
+ else
+ {
+ if (SCM_BOOL_F == fill)
+ for (i = base; n--; i += inc)
+ ve[i / SCM_LONG_BIT] &= ~(1L << (i % SCM_LONG_BIT));
+ else if (SCM_BOOL_T == fill)
+ for (i = base; n--; i += inc)
+ ve[i / SCM_LONG_BIT] |= (1L << (i % SCM_LONG_BIT));
+ else
+ goto badarg2;
+ }
+ break;
+ }
+ case scm_tc7_uvect:
+ SCM_ASRTGO (0 <= SCM_INUM (fill), badarg2);
+ case scm_tc7_ivect:
+ SCM_ASRTGO (SCM_INUMP (fill), badarg2);
+ {
+ long f = SCM_INUM (fill), *ve = (long *) SCM_VELTS (ra);
+ for (i = base; n--; i += inc)
+ ve[i] = f;
+ break;
+ }
+#ifdef SCM_FLOATS
+#ifdef SCM_SINGLES
+ case scm_tc7_fvect:
+ {
+ float f, *ve = (float *) SCM_VELTS (ra);
+ SCM_ASRTGO (SCM_NIMP (fill) && SCM_REALP (fill), badarg2);
+ f = SCM_REALPART (fill);
+ for (i = base; n--; i += inc)
+ ve[i] = f;
+ break;
+ }
+#endif /* SCM_SINGLES */
+ case scm_tc7_dvect:
+ {
+ double f, *ve = (double *) SCM_VELTS (ra);
+ SCM_ASRTGO (SCM_NIMP (fill) && SCM_REALP (fill), badarg2);
+ f = SCM_REALPART (fill);
+ for (i = base; n--; i += inc)
+ ve[i] = f;
+ break;
+ }
+ case scm_tc7_cvect:
+ {
+ double fr, fi;
+ double (*ve)[2] = (double (*)[2]) SCM_VELTS (ra);
+ SCM_ASRTGO (SCM_NIMP (fill) && SCM_INEXP (fill), badarg2);
+ fr = SCM_REALPART (fill);
+ fi = (SCM_CPLXP (fill) ? SCM_IMAG (fill) : 0.0);
+ for (i = base; n--; i += inc)
+ {
+ ve[i][0] = fr;
+ ve[i][1] = fi;
+ }
+ break;
+ }
+#endif /* SCM_FLOATS */
+ }
+ return 1;
+}
+
+SCM_PROC(s_array_fill_x, "array-fill!", 2, 0, 0, scm_array_fill_x);
+#ifdef __STDC__
+SCM
+scm_array_fill_x (SCM ra, SCM fill)
+#else
+SCM
+scm_array_fill_x (ra, fill)
+ SCM ra;
+ SCM fill;
+#endif
+{
+ scm_ramapc (scm_array_fill_int, fill, ra, SCM_EOL, s_array_fill_x);
+ return SCM_UNSPECIFIED;
+}
+
+
+
+#ifdef __STDC__
+static int
+racp (SCM dst, SCM src)
+#else
+static int
+racp (src, dst)
+ SCM dst;
+ SCM src;
+#endif
+{
+ long n = (SCM_ARRAY_DIMS (src)->ubnd - SCM_ARRAY_DIMS (src)->lbnd + 1);
+ long inc_d, inc_s = SCM_ARRAY_DIMS (src)->inc;
+ scm_sizet i_d, i_s = SCM_ARRAY_BASE (src);
+ dst = SCM_CAR (dst);
+ inc_d = SCM_ARRAY_DIMS (dst)->inc;
+ i_d = SCM_ARRAY_BASE (dst);
+ src = SCM_ARRAY_V (src);
+ dst = SCM_ARRAY_V (dst);
+ switch SCM_TYP7
+ (dst)
+ {
+ default:
+ gencase: case scm_tc7_vector:
+ for (; n-- > 0; i_s += inc_s, i_d += inc_d)
+ scm_array_set_x (dst, scm_cvref (src, i_s, SCM_UNDEFINED), SCM_MAKINUM (i_d));
+ break;
+ case scm_tc7_string:
+ if (scm_tc7_string != SCM_TYP7 (dst))
+ goto gencase;
+ for (; n-- > 0; i_s += inc_s, i_d += inc_d)
+ SCM_CHARS (dst)[i_d] = SCM_CHARS (src)[i_s];
+ break;
+ case scm_tc7_bvect:
+ if (scm_tc7_bvect != SCM_TYP7 (dst))
+ goto gencase;
+ if (1 == inc_d && 1 == inc_s && i_s % SCM_LONG_BIT == i_d % SCM_LONG_BIT && n >= SCM_LONG_BIT)
+ {
+ long *sv = (long *) SCM_VELTS (src);
+ long *dv = (long *) SCM_VELTS (dst);
+ sv += i_s / SCM_LONG_BIT;
+ dv += i_d / SCM_LONG_BIT;
+ if (i_s % SCM_LONG_BIT)
+ { /* leading partial word */
+ *dv = (*dv & ~(~0L << (i_s % SCM_LONG_BIT))) | (*sv & (~0L << (i_s % SCM_LONG_BIT)));
+ dv++;
+ sv++;
+ n -= SCM_LONG_BIT - (i_s % SCM_LONG_BIT);
+ }
+ IVDEP (src != dst,
+ for (; n >= SCM_LONG_BIT; n -= SCM_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 (SCM_VELTS (src)[i_s / SCM_LONG_BIT] & (1L << (i_s % SCM_LONG_BIT)))
+ SCM_VELTS (dst)[i_d / SCM_LONG_BIT] |= (1L << (i_d % SCM_LONG_BIT));
+ else
+ SCM_VELTS (dst)[i_d / SCM_LONG_BIT] &= ~(1L << (i_d % SCM_LONG_BIT));
+ }
+ break;
+ case scm_tc7_uvect:
+ if (scm_tc7_uvect != SCM_TYP7 (src))
+ goto gencase;
+ else
+ {
+ long *d = (long *) SCM_VELTS (dst), *s = (long *) SCM_VELTS (src);
+ IVDEP (src != dst,
+ for (; n-- > 0; i_s += inc_s, i_d += inc_d)
+ d[i_d] = s[i_s];)
+ break;
+ }
+ case scm_tc7_ivect:
+ if (scm_tc7_uvect != SCM_TYP7 (src) && scm_tc7_ivect != SCM_TYP7 (src))
+ goto gencase;
+ else
+ {
+ long *d = (long *) SCM_VELTS (dst), *s = (long *) SCM_VELTS (src);
+ IVDEP (src != dst,
+ for (; n-- > 0; i_s += inc_s, i_d += inc_d)
+ d[i_d] = s[i_s];)
+ break;
+ }
+#ifdef SCM_FLOATS
+#ifdef SCM_SINGLES
+ case scm_tc7_fvect:
+ {
+ float *d = (float *) SCM_VELTS (dst);
+ float *s = (float *) SCM_VELTS (src);
+ switch SCM_TYP7
+ (src)
+ {
+ default:
+ goto gencase;
+ case scm_tc7_ivect:
+ case scm_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 scm_tc7_fvect:
+ IVDEP (src != dst,
+ for (; n-- > 0; i_s += inc_s, i_d += inc_d)
+ d[i_d] = s[i_s];)
+ break;
+ case scm_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 /* SCM_SINGLES */
+ case scm_tc7_dvect:
+ {
+ double *d = (double *) SCM_VELTS (dst);
+ double *s = (double *) SCM_VELTS (src);
+ switch SCM_TYP7
+ (src)
+ {
+ default:
+ goto gencase;
+ case scm_tc7_ivect:
+ case scm_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 scm_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 scm_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 scm_tc7_cvect:
+ {
+ double (*d)[2] = (double (*)[2]) SCM_VELTS (dst);
+ double (*s)[2] = (double (*)[2]) SCM_VELTS (src);
+ switch SCM_TYP7
+ (src)
+ {
+ default:
+ goto gencase;
+ case scm_tc7_ivect:
+ case scm_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 scm_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 scm_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 scm_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 /* SCM_FLOATS */
+ return 1;
+}
+
+
+SCM_PROC(s_serial_array_copy_x, "serial-array-copy!", 2, 0, 0, scm_array_copy_x);
+SCM_PROC(s_array_copy_x, "array-copy!", 2, 0, 0, scm_array_copy_x);
+#ifdef __STDC__
+SCM
+scm_array_copy_x (SCM src, SCM dst)
+#else
+SCM
+scm_array_copy_x (src, dst)
+ SCM src;
+ SCM dst;
+#endif
+{
+ scm_ramapc (racp, SCM_UNDEFINED, src, scm_cons (dst, SCM_EOL), s_array_copy_x);
+ return SCM_UNSPECIFIED;
+}
+
+/* Functions callable by ARRAY-MAP! */
+
+#ifdef __STDC__
+int
+scm_ra_eqp (SCM ra0, SCM ras)
+#else
+int
+scm_ra_eqp (ra0, ras)
+ SCM ra0;
+ SCM ras;
+#endif
+{
+ SCM ra1 = SCM_CAR (ras), ra2 = SCM_CAR (SCM_CDR (ras));
+ long n = SCM_ARRAY_DIMS (ra0)->ubnd - SCM_ARRAY_DIMS (ra0)->lbnd + 1;
+ scm_sizet i0 = SCM_ARRAY_BASE (ra0), i1 = SCM_ARRAY_BASE (ra1), i2 = SCM_ARRAY_BASE (ra2);
+ long inc0 = SCM_ARRAY_DIMS (ra0)->inc;
+ long inc1 = SCM_ARRAY_DIMS (ra1)->inc;
+ long inc2 = SCM_ARRAY_DIMS (ra1)->inc;
+ ra0 = SCM_ARRAY_V (ra0);
+ ra1 = SCM_ARRAY_V (ra1);
+ ra2 = SCM_ARRAY_V (ra2);
+ switch (SCM_TYP7 (ra1) == SCM_TYP7 (ra2) ? SCM_TYP7 (ra1) : 0)
+ {
+ default:
+ {
+ SCM e1 = SCM_UNDEFINED, e2 = SCM_UNDEFINED;
+ for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
+ if BVE_REF
+ (ra0, i0)
+ if SCM_FALSEP
+ (scm_eq_p (RVREF (ra1, i1, e1), RVREF (ra2, i2, e2)))
+ BVE_CLR (ra0, i0);
+ break;
+ }
+ case scm_tc7_uvect:
+ case scm_tc7_ivect:
+ for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
+ if BVE_REF
+ (ra0, i0)
+ if (SCM_VELTS (ra1)[i1] != SCM_VELTS (ra2)[i2])
+ BVE_CLR (ra0, i0);
+ break;
+#ifdef SCM_FLOATS
+#ifdef SCM_SINGLES
+ case scm_tc7_fvect:
+ for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
+ if BVE_REF
+ (ra0, i0)
+ if (((float *) SCM_VELTS (ra1))[i1] != ((float *) SCM_VELTS (ra2))[i2])
+ BVE_CLR (ra0, i0);
+ break;
+#endif /*SCM_SINGLES*/
+ case scm_tc7_dvect:
+ for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
+ if BVE_REF
+ (ra0, i0)
+ if (((double *) SCM_VELTS (ra1))[i1] != ((double *) SCM_VELTS (ra2))[i2])
+ BVE_CLR (ra0, i0);
+ break;
+ case scm_tc7_cvect:
+ for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
+ if BVE_REF
+ (ra0, i0)
+ if (((double *) SCM_VELTS (ra1))[2 * i1] != ((double *) SCM_VELTS (ra2))[2 * i2] ||
+ ((double *) SCM_VELTS (ra1))[2 * i1 + 1] != ((double *) SCM_VELTS (ra2))[2 * i2 + 1])
+ BVE_CLR (ra0, i0);
+ break;
+#endif /*SCM_FLOATS*/
+ }
+ return 1;
+}
+
+/* opt 0 means <, nonzero means >= */
+#ifdef __STDC__
+static int
+ra_compare (SCM ra0, SCM ra1, SCM ra2, int opt)
+#else
+static int
+ra_compare (ra0, ra1, ra2, opt)
+ SCM ra0;
+ SCM ra1;
+ SCM ra2;
+ int opt;
+#endif
+{
+ long n = SCM_ARRAY_DIMS (ra0)->ubnd - SCM_ARRAY_DIMS (ra0)->lbnd + 1;
+ scm_sizet i0 = SCM_ARRAY_BASE (ra0), i1 = SCM_ARRAY_BASE (ra1), i2 = SCM_ARRAY_BASE (ra2);
+ long inc0 = SCM_ARRAY_DIMS (ra0)->inc;
+ long inc1 = SCM_ARRAY_DIMS (ra1)->inc;
+ long inc2 = SCM_ARRAY_DIMS (ra1)->inc;
+ ra0 = SCM_ARRAY_V (ra0);
+ ra1 = SCM_ARRAY_V (ra1);
+ ra2 = SCM_ARRAY_V (ra2);
+ switch (SCM_TYP7 (ra1) == SCM_TYP7 (ra2) ? SCM_TYP7 (ra1) : 0)
+ {
+ default:
+ {
+ SCM e1 = SCM_UNDEFINED, e2 = SCM_UNDEFINED;
+ for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
+ if BVE_REF
+ (ra0, i0)
+ if (opt ?
+ SCM_NFALSEP (scm_less_p (RVREF (ra1, i1, e1), RVREF (ra2, i2, e2))) :
+ SCM_FALSEP (scm_less_p (RVREF (ra1, i1, e1), RVREF (ra2, i2, e2))))
+ BVE_CLR (ra0, i0);
+ break;
+ }
+ case scm_tc7_uvect:
+ case scm_tc7_ivect:
+ for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
+ {
+ if BVE_REF
+ (ra0, i0)
+ if (opt ?
+ SCM_VELTS (ra1)[i1] < SCM_VELTS (ra2)[i2] :
+ SCM_VELTS (ra1)[i1] >= SCM_VELTS (ra2)[i2])
+ BVE_CLR (ra0, i0);
+ }
+ break;
+#ifdef SCM_FLOATS
+#ifdef SCM_SINGLES
+ case scm_tc7_fvect:
+ for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
+ if BVE_REF
+ (ra0, i0)
+ if (opt ?
+ ((float *) SCM_VELTS (ra1))[i1] < ((float *) SCM_VELTS (ra2))[i2] :
+ ((float *) SCM_VELTS (ra1))[i1] >= ((float *) SCM_VELTS (ra2))[i2])
+ BVE_CLR (ra0, i0);
+ break;
+#endif /*SCM_SINGLES*/
+ case scm_tc7_dvect:
+ for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
+ if BVE_REF
+ (ra0, i0)
+ if (opt ?
+ ((double *) SCM_VELTS (ra1))[i1] < ((double *) SCM_VELTS (ra2))[i2] :
+ ((double *) SCM_VELTS (ra1))[i1] >= ((double *) SCM_VELTS (ra2))[i2])
+ BVE_CLR (ra0, i0);
+ break;
+#endif /*SCM_FLOATS*/
+ }
+ return 1;
+}
+
+
+#ifdef __STDC__
+int
+scm_ra_lessp (SCM ra0, SCM ras)
+#else
+int
+scm_ra_lessp (ra0, ras)
+ SCM ra0;
+ SCM ras;
+#endif
+{
+ return ra_compare (ra0, SCM_CAR (ras), SCM_CAR (SCM_CDR (ras)), 0);
+}
+
+#ifdef __STDC__
+int
+scm_ra_leqp (SCM ra0, SCM ras)
+#else
+int
+scm_ra_leqp (ra0, ras)
+ SCM ra0;
+ SCM ras;
+#endif
+{
+ return ra_compare (ra0, SCM_CAR (SCM_CDR (ras)), SCM_CAR (ras), 1);
+}
+
+#ifdef __STDC__
+int
+scm_ra_grp (SCM ra0, SCM ras)
+#else
+int
+scm_ra_grp (ra0, ras)
+ SCM ra0;
+ SCM ras;
+#endif
+{
+ return ra_compare (ra0, SCM_CAR (SCM_CDR (ras)), SCM_CAR (ras), 0);
+}
+
+#ifdef __STDC__
+int
+scm_ra_greqp (SCM ra0, SCM ras)
+#else
+int
+scm_ra_greqp (ra0, ras)
+ SCM ra0;
+ SCM ras;
+#endif
+{
+ return ra_compare (ra0, SCM_CAR (ras), SCM_CAR (SCM_CDR (ras)), 1);
+}
+
+
+#ifdef __STDC__
+int
+scm_ra_sum (SCM ra0, SCM ras)
+#else
+int
+scm_ra_sum (ra0, ras)
+ SCM ra0;
+ SCM ras;
+#endif
+{
+ long n = SCM_ARRAY_DIMS (ra0)->ubnd - SCM_ARRAY_DIMS (ra0)->lbnd + 1;
+ scm_sizet i0 = SCM_ARRAY_BASE (ra0);
+ long inc0 = SCM_ARRAY_DIMS (ra0)->inc;
+ ra0 = SCM_ARRAY_V (ra0);
+ if SCM_NNULLP
+ (ras)
+ {
+ SCM ra1 = SCM_CAR (ras);
+ scm_sizet i1 = SCM_ARRAY_BASE (ra1);
+ long inc1 = SCM_ARRAY_DIMS (ra1)->inc;
+ ra1 = SCM_ARRAY_V (ra1);
+ switch (SCM_TYP7 (ra0) == SCM_TYP7 (ra1) ? SCM_TYP7 (ra0) : 0)
+ {
+ default:
+ {
+ SCM e0 = SCM_UNDEFINED, e1 = SCM_UNDEFINED;
+ for (; n-- > 0; i0 += inc0, i1 += inc1)
+ scm_array_set_x (ra0, scm_sum (RVREF (ra0, i0, e0), RVREF (ra1, i1, e1)),
+ SCM_MAKINUM (i0));
+ break;
+ }
+ case scm_tc7_uvect:
+ case scm_tc7_ivect:
+ {
+ long *v0 = SCM_VELTS (ra0);
+ long *v1 = SCM_VELTS (ra1);
+ IVDEP (ra0 != ra1,
+ for (; n-- > 0; i0 += inc0, i1 += inc1)
+ v0[i0] += v1[i1]);
+ break;
+ }
+#ifdef SCM_FLOATS
+#ifdef SCM_SINGLES
+ case scm_tc7_fvect:
+ {
+ float *v0 = (float *) SCM_VELTS (ra0);
+ float *v1 = (float *) SCM_VELTS (ra1);
+ IVDEP (ra0 != ra1,
+ for (; n-- > 0; i0 += inc0, i1 += inc1)
+ v0[i0] += v1[i1]);
+ break;
+ }
+#endif /* SCM_SINGLES */
+ case scm_tc7_dvect:
+ {
+ double *v0 = (double *) SCM_VELTS (ra0);
+ double *v1 = (double *) SCM_VELTS (ra1);
+ IVDEP (ra0 != ra1,
+ for (; n-- > 0; i0 += inc0, i1 += inc1)
+ v0[i0] += v1[i1]);
+ break;
+ }
+ case scm_tc7_cvect:
+ {
+ double (*v0)[2] = (double (*)[2]) SCM_VELTS (ra0);
+ double (*v1)[2] = (double (*)[2]) SCM_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 /* SCM_FLOATS */
+ }
+ }
+ return 1;
+}
+
+
+#ifdef __STDC__
+int
+scm_ra_difference (SCM ra0, SCM ras)
+#else
+int
+scm_ra_difference (ra0, ras)
+ SCM ra0;
+ SCM ras;
+#endif
+{
+ long n = SCM_ARRAY_DIMS (ra0)->ubnd - SCM_ARRAY_DIMS (ra0)->lbnd + 1;
+ scm_sizet i0 = SCM_ARRAY_BASE (ra0);
+ long inc0 = SCM_ARRAY_DIMS (ra0)->inc;
+ ra0 = SCM_ARRAY_V (ra0);
+ if SCM_NULLP
+ (ras)
+ {
+ switch SCM_TYP7
+ (ra0)
+ {
+ default:
+ {
+ SCM e0 = SCM_UNDEFINED;
+ for (; n-- > 0; i0 += inc0)
+ scm_array_set_x (ra0, scm_difference (RVREF (ra0, i0, e0), SCM_UNDEFINED), SCM_MAKINUM (i0));
+ break;
+ }
+#ifdef SCM_FLOATS
+#ifdef SCM_SINGLES
+ case scm_tc7_fvect:
+ {
+ float *v0 = (float *) SCM_VELTS (ra0);
+ for (; n-- > 0; i0 += inc0)
+ v0[i0] = -v0[i0];
+ break;
+ }
+#endif /* SCM_SINGLES */
+ case scm_tc7_dvect:
+ {
+ double *v0 = (double *) SCM_VELTS (ra0);
+ for (; n-- > 0; i0 += inc0)
+ v0[i0] = -v0[i0];
+ break;
+ }
+ case scm_tc7_cvect:
+ {
+ double (*v0)[2] = (double (*)[2]) SCM_VELTS (ra0);
+ for (; n-- > 0; i0 += inc0)
+ {
+ v0[i0][0] = -v0[i0][0];
+ v0[i0][1] = -v0[i0][1];
+ }
+ break;
+ }
+#endif /* SCM_FLOATS */
+ }
+ }
+ else
+ {
+ SCM ra1 = SCM_CAR (ras);
+ scm_sizet i1 = SCM_ARRAY_BASE (ra1);
+ long inc1 = SCM_ARRAY_DIMS (ra1)->inc;
+ ra1 = SCM_ARRAY_V (ra1);
+ switch (SCM_TYP7 (ra0) == SCM_TYP7 (ra1) ? SCM_TYP7 (ra0) : 0)
+ {
+ default:
+ {
+ SCM e0 = SCM_UNDEFINED, e1 = SCM_UNDEFINED;
+ for (; n-- > 0; i0 += inc0, i1 += inc1)
+ scm_array_set_x (ra0, scm_difference (RVREF (ra0, i0, e0), RVREF (ra1, i1, e1)), SCM_MAKINUM (i0));
+ break;
+ }
+#ifdef SCM_FLOATS
+#ifdef SCM_SINGLES
+ case scm_tc7_fvect:
+ {
+ float *v0 = (float *) SCM_VELTS (ra0);
+ float *v1 = (float *) SCM_VELTS (ra1);
+ IVDEP (ra0 != ra1,
+ for (; n-- > 0; i0 += inc0, i1 += inc1)
+ v0[i0] -= v1[i1]);
+ break;
+ }
+#endif /* SCM_SINGLES */
+ case scm_tc7_dvect:
+ {
+ double *v0 = (double *) SCM_VELTS (ra0);
+ double *v1 = (double *) SCM_VELTS (ra1);
+ IVDEP (ra0 != ra1,
+ for (; n-- > 0; i0 += inc0, i1 += inc1)
+ v0[i0] -= v1[i1]);
+ break;
+ }
+ case scm_tc7_cvect:
+ {
+ double (*v0)[2] = (double (*)[2]) SCM_VELTS (ra0);
+ double (*v1)[2] = (double (*)[2]) SCM_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 /* SCM_FLOATS */
+ }
+ }
+ return 1;
+}
+
+
+#ifdef __STDC__
+int
+scm_ra_product (SCM ra0, SCM ras)
+#else
+int
+scm_ra_product (ra0, ras)
+ SCM ra0;
+ SCM ras;
+#endif
+{
+ long n = SCM_ARRAY_DIMS (ra0)->ubnd - SCM_ARRAY_DIMS (ra0)->lbnd + 1;
+ scm_sizet i0 = SCM_ARRAY_BASE (ra0);
+ long inc0 = SCM_ARRAY_DIMS (ra0)->inc;
+ ra0 = SCM_ARRAY_V (ra0);
+ if SCM_NNULLP
+ (ras)
+ {
+ SCM ra1 = SCM_CAR (ras);
+ scm_sizet i1 = SCM_ARRAY_BASE (ra1);
+ long inc1 = SCM_ARRAY_DIMS (ra1)->inc;
+ ra1 = SCM_ARRAY_V (ra1);
+ switch (SCM_TYP7 (ra0) == SCM_TYP7 (ra1) ? SCM_TYP7 (ra0) : 0)
+ {
+ default:
+ {
+ SCM e0 = SCM_UNDEFINED, e1 = SCM_UNDEFINED;
+ for (; n-- > 0; i0 += inc0, i1 += inc1)
+ scm_array_set_x (ra0, scm_product (RVREF (ra0, i0, e0), RVREF (ra1, i1, e1)),
+ SCM_MAKINUM (i0));
+ break;
+ }
+ case scm_tc7_uvect:
+ case scm_tc7_ivect:
+ {
+ long *v0 = SCM_VELTS (ra0);
+ long *v1 = SCM_VELTS (ra1);
+ IVDEP (ra0 != ra1,
+ for (; n-- > 0; i0 += inc0, i1 += inc1)
+ v0[i0] *= v1[i1]);
+ break;
+ }
+#ifdef SCM_FLOATS
+#ifdef SCM_SINGLES
+ case scm_tc7_fvect:
+ {
+ float *v0 = (float *) SCM_VELTS (ra0);
+ float *v1 = (float *) SCM_VELTS (ra1);
+ IVDEP (ra0 != ra1,
+ for (; n-- > 0; i0 += inc0, i1 += inc1)
+ v0[i0] *= v1[i1]);
+ break;
+ }
+#endif /* SCM_SINGLES */
+ case scm_tc7_dvect:
+ {
+ double *v0 = (double *) SCM_VELTS (ra0);
+ double *v1 = (double *) SCM_VELTS (ra1);
+ IVDEP (ra0 != ra1,
+ for (; n-- > 0; i0 += inc0, i1 += inc1)
+ v0[i0] *= v1[i1]);
+ break;
+ }
+ case scm_tc7_cvect:
+ {
+ double (*v0)[2] = (double (*)[2]) SCM_VELTS (ra0);
+ register double r;
+ double (*v1)[2] = (double (*)[2]) SCM_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 /* SCM_FLOATS */
+ }
+ }
+ return 1;
+}
+
+#ifdef __STDC__
+int
+scm_ra_divide (SCM ra0, SCM ras)
+#else
+int
+scm_ra_divide (ra0, ras)
+ SCM ra0;
+ SCM ras;
+#endif
+{
+ long n = SCM_ARRAY_DIMS (ra0)->ubnd - SCM_ARRAY_DIMS (ra0)->lbnd + 1;
+ scm_sizet i0 = SCM_ARRAY_BASE (ra0);
+ long inc0 = SCM_ARRAY_DIMS (ra0)->inc;
+ ra0 = SCM_ARRAY_V (ra0);
+ if SCM_NULLP
+ (ras)
+ {
+ switch SCM_TYP7
+ (ra0)
+ {
+ default:
+ {
+ SCM e0 = SCM_UNDEFINED;
+ for (; n-- > 0; i0 += inc0)
+ scm_array_set_x (ra0, scm_divide (RVREF (ra0, i0, e0), SCM_UNDEFINED), SCM_MAKINUM (i0));
+ break;
+ }
+#ifdef SCM_FLOATS
+#ifdef SCM_SINGLES
+ case scm_tc7_fvect:
+ {
+ float *v0 = (float *) SCM_VELTS (ra0);
+ for (; n-- > 0; i0 += inc0)
+ v0[i0] = 1.0 / v0[i0];
+ break;
+ }
+#endif /* SCM_SINGLES */
+ case scm_tc7_dvect:
+ {
+ double *v0 = (double *) SCM_VELTS (ra0);
+ for (; n-- > 0; i0 += inc0)
+ v0[i0] = 1.0 / v0[i0];
+ break;
+ }
+ case scm_tc7_cvect:
+ {
+ register double d;
+ double (*v0)[2] = (double (*)[2]) SCM_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 /* SCM_FLOATS */
+ }
+ }
+ else
+ {
+ SCM ra1 = SCM_CAR (ras);
+ scm_sizet i1 = SCM_ARRAY_BASE (ra1);
+ long inc1 = SCM_ARRAY_DIMS (ra1)->inc;
+ ra1 = SCM_ARRAY_V (ra1);
+ switch (SCM_TYP7 (ra0) == SCM_TYP7 (ra1) ? SCM_TYP7 (ra0) : 0)
+ {
+ default:
+ {
+ SCM e0 = SCM_UNDEFINED, e1 = SCM_UNDEFINED;
+ for (; n-- > 0; i0 += inc0, i1 += inc1)
+ scm_array_set_x (ra0, scm_divide (RVREF (ra0, i0, e0), RVREF (ra1, i1, e1)), SCM_MAKINUM (i0));
+ break;
+ }
+#ifdef SCM_FLOATS
+#ifdef SCM_SINGLES
+ case scm_tc7_fvect:
+ {
+ float *v0 = (float *) SCM_VELTS (ra0);
+ float *v1 = (float *) SCM_VELTS (ra1);
+ IVDEP (ra0 != ra1,
+ for (; n-- > 0; i0 += inc0, i1 += inc1)
+ v0[i0] /= v1[i1]);
+ break;
+ }
+#endif /* SCM_SINGLES */
+ case scm_tc7_dvect:
+ {
+ double *v0 = (double *) SCM_VELTS (ra0);
+ double *v1 = (double *) SCM_VELTS (ra1);
+ IVDEP (ra0 != ra1,
+ for (; n-- > 0; i0 += inc0, i1 += inc1)
+ v0[i0] /= v1[i1]);
+ break;
+ }
+ case scm_tc7_cvect:
+ {
+ register double d, r;
+ double (*v0)[2] = (double (*)[2]) SCM_VELTS (ra0);
+ double (*v1)[2] = (double (*)[2]) SCM_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 /* SCM_FLOATS */
+ }
+ }
+ return 1;
+}
+
+#ifdef __STDC__
+int
+scm_array_identity (SCM src, SCM dst)
+#else
+int
+scm_array_identity (dst, src)
+ SCM src;
+ SCM dst;
+#endif
+{
+ return racp (SCM_CAR (src), scm_cons (dst, SCM_EOL));
+}
+
+
+#ifdef __STDC__
+static
+int
+ramap (SCM ra0, SCM proc, SCM ras)
+#else
+static int
+ramap (ra0, proc, ras)
+ SCM ra0;
+ SCM proc;
+ SCM ras;
+#endif
+{
+ long i = SCM_ARRAY_DIMS (ra0)->lbnd;
+ long inc = SCM_ARRAY_DIMS (ra0)->inc;
+ long n = SCM_ARRAY_DIMS (ra0)->ubnd;
+ long base = SCM_ARRAY_BASE (ra0) - i * inc;
+ ra0 = SCM_ARRAY_V (ra0);
+ if SCM_NULLP
+ (ras)
+ for (; i <= n; i++)
+ scm_array_set_x (ra0, scm_apply (proc, SCM_EOL, SCM_EOL), SCM_MAKINUM (i * inc + base));
+ else
+ {
+ SCM ra1 = SCM_CAR (ras);
+ SCM args, *ve = &ras;
+ scm_sizet k, i1 = SCM_ARRAY_BASE (ra1);
+ long inc1 = SCM_ARRAY_DIMS (ra1)->inc;
+ ra1 = SCM_ARRAY_V (ra1);
+ ras = SCM_CDR (ras);
+ if SCM_NULLP
+ (ras)
+ ras = scm_nullvect;
+ else
+ {
+ ras = scm_vector (ras);
+ ve = SCM_VELTS (ras);
+ }
+ for (; i <= n; i++, i1 += inc1)
+ {
+ args = SCM_EOL;
+ for (k = SCM_LENGTH (ras); k--;)
+ args = scm_cons (scm_uniform_vector_ref (ve[k], SCM_MAKINUM (i)), args);
+ args = scm_cons (scm_cvref (ra1, i1, SCM_UNDEFINED), args);
+ scm_array_set_x (ra0, scm_apply (proc, args, SCM_EOL), SCM_MAKINUM (i * inc + base));
+ }
+ }
+ return 1;
+}
+
+#ifdef __STDC__
+static int
+ramap_cxr (SCM ra0, SCM proc, SCM ras)
+#else
+static int
+ramap_cxr (ra0, proc, ras)
+ SCM ra0;
+ SCM proc;
+ SCM ras;
+#endif
+{
+ SCM ra1 = SCM_CAR (ras);
+ SCM e1 = SCM_UNDEFINED;
+ scm_sizet i0 = SCM_ARRAY_BASE (ra0), i1 = SCM_ARRAY_BASE (ra1);
+ long inc0 = SCM_ARRAY_DIMS (ra0)->inc, inc1 = SCM_ARRAY_DIMS (ra1)->inc;
+ long n = SCM_ARRAY_DIMS (ra0)->ubnd - SCM_ARRAY_DIMS (ra1)->lbnd + 1;
+ ra0 = SCM_ARRAY_V (ra0);
+ ra1 = SCM_ARRAY_V (ra1);
+ switch SCM_TYP7
+ (ra0)
+ {
+ default:
+ gencase:
+ for (; n-- > 0; i0 += inc0, i1 += inc1)
+ scm_array_set_x (ra0, scm_apply (proc, RVREF (ra1, i1, e1), scm_listofnull), SCM_MAKINUM (i0));
+ break;
+#ifdef SCM_FLOATS
+#ifdef SCM_SINGLES
+ case scm_tc7_fvect:
+ {
+ float *dst = (float *) SCM_VELTS (ra0);
+ switch SCM_TYP7
+ (ra1)
+ {
+ default:
+ goto gencase;
+ case scm_tc7_fvect:
+ for (; n-- > 0; i0 += inc0, i1 += inc1)
+ dst[i0] = SCM_DSUBRF (proc) ((double) ((float *) SCM_VELTS (ra1))[i1]);
+ break;
+ case scm_tc7_uvect:
+ case scm_tc7_ivect:
+ for (; n-- > 0; i0 += inc0, i1 += inc1)
+ dst[i0] = SCM_DSUBRF (proc) ((double) SCM_VELTS (ra1)[i1]);
+ break;
+ }
+ break;
+ }
+#endif /* SCM_SINGLES */
+ case scm_tc7_dvect:
+ {
+ double *dst = (double *) SCM_VELTS (ra0);
+ switch SCM_TYP7
+ (ra1)
+ {
+ default:
+ goto gencase;
+ case scm_tc7_dvect:
+ for (; n-- > 0; i0 += inc0, i1 += inc1)
+ dst[i0] = SCM_DSUBRF (proc) (((double *) SCM_VELTS (ra1))[i1]);
+ break;
+ case scm_tc7_uvect:
+ case scm_tc7_ivect:
+ for (; n-- > 0; i0 += inc0, i1 += inc1)
+ dst[i0] = SCM_DSUBRF (proc) ((double) SCM_VELTS (ra1)[i1]);
+ break;
+ }
+ break;
+ }
+#endif /* SCM_FLOATS */
+ }
+ return 1;
+}
+
+
+#ifdef __STDC__
+static int
+ramap_rp (SCM ra0, SCM proc, SCM ras)
+#else
+static int
+ramap_rp (ra0, proc, ras)
+ SCM ra0;
+ SCM proc;
+ SCM ras;
+#endif
+{
+ SCM ra1 = SCM_CAR (ras), ra2 = SCM_CAR (SCM_CDR (ras));
+ SCM e1 = SCM_UNDEFINED, e2 = SCM_UNDEFINED;
+ long n = SCM_ARRAY_DIMS (ra0)->ubnd - SCM_ARRAY_DIMS (ra0)->lbnd + 1;
+ scm_sizet i0 = SCM_ARRAY_BASE (ra0), i1 = SCM_ARRAY_BASE (ra1), i2 = SCM_ARRAY_BASE (ra2);
+ long inc0 = SCM_ARRAY_DIMS (ra0)->inc;
+ long inc1 = SCM_ARRAY_DIMS (ra1)->inc;
+ long inc2 = SCM_ARRAY_DIMS (ra1)->inc;
+ ra0 = SCM_ARRAY_V (ra0);
+ ra1 = SCM_ARRAY_V (ra1);
+ ra2 = SCM_ARRAY_V (ra2);
+ switch (SCM_TYP7 (ra1) == SCM_TYP7 (ra2) ? SCM_TYP7 (ra1) : 0)
+ {
+ default:
+ for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
+ if BVE_REF
+ (ra0, i0)
+ if SCM_FALSEP
+ (SCM_SUBRF (proc) (RVREF (ra1, i1, e1), RVREF (ra2, i2, e2)))
+ BVE_CLR (ra0, i0);
+ break;
+ case scm_tc7_uvect:
+ case scm_tc7_ivect:
+ for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
+ if BVE_REF
+ (ra0, i0)
+ {
+ if SCM_FALSEP
+ (SCM_SUBRF (proc) (SCM_MAKINUM (SCM_VELTS (ra1)[i1]),
+ SCM_MAKINUM (SCM_VELTS (ra2)[i2])))
+ BVE_CLR (ra0, i0);
+ }
+ break;
+#ifdef SCM_FLOATS
+#ifdef SCM_SINGLES
+ case scm_tc7_fvect:
+ {
+ SCM a1 = scm_makflo (1.0), a2 = scm_makflo (1.0);
+ for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
+ if BVE_REF
+ (ra0, i0)
+ {
+ SCM_FLO (a1) = ((float *) SCM_VELTS (ra1))[i1];
+ SCM_FLO (a2) = ((float *) SCM_VELTS (ra2))[i2];
+ if SCM_FALSEP
+ (SCM_SUBRF (proc) (a1, a2))
+ BVE_CLR (ra0, i0);
+ }
+ break;
+ }
+#endif /*SCM_SINGLES*/
+ case scm_tc7_dvect:
+ {
+ SCM a1 = scm_makdbl (1.0 / 3.0, 0.0), a2 = scm_makdbl (1.0 / 3.0, 0.0);
+ for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
+ if BVE_REF
+ (ra0, i0)
+ {
+ SCM_REAL (a1) = ((double *) SCM_VELTS (ra1))[i1];
+ SCM_REAL (a2) = ((double *) SCM_VELTS (ra2))[i2];
+ if SCM_FALSEP
+ (SCM_SUBRF (proc) (a1, a2))
+ BVE_CLR (ra0, i0);
+ }
+ break;
+ }
+ case scm_tc7_cvect:
+ {
+ SCM a1 = scm_makdbl (1.0, 1.0), a2 = scm_makdbl (1.0, 1.0);
+ for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
+ if BVE_REF
+ (ra0, i0)
+ {
+ SCM_REAL (a1) = ((double *) SCM_VELTS (ra1))[2 * i1];
+ SCM_IMAG (a1) = ((double *) SCM_VELTS (ra1))[2 * i1 + 1];
+ SCM_REAL (a2) = ((double *) SCM_VELTS (ra2))[2 * i2];
+ SCM_IMAG (a2) = ((double *) SCM_VELTS (ra2))[2 * i2 + 1];
+ if SCM_FALSEP
+ (SCM_SUBRF (proc) (a1, a2))
+ BVE_CLR (ra0, i0);
+ }
+ break;
+ }
+#endif /*SCM_FLOATS*/
+ }
+ return 1;
+}
+
+
+#ifdef __STDC__
+static int
+ramap_1 (SCM ra0, SCM proc, SCM ras)
+#else
+static int
+ramap_1 (ra0, proc, ras)
+ SCM ra0;
+ SCM proc;
+ SCM ras;
+#endif
+{
+ SCM ra1 = SCM_CAR (ras);
+ SCM e1 = SCM_UNDEFINED;
+ long n = SCM_ARRAY_DIMS (ra0)->ubnd - SCM_ARRAY_DIMS (ra0)->lbnd + 1;
+ scm_sizet i0 = SCM_ARRAY_BASE (ra0), i1 = SCM_ARRAY_BASE (ra1);
+ long inc0 = SCM_ARRAY_DIMS (ra0)->inc, inc1 = SCM_ARRAY_DIMS (ra1)->inc;
+ ra0 = SCM_ARRAY_V (ra0);
+ ra1 = SCM_ARRAY_V (ra1);
+ if (scm_tc7_vector == SCM_TYP7 (ra0))
+ for (; n-- > 0; i0 += inc0, i1 += inc1)
+ scm_array_set_x (ra0, SCM_SUBRF (proc) (scm_cvref (ra1, i1, SCM_UNDEFINED)), SCM_MAKINUM (i0));
+ else
+ for (; n-- > 0; i0 += inc0, i1 += inc1)
+ scm_array_set_x (ra0, SCM_SUBRF (proc) (RVREF (ra1, i1, e1)), SCM_MAKINUM (i0));
+ return 1;
+}
+
+
+#ifdef __STDC__
+static int
+ramap_2o (SCM ra0, SCM proc, SCM ras)
+#else
+static int
+ramap_2o (ra0, proc, ras)
+ SCM ra0;
+ SCM proc;
+ SCM ras;
+#endif
+{
+ SCM ra1 = SCM_CAR (ras);
+ SCM e1 = SCM_UNDEFINED;
+ long n = SCM_ARRAY_DIMS (ra0)->ubnd - SCM_ARRAY_DIMS (ra0)->lbnd + 1;
+ scm_sizet i0 = SCM_ARRAY_BASE (ra0), i1 = SCM_ARRAY_BASE (ra1);
+ long inc0 = SCM_ARRAY_DIMS (ra0)->inc, inc1 = SCM_ARRAY_DIMS (ra1)->inc;
+ ra0 = SCM_ARRAY_V (ra0);
+ ra1 = SCM_ARRAY_V (ra1);
+ ras = SCM_CDR (ras);
+ if SCM_NULLP
+ (ras)
+ {
+ if (scm_tc7_vector == SCM_TYP7 (ra0))
+ for (; n-- > 0; i0 += inc0, i1 += inc1)
+ scm_array_set_x (ra0, SCM_SUBRF (proc) (scm_cvref (ra1, i1, SCM_UNDEFINED), SCM_UNDEFINED),
+ SCM_MAKINUM (i0));
+ else
+ for (; n-- > 0; i0 += inc0, i1 += inc1)
+ scm_array_set_x (ra0, SCM_SUBRF (proc) (RVREF (ra1, i1, e1), SCM_UNDEFINED),
+ SCM_MAKINUM (i0));
+ }
+ else
+ {
+ SCM ra2 = SCM_CAR (ras);
+ SCM e2 = SCM_UNDEFINED;
+ scm_sizet i2 = SCM_ARRAY_BASE (ra2);
+ long inc2 = SCM_ARRAY_DIMS (ra2)->inc;
+ ra2 = SCM_ARRAY_V (ra2);
+ if (scm_tc7_vector == SCM_TYP7 (ra0))
+ for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
+ scm_array_set_x (ra0,
+ SCM_SUBRF (proc) (scm_cvref (ra1, i1, SCM_UNDEFINED), scm_cvref (ra2, i2, SCM_UNDEFINED)),
+ SCM_MAKINUM (i0));
+ else
+ for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
+ scm_array_set_x (ra0,
+ SCM_SUBRF (proc) (RVREF (ra1, i1, e1), RVREF (ra2, i2, e2)),
+ SCM_MAKINUM (i0));
+ }
+ return 1;
+}
+
+
+#ifdef __STDC__
+static int
+ramap_a (SCM ra0, SCM proc, SCM ras)
+#else
+static int
+ramap_a (ra0, proc, ras)
+ SCM ra0;
+ SCM proc;
+ SCM ras;
+#endif
+{
+ SCM e0 = SCM_UNDEFINED, e1 = SCM_UNDEFINED;
+ long n = SCM_ARRAY_DIMS (ra0)->ubnd - SCM_ARRAY_DIMS (ra0)->lbnd + 1;
+ scm_sizet i0 = SCM_ARRAY_BASE (ra0);
+ long inc0 = SCM_ARRAY_DIMS (ra0)->inc;
+ ra0 = SCM_ARRAY_V (ra0);
+ if SCM_NULLP
+ (ras)
+ for (; n-- > 0; i0 += inc0)
+ scm_array_set_x (ra0, SCM_SUBRF (proc) (RVREF (ra0, i0, e0), SCM_UNDEFINED), SCM_MAKINUM (i0));
+ else
+ {
+ SCM ra1 = SCM_CAR (ras);
+ scm_sizet i1 = SCM_ARRAY_BASE (ra1);
+ long inc1 = SCM_ARRAY_DIMS (ra1)->inc;
+ ra1 = SCM_ARRAY_V (ra1);
+ for (; n-- > 0; i0 += inc0, i1 += inc1)
+ scm_array_set_x (ra0, SCM_SUBRF (proc) (RVREF (ra0, i0, e0), RVREF (ra1, i1, e1)),
+ SCM_MAKINUM (i0));
+ }
+ return 1;
+}
+
+SCM_PROC(s_serial_array_map, "serial-array-map", 2, 0, 1, scm_array_map);
+SCM_PROC(s_array_map, "array-map", 2, 0, 1, scm_array_map);
+#ifdef __STDC__
+SCM
+scm_array_map (SCM ra0, SCM proc, SCM lra)
+#else
+SCM
+scm_array_map (ra0, proc, lra)
+ SCM ra0;
+ SCM proc;
+ SCM lra;
+#endif
+{
+ SCM_ASSERT (SCM_BOOL_T == scm_procedure_p (proc), proc, SCM_ARG2, s_array_map);
+ switch (SCM_TYP7 (proc))
+ {
+ default:
+ gencase:
+ scm_ramapc (ramap, proc, ra0, lra, s_array_map);
+ return SCM_UNSPECIFIED;
+ case scm_tc7_subr_1:
+ scm_ramapc (ramap_1, proc, ra0, lra, s_array_map);
+ return SCM_UNSPECIFIED;
+ case scm_tc7_subr_2:
+ case scm_tc7_subr_2o:
+ scm_ramapc (ramap_2o, proc, ra0, lra, s_array_map);
+ return SCM_UNSPECIFIED;
+ case scm_tc7_cxr:
+ if (!SCM_SUBRF (proc))
+ goto gencase;
+ scm_ramapc (ramap_cxr, proc, ra0, lra, s_array_map);
+ return SCM_UNSPECIFIED;
+ case scm_tc7_rpsubr:
+ {
+ ra_iproc *p;
+ if (SCM_FALSEP (scm_array_p (ra0, SCM_BOOL_T)))
+ goto gencase;
+ scm_array_fill_x (ra0, SCM_BOOL_T);
+ for (p = ra_rpsubrs; p->name; p++)
+ if (proc == p->sproc)
+ {
+ while (SCM_NNULLP (lra) && SCM_NNULLP (SCM_CDR (lra)))
+ {
+ scm_ramapc (p->vproc, SCM_UNDEFINED, ra0, lra, s_array_map);
+ lra = SCM_CDR (lra);
+ }
+ return SCM_UNSPECIFIED;
+ }
+ while (SCM_NNULLP (lra) && SCM_NNULLP (SCM_CDR (lra)))
+ {
+ scm_ramapc (ramap_rp, proc, ra0, lra, s_array_map);
+ lra = SCM_CDR (lra);
+ }
+ return SCM_UNSPECIFIED;
+ }
+ case scm_tc7_asubr:
+ if SCM_NULLP
+ (lra)
+ {
+ SCM prot, fill = SCM_SUBRF (proc) (SCM_UNDEFINED, SCM_UNDEFINED);
+ if SCM_INUMP
+ (fill)
+ {
+ prot = scm_array_prototype (ra0);
+ if (SCM_NIMP (prot) && SCM_INEXP (prot))
+ fill = scm_makdbl ((double) SCM_INUM (fill), 0.0);
+ }
+
+ scm_array_fill_x (ra0, fill);
+ }
+ else
+ {
+ SCM tail, ra1 = SCM_CAR (lra);
+ SCM v0 = (SCM_NIMP (ra0) && SCM_ARRAYP (ra0) ? SCM_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 || (SCM_NIMP (ra1) && SCM_ARRAYP (ra1) && v0 == SCM_ARRAY_V (ra1)))
+ if (ra0 != ra1 || (SCM_ARRAYP(ra0) && !SCM_ARRAY_CONTP(ra0)))
+ goto gencase;
+ for (tail = SCM_CDR (lra); SCM_NNULLP (tail); tail = SCM_CDR (tail))
+ {
+ ra1 = SCM_CAR (tail);
+ if (v0 == ra1 || (SCM_NIMP (ra1) && SCM_ARRAYP (ra1) && v0 == SCM_ARRAY_V (ra1)))
+ goto gencase;
+ }
+ for (p = ra_asubrs; p->name; p++)
+ if (proc == p->sproc)
+ {
+ if (ra0 != SCM_CAR (lra))
+ scm_ramapc (scm_array_identity, SCM_UNDEFINED, ra0, scm_cons (SCM_CAR (lra), SCM_EOL), s_array_map);
+ lra = SCM_CDR (lra);
+ while (1)
+ {
+ scm_ramapc (p->vproc, SCM_UNDEFINED, ra0, lra, s_array_map);
+ if (SCM_IMP (lra) || SCM_IMP (SCM_CDR (lra)))
+ return SCM_UNSPECIFIED;
+ lra = SCM_CDR (lra);
+ }
+ }
+ scm_ramapc (ramap_2o, proc, ra0, lra, s_array_map);
+ lra = SCM_CDR (lra);
+ if SCM_NIMP
+ (lra)
+ for (lra = SCM_CDR (lra); SCM_NIMP (lra); lra = SCM_CDR (lra))
+ scm_ramapc (ramap_a, proc, ra0, lra, s_array_map);
+ }
+ return SCM_UNSPECIFIED;
+ }
+}
+
+#ifdef __STDC__
+static int
+rafe (SCM ra0, SCM proc, SCM ras)
+#else
+static int
+rafe (ra0, proc, ras)
+ SCM ra0;
+ SCM proc;
+ SCM ras;
+#endif
+{
+ long i = SCM_ARRAY_DIMS (ra0)->lbnd;
+ scm_sizet i0 = SCM_ARRAY_BASE (ra0);
+ long inc0 = SCM_ARRAY_DIMS (ra0)->inc;
+ long n = SCM_ARRAY_DIMS (ra0)->ubnd;
+ ra0 = SCM_ARRAY_V (ra0);
+ if SCM_NULLP
+ (ras)
+ for (; i <= n; i++, i0 += inc0)
+ scm_apply (proc, scm_cvref (ra0, i0, SCM_UNDEFINED), scm_listofnull);
+ else
+ {
+ SCM ra1 = SCM_CAR (ras);
+ SCM args, *ve = &ras;
+ scm_sizet k, i1 = SCM_ARRAY_BASE (ra1);
+ long inc1 = SCM_ARRAY_DIMS (ra1)->inc;
+ ra1 = SCM_ARRAY_V (ra1);
+ ras = SCM_CDR (ras);
+ if SCM_NULLP
+ (ras)
+ ras = scm_nullvect;
+ else
+ {
+ ras = scm_vector (ras);
+ ve = SCM_VELTS (ras);
+ }
+ for (; i <= n; i++, i0 += inc0, i1 += inc1)
+ {
+ args = SCM_EOL;
+ for (k = SCM_LENGTH (ras); k--;)
+ args = scm_cons (scm_uniform_vector_ref (ve[k], SCM_MAKINUM (i)), args);
+ args = scm_cons2 (scm_cvref (ra0, i0, SCM_UNDEFINED), scm_cvref (ra1, i1, SCM_UNDEFINED), args);
+ scm_apply (proc, args, SCM_EOL);
+ }
+ }
+ return 1;
+}
+
+
+SCM_PROC(s_array_for_each, "array-for-each", 2, 0, 1, scm_array_for_each);
+#ifdef __STDC__
+SCM
+scm_array_for_each (SCM proc, SCM ra0, SCM lra)
+#else
+SCM
+scm_array_for_each (proc, ra0, lra)
+ SCM proc;
+ SCM ra0;
+ SCM lra;
+#endif
+{
+ SCM_ASSERT (SCM_BOOL_T == scm_procedure_p (proc), proc, SCM_ARG1, s_array_for_each);
+ scm_ramapc (rafe, proc, ra0, lra, s_array_for_each);
+ return SCM_UNSPECIFIED;
+}
+
+SCM_PROC(s_array_index_map_x, "array-index-map!", 2, 0, 0, scm_array_index_map_x);
+#ifdef __STDC__
+SCM
+scm_array_index_map_x (SCM ra, SCM proc)
+#else
+SCM
+scm_array_index_map_x (ra, proc)
+ SCM ra;
+ SCM proc;
+#endif
+{
+ scm_sizet i;
+ SCM_ASSERT (SCM_NIMP (ra), ra, SCM_ARG1, s_array_index_map_x);
+ SCM_ASSERT (SCM_BOOL_T == scm_procedure_p (proc), proc, SCM_ARG2, s_array_index_map_x);
+ switch SCM_TYP7
+ (ra)
+ {
+ default:
+ badarg:scm_wta (ra, (char *) SCM_ARG1, s_array_index_map_x);
+ case scm_tc7_vector:
+ {
+ SCM *ve = SCM_VELTS (ra);
+ for (i = 0; i < SCM_LENGTH (ra); i++)
+ ve[i] = scm_apply (proc, SCM_MAKINUM (i), scm_listofnull);
+ return SCM_UNSPECIFIED;
+ }
+ case scm_tc7_string:
+ case scm_tc7_bvect:
+ case scm_tc7_uvect:
+ case scm_tc7_ivect:
+ case scm_tc7_fvect:
+ case scm_tc7_dvect:
+ case scm_tc7_cvect:
+ for (i = 0; i < SCM_LENGTH (ra); i++)
+ scm_array_set_x (ra, scm_apply (proc, SCM_MAKINUM (i), scm_listofnull), SCM_MAKINUM (i));
+ return SCM_UNSPECIFIED;
+ case scm_tc7_smob:
+ SCM_ASRTGO (SCM_ARRAYP (ra), badarg);
+ {
+ SCM args = SCM_EOL;
+ SCM inds = scm_make_uve (SCM_ARRAY_NDIM (ra), SCM_MAKINUM (-1L));
+ long *vinds = SCM_VELTS (inds);
+ int j, k, kmax = SCM_ARRAY_NDIM (ra) - 1;
+ for (k = 0; k <= kmax; k++)
+ vinds[k] = SCM_ARRAY_DIMS (ra)[k].lbnd;
+ k = kmax;
+ do
+ {
+ if (k == kmax)
+ {
+ vinds[k] = SCM_ARRAY_DIMS (ra)[k].lbnd;
+ i = cind (ra, inds);
+ for (; vinds[k] <= SCM_ARRAY_DIMS (ra)[k].ubnd; vinds[k]++)
+ {
+ for (j = kmax + 1, args = SCM_EOL; j--;)
+ args = scm_cons (SCM_MAKINUM (vinds[j]), args);
+ scm_array_set_x (SCM_ARRAY_V (ra), scm_apply (proc, args, SCM_EOL), SCM_MAKINUM (i));
+ i += SCM_ARRAY_DIMS (ra)[k].inc;
+ }
+ k--;
+ continue;
+ }
+ if (vinds[k] < SCM_ARRAY_DIMS (ra)[k].ubnd)
+ {
+ vinds[k]++;
+ k++;
+ continue;
+ }
+ vinds[k] = SCM_ARRAY_DIMS (ra)[k].lbnd - 1;
+ k--;
+ }
+ while (k >= 0);
+ return SCM_UNSPECIFIED;
+ }
+ }
+}
+
+#ifdef __STDC__
+static int
+raeql_1 (SCM ra0, SCM as_equal, SCM ra1)
+#else
+static int
+raeql_1 (ra0, as_equal, ra1)
+ SCM ra0;
+ SCM as_equal;
+ SCM ra1;
+#endif
+{
+ SCM e0 = SCM_UNDEFINED, e1 = SCM_UNDEFINED;
+ scm_sizet i0 = 0, i1 = 0;
+ long inc0 = 1, inc1 = 1;
+ scm_sizet n = SCM_LENGTH (ra0);
+ ra1 = SCM_CAR (ra1);
+ if SCM_ARRAYP
+ (ra0)
+ {
+ n = SCM_ARRAY_DIMS (ra0)->ubnd - SCM_ARRAY_DIMS (ra0)->lbnd + 1;
+ i0 = SCM_ARRAY_BASE (ra0);
+ inc0 = SCM_ARRAY_DIMS (ra0)->inc;
+ ra0 = SCM_ARRAY_V (ra0);
+ }
+ if SCM_ARRAYP
+ (ra1)
+ {
+ i1 = SCM_ARRAY_BASE (ra1);
+ inc1 = SCM_ARRAY_DIMS (ra1)->inc;
+ ra1 = SCM_ARRAY_V (ra1);
+ }
+ switch SCM_TYP7
+ (ra0)
+ {
+ case scm_tc7_vector:
+ default:
+ for (; n--; i0 += inc0, i1 += inc1)
+ {
+ if SCM_FALSEP
+ (as_equal)
+ {
+ if SCM_FALSEP
+ (scm_array_equal_p (RVREF (ra0, i0, e0), RVREF (ra1, i1, e1)))
+ return 0;
+ }
+ else if SCM_FALSEP
+ (scm_equal_p (RVREF (ra0, i0, e0), RVREF (ra1, i1, e1)))
+ return 0;
+ }
+ return 1;
+ case scm_tc7_string:
+ {
+ char *v0 = SCM_CHARS (ra0) + i0;
+ char *v1 = SCM_CHARS (ra1) + i1;
+ for (; n--; v0 += inc0, v1 += inc1)
+ if (*v0 != *v1)
+ return 0;
+ return 1;
+ }
+ case scm_tc7_bvect:
+ for (; n--; i0 += inc0, i1 += inc1)
+ if (BVE_REF (ra0, i0) != BVE_REF (ra1, i1))
+ return 0;
+ return 1;
+ case scm_tc7_uvect:
+ case scm_tc7_ivect:
+ {
+ long *v0 = (long *) SCM_VELTS (ra0) + i0;
+ long *v1 = (long *) SCM_VELTS (ra1) + i1;
+ for (; n--; v0 += inc0, v1 += inc1)
+ if (*v0 != *v1)
+ return 0;
+ return 1;
+ }
+#ifdef SCM_FLOATS
+#ifdef SCM_SINGLES
+ case scm_tc7_fvect:
+ {
+ float *v0 = (float *) SCM_VELTS (ra0) + i0;
+ float *v1 = (float *) SCM_VELTS (ra1) + i1;
+ for (; n--; v0 += inc0, v1 += inc1)
+ if (*v0 != *v1)
+ return 0;
+ return 1;
+ }
+#endif /* SCM_SINGLES */
+ case scm_tc7_dvect:
+ {
+ double *v0 = (double *) SCM_VELTS (ra0) + i0;
+ double *v1 = (double *) SCM_VELTS (ra1) + i1;
+ for (; n--; v0 += inc0, v1 += inc1)
+ if (*v0 != *v1)
+ return 0;
+ return 1;
+ }
+ case scm_tc7_cvect:
+ {
+ double (*v0)[2] = (double (*)[2]) SCM_VELTS (ra0) + i0;
+ double (*v1)[2] = (double (*)[2]) SCM_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 /* SCM_FLOATS */
+ }
+}
+
+
+#ifdef __STDC__
+static int
+raeql (SCM ra0, SCM as_equal, SCM ra1)
+#else
+static int
+raeql (ra0, as_equal, ra1)
+ SCM ra0;
+ SCM as_equal;
+ SCM ra1;
+#endif
+{
+ SCM v0 = ra0, v1 = ra1;
+ scm_array_dim dim0, dim1;
+ scm_array_dim *s0 = &dim0, *s1 = &dim1;
+ scm_sizet bas0 = 0, bas1 = 0;
+ int k, unroll = 1, vlen = 1, ndim = 1;
+ if SCM_ARRAYP
+ (ra0)
+ {
+ ndim = SCM_ARRAY_NDIM (ra0);
+ s0 = SCM_ARRAY_DIMS (ra0);
+ bas0 = SCM_ARRAY_BASE (ra0);
+ v0 = SCM_ARRAY_V (ra0);
+ }
+ else
+ {
+ s0->inc = 1;
+ s0->lbnd = 0;
+ s0->ubnd = SCM_LENGTH (v0) - 1;
+ unroll = 0;
+ }
+ if SCM_ARRAYP
+ (ra1)
+ {
+ if (ndim != SCM_ARRAY_NDIM (ra1))
+ return 0;
+ s1 = SCM_ARRAY_DIMS (ra1);
+ bas1 = SCM_ARRAY_BASE (ra1);
+ v1 = SCM_ARRAY_V (ra1);
+ }
+ else
+ {
+ if (1 != ndim)
+ return SCM_BOOL_F;
+ s1->inc = 1;
+ s1->lbnd = 0;
+ s1->ubnd = SCM_LENGTH (v1) - 1;
+ unroll = 0;
+ }
+ if (SCM_TYP7 (v0) != SCM_TYP7 (v1))
+ return 0;
+ 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);
+ vlen *= s0[k].ubnd - s1[k].lbnd + 1;
+ }
+ }
+ if (unroll && bas0 == bas1 && v0 == v1)
+ return SCM_BOOL_T;
+ return scm_ramapc (raeql_1, as_equal, ra0, scm_cons (ra1, SCM_EOL), "");
+}
+
+#ifdef __STDC__
+SCM
+scm_raequal (SCM ra0, SCM ra1)
+#else
+SCM
+scm_raequal (ra0, ra1)
+ SCM ra0;
+ SCM ra1;
+#endif
+{
+ return (raeql (ra0, SCM_BOOL_T, ra1) ? SCM_BOOL_T : SCM_BOOL_F);
+}
+
+static char s_array_equal_p[] = "array-equal?";
+
+#ifdef __STDC__
+SCM
+scm_array_equal_p (SCM ra0, SCM ra1)
+#else
+SCM
+scm_array_equal_p (ra0, ra1)
+ SCM ra0;
+ SCM ra1;
+#endif
+{
+ if (SCM_IMP (ra0) || SCM_IMP (ra1))
+ callequal:return scm_equal_p (ra0, ra1);
+ switch SCM_TYP7
+ (ra0)
+ {
+ default:
+ goto callequal;
+ case scm_tc7_bvect:
+ case scm_tc7_string:
+ case scm_tc7_uvect:
+ case scm_tc7_ivect:
+ case scm_tc7_fvect:
+ case scm_tc7_dvect:
+ case scm_tc7_cvect:
+ case scm_tc7_vector:
+ break;
+ case scm_tc7_smob:
+ if (!SCM_ARRAYP (ra0))
+ goto callequal;
+ }
+ switch SCM_TYP7
+ (ra1)
+ {
+ default:
+ goto callequal;
+ case scm_tc7_bvect:
+ case scm_tc7_string:
+ case scm_tc7_uvect:
+ case scm_tc7_ivect:
+ case scm_tc7_fvect:
+ case scm_tc7_dvect:
+ case scm_tc7_cvect:
+ case scm_tc7_vector:
+ break;
+ case scm_tc7_smob:
+ if (!SCM_ARRAYP (ra1))
+ goto callequal;
+ }
+ return (raeql (ra0, SCM_BOOL_F, ra1) ? SCM_BOOL_T : SCM_BOOL_F);
+}
+
+
+
+
+/* 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 SCM_CAR of all subrs (like those selected by SCM_SMOBNUM) to hold an
+ * offset into a table of vectorized subrs.
+ */
+
+static ra_iproc ra_rpsubrs[] =
+{
+ {"=", SCM_UNDEFINED, scm_ra_eqp},
+ {"<", SCM_UNDEFINED, scm_ra_lessp},
+ {"<=", SCM_UNDEFINED, scm_ra_leqp},
+ {">", SCM_UNDEFINED, scm_ra_grp},
+ {">=", SCM_UNDEFINED, scm_ra_greqp},
+ {0, 0, 0}
+};
+
+static ra_iproc ra_asubrs[] =
+{
+ {"+", SCM_UNDEFINED, scm_ra_sum},
+ {"-", SCM_UNDEFINED, scm_ra_difference},
+ {"*", SCM_UNDEFINED, scm_ra_product},
+ {"/", SCM_UNDEFINED, scm_ra_divide},
+ {0, 0, 0}
+};
+
+static void init_raprocs (subra)
+ ra_iproc *subra;
+{
+ for (; subra->name; subra++)
+ subra->sproc = SCM_CDR (scm_intern (subra->name, strlen (subra->name)));
+}
+
+#ifdef __STDC__
+void
+scm_init_ramap (void)
+#else
+void
+scm_init_ramap ()
+#endif
+{
+ init_raprocs (ra_rpsubrs);
+ init_raprocs (ra_asubrs);
+ scm_make_subr (s_array_equal_p, scm_tc7_rpsubr, scm_array_equal_p);
+ scm_smobs[0x0ff & (scm_tc16_array >> 8)].equalp = scm_raequal;
+#include "ramap.x"
+ scm_add_feature (s_array_for_each);
+}
+
+#endif /* ARRAYS */