From 2fa901a51f62da8a01112aefbf687530f4bff160 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 17 Jul 2009 01:08:35 +0200 Subject: rename unif.[ch] to arrays.[ch] * libguile/Makefile.am: * libguile/unif.c: * libguile/unif.h: * libguile/arrays.c: * libguile/arrays.h: Rename unif.[ch] to arrays.[ch]. * libguile.h: * libguile/array-handle.c: * libguile/array-map.c: * libguile/bitvectors.c: * libguile/bytevectors.c: * libguile/eq.c: * libguile/gc-card.c: * libguile/gc-malloc.c: * libguile/gc-mark.c: * libguile/gc.c: * libguile/init.c: * libguile/inline.h: * libguile/print.c: * libguile/random.c: * libguile/read.c: * libguile/socket.c: * libguile/sort.c: * libguile/srfi-4.c: * libguile/srfi-4.h: * libguile/strports.c: * libguile/vectors.c: * libguile/vectors.h: Update includers. --- libguile/arrays.c | 1634 +++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 1634 insertions(+) create mode 100644 libguile/arrays.c (limited to 'libguile/arrays.c') diff --git a/libguile/arrays.c b/libguile/arrays.c new file mode 100644 index 000000000..c70d24772 --- /dev/null +++ b/libguile/arrays.c @@ -0,0 +1,1634 @@ +/* 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 + */ + + +/* + This file has code for arrays in lots of variants (double, integer, + unsigned etc. ). It suffers from hugely repetitive code because + there is similar (but different) code for every variant included. (urg.) + + --hwn +*/ + + +#ifdef HAVE_CONFIG_H +# include +#endif + +#include +#include +#include + +#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/validate.h" +#include "libguile/arrays.h" +#include "libguile/array-map.h" +#include "libguile/print.h" +#include "libguile/read.h" + +#ifdef HAVE_UNISTD_H +#include +#endif + +#ifdef HAVE_IO_H +#include +#endif + + +/* The set of uniform scm_vector types is: + * Vector of: Called: Replaced by: + * unsigned char string + * char byvect s8 or u8, depending on signedness of 'char' + * boolean bvect + * signed long ivect s32 + * unsigned long uvect u32 + * float fvect f32 + * double dvect d32 + * complex double cvect c64 + * short svect s16 + * long long llvect s64 + */ + +scm_t_bits scm_i_tc16_array; +scm_t_bits scm_i_tc16_enclosed_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)) + +typedef SCM creator_proc (SCM len, SCM fill); + +struct { + char *type_name; + SCM type; + creator_proc *creator; +} type_creator_table[] = { + { "a", SCM_UNSPECIFIED, scm_make_string }, + { "b", SCM_UNSPECIFIED, scm_make_bitvector }, + { "u8", SCM_UNSPECIFIED, scm_make_u8vector }, + { "s8", SCM_UNSPECIFIED, scm_make_s8vector }, + { "u16", SCM_UNSPECIFIED, scm_make_u16vector }, + { "s16", SCM_UNSPECIFIED, scm_make_s16vector }, + { "u32", SCM_UNSPECIFIED, scm_make_u32vector }, + { "s32", SCM_UNSPECIFIED, scm_make_s32vector }, + { "u64", SCM_UNSPECIFIED, scm_make_u64vector }, + { "s64", SCM_UNSPECIFIED, scm_make_s64vector }, + { "f32", SCM_UNSPECIFIED, scm_make_f32vector }, + { "f64", SCM_UNSPECIFIED, scm_make_f64vector }, + { "c32", SCM_UNSPECIFIED, scm_make_c32vector }, + { "c64", SCM_UNSPECIFIED, scm_make_c64vector }, + { "vu8", SCM_UNSPECIFIED, scm_make_bytevector }, + { NULL } +}; + +static void +init_type_creator_table () +{ + int i; + for (i = 0; type_creator_table[i].type_name; i++) + { + SCM sym = scm_from_locale_symbol (type_creator_table[i].type_name); + type_creator_table[i].type = scm_permanent_object (sym); + } +} + +static creator_proc * +type_to_creator (SCM type) +{ + int i; + + if (scm_is_eq (type, SCM_BOOL_T)) + return scm_make_vector; + for (i = 0; type_creator_table[i].type_name; i++) + if (scm_is_eq (type, type_creator_table[i].type)) + return type_creator_table[i].creator; + + scm_misc_error (NULL, "unknown array type: ~a", scm_list_1 (type)); +} + +static SCM +make_typed_vector (SCM type, size_t len) +{ + creator_proc *creator = type_to_creator (type); + return creator (scm_from_size_t (len), SCM_UNDEFINED); +} + +int +scm_is_array (SCM obj) +{ + return (SCM_I_ENCLOSED_ARRAYP (obj) + || SCM_I_ARRAYP (obj) + || scm_is_generalized_vector (obj)); +} + +int +scm_is_typed_array (SCM obj, SCM type) +{ + if (SCM_I_ENCLOSED_ARRAYP (obj)) + { + /* Enclosed arrays are arrays but are not of any type. + */ + return 0; + } + + /* Get storage vector. + */ + if (SCM_I_ARRAYP (obj)) + obj = SCM_I_ARRAY_V (obj); + + /* It must be a generalized vector (which includes vectors, strings, etc). + */ + if (!scm_is_generalized_vector (obj)) + return 0; + + return scm_is_eq (type, scm_i_generalized_vector_type (obj)); +} + +/* We keep the old 2-argument C prototype for a while although the old + PROT argument is always ignored now. C code should probably use + scm_is_array or scm_is_typed_array anyway. +*/ + +SCM_DEFINE (scm_array_p, "array?", 1, 0, 0, + (SCM obj), + "Return @code{#t} if the @var{obj} is an array, and @code{#f} if\n" + "not.") +#define FUNC_NAME s_scm_array_p +{ + return scm_from_bool (scm_is_array (obj)); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_typed_array_p, "typed-array?", 2, 0, 0, + (SCM obj, SCM type), + "Return @code{#t} if the @var{obj} is an array of type\n" + "@var{type}, and @code{#f} if not.") +#define FUNC_NAME s_scm_typed_array_p +{ + return scm_from_bool (scm_is_typed_array (obj, type)); +} +#undef FUNC_NAME + +size_t +scm_c_array_rank (SCM array) +{ + scm_t_array_handle handle; + size_t res; + + scm_array_get_handle (array, &handle); + res = scm_array_handle_rank (&handle); + scm_array_handle_release (&handle); + return res; +} + +SCM_DEFINE (scm_array_rank, "array-rank", 1, 0, 0, + (SCM array), + "Return the number of dimensions of the array @var{array.}\n") +#define FUNC_NAME s_scm_array_rank +{ + return scm_from_size_t (scm_c_array_rank (array)); +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_array_dimensions, "array-dimensions", 1, 0, 0, + (SCM ra), + "@code{array-dimensions} is similar to @code{array-shape} but replaces\n" + "elements with a @code{0} minimum with one greater than the maximum. So:\n" + "@lisp\n" + "(array-dimensions (make-array 'foo '(-1 3) 5)) @result{} ((-1 3) 5)\n" + "@end lisp") +#define FUNC_NAME s_scm_array_dimensions +{ + scm_t_array_handle handle; + scm_t_array_dim *s; + SCM res = SCM_EOL; + size_t k; + + scm_array_get_handle (ra, &handle); + s = scm_array_handle_dims (&handle); + k = scm_array_handle_rank (&handle); + + while (k--) + res = scm_cons (s[k].lbnd + ? scm_cons2 (scm_from_ssize_t (s[k].lbnd), + scm_from_ssize_t (s[k].ubnd), + SCM_EOL) + : scm_from_ssize_t (1 + s[k].ubnd), + res); + + scm_array_handle_release (&handle); + return res; +} +#undef FUNC_NAME + + +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) || SCM_I_ENCLOSED_ARRAYP (ra)) + return SCM_I_ARRAY_V (ra); + else if (scm_is_generalized_vector (ra)) + return ra; + scm_wrong_type_arg_msg (NULL, 0, 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 + +ssize_t +scm_array_handle_pos (scm_t_array_handle *h, SCM indices) +{ + scm_t_array_dim *s = scm_array_handle_dims (h); + ssize_t pos = 0, i; + size_t k = scm_array_handle_rank (h); + + while (k > 0 && scm_is_pair (indices)) + { + i = scm_to_signed_integer (SCM_CAR (indices), s->lbnd, s->ubnd); + pos += (i - s->lbnd) * s->inc; + k--; + s++; + indices = SCM_CDR (indices); + } + if (k > 0 || !scm_is_null (indices)) + scm_misc_error (NULL, "wrong number of indices, expecting ~a", + scm_list_1 (scm_from_size_t (scm_array_handle_rank (h)))); + return pos; +} + +SCM +scm_i_make_array (int ndim, int enclosed) +{ + scm_t_bits tag = enclosed? scm_i_tc16_enclosed_array : scm_i_tc16_array; + SCM ra; + SCM_NEWSMOB(ra, ((scm_t_bits) ndim << 17) + tag, + 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, 0); + 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; + creator_proc *creator; + SCM ra; + + creator = type_to_creator (type); + 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) = creator (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; + creator_proc *creator; + SCM ra; + scm_t_array_handle h; + void *base; + size_t sz; + + creator = type_to_creator (type); + 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) = creator (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 = make_typed_vector (scm_array_type (ra), 0); + else + SCM_I_ARRAY_V (ra) = make_typed_vector (scm_array_type (ra), 0); + 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 make_typed_vector (scm_array_type (ra), 0); + } + 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) || SCM_I_ENCLOSED_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, 0); + 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 + +/* args are RA . AXES */ +SCM_DEFINE (scm_enclose_array, "enclose-array", 1, 0, 1, + (SCM ra, SCM axes), + "@var{dim0}, @var{dim1} @dots{} should be nonnegative integers less than\n" + "the rank of @var{array}. @var{enclose-array} returns an array\n" + "resembling an array of shared arrays. The dimensions of each shared\n" + "array are the same as the @var{dim}th dimensions of the original array,\n" + "the dimensions of the outer array are the same as those of the original\n" + "array that did not match a @var{dim}.\n\n" + "An enclosed array is not a general Scheme array. Its elements may not\n" + "be set using @code{array-set!}. Two references to the same element of\n" + "an enclosed array will be @code{equal?} but will not in general be\n" + "@code{eq?}. The value returned by @var{array-prototype} when given an\n" + "enclosed array is unspecified.\n\n" + "examples:\n" + "@lisp\n" + "(enclose-array '#3(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1) @result{}\n" + " #\n\n" + "(enclose-array '#3(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1 0) @result{}\n" + " #\n" + "@end lisp") +#define FUNC_NAME s_scm_enclose_array +{ + SCM axv, res, ra_inr; + const char *c_axv; + scm_t_array_dim vdim, *s = &vdim; + int ndim, j, k, ninr, noutr; + + SCM_VALIDATE_REST_ARGUMENT (axes); + if (scm_is_null (axes)) + axes = scm_cons ((SCM_I_ARRAYP (ra) ? scm_from_size_t (SCM_I_ARRAY_NDIM (ra) - 1) : SCM_INUM0), SCM_EOL); + ninr = scm_ilength (axes); + if (ninr < 0) + SCM_WRONG_NUM_ARGS (); + ra_inr = scm_i_make_array (ninr, 0); + + if (scm_is_generalized_vector (ra)) + { + s->lbnd = 0; + s->ubnd = scm_c_generalized_vector_length (ra) - 1; + s->inc = 1; + SCM_I_ARRAY_V (ra_inr) = ra; + SCM_I_ARRAY_BASE (ra_inr) = 0; + ndim = 1; + } + else if (SCM_I_ARRAYP (ra)) + { + s = SCM_I_ARRAY_DIMS (ra); + SCM_I_ARRAY_V (ra_inr) = SCM_I_ARRAY_V (ra); + SCM_I_ARRAY_BASE (ra_inr) = SCM_I_ARRAY_BASE (ra); + ndim = SCM_I_ARRAY_NDIM (ra); + } + else + scm_wrong_type_arg_msg (NULL, 0, ra, "array"); + + noutr = ndim - ninr; + if (noutr < 0) + SCM_WRONG_NUM_ARGS (); + axv = scm_make_string (scm_from_int (ndim), SCM_MAKE_CHAR (0)); + res = scm_i_make_array (noutr, 1); + SCM_I_ARRAY_BASE (res) = SCM_I_ARRAY_BASE (ra_inr); + SCM_I_ARRAY_V (res) = ra_inr; + for (k = 0; k < ninr; k++, axes = SCM_CDR (axes)) + { + if (!scm_is_integer (SCM_CAR (axes))) + SCM_MISC_ERROR ("bad axis", SCM_EOL); + j = scm_to_int (SCM_CAR (axes)); + SCM_I_ARRAY_DIMS (ra_inr)[k].lbnd = s[j].lbnd; + SCM_I_ARRAY_DIMS (ra_inr)[k].ubnd = s[j].ubnd; + SCM_I_ARRAY_DIMS (ra_inr)[k].inc = s[j].inc; + scm_c_string_set_x (axv, j, SCM_MAKE_CHAR (1)); + } + c_axv = scm_i_string_chars (axv); + for (j = 0, k = 0; k < noutr; k++, j++) + { + while (c_axv[j]) + j++; + SCM_I_ARRAY_DIMS (res)[k].lbnd = s[j].lbnd; + SCM_I_ARRAY_DIMS (res)[k].ubnd = s[j].ubnd; + SCM_I_ARRAY_DIMS (res)[k].inc = s[j].inc; + } + scm_remember_upto_here_1 (axv); + scm_i_ra_set_contp (ra_inr); + scm_i_ra_set_contp (res); + return res; +} +#undef FUNC_NAME + + + +SCM_DEFINE (scm_array_in_bounds_p, "array-in-bounds?", 1, 0, 1, + (SCM v, SCM args), + "Return @code{#t} if its arguments would be acceptable to\n" + "@code{array-ref}.") +#define FUNC_NAME s_scm_array_in_bounds_p +{ + SCM res = SCM_BOOL_T; + + SCM_VALIDATE_REST_ARGUMENT (args); + + if (SCM_I_ARRAYP (v) || SCM_I_ENCLOSED_ARRAYP (v)) + { + size_t k, ndim = SCM_I_ARRAY_NDIM (v); + scm_t_array_dim *s = SCM_I_ARRAY_DIMS (v); + + for (k = 0; k < ndim; k++) + { + long ind; + + if (!scm_is_pair (args)) + SCM_WRONG_NUM_ARGS (); + ind = scm_to_long (SCM_CAR (args)); + args = SCM_CDR (args); + + if (ind < s[k].lbnd || ind > s[k].ubnd) + { + res = SCM_BOOL_F; + /* We do not stop the checking after finding a violation + since we want to validate the type-correctness and + number of arguments in any case. + */ + } + } + } + else if (scm_is_generalized_vector (v)) + { + /* Since real arrays have been covered above, all generalized + vectors are guaranteed to be zero-origin here. + */ + + long ind; + + if (!scm_is_pair (args)) + SCM_WRONG_NUM_ARGS (); + ind = scm_to_long (SCM_CAR (args)); + args = SCM_CDR (args); + res = scm_from_bool (ind >= 0 + && ind < scm_c_generalized_vector_length (v)); + } + else + scm_wrong_type_arg_msg (NULL, 0, v, "array"); + + if (!scm_is_null (args)) + SCM_WRONG_NUM_ARGS (); + + return res; +} +#undef FUNC_NAME + +SCM +scm_i_cvref (SCM v, size_t pos, int enclosed) +{ + if (enclosed) + { + int k = SCM_I_ARRAY_NDIM (v); + SCM res = scm_i_make_array (k, 0); + SCM_I_ARRAY_V (res) = SCM_I_ARRAY_V (v); + SCM_I_ARRAY_BASE (res) = pos; + while (k--) + { + SCM_I_ARRAY_DIMS (res)[k].ubnd = SCM_I_ARRAY_DIMS (v)[k].ubnd; + SCM_I_ARRAY_DIMS (res)[k].lbnd = SCM_I_ARRAY_DIMS (v)[k].lbnd; + SCM_I_ARRAY_DIMS (res)[k].inc = SCM_I_ARRAY_DIMS (v)[k].inc; + } + return res; + } + else + return scm_c_generalized_vector_ref (v, pos); +} + +SCM_DEFINE (scm_array_ref, "array-ref", 1, 0, 1, + (SCM v, SCM args), + "Return the element at the @code{(index1, index2)} element in\n" + "@var{array}.") +#define FUNC_NAME s_scm_array_ref +{ + scm_t_array_handle handle; + SCM res; + + scm_array_get_handle (v, &handle); + res = scm_array_handle_ref (&handle, scm_array_handle_pos (&handle, args)); + scm_array_handle_release (&handle); + return res; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_array_set_x, "array-set!", 2, 0, 1, + (SCM v, SCM obj, SCM args), + "Set the element at the @code{(index1, index2)} element in @var{array} to\n" + "@var{new-value}. The value returned by array-set! is unspecified.") +#define FUNC_NAME s_scm_array_set_x +{ + scm_t_array_handle handle; + + scm_array_get_handle (v, &handle); + scm_array_handle_set (&handle, scm_array_handle_pos (&handle, args), obj); + scm_array_handle_release (&handle); + return SCM_UNSPECIFIED; +} +#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)) + { + 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, 0); + 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 if (SCM_I_ENCLOSED_ARRAYP (ra)) + scm_wrong_type_arg_msg (NULL, 0, ra, "non-enclosed array"); + 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, 0); + 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) = make_typed_vector (scm_array_type (ra), inc); + 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 if (SCM_I_ENCLOSED_ARRAYP (ura)) + scm_wrong_type_arg_msg (NULL, 0, ura, "non-enclosed array"); + 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 if (SCM_I_ENCLOSED_ARRAYP (ura)) + scm_wrong_type_arg_msg (NULL, 0, ura, "non-enclosed array"); + else + scm_wrong_type_arg_msg (NULL, 0, ura, "array"); +} +#undef FUNC_NAME + + +static SCM +ra2l (SCM ra, unsigned long base, unsigned long k) +{ + SCM res = SCM_EOL; + long inc; + size_t i; + int enclosed = SCM_I_ENCLOSED_ARRAYP (ra); + + if (k == SCM_I_ARRAY_NDIM (ra)) + return scm_i_cvref (SCM_I_ARRAY_V (ra), base, enclosed); + + inc = SCM_I_ARRAY_DIMS (ra)[k].inc; + if (SCM_I_ARRAY_DIMS (ra)[k].ubnd < SCM_I_ARRAY_DIMS (ra)[k].lbnd) + return SCM_EOL; + i = base + (1 + SCM_I_ARRAY_DIMS (ra)[k].ubnd - SCM_I_ARRAY_DIMS (ra)[k].lbnd) * inc; + do + { + i -= inc; + res = scm_cons (ra2l (ra, i, k + 1), res); + } + while (i != base); + return res; +} + + +SCM_DEFINE (scm_array_to_list, "array->list", 1, 0, 0, + (SCM v), + "Return a list consisting of all the elements, in order, of\n" + "@var{array}.") +#define FUNC_NAME s_scm_array_to_list +{ + if (scm_is_generalized_vector (v)) + return scm_generalized_vector_to_list (v); + else if (SCM_I_ARRAYP (v) || SCM_I_ENCLOSED_ARRAYP (v)) + return ra2l (v, SCM_I_ARRAY_BASE (v), 0); + + scm_wrong_type_arg_msg (NULL, 0, v, "array"); +} +#undef FUNC_NAME + + +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 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); + l2ra (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 + +static void +l2ra (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)) + { + l2ra (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))); + } +} + +/* Print dimension DIM of ARRAY. + */ + +static int +scm_i_print_array_dimension (SCM array, int dim, int base, int enclosed, + SCM port, scm_print_state *pstate) +{ + scm_t_array_dim *dim_spec = SCM_I_ARRAY_DIMS (array) + dim; + long idx; + + scm_putc ('(', port); + + for (idx = dim_spec->lbnd; idx <= dim_spec->ubnd; idx++) + { + if (dim < SCM_I_ARRAY_NDIM(array)-1) + scm_i_print_array_dimension (array, dim+1, base, enclosed, + port, pstate); + else + scm_iprin1 (scm_i_cvref (SCM_I_ARRAY_V (array), base, enclosed), + port, pstate); + if (idx < dim_spec->ubnd) + scm_putc (' ', port); + base += dim_spec->inc; + } + + scm_putc (')', port); + return 1; +} + +/* Print an array. (Only for strict arrays, not for generalized vectors.) +*/ + +static int +scm_i_print_array (SCM array, SCM port, scm_print_state *pstate) +{ + long ndim = SCM_I_ARRAY_NDIM (array); + scm_t_array_dim *dim_specs = SCM_I_ARRAY_DIMS (array); + SCM v = SCM_I_ARRAY_V (array); + unsigned long base = SCM_I_ARRAY_BASE (array); + long i; + int print_lbnds = 0, zero_size = 0, print_lens = 0; + + scm_putc ('#', port); + if (ndim != 1 || dim_specs[0].lbnd != 0) + scm_intprint (ndim, 10, port); + if (scm_is_uniform_vector (v)) + scm_puts (scm_i_uniform_vector_tag (v), port); + else if (scm_is_bitvector (v)) + scm_puts ("b", port); + else if (scm_is_string (v)) + scm_puts ("a", port); + else if (!scm_is_vector (v)) + scm_puts ("?", port); + + for (i = 0; i < ndim; i++) + { + if (dim_specs[i].lbnd != 0) + print_lbnds = 1; + if (dim_specs[i].ubnd - dim_specs[i].lbnd + 1 == 0) + zero_size = 1; + else if (zero_size) + print_lens = 1; + } + + if (print_lbnds || print_lens) + for (i = 0; i < ndim; i++) + { + if (print_lbnds) + { + scm_putc ('@', port); + scm_intprint (dim_specs[i].lbnd, 10, port); + } + if (print_lens) + { + scm_putc (':', port); + scm_intprint (dim_specs[i].ubnd - dim_specs[i].lbnd + 1, + 10, port); + } + } + + if (ndim == 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_iprin1 (scm_i_cvref (v, base, 0), port, pstate); + scm_putc (')', port); + return 1; + } + else + return scm_i_print_array_dimension (array, 0, base, 0, port, pstate); +} + +static int +scm_i_print_enclosed_array (SCM array, SCM port, scm_print_state *pstate) +{ + size_t base; + + scm_putc ('#', port); + base = SCM_I_ARRAY_BASE (array); + scm_puts ("', port); + return 1; +} + +/* 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); +} + +SCM_DEFINE (scm_array_type, "array-type", 1, 0, 0, + (SCM ra), + "") +#define FUNC_NAME s_scm_array_type +{ + if (SCM_I_ARRAYP (ra)) + return scm_i_generalized_vector_type (SCM_I_ARRAY_V (ra)); + else if (scm_is_generalized_vector (ra)) + return scm_i_generalized_vector_type (ra); + else if (SCM_I_ENCLOSED_ARRAYP (ra)) + scm_wrong_type_arg_msg (NULL, 0, ra, "non-enclosed array"); + else + scm_wrong_type_arg_msg (NULL, 0, ra, "array"); +} +#undef FUNC_NAME + +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; +} + +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_i_tc16_enclosed_array = scm_make_smob_type ("enclosed-array", 0); + scm_set_smob_mark (scm_i_tc16_enclosed_array, array_mark); + scm_set_smob_free (scm_i_tc16_enclosed_array, array_free); + scm_set_smob_print (scm_i_tc16_enclosed_array, scm_i_print_enclosed_array); + scm_set_smob_equalp (scm_i_tc16_enclosed_array, scm_array_equal_p); + + scm_add_feature ("array"); + + init_type_creator_table (); + +#include "libguile/arrays.x" + +} + +/* + Local Variables: + c-file-style: "gnu" + End: +*/ -- cgit v1.2.3 From 2a610be59412a9d633a373c6f6ec4d4794c40fd8 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sun, 19 Jul 2009 15:04:40 +0200 Subject: add generic array implementation facility * libguile/array-handle.c (scm_i_register_array_implementation): (scm_i_array_implementation_for_obj): Add generic array facility, which will (in a few commits) detangle the array code. (scm_array_get_handle): Use the generic array facility. Note that scm_t_array_handle no longer has ref and set function pointers; instead it has a pointer to the array implementation. It is unlikely that code out there used these functions, however, as the supported way was through scm_array_handle_ref/set_x. (scm_array_handle_pos): Move this function here from arrays.c. (scm_array_handle_element_type): New function, returns a Scheme value representing the type of element stored in this array. * libguile/array-handle.h (scm_t_array_element_type): New enum, for generically determining the type of an array. (scm_array_handle_rank): (scm_array_handle_dims): These are now just #defines. * libguile/arrays.c: * libguile/bitvectors.c: * libguile/bytevectors.c: * libguile/srfi-4.c: * libguile/strings.c: * libguile/vectors.c: Register array implementations for all of these. * libguile/inline.h: Update for array_handle_ref/set change. * libguile/deprecated.h: Need to include arrays.h now. --- libguile/array-handle.c | 293 +++++++++++++-------------------------------- libguile/array-handle.h | 75 ++++++++++-- libguile/arrays.c | 53 ++++---- libguile/bitvectors.c | 30 +++++ libguile/bytevectors.c | 39 ++++++ libguile/deprecated.h | 3 +- libguile/inline.h | 15 ++- libguile/srfi-4.c | 36 ++++-- libguile/srfi-4.i.c | 4 +- libguile/strings.c | 31 ++++- libguile/vectors.c | 35 ++++++ test-suite/tests/unif.test | 4 +- 12 files changed, 359 insertions(+), 259 deletions(-) (limited to 'libguile/arrays.c') diff --git a/libguile/array-handle.c b/libguile/array-handle.c index 35fc1fc2f..cd5a46698 100644 --- a/libguile/array-handle.c +++ b/libguile/array-handle.c @@ -27,206 +27,82 @@ #include "libguile/__scm.h" #include "libguile/array-handle.h" -#include "libguile/arrays.h" -#include "libguile/strings.h" -#include "libguile/vectors.h" -#include "libguile/srfi-4.h" -#include "libguile/bitvectors.h" -#include "libguile/bytevectors.h" -static SCM -enclosed_ref (scm_t_array_handle *h, ssize_t pos) -{ - return scm_i_cvref (SCM_I_ARRAY_V (h->array), pos + h->base, 1); -} +SCM scm_i_array_element_types[SCM_ARRAY_ELEMENT_TYPE_LAST + 1]; -static SCM -vector_ref (scm_t_array_handle *h, ssize_t pos) -{ - return ((const SCM *)h->elements)[pos]; -} -static SCM -string_ref (scm_t_array_handle *h, ssize_t pos) -{ - pos += h->base; - if (SCM_I_ARRAYP (h->array)) - return scm_c_string_ref (SCM_I_ARRAY_V (h->array), pos); - else - return scm_c_string_ref (h->array, pos); -} +#define ARRAY_IMPLS_N_STATIC_ALLOC 7 +static scm_t_array_implementation array_impls[ARRAY_IMPLS_N_STATIC_ALLOC]; +static int num_array_impls_registered = 0; -static SCM -bitvector_ref (scm_t_array_handle *h, ssize_t pos) -{ - pos += scm_array_handle_bit_elements_offset (h); - return - scm_from_bool (((scm_t_uint32 *)h->elements)[pos/32] & (1l << (pos % 32))); -} - -static SCM -bytevector_ref (scm_t_array_handle *h, ssize_t pos) -{ - return scm_from_uint8 (((scm_t_uint8 *) h->elements)[pos]); -} - -static SCM -memoize_ref (scm_t_array_handle *h, ssize_t pos) -{ - SCM v = h->array; - - if (SCM_I_ENCLOSED_ARRAYP (v)) - { - h->ref = enclosed_ref; - return enclosed_ref (h, pos); - } - - if (SCM_I_ARRAYP (v)) - v = SCM_I_ARRAY_V (v); - - if (scm_is_vector (v)) - { - h->elements = scm_array_handle_elements (h); - h->ref = vector_ref; - } - else if (scm_is_uniform_vector (v)) - { - h->elements = scm_array_handle_uniform_elements (h); - h->ref = scm_i_uniform_vector_ref_proc (v); - } - else if (scm_is_string (v)) - { - h->ref = string_ref; - } - else if (scm_is_bitvector (v)) - { - h->elements = scm_array_handle_bit_elements (h); - h->ref = bitvector_ref; - } - else if (scm_is_bytevector (v)) - { - h->elements = scm_array_handle_uniform_elements (h); - h->ref = bytevector_ref; - } - else - scm_misc_error (NULL, "unknown array type: ~a", scm_list_1 (h->array)); - - return h->ref (h, pos); -} - -static void -enclosed_set (scm_t_array_handle *h, ssize_t pos, SCM val) -{ - scm_wrong_type_arg_msg (NULL, 0, h->array, "non-enclosed array"); -} - -static void -vector_set (scm_t_array_handle *h, ssize_t pos, SCM val) -{ - ((SCM *)h->writable_elements)[pos] = val; -} - -static void -string_set (scm_t_array_handle *h, ssize_t pos, SCM val) -{ - pos += h->base; - if (SCM_I_ARRAYP (h->array)) - scm_c_string_set_x (SCM_I_ARRAY_V (h->array), pos, val); - else - scm_c_string_set_x (h->array, pos, val); -} -static void -bitvector_set (scm_t_array_handle *h, ssize_t pos, SCM val) +void +scm_i_register_array_implementation (scm_t_array_implementation *impl) { - scm_t_uint32 mask; - pos += scm_array_handle_bit_elements_offset (h); - mask = 1l << (pos % 32); - if (scm_to_bool (val)) - ((scm_t_uint32 *)h->writable_elements)[pos/32] |= mask; + if (num_array_impls_registered >= ARRAY_IMPLS_N_STATIC_ALLOC) + /* need to increase ARRAY_IMPLS_N_STATIC_ALLOC, buster */ + abort (); else - ((scm_t_uint32 *)h->writable_elements)[pos/32] &= ~mask; + array_impls[num_array_impls_registered++] = *impl; } -static void -bytevector_set (scm_t_array_handle *h, ssize_t pos, SCM val) +scm_t_array_implementation* +scm_i_array_implementation_for_obj (SCM obj) { - scm_t_uint8 c_value; - scm_t_uint8 *elements; - - c_value = scm_to_uint8 (val); - elements = (scm_t_uint8 *) h->elements; - elements[pos] = (scm_t_uint8) c_value; -} - -static void -memoize_set (scm_t_array_handle *h, ssize_t pos, SCM val) -{ - SCM v = h->array; - - if (SCM_I_ENCLOSED_ARRAYP (v)) - { - h->set = enclosed_set; - enclosed_set (h, pos, val); - return; - } - - if (SCM_I_ARRAYP (v)) - v = SCM_I_ARRAY_V (v); - - if (scm_is_vector (v)) - { - h->writable_elements = scm_array_handle_writable_elements (h); - h->set = vector_set; - } - else if (scm_is_uniform_vector (v)) - { - h->writable_elements = scm_array_handle_uniform_writable_elements (h); - h->set = scm_i_uniform_vector_set_proc (v); - } - else if (scm_is_string (v)) - { - h->set = string_set; - } - else if (scm_is_bitvector (v)) - { - h->writable_elements = scm_array_handle_bit_writable_elements (h); - h->set = bitvector_set; - } - else if (scm_is_bytevector (v)) - { - h->elements = scm_array_handle_uniform_writable_elements (h); - h->set = bytevector_set; - } - else - scm_misc_error (NULL, "unknown array type: ~a", scm_list_1 (h->array)); - - h->set (h, pos, val); + int i; + for (i = 0; i < num_array_impls_registered; i++) + if (SCM_NIMP (obj) + && (SCM_CELL_TYPE (obj) & array_impls[i].mask) == array_impls[i].tag) + return &array_impls[i]; + return NULL; } void scm_array_get_handle (SCM array, scm_t_array_handle *h) { + scm_t_array_implementation *impl = scm_i_array_implementation_for_obj (array); + if (!impl) + scm_wrong_type_arg_msg (NULL, 0, array, "array"); h->array = array; - h->ref = memoize_ref; - h->set = memoize_set; - - if (SCM_I_ARRAYP (array) || SCM_I_ENCLOSED_ARRAYP (array)) - { - h->dims = SCM_I_ARRAY_DIMS (array); - h->base = SCM_I_ARRAY_BASE (array); - } - else if (scm_is_generalized_vector (array)) + h->impl = impl; + h->base = 0; + h->ndims = 0; + h->dims = NULL; + h->element_type = SCM_ARRAY_ELEMENT_TYPE_SCM; /* have to default to + something... */ + h->elements = NULL; + h->writable_elements = NULL; + h->impl->get_handle (array, h); +} + +ssize_t +scm_array_handle_pos (scm_t_array_handle *h, SCM indices) +{ + scm_t_array_dim *s = scm_array_handle_dims (h); + ssize_t pos = 0, i; + size_t k = scm_array_handle_rank (h); + + while (k > 0 && scm_is_pair (indices)) { - h->dim0.lbnd = 0; - h->dim0.ubnd = scm_c_generalized_vector_length (array) - 1; - h->dim0.inc = 1; - h->dims = &h->dim0; - h->base = 0; + i = scm_to_signed_integer (SCM_CAR (indices), s->lbnd, s->ubnd); + pos += (i - s->lbnd) * s->inc; + k--; + s++; + indices = SCM_CDR (indices); } - else - scm_wrong_type_arg_msg (NULL, 0, array, "array"); + if (k > 0 || !scm_is_null (indices)) + scm_misc_error (NULL, "wrong number of indices, expecting ~a", + scm_list_1 (scm_from_size_t (scm_array_handle_rank (h)))); + return pos; +} + +SCM +scm_array_handle_element_type (scm_t_array_handle *h) +{ + if (h->element_type < 0 || h->element_type > SCM_ARRAY_ELEMENT_TYPE_LAST) + abort (); /* guile programming error */ + return scm_i_array_element_types[h->element_type]; } void @@ -236,47 +112,46 @@ scm_array_handle_release (scm_t_array_handle *h) */ } -size_t -scm_array_handle_rank (scm_t_array_handle *h) -{ - if (SCM_I_ARRAYP (h->array) || SCM_I_ENCLOSED_ARRAYP (h->array)) - return SCM_I_ARRAY_NDIM (h->array); - else - return 1; -} - -scm_t_array_dim * -scm_array_handle_dims (scm_t_array_handle *h) -{ - return h->dims; -} - const SCM * scm_array_handle_elements (scm_t_array_handle *h) { - SCM vec = h->array; - if (SCM_I_ARRAYP (vec)) - vec = SCM_I_ARRAY_V (vec); - if (SCM_I_IS_VECTOR (vec)) - return SCM_I_VECTOR_ELTS (vec) + h->base; - scm_wrong_type_arg_msg (NULL, 0, h->array, "non-uniform array"); + if (h->element_type != SCM_ARRAY_ELEMENT_TYPE_SCM) + scm_wrong_type_arg_msg (NULL, 0, h->array, "non-uniform array"); + return ((const SCM*)h->elements) + h->base; } SCM * scm_array_handle_writable_elements (scm_t_array_handle *h) { - SCM vec = h->array; - if (SCM_I_ARRAYP (vec)) - vec = SCM_I_ARRAY_V (vec); - if (SCM_I_IS_VECTOR (vec)) - return SCM_I_VECTOR_WELTS (vec) + h->base; - scm_wrong_type_arg_msg (NULL, 0, h->array, "non-uniform array"); + if (h->element_type != SCM_ARRAY_ELEMENT_TYPE_SCM) + scm_wrong_type_arg_msg (NULL, 0, h->array, "non-uniform array"); + return ((SCM*)h->elements) + h->base; } - void scm_init_array_handle (void) { +#define DEFINE_ARRAY_TYPE(tag, TAG) \ + scm_i_array_element_types[SCM_ARRAY_ELEMENT_TYPE_##TAG] \ + = (scm_permanent_object (scm_from_locale_symbol (#tag))) + + scm_i_array_element_types[SCM_ARRAY_ELEMENT_TYPE_SCM] = SCM_BOOL_T; + DEFINE_ARRAY_TYPE (a, CHAR); + DEFINE_ARRAY_TYPE (b, BIT); + DEFINE_ARRAY_TYPE (vu8, VU8); + DEFINE_ARRAY_TYPE (u8, U8); + DEFINE_ARRAY_TYPE (s8, S8); + DEFINE_ARRAY_TYPE (u16, U16); + DEFINE_ARRAY_TYPE (s16, S16); + DEFINE_ARRAY_TYPE (u32, U32); + DEFINE_ARRAY_TYPE (s32, S32); + DEFINE_ARRAY_TYPE (u64, U64); + DEFINE_ARRAY_TYPE (s64, S64); + DEFINE_ARRAY_TYPE (f32, F32); + DEFINE_ARRAY_TYPE (f64, F64); + DEFINE_ARRAY_TYPE (c32, C32); + DEFINE_ARRAY_TYPE (c64, C64); + #include "libguile/array-handle.x" } diff --git a/libguile/array-handle.h b/libguile/array-handle.h index 21e1f8436..caf9cefbf 100644 --- a/libguile/array-handle.h +++ b/libguile/array-handle.h @@ -25,6 +25,36 @@ #include "libguile/__scm.h" + + +struct scm_t_array_handle; + +typedef SCM (*scm_i_t_array_ref) (struct scm_t_array_handle *, size_t); +typedef void (*scm_i_t_array_set) (struct scm_t_array_handle *, size_t, SCM); + +typedef struct +{ + scm_t_bits tag; + scm_t_bits mask; + scm_i_t_array_ref vref; + scm_i_t_array_set vset; + void (*get_handle)(SCM, struct scm_t_array_handle*); +} scm_t_array_implementation; + +#define SCM_ARRAY_IMPLEMENTATION(tag_,mask_,vref_,vset_,handle_) \ + SCM_SNARF_INIT ({ \ + scm_t_array_implementation impl; \ + impl.tag = tag_; impl.mask = mask_; \ + impl.vref = vref_; impl.vset = vset_; \ + impl.get_handle = handle_; \ + scm_i_register_array_implementation (&impl); \ + }) + + +SCM_INTERNAL void scm_i_register_array_implementation (scm_t_array_implementation *impl); +SCM_INTERNAL scm_t_array_implementation* scm_i_array_implementation_for_obj (SCM obj); + + typedef struct scm_t_array_dim @@ -34,29 +64,56 @@ typedef struct scm_t_array_dim ssize_t inc; } scm_t_array_dim; -struct scm_t_array_handle; +typedef enum { + SCM_ARRAY_ELEMENT_TYPE_SCM = 0, /* SCM values */ + SCM_ARRAY_ELEMENT_TYPE_CHAR = 1, /* characters */ + SCM_ARRAY_ELEMENT_TYPE_BIT = 2, /* packed numeric values */ + SCM_ARRAY_ELEMENT_TYPE_VU8 = 3, + SCM_ARRAY_ELEMENT_TYPE_U8 = 4, + SCM_ARRAY_ELEMENT_TYPE_S8 = 5, + SCM_ARRAY_ELEMENT_TYPE_U16 = 6, + SCM_ARRAY_ELEMENT_TYPE_S16 = 7, + SCM_ARRAY_ELEMENT_TYPE_U32 = 8, + SCM_ARRAY_ELEMENT_TYPE_S32 = 9, + SCM_ARRAY_ELEMENT_TYPE_U64 = 10, + SCM_ARRAY_ELEMENT_TYPE_S64 = 11, + SCM_ARRAY_ELEMENT_TYPE_F32 = 12, + SCM_ARRAY_ELEMENT_TYPE_F64 = 13, + SCM_ARRAY_ELEMENT_TYPE_C32 = 14, + SCM_ARRAY_ELEMENT_TYPE_C64 = 15, + SCM_ARRAY_ELEMENT_TYPE_LAST = 15, +} scm_t_array_element_type; + +SCM_INTERNAL SCM scm_i_array_element_types[]; -typedef SCM (*scm_i_t_array_ref) (struct scm_t_array_handle *, ssize_t); -typedef void (*scm_i_t_array_set) (struct scm_t_array_handle *, ssize_t, SCM); typedef struct scm_t_array_handle { SCM array; + scm_t_array_implementation *impl; + /* `Base' is an offset into elements or writable_elements, corresponding to + the first element in the array. It would be nicer just to adjust the + elements/writable_elements pointer, but we can't because that element might + not even be byte-addressable, as is the case with bitvectors. A nicer + solution would be, well, nice. + */ size_t base; + size_t ndims; /* ndims == the rank of the array */ scm_t_array_dim *dims; scm_t_array_dim dim0; - scm_i_t_array_ref ref; - scm_i_t_array_set set; + scm_t_array_element_type element_type; const void *elements; void *writable_elements; } scm_t_array_handle; +#define scm_array_handle_rank(h) ((h)->ndims) +#define scm_array_handle_dims(h) ((h)->dims) + SCM_API void scm_array_get_handle (SCM array, scm_t_array_handle *h); -SCM_API size_t scm_array_handle_rank (scm_t_array_handle *h); -SCM_API scm_t_array_dim *scm_array_handle_dims (scm_t_array_handle *h); SCM_API ssize_t scm_array_handle_pos (scm_t_array_handle *h, SCM indices); -SCM_API const SCM *scm_array_handle_elements (scm_t_array_handle *h); -SCM_API SCM *scm_array_handle_writable_elements (scm_t_array_handle *h); +SCM_API SCM scm_array_handle_element_type (scm_t_array_handle *h); SCM_API void scm_array_handle_release (scm_t_array_handle *h); +SCM_API const SCM* scm_array_handle_elements (scm_t_array_handle *h); +SCM_API SCM* scm_array_handle_writable_elements (scm_t_array_handle *h); /* See inline.h for scm_array_handle_ref and scm_array_handle_set */ diff --git a/libguile/arrays.c b/libguile/arrays.c index c70d24772..ff6c9516b 100644 --- a/libguile/arrays.c +++ b/libguile/arrays.c @@ -306,27 +306,6 @@ SCM_DEFINE (scm_shared_array_increments, "shared-array-increments", 1, 0, 0, } #undef FUNC_NAME -ssize_t -scm_array_handle_pos (scm_t_array_handle *h, SCM indices) -{ - scm_t_array_dim *s = scm_array_handle_dims (h); - ssize_t pos = 0, i; - size_t k = scm_array_handle_rank (h); - - while (k > 0 && scm_is_pair (indices)) - { - i = scm_to_signed_integer (SCM_CAR (indices), s->lbnd, s->ubnd); - pos += (i - s->lbnd) * s->inc; - k--; - s++; - indices = SCM_CDR (indices); - } - if (k > 0 || !scm_is_null (indices)) - scm_misc_error (NULL, "wrong number of indices, expecting ~a", - scm_list_1 (scm_from_size_t (scm_array_handle_rank (h)))); - return pos; -} - SCM scm_i_make_array (int ndim, int enclosed) { @@ -1604,6 +1583,38 @@ array_free (SCM ptr) 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 () { diff --git a/libguile/bitvectors.c b/libguile/bitvectors.c index a5da47c42..f0bb5c6c8 100644 --- a/libguile/bitvectors.c +++ b/libguile/bitvectors.c @@ -861,6 +861,36 @@ scm_istr2bve (SCM str) return res; } +/* FIXME: h->array should be h->vector */ +static SCM +bitvector_handle_ref (scm_t_array_handle *h, size_t pos) +{ + return scm_c_bitvector_ref (h->array, pos); +} + +static void +bitvector_handle_set (scm_t_array_handle *h, size_t pos, SCM val) +{ + scm_c_bitvector_set_x (h->array, pos, val); +} + +static void +bitvector_get_handle (SCM bv, scm_t_array_handle *h) +{ + h->array = bv; + h->ndims = 1; + h->dims = &h->dim0; + h->dim0.lbnd = 0; + h->dim0.ubnd = BITVECTOR_LENGTH (bv) - 1; + h->dim0.inc = 1; + h->element_type = SCM_ARRAY_ELEMENT_TYPE_BIT; + h->elements = h->writable_elements = BITVECTOR_BITS (bv); +} + +SCM_ARRAY_IMPLEMENTATION (scm_tc16_bitvector, 0xffff, + bitvector_handle_ref, bitvector_handle_set, + bitvector_get_handle); + void scm_init_bitvectors () { diff --git a/libguile/bytevectors.c b/libguile/bytevectors.c index f50102d30..c44db47f2 100644 --- a/libguile/bytevectors.c +++ b/libguile/bytevectors.c @@ -32,6 +32,7 @@ #include "libguile/validate.h" #include "libguile/ieee-754.h" #include "libguile/arrays.h" +#include "libguile/array-handle.h" #include "libguile/srfi-4.h" #include @@ -2058,6 +2059,34 @@ SCM_DEFINE (scm_utf32_to_string, "utf32->string", #undef FUNC_NAME + +/* Bytevectors as generalized vectors & arrays. */ + +static SCM +bv_handle_ref (scm_t_array_handle *h, size_t index) +{ + return SCM_I_MAKINUM (scm_c_bytevector_ref (h->array, index)); +} + +static void +bv_handle_set_x (scm_t_array_handle *h, size_t index, SCM val) +{ + scm_c_bytevector_set_x (h->array, index, scm_to_uint8 (val)); +} + +static void +bytevector_get_handle (SCM v, scm_t_array_handle *h) +{ + h->array = v; + h->ndims = 1; + h->dims = &h->dim0; + h->dim0.lbnd = 0; + h->dim0.ubnd = SCM_BYTEVECTOR_LENGTH (v) - 1; + h->dim0.inc = 1; + h->element_type = SCM_ARRAY_ELEMENT_TYPE_VU8; + h->elements = h->writable_elements = SCM_BYTEVECTOR_CONTENTS (v); +} + /* Initialization. */ @@ -2084,6 +2113,16 @@ scm_bootstrap_bytevectors (void) scm_c_register_extension ("libguile", "scm_init_bytevectors", (scm_t_extension_init_func) scm_init_bytevectors, NULL); + + { + scm_t_array_implementation impl; + impl.tag = scm_tc16_bytevector; + impl.mask = 0xffff; + impl.vref = bv_handle_ref; + impl.vset = bv_handle_set_x; + impl.get_handle = bytevector_get_handle; + scm_i_register_array_implementation (&impl); + } } void diff --git a/libguile/deprecated.h b/libguile/deprecated.h index 5b443c761..ad62a2bad 100644 --- a/libguile/deprecated.h +++ b/libguile/deprecated.h @@ -5,7 +5,7 @@ #ifndef SCM_DEPRECATED_H #define SCM_DEPRECATED_H -/* Copyright (C) 2003,2004, 2005, 2006, 2007 Free Software Foundation, Inc. +/* Copyright (C) 2003,2004, 2005, 2006, 2007, 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 @@ -24,6 +24,7 @@ */ #include "libguile/__scm.h" +#include "libguile/arrays.h" #include "libguile/strings.h" #if (SCM_ENABLE_DEPRECATED == 1) diff --git a/libguile/inline.h b/libguile/inline.h index 0adc92caf..f7a216d7d 100644 --- a/libguile/inline.h +++ b/libguile/inline.h @@ -34,8 +34,9 @@ #include "libguile/pairs.h" #include "libguile/gc.h" #include "libguile/threads.h" -#include "libguile/arrays.h" +#include "libguile/array-handle.h" #include "libguile/ports.h" +#include "libguile/numbers.h" #include "libguile/error.h" @@ -241,7 +242,11 @@ SCM_C_EXTERN_INLINE SCM scm_array_handle_ref (scm_t_array_handle *h, ssize_t p) { - return h->ref (h, p); + if (SCM_UNLIKELY (p < 0 && -p > h->base)) + /* catch overflow */ + scm_out_of_range (NULL, scm_from_ssize_t (p)); + /* perhaps should catch overflow here too */ + return h->impl->vref (h, h->base + p); } #ifndef SCM_INLINE_C_INCLUDING_INLINE_H @@ -250,7 +255,11 @@ SCM_C_EXTERN_INLINE void scm_array_handle_set (scm_t_array_handle *h, ssize_t p, SCM v) { - h->set (h, p, v); + if (SCM_UNLIKELY (p < 0 && -p > h->base)) + /* catch overflow */ + scm_out_of_range (NULL, scm_from_ssize_t (p)); + /* perhaps should catch overflow here too */ + h->impl->vset (h, h->base + p, v); } #ifndef SCM_INLINE_C_INCLUDING_INLINE_H diff --git a/libguile/srfi-4.c b/libguile/srfi-4.c index 14ce84069..408355d38 100644 --- a/libguile/srfi-4.c +++ b/libguile/srfi-4.c @@ -497,11 +497,8 @@ uvec_to_list (int type, SCM uvec) SCM res = SCM_EOL; elts = uvec_elements (type, uvec, &handle, &len, &inc); - for (i = len*inc; i > 0;) - { - i -= inc; - res = scm_cons (scm_array_handle_ref (&handle, i), res); - } + for (i = len - 1; i >= 0; i--) + res = scm_cons (scm_array_handle_ref (&handle, i*inc), res); scm_array_handle_release (&handle); return res; } @@ -1086,18 +1083,35 @@ static scm_i_t_array_set uvec_setters[12] = { c32set, c64set }; -scm_i_t_array_ref -scm_i_uniform_vector_ref_proc (SCM uvec) +static SCM +uvec_handle_ref (scm_t_array_handle *h, size_t index) { - return uvec_reffers[SCM_UVEC_TYPE(uvec)]; + return uvec_reffers [SCM_UVEC_TYPE(h->array)] (h, index); } -scm_i_t_array_set -scm_i_uniform_vector_set_proc (SCM uvec) +static void +uvec_handle_set (scm_t_array_handle *h, size_t index, SCM val) { - return uvec_setters[SCM_UVEC_TYPE(uvec)]; + uvec_setters [SCM_UVEC_TYPE(h->array)] (h, index, val); } +static void +uvec_get_handle (SCM v, scm_t_array_handle *h) +{ + h->array = v; + h->ndims = 1; + h->dims = &h->dim0; + h->dim0.lbnd = 0; + h->dim0.ubnd = SCM_UVEC_LENGTH (v) - 1; + h->dim0.inc = 1; + h->element_type = SCM_UVEC_TYPE (v) + SCM_ARRAY_ELEMENT_TYPE_U8; + h->elements = h->writable_elements = SCM_UVEC_BASE (v); +} + +SCM_ARRAY_IMPLEMENTATION (scm_tc16_uvec, 0xffff, + uvec_handle_ref, uvec_handle_set, + uvec_get_handle); + void scm_init_srfi_4 (void) { diff --git a/libguile/srfi-4.i.c b/libguile/srfi-4.i.c index 58a52c1d8..84553c804 100644 --- a/libguile/srfi-4.i.c +++ b/libguile/srfi-4.i.c @@ -187,13 +187,13 @@ F(scm_,TAG,vector_writable_elements) (SCM uvec, #endif static SCM -F(,TAG,ref) (scm_t_array_handle *handle, ssize_t pos) +F(,TAG,ref) (scm_t_array_handle *handle, size_t pos) { return uvec_fast_ref (TYPE, handle->elements, pos); } static void -F(,TAG,set) (scm_t_array_handle *handle, ssize_t pos, SCM val) +F(,TAG,set) (scm_t_array_handle *handle, size_t pos, SCM val) { uvec_fast_set_x (TYPE, handle->writable_elements, pos, val); } diff --git a/libguile/strings.c b/libguile/strings.c index 4e21f3e28..a35b7bfdf 100644 --- a/libguile/strings.c +++ b/libguile/strings.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995,1996,1998,2000,2001, 2004, 2006, 2008 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1998,2000,2001, 2004, 2006, 2008, 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 @@ -1096,6 +1096,35 @@ scm_i_deprecated_string_length (SCM str) #endif +static SCM +string_handle_ref (scm_t_array_handle *h, size_t index) +{ + return scm_c_string_ref (h->array, index); +} + +static void +string_handle_set (scm_t_array_handle *h, size_t index, SCM val) +{ + scm_c_string_set_x (h->array, index, val); +} + +static void +string_get_handle (SCM v, scm_t_array_handle *h) +{ + h->array = v; + h->ndims = 1; + h->dims = &h->dim0; + h->dim0.lbnd = 0; + h->dim0.ubnd = scm_c_string_length (v) - 1; + h->dim0.inc = 1; + h->element_type = SCM_ARRAY_ELEMENT_TYPE_CHAR; + h->elements = h->writable_elements = NULL; +} + +SCM_ARRAY_IMPLEMENTATION (scm_tc7_string, 0x7f & ~2, + string_handle_ref, string_handle_set, + string_get_handle); + void scm_init_strings () { diff --git a/libguile/vectors.c b/libguile/vectors.c index 93f110a21..2d77f158b 100644 --- a/libguile/vectors.c +++ b/libguile/vectors.c @@ -656,6 +656,41 @@ SCM_DEFINE (scm_generalized_vector_to_list, "generalized-vector->list", 1, 0, 0, } #undef FUNC_NAME +static SCM +vector_handle_ref (scm_t_array_handle *h, size_t idx) +{ + if (idx > h->dims[0].ubnd) + scm_out_of_range ("vector-handle-ref", scm_from_size_t (idx)); + return ((SCM*)h->elements)[idx]; +} + +static void +vector_handle_set (scm_t_array_handle *h, size_t idx, SCM val) +{ + if (idx > h->dims[0].ubnd) + scm_out_of_range ("vector-handle-set!", scm_from_size_t (idx)); + ((SCM*)h->writable_elements)[idx] = val; +} + +static void +vector_get_handle (SCM v, scm_t_array_handle *h) +{ + h->array = v; + h->ndims = 1; + h->dims = &h->dim0; + h->dim0.lbnd = 0; + h->dim0.ubnd = SCM_I_VECTOR_LENGTH (v) - 1; + h->dim0.inc = 1; + h->element_type = SCM_ARRAY_ELEMENT_TYPE_SCM; + h->elements = h->writable_elements = SCM_I_VECTOR_WELTS (v); +} + +SCM_ARRAY_IMPLEMENTATION (scm_tc7_vector, 0x7f & ~2, + vector_handle_ref, vector_handle_set, + vector_get_handle); +SCM_ARRAY_IMPLEMENTATION (scm_tc7_wvect, 0x7f & ~2, + vector_handle_ref, vector_handle_set, + vector_get_handle); void scm_init_vectors () diff --git a/test-suite/tests/unif.test b/test-suite/tests/unif.test index 61dbeb89e..5d584e86e 100644 --- a/test-suite/tests/unif.test +++ b/test-suite/tests/unif.test @@ -1,6 +1,6 @@ ;;;; unif.test --- tests guile's uniform arrays -*- scheme -*- ;;;; -;;;; Copyright 2004, 2006 Free Software Foundation, Inc. +;;;; Copyright 2004, 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 @@ -17,7 +17,7 @@ ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA (define-module (test-suite test-unif) - #:use-module (test-suite lib)) + #:use-module (test-suite lib)) ;;; ;;; array? -- cgit v1.2.3 From 66b9d7d304a349d5bb4f763a47143f09da58d97f Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 17 Jul 2009 12:45:24 +0200 Subject: remove enclosed arrays * libguile/arrays.h: * libguile/array-map.c: * libguile/arrays.c: * libguile/deprecated.c: Remove "enclosed arrays". The only user-facing procedures that this affects are scm_enclose_array / enclose-array. If enclosed arrays are added back, it should be through the generic array interface; but really, it sounds like something that would be better implemented in Scheme. --- libguile/array-map.c | 8 +-- libguile/arrays.c | 183 +++++--------------------------------------------- libguile/arrays.h | 7 +- libguile/deprecated.c | 2 +- 4 files changed, 23 insertions(+), 177 deletions(-) (limited to 'libguile/arrays.c') diff --git a/libguile/array-map.c b/libguile/array-map.c index 3b60f45e7..eec42126f 100644 --- a/libguile/array-map.c +++ b/libguile/array-map.c @@ -220,7 +220,7 @@ scm_ramapc (int (*cproc)(), SCM data, SCM ra0, SCM lra, const char *what) if (!SCM_I_ARRAYP (vra0)) { size_t length = scm_c_generalized_vector_length (vra0); - vra1 = scm_i_make_array (1, 0); + vra1 = scm_i_make_array (1); SCM_I_ARRAY_BASE (vra1) = 0; SCM_I_ARRAY_DIMS (vra1)->lbnd = 0; SCM_I_ARRAY_DIMS (vra1)->ubnd = length - 1; @@ -233,7 +233,7 @@ scm_ramapc (int (*cproc)(), SCM data, SCM ra0, SCM lra, const char *what) for (z = lra; SCM_NIMP (z); z = SCM_CDR (z)) { ra1 = SCM_CAR (z); - vra1 = scm_i_make_array (1, 0); + vra1 = scm_i_make_array (1); SCM_I_ARRAY_DIMS (vra1)->lbnd = SCM_I_ARRAY_DIMS (vra0)->lbnd; SCM_I_ARRAY_DIMS (vra1)->ubnd = SCM_I_ARRAY_DIMS (vra0)->ubnd; if (!SCM_I_ARRAYP (ra1)) @@ -256,7 +256,7 @@ scm_ramapc (int (*cproc)(), SCM data, SCM ra0, SCM lra, const char *what) return (SCM_UNBNDP (data) ? cproc(vra0, lvra) : cproc(vra0, data, lvra)); case 1: gencase: /* Have to loop over all dimensions. */ - vra0 = scm_i_make_array (1, 0); + vra0 = scm_i_make_array (1); if (SCM_I_ARRAYP (ra0)) { kmax = SCM_I_ARRAY_NDIM (ra0) - 1; @@ -291,7 +291,7 @@ scm_ramapc (int (*cproc)(), SCM data, SCM ra0, SCM lra, const char *what) for (z = lra; SCM_NIMP (z); z = SCM_CDR (z)) { ra1 = SCM_CAR (z); - vra1 = scm_i_make_array (1, 0); + vra1 = scm_i_make_array (1); SCM_I_ARRAY_DIMS (vra1)->lbnd = SCM_I_ARRAY_DIMS (vra0)->lbnd; SCM_I_ARRAY_DIMS (vra1)->ubnd = SCM_I_ARRAY_DIMS (vra0)->ubnd; if (SCM_I_ARRAYP (ra1)) diff --git a/libguile/arrays.c b/libguile/arrays.c index ff6c9516b..31a478e80 100644 --- a/libguile/arrays.c +++ b/libguile/arrays.c @@ -82,7 +82,6 @@ */ scm_t_bits scm_i_tc16_array; -scm_t_bits scm_i_tc16_enclosed_array; #define SCM_SET_ARRAY_CONTIGUOUS_FLAG(x) \ (SCM_SET_CELL_WORD_0 ((x), SCM_CELL_WORD_0 (x) | SCM_I_ARRAY_FLAG_CONTIGUOUS)) @@ -149,21 +148,13 @@ make_typed_vector (SCM type, size_t len) int scm_is_array (SCM obj) { - return (SCM_I_ENCLOSED_ARRAYP (obj) - || SCM_I_ARRAYP (obj) + return (SCM_I_ARRAYP (obj) || scm_is_generalized_vector (obj)); } int scm_is_typed_array (SCM obj, SCM type) { - if (SCM_I_ENCLOSED_ARRAYP (obj)) - { - /* Enclosed arrays are arrays but are not of any type. - */ - return 0; - } - /* Get storage vector. */ if (SCM_I_ARRAYP (obj)) @@ -261,7 +252,7 @@ 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_I_ARRAYP (ra) || SCM_I_ENCLOSED_ARRAYP (ra)) + if (SCM_I_ARRAYP (ra)) return SCM_I_ARRAY_V (ra); else if (scm_is_generalized_vector (ra)) return ra; @@ -307,11 +298,10 @@ SCM_DEFINE (scm_shared_array_increments, "shared-array-increments", 1, 0, 0, #undef FUNC_NAME SCM -scm_i_make_array (int ndim, int enclosed) +scm_i_make_array (int ndim) { - scm_t_bits tag = enclosed? scm_i_tc16_enclosed_array : scm_i_tc16_array; SCM ra; - SCM_NEWSMOB(ra, ((scm_t_bits) ndim << 17) + tag, + 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")); @@ -333,7 +323,7 @@ scm_i_shap2ra (SCM args) if (ndim < 0) scm_misc_error (NULL, s_bad_spec, SCM_EOL); - ra = scm_i_make_array (ndim, 0); + 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)) @@ -633,7 +623,7 @@ SCM_DEFINE (scm_transpose_array, "transpose-array", 1, 0, 1, return ra; } - if (SCM_I_ARRAYP (ra) || SCM_I_ENCLOSED_ARRAYP (ra)) + if (SCM_I_ARRAYP (ra)) { vargs = scm_vector (args); if (SCM_SIMPLE_VECTOR_LENGTH (vargs) != SCM_I_ARRAY_NDIM (ra)) @@ -647,7 +637,7 @@ SCM_DEFINE (scm_transpose_array, "transpose-array", 1, 0, 1, ndim = i; } ndim++; - res = scm_i_make_array (ndim, 0); + 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--;) @@ -689,96 +679,6 @@ SCM_DEFINE (scm_transpose_array, "transpose-array", 1, 0, 1, } #undef FUNC_NAME -/* args are RA . AXES */ -SCM_DEFINE (scm_enclose_array, "enclose-array", 1, 0, 1, - (SCM ra, SCM axes), - "@var{dim0}, @var{dim1} @dots{} should be nonnegative integers less than\n" - "the rank of @var{array}. @var{enclose-array} returns an array\n" - "resembling an array of shared arrays. The dimensions of each shared\n" - "array are the same as the @var{dim}th dimensions of the original array,\n" - "the dimensions of the outer array are the same as those of the original\n" - "array that did not match a @var{dim}.\n\n" - "An enclosed array is not a general Scheme array. Its elements may not\n" - "be set using @code{array-set!}. Two references to the same element of\n" - "an enclosed array will be @code{equal?} but will not in general be\n" - "@code{eq?}. The value returned by @var{array-prototype} when given an\n" - "enclosed array is unspecified.\n\n" - "examples:\n" - "@lisp\n" - "(enclose-array '#3(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1) @result{}\n" - " #\n\n" - "(enclose-array '#3(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1 0) @result{}\n" - " #\n" - "@end lisp") -#define FUNC_NAME s_scm_enclose_array -{ - SCM axv, res, ra_inr; - const char *c_axv; - scm_t_array_dim vdim, *s = &vdim; - int ndim, j, k, ninr, noutr; - - SCM_VALIDATE_REST_ARGUMENT (axes); - if (scm_is_null (axes)) - axes = scm_cons ((SCM_I_ARRAYP (ra) ? scm_from_size_t (SCM_I_ARRAY_NDIM (ra) - 1) : SCM_INUM0), SCM_EOL); - ninr = scm_ilength (axes); - if (ninr < 0) - SCM_WRONG_NUM_ARGS (); - ra_inr = scm_i_make_array (ninr, 0); - - if (scm_is_generalized_vector (ra)) - { - s->lbnd = 0; - s->ubnd = scm_c_generalized_vector_length (ra) - 1; - s->inc = 1; - SCM_I_ARRAY_V (ra_inr) = ra; - SCM_I_ARRAY_BASE (ra_inr) = 0; - ndim = 1; - } - else if (SCM_I_ARRAYP (ra)) - { - s = SCM_I_ARRAY_DIMS (ra); - SCM_I_ARRAY_V (ra_inr) = SCM_I_ARRAY_V (ra); - SCM_I_ARRAY_BASE (ra_inr) = SCM_I_ARRAY_BASE (ra); - ndim = SCM_I_ARRAY_NDIM (ra); - } - else - scm_wrong_type_arg_msg (NULL, 0, ra, "array"); - - noutr = ndim - ninr; - if (noutr < 0) - SCM_WRONG_NUM_ARGS (); - axv = scm_make_string (scm_from_int (ndim), SCM_MAKE_CHAR (0)); - res = scm_i_make_array (noutr, 1); - SCM_I_ARRAY_BASE (res) = SCM_I_ARRAY_BASE (ra_inr); - SCM_I_ARRAY_V (res) = ra_inr; - for (k = 0; k < ninr; k++, axes = SCM_CDR (axes)) - { - if (!scm_is_integer (SCM_CAR (axes))) - SCM_MISC_ERROR ("bad axis", SCM_EOL); - j = scm_to_int (SCM_CAR (axes)); - SCM_I_ARRAY_DIMS (ra_inr)[k].lbnd = s[j].lbnd; - SCM_I_ARRAY_DIMS (ra_inr)[k].ubnd = s[j].ubnd; - SCM_I_ARRAY_DIMS (ra_inr)[k].inc = s[j].inc; - scm_c_string_set_x (axv, j, SCM_MAKE_CHAR (1)); - } - c_axv = scm_i_string_chars (axv); - for (j = 0, k = 0; k < noutr; k++, j++) - { - while (c_axv[j]) - j++; - SCM_I_ARRAY_DIMS (res)[k].lbnd = s[j].lbnd; - SCM_I_ARRAY_DIMS (res)[k].ubnd = s[j].ubnd; - SCM_I_ARRAY_DIMS (res)[k].inc = s[j].inc; - } - scm_remember_upto_here_1 (axv); - scm_i_ra_set_contp (ra_inr); - scm_i_ra_set_contp (res); - return res; -} -#undef FUNC_NAME - - - SCM_DEFINE (scm_array_in_bounds_p, "array-in-bounds?", 1, 0, 1, (SCM v, SCM args), "Return @code{#t} if its arguments would be acceptable to\n" @@ -789,7 +689,7 @@ SCM_DEFINE (scm_array_in_bounds_p, "array-in-bounds?", 1, 0, 1, SCM_VALIDATE_REST_ARGUMENT (args); - if (SCM_I_ARRAYP (v) || SCM_I_ENCLOSED_ARRAYP (v)) + if (SCM_I_ARRAYP (v)) { size_t k, ndim = SCM_I_ARRAY_NDIM (v); scm_t_array_dim *s = SCM_I_ARRAY_DIMS (v); @@ -838,27 +738,6 @@ SCM_DEFINE (scm_array_in_bounds_p, "array-in-bounds?", 1, 0, 1, } #undef FUNC_NAME -SCM -scm_i_cvref (SCM v, size_t pos, int enclosed) -{ - if (enclosed) - { - int k = SCM_I_ARRAY_NDIM (v); - SCM res = scm_i_make_array (k, 0); - SCM_I_ARRAY_V (res) = SCM_I_ARRAY_V (v); - SCM_I_ARRAY_BASE (res) = pos; - while (k--) - { - SCM_I_ARRAY_DIMS (res)[k].ubnd = SCM_I_ARRAY_DIMS (v)[k].ubnd; - SCM_I_ARRAY_DIMS (res)[k].lbnd = SCM_I_ARRAY_DIMS (v)[k].lbnd; - SCM_I_ARRAY_DIMS (res)[k].inc = SCM_I_ARRAY_DIMS (v)[k].inc; - } - return res; - } - else - return scm_c_generalized_vector_ref (v, pos); -} - SCM_DEFINE (scm_array_ref, "array-ref", 1, 0, 1, (SCM v, SCM args), "Return the element at the @code{(index1, index2)} element in\n" @@ -940,7 +819,7 @@ SCM_DEFINE (scm_array_contents, "array-contents", 1, 1, 0, return v; } - sra = scm_i_make_array (1, 0); + 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); @@ -948,8 +827,6 @@ SCM_DEFINE (scm_array_contents, "array-contents", 1, 1, 0, SCM_I_ARRAY_DIMS (sra)->inc = (ndim ? SCM_I_ARRAY_DIMS (ra)[ndim - 1].inc : 1); return sra; } - else if (SCM_I_ENCLOSED_ARRAYP (ra)) - scm_wrong_type_arg_msg (NULL, 0, ra, "non-enclosed array"); else scm_wrong_type_arg_msg (NULL, 0, ra, "array"); } @@ -974,7 +851,7 @@ scm_ra2contig (SCM ra, int copy) 0 == len % SCM_LONG_BIT)) return ra; } - ret = scm_i_make_array (k, 0); + ret = scm_i_make_array (k); SCM_I_ARRAY_BASE (ret) = 0; while (k--) { @@ -1042,8 +919,6 @@ SCM_DEFINE (scm_uniform_array_read_x, "uniform-array-read!", 1, 3, 0, scm_array_copy_x (cra, ura); return ans; } - else if (SCM_I_ENCLOSED_ARRAYP (ura)) - scm_wrong_type_arg_msg (NULL, 0, ura, "non-enclosed array"); else scm_wrong_type_arg_msg (NULL, 0, ura, "array"); } @@ -1094,8 +969,6 @@ SCM_DEFINE (scm_uniform_array_write, "uniform-array-write", 1, 3, 0, return ans; } - else if (SCM_I_ENCLOSED_ARRAYP (ura)) - scm_wrong_type_arg_msg (NULL, 0, ura, "non-enclosed array"); else scm_wrong_type_arg_msg (NULL, 0, ura, "array"); } @@ -1108,10 +981,9 @@ ra2l (SCM ra, unsigned long base, unsigned long k) SCM res = SCM_EOL; long inc; size_t i; - int enclosed = SCM_I_ENCLOSED_ARRAYP (ra); if (k == SCM_I_ARRAY_NDIM (ra)) - return scm_i_cvref (SCM_I_ARRAY_V (ra), base, enclosed); + return scm_c_generalized_vector_ref (SCM_I_ARRAY_V (ra), base); inc = SCM_I_ARRAY_DIMS (ra)[k].inc; if (SCM_I_ARRAY_DIMS (ra)[k].ubnd < SCM_I_ARRAY_DIMS (ra)[k].lbnd) @@ -1135,7 +1007,7 @@ SCM_DEFINE (scm_array_to_list, "array->list", 1, 0, 0, { if (scm_is_generalized_vector (v)) return scm_generalized_vector_to_list (v); - else if (SCM_I_ARRAYP (v) || SCM_I_ENCLOSED_ARRAYP (v)) + else if (SCM_I_ARRAYP (v)) return ra2l (v, SCM_I_ARRAY_BASE (v), 0); scm_wrong_type_arg_msg (NULL, 0, v, "array"); @@ -1258,7 +1130,7 @@ l2ra (SCM lst, scm_t_array_handle *handle, ssize_t pos, size_t k) */ static int -scm_i_print_array_dimension (SCM array, int dim, int base, int enclosed, +scm_i_print_array_dimension (SCM array, int dim, int base, SCM port, scm_print_state *pstate) { scm_t_array_dim *dim_spec = SCM_I_ARRAY_DIMS (array) + dim; @@ -1269,10 +1141,10 @@ scm_i_print_array_dimension (SCM array, int dim, int base, int enclosed, for (idx = dim_spec->lbnd; idx <= dim_spec->ubnd; idx++) { if (dim < SCM_I_ARRAY_NDIM(array)-1) - scm_i_print_array_dimension (array, dim+1, base, enclosed, + scm_i_print_array_dimension (array, dim+1, base, port, pstate); else - scm_iprin1 (scm_i_cvref (SCM_I_ARRAY_V (array), base, enclosed), + scm_iprin1 (scm_c_generalized_vector_ref (SCM_I_ARRAY_V (array), base), port, pstate); if (idx < dim_spec->ubnd) scm_putc (' ', port); @@ -1357,25 +1229,12 @@ scm_i_print_array (SCM array, SCM port, scm_print_state *pstate) can be modified with array-set!, say. */ scm_putc ('(', port); - scm_iprin1 (scm_i_cvref (v, base, 0), port, pstate); + scm_iprin1 (scm_c_generalized_vector_ref (v, base), port, pstate); scm_putc (')', port); return 1; } else - return scm_i_print_array_dimension (array, 0, base, 0, port, pstate); -} - -static int -scm_i_print_enclosed_array (SCM array, SCM port, scm_print_state *pstate) -{ - size_t base; - - scm_putc ('#', port); - base = SCM_I_ARRAY_BASE (array); - scm_puts ("', port); - return 1; + return scm_i_print_array_dimension (array, 0, base, port, pstate); } /* Read an array. This function can also read vectors and uniform @@ -1560,8 +1419,6 @@ SCM_DEFINE (scm_array_type, "array-type", 1, 0, 0, return scm_i_generalized_vector_type (SCM_I_ARRAY_V (ra)); else if (scm_is_generalized_vector (ra)) return scm_i_generalized_vector_type (ra); - else if (SCM_I_ENCLOSED_ARRAYP (ra)) - scm_wrong_type_arg_msg (NULL, 0, ra, "non-enclosed array"); else scm_wrong_type_arg_msg (NULL, 0, ra, "array"); } @@ -1624,12 +1481,6 @@ scm_init_arrays () 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_i_tc16_enclosed_array = scm_make_smob_type ("enclosed-array", 0); - scm_set_smob_mark (scm_i_tc16_enclosed_array, array_mark); - scm_set_smob_free (scm_i_tc16_enclosed_array, array_free); - scm_set_smob_print (scm_i_tc16_enclosed_array, scm_i_print_enclosed_array); - scm_set_smob_equalp (scm_i_tc16_enclosed_array, scm_array_equal_p); - scm_add_feature ("array"); init_type_creator_table (); diff --git a/libguile/arrays.h b/libguile/arrays.h index 4ca39d00b..45c0bec38 100644 --- a/libguile/arrays.h +++ b/libguile/arrays.h @@ -51,7 +51,6 @@ SCM_API SCM scm_shared_array_offset (SCM ra); SCM_API SCM scm_shared_array_increments (SCM ra); SCM_API SCM scm_make_shared_array (SCM oldra, SCM mapfunc, SCM dims); SCM_API SCM scm_transpose_array (SCM ra, SCM args); -SCM_API SCM scm_enclose_array (SCM ra, SCM axes); SCM_API SCM scm_array_in_bounds_p (SCM v, SCM args); SCM_API SCM scm_array_ref (SCM v, SCM args); SCM_API SCM scm_array_set_x (SCM v, SCM obj, SCM args); @@ -79,13 +78,10 @@ typedef struct scm_i_t_array } scm_i_t_array; SCM_API scm_t_bits scm_i_tc16_array; -SCM_API scm_t_bits scm_i_tc16_enclosed_array; #define SCM_I_ARRAY_FLAG_CONTIGUOUS (1 << 16) #define SCM_I_ARRAYP(a) SCM_TYP16_PREDICATE (scm_i_tc16_array, a) -#define SCM_I_ENCLOSED_ARRAYP(a) \ - SCM_TYP16_PREDICATE (scm_i_tc16_enclosed_array, a) #define SCM_I_ARRAY_NDIM(x) ((size_t) (SCM_CELL_WORD_0 (x) >> 17)) #define SCM_I_ARRAY_CONTP(x) (SCM_CELL_WORD_0(x) & SCM_I_ARRAY_FLAG_CONTIGUOUS) @@ -95,8 +91,7 @@ SCM_API scm_t_bits scm_i_tc16_enclosed_array; #define SCM_I_ARRAY_DIMS(a) \ ((scm_t_array_dim *)((char *) SCM_I_ARRAY_MEM (a) + sizeof (scm_i_t_array))) -SCM_INTERNAL SCM scm_i_make_array (int ndim, int enclosed); -SCM_INTERNAL SCM scm_i_cvref (SCM v, size_t p, int enclosed); +SCM_INTERNAL SCM scm_i_make_array (int ndim); SCM_INTERNAL SCM scm_i_read_array (SCM port, int c); SCM_INTERNAL void scm_init_arrays (void); diff --git a/libguile/deprecated.c b/libguile/deprecated.c index 57a2f0657..f9a858b53 100644 --- a/libguile/deprecated.c +++ b/libguile/deprecated.c @@ -1309,7 +1309,7 @@ scm_i_arrayp (SCM a) { scm_c_issue_deprecation_warning ("SCM_ARRAYP is deprecated. Use scm_is_array instead."); - return SCM_I_ARRAYP(a) || SCM_I_ENCLOSED_ARRAYP(a); + return SCM_I_ARRAYP(a); } size_t -- cgit v1.2.3 From 1030b45049f564f4abd459abd8e59db34c7867cc Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 17 Jul 2009 18:54:06 +0200 Subject: move generic array foo out to its own file * libguile/arrays.h: * libguile/arrays.c: * libguile/generalized-arrays.h: * libguile/generalized-arrays.c: Move some generic functionality out of arrays.c to a new file. * libguile/array-map.c: * libguile/deprecated.c: * libguile/init.c: Update includers. --- libguile.h | 1 + libguile/Makefile.am | 4 + libguile/array-map.c | 1 + libguile/arrays.c | 253 +------------------------------------- libguile/arrays.h | 26 +--- libguile/deprecated.c | 1 + libguile/generalized-arrays.c | 276 ++++++++++++++++++++++++++++++++++++++++++ libguile/generalized-arrays.h | 63 ++++++++++ libguile/init.c | 2 + 9 files changed, 355 insertions(+), 272 deletions(-) create mode 100644 libguile/generalized-arrays.c create mode 100644 libguile/generalized-arrays.h (limited to 'libguile/arrays.c') diff --git a/libguile.h b/libguile.h index 2018a0be1..3fdafc2ba 100644 --- a/libguile.h +++ b/libguile.h @@ -54,6 +54,7 @@ extern "C" { #include "libguile/futures.h" #include "libguile/gc.h" #include "libguile/gdbint.h" +#include "libguile/generalized-arrays.h" #include "libguile/goops.h" #include "libguile/gsubr.h" #include "libguile/guardians.h" diff --git a/libguile/Makefile.am b/libguile/Makefile.am index bc1ec2ba9..3b5828f50 100644 --- a/libguile/Makefile.am +++ b/libguile/Makefile.am @@ -143,6 +143,7 @@ libguile_la_SOURCES = \ gc_os_dep.c \ gdbint.c \ gettext.c \ + generalized-arrays.c \ goops.c \ gsubr.c \ guardians.c \ @@ -250,6 +251,7 @@ DOT_X_FILES = \ gc-segment.x \ gc.x \ gettext.x \ + generalized-arrays.x \ goops.x \ gsubr.x \ guardians.x \ @@ -348,6 +350,7 @@ DOT_DOC_FILES = \ gc-segment.doc \ gc.doc \ gettext.doc \ + generalized-arrays.doc \ goops.doc \ gsubr.doc \ guardians.doc \ @@ -490,6 +493,7 @@ modinclude_HEADERS = \ gdb_interface.h \ gdbint.h \ gettext.h \ + generalized-arrays.h \ goops.h \ gsubr.h \ guardians.h \ diff --git a/libguile/array-map.c b/libguile/array-map.c index eec42126f..c6f5ead1d 100644 --- a/libguile/array-map.c +++ b/libguile/array-map.c @@ -38,6 +38,7 @@ #include "libguile/bitvectors.h" #include "libguile/srfi-4.h" #include "libguile/dynwind.h" +#include "libguile/generalized-arrays.h" #include "libguile/validate.h" #include "libguile/array-map.h" diff --git a/libguile/arrays.c b/libguile/arrays.c index 31a478e80..0d2302d9c 100644 --- a/libguile/arrays.c +++ b/libguile/arrays.c @@ -17,13 +17,6 @@ */ -/* - This file has code for arrays in lots of variants (double, integer, - unsigned etc. ). It suffers from hugely repetitive code because - there is similar (but different) code for every variant included. (urg.) - - --hwn -*/ #ifdef HAVE_CONFIG_H @@ -54,6 +47,7 @@ #include "libguile/validate.h" #include "libguile/arrays.h" +#include "libguile/generalized-arrays.h" #include "libguile/array-map.h" #include "libguile/print.h" #include "libguile/read.h" @@ -145,107 +139,6 @@ make_typed_vector (SCM type, size_t len) return creator (scm_from_size_t (len), SCM_UNDEFINED); } -int -scm_is_array (SCM obj) -{ - return (SCM_I_ARRAYP (obj) - || scm_is_generalized_vector (obj)); -} - -int -scm_is_typed_array (SCM obj, SCM type) -{ - /* Get storage vector. - */ - if (SCM_I_ARRAYP (obj)) - obj = SCM_I_ARRAY_V (obj); - - /* It must be a generalized vector (which includes vectors, strings, etc). - */ - if (!scm_is_generalized_vector (obj)) - return 0; - - return scm_is_eq (type, scm_i_generalized_vector_type (obj)); -} - -/* We keep the old 2-argument C prototype for a while although the old - PROT argument is always ignored now. C code should probably use - scm_is_array or scm_is_typed_array anyway. -*/ - -SCM_DEFINE (scm_array_p, "array?", 1, 0, 0, - (SCM obj), - "Return @code{#t} if the @var{obj} is an array, and @code{#f} if\n" - "not.") -#define FUNC_NAME s_scm_array_p -{ - return scm_from_bool (scm_is_array (obj)); -} -#undef FUNC_NAME - -SCM_DEFINE (scm_typed_array_p, "typed-array?", 2, 0, 0, - (SCM obj, SCM type), - "Return @code{#t} if the @var{obj} is an array of type\n" - "@var{type}, and @code{#f} if not.") -#define FUNC_NAME s_scm_typed_array_p -{ - return scm_from_bool (scm_is_typed_array (obj, type)); -} -#undef FUNC_NAME - -size_t -scm_c_array_rank (SCM array) -{ - scm_t_array_handle handle; - size_t res; - - scm_array_get_handle (array, &handle); - res = scm_array_handle_rank (&handle); - scm_array_handle_release (&handle); - return res; -} - -SCM_DEFINE (scm_array_rank, "array-rank", 1, 0, 0, - (SCM array), - "Return the number of dimensions of the array @var{array.}\n") -#define FUNC_NAME s_scm_array_rank -{ - return scm_from_size_t (scm_c_array_rank (array)); -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_array_dimensions, "array-dimensions", 1, 0, 0, - (SCM ra), - "@code{array-dimensions} is similar to @code{array-shape} but replaces\n" - "elements with a @code{0} minimum with one greater than the maximum. So:\n" - "@lisp\n" - "(array-dimensions (make-array 'foo '(-1 3) 5)) @result{} ((-1 3) 5)\n" - "@end lisp") -#define FUNC_NAME s_scm_array_dimensions -{ - scm_t_array_handle handle; - scm_t_array_dim *s; - SCM res = SCM_EOL; - size_t k; - - scm_array_get_handle (ra, &handle); - s = scm_array_handle_dims (&handle); - k = scm_array_handle_rank (&handle); - - while (k--) - res = scm_cons (s[k].lbnd - ? scm_cons2 (scm_from_ssize_t (s[k].lbnd), - scm_from_ssize_t (s[k].ubnd), - SCM_EOL) - : scm_from_ssize_t (1 + s[k].ubnd), - res); - - scm_array_handle_release (&handle); - return res; -} -#undef FUNC_NAME - SCM_DEFINE (scm_shared_array_root, "shared-array-root", 1, 0, 0, (SCM ra), @@ -679,97 +572,6 @@ SCM_DEFINE (scm_transpose_array, "transpose-array", 1, 0, 1, } #undef FUNC_NAME -SCM_DEFINE (scm_array_in_bounds_p, "array-in-bounds?", 1, 0, 1, - (SCM v, SCM args), - "Return @code{#t} if its arguments would be acceptable to\n" - "@code{array-ref}.") -#define FUNC_NAME s_scm_array_in_bounds_p -{ - SCM res = SCM_BOOL_T; - - SCM_VALIDATE_REST_ARGUMENT (args); - - if (SCM_I_ARRAYP (v)) - { - size_t k, ndim = SCM_I_ARRAY_NDIM (v); - scm_t_array_dim *s = SCM_I_ARRAY_DIMS (v); - - for (k = 0; k < ndim; k++) - { - long ind; - - if (!scm_is_pair (args)) - SCM_WRONG_NUM_ARGS (); - ind = scm_to_long (SCM_CAR (args)); - args = SCM_CDR (args); - - if (ind < s[k].lbnd || ind > s[k].ubnd) - { - res = SCM_BOOL_F; - /* We do not stop the checking after finding a violation - since we want to validate the type-correctness and - number of arguments in any case. - */ - } - } - } - else if (scm_is_generalized_vector (v)) - { - /* Since real arrays have been covered above, all generalized - vectors are guaranteed to be zero-origin here. - */ - - long ind; - - if (!scm_is_pair (args)) - SCM_WRONG_NUM_ARGS (); - ind = scm_to_long (SCM_CAR (args)); - args = SCM_CDR (args); - res = scm_from_bool (ind >= 0 - && ind < scm_c_generalized_vector_length (v)); - } - else - scm_wrong_type_arg_msg (NULL, 0, v, "array"); - - if (!scm_is_null (args)) - SCM_WRONG_NUM_ARGS (); - - return res; -} -#undef FUNC_NAME - -SCM_DEFINE (scm_array_ref, "array-ref", 1, 0, 1, - (SCM v, SCM args), - "Return the element at the @code{(index1, index2)} element in\n" - "@var{array}.") -#define FUNC_NAME s_scm_array_ref -{ - scm_t_array_handle handle; - SCM res; - - scm_array_get_handle (v, &handle); - res = scm_array_handle_ref (&handle, scm_array_handle_pos (&handle, args)); - scm_array_handle_release (&handle); - return res; -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_array_set_x, "array-set!", 2, 0, 1, - (SCM v, SCM obj, SCM args), - "Set the element at the @code{(index1, index2)} element in @var{array} to\n" - "@var{new-value}. The value returned by array-set! is unspecified.") -#define FUNC_NAME s_scm_array_set_x -{ - scm_t_array_handle handle; - - scm_array_get_handle (v, &handle); - scm_array_handle_set (&handle, scm_array_handle_pos (&handle, args), obj); - scm_array_handle_release (&handle); - return SCM_UNSPECIFIED; -} -#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 @@ -975,46 +777,6 @@ SCM_DEFINE (scm_uniform_array_write, "uniform-array-write", 1, 3, 0, #undef FUNC_NAME -static SCM -ra2l (SCM ra, unsigned long base, unsigned long k) -{ - SCM res = SCM_EOL; - long inc; - size_t i; - - if (k == SCM_I_ARRAY_NDIM (ra)) - return scm_c_generalized_vector_ref (SCM_I_ARRAY_V (ra), base); - - inc = SCM_I_ARRAY_DIMS (ra)[k].inc; - if (SCM_I_ARRAY_DIMS (ra)[k].ubnd < SCM_I_ARRAY_DIMS (ra)[k].lbnd) - return SCM_EOL; - i = base + (1 + SCM_I_ARRAY_DIMS (ra)[k].ubnd - SCM_I_ARRAY_DIMS (ra)[k].lbnd) * inc; - do - { - i -= inc; - res = scm_cons (ra2l (ra, i, k + 1), res); - } - while (i != base); - return res; -} - - -SCM_DEFINE (scm_array_to_list, "array->list", 1, 0, 0, - (SCM v), - "Return a list consisting of all the elements, in order, of\n" - "@var{array}.") -#define FUNC_NAME s_scm_array_to_list -{ - if (scm_is_generalized_vector (v)) - return scm_generalized_vector_to_list (v); - else if (SCM_I_ARRAYP (v)) - return ra2l (v, SCM_I_ARRAY_BASE (v), 0); - - scm_wrong_type_arg_msg (NULL, 0, v, "array"); -} -#undef FUNC_NAME - - 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, @@ -1410,19 +1172,6 @@ scm_i_read_array (SCM port, int c) return scm_list_to_typed_array (tag_to_type (tag, port), shape, elements); } -SCM_DEFINE (scm_array_type, "array-type", 1, 0, 0, - (SCM ra), - "") -#define FUNC_NAME s_scm_array_type -{ - if (SCM_I_ARRAYP (ra)) - return scm_i_generalized_vector_type (SCM_I_ARRAY_V (ra)); - else if (scm_is_generalized_vector (ra)) - return scm_i_generalized_vector_type (ra); - else - scm_wrong_type_arg_msg (NULL, 0, ra, "array"); -} -#undef FUNC_NAME static SCM array_mark (SCM ptr) diff --git a/libguile/arrays.h b/libguile/arrays.h index 45c0bec38..35e5471bf 100644 --- a/libguile/arrays.h +++ b/libguile/arrays.h @@ -1,7 +1,7 @@ /* classes: h_files */ -#ifndef SCM_UNIF_H -#define SCM_UNIF_H +#ifndef SCM_ARRAY_H +#define SCM_ARRAY_H /* Copyright (C) 1995,1996,1997,1999,2000,2001, 2004, 2006, 2008, 2009 Free Software Foundation, Inc. * @@ -25,47 +25,33 @@ #include "libguile/__scm.h" #include "libguile/print.h" -#include "libguile/array-handle.h" -/* This file contains the definitions for arrays and bit vectors. - Uniform numeric vectors are now in srfi-4.c. -*/ +/* Multidimensional arrays. Woo hoo! + Also see .... + */ /** Arrays */ -SCM_API SCM scm_array_p (SCM v); -SCM_API SCM scm_typed_array_p (SCM v, SCM type); SCM_API SCM scm_make_array (SCM fill, SCM bounds); SCM_API SCM scm_make_typed_array (SCM type, SCM fill, SCM bounds); SCM_API SCM scm_from_contiguous_typed_array (SCM type, SCM bounds, const void *bytes, size_t byte_len); -SCM_API SCM scm_array_rank (SCM ra); -SCM_API size_t scm_c_array_rank (SCM ra); -SCM_API SCM scm_array_dimensions (SCM ra); SCM_API SCM scm_shared_array_root (SCM ra); SCM_API SCM scm_shared_array_offset (SCM ra); SCM_API SCM scm_shared_array_increments (SCM ra); SCM_API SCM scm_make_shared_array (SCM oldra, SCM mapfunc, SCM dims); SCM_API SCM scm_transpose_array (SCM ra, SCM args); -SCM_API SCM scm_array_in_bounds_p (SCM v, SCM args); -SCM_API SCM scm_array_ref (SCM v, SCM args); -SCM_API SCM scm_array_set_x (SCM v, SCM obj, SCM args); SCM_API SCM scm_array_contents (SCM ra, SCM strict); SCM_API SCM scm_uniform_array_read_x (SCM ra, SCM port_or_fd, SCM start, SCM end); SCM_API SCM scm_uniform_array_write (SCM v, SCM port_or_fd, SCM start, SCM end); -SCM_API SCM scm_array_to_list (SCM v); SCM_API SCM scm_list_to_array (SCM ndim, SCM lst); SCM_API SCM scm_list_to_typed_array (SCM type, SCM ndim, SCM lst); -SCM_API SCM scm_array_type (SCM ra); - -SCM_API int scm_is_array (SCM obj); -SCM_API int scm_is_typed_array (SCM obj, SCM type); SCM_API SCM scm_ra2contig (SCM ra, int copy); @@ -96,7 +82,7 @@ SCM_INTERNAL SCM scm_i_read_array (SCM port, int c); SCM_INTERNAL void scm_init_arrays (void); -#endif /* SCM_UNIF_H */ +#endif /* SCM_ARRAYS_H */ /* Local Variables: diff --git a/libguile/deprecated.c b/libguile/deprecated.c index f9a858b53..768d6f996 100644 --- a/libguile/deprecated.c +++ b/libguile/deprecated.c @@ -34,6 +34,7 @@ #include "libguile/strings.h" #include "libguile/srfi-13.h" #include "libguile/modules.h" +#include "libguile/generalized-arrays.h" #include "libguile/eval.h" #include "libguile/smob.h" #include "libguile/procprop.h" diff --git a/libguile/generalized-arrays.c b/libguile/generalized-arrays.c new file mode 100644 index 000000000..6394405dd --- /dev/null +++ b/libguile/generalized-arrays.c @@ -0,0 +1,276 @@ +/* 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 +#endif + +#include +#include +#include + +#include "libguile/_scm.h" +#include "libguile/__scm.h" +#include "libguile/array-handle.h" +#include "libguile/generalized-arrays.h" + + +int +scm_is_array (SCM obj) +{ + return scm_i_array_implementation_for_obj (obj) ? 1 : 0; +} + +SCM_DEFINE (scm_array_p, "array?", 1, 0, 0, + (SCM obj), + "Return @code{#t} if the @var{obj} is an array, and @code{#f} if\n" + "not.") +#define FUNC_NAME s_scm_array_p +{ + return scm_from_bool (scm_is_array (obj)); +} +#undef FUNC_NAME + +int +scm_is_typed_array (SCM obj, SCM type) +{ + int ret = 0; + if (scm_i_array_implementation_for_obj (obj)) + { + scm_t_array_handle h; + + scm_array_get_handle (obj, &h); + ret = scm_is_eq (scm_array_handle_element_type (&h), type); + scm_array_handle_release (&h); + } + + return ret; +} + +SCM_DEFINE (scm_typed_array_p, "typed-array?", 2, 0, 0, + (SCM obj, SCM type), + "Return @code{#t} if the @var{obj} is an array of type\n" + "@var{type}, and @code{#f} if not.") +#define FUNC_NAME s_scm_typed_array_p +{ + return scm_from_bool (scm_is_typed_array (obj, type)); +} +#undef FUNC_NAME + +size_t +scm_c_array_rank (SCM array) +{ + scm_t_array_handle handle; + size_t res; + + scm_array_get_handle (array, &handle); + res = scm_array_handle_rank (&handle); + scm_array_handle_release (&handle); + return res; +} + +SCM_DEFINE (scm_array_rank, "array-rank", 1, 0, 0, + (SCM array), + "Return the number of dimensions of the array @var{array.}\n") +#define FUNC_NAME s_scm_array_rank +{ + return scm_from_size_t (scm_c_array_rank (array)); +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_array_dimensions, "array-dimensions", 1, 0, 0, + (SCM ra), + "@code{array-dimensions} is similar to @code{array-shape} but replaces\n" + "elements with a @code{0} minimum with one greater than the maximum. So:\n" + "@lisp\n" + "(array-dimensions (make-array 'foo '(-1 3) 5)) @result{} ((-1 3) 5)\n" + "@end lisp") +#define FUNC_NAME s_scm_array_dimensions +{ + scm_t_array_handle handle; + scm_t_array_dim *s; + SCM res = SCM_EOL; + size_t k; + + scm_array_get_handle (ra, &handle); + s = scm_array_handle_dims (&handle); + k = scm_array_handle_rank (&handle); + + while (k--) + res = scm_cons (s[k].lbnd + ? scm_cons2 (scm_from_ssize_t (s[k].lbnd), + scm_from_ssize_t (s[k].ubnd), + SCM_EOL) + : scm_from_ssize_t (1 + s[k].ubnd), + res); + + scm_array_handle_release (&handle); + return res; +} +#undef FUNC_NAME + +/* HACK*/ +#include "libguile/bytevectors.h" + +SCM_DEFINE (scm_array_type, "array-type", 1, 0, 0, + (SCM ra), + "") +#define FUNC_NAME s_scm_array_type +{ + scm_t_array_handle h; + SCM type; + + /* a hack, until srfi-4 and bytevectors are reunited */ + if (scm_is_bytevector (ra)) + return scm_from_locale_symbol ("vu8"); + + scm_array_get_handle (ra, &h); + type = scm_array_handle_element_type (&h); + scm_array_handle_release (&h); + + return type; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_array_in_bounds_p, "array-in-bounds?", 1, 0, 1, + (SCM ra, SCM args), + "Return @code{#t} if its arguments would be acceptable to\n" + "@code{array-ref}.") +#define FUNC_NAME s_scm_array_in_bounds_p +{ + SCM res = SCM_BOOL_T; + size_t k, ndim; + scm_t_array_dim *s; + scm_t_array_handle handle; + + SCM_VALIDATE_REST_ARGUMENT (args); + + scm_array_get_handle (ra, &handle); + s = scm_array_handle_dims (&handle); + ndim = scm_array_handle_rank (&handle); + + for (k = 0; k < ndim; k++) + { + long ind; + + if (!scm_is_pair (args)) + SCM_WRONG_NUM_ARGS (); + ind = scm_to_long (SCM_CAR (args)); + args = SCM_CDR (args); + + if (ind < s[k].lbnd || ind > s[k].ubnd) + { + res = SCM_BOOL_F; + /* We do not stop the checking after finding a violation + since we want to validate the type-correctness and + number of arguments in any case. + */ + } + } + + scm_array_handle_release (&handle); + return res; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_array_ref, "array-ref", 1, 0, 1, + (SCM v, SCM args), + "Return the element at the @code{(index1, index2)} element in\n" + "@var{array}.") +#define FUNC_NAME s_scm_array_ref +{ + scm_t_array_handle handle; + SCM res; + + scm_array_get_handle (v, &handle); + res = scm_array_handle_ref (&handle, scm_array_handle_pos (&handle, args)); + scm_array_handle_release (&handle); + return res; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_array_set_x, "array-set!", 2, 0, 1, + (SCM v, SCM obj, SCM args), + "Set the element at the @code{(index1, index2)} element in @var{array} to\n" + "@var{new-value}. The value returned by array-set! is unspecified.") +#define FUNC_NAME s_scm_array_set_x +{ + scm_t_array_handle handle; + + scm_array_get_handle (v, &handle); + scm_array_handle_set (&handle, scm_array_handle_pos (&handle, args), obj); + scm_array_handle_release (&handle); + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME + +static SCM +array_to_list (scm_t_array_handle *h, size_t dim, unsigned long pos) +{ + if (dim == scm_array_handle_rank (h)) + return scm_array_handle_ref (h, pos); + else + { + SCM res = SCM_EOL; + long inc; + size_t i, lbnd; + + i = h->dims[dim].ubnd; + lbnd = h->dims[dim].lbnd; + inc = h->dims[dim].inc; + pos += (i - h->dims[dim].ubnd) * inc; + + for (; i >= lbnd; i--, pos -= inc) + res = scm_cons (array_to_list (h, dim + 1, pos), res); + return res; + } +} + +SCM_DEFINE (scm_array_to_list, "array->list", 1, 0, 0, + (SCM array), + "FIXME description a list consisting of all the elements, in order, of\n" + "@var{array}.") +#define FUNC_NAME s_scm_array_to_list +{ + scm_t_array_handle h; + SCM res; + + scm_array_get_handle (array, &h); + res = array_to_list (&h, 0, 0); + scm_array_handle_release (&h); + + return res; +} +#undef FUNC_NAME + +void +scm_init_generalized_arrays () +{ +#include "libguile/generalized-arrays.x" +} + +/* + Local Variables: + c-file-style: "gnu" + End: +*/ diff --git a/libguile/generalized-arrays.h b/libguile/generalized-arrays.h new file mode 100644 index 000000000..cc7214e8b --- /dev/null +++ b/libguile/generalized-arrays.h @@ -0,0 +1,63 @@ +/* classes: h_files */ + +#ifndef SCM_GENERALIZED_ARRAYS_H +#define SCM_GENERALIZED_ARRAYS_H + +/* Copyright (C) 1995,1996,1997,1999,2000,2001, 2004, 2006, 2008, 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 + */ + + + +#include "libguile/__scm.h" +#include "libguile/array-handle.h" + + + +/* These functions operate on all kinds of arrays that Guile knows about. + */ + + +/** Arrays */ + +SCM_API int scm_is_array (SCM obj); +SCM_API SCM scm_array_p (SCM v); + +SCM_API int scm_is_typed_array (SCM obj, SCM type); +SCM_API SCM scm_typed_array_p (SCM v, SCM type); + +SCM_API size_t scm_c_array_rank (SCM ra); +SCM_API SCM scm_array_rank (SCM ra); + +SCM_API SCM scm_array_dimensions (SCM ra); +SCM_API SCM scm_array_type (SCM ra); +SCM_API SCM scm_array_in_bounds_p (SCM v, SCM args); + +SCM_API SCM scm_array_ref (SCM v, SCM args); +SCM_API SCM scm_array_set_x (SCM v, SCM obj, SCM args); +SCM_API SCM scm_array_to_list (SCM v); + +SCM_INTERNAL void scm_init_generalized_arrays (void); + + +#endif /* SCM_GENERALIZED_ARRAYS_H */ + +/* + Local Variables: + c-file-style: "gnu" + End: +*/ diff --git a/libguile/init.c b/libguile/init.c index 1d9827029..7478676dc 100644 --- a/libguile/init.c +++ b/libguile/init.c @@ -63,6 +63,7 @@ #include "libguile/futures.h" #include "libguile/gc.h" #include "libguile/gdbint.h" +#include "libguile/generalized-arrays.h" #include "libguile/goops.h" #include "libguile/gsubr.h" #include "libguile/hash.h" @@ -542,6 +543,7 @@ scm_i_init_guile (SCM_STACKITEM *base) scm_init_debug (); /* Requires macro smobs */ scm_init_random (); scm_init_array_handle (); + scm_init_generalized_arrays (); scm_init_bitvectors (); scm_init_array_map (); scm_init_arrays (); -- cgit v1.2.3 From f332e9571703ddcd27c51ebe3c847459c2a649b7 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 17 Jul 2009 19:05:32 +0200 Subject: generic vector ops to own file * libguile/Makefile.am: * libguile/vectors.c: * libguile/vectors.h: * libguile/generalized-vectors.c: * libguile/generalized-vectors.h: Move generic vector ops off into their own file too. The implementation is now based on the generic array-handle infrastructure. * libguile.h: * libguile/array-map.c: * libguile/bitvectors.c: * libguile/random.c: * libguile/srfi-4.c: Update includers. --- libguile.h | 1 + libguile/Makefile.am | 4 + libguile/array-map.c | 1 + libguile/arrays.c | 1 + libguile/bitvectors.c | 1 + libguile/generalized-vectors.c | 164 +++++++++++++++++++++++++++++++++++++++++ libguile/generalized-vectors.h | 55 ++++++++++++++ libguile/init.c | 2 + libguile/random.c | 1 + libguile/srfi-4.c | 1 + libguile/vectors.c | 131 +------------------------------- libguile/vectors.h | 15 ---- 12 files changed, 232 insertions(+), 145 deletions(-) create mode 100644 libguile/generalized-vectors.c create mode 100644 libguile/generalized-vectors.h (limited to 'libguile/arrays.c') diff --git a/libguile.h b/libguile.h index 3fdafc2ba..4eaedbf3e 100644 --- a/libguile.h +++ b/libguile.h @@ -55,6 +55,7 @@ extern "C" { #include "libguile/gc.h" #include "libguile/gdbint.h" #include "libguile/generalized-arrays.h" +#include "libguile/generalized-vectors.h" #include "libguile/goops.h" #include "libguile/gsubr.h" #include "libguile/guardians.h" diff --git a/libguile/Makefile.am b/libguile/Makefile.am index 3b5828f50..9918672d5 100644 --- a/libguile/Makefile.am +++ b/libguile/Makefile.am @@ -144,6 +144,7 @@ libguile_la_SOURCES = \ gdbint.c \ gettext.c \ generalized-arrays.c \ + generalized-vectors.c \ goops.c \ gsubr.c \ guardians.c \ @@ -252,6 +253,7 @@ DOT_X_FILES = \ gc.x \ gettext.x \ generalized-arrays.x \ + generalized-vectors.x \ goops.x \ gsubr.x \ guardians.x \ @@ -351,6 +353,7 @@ DOT_DOC_FILES = \ gc.doc \ gettext.doc \ generalized-arrays.doc \ + generalized-vectos.doc \ goops.doc \ gsubr.doc \ guardians.doc \ @@ -494,6 +497,7 @@ modinclude_HEADERS = \ gdbint.h \ gettext.h \ generalized-arrays.h \ + generalized-vectors.h \ goops.h \ gsubr.h \ guardians.h \ diff --git a/libguile/array-map.c b/libguile/array-map.c index c6f5ead1d..fb9ceea37 100644 --- a/libguile/array-map.c +++ b/libguile/array-map.c @@ -39,6 +39,7 @@ #include "libguile/srfi-4.h" #include "libguile/dynwind.h" #include "libguile/generalized-arrays.h" +#include "libguile/generalized-vectors.h" #include "libguile/validate.h" #include "libguile/array-map.h" diff --git a/libguile/arrays.c b/libguile/arrays.c index 0d2302d9c..bc01c6182 100644 --- a/libguile/arrays.c +++ b/libguile/arrays.c @@ -48,6 +48,7 @@ #include "libguile/validate.h" #include "libguile/arrays.h" #include "libguile/generalized-arrays.h" +#include "libguile/generalized-vectors.h" #include "libguile/array-map.h" #include "libguile/print.h" #include "libguile/read.h" diff --git a/libguile/bitvectors.c b/libguile/bitvectors.c index f0bb5c6c8..ed2e9a09a 100644 --- a/libguile/bitvectors.c +++ b/libguile/bitvectors.c @@ -34,6 +34,7 @@ #include "libguile/arrays.h" #include "libguile/vectors.h" #include "libguile/srfi-4.h" +#include "libguile/generalized-vectors.h" /* Bit vectors. Would be nice if they were implemented on top of bytevectors, * but alack, all we have is this crufty C. diff --git a/libguile/generalized-vectors.c b/libguile/generalized-vectors.c new file mode 100644 index 000000000..0c85f368a --- /dev/null +++ b/libguile/generalized-vectors.c @@ -0,0 +1,164 @@ +/* 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 +#endif + +#include "libguile/_scm.h" +#include "libguile/__scm.h" + +#include "libguile/array-handle.h" +#include "libguile/generalized-arrays.h" +#include "libguile/generalized-vectors.h" + + +int +scm_is_generalized_vector (SCM obj) +{ + int ret = 0; + if (scm_is_array (obj)) + { + scm_t_array_handle h; + scm_array_get_handle (obj, &h); + ret = scm_array_handle_rank (&h) == 1; + scm_array_handle_release (&h); + } + return ret; +} + +SCM_DEFINE (scm_generalized_vector_p, "generalized-vector?", 1, 0, 0, + (SCM obj), + "Return @code{#t} if @var{obj} is a vector, string,\n" + "bitvector, or uniform numeric vector.") +#define FUNC_NAME s_scm_generalized_vector_p +{ + return scm_from_bool (scm_is_generalized_vector (obj)); +} +#undef FUNC_NAME + +#define SCM_VALIDATE_VECTOR_WITH_HANDLE(pos, val, handle) \ + scm_generalized_vector_get_handle (val, handle) + + +void +scm_generalized_vector_get_handle (SCM vec, scm_t_array_handle *h) +{ + scm_array_get_handle (vec, h); + if (scm_array_handle_rank (h) != 1) + { + scm_array_handle_release (h); + scm_wrong_type_arg_msg (NULL, 0, vec, "vector"); + } +} + +size_t +scm_c_generalized_vector_length (SCM v) +{ + scm_t_array_handle h; + size_t ret; + scm_generalized_vector_get_handle (v, &h); + ret = h.dims[0].ubnd - h.dims[0].lbnd + 1; + scm_array_handle_release (&h); + return ret; +} + +SCM_DEFINE (scm_generalized_vector_length, "generalized-vector-length", 1, 0, 0, + (SCM v), + "Return the length of the generalized vector @var{v}.") +#define FUNC_NAME s_scm_generalized_vector_length +{ + return scm_from_size_t (scm_c_generalized_vector_length (v)); +} +#undef FUNC_NAME + +SCM +scm_c_generalized_vector_ref (SCM v, size_t idx) +{ + scm_t_array_handle h; + SCM ret; + scm_generalized_vector_get_handle (v, &h); + ret = h.impl->vref (&h, idx); + scm_array_handle_release (&h); + return ret; +} + +SCM_DEFINE (scm_generalized_vector_ref, "generalized-vector-ref", 2, 0, 0, + (SCM v, SCM idx), + "Return the element at index @var{idx} of the\n" + "generalized vector @var{v}.") +#define FUNC_NAME s_scm_generalized_vector_ref +{ + return scm_c_generalized_vector_ref (v, scm_to_size_t (idx)); +} +#undef FUNC_NAME + +void +scm_c_generalized_vector_set_x (SCM v, size_t idx, SCM val) +{ + scm_t_array_handle h; + scm_generalized_vector_get_handle (v, &h); + h.impl->vset (&h, idx, val); + scm_array_handle_release (&h); +} + +SCM_DEFINE (scm_generalized_vector_set_x, "generalized-vector-set!", 3, 0, 0, + (SCM v, SCM idx, SCM val), + "Set the element at index @var{idx} of the\n" + "generalized vector @var{v} to @var{val}.") +#define FUNC_NAME s_scm_generalized_vector_set_x +{ + scm_c_generalized_vector_set_x (v, scm_to_size_t (idx), val); + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_generalized_vector_to_list, "generalized-vector->list", 1, 0, 0, + (SCM v), + "Return a new list whose elements are the elements of the\n" + "generalized vector @var{v}.") +#define FUNC_NAME s_scm_generalized_vector_to_list +{ + SCM ret = SCM_EOL; + ssize_t pos, i = 0; + scm_t_array_handle h; + scm_generalized_vector_get_handle (v, &h); + // FIXME CHECKME + for (pos = h.dims[0].ubnd, i = (h.dims[0].ubnd - h.dims[0].lbnd + 1); + i >= 0; + pos += h.dims[0].inc) + ret = scm_cons (h.impl->vref (&h, pos), ret); + scm_array_handle_release (&h); + return ret; +} +#undef FUNC_NAME + +void +scm_init_generalized_vectors () +{ +#include "libguile/generalized-vectors.x" +} + +/* + Local Variables: + c-file-style: "gnu" + End: +*/ diff --git a/libguile/generalized-vectors.h b/libguile/generalized-vectors.h new file mode 100644 index 000000000..08321d106 --- /dev/null +++ b/libguile/generalized-vectors.h @@ -0,0 +1,55 @@ +/* classes: h_files */ + +#ifndef SCM_GENERALIZED_VECTORS_H +#define SCM_GENERALIZED_VECTORS_H + +/* Copyright (C) 1995,1996,1997,1999,2000,2001, 2004, 2006, 2008, 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 + */ + + + +#include "libguile/__scm.h" +#include "libguile/array-handle.h" + + + +/* Generalized vectors */ + +SCM_API SCM scm_generalized_vector_p (SCM v); +SCM_API SCM scm_generalized_vector_length (SCM v); +SCM_API SCM scm_generalized_vector_ref (SCM v, SCM idx); +SCM_API SCM scm_generalized_vector_set_x (SCM v, SCM idx, SCM val); +SCM_API SCM scm_generalized_vector_to_list (SCM v); + +SCM_API int scm_is_generalized_vector (SCM obj); +SCM_API size_t scm_c_generalized_vector_length (SCM v); +SCM_API SCM scm_c_generalized_vector_ref (SCM v, size_t idx); +SCM_API void scm_c_generalized_vector_set_x (SCM v, size_t idx, SCM val); +SCM_API void scm_generalized_vector_get_handle (SCM vec, + scm_t_array_handle *h); + + +SCM_INTERNAL void scm_init_generalized_vectors (void); + +#endif /* SCM_GENERALIZED_VECTORS_H */ + +/* + Local Variables: + c-file-style: "gnu" + End: +*/ diff --git a/libguile/init.c b/libguile/init.c index 7478676dc..16b560e1b 100644 --- a/libguile/init.c +++ b/libguile/init.c @@ -64,6 +64,7 @@ #include "libguile/gc.h" #include "libguile/gdbint.h" #include "libguile/generalized-arrays.h" +#include "libguile/generalized-vectors.h" #include "libguile/goops.h" #include "libguile/gsubr.h" #include "libguile/hash.h" @@ -544,6 +545,7 @@ scm_i_init_guile (SCM_STACKITEM *base) scm_init_random (); scm_init_array_handle (); scm_init_generalized_arrays (); + scm_init_generalized_vectors (); scm_init_bitvectors (); scm_init_array_map (); scm_init_arrays (); diff --git a/libguile/random.c b/libguile/random.c index dfda4d082..32c770a99 100644 --- a/libguile/random.c +++ b/libguile/random.c @@ -36,6 +36,7 @@ #include "libguile/arrays.h" #include "libguile/srfi-4.h" #include "libguile/vectors.h" +#include "libguile/generalized-vectors.h" #include "libguile/validate.h" #include "libguile/random.h" diff --git a/libguile/srfi-4.c b/libguile/srfi-4.c index 408355d38..ba7e9e6a0 100644 --- a/libguile/srfi-4.c +++ b/libguile/srfi-4.c @@ -31,6 +31,7 @@ #include "libguile/srfi-4.h" #include "libguile/bitvectors.h" #include "libguile/bytevectors.h" +#include "libguile/generalized-vectors.h" #include "libguile/error.h" #include "libguile/read.h" #include "libguile/ports.h" diff --git a/libguile/vectors.c b/libguile/vectors.c index 2d77f158b..f1388cf12 100644 --- a/libguile/vectors.c +++ b/libguile/vectors.c @@ -30,6 +30,7 @@ #include "libguile/validate.h" #include "libguile/vectors.h" +#include "libguile/generalized-vectors.h" #include "libguile/arrays.h" #include "libguile/bitvectors.h" #include "libguile/bytevectors.h" @@ -526,136 +527,6 @@ SCM_DEFINE (scm_vector_move_right_x, "vector-move-right!", 5, 0, 0, #undef FUNC_NAME -/* Generalized vectors. */ - -int -scm_is_generalized_vector (SCM obj) -{ - return (scm_is_vector (obj) - || scm_is_string (obj) - || scm_is_bitvector (obj) - || scm_is_uniform_vector (obj) - || scm_is_bytevector (obj)); -} - -SCM_DEFINE (scm_generalized_vector_p, "generalized-vector?", 1, 0, 0, - (SCM obj), - "Return @code{#t} if @var{obj} is a vector, string,\n" - "bitvector, or uniform numeric vector.") -#define FUNC_NAME s_scm_generalized_vector_p -{ - return scm_from_bool (scm_is_generalized_vector (obj)); -} -#undef FUNC_NAME - -void -scm_generalized_vector_get_handle (SCM vec, scm_t_array_handle *h) -{ - scm_array_get_handle (vec, h); - if (scm_array_handle_rank (h) != 1) - scm_wrong_type_arg_msg (NULL, 0, vec, "vector"); -} - -size_t -scm_c_generalized_vector_length (SCM v) -{ - if (scm_is_vector (v)) - return scm_c_vector_length (v); - else if (scm_is_string (v)) - return scm_c_string_length (v); - else if (scm_is_bitvector (v)) - return scm_c_bitvector_length (v); - else if (scm_is_uniform_vector (v)) - return scm_c_uniform_vector_length (v); - else if (scm_is_bytevector (v)) - return scm_c_bytevector_length (v); - else - scm_wrong_type_arg_msg (NULL, 0, v, "generalized vector"); -} - -SCM_DEFINE (scm_generalized_vector_length, "generalized-vector-length", 1, 0, 0, - (SCM v), - "Return the length of the generalized vector @var{v}.") -#define FUNC_NAME s_scm_generalized_vector_length -{ - return scm_from_size_t (scm_c_generalized_vector_length (v)); -} -#undef FUNC_NAME - -SCM -scm_c_generalized_vector_ref (SCM v, size_t idx) -{ - if (scm_is_vector (v)) - return scm_c_vector_ref (v, idx); - else if (scm_is_string (v)) - return scm_c_string_ref (v, idx); - else if (scm_is_bitvector (v)) - return scm_c_bitvector_ref (v, idx); - else if (scm_is_uniform_vector (v)) - return scm_c_uniform_vector_ref (v, idx); - else if (scm_is_bytevector (v)) - return scm_from_uint8 (scm_c_bytevector_ref (v, idx)); - else - scm_wrong_type_arg_msg (NULL, 0, v, "generalized vector"); -} - -SCM_DEFINE (scm_generalized_vector_ref, "generalized-vector-ref", 2, 0, 0, - (SCM v, SCM idx), - "Return the element at index @var{idx} of the\n" - "generalized vector @var{v}.") -#define FUNC_NAME s_scm_generalized_vector_ref -{ - return scm_c_generalized_vector_ref (v, scm_to_size_t (idx)); -} -#undef FUNC_NAME - -void -scm_c_generalized_vector_set_x (SCM v, size_t idx, SCM val) -{ - if (scm_is_vector (v)) - scm_c_vector_set_x (v, idx, val); - else if (scm_is_string (v)) - scm_c_string_set_x (v, idx, val); - else if (scm_is_bitvector (v)) - scm_c_bitvector_set_x (v, idx, val); - else if (scm_is_uniform_vector (v)) - scm_c_uniform_vector_set_x (v, idx, val); - else if (scm_is_bytevector (v)) - scm_i_bytevector_generalized_set_x (v, idx, val); - else - scm_wrong_type_arg_msg (NULL, 0, v, "generalized vector"); -} - -SCM_DEFINE (scm_generalized_vector_set_x, "generalized-vector-set!", 3, 0, 0, - (SCM v, SCM idx, SCM val), - "Set the element at index @var{idx} of the\n" - "generalized vector @var{v} to @var{val}.") -#define FUNC_NAME s_scm_generalized_vector_set_x -{ - scm_c_generalized_vector_set_x (v, scm_to_size_t (idx), val); - return SCM_UNSPECIFIED; -} -#undef FUNC_NAME - -SCM_DEFINE (scm_generalized_vector_to_list, "generalized-vector->list", 1, 0, 0, - (SCM v), - "Return a new list whose elements are the elements of the\n" - "generalized vector @var{v}.") -#define FUNC_NAME s_scm_generalized_vector_to_list -{ - if (scm_is_vector (v)) - return scm_vector_to_list (v); - else if (scm_is_string (v)) - return scm_string_to_list (v); - else if (scm_is_bitvector (v)) - return scm_bitvector_to_list (v); - else if (scm_is_uniform_vector (v)) - return scm_uniform_vector_to_list (v); - else - scm_wrong_type_arg_msg (NULL, 0, v, "generalized vector"); -} -#undef FUNC_NAME - static SCM vector_handle_ref (scm_t_array_handle *h, size_t idx) { diff --git a/libguile/vectors.h b/libguile/vectors.h index eb0c9436e..bc5b41cb9 100644 --- a/libguile/vectors.h +++ b/libguile/vectors.h @@ -61,21 +61,6 @@ SCM_API SCM *scm_vector_writable_elements (SCM vec, #define SCM_SIMPLE_VECTOR_REF(x,idx) ((SCM_I_VECTOR_ELTS(x))[idx]) #define SCM_SIMPLE_VECTOR_SET(x,idx,val) ((SCM_I_VECTOR_WELTS(x))[idx]=(val)) -/* Generalized vectors */ - -SCM_API SCM scm_generalized_vector_p (SCM v); -SCM_API SCM scm_generalized_vector_length (SCM v); -SCM_API SCM scm_generalized_vector_ref (SCM v, SCM idx); -SCM_API SCM scm_generalized_vector_set_x (SCM v, SCM idx, SCM val); -SCM_API SCM scm_generalized_vector_to_list (SCM v); - -SCM_API int scm_is_generalized_vector (SCM obj); -SCM_API size_t scm_c_generalized_vector_length (SCM v); -SCM_API SCM scm_c_generalized_vector_ref (SCM v, size_t idx); -SCM_API void scm_c_generalized_vector_set_x (SCM v, size_t idx, SCM val); -SCM_API void scm_generalized_vector_get_handle (SCM vec, - scm_t_array_handle *h); - /* Internals */ #define SCM_I_IS_VECTOR(x) (!SCM_IMP(x) && (SCM_TYP7S(x)==scm_tc7_vector)) -- cgit v1.2.3 From 476b894c71b436f3befb8af46b899aaf244763e2 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sat, 18 Jul 2009 12:18:15 +0200 Subject: uniform vector functions to their own file * libguile/uniform.c: * libguile/uniform.h: * libguile/srfi-4.c: * libguile/srfi-4.h: * libguile/Makefile.am: Move uniform vector funcs out of srfi-4 to their own file. * libguile.h: * libguile/arrays.c: * libguile/bytevectors.c: Update includers. --- libguile.h | 1 + libguile/Makefile.am | 6 +- libguile/arrays.c | 1 + libguile/bytevectors.c | 1 + libguile/init.c | 2 + libguile/srfi-4.c | 217 +----------------------------------------- libguile/srfi-4.h | 31 +----- libguile/uniform.c | 254 +++++++++++++++++++++++++++++++++++++++++++++++++ libguile/uniform.h | 77 +++++++++++++++ 9 files changed, 343 insertions(+), 247 deletions(-) create mode 100644 libguile/uniform.c create mode 100644 libguile/uniform.h (limited to 'libguile/arrays.c') diff --git a/libguile.h b/libguile.h index 4eaedbf3e..74674d5b9 100644 --- a/libguile.h +++ b/libguile.h @@ -106,6 +106,7 @@ extern "C" { #include "libguile/symbols.h" #include "libguile/tags.h" #include "libguile/throw.h" +#include "libguile/uniform.h" #include "libguile/validate.h" #include "libguile/values.h" #include "libguile/variable.h" diff --git a/libguile/Makefile.am b/libguile/Makefile.am index 9918672d5..825e6b297 100644 --- a/libguile/Makefile.am +++ b/libguile/Makefile.am @@ -200,6 +200,7 @@ libguile_la_SOURCES = \ symbols.c \ threads.c \ throw.c \ + uniform.c \ values.c \ variable.c \ vectors.c \ @@ -305,6 +306,7 @@ DOT_X_FILES = \ symbols.x \ threads.x \ throw.x \ + uniform.x \ values.x \ variable.x \ vectors.x \ @@ -353,7 +355,7 @@ DOT_DOC_FILES = \ gc.doc \ gettext.doc \ generalized-arrays.doc \ - generalized-vectos.doc \ + generalized-vectors.doc \ goops.doc \ gsubr.doc \ guardians.doc \ @@ -405,6 +407,7 @@ DOT_DOC_FILES = \ symbols.doc \ threads.doc \ throw.doc \ + uniform.doc \ values.doc \ variable.doc \ vectors.doc \ @@ -563,6 +566,7 @@ modinclude_HEADERS = \ threads.h \ throw.h \ validate.h \ + uniform.h \ values.h \ variable.h \ vectors.h \ diff --git a/libguile/arrays.c b/libguile/arrays.c index bc01c6182..6114adc0e 100644 --- a/libguile/arrays.c +++ b/libguile/arrays.c @@ -49,6 +49,7 @@ #include "libguile/arrays.h" #include "libguile/generalized-arrays.h" #include "libguile/generalized-vectors.h" +#include "libguile/uniform.h" #include "libguile/array-map.h" #include "libguile/print.h" #include "libguile/read.h" diff --git a/libguile/bytevectors.c b/libguile/bytevectors.c index c44db47f2..75028aee1 100644 --- a/libguile/bytevectors.c +++ b/libguile/bytevectors.c @@ -33,6 +33,7 @@ #include "libguile/ieee-754.h" #include "libguile/arrays.h" #include "libguile/array-handle.h" +#include "libguile/uniform.h" #include "libguile/srfi-4.h" #include diff --git a/libguile/init.c b/libguile/init.c index 16b560e1b..9e3151c82 100644 --- a/libguile/init.c +++ b/libguile/init.c @@ -128,6 +128,7 @@ #include "libguile/weaks.h" #include "libguile/guardians.h" #include "libguile/extensions.h" +#include "libguile/uniform.h" #include "libguile/srfi-4.h" #include "libguile/discouraged.h" #include "libguile/deprecated.h" @@ -546,6 +547,7 @@ scm_i_init_guile (SCM_STACKITEM *base) scm_init_array_handle (); scm_init_generalized_arrays (); scm_init_generalized_vectors (); + scm_init_uniform (); scm_init_bitvectors (); scm_init_array_map (); scm_init_arrays (); diff --git a/libguile/srfi-4.c b/libguile/srfi-4.c index ba7e9e6a0..e87064569 100644 --- a/libguile/srfi-4.c +++ b/libguile/srfi-4.c @@ -32,6 +32,7 @@ #include "libguile/bitvectors.h" #include "libguile/bytevectors.h" #include "libguile/generalized-vectors.h" +#include "libguile/uniform.h" #include "libguile/error.h" #include "libguile/read.h" #include "libguile/ports.h" @@ -615,222 +616,6 @@ scm_i_generalized_vector_type (SCM v) return SCM_BOOL_F; } -int -scm_is_uniform_vector (SCM obj) -{ - if (SCM_IS_UVEC (obj)) - return 1; - if (SCM_I_ARRAYP (obj) && SCM_I_ARRAY_NDIM (obj) == 1) - { - SCM v = SCM_I_ARRAY_V (obj); - return SCM_IS_UVEC (v); - } - return 0; -} - -size_t -scm_c_uniform_vector_length (SCM uvec) -{ - /* scm_generalized_vector_get_handle will ultimately call us to get - the length of uniform vectors, so we can't use uvec_elements for - naked vectors. - */ - - if (SCM_IS_UVEC (uvec)) - return SCM_UVEC_LENGTH (uvec); - else - { - scm_t_array_handle handle; - size_t len; - ssize_t inc; - uvec_elements (-1, uvec, &handle, &len, &inc); - scm_array_handle_release (&handle); - return len; - } -} - -SCM_DEFINE (scm_uniform_vector_p, "uniform-vector?", 1, 0, 0, - (SCM obj), - "Return @code{#t} if @var{obj} is a uniform vector.") -#define FUNC_NAME s_scm_uniform_vector_p -{ - return scm_from_bool (scm_is_uniform_vector (obj)); -} -#undef FUNC_NAME - -SCM -scm_c_uniform_vector_ref (SCM v, size_t idx) -{ - scm_t_array_handle handle; - size_t len; - ssize_t inc; - SCM res; - - uvec_elements (-1, v, &handle, &len, &inc); - if (idx >= len) - scm_out_of_range (NULL, scm_from_size_t (idx)); - res = scm_array_handle_ref (&handle, idx*inc); - scm_array_handle_release (&handle); - return res; -} - -SCM_DEFINE (scm_uniform_vector_ref, "uniform-vector-ref", 2, 0, 0, - (SCM v, SCM idx), - "Return the element at index @var{idx} of the\n" - "homogenous numeric vector @var{v}.") -#define FUNC_NAME s_scm_uniform_vector_ref -{ -#if SCM_ENABLE_DEPRECATED - /* Support old argument convention. - */ - if (scm_is_pair (idx)) - { - scm_c_issue_deprecation_warning - ("Using a list as the index to uniform-vector-ref is deprecated."); - if (!scm_is_null (SCM_CDR (idx))) - scm_wrong_num_args (NULL); - idx = SCM_CAR (idx); - } -#endif - - return scm_c_uniform_vector_ref (v, scm_to_size_t (idx)); -} -#undef FUNC_NAME - -void -scm_c_uniform_vector_set_x (SCM v, size_t idx, SCM val) -{ - scm_t_array_handle handle; - size_t len; - ssize_t inc; - - uvec_writable_elements (-1, v, &handle, &len, &inc); - if (idx >= len) - scm_out_of_range (NULL, scm_from_size_t (idx)); - scm_array_handle_set (&handle, idx*inc, val); - scm_array_handle_release (&handle); -} - -SCM_DEFINE (scm_uniform_vector_set_x, "uniform-vector-set!", 3, 0, 0, - (SCM v, SCM idx, SCM val), - "Set the element at index @var{idx} of the\n" - "homogenous numeric vector @var{v} to @var{val}.") -#define FUNC_NAME s_scm_uniform_vector_set_x -{ -#if SCM_ENABLE_DEPRECATED - /* Support old argument convention. - */ - if (scm_is_pair (idx)) - { - scm_c_issue_deprecation_warning - ("Using a list as the index to uniform-vector-set! is deprecated."); - if (!scm_is_null (SCM_CDR (idx))) - scm_wrong_num_args (NULL); - idx = SCM_CAR (idx); - } -#endif - - scm_c_uniform_vector_set_x (v, scm_to_size_t (idx), val); - return SCM_UNSPECIFIED; -} -#undef FUNC_NAME - -SCM_DEFINE (scm_uniform_vector_to_list, "uniform-vector->list", 1, 0, 0, - (SCM uvec), - "Convert the uniform numeric vector @var{uvec} to a list.") -#define FUNC_NAME s_scm_uniform_vector_to_list -{ - return uvec_to_list (-1, uvec); -} -#undef FUNC_NAME - -size_t -scm_array_handle_uniform_element_size (scm_t_array_handle *h) -{ - SCM vec = h->array; - if (SCM_I_ARRAYP (vec)) - vec = SCM_I_ARRAY_V (vec); - if (scm_is_uniform_vector (vec)) - return uvec_sizes[SCM_UVEC_TYPE(vec)]; - if (scm_is_bytevector (vec)) - return 1U; - scm_wrong_type_arg_msg (NULL, 0, h->array, "uniform array"); -} - -#if SCM_ENABLE_DEPRECATED - -/* return the size of an element in a uniform array or 0 if type not - found. */ -size_t -scm_uniform_element_size (SCM obj) -{ - scm_c_issue_deprecation_warning - ("scm_uniform_element_size is deprecated. " - "Use scm_array_handle_uniform_element_size instead."); - - if (SCM_IS_UVEC (obj)) - return uvec_sizes[SCM_UVEC_TYPE(obj)]; - else - return 0; -} - -#endif - -const void * -scm_array_handle_uniform_elements (scm_t_array_handle *h) -{ - return scm_array_handle_uniform_writable_elements (h); -} - -void * -scm_array_handle_uniform_writable_elements (scm_t_array_handle *h) -{ - SCM vec = h->array; - if (SCM_I_ARRAYP (vec)) - vec = SCM_I_ARRAY_V (vec); - if (SCM_IS_UVEC (vec)) - { - size_t size = uvec_sizes[SCM_UVEC_TYPE(vec)]; - char *elts = SCM_UVEC_BASE (vec); - return (void *) (elts + size*h->base); - } - if (scm_is_bytevector (vec)) - return SCM_BYTEVECTOR_CONTENTS (vec); - scm_wrong_type_arg_msg (NULL, 0, h->array, "uniform array"); -} - -const void * -scm_uniform_vector_elements (SCM uvec, - scm_t_array_handle *h, - size_t *lenp, ssize_t *incp) -{ - return scm_uniform_vector_writable_elements (uvec, h, lenp, incp); -} - -void * -scm_uniform_vector_writable_elements (SCM uvec, - scm_t_array_handle *h, - size_t *lenp, ssize_t *incp) -{ - scm_generalized_vector_get_handle (uvec, h); - if (lenp) - { - scm_t_array_dim *dim = scm_array_handle_dims (h); - *lenp = dim->ubnd - dim->lbnd + 1; - *incp = dim->inc; - } - return scm_array_handle_uniform_writable_elements (h); -} - -SCM_DEFINE (scm_uniform_vector_length, "uniform-vector-length", 1, 0, 0, - (SCM v), - "Return the number of elements in the uniform vector @var{v}.") -#define FUNC_NAME s_scm_uniform_vector_length -{ - return uvec_length (-1, v); -} -#undef FUNC_NAME - SCM_DEFINE (scm_uniform_vector_read_x, "uniform-vector-read!", 1, 3, 0, (SCM uvec, SCM port_or_fd, SCM start, SCM end), "Fill the elements of @var{uvec} by reading\n" diff --git a/libguile/srfi-4.h b/libguile/srfi-4.h index 039fa2e8d..3a45fd9e0 100644 --- a/libguile/srfi-4.h +++ b/libguile/srfi-4.h @@ -2,7 +2,7 @@ #define SCM_SRFI_4_H /* srfi-4.c --- Homogeneous numeric vector datatypes. * - * Copyright (C) 2001, 2004, 2006, 2008 Free Software Foundation, Inc. + * Copyright (C) 2001, 2004, 2006, 2008, 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 @@ -22,35 +22,6 @@ #include "libguile/__scm.h" -#include "libguile/arrays.h" - -/* Generic procedures. - */ - -SCM_API SCM scm_uniform_vector_p (SCM v); -SCM_API SCM scm_uniform_vector_length (SCM v); -SCM_API SCM scm_uniform_vector_ref (SCM v, SCM idx); -SCM_API SCM scm_uniform_vector_set_x (SCM v, SCM idx, SCM val); -SCM_API SCM scm_uniform_vector_to_list (SCM v); -SCM_API SCM scm_uniform_vector_read_x (SCM v, SCM port_or_fd, - SCM start, SCM end); -SCM_API SCM scm_uniform_vector_write (SCM v, SCM port_or_fd, - SCM start, SCM end); - -SCM_API int scm_is_uniform_vector (SCM obj); -SCM_API size_t scm_c_uniform_vector_length (SCM v); -SCM_API SCM scm_c_uniform_vector_ref (SCM v, size_t idx); -SCM_API void scm_c_uniform_vector_set_x (SCM v, size_t idx, SCM val); -SCM_API size_t scm_array_handle_uniform_element_size (scm_t_array_handle *h); -SCM_API const void *scm_array_handle_uniform_elements (scm_t_array_handle *h); -SCM_API void *scm_array_handle_uniform_writable_elements (scm_t_array_handle *h); -SCM_API const void *scm_uniform_vector_elements (SCM uvec, - scm_t_array_handle *h, - size_t *lenp, ssize_t *incp); -SCM_API void *scm_uniform_vector_writable_elements (SCM uvec, - scm_t_array_handle *h, - size_t *lenp, - ssize_t *incp); /* Specific procedures. */ diff --git a/libguile/uniform.c b/libguile/uniform.c new file mode 100644 index 000000000..28125da8b --- /dev/null +++ b/libguile/uniform.c @@ -0,0 +1,254 @@ +/* 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 +#endif + +#include + +#include "libguile/_scm.h" +#include "libguile/__scm.h" + +#include "libguile/uniform.h" + + +const size_t scm_i_array_element_type_sizes[SCM_ARRAY_ELEMENT_TYPE_LAST + 1] = { + 0, + 0, + 1, + 8, + 8, 8, + 16, 16, + 32, 32, + 64, 64, + 32, 64, + 64, 128 +}; + +/* FIXME: return bit size instead of byte size? */ +size_t +scm_array_handle_uniform_element_size (scm_t_array_handle *h) +{ + size_t ret = scm_i_array_element_type_sizes[h->element_type]; + if (ret && ret % 8 == 0) + return ret / 8; + else + scm_wrong_type_arg_msg (NULL, 0, h->array, "uniform array"); +} + +const void * +scm_array_handle_uniform_elements (scm_t_array_handle *h) +{ + return scm_array_handle_uniform_writable_elements (h); +} + +void * +scm_array_handle_uniform_writable_elements (scm_t_array_handle *h) +{ + size_t esize; + scm_t_uint8 *ret; + + esize = scm_array_handle_uniform_element_size (h); + ret = ((scm_t_uint8*) h->writable_elements) + h->base * esize; + return ret; +} + +int +scm_is_uniform_vector (SCM obj) +{ + scm_t_array_handle h; + int ret = 0; + + if (scm_is_generalized_vector (obj)) + { + scm_generalized_vector_get_handle (obj, &h); + ret = SCM_ARRAY_ELEMENT_TYPE_IS_UNBOXED (h.element_type); + scm_array_handle_release (&h); + } + return ret; +} + +size_t +scm_c_uniform_vector_length (SCM uvec) +{ + scm_t_array_handle h; + size_t len; + ssize_t inc; + + scm_uniform_vector_elements (uvec, &h, &len, &inc); + scm_array_handle_release (&h); + return len; +} + +SCM_DEFINE (scm_uniform_vector_p, "uniform-vector?", 1, 0, 0, + (SCM obj), + "Return @code{#t} if @var{obj} is a uniform vector.") +#define FUNC_NAME s_scm_uniform_vector_p +{ + return scm_from_bool (scm_is_uniform_vector (obj)); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_uniform_vector_element_type, "uniform-vector-element-type", 1, 0, 0, + (SCM v), + "Return the number of elements in the uniform vector, @var{v}.") +#define FUNC_NAME s_scm_uniform_vector_element_type +{ + scm_t_array_handle h; + size_t len; + ssize_t inc; + SCM ret; + scm_uniform_vector_elements (v, &h, &len, &inc); + ret = scm_array_handle_element_type (&h); + scm_array_handle_release (&h); + return ret; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_uniform_vector_element_size, "uniform-vector-element-size", 1, 0, 0, + (SCM v), + "Return the number of bytes allocated to each element in the\n" + "uniform vector, @var{v}.") +#define FUNC_NAME s_scm_uniform_vector_element_size +{ + scm_t_array_handle h; + size_t len; + ssize_t inc; + SCM ret; + scm_uniform_vector_elements (v, &h, &len, &inc); + ret = scm_from_size_t (scm_array_handle_uniform_element_size (&h)); + scm_array_handle_release (&h); + return ret; +} +#undef FUNC_NAME + +SCM +scm_c_uniform_vector_ref (SCM v, size_t idx) +{ + SCM ret; + scm_t_array_handle h; + size_t len; + ssize_t inc; + + scm_uniform_vector_elements (v, &h, &len, &inc); + ret = scm_array_handle_ref (&h, idx*inc); + scm_array_handle_release (&h); + return ret; +} + +SCM_DEFINE (scm_uniform_vector_ref, "uniform-vector-ref", 2, 0, 0, + (SCM v, SCM idx), + "Return the element at index @var{idx} of the\n" + "homogenous numeric vector @var{v}.") +#define FUNC_NAME s_scm_uniform_vector_ref +{ + return scm_c_uniform_vector_ref (v, scm_to_size_t (idx)); +} +#undef FUNC_NAME + +void +scm_c_uniform_vector_set_x (SCM v, size_t idx, SCM val) +{ + scm_t_array_handle h; + size_t len; + ssize_t inc; + + scm_uniform_vector_elements (v, &h, &len, &inc); + scm_array_handle_set (&h, idx*inc, val); + scm_array_handle_release (&h); +} + +SCM_DEFINE (scm_uniform_vector_set_x, "uniform-vector-set!", 3, 0, 0, + (SCM v, SCM idx, SCM val), + "Set the element at index @var{idx} of the\n" + "homogenous numeric vector @var{v} to @var{val}.") +#define FUNC_NAME s_scm_uniform_vector_set_x +{ + scm_c_uniform_vector_set_x (v, scm_to_size_t (idx), val); + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_uniform_vector_to_list, "uniform-vector->list", 1, 0, 0, + (SCM uvec), + "Convert the uniform numeric vector @var{uvec} to a list.") +#define FUNC_NAME s_scm_uniform_vector_to_list +{ + SCM ret; + scm_t_array_handle h; + size_t len; + ssize_t inc; + + scm_uniform_vector_elements (uvec, &h, &len, &inc); + ret = scm_generalized_vector_to_list (uvec); + scm_array_handle_release (&h); + return ret; +} +#undef FUNC_NAME + +const void * +scm_uniform_vector_elements (SCM uvec, + scm_t_array_handle *h, + size_t *lenp, ssize_t *incp) +{ + return scm_uniform_vector_writable_elements (uvec, h, lenp, incp); +} + +void * +scm_uniform_vector_writable_elements (SCM uvec, + scm_t_array_handle *h, + size_t *lenp, ssize_t *incp) +{ + void *ret; + scm_generalized_vector_get_handle (uvec, h); + /* FIXME nonlocal exit */ + ret = scm_array_handle_uniform_writable_elements (h); + if (lenp) + { + scm_t_array_dim *dim = scm_array_handle_dims (h); + *lenp = dim->ubnd - dim->lbnd + 1; + *incp = dim->inc; + } + return ret; +} + +SCM_DEFINE (scm_uniform_vector_length, "uniform-vector-length", 1, 0, 0, + (SCM v), + "Return the number of elements in the uniform vector @var{v}.") +#define FUNC_NAME s_scm_uniform_vector_length +{ + return scm_from_size_t (scm_c_uniform_vector_length (v)); +} +#undef FUNC_NAME + + +void +scm_init_uniform (void) +{ +#include "libguile/uniform.x" +} + +/* + Local Variables: + c-file-style: "gnu" + End: +*/ diff --git a/libguile/uniform.h b/libguile/uniform.h new file mode 100644 index 000000000..b1f396594 --- /dev/null +++ b/libguile/uniform.h @@ -0,0 +1,77 @@ +/* classes: h_files */ + +#ifndef SCM_UNIFORM_H +#define SCM_UNIFORM_H + +/* Copyright (C) 1995,1996,1997,1999,2000,2001, 2004, 2006, 2008, 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 + */ + + + +#include "libguile/__scm.h" +#include "libguile/generalized-vectors.h" + + + +/* + * Uniform vectors contain unboxed values. They are not necessarily contiguous. + */ + +SCM_INTERNAL const size_t scm_i_array_element_type_sizes[]; +#define SCM_ARRAY_ELEMENT_TYPE_IS_UNBOXED(t) \ + (scm_i_array_element_type_sizes[(t)] != 0) + +/* returns type size in bits */ +SCM_API size_t scm_array_handle_uniform_element_size (scm_t_array_handle *h); + +SCM_API const void *scm_array_handle_uniform_elements (scm_t_array_handle *h); +SCM_API void *scm_array_handle_uniform_writable_elements (scm_t_array_handle *h); + +SCM_API SCM scm_uniform_vector_p (SCM v); +SCM_API SCM scm_uniform_vector_length (SCM v); +SCM_API SCM scm_uniform_vector_element_type (SCM v); +SCM_API SCM scm_uniform_vector_element_size (SCM v); +SCM_API SCM scm_uniform_vector_ref (SCM v, SCM idx); +SCM_API SCM scm_uniform_vector_set_x (SCM v, SCM idx, SCM val); +SCM_API SCM scm_uniform_vector_to_list (SCM v); +SCM_API SCM scm_uniform_vector_read_x (SCM v, SCM port_or_fd, + SCM start, SCM end); +SCM_API SCM scm_uniform_vector_write (SCM v, SCM port_or_fd, + SCM start, SCM end); + +SCM_API int scm_is_uniform_vector (SCM obj); +SCM_API size_t scm_c_uniform_vector_length (SCM v); +SCM_API SCM scm_c_uniform_vector_ref (SCM v, size_t idx); +SCM_API void scm_c_uniform_vector_set_x (SCM v, size_t idx, SCM val); +SCM_API const void *scm_uniform_vector_elements (SCM uvec, + scm_t_array_handle *h, + size_t *lenp, ssize_t *incp); +SCM_API void *scm_uniform_vector_writable_elements (SCM uvec, + scm_t_array_handle *h, + size_t *lenp, + ssize_t *incp); + +SCM_INTERNAL void scm_init_uniform (void); + +#endif /* SCM_UNIFORM_H */ + +/* + Local Variables: + c-file-style: "gnu" + End: +*/ -- cgit v1.2.3 From 943a0a8759504c4a367c1904bef4a8afbc6208dd Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sat, 18 Jul 2009 12:58:37 +0200 Subject: make-typed-array builds backing vector via make-generalized-vector * libguile/arrays.c: Rework to use scm_make_generalized_vector instead of our own type table. * libguile/bitvectors.c: Fix some includes. --- libguile/arrays.c | 253 ++++++++++++++++---------------------------------- libguile/bitvectors.c | 3 +- 2 files changed, 82 insertions(+), 174 deletions(-) (limited to 'libguile/arrays.c') diff --git a/libguile/arrays.c b/libguile/arrays.c index 6114adc0e..2be9ec3f0 100644 --- a/libguile/arrays.c +++ b/libguile/arrays.c @@ -44,103 +44,22 @@ #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/generalized-arrays.h" +#include "libguile/array-map.h" #include "libguile/generalized-vectors.h" +#include "libguile/generalized-arrays.h" #include "libguile/uniform.h" -#include "libguile/array-map.h" -#include "libguile/print.h" -#include "libguile/read.h" -#ifdef HAVE_UNISTD_H -#include -#endif - -#ifdef HAVE_IO_H -#include -#endif - - -/* The set of uniform scm_vector types is: - * Vector of: Called: Replaced by: - * unsigned char string - * char byvect s8 or u8, depending on signedness of 'char' - * boolean bvect - * signed long ivect s32 - * unsigned long uvect u32 - * float fvect f32 - * double dvect d32 - * complex double cvect c64 - * short svect s16 - * long long llvect s64 - */ 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)) -typedef SCM creator_proc (SCM len, SCM fill); - -struct { - char *type_name; - SCM type; - creator_proc *creator; -} type_creator_table[] = { - { "a", SCM_UNSPECIFIED, scm_make_string }, - { "b", SCM_UNSPECIFIED, scm_make_bitvector }, - { "u8", SCM_UNSPECIFIED, scm_make_u8vector }, - { "s8", SCM_UNSPECIFIED, scm_make_s8vector }, - { "u16", SCM_UNSPECIFIED, scm_make_u16vector }, - { "s16", SCM_UNSPECIFIED, scm_make_s16vector }, - { "u32", SCM_UNSPECIFIED, scm_make_u32vector }, - { "s32", SCM_UNSPECIFIED, scm_make_s32vector }, - { "u64", SCM_UNSPECIFIED, scm_make_u64vector }, - { "s64", SCM_UNSPECIFIED, scm_make_s64vector }, - { "f32", SCM_UNSPECIFIED, scm_make_f32vector }, - { "f64", SCM_UNSPECIFIED, scm_make_f64vector }, - { "c32", SCM_UNSPECIFIED, scm_make_c32vector }, - { "c64", SCM_UNSPECIFIED, scm_make_c64vector }, - { "vu8", SCM_UNSPECIFIED, scm_make_bytevector }, - { NULL } -}; - -static void -init_type_creator_table () -{ - int i; - for (i = 0; type_creator_table[i].type_name; i++) - { - SCM sym = scm_from_locale_symbol (type_creator_table[i].type_name); - type_creator_table[i].type = scm_permanent_object (sym); - } -} - -static creator_proc * -type_to_creator (SCM type) -{ - int i; - - if (scm_is_eq (type, SCM_BOOL_T)) - return scm_make_vector; - for (i = 0; type_creator_table[i].type_name; i++) - if (scm_is_eq (type, type_creator_table[i].type)) - return type_creator_table[i].creator; - - scm_misc_error (NULL, "unknown array type: ~a", scm_list_1 (type)); -} - -static SCM -make_typed_vector (SCM type, size_t len) -{ - creator_proc *creator = type_to_creator (type); - return creator (scm_from_size_t (len), SCM_UNDEFINED); -} - SCM_DEFINE (scm_shared_array_root, "shared-array-root", 1, 0, 0, (SCM ra), @@ -151,7 +70,7 @@ SCM_DEFINE (scm_shared_array_root, "shared-array-root", 1, 0, 0, return SCM_I_ARRAY_V (ra); else if (scm_is_generalized_vector (ra)) return ra; - scm_wrong_type_arg_msg (NULL, 0, ra, "array"); + scm_wrong_type_arg_msg (FUNC_NAME, SCM_ARG1, ra, "array"); } #undef FUNC_NAME @@ -256,10 +175,8 @@ SCM_DEFINE (scm_make_typed_array, "make-typed-array", 2, 0, 1, { size_t k, rlen = 1; scm_t_array_dim *s; - creator_proc *creator; SCM ra; - creator = type_to_creator (type); ra = scm_i_shap2ra (bounds); SCM_SET_ARRAY_CONTIGUOUS_FLAG (ra); s = SCM_I_ARRAY_DIMS (ra); @@ -275,7 +192,8 @@ 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) = creator (scm_from_size_t (rlen), fill); + 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)) @@ -291,13 +209,11 @@ scm_from_contiguous_typed_array (SCM type, SCM bounds, const void *bytes, { size_t k, rlen = 1; scm_t_array_dim *s; - creator_proc *creator; SCM ra; scm_t_array_handle h; void *base; size_t sz; - creator = type_to_creator (type); ra = scm_i_shap2ra (bounds); SCM_SET_ARRAY_CONTIGUOUS_FLAG (ra); s = SCM_I_ARRAY_DIMS (ra); @@ -309,7 +225,8 @@ 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) = creator (scm_from_size_t (rlen), SCM_UNDEFINED); + SCM_I_ARRAY_V (ra) = + scm_make_generalized_vector (type, scm_from_size_t (rlen), SCM_UNDEFINED); scm_array_get_handle (ra, &h); @@ -425,9 +342,12 @@ SCM_DEFINE (scm_make_shared_array, "make-shared-array", 2, 0, 1, if (s[k].ubnd < s[k].lbnd) { if (1 == SCM_I_ARRAY_NDIM (ra)) - ra = make_typed_vector (scm_array_type (ra), 0); + ra = scm_make_generalized_vector (scm_array_type (ra), + SCM_INUM0, SCM_UNDEFINED); else - SCM_I_ARRAY_V (ra) = make_typed_vector (scm_array_type (ra), 0); + 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; } @@ -467,7 +387,8 @@ SCM_DEFINE (scm_make_shared_array, "make-shared-array", 2, 0, 1, if (1 == s->inc && 0 == s->lbnd && length == 1 + s->ubnd) return v; if (s->ubnd < s->lbnd) - return make_typed_vector (scm_array_type (ra), 0); + return scm_make_generalized_vector (scm_array_type (ra), SCM_INUM0, + SCM_UNDEFINED); } scm_i_ra_set_contp (ra); return ra; @@ -603,7 +524,7 @@ SCM_DEFINE (scm_array_contents, "array-contents", 1, 1, 0, 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)) + if (!SCM_UNBNDP (strict) && scm_is_true (strict)) { if (ndim && (1 != SCM_I_ARRAY_DIMS (ra)[ndim - 1].inc)) return SCM_BOOL_F; @@ -664,7 +585,9 @@ scm_ra2contig (SCM ra, int copy) 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) = make_typed_vector (scm_array_type (ra), inc); + 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; @@ -779,7 +702,36 @@ SCM_DEFINE (scm_uniform_array_write, "uniform-array-write", 1, 3, 0, #undef FUNC_NAME -static void l2ra (SCM lst, scm_t_array_handle *handle, ssize_t pos, size_t k); +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), @@ -844,7 +796,7 @@ SCM_DEFINE (scm_list_to_typed_array, "list->typed-array", 3, 0, 0, scm_reverse_x (shape, SCM_EOL)); scm_array_get_handle (ra, &handle); - l2ra (lst, &handle, 0, 0); + list_to_array (lst, &handle, 0, 0); scm_array_handle_release (&handle); return ra; @@ -860,117 +812,76 @@ SCM_DEFINE (scm_list_to_array, "list->array", 2, 0, 0, } #undef FUNC_NAME -static void -l2ra (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)) - { - l2ra (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))); - } -} - /* Print dimension DIM of ARRAY. */ static int -scm_i_print_array_dimension (SCM array, int dim, int base, +scm_i_print_array_dimension (scm_t_array_handle *h, int dim, int pos, SCM port, scm_print_state *pstate) { - scm_t_array_dim *dim_spec = SCM_I_ARRAY_DIMS (array) + dim; - long idx; - - scm_putc ('(', port); - - for (idx = dim_spec->lbnd; idx <= dim_spec->ubnd; idx++) + if (dim == h->ndims) + scm_iprin1 (scm_array_handle_ref (h, pos), port, pstate); + else { - if (dim < SCM_I_ARRAY_NDIM(array)-1) - scm_i_print_array_dimension (array, dim+1, base, - port, pstate); - else - scm_iprin1 (scm_c_generalized_vector_ref (SCM_I_ARRAY_V (array), base), - port, pstate); - if (idx < dim_spec->ubnd) - scm_putc (' ', port); - base += dim_spec->inc; + 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); } - - scm_putc (')', port); return 1; } -/* Print an array. (Only for strict arrays, not for generalized vectors.) +/* Print an array. */ static int scm_i_print_array (SCM array, SCM port, scm_print_state *pstate) { - long ndim = SCM_I_ARRAY_NDIM (array); - scm_t_array_dim *dim_specs = SCM_I_ARRAY_DIMS (array); - SCM v = SCM_I_ARRAY_V (array); - unsigned long base = SCM_I_ARRAY_BASE (array); + 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 (ndim != 1 || dim_specs[0].lbnd != 0) - scm_intprint (ndim, 10, port); - if (scm_is_uniform_vector (v)) - scm_puts (scm_i_uniform_vector_tag (v), port); - else if (scm_is_bitvector (v)) - scm_puts ("b", port); - else if (scm_is_string (v)) - scm_puts ("a", port); - else if (!scm_is_vector (v)) - scm_puts ("?", 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 < ndim; i++) + for (i = 0; i < h.ndims; i++) { - if (dim_specs[i].lbnd != 0) + if (h.dims[i].lbnd != 0) print_lbnds = 1; - if (dim_specs[i].ubnd - dim_specs[i].lbnd + 1 == 0) + 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 < ndim; i++) + for (i = 0; i < h.ndims; i++) { if (print_lbnds) { scm_putc ('@', port); - scm_intprint (dim_specs[i].lbnd, 10, port); + scm_intprint (h.dims[i].lbnd, 10, port); } if (print_lens) { scm_putc (':', port); - scm_intprint (dim_specs[i].ubnd - dim_specs[i].lbnd + 1, + scm_intprint (h.dims[i].ubnd - h.dims[i].lbnd + 1, 10, port); } } - if (ndim == 0) + if (h.ndims == 0) { /* Rank zero arrays, which are really just scalars, are printed specially. The consequent way would be to print them as @@ -993,12 +904,12 @@ scm_i_print_array (SCM array, SCM port, scm_print_state *pstate) can be modified with array-set!, say. */ scm_putc ('(', port); - scm_iprin1 (scm_c_generalized_vector_ref (v, base), port, pstate); + scm_i_print_array_dimension (&h, 0, 0, port, pstate); scm_putc (')', port); return 1; } else - return scm_i_print_array_dimension (array, 0, base, port, pstate); + return scm_i_print_array_dimension (&h, 0, 0, port, pstate); } /* Read an array. This function can also read vectors and uniform @@ -1234,8 +1145,6 @@ scm_init_arrays () scm_add_feature ("array"); - init_type_creator_table (); - #include "libguile/arrays.x" } diff --git a/libguile/bitvectors.c b/libguile/bitvectors.c index 95d37a38a..f1d8473d9 100644 --- a/libguile/bitvectors.c +++ b/libguile/bitvectors.c @@ -32,9 +32,8 @@ #include "libguile/array-handle.h" #include "libguile/bitvectors.h" #include "libguile/arrays.h" -#include "libguile/vectors.h" -#include "libguile/srfi-4.h" #include "libguile/generalized-vectors.h" +#include "libguile/srfi-4.h" /* Bit vectors. Would be nice if they were implemented on top of bytevectors, * but alack, all we have is this crufty C. -- cgit v1.2.3