X-Git-Url: http://git.hcoop.net/bpt/guile.git/blobdiff_plain/ae9c16e89565f997936778a710d5addf1ec256c2..47612fd68ae93815c08a92b504f9334b224c557e:/libguile/arrays.c diff --git a/libguile/arrays.c b/libguile/arrays.c index 98c8075e9..9e5715cf1 100644 --- a/libguile/arrays.c +++ b/libguile/arrays.c @@ -1,6 +1,6 @@ /* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004,2005, - * 2006, 2009, 2010, 2011, 2012, 2013 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 * as published by the Free Software Foundation; either version 3 of @@ -27,6 +27,9 @@ #include #include #include +#include + +#include "verify.h" #include "libguile/_scm.h" #include "libguile/__scm.h" @@ -60,21 +63,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 @@ -90,7 +94,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 @@ -110,15 +114,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; } @@ -127,42 +135,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; } @@ -175,7 +185,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); @@ -191,12 +201,12 @@ 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 (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 @@ -212,7 +222,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); @@ -224,8 +234,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); @@ -254,7 +263,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; } @@ -268,7 +277,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); @@ -283,13 +292,13 @@ 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); 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; } @@ -304,13 +313,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) @@ -318,7 +327,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); } } @@ -363,7 +372,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); @@ -377,25 +386,24 @@ 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_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)) 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; } @@ -403,7 +411,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--) @@ -431,7 +440,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) @@ -445,7 +454,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" @@ -475,20 +484,22 @@ SCM_DEFINE (scm_transpose_array, "transpose-array", 1, 0, 1, SCM_VALIDATE_REST_ARGUMENT (args); 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 (); @@ -502,8 +513,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; @@ -527,7 +538,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; @@ -538,15 +549,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" @@ -560,15 +569,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; @@ -584,24 +591,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_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 @@ -631,11 +637,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), @@ -748,7 +754,7 @@ 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); @@ -758,7 +764,7 @@ scm_i_print_array (SCM array, SCM port, scm_print_state *pstate) 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) @@ -816,39 +822,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 *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 () {