diff options
author | Marius Vollmer <mvo@zagadka.de> | 2005-01-09 17:45:59 +0000 |
---|---|---|
committer | Marius Vollmer <mvo@zagadka.de> | 2005-01-09 17:45:59 +0000 |
commit | bcbbea0e2f81731f1296cd990a6f9875c6390421 (patch) | |
tree | f51563f177d3a5c89b9c26a6399bf6914b417195 /libguile/unif.c | |
parent | 7c2ef9a87be97c259f729b86fb8d5cef1882f3f3 (diff) | |
download | guile-bcbbea0e2f81731f1296cd990a6f9875c6390421.tar.gz |
(scm_array_handle_set): Correctly execute only one
alternative. D'Oh!
(scm_list_to_typed_array, l2ra): Use scm_t_array_handle to fill
the array; this covers all cases with much simpler code.
Diffstat (limited to 'libguile/unif.c')
-rw-r--r-- | libguile/unif.c | 76 |
1 files changed, 27 insertions, 49 deletions
diff --git a/libguile/unif.c b/libguile/unif.c index ebf9120c0..85ab391c9 100644 --- a/libguile/unif.c +++ b/libguile/unif.c @@ -313,9 +313,10 @@ scm_array_handle_set (scm_t_array_handle *h, ssize_t pos, SCM val) pos += h->base; if (SCM_ARRAYP (h->array)) scm_c_generalized_vector_set_x (SCM_ARRAY_V (h->array), pos, val); - if (SCM_ENCLOSED_ARRAYP (h->array)) + else if (SCM_ENCLOSED_ARRAYP (h->array)) scm_wrong_type_arg_msg (NULL, 0, h->array, "non-enclosed array"); - scm_c_generalized_vector_set_x (h->array, pos, val); + else + scm_c_generalized_vector_set_x (h->array, pos, val); } const SCM * @@ -2246,7 +2247,7 @@ SCM_DEFINE (scm_array_to_list, "array->list", 1, 0, 0, #undef FUNC_NAME -static int l2ra(SCM lst, SCM ra, unsigned long base, unsigned long k); +static void l2ra (SCM lst, scm_t_array_handle *handle, ssize_t pos, size_t k); SCM_DEFINE (scm_list_to_typed_array, "list->typed-array", 3, 0, 0, (SCM type, SCM ndim, SCM lst), @@ -2262,7 +2263,7 @@ SCM_DEFINE (scm_list_to_typed_array, "list->typed-array", 3, 0, 0, { SCM shape, row; SCM ra; - unsigned long k; + scm_t_array_handle handle; shape = SCM_EOL; row = lst; @@ -2296,24 +2297,11 @@ SCM_DEFINE (scm_list_to_typed_array, "list->typed-array", 3, 0, 0, ra = scm_make_typed_array (type, SCM_UNSPECIFIED, scm_reverse_x (shape, SCM_EOL)); - if (scm_is_null (shape)) - { - SCM_ASRTGO (1 == scm_ilength (lst), badlst); - scm_array_set_x (ra, SCM_CAR (lst), SCM_EOL); - return ra; - } - if (!SCM_ARRAYP (ra)) - { - size_t length = scm_c_generalized_vector_length (ra); - for (k = 0; k < length; k++, lst = SCM_CDR (lst)) - scm_c_generalized_vector_set_x (ra, k, SCM_CAR (lst)); - return ra; - } - if (l2ra (lst, ra, SCM_ARRAY_BASE (ra), 0)) - return ra; - else - badlst:SCM_MISC_ERROR ("Bad scm_array contents list: ~S", - scm_list_1 (lst)); + scm_array_get_handle (ra, &handle); + l2ra (lst, &handle, 0, 0); + scm_array_handle_release (&handle); + + return ra; } #undef FUNC_NAME @@ -2326,41 +2314,31 @@ SCM_DEFINE (scm_list_to_array, "list->array", 2, 0, 0, } #undef FUNC_NAME -static int -l2ra (SCM lst, SCM ra, unsigned long base, unsigned long k) +static void +l2ra (SCM lst, scm_t_array_handle *handle, ssize_t pos, size_t k) { - register long inc = SCM_ARRAY_DIMS (ra)[k].inc; - register long n = (1 + SCM_ARRAY_DIMS (ra)[k].ubnd - SCM_ARRAY_DIMS (ra)[k].lbnd); - int ok = 1; - if (n <= 0) - return (scm_is_null (lst)); - if (k < SCM_ARRAY_NDIM (ra) - 1) - { - while (n--) - { - if (!scm_is_pair (lst)) - return 0; - ok = ok && l2ra (SCM_CAR (lst), ra, base, k + 1); - base += inc; - lst = SCM_CDR (lst); - } - if (!scm_is_null (lst)) - return 0; - } + if (k == scm_array_handle_rank (handle)) + scm_array_handle_set (handle, pos, lst); else { - while (n--) + scm_t_array_dim *dim = scm_array_handle_dims (handle) + k; + ssize_t inc = dim->inc; + size_t n = 1 + dim->ubnd - dim->lbnd; + + while (n > 0 && scm_is_pair (lst)) { - if (!scm_is_pair (lst)) - return 0; - scm_array_set_x (SCM_ARRAY_V (ra), SCM_CAR (lst), scm_from_ulong (base)); - base += inc; + l2ra (SCM_CAR (lst), handle, pos, k + 1); + pos += inc; lst = SCM_CDR (lst); + n -= 1; } + if (n != 0) + scm_misc_error (NULL, "too few elements for array dimension ~a", + scm_list_1 (scm_from_ulong (k))); if (!scm_is_null (lst)) - return 0; + scm_misc_error (NULL, "too many elements for array dimension ~a", + scm_list_1 (scm_from_ulong (k))); } - return ok; } #if SCM_ENABLE_DEPRECATED |