diff options
author | Andy Wingo <wingo@pobox.com> | 2009-07-17 18:54:06 +0200 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2009-07-19 15:15:44 +0200 |
commit | 1030b45049f564f4abd459abd8e59db34c7867cc (patch) | |
tree | 25859c15badfd66f0e2757bc324c8352634a567c /libguile/generalized-arrays.c | |
parent | 66b9d7d304a349d5bb4f763a47143f09da58d97f (diff) | |
download | guile-1030b45049f564f4abd459abd8e59db34c7867cc.tar.gz |
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.
Diffstat (limited to 'libguile/generalized-arrays.c')
-rw-r--r-- | libguile/generalized-arrays.c | 276 |
1 files changed, 276 insertions, 0 deletions
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 <config.h> +#endif + +#include <stdio.h> +#include <errno.h> +#include <string.h> + +#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: +*/ |