diff options
Diffstat (limited to 'libguile/arrays.c')
-rw-r--r-- | libguile/arrays.c | 1156 |
1 files changed, 1156 insertions, 0 deletions
diff --git a/libguile/arrays.c b/libguile/arrays.c new file mode 100644 index 000000000..2be9ec3f0 --- /dev/null +++ b/libguile/arrays.c @@ -0,0 +1,1156 @@ +/* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004, 2005, 2006, 2009 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 + * the License, or (at your option) any later version. + * + * This library is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this library; if not, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA + */ + + + + +#ifdef HAVE_CONFIG_H +# include <config.h> +#endif + +#include <stdio.h> +#include <errno.h> +#include <string.h> + +#include "libguile/_scm.h" +#include "libguile/__scm.h" +#include "libguile/eq.h" +#include "libguile/chars.h" +#include "libguile/eval.h" +#include "libguile/fports.h" +#include "libguile/smob.h" +#include "libguile/feature.h" +#include "libguile/root.h" +#include "libguile/strings.h" +#include "libguile/srfi-13.h" +#include "libguile/srfi-4.h" +#include "libguile/vectors.h" +#include "libguile/bitvectors.h" +#include "libguile/bytevectors.h" +#include "libguile/list.h" +#include "libguile/dynwind.h" +#include "libguile/read.h" + +#include "libguile/validate.h" +#include "libguile/arrays.h" +#include "libguile/array-map.h" +#include "libguile/generalized-vectors.h" +#include "libguile/generalized-arrays.h" +#include "libguile/uniform.h" + + +scm_t_bits scm_i_tc16_array; +#define SCM_SET_ARRAY_CONTIGUOUS_FLAG(x) \ + (SCM_SET_CELL_WORD_0 ((x), SCM_CELL_WORD_0 (x) | SCM_I_ARRAY_FLAG_CONTIGUOUS)) +#define SCM_CLR_ARRAY_CONTIGUOUS_FLAG(x) \ + (SCM_SET_CELL_WORD_0 ((x), SCM_CELL_WORD_0 (x) & ~SCM_I_ARRAY_FLAG_CONTIGUOUS)) + + +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)) + 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 ra), + "Return the root vector index of the first element in the array.") +#define FUNC_NAME s_scm_shared_array_offset +{ + scm_t_array_handle handle; + SCM res; + + scm_array_get_handle (ra, &handle); + res = scm_from_size_t (handle.base); + scm_array_handle_release (&handle); + return res; +} +#undef FUNC_NAME + + +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 +{ + scm_t_array_handle handle; + SCM res = SCM_EOL; + size_t k; + scm_t_array_dim *s; + + scm_array_get_handle (ra, &handle); + k = scm_array_handle_rank (&handle); + s = scm_array_handle_dims (&handle); + while (k--) + res = scm_cons (scm_from_ssize_t (s[k].inc), res); + scm_array_handle_release (&handle); + return res; +} +#undef FUNC_NAME + +SCM +scm_i_make_array (int ndim) +{ + SCM ra; + SCM_NEWSMOB(ra, ((scm_t_bits) ndim << 17) + scm_i_tc16_array, + scm_gc_malloc ((sizeof (scm_i_t_array) + + ndim * sizeof (scm_t_array_dim)), + "array")); + SCM_I_ARRAY_V (ra) = SCM_BOOL_F; + return ra; +} + +static char s_bad_spec[] = "Bad scm_array dimension"; + + +/* Increments will still need to be set. */ + +static SCM +scm_i_shap2ra (SCM args) +{ + scm_t_array_dim *s; + SCM ra, spec, sp; + 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; + 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; + } + 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))) + scm_misc_error (NULL, s_bad_spec, SCM_EOL); + s->ubnd = scm_to_long (SCM_CAR (sp)); + s->inc = 1; + } + } + return ra; +} + +SCM_DEFINE (scm_make_typed_array, "make-typed-array", 2, 0, 1, + (SCM type, SCM fill, SCM bounds), + "Create and return an array of type @var{type}.") +#define FUNC_NAME s_scm_make_typed_array +{ + 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); + k = SCM_I_ARRAY_NDIM (ra); + + while (k--) + { + s[k].inc = rlen; + SCM_ASSERT_RANGE (1, bounds, s[k].lbnd <= s[k].ubnd + 1); + rlen = (s[k].ubnd - s[k].lbnd + 1) * s[k].inc; + } + + 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); + + if (1 == SCM_I_ARRAY_NDIM (ra) && 0 == SCM_I_ARRAY_BASE (ra)) + if (s->ubnd < s->lbnd || (0 == s->lbnd && 1 == s->inc)) + return SCM_I_ARRAY_V (ra); + return ra; +} +#undef FUNC_NAME + +SCM +scm_from_contiguous_typed_array (SCM type, SCM bounds, const void *bytes, + size_t byte_len) +#define FUNC_NAME "scm_from_contiguous_typed_array" +{ + size_t k, rlen = 1; + scm_t_array_dim *s; + SCM ra; + scm_t_array_handle h; + void *base; + size_t sz; + + ra = scm_i_shap2ra (bounds); + SCM_SET_ARRAY_CONTIGUOUS_FLAG (ra); + s = SCM_I_ARRAY_DIMS (ra); + k = SCM_I_ARRAY_NDIM (ra); + + while (k--) + { + s[k].inc = rlen; + 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_array_get_handle (ra, &h); + base = scm_array_handle_uniform_writable_elements (&h); + sz = scm_array_handle_uniform_element_size (&h); + scm_array_handle_release (&h); + + if (byte_len % sz) + SCM_MISC_ERROR ("byte length not a multiple of the unit size", SCM_EOL); + if (byte_len / sz != rlen) + SCM_MISC_ERROR ("byte length and dimensions do not match", SCM_EOL); + + memcpy (base, 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)) + return SCM_I_ARRAY_V (ra); + return ra; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_make_array, "make-array", 1, 0, 1, + (SCM fill, SCM bounds), + "Create and return an array.") +#define FUNC_NAME s_scm_make_array +{ + return scm_make_typed_array (SCM_BOOL_T, fill, bounds); +} +#undef FUNC_NAME + +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; + while (k--) + { + if (inc != SCM_I_ARRAY_DIMS (ra)[k].inc) + { + SCM_CLR_ARRAY_CONTIGUOUS_FLAG (ra); + return; + } + inc *= (SCM_I_ARRAY_DIMS (ra)[k].ubnd + - SCM_I_ARRAY_DIMS (ra)[k].lbnd + 1); + } + } + SCM_SET_ARRAY_CONTIGUOUS_FLAG (ra); +} + + +SCM_DEFINE (scm_make_shared_array, "make-shared-array", 2, 0, 1, + (SCM oldra, SCM mapfunc, SCM dims), + "@code{make-shared-array} can be used to create shared subarrays of other\n" + "arrays. The @var{mapper} is a function that translates coordinates in\n" + "the new array into coordinates in the old array. A @var{mapper} must be\n" + "linear, and its range must stay within the bounds of the old array, but\n" + "it can be otherwise arbitrary. A simple example:\n" + "@lisp\n" + "(define fred (make-array #f 8 8))\n" + "(define freds-diagonal\n" + " (make-shared-array fred (lambda (i) (list i i)) 8))\n" + "(array-set! freds-diagonal 'foo 3)\n" + "(array-ref fred 3 3) @result{} foo\n" + "(define freds-center\n" + " (make-shared-array fred (lambda (i j) (list (+ 3 i) (+ 3 j))) 2 2))\n" + "(array-ref freds-center 0 0) @result{} foo\n" + "@end lisp") +#define FUNC_NAME s_scm_make_shared_array +{ + scm_t_array_handle old_handle; + SCM ra; + SCM inds, indptr; + SCM imap; + size_t k; + ssize_t i; + long old_base, old_min, new_min, old_max, new_max; + scm_t_array_dim *s; + + SCM_VALIDATE_REST_ARGUMENT (dims); + SCM_VALIDATE_PROC (2, mapfunc); + ra = scm_i_shap2ra (dims); + + scm_array_get_handle (oldra, &old_handle); + + if (SCM_I_ARRAYP (oldra)) + { + SCM_I_ARRAY_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); + while (k--) + { + if (s[k].inc > 0) + old_max += (s[k].ubnd - s[k].lbnd) * s[k].inc; + else + old_min += (s[k].ubnd - s[k].lbnd) * s[k].inc; + } + } + else + { + SCM_I_ARRAY_V (ra) = oldra; + old_base = old_min = 0; + old_max = scm_c_generalized_vector_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); + 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_array_handle_release (&old_handle); + return ra; + } + } + + 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; + indptr = inds; + k = SCM_I_ARRAY_NDIM (ra); + while (k--) + { + if (s[k].ubnd > s[k].lbnd) + { + SCM_SETCAR (indptr, scm_sum (SCM_CAR (indptr), scm_from_int (1))); + imap = scm_apply_0 (mapfunc, scm_reverse (inds)); + s[k].inc = scm_array_handle_pos (&old_handle, imap) - i; + i += s[k].inc; + if (s[k].inc > 0) + new_max += (s[k].ubnd - s[k].lbnd) * s[k].inc; + else + new_min += (s[k].ubnd - s[k].lbnd) * s[k].inc; + } + else + s[k].inc = new_max - new_min + 1; /* contiguous by default */ + indptr = SCM_CDR (indptr); + } + + scm_array_handle_release (&old_handle); + + if (old_min > new_min || old_max < new_max) + SCM_MISC_ERROR ("mapping out of range", SCM_EOL); + 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); + if (1 == s->inc && 0 == s->lbnd && length == 1 + s->ubnd) + return v; + if (s->ubnd < s->lbnd) + return scm_make_generalized_vector (scm_array_type (ra), SCM_INUM0, + SCM_UNDEFINED); + } + scm_i_ra_set_contp (ra); + return ra; +} +#undef FUNC_NAME + + +/* args are RA . DIMS */ +SCM_DEFINE (scm_transpose_array, "transpose-array", 1, 0, 1, + (SCM ra, SCM args), + "Return an array sharing contents with @var{array}, but with\n" + "dimensions arranged in a different order. There must be one\n" + "@var{dim} argument for each dimension of @var{array}.\n" + "@var{dim0}, @var{dim1}, @dots{} should be integers between 0\n" + "and the rank of the array to be returned. Each integer in that\n" + "range must appear at least once in the argument list.\n" + "\n" + "The values of @var{dim0}, @var{dim1}, @dots{} correspond to\n" + "dimensions in the array to be returned, their positions in the\n" + "argument list to dimensions of @var{array}. Several @var{dim}s\n" + "may have the same value, in which case the returned array will\n" + "have smaller rank than @var{array}.\n" + "\n" + "@lisp\n" + "(transpose-array '#2((a b) (c d)) 1 0) @result{} #2((a c) (b d))\n" + "(transpose-array '#2((a b) (c d)) 0 0) @result{} #1(a d)\n" + "(transpose-array '#3(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1 1 0) @result{}\n" + " #2((a 4) (b 5) (c 6))\n" + "@end lisp") +#define FUNC_NAME s_scm_transpose_array +{ + SCM res, vargs; + scm_t_array_dim *s, *r; + int ndim, i, k; + + SCM_VALIDATE_REST_ARGUMENT (args); + SCM_ASSERT (SCM_NIMP (ra), ra, SCM_ARG1, FUNC_NAME); + + if (scm_is_generalized_vector (ra)) + { + /* Make sure that we are called with a single zero as + 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)) + { + vargs = scm_vector (args); + if (SCM_SIMPLE_VECTOR_LENGTH (vargs) != SCM_I_ARRAY_NDIM (ra)) + SCM_WRONG_NUM_ARGS (); + ndim = 0; + for (k = 0; k < SCM_I_ARRAY_NDIM (ra); k++) + { + i = scm_to_signed_integer (SCM_SIMPLE_VECTOR_REF (vargs, k), + 0, SCM_I_ARRAY_NDIM(ra)); + if (ndim < i) + ndim = i; + } + 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); + for (k = ndim; k--;) + { + SCM_I_ARRAY_DIMS (res)[k].lbnd = 0; + SCM_I_ARRAY_DIMS (res)[k].ubnd = -1; + } + for (k = SCM_I_ARRAY_NDIM (ra); k--;) + { + i = scm_to_int (SCM_SIMPLE_VECTOR_REF (vargs, k)); + s = &(SCM_I_ARRAY_DIMS (ra)[k]); + r = &(SCM_I_ARRAY_DIMS (res)[i]); + if (r->ubnd < r->lbnd) + { + r->lbnd = s->lbnd; + r->ubnd = s->ubnd; + r->inc = s->inc; + ndim--; + } + else + { + if (r->ubnd > s->ubnd) + r->ubnd = s->ubnd; + if (r->lbnd < s->lbnd) + { + SCM_I_ARRAY_BASE (res) += (s->lbnd - r->lbnd) * r->inc; + r->lbnd = s->lbnd; + } + r->inc += s->inc; + } + } + if (ndim > 0) + SCM_MISC_ERROR ("bad argument list", SCM_EOL); + 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. */ +SCM_DEFINE (scm_array_contents, "array-contents", 1, 1, 0, + (SCM ra, SCM strict), + "If @var{array} may be @dfn{unrolled} into a one dimensional shared array\n" + "without changing their order (last subscript changing fastest), then\n" + "@code{array-contents} returns that shared array, otherwise it returns\n" + "@code{#f}. All arrays made by @var{make-array} and\n" + "@var{make-uniform-array} may be unrolled, some arrays made by\n" + "@var{make-shared-array} may not be.\n\n" + "If the optional argument @var{strict} is provided, a shared array will\n" + "be returned only if its elements are stored internally contiguous in\n" + "memory.") +#define FUNC_NAME s_scm_array_contents +{ + SCM sra; + + if (scm_is_generalized_vector (ra)) + return ra; + + if (SCM_I_ARRAYP (ra)) + { + size_t k, ndim = SCM_I_ARRAY_NDIM (ra), len = 1; + if (!SCM_I_ARRAYP (ra) || !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; + if (!SCM_UNBNDP (strict) && scm_is_true (strict)) + { + if (ndim && (1 != SCM_I_ARRAY_DIMS (ra)[ndim - 1].inc)) + return SCM_BOOL_F; + if (scm_is_bitvector (SCM_I_ARRAY_V (ra))) + { + if (len != scm_c_bitvector_length (SCM_I_ARRAY_V (ra)) || + SCM_I_ARRAY_BASE (ra) % SCM_LONG_BIT || + len % SCM_LONG_BIT) + 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; + } + else + scm_wrong_type_arg_msg (NULL, 0, ra, "array"); +} +#undef FUNC_NAME + + +SCM +scm_ra2contig (SCM ra, int copy) +{ + SCM ret; + long inc = 1; + size_t k, len = 1; + for (k = SCM_I_ARRAY_NDIM (ra); k--;) + len *= SCM_I_ARRAY_DIMS (ra)[k].ubnd - SCM_I_ARRAY_DIMS (ra)[k].lbnd + 1; + k = SCM_I_ARRAY_NDIM (ra); + if (SCM_I_ARRAY_CONTP (ra) && ((0 == k) || (1 == SCM_I_ARRAY_DIMS (ra)[k - 1].inc))) + { + if (!scm_is_bitvector (SCM_I_ARRAY_V (ra))) + return ra; + if ((len == scm_c_bitvector_length (SCM_I_ARRAY_V (ra)) && + 0 == SCM_I_ARRAY_BASE (ra) % SCM_LONG_BIT && + 0 == len % SCM_LONG_BIT)) + return ra; + } + ret = scm_i_make_array (k); + SCM_I_ARRAY_BASE (ret) = 0; + while (k--) + { + SCM_I_ARRAY_DIMS (ret)[k].lbnd = SCM_I_ARRAY_DIMS (ra)[k].lbnd; + SCM_I_ARRAY_DIMS (ret)[k].ubnd = SCM_I_ARRAY_DIMS (ra)[k].ubnd; + SCM_I_ARRAY_DIMS (ret)[k].inc = inc; + inc *= SCM_I_ARRAY_DIMS (ra)[k].ubnd - SCM_I_ARRAY_DIMS (ra)[k].lbnd + 1; + } + SCM_I_ARRAY_V (ret) = scm_make_generalized_vector (scm_array_type (ra), + scm_from_long (inc), + SCM_UNDEFINED); + if (copy) + scm_array_copy_x (ra, ret); + return ret; +} + + + +SCM_DEFINE (scm_uniform_array_read_x, "uniform-array-read!", 1, 3, 0, + (SCM ura, SCM port_or_fd, SCM start, SCM end), + "@deffnx {Scheme Procedure} uniform-vector-read! uve [port-or-fdes] [start] [end]\n" + "Attempt to read all elements of @var{ura}, in lexicographic order, as\n" + "binary objects from @var{port-or-fdes}.\n" + "If an end of file is encountered,\n" + "the objects up to that point are put into @var{ura}\n" + "(starting at the beginning) and the remainder of the array is\n" + "unchanged.\n\n" + "The optional arguments @var{start} and @var{end} allow\n" + "a specified region of a vector (or linearized array) to be read,\n" + "leaving the remainder of the vector unchanged.\n\n" + "@code{uniform-array-read!} returns the number of objects read.\n" + "@var{port-or-fdes} may be omitted, in which case it defaults to the value\n" + "returned by @code{(current-input-port)}.") +#define FUNC_NAME s_scm_uniform_array_read_x +{ + if (SCM_UNBNDP (port_or_fd)) + port_or_fd = scm_current_input_port (); + + if (scm_is_uniform_vector (ura)) + { + return scm_uniform_vector_read_x (ura, port_or_fd, start, end); + } + else if (SCM_I_ARRAYP (ura)) + { + size_t base, vlen, cstart, cend; + SCM cra, ans; + + cra = scm_ra2contig (ura, 0); + base = SCM_I_ARRAY_BASE (cra); + vlen = SCM_I_ARRAY_DIMS (cra)->inc * + (SCM_I_ARRAY_DIMS (cra)->ubnd - SCM_I_ARRAY_DIMS (cra)->lbnd + 1); + + cstart = 0; + cend = vlen; + if (!SCM_UNBNDP (start)) + { + cstart = scm_to_unsigned_integer (start, 0, vlen); + if (!SCM_UNBNDP (end)) + cend = scm_to_unsigned_integer (end, cstart, vlen); + } + + ans = scm_uniform_vector_read_x (SCM_I_ARRAY_V (cra), port_or_fd, + scm_from_size_t (base + cstart), + scm_from_size_t (base + cend)); + + if (!scm_is_eq (cra, ura)) + scm_array_copy_x (cra, ura); + return ans; + } + else + scm_wrong_type_arg_msg (NULL, 0, ura, "array"); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_uniform_array_write, "uniform-array-write", 1, 3, 0, + (SCM ura, SCM port_or_fd, SCM start, SCM end), + "Writes all elements of @var{ura} as binary objects to\n" + "@var{port-or-fdes}.\n\n" + "The optional arguments @var{start}\n" + "and @var{end} allow\n" + "a specified region of a vector (or linearized array) to be written.\n\n" + "The number of objects actually written is returned.\n" + "@var{port-or-fdes} may be\n" + "omitted, in which case it defaults to the value returned by\n" + "@code{(current-output-port)}.") +#define FUNC_NAME s_scm_uniform_array_write +{ + if (SCM_UNBNDP (port_or_fd)) + port_or_fd = scm_current_output_port (); + + if (scm_is_uniform_vector (ura)) + { + return scm_uniform_vector_write (ura, port_or_fd, start, end); + } + else if (SCM_I_ARRAYP (ura)) + { + size_t base, vlen, cstart, cend; + SCM cra, ans; + + cra = scm_ra2contig (ura, 1); + base = SCM_I_ARRAY_BASE (cra); + vlen = SCM_I_ARRAY_DIMS (cra)->inc * + (SCM_I_ARRAY_DIMS (cra)->ubnd - SCM_I_ARRAY_DIMS (cra)->lbnd + 1); + + cstart = 0; + cend = vlen; + if (!SCM_UNBNDP (start)) + { + cstart = scm_to_unsigned_integer (start, 0, vlen); + if (!SCM_UNBNDP (end)) + cend = scm_to_unsigned_integer (end, cstart, vlen); + } + + ans = scm_uniform_vector_write (SCM_I_ARRAY_V (cra), port_or_fd, + scm_from_size_t (base + cstart), + scm_from_size_t (base + cend)); + + return ans; + } + else + scm_wrong_type_arg_msg (NULL, 0, ura, "array"); +} +#undef FUNC_NAME + + +static void +list_to_array (SCM lst, scm_t_array_handle *handle, ssize_t pos, size_t k) +{ + if (k == scm_array_handle_rank (handle)) + scm_array_handle_set (handle, pos, lst); + else + { + scm_t_array_dim *dim = scm_array_handle_dims (handle) + k; + ssize_t inc = dim->inc; + size_t len = 1 + dim->ubnd - dim->lbnd, n; + char *errmsg = NULL; + + n = len; + while (n > 0 && scm_is_pair (lst)) + { + list_to_array (SCM_CAR (lst), handle, pos, k + 1); + pos += inc; + lst = SCM_CDR (lst); + n -= 1; + } + if (n != 0) + errmsg = "too few elements for array dimension ~a, need ~a"; + 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_from_size_t (len))); + } +} + + +SCM_DEFINE (scm_list_to_typed_array, "list->typed-array", 3, 0, 0, + (SCM type, SCM shape, SCM lst), + "Return an array of the type @var{type}\n" + "with elements the same as those of @var{lst}.\n" + "\n" + "The argument @var{shape} determines the number of dimensions\n" + "of the array and their shape. It is either an exact integer,\n" + "giving the\n" + "number of dimensions directly, or a list whose length\n" + "specifies the number of dimensions and each element specified\n" + "the lower and optionally the upper bound of the corresponding\n" + "dimension.\n" + "When the element is list of two elements, these elements\n" + "give the lower and upper bounds. When it is an exact\n" + "integer, it gives only the lower bound.") +#define FUNC_NAME s_scm_list_to_typed_array +{ + SCM row; + SCM ra; + scm_t_array_handle handle; + + row = lst; + if (scm_is_integer (shape)) + { + size_t k = scm_to_size_t (shape); + shape = SCM_EOL; + while (k-- > 0) + { + shape = scm_cons (scm_length (row), shape); + if (k > 0 && !scm_is_null (row)) + row = scm_car (row); + } + } + else + { + SCM shape_spec = shape; + shape = SCM_EOL; + while (1) + { + SCM spec = scm_car (shape_spec); + if (scm_is_pair (spec)) + shape = scm_cons (spec, shape); + else + shape = scm_cons (scm_list_2 (spec, + scm_sum (scm_sum (spec, + scm_length (row)), + scm_from_int (-1))), + shape); + shape_spec = scm_cdr (shape_spec); + if (scm_is_pair (shape_spec)) + { + if (!scm_is_null (row)) + row = scm_car (row); + } + else + break; + } + } + + ra = scm_make_typed_array (type, SCM_UNSPECIFIED, + scm_reverse_x (shape, SCM_EOL)); + + scm_array_get_handle (ra, &handle); + list_to_array (lst, &handle, 0, 0); + scm_array_handle_release (&handle); + + return ra; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_list_to_array, "list->array", 2, 0, 0, + (SCM ndim, SCM lst), + "Return an array with elements the same as those of @var{lst}.") +#define FUNC_NAME s_scm_list_to_array +{ + return scm_list_to_typed_array (SCM_BOOL_T, ndim, lst); +} +#undef FUNC_NAME + +/* Print dimension DIM of ARRAY. + */ + +static int +scm_i_print_array_dimension (scm_t_array_handle *h, int dim, int pos, + SCM port, scm_print_state *pstate) +{ + if (dim == h->ndims) + scm_iprin1 (scm_array_handle_ref (h, pos), port, pstate); + else + { + ssize_t i; + scm_putc ('(', 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 (')', port); + } + return 1; +} + +/* Print an array. +*/ + +static int +scm_i_print_array (SCM array, SCM port, scm_print_state *pstate) +{ + scm_t_array_handle h; + long i; + int print_lbnds = 0, zero_size = 0, print_lens = 0; + + scm_array_get_handle (array, &h); + + scm_putc ('#', 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) + scm_write (scm_array_handle_element_type (&h), port); + + for (i = 0; i < h.ndims; i++) + { + if (h.dims[i].lbnd != 0) + print_lbnds = 1; + if (h.dims[i].ubnd - h.dims[i].lbnd + 1 == 0) + zero_size = 1; + else if (zero_size) + print_lens = 1; + } + + if (print_lbnds || print_lens) + for (i = 0; i < h.ndims; i++) + { + if (print_lbnds) + { + scm_putc ('@', port); + scm_intprint (h.dims[i].lbnd, 10, port); + } + if (print_lens) + { + scm_putc (':', port); + scm_intprint (h.dims[i].ubnd - h.dims[i].lbnd + 1, + 10, port); + } + } + + if (h.ndims == 0) + { + /* Rank zero arrays, which are really just scalars, are printed + specially. The consequent way would be to print them as + + #0 OBJ + + where OBJ is the printed representation of the scalar, but we + print them instead as + + #0(OBJ) + + to make them look less strange. + + Just printing them as + + OBJ + + would be correct in a way as well, but zero rank arrays are + not really the same as Scheme values since they are boxed and + can be modified with array-set!, say. + */ + scm_putc ('(', port); + scm_i_print_array_dimension (&h, 0, 0, port, pstate); + scm_putc (')', port); + return 1; + } + else + return scm_i_print_array_dimension (&h, 0, 0, port, pstate); +} + +/* Read an array. This function can also read vectors and uniform + vectors. Also, the conflict between '#f' and '#f32' and '#f64' is + handled here. + + C is the first character read after the '#'. +*/ + +static SCM +tag_to_type (const char *tag, SCM port) +{ + if (*tag == '\0') + return SCM_BOOL_T; + else + return scm_from_locale_symbol (tag); +} + +static int +read_decimal_integer (SCM port, int c, ssize_t *resp) +{ + ssize_t sign = 1; + ssize_t res = 0; + int got_it = 0; + + if (c == '-') + { + sign = -1; + c = scm_getc (port); + } + + while ('0' <= c && c <= '9') + { + res = 10*res + c-'0'; + got_it = 1; + c = scm_getc (port); + } + + if (got_it) + *resp = sign * res; + return c; +} + +SCM +scm_i_read_array (SCM port, int c) +{ + ssize_t rank; + int got_rank; + char tag[80]; + int tag_len; + + SCM shape = SCM_BOOL_F, elements; + + /* XXX - shortcut for ordinary vectors. Shouldn't be necessary but + the array code can not deal with zero-length dimensions yet, and + we want to allow zero-length vectors, of course. + */ + if (c == '(') + { + scm_ungetc (c, port); + return scm_vector (scm_read (port)); + } + + /* Disambiguate between '#f' and uniform floating point vectors. + */ + if (c == 'f') + { + c = scm_getc (port); + if (c != '3' && c != '6') + { + if (c != EOF) + scm_ungetc (c, port); + return SCM_BOOL_F; + } + rank = 1; + got_rank = 1; + tag[0] = 'f'; + tag_len = 1; + goto continue_reading_tag; + } + + /* Read rank. + */ + rank = 1; + c = read_decimal_integer (port, c, &rank); + if (rank < 0) + scm_i_input_error (NULL, port, "array rank must be non-negative", + SCM_EOL); + + /* Read tag. + */ + tag_len = 0; + continue_reading_tag: + while (c != EOF && c != '(' && c != '@' && c != ':' && tag_len < 80) + { + tag[tag_len++] = c; + c = scm_getc (port); + } + tag[tag_len] = '\0'; + + /* Read shape. + */ + if (c == '@' || c == ':') + { + shape = SCM_EOL; + + do + { + ssize_t lbnd = 0, len = 0; + SCM s; + + if (c == '@') + { + c = scm_getc (port); + c = read_decimal_integer (port, c, &lbnd); + } + + s = scm_from_ssize_t (lbnd); + + if (c == ':') + { + c = scm_getc (port); + c = read_decimal_integer (port, c, &len); + if (len < 0) + scm_i_input_error (NULL, port, + "array length must be non-negative", + SCM_EOL); + + s = scm_list_2 (s, scm_from_ssize_t (lbnd+len-1)); + } + + shape = scm_cons (s, shape); + } while (c == '@' || c == ':'); + + shape = scm_reverse_x (shape, SCM_EOL); + } + + /* Read nested lists of elements. + */ + if (c != '(') + scm_i_input_error (NULL, port, + "missing '(' in vector or array literal", + SCM_EOL); + scm_ungetc (c, port); + elements = scm_read (port); + + if (scm_is_false (shape)) + shape = scm_from_ssize_t (rank); + else if (scm_ilength (shape) != rank) + scm_i_input_error + (NULL, port, + "the number of shape specifications must match the array rank", + SCM_EOL); + + /* Handle special print syntax of rank zero arrays; see + scm_i_print_array for a rationale. + */ + if (rank == 0) + { + if (!scm_is_pair (elements)) + scm_i_input_error (NULL, port, + "too few elements in array literal, need 1", + SCM_EOL); + if (!scm_is_null (SCM_CDR (elements))) + scm_i_input_error (NULL, port, + "too many elements in array literal, want 1", + SCM_EOL); + elements = SCM_CAR (elements); + } + + /* Construct array. + */ + return scm_list_to_typed_array (tag_to_type (tag, port), shape, elements); +} + + +static SCM +array_mark (SCM ptr) +{ + return SCM_I_ARRAY_V (ptr); +} + +static size_t +array_free (SCM ptr) +{ + scm_gc_free (SCM_I_ARRAY_MEM (ptr), + (sizeof (scm_i_t_array) + + SCM_I_ARRAY_NDIM (ptr) * sizeof (scm_t_array_dim)), + "array"); + return 0; +} + +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_i_tc16_array, 0xffff, + array_handle_ref, array_handle_set, + array_get_handle); + +void +scm_init_arrays () +{ + scm_i_tc16_array = scm_make_smob_type ("array", 0); + scm_set_smob_mark (scm_i_tc16_array, array_mark); + scm_set_smob_free (scm_i_tc16_array, array_free); + scm_set_smob_print (scm_i_tc16_array, scm_i_print_array); + scm_set_smob_equalp (scm_i_tc16_array, scm_array_equal_p); + + scm_add_feature ("array"); + +#include "libguile/arrays.x" + +} + +/* + Local Variables: + c-file-style: "gnu" + End: +*/ |