diff options
author | Marius Vollmer <mvo@zagadka.de> | 2004-10-26 17:01:35 +0000 |
---|---|---|
committer | Marius Vollmer <mvo@zagadka.de> | 2004-10-26 17:01:35 +0000 |
commit | 0d0f372f5b67914d11ec986338f15ea1e8b658b4 (patch) | |
tree | 1a0b7668e495ab9bbcd6828d19a9b948438be06d | |
parent | a4022e691e12857b9c836c4bdc5b31462b73c1b2 (diff) | |
download | guile-0d0f372f5b67914d11ec986338f15ea1e8b658b4.tar.gz |
Moved content into core; only the skeletons remains.
-rw-r--r-- | srfi/srfi-4.c | 1757 | ||||
-rw-r--r-- | srfi/srfi-4.h | 110 | ||||
-rw-r--r-- | srfi/srfi-4.scm | 122 |
3 files changed, 18 insertions, 1971 deletions
diff --git a/srfi/srfi-4.c b/srfi/srfi-4.c index 96f487e0f..d71c061eb 100644 --- a/srfi/srfi-4.c +++ b/srfi/srfi-4.c @@ -17,1763 +17,16 @@ * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA */ -#include <libguile.h> +/* This file is now empty since all its procedures are now in the + core. We keep the libguile-srfi-srfi-4.so library around anyway + since people might still be linking with it. +*/ -#include "srfi-4.h" +#include "srfi/srfi-4.h" - -/* For brevity and maintainability, we define our own types for the - various integer and floating point types. */ -typedef scm_t_uint8 int_u8; -typedef scm_t_int8 int_s8; -typedef scm_t_uint16 int_u16; -typedef scm_t_int16 int_s16; -typedef scm_t_uint32 int_u32; -typedef scm_t_int32 int_s32; - -#if SCM_HAVE_T_UINT64 -typedef scm_t_uint64 int_u64; -#endif /* SCM_HAVE_T_UINT64 */ - -#if SCM_HAVE_T_INT64 -typedef scm_t_int64 int_s64; -#endif /* SCM_HAVE_T_INT64 */ - -typedef float float_f32; -typedef double float_f64; - - -/* Smob type code for homogeneous numeric vectors. */ -int scm_tc16_uvec = 0; - - -/* Accessor macros for the three components of a homogeneous numeric - vector: - - The type tag (one of the symbolic constants below). - - The vector's length (counted in elements). - - The address of the data area (holding the elements of the - vector). */ -#define SCM_UVEC_TYPE(u) (SCM_CELL_WORD_1(u)) -#define SCM_UVEC_LENGTH(u) (SCM_CELL_WORD_2(u)) -#define SCM_UVEC_BASE(u) (SCM_CELL_OBJECT_3(u)) - - -/* Symbolic constants encoding the various types of homogeneous - numeric vectors. */ -#define SCM_UVEC_U8 0 -#define SCM_UVEC_S8 1 -#define SCM_UVEC_U16 2 -#define SCM_UVEC_S16 3 -#define SCM_UVEC_U32 4 -#define SCM_UVEC_S32 5 -#define SCM_UVEC_U64 6 -#define SCM_UVEC_S64 7 -#define SCM_UVEC_F32 8 -#define SCM_UVEC_F64 9 - - -/* This array maps type tags to the size of the elements. */ -static const int uvec_sizes[10] = {1, 1, 2, 2, 4, 4, 8, 8, 4, 8}; - - -/* ================================================================ */ -/* SMOB procedures. */ -/* ================================================================ */ - - -/* Smob print hook for homogeneous vectors. */ -static int -uvec_print (SCM uvec, SCM port, scm_print_state *pstate) -{ - union { - int_u8 *u8; - int_s8 *s8; - int_u16 *u16; - int_s16 *s16; - int_u32 *u32; - int_s32 *s32; -#if SCM_HAVE_T_INT64 - int_u64 *u64; - int_s64 *s64; -#endif - float_f32 *f32; - float_f64 *f64; - } np; - - 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 = (int_u8 *) uptr; break; - case SCM_UVEC_S8: tagstr = "s8"; np.s8 = (int_s8 *) uptr; break; - case SCM_UVEC_U16: tagstr = "u16"; np.u16 = (int_u16 *) uptr; break; - case SCM_UVEC_S16: tagstr = "s16"; np.s16 = (int_s16 *) uptr; break; - case SCM_UVEC_U32: tagstr = "u32"; np.u32 = (int_u32 *) uptr; break; - case SCM_UVEC_S32: tagstr = "s32"; np.s32 = (int_s32 *) uptr; break; -#if SCM_HAVE_T_INT64 - case SCM_UVEC_U64: tagstr = "u64"; np.u64 = (int_u64 *) uptr; break; - case SCM_UVEC_S64: tagstr = "s64"; np.s64 = (int_s64 *) uptr; break; -#endif - case SCM_UVEC_F32: tagstr = "f32"; np.f32 = (float_f32 *) uptr; break; - case SCM_UVEC_F64: tagstr = "f64"; np.f64 = (float_f64 *) uptr; break; - default: - abort (); /* Sanity check. */ - break; - } - - scm_putc ('#', port); - scm_puts (tagstr, port); - scm_putc ('(', port); - - while (i < uvlen) - { - if (i != 0) scm_puts (" ", port); - switch (SCM_UVEC_TYPE (uvec)) - { - case SCM_UVEC_U8: scm_uintprint (*np.u8, 10, port); np.u8++; break; - case SCM_UVEC_S8: scm_intprint (*np.s8, 10, port); np.s8++; break; - case SCM_UVEC_U16: scm_uintprint (*np.u16, 10, port); np.u16++; break; - case SCM_UVEC_S16: scm_intprint (*np.s16, 10, port); np.s16++; break; - case SCM_UVEC_U32: scm_uintprint (*np.u32, 10, port); np.u32++; break; - case SCM_UVEC_S32: scm_intprint (*np.s32, 10, port); np.s32++; 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; -#endif - case SCM_UVEC_F32: - scm_iprin1 (scm_from_double (*np.f32), port, pstate); - np.f32++; - break; - case SCM_UVEC_F64: - scm_iprin1 (scm_from_double (*np.f64), port, pstate); - np.f64++; - break; - default: - abort (); /* Sanity check. */ - break; - } - i++; - } - scm_remember_upto_here_1 (uvec); - scm_puts (")", port); - return 1; -} - - -/* Smob free hook for homogeneous numeric vectors. */ -static size_t -uvec_free (SCM uvec) -{ - scm_gc_free (SCM_UVEC_BASE (uvec), - SCM_UVEC_LENGTH (uvec) * uvec_sizes[SCM_UVEC_TYPE (uvec)], - "uvec"); - return 0; -} - - -/* ================================================================ */ -/* Utility procedures. */ -/* ================================================================ */ - - -/* Create a new, uninitialized homogeneous numeric vector of type TYPE - with space for LEN elements. */ -static SCM -make_uvec (const char * func_name, int type, int len) -{ - void * p; - - p = scm_gc_malloc (len * uvec_sizes[type], "uvec"); - SCM_RETURN_NEWSMOB3 (scm_tc16_uvec, type, len, p); -} - - -/* ================================================================ */ -/* U8 procedures. */ -/* ================================================================ */ - - -SCM_DEFINE (scm_u8vector_p, "u8vector?", 1, 0, 0, - (SCM obj), - "Return @code{#t} if @var{obj} is a vector of type u8,\n" - "@code{#f} otherwise.") -#define FUNC_NAME s_scm_u8vector_p -{ - return scm_from_bool (SCM_SMOB_PREDICATE (scm_tc16_uvec, obj) && - SCM_UVEC_TYPE (obj) == SCM_UVEC_U8); -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_make_u8vector, "make-u8vector", 1, 1, 0, - (SCM len, SCM fill), - "Create a newly allocated homogeneous numeric vector which can\n" - "hold @var{len} elements. If @var{fill} is given, it is used to\n" - "initialize the elements, otherwise the contents of the vector\n" - "is unspecified.") -#define FUNC_NAME s_scm_make_u8vector -{ - SCM uvec; - int_u8 * p; - int_u8 f; - size_t count; - - count = scm_to_size_t (len); - uvec = make_uvec (FUNC_NAME, SCM_UVEC_U8, count); - if (SCM_UNBNDP (fill)) - f = 0; - else - f = scm_to_uint8 (fill); - p = (int_u8 *) SCM_UVEC_BASE (uvec); - while (count-- > 0) - *p++ = f; - return uvec; -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_u8vector, "u8vector", 0, 0, 1, - (SCM l), - "Create a newly allocated homogeneous numeric vector containing\n" - "all argument values.") -#define FUNC_NAME s_scm_u8vector -{ - SCM_VALIDATE_REST_ARGUMENT (l); - return scm_list_to_u8vector (l); -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_u8vector_length, "u8vector-length", 1, 0, 0, - (SCM uvec), - "Return the number of elements in the homogeneous numeric vector\n" - "@var{uvec}.") -#define FUNC_NAME s_scm_u8vector_length -{ - SCM_VALIDATE_SMOB (1, uvec, uvec); - if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_U8) - scm_wrong_type_arg (FUNC_NAME, 1, uvec); - return scm_from_size_t (SCM_UVEC_LENGTH (uvec)); -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_u8vector_ref, "u8vector-ref", 2, 0, 0, - (SCM uvec, SCM index), - "Return the element at @var{index} in the homogeneous numeric\n" - "vector @var{uvec}.") -#define FUNC_NAME s_scm_u8vector_ref -{ - int idx; - - SCM_VALIDATE_SMOB (1, uvec, uvec); - if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_U8) - scm_wrong_type_arg (FUNC_NAME, 1, uvec); - - idx = scm_to_unsigned_integer (index, 0, SCM_UVEC_LENGTH (uvec)-1); - return scm_from_uint8 (((int_u8 *) SCM_UVEC_BASE (uvec))[idx]); -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_u8vector_set_x, "u8vector-set!", 3, 0, 0, - (SCM uvec, SCM index, SCM value), - "Set the element at @var{index} in the homogeneous numeric\n" - "vector @var{uvec} to @var{value}. The return value is not\n" - "specified.") -#define FUNC_NAME s_scm_u8vector_ref -{ - int idx; - - SCM_VALIDATE_SMOB (1, uvec, uvec); - if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_U8) - scm_wrong_type_arg (FUNC_NAME, 1, uvec); - - idx = scm_to_unsigned_integer (index, 0, SCM_UVEC_LENGTH (uvec)-1); - ((int_u8 *) SCM_UVEC_BASE (uvec))[idx] = scm_to_uint8 (value); - return SCM_UNSPECIFIED; -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_u8vector_to_list, "u8vector->list", 1, 0, 0, - (SCM uvec), - "Convert the homogeneous numeric vector @var{uvec} to a list.") -#define FUNC_NAME s_scm_u8vector_to_list -{ - int idx; - int_u8 * p; - SCM res = SCM_EOL; - - SCM_VALIDATE_SMOB (1, uvec, uvec); - if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_U8) - scm_wrong_type_arg (FUNC_NAME, 1, uvec); - - idx = SCM_UVEC_LENGTH (uvec); - p = (int_u8 *) SCM_UVEC_BASE (uvec) + idx; - while (idx-- > 0) - { - p--; - res = scm_cons (scm_from_uint8 (*p), res); - } - return res; -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_list_to_u8vector, "list->u8vector", 1, 0, 0, - (SCM l), - "Convert the list @var{l}, which must only contain unsigned\n" - "8-bit values, to a numeric homogeneous vector.") -#define FUNC_NAME s_scm_list_to_u8vector -{ - SCM uvec; - int_u8 * p; - int n; - - SCM_VALIDATE_LIST_COPYLEN (1, l, n); - - uvec = make_uvec (FUNC_NAME, SCM_UVEC_U8, n); - p = (int_u8 *) SCM_UVEC_BASE (uvec); - while (SCM_CONSP (l)) - { - *p++ = scm_to_uint8 (SCM_CAR (l)); - l = SCM_CDR (l); - } - return uvec; -} -#undef FUNC_NAME - - -/* ================================================================ */ -/* S8 procedures. */ -/* ================================================================ */ - - -SCM_DEFINE (scm_s8vector_p, "s8vector?", 1, 0, 0, - (SCM obj), - "Return @code{#t} if @var{obj} is a vector of type s8,\n" - "@code{#f} otherwise.") -#define FUNC_NAME s_scm_s8vector_p -{ - return scm_from_bool (SCM_SMOB_PREDICATE (scm_tc16_uvec, obj) && - SCM_UVEC_TYPE (obj) == SCM_UVEC_S8); -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_make_s8vector, "make-s8vector", 1, 1, 0, - (SCM len, SCM fill), - "Create a newly allocated homogeneous numeric vector which can\n" - "hold @var{len} elements. If @var{fill} is given, it is used to\n" - "initialize the elements, otherwise the contents of the vector\n" - "is unspecified.") -#define FUNC_NAME s_scm_make_s8vector -{ - SCM uvec; - int_s8 * p; - int_s8 f; - size_t count; - - count = scm_to_size_t (len); - uvec = make_uvec (FUNC_NAME, SCM_UVEC_S8, count); - if (SCM_UNBNDP (fill)) - f = 0; - else - f = scm_to_int8 (fill); - p = (int_s8 *) SCM_UVEC_BASE (uvec); - while (count-- > 0) - *p++ = f; - return uvec; -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_s8vector, "s8vector", 0, 0, 1, - (SCM l), - "Create a newly allocated homogeneous numeric vector containing\n" - "all argument values.") -#define FUNC_NAME s_scm_s8vector -{ - SCM_VALIDATE_REST_ARGUMENT (l); - return scm_list_to_s8vector (l); -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_s8vector_length, "s8vector-length", 1, 0, 0, - (SCM uvec), - "Return the number of elements in the homogeneous numeric vector\n" - "@var{uvec}.") -#define FUNC_NAME s_scm_s8vector_length -{ - SCM_VALIDATE_SMOB (1, uvec, uvec); - if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_S8) - scm_wrong_type_arg (FUNC_NAME, 1, uvec); - return scm_from_size_t (SCM_UVEC_LENGTH (uvec)); -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_s8vector_ref, "s8vector-ref", 2, 0, 0, - (SCM uvec, SCM index), - "Return the element at @var{index} in the homogeneous numeric\n" - "vector @var{uvec}.") -#define FUNC_NAME s_scm_s8vector_ref -{ - int idx; - - SCM_VALIDATE_SMOB (1, uvec, uvec); - if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_S8) - scm_wrong_type_arg (FUNC_NAME, 1, uvec); - - idx = scm_to_unsigned_integer (index, 0, SCM_UVEC_LENGTH (uvec)-1); - return scm_from_uint8 (((int_s8 *) SCM_UVEC_BASE (uvec))[idx]); -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_s8vector_set_x, "s8vector-set!", 3, 0, 0, - (SCM uvec, SCM index, SCM value), - "Set the element at @var{index} in the homogeneous numeric\n" - "vector @var{uvec} to @var{value}. The return value is not\n" - "specified.") -#define FUNC_NAME s_scm_s8vector_ref -{ - int idx; - - SCM_VALIDATE_SMOB (1, uvec, uvec); - if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_S8) - scm_wrong_type_arg (FUNC_NAME, 1, uvec); - - idx = scm_to_unsigned_integer (index, 0, SCM_UVEC_LENGTH (uvec)-1); - ((int_s8 *) SCM_UVEC_BASE (uvec))[idx] = scm_to_int8 (value); - return SCM_UNSPECIFIED; -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_s8vector_to_list, "s8vector->list", 1, 0, 0, - (SCM uvec), - "Convert the homogeneous numeric vector @var{uvec} to a list.") -#define FUNC_NAME s_scm_s8vector_to_list -{ - int idx; - int_s8 * p; - SCM res = SCM_EOL; - - SCM_VALIDATE_SMOB (1, uvec, uvec); - if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_S8) - scm_wrong_type_arg (FUNC_NAME, 1, uvec); - - idx = SCM_UVEC_LENGTH (uvec); - p = (int_s8 *) SCM_UVEC_BASE (uvec) + idx; - while (idx-- > 0) - { - p--; - res = scm_cons (scm_from_int8 (*p), res); - } - return res; -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_list_to_s8vector, "list->s8vector", 1, 0, 0, - (SCM l), - "Convert the list @var{l}, which must only contain signed\n" - "8-bit values, to a numeric homogeneous vector.") -#define FUNC_NAME s_scm_list_to_s8vector -{ - SCM uvec; - int_s8 * p; - int n; - - SCM_VALIDATE_LIST_COPYLEN (1, l, n); - - uvec = make_uvec (FUNC_NAME, SCM_UVEC_S8, n); - p = (int_s8 *) SCM_UVEC_BASE (uvec); - while (SCM_CONSP (l)) - { - *p++ = scm_to_int8 (SCM_CAR (l)); - l = SCM_CDR (l); - } - return uvec; -} -#undef FUNC_NAME - - -/* ================================================================ */ -/* U16 procedures. */ -/* ================================================================ */ - - -SCM_DEFINE (scm_u16vector_p, "u16vector?", 1, 0, 0, - (SCM obj), - "Return @code{#t} if @var{obj} is a vector of type u16,\n" - "@code{#f} otherwise.") -#define FUNC_NAME s_scm_u16vector_p -{ - return scm_from_bool (SCM_SMOB_PREDICATE (scm_tc16_uvec, obj) && - SCM_UVEC_TYPE (obj) == SCM_UVEC_U16); -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_make_u16vector, "make-u16vector", 1, 1, 0, - (SCM len, SCM fill), - "Create a newly allocated homogeneous numeric vector which can\n" - "hold @var{len} elements. If @var{fill} is given, it is used to\n" - "initialize the elements, otherwise the contents of the vector\n" - "is unspecified.") -#define FUNC_NAME s_scm_make_u16vector -{ - SCM uvec; - int_u16 * p; - int_u16 f; - size_t count; - - count = scm_to_size_t (len); - uvec = make_uvec (FUNC_NAME, SCM_UVEC_U16, count); - if (SCM_UNBNDP (fill)) - f = 0; - else - f = scm_to_uint16 (fill); - p = (int_u16 *) SCM_UVEC_BASE (uvec); - while (count-- > 0) - *p++ = f; - return uvec; -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_u16vector, "u16vector", 0, 0, 1, - (SCM l), - "Create a newly allocated homogeneous numeric vector containing\n" - "all argument values.") -#define FUNC_NAME s_scm_u16vector -{ - SCM_VALIDATE_REST_ARGUMENT (l); - return scm_list_to_u16vector (l); -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_u16vector_length, "u16vector-length", 1, 0, 0, - (SCM uvec), - "Return the number of elements in the homogeneous numeric vector\n" - "@var{uvec}.") -#define FUNC_NAME s_scm_u16vector_length -{ - SCM_VALIDATE_SMOB (1, uvec, uvec); - if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_U16) - scm_wrong_type_arg (FUNC_NAME, 1, uvec); - return scm_from_size_t (SCM_UVEC_LENGTH (uvec)); -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_u16vector_ref, "u16vector-ref", 2, 0, 0, - (SCM uvec, SCM index), - "Return the element at @var{index} in the homogeneous numeric\n" - "vector @var{uvec}.") -#define FUNC_NAME s_scm_u16vector_ref -{ - int idx; - - SCM_VALIDATE_SMOB (1, uvec, uvec); - if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_U16) - scm_wrong_type_arg (FUNC_NAME, 1, uvec); - - idx = scm_to_unsigned_integer (index, 0, SCM_UVEC_LENGTH (uvec)-1); - return scm_from_uint16 (((int_u16 *) SCM_UVEC_BASE (uvec))[idx]); -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_u16vector_set_x, "u16vector-set!", 3, 0, 0, - (SCM uvec, SCM index, SCM value), - "Set the element at @var{index} in the homogeneous numeric\n" - "vector @var{uvec} to @var{value}. The return value is not\n" - "specified.") -#define FUNC_NAME s_scm_u16vector_ref -{ - int idx; - - SCM_VALIDATE_SMOB (1, uvec, uvec); - if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_U16) - scm_wrong_type_arg (FUNC_NAME, 1, uvec); - - idx = scm_to_unsigned_integer (index, 0, SCM_UVEC_LENGTH (uvec)-1); - ((int_u16 *) SCM_UVEC_BASE (uvec))[idx] = scm_to_uint16 (value); - return SCM_UNSPECIFIED; -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_u16vector_to_list, "u16vector->list", 1, 0, 0, - (SCM uvec), - "Convert the homogeneous numeric vector @var{uvec} to a list.") -#define FUNC_NAME s_scm_u16vector_to_list -{ - int idx; - int_u16 * p; - SCM res = SCM_EOL; - - SCM_VALIDATE_SMOB (1, uvec, uvec); - if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_U16) - scm_wrong_type_arg (FUNC_NAME, 1, uvec); - - idx = SCM_UVEC_LENGTH (uvec); - p = (int_u16 *) SCM_UVEC_BASE (uvec) + idx; - while (idx-- > 0) - { - p--; - res = scm_cons (scm_from_uint16 (*p), res); - } - return res; -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_list_to_u16vector, "list->u16vector", 1, 0, 0, - (SCM l), - "Convert the list @var{l}, which must only contain unsigned\n" - "16-bit values, to a numeric homogeneous vector.") -#define FUNC_NAME s_scm_list_to_u16vector -{ - SCM uvec; - int_u16 * p; - int n; - - SCM_VALIDATE_LIST_COPYLEN (1, l, n); - - uvec = make_uvec (FUNC_NAME, SCM_UVEC_U16, n); - p = (int_u16 *) SCM_UVEC_BASE (uvec); - while (SCM_CONSP (l)) - { - *p++ = scm_to_uint16 (SCM_CAR (l)); - l = SCM_CDR (l); - } - return uvec; -} -#undef FUNC_NAME - - -/* ================================================================ */ -/* S16 procedures. */ -/* ================================================================ */ - - -SCM_DEFINE (scm_s16vector_p, "s16vector?", 1, 0, 0, - (SCM obj), - "Return @code{#t} if @var{obj} is a vector of type s16,\n" - "@code{#f} otherwise.") -#define FUNC_NAME s_scm_s16vector_p -{ - return scm_from_bool (SCM_SMOB_PREDICATE (scm_tc16_uvec, obj) && - SCM_UVEC_TYPE (obj) == SCM_UVEC_S16); -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_make_s16vector, "make-s16vector", 1, 1, 0, - (SCM len, SCM fill), - "Create a newly allocated homogeneous numeric vector which can\n" - "hold @var{len} elements. If @var{fill} is given, it is used to\n" - "initialize the elements, otherwise the contents of the vector\n" - "is unspecified.") -#define FUNC_NAME s_scm_make_s16vector -{ - SCM uvec; - int_s16 * p; - int_s16 f; - size_t count; - - count = scm_to_size_t (len); - uvec = make_uvec (FUNC_NAME, SCM_UVEC_S16, count); - if (SCM_UNBNDP (fill)) - f = 0; - else - f = scm_to_int16 (fill); - p = (int_s16 *) SCM_UVEC_BASE (uvec); - while (count-- > 0) - *p++ = f; - return uvec; -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_s16vector, "s16vector", 0, 0, 1, - (SCM l), - "Create a newly allocated homogeneous numeric vector containing\n" - "all argument values.") -#define FUNC_NAME s_scm_s16vector -{ - SCM_VALIDATE_REST_ARGUMENT (l); - return scm_list_to_s16vector (l); -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_s16vector_length, "s16vector-length", 1, 0, 0, - (SCM uvec), - "Return the number of elements in the homogeneous numeric vector\n" - "@var{uvec}.") -#define FUNC_NAME s_scm_s16vector_length -{ - SCM_VALIDATE_SMOB (1, uvec, uvec); - if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_S16) - scm_wrong_type_arg (FUNC_NAME, 1, uvec); - return scm_from_size_t (SCM_UVEC_LENGTH (uvec)); -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_s16vector_ref, "s16vector-ref", 2, 0, 0, - (SCM uvec, SCM index), - "Return the element at @var{index} in the homogeneous numeric\n" - "vector @var{uvec}.") -#define FUNC_NAME s_scm_s16vector_ref -{ - int idx; - - SCM_VALIDATE_SMOB (1, uvec, uvec); - if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_S16) - scm_wrong_type_arg (FUNC_NAME, 1, uvec); - - idx = scm_to_unsigned_integer (index, 0, SCM_UVEC_LENGTH (uvec)-1); - return scm_from_int16 (((int_s16 *) SCM_UVEC_BASE (uvec))[idx]); -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_s16vector_set_x, "s16vector-set!", 3, 0, 0, - (SCM uvec, SCM index, SCM value), - "Set the element at @var{index} in the homogeneous numeric\n" - "vector @var{uvec} to @var{value}. The return value is not\n" - "specified.") -#define FUNC_NAME s_scm_s16vector_ref -{ - int idx; - - SCM_VALIDATE_SMOB (1, uvec, uvec); - if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_S16) - scm_wrong_type_arg (FUNC_NAME, 1, uvec); - - idx = scm_to_unsigned_integer (index, 0, SCM_UVEC_LENGTH (uvec)-1); - ((int_s16 *) SCM_UVEC_BASE (uvec))[idx] = scm_to_int16 (value); - return SCM_UNSPECIFIED; -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_s16vector_to_list, "s16vector->list", 1, 0, 0, - (SCM uvec), - "Convert the homogeneous numeric vector @var{uvec} to a list.") -#define FUNC_NAME s_scm_s16vector_to_list -{ - int idx; - int_s16 * p; - SCM res = SCM_EOL; - - SCM_VALIDATE_SMOB (1, uvec, uvec); - if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_S16) - scm_wrong_type_arg (FUNC_NAME, 1, uvec); - - idx = SCM_UVEC_LENGTH (uvec); - p = (int_s16 *) SCM_UVEC_BASE (uvec) + idx; - while (idx-- > 0) - { - p--; - res = scm_cons (scm_from_int16 (*p), res); - } - return res; -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_list_to_s16vector, "list->s16vector", 1, 0, 0, - (SCM l), - "Convert the list @var{l}, which must only contain signed\n" - "16-bit values, to a numeric homogeneous vector.") -#define FUNC_NAME s_scm_list_to_s16vector -{ - SCM uvec; - int_s16 * p; - int n; - - SCM_VALIDATE_LIST_COPYLEN (1, l, n); - - uvec = make_uvec (FUNC_NAME, SCM_UVEC_S16, n); - p = (int_s16 *) SCM_UVEC_BASE (uvec); - while (SCM_CONSP (l)) - { - *p++ = scm_to_int16 (SCM_CAR (l)); - l = SCM_CDR (l); - } - return uvec; -} -#undef FUNC_NAME - - -/* ================================================================ */ -/* U32 procedures. */ -/* ================================================================ */ - - -SCM_DEFINE (scm_u32vector_p, "u32vector?", 1, 0, 0, - (SCM obj), - "Return @code{#t} if @var{obj} is a vector of type u32,\n" - "@code{#f} otherwise.") -#define FUNC_NAME s_scm_u32vector_p -{ - return scm_from_bool (SCM_SMOB_PREDICATE (scm_tc16_uvec, obj) && - SCM_UVEC_TYPE (obj) == SCM_UVEC_U32); -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_make_u32vector, "make-u32vector", 1, 1, 0, - (SCM len, SCM fill), - "Create a newly allocated homogeneous numeric vector which can\n" - "hold @var{len} elements. If @var{fill} is given, it is used to\n" - "initialize the elements, otherwise the contents of the vector\n" - "is unspecified.") -#define FUNC_NAME s_scm_make_u32vector -{ - SCM uvec; - int_u32 * p; - int_u32 f; - size_t count; - - count = scm_to_size_t (len); - uvec = make_uvec (FUNC_NAME, SCM_UVEC_U32, count); - if (SCM_UNBNDP (fill)) - f = 0; - else - f = scm_to_uint32 (fill); - p = (int_u32 *) SCM_UVEC_BASE (uvec); - while (count-- > 0) - *p++ = f; - return uvec; -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_u32vector, "u32vector", 0, 0, 1, - (SCM l), - "Create a newly allocated homogeneous numeric vector containing\n" - "all argument values.") -#define FUNC_NAME s_scm_u32vector -{ - SCM_VALIDATE_REST_ARGUMENT (l); - return scm_list_to_u32vector (l); -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_u32vector_length, "u32vector-length", 1, 0, 0, - (SCM uvec), - "Return the number of elements in the homogeneous numeric vector\n" - "@var{uvec}.") -#define FUNC_NAME s_scm_u32vector_length -{ - SCM_VALIDATE_SMOB (1, uvec, uvec); - if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_U32) - scm_wrong_type_arg (FUNC_NAME, 1, uvec); - return scm_from_size_t (SCM_UVEC_LENGTH (uvec)); -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_u32vector_ref, "u32vector-ref", 2, 0, 0, - (SCM uvec, SCM index), - "Return the element at @var{index} in the homogeneous numeric\n" - "vector @var{uvec}.") -#define FUNC_NAME s_scm_u32vector_ref -{ - int idx; - - SCM_VALIDATE_SMOB (1, uvec, uvec); - if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_U32) - scm_wrong_type_arg (FUNC_NAME, 1, uvec); - - idx = scm_to_unsigned_integer (index, 0, SCM_UVEC_LENGTH (uvec)-1); - return scm_from_uint32 (((int_u32 *) SCM_UVEC_BASE (uvec))[idx]); -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_u32vector_set_x, "u32vector-set!", 3, 0, 0, - (SCM uvec, SCM index, SCM value), - "Set the element at @var{index} in the homogeneous numeric\n" - "vector @var{uvec} to @var{value}. The return value is not\n" - "specified.") -#define FUNC_NAME s_scm_u32vector_ref -{ - int idx; - - SCM_VALIDATE_SMOB (1, uvec, uvec); - if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_U32) - scm_wrong_type_arg (FUNC_NAME, 1, uvec); - - idx = scm_to_unsigned_integer (index, 0, SCM_UVEC_LENGTH (uvec)-1); - ((int_u32 *) SCM_UVEC_BASE (uvec))[idx] = scm_to_uint32 (value); - return SCM_UNSPECIFIED; -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_u32vector_to_list, "u32vector->list", 1, 0, 0, - (SCM uvec), - "Convert the homogeneous numeric vector @var{uvec} to a list.") -#define FUNC_NAME s_scm_u32vector_to_list -{ - int idx; - int_u32 * p; - SCM res = SCM_EOL; - - SCM_VALIDATE_SMOB (1, uvec, uvec); - if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_U32) - scm_wrong_type_arg (FUNC_NAME, 1, uvec); - - idx = SCM_UVEC_LENGTH (uvec); - p = (int_u32 *) SCM_UVEC_BASE (uvec) + idx; - while (idx-- > 0) - { - p--; - res = scm_cons (scm_from_uint32 (*p), res); - } - return res; -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_list_to_u32vector, "list->u32vector", 1, 0, 0, - (SCM l), - "Convert the list @var{l}, which must only contain unsigned\n" - "32-bit values, to a numeric homogeneous vector.") -#define FUNC_NAME s_scm_list_to_u32vector -{ - SCM uvec; - int_u32 * p; - int n; - - SCM_VALIDATE_LIST_COPYLEN (1, l, n); - - uvec = make_uvec (FUNC_NAME, SCM_UVEC_U32, n); - p = (int_u32 *) SCM_UVEC_BASE (uvec); - while (SCM_CONSP (l)) - { - *p++ = scm_to_uint32 (SCM_CAR (l)); - l = SCM_CDR (l); - } - return uvec; -} -#undef FUNC_NAME - - -/* ================================================================ */ -/* S32 procedures. */ -/* ================================================================ */ - - -SCM_DEFINE (scm_s32vector_p, "s32vector?", 1, 0, 0, - (SCM obj), - "Return @code{#t} if @var{obj} is a vector of type s32,\n" - "@code{#f} otherwise.") -#define FUNC_NAME s_scm_s32vector_p -{ - return scm_from_bool (SCM_SMOB_PREDICATE (scm_tc16_uvec, obj) && - SCM_UVEC_TYPE (obj) == SCM_UVEC_S32); -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_make_s32vector, "make-s32vector", 1, 1, 0, - (SCM len, SCM fill), - "Create a newly allocated homogeneous numeric vector which can\n" - "hold @var{len} elements. If @var{fill} is given, it is used to\n" - "initialize the elements, otherwise the contents of the vector\n" - "is unspecified.") -#define FUNC_NAME s_scm_make_s32vector -{ - SCM uvec; - int_s32 * p; - int_s32 f; - size_t count; - - count = scm_to_size_t (len); - uvec = make_uvec (FUNC_NAME, SCM_UVEC_S32, count); - if (SCM_UNBNDP (fill)) - f = 0; - else - f = scm_to_int32 (fill); - p = (int_s32 *) SCM_UVEC_BASE (uvec); - while (count-- > 0) - *p++ = f; - return uvec; -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_s32vector, "s32vector", 0, 0, 1, - (SCM l), - "Create a newly allocated homogeneous numeric vector containing\n" - "all argument values.") -#define FUNC_NAME s_scm_s32vector -{ - SCM_VALIDATE_REST_ARGUMENT (l); - return scm_list_to_s32vector (l); -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_s32vector_length, "s32vector-length", 1, 0, 0, - (SCM uvec), - "Return the number of elements in the homogeneous numeric vector\n" - "@var{uvec}.") -#define FUNC_NAME s_scm_s32vector_length -{ - SCM_VALIDATE_SMOB (1, uvec, uvec); - if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_S32) - scm_wrong_type_arg (FUNC_NAME, 1, uvec); - return scm_from_size_t (SCM_UVEC_LENGTH (uvec)); -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_s32vector_ref, "s32vector-ref", 2, 0, 0, - (SCM uvec, SCM index), - "Return the element at @var{index} in the homogeneous numeric\n" - "vector @var{uvec}.") -#define FUNC_NAME s_scm_s32vector_ref -{ - int idx; - - SCM_VALIDATE_SMOB (1, uvec, uvec); - if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_S32) - scm_wrong_type_arg (FUNC_NAME, 1, uvec); - - idx = scm_to_unsigned_integer (index, 0, SCM_UVEC_LENGTH (uvec)-1); - return scm_from_int32 (((int_s32 *) SCM_UVEC_BASE (uvec))[idx]); -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_s32vector_set_x, "s32vector-set!", 3, 0, 0, - (SCM uvec, SCM index, SCM value), - "Set the element at @var{index} in the homogeneous numeric\n" - "vector @var{uvec} to @var{value}. The return value is not\n" - "specified.") -#define FUNC_NAME s_scm_s32vector_ref -{ - int idx; - - SCM_VALIDATE_SMOB (1, uvec, uvec); - if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_S32) - scm_wrong_type_arg (FUNC_NAME, 1, uvec); - - idx = scm_to_unsigned_integer (index, 0, SCM_UVEC_LENGTH (uvec)-1); - ((int_s32 *) SCM_UVEC_BASE (uvec))[idx] = scm_to_int32 (value); - return SCM_UNSPECIFIED; -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_s32vector_to_list, "s32vector->list", 1, 0, 0, - (SCM uvec), - "Convert the homogeneous numeric vector @var{uvec} to a list.") -#define FUNC_NAME s_scm_s32vector_to_list -{ - int idx; - int_s32 * p; - SCM res = SCM_EOL; - - SCM_VALIDATE_SMOB (1, uvec, uvec); - if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_S32) - scm_wrong_type_arg (FUNC_NAME, 1, uvec); - - idx = SCM_UVEC_LENGTH (uvec); - p = (int_s32 *) SCM_UVEC_BASE (uvec) + idx; - while (idx-- > 0) - { - p--; - res = scm_cons (scm_from_int32 (*p), res); - } - return res; -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_list_to_s32vector, "list->s32vector", 1, 0, 0, - (SCM l), - "Convert the list @var{l}, which must only contain signed\n" - "32-bit values, to a numeric homogeneous vector.") -#define FUNC_NAME s_scm_list_to_s32vector -{ - SCM uvec; - int_s32 * p; - int n; - - SCM_VALIDATE_LIST_COPYLEN (1, l, n); - - uvec = make_uvec (FUNC_NAME, SCM_UVEC_S32, n); - p = (int_s32 *) SCM_UVEC_BASE (uvec); - while (SCM_CONSP (l)) - { - *p++ = scm_to_int32 (SCM_CAR (l)); - l = SCM_CDR (l); - } - return uvec; -} -#undef FUNC_NAME - - -#if SCM_HAVE_T_INT64 - -/* ================================================================ */ -/* U64 procedures. */ -/* ================================================================ */ - - -SCM_DEFINE (scm_u64vector_p, "u64vector?", 1, 0, 0, - (SCM obj), - "Return @code{#t} if @var{obj} is a vector of type u64,\n" - "@code{#f} otherwise.") -#define FUNC_NAME s_scm_u64vector_p -{ - return scm_from_bool (SCM_SMOB_PREDICATE (scm_tc16_uvec, obj) && - SCM_UVEC_TYPE (obj) == SCM_UVEC_U64); -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_make_u64vector, "make-u64vector", 1, 1, 0, - (SCM len, SCM fill), - "Create a newly allocated homogeneous numeric vector which can\n" - "hold @var{len} elements. If @var{fill} is given, it is used to\n" - "initialize the elements, otherwise the contents of the vector\n" - "is unspecified.") -#define FUNC_NAME s_scm_make_u64vector -{ - SCM uvec; - int_u64 * p; - int_u64 f; - size_t count; - - count = scm_to_size_t (len); - uvec = make_uvec (FUNC_NAME, SCM_UVEC_U64, count); - if (SCM_UNBNDP (fill)) - f = 0; - else - f = scm_to_uint64 (fill); - p = (int_u64 *) SCM_UVEC_BASE (uvec); - while (count-- > 0) - *p++ = f; - return uvec; -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_u64vector, "u64vector", 0, 0, 1, - (SCM l), - "Create a newly allocated homogeneous numeric vector containing\n" - "all argument values.") -#define FUNC_NAME s_scm_u64vector -{ - SCM_VALIDATE_REST_ARGUMENT (l); - return scm_list_to_u64vector (l); -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_u64vector_length, "u64vector-length", 1, 0, 0, - (SCM uvec), - "Return the number of elements in the homogeneous numeric vector\n" - "@var{uvec}.") -#define FUNC_NAME s_scm_u64vector_length -{ - SCM_VALIDATE_SMOB (1, uvec, uvec); - if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_U64) - scm_wrong_type_arg (FUNC_NAME, 1, uvec); - return scm_from_size_t (SCM_UVEC_LENGTH (uvec)); -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_u64vector_ref, "u64vector-ref", 2, 0, 0, - (SCM uvec, SCM index), - "Return the element at @var{index} in the homogeneous numeric\n" - "vector @var{uvec}.") -#define FUNC_NAME s_scm_u64vector_ref -{ - int idx; - - SCM_VALIDATE_SMOB (1, uvec, uvec); - if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_U64) - scm_wrong_type_arg (FUNC_NAME, 1, uvec); - - idx = scm_to_unsigned_integer (index, 0, SCM_UVEC_LENGTH (uvec)-1); - return scm_from_uint64 (((int_u64 *) SCM_UVEC_BASE (uvec))[idx]); -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_u64vector_set_x, "u64vector-set!", 3, 0, 0, - (SCM uvec, SCM index, SCM value), - "Set the element at @var{index} in the homogeneous numeric\n" - "vector @var{uvec} to @var{value}. The return value is not\n" - "specified.") -#define FUNC_NAME s_scm_u64vector_ref -{ - int idx; - - SCM_VALIDATE_SMOB (1, uvec, uvec); - if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_U64) - scm_wrong_type_arg (FUNC_NAME, 1, uvec); - - idx = scm_to_unsigned_integer (index, 0, SCM_UVEC_LENGTH (uvec)-1); - ((int_u64 *) SCM_UVEC_BASE (uvec))[idx] = scm_to_uint64 (value); - return SCM_UNSPECIFIED; -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_u64vector_to_list, "u64vector->list", 1, 0, 0, - (SCM uvec), - "Convert the homogeneous numeric vector @var{uvec} to a list.") -#define FUNC_NAME s_scm_u64vector_to_list -{ - int idx; - int_u64 * p; - SCM res = SCM_EOL; - - SCM_VALIDATE_SMOB (1, uvec, uvec); - if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_U64) - scm_wrong_type_arg (FUNC_NAME, 1, uvec); - - idx = SCM_UVEC_LENGTH (uvec); - p = (int_u64 *) SCM_UVEC_BASE (uvec) + idx; - while (idx-- > 0) - { - p--; - res = scm_cons (scm_from_long_long (*p), res); - } - return res; -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_list_to_u64vector, "list->u64vector", 1, 0, 0, - (SCM l), - "Convert the list @var{l}, which must only contain unsigned\n" - "64-bit values, to a numeric homogeneous vector.") -#define FUNC_NAME s_scm_list_to_u64vector -{ - SCM uvec; - int_u64 * p; - int n; - - SCM_VALIDATE_LIST_COPYLEN (1, l, n); - - uvec = make_uvec (FUNC_NAME, SCM_UVEC_U64, n); - p = (int_u64 *) SCM_UVEC_BASE (uvec); - while (SCM_CONSP (l)) - { - *p++ = scm_to_uint64 (SCM_CAR (l)); - l = SCM_CDR (l); - } - return uvec; -} -#undef FUNC_NAME - - -/* ================================================================ */ -/* S64 procedures. */ -/* ================================================================ */ - - -SCM_DEFINE (scm_s64vector_p, "s64vector?", 1, 0, 0, - (SCM obj), - "Return @code{#t} if @var{obj} is a vector of type s64,\n" - "@code{#f} otherwise.") -#define FUNC_NAME s_scm_s64vector_p -{ - return scm_from_bool (SCM_SMOB_PREDICATE (scm_tc16_uvec, obj) && - SCM_UVEC_TYPE (obj) == SCM_UVEC_S64); -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_make_s64vector, "make-s64vector", 1, 1, 0, - (SCM len, SCM fill), - "Create a newly allocated homogeneous numeric vector which can\n" - "hold @var{len} elements. If @var{fill} is given, it is used to\n" - "initialize the elements, otherwise the contents of the vector\n" - "is unspecified.") -#define FUNC_NAME s_scm_make_s64vector -{ - SCM uvec; - int_s64 * p; - int_s64 f; - size_t count; - - count = scm_to_size_t (len); - uvec = make_uvec (FUNC_NAME, SCM_UVEC_S64, count); - if (SCM_UNBNDP (fill)) - f = 0; - else - f = scm_to_int64 (fill); - p = (int_s64 *) SCM_UVEC_BASE (uvec); - while (count-- > 0) - *p++ = f; - return uvec; -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_s64vector, "s64vector", 0, 0, 1, - (SCM l), - "Create a newly allocated homogeneous numeric vector containing\n" - "all argument values.") -#define FUNC_NAME s_scm_s64vector -{ - SCM_VALIDATE_REST_ARGUMENT (l); - return scm_list_to_s64vector (l); -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_s64vector_length, "s64vector-length", 1, 0, 0, - (SCM uvec), - "Return the number of elements in the homogeneous numeric vector\n" - "@var{uvec}.") -#define FUNC_NAME s_scm_s64vector_length -{ - SCM_VALIDATE_SMOB (1, uvec, uvec); - if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_S64) - scm_wrong_type_arg (FUNC_NAME, 1, uvec); - return scm_from_size_t (SCM_UVEC_LENGTH (uvec)); -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_s64vector_ref, "s64vector-ref", 2, 0, 0, - (SCM uvec, SCM index), - "Return the element at @var{index} in the homogeneous numeric\n" - "vector @var{uvec}.") -#define FUNC_NAME s_scm_s64vector_ref -{ - int idx; - - SCM_VALIDATE_SMOB (1, uvec, uvec); - if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_S64) - scm_wrong_type_arg (FUNC_NAME, 1, uvec); - - idx = scm_to_unsigned_integer (index, 0, SCM_UVEC_LENGTH (uvec)-1); - return scm_from_int64 (((int_s64 *) SCM_UVEC_BASE (uvec))[idx]); -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_s64vector_set_x, "s64vector-set!", 3, 0, 0, - (SCM uvec, SCM index, SCM value), - "Set the element at @var{index} in the homogeneous numeric\n" - "vector @var{uvec} to @var{value}. The return value is not\n" - "specified.") -#define FUNC_NAME s_scm_s64vector_ref -{ - int idx; - - SCM_VALIDATE_SMOB (1, uvec, uvec); - if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_S64) - scm_wrong_type_arg (FUNC_NAME, 1, uvec); - - idx = scm_to_unsigned_integer (index, 0, SCM_UVEC_LENGTH (uvec)-1); - ((int_s64 *) SCM_UVEC_BASE (uvec))[idx] = scm_to_int64 (value); - return SCM_UNSPECIFIED; -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_s64vector_to_list, "s64vector->list", 1, 0, 0, - (SCM uvec), - "Convert the homogeneous numeric vector @var{uvec} to a list.") -#define FUNC_NAME s_scm_s64vector_to_list -{ - int idx; - int_s64 * p; - SCM res = SCM_EOL; - - SCM_VALIDATE_SMOB (1, uvec, uvec); - if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_S64) - scm_wrong_type_arg (FUNC_NAME, 1, uvec); - - idx = SCM_UVEC_LENGTH (uvec); - p = (int_s64 *) SCM_UVEC_BASE (uvec) + idx; - while (idx-- > 0) - { - p--; - res = scm_cons (scm_from_int64 (*p), res); - } - return res; -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_list_to_s64vector, "list->s64vector", 1, 0, 0, - (SCM l), - "Convert the list @var{l}, which must only contain signed\n" - "64-bit values, to a numeric homogeneous vector.") -#define FUNC_NAME s_scm_list_to_s64vector -{ - SCM uvec; - int_s64 * p; - int n; - - SCM_VALIDATE_LIST_COPYLEN (1, l, n); - - uvec = make_uvec (FUNC_NAME, SCM_UVEC_S64, n); - p = (int_s64 *) SCM_UVEC_BASE (uvec); - while (SCM_CONSP (l)) - { - *p++ = scm_to_int64 (SCM_CAR (l)); - l = SCM_CDR (l); - } - return uvec; -} -#undef FUNC_NAME - -#endif /* SCM_HAVE_T_INT64 */ - - -/* ================================================================ */ -/* F32 procedures. */ -/* ================================================================ */ - - -SCM_DEFINE (scm_f32vector_p, "f32vector?", 1, 0, 0, - (SCM obj), - "Return @code{#t} if @var{obj} is a vector of type f32,\n" - "@code{#f} otherwise.") -#define FUNC_NAME s_scm_f32vector_p -{ - return scm_from_bool (SCM_SMOB_PREDICATE (scm_tc16_uvec, obj) && - SCM_UVEC_TYPE (obj) == SCM_UVEC_F32); -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_make_f32vector, "make-f32vector", 1, 1, 0, - (SCM len, SCM fill), - "Create a newly allocated homogeneous numeric vector which can\n" - "hold @var{len} elements. If @var{fill} is given, it is used to\n" - "initialize the elements, otherwise the contents of the vector\n" - "is unspecified.") -#define FUNC_NAME s_scm_make_f32vector -{ - SCM uvec; - float_f32 * p; - float_f32 f; - size_t count; - - count = scm_to_size_t (len); - uvec = make_uvec (FUNC_NAME, SCM_UVEC_F32, count); - if (SCM_UNBNDP (fill)) - f = 0; - else - f = scm_to_double (fill); - p = (float_f32 *) SCM_UVEC_BASE (uvec); - while (count-- > 0) - *p++ = f; - return uvec; -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_f32vector, "f32vector", 0, 0, 1, - (SCM l), - "Create a newly allocated homogeneous numeric vector containing\n" - "all argument values.") -#define FUNC_NAME s_scm_f32vector -{ - SCM_VALIDATE_REST_ARGUMENT (l); - return scm_list_to_f32vector (l); -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_f32vector_length, "f32vector-length", 1, 0, 0, - (SCM uvec), - "Return the number of elements in the homogeneous numeric vector\n" - "@var{uvec}.") -#define FUNC_NAME s_scm_f32vector_length -{ - SCM_VALIDATE_SMOB (1, uvec, uvec); - if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_F32) - scm_wrong_type_arg (FUNC_NAME, 1, uvec); - return scm_from_size_t (SCM_UVEC_LENGTH (uvec)); -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_f32vector_ref, "f32vector-ref", 2, 0, 0, - (SCM uvec, SCM index), - "Return the element at @var{index} in the homogeneous numeric\n" - "vector @var{uvec}.") -#define FUNC_NAME s_scm_f32vector_ref -{ - int idx; - - SCM_VALIDATE_SMOB (1, uvec, uvec); - if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_F32) - scm_wrong_type_arg (FUNC_NAME, 1, uvec); - - idx = scm_to_unsigned_integer (index, 0, SCM_UVEC_LENGTH (uvec)-1); - return scm_from_double (((float_f32 *) SCM_UVEC_BASE (uvec))[idx]); -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_f32vector_set_x, "f32vector-set!", 3, 0, 0, - (SCM uvec, SCM index, SCM value), - "Set the element at @var{index} in the homogeneous numeric\n" - "vector @var{uvec} to @var{value}. The return value is not\n" - "specified.") -#define FUNC_NAME s_scm_f32vector_ref -{ - int idx; - - SCM_VALIDATE_SMOB (1, uvec, uvec); - if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_F32) - scm_wrong_type_arg (FUNC_NAME, 1, uvec); - - idx = scm_to_unsigned_integer (index, 0, SCM_UVEC_LENGTH (uvec)-1); - ((float_f32 *) SCM_UVEC_BASE (uvec))[idx] = scm_to_double (value); - return SCM_UNSPECIFIED; -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_f32vector_to_list, "f32vector->list", 1, 0, 0, - (SCM uvec), - "Convert the homogeneous numeric vector @var{uvec} to a list.") -#define FUNC_NAME s_scm_f32vector_to_list -{ - int idx; - float_f32 * p; - SCM res = SCM_EOL; - - SCM_VALIDATE_SMOB (1, uvec, uvec); - if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_F32) - scm_wrong_type_arg (FUNC_NAME, 1, uvec); - - idx = SCM_UVEC_LENGTH (uvec); - p = (float_f32 *) SCM_UVEC_BASE (uvec) + idx; - while (idx-- > 0) - { - p--; - res = scm_cons (scm_from_double (*p), res); - } - return res; -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_list_to_f32vector, "list->f32vector", 1, 0, 0, - (SCM l), - "Convert the list @var{l}, which must only contain unsigned\n" - "8-bit values, to a numeric homogeneous vector.") -#define FUNC_NAME s_scm_list_to_f32vector -{ - SCM uvec; - float_f32 * p; - int n; - - SCM_VALIDATE_LIST_COPYLEN (1, l, n); - - uvec = make_uvec (FUNC_NAME, SCM_UVEC_F32, n); - p = (float_f32 *) SCM_UVEC_BASE (uvec); - while (SCM_CONSP (l)) - { - *p++ = scm_to_double (SCM_CAR (l)); - l = SCM_CDR (l); - } - return uvec; -} -#undef FUNC_NAME - - -/* ================================================================ */ -/* F64 procedures. */ -/* ================================================================ */ - - -SCM_DEFINE (scm_f64vector_p, "f64vector?", 1, 0, 0, - (SCM obj), - "Return @code{#t} if @var{obj} is a vector of type f64,\n" - "@code{#f} otherwise.") -#define FUNC_NAME s_scm_f64vector_p -{ - return scm_from_bool (SCM_SMOB_PREDICATE (scm_tc16_uvec, obj) && - SCM_UVEC_TYPE (obj) == SCM_UVEC_F64); -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_make_f64vector, "make-f64vector", 1, 1, 0, - (SCM len, SCM fill), - "Create a newly allocated homogeneous numeric vector which can\n" - "hold @var{len} elements. If @var{fill} is given, it is used to\n" - "initialize the elements, otherwise the contents of the vector\n" - "is unspecified.") -#define FUNC_NAME s_scm_make_f64vector -{ - SCM uvec; - float_f64 * p; - float_f64 f; - size_t count; - - count = scm_to_size_t (len); - uvec = make_uvec (FUNC_NAME, SCM_UVEC_F64, count); - if (SCM_UNBNDP (fill)) - f = 0; - else - f = scm_to_double (fill); - p = (float_f64 *) SCM_UVEC_BASE (uvec); - while (count-- > 0) - *p++ = f; - return uvec; -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_f64vector, "f64vector", 0, 0, 1, - (SCM l), - "Create a newly allocated homogeneous numeric vector containing\n" - "all argument values.") -#define FUNC_NAME s_scm_f64vector -{ - SCM_VALIDATE_REST_ARGUMENT (l); - return scm_list_to_f64vector (l); -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_f64vector_length, "f64vector-length", 1, 0, 0, - (SCM uvec), - "Return the number of elements in the homogeneous numeric vector\n" - "@var{uvec}.") -#define FUNC_NAME s_scm_f64vector_length -{ - SCM_VALIDATE_SMOB (1, uvec, uvec); - if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_F64) - scm_wrong_type_arg (FUNC_NAME, 1, uvec); - return scm_from_size_t (SCM_UVEC_LENGTH (uvec)); -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_f64vector_ref, "f64vector-ref", 2, 0, 0, - (SCM uvec, SCM index), - "Return the element at @var{index} in the homogeneous numeric\n" - "vector @var{uvec}.") -#define FUNC_NAME s_scm_f64vector_ref -{ - int idx; - - SCM_VALIDATE_SMOB (1, uvec, uvec); - if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_F64) - scm_wrong_type_arg (FUNC_NAME, 1, uvec); - - idx = scm_to_unsigned_integer (index, 0, SCM_UVEC_LENGTH (uvec)-1); - return scm_from_double (((float_f64 *) SCM_UVEC_BASE (uvec))[idx]); -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_f64vector_set_x, "f64vector-set!", 3, 0, 0, - (SCM uvec, SCM index, SCM value), - "Set the element at @var{index} in the homogeneous numeric\n" - "vector @var{uvec} to @var{value}. The return value is not\n" - "specified.") -#define FUNC_NAME s_scm_f64vector_ref -{ - int idx; - - SCM_VALIDATE_SMOB (1, uvec, uvec); - if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_F64) - scm_wrong_type_arg (FUNC_NAME, 1, uvec); - - idx = scm_to_unsigned_integer (index, 0, SCM_UVEC_LENGTH (uvec)-1); - ((float_f64 *) SCM_UVEC_BASE (uvec))[idx] = scm_to_double (value); - return SCM_UNSPECIFIED; -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_f64vector_to_list, "f64vector->list", 1, 0, 0, - (SCM uvec), - "Convert the homogeneous numeric vector @var{uvec} to a list.") -#define FUNC_NAME s_scm_f64vector_to_list -{ - int idx; - float_f64 * p; - SCM res = SCM_EOL; - - SCM_VALIDATE_SMOB (1, uvec, uvec); - if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_F64) - scm_wrong_type_arg (FUNC_NAME, 1, uvec); - - idx = SCM_UVEC_LENGTH (uvec); - p = (float_f64 *) SCM_UVEC_BASE (uvec) + idx; - while (idx-- > 0) - { - p--; - res = scm_cons (scm_from_double (*p), res); - } - return res; -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_list_to_f64vector, "list->f64vector", 1, 0, 0, - (SCM l), - "Convert the list @var{l}, which must only contain signed\n" - "8-bit values, to a numeric homogeneous vector.") -#define FUNC_NAME s_scm_list_to_f64vector -{ - SCM uvec; - float_f64 * p; - int n; - - SCM_VALIDATE_LIST_COPYLEN (1, l, n); - - uvec = make_uvec (FUNC_NAME, SCM_UVEC_F64, n); - p = (float_f64 *) SCM_UVEC_BASE (uvec); - while (SCM_CONSP (l)) - { - *p++ = scm_to_double (SCM_CAR (l)); - l = SCM_CDR (l); - } - return uvec; -} -#undef FUNC_NAME - - -/* Create the smob type for homogeneous numeric vectors and install - the primitives. */ void scm_init_srfi_4 (void) { - scm_tc16_uvec = scm_make_smob_type ("uvec", 0); - scm_set_smob_free (scm_tc16_uvec, uvec_free); - scm_set_smob_print (scm_tc16_uvec, uvec_print); -#include "srfi/srfi-4.x" } /* End of srfi-4.c. */ diff --git a/srfi/srfi-4.h b/srfi/srfi-4.h index a27d86093..99a7d9b7c 100644 --- a/srfi/srfi-4.h +++ b/srfi/srfi-4.h @@ -1,5 +1,5 @@ -#ifndef SCM_SRFI_4_H -#define SCM_SRFI_4_H +#ifndef SCM_SRFI_SRFI_4_H +#define SCM_SRFI_SRFI_4_H /* srfi-4.c --- Homogeneous numeric vector datatypes. * * Copyright (C) 2001 Free Software Foundation, Inc. @@ -20,108 +20,8 @@ */ -/* SCM_SRFI4_API is a macro prepended to all function and data definitions - which should be exported or imported in the resulting dynamic link - library in the Win32 port. */ +/* All SRFI-4 procedures are in in the core now. */ -#if defined (SCM_SRFI4_IMPORT) -# define SCM_SRFI4_API __declspec (dllimport) extern -#elif defined (SCM_SRFI4_EXPORT) || defined (DLL_EXPORT) -# define SCM_SRFI4_API __declspec (dllexport) extern -#else -# define SCM_SRFI4_API extern -#endif +#include <libguile.h> -SCM_SRFI4_API SCM scm_u8vector_p (SCM obj); -SCM_SRFI4_API SCM scm_make_u8vector (SCM n, SCM fill); -SCM_SRFI4_API SCM scm_u8vector (SCM l); -SCM_SRFI4_API SCM scm_u8vector_length (SCM uvec); -SCM_SRFI4_API SCM scm_u8vector_ref (SCM uvec, SCM index); -SCM_SRFI4_API SCM scm_u8vector_set_x (SCM uvec, SCM index, SCM value); -SCM_SRFI4_API SCM scm_u8vector_to_list (SCM uvec); -SCM_SRFI4_API SCM scm_list_to_u8vector (SCM l); - -SCM_SRFI4_API SCM scm_s8vector_p (SCM obj); -SCM_SRFI4_API SCM scm_make_s8vector (SCM n, SCM fill); -SCM_SRFI4_API SCM scm_s8vector (SCM l); -SCM_SRFI4_API SCM scm_s8vector_length (SCM uvec); -SCM_SRFI4_API SCM scm_s8vector_ref (SCM uvec, SCM index); -SCM_SRFI4_API SCM scm_s8vector_set_x (SCM uvec, SCM index, SCM value); -SCM_SRFI4_API SCM scm_s8vector_to_list (SCM uvec); -SCM_SRFI4_API SCM scm_list_to_s8vector (SCM l); - -SCM_SRFI4_API SCM scm_u16vector_p (SCM obj); -SCM_SRFI4_API SCM scm_make_u16vector (SCM n, SCM fill); -SCM_SRFI4_API SCM scm_u16vector (SCM l); -SCM_SRFI4_API SCM scm_u16vector_length (SCM uvec); -SCM_SRFI4_API SCM scm_u16vector_ref (SCM uvec, SCM index); -SCM_SRFI4_API SCM scm_u16vector_set_x (SCM uvec, SCM index, SCM value); -SCM_SRFI4_API SCM scm_u16vector_to_list (SCM uvec); -SCM_SRFI4_API SCM scm_list_to_u16vector (SCM l); - -SCM_SRFI4_API SCM scm_s16vector_p (SCM obj); -SCM_SRFI4_API SCM scm_make_s16vector (SCM n, SCM fill); -SCM_SRFI4_API SCM scm_s16vector (SCM l); -SCM_SRFI4_API SCM scm_s16vector_length (SCM uvec); -SCM_SRFI4_API SCM scm_s16vector_ref (SCM uvec, SCM index); -SCM_SRFI4_API SCM scm_s16vector_set_x (SCM uvec, SCM index, SCM value); -SCM_SRFI4_API SCM scm_s16vector_to_list (SCM uvec); -SCM_SRFI4_API SCM scm_list_to_s16vector (SCM l); - -SCM_SRFI4_API SCM scm_u32vector_p (SCM obj); -SCM_SRFI4_API SCM scm_make_u32vector (SCM n, SCM fill); -SCM_SRFI4_API SCM scm_u32vector (SCM l); -SCM_SRFI4_API SCM scm_u32vector_length (SCM uvec); -SCM_SRFI4_API SCM scm_u32vector_ref (SCM uvec, SCM index); -SCM_SRFI4_API SCM scm_u32vector_set_x (SCM uvec, SCM index, SCM value); -SCM_SRFI4_API SCM scm_u32vector_to_list (SCM uvec); -SCM_SRFI4_API SCM scm_list_to_u32vector (SCM l); - -SCM_SRFI4_API SCM scm_s32vector_p (SCM obj); -SCM_SRFI4_API SCM scm_make_s32vector (SCM n, SCM fill); -SCM_SRFI4_API SCM scm_s32vector (SCM l); -SCM_SRFI4_API SCM scm_s32vector_length (SCM uvec); -SCM_SRFI4_API SCM scm_s32vector_ref (SCM uvec, SCM index); -SCM_SRFI4_API SCM scm_s32vector_set_x (SCM uvec, SCM index, SCM value); -SCM_SRFI4_API SCM scm_s32vector_to_list (SCM uvec); -SCM_SRFI4_API SCM scm_list_to_s32vector (SCM l); - -SCM_SRFI4_API SCM scm_u64vector_p (SCM obj); -SCM_SRFI4_API SCM scm_make_u64vector (SCM n, SCM fill); -SCM_SRFI4_API SCM scm_u64vector (SCM l); -SCM_SRFI4_API SCM scm_u64vector_length (SCM uvec); -SCM_SRFI4_API SCM scm_u64vector_ref (SCM uvec, SCM index); -SCM_SRFI4_API SCM scm_u64vector_set_x (SCM uvec, SCM index, SCM value); -SCM_SRFI4_API SCM scm_u64vector_to_list (SCM uvec); -SCM_SRFI4_API SCM scm_list_to_u64vector (SCM l); - -SCM_SRFI4_API SCM scm_s64vector_p (SCM obj); -SCM_SRFI4_API SCM scm_make_s64vector (SCM n, SCM fill); -SCM_SRFI4_API SCM scm_s64vector (SCM l); -SCM_SRFI4_API SCM scm_s64vector_length (SCM uvec); -SCM_SRFI4_API SCM scm_s64vector_ref (SCM uvec, SCM index); -SCM_SRFI4_API SCM scm_s64vector_set_x (SCM uvec, SCM index, SCM value); -SCM_SRFI4_API SCM scm_s64vector_to_list (SCM uvec); -SCM_SRFI4_API SCM scm_list_to_s64vector (SCM l); - -SCM_SRFI4_API SCM scm_f32vector_p (SCM obj); -SCM_SRFI4_API SCM scm_make_f32vector (SCM n, SCM fill); -SCM_SRFI4_API SCM scm_f32vector (SCM l); -SCM_SRFI4_API SCM scm_f32vector_length (SCM uvec); -SCM_SRFI4_API SCM scm_f32vector_ref (SCM uvec, SCM index); -SCM_SRFI4_API SCM scm_f32vector_set_x (SCM uvec, SCM index, SCM value); -SCM_SRFI4_API SCM scm_f32vector_to_list (SCM uvec); -SCM_SRFI4_API SCM scm_list_to_f32vector (SCM l); - -SCM_SRFI4_API SCM scm_f64vector_p (SCM obj); -SCM_SRFI4_API SCM scm_make_f64vector (SCM n, SCM fill); -SCM_SRFI4_API SCM scm_f64vector (SCM l); -SCM_SRFI4_API SCM scm_f64vector_length (SCM uvec); -SCM_SRFI4_API SCM scm_f64vector_ref (SCM uvec, SCM index); -SCM_SRFI4_API SCM scm_f64vector_set_x (SCM uvec, SCM index, SCM value); -SCM_SRFI4_API SCM scm_f64vector_to_list (SCM uvec); -SCM_SRFI4_API SCM scm_list_to_f64vector (SCM l); - -SCM_SRFI4_API void scm_init_srfi_4 (void); - -#endif /* SCM_SRFI_4_H */ +#endif /* SCM_SRFI_SRFI_4_H */ diff --git a/srfi/srfi-4.scm b/srfi/srfi-4.scm index 715b555c4..a15f6941c 100644 --- a/srfi/srfi-4.scm +++ b/srfi/srfi-4.scm @@ -1,6 +1,6 @@ ;;; srfi-4.scm --- Homogeneous Numeric Vector Datatypes -;; Copyright (C) 2001, 2002 Free Software Foundation, Inc. +;; Copyright (C) 2001, 2002, 2004 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 @@ -20,13 +20,15 @@ ;;; Commentary: -;; This module implements homogeneous numeric vectors as defined in SRFI-4. -;; This module is fully documented in the Guile Reference Manual. +;; This module exports the homogeneous numeric vector procedures as +;; defined in SRFI-4. They are fully documented in the Guile +;; Reference Manual. ;;; Code: -(define-module (srfi srfi-4) - :export ( +(define-module (srfi srfi-4)) + +(re-export ;;; Unsigned 8-bit vectors. u8vector? make-u8vector u8vector u8vector-length u8vector-ref u8vector-set! u8vector->list list->u8vector @@ -66,112 +68,4 @@ ;;; 64-bit floating point vectors. f64vector? make-f64vector f64vector f64vector-length f64vector-ref f64vector-set! f64vector->list list->f64vector - )) - - -;; Make 'srfi-4 available as a feature identifiere to `cond-expand'. -;; -(cond-expand-provide (current-module) '(srfi-4)) - - -;; Load the compiled primitives from the shared library. -;; -(load-extension "libguile-srfi-srfi-4-v-2" "scm_init_srfi_4") - - -;; Reader extension for #f32() and #f64() vectors. -;; -(define (hash-f char port) - (if (or (char=? (peek-char port) #\3) - (char=? (peek-char port) #\6)) - (let* ((obj (read port))) - (if (number? obj) - (cond ((= obj 32) - (let ((l (read port))) - (if (list? l) - (list->f32vector l) - (error "syntax error in #f32() vector literal")))) - ((= obj 64) - (let ((l (read port))) - (if (list? l) - (list->f64vector l) - (error "syntax error in #f64() vector literal")))) - (else - (error "syntax error in #f...() vector literal"))) - (error "syntax error in #f...() vector literal"))) - #f)) - - -;; Reader extension for #u8(), #u16(), #u32() and #u64() vectors. -;; -(define (hash-u char port) - (if (or (char=? (peek-char port) #\8) - (char=? (peek-char port) #\1) - (char=? (peek-char port) #\3) - (char=? (peek-char port) #\6)) - (let ((obj (read port))) - (cond ((= obj 8) - (let ((l (read port))) - (if (list? l) - (list->u8vector l) - (error "syntax error in #u8() vector literal")))) - ((= obj 16) - (let ((l (read port))) - (if (list? l) - (list->u16vector l) - (error "syntax error in #u16() vector literal")))) - ((= obj 32) - (let ((l (read port))) - (if (list? l) - (list->u32vector l) - (error "syntax error in #u32() vector literal")))) - ((= obj 64) - (let ((l (read port))) - (if (list? l) - (list->u64vector l) - (error "syntax error in #u64() vector literal")))) - (else - (error "syntax error in #u...() vector literal")))) - (error "syntax error in #u...() vector literal"))) - - -;; Reader extension for #s8(), #s16(), #s32() and #s64() vectors. -;; -(define (hash-s char port) - (if (or (char=? (peek-char port) #\8) - (char=? (peek-char port) #\1) - (char=? (peek-char port) #\3) - (char=? (peek-char port) #\6)) - (let ((obj (read port))) - (cond ((= obj 8) - (let ((l (read port))) - (if (list? l) - (list->s8vector l) - (error "syntax error in #s8() vector literal")))) - ((= obj 16) - (let ((l (read port))) - (if (list? l) - (list->s16vector l) - (error "syntax error in #s16() vector literal")))) - ((= obj 32) - (let ((l (read port))) - (if (list? l) - (list->s32vector l) - (error "syntax error in #s32() vector literal")))) - ((= obj 64) - (let ((l (read port))) - (if (list? l) - (list->s64vector l) - (error "syntax error in #s64() vector literal")))) - (else - (error "syntax error in #s...() vector literal")))) - (error "syntax error in #s...() vector literal"))) - - -;; Install the hash extensions. -;; -(read-hash-extend #\f hash-f) -(read-hash-extend #\u hash-u) -(read-hash-extend #\s hash-s) - -;;; srfi-4.scm ends here + ) |