summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--srfi/ChangeLog6
-rw-r--r--srfi/Makefile.am8
-rw-r--r--srfi/srfi-4.c2150
-rw-r--r--srfi/srfi-4.h141
-rw-r--r--srfi/srfi-4.scm200
5 files changed, 2503 insertions, 2 deletions
diff --git a/srfi/ChangeLog b/srfi/ChangeLog
index 05c1c1998..0984f87bb 100644
--- a/srfi/ChangeLog
+++ b/srfi/ChangeLog
@@ -1,3 +1,9 @@
+2001-06-27 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+
+ * Makefile.am: Added SRFI-4 files in various places.
+
+ * srfi-4.c, srfi-4.h, srfi-4.scm: New files implementing SRFI-4.
+
2001-06-26 Dirk Herrmann <D.Herrmann@tu-bs.de>
* srfi-13.c (scm_string_copyS, scm_string_take, scm_string_drop,
diff --git a/srfi/Makefile.am b/srfi/Makefile.am
index 188688cd5..8340ab1b2 100644
--- a/srfi/Makefile.am
+++ b/srfi/Makefile.am
@@ -29,16 +29,20 @@ DEFS = @DEFS@
INCLUDES = -I.. -I$(srcdir)/..
-lib_LTLIBRARIES = libguile-srfi-srfi-13-14.la
+lib_LTLIBRARIES = libguile-srfi-srfi-13-14.la libguile-srfi-srfi-4.la
-BUILT_SOURCES = srfi-13.x srfi-14.x
+BUILT_SOURCES = srfi-13.x srfi-14.x srfi-4.x
libguile_srfi_srfi_13_14_la_SOURCES = srfi-13.x srfi-13.c srfi-14.x srfi-14.c\
srfi-13.h srfi-14.h
libguile_srfi_srfi_13_14_la_LDFLAGS = -version-info 0:0 -export-dynamic
+libguile_srfi_srfi_4_la_SOURCES = srfi-4.x srfi-4.c srfi-4.h
+libguile_srfi_srfi_4_la_LDFLAGS = -version-info 0:0 -export-dynamic
+
srfidir = $(datadir)/guile/$(VERSION)/srfi
srfi_DATA = srfi-1.scm \
srfi-2.scm \
+ srfi-4.scm \
srfi-6.scm \
srfi-8.scm \
srfi-9.scm \
diff --git a/srfi/srfi-4.c b/srfi/srfi-4.c
new file mode 100644
index 000000000..da3025e1d
--- /dev/null
+++ b/srfi/srfi-4.c
@@ -0,0 +1,2150 @@
+/* srfi-4.c --- Homogeneous numeric vector datatypes.
+ *
+ * Copyright (C) 2001 Free Software Foundation, Inc.
+ *
+ * This program is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License as
+ * published by the Free Software Foundation; either version 2, or (at
+ * your option) any later version.
+ *
+ * This program 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
+ * General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this software; see the file COPYING. If not, write to
+ * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
+ * Boston, MA 02111-1307 USA
+ *
+ * As a special exception, the Free Software Foundation gives
+ * permission for additional uses of the text contained in its release
+ * of GUILE.
+ *
+ * The exception is that, if you link the GUILE library with other
+ * files to produce an executable, this does not by itself cause the
+ * resulting executable to be covered by the GNU General Public
+ * License. Your use of that executable is in no way restricted on
+ * account of linking the GUILE library code into it.
+ *
+ * This exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public
+ * License.
+ *
+ * This exception applies only to the code released by the Free
+ * Software Foundation under the name GUILE. If you copy code from
+ * other Free Software Foundation releases into a copy of GUILE, as
+ * the General Public License permits, the exception does not apply to
+ * the code that you add in this way. To avoid misleading anyone as
+ * to the status of such modified files, you must delete this
+ * exception notice from them.
+ *
+ * If you write modifications of your own for GUILE, it is your choice
+ * whether to permit this exception to apply to your modifications.
+ * If you do not wish that, delete this exception notice. */
+
+#include <libguile.h>
+
+#include "srfi-4.h"
+
+
+/* For brevity and maintainability, we define our own types for the
+ various integer and floating point types. */
+typedef unsigned char int_u8;
+typedef signed char int_s8;
+typedef unsigned short int_u16;
+typedef signed short int_s16;
+typedef unsigned int int_u32;
+typedef signed int int_s32;
+#if HAVE_LONG_LONGS
+#if SIZEOF_LONG == 8
+typedef unsigned long int_u64;
+typedef signed long int_s64;
+#else
+typedef unsigned long long int_u64;
+typedef signed long long int_s64;
+#endif /* SIZEOF_LONG */
+#endif /* HAVE_LONG_LONGS */
+typedef float float_f32;
+typedef double float_f64;
+
+/* Smob type code for homogeneous numeric vectors. */
+int scm_tc16_uvec = 0;
+
+
+/* Accessor macros for the three components of a homogeneous numeric
+ vector:
+ - The type tag (one of the symbolic constants below).
+ - The vector's length (counted in elements).
+ - The address of the data area (holding the elements of the
+ vector). */
+#define SCM_UVEC_TYPE(u) (SCM_CELL_WORD_1(u))
+#define SCM_UVEC_LENGTH(u) (SCM_CELL_WORD_2(u))
+#define SCM_UVEC_BASE(u) (SCM_CELL_OBJECT_3(u))
+
+
+/* Symbolic constants encoding the various types of homogeneous
+ numeric vectors. */
+#define SCM_UVEC_U8 0
+#define SCM_UVEC_S8 1
+#define SCM_UVEC_U16 2
+#define SCM_UVEC_S16 3
+#define SCM_UVEC_U32 4
+#define SCM_UVEC_S32 5
+#define SCM_UVEC_U64 6
+#define SCM_UVEC_S64 7
+#define SCM_UVEC_F32 8
+#define SCM_UVEC_F64 9
+
+
+/* This array maps type tags to the size of the elements. */
+static int uvec_sizes[10] = {1, 1, 2, 2, 4, 4, 8, 8, 4, 8};
+
+
+/* ================================================================ */
+/* SMOB procedures. */
+/* ================================================================ */
+
+
+/* Smob print hook for homogeneous vectors. */
+static int
+uvec_print (SCM uvec, SCM port, scm_print_state *pstate SCM_UNUSED)
+{
+ switch (SCM_UVEC_TYPE (uvec))
+ {
+ case SCM_UVEC_U8:
+ {
+ int_u8 * p = (int_u8 *) SCM_UVEC_BASE (uvec);
+ int i = 0;
+
+ scm_puts ("#u8(", port);
+ if (SCM_UVEC_LENGTH (uvec) > 0)
+ {
+ scm_intprint (*p, 10, port);
+ p++;
+ i++;
+ for (; i < SCM_UVEC_LENGTH (uvec); i++)
+ {
+ scm_puts (" ", port);
+ scm_intprint (*p, 10, port);
+ p++;
+ }
+ }
+ scm_puts (")", port);
+ break;
+ }
+
+ case SCM_UVEC_S8:
+ {
+ int_s8 * p = (int_s8 *) SCM_UVEC_BASE (uvec);
+ int i = 0;
+
+ scm_puts ("#s8(", port);
+ if (SCM_UVEC_LENGTH (uvec) > 0)
+ {
+ scm_intprint (*p, 10, port);
+ p++;
+ i++;
+ for (; i < SCM_UVEC_LENGTH (uvec); i++)
+ {
+ scm_puts (" ", port);
+ scm_intprint (*p, 10, port);
+ p++;
+ }
+ }
+ scm_puts (")", port);
+ break;
+ }
+
+ case SCM_UVEC_U16:
+ {
+ int_u16 * p = (int_u16 *) SCM_UVEC_BASE (uvec);
+ int i = 0;
+
+ scm_puts ("#u16(", port);
+ if (SCM_UVEC_LENGTH (uvec) > 0)
+ {
+ scm_intprint (*p, 10, port);
+ p++;
+ i++;
+ for (; i < SCM_UVEC_LENGTH (uvec); i++)
+ {
+ scm_puts (" ", port);
+ scm_intprint (*p, 10, port);
+ p++;
+ }
+ }
+ scm_puts (")", port);
+ break;
+ }
+
+ case SCM_UVEC_S16:
+ {
+ int_s16 * p = (int_s16 *) SCM_UVEC_BASE (uvec);
+ int i = 0;
+
+ scm_puts ("#s16(", port);
+ if (SCM_UVEC_LENGTH (uvec) > 0)
+ {
+ scm_intprint (*p, 10, port);
+ p++;
+ i++;
+ for (; i < SCM_UVEC_LENGTH (uvec); i++)
+ {
+ scm_puts (" ", port);
+ scm_intprint (*p, 10, port);
+ p++;
+ }
+ }
+ scm_puts (")", port);
+ break;
+ }
+
+ case SCM_UVEC_U32:
+ {
+ int_u32 * p = (int_u32 *) SCM_UVEC_BASE (uvec);
+ int i = 0;
+
+ scm_puts ("#u32(", port);
+ if (SCM_UVEC_LENGTH (uvec) > 0)
+ {
+ scm_intprint (*p, 10, port);
+ p++;
+ i++;
+ for (; i < SCM_UVEC_LENGTH (uvec); i++)
+ {
+ scm_puts (" ", port);
+ scm_intprint (*p, 10, port);
+ p++;
+ }
+ }
+ scm_puts (")", port);
+ break;
+ }
+
+ case SCM_UVEC_S32:
+ {
+ int_s32 * p = (int_s32 *) SCM_UVEC_BASE (uvec);
+ int i = 0;
+
+ scm_puts ("#s32(", port);
+ if (SCM_UVEC_LENGTH (uvec) > 0)
+ {
+ scm_intprint (*p, 10, port);
+ p++;
+ i++;
+ for (; i < SCM_UVEC_LENGTH (uvec); i++)
+ {
+ scm_puts (" ", port);
+ scm_intprint (*p, 10, port);
+ p++;
+ }
+ }
+ scm_puts (")", port);
+ break;
+ }
+
+#if HAVE_LONG_LONGS
+ case SCM_UVEC_U64:
+ {
+ int_u64 * p = (int_u64 *) SCM_UVEC_BASE (uvec);
+ int i = 0;
+
+ scm_puts ("#u64(", port);
+ if (SCM_UVEC_LENGTH (uvec) > 0)
+ {
+ scm_intprint (*p, 10, port);
+ p++;
+ i++;
+ for (; i < SCM_UVEC_LENGTH (uvec); i++)
+ {
+ scm_puts (" ", port);
+ scm_intprint (*p, 10, port);
+ p++;
+ }
+ }
+ scm_puts (")", port);
+ break;
+ }
+
+ case SCM_UVEC_S64:
+ {
+ int_s64 * p = (int_s64 *) SCM_UVEC_BASE (uvec);
+ int i = 0;
+
+ scm_puts ("#s64(", port);
+ if (SCM_UVEC_LENGTH (uvec) > 0)
+ {
+ scm_intprint (*p, 10, port);
+ p++;
+ i++;
+ for (; i < SCM_UVEC_LENGTH (uvec); i++)
+ {
+ scm_puts (" ", port);
+ scm_intprint (*p, 10, port);
+ p++;
+ }
+ }
+ scm_puts (")", port);
+ break;
+ }
+#endif
+
+ case SCM_UVEC_F32:
+ {
+ float_f32 * p = (float_f32 *) SCM_UVEC_BASE (uvec);
+ int i = 0;
+
+ scm_puts ("#f32(", port);
+ if (SCM_UVEC_LENGTH (uvec) > 0)
+ {
+ scm_iprin1 (scm_make_real (*p), port, pstate);
+ p++;
+ i++;
+ for (; i < SCM_UVEC_LENGTH (uvec); i++)
+ {
+ scm_puts (" ", port);
+ scm_iprin1 (scm_make_real (*p), port, pstate);
+ p++;
+ }
+ }
+ scm_puts (")", port);
+ break;
+ }
+
+ case SCM_UVEC_F64:
+ {
+ float_f64 * p = (float_f64 *) SCM_UVEC_BASE (uvec);
+ int i = 0;
+
+ scm_puts ("#f64(", port);
+ if (SCM_UVEC_LENGTH (uvec) > 0)
+ {
+ scm_iprin1 (scm_make_real (*p), port, pstate);
+ p++;
+ i++;
+ for (; i < SCM_UVEC_LENGTH (uvec); i++)
+ {
+ scm_puts (" ", port);
+ scm_iprin1 (scm_make_real (*p), port, pstate);
+ p++;
+ }
+ }
+ scm_puts (")", port);
+ break;
+ }
+
+ default:
+ abort (); /* Sanity check. */
+ }
+ return 1;
+}
+
+
+/* Smob free hook for homogeneous numeric vectors. */
+static size_t
+uvec_free (SCM uvec)
+{
+ scm_must_free (SCM_UVEC_BASE (uvec));
+ return SCM_UVEC_LENGTH (uvec) * uvec_sizes[SCM_UVEC_TYPE (uvec)];
+}
+
+
+/* ================================================================ */
+/* Utility procedures. */
+/* ================================================================ */
+
+
+/* Create a new, uninitialized homogeneous numeric vector of type TYPE
+ with space for LEN elements. */
+static SCM
+make_uvec (const char * func_name, int type, int len)
+{
+ void * p;
+
+ p = scm_must_malloc (len * uvec_sizes[type], func_name);
+ SCM_RETURN_NEWSMOB3 (scm_tc16_uvec, type, len, p);
+}
+
+
+/* ================================================================ */
+/* U8 procedures. */
+/* ================================================================ */
+
+
+SCM_DEFINE (scm_u8vector_p, "u8vector?", 1, 0, 0,
+ (SCM obj),
+ "Return @code{#t} if @var{obj} is a vector of type u8,\n"
+ "@code{#f} otherwise.")
+#define FUNC_NAME s_scm_u8vector_p
+{
+ return SCM_BOOL (SCM_SMOB_PREDICATE (scm_tc16_uvec, obj) &&
+ SCM_UVEC_TYPE (obj) == SCM_UVEC_U8);
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_make_u8vector, "make-u8vector", 1, 1, 0,
+ (SCM n, SCM fill),
+ "Create a newly allocated homogeneous numeric vector which can\n"
+ "hold @var{len} elements. If @var{fill} is given, it is used to\n"
+ "initialize the elements, otherwise the contents of the vector\n"
+ "is unspecified.")
+#define FUNC_NAME s_scm_make_u8vector
+{
+ SCM uvec;
+ int_u8 * p;
+ int_u8 f;
+ int count;
+
+ SCM_VALIDATE_INUM (1, n);
+ count = SCM_INUM (n);
+ uvec = make_uvec (FUNC_NAME, SCM_UVEC_U8, count);
+ if (SCM_UNBNDP (fill))
+ f = 0;
+ else
+ {
+ unsigned int s = scm_num2uint (fill, 2, FUNC_NAME);
+ f = s;
+ if ((unsigned int) f != s)
+ scm_out_of_range_pos (FUNC_NAME, fill, SCM_MAKINUM (2));
+ }
+ p = (int_u8 *) SCM_UVEC_BASE (uvec);
+ while (count-- > 0)
+ *p++ = f;
+ return uvec;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_u8vector, "u8vector", 0, 0, 1,
+ (SCM l),
+ "Create a newly allocated homogeneous numeric vector containing\n"
+ "all argument values.")
+#define FUNC_NAME s_scm_u8vector
+{
+ SCM_VALIDATE_REST_ARGUMENT (l);
+ return scm_list_to_u8vector (l);
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_u8vector_length, "u8vector-length", 1, 0, 0,
+ (SCM uvec),
+ "Return the number of elements in the homogeneous numeric vector\n"
+ "@var{uvec}.")
+#define FUNC_NAME s_scm_u8vector_length
+{
+ SCM_VALIDATE_SMOB (1, uvec, uvec);
+ if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_U8)
+ scm_wrong_type_arg (FUNC_NAME, 1, uvec);
+ return scm_int2num (SCM_UVEC_LENGTH (uvec));
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_u8vector_ref, "u8vector-ref", 2, 0, 0,
+ (SCM uvec, SCM index),
+ "Return the element at @var{index} in the homogeneous numeric\n"
+ "vector @var{uvec}.")
+#define FUNC_NAME s_scm_u8vector_ref
+{
+ int idx;
+
+ SCM_VALIDATE_SMOB (1, uvec, uvec);
+ if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_U8)
+ scm_wrong_type_arg (FUNC_NAME, 1, uvec);
+
+ idx = scm_num2int (index, 2, FUNC_NAME);
+ if (idx < 0 || idx >= SCM_UVEC_LENGTH (uvec))
+ scm_out_of_range_pos (FUNC_NAME, index, SCM_MAKINUM (2));
+
+ return scm_short2num (((int_u8 *) SCM_UVEC_BASE (uvec))[idx]);
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_u8vector_set_x, "u8vector-set!", 3, 0, 0,
+ (SCM uvec, SCM index, SCM value),
+ "Set the element at @var{index} in the homogeneous numeric\n"
+ "vector @var{uvec} to @var{value}. The return value is not\n"
+ "specified.")
+#define FUNC_NAME s_scm_u8vector_ref
+{
+ int idx;
+ int_u8 f;
+ unsigned int s;
+
+ SCM_VALIDATE_SMOB (1, uvec, uvec);
+ if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_U8)
+ scm_wrong_type_arg (FUNC_NAME, 1, uvec);
+
+ idx = scm_num2int (index, 2, FUNC_NAME);
+ if (idx < 0 || idx >= SCM_UVEC_LENGTH (uvec))
+ scm_out_of_range_pos (FUNC_NAME, index, SCM_MAKINUM (2));
+
+ s = scm_num2uint (value, 3, FUNC_NAME);
+ f = s;
+ if ((unsigned int) f != s)
+ scm_out_of_range_pos (FUNC_NAME, value, SCM_MAKINUM (3));
+
+ ((int_u8 *) SCM_UVEC_BASE (uvec))[idx] = f;
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_u8vector_to_list, "u8vector->list", 1, 0, 0,
+ (SCM uvec),
+ "Convert the homogeneous numeric vector @var{uvec} to a list.")
+#define FUNC_NAME s_scm_u8vector_to_list
+{
+ int idx;
+ int_u8 * p;
+ SCM res = SCM_EOL;
+
+ SCM_VALIDATE_SMOB (1, uvec, uvec);
+ if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_U8)
+ scm_wrong_type_arg (FUNC_NAME, 1, uvec);
+
+ idx = SCM_UVEC_LENGTH (uvec);
+ p = (int_u8 *) SCM_UVEC_BASE (uvec) + idx;
+ while (idx-- > 0)
+ {
+ p--;
+ res = scm_cons (SCM_MAKINUM (*p), res);
+ }
+ return res;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_list_to_u8vector, "list->u8vector", 1, 0, 0,
+ (SCM l),
+ "Convert the list @var{l}, which must only contain unsigned\n"
+ "8-bit values, to a numeric homogeneous vector.")
+#define FUNC_NAME s_scm_list_to_u8vector
+{
+ SCM uvec;
+ SCM tmp;
+ int_u8 * p;
+ int n;
+ int arg_pos = 1;
+
+ SCM_VALIDATE_LIST_COPYLEN (1, l, n);
+
+ uvec = make_uvec (FUNC_NAME, SCM_UVEC_U8, n);
+ p = (int_u8 *) SCM_UVEC_BASE (uvec);
+ tmp = l;
+ while (SCM_CONSP (tmp))
+ {
+ int_u8 f;
+ unsigned int s = scm_num2uint (SCM_CAR (tmp), 2, FUNC_NAME);
+ f = s;
+ if ((unsigned int) f != s)
+ scm_out_of_range (FUNC_NAME, SCM_CAR (tmp));
+ *p++ = f;
+ tmp = SCM_CDR (tmp);
+ arg_pos++;
+ }
+ scm_remember_upto_here_1 (l);
+ return uvec;
+}
+#undef FUNC_NAME
+
+
+/* ================================================================ */
+/* S8 procedures. */
+/* ================================================================ */
+
+
+SCM_DEFINE (scm_s8vector_p, "s8vector?", 1, 0, 0,
+ (SCM obj),
+ "Return @code{#t} if @var{obj} is a vector of type s8,\n"
+ "@code{#f} otherwise.")
+#define FUNC_NAME s_scm_s8vector_p
+{
+ return SCM_BOOL (SCM_SMOB_PREDICATE (scm_tc16_uvec, obj) &&
+ SCM_UVEC_TYPE (obj) == SCM_UVEC_S8);
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_make_s8vector, "make-s8vector", 1, 1, 0,
+ (SCM n, SCM fill),
+ "Create a newly allocated homogeneous numeric vector which can\n"
+ "hold @var{len} elements. If @var{fill} is given, it is used to\n"
+ "initialize the elements, otherwise the contents of the vector\n"
+ "is unspecified.")
+#define FUNC_NAME s_scm_make_s8vector
+{
+ SCM uvec;
+ int_s8 * p;
+ int_s8 f;
+ int count;
+
+ SCM_VALIDATE_INUM (1, n);
+ count = SCM_INUM (n);
+ uvec = make_uvec (FUNC_NAME, SCM_UVEC_S8, count);
+ if (SCM_UNBNDP (fill))
+ f = 0;
+ else
+ {
+ signed int s = scm_num2int (fill, 2, FUNC_NAME);
+ f = s;
+ if ((signed int) f != s)
+ scm_out_of_range_pos (FUNC_NAME, fill, SCM_MAKINUM (2));
+ }
+ p = (int_s8 *) SCM_UVEC_BASE (uvec);
+ while (count-- > 0)
+ *p++ = f;
+ return uvec;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_s8vector, "s8vector", 0, 0, 1,
+ (SCM l),
+ "Create a newly allocated homogeneous numeric vector containing\n"
+ "all argument values.")
+#define FUNC_NAME s_scm_s8vector
+{
+ SCM_VALIDATE_REST_ARGUMENT (l);
+ return scm_list_to_s8vector (l);
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_s8vector_length, "s8vector-length", 1, 0, 0,
+ (SCM uvec),
+ "Return the number of elements in the homogeneous numeric vector\n"
+ "@var{uvec}.")
+#define FUNC_NAME s_scm_s8vector_length
+{
+ SCM_VALIDATE_SMOB (1, uvec, uvec);
+ if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_S8)
+ scm_wrong_type_arg (FUNC_NAME, 1, uvec);
+ return scm_int2num (SCM_UVEC_LENGTH (uvec));
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_s8vector_ref, "s8vector-ref", 2, 0, 0,
+ (SCM uvec, SCM index),
+ "Return the element at @var{index} in the homogeneous numeric\n"
+ "vector @var{uvec}.")
+#define FUNC_NAME s_scm_s8vector_ref
+{
+ int idx;
+
+ SCM_VALIDATE_SMOB (1, uvec, uvec);
+ if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_S8)
+ scm_wrong_type_arg (FUNC_NAME, 1, uvec);
+
+ idx = scm_num2int (index, 2, FUNC_NAME);
+ if (idx < 0 || idx >= SCM_UVEC_LENGTH (uvec))
+ scm_out_of_range_pos (FUNC_NAME, index, SCM_MAKINUM (2));
+
+ return scm_short2num (((int_s8 *) SCM_UVEC_BASE (uvec))[idx]);
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_s8vector_set_x, "s8vector-set!", 3, 0, 0,
+ (SCM uvec, SCM index, SCM value),
+ "Set the element at @var{index} in the homogeneous numeric\n"
+ "vector @var{uvec} to @var{value}. The return value is not\n"
+ "specified.")
+#define FUNC_NAME s_scm_s8vector_ref
+{
+ int idx;
+ int_s8 f;
+ signed int s;
+
+ SCM_VALIDATE_SMOB (1, uvec, uvec);
+ if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_S8)
+ scm_wrong_type_arg (FUNC_NAME, 1, uvec);
+
+ idx = scm_num2int (index, 2, FUNC_NAME);
+ if (idx < 0 || idx >= SCM_UVEC_LENGTH (uvec))
+ scm_out_of_range_pos (FUNC_NAME, index, SCM_MAKINUM (2));
+
+ s = scm_num2int (value, 3, FUNC_NAME);
+ f = s;
+ if ((signed int) f != s)
+ scm_out_of_range_pos (FUNC_NAME, value, SCM_MAKINUM (3));
+
+ ((int_s8 *) SCM_UVEC_BASE (uvec))[idx] = f;
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_s8vector_to_list, "s8vector->list", 1, 0, 0,
+ (SCM uvec),
+ "Convert the homogeneous numeric vector @var{uvec} to a list.")
+#define FUNC_NAME s_scm_s8vector_to_list
+{
+ int idx;
+ int_s8 * p;
+ SCM res = SCM_EOL;
+
+ SCM_VALIDATE_SMOB (1, uvec, uvec);
+ if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_S8)
+ scm_wrong_type_arg (FUNC_NAME, 1, uvec);
+
+ idx = SCM_UVEC_LENGTH (uvec);
+ p = (int_s8 *) SCM_UVEC_BASE (uvec) + idx;
+ while (idx-- > 0)
+ {
+ p--;
+ res = scm_cons (SCM_MAKINUM (*p), res);
+ }
+ return res;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_list_to_s8vector, "list->s8vector", 1, 0, 0,
+ (SCM l),
+ "Convert the list @var{l}, which must only contain signed\n"
+ "8-bit values, to a numeric homogeneous vector.")
+#define FUNC_NAME s_scm_list_to_s8vector
+{
+ SCM uvec;
+ SCM tmp;
+ int_s8 * p;
+ int n;
+ int arg_pos = 1;
+
+ SCM_VALIDATE_LIST_COPYLEN (1, l, n);
+
+ uvec = make_uvec (FUNC_NAME, SCM_UVEC_S8, n);
+ p = (int_s8 *) SCM_UVEC_BASE (uvec);
+ tmp = l;
+ while (SCM_CONSP (tmp))
+ {
+ int_s8 f;
+ signed int s;
+
+ s = scm_num2int (SCM_CAR (tmp), 2, FUNC_NAME);
+ f = s;
+ if ((signed int) f != s)
+ scm_out_of_range (FUNC_NAME, SCM_CAR (tmp));
+ *p++ = f;
+ tmp = SCM_CDR (tmp);
+ arg_pos++;
+ }
+ scm_remember_upto_here_1 (l);
+ return uvec;
+}
+#undef FUNC_NAME
+
+
+/* ================================================================ */
+/* U16 procedures. */
+/* ================================================================ */
+
+
+SCM_DEFINE (scm_u16vector_p, "u16vector?", 1, 0, 0,
+ (SCM obj),
+ "Return @code{#t} if @var{obj} is a vector of type u16,\n"
+ "@code{#f} otherwise.")
+#define FUNC_NAME s_scm_u16vector_p
+{
+ return SCM_BOOL (SCM_SMOB_PREDICATE (scm_tc16_uvec, obj) &&
+ SCM_UVEC_TYPE (obj) == SCM_UVEC_U16);
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_make_u16vector, "make-u16vector", 1, 1, 0,
+ (SCM n, SCM fill),
+ "Create a newly allocated homogeneous numeric vector which can\n"
+ "hold @var{len} elements. If @var{fill} is given, it is used to\n"
+ "initialize the elements, otherwise the contents of the vector\n"
+ "is unspecified.")
+#define FUNC_NAME s_scm_make_u16vector
+{
+ SCM uvec;
+ int_u16 * p;
+ int_u16 f;
+ int count;
+
+ SCM_VALIDATE_INUM (1, n);
+ count = SCM_INUM (n);
+ uvec = make_uvec (FUNC_NAME, SCM_UVEC_U16, count);
+ if (SCM_UNBNDP (fill))
+ f = 0;
+ else
+ f = scm_num2ushort (fill, 2, FUNC_NAME);
+ p = (int_u16 *) SCM_UVEC_BASE (uvec);
+ while (count-- > 0)
+ *p++ = f;
+ return uvec;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_u16vector, "u16vector", 0, 0, 1,
+ (SCM l),
+ "Create a newly allocated homogeneous numeric vector containing\n"
+ "all argument values.")
+#define FUNC_NAME s_scm_u16vector
+{
+ SCM_VALIDATE_REST_ARGUMENT (l);
+ return scm_list_to_u16vector (l);
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_u16vector_length, "u16vector-length", 1, 0, 0,
+ (SCM uvec),
+ "Return the number of elements in the homogeneous numeric vector\n"
+ "@var{uvec}.")
+#define FUNC_NAME s_scm_u16vector_length
+{
+ SCM_VALIDATE_SMOB (1, uvec, uvec);
+ if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_U16)
+ scm_wrong_type_arg (FUNC_NAME, 1, uvec);
+ return scm_int2num (SCM_UVEC_LENGTH (uvec));
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_u16vector_ref, "u16vector-ref", 2, 0, 0,
+ (SCM uvec, SCM index),
+ "Return the element at @var{index} in the homogeneous numeric\n"
+ "vector @var{uvec}.")
+#define FUNC_NAME s_scm_u16vector_ref
+{
+ int idx;
+
+ SCM_VALIDATE_SMOB (1, uvec, uvec);
+ if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_U16)
+ scm_wrong_type_arg (FUNC_NAME, 1, uvec);
+
+ idx = scm_num2int (index, 2, FUNC_NAME);
+ if (idx < 0 || idx >= SCM_UVEC_LENGTH (uvec))
+ scm_out_of_range_pos (FUNC_NAME, index, SCM_MAKINUM (2));
+
+ return scm_ushort2num (((int_u16 *) SCM_UVEC_BASE (uvec))[idx]);
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_u16vector_set_x, "u16vector-set!", 3, 0, 0,
+ (SCM uvec, SCM index, SCM value),
+ "Set the element at @var{index} in the homogeneous numeric\n"
+ "vector @var{uvec} to @var{value}. The return value is not\n"
+ "specified.")
+#define FUNC_NAME s_scm_u16vector_ref
+{
+ int idx;
+ int_u16 f;
+
+ SCM_VALIDATE_SMOB (1, uvec, uvec);
+ if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_U16)
+ scm_wrong_type_arg (FUNC_NAME, 1, uvec);
+
+ idx = scm_num2int (index, 2, FUNC_NAME);
+ if (idx < 0 || idx >= SCM_UVEC_LENGTH (uvec))
+ scm_out_of_range_pos (FUNC_NAME, index, SCM_MAKINUM (2));
+
+ f = scm_num2ushort (value, 3, FUNC_NAME);
+
+ ((int_u16 *) SCM_UVEC_BASE (uvec))[idx] = f;
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_u16vector_to_list, "u16vector->list", 1, 0, 0,
+ (SCM uvec),
+ "Convert the homogeneous numeric vector @var{uvec} to a list.")
+#define FUNC_NAME s_scm_u16vector_to_list
+{
+ int idx;
+ int_u16 * p;
+ SCM res = SCM_EOL;
+
+ SCM_VALIDATE_SMOB (1, uvec, uvec);
+ if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_U16)
+ scm_wrong_type_arg (FUNC_NAME, 1, uvec);
+
+ idx = SCM_UVEC_LENGTH (uvec);
+ p = (int_u16 *) SCM_UVEC_BASE (uvec) + idx;
+ while (idx-- > 0)
+ {
+ p--;
+ res = scm_cons (SCM_MAKINUM (*p), res);
+ }
+ return res;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_list_to_u16vector, "list->u16vector", 1, 0, 0,
+ (SCM l),
+ "Convert the list @var{l}, which must only contain unsigned\n"
+ "16-bit values, to a numeric homogeneous vector.")
+#define FUNC_NAME s_scm_list_to_u16vector
+{
+ SCM uvec;
+ int_u16 * p;
+ int n;
+ int arg_pos = 1;
+
+ SCM_VALIDATE_LIST_COPYLEN (1, l, n);
+
+ uvec = make_uvec (FUNC_NAME, SCM_UVEC_U16, n);
+ p = (int_u16 *) SCM_UVEC_BASE (uvec);
+ while (SCM_CONSP (l))
+ {
+ int_u16 f = scm_num2ushort (SCM_CAR (l), 2, FUNC_NAME);
+ *p++ = f;
+ l = SCM_CDR (l);
+ arg_pos++;
+ }
+ return uvec;
+}
+#undef FUNC_NAME
+
+
+/* ================================================================ */
+/* S16 procedures. */
+/* ================================================================ */
+
+
+SCM_DEFINE (scm_s16vector_p, "s16vector?", 1, 0, 0,
+ (SCM obj),
+ "Return @code{#t} if @var{obj} is a vector of type s16,\n"
+ "@code{#f} otherwise.")
+#define FUNC_NAME s_scm_s16vector_p
+{
+ return SCM_BOOL (SCM_SMOB_PREDICATE (scm_tc16_uvec, obj) &&
+ SCM_UVEC_TYPE (obj) == SCM_UVEC_S16);
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_make_s16vector, "make-s16vector", 1, 1, 0,
+ (SCM n, SCM fill),
+ "Create a newly allocated homogeneous numeric vector which can\n"
+ "hold @var{len} elements. If @var{fill} is given, it is used to\n"
+ "initialize the elements, otherwise the contents of the vector\n"
+ "is unspecified.")
+#define FUNC_NAME s_scm_make_s16vector
+{
+ SCM uvec;
+ int_s16 * p;
+ int_s16 f;
+ int count;
+
+ SCM_VALIDATE_INUM (1, n);
+ count = SCM_INUM (n);
+ uvec = make_uvec (FUNC_NAME, SCM_UVEC_S16, count);
+ if (SCM_UNBNDP (fill))
+ f = 0;
+ else
+ f = scm_num2short (fill, 2, FUNC_NAME);
+ p = (int_s16 *) SCM_UVEC_BASE (uvec);
+ while (count-- > 0)
+ *p++ = f;
+ return uvec;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_s16vector, "s16vector", 0, 0, 1,
+ (SCM l),
+ "Create a newly allocated homogeneous numeric vector containing\n"
+ "all argument values.")
+#define FUNC_NAME s_scm_s16vector
+{
+ SCM_VALIDATE_REST_ARGUMENT (l);
+ return scm_list_to_s16vector (l);
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_s16vector_length, "s16vector-length", 1, 0, 0,
+ (SCM uvec),
+ "Return the number of elements in the homogeneous numeric vector\n"
+ "@var{uvec}.")
+#define FUNC_NAME s_scm_s16vector_length
+{
+ SCM_VALIDATE_SMOB (1, uvec, uvec);
+ if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_S16)
+ scm_wrong_type_arg (FUNC_NAME, 1, uvec);
+ return scm_int2num (SCM_UVEC_LENGTH (uvec));
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_s16vector_ref, "s16vector-ref", 2, 0, 0,
+ (SCM uvec, SCM index),
+ "Return the element at @var{index} in the homogeneous numeric\n"
+ "vector @var{uvec}.")
+#define FUNC_NAME s_scm_s16vector_ref
+{
+ int idx;
+
+ SCM_VALIDATE_SMOB (1, uvec, uvec);
+ if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_S16)
+ scm_wrong_type_arg (FUNC_NAME, 1, uvec);
+
+ idx = scm_num2int (index, 2, FUNC_NAME);
+ if (idx < 0 || idx >= SCM_UVEC_LENGTH (uvec))
+ scm_out_of_range_pos (FUNC_NAME, index, SCM_MAKINUM (2));
+
+ return scm_short2num (((int_s16 *) SCM_UVEC_BASE (uvec))[idx]);
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_s16vector_set_x, "s16vector-set!", 3, 0, 0,
+ (SCM uvec, SCM index, SCM value),
+ "Set the element at @var{index} in the homogeneous numeric\n"
+ "vector @var{uvec} to @var{value}. The return value is not\n"
+ "specified.")
+#define FUNC_NAME s_scm_s16vector_ref
+{
+ int idx;
+ int_s16 f;
+
+ SCM_VALIDATE_SMOB (1, uvec, uvec);
+ if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_S16)
+ scm_wrong_type_arg (FUNC_NAME, 1, uvec);
+
+ idx = scm_num2int (index, 2, FUNC_NAME);
+ if (idx < 0 || idx >= SCM_UVEC_LENGTH (uvec))
+ scm_out_of_range_pos (FUNC_NAME, index, SCM_MAKINUM (2));
+
+ f = scm_num2short (value, 3, FUNC_NAME);
+
+ ((int_s16 *) SCM_UVEC_BASE (uvec))[idx] = f;
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_s16vector_to_list, "s16vector->list", 1, 0, 0,
+ (SCM uvec),
+ "Convert the homogeneous numeric vector @var{uvec} to a list.")
+#define FUNC_NAME s_scm_s16vector_to_list
+{
+ int idx;
+ int_s16 * p;
+ SCM res = SCM_EOL;
+
+ SCM_VALIDATE_SMOB (1, uvec, uvec);
+ if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_S16)
+ scm_wrong_type_arg (FUNC_NAME, 1, uvec);
+
+ idx = SCM_UVEC_LENGTH (uvec);
+ p = (int_s16 *) SCM_UVEC_BASE (uvec) + idx;
+ while (idx-- > 0)
+ {
+ p--;
+ res = scm_cons (SCM_MAKINUM (*p), res);
+ }
+ return res;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_list_to_s16vector, "list->s16vector", 1, 0, 0,
+ (SCM l),
+ "Convert the list @var{l}, which must only contain signed\n"
+ "16-bit values, to a numeric homogeneous vector.")
+#define FUNC_NAME s_scm_list_to_s16vector
+{
+ SCM uvec;
+ SCM tmp;
+ int_s16 * p;
+ int n;
+ int arg_pos = 1;
+
+ SCM_VALIDATE_LIST_COPYLEN (1, l, n);
+
+ uvec = make_uvec (FUNC_NAME, SCM_UVEC_S16, n);
+ p = (int_s16 *) SCM_UVEC_BASE (uvec);
+ tmp = l;
+ while (SCM_CONSP (tmp))
+ {
+ int_s16 f = scm_num2short (SCM_CAR (tmp), 2, FUNC_NAME);
+ *p++ = f;
+ tmp = SCM_CDR (tmp);
+ arg_pos++;
+ }
+ scm_remember_upto_here_1 (l);
+ return uvec;
+}
+#undef FUNC_NAME
+
+
+/* ================================================================ */
+/* U32 procedures. */
+/* ================================================================ */
+
+
+SCM_DEFINE (scm_u32vector_p, "u32vector?", 1, 0, 0,
+ (SCM obj),
+ "Return @code{#t} if @var{obj} is a vector of type u32,\n"
+ "@code{#f} otherwise.")
+#define FUNC_NAME s_scm_u32vector_p
+{
+ return SCM_BOOL (SCM_SMOB_PREDICATE (scm_tc16_uvec, obj) &&
+ SCM_UVEC_TYPE (obj) == SCM_UVEC_U32);
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_make_u32vector, "make-u32vector", 1, 1, 0,
+ (SCM n, SCM fill),
+ "Create a newly allocated homogeneous numeric vector which can\n"
+ "hold @var{len} elements. If @var{fill} is given, it is used to\n"
+ "initialize the elements, otherwise the contents of the vector\n"
+ "is unspecified.")
+#define FUNC_NAME s_scm_make_u32vector
+{
+ SCM uvec;
+ int_u32 * p;
+ int_u32 f;
+ int count;
+
+ SCM_VALIDATE_INUM (1, n);
+ count = SCM_INUM (n);
+ uvec = make_uvec (FUNC_NAME, SCM_UVEC_U32, count);
+ if (SCM_UNBNDP (fill))
+ f = 0;
+ else
+ f = scm_num2uint (fill, 2, FUNC_NAME);
+ p = (int_u32 *) SCM_UVEC_BASE (uvec);
+ while (count-- > 0)
+ *p++ = f;
+ return uvec;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_u32vector, "u32vector", 0, 0, 1,
+ (SCM l),
+ "Create a newly allocated homogeneous numeric vector containing\n"
+ "all argument values.")
+#define FUNC_NAME s_scm_u32vector
+{
+ SCM_VALIDATE_REST_ARGUMENT (l);
+ return scm_list_to_u32vector (l);
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_u32vector_length, "u32vector-length", 1, 0, 0,
+ (SCM uvec),
+ "Return the number of elements in the homogeneous numeric vector\n"
+ "@var{uvec}.")
+#define FUNC_NAME s_scm_u32vector_length
+{
+ SCM_VALIDATE_SMOB (1, uvec, uvec);
+ if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_U32)
+ scm_wrong_type_arg (FUNC_NAME, 1, uvec);
+ return scm_int2num (SCM_UVEC_LENGTH (uvec));
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_u32vector_ref, "u32vector-ref", 2, 0, 0,
+ (SCM uvec, SCM index),
+ "Return the element at @var{index} in the homogeneous numeric\n"
+ "vector @var{uvec}.")
+#define FUNC_NAME s_scm_u32vector_ref
+{
+ int idx;
+
+ SCM_VALIDATE_SMOB (1, uvec, uvec);
+ if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_U32)
+ scm_wrong_type_arg (FUNC_NAME, 1, uvec);
+
+ idx = scm_num2int (index, 2, FUNC_NAME);
+ if (idx < 0 || idx >= SCM_UVEC_LENGTH (uvec))
+ scm_out_of_range_pos (FUNC_NAME, index, SCM_MAKINUM (2));
+
+ return scm_uint2num (((int_u32 *) SCM_UVEC_BASE (uvec))[idx]);
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_u32vector_set_x, "u32vector-set!", 3, 0, 0,
+ (SCM uvec, SCM index, SCM value),
+ "Set the element at @var{index} in the homogeneous numeric\n"
+ "vector @var{uvec} to @var{value}. The return value is not\n"
+ "specified.")
+#define FUNC_NAME s_scm_u32vector_ref
+{
+ int idx;
+ int_u32 f;
+
+ SCM_VALIDATE_SMOB (1, uvec, uvec);
+ if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_U32)
+ scm_wrong_type_arg (FUNC_NAME, 1, uvec);
+
+ idx = scm_num2int (index, 2, FUNC_NAME);
+ if (idx < 0 || idx >= SCM_UVEC_LENGTH (uvec))
+ scm_out_of_range_pos (FUNC_NAME, index, SCM_MAKINUM (2));
+
+ f = scm_num2uint (value, 3, FUNC_NAME);
+
+ ((int_u32 *) SCM_UVEC_BASE (uvec))[idx] = f;
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_u32vector_to_list, "u32vector->list", 1, 0, 0,
+ (SCM uvec),
+ "Convert the homogeneous numeric vector @var{uvec} to a list.")
+#define FUNC_NAME s_scm_u32vector_to_list
+{
+ int idx;
+ int_u32 * p;
+ SCM res = SCM_EOL;
+
+ SCM_VALIDATE_SMOB (1, uvec, uvec);
+ if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_U32)
+ scm_wrong_type_arg (FUNC_NAME, 1, uvec);
+
+ idx = SCM_UVEC_LENGTH (uvec);
+ p = (int_u32 *) SCM_UVEC_BASE (uvec) + idx;
+ while (idx-- > 0)
+ {
+ p--;
+ res = scm_cons (scm_uint2num (*p), res);
+ }
+ return res;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_list_to_u32vector, "list->u32vector", 1, 0, 0,
+ (SCM l),
+ "Convert the list @var{l}, which must only contain unsigned\n"
+ "32-bit values, to a numeric homogeneous vector.")
+#define FUNC_NAME s_scm_list_to_u32vector
+{
+ SCM uvec;
+ int_u32 * p;
+ int n;
+ int arg_pos = 1;
+
+ SCM_VALIDATE_LIST_COPYLEN (1, l, n);
+
+ uvec = make_uvec (FUNC_NAME, SCM_UVEC_U32, n);
+ p = (int_u32 *) SCM_UVEC_BASE (uvec);
+ while (SCM_CONSP (l))
+ {
+ int_u32 f;
+ f = scm_num2uint (SCM_CAR (l), 2, FUNC_NAME);
+ *p++ = f;
+ l = SCM_CDR (l);
+ arg_pos++;
+ }
+ return uvec;
+}
+#undef FUNC_NAME
+
+
+/* ================================================================ */
+/* S32 procedures. */
+/* ================================================================ */
+
+
+SCM_DEFINE (scm_s32vector_p, "s32vector?", 1, 0, 0,
+ (SCM obj),
+ "Return @code{#t} if @var{obj} is a vector of type s32,\n"
+ "@code{#f} otherwise.")
+#define FUNC_NAME s_scm_s32vector_p
+{
+ return SCM_BOOL (SCM_SMOB_PREDICATE (scm_tc16_uvec, obj) &&
+ SCM_UVEC_TYPE (obj) == SCM_UVEC_S32);
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_make_s32vector, "make-s32vector", 1, 1, 0,
+ (SCM n, SCM fill),
+ "Create a newly allocated homogeneous numeric vector which can\n"
+ "hold @var{len} elements. If @var{fill} is given, it is used to\n"
+ "initialize the elements, otherwise the contents of the vector\n"
+ "is unspecified.")
+#define FUNC_NAME s_scm_make_s32vector
+{
+ SCM uvec;
+ int_s32 * p;
+ int_s32 f;
+ int count;
+
+ SCM_VALIDATE_INUM (1, n);
+ count = SCM_INUM (n);
+ uvec = make_uvec (FUNC_NAME, SCM_UVEC_S32, count);
+ if (SCM_UNBNDP (fill))
+ f = 0;
+ else
+ f = scm_num2int (fill, 2, FUNC_NAME);
+ p = (int_s32 *) SCM_UVEC_BASE (uvec);
+ while (count-- > 0)
+ *p++ = f;
+ return uvec;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_s32vector, "s32vector", 0, 0, 1,
+ (SCM l),
+ "Create a newly allocated homogeneous numeric vector containing\n"
+ "all argument values.")
+#define FUNC_NAME s_scm_s32vector
+{
+ SCM_VALIDATE_REST_ARGUMENT (l);
+ return scm_list_to_s32vector (l);
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_s32vector_length, "s32vector-length", 1, 0, 0,
+ (SCM uvec),
+ "Return the number of elements in the homogeneous numeric vector\n"
+ "@var{uvec}.")
+#define FUNC_NAME s_scm_s32vector_length
+{
+ SCM_VALIDATE_SMOB (1, uvec, uvec);
+ if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_S32)
+ scm_wrong_type_arg (FUNC_NAME, 1, uvec);
+ return scm_int2num (SCM_UVEC_LENGTH (uvec));
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_s32vector_ref, "s32vector-ref", 2, 0, 0,
+ (SCM uvec, SCM index),
+ "Return the element at @var{index} in the homogeneous numeric\n"
+ "vector @var{uvec}.")
+#define FUNC_NAME s_scm_s32vector_ref
+{
+ int idx;
+
+ SCM_VALIDATE_SMOB (1, uvec, uvec);
+ if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_S32)
+ scm_wrong_type_arg (FUNC_NAME, 1, uvec);
+
+ idx = scm_num2int (index, 2, FUNC_NAME);
+ if (idx < 0 || idx >= SCM_UVEC_LENGTH (uvec))
+ scm_out_of_range_pos (FUNC_NAME, index, SCM_MAKINUM (2));
+
+ return scm_int2num (((int_s32 *) SCM_UVEC_BASE (uvec))[idx]);
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_s32vector_set_x, "s32vector-set!", 3, 0, 0,
+ (SCM uvec, SCM index, SCM value),
+ "Set the element at @var{index} in the homogeneous numeric\n"
+ "vector @var{uvec} to @var{value}. The return value is not\n"
+ "specified.")
+#define FUNC_NAME s_scm_s32vector_ref
+{
+ int idx;
+ int_s32 f;
+
+ SCM_VALIDATE_SMOB (1, uvec, uvec);
+ if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_S32)
+ scm_wrong_type_arg (FUNC_NAME, 1, uvec);
+
+ idx = scm_num2int (index, 2, FUNC_NAME);
+ if (idx < 0 || idx >= SCM_UVEC_LENGTH (uvec))
+ scm_out_of_range_pos (FUNC_NAME, index, SCM_MAKINUM (2));
+
+ f = scm_num2int (value, 3, FUNC_NAME);
+
+ ((int_s32 *) SCM_UVEC_BASE (uvec))[idx] = f;
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_s32vector_to_list, "s32vector->list", 1, 0, 0,
+ (SCM uvec),
+ "Convert the homogeneous numeric vector @var{uvec} to a list.")
+#define FUNC_NAME s_scm_s32vector_to_list
+{
+ int idx;
+ int_s32 * p;
+ SCM res = SCM_EOL;
+
+ SCM_VALIDATE_SMOB (1, uvec, uvec);
+ if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_S32)
+ scm_wrong_type_arg (FUNC_NAME, 1, uvec);
+
+ idx = SCM_UVEC_LENGTH (uvec);
+ p = (int_s32 *) SCM_UVEC_BASE (uvec) + idx;
+ while (idx-- > 0)
+ {
+ p--;
+ res = scm_cons (scm_int2num (*p), res);
+ }
+ return res;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_list_to_s32vector, "list->s32vector", 1, 0, 0,
+ (SCM l),
+ "Convert the list @var{l}, which must only contain signed\n"
+ "32-bit values, to a numeric homogeneous vector.")
+#define FUNC_NAME s_scm_list_to_s32vector
+{
+ SCM uvec;
+ int_s32 * p;
+ int n;
+ int arg_pos = 1;
+
+ SCM_VALIDATE_LIST_COPYLEN (1, l, n);
+
+ uvec = make_uvec (FUNC_NAME, SCM_UVEC_S32, n);
+ p = (int_s32 *) SCM_UVEC_BASE (uvec);
+ while (SCM_CONSP (l))
+ {
+ int_s32 f;
+ f = scm_num2int (SCM_CAR (l), 2, FUNC_NAME);
+ *p++ = f;
+ l = SCM_CDR (l);
+ arg_pos++;
+ }
+ return uvec;
+}
+#undef FUNC_NAME
+
+
+#if HAVE_LONG_LONGS
+
+/* ================================================================ */
+/* U64 procedures. */
+/* ================================================================ */
+
+
+SCM_DEFINE (scm_u64vector_p, "u64vector?", 1, 0, 0,
+ (SCM obj),
+ "Return @code{#t} if @var{obj} is a vector of type u64,\n"
+ "@code{#f} otherwise.")
+#define FUNC_NAME s_scm_u64vector_p
+{
+ return SCM_BOOL (SCM_SMOB_PREDICATE (scm_tc16_uvec, obj) &&
+ SCM_UVEC_TYPE (obj) == SCM_UVEC_U64);
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_make_u64vector, "make-u64vector", 1, 1, 0,
+ (SCM n, SCM fill),
+ "Create a newly allocated homogeneous numeric vector which can\n"
+ "hold @var{len} elements. If @var{fill} is given, it is used to\n"
+ "initialize the elements, otherwise the contents of the vector\n"
+ "is unspecified.")
+#define FUNC_NAME s_scm_make_u64vector
+{
+ SCM uvec;
+ int_u64 * p;
+ int_u64 f;
+ int count;
+
+ SCM_VALIDATE_INUM (1, n);
+ count = SCM_INUM (n);
+ uvec = make_uvec (FUNC_NAME, SCM_UVEC_U64, count);
+ if (SCM_UNBNDP (fill))
+ f = 0;
+ else
+ f = scm_num2ulong_long (fill, 2, FUNC_NAME);
+ p = (int_u64 *) SCM_UVEC_BASE (uvec);
+ while (count-- > 0)
+ *p++ = f;
+ return uvec;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_u64vector, "u64vector", 0, 0, 1,
+ (SCM l),
+ "Create a newly allocated homogeneous numeric vector containing\n"
+ "all argument values.")
+#define FUNC_NAME s_scm_u64vector
+{
+ SCM_VALIDATE_REST_ARGUMENT (l);
+ return scm_list_to_u64vector (l);
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_u64vector_length, "u64vector-length", 1, 0, 0,
+ (SCM uvec),
+ "Return the number of elements in the homogeneous numeric vector\n"
+ "@var{uvec}.")
+#define FUNC_NAME s_scm_u64vector_length
+{
+ SCM_VALIDATE_SMOB (1, uvec, uvec);
+ if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_U64)
+ scm_wrong_type_arg (FUNC_NAME, 1, uvec);
+ return scm_int2num (SCM_UVEC_LENGTH (uvec));
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_u64vector_ref, "u64vector-ref", 2, 0, 0,
+ (SCM uvec, SCM index),
+ "Return the element at @var{index} in the homogeneous numeric\n"
+ "vector @var{uvec}.")
+#define FUNC_NAME s_scm_u64vector_ref
+{
+ int idx;
+
+ SCM_VALIDATE_SMOB (1, uvec, uvec);
+ if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_U64)
+ scm_wrong_type_arg (FUNC_NAME, 1, uvec);
+
+ idx = scm_num2int (index, 2, FUNC_NAME);
+ if (idx < 0 || idx >= SCM_UVEC_LENGTH (uvec))
+ scm_out_of_range_pos (FUNC_NAME, index, SCM_MAKINUM (2));
+
+ return scm_ulong_long2num (((int_u64 *) SCM_UVEC_BASE (uvec))[idx]);
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_u64vector_set_x, "u64vector-set!", 3, 0, 0,
+ (SCM uvec, SCM index, SCM value),
+ "Set the element at @var{index} in the homogeneous numeric\n"
+ "vector @var{uvec} to @var{value}. The return value is not\n"
+ "specified.")
+#define FUNC_NAME s_scm_u64vector_ref
+{
+ int idx;
+ int_u64 f;
+
+ SCM_VALIDATE_SMOB (1, uvec, uvec);
+ if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_U64)
+ scm_wrong_type_arg (FUNC_NAME, 1, uvec);
+
+ idx = scm_num2int (index, 2, FUNC_NAME);
+ if (idx < 0 || idx >= SCM_UVEC_LENGTH (uvec))
+ scm_out_of_range_pos (FUNC_NAME, index, SCM_MAKINUM (2));
+
+ f = scm_num2ulong_long (value, 3, FUNC_NAME);
+
+ ((int_u64 *) SCM_UVEC_BASE (uvec))[idx] = f;
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_u64vector_to_list, "u64vector->list", 1, 0, 0,
+ (SCM uvec),
+ "Convert the homogeneous numeric vector @var{uvec} to a list.")
+#define FUNC_NAME s_scm_u64vector_to_list
+{
+ int idx;
+ int_u64 * p;
+ SCM res = SCM_EOL;
+
+ SCM_VALIDATE_SMOB (1, uvec, uvec);
+ if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_U64)
+ scm_wrong_type_arg (FUNC_NAME, 1, uvec);
+
+ idx = SCM_UVEC_LENGTH (uvec);
+ p = (int_u64 *) SCM_UVEC_BASE (uvec) + idx;
+ while (idx-- > 0)
+ {
+ p--;
+ res = scm_cons (scm_long_long2num (*p), res);
+ }
+ return res;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_list_to_u64vector, "list->u64vector", 1, 0, 0,
+ (SCM l),
+ "Convert the list @var{l}, which must only contain unsigned\n"
+ "64-bit values, to a numeric homogeneous vector.")
+#define FUNC_NAME s_scm_list_to_u64vector
+{
+ SCM uvec;
+ int_u64 * p;
+ int n;
+ int arg_pos = 1;
+
+ SCM_VALIDATE_LIST_COPYLEN (1, l, n);
+
+ uvec = make_uvec (FUNC_NAME, SCM_UVEC_U64, n);
+ p = (int_u64 *) SCM_UVEC_BASE (uvec);
+ while (SCM_CONSP (l))
+ {
+ int_u64 f;
+ f = scm_num2ulong_long (SCM_CAR (l), 2, FUNC_NAME);
+ *p++ = f;
+ l = SCM_CDR (l);
+ arg_pos++;
+ }
+ return uvec;
+}
+#undef FUNC_NAME
+
+
+/* ================================================================ */
+/* S64 procedures. */
+/* ================================================================ */
+
+
+SCM_DEFINE (scm_s64vector_p, "s64vector?", 1, 0, 0,
+ (SCM obj),
+ "Return @code{#t} if @var{obj} is a vector of type s64,\n"
+ "@code{#f} otherwise.")
+#define FUNC_NAME s_scm_s64vector_p
+{
+ return SCM_BOOL (SCM_SMOB_PREDICATE (scm_tc16_uvec, obj) &&
+ SCM_UVEC_TYPE (obj) == SCM_UVEC_S64);
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_make_s64vector, "make-s64vector", 1, 1, 0,
+ (SCM n, SCM fill),
+ "Create a newly allocated homogeneous numeric vector which can\n"
+ "hold @var{len} elements. If @var{fill} is given, it is used to\n"
+ "initialize the elements, otherwise the contents of the vector\n"
+ "is unspecified.")
+#define FUNC_NAME s_scm_make_s64vector
+{
+ SCM uvec;
+ int_s64 * p;
+ int_s64 f;
+ int count;
+
+ SCM_VALIDATE_INUM (1, n);
+ count = SCM_INUM (n);
+ uvec = make_uvec (FUNC_NAME, SCM_UVEC_S64, count);
+ if (SCM_UNBNDP (fill))
+ f = 0;
+ else
+ f = scm_num2long_long (fill, 2, FUNC_NAME);
+ p = (int_s64 *) SCM_UVEC_BASE (uvec);
+ while (count-- > 0)
+ *p++ = f;
+ return uvec;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_s64vector, "s64vector", 0, 0, 1,
+ (SCM l),
+ "Create a newly allocated homogeneous numeric vector containing\n"
+ "all argument values.")
+#define FUNC_NAME s_scm_s64vector
+{
+ SCM_VALIDATE_REST_ARGUMENT (l);
+ return scm_list_to_s64vector (l);
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_s64vector_length, "s64vector-length", 1, 0, 0,
+ (SCM uvec),
+ "Return the number of elements in the homogeneous numeric vector\n"
+ "@var{uvec}.")
+#define FUNC_NAME s_scm_s64vector_length
+{
+ SCM_VALIDATE_SMOB (1, uvec, uvec);
+ if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_S64)
+ scm_wrong_type_arg (FUNC_NAME, 1, uvec);
+ return scm_int2num (SCM_UVEC_LENGTH (uvec));
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_s64vector_ref, "s64vector-ref", 2, 0, 0,
+ (SCM uvec, SCM index),
+ "Return the element at @var{index} in the homogeneous numeric\n"
+ "vector @var{uvec}.")
+#define FUNC_NAME s_scm_s64vector_ref
+{
+ int idx;
+
+ SCM_VALIDATE_SMOB (1, uvec, uvec);
+ if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_S64)
+ scm_wrong_type_arg (FUNC_NAME, 1, uvec);
+
+ idx = scm_num2int (index, 2, FUNC_NAME);
+ if (idx < 0 || idx >= SCM_UVEC_LENGTH (uvec))
+ scm_out_of_range_pos (FUNC_NAME, index, SCM_MAKINUM (2));
+
+ return scm_long_long2num (((int_s64 *) SCM_UVEC_BASE (uvec))[idx]);
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_s64vector_set_x, "s64vector-set!", 3, 0, 0,
+ (SCM uvec, SCM index, SCM value),
+ "Set the element at @var{index} in the homogeneous numeric\n"
+ "vector @var{uvec} to @var{value}. The return value is not\n"
+ "specified.")
+#define FUNC_NAME s_scm_s64vector_ref
+{
+ int idx;
+ int_s64 f;
+
+ SCM_VALIDATE_SMOB (1, uvec, uvec);
+ if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_S64)
+ scm_wrong_type_arg (FUNC_NAME, 1, uvec);
+
+ idx = scm_num2int (index, 2, FUNC_NAME);
+ if (idx < 0 || idx >= SCM_UVEC_LENGTH (uvec))
+ scm_out_of_range_pos (FUNC_NAME, index, SCM_MAKINUM (2));
+
+ f = scm_num2long_long (value, 3, FUNC_NAME);
+
+ ((int_s64 *) SCM_UVEC_BASE (uvec))[idx] = f;
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_s64vector_to_list, "s64vector->list", 1, 0, 0,
+ (SCM uvec),
+ "Convert the homogeneous numeric vector @var{uvec} to a list.")
+#define FUNC_NAME s_scm_s64vector_to_list
+{
+ int idx;
+ int_s64 * p;
+ SCM res = SCM_EOL;
+
+ SCM_VALIDATE_SMOB (1, uvec, uvec);
+ if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_S64)
+ scm_wrong_type_arg (FUNC_NAME, 1, uvec);
+
+ idx = SCM_UVEC_LENGTH (uvec);
+ p = (int_s64 *) SCM_UVEC_BASE (uvec) + idx;
+ while (idx-- > 0)
+ {
+ p--;
+ res = scm_cons (scm_long_long2num (*p), res);
+ }
+ return res;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_list_to_s64vector, "list->s64vector", 1, 0, 0,
+ (SCM l),
+ "Convert the list @var{l}, which must only contain signed\n"
+ "64-bit values, to a numeric homogeneous vector.")
+#define FUNC_NAME s_scm_list_to_s64vector
+{
+ SCM uvec;
+ int_s64 * p;
+ int n;
+ int arg_pos = 1;
+
+ SCM_VALIDATE_LIST_COPYLEN (1, l, n);
+
+ uvec = make_uvec (FUNC_NAME, SCM_UVEC_S64, n);
+ p = (int_s64 *) SCM_UVEC_BASE (uvec);
+ while (SCM_CONSP (l))
+ {
+ int_s64 f;
+ f = scm_num2long_long (SCM_CAR (l), 2, FUNC_NAME);
+ *p++ = f;
+ l = SCM_CDR (l);
+ arg_pos++;
+ }
+ return uvec;
+}
+#undef FUNC_NAME
+
+#endif /* HAVE_LONG_LONGS */
+
+
+/* ================================================================ */
+/* F32 procedures. */
+/* ================================================================ */
+
+
+SCM_DEFINE (scm_f32vector_p, "f32vector?", 1, 0, 0,
+ (SCM obj),
+ "Return @code{#t} if @var{obj} is a vector of type f32,\n"
+ "@code{#f} otherwise.")
+#define FUNC_NAME s_scm_f32vector_p
+{
+ return SCM_BOOL (SCM_SMOB_PREDICATE (scm_tc16_uvec, obj) &&
+ SCM_UVEC_TYPE (obj) == SCM_UVEC_F32);
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_make_f32vector, "make-f32vector", 1, 1, 0,
+ (SCM n, SCM fill),
+ "Create a newly allocated homogeneous numeric vector which can\n"
+ "hold @var{len} elements. If @var{fill} is given, it is used to\n"
+ "initialize the elements, otherwise the contents of the vector\n"
+ "is unspecified.")
+#define FUNC_NAME s_scm_make_f32vector
+{
+ SCM uvec;
+ float_f32 * p;
+ float_f32 f;
+ int count;
+
+ SCM_VALIDATE_INUM (1, n);
+ count = SCM_INUM (n);
+ uvec = make_uvec (FUNC_NAME, SCM_UVEC_F32, count);
+ if (SCM_UNBNDP (fill))
+ f = 0;
+ else
+ {
+ double d = scm_num2dbl (fill, FUNC_NAME);
+ f = d;
+#if 0
+ /* This test somehow fails for even the simplest inexact
+ numbers, like 3.1. Must find out how to check properly. */
+ if (f != d)
+ scm_out_of_range_pos (FUNC_NAME, fill, SCM_MAKINUM (2));
+#endif /* 0 */
+ }
+ p = (float_f32 *) SCM_UVEC_BASE (uvec);
+ while (count-- > 0)
+ *p++ = f;
+ return uvec;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_f32vector, "f32vector", 0, 0, 1,
+ (SCM l),
+ "Create a newly allocated homogeneous numeric vector containing\n"
+ "all argument values.")
+#define FUNC_NAME s_scm_f32vector
+{
+ SCM_VALIDATE_REST_ARGUMENT (l);
+ return scm_list_to_f32vector (l);
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_f32vector_length, "f32vector-length", 1, 0, 0,
+ (SCM uvec),
+ "Return the number of elements in the homogeneous numeric vector\n"
+ "@var{uvec}.")
+#define FUNC_NAME s_scm_f32vector_length
+{
+ SCM_VALIDATE_SMOB (1, uvec, uvec);
+ if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_F32)
+ scm_wrong_type_arg (FUNC_NAME, 1, uvec);
+ return scm_int2num (SCM_UVEC_LENGTH (uvec));
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_f32vector_ref, "f32vector-ref", 2, 0, 0,
+ (SCM uvec, SCM index),
+ "Return the element at @var{index} in the homogeneous numeric\n"
+ "vector @var{uvec}.")
+#define FUNC_NAME s_scm_f32vector_ref
+{
+ int idx;
+
+ SCM_VALIDATE_SMOB (1, uvec, uvec);
+ if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_F32)
+ scm_wrong_type_arg (FUNC_NAME, 1, uvec);
+
+ idx = scm_num2int (index, 2, FUNC_NAME);
+ if (idx < 0 || idx >= SCM_UVEC_LENGTH (uvec))
+ scm_out_of_range_pos (FUNC_NAME, index, SCM_MAKINUM (2));
+
+ return scm_make_real (((float_f32 *) SCM_UVEC_BASE (uvec))[idx]);
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_f32vector_set_x, "f32vector-set!", 3, 0, 0,
+ (SCM uvec, SCM index, SCM value),
+ "Set the element at @var{index} in the homogeneous numeric\n"
+ "vector @var{uvec} to @var{value}. The return value is not\n"
+ "specified.")
+#define FUNC_NAME s_scm_f32vector_ref
+{
+ int idx;
+ float_f32 f;
+ double d;
+
+ SCM_VALIDATE_SMOB (1, uvec, uvec);
+ if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_F32)
+ scm_wrong_type_arg (FUNC_NAME, 1, uvec);
+
+ idx = scm_num2int (index, 2, FUNC_NAME);
+ if (idx < 0 || idx >= SCM_UVEC_LENGTH (uvec))
+ scm_out_of_range_pos (FUNC_NAME, index, SCM_MAKINUM (2));
+
+ d = scm_num2dbl (value, FUNC_NAME);
+ f = d;
+#if 0
+ /* This test somehow fails for even the simplest inexact
+ numbers, like 3.1. Must find out how to check properly. */
+ if (f != d)
+ scm_out_of_range_pos (FUNC_NAME, value, SCM_MAKINUM (3));
+#endif /* 0 */
+
+ ((float_f32 *) SCM_UVEC_BASE (uvec))[idx] = f;
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_f32vector_to_list, "f32vector->list", 1, 0, 0,
+ (SCM uvec),
+ "Convert the homogeneous numeric vector @var{uvec} to a list.")
+#define FUNC_NAME s_scm_f32vector_to_list
+{
+ int idx;
+ float_f32 * p;
+ SCM res = SCM_EOL;
+
+ SCM_VALIDATE_SMOB (1, uvec, uvec);
+ if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_F32)
+ scm_wrong_type_arg (FUNC_NAME, 1, uvec);
+
+ idx = SCM_UVEC_LENGTH (uvec);
+ p = (float_f32 *) SCM_UVEC_BASE (uvec) + idx;
+ while (idx-- > 0)
+ {
+ p--;
+ res = scm_cons (scm_make_real (*p), res);
+ }
+ return res;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_list_to_f32vector, "list->f32vector", 1, 0, 0,
+ (SCM l),
+ "Convert the list @var{l}, which must only contain unsigned\n"
+ "8-bit values, to a numeric homogeneous vector.")
+#define FUNC_NAME s_scm_list_to_f32vector
+{
+ SCM uvec;
+ float_f32 * p;
+ int n;
+ int arg_pos = 1;
+
+ SCM_VALIDATE_LIST_COPYLEN (1, l, n);
+
+ uvec = make_uvec (FUNC_NAME, SCM_UVEC_F32, n);
+ p = (float_f32 *) SCM_UVEC_BASE (uvec);
+ while (SCM_CONSP (l))
+ {
+ float_f32 f;
+ double d;
+ d = scm_num2dbl (SCM_CAR (l), FUNC_NAME);
+ f = d;
+#if 0
+ /* This test somehow fails for even the simplest inexact
+ numbers, like 3.1. Must find out how to check properly. */
+ if (d != f)
+ scm_out_of_range_pos (FUNC_NAME, l, SCM_MAKINUM (1));
+#endif /* 0 */
+ *p++ = f;
+ l = SCM_CDR (l);
+ arg_pos++;
+ }
+ return uvec;
+}
+#undef FUNC_NAME
+
+
+/* ================================================================ */
+/* F64 procedures. */
+/* ================================================================ */
+
+
+SCM_DEFINE (scm_f64vector_p, "f64vector?", 1, 0, 0,
+ (SCM obj),
+ "Return @code{#t} if @var{obj} is a vector of type f64,\n"
+ "@code{#f} otherwise.")
+#define FUNC_NAME s_scm_f64vector_p
+{
+ return SCM_BOOL (SCM_SMOB_PREDICATE (scm_tc16_uvec, obj) &&
+ SCM_UVEC_TYPE (obj) == SCM_UVEC_F64);
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_make_f64vector, "make-f64vector", 1, 1, 0,
+ (SCM n, SCM fill),
+ "Create a newly allocated homogeneous numeric vector which can\n"
+ "hold @var{len} elements. If @var{fill} is given, it is used to\n"
+ "initialize the elements, otherwise the contents of the vector\n"
+ "is unspecified.")
+#define FUNC_NAME s_scm_make_f64vector
+{
+ SCM uvec;
+ float_f64 * p;
+ float_f64 f;
+ int count;
+
+ SCM_VALIDATE_INUM (1, n);
+ count = SCM_INUM (n);
+ uvec = make_uvec (FUNC_NAME, SCM_UVEC_F64, count);
+ if (SCM_UNBNDP (fill))
+ f = 0;
+ else
+ f = scm_num2dbl (fill, FUNC_NAME);
+ p = (float_f64 *) SCM_UVEC_BASE (uvec);
+ while (count-- > 0)
+ *p++ = f;
+ return uvec;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_f64vector, "f64vector", 0, 0, 1,
+ (SCM l),
+ "Create a newly allocated homogeneous numeric vector containing\n"
+ "all argument values.")
+#define FUNC_NAME s_scm_f64vector
+{
+ SCM_VALIDATE_REST_ARGUMENT (l);
+ return scm_list_to_f64vector (l);
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_f64vector_length, "f64vector-length", 1, 0, 0,
+ (SCM uvec),
+ "Return the number of elements in the homogeneous numeric vector\n"
+ "@var{uvec}.")
+#define FUNC_NAME s_scm_f64vector_length
+{
+ SCM_VALIDATE_SMOB (1, uvec, uvec);
+ if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_F64)
+ scm_wrong_type_arg (FUNC_NAME, 1, uvec);
+ return scm_int2num (SCM_UVEC_LENGTH (uvec));
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_f64vector_ref, "f64vector-ref", 2, 0, 0,
+ (SCM uvec, SCM index),
+ "Return the element at @var{index} in the homogeneous numeric\n"
+ "vector @var{uvec}.")
+#define FUNC_NAME s_scm_f64vector_ref
+{
+ int idx;
+
+ SCM_VALIDATE_SMOB (1, uvec, uvec);
+ if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_F64)
+ scm_wrong_type_arg (FUNC_NAME, 1, uvec);
+
+ idx = scm_num2int (index, 2, FUNC_NAME);
+ if (idx < 0 || idx >= SCM_UVEC_LENGTH (uvec))
+ scm_out_of_range_pos (FUNC_NAME, index, SCM_MAKINUM (2));
+
+ return scm_make_real (((float_f64 *) SCM_UVEC_BASE (uvec))[idx]);
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_f64vector_set_x, "f64vector-set!", 3, 0, 0,
+ (SCM uvec, SCM index, SCM value),
+ "Set the element at @var{index} in the homogeneous numeric\n"
+ "vector @var{uvec} to @var{value}. The return value is not\n"
+ "specified.")
+#define FUNC_NAME s_scm_f64vector_ref
+{
+ int idx;
+ float_f64 f;
+
+ SCM_VALIDATE_SMOB (1, uvec, uvec);
+ if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_F64)
+ scm_wrong_type_arg (FUNC_NAME, 1, uvec);
+
+ idx = scm_num2int (index, 2, FUNC_NAME);
+ if (idx < 0 || idx >= SCM_UVEC_LENGTH (uvec))
+ scm_out_of_range_pos (FUNC_NAME, index, SCM_MAKINUM (2));
+
+ f = scm_num2dbl (value, FUNC_NAME);
+
+ ((float_f64 *) SCM_UVEC_BASE (uvec))[idx] = f;
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_f64vector_to_list, "f64vector->list", 1, 0, 0,
+ (SCM uvec),
+ "Convert the homogeneous numeric vector @var{uvec} to a list.")
+#define FUNC_NAME s_scm_f64vector_to_list
+{
+ int idx;
+ float_f64 * p;
+ SCM res = SCM_EOL;
+
+ SCM_VALIDATE_SMOB (1, uvec, uvec);
+ if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_F64)
+ scm_wrong_type_arg (FUNC_NAME, 1, uvec);
+
+ idx = SCM_UVEC_LENGTH (uvec);
+ p = (float_f64 *) SCM_UVEC_BASE (uvec) + idx;
+ while (idx-- > 0)
+ {
+ p--;
+ res = scm_cons (scm_make_real (*p), res);
+ }
+ return res;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_list_to_f64vector, "list->f64vector", 1, 0, 0,
+ (SCM l),
+ "Convert the list @var{l}, which must only contain signed\n"
+ "8-bit values, to a numeric homogeneous vector.")
+#define FUNC_NAME s_scm_list_to_f64vector
+{
+ SCM uvec;
+ float_f64 * p;
+ int n;
+ int arg_pos = 1;
+
+ SCM_VALIDATE_LIST_COPYLEN (1, l, n);
+
+ uvec = make_uvec (FUNC_NAME, SCM_UVEC_F64, n);
+ p = (float_f64 *) SCM_UVEC_BASE (uvec);
+ while (SCM_CONSP (l))
+ {
+ float_f64 f = scm_num2dbl (SCM_CAR (l), FUNC_NAME);
+ *p++ = f;
+ l = SCM_CDR (l);
+ arg_pos++;
+ }
+ return uvec;
+}
+#undef FUNC_NAME
+
+
+void
+scm_init_srfi_4 (void)
+{
+ scm_tc16_uvec = scm_make_smob_type ("uvec", 0);
+ scm_set_smob_free (scm_tc16_uvec, uvec_free);
+ scm_set_smob_print (scm_tc16_uvec, uvec_print);
+#ifndef SCM_MAGIC_SNARFER
+#include "srfi/srfi-4.x"
+#endif
+}
diff --git a/srfi/srfi-4.h b/srfi/srfi-4.h
new file mode 100644
index 000000000..2b8df5161
--- /dev/null
+++ b/srfi/srfi-4.h
@@ -0,0 +1,141 @@
+#ifndef SCM_SRFI_4_H
+#define SCM_SRFI_4_H
+/* srfi-4.c --- Homogeneous numeric vector datatypes.
+ *
+ * Copyright (C) 2001 Free Software Foundation, Inc.
+ *
+ * This program is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License as
+ * published by the Free Software Foundation; either version 2, or (at
+ * your option) any later version.
+ *
+ * This program 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
+ * General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this software; see the file COPYING. If not, write to
+ * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
+ * Boston, MA 02111-1307 USA
+ *
+ * As a special exception, the Free Software Foundation gives
+ * permission for additional uses of the text contained in its release
+ * of GUILE.
+ *
+ * The exception is that, if you link the GUILE library with other
+ * files to produce an executable, this does not by itself cause the
+ * resulting executable to be covered by the GNU General Public
+ * License. Your use of that executable is in no way restricted on
+ * account of linking the GUILE library code into it.
+ *
+ * This exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public
+ * License.
+ *
+ * This exception applies only to the code released by the Free
+ * Software Foundation under the name GUILE. If you copy code from
+ * other Free Software Foundation releases into a copy of GUILE, as
+ * the General Public License permits, the exception does not apply to
+ * the code that you add in this way. To avoid misleading anyone as
+ * to the status of such modified files, you must delete this
+ * exception notice from them.
+ *
+ * If you write modifications of your own for GUILE, it is your choice
+ * whether to permit this exception to apply to your modifications.
+ * If you do not wish that, delete this exception notice. */
+
+
+SCM scm_u8vector_p (SCM obj);
+SCM scm_make_u8vector (SCM n, SCM fill);
+SCM scm_u8vector (SCM l);
+SCM scm_u8vector_length (SCM uvec);
+SCM scm_u8vector_ref (SCM uvec, SCM index);
+SCM scm_u8vector_set_x (SCM uvec, SCM index, SCM value);
+SCM scm_u8vector_to_list (SCM uvec);
+SCM scm_list_to_u8vector (SCM l);
+
+SCM scm_s8vector_p (SCM obj);
+SCM scm_make_s8vector (SCM n, SCM fill);
+SCM scm_s8vector (SCM l);
+SCM scm_s8vector_length (SCM uvec);
+SCM scm_s8vector_ref (SCM uvec, SCM index);
+SCM scm_s8vector_set_x (SCM uvec, SCM index, SCM value);
+SCM scm_s8vector_to_list (SCM uvec);
+SCM scm_list_to_s8vector (SCM l);
+
+SCM scm_u16vector_p (SCM obj);
+SCM scm_make_u16vector (SCM n, SCM fill);
+SCM scm_u16vector (SCM l);
+SCM scm_u16vector_length (SCM uvec);
+SCM scm_u16vector_ref (SCM uvec, SCM index);
+SCM scm_u16vector_set_x (SCM uvec, SCM index, SCM value);
+SCM scm_u16vector_to_list (SCM uvec);
+SCM scm_list_to_u16vector (SCM l);
+
+SCM scm_s16vector_p (SCM obj);
+SCM scm_make_s16vector (SCM n, SCM fill);
+SCM scm_s16vector (SCM l);
+SCM scm_s16vector_length (SCM uvec);
+SCM scm_s16vector_ref (SCM uvec, SCM index);
+SCM scm_s16vector_set_x (SCM uvec, SCM index, SCM value);
+SCM scm_s16vector_to_list (SCM uvec);
+SCM scm_list_to_s16vector (SCM l);
+
+SCM scm_u32vector_p (SCM obj);
+SCM scm_make_u32vector (SCM n, SCM fill);
+SCM scm_u32vector (SCM l);
+SCM scm_u32vector_length (SCM uvec);
+SCM scm_u32vector_ref (SCM uvec, SCM index);
+SCM scm_u32vector_set_x (SCM uvec, SCM index, SCM value);
+SCM scm_u32vector_to_list (SCM uvec);
+SCM scm_list_to_u32vector (SCM l);
+
+SCM scm_s32vector_p (SCM obj);
+SCM scm_make_s32vector (SCM n, SCM fill);
+SCM scm_s32vector (SCM l);
+SCM scm_s32vector_length (SCM uvec);
+SCM scm_s32vector_ref (SCM uvec, SCM index);
+SCM scm_s32vector_set_x (SCM uvec, SCM index, SCM value);
+SCM scm_s32vector_to_list (SCM uvec);
+SCM scm_list_to_s32vector (SCM l);
+
+SCM scm_u64vector_p (SCM obj);
+SCM scm_make_u64vector (SCM n, SCM fill);
+SCM scm_u64vector (SCM l);
+SCM scm_u64vector_length (SCM uvec);
+SCM scm_u64vector_ref (SCM uvec, SCM index);
+SCM scm_u64vector_set_x (SCM uvec, SCM index, SCM value);
+SCM scm_u64vector_to_list (SCM uvec);
+SCM scm_list_to_u64vector (SCM l);
+
+SCM scm_s64vector_p (SCM obj);
+SCM scm_make_s64vector (SCM n, SCM fill);
+SCM scm_s64vector (SCM l);
+SCM scm_s64vector_length (SCM uvec);
+SCM scm_s64vector_ref (SCM uvec, SCM index);
+SCM scm_s64vector_set_x (SCM uvec, SCM index, SCM value);
+SCM scm_s64vector_to_list (SCM uvec);
+SCM scm_list_to_s64vector (SCM l);
+
+SCM scm_f32vector_p (SCM obj);
+SCM scm_make_f32vector (SCM n, SCM fill);
+SCM scm_f32vector (SCM l);
+SCM scm_f32vector_length (SCM uvec);
+SCM scm_f32vector_ref (SCM uvec, SCM index);
+SCM scm_f32vector_set_x (SCM uvec, SCM index, SCM value);
+SCM scm_f32vector_to_list (SCM uvec);
+SCM scm_list_to_f32vector (SCM l);
+
+SCM scm_f64vector_p (SCM obj);
+SCM scm_make_f64vector (SCM n, SCM fill);
+SCM scm_f64vector (SCM l);
+SCM scm_f64vector_length (SCM uvec);
+SCM scm_f64vector_ref (SCM uvec, SCM index);
+SCM scm_f64vector_set_x (SCM uvec, SCM index, SCM value);
+SCM scm_f64vector_to_list (SCM uvec);
+SCM scm_list_to_f64vector (SCM l);
+
+void scm_init_srfi_4 (void);
+
+#endif /* SCM_SRFI_4_H */
diff --git a/srfi/srfi-4.scm b/srfi/srfi-4.scm
new file mode 100644
index 000000000..ea7137cd1
--- /dev/null
+++ b/srfi/srfi-4.scm
@@ -0,0 +1,200 @@
+;;;; srfi-4.scm --- Homogeneous numeric vector datatypes.
+;;;;
+;;;; Copyright (C) 2001 Free Software Foundation, Inc.
+;;;;
+;;;; This program is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU General Public License as
+;;;; published by the Free Software Foundation; either version 2, or
+;;;; (at your option) any later version.
+;;;;
+;;;; This program 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
+;;;; General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU General Public License
+;;;; along with this software; see the file COPYING. If not, write to
+;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
+;;;; Boston, MA 02111-1307 USA
+;;;;
+;;;; As a special exception, the Free Software Foundation gives permission
+;;;; for additional uses of the text contained in its release of GUILE.
+;;;;
+;;;; The exception is that, if you link the GUILE library with other files
+;;;; to produce an executable, this does not by itself cause the
+;;;; resulting executable to be covered by the GNU General Public License.
+;;;; Your use of that executable is in no way restricted on account of
+;;;; linking the GUILE library code into it.
+;;;;
+;;;; This exception does not however invalidate any other reasons why
+;;;; the executable file might be covered by the GNU General Public License.
+;;;;
+;;;; This exception applies only to the code released by the
+;;;; Free Software Foundation under the name GUILE. If you copy
+;;;; code from other Free Software Foundation releases into a copy of
+;;;; GUILE, as the General Public License permits, the exception does
+;;;; not apply to the code that you add in this way. To avoid misleading
+;;;; anyone as to the status of such modified files, you must delete
+;;;; this exception notice from them.
+;;;;
+;;;; If you write modifications of your own for GUILE, it is your choice
+;;;; whether to permit this exception to apply to your modifications.
+;;;; If you do not wish that, delete this exception notice.
+
+;;; Commentary:
+
+;;; This module implements homogeneous numeric vectors as defined in SRFI-4.
+
+;;; Code:
+
+;;; Author: Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+
+(define-module (srfi srfi-4))
+
+(export
+;;; Unsigned 8-bit vectors.
+ u8vector? make-u8vector u8vector u8vector-length u8vector-ref
+ u8vector-set! u8vector->list list->u8vector
+
+;;; Signed 8-bit vectors.
+ s8vector? make-s8vector s8vector s8vector-length s8vector-ref
+ s8vector-set! s8vector->list list->s8vector
+
+;;; Unsigned 16-bit vectors.
+ u16vector? make-u16vector u16vector u16vector-length u16vector-ref
+ u16vector-set! u16vector->list list->u16vector
+
+;;; Signed 16-bit vectors.
+ s16vector? make-s16vector s16vector s16vector-length s16vector-ref
+ s16vector-set! s16vector->list list->s16vector
+
+;;; Unsigned 32-bit vectors.
+ u32vector? make-u32vector u32vector u32vector-length u32vector-ref
+ u32vector-set! u32vector->list list->u32vector
+
+;;; Signed 32-bit vectors.
+ s32vector? make-s32vector s32vector s32vector-length s32vector-ref
+ s32vector-set! s32vector->list list->s32vector
+
+;;; Unsigned 64-bit vectors.
+ u64vector? make-u64vector u64vector u64vector-length u64vector-ref
+ u64vector-set! u64vector->list list->u64vector
+
+;;; Signed 64-bit vectors.
+ s64vector? make-s64vector s64vector s64vector-length s64vector-ref
+ s64vector-set! s64vector->list list->s64vector
+
+;;; 32-bit floating point vectors.
+ f32vector? make-f32vector f32vector f32vector-length f32vector-ref
+ f32vector-set! f32vector->list list->f32vector
+
+;;; 64-bit floating point vectors.
+ f64vector? make-f64vector f64vector f64vector-length f64vector-ref
+ f64vector-set! f64vector->list list->f64vector
+ )
+
+
+;; Make 'srfi-4 available as a feature identifiere to `cond-expand'.
+;;
+(cond-expand-provide (current-module) '(srfi-4))
+
+
+;; Load the compiled primitives from the shared library.
+;;
+(load-extension "libguile-srfi-srfi-4" "scm_init_srfi_4")
+
+
+;; Reader extension for #f32() and #f64() vectors.
+;;
+(define (hash-f char port)
+ (if (or (char=? (peek-char port) #\3)
+ (char=? (peek-char port) #\6))
+ (let* ((obj (read port)))
+ (if (number? obj)
+ (cond ((= obj 32)
+ (let ((l (read port)))
+ (if (list? l)
+ (list->f32vector l)
+ (error "syntax error in #f32() vector literal"))))
+ ((= obj 64)
+ (let ((l (read port)))
+ (if (list? l)
+ (list->f64vector l)
+ (error "syntax error in #f64() vector literal"))))
+ (else
+ (error "syntax error in #f...() vector literal")))
+ (error "syntax error in #f...() vector literal")))
+ #f))
+
+
+;; Reader extension for #u8(), #u16(), #u32() and #u64() vectors.
+;;
+(define (hash-u char port)
+ (if (or (char=? (peek-char port) #\8)
+ (char=? (peek-char port) #\1)
+ (char=? (peek-char port) #\3)
+ (char=? (peek-char port) #\6))
+ (let ((obj (read port)))
+ (cond ((= obj 8)
+ (let ((l (read port)))
+ (if (list? l)
+ (list->u8vector l)
+ (error "syntax error in #u8() vector literal"))))
+ ((= obj 16)
+ (let ((l (read port)))
+ (if (list? l)
+ (list->u16vector l)
+ (error "syntax error in #u16() vector literal"))))
+ ((= obj 32)
+ (let ((l (read port)))
+ (if (list? l)
+ (list->u32vector l)
+ (error "syntax error in #u32() vector literal"))))
+ ((= obj 64)
+ (let ((l (read port)))
+ (if (list? l)
+ (list->u64vector l)
+ (error "syntax error in #u64() vector literal"))))
+ (else
+ (error "syntax error in #u...() vector literal"))))
+ (error "syntax error in #u...() vector literal")))
+
+
+;; Reader extension for #s8(), #s16(), #s32() and #s64() vectors.
+;;
+(define (hash-s char port)
+ (if (or (char=? (peek-char port) #\8)
+ (char=? (peek-char port) #\1)
+ (char=? (peek-char port) #\3)
+ (char=? (peek-char port) #\6))
+ (let ((obj (read port)))
+ (cond ((= obj 8)
+ (let ((l (read port)))
+ (if (list? l)
+ (list->s8vector l)
+ (error "syntax error in #s8() vector literal"))))
+ ((= obj 16)
+ (let ((l (read port)))
+ (if (list? l)
+ (list->s16vector l)
+ (error "syntax error in #s16() vector literal"))))
+ ((= obj 32)
+ (let ((l (read port)))
+ (if (list? l)
+ (list->s32vector l)
+ (error "syntax error in #s32() vector literal"))))
+ ((= obj 64)
+ (let ((l (read port)))
+ (if (list? l)
+ (list->s64vector l)
+ (error "syntax error in #s64() vector literal"))))
+ (else
+ (error "syntax error in #s...() vector literal"))))
+ (error "syntax error in #s...() vector literal")))
+
+
+;; Install the hash extensions.
+;;
+(read-hash-extend #\f hash-f)
+(read-hash-extend #\u hash-u)
+(read-hash-extend #\s hash-s)