X-Git-Url: https://git.hcoop.net/bpt/guile.git/blobdiff_plain/e0a00fe7e400aeb4d4314af410d43aea706cef62..cfdc8416a2540e43504a021d4f7c44c7d21a668d:/libguile/array-map.c diff --git a/libguile/array-map.c b/libguile/array-map.c index 245cc1ffa..938f0a7b9 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, 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 @@ -45,7 +45,7 @@ /* 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) @@ -59,284 +59,182 @@ 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?) */ + 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; +} - 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)) +/* Linear index of not-unrolled index set. */ +static size_t +cindk (SCM ra, ssize_t *ve, int kend) +{ + if (SCM_I_ARRAYP (ra)) { - s0->lbnd = 0; - s0->inc = 1; - s0->ubnd = scm_c_array_length (ra0) - 1; + 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; } else - return 0; - - while (scm_is_pair (ras)) - { - ra1 = SCM_CAR (ras); - - if (!SCM_I_ARRAYP (ra1)) - { - size_t length; - - if (1 != ndim) - return 0; - - length = scm_c_array_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 (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); - } - - return exact; + 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) () = cproc_ptr; + SCM z, va0, lva, *plva; + int k, kmax, kroll; + ssize_t *vi, inc; + size_t len; - switch (scm_ra_matchp (ra0, lra)) + /* Prepare reference argument. */ + if (SCM_I_ARRAYP (ra0)) { - 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_array_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_array_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); + 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); - return 1; + /* 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 + { + kroll = kmax = 0; + va0 = ra0 = make1array (ra0, 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 = 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; @@ -357,22 +255,33 @@ SCM_DEFINE (scm_array_fill_x, "array-fill!", 2, 0, 0, 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 = 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); - 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)); + 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); @@ -662,42 +571,43 @@ scm_array_identity (SCM dst, SCM src) 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); + size_t n, i0; + ssize_t i, inc0; i0 = SCM_I_ARRAY_BASE (ra0); inc0 = SCM_I_ARRAY_DIMS (ra0)->inc; - i0end = i0 + n*inc0; + 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 = 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 (AREF (scm_c_vector_ref (ras, k), i), args); - h0.impl->vset (&h0, i0, scm_apply_1 (proc, h1.impl->vref (&h1, i1), args)); + h0.vset (h0.vector, i0, + scm_apply_1 (proc, h1.vref (h1.vector, i1), args)); } } scm_array_handle_release (&h1); @@ -739,25 +649,25 @@ rafe (SCM ra0, SCM proc, SCM ras) 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 = SCM_I_ARRAY_BASE (ra0); inc0 = SCM_I_ARRAY_DIMS (ra0)->inc; - i0end = i0 + n*inc0; + 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 (AREF (scm_c_vector_ref (ras, k), i), args); - scm_apply_1 (proc, h0.impl->vref (&h0, i0), args); + scm_apply_1 (proc, h0.vref (h0.vector, i0), args); } } scm_array_handle_release (&h0); @@ -783,12 +693,10 @@ 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))); + h.vset (h.vector, p, scm_call_1 (proc, scm_from_ssize_t (i))); scm_array_handle_release (&h); } @@ -797,43 +705,56 @@ array_index_map_1 (SCM ra, SCM proc) 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; - int j, k, kmax = SCM_I_ARRAY_NDIM (ra) - 1; - long *vinds; + SCM *p = &args; - vinds = scm_gc_malloc_pointerless (sizeof(long) * SCM_I_ARRAY_NDIM (ra), - indices_gc_hint); + 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++) - vinds[k] = SCM_I_ARRAY_DIMS (ra)[k].lbnd; + { + 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) { - 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]++) + 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]) { - 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; + *(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--; - continue; } - if (vinds[k] < SCM_I_ARRAY_DIMS (ra)[k].ubnd) + else if (vi[k] < SCM_I_ARRAY_DIMS (ra)[k].ubnd) { - vinds[k]++; + *(si[k]) = scm_from_ssize_t (++vi[k]); k++; - continue; } - vinds[k] = SCM_I_ARRAY_DIMS (ra)[k].lbnd - 1; - 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, @@ -894,7 +815,7 @@ array_compare (scm_t_array_handle *hx, scm_t_array_handle *hy, 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; @@ -911,11 +832,11 @@ SCM 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); @@ -939,7 +860,7 @@ SCM_DEFINE (scm_i_array_equal_p, "array-equal?", 0, 2, 1, { 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;