summaryrefslogtreecommitdiff
path: root/libguile/generalized-arrays.c
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2009-07-17 18:54:06 +0200
committerAndy Wingo <wingo@pobox.com>2009-07-19 15:15:44 +0200
commit1030b45049f564f4abd459abd8e59db34c7867cc (patch)
tree25859c15badfd66f0e2757bc324c8352634a567c /libguile/generalized-arrays.c
parent66b9d7d304a349d5bb4f763a47143f09da58d97f (diff)
downloadguile-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.c276
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:
+*/