-/* srfi-4.c --- Homogeneous numeric vector datatypes.
+/* srfi-4.c --- Uniform numeric vector datatypes.
*
- * Copyright (C) 2001, 2004 Free Software Foundation, Inc.
+ * Copyright (C) 2001, 2004, 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 2.1 of the License, or (at your option) any later version.
+ * 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
+ * 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., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
-#include <libguile.h>
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
#include <string.h>
+#include <errno.h>
#include <stdio.h>
+#include "libguile/_scm.h"
+#include "libguile/__scm.h"
+#include "libguile/bdw-gc.h"
#include "libguile/srfi-4.h"
+#include "libguile/bitvectors.h"
+#include "libguile/bytevectors.h"
+#include "libguile/generalized-vectors.h"
+#include "libguile/uniform.h"
#include "libguile/error.h"
+#include "libguile/eval.h"
#include "libguile/read.h"
#include "libguile/ports.h"
#include "libguile/chars.h"
+#include "libguile/vectors.h"
+#include "libguile/arrays.h"
+#include "libguile/strings.h"
+#include "libguile/strports.h"
+#include "libguile/dynwind.h"
+#include "libguile/deprecation.h"
+
+#ifdef HAVE_UNISTD_H
+#include <unistd.h>
+#endif
-/* Smob type code for homogeneous numeric vectors. */
+#ifdef HAVE_IO_H
+#include <io.h>
+#endif
+
+/* Smob type code for uniform numeric vectors. */
int scm_tc16_uvec = 0;
+#define SCM_IS_UVEC(obj) SCM_SMOB_PREDICATE (scm_tc16_uvec, (obj))
-/* Accessor macros for the three components of a homogeneous numeric
+/* Accessor macros for the three components of a uniform numeric
vector:
- The type tag (one of the symbolic constants below).
- The vector's length (counted in elements).
#define SCM_UVEC_BASE(u) ((void *)SCM_CELL_WORD_3(u))
-/* Symbolic constants encoding the various types of homogeneous
+/* Symbolic constants encoding the various types of uniform
numeric vectors. */
#define SCM_UVEC_U8 0
#define SCM_UVEC_S8 1
1, 1,
2, 2,
4, 4,
+#if SCM_HAVE_T_INT64
8, 8,
+#else
+ sizeof (SCM), sizeof (SCM),
+#endif
sizeof(float), sizeof(double),
2*sizeof(float), 2*sizeof(double)
};
/* ================================================================ */
-/* Smob print hook for homogeneous vectors. */
+/* Smob print hook for uniform vectors. */
static int
uvec_print (SCM uvec, SCM port, scm_print_state *pstate)
{
#endif
float *f32;
double *f64;
+ SCM *fake_64;
} np;
size_t i = 0;
#if SCM_HAVE_T_INT64
case SCM_UVEC_U64: np.u64 = (scm_t_uint64 *) uptr; break;
case SCM_UVEC_S64: np.s64 = (scm_t_int64 *) uptr; break;
-#endif
+#else
+ case SCM_UVEC_U64:
+ case SCM_UVEC_S64: np.fake_64 = (SCM *) uptr; break;
+#endif
case SCM_UVEC_F32: np.f32 = (float *) uptr; break;
case SCM_UVEC_F64: np.f64 = (double *) uptr; break;
case SCM_UVEC_C32: np.f32 = (float *) uptr; break;
#if SCM_HAVE_T_INT64
case SCM_UVEC_U64: scm_uintprint (*np.u64, 10, port); np.u64++; break;
case SCM_UVEC_S64: scm_intprint (*np.s64, 10, port); np.s64++; break;
+#else
+ case SCM_UVEC_U64:
+ case SCM_UVEC_S64: scm_iprin1 (*np.fake_64, port, pstate);
+ np.fake_64++; break;
#endif
case SCM_UVEC_F32: scm_i_print_double (*np.f32, port); np.f32++; break;
case SCM_UVEC_F64: scm_i_print_double (*np.f64, port); np.f64++; break;
result = SCM_BOOL_F;
else if (SCM_UVEC_LENGTH (a) != SCM_UVEC_LENGTH (b))
result = SCM_BOOL_F;
+#if SCM_HAVE_T_INT64 == 0
+ else if (SCM_UVEC_TYPE (a) == SCM_UVEC_U64
+ || SCM_UVEC_TYPE (a) == SCM_UVEC_S64)
+ {
+ SCM *aptr = (SCM *)SCM_UVEC_BASE (a), *bptr = (SCM *)SCM_UVEC_BASE (b);
+ size_t len = SCM_UVEC_LENGTH (a), i;
+ for (i = 0; i < len; i++)
+ if (scm_is_false (scm_num_eq_p (*aptr++, *bptr++)))
+ {
+ result = SCM_BOOL_F;
+ break;
+ }
+ }
+#endif
else if (memcmp (SCM_UVEC_BASE (a), SCM_UVEC_BASE (b),
SCM_UVEC_LENGTH (a) * uvec_sizes[SCM_UVEC_TYPE(a)]) != 0)
result = SCM_BOOL_F;
return result;
}
-/* Smob free hook for homogeneous numeric vectors. */
-static size_t
-uvec_free (SCM uvec)
-{
- int type = SCM_UVEC_TYPE (uvec);
- scm_gc_free (SCM_UVEC_BASE (uvec),
- SCM_UVEC_LENGTH (uvec) * uvec_sizes[type],
- uvec_names[type]);
- return 0;
-}
/* ================================================================ */
/* Utility procedures. */
/* ================================================================ */
-static SCM_C_INLINE int
+static SCM_C_INLINE_KEYWORD int
is_uvec (int type, SCM obj)
{
- return (SCM_SMOB_PREDICATE (scm_tc16_uvec, obj)
- && SCM_UVEC_TYPE (obj) == type);
+ if (SCM_IS_UVEC (obj))
+ return SCM_UVEC_TYPE (obj) == type;
+ if (SCM_I_ARRAYP (obj) && SCM_I_ARRAY_NDIM (obj) == 1)
+ {
+ SCM v = SCM_I_ARRAY_V (obj);
+ return SCM_IS_UVEC (v) && SCM_UVEC_TYPE (v) == type;
+ }
+ return 0;
}
-static SCM_C_INLINE SCM
+static SCM_C_INLINE_KEYWORD SCM
uvec_p (int type, SCM obj)
{
return scm_from_bool (is_uvec (type, obj));
}
-static SCM_C_INLINE void
+static SCM_C_INLINE_KEYWORD void
uvec_assert (int type, SCM obj)
{
if (!is_uvec (type, obj))
scm_wrong_type_arg_msg (NULL, 0, obj, uvec_names[type]);
}
+/* Invoke free(3) on DATA, a user-provided buffer passed to one of the
+ `scm_take_' functions. */
+static void
+free_user_data (GC_PTR data, GC_PTR unused)
+{
+ free (data);
+}
+
static SCM
-take_uvec (int type, const void *base, size_t len)
+take_uvec (int type, void *base, size_t len)
{
SCM_RETURN_NEWSMOB3 (scm_tc16_uvec, type, len, (scm_t_bits) base);
}
-/* Create a new, uninitialized homogeneous numeric vector of type TYPE
+/* Create a new, uninitialized uniform numeric vector of type TYPE
with space for LEN elements. */
static SCM
alloc_uvec (int type, size_t len)
if (len > SCM_I_SIZE_MAX / uvec_sizes[type])
scm_out_of_range (NULL, scm_from_size_t (len));
base = scm_gc_malloc (len * uvec_sizes[type], uvec_names[type]);
+#if SCM_HAVE_T_INT64 == 0
+ if (type == SCM_UVEC_U64 || type == SCM_UVEC_S64)
+ {
+ SCM *ptr = (SCM *)base;
+ size_t i;
+ for (i = 0; i < len; i++)
+ *ptr++ = SCM_UNSPECIFIED;
+ }
+#endif
return take_uvec (type, base, len);
}
so we use a big 'if' in the next two functions.
*/
-static SCM_C_INLINE SCM
-uvec_fast_ref (int type, void *base, size_t c_idx)
+static SCM_C_INLINE_KEYWORD SCM
+uvec_fast_ref (int type, const void *base, size_t c_idx)
{
if (type == SCM_UVEC_U8)
return scm_from_uint8 (((scm_t_uint8*)base)[c_idx]);
return scm_from_uint64 (((scm_t_uint64*)base)[c_idx]);
else if (type == SCM_UVEC_S64)
return scm_from_int64 (((scm_t_int64*)base)[c_idx]);
+#else
+ else if (type == SCM_UVEC_U64)
+ return ((SCM *)base)[c_idx];
+ else if (type == SCM_UVEC_S64)
+ return ((SCM *)base)[c_idx];
#endif
else if (type == SCM_UVEC_F32)
return scm_from_double (((float*)base)[c_idx]);
return SCM_BOOL_F;
}
-static SCM_C_INLINE void
+#if SCM_HAVE_T_INT64 == 0
+static SCM scm_uint64_min, scm_uint64_max;
+static SCM scm_int64_min, scm_int64_max;
+
+static void
+assert_exact_integer_range (SCM val, SCM min, SCM max)
+{
+ if (!scm_is_integer (val)
+ || scm_is_false (scm_exact_p (val)))
+ scm_wrong_type_arg_msg (NULL, 0, val, "exact integer");
+ if (scm_is_true (scm_less_p (val, min))
+ || scm_is_true (scm_gr_p (val, max)))
+ scm_out_of_range (NULL, val);
+}
+#endif
+
+static SCM_C_INLINE_KEYWORD void
uvec_fast_set_x (int type, void *base, size_t c_idx, SCM val)
{
if (type == SCM_UVEC_U8)
(((scm_t_uint64*)base)[c_idx]) = scm_to_uint64 (val);
else if (type == SCM_UVEC_S64)
(((scm_t_int64*)base)[c_idx]) = scm_to_int64 (val);
+#else
+ else if (type == SCM_UVEC_U64)
+ {
+ assert_exact_integer_range (val, scm_uint64_min, scm_uint64_max);
+ ((SCM *)base)[c_idx] = val;
+ }
+ else if (type == SCM_UVEC_S64)
+ {
+ assert_exact_integer_range (val, scm_int64_min, scm_int64_max);
+ ((SCM *)base)[c_idx] = val;
+ }
#endif
else if (type == SCM_UVEC_F32)
(((float*)base)[c_idx]) = scm_to_double (val);
}
}
-static SCM_C_INLINE SCM
+static SCM_C_INLINE_KEYWORD SCM
make_uvec (int type, SCM len, SCM fill)
{
size_t c_len = scm_to_size_t (len);
return uvec;
}
-static SCM_C_INLINE SCM
-uvec_length (int type, SCM uvec)
+static SCM_C_INLINE_KEYWORD void *
+uvec_writable_elements (int type, SCM uvec, scm_t_array_handle *handle,
+ size_t *lenp, ssize_t *incp)
{
- uvec_assert (type, uvec);
- return scm_from_size_t (SCM_UVEC_LENGTH (uvec));
+ if (type >= 0)
+ {
+ SCM v = uvec;
+ if (SCM_I_ARRAYP (v))
+ v = SCM_I_ARRAY_V (v);
+ uvec_assert (type, v);
+ }
+
+ return scm_uniform_vector_writable_elements (uvec, handle, lenp, incp);
}
-static SCM_C_INLINE SCM
-uvec_ref (int type, SCM uvec, SCM idx)
+static SCM_C_INLINE_KEYWORD const void *
+uvec_elements (int type, SCM uvec, scm_t_array_handle *handle,
+ size_t *lenp, ssize_t *incp)
{
- size_t c_idx;
- SCM res;
-
- uvec_assert (type, uvec);
- c_idx = scm_to_unsigned_integer (idx, 0, SCM_UVEC_LENGTH (uvec)-1);
- res = uvec_fast_ref (type, SCM_UVEC_BASE(uvec), c_idx);
- scm_remember_upto_here_1 (uvec);
- return res;
+ return uvec_writable_elements (type, uvec, handle, lenp, incp);
}
-static SCM_C_INLINE SCM
-uvec_set_x (int type, SCM uvec, SCM idx, SCM val)
+static int
+uvec_type (scm_t_array_handle *h)
{
- size_t c_idx;
-
- uvec_assert (type, uvec);
- c_idx = scm_to_unsigned_integer (idx, 0, SCM_UVEC_LENGTH (uvec)-1);
- uvec_fast_set_x (type, SCM_UVEC_BASE(uvec), c_idx, val);
- scm_remember_upto_here_1 (uvec);
- return SCM_UNSPECIFIED;
+ SCM v = h->array;
+ if (SCM_I_ARRAYP (v))
+ v = SCM_I_ARRAY_V (v);
+ return SCM_UVEC_TYPE (v);
}
-static SCM_C_INLINE SCM
+static SCM
uvec_to_list (int type, SCM uvec)
{
- size_t c_idx;
- void *base;
+ scm_t_array_handle handle;
+ size_t len;
+ ssize_t i, inc;
+ const void *elts;
SCM res = SCM_EOL;
- uvec_assert (type, uvec);
- c_idx = SCM_UVEC_LENGTH (uvec);
- base = SCM_UVEC_BASE (uvec);
- while (c_idx-- > 0)
- res = scm_cons (uvec_fast_ref (type, base, c_idx), res);
- scm_remember_upto_here_1 (uvec);
+ elts = uvec_elements (type, uvec, &handle, &len, &inc);
+ for (i = len - 1; i >= 0; i--)
+ res = scm_cons (scm_array_handle_ref (&handle, i*inc), res);
+ scm_array_handle_release (&handle);
return res;
}
-static SCM_C_INLINE SCM
+static SCM_C_INLINE_KEYWORD SCM
+uvec_length (int type, SCM uvec)
+{
+ scm_t_array_handle handle;
+ size_t len;
+ ssize_t inc;
+ uvec_elements (type, uvec, &handle, &len, &inc);
+ scm_array_handle_release (&handle);
+ return scm_from_size_t (len);
+}
+
+static SCM_C_INLINE_KEYWORD SCM
+uvec_ref (int type, SCM uvec, SCM idx)
+{
+ scm_t_array_handle handle;
+ size_t i, len;
+ ssize_t inc;
+ const void *elts;
+ SCM res;
+
+ elts = uvec_elements (type, uvec, &handle, &len, &inc);
+ if (type < 0)
+ type = uvec_type (&handle);
+ i = scm_to_unsigned_integer (idx, 0, len-1);
+ res = uvec_fast_ref (type, elts, i*inc);
+ scm_array_handle_release (&handle);
+ return res;
+}
+
+static SCM_C_INLINE_KEYWORD SCM
+uvec_set_x (int type, SCM uvec, SCM idx, SCM val)
+{
+ scm_t_array_handle handle;
+ size_t i, len;
+ ssize_t inc;
+ void *elts;
+
+ elts = uvec_writable_elements (type, uvec, &handle, &len, &inc);
+ if (type < 0)
+ type = uvec_type (&handle);
+ i = scm_to_unsigned_integer (idx, 0, len-1);
+ uvec_fast_set_x (type, elts, i*inc, val);
+ scm_array_handle_release (&handle);
+ return SCM_UNSPECIFIED;
+}
+
+static SCM_C_INLINE_KEYWORD SCM
list_to_uvec (int type, SCM list)
{
SCM uvec;
return uvec;
}
-static SCM
-coerce_to_uvec (int type, SCM obj)
-{
- if (is_uvec (type, obj))
- return obj;
- else if (scm_is_pair (obj))
- return list_to_uvec (type, obj);
- else if (scm_is_generalized_vector (obj))
- {
- size_t len = scm_c_generalized_vector_length (obj), i;
- SCM uvec = alloc_uvec (type, len);
- void *base = SCM_UVEC_BASE (uvec);
- for (i = 0; i < len; i++)
- uvec_fast_set_x (type, base, i, scm_c_generalized_vector_ref (obj, i));
- return uvec;
- }
- else
- scm_wrong_type_arg_msg (NULL, 0, obj, "list or generalized vector");
-}
-
-static SCM *uvec_proc_vars[12] = {
- &scm_i_proc_make_u8vector,
- &scm_i_proc_make_s8vector,
- &scm_i_proc_make_u16vector,
- &scm_i_proc_make_s16vector,
- &scm_i_proc_make_u32vector,
- &scm_i_proc_make_s32vector,
- &scm_i_proc_make_u64vector,
- &scm_i_proc_make_s64vector,
- &scm_i_proc_make_f32vector,
- &scm_i_proc_make_f64vector,
- &scm_i_proc_make_c32vector,
- &scm_i_proc_make_c64vector
-};
+SCM_SYMBOL (scm_sym_a, "a");
+SCM_SYMBOL (scm_sym_b, "b");
SCM
-scm_i_generalized_vector_creator (SCM v)
+scm_i_generalized_vector_type (SCM v)
{
if (scm_is_vector (v))
- return scm_i_proc_make_vector;
+ return SCM_BOOL_T;
else if (scm_is_string (v))
- return scm_i_proc_make_string;
+ return scm_sym_a;
else if (scm_is_bitvector (v))
- return scm_i_proc_make_bitvector;
+ return scm_sym_b;
else if (scm_is_uniform_vector (v))
- return *(uvec_proc_vars[SCM_UVEC_TYPE(v)]);
+ return scm_from_locale_symbol (uvec_tags[SCM_UVEC_TYPE(v)]);
+ else if (scm_is_bytevector (v))
+ return scm_from_locale_symbol ("vu8");
else
return SCM_BOOL_F;
}
-int
-scm_is_uniform_vector (SCM obj)
-{
- return SCM_SMOB_PREDICATE (scm_tc16_uvec, obj);
-}
-
-size_t
-scm_c_uniform_vector_length (SCM v)
-{
- if (scm_is_uniform_vector (v))
- return SCM_UVEC_LENGTH (v);
+SCM_DEFINE (scm_uniform_vector_read_x, "uniform-vector-read!", 1, 3, 0,
+ (SCM uvec, SCM port_or_fd, SCM start, SCM end),
+ "Fill the elements of @var{uvec} by reading\n"
+ "raw bytes from @var{port-or-fdes}, using host byte order.\n\n"
+ "The optional arguments @var{start} (inclusive) and @var{end}\n"
+ "(exclusive) allow a specified region to be read,\n"
+ "leaving the remainder of the vector unchanged.\n\n"
+ "When @var{port-or-fdes} is a port, all specified elements\n"
+ "of @var{uvec} are attempted to be read, potentially blocking\n"
+ "while waiting formore input or end-of-file.\n"
+ "When @var{port-or-fd} is an integer, a single call to\n"
+ "read(2) is made.\n\n"
+ "An error is signalled when the last element has only\n"
+ "been partially filled before reaching end-of-file or in\n"
+ "the single call to read(2).\n\n"
+ "@code{uniform-vector-read!} returns the number of elements\n"
+ "read.\n\n"
+ "@var{port-or-fdes} may be omitted, in which case it defaults\n"
+ "to the value returned by @code{(current-input-port)}.")
+#define FUNC_NAME s_scm_uniform_vector_read_x
+{
+ scm_t_array_handle handle;
+ size_t vlen, sz, ans;
+ ssize_t inc;
+ size_t cstart, cend;
+ size_t remaining, off;
+ char *base;
+
+ if (SCM_UNBNDP (port_or_fd))
+ port_or_fd = scm_current_input_port ();
else
- scm_wrong_type_arg_msg (NULL, 0, v, "uniform vector");
-}
+ SCM_ASSERT (scm_is_integer (port_or_fd)
+ || (SCM_OPINPORTP (port_or_fd)),
+ port_or_fd, SCM_ARG2, FUNC_NAME);
-size_t
-scm_c_uniform_vector_size (SCM v)
-{
- if (scm_is_uniform_vector (v))
- return SCM_UVEC_LENGTH (v) * uvec_sizes[SCM_UVEC_TYPE (v)];
- else
- scm_wrong_type_arg_msg (NULL, 0, v, "uniform vector");
-}
+ if (!scm_is_uniform_vector (uvec))
+ scm_wrong_type_arg_msg (NULL, 0, uvec, "uniform vector");
-SCM_DEFINE (scm_uniform_vector_p, "uniform-vector?", 1, 0, 0,
- (SCM obj),
- "Return @code{#t} if @var{obj} is a uniform vector.")
-#define FUNC_NAME s_scm_uniform_vector_p
-{
- return scm_from_bool (scm_is_uniform_vector (obj));
-}
-#undef FUNC_NAME
+ base = scm_uniform_vector_writable_elements (uvec, &handle, &vlen, &inc);
+ sz = scm_array_handle_uniform_element_size (&handle);
-SCM_DEFINE (scm_uniform_vector_ref, "uniform-vector-ref", 2, 0, 0,
- (SCM v, SCM idx),
- "Return the element at index @var{idx} of the\n"
- "homogenous numeric vector @var{v}.")
-#define FUNC_NAME s_scm_uniform_vector_ref
-{
- /* Support old argument convention.
- */
- if (scm_is_pair (idx))
+ if (inc != 1)
{
- if (!scm_is_null (SCM_CDR (idx)))
- scm_wrong_num_args (NULL);
- idx = SCM_CAR (idx);
+ /* XXX - we should of course support non contiguous vectors. */
+ scm_misc_error (NULL, "only contiguous vectors are supported: ~a",
+ scm_list_1 (uvec));
}
- if (scm_is_uniform_vector (v))
- return uvec_ref (SCM_UVEC_TYPE (v), v, idx);
- else
- scm_wrong_type_arg_msg (NULL, 0, v, "uniform vector");
-}
-#undef FUNC_NAME
-
-SCM
-scm_c_uniform_vector_ref (SCM v, size_t idx)
-{
- if (scm_is_uniform_vector (v))
+ cstart = 0;
+ cend = vlen;
+ if (!SCM_UNBNDP (start))
{
- if (idx < SCM_UVEC_LENGTH (v))
- return uvec_fast_ref (SCM_UVEC_TYPE (v), SCM_UVEC_BASE (v), idx);
- else
- scm_out_of_range (NULL, scm_from_size_t (idx));
+ cstart = scm_to_unsigned_integer (start, 0, vlen);
+ if (!SCM_UNBNDP (end))
+ cend = scm_to_unsigned_integer (end, cstart, vlen);
}
- else
- scm_wrong_type_arg_msg (NULL, 0, v, "uniform vector");
-}
-SCM_DEFINE (scm_uniform_vector_set_x, "uniform-vector-set!", 3, 0, 0,
- (SCM v, SCM idx, SCM val),
- "Set the element at index @var{idx} of the\n"
- "homogenous numeric vector @var{v} to @var{val}.")
-#define FUNC_NAME s_scm_uniform_vector_set_x
-{
- /* Support old argument convention.
- */
- if (scm_is_pair (idx))
+ remaining = (cend - cstart) * sz;
+ off = cstart * sz;
+
+ if (SCM_NIMP (port_or_fd))
{
- if (!scm_is_null (SCM_CDR (idx)))
- scm_wrong_num_args (NULL);
- idx = SCM_CAR (idx);
+ ans = cend - cstart;
+ remaining -= scm_c_read (port_or_fd, base + off, remaining);
+ if (remaining % sz != 0)
+ SCM_MISC_ERROR ("unexpected EOF", SCM_EOL);
+ ans -= remaining / sz;
}
-
- if (scm_is_uniform_vector (v))
- return uvec_set_x (SCM_UVEC_TYPE (v), v, idx, val);
- else
- scm_wrong_type_arg_msg (NULL, 0, v, "uniform vector");
-}
-#undef FUNC_NAME
-
-void
-scm_c_uniform_vector_set_x (SCM v, size_t idx, SCM val)
-{
- if (scm_is_uniform_vector (v))
+ else /* file descriptor. */
{
- if (idx < SCM_UVEC_LENGTH (v))
- uvec_fast_set_x (SCM_UVEC_TYPE (v), SCM_UVEC_BASE (v), idx, val);
- else
- scm_out_of_range (NULL, scm_from_size_t (idx));
+ int fd = scm_to_int (port_or_fd);
+ int n;
+
+ SCM_SYSCALL (n = read (fd, base + off, remaining));
+ if (n == -1)
+ SCM_SYSERROR;
+ if (n % sz != 0)
+ SCM_MISC_ERROR ("unexpected EOF", SCM_EOL);
+ ans = n / sz;
}
- else
- scm_wrong_type_arg_msg (NULL, 0, v, "uniform vector");
-}
-SCM_DEFINE (scm_uniform_vector_to_list, "uniform-vector->list", 1, 0, 0,
- (SCM uvec),
- "Convert the homogeneous numeric vector @var{uvec} to a list.")
-#define FUNC_NAME s_scm_uniform_vector_to_list
-{
- if (scm_is_uniform_vector (uvec))
- return uvec_to_list (SCM_UVEC_TYPE (uvec), uvec);
- else
- scm_wrong_type_arg_msg (NULL, 0, uvec, "uniform vector");
+ scm_array_handle_release (&handle);
+
+ return scm_from_size_t (ans);
}
#undef FUNC_NAME
-void *
-scm_uniform_vector_elements (SCM uvec)
-{
- if (scm_is_uniform_vector (uvec))
- return SCM_UVEC_BASE (uvec);
+SCM_DEFINE (scm_uniform_vector_write, "uniform-vector-write", 1, 3, 0,
+ (SCM uvec, SCM port_or_fd, SCM start, SCM end),
+ "Write the elements of @var{uvec} as raw bytes to\n"
+ "@var{port-or-fdes}, in the host byte order.\n\n"
+ "The optional arguments @var{start} (inclusive)\n"
+ "and @var{end} (exclusive) allow\n"
+ "a specified region to be written.\n\n"
+ "When @var{port-or-fdes} is a port, all specified elements\n"
+ "of @var{uvec} are attempted to be written, potentially blocking\n"
+ "while waiting for more room.\n"
+ "When @var{port-or-fd} is an integer, a single call to\n"
+ "write(2) is made.\n\n"
+ "An error is signalled when the last element has only\n"
+ "been partially written in the single call to write(2).\n\n"
+ "The number of objects actually written is returned.\n"
+ "@var{port-or-fdes} may be\n"
+ "omitted, in which case it defaults to the value returned by\n"
+ "@code{(current-output-port)}.")
+#define FUNC_NAME s_scm_uniform_vector_write
+{
+ scm_t_array_handle handle;
+ size_t vlen, sz, ans;
+ ssize_t inc;
+ size_t cstart, cend;
+ size_t amount, off;
+ const char *base;
+
+ port_or_fd = SCM_COERCE_OUTPORT (port_or_fd);
+
+ if (SCM_UNBNDP (port_or_fd))
+ port_or_fd = scm_current_output_port ();
else
- scm_wrong_type_arg_msg (NULL, 0, uvec, "uniform vector");
-}
+ SCM_ASSERT (scm_is_integer (port_or_fd)
+ || (SCM_OPOUTPORTP (port_or_fd)),
+ port_or_fd, SCM_ARG2, FUNC_NAME);
-void
-scm_uniform_vector_release (SCM uvec)
-{
- /* Nothing to do right now, but this function might come in handy
- when uniform vectors need to be locked when giving away a pointer
- to their elements.
-
- Also, a call to scm_uniform_vector_release acts like
- scm_remember_upto_here, which is needed in any case.
- */
-}
+ base = scm_uniform_vector_elements (uvec, &handle, &vlen, &inc);
+ sz = scm_array_handle_uniform_element_size (&handle);
-void
-scm_frame_uniform_vector_release (SCM uvec)
-{
- scm_frame_unwind_handler_with_scm (scm_uniform_vector_release, uvec,
- SCM_F_WIND_EXPLICITLY);
-}
+ if (inc != 1)
+ {
+ /* XXX - we should of course support non contiguous vectors. */
+ scm_misc_error (NULL, "only contiguous vectors are supported: ~a",
+ scm_list_1 (uvec));
+ }
-size_t
-scm_uniform_vector_element_size (SCM uvec)
-{
- if (scm_is_uniform_vector (uvec))
- return uvec_sizes[SCM_UVEC_TYPE (uvec)];
- else
- scm_wrong_type_arg_msg (NULL, 0, uvec, "uniform vector");
-}
-
-/* return the size of an element in a uniform array or 0 if type not
- found. */
-size_t
-scm_uniform_element_size (SCM obj)
-{
- if (scm_is_uniform_vector (obj))
- return scm_uniform_vector_element_size (obj);
- else
- return 0;
-}
+ cstart = 0;
+ cend = vlen;
+ if (!SCM_UNBNDP (start))
+ {
+ cstart = scm_to_unsigned_integer (start, 0, vlen);
+ if (!SCM_UNBNDP (end))
+ cend = scm_to_unsigned_integer (end, cstart, vlen);
+ }
-SCM_DEFINE (scm_uniform_vector_length, "uniform-vector-length", 1, 0, 0,
- (SCM v),
- "Return the number of elements in the uniform vector @var{v}.")
-#define FUNC_NAME s_scm_uniform_vector_length
-{
- return scm_from_size_t (scm_c_uniform_vector_length (v));
+ amount = (cend - cstart) * sz;
+ off = cstart * sz;
+
+ if (SCM_NIMP (port_or_fd))
+ {
+ scm_lfwrite (base + off, amount, port_or_fd);
+ ans = cend - cstart;
+ }
+ else /* file descriptor. */
+ {
+ int fd = scm_to_int (port_or_fd), n;
+ SCM_SYSCALL (n = write (fd, base + off, amount));
+ if (n == -1)
+ SCM_SYSERROR;
+ if (n % sz != 0)
+ SCM_MISC_ERROR ("last element only written partially", SCM_EOL);
+ ans = n / sz;
+ }
+
+ scm_array_handle_release (&handle);
+
+ return scm_from_size_t (ans);
}
#undef FUNC_NAME
#define TYPE SCM_UVEC_U64
#define TAG u64
+#if SCM_HAVE_T_UINT64
#define CTYPE scm_t_uint64
+#endif
#include "libguile/srfi-4.i.c"
#define TYPE SCM_UVEC_S64
#define TAG s64
+#if SCM_HAVE_T_INT64
#define CTYPE scm_t_int64
+#endif
#include "libguile/srfi-4.i.c"
#define TYPE SCM_UVEC_F32
#define CTYPE double
#include "libguile/srfi-4.i.c"
-SCM scm_i_proc_make_u8vector;
-SCM scm_i_proc_make_s8vector;
-SCM scm_i_proc_make_u16vector;
-SCM scm_i_proc_make_s16vector;
-SCM scm_i_proc_make_u32vector;
-SCM scm_i_proc_make_s32vector;
-SCM scm_i_proc_make_u64vector;
-SCM scm_i_proc_make_s64vector;
-SCM scm_i_proc_make_f32vector;
-SCM scm_i_proc_make_f64vector;
-SCM scm_i_proc_make_c32vector;
-SCM scm_i_proc_make_c64vector;
-
-/* Create the smob type for homogeneous numeric vectors and install
- the primitives. */
+#define DEFINE_SCHEME_PROXY100(cname, modname, scmname) \
+ SCM cname (SCM arg1) \
+ { \
+ static SCM var = SCM_BOOL_F; \
+ if (scm_is_false (var)) \
+ var = scm_c_module_lookup (scm_c_resolve_module (modname), scmname); \
+ return scm_call_1 (SCM_VARIABLE_REF (var), arg1); \
+ }
+
+#define DEFPROXY100(cname, scmname) \
+ DEFINE_SCHEME_PROXY100 (cname, MOD, scmname)
+
+#define DEFINE_SRFI_4_GNU_PROXIES(tag) \
+ DEFPROXY100 (scm_any_to_##tag##vector, "any->" #tag "vector")
+
+#define MOD "srfi srfi-4 gnu"
+DEFINE_SRFI_4_GNU_PROXIES (u8);
+DEFINE_SRFI_4_GNU_PROXIES (s8);
+DEFINE_SRFI_4_GNU_PROXIES (u16);
+DEFINE_SRFI_4_GNU_PROXIES (s16);
+DEFINE_SRFI_4_GNU_PROXIES (u32);
+DEFINE_SRFI_4_GNU_PROXIES (s32);
+DEFINE_SRFI_4_GNU_PROXIES (u64);
+DEFINE_SRFI_4_GNU_PROXIES (s64);
+DEFINE_SRFI_4_GNU_PROXIES (f32);
+DEFINE_SRFI_4_GNU_PROXIES (f64);
+DEFINE_SRFI_4_GNU_PROXIES (c32);
+DEFINE_SRFI_4_GNU_PROXIES (c64);
+
+
+static scm_i_t_array_ref uvec_reffers[12] = {
+ u8ref, s8ref,
+ u16ref, s16ref,
+ u32ref, s32ref,
+ u64ref, s64ref,
+ f32ref, f64ref,
+ c32ref, c64ref
+};
+
+static scm_i_t_array_set uvec_setters[12] = {
+ u8set, s8set,
+ u16set, s16set,
+ u32set, s32set,
+ u64set, s64set,
+ f32set, f64set,
+ c32set, c64set
+};
+
+static SCM
+uvec_handle_ref (scm_t_array_handle *h, size_t index)
+{
+ return uvec_reffers [SCM_UVEC_TYPE(h->array)] (h, index);
+}
+
+static void
+uvec_handle_set (scm_t_array_handle *h, size_t index, SCM val)
+{
+ uvec_setters [SCM_UVEC_TYPE(h->array)] (h, index, val);
+}
+
+static void
+uvec_get_handle (SCM v, scm_t_array_handle *h)
+{
+ h->array = v;
+ h->ndims = 1;
+ h->dims = &h->dim0;
+ h->dim0.lbnd = 0;
+ h->dim0.ubnd = SCM_UVEC_LENGTH (v) - 1;
+ h->dim0.inc = 1;
+ h->element_type = SCM_UVEC_TYPE (v) + SCM_ARRAY_ELEMENT_TYPE_U8;
+ h->elements = h->writable_elements = SCM_UVEC_BASE (v);
+}
+
+SCM_ARRAY_IMPLEMENTATION (scm_tc16_uvec, 0xffff,
+ uvec_handle_ref, uvec_handle_set,
+ uvec_get_handle);
+
void
scm_init_srfi_4 (void)
{
scm_tc16_uvec = scm_make_smob_type ("uvec", 0);
scm_set_smob_equalp (scm_tc16_uvec, uvec_equalp);
- scm_set_smob_free (scm_tc16_uvec, uvec_free);
scm_set_smob_print (scm_tc16_uvec, uvec_print);
+
+#if SCM_HAVE_T_INT64 == 0
+ scm_uint64_min =
+ scm_permanent_object (scm_from_int (0));
+ scm_uint64_max =
+ scm_permanent_object (scm_c_read_string ("18446744073709551615"));
+ scm_int64_min =
+ scm_permanent_object (scm_c_read_string ("-9223372036854775808"));
+ scm_int64_max =
+ scm_permanent_object (scm_c_read_string ("9223372036854775807"));
+#endif
+
+#define REGISTER(tag, TAG) \
+ scm_i_register_vector_constructor \
+ (scm_i_array_element_types[SCM_ARRAY_ELEMENT_TYPE_##TAG], \
+ scm_make_##tag##vector)
+
+ REGISTER (u8, U8);
+ REGISTER (s8, S8);
+ REGISTER (u16, U16);
+ REGISTER (s16, S16);
+ REGISTER (u32, U32);
+ REGISTER (s32, S32);
+ REGISTER (u64, U64);
+ REGISTER (s64, S64);
+ REGISTER (f32, F32);
+ REGISTER (f64, F64);
+ REGISTER (c32, C32);
+ REGISTER (c64, C64);
+
#include "libguile/srfi-4.x"
-#define GETPROC(tag) \
- scm_i_proc_make_##tag##vector = \
- scm_variable_ref (scm_c_lookup ("make-"#tag"vector"))
-
- GETPROC (u8);
- GETPROC (s8);
- GETPROC (u16);
- GETPROC (s16);
- GETPROC (u32);
- GETPROC (s32);
- GETPROC (u64);
- GETPROC (s64);
- GETPROC (f32);
- GETPROC (f64);
- GETPROC (c32);
- GETPROC (c64);
}
/* End of srfi-4.c. */
HCoop / bpt / guile.git / blobdiff