diff options
author | Marius Vollmer <mvo@zagadka.de> | 2004-10-27 18:11:14 +0000 |
---|---|---|
committer | Marius Vollmer <mvo@zagadka.de> | 2004-10-27 18:11:14 +0000 |
commit | e0e496707beaea694fa79b4ca291dbc67abdc328 (patch) | |
tree | 09f5aaaf339b1824d8058e36804b95eb9bdbaa51 | |
parent | 7b1574ed4fe3a2b2ffa0e13a82e8cdaf6f66ef6a (diff) | |
download | guile-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.
-rw-r--r-- | libguile/srfi-4.c | 313 | ||||
-rw-r--r-- | libguile/srfi-4.h | 34 | ||||
-rw-r--r-- | libguile/srfi-4.i.c | 12 | ||||
-rw-r--r-- | libguile/unif.c | 599 | ||||
-rw-r--r-- | libguile/unif.h | 4 |
5 files changed, 671 insertions, 291 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" diff --git a/libguile/srfi-4.h b/libguile/srfi-4.h index afc7e4aef..11014e94e 100644 --- a/libguile/srfi-4.h +++ b/libguile/srfi-4.h @@ -22,6 +22,26 @@ #include "libguile/__scm.h" +/* Generic procedures. + */ + +SCM_API SCM scm_uniform_vector_p (SCM v); +SCM_API SCM scm_uniform_vector_length (SCM v); +SCM_API SCM scm_uniform_vector_ref (SCM v, SCM idx); +SCM_API SCM scm_uniform_vector_set_x (SCM v, SCM idx, SCM val); +SCM_API SCM scm_uniform_vector_to_list (SCM v); + +SCM_API int scm_is_uniform_vector (SCM obj); +SCM_API size_t scm_c_uniform_vector_length (SCM v); +SCM_API size_t scm_c_uniform_vector_size (SCM v); + +SCM_API void *scm_uniform_vector_elements (SCM uvec); +SCM_API size_t scm_uniform_vector_element_size (SCM uvec); +SCM_API void scm_uniform_vector_release (SCM uvec); + +/* Specific procedures. + */ + SCM_API SCM scm_u8vector_p (SCM obj); SCM_API SCM scm_make_u8vector (SCM n, SCM fill); SCM_API SCM scm_u8vector (SCM l); @@ -30,6 +50,7 @@ SCM_API SCM scm_u8vector_ref (SCM uvec, SCM index); SCM_API SCM scm_u8vector_set_x (SCM uvec, SCM index, SCM value); SCM_API SCM scm_u8vector_to_list (SCM uvec); SCM_API SCM scm_list_to_u8vector (SCM l); +SCM_API scm_t_uint8 *scm_u8vector_elements (SCM uvec); SCM_API SCM scm_s8vector_p (SCM obj); SCM_API SCM scm_make_s8vector (SCM n, SCM fill); @@ -39,6 +60,7 @@ SCM_API SCM scm_s8vector_ref (SCM uvec, SCM index); SCM_API SCM scm_s8vector_set_x (SCM uvec, SCM index, SCM value); SCM_API SCM scm_s8vector_to_list (SCM uvec); SCM_API SCM scm_list_to_s8vector (SCM l); +SCM_API scm_t_int8 *scm_s8vector_elements (SCM uvec); SCM_API SCM scm_u16vector_p (SCM obj); SCM_API SCM scm_make_u16vector (SCM n, SCM fill); @@ -48,6 +70,7 @@ SCM_API SCM scm_u16vector_ref (SCM uvec, SCM index); SCM_API SCM scm_u16vector_set_x (SCM uvec, SCM index, SCM value); SCM_API SCM scm_u16vector_to_list (SCM uvec); SCM_API SCM scm_list_to_u16vector (SCM l); +SCM_API scm_t_uint16 *scm_u16vector_elements (SCM uvec); SCM_API SCM scm_s16vector_p (SCM obj); SCM_API SCM scm_make_s16vector (SCM n, SCM fill); @@ -57,6 +80,7 @@ SCM_API SCM scm_s16vector_ref (SCM uvec, SCM index); SCM_API SCM scm_s16vector_set_x (SCM uvec, SCM index, SCM value); SCM_API SCM scm_s16vector_to_list (SCM uvec); SCM_API SCM scm_list_to_s16vector (SCM l); +SCM_API scm_t_int16 *scm_s16vector_elements (SCM uvec); SCM_API SCM scm_u32vector_p (SCM obj); SCM_API SCM scm_make_u32vector (SCM n, SCM fill); @@ -66,6 +90,7 @@ SCM_API SCM scm_u32vector_ref (SCM uvec, SCM index); SCM_API SCM scm_u32vector_set_x (SCM uvec, SCM index, SCM value); SCM_API SCM scm_u32vector_to_list (SCM uvec); SCM_API SCM scm_list_to_u32vector (SCM l); +SCM_API scm_t_uint32 *scm_u32vector_elements (SCM uvec); SCM_API SCM scm_s32vector_p (SCM obj); SCM_API SCM scm_make_s32vector (SCM n, SCM fill); @@ -75,6 +100,7 @@ SCM_API SCM scm_s32vector_ref (SCM uvec, SCM index); SCM_API SCM scm_s32vector_set_x (SCM uvec, SCM index, SCM value); SCM_API SCM scm_s32vector_to_list (SCM uvec); SCM_API SCM scm_list_to_s32vector (SCM l); +SCM_API scm_t_int32 *scm_s32vector_elements (SCM uvec); SCM_API SCM scm_u64vector_p (SCM obj); SCM_API SCM scm_make_u64vector (SCM n, SCM fill); @@ -84,6 +110,7 @@ SCM_API SCM scm_u64vector_ref (SCM uvec, SCM index); SCM_API SCM scm_u64vector_set_x (SCM uvec, SCM index, SCM value); SCM_API SCM scm_u64vector_to_list (SCM uvec); SCM_API SCM scm_list_to_u64vector (SCM l); +SCM_API scm_t_uint64 *scm_u64vector_elements (SCM uvec); SCM_API SCM scm_s64vector_p (SCM obj); SCM_API SCM scm_make_s64vector (SCM n, SCM fill); @@ -93,6 +120,7 @@ SCM_API SCM scm_s64vector_ref (SCM uvec, SCM index); SCM_API SCM scm_s64vector_set_x (SCM uvec, SCM index, SCM value); SCM_API SCM scm_s64vector_to_list (SCM uvec); SCM_API SCM scm_list_to_s64vector (SCM l); +SCM_API scm_t_int64 *scm_s64vector_elements (SCM uvec); SCM_API SCM scm_f32vector_p (SCM obj); SCM_API SCM scm_make_f32vector (SCM n, SCM fill); @@ -102,6 +130,7 @@ SCM_API SCM scm_f32vector_ref (SCM uvec, SCM index); SCM_API SCM scm_f32vector_set_x (SCM uvec, SCM index, SCM value); SCM_API SCM scm_f32vector_to_list (SCM uvec); SCM_API SCM scm_list_to_f32vector (SCM l); +SCM_API float *scm_f32vector_elements (SCM uvec); SCM_API SCM scm_f64vector_p (SCM obj); SCM_API SCM scm_make_f64vector (SCM n, SCM fill); @@ -111,8 +140,13 @@ SCM_API SCM scm_f64vector_ref (SCM uvec, SCM index); SCM_API SCM scm_f64vector_set_x (SCM uvec, SCM index, SCM value); SCM_API SCM scm_f64vector_to_list (SCM uvec); SCM_API SCM scm_list_to_f64vector (SCM l); +SCM_API double *scm_f64vector_elements (SCM uvec); SCM_API SCM scm_i_read_homogenous_vector (SCM port, char pfx); +SCM_API SCM scm_i_uniform_vector_prototype (SCM uvec); +SCM_API const char *scm_i_uniform_vector_tag (SCM uvec); + +SCM_API size_t scm_uniform_element_size (SCM obj); SCM_API void scm_init_srfi_4 (void); diff --git a/libguile/srfi-4.i.c b/libguile/srfi-4.i.c index 3350d60e4..48cc29eae 100644 --- a/libguile/srfi-4.i.c +++ b/libguile/srfi-4.i.c @@ -15,6 +15,10 @@ The tag name of the vector, for example u8. The tag is used to form the function names and is included in the docstrings, for example. + + - CTYPE + + The C type of the elements, for example scm_t_uint8. */ /* The first level does not expand macros in the arguments. */ @@ -113,6 +117,13 @@ SCM_DEFINE (F(scm_list_to_,TAG,vector), "list->"S(TAG)"vector", 1, 0, 0, } #undef FUNC_NAME +CTYPE * +F(scm_,TAG,vector_elements) (SCM obj) +{ + uvec_assert (TYPE, obj); + return (CTYPE *)SCM_UVEC_BASE (obj); +} + #undef paste #undef s_paste #undef stringify @@ -122,3 +133,4 @@ SCM_DEFINE (F(scm_list_to_,TAG,vector), "list->"S(TAG)"vector", 1, 0, 0, #undef TYPE #undef TAG +#undef CTYPE diff --git a/libguile/unif.c b/libguile/unif.c index dceb05b0e..8d9c0b4e2 100644 --- a/libguile/unif.c +++ b/libguile/unif.c @@ -34,6 +34,8 @@ #include <string.h> #include "libguile/_scm.h" +#include "libguile/__scm.h" +#include "libguile/eq.h" #include "libguile/chars.h" #include "libguile/eval.h" #include "libguile/fports.h" @@ -42,6 +44,7 @@ #include "libguile/root.h" #include "libguile/strings.h" #include "libguile/srfi-13.h" +#include "libguile/srfi-4.h" #include "libguile/vectors.h" #include "libguile/validate.h" @@ -59,69 +62,22 @@ /* The set of uniform scm_vector types is: - * Vector of: Called: - * unsigned char string - * char byvect - * boolean bvect - * signed long ivect - * unsigned long uvect - * float fvect - * double dvect + * Vector of: Called: Replaced by: + * unsigned char string u8 + * char byvect s8 + * boolean bvect + * signed long ivect s32 + * unsigned long uvect u32 + * float fvect f32 + * double dvect d32 * complex double cvect - * short svect - * long long llvect + * short svect s16 + * long long llvect s64 */ scm_t_bits scm_tc16_array; static SCM exactly_one_third; -/* 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; - - switch (SCM_TYP7 (obj)) - { - case scm_tc7_bvect: - case scm_tc7_uvect: - case scm_tc7_ivect: - result = sizeof (long); - break; - - case scm_tc7_byvect: - result = sizeof (char); - 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; -} - /* Silly function used not to modify the semantics of the silly * prototype system in order to be backward compatible. */ @@ -168,7 +124,7 @@ scm_make_uve (long k, SCM prot) return scm_cell (SCM_MAKE_BITVECTOR_TAG (0), 0); } else if (SCM_CHARP (prot) && (SCM_CHAR (prot) == '\0')) - return make_uve (scm_tc7_byvect, k, sizeof (char)); + return scm_make_s8vector (scm_from_long (k), SCM_UNDEFINED); else if (SCM_CHARP (prot)) return scm_c_make_string (sizeof (char) * k, SCM_UNDEFINED); else if (SCM_I_INUMP (prot)) @@ -207,38 +163,6 @@ scm_make_uve (long k, SCM prot) } #undef FUNC_NAME -SCM_DEFINE (scm_uniform_vector_length, "uniform-vector-length", 1, 0, 0, - (SCM v), - "Return the number of elements in @var{uve}.") -#define FUNC_NAME s_scm_uniform_vector_length -{ - SCM_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_byvect: - 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 - SCM_DEFINE (scm_array_p, "array?", 1, 1, 0, (SCM v, SCM prot), "Return @code{#t} if the @var{obj} is an array, and @code{#f} if\n" @@ -253,16 +177,22 @@ SCM_DEFINE (scm_array_p, "array?", 1, 1, 0, if (SCM_IMP (v)) return SCM_BOOL_F; - while (SCM_TYP7 (v) == scm_tc7_smob) + while (SCM_ARRAYP (v)) { - if (!SCM_ARRAYP (v)) - return SCM_BOOL_F; if (nprot) return SCM_BOOL_T; if (enclosed++) return SCM_BOOL_F; v = SCM_ARRAY_V (v); - } + } + + if (scm_is_uniform_vector (v)) + { + if (nprot) + return SCM_BOOL_T; + else + return scm_eq_p (prot, scm_i_uniform_vector_prototype (v)); + } if (nprot) { @@ -270,7 +200,6 @@ SCM_DEFINE (scm_array_p, "array?", 1, 1, 0, { case scm_tc7_bvect: case scm_tc7_string: - case scm_tc7_byvect: case scm_tc7_uvect: case scm_tc7_ivect: case scm_tc7_svect: @@ -290,7 +219,7 @@ SCM_DEFINE (scm_array_p, "array?", 1, 1, 0, else { int protp = 0; - + switch (SCM_TYP7 (v)) { case scm_tc7_bvect: @@ -299,9 +228,6 @@ SCM_DEFINE (scm_array_p, "array?", 1, 1, 0, case scm_tc7_string: protp = SCM_CHARP(prot) && (SCM_CHAR (prot) != '\0'); break; - case scm_tc7_byvect: - protp = scm_is_eq (prot, SCM_MAKE_CHAR ('\0')); - break; case scm_tc7_uvect: protp = SCM_I_INUMP(prot) && SCM_I_INUM(prot)>0; break; @@ -351,6 +277,9 @@ SCM_DEFINE (scm_array_rank, "array-rank", 1, 0, 0, "not an array, @code{0} is returned.") #define FUNC_NAME s_scm_array_rank { + if (scm_is_uniform_vector (ra)) + return scm_from_int (1); + if (SCM_IMP (ra)) return SCM_INUM0; switch (SCM_TYP7 (ra)) @@ -360,7 +289,6 @@ SCM_DEFINE (scm_array_rank, "array-rank", 1, 0, 0, case scm_tc7_string: case scm_tc7_vector: case scm_tc7_wvect: - case scm_tc7_byvect: case scm_tc7_uvect: case scm_tc7_ivect: case scm_tc7_fvect: @@ -394,6 +322,10 @@ SCM_DEFINE (scm_array_dimensions, "array-dimensions", 1, 0, 0, scm_t_array_dim *s; if (SCM_IMP (ra)) return SCM_BOOL_F; + + if (scm_is_uniform_vector (ra)) + return scm_cons (scm_uniform_vector_length (ra), SCM_EOL); + switch (SCM_TYP7 (ra)) { default: @@ -402,7 +334,6 @@ SCM_DEFINE (scm_array_dimensions, "array-dimensions", 1, 0, 0, case scm_tc7_vector: case scm_tc7_wvect: case scm_tc7_bvect: - case scm_tc7_byvect: case scm_tc7_uvect: case scm_tc7_ivect: case scm_tc7_fvect: @@ -587,7 +518,7 @@ SCM_DEFINE (scm_dimensions_to_uniform_array, "dimensions->uniform-array", 2, 1, SCM answer = scm_make_uve (scm_to_long (dims), prot); if (!SCM_UNBNDP (fill)) scm_array_fill_x (answer, fill); - else if (scm_is_symbol (prot)) + else if (scm_is_symbol (prot) || scm_is_eq (prot, SCM_MAKE_CHAR (0))) scm_array_fill_x (answer, scm_from_int (0)); else scm_array_fill_x (answer, prot); @@ -612,7 +543,7 @@ SCM_DEFINE (scm_dimensions_to_uniform_array, "dimensions->uniform-array", 2, 1, if (!SCM_UNBNDP (fill)) scm_array_fill_x (ra, fill); - else if (scm_is_symbol (prot)) + else if (scm_is_symbol (prot) || scm_is_eq (prot, SCM_MAKE_CHAR (0))) scm_array_fill_x (ra, scm_from_int (0)); else scm_array_fill_x (ra, prot); @@ -804,13 +735,25 @@ SCM_DEFINE (scm_transpose_array, "transpose-array", 1, 0, 1, SCM_VALIDATE_REST_ARGUMENT (args); SCM_ASSERT (SCM_NIMP (ra), ra, SCM_ARG1, FUNC_NAME); + + if (scm_is_uniform_vector (ra)) + { + /* Make sure that we are called with a single zero as + arguments. + */ + if (scm_is_null (args) || !scm_is_null (SCM_CDR (args))) + SCM_WRONG_NUM_ARGS (); + SCM_VALIDATE_INT_COPY (SCM_ARG2, SCM_CAR (args), i); + SCM_ASSERT_RANGE (SCM_ARG2, SCM_CAR (args), i == 0); + return ra; + } + switch (SCM_TYP7 (ra)) { default: badarg:SCM_WRONG_TYPE_ARG (1, ra); case scm_tc7_bvect: case scm_tc7_string: - case scm_tc7_byvect: case scm_tc7_uvect: case scm_tc7_ivect: case scm_tc7_fvect: @@ -915,13 +858,16 @@ SCM_DEFINE (scm_enclose_array, "enclose-array", 1, 0, 1, SCM_WRONG_NUM_ARGS (); ra_inr = scm_make_ra (ninr); SCM_ASRTGO (SCM_NIMP (ra), badarg1); + + if (scm_is_uniform_vector (ra)) + goto uniform_vector; + switch SCM_TYP7 (ra) { default: badarg1:SCM_WRONG_TYPE_ARG (1, ra); case scm_tc7_string: case scm_tc7_bvect: - case scm_tc7_byvect: case scm_tc7_uvect: case scm_tc7_ivect: case scm_tc7_fvect: @@ -933,6 +879,7 @@ SCM_DEFINE (scm_enclose_array, "enclose-array", 1, 0, 1, #if SCM_SIZEOF_LONG_LONG != 0 case scm_tc7_llvect: #endif + uniform_vector: s->lbnd = 0; s->ubnd = scm_to_long (scm_uniform_vector_length (ra)) - 1; s->inc = 1; @@ -1005,6 +952,10 @@ SCM_DEFINE (scm_array_in_bounds_p, "array-in-bounds?", 1, 0, 1, pos = scm_to_long (ind); } tail: + + if (scm_is_uniform_vector (v)) + goto uniform_vector; + switch SCM_TYP7 (v) { default: @@ -1042,7 +993,6 @@ tail: goto tail; case scm_tc7_bvect: case scm_tc7_string: - case scm_tc7_byvect: case scm_tc7_uvect: case scm_tc7_ivect: case scm_tc7_fvect: @@ -1054,6 +1004,7 @@ tail: #endif case scm_tc7_vector: case scm_tc7_wvect: + uniform_vector: { unsigned long length = scm_to_ulong (scm_uniform_vector_length (v)); SCM_ASRTGO (scm_is_null (args) && scm_is_integer (ind), wna); @@ -1064,15 +1015,11 @@ tail: #undef FUNC_NAME -SCM_REGISTER_PROC(s_array_ref, "array-ref", 1, 0, 1, scm_uniform_vector_ref); - - -SCM_DEFINE (scm_uniform_vector_ref, "uniform-vector-ref", 2, 0, 0, +SCM_DEFINE (scm_array_ref, "array-ref", 1, 0, 1, (SCM v, SCM args), - "@deffnx {Scheme Procedure} array-ref v . args\n" "Return the element at the @code{(index1, index2)} element in\n" "@var{array}.") -#define FUNC_NAME s_scm_uniform_vector_ref +#define FUNC_NAME s_scm_array_ref { long pos; @@ -1102,6 +1049,10 @@ SCM_DEFINE (scm_uniform_vector_ref, "uniform-vector-ref", 2, 0, 0, length = scm_to_ulong (scm_uniform_vector_length (v)); SCM_ASRTGO (pos >= 0 && pos < length, outrng); } + + if (scm_is_uniform_vector (v)) + return scm_uniform_vector_ref (v, scm_from_long (pos)); + switch SCM_TYP7 (v) { default: @@ -1136,12 +1087,10 @@ SCM_DEFINE (scm_uniform_vector_ref, "uniform-vector-ref", 2, 0, 0, return SCM_BOOL_F; case scm_tc7_string: return scm_c_string_ref (v, pos); - case scm_tc7_byvect: - return scm_from_schar (((char *) SCM_UVECTOR_BASE (v))[pos]); - case scm_tc7_uvect: + case scm_tc7_uvect: return scm_from_ulong (((unsigned long *) SCM_VELTS (v))[pos]); - case scm_tc7_ivect: - return scm_from_long (((signed long *) SCM_VELTS (v))[pos]); + case scm_tc7_ivect: + return scm_from_long (((signed long *) SCM_VELTS (v))[pos]); case scm_tc7_svect: return scm_from_short (((short *) SCM_CELL_WORD_1 (v))[pos]); @@ -1171,6 +1120,9 @@ SCM scm_cvref (SCM v, unsigned long pos, SCM last) #define FUNC_NAME "scm_cvref" { + if (scm_is_uniform_vector (v)) + return scm_uniform_vector_ref (v, scm_from_ulong (pos)); + switch SCM_TYP7 (v) { default: @@ -1182,8 +1134,6 @@ scm_cvref (SCM v, unsigned long pos, SCM last) return SCM_BOOL_F; case scm_tc7_string: return scm_c_string_ref (v, pos); - case scm_tc7_byvect: - return scm_from_char (((char *) SCM_UVECTOR_BASE (v))[pos]); case scm_tc7_uvect: return scm_from_ulong (((unsigned long *) SCM_VELTS (v))[pos]); case scm_tc7_ivect: @@ -1274,6 +1224,10 @@ SCM_DEFINE (scm_array_set_x, "array-set!", 2, 0, 1, length = scm_to_ulong (scm_uniform_vector_length (v)); SCM_ASRTGO (pos >= 0 && pos < length, outrng); } + + if (scm_is_uniform_vector (v)) + return scm_uniform_vector_set_x (v, scm_from_long (pos), obj); + switch (SCM_TYP7 (v)) { default: badarg1: @@ -1297,11 +1251,6 @@ SCM_DEFINE (scm_array_set_x, "array-set!", 2, 0, 1, SCM_ASRTGO (SCM_CHARP (obj), badobj); scm_c_string_set_x (v, pos, obj); break; - case scm_tc7_byvect: - if (SCM_CHARP (obj)) - obj = scm_from_schar ((char) SCM_CHAR (obj)); - ((char *) SCM_UVECTOR_BASE (v))[pos] = scm_to_schar (obj); - break; case scm_tc7_uvect: ((unsigned long *) SCM_UVECTOR_BASE (v))[pos] = scm_to_ulong (obj); break; @@ -1359,8 +1308,13 @@ SCM_DEFINE (scm_array_contents, "array-contents", 1, 1, 0, #define FUNC_NAME s_scm_array_contents { SCM sra; + + if (scm_is_uniform_vector (ra)) + return ra; + if (SCM_IMP (ra)) return SCM_BOOL_F; + switch SCM_TYP7 (ra) { default: @@ -1369,7 +1323,6 @@ SCM_DEFINE (scm_array_contents, "array-contents", 1, 1, 0, case scm_tc7_wvect: case scm_tc7_string: case scm_tc7_bvect: - case scm_tc7_byvect: case scm_tc7_uvect: case scm_tc7_ivect: case scm_tc7_fvect: @@ -1491,61 +1444,63 @@ SCM_DEFINE (scm_uniform_array_read_x, "uniform-array-read!", 1, 3, 0, : scm_to_long (scm_uniform_vector_length (v))); loop: - switch SCM_TYP7 (v) + if (scm_is_uniform_vector (v)) { - default: - badarg1:SCM_WRONG_TYPE_ARG (SCM_ARG1, v); - case scm_tc7_smob: - SCM_ASRTGO (SCM_ARRAYP (v), badarg1); - cra = scm_ra2contig (ra, 0); - cstart += SCM_ARRAY_BASE (cra); - vlen = SCM_ARRAY_DIMS (cra)->inc * - (SCM_ARRAY_DIMS (cra)->ubnd - SCM_ARRAY_DIMS (cra)->lbnd + 1); - v = SCM_ARRAY_V (cra); - goto loop; - case scm_tc7_string: - base = NULL; /* writing to strings is special, see below. */ - sz = sizeof (char); - break; - case scm_tc7_bvect: - base = (char *) SCM_BITVECTOR_BASE (v); - vlen = (vlen + SCM_LONG_BIT - 1) / SCM_LONG_BIT; - cstart /= SCM_LONG_BIT; - sz = sizeof (long); - break; - case scm_tc7_byvect: - base = (char *) SCM_UVECTOR_BASE (v); - sz = sizeof (char); - break; - case scm_tc7_uvect: - case scm_tc7_ivect: - base = (char *) SCM_UVECTOR_BASE (v); - sz = sizeof (long); - break; - case scm_tc7_svect: - base = (char *) SCM_UVECTOR_BASE (v); - sz = sizeof (short); - break; + base = scm_uniform_vector_elements (v); + sz = scm_uniform_vector_element_size (v); + } + else + switch SCM_TYP7 (v) + { + default: + badarg1:SCM_WRONG_TYPE_ARG (SCM_ARG1, v); + case scm_tc7_smob: + SCM_ASRTGO (SCM_ARRAYP (v), badarg1); + cra = scm_ra2contig (ra, 0); + cstart += SCM_ARRAY_BASE (cra); + vlen = SCM_ARRAY_DIMS (cra)->inc * + (SCM_ARRAY_DIMS (cra)->ubnd - SCM_ARRAY_DIMS (cra)->lbnd + 1); + v = SCM_ARRAY_V (cra); + goto loop; + case scm_tc7_string: + base = NULL; /* writing to strings is special, see below. */ + sz = sizeof (char); + break; + case scm_tc7_bvect: + base = (char *) SCM_BITVECTOR_BASE (v); + vlen = (vlen + SCM_LONG_BIT - 1) / SCM_LONG_BIT; + cstart /= SCM_LONG_BIT; + sz = sizeof (long); + break; + case scm_tc7_uvect: + case scm_tc7_ivect: + base = (char *) SCM_UVECTOR_BASE (v); + sz = sizeof (long); + break; + case scm_tc7_svect: + base = (char *) SCM_UVECTOR_BASE (v); + sz = sizeof (short); + break; #if SCM_SIZEOF_LONG_LONG != 0 - case scm_tc7_llvect: - base = (char *) SCM_UVECTOR_BASE (v); - sz = sizeof (long long); - break; + case scm_tc7_llvect: + base = (char *) SCM_UVECTOR_BASE (v); + sz = sizeof (long long); + break; #endif - case scm_tc7_fvect: - base = (char *) SCM_UVECTOR_BASE (v); - sz = sizeof (float); - break; - case scm_tc7_dvect: - base = (char *) SCM_UVECTOR_BASE (v); - sz = sizeof (double); - break; - case scm_tc7_cvect: - base = (char *) SCM_UVECTOR_BASE (v); - sz = 2 * sizeof (double); - break; - } - + case scm_tc7_fvect: + base = (char *) SCM_UVECTOR_BASE (v); + sz = sizeof (float); + break; + case scm_tc7_dvect: + base = (char *) SCM_UVECTOR_BASE (v); + sz = sizeof (double); + break; + case scm_tc7_cvect: + base = (char *) SCM_UVECTOR_BASE (v); + sz = 2 * sizeof (double); + break; + } + cend = vlen; if (!SCM_UNBNDP (start)) { @@ -1675,61 +1630,63 @@ SCM_DEFINE (scm_uniform_array_write, "uniform-array-write", 1, 3, 0, : scm_to_long (scm_uniform_vector_length (v))); loop: - switch SCM_TYP7 (v) + if (scm_is_uniform_vector (v)) { - default: - badarg1:SCM_WRONG_TYPE_ARG (1, v); - case scm_tc7_smob: - SCM_ASRTGO (SCM_ARRAYP (v), badarg1); - v = scm_ra2contig (v, 1); - cstart = SCM_ARRAY_BASE (v); - vlen = (SCM_ARRAY_DIMS (v)->inc - * (SCM_ARRAY_DIMS (v)->ubnd - SCM_ARRAY_DIMS (v)->lbnd + 1)); - v = SCM_ARRAY_V (v); - goto loop; - case scm_tc7_string: - base = scm_i_string_chars (v); - sz = sizeof (char); - break; - case scm_tc7_bvect: - base = (char *) SCM_BITVECTOR_BASE (v); - vlen = (vlen + SCM_LONG_BIT - 1) / SCM_LONG_BIT; - cstart /= SCM_LONG_BIT; - sz = sizeof (long); - break; - case scm_tc7_byvect: - base = (char *) SCM_UVECTOR_BASE (v); - sz = sizeof (char); - break; - case scm_tc7_uvect: - case scm_tc7_ivect: - base = (char *) SCM_UVECTOR_BASE (v); - sz = sizeof (long); - break; - case scm_tc7_svect: - base = (char *) SCM_UVECTOR_BASE (v); - sz = sizeof (short); - break; + base = scm_uniform_vector_elements (v); + sz = scm_uniform_vector_element_size (v); + } + else + switch SCM_TYP7 (v) + { + default: + badarg1:SCM_WRONG_TYPE_ARG (1, v); + case scm_tc7_smob: + SCM_ASRTGO (SCM_ARRAYP (v), badarg1); + v = scm_ra2contig (v, 1); + cstart = SCM_ARRAY_BASE (v); + vlen = (SCM_ARRAY_DIMS (v)->inc + * (SCM_ARRAY_DIMS (v)->ubnd - SCM_ARRAY_DIMS (v)->lbnd + 1)); + v = SCM_ARRAY_V (v); + goto loop; + case scm_tc7_string: + base = scm_i_string_chars (v); + sz = sizeof (char); + break; + case scm_tc7_bvect: + base = (char *) SCM_BITVECTOR_BASE (v); + vlen = (vlen + SCM_LONG_BIT - 1) / SCM_LONG_BIT; + cstart /= SCM_LONG_BIT; + sz = sizeof (long); + break; + case scm_tc7_uvect: + case scm_tc7_ivect: + base = (char *) SCM_UVECTOR_BASE (v); + sz = sizeof (long); + break; + case scm_tc7_svect: + base = (char *) SCM_UVECTOR_BASE (v); + sz = sizeof (short); + break; #if SCM_SIZEOF_LONG_LONG != 0 - case scm_tc7_llvect: - base = (char *) SCM_UVECTOR_BASE (v); - sz = sizeof (long long); - break; + case scm_tc7_llvect: + base = (char *) SCM_UVECTOR_BASE (v); + sz = sizeof (long long); + break; #endif - case scm_tc7_fvect: - base = (char *) SCM_UVECTOR_BASE (v); - sz = sizeof (float); - break; - case scm_tc7_dvect: - base = (char *) SCM_UVECTOR_BASE (v); - sz = sizeof (double); - break; - case scm_tc7_cvect: - base = (char *) SCM_UVECTOR_BASE (v); - sz = 2 * sizeof (double); - break; - } - + case scm_tc7_fvect: + base = (char *) SCM_UVECTOR_BASE (v); + sz = sizeof (float); + break; + case scm_tc7_dvect: + base = (char *) SCM_UVECTOR_BASE (v); + sz = sizeof (double); + break; + case scm_tc7_cvect: + base = (char *) SCM_UVECTOR_BASE (v); + sz = 2 * sizeof (double); + break; + } + cend = vlen; if (!SCM_UNBNDP (start)) { @@ -2128,6 +2085,10 @@ SCM_DEFINE (scm_array_to_list, "array->list", 1, 0, 0, { SCM res = SCM_EOL; register long k; + + if (scm_is_uniform_vector (v)) + return scm_uniform_vector_to_list (v); + SCM_ASRTGO (SCM_NIMP (v), badarg1); switch SCM_TYP7 (v) { @@ -2152,14 +2113,6 @@ SCM_DEFINE (scm_array_to_list, "array->list", 1, 0, 0, res = scm_cons (scm_from_bool(((long *) data)[k] & mask), res); return res; } - case scm_tc7_byvect: - { - signed char *data = (signed char *) SCM_VELTS (v); - unsigned long k = SCM_UVECTOR_LENGTH (v); - while (k != 0) - res = scm_cons (scm_from_schar (data[--k]), res); - return res; - } case scm_tc7_uvect: { unsigned long *data = (unsigned long *)SCM_VELTS(v); @@ -2359,7 +2312,7 @@ tail: default: /* scm_tc7_bvect and scm_tc7_llvect only? */ if (n-- > 0) - scm_iprin1 (scm_uniform_vector_ref (ra, scm_from_ulong (j)), port, pstate); + scm_iprin1 (scm_cvref (ra, j, SCM_UNDEFINED), port, pstate); for (j += inc; n-- > 0; j += inc) { scm_putc (' ', port); @@ -2384,20 +2337,11 @@ tail: scm_remember_upto_here_1 (ra); } break; - case scm_tc7_byvect: - if (n-- > 0) - scm_intprint (((char *) SCM_CELL_WORD_1 (ra))[j], 10, port); - for (j += inc; n-- > 0; j += inc) - { - scm_putc (' ', port); - scm_intprint (((char *)SCM_CELL_WORD_1 (ra))[j], 10, port); - } - break; - + case scm_tc7_uvect: { char str[11]; - + if (n-- > 0) { /* intprint can't handle >= 2^31. */ @@ -2420,7 +2364,7 @@ tail: scm_intprint (((signed long *) SCM_VELTS (ra))[j], 10, port); } break; - + case scm_tc7_svect: if (n-- > 0) scm_intprint (((short *) SCM_CELL_WORD_1 (ra))[j], 10, port); @@ -2430,7 +2374,7 @@ tail: scm_intprint (((short *) SCM_CELL_WORD_1 (ra))[j], 10, port); } break; - + case scm_tc7_fvect: if (n-- > 0) { @@ -2483,13 +2427,158 @@ tail: } } +/* Print dimension DIM of ARRAY. + */ +static int +scm_i_print_array_dimension (SCM array, int dim, int base, + SCM port, scm_print_state *pstate) +{ + scm_t_array_dim *dim_spec = SCM_ARRAY_DIMS (array) + dim; + long idx; + + scm_putc ('(', port); + +#if 0 + scm_putc ('{', port); + scm_intprint (dim_spec->lbnd, 10, port); + scm_putc (':', port); + scm_intprint (dim_spec->ubnd, 10, port); + scm_putc (':', port); + scm_intprint (dim_spec->inc, 10, port); + scm_putc ('}', port); +#endif + + for (idx = dim_spec->lbnd; idx <= dim_spec->ubnd; idx++) + { + if (dim < SCM_ARRAY_NDIM(array)-1) + scm_i_print_array_dimension (array, dim+1, base, port, pstate); + else + scm_iprin1 (scm_cvref (SCM_ARRAY_V (array), base, SCM_UNDEFINED), + port, pstate); + if (idx < dim_spec->ubnd) + scm_putc (' ', port); + base += dim_spec->inc; + } + + scm_putc (')', port); + return 1; +} + +static const char * +scm_i_legacy_tag (SCM v) +{ + switch (SCM_TYP7 (v)) + { + case scm_tc7_bvect: + return "b"; + case scm_tc7_string: + return "a"; + case scm_tc7_uvect: + return "u"; + case scm_tc7_ivect: + return "e"; + case scm_tc7_svect: + return "h"; +#if SCM_SIZEOF_LONG_LONG != 0 + case scm_tc7_llvect: + return "l"; +#endif + case scm_tc7_fvect: + return "s"; + case scm_tc7_dvect: + return "i"; + case scm_tc7_cvect: + return "c"; + case scm_tc7_vector: + case scm_tc7_wvect: + return ""; + default: + return "?"; + } +} + +/* Print a array. (Only for strict arrays, not for strings, uniform + vectors, vectors and other stuff that can masquerade as an array.) +*/ + +/* The array tag is generally of the form + * + * #<rank><unif><@lower><@lower>... + * + * <rank> is a positive integer in decimal giving the rank of the + * array. It is omitted when the rank is 1. + * + * <unif> is the tag for a uniform (or homogenous) numeric vector, + * like u8, s16, etc, as defined by SRFI-4. It is omitted when the + * array is not uniform. + * + * <@lower> is a 'at' sign followed by a integer in decimal giving the + * lower bound of a dimension. There is one <@lower> for each + * dimension. When all lower bounds are zero, all <@lower> are + * omitted. + * + * Thus, + * + * #(1 2 3) is non-uniform array of rank 1 with lower bound 0 in + * dimension 0. (I.e., a regular vector.) + * + * #@2(1 2 3) is non-uniform array of rank 1 with lower bound 2 in + * dimension 0. + * + * #2((1 2 3) (4 5 6)) is a non-uniform array of rank 2; a 3x3 + * matrix with index ranges 0..2 and 0..2. + * + * #u32(0 1 2) is a uniform u8 array of rank 1. + * + * #2u32@2@3((1 2) (2 3)) is a uniform u8 array of rank 2 with index + * ranges 2..3 and 3..4. + */ + +static int +scm_i_print_array (SCM array, SCM port, scm_print_state *pstate) +{ + long ndim = SCM_ARRAY_NDIM (array); + scm_t_array_dim *dim_specs = SCM_ARRAY_DIMS (array); + unsigned long base = SCM_ARRAY_BASE (array); + long i; + + scm_putc ('#', port); + if (ndim != 1) + scm_intprint (ndim, 10, port); + if (scm_is_uniform_vector (SCM_ARRAY_V (array))) + scm_puts (scm_i_uniform_vector_tag (SCM_ARRAY_V (array)), port); + else + scm_puts (scm_i_legacy_tag (SCM_ARRAY_V (array)), port); + for (i = 0; i < ndim; i++) + if (dim_specs[i].lbnd != 0) + { + for (i = 0; i < ndim; i++) + { + scm_putc ('@', port); + scm_uintprint (dim_specs[i].lbnd, 10, port); + } + break; + } + +#if 0 + scm_putc ('{', port); + scm_uintprint (base, 10, port); + scm_putc ('}', port); +#endif + + return scm_i_print_array_dimension (array, 0, base, port, pstate); +} int scm_raprin1 (SCM exp, SCM port, scm_print_state *pstate) { SCM v = exp; unsigned long base = 0; + + if (SCM_ARRAYP (exp)) // && scm_is_uniform_vector (SCM_ARRAY_V (exp))) + return scm_i_print_array (exp, port, pstate); + scm_putc ('#', port); tail: switch SCM_TYP7 (v) @@ -2545,9 +2634,6 @@ tail: case scm_tc7_string: scm_putc ('a', port); break; - case scm_tc7_byvect: - scm_putc ('y', port); - break; case scm_tc7_uvect: scm_putc ('u', port); break; @@ -2588,6 +2674,9 @@ SCM_DEFINE (scm_array_prototype, "array-prototype", 1, 0, 0, int enclosed = 0; SCM_ASRTGO (SCM_NIMP (ra), badarg); loop: + if (scm_is_uniform_vector (ra)) + return scm_i_uniform_vector_prototype (ra); + switch SCM_TYP7 (ra) { default: @@ -2605,8 +2694,6 @@ loop: return SCM_BOOL_T; case scm_tc7_string: return SCM_MAKE_CHAR ('a'); - case scm_tc7_byvect: - return SCM_MAKE_CHAR ('\0'); case scm_tc7_uvect: return scm_from_int (1); case scm_tc7_ivect: diff --git a/libguile/unif.h b/libguile/unif.h index 80eaa674e..197cfb91f 100644 --- a/libguile/unif.h +++ b/libguile/unif.h @@ -85,9 +85,7 @@ SCM_API scm_t_bits scm_tc16_array; -SCM_API size_t scm_uniform_element_size (SCM obj); SCM_API SCM scm_make_uve (long k, SCM prot); -SCM_API SCM scm_uniform_vector_length (SCM v); SCM_API SCM scm_array_p (SCM v, SCM prot); SCM_API SCM scm_array_rank (SCM ra); SCM_API SCM scm_array_dimensions (SCM ra); @@ -103,7 +101,7 @@ SCM_API SCM scm_make_shared_array (SCM oldra, SCM mapfunc, SCM dims); SCM_API SCM scm_transpose_array (SCM ra, SCM args); SCM_API SCM scm_enclose_array (SCM ra, SCM axes); SCM_API SCM scm_array_in_bounds_p (SCM v, SCM args); -SCM_API SCM scm_uniform_vector_ref (SCM v, SCM args); +SCM_API SCM scm_array_ref (SCM v, SCM args); SCM_API SCM scm_cvref (SCM v, unsigned long pos, SCM last); SCM_API SCM scm_array_set_x (SCM v, SCM obj, SCM args); SCM_API SCM scm_array_contents (SCM ra, SCM strict); |