summaryrefslogtreecommitdiff
path: root/libguile/array-map.c
diff options
context:
space:
mode:
Diffstat (limited to 'libguile/array-map.c')
-rw-r--r--libguile/array-map.c236
1 files changed, 129 insertions, 107 deletions
diff --git a/libguile/array-map.c b/libguile/array-map.c
index 1c443ac47..245cc1ffa 100644
--- a/libguile/array-map.c
+++ b/libguile/array-map.c
@@ -1,6 +1,6 @@
/* Copyright (C) 1996, 1998, 2000, 2001, 2004, 2005, 2006, 2008, 2009,
- * 2010, 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
@@ -39,7 +39,6 @@
#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"
@@ -48,9 +47,17 @@
/* The WHAT argument for `scm_gc_malloc ()' et al. */
static const char indices_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)
@@ -85,34 +92,34 @@ scm_ra_matchp (SCM ra0, SCM ras)
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))
+ if (SCM_I_ARRAYP (ra0))
{
ndim = SCM_I_ARRAY_NDIM (ra0);
s0 = SCM_I_ARRAY_DIMS (ra0);
bas0 = SCM_I_ARRAY_BASE (ra0);
}
+ else if (scm_is_array (ra0))
+ {
+ s0->lbnd = 0;
+ s0->inc = 1;
+ s0->ubnd = scm_c_array_length (ra0) - 1;
+ }
else
return 0;
- while (SCM_NIMP (ras))
+ while (scm_is_pair (ras))
{
ra1 = SCM_CAR (ras);
-
- if (scm_is_generalized_vector (ra1))
+
+ if (!SCM_I_ARRAYP (ra1))
{
size_t length;
-
+
if (1 != ndim)
return 0;
-
- length = scm_c_generalized_vector_length (ra1);
-
+
+ length = scm_c_array_length (ra1);
+
switch (exact)
{
case 4:
@@ -130,7 +137,7 @@ scm_ra_matchp (SCM ra0, SCM ras)
return 0;
}
}
- else if (SCM_I_ARRAYP (ra1) && ndim == SCM_I_ARRAY_NDIM (ra1))
+ else if (ndim == SCM_I_ARRAY_NDIM (ra1))
{
s1 = SCM_I_ARRAY_DIMS (ra1);
if (bas0 != SCM_I_ARRAY_BASE (ra1))
@@ -176,9 +183,8 @@ scm_ramapc (void *cproc_ptr, SCM data, SCM ra0, SCM lra, const char *what)
SCM lvra, *plvra;
long *vinds;
int k, kmax;
- int (*cproc) ();
+ int (*cproc) () = cproc_ptr;
- cproc = cproc_ptr;
switch (scm_ra_matchp (ra0, lra))
{
default:
@@ -194,7 +200,7 @@ scm_ramapc (void *cproc_ptr, SCM data, SCM ra0, SCM lra, const char *what)
if (SCM_IMP (vra0)) goto gencase;
if (!SCM_I_ARRAYP (vra0))
{
- size_t length = scm_c_generalized_vector_length (vra0);
+ size_t length = scm_c_array_length (vra0);
vra1 = scm_i_make_array (1);
SCM_I_ARRAY_BASE (vra1) = 0;
SCM_I_ARRAY_DIMS (vra1)->lbnd = 0;
@@ -205,7 +211,7 @@ scm_ramapc (void *cproc_ptr, SCM data, SCM ra0, SCM lra, const char *what)
}
lvra = SCM_EOL;
plvra = &lvra;
- for (z = lra; SCM_NIMP (z); z = SCM_CDR (z))
+ for (z = lra; scm_is_pair (z); z = SCM_CDR (z))
{
ra1 = SCM_CAR (z);
vra1 = scm_i_make_array (1);
@@ -252,7 +258,7 @@ scm_ramapc (void *cproc_ptr, SCM data, SCM ra0, SCM lra, const char *what)
}
else
{
- size_t length = scm_c_generalized_vector_length (ra0);
+ size_t length = scm_c_array_length (ra0);
kmax = 0;
SCM_I_ARRAY_DIMS (vra0)->lbnd = 0;
SCM_I_ARRAY_DIMS (vra0)->ubnd = length - 1;
@@ -263,7 +269,7 @@ scm_ramapc (void *cproc_ptr, SCM data, SCM ra0, SCM lra, const char *what)
}
lvra = SCM_EOL;
plvra = &lvra;
- for (z = lra; SCM_NIMP (z); z = SCM_CDR (z))
+ for (z = lra; scm_is_pair (z); z = SCM_CDR (z))
{
ra1 = SCM_CAR (z);
vra1 = scm_i_make_array (1);
@@ -296,7 +302,7 @@ scm_ramapc (void *cproc_ptr, SCM data, SCM ra0, SCM lra, const char *what)
{
SCM y = lra;
SCM_I_ARRAY_BASE (vra0) = cind (ra0, vinds);
- for (z = lvra; SCM_NIMP (z); z = SCM_CDR (z), y = SCM_CDR (y))
+ 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;
@@ -326,8 +332,8 @@ rafill (SCM dst, SCM fill)
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;
+ i = SCM_I_ARRAY_BASE (dst);
+ inc = SCM_I_ARRAY_DIMS (dst)->inc;
for (; n-- > 0; i += inc)
h.impl->vset (&h, i, fill);
@@ -360,10 +366,10 @@ racp (SCM src, SCM 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;
+ 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;
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));
@@ -407,7 +413,7 @@ scm_array_fill_int (SCM ra, SCM fill, SCM ignore SCM_UNUSED)
ra = SCM_I_ARRAY_V (ra);
for (i = base; n--; i += inc)
- GVSET (ra, i, fill);
+ ASET (ra, i, fill);
return 1;
}
@@ -437,7 +443,7 @@ scm_ra_eqp (SCM ra0, SCM ras)
{
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);
}
@@ -470,8 +476,8 @@ ra_compare (SCM ra0, SCM ra1, SCM ra2, int opt)
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);
}
@@ -527,7 +533,7 @@ scm_ra_sum (SCM ra0, SCM ras)
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;
}
}
@@ -551,7 +557,7 @@ scm_ra_difference (SCM ra0, SCM ras)
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;
}
}
@@ -567,8 +573,7 @@ scm_ra_difference (SCM ra0, SCM ras)
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;
}
}
@@ -596,8 +601,7 @@ scm_ra_product (SCM ra0, SCM ras)
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)));
}
}
}
@@ -619,7 +623,7 @@ scm_ra_divide (SCM ra0, SCM ras)
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;
}
}
@@ -636,9 +640,8 @@ scm_ra_divide (SCM ra0, SCM ras)
{
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;
}
@@ -666,8 +669,8 @@ ramap (SCM ra0, SCM proc, SCM ras)
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;
+ i0 = SCM_I_ARRAY_BASE (ra0);
+ inc0 = SCM_I_ARRAY_DIMS (ra0)->inc;
i0end = i0 + n*inc0;
if (scm_is_null (ras))
for (; i0 < i0end; i0 += inc0)
@@ -679,8 +682,8 @@ ramap (SCM ra0, SCM proc, SCM ras)
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);
if (scm_is_null (ras))
for (; i0 < i0end; i0 += inc0, i1 += inc1)
@@ -693,7 +696,7 @@ ramap (SCM ra0, SCM proc, SCM ras)
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);
+ args = scm_cons (AREF (scm_c_vector_ref (ras, k), i), args);
h0.impl->vset (&h0, i0, scm_apply_1 (proc, h1.impl->vref (&h1, i1), args));
}
}
@@ -739,8 +742,8 @@ rafe (SCM ra0, SCM proc, SCM ras)
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;
+ i0 = SCM_I_ARRAY_BASE (ra0);
+ inc0 = SCM_I_ARRAY_DIMS (ra0)->inc;
i0end = i0 + n*inc0;
if (scm_is_null (ras))
for (; i0 < i0end; i0 += inc0)
@@ -753,7 +756,7 @@ rafe (SCM ra0, SCM proc, SCM ras)
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);
+ args = scm_cons (AREF (scm_c_vector_ref (ras, k), i), args);
scm_apply_1 (proc, h0.impl->vref (&h0, i0), args);
}
}
@@ -774,6 +777,65 @@ SCM_DEFINE (scm_array_for_each, "array-for-each", 2, 0, 1,
}
#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 v;
+ scm_array_get_handle (ra, &h);
+ v = h.array;
+ inc = h.dims[0].inc;
+ for (i = h.dims[0].lbnd, p = h.base; i <= h.dims[0].ubnd; ++i, p += inc)
+ h.impl->vset (&h, p, scm_call_1 (proc, scm_from_ulong (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)
+{
+ size_t i;
+ SCM args = SCM_EOL;
+ int j, k, kmax = SCM_I_ARRAY_NDIM (ra) - 1;
+ long *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;
+ 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);
+ ASET (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);
+}
+
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"
@@ -795,62 +857,22 @@ SCM_DEFINE (scm_array_index_map_x, "array-index-map!", 2, 0, 0,
"@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