diff options
Diffstat (limited to 'libguile/arrays.c')
-rw-r--r-- | libguile/arrays.c | 182 |
1 files changed, 76 insertions, 106 deletions
diff --git a/libguile/arrays.c b/libguile/arrays.c index 1eb10b981..702faacbe 100644 --- a/libguile/arrays.c +++ b/libguile/arrays.c @@ -1,5 +1,5 @@ /* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004,2005, - * 2006, 2009, 2010, 2011, 2012 Free Software Foundation, Inc. + * 2006, 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 @@ -27,6 +27,7 @@ #include <stdio.h> #include <errno.h> #include <string.h> +#include <assert.h> #include "libguile/_scm.h" #include "libguile/__scm.h" @@ -60,21 +61,22 @@ (SCM_SET_CELL_WORD_0 ((x), SCM_CELL_WORD_0 (x) & ~(SCM_I_ARRAY_FLAG_CONTIGUOUS << 16))) -SCM_DEFINE (scm_shared_array_root, "shared-array-root", 1, 0, 0, +SCM_DEFINE (scm_shared_array_root, "shared-array-root", 1, 0, 0, (SCM ra), "Return the root vector of a shared array.") #define FUNC_NAME s_scm_shared_array_root { if (SCM_I_ARRAYP (ra)) return SCM_I_ARRAY_V (ra); - else if (scm_is_generalized_vector (ra)) + else if (!scm_is_array (ra)) + scm_wrong_type_arg_msg (FUNC_NAME, SCM_ARG1, ra, "array"); + else return ra; - scm_wrong_type_arg_msg (FUNC_NAME, SCM_ARG1, ra, "array"); } #undef FUNC_NAME -SCM_DEFINE (scm_shared_array_offset, "shared-array-offset", 1, 0, 0, +SCM_DEFINE (scm_shared_array_offset, "shared-array-offset", 1, 0, 0, (SCM ra), "Return the root vector index of the first element in the array.") #define FUNC_NAME s_scm_shared_array_offset @@ -127,11 +129,11 @@ static char s_bad_spec[] = "Bad scm_array dimension"; /* Increments will still need to be set. */ -static SCM +static SCM scm_i_shap2ra (SCM args) { scm_t_array_dim *s; - SCM ra, spec, sp; + SCM ra, spec; int ndim = scm_ilength (args); if (ndim < 0) scm_misc_error (NULL, s_bad_spec, SCM_EOL); @@ -144,25 +146,27 @@ scm_i_shap2ra (SCM args) spec = SCM_CAR (args); if (scm_is_integer (spec)) { - if (scm_to_long (spec) < 0) - scm_misc_error (NULL, s_bad_spec, SCM_EOL); s->lbnd = 0; - s->ubnd = scm_to_long (spec) - 1; - s->inc = 1; + s->ubnd = scm_to_ssize_t (spec); + if (s->ubnd < 0) + scm_misc_error (NULL, s_bad_spec, SCM_EOL); + --s->ubnd; } else { if (!scm_is_pair (spec) || !scm_is_integer (SCM_CAR (spec))) scm_misc_error (NULL, s_bad_spec, SCM_EOL); - s->lbnd = scm_to_long (SCM_CAR (spec)); - sp = SCM_CDR (spec); - if (!scm_is_pair (sp) - || !scm_is_integer (SCM_CAR (sp)) - || !scm_is_null (SCM_CDR (sp))) + s->lbnd = scm_to_ssize_t (SCM_CAR (spec)); + spec = SCM_CDR (spec); + if (!scm_is_pair (spec) + || !scm_is_integer (SCM_CAR (spec)) + || !scm_is_null (SCM_CDR (spec))) scm_misc_error (NULL, s_bad_spec, SCM_EOL); - s->ubnd = scm_to_long (SCM_CAR (sp)); - s->inc = 1; + s->ubnd = scm_to_ssize_t (SCM_CAR (spec)); + if (s->ubnd - s->lbnd < -1) + scm_misc_error (NULL, s_bad_spec, SCM_EOL); } + s->inc = 1; } return ra; } @@ -195,8 +199,9 @@ SCM_DEFINE (scm_make_typed_array, "make-typed-array", 2, 0, 1, scm_make_generalized_vector (type, scm_from_size_t (rlen), fill); if (1 == SCM_I_ARRAY_NDIM (ra) && 0 == SCM_I_ARRAY_BASE (ra)) - if (s->ubnd < s->lbnd || (0 == s->lbnd && 1 == s->inc)) + if (0 == s->lbnd) return SCM_I_ARRAY_V (ra); + return ra; } #undef FUNC_NAME @@ -242,8 +247,9 @@ scm_from_contiguous_typed_array (SCM type, SCM bounds, const void *bytes, } else if (sz < 8) { - /* byte_len ?= ceil (rlen * sz / 8) */ - if (byte_len != (rlen * sz + 7) / 8) + /* Elements of sub-byte size (bitvectors) are addressed in 32-bit + units. */ + if (byte_len != ((rlen * sz + 31) / 32) * 4) SCM_MISC_ERROR ("byte length and dimensions do not match", SCM_EOL); } else @@ -253,7 +259,7 @@ scm_from_contiguous_typed_array (SCM type, SCM bounds, const void *bytes, memcpy (elts, bytes, byte_len); if (1 == SCM_I_ARRAY_NDIM (ra) && 0 == SCM_I_ARRAY_BASE (ra)) - if (s->ubnd < s->lbnd || (0 == s->lbnd && 1 == s->inc)) + if (0 == s->lbnd) return SCM_I_ARRAY_V (ra); return ra; } @@ -288,7 +294,7 @@ scm_from_contiguous_array (SCM bounds, const SCM *elts, size_t len) scm_array_handle_release (&h); if (1 == SCM_I_ARRAY_NDIM (ra) && 0 == SCM_I_ARRAY_BASE (ra)) - if (s->ubnd < s->lbnd || (0 == s->lbnd && 1 == s->inc)) + if (0 == s->lbnd) return SCM_I_ARRAY_V (ra); return ra; } @@ -303,13 +309,13 @@ SCM_DEFINE (scm_make_array, "make-array", 1, 0, 1, } #undef FUNC_NAME -static void +static void scm_i_ra_set_contp (SCM ra) { size_t k = SCM_I_ARRAY_NDIM (ra); if (k) { - long inc = SCM_I_ARRAY_DIMS (ra)[k - 1].inc; + ssize_t inc = SCM_I_ARRAY_DIMS (ra)[k - 1].inc; while (k--) { if (inc != SCM_I_ARRAY_DIMS (ra)[k].inc) @@ -378,14 +384,14 @@ SCM_DEFINE (scm_make_shared_array, "make-shared-array", 2, 0, 1, { SCM_I_ARRAY_V (ra) = oldra; old_base = old_min = 0; - old_max = scm_c_generalized_vector_length (oldra) - 1; + old_max = scm_c_array_length (oldra) - 1; } inds = SCM_EOL; s = SCM_I_ARRAY_DIMS (ra); for (k = 0; k < SCM_I_ARRAY_NDIM (ra); k++) { - inds = scm_cons (scm_from_long (s[k].lbnd), inds); + inds = scm_cons (scm_from_ssize_t (s[k].lbnd), inds); if (s[k].ubnd < s[k].lbnd) { if (1 == SCM_I_ARRAY_NDIM (ra)) @@ -430,7 +436,7 @@ SCM_DEFINE (scm_make_shared_array, "make-shared-array", 2, 0, 1, if (1 == SCM_I_ARRAY_NDIM (ra) && 0 == SCM_I_ARRAY_BASE (ra)) { SCM v = SCM_I_ARRAY_V (ra); - size_t length = scm_c_generalized_vector_length (v); + size_t length = scm_c_array_length (v); if (1 == s->inc && 0 == s->lbnd && length == 1 + s->ubnd) return v; if (s->ubnd < s->lbnd) @@ -472,22 +478,24 @@ SCM_DEFINE (scm_transpose_array, "transpose-array", 1, 0, 1, int ndim, i, k; SCM_VALIDATE_REST_ARGUMENT (args); - SCM_ASSERT (SCM_NIMP (ra), ra, SCM_ARG1, FUNC_NAME); + SCM_ASSERT (SCM_HEAP_OBJECT_P (ra), ra, SCM_ARG1, FUNC_NAME); - if (scm_is_generalized_vector (ra)) + switch (scm_c_array_rank (ra)) { + case 0: + if (!scm_is_null (args)) + SCM_WRONG_NUM_ARGS (); + return ra; + case 1: /* Make sure that we are called with a single zero as - arguments. + arguments. */ if (scm_is_null (args) || !scm_is_null (SCM_CDR (args))) SCM_WRONG_NUM_ARGS (); SCM_VALIDATE_INT_COPY (SCM_ARG2, SCM_CAR (args), i); SCM_ASSERT_RANGE (SCM_ARG2, SCM_CAR (args), i == 0); return ra; - } - - if (SCM_I_ARRAYP (ra)) - { + default: vargs = scm_vector (args); if (SCM_SIMPLE_VECTOR_LENGTH (vargs) != SCM_I_ARRAY_NDIM (ra)) SCM_WRONG_NUM_ARGS (); @@ -537,15 +545,13 @@ SCM_DEFINE (scm_transpose_array, "transpose-array", 1, 0, 1, scm_i_ra_set_contp (res); return res; } - - scm_wrong_type_arg_msg (NULL, 0, ra, "array"); } #undef FUNC_NAME /* attempts to unroll an array into a one-dimensional array. returns the unrolled array or #f if it can't be done. */ - /* if strict is not SCM_UNDEFINED, return #f if returned array - wouldn't have contiguous elements. */ +/* if strict is true, return #f if returned array + wouldn't have contiguous elements. */ SCM_DEFINE (scm_array_contents, "array-contents", 1, 1, 0, (SCM ra, SCM strict), "If @var{ra} may be @dfn{unrolled} into a one dimensional shared\n" @@ -559,15 +565,13 @@ SCM_DEFINE (scm_array_contents, "array-contents", 1, 1, 0, "contiguous in memory.") #define FUNC_NAME s_scm_array_contents { - SCM sra; - - if (scm_is_generalized_vector (ra)) - return ra; - - if (SCM_I_ARRAYP (ra)) + if (!scm_is_array (ra)) + scm_wrong_type_arg_msg (NULL, 0, ra, "array"); + else if (SCM_I_ARRAYP (ra)) { + SCM v; size_t k, ndim = SCM_I_ARRAY_NDIM (ra), len = 1; - if (!SCM_I_ARRAYP (ra) || !SCM_I_ARRAY_CONTP (ra)) + if (!SCM_I_ARRAY_CONTP (ra)) return SCM_BOOL_F; for (k = 0; k < ndim; k++) len *= SCM_I_ARRAY_DIMS (ra)[k].ubnd - SCM_I_ARRAY_DIMS (ra)[k].lbnd + 1; @@ -583,24 +587,23 @@ SCM_DEFINE (scm_array_contents, "array-contents", 1, 1, 0, return SCM_BOOL_F; } } - - { - SCM v = SCM_I_ARRAY_V (ra); - size_t length = scm_c_generalized_vector_length (v); - if ((len == length) && 0 == SCM_I_ARRAY_BASE (ra) && SCM_I_ARRAY_DIMS (ra)->inc) - return v; - } - - sra = scm_i_make_array (1); - SCM_I_ARRAY_DIMS (sra)->lbnd = 0; - SCM_I_ARRAY_DIMS (sra)->ubnd = len - 1; - SCM_I_ARRAY_V (sra) = SCM_I_ARRAY_V (ra); - SCM_I_ARRAY_BASE (sra) = SCM_I_ARRAY_BASE (ra); - SCM_I_ARRAY_DIMS (sra)->inc = (ndim ? SCM_I_ARRAY_DIMS (ra)[ndim - 1].inc : 1); - return sra; + + v = SCM_I_ARRAY_V (ra); + if ((len == scm_c_array_length (v)) && (0 == SCM_I_ARRAY_BASE (ra))) + return v; + else + { + SCM sra = scm_i_make_array (1); + SCM_I_ARRAY_DIMS (sra)->lbnd = 0; + SCM_I_ARRAY_DIMS (sra)->ubnd = len - 1; + SCM_I_ARRAY_V (sra) = v; + SCM_I_ARRAY_BASE (sra) = SCM_I_ARRAY_BASE (ra); + SCM_I_ARRAY_DIMS (sra)->inc = (ndim ? SCM_I_ARRAY_DIMS (ra)[ndim - 1].inc : 1); + return sra; + } } else - scm_wrong_type_arg_msg (NULL, 0, ra, "array"); + return ra; } #undef FUNC_NAME @@ -630,11 +633,11 @@ list_to_array (SCM lst, scm_t_array_handle *handle, ssize_t pos, size_t k) if (!scm_is_null (lst)) errmsg = "too many elements for array dimension ~a, want ~a"; if (errmsg) - scm_misc_error (NULL, errmsg, scm_list_2 (scm_from_ulong (k), + scm_misc_error (NULL, errmsg, scm_list_2 (scm_from_size_t (k), scm_from_size_t (len))); } } - + SCM_DEFINE (scm_list_to_typed_array, "list->typed-array", 3, 0, 0, (SCM type, SCM shape, SCM lst), @@ -727,15 +730,15 @@ scm_i_print_array_dimension (scm_t_array_handle *h, int dim, int pos, else { ssize_t i; - scm_putc ('(', port); + scm_putc_unlocked ('(', port); for (i = h->dims[dim].lbnd; i <= h->dims[dim].ubnd; i++, pos += h->dims[dim].inc) { scm_i_print_array_dimension (h, dim+1, pos, port, pstate); if (i < h->dims[dim].ubnd) - scm_putc (' ', port); + scm_putc_unlocked (' ', port); } - scm_putc (')', port); + scm_putc_unlocked (')', port); } return 1; } @@ -747,12 +750,12 @@ int scm_i_print_array (SCM array, SCM port, scm_print_state *pstate) { scm_t_array_handle h; - long i; + size_t i; int print_lbnds = 0, zero_size = 0, print_lens = 0; scm_array_get_handle (array, &h); - scm_putc ('#', port); + scm_putc_unlocked ('#', port); if (h.ndims != 1 || h.dims[0].lbnd != 0) scm_intprint (h.ndims, 10, port); if (h.element_type != SCM_ARRAY_ELEMENT_TYPE_SCM) @@ -773,12 +776,12 @@ scm_i_print_array (SCM array, SCM port, scm_print_state *pstate) { if (print_lbnds) { - scm_putc ('@', port); + scm_putc_unlocked ('@', port); scm_intprint (h.dims[i].lbnd, 10, port); } if (print_lens) { - scm_putc (':', port); + scm_putc_unlocked (':', port); scm_intprint (h.dims[i].ubnd - h.dims[i].lbnd + 1, 10, port); } @@ -806,48 +809,15 @@ scm_i_print_array (SCM array, SCM port, scm_print_state *pstate) not really the same as Scheme values since they are boxed and can be modified with array-set!, say. */ - scm_putc ('(', port); + scm_putc_unlocked ('(', port); scm_i_print_array_dimension (&h, 0, 0, port, pstate); - scm_putc (')', port); + scm_putc_unlocked (')', port); return 1; } else return scm_i_print_array_dimension (&h, 0, 0, port, pstate); } -static SCM -array_handle_ref (scm_t_array_handle *h, size_t pos) -{ - return scm_c_generalized_vector_ref (SCM_I_ARRAY_V (h->array), pos); -} - -static void -array_handle_set (scm_t_array_handle *h, size_t pos, SCM val) -{ - scm_c_generalized_vector_set_x (SCM_I_ARRAY_V (h->array), pos, val); -} - -/* FIXME: should be handle for vect? maybe not, because of dims */ -static void -array_get_handle (SCM array, scm_t_array_handle *h) -{ - scm_t_array_handle vh; - scm_array_get_handle (SCM_I_ARRAY_V (array), &vh); - h->element_type = vh.element_type; - h->elements = vh.elements; - h->writable_elements = vh.writable_elements; - scm_array_handle_release (&vh); - - h->dims = SCM_I_ARRAY_DIMS (array); - h->ndims = SCM_I_ARRAY_NDIM (array); - h->base = SCM_I_ARRAY_BASE (array); -} - -SCM_ARRAY_IMPLEMENTATION (scm_tc7_array, - 0x7f, - array_handle_ref, array_handle_set, - array_get_handle) - void scm_init_arrays () { |