mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-15 08:10:17 +02:00
Code Activity

* srfi-4.h, srfi-4.i.c (scm_u8vector_elements, etc): New.

Browse source 
* 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.
This commit is contained in:
Marius Vollmer 2004-10-27 18:11:14 +00:00
parent 7b1574ed4f
commit e0e496707b
5 changed files with 673 additions and 293 deletions
Download patch file Download diff file Expand all files Collapse all files

313
libguile/srfi-4.c
View file

@ -65,6 +65,14 @@ static const int uvec_sizes[10] = {
sizeof(float), sizeof(double) 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] = { static const char *uvec_names[10] = {
"u8vector", "s8vector", "u8vector", "s8vector",
"u16vector", "s16vector", "u16vector", "s16vector",
@ -99,30 +107,29 @@ uvec_print (SCM uvec, SCM port, scm_print_state *pstate)
size_t i = 0; size_t i = 0;
const size_t uvlen = SCM_UVEC_LENGTH (uvec); const size_t uvlen = SCM_UVEC_LENGTH (uvec);
char *tagstr;
void *uptr = SCM_UVEC_BASE (uvec); void *uptr = SCM_UVEC_BASE (uvec);
switch (SCM_UVEC_TYPE (uvec)) switch (SCM_UVEC_TYPE (uvec))
{ {
case SCM_UVEC_U8: tagstr = "u8"; np.u8 = (scm_t_uint8 *) uptr; break; case SCM_UVEC_U8: np.u8 = (scm_t_uint8 *) uptr; break;
case SCM_UVEC_S8: tagstr = "s8"; np.s8 = (scm_t_int8 *) uptr; break; case SCM_UVEC_S8: np.s8 = (scm_t_int8 *) uptr; break;
case SCM_UVEC_U16: tagstr = "u16"; np.u16 = (scm_t_uint16 *) uptr; break; case SCM_UVEC_U16: np.u16 = (scm_t_uint16 *) uptr; break;
case SCM_UVEC_S16: tagstr = "s16"; np.s16 = (scm_t_int16 *) uptr; break; case SCM_UVEC_S16: np.s16 = (scm_t_int16 *) uptr; break;
case SCM_UVEC_U32: tagstr = "u32"; np.u32 = (scm_t_uint32 *) uptr; break; case SCM_UVEC_U32: np.u32 = (scm_t_uint32 *) uptr; break;
case SCM_UVEC_S32: tagstr = "s32"; np.s32 = (scm_t_int32 *) uptr; break; case SCM_UVEC_S32: np.s32 = (scm_t_int32 *) uptr; break;
#if SCM_HAVE_T_INT64 #if SCM_HAVE_T_INT64
case SCM_UVEC_U64: tagstr = "u64"; np.u64 = (scm_t_uint64 *) uptr; break; case SCM_UVEC_U64: np.u64 = (scm_t_uint64 *) uptr; break;
case SCM_UVEC_S64: tagstr = "s64"; np.s64 = (scm_t_int64 *) uptr; break; case SCM_UVEC_S64: np.s64 = (scm_t_int64 *) uptr; break;
#endif #endif
case SCM_UVEC_F32: tagstr = "f32"; np.f32 = (float *) uptr; break; case SCM_UVEC_F32: np.f32 = (float *) uptr; break;
case SCM_UVEC_F64: tagstr = "f64"; np.f64 = (double *) uptr; break; case SCM_UVEC_F64: np.f64 = (double *) uptr; break;
default: default:
abort (); /* Sanity check. */ abort (); /* Sanity check. */
break; break;
} }
scm_putc ('#', port); scm_putc ('#', port);
scm_puts (tagstr, port); scm_puts (uvec_tags [SCM_UVEC_TYPE (uvec)], port);
scm_putc ('(', port); scm_putc ('(', port);
while (i < uvlen) while (i < uvlen)
@ -153,6 +160,12 @@ uvec_print (SCM uvec, SCM port, scm_print_state *pstate)
return 1; return 1;
} }
const char *
scm_i_uniform_vector_tag (SCM uvec)
{
return uvec_tags[SCM_UVEC_TYPE (uvec)];
}
static SCM static SCM
uvec_equalp (SCM a, SCM b) uvec_equalp (SCM a, SCM b)
{ {
@ -426,48 +439,284 @@ scm_i_read_homogenous_vector (SCM port, char pfx)
return SCM_BOOL_F; 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. */ /* Exported procedures. */
/* ================================================================ */ /* ================================================================ */
#define TYPE SCM_UVEC_U8 #define TYPE SCM_UVEC_U8
#define TAG u8 #define TAG u8
#define CTYPE scm_t_uint8
#include "libguile/srfi-4.i.c" #include "libguile/srfi-4.i.c"
#define TYPE SCM_UVEC_S8 #define TYPE SCM_UVEC_S8
#define TAG s8 #define TAG s8
#define CTYPE scm_t_int8
#include "libguile/srfi-4.i.c" #include "libguile/srfi-4.i.c"
#define TYPE SCM_UVEC_U16 #define TYPE SCM_UVEC_U16
#define TAG u16 #define TAG u16
#define CTYPE scm_t_uint16
#include "libguile/srfi-4.i.c" #include "libguile/srfi-4.i.c"
#define TYPE SCM_UVEC_S16 #define TYPE SCM_UVEC_S16
#define TAG s16 #define TAG s16
#define CTYPE scm_t_int16
#include "libguile/srfi-4.i.c" #include "libguile/srfi-4.i.c"
#define TYPE SCM_UVEC_U32 #define TYPE SCM_UVEC_U32
#define TAG u32 #define TAG u32
#define CTYPE scm_t_uint32
#include "libguile/srfi-4.i.c" #include "libguile/srfi-4.i.c"
#define TYPE SCM_UVEC_S32 #define TYPE SCM_UVEC_S32
#define TAG s32 #define TAG s32
#define CTYPE scm_t_int32
#include "libguile/srfi-4.i.c" #include "libguile/srfi-4.i.c"
#define TYPE SCM_UVEC_U64 #define TYPE SCM_UVEC_U64
#define TAG u64 #define TAG u64
#define CTYPE scm_t_uint64
#include "libguile/srfi-4.i.c" #include "libguile/srfi-4.i.c"
#define TYPE SCM_UVEC_S64 #define TYPE SCM_UVEC_S64
#define TAG s64 #define TAG s64
#define CTYPE scm_t_int64
#include "libguile/srfi-4.i.c" #include "libguile/srfi-4.i.c"
#define TYPE SCM_UVEC_F32 #define TYPE SCM_UVEC_F32
#define TAG f32 #define TAG f32
#define CTYPE float
#include "libguile/srfi-4.i.c" #include "libguile/srfi-4.i.c"
#define TYPE SCM_UVEC_F64 #define TYPE SCM_UVEC_F64
#define TAG f64 #define TAG f64
#define CTYPE double
#include "libguile/srfi-4.i.c" #include "libguile/srfi-4.i.c"

34
libguile/srfi-4.h
View file

@ -22,6 +22,26 @@
#include "libguile/__scm.h" #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_u8vector_p (SCM obj);
SCM_API SCM scm_make_u8vector (SCM n, SCM fill); SCM_API SCM scm_make_u8vector (SCM n, SCM fill);
SCM_API SCM scm_u8vector (SCM l); 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_set_x (SCM uvec, SCM index, SCM value);
SCM_API SCM scm_u8vector_to_list (SCM uvec); SCM_API SCM scm_u8vector_to_list (SCM uvec);
SCM_API SCM scm_list_to_u8vector (SCM l); 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_s8vector_p (SCM obj);
SCM_API SCM scm_make_s8vector (SCM n, SCM fill); 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_set_x (SCM uvec, SCM index, SCM value);
SCM_API SCM scm_s8vector_to_list (SCM uvec); SCM_API SCM scm_s8vector_to_list (SCM uvec);
SCM_API SCM scm_list_to_s8vector (SCM l); 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_u16vector_p (SCM obj);
SCM_API SCM scm_make_u16vector (SCM n, SCM fill); 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_set_x (SCM uvec, SCM index, SCM value);
SCM_API SCM scm_u16vector_to_list (SCM uvec); SCM_API SCM scm_u16vector_to_list (SCM uvec);
SCM_API SCM scm_list_to_u16vector (SCM l); 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_s16vector_p (SCM obj);
SCM_API SCM scm_make_s16vector (SCM n, SCM fill); 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_set_x (SCM uvec, SCM index, SCM value);
SCM_API SCM scm_s16vector_to_list (SCM uvec); SCM_API SCM scm_s16vector_to_list (SCM uvec);
SCM_API SCM scm_list_to_s16vector (SCM l); 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_u32vector_p (SCM obj);
SCM_API SCM scm_make_u32vector (SCM n, SCM fill); 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_set_x (SCM uvec, SCM index, SCM value);
SCM_API SCM scm_u32vector_to_list (SCM uvec); SCM_API SCM scm_u32vector_to_list (SCM uvec);
SCM_API SCM scm_list_to_u32vector (SCM l); 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_s32vector_p (SCM obj);
SCM_API SCM scm_make_s32vector (SCM n, SCM fill); 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_set_x (SCM uvec, SCM index, SCM value);
SCM_API SCM scm_s32vector_to_list (SCM uvec); SCM_API SCM scm_s32vector_to_list (SCM uvec);
SCM_API SCM scm_list_to_s32vector (SCM l); 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_u64vector_p (SCM obj);
SCM_API SCM scm_make_u64vector (SCM n, SCM fill); 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_set_x (SCM uvec, SCM index, SCM value);
SCM_API SCM scm_u64vector_to_list (SCM uvec); SCM_API SCM scm_u64vector_to_list (SCM uvec);
SCM_API SCM scm_list_to_u64vector (SCM l); 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_s64vector_p (SCM obj);
SCM_API SCM scm_make_s64vector (SCM n, SCM fill); 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_set_x (SCM uvec, SCM index, SCM value);
SCM_API SCM scm_s64vector_to_list (SCM uvec); SCM_API SCM scm_s64vector_to_list (SCM uvec);
SCM_API SCM scm_list_to_s64vector (SCM l); 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_f32vector_p (SCM obj);
SCM_API SCM scm_make_f32vector (SCM n, SCM fill); 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_set_x (SCM uvec, SCM index, SCM value);
SCM_API SCM scm_f32vector_to_list (SCM uvec); SCM_API SCM scm_f32vector_to_list (SCM uvec);
SCM_API SCM scm_list_to_f32vector (SCM l); 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_f64vector_p (SCM obj);
SCM_API SCM scm_make_f64vector (SCM n, SCM fill); 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_set_x (SCM uvec, SCM index, SCM value);
SCM_API SCM scm_f64vector_to_list (SCM uvec); SCM_API SCM scm_f64vector_to_list (SCM uvec);
SCM_API SCM scm_list_to_f64vector (SCM l); 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_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); SCM_API void scm_init_srfi_4 (void);

12
libguile/srfi-4.i.c
View file

@ -15,6 +15,10 @@
The tag name of the vector, for example u8. The tag is used to 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 form the function names and is included in the docstrings, for
example. example.
- CTYPE
The C type of the elements, for example scm_t_uint8.
*/ */
/* The first level does not expand macros in the arguments. */ /* 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 #undef FUNC_NAME
CTYPE *
F(scm_,TAG,vector_elements) (SCM obj)
{
uvec_assert (TYPE, obj);
return (CTYPE *)SCM_UVEC_BASE (obj);
}
#undef paste #undef paste
#undef s_paste #undef s_paste
#undef stringify #undef stringify
@ -122,3 +133,4 @@ SCM_DEFINE (F(scm_list_to_,TAG,vector), "list->"S(TAG)"vector", 1, 0, 0,
#undef TYPE #undef TYPE
#undef TAG #undef TAG
#undef CTYPE

603
libguile/unif.c
View file

@ -34,6 +34,8 @@
#include <string.h> #include <string.h>
#include "libguile/_scm.h" #include "libguile/_scm.h"
#include "libguile/__scm.h"
#include "libguile/eq.h"
#include "libguile/chars.h" #include "libguile/chars.h"
#include "libguile/eval.h" #include "libguile/eval.h"
#include "libguile/fports.h" #include "libguile/fports.h"
@ -42,6 +44,7 @@
#include "libguile/root.h" #include "libguile/root.h"
#include "libguile/strings.h" #include "libguile/strings.h"
#include "libguile/srfi-13.h" #include "libguile/srfi-13.h"
#include "libguile/srfi-4.h"
#include "libguile/vectors.h" #include "libguile/vectors.h"
#include "libguile/validate.h" #include "libguile/validate.h"
@ -59,69 +62,22 @@
/* The set of uniform scm_vector types is: /* The set of uniform scm_vector types is:
* Vector of: Called: * Vector of: Called: Replaced by:
* unsigned char string * unsigned char string u8
* char byvect * char byvect s8
* boolean bvect * boolean bvect
* signed long ivect * signed long ivect s32
* unsigned long uvect * unsigned long uvect u32
* float fvect * float fvect f32
* double dvect * double dvect d32
* complex double cvect * complex double cvect
* short svect * short svect s16
* long long llvect * long long llvect s64
*/ */
scm_t_bits scm_tc16_array; scm_t_bits scm_tc16_array;
static SCM exactly_one_third; 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 /* Silly function used not to modify the semantics of the silly
* prototype system in order to be backward compatible. * 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); return scm_cell (SCM_MAKE_BITVECTOR_TAG (0), 0);
} }
else if (SCM_CHARP (prot) && (SCM_CHAR (prot) == '\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)) else if (SCM_CHARP (prot))
return scm_c_make_string (sizeof (char) * k, SCM_UNDEFINED); return scm_c_make_string (sizeof (char) * k, SCM_UNDEFINED);
else if (SCM_I_INUMP (prot)) else if (SCM_I_INUMP (prot))
@ -207,38 +163,6 @@ scm_make_uve (long k, SCM prot)
} }
#undef FUNC_NAME #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_DEFINE (scm_array_p, "array?", 1, 1, 0,
(SCM v, SCM prot), (SCM v, SCM prot),
"Return @code{#t} if the @var{obj} is an array, and @code{#f} if\n" "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)) if (SCM_IMP (v))
return SCM_BOOL_F; 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) if (nprot)
return SCM_BOOL_T; return SCM_BOOL_T;
if (enclosed++) if (enclosed++)
return SCM_BOOL_F; return SCM_BOOL_F;
v = SCM_ARRAY_V (v); 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) if (nprot)
{ {
@ -270,7 +200,6 @@ SCM_DEFINE (scm_array_p, "array?", 1, 1, 0,
{ {
case scm_tc7_bvect: case scm_tc7_bvect:
case scm_tc7_string: case scm_tc7_string:
case scm_tc7_byvect:
case scm_tc7_uvect: case scm_tc7_uvect:
case scm_tc7_ivect: case scm_tc7_ivect:
case scm_tc7_svect: case scm_tc7_svect:
@ -290,7 +219,7 @@ SCM_DEFINE (scm_array_p, "array?", 1, 1, 0,
else else
{ {
int protp = 0; int protp = 0;
switch (SCM_TYP7 (v)) switch (SCM_TYP7 (v))
{ {
case scm_tc7_bvect: case scm_tc7_bvect:
@ -299,9 +228,6 @@ SCM_DEFINE (scm_array_p, "array?", 1, 1, 0,
case scm_tc7_string: case scm_tc7_string:
protp = SCM_CHARP(prot) && (SCM_CHAR (prot) != '\0'); protp = SCM_CHARP(prot) && (SCM_CHAR (prot) != '\0');
break; break;
case scm_tc7_byvect:
protp = scm_is_eq (prot, SCM_MAKE_CHAR ('\0'));
break;
case scm_tc7_uvect: case scm_tc7_uvect:
protp = SCM_I_INUMP(prot) && SCM_I_INUM(prot)>0; protp = SCM_I_INUMP(prot) && SCM_I_INUM(prot)>0;
break; break;
@ -351,6 +277,9 @@ SCM_DEFINE (scm_array_rank, "array-rank", 1, 0, 0,
"not an array, @code{0} is returned.") "not an array, @code{0} is returned.")
#define FUNC_NAME s_scm_array_rank #define FUNC_NAME s_scm_array_rank
{ {
if (scm_is_uniform_vector (ra))
return scm_from_int (1);
if (SCM_IMP (ra)) if (SCM_IMP (ra))
return SCM_INUM0; return SCM_INUM0;
switch (SCM_TYP7 (ra)) 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_string:
case scm_tc7_vector: case scm_tc7_vector:
case scm_tc7_wvect: case scm_tc7_wvect:
case scm_tc7_byvect:
case scm_tc7_uvect: case scm_tc7_uvect:
case scm_tc7_ivect: case scm_tc7_ivect:
case scm_tc7_fvect: case scm_tc7_fvect:
@ -394,6 +322,10 @@ SCM_DEFINE (scm_array_dimensions, "array-dimensions", 1, 0, 0,
scm_t_array_dim *s; scm_t_array_dim *s;
if (SCM_IMP (ra)) if (SCM_IMP (ra))
return SCM_BOOL_F; return SCM_BOOL_F;
if (scm_is_uniform_vector (ra))
return scm_cons (scm_uniform_vector_length (ra), SCM_EOL);
switch (SCM_TYP7 (ra)) switch (SCM_TYP7 (ra))
{ {
default: default:
@ -402,7 +334,6 @@ SCM_DEFINE (scm_array_dimensions, "array-dimensions", 1, 0, 0,
case scm_tc7_vector: case scm_tc7_vector:
case scm_tc7_wvect: case scm_tc7_wvect:
case scm_tc7_bvect: case scm_tc7_bvect:
case scm_tc7_byvect:
case scm_tc7_uvect: case scm_tc7_uvect:
case scm_tc7_ivect: case scm_tc7_ivect:
case scm_tc7_fvect: 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); SCM answer = scm_make_uve (scm_to_long (dims), prot);
if (!SCM_UNBNDP (fill)) if (!SCM_UNBNDP (fill))
scm_array_fill_x (answer, 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)); scm_array_fill_x (answer, scm_from_int (0));
else else
scm_array_fill_x (answer, prot); 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)) if (!SCM_UNBNDP (fill))
scm_array_fill_x (ra, 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)); scm_array_fill_x (ra, scm_from_int (0));
else else
scm_array_fill_x (ra, prot); 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_VALIDATE_REST_ARGUMENT (args);
SCM_ASSERT (SCM_NIMP (ra), ra, SCM_ARG1, FUNC_NAME); 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)) switch (SCM_TYP7 (ra))
{ {
default: default:
badarg:SCM_WRONG_TYPE_ARG (1, ra); badarg:SCM_WRONG_TYPE_ARG (1, ra);
case scm_tc7_bvect: case scm_tc7_bvect:
case scm_tc7_string: case scm_tc7_string:
case scm_tc7_byvect:
case scm_tc7_uvect: case scm_tc7_uvect:
case scm_tc7_ivect: case scm_tc7_ivect:
case scm_tc7_fvect: case scm_tc7_fvect:
@ -915,13 +858,16 @@ SCM_DEFINE (scm_enclose_array, "enclose-array", 1, 0, 1,
SCM_WRONG_NUM_ARGS (); SCM_WRONG_NUM_ARGS ();
ra_inr = scm_make_ra (ninr); ra_inr = scm_make_ra (ninr);
SCM_ASRTGO (SCM_NIMP (ra), badarg1); SCM_ASRTGO (SCM_NIMP (ra), badarg1);
if (scm_is_uniform_vector (ra))
goto uniform_vector;
switch SCM_TYP7 (ra) switch SCM_TYP7 (ra)
{ {
default: default:
badarg1:SCM_WRONG_TYPE_ARG (1, ra); badarg1:SCM_WRONG_TYPE_ARG (1, ra);
case scm_tc7_string: case scm_tc7_string:
case scm_tc7_bvect: case scm_tc7_bvect:
case scm_tc7_byvect:
case scm_tc7_uvect: case scm_tc7_uvect:
case scm_tc7_ivect: case scm_tc7_ivect:
case scm_tc7_fvect: case scm_tc7_fvect:
@ -933,6 +879,7 @@ SCM_DEFINE (scm_enclose_array, "enclose-array", 1, 0, 1,
#if SCM_SIZEOF_LONG_LONG != 0 #if SCM_SIZEOF_LONG_LONG != 0
case scm_tc7_llvect: case scm_tc7_llvect:
#endif #endif
uniform_vector:
s->lbnd = 0; s->lbnd = 0;
s->ubnd = scm_to_long (scm_uniform_vector_length (ra)) - 1; s->ubnd = scm_to_long (scm_uniform_vector_length (ra)) - 1;
s->inc = 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); pos = scm_to_long (ind);
} }
tail: tail:
if (scm_is_uniform_vector (v))
goto uniform_vector;
switch SCM_TYP7 (v) switch SCM_TYP7 (v)
{ {
default: default:
@ -1042,7 +993,6 @@ tail:
goto tail; goto tail;
case scm_tc7_bvect: case scm_tc7_bvect:
case scm_tc7_string: case scm_tc7_string:
case scm_tc7_byvect:
case scm_tc7_uvect: case scm_tc7_uvect:
case scm_tc7_ivect: case scm_tc7_ivect:
case scm_tc7_fvect: case scm_tc7_fvect:
@ -1054,6 +1004,7 @@ tail:
#endif #endif
case scm_tc7_vector: case scm_tc7_vector:
case scm_tc7_wvect: case scm_tc7_wvect:
uniform_vector:
{ {
unsigned long length = scm_to_ulong (scm_uniform_vector_length (v)); unsigned long length = scm_to_ulong (scm_uniform_vector_length (v));
SCM_ASRTGO (scm_is_null (args) && scm_is_integer (ind), wna); SCM_ASRTGO (scm_is_null (args) && scm_is_integer (ind), wna);
@ -1064,15 +1015,11 @@ tail:
#undef FUNC_NAME #undef FUNC_NAME
SCM_REGISTER_PROC(s_array_ref, "array-ref", 1, 0, 1, scm_uniform_vector_ref); SCM_DEFINE (scm_array_ref, "array-ref", 1, 0, 1,
SCM_DEFINE (scm_uniform_vector_ref, "uniform-vector-ref", 2, 0, 0,
(SCM v, SCM args), (SCM v, SCM args),
"@deffnx {Scheme Procedure} array-ref v . args\n"
"Return the element at the @code{(index1, index2)} element in\n" "Return the element at the @code{(index1, index2)} element in\n"
"@var{array}.") "@var{array}.")
#define FUNC_NAME s_scm_uniform_vector_ref #define FUNC_NAME s_scm_array_ref
{ {
long pos; 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)); length = scm_to_ulong (scm_uniform_vector_length (v));
SCM_ASRTGO (pos >= 0 && pos < length, outrng); 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) switch SCM_TYP7 (v)
{ {
default: default:
@ -1136,12 +1087,10 @@ SCM_DEFINE (scm_uniform_vector_ref, "uniform-vector-ref", 2, 0, 0,
return SCM_BOOL_F; return SCM_BOOL_F;
case scm_tc7_string: case scm_tc7_string:
return scm_c_string_ref (v, pos); return scm_c_string_ref (v, pos);
case scm_tc7_byvect: case scm_tc7_uvect:
return scm_from_schar (((char *) SCM_UVECTOR_BASE (v))[pos]);
case scm_tc7_uvect:
return scm_from_ulong (((unsigned long *) SCM_VELTS (v))[pos]); return scm_from_ulong (((unsigned long *) SCM_VELTS (v))[pos]);
case scm_tc7_ivect: case scm_tc7_ivect:
return scm_from_long (((signed long *) SCM_VELTS (v))[pos]); return scm_from_long (((signed long *) SCM_VELTS (v))[pos]);
case scm_tc7_svect: case scm_tc7_svect:
return scm_from_short (((short *) SCM_CELL_WORD_1 (v))[pos]); 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) scm_cvref (SCM v, unsigned long pos, SCM last)
#define FUNC_NAME "scm_cvref" #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) switch SCM_TYP7 (v)
{ {
default: default:
@ -1182,8 +1134,6 @@ scm_cvref (SCM v, unsigned long pos, SCM last)
return SCM_BOOL_F; return SCM_BOOL_F;
case scm_tc7_string: case scm_tc7_string:
return scm_c_string_ref (v, pos); 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: case scm_tc7_uvect:
return scm_from_ulong (((unsigned long *) SCM_VELTS (v))[pos]); return scm_from_ulong (((unsigned long *) SCM_VELTS (v))[pos]);
case scm_tc7_ivect: 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)); length = scm_to_ulong (scm_uniform_vector_length (v));
SCM_ASRTGO (pos >= 0 && pos < length, outrng); 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)) switch (SCM_TYP7 (v))
{ {
default: badarg1: default: badarg1:
@ -1297,11 +1251,6 @@ SCM_DEFINE (scm_array_set_x, "array-set!", 2, 0, 1,
SCM_ASRTGO (SCM_CHARP (obj), badobj); SCM_ASRTGO (SCM_CHARP (obj), badobj);
scm_c_string_set_x (v, pos, obj); scm_c_string_set_x (v, pos, obj);
break; 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: case scm_tc7_uvect:
((unsigned long *) SCM_UVECTOR_BASE (v))[pos] = scm_to_ulong (obj); ((unsigned long *) SCM_UVECTOR_BASE (v))[pos] = scm_to_ulong (obj);
break; break;
@ -1359,8 +1308,13 @@ SCM_DEFINE (scm_array_contents, "array-contents", 1, 1, 0,
#define FUNC_NAME s_scm_array_contents #define FUNC_NAME s_scm_array_contents
{ {
SCM sra; SCM sra;
if (scm_is_uniform_vector (ra))
return ra;
if (SCM_IMP (ra)) if (SCM_IMP (ra))
return SCM_BOOL_F; return SCM_BOOL_F;
switch SCM_TYP7 (ra) switch SCM_TYP7 (ra)
{ {
default: default:
@ -1369,7 +1323,6 @@ SCM_DEFINE (scm_array_contents, "array-contents", 1, 1, 0,
case scm_tc7_wvect: case scm_tc7_wvect:
case scm_tc7_string: case scm_tc7_string:
case scm_tc7_bvect: case scm_tc7_bvect:
case scm_tc7_byvect:
case scm_tc7_uvect: case scm_tc7_uvect:
case scm_tc7_ivect: case scm_tc7_ivect:
case scm_tc7_fvect: 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))); : scm_to_long (scm_uniform_vector_length (v)));
loop: loop:
switch SCM_TYP7 (v) if (scm_is_uniform_vector (v))
{ {
default: base = scm_uniform_vector_elements (v);
badarg1:SCM_WRONG_TYPE_ARG (SCM_ARG1, v); sz = scm_uniform_vector_element_size (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;
#if SCM_SIZEOF_LONG_LONG != 0
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;
} }
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;
#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;
}
cend = vlen; cend = vlen;
if (!SCM_UNBNDP (start)) 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))); : scm_to_long (scm_uniform_vector_length (v)));
loop: loop:
switch SCM_TYP7 (v) if (scm_is_uniform_vector (v))
{ {
default: base = scm_uniform_vector_elements (v);
badarg1:SCM_WRONG_TYPE_ARG (1, v); sz = scm_uniform_vector_element_size (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;
#if SCM_SIZEOF_LONG_LONG != 0
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;
} }
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;
#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;
}
cend = vlen; cend = vlen;
if (!SCM_UNBNDP (start)) if (!SCM_UNBNDP (start))
{ {
@ -2128,6 +2085,10 @@ SCM_DEFINE (scm_array_to_list, "array->list", 1, 0, 0,
{ {
SCM res = SCM_EOL; SCM res = SCM_EOL;
register long k; register long k;
if (scm_is_uniform_vector (v))
return scm_uniform_vector_to_list (v);
SCM_ASRTGO (SCM_NIMP (v), badarg1); SCM_ASRTGO (SCM_NIMP (v), badarg1);
switch SCM_TYP7 (v) 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); res = scm_cons (scm_from_bool(((long *) data)[k] & mask), res);
return 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: case scm_tc7_uvect:
{ {
unsigned long *data = (unsigned long *)SCM_VELTS(v); unsigned long *data = (unsigned long *)SCM_VELTS(v);
@ -2359,7 +2312,7 @@ tail:
default: default:
/* scm_tc7_bvect and scm_tc7_llvect only? */ /* scm_tc7_bvect and scm_tc7_llvect only? */
if (n-- > 0) 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) for (j += inc; n-- > 0; j += inc)
{ {
scm_putc (' ', port); scm_putc (' ', port);
@ -2384,20 +2337,11 @@ tail:
scm_remember_upto_here_1 (ra); scm_remember_upto_here_1 (ra);
} }
break; 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: case scm_tc7_uvect:
{ {
char str[11]; char str[11];
if (n-- > 0) if (n-- > 0)
{ {
/* intprint can't handle >= 2^31. */ /* intprint can't handle >= 2^31. */
@ -2420,7 +2364,7 @@ tail:
scm_intprint (((signed long *) SCM_VELTS (ra))[j], 10, port); scm_intprint (((signed long *) SCM_VELTS (ra))[j], 10, port);
} }
break; break;
case scm_tc7_svect: case scm_tc7_svect:
if (n-- > 0) if (n-- > 0)
scm_intprint (((short *) SCM_CELL_WORD_1 (ra))[j], 10, port); 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); scm_intprint (((short *) SCM_CELL_WORD_1 (ra))[j], 10, port);
} }
break; break;
case scm_tc7_fvect: case scm_tc7_fvect:
if (n-- > 0) 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 int
scm_raprin1 (SCM exp, SCM port, scm_print_state *pstate) scm_raprin1 (SCM exp, SCM port, scm_print_state *pstate)
{ {
SCM v = exp; SCM v = exp;
unsigned long base = 0; 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); scm_putc ('#', port);
tail: tail:
switch SCM_TYP7 (v) switch SCM_TYP7 (v)
@ -2545,9 +2634,6 @@ tail:
case scm_tc7_string: case scm_tc7_string:
scm_putc ('a', port); scm_putc ('a', port);
break; break;
case scm_tc7_byvect:
scm_putc ('y', port);
break;
case scm_tc7_uvect: case scm_tc7_uvect:
scm_putc ('u', port); scm_putc ('u', port);
break; break;
@ -2588,6 +2674,9 @@ SCM_DEFINE (scm_array_prototype, "array-prototype", 1, 0, 0,
int enclosed = 0; int enclosed = 0;
SCM_ASRTGO (SCM_NIMP (ra), badarg); SCM_ASRTGO (SCM_NIMP (ra), badarg);
loop: loop:
if (scm_is_uniform_vector (ra))
return scm_i_uniform_vector_prototype (ra);
switch SCM_TYP7 (ra) switch SCM_TYP7 (ra)
{ {
default: default:
@ -2605,8 +2694,6 @@ loop:
return SCM_BOOL_T; return SCM_BOOL_T;
case scm_tc7_string: case scm_tc7_string:
return SCM_MAKE_CHAR ('a'); return SCM_MAKE_CHAR ('a');
case scm_tc7_byvect:
return SCM_MAKE_CHAR ('\0');
case scm_tc7_uvect: case scm_tc7_uvect:
return scm_from_int (1); return scm_from_int (1);
case scm_tc7_ivect: case scm_tc7_ivect:

4
libguile/unif.h
View file

@ -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_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_p (SCM v, SCM prot);
SCM_API SCM scm_array_rank (SCM ra); SCM_API SCM scm_array_rank (SCM ra);
SCM_API SCM scm_array_dimensions (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_transpose_array (SCM ra, SCM args);
SCM_API SCM scm_enclose_array (SCM ra, SCM axes); 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_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_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_set_x (SCM v, SCM obj, SCM args);
SCM_API SCM scm_array_contents (SCM ra, SCM strict); SCM_API SCM scm_array_contents (SCM ra, SCM strict);