-/* 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
*/
-#if HAVE_CONFIG_H
+#ifdef HAVE_CONFIG_H
# include <config.h>
#endif
#include "libguile/_scm.h"
#include "libguile/__scm.h"
#include "libguile/srfi-4.h"
+#include "libguile/bytevectors.h"
#include "libguile/error.h"
#include "libguile/read.h"
#include "libguile/ports.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>
#include <io.h>
#endif
-/* Smob type code for homogeneous numeric vectors. */
+/* 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))
}
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*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
+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 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);
- void *base = SCM_UVEC_BASE (uvec);
+ scm_array_get_handle (uvec, &handle);
for (i = 0; i < len; i++)
- uvec_fast_set_x (type, base, i, scm_c_generalized_vector_ref (obj, i));
+ scm_array_handle_set (&handle, i,
+ scm_c_generalized_vector_ref (obj, i));
+ scm_array_handle_release (&handle);
return uvec;
}
else
return scm_sym_b;
else if (scm_is_uniform_vector (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);
+ 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
-SCM
-scm_c_uniform_vector_ref (SCM v, size_t idx)
+void
+scm_c_uniform_vector_set_x (SCM v, size_t idx, SCM val)
{
- if (scm_is_uniform_vector (v))
- {
- 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));
- }
- else
- scm_wrong_type_arg_msg (NULL, 0, v, "uniform vector");
+ 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,
"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
-void
-scm_c_uniform_vector_set_x (SCM v, size_t idx, SCM val)
-{
- if (scm_is_uniform_vector (v))
- {
- 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));
- }
- 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.")
+ "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
-const void *
-scm_uniform_vector_elements (SCM uvec)
+size_t
+scm_array_handle_uniform_element_size (scm_t_array_handle *h)
{
- if (scm_is_uniform_vector (uvec))
- return SCM_UVEC_BASE (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_uniform_vector (vec))
+ return uvec_sizes[SCM_UVEC_TYPE(vec)];
+ if (scm_is_bytevector (vec))
+ return 1U;
+ scm_wrong_type_arg_msg (NULL, 0, h->array, "uniform array");
}
-void
-scm_uniform_vector_release_elements (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.
- */
-
- scm_remember_upto_here_1 (uvec);
-}
-
-void
-scm_frame_uniform_vector_release_elements (SCM uvec)
+#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)
{
- scm_frame_unwind_handler_with_scm (scm_uniform_vector_release_elements, uvec,
- SCM_F_WIND_EXPLICITLY);
-}
+ scm_c_issue_deprecation_warning
+ ("scm_uniform_element_size is deprecated. "
+ "Use scm_array_handle_uniform_element_size instead.");
-void *
-scm_uniform_vector_writable_elements (SCM uvec)
-{
- if (scm_is_uniform_vector (uvec))
- return SCM_UVEC_BASE (uvec);
+ 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_writable_elements (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.
- */
+#endif
- scm_remember_upto_here_1 (uvec);
+const void *
+scm_array_handle_uniform_elements (scm_t_array_handle *h)
+{
+ return scm_array_handle_uniform_writable_elements (h);
}
-void
-scm_frame_uniform_vector_release_writable_elements (SCM uvec)
+void *
+scm_array_handle_uniform_writable_elements (scm_t_array_handle *h)
{
- scm_frame_unwind_handler_with_scm
- (scm_uniform_vector_release_writable_elements, uvec,
- SCM_F_WIND_EXPLICITLY);
+ 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);
+ }
+ if (scm_is_bytevector (vec))
+ return SCM_BYTEVECTOR_CONTENTS (vec);
+ scm_wrong_type_arg_msg (NULL, 0, h->array, "uniform array");
}
-size_t
-scm_uniform_vector_element_size (SCM uvec)
+const void *
+scm_uniform_vector_elements (SCM uvec,
+ scm_t_array_handle *h,
+ size_t *lenp, ssize_t *incp)
{
- 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 scm_uniform_vector_writable_elements (uvec, h, lenp, incp);
}
-
-/* return the size of an element in a uniform array or 0 if type not
- found. */
-size_t
-scm_uniform_element_size (SCM obj)
+
+void *
+scm_uniform_vector_writable_elements (SCM uvec,
+ scm_t_array_handle *h,
+ size_t *lenp, ssize_t *incp)
{
- if (scm_is_uniform_vector (obj))
- return scm_uniform_vector_element_size (obj);
- else
- return 0;
+ 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);
}
SCM_DEFINE (scm_uniform_vector_length, "uniform-vector-length", 1, 0, 0,
"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));
+ return uvec_length (-1, v);
}
#undef FUNC_NAME
"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-array-read!} returns the number of elements read.\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;
+ char *base;
if (SCM_UNBNDP (port_or_fd))
- port_or_fd = scm_cur_inp;
+ 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);
-
- scm_frame_begin (0);
+ if (!scm_is_uniform_vector (uvec))
+ scm_wrong_type_arg_msg (NULL, 0, uvec, "uniform vector");
- vlen = scm_c_uniform_vector_length (uvec);
- sz = scm_uniform_vector_element_size (uvec);
- base = scm_uniform_vector_writable_elements (uvec);
- scm_frame_uniform_vector_release_writable_elements (uvec);
+ base = scm_uniform_vector_writable_elements (uvec, &handle, &vlen, &inc);
+ sz = scm_array_handle_uniform_element_size (&handle);
+
+ 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));
+ }
cstart = 0;
cend = vlen;
if (SCM_NIMP (port_or_fd))
{
- scm_t_port *pt = SCM_PTAB_ENTRY (port_or_fd);
-
- if (pt->rw_active == SCM_PORT_WRITE)
- scm_flush (port_or_fd);
-
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;
- }
- }
- }
-
- if (pt->rw_random)
- pt->rw_active = SCM_PORT_READ;
+ remaining -= scm_c_read (port_or_fd, base + off, remaining);
+ if (remaining % sz != 0)
+ SCM_MISC_ERROR ("unexpected EOF", SCM_EOL);
+ ans -= remaining / sz;
}
else /* file descriptor. */
{
ans = n / sz;
}
- scm_frame_end ();
+ scm_array_handle_release (&handle);
return scm_from_size_t (ans);
}
"@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 void *base;
+ const char *base;
port_or_fd = SCM_COERCE_OUTPORT (port_or_fd);
if (SCM_UNBNDP (port_or_fd))
- port_or_fd = scm_cur_outp;
+ 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);
- scm_frame_begin (0);
+ base = scm_uniform_vector_elements (uvec, &handle, &vlen, &inc);
+ sz = scm_array_handle_uniform_element_size (&handle);
- vlen = scm_c_generalized_vector_length (uvec);
- sz = scm_uniform_vector_element_size (uvec);
- base = scm_uniform_vector_elements (uvec);
- scm_frame_uniform_vector_release_elements (uvec);
+ 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));
+ }
cstart = 0;
cend = vlen;
ans = n / sz;
}
- scm_frame_end ();
+ scm_array_handle_release (&handle);
return scm_from_size_t (ans);
}
#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"
+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);
- 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"
}