X-Git-Url: https://git.hcoop.net/bpt/guile.git/blobdiff_plain/04023cceb7584810005906b86c876d703a0e98b5..1f47b6975a4acc980a95ba477b9d90835a7e331c:/libguile/arrays.c diff --git a/libguile/arrays.c b/libguile/arrays.c index a771739ad..4c1b824f2 100644 --- a/libguile/arrays.c +++ b/libguile/arrays.c @@ -1,6 +1,7 @@ /* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004,2005, - * 2006, 2009, 2010, 2011, 2012, 2013, 2014 Free Software Foundation, Inc. - * + * 2006, 2009, 2010, 2011, 2012, 2013, 2014, 2015 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 @@ -29,6 +30,8 @@ #include #include +#include "verify.h" + #include "libguile/_scm.h" #include "libguile/__scm.h" #include "libguile/eq.h" @@ -66,10 +69,10 @@ SCM_DEFINE (scm_shared_array_root, "shared-array-root", 1, 0, 0, "Return the root vector of a shared array.") #define FUNC_NAME s_scm_shared_array_root { - if (!scm_is_array (ra)) - scm_wrong_type_arg_msg (FUNC_NAME, SCM_ARG1, ra, "array"); - else if (SCM_I_ARRAYP (ra)) + if (SCM_I_ARRAYP (ra)) return SCM_I_ARRAY_V (ra); + else if (!scm_is_array (ra)) + scm_wrong_type_arg_msg (FUNC_NAME, SCM_ARG1, ra, "array"); else return ra; } @@ -92,7 +95,7 @@ SCM_DEFINE (scm_shared_array_offset, "shared-array-offset", 1, 0, 0, #undef FUNC_NAME -SCM_DEFINE (scm_shared_array_increments, "shared-array-increments", 1, 0, 0, +SCM_DEFINE (scm_shared_array_increments, "shared-array-increments", 1, 0, 0, (SCM ra), "For each dimension, return the distance between elements in the root vector.") #define FUNC_NAME s_scm_shared_array_increments @@ -112,15 +115,19 @@ SCM_DEFINE (scm_shared_array_increments, "shared-array-increments", 1, 0, 0, } #undef FUNC_NAME +/* FIXME: to avoid this assumption, fix the accessors in arrays.h, + scm_i_make_array, and the array cases in system/vm/assembler.scm. */ + +verify (sizeof (scm_t_array_dim) == 3*sizeof (scm_t_bits)); + +/* Matching SCM_I_ARRAY accessors in arrays.h */ SCM scm_i_make_array (int ndim) { - SCM ra; - ra = scm_cell (((scm_t_bits) ndim << 17) + scm_tc7_array, - (scm_t_bits) scm_gc_malloc (sizeof (scm_i_t_array) + - ndim * sizeof (scm_t_array_dim), - "array")); - SCM_I_ARRAY_V (ra) = SCM_BOOL_F; + SCM ra = scm_words (((scm_t_bits) ndim << 17) + scm_tc7_array, 3 + ndim*3); + SCM_I_ARRAY_SET_V (ra, SCM_BOOL_F); + SCM_I_ARRAY_SET_BASE (ra, 0); + /* dimensions are unset */ return ra; } @@ -129,42 +136,44 @@ 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); ra = scm_i_make_array (ndim); - SCM_I_ARRAY_BASE (ra) = 0; + SCM_I_ARRAY_SET_BASE (ra, 0); s = SCM_I_ARRAY_DIMS (ra); for (; !scm_is_null (args); s++, args = SCM_CDR (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; } @@ -177,7 +186,7 @@ SCM_DEFINE (scm_make_typed_array, "make-typed-array", 2, 0, 1, size_t k, rlen = 1; scm_t_array_dim *s; SCM ra; - + ra = scm_i_shap2ra (bounds); SCM_SET_ARRAY_CONTIGUOUS_FLAG (ra); s = SCM_I_ARRAY_DIMS (ra); @@ -193,8 +202,7 @@ SCM_DEFINE (scm_make_typed_array, "make-typed-array", 2, 0, 1, if (scm_is_eq (fill, SCM_UNSPECIFIED)) fill = SCM_UNDEFINED; - SCM_I_ARRAY_V (ra) = - scm_make_generalized_vector (type, scm_from_size_t (rlen), fill); + SCM_I_ARRAY_SET_V (ra, 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 (0 == s->lbnd) @@ -215,7 +223,7 @@ scm_from_contiguous_typed_array (SCM type, SCM bounds, const void *bytes, scm_t_array_handle h; void *elts; size_t sz; - + ra = scm_i_shap2ra (bounds); SCM_SET_ARRAY_CONTIGUOUS_FLAG (ra); s = SCM_I_ARRAY_DIMS (ra); @@ -227,8 +235,7 @@ scm_from_contiguous_typed_array (SCM type, SCM bounds, const void *bytes, SCM_ASSERT_RANGE (1, bounds, s[k].lbnd <= s[k].ubnd + 1); rlen = (s[k].ubnd - s[k].lbnd + 1) * s[k].inc; } - SCM_I_ARRAY_V (ra) = - scm_make_generalized_vector (type, scm_from_size_t (rlen), SCM_UNDEFINED); + SCM_I_ARRAY_SET_V (ra, scm_make_generalized_vector (type, scm_from_size_t (rlen), SCM_UNDEFINED)); scm_array_get_handle (ra, &h); @@ -271,7 +278,7 @@ scm_from_contiguous_array (SCM bounds, const SCM *elts, size_t len) scm_t_array_dim *s; SCM ra; scm_t_array_handle h; - + ra = scm_i_shap2ra (bounds); SCM_SET_ARRAY_CONTIGUOUS_FLAG (ra); s = SCM_I_ARRAY_DIMS (ra); @@ -286,7 +293,7 @@ scm_from_contiguous_array (SCM bounds, const SCM *elts, size_t len) if (rlen != len) SCM_MISC_ERROR ("element length and dimensions do not match", SCM_EOL); - SCM_I_ARRAY_V (ra) = scm_c_make_vector (rlen, SCM_UNDEFINED); + SCM_I_ARRAY_SET_V (ra, scm_c_make_vector (rlen, SCM_UNDEFINED)); scm_array_get_handle (ra, &h); memcpy (h.writable_elements, elts, rlen * sizeof(SCM)); scm_array_handle_release (&h); @@ -307,13 +314,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) @@ -321,7 +328,7 @@ scm_i_ra_set_contp (SCM ra) SCM_CLR_ARRAY_CONTIGUOUS_FLAG (ra); return; } - inc *= (SCM_I_ARRAY_DIMS (ra)[k].ubnd + inc *= (SCM_I_ARRAY_DIMS (ra)[k].ubnd - SCM_I_ARRAY_DIMS (ra)[k].lbnd + 1); } } @@ -366,7 +373,7 @@ SCM_DEFINE (scm_make_shared_array, "make-shared-array", 2, 0, 1, if (SCM_I_ARRAYP (oldra)) { - SCM_I_ARRAY_V (ra) = SCM_I_ARRAY_V (oldra); + SCM_I_ARRAY_SET_V (ra, SCM_I_ARRAY_V (oldra)); old_base = old_min = old_max = SCM_I_ARRAY_BASE (oldra); s = scm_array_handle_dims (&old_handle); k = scm_array_handle_rank (&old_handle); @@ -380,7 +387,7 @@ SCM_DEFINE (scm_make_shared_array, "make-shared-array", 2, 0, 1, } else { - SCM_I_ARRAY_V (ra) = oldra; + SCM_I_ARRAY_SET_V (ra, oldra); old_base = old_min = 0; old_max = scm_c_array_length (oldra) - 1; } @@ -389,16 +396,15 @@ SCM_DEFINE (scm_make_shared_array, "make-shared-array", 2, 0, 1, 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)) ra = scm_make_generalized_vector (scm_array_type (ra), SCM_INUM0, SCM_UNDEFINED); else - SCM_I_ARRAY_V (ra) = - scm_make_generalized_vector (scm_array_type (ra), - SCM_INUM0, SCM_UNDEFINED); + SCM_I_ARRAY_SET_V (ra, scm_make_generalized_vector (scm_array_type (ra), + SCM_INUM0, SCM_UNDEFINED)); scm_array_handle_release (&old_handle); return ra; } @@ -406,7 +412,8 @@ SCM_DEFINE (scm_make_shared_array, "make-shared-array", 2, 0, 1, imap = scm_apply_0 (mapfunc, scm_reverse (inds)); i = scm_array_handle_pos (&old_handle, imap); - SCM_I_ARRAY_BASE (ra) = new_min = new_max = i + old_base; + new_min = new_max = i + old_base; + SCM_I_ARRAY_SET_BASE (ra, new_min); indptr = inds; k = SCM_I_ARRAY_NDIM (ra); while (k--) @@ -448,7 +455,7 @@ SCM_DEFINE (scm_make_shared_array, "make-shared-array", 2, 0, 1, /* args are RA . DIMS */ -SCM_DEFINE (scm_transpose_array, "transpose-array", 1, 0, 1, +SCM_DEFINE (scm_transpose_array, "transpose-array", 1, 0, 1, (SCM ra, SCM args), "Return an array sharing contents with @var{ra}, but with\n" "dimensions arranged in a different order. There must be one\n" @@ -507,8 +514,8 @@ SCM_DEFINE (scm_transpose_array, "transpose-array", 1, 0, 1, } ndim++; res = scm_i_make_array (ndim); - SCM_I_ARRAY_V (res) = SCM_I_ARRAY_V (ra); - SCM_I_ARRAY_BASE (res) = SCM_I_ARRAY_BASE (ra); + SCM_I_ARRAY_SET_V (res, SCM_I_ARRAY_V (ra)); + SCM_I_ARRAY_SET_BASE (res, SCM_I_ARRAY_BASE (ra)); for (k = ndim; k--;) { SCM_I_ARRAY_DIMS (res)[k].lbnd = 0; @@ -532,7 +539,7 @@ SCM_DEFINE (scm_transpose_array, "transpose-array", 1, 0, 1, r->ubnd = s->ubnd; if (r->lbnd < s->lbnd) { - SCM_I_ARRAY_BASE (res) += (s->lbnd - r->lbnd) * r->inc; + SCM_I_ARRAY_SET_BASE (res, SCM_I_ARRAY_BASE (res) + (s->lbnd - r->lbnd) * r->inc); r->lbnd = s->lbnd; } r->inc += s->inc; @@ -548,8 +555,8 @@ SCM_DEFINE (scm_transpose_array, "transpose-array", 1, 0, 1, /* 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" @@ -563,15 +570,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; @@ -588,23 +593,22 @@ SCM_DEFINE (scm_array_contents, "array-contents", 1, 1, 0, } } - { - SCM v = SCM_I_ARRAY_V (ra); - size_t length = scm_c_array_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_SET_V (sra, v); + SCM_I_ARRAY_SET_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 @@ -634,11 +638,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), @@ -751,17 +755,17 @@ 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_unlocked ('#', port); - if (h.ndims != 1 || h.dims[0].lbnd != 0) + if (SCM_I_ARRAYP (array)) scm_intprint (h.ndims, 10, port); if (h.element_type != SCM_ARRAY_ELEMENT_TYPE_SCM) scm_write (scm_array_handle_element_type (&h), port); - + for (i = 0; i < h.ndims; i++) { if (h.dims[i].lbnd != 0) @@ -819,40 +823,6 @@ scm_i_print_array (SCM array, SCM port, scm_print_state *pstate) return scm_i_print_array_dimension (&h, 0, 0, port, pstate); } -static SCM -array_handle_ref (scm_t_array_handle *hh, size_t pos) -{ - return scm_c_array_ref_1 (SCM_I_ARRAY_V (hh->array), pos); -} - -static void -array_handle_set (scm_t_array_handle *hh, size_t pos, SCM val) -{ - scm_c_array_set_1_x (SCM_I_ARRAY_V (hh->array), val, pos); -} - -/* 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); - assert (vh.dims[0].inc == 1 && vh.dims[0].lbnd == 0 && vh.base == 0); - 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 () {