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)
};
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"

34
libguile/srfi-4.h
View file

@ -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);

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
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

603
libguile/unif.c
View file

@ -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;
#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;
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;
#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;
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;
#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;
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;
#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;
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:

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_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);