diff options
Diffstat (limited to 'libguile/array-map.c')
-rw-r--r-- | libguile/array-map.c | 236 |
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 |