summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--libguile/Makefile.am4
-rw-r--r--libguile/array-handle.c286
-rw-r--r--libguile/array-handle.h72
-rw-r--r--libguile/init.c1
-rw-r--r--libguile/unif.c238
-rw-r--r--libguile/unif.h34
6 files changed, 364 insertions, 271 deletions
diff --git a/libguile/Makefile.am b/libguile/Makefile.am
index 6166e72de..46092bc28 100644
--- a/libguile/Makefile.am
+++ b/libguile/Makefile.am
@@ -108,6 +108,7 @@ libguile_la_CFLAGS = $(GUILE_CFLAGS) $(AM_CFLAGS)
libguile_la_SOURCES = \
alist.c \
arbiters.c \
+ array-handle.c \
array-map.c \
async.c \
backtrace.c \
@@ -216,6 +217,7 @@ libguile_i18n_v_@LIBGUILE_I18N_MAJOR@_la_LDFLAGS = \
DOT_X_FILES = \
alist.x \
arbiters.x \
+ array-handle.x \
array-map.x \
async.x \
backtrace.x \
@@ -312,6 +314,7 @@ EXTRA_DOT_X_FILES = @EXTRA_DOT_X_FILES@
DOT_DOC_FILES = \
alist.doc \
arbiters.doc \
+ array-handle.doc \
array-map.doc \
async.doc \
backtrace.doc \
@@ -452,6 +455,7 @@ modinclude_HEADERS = \
__scm.h \
alist.h \
arbiters.h \
+ array-handle.h \
array-map.h \
async.h \
backtrace.h \
diff --git a/libguile/array-handle.c b/libguile/array-handle.c
new file mode 100644
index 000000000..e48938ea3
--- /dev/null
+++ b/libguile/array-handle.c
@@ -0,0 +1,286 @@
+/* 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 "libguile/_scm.h"
+#include "libguile/__scm.h"
+
+#include "libguile/array-handle.h"
+#include "libguile/unif.h"
+#include "libguile/strings.h"
+#include "libguile/vectors.h"
+#include "libguile/srfi-4.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);
+}
+
+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);
+}
+
+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)
+{
+ 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;
+ else
+ ((scm_t_uint32 *)h->writable_elements)[pos/32] &= ~mask;
+}
+
+static void
+bytevector_set (scm_t_array_handle *h, ssize_t pos, SCM val)
+{
+ 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);
+}
+
+void
+scm_array_get_handle (SCM array, scm_t_array_handle *h)
+{
+ 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->dim0.lbnd = 0;
+ h->dim0.ubnd = scm_c_generalized_vector_length (array) - 1;
+ h->dim0.inc = 1;
+ h->dims = &h->dim0;
+ h->base = 0;
+ }
+ else
+ scm_wrong_type_arg_msg (NULL, 0, array, "array");
+}
+
+void
+scm_array_handle_release (scm_t_array_handle *h)
+{
+ /* Nothing to do here until arrays need to be reserved for real.
+ */
+}
+
+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");
+}
+
+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");
+}
+
+
+void
+scm_init_array_handle (void)
+{
+#include "libguile/array-handle.x"
+}
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
diff --git a/libguile/array-handle.h b/libguile/array-handle.h
new file mode 100644
index 000000000..21e1f8436
--- /dev/null
+++ b/libguile/array-handle.h
@@ -0,0 +1,72 @@
+/* classes: h_files */
+
+#ifndef SCM_ARRAY_HANDLE_H
+#define SCM_ARRAY_HANDLE_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"
+
+
+
+typedef struct scm_t_array_dim
+{
+ ssize_t lbnd;
+ ssize_t ubnd;
+ ssize_t inc;
+} scm_t_array_dim;
+
+struct scm_t_array_handle;
+
+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;
+ size_t base;
+ scm_t_array_dim *dims;
+ scm_t_array_dim dim0;
+ scm_i_t_array_ref ref;
+ scm_i_t_array_set set;
+ const void *elements;
+ void *writable_elements;
+} scm_t_array_handle;
+
+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 void scm_array_handle_release (scm_t_array_handle *h);
+
+/* See inline.h for scm_array_handle_ref and scm_array_handle_set */
+
+SCM_INTERNAL void scm_init_array_handle (void);
+
+
+#endif /* SCM_ARRAY_HANDLE_H */
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
diff --git a/libguile/init.c b/libguile/init.c
index 905be2bc8..0beb9d411 100644
--- a/libguile/init.c
+++ b/libguile/init.c
@@ -540,6 +540,7 @@ scm_i_init_guile (SCM_STACKITEM *base)
scm_init_evalext ();
scm_init_debug (); /* Requires macro smobs */
scm_init_random ();
+ scm_init_array_handle ();
scm_init_array_map ();
scm_init_unif ();
scm_init_simpos ();
diff --git a/libguile/unif.c b/libguile/unif.c
index 6dc3dba8e..de8aba381 100644
--- a/libguile/unif.c
+++ b/libguile/unif.c
@@ -176,244 +176,6 @@ scm_is_typed_array (SCM obj, SCM type)
return scm_is_eq (type, scm_i_generalized_vector_type (obj));
}
-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);
-}
-
-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);
-}
-
-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)
-{
- 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;
- else
- ((scm_t_uint32 *)h->writable_elements)[pos/32] &= ~mask;
-}
-
-static void
-bytevector_set (scm_t_array_handle *h, ssize_t pos, SCM val)
-{
- 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);
-}
-
-void
-scm_array_get_handle (SCM array, scm_t_array_handle *h)
-{
- 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->dim0.lbnd = 0;
- h->dim0.ubnd = scm_c_generalized_vector_length (array) - 1;
- h->dim0.inc = 1;
- h->dims = &h->dim0;
- h->base = 0;
- }
- else
- scm_wrong_type_arg_msg (NULL, 0, array, "array");
-}
-
-void
-scm_array_handle_release (scm_t_array_handle *h)
-{
- /* Nothing to do here until arrays need to be reserved for real.
- */
-}
-
-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");
-}
-
-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");
-}
-
/* 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.
diff --git a/libguile/unif.h b/libguile/unif.h
index 701802767..e7c2e6ff4 100644
--- a/libguile/unif.h
+++ b/libguile/unif.h
@@ -25,6 +25,7 @@
#include "libguile/__scm.h"
#include "libguile/print.h"
+#include "libguile/array-handle.h"
@@ -35,13 +36,6 @@
/** Arrays */
-typedef struct scm_t_array_dim
-{
- ssize_t lbnd;
- ssize_t ubnd;
- ssize_t inc;
-} scm_t_array_dim;
-
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);
@@ -76,32 +70,6 @@ SCM_API int scm_is_typed_array (SCM obj, SCM type);
SCM_API SCM scm_ra2contig (SCM ra, int copy);
-struct scm_t_array_handle;
-
-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;
- size_t base;
- scm_t_array_dim *dims;
- scm_t_array_dim dim0;
- scm_i_t_array_ref ref;
- scm_i_t_array_set set;
- const void *elements;
- void *writable_elements;
-} scm_t_array_handle;
-
-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 void scm_array_handle_release (scm_t_array_handle *h);
-
-/* See inline.h for scm_array_handle_ref and scm_array_handle_set */
-
/** Bit vectors */