-/* Copyright (C) 1996, 1998, 2000 Free Software Foundation, Inc.
+/* Copyright (C) 1996,1998,2000,2001 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
* 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 */
/*
HWN:FIXME::
\f
-#include <stdio.h>
#include "libguile/_scm.h"
#include "libguile/strings.h"
#include "libguile/unif.h"
IVDEP (ra0 != ra1, \
for (; n-- > 0; i0 += inc0, i1 += inc1) \
v0[i0] OPERATOR v1[i1];) \
- break; \
} while (0)
/* This macro is used for all but binary division and
v0[i0][0] OPERATOR v1[i1][0]; \
v0[i0][1] OPERATOR v1[i1][1]; \
}) \
- break; \
} while (0)
#define UNARY_ELTS_CODE(OPERATOR, type) \
do { type *v0 = (type *) SCM_VELTS (ra0);\
for (; n-- > 0; i0 += inc0) \
v0[i0] OPERATOR v0[i0];\
- break;\
} while (0)
break;\
} while (0)
-static scm_sizet
+static unsigned long
cind (SCM ra, SCM inds)
{
- scm_sizet i;
+ unsigned long i;
int k;
long *ve = (long*) SCM_VELTS (inds);
if (!SCM_ARRAYP (ra))
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;
+ scm_t_array_dim dims;
+ scm_t_array_dim *s0 = &dims;
+ scm_t_array_dim *s1;
+ unsigned long bas0 = 0;
int i, ndim = 1;
int exact = 2 /* 4 */ ; /* Don't care about values >2 (yet?) */
if (SCM_IMP (ra0)) return 0;
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"
+ "Store @var{fill} in every element of @var{array}. The value returned\n"
"is unspecified.")
#define FUNC_NAME s_scm_array_fill_x
{
/* 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)
+scm_array_fill_int (SCM ra, SCM fill, SCM ignore SCM_UNUSED)
#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;
+ unsigned long i;
+ unsigned long 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);
+ unsigned long base = SCM_ARRAY_BASE (ra);
ra = SCM_ARRAY_V (ra);
switch SCM_TYP7 (ra)
case scm_tc7_vector:
case scm_tc7_wvect:
for (i = base; n--; i += inc)
- SCM_VELTS (ra)[i] = fill;
+ SCM_VECTOR_SET (ra, i, fill);
break;
case scm_tc7_string:
SCM_ASRTGO (SCM_CHARP (fill), badarg2);
ve[i] |= ~(~0L << ((base + n) % SCM_LONG_BIT));
}
else
- badarg2:SCM_WTA (2,fill);
+ badarg2:SCM_WRONG_TYPE_ARG (2, fill);
}
else
{
}
case scm_tc7_uvect:
{ /* scope */
- unsigned long f = SCM_NUM2ULONG (2,fill);
+ unsigned long f = SCM_NUM2ULONG (2, fill);
unsigned long *ve = (unsigned long *) SCM_VELTS (ra);
for (i = base; n--; i += inc)
}
case scm_tc7_ivect:
{ /* scope */
- long f = SCM_NUM2LONG (2,fill);
+ long f = SCM_NUM2LONG (2, fill);
long *ve = (long *) SCM_VELTS (ra);
for (i = base; n--; i += inc)
#ifdef HAVE_LONG_LONGS
case scm_tc7_llvect:
{ /* scope */
- long long f = SCM_NUM2LONG_LONG (2,fill);
+ long long f = SCM_NUM2LONG_LONG (2, fill);
long long *ve = (long long *) SCM_VELTS (ra);
for (i = base; n--; i += inc)
{
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);
+ unsigned long 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);
-
- /* untested optimization: don't copy if we're we. This allows the
- ugly UNICOS macros (IVDEP) to go .
- */
-
- if (SCM_EQ_P (src, dst))
- return 1 ;
-
switch SCM_TYP7 (dst)
{
default:
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));
+ scm_array_set_x (dst,
+ scm_cvref (src, i_s, SCM_UNDEFINED),
+ SCM_MAKINUM (i_d));
break;
case scm_tc7_string:
if (SCM_TYP7 (src) != scm_tc7_string)
if (SCM_TYP7 (src) != scm_tc7_byvect)
goto gencase;
for (; n-- > 0; i_s += inc_s, i_d += inc_d)
- ((char *) SCM_UVECTOR_BASE (dst))[i_d] = ((char *) SCM_UVECTOR_BASE (src))[i_s];
+ ((char *) SCM_UVECTOR_BASE (dst))[i_d]
+ = ((char *) SCM_UVECTOR_BASE (src))[i_s];
break;
case scm_tc7_bvect:
if (SCM_TYP7 (src) != scm_tc7_bvect)
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;
+ *dv = *sv;)
if (n) /* trailing partial word */
*dv = (*dv & (~0L << n)) | (*sv & ~(~0L << n));
}
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];
+ d[i_d] = s[i_s];)
break;
}
case scm_tc7_ivect:
else
{
long *d = (long *) SCM_VELTS (dst), *s = (long *) SCM_VELTS (src);
- for (; n-- > 0; i_s += inc_s, i_d += inc_d)
- d[i_d] = s[i_s];
- break;
+ IVDEP (src != dst,
+ for (; n-- > 0; i_s += inc_s, i_d += inc_d)
+ d[i_d] = s[i_s];)
+ break;
}
case scm_tc7_fvect:
{
goto gencase;
case scm_tc7_ivect:
case scm_tc7_uvect:
- for (; n-- > 0; i_s += inc_s, i_d += inc_d)
- d[i_d] = ((long *) s)[i_s];
+ 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:
- for (; n-- > 0; i_s += inc_s, i_d += inc_d)
- d[i_d] = s[i_s];
+ 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:
- for (; n-- > 0; i_s += inc_s, i_d += inc_d)
- d[i_d] = ((double *) s)[i_s];
- break;
+ IVDEP (src !=dst,
+ for (; n-- > 0; i_s += inc_s, i_d += inc_d)
+ d[i_d] = ((double *) s)[i_s];)
+ break;
}
break;
}
goto gencase;
case scm_tc7_ivect:
case scm_tc7_uvect:
- for (; n-- > 0; i_s += inc_s, i_d += inc_d)
- d[i_d] = ((long *) s)[i_s];
+ 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:
- for (; n-- > 0; i_s += inc_s, i_d += inc_d)
- d[i_d] = ((float *) s)[i_s];
+ 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:
- for (; n-- > 0; i_s += inc_s, i_d += inc_d)
- d[i_d] = s[i_s];
+ IVDEP (src != dst,
+ for (; n-- > 0; i_s += inc_s, i_d += inc_d)
+ d[i_d] = s[i_s];)
break;
}
break;
goto gencase;
case scm_tc7_ivect:
case scm_tc7_uvect:
- 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;
- }
+ 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:
- 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;
- }
+ 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:
- 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;
- }
+ 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:
- 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];
+ 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;
}
}
SCM_DEFINE (scm_array_copy_x, "array-copy!", 2, 0, 0,
(SCM src, SCM dst),
- "@deffnx primitive array-copy-in-order! src dst\n"
- "Copies every element from vector or array @var{source} to the\n"
+ "@deffnx {Scheme Procedure} array-copy-in-order! src dst\n"
+ "Copy 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.")
{
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);
+ unsigned long 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;
/* opt 0 means <, nonzero means >= */
static int
-ra_compare (SCM ra0,SCM ra1,SCM ra2,int opt)
+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);
+ unsigned long 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;
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);
+ unsigned long 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);
+ unsigned long 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)
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);
+ unsigned long i0 = SCM_ARRAY_BASE (ra0);
long inc0 = SCM_ARRAY_DIMS (ra0)->inc;
ra0 = SCM_ARRAY_V (ra0);
if (SCM_NULLP (ras))
else
{
SCM ra1 = SCM_CAR (ras);
- scm_sizet i1 = SCM_ARRAY_BASE (ra1);
+ unsigned long 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)
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);
+ unsigned long 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);
+ unsigned long 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)
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);
+ unsigned long i0 = SCM_ARRAY_BASE (ra0);
long inc0 = SCM_ARRAY_DIMS (ra0)->inc;
ra0 = SCM_ARRAY_V (ra0);
if (SCM_NULLP (ras))
else
{
SCM ra1 = SCM_CAR (ras);
- scm_sizet i1 = SCM_ARRAY_BASE (ra1);
+ unsigned long 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)
static int
-ramap (SCM ra0,SCM proc,SCM ras)
+ramap (SCM ra0, SCM proc, SCM ras)
{
long i = SCM_ARRAY_DIMS (ra0)->lbnd;
long inc = SCM_ARRAY_DIMS (ra0)->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));
+ scm_array_set_x (ra0, scm_call_0 (proc), SCM_MAKINUM (i * inc + base));
else
{
SCM ra1 = SCM_CAR (ras);
- SCM args, *ve = &ras;
- scm_sizet k, i1 = SCM_ARRAY_BASE (ra1);
+ SCM args;
+ SCM const *ve = &ras;
+ unsigned long k, i1 = SCM_ARRAY_BASE (ra1);
long inc1 = SCM_ARRAY_DIMS (ra1)->inc;
ra1 = SCM_ARRAY_V (ra1);
ras = SCM_CDR (ras);
ras = scm_vector (ras);
ve = SCM_VELTS (ras);
}
+
for (; i <= n; i++, i1 += inc1)
{
args = SCM_EOL;
for (k = SCM_INUM (scm_uniform_vector_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));
+ scm_array_set_x (ra0, scm_apply_0 (proc, args), SCM_MAKINUM (i * inc + base));
}
}
return 1;
static int
-ramap_cxr (SCM ra0,SCM proc,SCM ras)
+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);
+ unsigned long 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);
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));
+ scm_array_set_x (ra0, scm_call_1 (proc, RVREF (ra1, i1, e1)), SCM_MAKINUM (i0));
break;
case scm_tc7_fvect:
{
static int
-ramap_rp (SCM ra0,SCM proc,SCM ras)
+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);
+ unsigned long 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;
*/
SCM n1 = SCM_MAKINUM (((long *) SCM_UNPACK (SCM_CDR (ra1)))[i1]);
SCM n2 = SCM_MAKINUM (((long *) SCM_UNPACK (SCM_CDR (ra2)))[i2]);
- if (SCM_FALSEP (SCM_SUBRF (proc) (n1, n2)));
+ if (SCM_FALSEP (SCM_SUBRF (proc) (n1, n2)))
SCM_BITVEC_CLR (ra0, i0);
}
break;
static int
-ramap_1 (SCM ra0,SCM proc,SCM ras)
+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);
+ unsigned long 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);
static int
-ramap_2o (SCM ra0,SCM proc,SCM ras)
+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);
+ unsigned long 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);
{
SCM ra2 = SCM_CAR (ras);
SCM e2 = SCM_UNDEFINED;
- scm_sizet i2 = SCM_ARRAY_BASE (ra2);
+ unsigned long 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))
static int
-ramap_a (SCM ra0,SCM proc,SCM ras)
+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);
+ unsigned long i0 = SCM_ARRAY_BASE (ra0);
long inc0 = SCM_ARRAY_DIMS (ra0)->inc;
ra0 = SCM_ARRAY_V (ra0);
if (SCM_NULLP (ras))
else
{
SCM ra1 = SCM_CAR (ras);
- scm_sizet i1 = SCM_ARRAY_BASE (ra1);
+ unsigned long 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_DEFINE (scm_array_map_x, "array-map!", 2, 0, 1,
(SCM ra0, SCM proc, SCM lra),
- "@deffnx primitive array-map-in-order! ra0 proc . lra\n"
+ "@deffnx {Scheme Procedure} array-map-in-order! ra0 proc . lra\n"
"@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"
"unspecified. The order of application is unspecified.")
#define FUNC_NAME s_scm_array_map_x
{
- SCM_VALIDATE_PROC (2,proc);
+ SCM_VALIDATE_PROC (2, proc);
SCM_VALIDATE_REST_ARGUMENT (lra);
switch (SCM_TYP7 (proc))
{
static int
-rafe (SCM ra0,SCM proc,SCM ras)
+rafe (SCM ra0, SCM proc, SCM ras)
{
long i = SCM_ARRAY_DIMS (ra0)->lbnd;
- scm_sizet i0 = SCM_ARRAY_BASE (ra0);
+ unsigned long 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);
+ scm_call_1 (proc, scm_cvref (ra0, i0, SCM_UNDEFINED));
else
{
SCM ra1 = SCM_CAR (ras);
- SCM args, *ve = &ras;
- scm_sizet k, i1 = SCM_ARRAY_BASE (ra1);
+ SCM args;
+ SCM const*ve = &ras;
+ unsigned long k, i1 = SCM_ARRAY_BASE (ra1);
long inc1 = SCM_ARRAY_DIMS (ra1)->inc;
ra1 = SCM_ARRAY_V (ra1);
ras = SCM_CDR (ras);
for (k = SCM_INUM (scm_uniform_vector_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);
+ scm_apply_0 (proc, args);
}
}
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"
+ "Apply @var{proc} 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_VALIDATE_PROC (1, proc);
SCM_VALIDATE_REST_ARGUMENT (lra);
scm_ramapc (rafe, proc, ra0, lra, FUNC_NAME);
return SCM_UNSPECIFIED;
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"
+ "Apply @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"
+ "@lisp\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"
+ "@end lisp\n"
"Another example:\n"
- "@example\n"
+ "@lisp\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")
+ "@end lisp")
#define FUNC_NAME s_scm_array_index_map_x
{
- scm_sizet i;
- SCM_VALIDATE_NIM (1,ra);
- SCM_VALIDATE_PROC (2,proc);
+ unsigned long i;
+ SCM_VALIDATE_NIM (1, ra);
+ SCM_VALIDATE_PROC (2, proc);
switch (SCM_TYP7(ra))
{
default:
- badarg:SCM_WTA (1,ra);
+ badarg:SCM_WRONG_TYPE_ARG (1, ra);
case scm_tc7_vector:
case scm_tc7_wvect:
{
- SCM *ve = SCM_VELTS (ra);
for (i = 0; i < SCM_VECTOR_LENGTH (ra); i++)
- ve[i] = scm_apply (proc, SCM_MAKINUM (i), scm_listofnull);
+ SCM_VECTOR_SET(ra, i, scm_call_1 (proc, SCM_MAKINUM (i)));
return SCM_UNSPECIFIED;
}
case scm_tc7_string:
{
unsigned long int length = SCM_INUM (scm_uniform_vector_length (ra));
for (i = 0; i < length; i++)
- scm_array_set_x (ra, scm_apply (proc, SCM_MAKINUM (i), scm_listofnull),
+ scm_array_set_x (ra, scm_call_1 (proc, SCM_MAKINUM (i)),
SCM_MAKINUM (i));
return SCM_UNSPECIFIED;
}
long *vinds = (long *) 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);
+ return scm_array_set_x (ra, scm_call_0 (proc), SCM_EOL);
for (k = 0; k <= kmax; k++)
vinds[k] = SCM_ARRAY_DIMS (ra)[k].lbnd;
k = kmax;
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_apply_0 (proc, args),
SCM_MAKINUM (i));
i += SCM_ARRAY_DIMS (ra)[k].inc;
}
static int
-raeql_1 (SCM ra0,SCM as_equal,SCM ra1)
+raeql_1 (SCM ra0, SCM as_equal, SCM ra1)
{
SCM e0 = SCM_UNDEFINED, e1 = SCM_UNDEFINED;
- scm_sizet i0 = 0, i1 = 0;
+ unsigned long i0 = 0, i1 = 0;
long inc0 = 1, inc1 = 1;
- scm_sizet n = SCM_INUM (scm_uniform_vector_length (ra0));
+ unsigned long n;
ra1 = SCM_CAR (ra1);
if (SCM_ARRAYP(ra0))
{
inc0 = SCM_ARRAY_DIMS (ra0)->inc;
ra0 = SCM_ARRAY_V (ra0);
}
+ else
+ n = SCM_INUM (scm_uniform_vector_length (ra0));
if (SCM_ARRAYP (ra1))
{
i1 = SCM_ARRAY_BASE (ra1);
static int
-raeql (SCM ra0,SCM as_equal,SCM ra1)
+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;
+ scm_t_array_dim dim0, dim1;
+ scm_t_array_dim *s0 = &dim0, *s1 = &dim1;
+ unsigned long bas0 = 0, bas1 = 0;
int k, unroll = 1, vlen = 1, ndim = 1;
if (SCM_ARRAYP (ra0))
{
/* 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.")
+ "Return @code{#t} iff all arguments are arrays with the same\n"
+ "shape, the same type, and have corresponding elements which are\n"
+ "either @code{equal?} or @code{array-equal?}. This function\n"
+ "differs from @code{equal?} in that a one dimensional shared\n"
+ "array may be @var{array-equal?} but not @var{equal?} to a\n"
+ "vector or uniform vector.")
#define FUNC_NAME s_scm_array_equal_p
{
}
}
-
static void
init_raprocs (ra_iproc *subra)
{
for (; subra->name; subra++)
- subra->sproc = scm_symbol_binding (SCM_BOOL_F, scm_str2symbol (subra->name));
+ {
+ SCM sym = scm_str2symbol (subra->name);
+ SCM var =
+ scm_sym2var (sym, scm_current_module_lookup_closure (), SCM_BOOL_F);
+ if (var != SCM_BOOL_F)
+ subra->sproc = SCM_VARIABLE_REF (var);
+ else
+ subra->sproc = SCM_BOOL_F;
+ }
}
{
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;
-#ifndef SCM_MAGIC_SNARFER
+ scm_c_define_subr (s_array_equal_p, scm_tc7_rpsubr, scm_array_equal_p);
+ scm_smobs[SCM_TC2SMOBNUM (scm_tc16_array)].equalp = scm_raequal;
#include "libguile/ramap.x"
-#endif
scm_add_feature (s_scm_array_for_each);
}
HCoop / bpt / guile.git / blobdiff