summaryrefslogtreecommitdiff
path: root/libguile/srfi-4.c
diff options
context:
space:
mode:
authorMarius Vollmer <mvo@zagadka.de>2004-10-27 18:11:14 +0000
committerMarius Vollmer <mvo@zagadka.de>2004-10-27 18:11:14 +0000
commite0e496707beaea694fa79b4ca291dbc67abdc328 (patch)
tree09f5aaaf339b1824d8058e36804b95eb9bdbaa51 /libguile/srfi-4.c
parent7b1574ed4fe3a2b2ffa0e13a82e8cdaf6f66ef6a (diff)
downloadguile-e0e496707beaea694fa79b4ca291dbc67abdc328.tar.gz
* srfi-4.h, srfi-4.i.c (scm_u8vector_elements, etc): New.
* srfi-4.h, srfi-4.c (scm_uniform_vector_p, scm_uniform_vector_ref, scm_uniform_vector_set_x, scm_uniform_vector_to_list, scm_is_uniform_vector, scm_c_uniform_vector_lengths, scm_c_uniform_vector_size, scm_uniform_vector_elements, scm_uniform_vector_element_size, scm_uniform_vector_release): New. (scm_i_uniform_vector_prototype, scm_i_uniform_vector_tag): New. (scm_uniform_element_size, scm_uniform_vector_length): Moved here from unif.h, unif.c and extended to handle both the old and new uniform vectors. * unif.h, unif.c (scm_uniform_vector_ref, scm_array_ref): Renamed the former to the latter. (scm_uniform_vector_length, scm_uniform_element_size): Moved to srfi-4.h, srfi-4.c. (scm_make_uve): Call scm_make_s8vector for #\nul prototype. (scm_array_p, scm_array_rank, scm_array_dimensions, scm_transpose_array, scm_enclose_array, scm_array_ref, scm_cvref, scm_array_set_x, scm_array_contents, scm_uniform_array_read_x, scm_array_to_list, scm_array_prototype): Handle srfi-4 uniform vectors. Removed code for scm_tc7_byvect. (scm_dimensions_to_uniform_array): Fill array with 0 when prototype is #\nul. (scm_i_print_array_dimension, scm_i_legacy_tag, scm_i_print_array): New. (scm_raprin1): Call scm_i_print_array for arrays. Removed code for scm_tc7_byvect.
Diffstat (limited to 'libguile/srfi-4.c')
-rw-r--r--libguile/srfi-4.c313
1 files changed, 281 insertions, 32 deletions
diff --git a/libguile/srfi-4.c b/libguile/srfi-4.c
index a598442a6..07b33ded9 100644
--- a/libguile/srfi-4.c
+++ b/libguile/srfi-4.c
@@ -65,6 +65,14 @@ static const int uvec_sizes[10] = {
sizeof(float), sizeof(double)
};
+static const char *uvec_tags[10] = {
+ "u8", "s8",
+ "u16", "s16",
+ "u32", "s32",
+ "u64", "s64",
+ "f32", "f64"
+};
+
static const char *uvec_names[10] = {
"u8vector", "s8vector",
"u16vector", "s16vector",
@@ -99,30 +107,29 @@ uvec_print (SCM uvec, SCM port, scm_print_state *pstate)
size_t i = 0;
const size_t uvlen = SCM_UVEC_LENGTH (uvec);
- char *tagstr;
void *uptr = SCM_UVEC_BASE (uvec);
switch (SCM_UVEC_TYPE (uvec))
{
- case SCM_UVEC_U8: tagstr = "u8"; np.u8 = (scm_t_uint8 *) uptr; break;
- case SCM_UVEC_S8: tagstr = "s8"; np.s8 = (scm_t_int8 *) uptr; break;
- case SCM_UVEC_U16: tagstr = "u16"; np.u16 = (scm_t_uint16 *) uptr; break;
- case SCM_UVEC_S16: tagstr = "s16"; np.s16 = (scm_t_int16 *) uptr; break;
- case SCM_UVEC_U32: tagstr = "u32"; np.u32 = (scm_t_uint32 *) uptr; break;
- case SCM_UVEC_S32: tagstr = "s32"; np.s32 = (scm_t_int32 *) uptr; break;
+ case SCM_UVEC_U8: np.u8 = (scm_t_uint8 *) uptr; break;
+ case SCM_UVEC_S8: np.s8 = (scm_t_int8 *) uptr; break;
+ case SCM_UVEC_U16: np.u16 = (scm_t_uint16 *) uptr; break;
+ case SCM_UVEC_S16: np.s16 = (scm_t_int16 *) uptr; break;
+ case SCM_UVEC_U32: np.u32 = (scm_t_uint32 *) uptr; break;
+ case SCM_UVEC_S32: np.s32 = (scm_t_int32 *) uptr; break;
#if SCM_HAVE_T_INT64
- case SCM_UVEC_U64: tagstr = "u64"; np.u64 = (scm_t_uint64 *) uptr; break;
- case SCM_UVEC_S64: tagstr = "s64"; np.s64 = (scm_t_int64 *) uptr; break;
+ case SCM_UVEC_U64: np.u64 = (scm_t_uint64 *) uptr; break;
+ case SCM_UVEC_S64: np.s64 = (scm_t_int64 *) uptr; break;
#endif
- case SCM_UVEC_F32: tagstr = "f32"; np.f32 = (float *) uptr; break;
- case SCM_UVEC_F64: tagstr = "f64"; np.f64 = (double *) uptr; break;
+ case SCM_UVEC_F32: np.f32 = (float *) uptr; break;
+ case SCM_UVEC_F64: np.f64 = (double *) uptr; break;
default:
abort (); /* Sanity check. */
break;
}
scm_putc ('#', port);
- scm_puts (tagstr, port);
+ scm_puts (uvec_tags [SCM_UVEC_TYPE (uvec)], port);
scm_putc ('(', port);
while (i < uvlen)
@@ -153,6 +160,12 @@ uvec_print (SCM uvec, SCM port, scm_print_state *pstate)
return 1;
}
+const char *
+scm_i_uniform_vector_tag (SCM uvec)
+{
+ return uvec_tags[SCM_UVEC_TYPE (uvec)];
+}
+
static SCM
uvec_equalp (SCM a, SCM b)
{
@@ -426,48 +439,284 @@ scm_i_read_homogenous_vector (SCM port, char pfx)
return SCM_BOOL_F;
}
+SCM
+scm_i_uniform_vector_prototype (SCM uvec)
+{
+ switch (SCM_UVEC_TYPE (uvec))
+ {
+ case SCM_UVEC_U8:
+ return SCM_BOOL_F;
+ case SCM_UVEC_S8:
+ return SCM_MAKE_CHAR ('\0');
+ case SCM_UVEC_U16:
+ return SCM_BOOL_F;
+ case SCM_UVEC_S16:
+ return SCM_BOOL_F;
+ case SCM_UVEC_U32:
+ return SCM_BOOL_F;
+ case SCM_UVEC_S32:
+ return SCM_BOOL_F;
+ case SCM_UVEC_U64:
+ return SCM_BOOL_F;
+ case SCM_UVEC_S64:
+ return SCM_BOOL_F;
+ case SCM_UVEC_F32:
+ return SCM_BOOL_F;
+ case SCM_UVEC_F64:
+ return SCM_BOOL_F;
+ default:
+ 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);
+ else
+ scm_wrong_type_arg_msg (NULL, 0, v, "uniform vector");
+}
+
+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");
+}
+
+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
+
+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 (!scm_is_null (SCM_CDR (idx)))
+ scm_wrong_num_args (NULL);
+ idx = SCM_CAR (idx);
+ }
+
+ 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_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))
+ {
+ if (!scm_is_null (SCM_CDR (idx)))
+ scm_wrong_num_args (NULL);
+ idx = SCM_CAR (idx);
+ }
+
+ 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
+
+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
+{
+ 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");
+}
+#undef FUNC_NAME
+
+void *
+scm_uniform_vector_elements (SCM uvec)
+{
+ if (scm_is_uniform_vector (uvec))
+ return SCM_UVEC_BASE (uvec);
+ else
+ scm_wrong_type_arg_msg (NULL, 0, uvec, "uniform vector");
+}
+
+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.
+ */
+}
+
+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)
+{
+ size_t result;
+
+ if (scm_is_uniform_vector (obj))
+ return scm_uniform_vector_element_size (obj);
+
+ switch (SCM_TYP7 (obj))
+ {
+ case scm_tc7_bvect:
+ case scm_tc7_uvect:
+ case scm_tc7_ivect:
+ result = sizeof (long);
+ break;
+
+ case scm_tc7_svect:
+ result = sizeof (short);
+ break;
+
+#if SCM_SIZEOF_LONG_LONG != 0
+ case scm_tc7_llvect:
+ result = sizeof (long long);
+ break;
+#endif
+
+ case scm_tc7_fvect:
+ result = sizeof (float);
+ break;
+
+ case scm_tc7_dvect:
+ result = sizeof (double);
+ break;
+
+ case scm_tc7_cvect:
+ result = 2 * sizeof (double);
+ break;
+
+ default:
+ result = 0;
+ }
+ return result;
+}
+
+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
+{
+ if (scm_is_uniform_vector (v))
+ return scm_from_size_t (SCM_UVEC_LENGTH (v));
+
+ SCM_ASRTGO (SCM_NIMP (v), badarg1);
+ switch SCM_TYP7 (v)
+ {
+ 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));
+ }
+}
+#undef FUNC_NAME
+
/* ================================================================ */
/* Exported procedures. */
/* ================================================================ */
-#define TYPE SCM_UVEC_U8
-#define TAG u8
+#define TYPE SCM_UVEC_U8
+#define TAG u8
+#define CTYPE scm_t_uint8
#include "libguile/srfi-4.i.c"
-#define TYPE SCM_UVEC_S8
-#define TAG s8
+#define TYPE SCM_UVEC_S8
+#define TAG s8
+#define CTYPE scm_t_int8
#include "libguile/srfi-4.i.c"
-#define TYPE SCM_UVEC_U16
-#define TAG u16
+#define TYPE SCM_UVEC_U16
+#define TAG u16
+#define CTYPE scm_t_uint16
#include "libguile/srfi-4.i.c"
-#define TYPE SCM_UVEC_S16
-#define TAG s16
+#define TYPE SCM_UVEC_S16
+#define TAG s16
+#define CTYPE scm_t_int16
#include "libguile/srfi-4.i.c"
-#define TYPE SCM_UVEC_U32
-#define TAG u32
+#define TYPE SCM_UVEC_U32
+#define TAG u32
+#define CTYPE scm_t_uint32
#include "libguile/srfi-4.i.c"
-#define TYPE SCM_UVEC_S32
-#define TAG s32
+#define TYPE SCM_UVEC_S32
+#define TAG s32
+#define CTYPE scm_t_int32
#include "libguile/srfi-4.i.c"
-#define TYPE SCM_UVEC_U64
-#define TAG u64
+#define TYPE SCM_UVEC_U64
+#define TAG u64
+#define CTYPE scm_t_uint64
#include "libguile/srfi-4.i.c"
-#define TYPE SCM_UVEC_S64
-#define TAG s64
+#define TYPE SCM_UVEC_S64
+#define TAG s64
+#define CTYPE scm_t_int64
#include "libguile/srfi-4.i.c"
-#define TYPE SCM_UVEC_F32
-#define TAG f32
+#define TYPE SCM_UVEC_F32
+#define TAG f32
+#define CTYPE float
#include "libguile/srfi-4.i.c"
-#define TYPE SCM_UVEC_F64
-#define TAG f64
+#define TYPE SCM_UVEC_F64
+#define TAG f64
+#define CTYPE double
#include "libguile/srfi-4.i.c"