From bc7bd22267903fcaab945fa6e4c03318f9fc664b Mon Sep 17 00:00:00 2001 From: Daniel Llorens Date: Tue, 3 Aug 2021 14:19:18 +0200 Subject: [PATCH] Merge libguile/generalized-arrays.* into libguile/arrays.* * libguile/arrays.h: * libguile/arrays.c: As stated. * libguile/init.c: Remove call to scm_init_generalized_arrays(). Elsewhere fix references to generalized-arrays.*. --- libguile.h | 1 - libguile/Makefile.am | 4 - libguile/array-map.c | 1 - libguile/arrays.c | 800 ++++++++++++++++++++++++---------- libguile/arrays.h | 33 +- libguile/eq.c | 2 +- libguile/generalized-arrays.c | 410 ----------------- libguile/generalized-arrays.h | 73 ---- libguile/init.c | 2 - libguile/random.c | 1 - libguile/sort.c | 1 - 11 files changed, 614 insertions(+), 714 deletions(-) delete mode 100644 libguile/generalized-arrays.c delete mode 100644 libguile/generalized-arrays.h diff --git a/libguile.h b/libguile.h index 45117af9e..6b76abe29 100644 --- a/libguile.h +++ b/libguile.h @@ -58,7 +58,6 @@ extern "C" { #include "libguile/fports.h" #include "libguile/frames.h" #include "libguile/gc.h" -#include "libguile/generalized-arrays.h" #include "libguile/generalized-vectors.h" #include "libguile/goops.h" #include "libguile/gsubr.h" diff --git a/libguile/Makefile.am b/libguile/Makefile.am index c0cc08cbc..3568767af 100644 --- a/libguile/Makefile.am +++ b/libguile/Makefile.am @@ -163,7 +163,6 @@ libguile_@GUILE_EFFECTIVE_VERSION@_la_SOURCES = \ gc-malloc.c \ gc.c \ gettext.c \ - generalized-arrays.c \ generalized-vectors.c \ goops.c \ gsubr.c \ @@ -281,7 +280,6 @@ DOT_X_FILES = \ gc-malloc.x \ gc.x \ gettext.x \ - generalized-arrays.x \ generalized-vectors.x \ goops.x \ gsubr.x \ @@ -388,7 +386,6 @@ DOT_DOC_FILES = \ gc-malloc.doc \ gc.doc \ gettext.doc \ - generalized-arrays.doc \ generalized-vectors.doc \ goops.doc \ gsubr.doc \ @@ -636,7 +633,6 @@ modinclude_HEADERS = \ gc.h \ gc-inline.h \ gettext.h \ - generalized-arrays.h \ generalized-vectors.h \ goops.h \ gsubr.h \ diff --git a/libguile/array-map.c b/libguile/array-map.c index 6460a2483..92a249bf9 100644 --- a/libguile/array-map.c +++ b/libguile/array-map.c @@ -36,7 +36,6 @@ #include "eq.h" #include "eval.h" #include "feature.h" -#include "generalized-arrays.h" #include "gsubr.h" #include "list.h" #include "numbers.h" diff --git a/libguile/arrays.c b/libguile/arrays.c index 0a919515b..1c81a14c1 100644 --- a/libguile/arrays.c +++ b/libguile/arrays.c @@ -1,5 +1,5 @@ -/* Copyright 1995-1998,2000-2006,2009-2015,2018 - Free Software Foundation, Inc. +/* Copyright 1995-1998,2000-2006,2009-2015,2018, 2021 + Free Software Foundation, Inc. This file is part of Guile. @@ -35,10 +35,10 @@ #include "chars.h" #include "dynwind.h" #include "eq.h" +#include "error.h" #include "eval.h" #include "feature.h" #include "fports.h" -#include "generalized-arrays.h" #include "generalized-vectors.h" #include "gsubr.h" #include "list.h" @@ -56,6 +56,370 @@ #include "arrays.h" +SCM_INTERNAL SCM scm_i_array_ref (SCM v, + SCM idx0, SCM idx1, SCM idxN); +SCM_INTERNAL SCM scm_i_array_set_x (SCM v, SCM obj, + SCM idx0, SCM idx1, SCM idxN); + + +int +scm_is_array (SCM obj) +{ + if (!SCM_HEAP_OBJECT_P (obj)) + return 0; + + switch (SCM_TYP7 (obj)) + { + case scm_tc7_string: + case scm_tc7_vector: + case scm_tc7_bitvector: + case scm_tc7_bytevector: + case scm_tc7_array: + return 1; + default: + return 0; + } +} + +SCM_DEFINE (scm_array_p_2, "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_2 +{ + return scm_from_bool (scm_is_array (obj)); +} +#undef FUNC_NAME + +/* The array type predicate, with an extra argument kept for backward + compatibility. Note that we can't use `SCM_DEFINE' directly because there + would be an argument count mismatch that would be caught by + `snarf-check-and-output-texi.scm'. */ +SCM +scm_array_p (SCM obj, SCM unused) +{ + return scm_array_p_2 (obj); +} + +int +scm_is_typed_array (SCM obj, SCM type) +{ + int ret = 0; + if (scm_is_array (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_length (SCM array) +{ + scm_t_array_handle handle; + size_t res; + + scm_array_get_handle (array, &handle); + if (scm_array_handle_rank (&handle) < 1) + { + scm_array_handle_release (&handle); + scm_wrong_type_arg_msg (NULL, 0, array, "array of nonzero rank"); + } + res = handle.dims[0].ubnd - handle.dims[0].lbnd + 1; + scm_array_handle_release (&handle); + + return res; +} + +SCM_DEFINE (scm_array_length, "array-length", 1, 0, 0, + (SCM array), + "Return the length of an array: its first dimension.\n" + "It is an error to ask for the length of an array of rank 0.") +#define FUNC_NAME s_scm_array_length +{ + return scm_from_size_t (scm_c_array_length (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_array_type, "array-type", 1, 0, 0, + (SCM ra), + "") +#define FUNC_NAME s_scm_array_type +{ + scm_t_array_handle h; + SCM type; + + 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_type_code, + "array-type-code", 1, 0, 0, + (SCM array), + "Return the type of the elements in @var{array},\n" + "as an integer code.") +#define FUNC_NAME s_scm_array_type_code +{ + scm_t_array_handle h; + scm_t_array_element_type element_type; + + scm_array_get_handle (array, &h); + element_type = h.element_type; + scm_array_handle_release (&h); + + return scm_from_uint16 (element_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 +scm_c_array_ref_1 (SCM array, ssize_t idx0) +{ + scm_t_array_handle handle; + SCM res; + + scm_array_get_handle (array, &handle); + res = scm_array_handle_ref (&handle, scm_array_handle_pos_1 (&handle, idx0)); + scm_array_handle_release (&handle); + return res; +} + + +SCM +scm_c_array_ref_2 (SCM array, ssize_t idx0, ssize_t idx1) +{ + scm_t_array_handle handle; + SCM res; + + scm_array_get_handle (array, &handle); + res = scm_array_handle_ref (&handle, scm_array_handle_pos_2 (&handle, idx0, idx1)); + scm_array_handle_release (&handle); + return res; +} + + +SCM +scm_array_ref (SCM v, SCM args) +{ + 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; +} + + +void +scm_c_array_set_1_x (SCM array, SCM obj, ssize_t idx0) +{ + scm_t_array_handle handle; + + scm_array_get_handle (array, &handle); + scm_array_handle_set (&handle, scm_array_handle_pos_1 (&handle, idx0), + obj); + scm_array_handle_release (&handle); +} + + +void +scm_c_array_set_2_x (SCM array, SCM obj, ssize_t idx0, ssize_t idx1) +{ + scm_t_array_handle handle; + + scm_array_get_handle (array, &handle); + scm_array_handle_set (&handle, scm_array_handle_pos_2 (&handle, idx0, idx1), + obj); + scm_array_handle_release (&handle); +} + + +SCM +scm_array_set_x (SCM v, SCM obj, SCM args) +{ + 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; +} + + +SCM_DEFINE (scm_i_array_ref, "array-ref", 1, 2, 1, + (SCM v, SCM idx0, SCM idx1, SCM idxN), + "Return the element at the @code{(idx0, idx1, idxN...)}\n" + "position in array @var{v}.") +#define FUNC_NAME s_scm_i_array_ref +{ + if (SCM_UNBNDP (idx0)) + return scm_array_ref (v, SCM_EOL); + else if (SCM_UNBNDP (idx1)) + return scm_c_array_ref_1 (v, scm_to_ssize_t (idx0)); + else if (scm_is_null (idxN)) + return scm_c_array_ref_2 (v, scm_to_ssize_t (idx0), scm_to_ssize_t (idx1)); + else + return scm_array_ref (v, scm_cons (idx0, scm_cons (idx1, idxN))); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_i_array_set_x, "array-set!", 2, 2, 1, + (SCM v, SCM obj, SCM idx0, SCM idx1, SCM idxN), + "Set the element at the @code{(idx0, idx1, idxN...)} position\n" + "in the array @var{v} to @var{obj}. The value returned by\n" + "@code{array-set!} is unspecified.") +#define FUNC_NAME s_scm_i_array_set_x +{ + if (SCM_UNBNDP (idx0)) + scm_array_set_x (v, obj, SCM_EOL); + else if (SCM_UNBNDP (idx1)) + scm_c_array_set_1_x (v, obj, scm_to_ssize_t (idx0)); + else if (scm_is_null (idxN)) + scm_c_array_set_2_x (v, obj, scm_to_ssize_t (idx0), scm_to_ssize_t (idx1)); + else + scm_array_set_x (v, obj, scm_cons (idx0, scm_cons (idx1, idxN))); + + 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; + + i = h->dims[dim].ubnd - h->dims[dim].lbnd + 1; + inc = h->dims[dim].inc; + pos += (i - 1) * inc; + + for (; i > 0; 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), + "Return a list representation of @var{array}.\n\n" + "It is easiest to specify the behavior of this function by\n" + "example:\n" + "@example\n" + "(array->list #0(a)) @result{} 1\n" + "(array->list #1(a b)) @result{} (a b)\n" + "(array->list #2((aa ab) (ba bb)) @result{} ((aa ab) (ba bb))\n" + "@end example\n") +#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 size_t scm_c_array_rank (SCM array) @@ -69,8 +433,8 @@ scm_c_array_rank (SCM array) } SCM_DEFINE (scm_array_rank, "array-rank", 1, 0, 0, - (SCM array), - "Return the number of dimensions of the array @var{array.}\n") + (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)); @@ -79,8 +443,8 @@ SCM_DEFINE (scm_array_rank, "array-rank", 1, 0, 0, SCM_DEFINE (scm_shared_array_root, "shared-array-root", 1, 0, 0, - (SCM ra), - "Return the root vector of a shared array.") + (SCM ra), + "Return the root vector of a shared array.") #define FUNC_NAME s_scm_shared_array_root { if (SCM_I_ARRAYP (ra)) @@ -94,8 +458,8 @@ SCM_DEFINE (scm_shared_array_root, "shared-array-root", 1, 0, 0, SCM_DEFINE (scm_shared_array_offset, "shared-array-offset", 1, 0, 0, - (SCM ra), - "Return the root vector index of the first element in the array.") + (SCM ra), + "Return the root vector index of the first element in the array.") #define FUNC_NAME s_scm_shared_array_offset { if (SCM_I_ARRAYP (ra)) @@ -109,8 +473,8 @@ SCM_DEFINE (scm_shared_array_offset, "shared-array-offset", 1, 0, 0, SCM_DEFINE (scm_shared_array_increments, "shared-array-increments", 1, 0, 0, - (SCM ra), - "For each dimension, return the distance between elements in the root vector.") + (SCM ra), + "For each dimension, return the distance between elements in the root vector.") #define FUNC_NAME s_scm_shared_array_increments { if (SCM_I_ARRAYP (ra)) @@ -166,35 +530,35 @@ scm_i_shap2ra (SCM args) { spec = SCM_CAR (args); if (scm_is_integer (spec)) - { - s->lbnd = 0; - s->ubnd = scm_to_ssize_t (spec); + { + s->lbnd = 0; + s->ubnd = scm_to_ssize_t (spec); if (s->ubnd < 0) scm_misc_error (NULL, s_bad_spec, SCM_EOL); --s->ubnd; - } + } else - { - if (!scm_is_pair (spec) || !scm_is_integer (SCM_CAR (spec))) - scm_misc_error (NULL, s_bad_spec, SCM_EOL); - s->lbnd = scm_to_ssize_t (SCM_CAR (spec)); - spec = SCM_CDR (spec); - if (!scm_is_pair (spec) - || !scm_is_integer (SCM_CAR (spec)) - || !scm_is_null (SCM_CDR (spec))) - scm_misc_error (NULL, s_bad_spec, SCM_EOL); - s->ubnd = scm_to_ssize_t (SCM_CAR (spec)); + { + if (!scm_is_pair (spec) || !scm_is_integer (SCM_CAR (spec))) + scm_misc_error (NULL, s_bad_spec, SCM_EOL); + s->lbnd = scm_to_ssize_t (SCM_CAR (spec)); + spec = SCM_CDR (spec); + if (!scm_is_pair (spec) + || !scm_is_integer (SCM_CAR (spec)) + || !scm_is_null (SCM_CDR (spec))) + scm_misc_error (NULL, s_bad_spec, SCM_EOL); + s->ubnd = scm_to_ssize_t (SCM_CAR (spec)); if (s->ubnd - s->lbnd < -1) scm_misc_error (NULL, s_bad_spec, SCM_EOL); - } + } s->inc = 1; } return ra; } 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}.") + (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; @@ -285,8 +649,8 @@ scm_from_contiguous_typed_array (SCM type, SCM bounds, const void *bytes, #undef FUNC_NAME SCM_DEFINE (scm_make_array, "make-array", 1, 0, 1, - (SCM fill, SCM bounds), - "Create and return an array.") + (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); @@ -302,38 +666,38 @@ scm_i_ra_set_contp (SCM ra) { ssize_t 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); - } + { + 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\n" - "of other arrays. The @var{mapfunc} is a function that\n" - "translates coordinates in the new array into coordinates in the\n" - "old array. A @var{mapfunc} must be linear, and its range must\n" - "stay within the bounds of the old array, but it can be\n" - "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") + (SCM oldra, SCM mapfunc, SCM dims), + "@code{make-shared-array} can be used to create shared subarrays\n" + "of other arrays. The @var{mapfunc} is a function that\n" + "translates coordinates in the new array into coordinates in the\n" + "old array. A @var{mapfunc} must be linear, and its range must\n" + "stay within the bounds of the old array, but it can be\n" + "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; @@ -358,12 +722,12 @@ SCM_DEFINE (scm_make_shared_array, "make-shared-array", 2, 0, 1, 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; - } + { + 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 { @@ -378,16 +742,16 @@ SCM_DEFINE (scm_make_shared_array, "make-shared-array", 2, 0, 1, { inds = scm_cons (scm_from_ssize_t (s[k].lbnd), inds); if (s[k].ubnd < s[k].lbnd) - { - if (1 == SCM_I_ARRAY_NDIM (ra)) - ra = scm_make_generalized_vector (scm_array_type (ra), + { + if (1 == SCM_I_ARRAY_NDIM (ra)) + ra = scm_make_generalized_vector (scm_array_type (ra), SCM_INUM0, SCM_UNDEFINED); - else - SCM_I_ARRAY_SET_V (ra, scm_make_generalized_vector (scm_array_type (ra), + else + SCM_I_ARRAY_SET_V (ra, scm_make_generalized_vector (scm_array_type (ra), SCM_INUM0, SCM_UNDEFINED)); - scm_array_handle_release (&old_handle); - return ra; - } + scm_array_handle_release (&old_handle); + return ra; + } } imap = scm_apply_0 (mapfunc, scm_reverse (inds)); @@ -399,18 +763,18 @@ SCM_DEFINE (scm_make_shared_array, "make-shared-array", 2, 0, 1, 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; - } + { + 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 */ + s[k].inc = new_max - new_min + 1; /* contiguous by default */ indptr = SCM_CDR (indptr); } @@ -423,9 +787,9 @@ SCM_DEFINE (scm_make_shared_array, "make-shared-array", 2, 0, 1, SCM v = SCM_I_ARRAY_V (ra); size_t length = scm_c_array_length (v); if (1 == s->inc && 0 == s->lbnd && length == 1 + s->ubnd) - return v; + return v; if (s->ubnd < s->lbnd) - return scm_make_generalized_vector (scm_array_type (ra), SCM_INUM0, + return scm_make_generalized_vector (scm_array_type (ra), SCM_INUM0, SCM_UNDEFINED); } scm_i_ra_set_contp (ra); @@ -470,7 +834,7 @@ array_from_get_o (scm_t_array_handle *handle, size_t k, scm_t_array_dim *s, ssiz } SCM_DEFINE (scm_array_slice, "array-slice", 1, 0, 1, - (SCM ra, SCM indices), + (SCM ra, SCM indices), "Return the array slice @var{ra}[@var{indices} ..., ...]\n" "The rank of @var{ra} must equal to the number of indices or larger.\n\n" "See also @code{array-ref}, @code{array-cell-ref}, @code{array-cell-set!}.\n\n" @@ -508,7 +872,7 @@ SCM_DEFINE (scm_array_slice, "array-slice", 1, 0, 1, SCM_DEFINE (scm_array_cell_ref, "array-cell-ref", 1, 0, 1, - (SCM ra, SCM indices), + (SCM ra, SCM indices), "Return the element at the @code{(@var{indices} ...)} position\n" "in array @var{ra}, or the array slice @var{ra}[@var{indices} ..., ...]\n" "if the rank of @var{ra} is larger than the number of indices.\n\n" @@ -608,26 +972,26 @@ SCM_DEFINE (scm_array_cell_set_x, "array-cell-set!", 2, 0, 1, /* 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{ra}, but with\n" - "dimensions arranged in a different order. There must be one\n" - "@var{dim} argument for each dimension of @var{ra}.\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{ra}. Several @var{dim}s\n" - "may have the same value, in which case the returned array will\n" - "have smaller rank than @var{ra}.\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") + (SCM ra, SCM args), + "Return an array sharing contents with @var{ra}, but with\n" + "dimensions arranged in a different order. There must be one\n" + "@var{dim} argument for each dimension of @var{ra}.\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{ra}. Several @var{dim}s\n" + "may have the same value, in which case the returned array will\n" + "have smaller rank than @var{ra}.\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; @@ -641,64 +1005,64 @@ SCM_DEFINE (scm_transpose_array, "transpose-array", 1, 0, 1, { case 0: if (!scm_is_null (args)) - SCM_WRONG_NUM_ARGS (); + SCM_WRONG_NUM_ARGS (); return ra; case 1: /* Make sure that we are called with a single zero as - arguments. + arguments. */ if (scm_is_null (args) || !scm_is_null (SCM_CDR (args))) - SCM_WRONG_NUM_ARGS (); + SCM_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; default: vargs = scm_vector (args); if (SCM_SIMPLE_VECTOR_LENGTH (vargs) != SCM_I_ARRAY_NDIM (ra)) - SCM_WRONG_NUM_ARGS (); + 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; - } + { + i = scm_to_signed_integer (SCM_SIMPLE_VECTOR_REF (vargs, k), + 0, SCM_I_ARRAY_NDIM(ra)); + if (ndim < i) + ndim = i; + } ndim++; res = scm_i_make_array (ndim); SCM_I_ARRAY_SET_V (res, SCM_I_ARRAY_V (ra)); SCM_I_ARRAY_SET_BASE (res, SCM_I_ARRAY_BASE (ra)); for (k = ndim; k--;) - { - SCM_I_ARRAY_DIMS (res)[k].lbnd = 0; - SCM_I_ARRAY_DIMS (res)[k].ubnd = -1; - } + { + 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_SET_BASE (res, SCM_I_ARRAY_BASE (res) + (s->lbnd - r->lbnd) * r->inc); - r->lbnd = s->lbnd; - } - r->inc += s->inc; - } - } + { + 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_SET_BASE (res, 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_MISC_ERROR ("bad argument list", SCM_EOL); scm_i_ra_set_contp (res); return res; } @@ -710,16 +1074,16 @@ SCM_DEFINE (scm_transpose_array, "transpose-array", 1, 0, 1, /* if strict is true, return #f if returned array wouldn't have contiguous elements. */ SCM_DEFINE (scm_array_contents, "array-contents", 1, 1, 0, - (SCM ra, SCM strict), - "If @var{ra} may be @dfn{unrolled} into a one dimensional shared\n" - "array without changing their order (last subscript changing\n" - "fastest), then @code{array-contents} returns that shared array,\n" - "otherwise it returns @code{#f}. All arrays made by\n" - "@code{make-array} and @code{make-uniform-array} may be unrolled,\n" - "some arrays made by @code{make-shared-array} may not be. If\n" - "the optional argument @var{strict} is provided, a shared array\n" - "will be returned only if its elements are stored contiguously\n" - "in memory.") + (SCM ra, SCM strict), + "If @var{ra} may be @dfn{unrolled} into a one dimensional shared\n" + "array without changing their order (last subscript changing\n" + "fastest), then @code{array-contents} returns that shared array,\n" + "otherwise it returns @code{#f}. All arrays made by\n" + "@code{make-array} and @code{make-uniform-array} may be unrolled,\n" + "some arrays made by @code{make-shared-array} may not be. If\n" + "the optional argument @var{strict} is provided, a shared array\n" + "will be returned only if its elements are stored contiguously\n" + "in memory.") #define FUNC_NAME s_scm_array_contents { if (SCM_I_ARRAYP (ra)) @@ -742,19 +1106,19 @@ SCM_DEFINE (scm_array_contents, "array-contents", 1, 1, 0, } if (!SCM_UNBNDP (strict) && scm_is_true (strict)) - { - if (ndim && (1 != s[ndim - 1].inc)) - return SCM_BOOL_F; - if (scm_is_bitvector (SCM_I_ARRAY_V (ra)) + { + if (ndim && (1 != s[ndim - 1].inc)) + return SCM_BOOL_F; + if (scm_is_bitvector (SCM_I_ARRAY_V (ra)) && (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; - } + } v = SCM_I_ARRAY_V (ra); if ((len == scm_c_array_length (v)) && (0 == SCM_I_ARRAY_BASE (ra))) - return v; + return v; else { SCM sra = scm_i_make_array (1); @@ -788,38 +1152,38 @@ list_to_array (SCM lst, scm_t_array_handle *handle, ssize_t pos, size_t k) 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; - } + { + 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"; + 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"; + errmsg = "too many elements for array dimension ~a, want ~a"; if (errmsg) - scm_misc_error (NULL, errmsg, scm_list_2 (scm_from_size_t (k), - scm_from_size_t (len))); + scm_misc_error (NULL, errmsg, scm_list_2 (scm_from_size_t (k), + scm_from_size_t (len))); } } SCM_DEFINE (scm_list_to_typed_array, "list->typed-array", 3, 0, 0, - (SCM type, SCM shape, SCM lst), - "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.") + (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; @@ -832,40 +1196,40 @@ SCM_DEFINE (scm_list_to_typed_array, "list->typed-array", 3, 0, 0, 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); - } + { + 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; - } + { + 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_reverse_x (shape, SCM_EOL)); scm_array_get_handle (ra, &handle); list_to_array (lst, &handle, 0, 0); @@ -876,8 +1240,8 @@ SCM_DEFINE (scm_list_to_typed_array, "list->typed-array", 3, 0, 0, #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}.") + (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); @@ -889,7 +1253,7 @@ SCM_DEFINE (scm_list_to_array, "list->array", 2, 0, 0, static int scm_i_print_array_dimension (scm_t_array_handle *h, int dim, int pos, - SCM port, scm_print_state *pstate) + SCM port, scm_print_state *pstate) { if (dim == h->ndims) scm_iprin1 (scm_array_handle_ref (h, pos), port, pstate); @@ -917,26 +1281,26 @@ scm_i_print_array (SCM array, SCM port, scm_print_state *pstate) scm_call_2 (scm_c_private_ref ("ice-9 arrays", "array-print-prefix"), array, port); - + scm_array_get_handle (array, &h); if (h.ndims == 0) { /* Rank zero arrays, which are really just scalars, are printed - specially. The consequent way would be to print them as + specially. The consequent way would be to print them as - #0 OBJ + #0 OBJ where OBJ is the printed representation of the scalar, but we print them instead as - #0(OBJ) + #0(OBJ) to make them look less strange. - Just printing them as + Just printing them as - OBJ + 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 @@ -958,7 +1322,5 @@ void scm_init_arrays () { scm_add_feature ("array"); - #include "arrays.x" - } diff --git a/libguile/arrays.h b/libguile/arrays.h index 7221fdb63..8cc84c2b1 100644 --- a/libguile/arrays.h +++ b/libguile/arrays.h @@ -22,8 +22,8 @@ -#include "libguile/gc.h" #include "libguile/print.h" +#include "libguile/array-handle.h" @@ -31,6 +31,12 @@ Also see .... */ +#define SCM_VALIDATE_ARRAY(pos, v) \ + do { \ + SCM_ASSERT (SCM_HEAP_OBJECT_P (v) \ + && scm_is_true (scm_array_p (v, SCM_UNDEFINED)), \ + v, pos, FUNC_NAME); \ + } while (0) /** Arrays */ @@ -57,6 +63,31 @@ SCM_API SCM scm_list_to_typed_array (SCM type, SCM ndim, SCM lst); SCM_API size_t scm_c_array_rank (SCM ra); SCM_API SCM scm_array_rank (SCM ra); +SCM_API int scm_is_array (SCM obj); +SCM_API SCM scm_array_p (SCM v, SCM unused); +SCM_INTERNAL SCM scm_array_p_2 (SCM); + +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_length (SCM ra); +SCM_API SCM scm_array_length (SCM ra); + +SCM_API SCM scm_array_dimensions (SCM ra); +SCM_API SCM scm_array_type (SCM ra); +SCM_API SCM scm_array_type_code (SCM ra); +SCM_API SCM scm_array_in_bounds_p (SCM v, SCM args); + +SCM_API SCM scm_c_array_ref_1 (SCM v, ssize_t idx0); +SCM_API SCM scm_c_array_ref_2 (SCM v, ssize_t idx0, ssize_t idx1); + +SCM_API void scm_c_array_set_1_x (SCM v, SCM obj, ssize_t idx0); +SCM_API void scm_c_array_set_2_x (SCM v, SCM obj, ssize_t idx0, ssize_t idx1); + +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); + /* internal. */ /* see scm_from_contiguous_array for these three */ diff --git a/libguile/eq.c b/libguile/eq.c index 627d6f09b..bf18cda88 100644 --- a/libguile/eq.c +++ b/libguile/eq.c @@ -32,7 +32,7 @@ #include "bytevectors.h" #include "eval.h" #include "foreign.h" -#include "generalized-arrays.h" +#include "arrays.h" #include "goops.h" #include "gsubr.h" #include "hashtab.h" diff --git a/libguile/generalized-arrays.c b/libguile/generalized-arrays.c deleted file mode 100644 index 28ca6b3c7..000000000 --- a/libguile/generalized-arrays.c +++ /dev/null @@ -1,410 +0,0 @@ -/* Copyright 1995-1998,2000-2006,2009-2010,2013-2014,2018 - Free Software Foundation, Inc. - - This file is part of Guile. - - Guile 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. - - Guile 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 Guile. If not, see - . */ - - - - -#ifdef HAVE_CONFIG_H -# include -#endif - -#include -#include -#include - -#include "array-handle.h" -#include "gsubr.h" -#include "list.h" -#include "numbers.h" -#include "pairs.h" - -#include "generalized-arrays.h" - - -SCM_INTERNAL SCM scm_i_array_ref (SCM v, - SCM idx0, SCM idx1, SCM idxN); -SCM_INTERNAL SCM scm_i_array_set_x (SCM v, SCM obj, - SCM idx0, SCM idx1, SCM idxN); - - -int -scm_is_array (SCM obj) -{ - if (!SCM_HEAP_OBJECT_P (obj)) - return 0; - - switch (SCM_TYP7 (obj)) - { - case scm_tc7_string: - case scm_tc7_vector: - case scm_tc7_bitvector: - case scm_tc7_bytevector: - case scm_tc7_array: - return 1; - default: - return 0; - } -} - -SCM_DEFINE (scm_array_p_2, "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_2 -{ - return scm_from_bool (scm_is_array (obj)); -} -#undef FUNC_NAME - -/* The array type predicate, with an extra argument kept for backward - compatibility. Note that we can't use `SCM_DEFINE' directly because there - would be an argument count mismatch that would be caught by - `snarf-check-and-output-texi.scm'. */ -SCM -scm_array_p (SCM obj, SCM unused) -{ - return scm_array_p_2 (obj); -} - -int -scm_is_typed_array (SCM obj, SCM type) -{ - int ret = 0; - if (scm_is_array (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_length (SCM array) -{ - scm_t_array_handle handle; - size_t res; - - scm_array_get_handle (array, &handle); - if (scm_array_handle_rank (&handle) < 1) - { - scm_array_handle_release (&handle); - scm_wrong_type_arg_msg (NULL, 0, array, "array of nonzero rank"); - } - res = handle.dims[0].ubnd - handle.dims[0].lbnd + 1; - scm_array_handle_release (&handle); - - return res; -} - -SCM_DEFINE (scm_array_length, "array-length", 1, 0, 0, - (SCM array), - "Return the length of an array: its first dimension.\n" - "It is an error to ask for the length of an array of rank 0.") -#define FUNC_NAME s_scm_array_length -{ - return scm_from_size_t (scm_c_array_length (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_array_type, "array-type", 1, 0, 0, - (SCM ra), - "") -#define FUNC_NAME s_scm_array_type -{ - scm_t_array_handle h; - SCM type; - - 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_type_code, - "array-type-code", 1, 0, 0, - (SCM array), - "Return the type of the elements in @var{array},\n" - "as an integer code.") -#define FUNC_NAME s_scm_array_type_code -{ - scm_t_array_handle h; - scm_t_array_element_type element_type; - - scm_array_get_handle (array, &h); - element_type = h.element_type; - scm_array_handle_release (&h); - - return scm_from_uint16 (element_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 -scm_c_array_ref_1 (SCM array, ssize_t idx0) -{ - scm_t_array_handle handle; - SCM res; - - scm_array_get_handle (array, &handle); - res = scm_array_handle_ref (&handle, scm_array_handle_pos_1 (&handle, idx0)); - scm_array_handle_release (&handle); - return res; -} - - -SCM -scm_c_array_ref_2 (SCM array, ssize_t idx0, ssize_t idx1) -{ - scm_t_array_handle handle; - SCM res; - - scm_array_get_handle (array, &handle); - res = scm_array_handle_ref (&handle, scm_array_handle_pos_2 (&handle, idx0, idx1)); - scm_array_handle_release (&handle); - return res; -} - - -SCM -scm_array_ref (SCM v, SCM args) -{ - 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; -} - - -void -scm_c_array_set_1_x (SCM array, SCM obj, ssize_t idx0) -{ - scm_t_array_handle handle; - - scm_array_get_handle (array, &handle); - scm_array_handle_set (&handle, scm_array_handle_pos_1 (&handle, idx0), - obj); - scm_array_handle_release (&handle); -} - - -void -scm_c_array_set_2_x (SCM array, SCM obj, ssize_t idx0, ssize_t idx1) -{ - scm_t_array_handle handle; - - scm_array_get_handle (array, &handle); - scm_array_handle_set (&handle, scm_array_handle_pos_2 (&handle, idx0, idx1), - obj); - scm_array_handle_release (&handle); -} - - -SCM -scm_array_set_x (SCM v, SCM obj, SCM args) -{ - 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; -} - - -SCM_DEFINE (scm_i_array_ref, "array-ref", 1, 2, 1, - (SCM v, SCM idx0, SCM idx1, SCM idxN), - "Return the element at the @code{(idx0, idx1, idxN...)}\n" - "position in array @var{v}.") -#define FUNC_NAME s_scm_i_array_ref -{ - if (SCM_UNBNDP (idx0)) - return scm_array_ref (v, SCM_EOL); - else if (SCM_UNBNDP (idx1)) - return scm_c_array_ref_1 (v, scm_to_ssize_t (idx0)); - else if (scm_is_null (idxN)) - return scm_c_array_ref_2 (v, scm_to_ssize_t (idx0), scm_to_ssize_t (idx1)); - else - return scm_array_ref (v, scm_cons (idx0, scm_cons (idx1, idxN))); -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_i_array_set_x, "array-set!", 2, 2, 1, - (SCM v, SCM obj, SCM idx0, SCM idx1, SCM idxN), - "Set the element at the @code{(idx0, idx1, idxN...)} position\n" - "in the array @var{v} to @var{obj}. The value returned by\n" - "@code{array-set!} is unspecified.") -#define FUNC_NAME s_scm_i_array_set_x -{ - if (SCM_UNBNDP (idx0)) - scm_array_set_x (v, obj, SCM_EOL); - else if (SCM_UNBNDP (idx1)) - scm_c_array_set_1_x (v, obj, scm_to_ssize_t (idx0)); - else if (scm_is_null (idxN)) - scm_c_array_set_2_x (v, obj, scm_to_ssize_t (idx0), scm_to_ssize_t (idx1)); - else - scm_array_set_x (v, obj, scm_cons (idx0, scm_cons (idx1, idxN))); - - 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; - - i = h->dims[dim].ubnd - h->dims[dim].lbnd + 1; - inc = h->dims[dim].inc; - pos += (i - 1) * inc; - - for (; i > 0; 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), - "Return a list representation of @var{array}.\n\n" - "It is easiest to specify the behavior of this function by\n" - "example:\n" - "@example\n" - "(array->list #0(a)) @result{} 1\n" - "(array->list #1(a b)) @result{} (a b)\n" - "(array->list #2((aa ab) (ba bb)) @result{} ((aa ab) (ba bb))\n" - "@end example\n") -#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 "generalized-arrays.x" -} diff --git a/libguile/generalized-arrays.h b/libguile/generalized-arrays.h deleted file mode 100644 index 130807b29..000000000 --- a/libguile/generalized-arrays.h +++ /dev/null @@ -1,73 +0,0 @@ -#ifndef SCM_GENERALIZED_ARRAYS_H -#define SCM_GENERALIZED_ARRAYS_H - -/* Copyright 1995-1997,1999-2001,2004,2006,2008-2009,2013-2014,2018 - Free Software Foundation, Inc. - - This file is part of Guile. - - Guile 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. - - Guile 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 Guile. If not, see - . */ - - - -#include "libguile/array-handle.h" -#include "libguile/boolean.h" -#include - - - -/* These functions operate on all kinds of arrays that Guile knows about. - */ - - -#define SCM_VALIDATE_ARRAY(pos, v) \ - do { \ - SCM_ASSERT (SCM_HEAP_OBJECT_P (v) \ - && scm_is_true (scm_array_p (v, SCM_UNDEFINED)), \ - v, pos, FUNC_NAME); \ - } while (0) - - -/** Arrays */ - -SCM_API int scm_is_array (SCM obj); -SCM_API SCM scm_array_p (SCM v, SCM unused); -SCM_INTERNAL SCM scm_array_p_2 (SCM); - -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_length (SCM ra); -SCM_API SCM scm_array_length (SCM ra); - -SCM_API SCM scm_array_dimensions (SCM ra); -SCM_API SCM scm_array_type (SCM ra); -SCM_API SCM scm_array_type_code (SCM ra); -SCM_API SCM scm_array_in_bounds_p (SCM v, SCM args); - -SCM_API SCM scm_c_array_ref_1 (SCM v, ssize_t idx0); -SCM_API SCM scm_c_array_ref_2 (SCM v, ssize_t idx0, ssize_t idx1); - -SCM_API void scm_c_array_set_1_x (SCM v, SCM obj, ssize_t idx0); -SCM_API void scm_c_array_set_2_x (SCM v, SCM obj, ssize_t idx0, ssize_t idx1); - -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 */ diff --git a/libguile/init.c b/libguile/init.c index beffc2c7a..4f4c65bf3 100644 --- a/libguile/init.c +++ b/libguile/init.c @@ -77,7 +77,6 @@ #include "fports.h" #include "frames.h" #include "gc.h" -#include "generalized-arrays.h" #include "generalized-vectors.h" #include "gettext.h" #include "goops.h" @@ -446,7 +445,6 @@ scm_i_init_guile (void *base) scm_init_srcprop (); /* requires smob_prehistory */ scm_init_stackchk (); - scm_init_generalized_arrays (); scm_init_generalized_vectors (); scm_init_vectors (); /* Requires array-handle, */ scm_init_uniform (); diff --git a/libguile/random.c b/libguile/random.c index 63da7f5d6..c6755e677 100644 --- a/libguile/random.c +++ b/libguile/random.c @@ -39,7 +39,6 @@ #include "arrays.h" #include "feature.h" -#include "generalized-arrays.h" #include "generalized-vectors.h" #include "gsubr.h" #include "list.h" diff --git a/libguile/sort.c b/libguile/sort.c index 05ecee577..38f64c37c 100644 --- a/libguile/sort.c +++ b/libguile/sort.c @@ -46,7 +46,6 @@ #include "dynwind.h" #include "eval.h" #include "feature.h" -#include "generalized-arrays.h" #include "gsubr.h" #include "list.h" #include "pairs.h"