mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-06 15:40:29 +02:00
Code Activity
guile/libguile/ramap.c
Gary Houston afe5177e7f * acconfig.h: add HAVE_ARRAYS. 
* configure.in: add --disable-arrays option, probably temporary.

	* the following changes allow guile to be built with the array
	"module" omitted.  some of this stuff is just tc7 type support,
	which wouldn't be needed if uniform array types were converted
	to smobs.

	* tag.c (scm_utag_bvect ... scm_utag_cvect): don't define unless
	HAVE_ARRAYS.
	(scm_tag): don't check array types unless HAVE_ARRAYS.

	* sort.c (scm_restricted_vector_sort_x, scm_sorted_p):
	remove the unused array types.
	* (scm_stable_sort, scm_sort): don't support vectors if not
	HAVE_ARRAYS.  a bit excessive.

	* random.c (vector_scale, vector_sum_squares,
	scm_random_solid_sphere_x, scm_random_hollow_sphere_x,
	scm_random_normal_vector_x): don't define unless HAVE_ARRAYS.

	* gh_data.c (makvect, gh_chars2byvect, gh_shorts2svect,
	gh_longs2ivect,	gh_ulongs2uvect, gh_floats2fvect, gh_doubles2dvect,
	gh_uniform_vector_length, gh_uniform_vector_ref):
	don't define unless HAVE_ARRAYS.
	(gh_scm2chars, gh_scm2shorts, gh_scm2longs, gh_scm2floats,
	gh_scm2doubles):
	don't check vector types if not HAVE_ARRAYS.

	* eq.c (scm_equal_p), eval.c (SCM_CEVAL), print.c (scm_iprin1),
	gc.c (scm_gc_mark, scm_gc_sweep), objects.c (scm_class_of):
	don't support the array types unless HAVE_ARRAYS is defined.

	* tags.h: make nine tc7 types conditional on HAVE_ARRAYS.

	* read.c (scm_lreadr): don't check for #* unless HAVE_ARRAYS is
	defined (this should use read-hash-extend).

	* ramap.c, unif.c: don't check whether ARRAYS is defined.

	* vectors.c (scm_vector_set_length_x): moved here from unif.c.  call
	scm_uniform_element_size if HAVE_ARRAYS.
	vectors.h: prototype too.

	* unif.c (scm_uniform_element_size): new procedure.

	* init.c (scm_boot_guile_1): don't call scm_init_ramap or
	scm_init_unif unless HAVE_ARRAYS is defined.

	* __scm.h: don't define ARRAYS.

	* Makefile.am (EXTRA_libguile_la_SOURCES): unif.c and ramap.c
	moved here from	libguile_la_SOURCES.


	* Makefile.am (ice9_sources): add arrays.scm.

	* boot-9.scm: load arrays.scm if 'array is provided.

	* arrays.scm: new file with stuff from boot-9.scm.
1999-11-19 18:16:19 +00:00

2174 lines
55 KiB
C
Raw Blame History

This file contains invisible Unicode characters

This file contains invisible Unicode characters that are indistinguishable to humans but may be processed differently by a computer. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.

/* 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. */
#include <stdio.h>
#include "_scm.h"
#include "unif.h"
#include "smob.h"
#include "chars.h"
#include "eq.h"
#include "eval.h"
#include "feature.h"
#include "ramap.h"
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_P ((SCM ra, SCM inds));
static scm_sizet
cind (ra, inds)
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 (ra0, ras)
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
scm_ramapc (cproc, data, ra0, lra, what)
int (*cproc) (); /* procedure to call on normalised 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. */
{
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_PROC(s_array_fill_x, "array-fill!", 2, 0, 0, scm_array_fill_x);
SCM
scm_array_fill_x (ra, fill)
SCM ra;
SCM fill;
{
scm_ramapc (scm_array_fill_int, fill, ra, SCM_EOL, s_array_fill_x);
return SCM_UNSPECIFIED;
}
/* to be used as cproc in scm_ramapc to fill an array dimension with
"fill". */
int
scm_array_fill_int (ra, fill, ignore)
SCM ra;
SCM fill;
SCM ignore;
{
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:
{
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:
{
unsigned long f = scm_num2ulong (fill, (char *) SCM_ARG2,
s_array_fill_x);
unsigned long *ve = (long *) SCM_VELTS (ra);
for (i = base; n--; i += inc)
ve[i] = f;
break;
}
case scm_tc7_ivect:
{
long f = scm_num2long (fill, (char *) SCM_ARG2, s_array_fill_x);
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);
{
short f = SCM_INUM (fill);
short *ve = (short *) SCM_VELTS (ra);
if (f != SCM_INUM (fill))
scm_out_of_range (s_array_fill_x, fill);
for (i = base; n--; i += inc)
ve[i] = f;
break;
}
#ifdef HAVE_LONG_LONGS
case scm_tc7_llvect:
{
long long f = scm_num2long_long (fill, (char *) SCM_ARG2,
s_array_fill_x);
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:
{
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;
}
static int racp SCM_P ((SCM dst, SCM src));
static int
racp (src, dst)
SCM dst;
SCM src;
{
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_PROC(s_serial_array_copy_x, "serial-array-copy!", 2, 0, 0, scm_array_copy_x);
SCM_PROC(s_array_copy_in_order_x, "array-copy-in-order!", 2, 0, 0, scm_array_copy_x);
SCM_PROC(s_array_copy_x, "array-copy!", 2, 0, 0, scm_array_copy_x);
SCM
scm_array_copy_x (src, dst)
SCM src;
SCM dst;
{
scm_ramapc (racp, SCM_UNDEFINED, src, scm_cons (dst, SCM_EOL), s_array_copy_x);
return SCM_UNSPECIFIED;
}
/* Functions callable by ARRAY-MAP! */
int
scm_ra_eqp (ra0, ras)
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_P ((SCM ra0, SCM ra1, SCM ra2, int opt));
static int
ra_compare (ra0, ra1, ra2, opt)
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 (ra0, ras)
SCM ra0;
SCM ras;
{
return ra_compare (ra0, SCM_CAR (ras), SCM_CAR (SCM_CDR (ras)), 0);
}
int
scm_ra_leqp (ra0, ras)
SCM ra0;
SCM ras;
{
return ra_compare (ra0, SCM_CAR (SCM_CDR (ras)), SCM_CAR (ras), 1);
}
int
scm_ra_grp (ra0, ras)
SCM ra0;
SCM ras;
{
return ra_compare (ra0, SCM_CAR (SCM_CDR (ras)), SCM_CAR (ras), 0);
}
int
scm_ra_greqp (ra0, ras)
SCM ra0;
SCM ras;
{
return ra_compare (ra0, SCM_CAR (ras), SCM_CAR (SCM_CDR (ras)), 1);
}
int
scm_ra_sum (ra0, ras)
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 (ra0, ras)
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 (ra0, ras)
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 (ra0, ras)
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 (dst, src)
SCM src;
SCM dst;
{
return racp (SCM_CAR (src), scm_cons (dst, SCM_EOL));
}
static int ramap SCM_P ((SCM ra0, SCM proc, SCM ras));
static int
ramap (ra0, proc, ras)
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_P ((SCM ra0, SCM proc, SCM ras));
static int
ramap_cxr (ra0, proc, ras)
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_P ((SCM ra0, SCM proc, SCM ras));
static int
ramap_rp (ra0, proc, ras)
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_P ((SCM ra0, SCM proc, SCM ras));
static int
ramap_1 (ra0, proc, ras)
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_P ((SCM ra0, SCM proc, SCM ras));
static int
ramap_2o (ra0, proc, ras)
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_P ((SCM ra0, SCM proc, SCM ras));
static int
ramap_a (ra0, proc, ras)
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_PROC(s_serial_array_map_x, "serial-array-map!", 2, 0, 1, scm_array_map_x);
SCM_PROC(s_array_map_in_order_x, "array-map-in-order!", 2, 0, 1, scm_array_map_x);
SCM_PROC(s_array_map_x, "array-map!", 2, 0, 1, scm_array_map_x);
SCM
scm_array_map_x (ra0, proc, lra)
SCM ra0;
SCM proc;
SCM lra;
{
SCM_ASSERT (SCM_BOOL_T == scm_procedure_p (proc), proc, SCM_ARG2, s_array_map_x);
switch (SCM_TYP7 (proc))
{
default:
gencase:
scm_ramapc (ramap, proc, ra0, lra, s_array_map_x);
return SCM_UNSPECIFIED;
case scm_tc7_subr_1:
scm_ramapc (ramap_1, proc, ra0, lra, s_array_map_x);
return SCM_UNSPECIFIED;
case scm_tc7_subr_2:
case scm_tc7_subr_2o:
scm_ramapc (ramap_2o, proc, ra0, lra, s_array_map_x);
return SCM_UNSPECIFIED;
case scm_tc7_cxr:
if (!SCM_SUBRF (proc))
goto gencase;
scm_ramapc (ramap_cxr, proc, ra0, lra, s_array_map_x);
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_x);
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_x);
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_x);
lra = SCM_CDR (lra);
while (1)
{
scm_ramapc (p->vproc, SCM_UNDEFINED, ra0, lra, s_array_map_x);
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_x);
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_x);
}
return SCM_UNSPECIFIED;
}
}
static int rafe SCM_P ((SCM ra0, SCM proc, SCM ras));
static int
rafe (ra0, proc, ras)
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_PROC(s_array_for_each, "array-for-each", 2, 0, 1, scm_array_for_each);
SCM
scm_array_for_each (proc, ra0, lra)
SCM proc;
SCM ra0;
SCM lra;
{
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);
SCM
scm_array_index_map_x (ra, proc)
SCM ra;
SCM proc;
{
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:
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;
}
}
}
static int raeql_1 SCM_P ((SCM ra0, SCM as_equal, SCM ra1));
static int
raeql_1 (ra0, as_equal, ra1)
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_P ((SCM ra0, SCM as_equal, SCM ra1));
static int
raeql (ra0, as_equal, ra1)
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 (ra0, ra1)
SCM ra0;
SCM ra1;
{
return (raeql (ra0, SCM_BOOL_T, ra1) ? SCM_BOOL_T : SCM_BOOL_F);
}
static char s_array_equal_p[] = "array-equal?";
SCM
scm_array_equal_p (ra0, ra1)
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 (raeql (ra0, SCM_BOOL_F, ra1) ? SCM_BOOL_T : SCM_BOOL_F);
}
static void
init_raprocs (subra)
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_array_for_each);
}
View git blame Copy permalink