-/* 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 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
*
* 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
#include "libguile/vectors.h"
#include "libguile/unif.h"
#include "libguile/strings.h"
+#include "libguile/strports.h"
#include "libguile/dynwind.h"
#include "libguile/deprecation.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. */
+/* 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)
{
{
if (SCM_IS_UVEC (obj))
return SCM_UVEC_TYPE (obj) == type;
- if (SCM_ARRAYP (obj) && SCM_ARRAY_NDIM (obj) == 1)
+ if (SCM_I_ARRAYP (obj) && SCM_I_ARRAY_NDIM (obj) == 1)
{
- SCM v = SCM_ARRAY_V (obj);
+ SCM v = SCM_I_ARRAY_V (obj);
return SCM_IS_UVEC (v) && SCM_UVEC_TYPE (v) == type;
}
return 0;
}
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);
}
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;
}
+#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);
if (type >= 0)
{
SCM v = uvec;
- if (SCM_ARRAYP (v))
- v = SCM_ARRAY_V (v);
+ if (SCM_I_ARRAYP (v))
+ v = SCM_I_ARRAY_V (v);
uvec_assert (type, v);
}
uvec_type (scm_t_array_handle *h)
{
SCM v = h->array;
- if (SCM_ARRAYP (v))
- v = SCM_ARRAY_V (v);
+ if (SCM_I_ARRAYP (v))
+ v = SCM_I_ARRAY_V (v);
return SCM_UVEC_TYPE (v);
}
SCM res = SCM_EOL;
elts = uvec_elements (type, uvec, &handle, &len, &inc);
- if (type < 0)
- type = uvec_type (&handle);
for (i = len*inc; i > 0;)
{
i -= inc;
- res = scm_cons (uvec_fast_ref (type, elts, i), res);
+ res = scm_cons (scm_array_handle_ref (&handle, i), res);
}
scm_array_handle_release (&handle);
return res;
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
{
if (SCM_IS_UVEC (obj))
return 1;
- if (SCM_ARRAYP (obj) && SCM_ARRAY_NDIM (obj) == 1)
+ if (SCM_I_ARRAYP (obj) && SCM_I_ARRAY_NDIM (obj) == 1)
{
- SCM v = SCM_ARRAY_V (obj);
+ SCM v = SCM_I_ARRAY_V (obj);
return SCM_IS_UVEC (v);
}
return 0;
scm_c_uniform_vector_ref (SCM v, size_t idx)
{
scm_t_array_handle handle;
- const void *elts;
size_t len;
ssize_t inc;
SCM res;
- int type;
- elts = uvec_elements (-1, v, &handle, &len, &inc);
- type = uvec_type (&handle);
+ uvec_elements (-1, v, &handle, &len, &inc);
if (idx >= len)
scm_out_of_range (NULL, scm_from_size_t (idx));
- res = uvec_fast_ref (type, elts, idx*inc);
+ res = scm_array_handle_ref (&handle, idx*inc);
scm_array_handle_release (&handle);
return res;
}
scm_c_uniform_vector_set_x (SCM v, size_t idx, SCM val)
{
scm_t_array_handle handle;
- void *elts;
size_t len;
ssize_t inc;
- int type;
- elts = uvec_writable_elements (-1, v, &handle, &len, &inc);
- type = uvec_type (&handle);
+ uvec_writable_elements (-1, v, &handle, &len, &inc);
if (idx >= len)
scm_out_of_range (NULL, scm_from_size_t (idx));
- uvec_fast_set_x (type, elts, idx*inc, val);
+ scm_array_handle_set (&handle, idx*inc, val);
scm_array_handle_release (&handle);
}
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
{
return uvec_to_list (-1, uvec);
scm_array_handle_uniform_element_size (scm_t_array_handle *h)
{
SCM vec = h->array;
- if (SCM_ARRAYP (vec))
- vec = SCM_ARRAY_V (vec);
+ 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)
{
+ 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
return 0;
}
+#endif
+
const void *
scm_array_handle_uniform_elements (scm_t_array_handle *h)
{
scm_array_handle_uniform_writable_elements (scm_t_array_handle *h)
{
SCM vec = h->array;
- if (SCM_ARRAYP (vec))
- vec = SCM_ARRAY_V (vec);
+ 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)];
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)),
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)),
#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);
+#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"
}
HCoop / bpt / guile.git / blobdiff