-/* srfi-4.c --- Homogeneous numeric vector datatypes.
+/* srfi-4.c --- Uniform numeric vector datatypes.
*
* Copyright (C) 2001, 2004 Free Software Foundation, Inc.
*
*
* 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>
+#if 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/srfi-4.h"
#include "libguile/error.h"
#include "libguile/read.h"
#include "libguile/ports.h"
#include "libguile/chars.h"
+#include "libguile/vectors.h"
+#include "libguile/unif.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. */
+/* Mark hook. Only used when U64 and S64 are implemented as SCMs. */
+
+#if SCM_HAVE_T_INT64 == 0
+static SCM
+uvec_mark (SCM uvec)
+{
+ if (SCM_UVEC_TYPE (uvec) == SCM_UVEC_U64
+ || SCM_UVEC_TYPE (uvec) == SCM_UVEC_S64)
+ {
+ SCM *ptr = (SCM *)SCM_UVEC_BASE (uvec);
+ size_t len = SCM_UVEC_LENGTH (uvec), i;
+ for (i = 0; i < len; i++)
+ scm_gc_mark (*ptr++);
+ }
+ return SCM_BOOL_F;
+}
+#endif
+
+/* Smob free hook for uniform numeric vectors. */
static size_t
uvec_free (SCM uvec)
{
static SCM_C_INLINE 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
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)
{
- void *base = scm_gc_malloc (len * uvec_sizes[type], uvec_names[type]);
+ void *base;
+ 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);
}
*/
static SCM_C_INLINE SCM
-uvec_fast_ref (int type, void *base, size_t c_idx)
+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]);
else if (type == SCM_UVEC_C64)
return scm_c_make_rectangular (((double*)base)[2*c_idx],
((double*)base)[2*c_idx+1]);
+ else
+ return SCM_BOOL_F;
}
+#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 void
uvec_fast_set_x (int type, void *base, size_t c_idx, SCM val)
{
(((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
make_uvec (int type, SCM len, SCM fill)
{
- size_t c_len = scm_to_unsigned_integer (len, 0, SIZE_MAX / uvec_sizes[type]);
+ size_t c_len = scm_to_size_t (len);
SCM uvec = alloc_uvec (type, c_len);
if (!SCM_UNBNDP (fill))
{
return uvec;
}
+static SCM_C_INLINE void *
+uvec_writable_elements (int type, SCM uvec, scm_t_array_handle *handle,
+ size_t *lenp, ssize_t *incp)
+{
+ 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 const void *
+uvec_elements (int type, SCM uvec, scm_t_array_handle *handle,
+ size_t *lenp, ssize_t *incp)
+{
+ return uvec_writable_elements (type, uvec, handle, lenp, incp);
+}
+
+static int
+uvec_type (scm_t_array_handle *h)
+{
+ SCM v = h->array;
+ if (SCM_I_ARRAYP (v))
+ v = SCM_I_ARRAY_V (v);
+ return SCM_UVEC_TYPE (v);
+}
+
+static SCM
+uvec_to_list (int type, SCM uvec)
+{
+ scm_t_array_handle handle;
+ size_t len;
+ ssize_t i, inc;
+ const void *elts;
+ SCM res = SCM_EOL;
+
+ elts = uvec_elements (type, uvec, &handle, &len, &inc);
+ for (i = len*inc; i > 0;)
+ {
+ i -= inc;
+ res = scm_cons (scm_array_handle_ref (&handle, i), res);
+ }
+ scm_array_handle_release (&handle);
+ return res;
+}
+
static SCM_C_INLINE SCM
uvec_length (int type, SCM uvec)
{
- uvec_assert (type, uvec);
- return scm_from_size_t (SCM_UVEC_LENGTH (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 SCM
uvec_ref (int type, SCM uvec, SCM idx)
{
- size_t c_idx;
+ scm_t_array_handle handle;
+ size_t i, len;
+ ssize_t inc;
+ const void *elts;
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);
+ 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 SCM
uvec_set_x (int type, SCM uvec, SCM idx, SCM val)
{
- 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);
+ 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 SCM
-uvec_to_list (int type, SCM uvec)
-{
- size_t c_idx;
- void *base;
- 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);
- return res;
-}
-
static SCM_C_INLINE SCM
list_to_uvec (int type, SCM list)
{
return uvec;
}
-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
-};
+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))
+ {
+ scm_t_array_handle handle;
+ size_t len = scm_c_generalized_vector_length (obj), i;
+ SCM uvec = alloc_uvec (type, len);
+ scm_array_get_handle (uvec, &handle);
+ for (i = 0; i < len; i++)
+ scm_array_handle_set (&handle, i,
+ scm_c_generalized_vector_ref (obj, i));
+ scm_array_handle_release (&handle);
+ return uvec;
+ }
+ else
+ scm_wrong_type_arg_msg (NULL, 0, obj, "list or generalized vector");
+}
+
+SCM_SYMBOL (scm_sym_a, "a");
+SCM_SYMBOL (scm_sym_b, "b");
SCM
-scm_i_uniform_vector_creator (SCM uvec)
+scm_i_generalized_vector_type (SCM v)
{
- return *(uvec_proc_vars[SCM_UVEC_TYPE(uvec)]);
+ if (scm_is_vector (v))
+ return SCM_BOOL_T;
+ else if (scm_is_string (v))
+ return scm_sym_a;
+ else if (scm_is_bitvector (v))
+ return scm_sym_b;
+ else if (scm_is_uniform_vector (v))
+ return scm_from_locale_symbol (uvec_tags[SCM_UVEC_TYPE(v)]);
+ else
+ return SCM_BOOL_F;
}
int
scm_is_uniform_vector (SCM obj)
{
- return SCM_SMOB_PREDICATE (scm_tc16_uvec, obj);
+ if (SCM_IS_UVEC (obj))
+ return 1;
+ if (SCM_I_ARRAYP (obj) && SCM_I_ARRAY_NDIM (obj) == 1)
+ {
+ SCM v = SCM_I_ARRAY_V (obj);
+ return SCM_IS_UVEC (v);
+ }
+ return 0;
}
size_t
-scm_c_uniform_vector_length (SCM v)
+scm_c_uniform_vector_length (SCM uvec)
{
- if (scm_is_uniform_vector (v))
- return SCM_UVEC_LENGTH (v);
- else
- scm_wrong_type_arg_msg (NULL, 0, v, "uniform vector");
-}
+ /* scm_generalized_vector_get_handle will ultimately call us to get
+ the length of uniform vectors, so we can't use uvec_elements for
+ naked vectors.
+ */
-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)];
+ if (SCM_IS_UVEC (uvec))
+ return SCM_UVEC_LENGTH (uvec);
else
- scm_wrong_type_arg_msg (NULL, 0, v, "uniform vector");
+ {
+ scm_t_array_handle handle;
+ size_t len;
+ ssize_t inc;
+ uvec_elements (-1, uvec, &handle, &len, &inc);
+ scm_array_handle_release (&handle);
+ return len;
+ }
}
SCM_DEFINE (scm_uniform_vector_p, "uniform-vector?", 1, 0, 0,
}
#undef FUNC_NAME
+SCM
+scm_c_uniform_vector_ref (SCM v, size_t idx)
+{
+ scm_t_array_handle handle;
+ size_t len;
+ ssize_t inc;
+ SCM res;
+
+ uvec_elements (-1, v, &handle, &len, &inc);
+ if (idx >= len)
+ scm_out_of_range (NULL, scm_from_size_t (idx));
+ res = scm_array_handle_ref (&handle, idx*inc);
+ scm_array_handle_release (&handle);
+ return res;
+}
+
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
{
+#if SCM_ENABLE_DEPRECATED
/* Support old argument convention.
*/
if (scm_is_pair (idx))
{
+ scm_c_issue_deprecation_warning
+ ("Using a list as the index to uniform-vector-ref is deprecated.");
if (!scm_is_null (SCM_CDR (idx)))
scm_wrong_num_args (NULL);
idx = SCM_CAR (idx);
}
+#endif
- 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");
+ return scm_c_uniform_vector_ref (v, scm_to_size_t (idx));
}
#undef FUNC_NAME
+void
+scm_c_uniform_vector_set_x (SCM v, size_t idx, SCM val)
+{
+ scm_t_array_handle handle;
+ size_t len;
+ ssize_t inc;
+
+ uvec_writable_elements (-1, v, &handle, &len, &inc);
+ if (idx >= len)
+ scm_out_of_range (NULL, scm_from_size_t (idx));
+ scm_array_handle_set (&handle, idx*inc, val);
+ scm_array_handle_release (&handle);
+}
+
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
{
+#if SCM_ENABLE_DEPRECATED
/* Support old argument convention.
*/
if (scm_is_pair (idx))
{
+ scm_c_issue_deprecation_warning
+ ("Using a list as the index to uniform-vector-set! is deprecated.");
if (!scm_is_null (SCM_CDR (idx)))
scm_wrong_num_args (NULL);
idx = SCM_CAR (idx);
}
+#endif
- 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");
+ scm_c_uniform_vector_set_x (v, scm_to_size_t (idx), val);
+ return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
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_uniform_vector_to_list
+ "Convert the uniform 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");
+ return uvec_to_list (-1, uvec);
}
#undef FUNC_NAME
-void *
-scm_uniform_vector_elements (SCM uvec)
+size_t
+scm_array_handle_uniform_element_size (scm_t_array_handle *h)
+{
+ SCM vec = h->array;
+ if (SCM_I_ARRAYP (vec))
+ vec = SCM_I_ARRAY_V (vec);
+ if (scm_is_uniform_vector (vec))
+ return uvec_sizes[SCM_UVEC_TYPE(vec)];
+ scm_wrong_type_arg_msg (NULL, 0, h->array, "uniform array");
+}
+
+#if SCM_ENABLE_DEPRECATED
+
+/* 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 (uvec))
- return SCM_UVEC_BASE (uvec);
+ scm_c_issue_deprecation_warning
+ ("scm_uniform_element_size is deprecated. "
+ "Use scm_array_handle_uniform_element_size instead.");
+
+ if (SCM_IS_UVEC (obj))
+ return uvec_sizes[SCM_UVEC_TYPE(obj)];
else
- scm_wrong_type_arg_msg (NULL, 0, uvec, "uniform vector");
+ return 0;
}
-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 acts like
- scm_remember_upto_here, which is needed in any case.
- */
+#endif
+
+const void *
+scm_array_handle_uniform_elements (scm_t_array_handle *h)
+{
+ return scm_array_handle_uniform_writable_elements (h);
}
-size_t
-scm_uniform_vector_element_size (SCM uvec)
+void *
+scm_array_handle_uniform_writable_elements (scm_t_array_handle *h)
{
- if (scm_is_uniform_vector (uvec))
- return uvec_sizes[SCM_UVEC_TYPE (uvec)];
- else
- scm_wrong_type_arg_msg (NULL, 0, uvec, "uniform vector");
+ SCM vec = h->array;
+ if (SCM_I_ARRAYP (vec))
+ vec = SCM_I_ARRAY_V (vec);
+ if (SCM_IS_UVEC (vec))
+ {
+ size_t size = uvec_sizes[SCM_UVEC_TYPE(vec)];
+ char *elts = SCM_UVEC_BASE (vec);
+ return (void *) (elts + size*h->base);
+ }
+ scm_wrong_type_arg_msg (NULL, 0, h->array, "uniform array");
}
-
-/* return the size of an element in a uniform array or 0 if type not
- found. */
-size_t
-scm_uniform_element_size (SCM obj)
+
+const void *
+scm_uniform_vector_elements (SCM uvec,
+ scm_t_array_handle *h,
+ size_t *lenp, ssize_t *incp)
{
- size_t result;
+ return scm_uniform_vector_writable_elements (uvec, h, lenp, incp);
+}
- if (scm_is_uniform_vector (obj))
- return scm_uniform_vector_element_size (obj);
+void *
+scm_uniform_vector_writable_elements (SCM uvec,
+ scm_t_array_handle *h,
+ size_t *lenp, ssize_t *incp)
+{
+ scm_generalized_vector_get_handle (uvec, h);
+ if (lenp)
+ {
+ scm_t_array_dim *dim = scm_array_handle_dims (h);
+ *lenp = dim->ubnd - dim->lbnd + 1;
+ *incp = dim->inc;
+ }
+ return scm_array_handle_uniform_writable_elements (h);
+}
- switch (SCM_TYP7 (obj))
+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 uvec_length (-1, v);
+}
+#undef FUNC_NAME
+
+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;
+ void *base;
+
+ if (SCM_UNBNDP (port_or_fd))
+ port_or_fd = scm_current_input_port ();
+ else
+ SCM_ASSERT (scm_is_integer (port_or_fd)
+ || (SCM_OPINPORTP (port_or_fd)),
+ port_or_fd, SCM_ARG2, FUNC_NAME);
+
+ if (!scm_is_uniform_vector (uvec))
+ scm_wrong_type_arg_msg (NULL, 0, uvec, "uniform vector");
+
+ base = scm_uniform_vector_writable_elements (uvec, &handle, &vlen, &inc);
+ sz = scm_array_handle_uniform_element_size (&handle);
+
+ if (inc != 1)
{
- case scm_tc7_bvect:
- case scm_tc7_uvect:
- case scm_tc7_ivect:
- result = sizeof (long);
- break;
+ /* XXX - we should of course support non contiguous vectors. */
+ scm_misc_error (NULL, "only contiguous vectors are supported: ~a",
+ scm_list_1 (uvec));
+ }
- case scm_tc7_svect:
- result = sizeof (short);
- break;
+ 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);
+ }
-#if SCM_SIZEOF_LONG_LONG != 0
- case scm_tc7_llvect:
- result = sizeof (long long);
- break;
-#endif
+ remaining = (cend - cstart) * sz;
+ off = cstart * sz;
- case scm_tc7_fvect:
- result = sizeof (float);
- break;
+ if (SCM_NIMP (port_or_fd))
+ {
+ scm_t_port *pt = SCM_PTAB_ENTRY (port_or_fd);
- case scm_tc7_dvect:
- result = sizeof (double);
- break;
+ if (pt->rw_active == SCM_PORT_WRITE)
+ scm_flush (port_or_fd);
- case scm_tc7_cvect:
- result = 2 * sizeof (double);
- break;
+ ans = cend - cstart;
+ while (remaining > 0)
+ {
+ if (pt->read_pos < pt->read_end)
+ {
+ size_t to_copy = min (pt->read_end - pt->read_pos,
+ remaining);
+
+ memcpy (base + off, pt->read_pos, to_copy);
+ pt->read_pos += to_copy;
+ remaining -= to_copy;
+ off += to_copy;
+ }
+ else
+ {
+ if (scm_fill_input (port_or_fd) == EOF)
+ {
+ if (remaining % sz != 0)
+ SCM_MISC_ERROR ("unexpected EOF", SCM_EOL);
+ ans -= remaining / sz;
+ break;
+ }
+ }
+ }
- default:
- result = 0;
+ if (pt->rw_random)
+ pt->rw_active = SCM_PORT_READ;
}
- return result;
+ else /* file descriptor. */
+ {
+ 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;
+ }
+
+ scm_array_handle_release (&handle);
+
+ return scm_from_size_t (ans);
}
+#undef FUNC_NAME
-SCM_DEFINE (scm_uniform_vector_length, "uniform-vector-length", 1, 0, 0,
- (SCM v),
- "Return the number of elements in @var{uve}.")
-#define FUNC_NAME s_scm_uniform_vector_length
+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
{
- if (scm_is_uniform_vector (v))
- return scm_from_size_t (SCM_UVEC_LENGTH (v));
+ scm_t_array_handle handle;
+ size_t vlen, sz, ans;
+ ssize_t inc;
+ size_t cstart, cend;
+ size_t amount, off;
+ const void *base;
+
+ port_or_fd = SCM_COERCE_OUTPORT (port_or_fd);
- SCM_ASRTGO (SCM_NIMP (v), badarg1);
- switch SCM_TYP7 (v)
+ if (SCM_UNBNDP (port_or_fd))
+ port_or_fd = scm_current_output_port ();
+ else
+ SCM_ASSERT (scm_is_integer (port_or_fd)
+ || (SCM_OPOUTPORTP (port_or_fd)),
+ port_or_fd, SCM_ARG2, FUNC_NAME);
+
+ base = scm_uniform_vector_elements (uvec, &handle, &vlen, &inc);
+ sz = scm_array_handle_uniform_element_size (&handle);
+
+ if (inc != 1)
{
- default:
- badarg1:SCM_WRONG_TYPE_ARG (1, v);
- case scm_tc7_vector:
- case scm_tc7_wvect:
- return scm_from_size_t (SCM_VECTOR_LENGTH (v));
- case scm_tc7_string:
- return scm_from_size_t (scm_i_string_length (v));
- case scm_tc7_bvect:
- return scm_from_size_t (SCM_BITVECTOR_LENGTH (v));
- case scm_tc7_uvect:
- case scm_tc7_ivect:
- case scm_tc7_fvect:
- case scm_tc7_dvect:
- case scm_tc7_cvect:
- case scm_tc7_svect:
-#if SCM_SIZEOF_LONG_LONG != 0
- case scm_tc7_llvect:
-#endif
- return scm_from_size_t (SCM_UVECTOR_LENGTH (v));
+ /* XXX - we should of course support non contiguous vectors. */
+ scm_misc_error (NULL, "only contiguous vectors are supported: ~a",
+ scm_list_1 (uvec));
+ }
+
+ 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);
+ }
+
+ 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. */
+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
+};
+
+scm_i_t_array_ref
+scm_i_uniform_vector_ref_proc (SCM uvec)
+{
+ return uvec_reffers[SCM_UVEC_TYPE(uvec)];
+}
+
+scm_i_t_array_set
+scm_i_uniform_vector_set_proc (SCM uvec)
+{
+ return uvec_setters[SCM_UVEC_TYPE(uvec)];
+}
+
void
scm_init_srfi_4 (void)
{
scm_tc16_uvec = scm_make_smob_type ("uvec", 0);
scm_set_smob_equalp (scm_tc16_uvec, uvec_equalp);
+#if SCM_HAVE_T_INT64 == 0
+ scm_set_smob_mark (scm_tc16_uvec, uvec_mark);
+#endif
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
+
#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