-/* Copyright (C) 1996,1998,2000,2001,2004,2005, 2006, 2008, 2009 Free Software Foundation, Inc.
- *
+/* Copyright (C) 1996, 1998, 2000, 2001, 2004, 2005, 2006, 2008, 2009,
+ * 2010, 2012, 2013 Free Software Foundation, Inc.
+ *
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
* as published by the Free Software Foundation; either version 3 of
#include "libguile/vectors.h"
#include "libguile/bitvectors.h"
#include "libguile/srfi-4.h"
-#include "libguile/dynwind.h"
#include "libguile/generalized-arrays.h"
#include "libguile/generalized-vectors.h"
#include "libguile/array-map.h"
\f
-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}
-};
+/* The WHAT argument for `scm_gc_malloc ()' et al. */
+static const char indices_gc_hint[] = "array-indices";
#define GVREF scm_c_generalized_vector_ref
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_ramapc (void *cproc_ptr, SCM data, SCM ra0, SCM lra, const char *what)
{
SCM z;
SCM vra0, ra1, vra1;
SCM lvra, *plvra;
long *vinds;
int k, kmax;
+ int (*cproc) ();
+
+ cproc = cproc_ptr;
switch (scm_ra_matchp (ra0, lra))
{
default:
plvra = SCM_CDRLOC (*plvra);
}
- scm_dynwind_begin (0);
-
- vinds = scm_malloc (sizeof(long) * SCM_I_ARRAY_NDIM (ra0));
- scm_dynwind_free (vinds);
+ vinds = scm_gc_malloc_pointerless (sizeof(long) * SCM_I_ARRAY_NDIM (ra0),
+ indices_gc_hint);
for (k = 0; k <= kmax; k++)
vinds[k] = SCM_I_ARRAY_DIMS (ra0)[k].lbnd;
}
while (k >= 0);
- scm_dynwind_end ();
return 1;
}
}
+static int
+rafill (SCM dst, SCM fill)
+{
+ long n = (SCM_I_ARRAY_DIMS (dst)->ubnd - SCM_I_ARRAY_DIMS (dst)->lbnd + 1);
+ scm_t_array_handle h;
+ size_t i;
+ ssize_t inc;
+ scm_array_get_handle (SCM_I_ARRAY_V (dst), &h);
+ i = h.base + h.dims[0].lbnd + SCM_I_ARRAY_BASE (dst)*h.dims[0].inc;
+ inc = SCM_I_ARRAY_DIMS (dst)->inc * h.dims[0].inc;
+
+ for (; n-- > 0; i += inc)
+ h.impl->vset (&h, i, fill);
+
+ scm_array_handle_release (&h);
+ return 1;
+}
SCM_DEFINE (scm_array_fill_x, "array-fill!", 2, 0, 0,
(SCM ra, SCM fill),
- "Store @var{fill} in every element of @var{array}. The value returned\n"
- "is unspecified.")
+ "Store @var{fill} in every element of array @var{ra}. The value\n"
+ "returned is unspecified.")
#define FUNC_NAME s_scm_array_fill_x
{
- scm_ramapc (scm_array_fill_int, fill, ra, SCM_EOL, FUNC_NAME);
+ scm_ramapc (rafill, fill, ra, SCM_EOL, FUNC_NAME);
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 SCM_UNUSED)
-#define FUNC_NAME s_scm_array_fill_x
-{
- unsigned long i;
- unsigned long n = SCM_I_ARRAY_DIMS (ra)->ubnd - SCM_I_ARRAY_DIMS (ra)->lbnd + 1;
- long inc = SCM_I_ARRAY_DIMS (ra)->inc;
- unsigned long base = SCM_I_ARRAY_BASE (ra);
-
- ra = SCM_I_ARRAY_V (ra);
- for (i = base; n--; i += inc)
- GVSET (ra, i, fill);
-
- return 1;
-}
-#undef FUNC_NAME
-
-
-
-static int
+static int
racp (SCM src, SCM dst)
{
long n = (SCM_I_ARRAY_DIMS (src)->ubnd - SCM_I_ARRAY_DIMS (src)->lbnd + 1);
- long inc_d, inc_s = SCM_I_ARRAY_DIMS (src)->inc;
- unsigned long i_d, i_s = SCM_I_ARRAY_BASE (src);
+ scm_t_array_handle h_s, h_d;
+ size_t i_s, i_d;
+ ssize_t inc_s, inc_d;
+
dst = SCM_CAR (dst);
- inc_d = SCM_I_ARRAY_DIMS (dst)->inc;
- i_d = SCM_I_ARRAY_BASE (dst);
- src = SCM_I_ARRAY_V (src);
- dst = SCM_I_ARRAY_V (dst);
+ scm_array_get_handle (SCM_I_ARRAY_V (src), &h_s);
+ scm_array_get_handle (SCM_I_ARRAY_V (dst), &h_d);
+
+ i_s = h_s.base + h_s.dims[0].lbnd + SCM_I_ARRAY_BASE (src) * h_s.dims[0].inc;
+ i_d = h_d.base + h_d.dims[0].lbnd + SCM_I_ARRAY_BASE (dst) * h_d.dims[0].inc;
+ inc_s = SCM_I_ARRAY_DIMS (src)->inc * h_s.dims[0].inc;
+ inc_d = SCM_I_ARRAY_DIMS (dst)->inc * h_d.dims[0].inc;
for (; n-- > 0; i_s += inc_s, i_d += inc_d)
- GVSET (dst, i_d, GVREF (src, i_s));
+ h_d.impl->vset (&h_d, i_d, h_s.impl->vref (&h_s, i_s));
+
+ scm_array_handle_release (&h_d);
+ scm_array_handle_release (&h_s);
+
return 1;
}
SCM_DEFINE (scm_array_copy_x, "array-copy!", 2, 0, 0,
(SCM src, SCM dst),
"@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"
+ "Copy every element from vector or array @var{src} to the\n"
+ "corresponding element of @var{dst}. @var{dst} must have the\n"
+ "same rank as @var{src}, and be at least as large in each\n"
"dimension. The order is unspecified.")
#define FUNC_NAME s_scm_array_copy_x
{
}
#undef FUNC_NAME
-/* Functions callable by ARRAY-MAP! */
+#if SCM_ENABLE_DEPRECATED == 1
+
+/* 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_UNUSED)
+{
+ unsigned long i;
+ unsigned long n = SCM_I_ARRAY_DIMS (ra)->ubnd - SCM_I_ARRAY_DIMS (ra)->lbnd + 1;
+ long inc = SCM_I_ARRAY_DIMS (ra)->inc;
+ unsigned long base = SCM_I_ARRAY_BASE (ra);
+
+ ra = SCM_I_ARRAY_V (ra);
+
+ for (i = base; n--; i += inc)
+ GVSET (ra, i, fill);
+
+ return 1;
+}
+
+/* Functions callable by ARRAY-MAP! */
int
scm_ra_eqp (SCM ra0, SCM ras)
return racp (SCM_CAR (src), scm_cons (dst, SCM_EOL));
}
+#endif /* SCM_ENABLE_DEPRECATED */
-
-static int
+static int
ramap (SCM ra0, SCM proc, SCM ras)
{
- long i = SCM_I_ARRAY_DIMS (ra0)->lbnd;
- long inc = SCM_I_ARRAY_DIMS (ra0)->inc;
- long n = SCM_I_ARRAY_DIMS (ra0)->ubnd;
- long base = SCM_I_ARRAY_BASE (ra0) - i * inc;
- ra0 = SCM_I_ARRAY_V (ra0);
+ ssize_t i = SCM_I_ARRAY_DIMS (ra0)->lbnd;
+ size_t n = SCM_I_ARRAY_DIMS (ra0)->ubnd - i + 1;
+
+ scm_t_array_handle h0;
+ size_t i0, i0end;
+ ssize_t inc0;
+ scm_array_get_handle (SCM_I_ARRAY_V (ra0), &h0);
+ i0 = h0.base + h0.dims[0].lbnd + SCM_I_ARRAY_BASE (ra0)*h0.dims[0].inc;
+ inc0 = SCM_I_ARRAY_DIMS (ra0)->inc * h0.dims[0].inc;
+ i0end = i0 + n*inc0;
if (scm_is_null (ras))
- for (; i <= n; i++)
- GVSET (ra0, i*inc+base, scm_call_0 (proc));
+ for (; i0 < i0end; i0 += inc0)
+ h0.impl->vset (&h0, i0, scm_call_0 (proc));
else
{
SCM ra1 = SCM_CAR (ras);
- SCM args;
- unsigned long k, i1 = SCM_I_ARRAY_BASE (ra1);
- long inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
- ra1 = SCM_I_ARRAY_V (ra1);
+ scm_t_array_handle h1;
+ size_t i1;
+ ssize_t inc1;
+ scm_array_get_handle (SCM_I_ARRAY_V (ra1), &h1);
+ i1 = h1.base + h1.dims[0].lbnd + SCM_I_ARRAY_BASE (ra1)*h1.dims[0].inc;
+ inc1 = SCM_I_ARRAY_DIMS (ra1)->inc * h1.dims[0].inc;
ras = SCM_CDR (ras);
- if (scm_is_null(ras))
- ras = scm_nullvect;
+ if (scm_is_null (ras))
+ for (; i0 < i0end; i0 += inc0, i1 += inc1)
+ h0.impl->vset (&h0, i0, scm_call_1 (proc, h1.impl->vref (&h1, i1)));
else
- ras = scm_vector (ras);
-
- for (; i <= n; i++, i1 += inc1)
- {
- args = SCM_EOL;
- for (k = scm_c_vector_length (ras); k--;)
- args = scm_cons (GVREF (scm_c_vector_ref (ras, k), i), args);
- args = scm_cons (GVREF (ra1, i1), args);
- GVSET (ra0, i*inc+base, scm_apply_0 (proc, args));
- }
- }
- return 1;
-}
-
-
-static int
-ramap_dsubr (SCM ra0, SCM proc, SCM ras)
-{
- SCM ra1 = SCM_CAR (ras);
- unsigned long i0 = SCM_I_ARRAY_BASE (ra0), i1 = SCM_I_ARRAY_BASE (ra1);
- long inc0 = SCM_I_ARRAY_DIMS (ra0)->inc, inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
- long n = SCM_I_ARRAY_DIMS (ra0)->ubnd - SCM_I_ARRAY_DIMS (ra1)->lbnd + 1;
- ra0 = SCM_I_ARRAY_V (ra0);
- ra1 = SCM_I_ARRAY_V (ra1);
- switch (SCM_TYP7 (ra0))
- {
- default:
- for (; n-- > 0; i0 += inc0, i1 += inc1)
- GVSET (ra0, i0, scm_call_1 (proc, GVREF (ra1, i1)));
- break;
- }
- return 1;
-}
-
-
-
-static int
-ramap_rp (SCM ra0, SCM proc, SCM ras)
-{
- SCM ra1 = SCM_CAR (ras), ra2 = SCM_CAR (SCM_CDR (ras));
- long n = SCM_I_ARRAY_DIMS (ra0)->ubnd - SCM_I_ARRAY_DIMS (ra0)->lbnd + 1;
- unsigned long i0 = SCM_I_ARRAY_BASE (ra0), i1 = SCM_I_ARRAY_BASE (ra1), i2 = SCM_I_ARRAY_BASE (ra2);
- long inc0 = SCM_I_ARRAY_DIMS (ra0)->inc;
- long inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
- long inc2 = SCM_I_ARRAY_DIMS (ra1)->inc;
- ra0 = SCM_I_ARRAY_V (ra0);
- ra1 = SCM_I_ARRAY_V (ra1);
- ra2 = SCM_I_ARRAY_V (ra2);
-
- for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
- if (scm_is_true (scm_c_bitvector_ref (ra0, i0)))
- if (scm_is_false (SCM_SUBRF (proc) (GVREF (ra1, i1), GVREF (ra2, i2))))
- scm_c_bitvector_set_x (ra0, i0, SCM_BOOL_F);
-
- return 1;
-}
-
-
-
-static int
-ramap_1 (SCM ra0, SCM proc, SCM ras)
-{
- SCM ra1 = SCM_CAR (ras);
- long n = SCM_I_ARRAY_DIMS (ra0)->ubnd - SCM_I_ARRAY_DIMS (ra0)->lbnd + 1;
- unsigned long i0 = SCM_I_ARRAY_BASE (ra0), i1 = SCM_I_ARRAY_BASE (ra1);
- long inc0 = SCM_I_ARRAY_DIMS (ra0)->inc, inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
- ra0 = SCM_I_ARRAY_V (ra0);
- ra1 = SCM_I_ARRAY_V (ra1);
- if (scm_tc7_vector == SCM_TYP7 (ra0) || scm_tc7_wvect == SCM_TYP7 (ra0))
- for (; n-- > 0; i0 += inc0, i1 += inc1)
- GVSET (ra0, i0, SCM_SUBRF (proc) (GVREF (ra1, i1)));
- else
- for (; n-- > 0; i0 += inc0, i1 += inc1)
- GVSET (ra0, i0, SCM_SUBRF (proc) (GVREF (ra1, i1)));
- return 1;
-}
-
-
-
-static int
-ramap_2o (SCM ra0, SCM proc, SCM ras)
-{
- SCM ra1 = SCM_CAR (ras);
- long n = SCM_I_ARRAY_DIMS (ra0)->ubnd - SCM_I_ARRAY_DIMS (ra0)->lbnd + 1;
- unsigned long i0 = SCM_I_ARRAY_BASE (ra0), i1 = SCM_I_ARRAY_BASE (ra1);
- long inc0 = SCM_I_ARRAY_DIMS (ra0)->inc, inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
- ra0 = SCM_I_ARRAY_V (ra0);
- ra1 = SCM_I_ARRAY_V (ra1);
- ras = SCM_CDR (ras);
- if (scm_is_null (ras))
- {
- for (; n-- > 0; i0 += inc0, i1 += inc1)
- GVSET (ra0, i0, SCM_SUBRF (proc) (GVREF (ra1, i1), SCM_UNDEFINED));
- }
- else
- {
- SCM ra2 = SCM_CAR (ras);
- unsigned long i2 = SCM_I_ARRAY_BASE (ra2);
- long inc2 = SCM_I_ARRAY_DIMS (ra2)->inc;
- ra2 = SCM_I_ARRAY_V (ra2);
- for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
- GVSET (ra0, i0, SCM_SUBRF (proc) (GVREF (ra1, i1), GVREF (ra2, i2)));
- }
- return 1;
-}
-
-
-
-static int
-ramap_a (SCM ra0, SCM proc, SCM ras)
-{
- long n = SCM_I_ARRAY_DIMS (ra0)->ubnd - SCM_I_ARRAY_DIMS (ra0)->lbnd + 1;
- unsigned long i0 = SCM_I_ARRAY_BASE (ra0);
- long inc0 = SCM_I_ARRAY_DIMS (ra0)->inc;
- ra0 = SCM_I_ARRAY_V (ra0);
- if (scm_is_null (ras))
- for (; n-- > 0; i0 += inc0)
- GVSET (ra0, i0, SCM_SUBRF (proc) (GVREF (ra0, i0), SCM_UNDEFINED));
- else
- {
- SCM ra1 = SCM_CAR (ras);
- unsigned long i1 = SCM_I_ARRAY_BASE (ra1);
- long inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
- ra1 = SCM_I_ARRAY_V (ra1);
- for (; n-- > 0; i0 += inc0, i1 += inc1)
- GVSET (ra0, i0, SCM_SUBRF (proc) (GVREF (ra0, i0), GVREF (ra1, i1)));
+ {
+ ras = scm_vector (ras);
+ for (; i0 < i0end; i0 += inc0, i1 += inc1, ++i)
+ {
+ SCM args = SCM_EOL;
+ unsigned long k;
+ for (k = scm_c_vector_length (ras); k--;)
+ args = scm_cons (GVREF (scm_c_vector_ref (ras, k), i), args);
+ h0.impl->vset (&h0, i0, scm_apply_1 (proc, h1.impl->vref (&h1, i1), args));
+ }
+ }
+ scm_array_handle_release (&h1);
}
+ scm_array_handle_release (&h0);
return 1;
}
SCM_DEFINE (scm_array_map_x, "array-map!", 2, 0, 1,
(SCM ra0, SCM proc, SCM lra),
"@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"
- "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.")
+ "@var{array1}, @dots{} must have the same number of dimensions\n"
+ "as @var{ra0} and have a range for each index which includes the\n"
+ "range for the corresponding index in @var{ra0}. @var{proc} is\n"
+ "applied to each tuple of elements of @var{array1}, @dots{} and\n"
+ "the result is stored as the corresponding element in @var{ra0}.\n"
+ "The value returned is unspecified. The order of application is\n"
+ "unspecified.")
#define FUNC_NAME s_scm_array_map_x
{
SCM_VALIDATE_PROC (2, proc);
SCM_VALIDATE_REST_ARGUMENT (lra);
- switch (SCM_TYP7 (proc))
- {
- default:
- gencase:
- scm_ramapc (ramap, proc, ra0, lra, FUNC_NAME);
- return SCM_UNSPECIFIED;
- case scm_tc7_subr_1:
- if (! scm_is_pair (lra))
- SCM_WRONG_NUM_ARGS (); /* need 1 source */
- scm_ramapc (ramap_1, proc, ra0, lra, FUNC_NAME);
- return SCM_UNSPECIFIED;
- case scm_tc7_subr_2:
- if (! (scm_is_pair (lra) && scm_is_pair (SCM_CDR (lra))))
- SCM_WRONG_NUM_ARGS (); /* need 2 sources */
- goto subr_2o;
- case scm_tc7_subr_2o:
- if (! scm_is_pair (lra))
- SCM_WRONG_NUM_ARGS (); /* need 1 source */
- subr_2o:
- scm_ramapc (ramap_2o, proc, ra0, lra, FUNC_NAME);
- return SCM_UNSPECIFIED;
- case scm_tc7_dsubr:
- if (! scm_is_pair (lra))
- SCM_WRONG_NUM_ARGS (); /* need 1 source */
- scm_ramapc (ramap_dsubr, proc, ra0, lra, FUNC_NAME);
- return SCM_UNSPECIFIED;
- case scm_tc7_rpsubr:
- {
- ra_iproc *p;
- if (!scm_is_typed_array (ra0, sym_b))
- goto gencase;
- scm_array_fill_x (ra0, SCM_BOOL_T);
- for (p = ra_rpsubrs; p->name; p++)
- if (scm_is_eq (proc, p->sproc))
- {
- while (!scm_is_null (lra) && !scm_is_null (SCM_CDR (lra)))
- {
- scm_ramapc (p->vproc, SCM_UNDEFINED, ra0, lra, FUNC_NAME);
- lra = SCM_CDR (lra);
- }
- return SCM_UNSPECIFIED;
- }
- while (!scm_is_null (lra) && !scm_is_null (SCM_CDR (lra)))
- {
- scm_ramapc (ramap_rp, proc, ra0, lra, FUNC_NAME);
- lra = SCM_CDR (lra);
- }
- return SCM_UNSPECIFIED;
- }
- case scm_tc7_asubr:
- if (scm_is_null (lra))
- {
- SCM fill = SCM_SUBRF (proc) (SCM_UNDEFINED, SCM_UNDEFINED);
- scm_array_fill_x (ra0, fill);
- }
- else
- {
- SCM tail, ra1 = SCM_CAR (lra);
- SCM v0 = (SCM_I_ARRAYP (ra0) ? SCM_I_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 (scm_is_eq (v0, ra1)
- || (SCM_I_ARRAYP (ra1) && scm_is_eq (v0, SCM_I_ARRAY_V (ra1))))
- if (!scm_is_eq (ra0, ra1)
- || (SCM_I_ARRAYP(ra0) && !SCM_I_ARRAY_CONTP(ra0)))
- goto gencase;
- for (tail = SCM_CDR (lra); !scm_is_null (tail); tail = SCM_CDR (tail))
- {
- ra1 = SCM_CAR (tail);
- if (scm_is_eq (v0, ra1)
- || (SCM_I_ARRAYP (ra1) && scm_is_eq (v0, SCM_I_ARRAY_V (ra1))))
- goto gencase;
- }
- for (p = ra_asubrs; p->name; p++)
- if (scm_is_eq (proc, p->sproc))
- {
- if (!scm_is_eq (ra0, SCM_CAR (lra)))
- scm_ramapc (scm_array_identity, SCM_UNDEFINED, ra0, scm_cons (SCM_CAR (lra), SCM_EOL), FUNC_NAME);
- lra = SCM_CDR (lra);
- while (1)
- {
- scm_ramapc (p->vproc, SCM_UNDEFINED, ra0, lra, FUNC_NAME);
- if (SCM_IMP (lra) || SCM_IMP (SCM_CDR (lra)))
- return SCM_UNSPECIFIED;
- lra = SCM_CDR (lra);
- }
- }
- scm_ramapc (ramap_2o, proc, ra0, lra, FUNC_NAME);
- 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, FUNC_NAME);
- }
- return SCM_UNSPECIFIED;
- }
+ scm_ramapc (ramap, proc, ra0, lra, FUNC_NAME);
+ return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
static int
rafe (SCM ra0, SCM proc, SCM ras)
{
- long i = SCM_I_ARRAY_DIMS (ra0)->lbnd;
- unsigned long i0 = SCM_I_ARRAY_BASE (ra0);
- long inc0 = SCM_I_ARRAY_DIMS (ra0)->inc;
- long n = SCM_I_ARRAY_DIMS (ra0)->ubnd;
- ra0 = SCM_I_ARRAY_V (ra0);
+ ssize_t i = SCM_I_ARRAY_DIMS (ra0)->lbnd;
+ size_t n = SCM_I_ARRAY_DIMS (ra0)->ubnd - i + 1;
+
+ scm_t_array_handle h0;
+ size_t i0, i0end;
+ ssize_t inc0;
+ scm_array_get_handle (SCM_I_ARRAY_V (ra0), &h0);
+ i0 = h0.base + h0.dims[0].lbnd + SCM_I_ARRAY_BASE (ra0)*h0.dims[0].inc;
+ inc0 = SCM_I_ARRAY_DIMS (ra0)->inc * h0.dims[0].inc;
+ i0end = i0 + n*inc0;
if (scm_is_null (ras))
- for (; i <= n; i++, i0 += inc0)
- scm_call_1 (proc, GVREF (ra0, i0));
+ for (; i0 < i0end; i0 += inc0)
+ scm_call_1 (proc, h0.impl->vref (&h0, i0));
else
{
- SCM ra1 = SCM_CAR (ras);
- SCM args;
- unsigned long k, i1 = SCM_I_ARRAY_BASE (ra1);
- long inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
- ra1 = SCM_I_ARRAY_V (ra1);
- ras = SCM_CDR (ras);
- if (scm_is_null(ras))
- ras = scm_nullvect;
- else
- ras = scm_vector (ras);
- for (; i <= n; i++, i0 += inc0, i1 += inc1)
- {
- args = SCM_EOL;
- for (k = scm_c_vector_length (ras); k--;)
- args = scm_cons (GVREF (scm_c_vector_ref (ras, k), i), args);
- args = scm_cons2 (GVREF (ra0, i0), GVREF (ra1, i1), args);
- scm_apply_0 (proc, args);
- }
+ ras = scm_vector (ras);
+ for (; i0 < i0end; i0 += inc0, ++i)
+ {
+ SCM args = SCM_EOL;
+ unsigned long k;
+ for (k = scm_c_vector_length (ras); k--;)
+ args = scm_cons (GVREF (scm_c_vector_ref (ras, k), i), args);
+ scm_apply_1 (proc, h0.impl->vref (&h0, i0), args);
+ }
}
+ scm_array_handle_release (&h0);
return 1;
}
-
SCM_DEFINE (scm_array_for_each, "array-for-each", 2, 0, 1,
(SCM proc, SCM ra0, SCM lra),
- "Apply @var{proc} to each tuple of elements of @var{array0} @dots{}\n"
+ "Apply @var{proc} to each tuple of elements of @var{ra0} @dots{}\n"
"in row-major order. The value returned is unspecified.")
#define FUNC_NAME s_scm_array_for_each
{
SCM_DEFINE (scm_array_index_map_x, "array-index-map!", 2, 0, 0,
(SCM ra, SCM proc),
- "Apply @var{proc} to the indices of each element of @var{array} in\n"
+ "Apply @var{proc} to the indices of each element of @var{ra} 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"
if (kmax < 0)
return scm_array_set_x (ra, scm_call_0 (proc), SCM_EOL);
- scm_dynwind_begin (0);
-
- vinds = scm_malloc (sizeof(long) * SCM_I_ARRAY_NDIM (ra));
- scm_dynwind_free (vinds);
+ vinds = scm_gc_malloc_pointerless (sizeof(long) * SCM_I_ARRAY_NDIM (ra),
+ indices_gc_hint);
for (k = 0; k <= kmax; k++)
vinds[k] = SCM_I_ARRAY_DIMS (ra)[k].lbnd;
}
while (k >= 0);
- scm_dynwind_end ();
return SCM_UNSPECIFIED;
}
else if (scm_is_generalized_vector (ra))
static int
-raeql_1 (SCM ra0, SCM as_equal, SCM ra1)
+array_compare (scm_t_array_handle *hx, scm_t_array_handle *hy,
+ size_t dim, unsigned long posx, unsigned long posy)
{
- unsigned long i0 = 0, i1 = 0;
- long inc0 = 1, inc1 = 1;
- unsigned long n;
- ra1 = SCM_CAR (ra1);
- if (SCM_I_ARRAYP(ra0))
- {
- n = SCM_I_ARRAY_DIMS (ra0)->ubnd - SCM_I_ARRAY_DIMS (ra0)->lbnd + 1;
- i0 = SCM_I_ARRAY_BASE (ra0);
- inc0 = SCM_I_ARRAY_DIMS (ra0)->inc;
- ra0 = SCM_I_ARRAY_V (ra0);
- }
+ if (dim == scm_array_handle_rank (hx))
+ return scm_is_true (scm_equal_p (scm_array_handle_ref (hx, posx),
+ scm_array_handle_ref (hy, posy)));
else
- n = scm_c_generalized_vector_length (ra0);
-
- if (SCM_I_ARRAYP (ra1))
{
- i1 = SCM_I_ARRAY_BASE (ra1);
- inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
- ra1 = SCM_I_ARRAY_V (ra1);
- }
+ long incx, incy;
+ size_t i;
- if (scm_is_generalized_vector (ra0))
- {
- for (; n--; i0 += inc0, i1 += inc1)
- {
- if (scm_is_false (as_equal))
- {
- if (scm_is_false (scm_array_equal_p (GVREF (ra0, i0), GVREF (ra1, i1))))
- return 0;
- }
- else if (scm_is_false (scm_equal_p (GVREF (ra0, i0), GVREF (ra1, i1))))
- return 0;
- }
+ if (hx->dims[dim].lbnd != hy->dims[dim].lbnd
+ || hx->dims[dim].ubnd != hy->dims[dim].ubnd)
+ return 0;
+
+ i = hx->dims[dim].ubnd - hx->dims[dim].lbnd + 1;
+
+ incx = hx->dims[dim].inc;
+ incy = hy->dims[dim].inc;
+ posx += (i - 1) * incx;
+ posy += (i - 1) * incy;
+
+ for (; i > 0; i--, posx -= incx, posy -= incy)
+ if (!array_compare (hx, hy, dim + 1, posx, posy))
+ return 0;
return 1;
}
- else
- return 0;
}
-
-
-static int
-raeql (SCM ra0, SCM as_equal, SCM ra1)
+SCM
+scm_array_equal_p (SCM x, SCM y)
{
- SCM v0 = ra0, v1 = ra1;
- 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_I_ARRAYP (ra0))
- {
- ndim = SCM_I_ARRAY_NDIM (ra0);
- s0 = SCM_I_ARRAY_DIMS (ra0);
- bas0 = SCM_I_ARRAY_BASE (ra0);
- v0 = SCM_I_ARRAY_V (ra0);
- }
- else
- {
- s0->inc = 1;
- s0->lbnd = 0;
- s0->ubnd = scm_c_generalized_vector_length (v0) - 1;
- unroll = 0;
- }
- if (SCM_I_ARRAYP (ra1))
- {
- if (ndim != SCM_I_ARRAY_NDIM (ra1))
- return 0;
- s1 = SCM_I_ARRAY_DIMS (ra1);
- bas1 = SCM_I_ARRAY_BASE (ra1);
- v1 = SCM_I_ARRAY_V (ra1);
- }
- else
- {
- /*
- Huh ? Schizophrenic return type. --hwn
- */
- if (1 != ndim)
- return 0;
- s1->inc = 1;
- s1->lbnd = 0;
- s1->ubnd = scm_c_generalized_vector_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 && scm_is_eq (v0, v1))
- return 1;
- return scm_ramapc (raeql_1, as_equal, ra0, scm_cons (ra1, SCM_EOL), "");
-}
+ scm_t_array_handle hx, hy;
+ SCM res;
+
+ scm_array_get_handle (x, &hx);
+ scm_array_get_handle (y, &hy);
+
+ res = scm_from_bool (hx.ndims == hy.ndims
+ && hx.element_type == hy.element_type);
+ if (scm_is_true (res))
+ res = scm_from_bool (array_compare (&hx, &hy, 0, 0, 0));
-SCM
-scm_raequal (SCM ra0, SCM ra1)
-{
- return scm_from_bool(raeql (ra0, SCM_BOOL_T, ra1));
+ scm_array_handle_release (&hy);
+ scm_array_handle_release (&hx);
+
+ return res;
}
-#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),
+static SCM scm_i_array_equal_p (SCM, SCM, SCM);
+SCM_DEFINE (scm_i_array_equal_p, "array-equal?", 0, 2, 1,
+ (SCM ra0, SCM ra1, SCM rest),
"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
-{
-}
-#undef FUNC_NAME
-#endif
-
-static char s_array_equal_p[] = "array-equal?";
-
-
-SCM
-scm_array_equal_p (SCM ra0, SCM ra1)
-{
- if (SCM_I_ARRAYP (ra0) || SCM_I_ARRAYP (ra1))
- return scm_from_bool(raeql (ra0, SCM_BOOL_F, ra1));
- return scm_equal_p (ra0, ra1);
-}
-
-
-static void
-init_raprocs (ra_iproc *subra)
-{
- for (; subra->name; subra++)
- {
- SCM sym = scm_from_locale_symbol (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;
+ "differs from @code{equal?} in that all arguments must be arrays.")
+#define FUNC_NAME s_scm_i_array_equal_p
+{
+ if (SCM_UNBNDP (ra0) || SCM_UNBNDP (ra1))
+ return SCM_BOOL_T;
+
+ while (!scm_is_null (rest))
+ { if (scm_is_false (scm_array_equal_p (ra0, ra1)))
+ return SCM_BOOL_F;
+ ra0 = ra1;
+ ra1 = scm_car (rest);
+ rest = scm_cdr (rest);
}
+ return scm_array_equal_p (ra0, ra1);
}
+#undef FUNC_NAME
void
scm_init_array_map (void)
{
- init_raprocs (ra_rpsubrs);
- init_raprocs (ra_asubrs);
- scm_c_define_subr (s_array_equal_p, scm_tc7_rpsubr, scm_array_equal_p);
- scm_smobs[SCM_TC2SMOBNUM (scm_i_tc16_array)].equalp = scm_raequal;
#include "libguile/array-map.x"
scm_add_feature (s_scm_array_for_each);
}
HCoop / bpt / guile.git / blobdiff