From f85aaa7dec597b1d45830a3d346b55f3d3cefbff Mon Sep 17 00:00:00 2001 From: Daniel Llorens Date: Wed, 20 Feb 2013 22:44:06 +0100 Subject: [PATCH] Extend array-ref, array-set! to work with cells of rank > 0 * libguile/generalized-arrays.c - scm_array_ref: if the index list comes up short, return the cell at the position computed up to then. - scm_array_set_x: if the index list comes up short, use the cell at the position computed up to then as destination for o. - s_scm_i_array_ref: branch to the optimization only if rank of v matches. - s_scm_i_array_set_x: idem. --- libguile/generalized-arrays.c | 127 ++++++++++++++++++++++++++++++++++-------- 1 file changed, 103 insertions(+), 24 deletions(-) diff --git a/libguile/generalized-arrays.c b/libguile/generalized-arrays.c index 9382e81..086019f 100644 --- a/libguile/generalized-arrays.c +++ b/libguile/generalized-arrays.c @@ -256,17 +256,49 @@ scm_c_array_ref_2 (SCM array, ssize_t idx0, ssize_t idx1) return res; } - SCM -scm_array_ref (SCM v, SCM args) +scm_array_ref (SCM a, SCM args) { - scm_t_array_handle handle; - SCM res; - - scm_array_get_handle (v, &handle); - res = scm_array_handle_ref (&handle, scm_array_handle_pos (&handle, args)); - scm_array_handle_release (&handle); - return res; + int k, arank; + ssize_t pos = 0; + SCM i = args; + SCM o; + scm_t_array_handle ah; + scm_t_array_dim * as; + scm_array_get_handle (a, &ah); + as = scm_array_handle_dims (&ah); + k = arank = scm_array_handle_rank (&ah); + for (; k>0 && scm_is_pair (i); --k, ++as, i=scm_cdr (i)) { + ssize_t ik = scm_to_ssize_t (scm_car (i)); + if (iklbnd || ik>as->ubnd) { + scm_array_handle_release (&ah); + scm_out_of_range (NULL, scm_list_2 (a, args)); + } + pos += (ik-as->lbnd)*as->inc; + } + if (k>0) { + if (k==arank) { + o = a; + } else { + scm_t_array_dim * os; + o = scm_i_make_array (k); + SCM_I_ARRAY_V (o) = SCM_I_ARRAY_V (a); + SCM_I_ARRAY_BASE (o) = pos + SCM_I_ARRAY_BASE (a); /* since arank>1. */ + os = SCM_I_ARRAY_DIMS (o); + for (; k>0; --k, ++as, ++os) { + os->ubnd = as->ubnd; + os->lbnd = as->lbnd; + os->inc = as->inc; + } + } + } else if (scm_is_null (i)) { + o = scm_array_handle_ref (&ah, pos); /* these may be non-arrays. */ + } else { + scm_array_handle_release (&ah); + scm_misc_error (NULL, "too many indices", scm_list_2 (a, args)); + } + scm_array_handle_release (&ah); + return o; } @@ -295,29 +327,70 @@ scm_c_array_set_2_x (SCM array, SCM obj, ssize_t idx0, ssize_t idx1) SCM -scm_array_set_x (SCM v, SCM obj, SCM args) +scm_array_set_x (SCM a, SCM o, SCM args) { - scm_t_array_handle handle; - - scm_array_get_handle (v, &handle); - scm_array_handle_set (&handle, scm_array_handle_pos (&handle, args), obj); - scm_array_handle_release (&handle); + int k, arank; + ssize_t pos = 0; + SCM i = args; + scm_t_array_handle ah; + scm_t_array_dim * as; + scm_array_get_handle (a, &ah); + as = scm_array_handle_dims (&ah); + k = arank = scm_array_handle_rank (&ah); + for (; k>0 && scm_is_pair (i); --k, ++as, i=scm_cdr (i)) { + ssize_t ik = scm_to_ssize_t (scm_car (i)); + if (iklbnd || ik>as->ubnd) { + scm_array_handle_release (&ah); + scm_misc_error (NULL, "out of range", scm_list_2 (a, args)); + } + pos += (ik-as->lbnd)*as->inc; + } + if (k>0) { + SCM ai; + if (k==arank) { + ai = a; + } else { + scm_t_array_dim * ais; + ai = scm_i_make_array (k); + SCM_I_ARRAY_V (ai) = SCM_I_ARRAY_V (a); + SCM_I_ARRAY_BASE (ai) = pos + SCM_I_ARRAY_BASE (a); /* since arank>1. */ + ais = SCM_I_ARRAY_DIMS (ai); + for (; k>0; --k, ++as, ++ais) { + ais->ubnd = as->ubnd; + ais->lbnd = as->lbnd; + ais->inc = as->inc; + } + } + /* an error is still possible here if o and ai don't match. */ + scm_array_copy_x (o, ai); + } else if (scm_is_null(i)) { + scm_array_handle_set (&ah, pos, o); + } else { + scm_array_handle_release (&ah); + scm_misc_error (NULL, "too many indices", scm_list_2 (a, args)); + } return SCM_UNSPECIFIED; } SCM_DEFINE (scm_i_array_ref, "array-ref", 1, 2, 1, (SCM v, SCM idx0, SCM idx1, SCM idxN), - "Return the element at the @code{(idx0, idx1, idxN...)}\n" - "position in array @var{v}.") + "Return the rank-(n-k) cell at the @code{(idx0 idx1 .. idx(k-1))}\n" + "position in n-rank array @var{v}.") #define FUNC_NAME s_scm_i_array_ref { if (SCM_UNBNDP (idx0)) return scm_array_ref (v, SCM_EOL); else if (SCM_UNBNDP (idx1)) - return scm_c_array_ref_1 (v, scm_to_ssize_t (idx0)); + if (scm_c_array_rank (v)==1) + return scm_c_array_ref_1 (v, scm_to_ssize_t (idx0)); + else + return scm_array_ref (v, scm_cons (idx0, SCM_EOL)); else if (scm_is_null (idxN)) - return scm_c_array_ref_2 (v, scm_to_ssize_t (idx0), scm_to_ssize_t (idx1)); + if (scm_c_array_rank (v)==2) + return scm_c_array_ref_2 (v, scm_to_ssize_t (idx0), scm_to_ssize_t (idx1)); + else + return scm_array_ref (v, scm_cons (idx0, scm_cons (idx1, SCM_EOL))); else return scm_array_ref (v, scm_cons (idx0, scm_cons (idx1, idxN))); } @@ -326,17 +399,23 @@ SCM_DEFINE (scm_i_array_ref, "array-ref", 1, 2, 1, SCM_DEFINE (scm_i_array_set_x, "array-set!", 2, 2, 1, (SCM v, SCM obj, SCM idx0, SCM idx1, SCM idxN), - "Set the element at the @code{(idx0, idx1, idxN...)} position\n" - "in the array @var{v} to @var{obj}. The value returned by\n" - "@code{array-set!} is unspecified.") + "Set the rank-(n-k) cell at the @code{(idx0 idx1 .. idx(k-1))}\n" + "position in the n-rank array @var{v} to the k-rank array\n" + "@var{obj}. The value returned is unspecified.") #define FUNC_NAME s_scm_i_array_set_x { if (SCM_UNBNDP (idx0)) scm_array_set_x (v, obj, SCM_EOL); else if (SCM_UNBNDP (idx1)) - scm_c_array_set_1_x (v, obj, scm_to_ssize_t (idx0)); + if (scm_c_array_rank (v)==1) + scm_c_array_set_1_x (v, obj, scm_to_ssize_t (idx0)); + else + scm_array_set_x (v, obj, scm_cons (idx0, SCM_EOL)); else if (scm_is_null (idxN)) - scm_c_array_set_2_x (v, obj, scm_to_ssize_t (idx0), scm_to_ssize_t (idx1)); + if (scm_c_array_rank (v)==2) + scm_c_array_set_2_x (v, obj, scm_to_ssize_t (idx0), scm_to_ssize_t (idx1)); + else + scm_array_set_x (v, obj, scm_cons (idx0, scm_cons (idx1, SCM_EOL))); else scm_array_set_x (v, obj, scm_cons (idx0, scm_cons (idx1, idxN))); -- 1.8.1.1