/* Copyright (C) 1996, 1998, 2000, 2001, 2004, 2005, 2006, 2008, 2009,
- * 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
- *
+ * 2010, 2011, 2012, 2013, 2014 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/bitvectors.h"
#include "libguile/srfi-4.h"
#include "libguile/generalized-arrays.h"
-#include "libguile/generalized-vectors.h"
#include "libguile/validate.h"
#include "libguile/array-map.h"
\f
/* The WHAT argument for `scm_gc_malloc ()' et al. */
-static const char indices_gc_hint[] = "array-indices";
+static const char vi_gc_hint[] = "array-indices";
+static SCM
+AREF (SCM v, size_t pos)
+{
+ return scm_c_array_ref_1 (v, pos);
+}
-#define GVREF scm_c_generalized_vector_ref
-#define GVSET scm_c_generalized_vector_set_x
+static void
+ASET (SCM v, size_t pos, SCM val)
+{
+ scm_c_array_set_1_x (v, val, pos);
+}
-static unsigned long
-cind (SCM ra, long *ve)
+static SCM
+make1array (SCM v, ssize_t inc)
{
- unsigned long i;
- int k;
- if (!SCM_I_ARRAYP (ra))
- return *ve;
- i = SCM_I_ARRAY_BASE (ra);
- for (k = 0; k < SCM_I_ARRAY_NDIM (ra); k++)
- i += (ve[k] - SCM_I_ARRAY_DIMS (ra)[k].lbnd) * SCM_I_ARRAY_DIMS (ra)[k].inc;
- return i;
-}
-
-
-/* Checker for scm_array mapping functions:
- return values: 4 --> shapes, increments, and bases are the same;
- 3 --> shapes and increments are the same;
- 2 --> shapes are the same;
- 1 --> ras are at least as big as ra0;
- 0 --> no match.
- */
-
-int
-scm_ra_matchp (SCM ra0, SCM ras)
-{
- SCM ra1;
- scm_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_is_generalized_vector (ra0))
- {
- s0->lbnd = 0;
- s0->inc = 1;
- s0->ubnd = scm_c_generalized_vector_length (ra0) - 1;
- }
- else if (SCM_I_ARRAYP (ra0))
- {
- ndim = SCM_I_ARRAY_NDIM (ra0);
- s0 = SCM_I_ARRAY_DIMS (ra0);
- bas0 = SCM_I_ARRAY_BASE (ra0);
- }
- else
- return 0;
+ SCM a = scm_i_make_array (1);
+ SCM_I_ARRAY_SET_BASE (a, 0);
+ SCM_I_ARRAY_DIMS (a)->lbnd = 0;
+ SCM_I_ARRAY_DIMS (a)->ubnd = scm_c_array_length (v) - 1;
+ SCM_I_ARRAY_DIMS (a)->inc = inc;
+ SCM_I_ARRAY_SET_V (a, v);
+ return a;
+}
- while (scm_is_pair (ras))
+/* Linear index of not-unrolled index set. */
+static size_t
+cindk (SCM ra, ssize_t *ve, int kend)
+{
+ if (SCM_I_ARRAYP (ra))
{
- ra1 = SCM_CAR (ras);
-
- if (scm_is_generalized_vector (ra1))
- {
- size_t length;
-
- if (1 != ndim)
- return 0;
-
- length = scm_c_generalized_vector_length (ra1);
-
- 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 == length - 1))
- break;
- exact = 1;
- case 1:
- if (s0->lbnd < 0 || s0->ubnd >= length)
- return 0;
- }
- }
- else if (SCM_I_ARRAYP (ra1) && ndim == SCM_I_ARRAY_NDIM (ra1))
- {
- s1 = SCM_I_ARRAY_DIMS (ra1);
- if (bas0 != SCM_I_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);
- }
- }
- else
- return 0;
-
- ras = SCM_CDR (ras);
+ int k;
+ size_t i = SCM_I_ARRAY_BASE (ra);
+ for (k = 0; k < kend; ++k)
+ i += (ve[k] - SCM_I_ARRAY_DIMS (ra)[k].lbnd) * SCM_I_ARRAY_DIMS (ra)[k].inc;
+ return i;
}
-
- return exact;
+ else
+ return 0; /* this is BASE */
}
-/* array mapper: apply cproc to each dimension of the given arrays?.
+/* array mapper: apply cproc to each dimension of the given arrays?.
int (*cproc) (); procedure to call on unrolled arrays?
cproc (dest, source list) or
- cproc (dest, data, source list).
- SCM data; data to give to cproc or unbound.
+ cproc (dest, data, source list).
+ SCM data; data to give to cproc or unbound.
SCM ra0; destination array.
SCM lra; list of source arrays.
const char *what; caller, for error reporting. */
-int
+
+#define LBND(ra, k) SCM_I_ARRAY_DIMS (ra)[k].lbnd
+#define UBND(ra, k) SCM_I_ARRAY_DIMS (ra)[k].ubnd
+
+int
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) ();
+ int (*cproc) () = cproc_ptr;
+ SCM z, va0, lva, *plva;
+ int k, kmax, kroll;
+ ssize_t *vi, inc;
+ size_t len;
+
+ /* Prepare reference argument. */
+ if (SCM_I_ARRAYP (ra0))
+ {
+ kmax = SCM_I_ARRAY_NDIM (ra0)-1;
+ inc = kmax < 0 ? 0 : SCM_I_ARRAY_DIMS (ra0)[kmax].inc;
+ va0 = make1array (SCM_I_ARRAY_V (ra0), inc);
- cproc = cproc_ptr;
- switch (scm_ra_matchp (ra0, lra))
+ /* Find unroll depth */
+ for (kroll = max(0, kmax); kroll > 0; --kroll)
+ {
+ inc *= (UBND (ra0, kroll) - LBND (ra0, kroll) + 1);
+ if (inc != SCM_I_ARRAY_DIMS (ra0)[kroll-1].inc)
+ break;
+ }
+ }
+ else
{
- default:
- case 0:
- scm_misc_error (what, "array shape mismatch: ~S", scm_list_1 (ra0));
- case 2:
- case 3:
- case 4: /* Try unrolling arrays */
- kmax = (SCM_I_ARRAYP (ra0) ? SCM_I_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_I_ARRAYP (vra0))
- {
- size_t length = scm_c_generalized_vector_length (vra0);
- vra1 = scm_i_make_array (1);
- SCM_I_ARRAY_BASE (vra1) = 0;
- SCM_I_ARRAY_DIMS (vra1)->lbnd = 0;
- SCM_I_ARRAY_DIMS (vra1)->ubnd = length - 1;
- SCM_I_ARRAY_DIMS (vra1)->inc = 1;
- SCM_I_ARRAY_V (vra1) = vra0;
- vra0 = vra1;
- }
- lvra = SCM_EOL;
- plvra = &lvra;
- for (z = lra; scm_is_pair (z); z = SCM_CDR (z))
- {
- ra1 = SCM_CAR (z);
- vra1 = scm_i_make_array (1);
- SCM_I_ARRAY_DIMS (vra1)->lbnd = SCM_I_ARRAY_DIMS (vra0)->lbnd;
- SCM_I_ARRAY_DIMS (vra1)->ubnd = SCM_I_ARRAY_DIMS (vra0)->ubnd;
- if (!SCM_I_ARRAYP (ra1))
- {
- SCM_I_ARRAY_BASE (vra1) = 0;
- SCM_I_ARRAY_DIMS (vra1)->inc = 1;
- SCM_I_ARRAY_V (vra1) = ra1;
- }
- else if (!SCM_I_ARRAY_CONTP (ra1))
- goto gencase;
- else
- {
- SCM_I_ARRAY_BASE (vra1) = SCM_I_ARRAY_BASE (ra1);
- SCM_I_ARRAY_DIMS (vra1)->inc = SCM_I_ARRAY_DIMS (ra1)[kmax].inc;
- SCM_I_ARRAY_V (vra1) = SCM_I_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_i_make_array (1);
- if (SCM_I_ARRAYP (ra0))
- {
- kmax = SCM_I_ARRAY_NDIM (ra0) - 1;
- if (kmax < 0)
- {
- SCM_I_ARRAY_DIMS (vra0)->lbnd = 0;
- SCM_I_ARRAY_DIMS (vra0)->ubnd = 0;
- SCM_I_ARRAY_DIMS (vra0)->inc = 1;
- }
- else
- {
- SCM_I_ARRAY_DIMS (vra0)->lbnd = SCM_I_ARRAY_DIMS (ra0)[kmax].lbnd;
- SCM_I_ARRAY_DIMS (vra0)->ubnd = SCM_I_ARRAY_DIMS (ra0)[kmax].ubnd;
- SCM_I_ARRAY_DIMS (vra0)->inc = SCM_I_ARRAY_DIMS (ra0)[kmax].inc;
- }
- SCM_I_ARRAY_BASE (vra0) = SCM_I_ARRAY_BASE (ra0);
- SCM_I_ARRAY_V (vra0) = SCM_I_ARRAY_V (ra0);
- }
- else
- {
- size_t length = scm_c_generalized_vector_length (ra0);
- kmax = 0;
- SCM_I_ARRAY_DIMS (vra0)->lbnd = 0;
- SCM_I_ARRAY_DIMS (vra0)->ubnd = length - 1;
- SCM_I_ARRAY_DIMS (vra0)->inc = 1;
- SCM_I_ARRAY_BASE (vra0) = 0;
- SCM_I_ARRAY_V (vra0) = ra0;
- ra0 = vra0;
- }
- lvra = SCM_EOL;
- plvra = &lvra;
- for (z = lra; scm_is_pair (z); z = SCM_CDR (z))
- {
- ra1 = SCM_CAR (z);
- vra1 = scm_i_make_array (1);
- SCM_I_ARRAY_DIMS (vra1)->lbnd = SCM_I_ARRAY_DIMS (vra0)->lbnd;
- SCM_I_ARRAY_DIMS (vra1)->ubnd = SCM_I_ARRAY_DIMS (vra0)->ubnd;
- if (SCM_I_ARRAYP (ra1))
- {
- if (kmax >= 0)
- SCM_I_ARRAY_DIMS (vra1)->inc = SCM_I_ARRAY_DIMS (ra1)[kmax].inc;
- SCM_I_ARRAY_V (vra1) = SCM_I_ARRAY_V (ra1);
- }
- else
- {
- SCM_I_ARRAY_DIMS (vra1)->inc = 1;
- SCM_I_ARRAY_V (vra1) = ra1;
- }
- *plvra = scm_cons (vra1, SCM_EOL);
- plvra = SCM_CDRLOC (*plvra);
- }
-
- 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;
- k = kmax;
- do
- {
- if (k == kmax)
- {
- SCM y = lra;
- SCM_I_ARRAY_BASE (vra0) = cind (ra0, vinds);
- for (z = lvra; scm_is_pair (z); z = SCM_CDR (z), y = SCM_CDR (y))
- SCM_I_ARRAY_BASE (SCM_CAR (z)) = cind (SCM_CAR (y), vinds);
- if (0 == (SCM_UNBNDP (data) ? cproc(vra0, lvra) : cproc(vra0, data, lvra)))
- return 0;
- k--;
- continue;
- }
- if (vinds[k] < SCM_I_ARRAY_DIMS (ra0)[k].ubnd)
- {
- vinds[k]++;
- k++;
- continue;
- }
- vinds[k] = SCM_I_ARRAY_DIMS (ra0)[k].lbnd - 1;
- k--;
- }
- while (k >= 0);
+ kroll = kmax = 0;
+ va0 = ra0 = make1array (ra0, 1);
+ }
- return 1;
+ /* Prepare rest arguments. */
+ lva = SCM_EOL;
+ plva = &lva;
+ for (z = lra; !scm_is_null (z); z = SCM_CDR (z))
+ {
+ SCM va1, ra1 = SCM_CAR (z);
+ if (SCM_I_ARRAYP (ra1))
+ {
+ if (kmax != SCM_I_ARRAY_NDIM (ra1) - 1)
+ scm_misc_error (what, "array shape mismatch: ~S", scm_list_1 (ra0));
+ inc = kmax < 0 ? 0 : SCM_I_ARRAY_DIMS (ra1)[kmax].inc;
+ va1 = make1array (SCM_I_ARRAY_V (ra1), inc);
+
+ /* Check unroll depth. */
+ for (k = kmax; k > kroll; --k)
+ {
+ ssize_t l0 = LBND (ra0, k), u0 = UBND (ra0, k);
+ if (l0 < LBND (ra1, k) || u0 > UBND (ra1, k))
+ scm_misc_error (what, "array shape mismatch: ~S", scm_list_1 (ra0));
+ inc *= (u0 - l0 + 1);
+ if (inc != SCM_I_ARRAY_DIMS (ra1)[k-1].inc)
+ {
+ kroll = k;
+ break;
+ }
+ }
+
+ /* Check matching of not-unrolled axes. */
+ for (; k>=0; --k)
+ if (LBND (ra0, k) < LBND (ra1, k) || UBND (ra0, k) > UBND (ra1, k))
+ scm_misc_error (what, "array shape mismatch: ~S", scm_list_1 (ra0));
+ }
+ else
+ {
+ if (kmax != 0)
+ scm_misc_error (what, "array shape mismatch: ~S", scm_list_1 (ra0));
+ va1 = make1array (ra1, 1);
+
+ if (LBND (ra0, 0) < LBND (va1, 0) || UBND (ra0, 0) > UBND (va1, 0))
+ scm_misc_error (what, "array shape mismatch: ~S", scm_list_1 (ra0));
+ }
+ *plva = scm_cons (va1, SCM_EOL);
+ plva = SCM_CDRLOC (*plva);
+ }
+
+ /* Check emptiness of not-unrolled axes. */
+ for (k = 0; k < kroll; ++k)
+ if (0 == (UBND (ra0, k) - LBND (ra0, k) + 1))
+ return 1;
+
+ /* Set unrolled size. */
+ for (len = 1; k <= kmax; ++k)
+ len *= (UBND (ra0, k) - LBND (ra0, k) + 1);
+ UBND (va0, 0) = len - 1;
+ for (z = lva; !scm_is_null (z); z = SCM_CDR (z))
+ UBND (SCM_CAR (z), 0) = len - 1;
+
+ /* Set starting indices and go. */
+ vi = scm_gc_malloc_pointerless (sizeof(ssize_t) * kroll, vi_gc_hint);
+ for (k = 0; k < kroll; ++k)
+ vi[k] = LBND (ra0, k);
+ do
+ {
+ if (k == kroll)
+ {
+ SCM y = lra;
+ SCM_I_ARRAY_SET_BASE (va0, cindk (ra0, vi, kroll));
+ for (z = lva; !scm_is_null (z); z = SCM_CDR (z), y = SCM_CDR (y))
+ SCM_I_ARRAY_SET_BASE (SCM_CAR (z), cindk (SCM_CAR (y), vi, kroll));
+ if (! (SCM_UNBNDP (data) ? cproc (va0, lva) : cproc (va0, data, lva)))
+ return 0;
+ --k;
+ }
+ else if (vi[k] < UBND (ra0, k))
+ {
+ ++vi[k];
+ ++k;
+ }
+ else
+ {
+ vi[k] = LBND (ra0, k) - 1;
+ --k;
+ }
}
+ while (k >= 0);
+
+ return 1;
}
+#undef UBND
+#undef LBND
+
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;
+ size_t n, 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;
+ i = SCM_I_ARRAY_BASE (dst);
+ inc = SCM_I_ARRAY_DIMS (dst)->inc;
+ n = (SCM_I_ARRAY_DIMS (dst)->ubnd - SCM_I_ARRAY_DIMS (dst)->lbnd + 1);
+ dst = SCM_I_ARRAY_V (dst);
for (; n-- > 0; i += inc)
- h.impl->vset (&h, i, fill);
+ h.vset (h.vector, i, fill);
scm_array_handle_release (&h);
return 1;
static int
racp (SCM src, SCM dst)
{
- long n = (SCM_I_ARRAY_DIMS (src)->ubnd - SCM_I_ARRAY_DIMS (src)->lbnd + 1);
scm_t_array_handle h_s, h_d;
- size_t i_s, i_d;
+ size_t n, i_s, i_d;
ssize_t inc_s, inc_d;
dst = SCM_CAR (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)
- h_d.impl->vset (&h_d, i_d, h_s.impl->vref (&h_s, i_s));
+ i_s = SCM_I_ARRAY_BASE (src);
+ i_d = SCM_I_ARRAY_BASE (dst);
+ inc_s = SCM_I_ARRAY_DIMS (src)->inc;
+ inc_d = SCM_I_ARRAY_DIMS (dst)->inc;
+ n = (SCM_I_ARRAY_DIMS (src)->ubnd - SCM_I_ARRAY_DIMS (src)->lbnd + 1);
+ src = SCM_I_ARRAY_V (src);
+ dst = SCM_I_ARRAY_V (dst);
+
+ scm_array_get_handle (src, &h_s);
+ scm_array_get_handle (dst, &h_d);
+
+ if (h_s.element_type == SCM_ARRAY_ELEMENT_TYPE_SCM
+ && h_d.element_type == SCM_ARRAY_ELEMENT_TYPE_SCM)
+ {
+ SCM const * el_s = h_s.elements;
+ SCM * el_d = h_d.writable_elements;
+ for (; n-- > 0; i_s += inc_s, i_d += inc_d)
+ el_d[i_d] = el_s[i_s];
+ }
+ else
+ for (; n-- > 0; i_s += inc_s, i_d += inc_d)
+ h_d.vset (h_d.vector, i_d, h_s.vref (h_s.vector, i_s));
scm_array_handle_release (&h_d);
scm_array_handle_release (&h_s);
ra = SCM_I_ARRAY_V (ra);
for (i = base; n--; i += inc)
- GVSET (ra, i, fill);
+ ASET (ra, i, fill);
return 1;
}
{
for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
if (scm_is_true (scm_array_handle_ref (&ra0_handle, i0)))
- if (!scm_is_eq (GVREF (ra1, i1), GVREF (ra2, i2)))
+ if (!scm_is_eq (AREF (ra1, i1), AREF (ra2, i2)))
scm_array_handle_set (&ra0_handle, i0, SCM_BOOL_F);
}
for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
if (scm_is_true (scm_array_handle_ref (&ra0_handle, i0)))
if (opt ?
- scm_is_true (scm_less_p (GVREF (ra1, i1), GVREF (ra2, i2))) :
- scm_is_false (scm_less_p (GVREF (ra1, i1), GVREF (ra2, i2))))
+ scm_is_true (scm_less_p (AREF (ra1, i1), AREF (ra2, i2))) :
+ scm_is_false (scm_less_p (AREF (ra1, i1), AREF (ra2, i2))))
scm_array_handle_set (&ra0_handle, i0, SCM_BOOL_F);
}
default:
{
for (; n-- > 0; i0 += inc0, i1 += inc1)
- GVSET (ra0, i0, scm_sum (GVREF(ra0, i0), GVREF(ra1, i1)));
+ ASET (ra0, i0, scm_sum (AREF(ra0, i0), AREF(ra1, i1)));
break;
}
}
default:
{
for (; n-- > 0; i0 += inc0)
- GVSET (ra0, i0, scm_difference (GVREF(ra0, i0), SCM_UNDEFINED));
+ ASET (ra0, i0, scm_difference (AREF(ra0, i0), SCM_UNDEFINED));
break;
}
}
default:
{
for (; n-- > 0; i0 += inc0, i1 += inc1)
- GVSET (ra0, i0, scm_difference (GVREF (ra0, i0),
- GVREF (ra1, i1)));
+ ASET (ra0, i0, scm_difference (AREF (ra0, i0), AREF (ra1, i1)));
break;
}
}
default:
{
for (; n-- > 0; i0 += inc0, i1 += inc1)
- GVSET (ra0, i0, scm_product (GVREF (ra0, i0),
- GVREF (ra1, i1)));
+ ASET (ra0, i0, scm_product (AREF (ra0, i0), AREF (ra1, i1)));
}
}
}
default:
{
for (; n-- > 0; i0 += inc0)
- GVSET (ra0, i0, scm_divide (GVREF (ra0, i0), SCM_UNDEFINED));
+ ASET (ra0, i0, scm_divide (AREF (ra0, i0), SCM_UNDEFINED));
break;
}
}
{
for (; n-- > 0; i0 += inc0, i1 += inc1)
{
- SCM res = scm_divide (GVREF (ra0, i0),
- GVREF (ra1, i1));
- GVSET (ra0, i0, res);
+ SCM res = scm_divide (AREF (ra0, i0), AREF (ra1, i1));
+ ASET (ra0, i0, res);
}
break;
}
static int
ramap (SCM ra0, SCM proc, SCM ras)
{
- 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;
+ size_t n, i0;
+ ssize_t i, inc0;
+ i0 = SCM_I_ARRAY_BASE (ra0);
+ inc0 = SCM_I_ARRAY_DIMS (ra0)->inc;
+ i = SCM_I_ARRAY_DIMS (ra0)->lbnd;
+ n = SCM_I_ARRAY_DIMS (ra0)->ubnd - i + 1;
+ ra0 = SCM_I_ARRAY_V (ra0);
+ scm_array_get_handle (ra0, &h0);
if (scm_is_null (ras))
- for (; i0 < i0end; i0 += inc0)
- h0.impl->vset (&h0, i0, scm_call_0 (proc));
+ for (; n--; i0 += inc0)
+ h0.vset (h0.vector, i0, scm_call_0 (proc));
else
{
SCM ra1 = SCM_CAR (ras);
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;
+ i1 = SCM_I_ARRAY_BASE (ra1);
+ inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
ras = SCM_CDR (ras);
+ ra1 = SCM_I_ARRAY_V (ra1);
+ scm_array_get_handle (ra1, &h1);
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)));
+ for (; n--; i0 += inc0, i1 += inc1)
+ h0.vset (h0.vector, i0, scm_call_1 (proc, h1.vref (h1.vector, i1)));
else
{
ras = scm_vector (ras);
- for (; i0 < i0end; i0 += inc0, i1 += inc1, ++i)
+ for (; n--; 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));
+ args = scm_cons (AREF (scm_c_vector_ref (ras, k), i), args);
+ h0.vset (h0.vector, i0,
+ scm_apply_1 (proc, h1.vref (h1.vector, i1), args));
}
}
scm_array_handle_release (&h1);
size_t n = SCM_I_ARRAY_DIMS (ra0)->ubnd - i + 1;
scm_t_array_handle h0;
- size_t i0, i0end;
+ size_t i0;
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;
+ i0 = SCM_I_ARRAY_BASE (ra0);
+ inc0 = SCM_I_ARRAY_DIMS (ra0)->inc;
+ ra0 = SCM_I_ARRAY_V (ra0);
+ scm_array_get_handle (ra0, &h0);
if (scm_is_null (ras))
- for (; i0 < i0end; i0 += inc0)
- scm_call_1 (proc, h0.impl->vref (&h0, i0));
+ for (; n--; i0 += inc0)
+ scm_call_1 (proc, h0.vref (h0.vector, i0));
else
{
ras = scm_vector (ras);
- for (; i0 < i0end; i0 += inc0, ++i)
+ for (; n--; 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);
+ args = scm_cons (AREF (scm_c_vector_ref (ras, k), i), args);
+ scm_apply_1 (proc, h0.vref (h0.vector, i0), args);
}
}
scm_array_handle_release (&h0);
}
#undef FUNC_NAME
+static void
+array_index_map_1 (SCM ra, SCM proc)
+{
+ scm_t_array_handle h;
+ ssize_t i, inc;
+ size_t p;
+ scm_array_get_handle (ra, &h);
+ inc = h.dims[0].inc;
+ for (i = h.dims[0].lbnd, p = h.base; i <= h.dims[0].ubnd; ++i, p += inc)
+ h.vset (h.vector, p, scm_call_1 (proc, scm_from_ssize_t (i)));
+ scm_array_handle_release (&h);
+}
+
+/* Here we assume that the array is a scm_tc7_array, as that is the only
+ kind of array in Guile that supports rank > 1. */
+static void
+array_index_map_n (SCM ra, SCM proc)
+{
+ scm_t_array_handle h;
+ size_t i;
+ int k, kmax = SCM_I_ARRAY_NDIM (ra) - 1;
+ ssize_t *vi;
+ SCM **si;
+ SCM args = SCM_EOL;
+ SCM *p = &args;
+
+ vi = scm_gc_malloc_pointerless (sizeof(ssize_t) * (kmax + 1), vi_gc_hint);
+ si = scm_gc_malloc_pointerless (sizeof(SCM *) * (kmax + 1), vi_gc_hint);
+
+ for (k = 0; k <= kmax; k++)
+ {
+ vi[k] = SCM_I_ARRAY_DIMS (ra)[k].lbnd;
+ if (vi[k] > SCM_I_ARRAY_DIMS (ra)[k].ubnd)
+ return;
+ *p = scm_cons (scm_from_ssize_t (vi[k]), SCM_EOL);
+ si[k] = SCM_CARLOC (*p);
+ p = SCM_CDRLOC (*p);
+ }
+
+ scm_array_get_handle (ra, &h);
+ k = kmax;
+ do
+ {
+ if (k == kmax)
+ {
+ vi[kmax] = SCM_I_ARRAY_DIMS (ra)[kmax].lbnd;
+ i = cindk (ra, vi, kmax+1);
+ for (; vi[kmax] <= SCM_I_ARRAY_DIMS (ra)[kmax].ubnd; ++vi[kmax])
+ {
+ *(si[kmax]) = scm_from_ssize_t (vi[kmax]);
+ h.vset (h.vector, i, scm_apply_0 (proc, args));
+ i += SCM_I_ARRAY_DIMS (ra)[kmax].inc;
+ }
+ k--;
+ }
+ else if (vi[k] < SCM_I_ARRAY_DIMS (ra)[k].ubnd)
+ {
+ *(si[k]) = scm_from_ssize_t (++vi[k]);
+ k++;
+ }
+ else
+ {
+ vi[k] = SCM_I_ARRAY_DIMS (ra)[k].lbnd - 1;
+ k--;
+ }
+ }
+ while (k >= 0);
+ scm_array_handle_release (&h);
+}
+
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{ra} in\n"
"@end lisp")
#define FUNC_NAME s_scm_array_index_map_x
{
- unsigned long i;
SCM_VALIDATE_PROC (2, proc);
- if (SCM_I_ARRAYP (ra))
- {
- SCM args = SCM_EOL;
- int j, k, kmax = SCM_I_ARRAY_NDIM (ra) - 1;
- long *vinds;
-
- if (kmax < 0)
- return scm_array_set_x (ra, scm_call_0 (proc), SCM_EOL);
-
- 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;
- k = kmax;
- do
- {
- if (k == kmax)
- {
- vinds[k] = SCM_I_ARRAY_DIMS (ra)[k].lbnd;
- i = cind (ra, vinds);
- for (; vinds[k] <= SCM_I_ARRAY_DIMS (ra)[k].ubnd; vinds[k]++)
- {
- for (j = kmax + 1, args = SCM_EOL; j--;)
- args = scm_cons (scm_from_long (vinds[j]), args);
- GVSET (SCM_I_ARRAY_V (ra), i, scm_apply_0 (proc, args));
- i += SCM_I_ARRAY_DIMS (ra)[k].inc;
- }
- k--;
- continue;
- }
- if (vinds[k] < SCM_I_ARRAY_DIMS (ra)[k].ubnd)
- {
- vinds[k]++;
- k++;
- continue;
- }
- vinds[k] = SCM_I_ARRAY_DIMS (ra)[k].lbnd - 1;
- k--;
- }
- while (k >= 0);
-
- return SCM_UNSPECIFIED;
- }
- else if (scm_is_generalized_vector (ra))
+ switch (scm_c_array_rank (ra))
{
- size_t length = scm_c_generalized_vector_length (ra);
- for (i = 0; i < length; i++)
- GVSET (ra, i, scm_call_1 (proc, scm_from_ulong (i)));
- return SCM_UNSPECIFIED;
+ case 0:
+ scm_array_set_x (ra, scm_call_0 (proc), SCM_EOL);
+ break;
+ case 1:
+ array_index_map_1 (ra, proc);
+ break;
+ default:
+ array_index_map_n (ra, proc);
+ break;
}
- else
- scm_wrong_type_arg_msg (NULL, 0, ra, "array");
+
+ return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
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;
scm_array_equal_p (SCM x, SCM y)
{
scm_t_array_handle hx, hy;
- SCM res;
-
+ 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_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;
HCoop / bpt / guile.git / blobdiff