/* Copyright (C) 1996, 1998 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, Inc., 59 Temple Place, Suite 330, * Boston, MA 02111-1307 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. */ /* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ #include #include "_scm.h" #include "unif.h" #include "smob.h" #include "chars.h" #include "eq.h" #include "eval.h" #include "feature.h" #include "scm_validate.h" #include "ramap.h" #define SCM_RAMAPC(ramap,proc,ra0,lra) do { scm_ramapc (ramap, proc, ra0, lra, FUNC_NAME); } while (0) typedef struct { char *name; SCM sproc; int (*vproc) (); } ra_iproc; /* 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} }; #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. */ static scm_sizet cind (SCM ra, SCM inds) { 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. */ int scm_ra_matchp (SCM ra0, SCM ras) { 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_wvect: case scm_tc7_string: case scm_tc7_byvect: case scm_tc7_bvect: case scm_tc7_uvect: case scm_tc7_ivect: case scm_tc7_svect: #ifdef HAVE_LONG_LONGS case scm_tc7_llvect: #endif 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_wvect: case scm_tc7_string: case scm_tc7_byvect: case scm_tc7_bvect: case scm_tc7_uvect: case scm_tc7_ivect: case scm_tc7_svect: #ifdef HAVE_LONG_LONGS case scm_tc7_llvect: #endif 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; } /* array mapper: apply cproc to each dimension of the given arrays?. int (*cproc) (); procedure to call on unrolled arrays? cproc (dest, source list) or cproc (dest, data, source list). SCM data; data to give to cproc or unbound. SCM ra0; destination array. SCM lra; list of source arrays. const char *what; caller, for error reporting. */ int scm_ramapc (int (*cproc)(), SCM data, SCM ra0, SCM lra, const char *what) { 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, "array shape 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_CDRLOC (*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_CDRLOC (*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; } } SCM_DEFINE (scm_array_fill_x, "array-fill!", 2, 0, 0, (SCM ra, SCM fill), "Stores @var{fill} in every element of @var{array}. The value returned\n" "is unspecified.") #define FUNC_NAME s_scm_array_fill_x { SCM_RAMAPC (scm_array_fill_int, fill, ra, SCM_EOL); return SCM_UNSPECIFIED; } #undef FUNC_NAME /* to be used as cproc in scm_ramapc to fill an array dimension with "fill". */ int scm_array_fill_int (SCM ra, SCM fill, SCM ignore) #define FUNC_NAME s_scm_array_fill_x { scm_sizet i; scm_sizet 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: case scm_tc7_wvect: 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_byvect: if (SCM_ICHRP (fill)) fill = SCM_MAKINUM ((char) SCM_ICHR (fill)); SCM_ASRTGO (SCM_INUMP (fill) && -128 <= SCM_INUM (fill) && SCM_INUM (fill) < 128, badarg2); for (i = base; n--; i += inc) SCM_CHARS (ra)[i] = SCM_INUM (fill); break; case scm_tc7_bvect: { /* scope */ 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 (2,fill); } 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: { /* scope */ unsigned long f = SCM_NUM2ULONG (2,fill); unsigned long *ve = (long *) SCM_VELTS (ra); for (i = base; n--; i += inc) ve[i] = f; break; } case scm_tc7_ivect: { /* scope */ long f = SCM_NUM2LONG (2,fill); long *ve = (long *) SCM_VELTS (ra); for (i = base; n--; i += inc) ve[i] = f; break; } case scm_tc7_svect: SCM_ASRTGO (SCM_INUMP (fill), badarg2); { /* scope */ short f = SCM_INUM (fill); short *ve = (short *) SCM_VELTS (ra); if (f != SCM_INUM (fill)) SCM_OUT_OF_RANGE (2, fill); for (i = base; n--; i += inc) ve[i] = f; break; } #ifdef HAVE_LONG_LONGS case scm_tc7_llvect: { /* scope */ long long f = SCM_NUM2LONG_LONG (2,fill); long long *ve = (long long *) SCM_VELTS (ra); for (i = base; n--; i += inc) ve[i] = f; break; } #endif #ifdef SCM_FLOATS #ifdef SCM_SINGLES case scm_tc7_fvect: { /* scope */ float f, *ve = (float *) SCM_VELTS (ra); SCM_ASRTGO (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: { /* scope */ double f, *ve = (double *) SCM_VELTS (ra); SCM_ASRTGO (SCM_REALP (fill), badarg2); f = SCM_REALPART (fill); for (i = base; n--; i += inc) ve[i] = f; break; } case scm_tc7_cvect: { /* scope */ double fr, fi; double (*ve)[2] = (double (*)[2]) SCM_VELTS (ra); SCM_ASRTGO (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; } #undef FUNC_NAME static int racp (SCM src, SCM dst) { 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: case scm_tc7_wvect: 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: case scm_tc7_byvect: 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; } /* This name is obsolete. Will go away in release 1.5. */ SCM_REGISTER_PROC(s_serial_array_copy_x, "serial-array-copy!", 2, 0, 0, scm_array_copy_x); SCM_REGISTER_PROC(s_array_copy_in_order_x, "array-copy-in-order!", 2, 0, 0, scm_array_copy_x); SCM_DEFINE (scm_array_copy_x, "array-copy!", 2, 0, 0, (SCM src, SCM dst), "Copies every element from vector or array @var{source} to the\n" "corresponding element of @var{destination}. @var{destination} must have\n" "the same rank as @var{source}, and be at least as large in each\n" "dimension. The order is unspecified.") #define FUNC_NAME s_scm_array_copy_x { SCM_RAMAPC (racp, SCM_UNDEFINED, src, scm_cons (dst, SCM_EOL)); return SCM_UNSPECIFIED; } #undef FUNC_NAME /* Functions callable by ARRAY-MAP! */ int scm_ra_eqp (SCM ra0, SCM ras) { 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 >= */ static int ra_compare (SCM ra0,SCM ra1,SCM ra2,int opt) { 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; } int scm_ra_lessp (SCM ra0, SCM ras) { return ra_compare (ra0, SCM_CAR (ras), SCM_CAR (SCM_CDR (ras)), 0); } int scm_ra_leqp (SCM ra0, SCM ras) { return ra_compare (ra0, SCM_CAR (SCM_CDR (ras)), SCM_CAR (ras), 1); } int scm_ra_grp (SCM ra0, SCM ras) { return ra_compare (ra0, SCM_CAR (SCM_CDR (ras)), SCM_CAR (ras), 0); } int scm_ra_greqp (SCM ra0, SCM ras) { return ra_compare (ra0, SCM_CAR (ras), SCM_CAR (SCM_CDR (ras)), 1); } int scm_ra_sum (SCM ra0, SCM ras) { 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; } int scm_ra_difference (SCM ra0, SCM ras) { 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; } int scm_ra_product (SCM ra0, SCM ras) { 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; } int scm_ra_divide (SCM ra0, SCM ras) { 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; } int scm_array_identity (SCM dst, SCM src) { return racp (SCM_CAR (src), scm_cons (dst, SCM_EOL)); } static int ramap (SCM ra0,SCM proc,SCM ras) { 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; } static int ramap_cxr (SCM ra0,SCM proc,SCM ras) { 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; } static int ramap_rp (SCM ra0,SCM proc,SCM ras) { 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; } static int ramap_1 (SCM ra0,SCM proc,SCM ras) { 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) || scm_tc7_wvect == 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; } static int ramap_2o (SCM ra0,SCM proc,SCM ras) { 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) || scm_tc7_wvect == 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) || scm_tc7_wvect == 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; } static int ramap_a (SCM ra0,SCM proc,SCM ras) { 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; } /* This name is obsolete. Will go away in release 1.5. */ SCM_REGISTER_PROC(s_serial_array_map_x, "serial-array-map!", 2, 0, 1, scm_array_map_x); SCM_REGISTER_PROC(s_array_map_in_order_x, "array-map-in-order!", 2, 0, 1, scm_array_map_x); SCM_DEFINE (scm_array_map_x, "array-map!", 2, 0, 1, (SCM ra0, SCM proc, SCM lra), "@var{array1}, @dots{} must have the same number of dimensions as\n" "@var{array0} and have a range for each index which includes the range\n" "for the corresponding index in @var{array0}. @var{proc} is applied to\n" "each tuple of elements of @var{array1} @dots{} and the result is stored\n" "as the corresponding element in @var{array0}. The value returned is\n" "unspecified. The order of application is unspecified.") #define FUNC_NAME s_scm_array_map_x { SCM_VALIDATE_PROC (2,proc); switch (SCM_TYP7 (proc)) { default: gencase: SCM_RAMAPC (ramap, proc, ra0, lra); return SCM_UNSPECIFIED; case scm_tc7_subr_1: SCM_RAMAPC (ramap_1, proc, ra0, lra); return SCM_UNSPECIFIED; case scm_tc7_subr_2: case scm_tc7_subr_2o: SCM_RAMAPC (ramap_2o, proc, ra0, lra); return SCM_UNSPECIFIED; case scm_tc7_cxr: if (!SCM_SUBRF (proc)) goto gencase; SCM_RAMAPC (ramap_cxr, proc, ra0, lra); 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); lra = SCM_CDR (lra); } return SCM_UNSPECIFIED; } while (SCM_NNULLP (lra) && SCM_NNULLP (SCM_CDR (lra))) { SCM_RAMAPC (ramap_rp, proc, ra0, lra); 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_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_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_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_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)); lra = SCM_CDR (lra); while (1) { SCM_RAMAPC (p->vproc, SCM_UNDEFINED, ra0, lra); if (SCM_IMP (lra) || SCM_IMP (SCM_CDR (lra))) return SCM_UNSPECIFIED; lra = SCM_CDR (lra); } } SCM_RAMAPC (ramap_2o, proc, ra0, lra); 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); } return SCM_UNSPECIFIED; } } #undef FUNC_NAME static int rafe (SCM ra0,SCM proc,SCM ras) { 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_DEFINE (scm_array_for_each, "array-for-each", 2, 0, 1, (SCM proc, SCM ra0, SCM lra), "@var{proc} is applied to each tuple of elements of @var{array0} @dots{}\n" "in row-major order. The value returned is unspecified.") #define FUNC_NAME s_scm_array_for_each { SCM_VALIDATE_PROC (1,proc); SCM_RAMAPC (rafe, proc, ra0, lra); return SCM_UNSPECIFIED; } #undef FUNC_NAME SCM_DEFINE (scm_array_index_map_x, "array-index-map!", 2, 0, 0, (SCM ra, SCM proc), "applies @var{proc} to the indices of each element of @var{array} in\n" "turn, storing the result in the corresponding element. The value\n" "returned and the order of application are unspecified.\n\n" "One can implement @var{array-indexes} as\n" "@example\n" "(define (array-indexes array)\n" " (let ((ra (apply make-array #f (array-shape array))))\n" " (array-index-map! ra (lambda x x))\n" " ra))\n" "@end example\n" "Another example:\n" "@example\n" "(define (apl:index-generator n)\n" " (let ((v (make-uniform-vector n 1)))\n" " (array-index-map! v (lambda (i) i))\n" " v))\n" "@end example") #define FUNC_NAME s_scm_array_index_map_x { scm_sizet i; SCM_VALIDATE_NIM (1,ra); SCM_VALIDATE_PROC (2,proc); switch (SCM_TYP7(ra)) { default: badarg:SCM_WTA (1,ra); case scm_tc7_vector: case scm_tc7_wvect: { 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_byvect: case scm_tc7_bvect: case scm_tc7_uvect: case scm_tc7_ivect: case scm_tc7_svect: #ifdef HAVE_LONG_LONGS case scm_tc7_llvect: #endif 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; if (kmax < 0) return scm_array_set_x (ra, scm_apply(proc, SCM_EOL, SCM_EOL), SCM_EOL); 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; } } } #undef FUNC_NAME static int raeql_1 (SCM ra0,SCM as_equal,SCM ra1) { 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: case scm_tc7_wvect: 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: case scm_tc7_byvect: { 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; } case scm_tc7_svect: { short *v0 = (short *) SCM_VELTS (ra0) + i0; short *v1 = (short *) SCM_VELTS (ra1) + i1; for (; n--; v0 += inc0, v1 += inc1) if (*v0 != *v1) return 0; return 1; } #ifdef HAVE_LONG_LONGS case scm_tc7_llvect: { long long *v0 = (long long *) SCM_VELTS (ra0) + i0; long long *v1 = (long long *) SCM_VELTS (ra1) + i1; for (; n--; v0 += inc0, v1 += inc1) if (*v0 != *v1) return 0; return 1; } #endif #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 */ } } static int raeql (SCM ra0,SCM as_equal,SCM ra1) { 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), ""); } SCM scm_raequal (SCM ra0, SCM ra1) { return SCM_BOOL(raeql (ra0, SCM_BOOL_T, ra1)); } #if 0 /* GJB:FIXME:: Why not use SCM_DEFINE1 for array-equal? */ SCM_DEFINE1 (scm_array_equal_p, "array-equal?", scm_tc7_rpsubr, (SCM ra0, SCM ra1), "Returns @code{#t} iff all arguments are arrays with the same shape, the\n" "same type, and have corresponding elements which are either\n" "@code{equal?} or @code{array-equal?}. This function differs from\n" "@code{equal?} in that a one dimensional shared array may be\n" "@var{array-equal?} but not @var{equal?} to a vector or uniform vector.") #define FUNC_NAME s_scm_array_equal_p { } #undef FUNC_NAME #endif static char s_array_equal_p[] = "array-equal?"; SCM scm_array_equal_p (SCM ra0, SCM ra1) { 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_byvect: case scm_tc7_uvect: case scm_tc7_ivect: case scm_tc7_fvect: case scm_tc7_dvect: case scm_tc7_cvect: case scm_tc7_vector: case scm_tc7_wvect: 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_byvect: case scm_tc7_uvect: case scm_tc7_ivect: case scm_tc7_fvect: case scm_tc7_dvect: case scm_tc7_cvect: case scm_tc7_vector: case scm_tc7_wvect: break; case scm_tc7_smob: if (!SCM_ARRAYP (ra1)) goto callequal; } return SCM_BOOL(raeql (ra0, SCM_BOOL_F, ra1)); } static void init_raprocs (ra_iproc *subra) { for (; subra->name; subra++) subra->sproc = SCM_CDR (scm_intern (subra->name, strlen (subra->name))); } void scm_init_ramap () { 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_scm_array_for_each); }