X-Git-Url: http://git.hcoop.net/bpt/guile.git/blobdiff_plain/ea0582c283c29e40f1eb1e85821a9c46bc386121..dd1c7decccd35dc37950310b403b8e45a658fea4:/libguile/array-map.c diff --git a/libguile/array-map.c b/libguile/array-map.c index 395fa11a0..e47fb5641 100644 --- a/libguile/array-map.c +++ b/libguile/array-map.c @@ -1,4 +1,5 @@ -/* Copyright (C) 1996,1998,2000,2001,2004,2005, 2006, 2008, 2009, 2010, 2011 Free Software Foundation, Inc. +/* Copyright (C) 1996, 1998, 2000, 2001, 2004, 2005, 2006, 2008, 2009, + * 2010, 2011, 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 @@ -317,54 +318,59 @@ scm_ramapc (void *cproc_ptr, SCM data, SCM ra0, SCM lra, const char *what) } } +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; } @@ -374,9 +380,9 @@ SCM_REGISTER_PROC(s_array_copy_in_order_x, "array-copy-in-order!", 2, 0, 0, scm_ 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 { @@ -385,8 +391,28 @@ SCM_DEFINE (scm_array_copy_x, "array-copy!", 2, 0, 0, } #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) @@ -628,37 +654,52 @@ scm_array_identity (SCM dst, SCM src) 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); - ras = scm_vector (SCM_CDR (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)); - } + 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)) + 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 (; 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; } @@ -670,12 +711,13 @@ SCM_SYMBOL (sym_b, "b"); 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); @@ -690,39 +732,38 @@ SCM_DEFINE (scm_array_map_x, "array-map!", 2, 0, 1, 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_vector (SCM_CDR (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 { @@ -735,7 +776,7 @@ SCM_DEFINE (scm_array_for_each, "array-for-each", 2, 0, 1, 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" @@ -892,7 +933,6 @@ SCM_DEFINE (scm_i_array_equal_p, "array-equal?", 0, 2, 1, void scm_init_array_map (void) { - scm_smobs[SCM_TC2SMOBNUM (scm_i_tc16_array)].equalp = scm_array_equal_p; #include "libguile/array-map.x" scm_add_feature (s_scm_array_for_each); }