mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-06-09 13:30:26 +02:00
Rewritten completely, using scm_any_to_u8vector, etc and other
new-style uniform vector functions.
This commit is contained in:
Marius Vollmer
parent
e911caec2b
commit
948972893c
2 changed files with 222 additions and 408 deletions
|
|
@ -36,111 +36,110 @@
|
||||||
#include <string.h>
|
#include <string.h>
|
||||||
#endif
|
#endif
|
||||||
|
|
||||||
|
/* char *scm_c_scm2chars (SCM obj, char *dst);
|
||||||
|
SCM scm_c_chars2scm (const char *src, long n);
|
||||||
|
SCM scm_c_chars2byvect (const char *src, long n);
|
||||||
|
*/
|
||||||
|
|
||||||
#define CTYPE char
|
#define CTYPE char
|
||||||
#define SIZEOF_CTYPE 1
|
#define FROM_CTYPE scm_from_char
|
||||||
#define SCM2CTYPES_FN "scm_c_scm2chars"
|
|
||||||
#define SCM2CTYPES scm_c_scm2chars
|
#define SCM2CTYPES scm_c_scm2chars
|
||||||
#define CTYPES2SCM_FN "scm_c_chars2scm"
|
|
||||||
#define CTYPES2SCM scm_c_chars2scm
|
#define CTYPES2SCM scm_c_chars2scm
|
||||||
#define CTYPES2UVECT_FN "scm_c_chars2byvect"
|
|
||||||
#define CTYPES2UVECT scm_c_chars2byvect
|
#define CTYPES2UVECT scm_c_chars2byvect
|
||||||
#define UVEC_CREATOR scm_take_s8vector
|
#if CHAR_MIN == 0
|
||||||
#define SIZEOF_UVECTTYPE 1
|
/* 'char' is unsigned. */
|
||||||
#define UVECTCTYPE char
|
#define UVEC_TAG u8
|
||||||
#define UVEC_PREDICATE scm_s8vector_p
|
#define UVEC_CTYPE scm_t_uint8
|
||||||
#define SIZEOF_ARRAYTYPE 1
|
#else
|
||||||
#define ARRAYCTYPE char
|
/* 'char' is signed. */
|
||||||
#include "convert.i.c"
|
#define UVEC_TAG s8
|
||||||
|
#define UVEC_CTYPE scm_t_int8
|
||||||
|
#endif
|
||||||
|
#include "libguile/convert.i.c"
|
||||||
|
|
||||||
|
/* short *scm_c_scm2shorts (SCM obj, short *dst);
|
||||||
|
SCM scm_c_shorts2scm (const short *src, long n);
|
||||||
|
SCM scm_c_shorts2svect (const short *src, long n);
|
||||||
|
*/
|
||||||
|
|
||||||
#define CTYPE short
|
#define CTYPE short
|
||||||
#define SIZEOF_CTYPE SIZEOF_SHORT
|
#define FROM_CTYPE scm_from_short
|
||||||
#define SCM2CTYPES_FN "scm_c_scm2shorts"
|
|
||||||
#define SCM2CTYPES scm_c_scm2shorts
|
#define SCM2CTYPES scm_c_scm2shorts
|
||||||
#define CTYPES2SCM_FN "scm_c_shorts2scm"
|
|
||||||
#define CTYPES2SCM scm_c_shorts2scm
|
#define CTYPES2SCM scm_c_shorts2scm
|
||||||
#define CTYPES2UVECT_FN "scm_c_shorts2svect"
|
|
||||||
#define CTYPES2UVECT scm_c_shorts2svect
|
#define CTYPES2UVECT scm_c_shorts2svect
|
||||||
#define UVECTTYPE scm_tc7_svect
|
#define UVEC_TAG s16
|
||||||
#define SIZEOF_UVECTTYPE SIZEOF_SHORT
|
#define UVEC_CTYPE scm_t_int16
|
||||||
#define UVECTCTYPE short
|
#include "libguile/convert.i.c"
|
||||||
#define ARRAYTYPE scm_tc7_svect
|
|
||||||
#define SIZEOF_ARRAYTYPE SIZEOF_SHORT
|
/* int *scm_c_scm2ints (SCM obj, int *dst);
|
||||||
#define ARRAYCTYPE short
|
SCM scm_c_ints2scm (const int *src, long n);
|
||||||
#include "convert.i.c"
|
SCM scm_c_ints2ivect (const int *src, long n);
|
||||||
|
SCM scm_c_uints2uvect (const unsigned int *src, long n);
|
||||||
|
*/
|
||||||
|
|
||||||
#define CTYPE int
|
#define CTYPE int
|
||||||
#define SIZEOF_CTYPE SIZEOF_INT
|
#define FROM_CTYPE scm_from_int
|
||||||
#define SCM2CTYPES_FN "scm_c_scm2ints"
|
|
||||||
#define SCM2CTYPES scm_c_scm2ints
|
#define SCM2CTYPES scm_c_scm2ints
|
||||||
#define CTYPES2SCM_FN "scm_c_ints2scm"
|
|
||||||
#define CTYPES2SCM scm_c_ints2scm
|
#define CTYPES2SCM scm_c_ints2scm
|
||||||
#define CTYPES2UVECT_FN "scm_c_ints2ivect"
|
|
||||||
#define CTYPES2UVECT scm_c_ints2ivect
|
#define CTYPES2UVECT scm_c_ints2ivect
|
||||||
#define UVECTTYPE scm_tc7_ivect
|
#define UVEC_TAG s32
|
||||||
#define SIZEOF_UVECTTYPE SIZEOF_LONG
|
#define UVEC_CTYPE scm_t_int32
|
||||||
#define UVECTCTYPE long
|
|
||||||
#define CTYPES2UVECT_FN_OPTIONAL "scm_c_uints2uvect"
|
#define CTYPES2UVECT_2 scm_c_uints2uvect
|
||||||
#define CTYPES2UVECT_OPTIONAL scm_c_uints2uvect
|
#define CTYPE_2 unsigned int
|
||||||
#define UVECTTYPE_OPTIONAL scm_tc7_uvect
|
#define UVEC_TAG_2 u32
|
||||||
#define ARRAYTYPE scm_tc7_ivect
|
#define UVEC_CTYPE_2 scm_t_uint32
|
||||||
#define SIZEOF_ARRAYTYPE SIZEOF_LONG
|
|
||||||
#define ARRAYCTYPE long
|
#include "libguile/convert.i.c"
|
||||||
#define ARRAYTYPE_OPTIONAL scm_tc7_uvect
|
|
||||||
#include "convert.i.c"
|
/* long *scm_c_scm2longs (SCM obj, long *dst);
|
||||||
|
SCM scm_c_longs2scm (const long *src, long n);
|
||||||
|
SCM scm_c_longs2ivect (const long *src, long n);
|
||||||
|
SCM scm_c_ulongs2uvect (const unsigned long *src, long n);
|
||||||
|
*/
|
||||||
|
|
||||||
#define CTYPE long
|
#define CTYPE long
|
||||||
#define SIZEOF_CTYPE SIZEOF_LONG
|
#define FROM_CTYPE scm_from_long
|
||||||
#define SCM2CTYPES_FN "scm_c_scm2longs"
|
|
||||||
#define SCM2CTYPES scm_c_scm2longs
|
#define SCM2CTYPES scm_c_scm2longs
|
||||||
#define CTYPES2SCM_FN "scm_c_longs2scm"
|
|
||||||
#define CTYPES2SCM scm_c_longs2scm
|
#define CTYPES2SCM scm_c_longs2scm
|
||||||
#define CTYPES2UVECT_FN "scm_c_longs2ivect"
|
|
||||||
#define CTYPES2UVECT scm_c_longs2ivect
|
#define CTYPES2UVECT scm_c_longs2ivect
|
||||||
#define UVECTTYPE scm_tc7_ivect
|
#define UVEC_TAG s32
|
||||||
#define SIZEOF_UVECTTYPE SIZEOF_LONG
|
#define UVEC_CTYPE scm_t_int32
|
||||||
#define UVECTCTYPE long
|
|
||||||
#define CTYPES2UVECT_FN_OPTIONAL "scm_c_ulongs2uvect"
|
#define CTYPES2UVECT_2 scm_c_ulongs2uvect
|
||||||
#define CTYPES2UVECT_OPTIONAL scm_c_ulongs2uvect
|
#define CTYPE_2 unsigned int
|
||||||
#define UVECTTYPE_OPTIONAL scm_tc7_uvect
|
#define UVEC_TAG_2 u32
|
||||||
#define ARRAYTYPE scm_tc7_ivect
|
#define UVEC_CTYPE_2 scm_t_uint32
|
||||||
#define SIZEOF_ARRAYTYPE SIZEOF_LONG
|
|
||||||
#define ARRAYCTYPE long
|
#include "libguile/convert.i.c"
|
||||||
#define ARRAYTYPE_OPTIONAL scm_tc7_uvect
|
|
||||||
#include "convert.i.c"
|
/* float *scm_c_scm2floats (SCM obj, float *dst);
|
||||||
|
SCM scm_c_floats2scm (const float *src, long n);
|
||||||
|
SCM scm_c_floats2fvect (const float *src, long n);
|
||||||
|
*/
|
||||||
|
|
||||||
#define CTYPE float
|
#define CTYPE float
|
||||||
#define SIZEOF_CTYPE 0
|
#define FROM_CTYPE scm_from_double
|
||||||
#define SCM2CTYPES_FN "scm_c_scm2floats"
|
|
||||||
#define SCM2CTYPES scm_c_scm2floats
|
#define SCM2CTYPES scm_c_scm2floats
|
||||||
#define CTYPES2SCM_FN "scm_c_floats2scm"
|
|
||||||
#define CTYPES2SCM scm_c_floats2scm
|
#define CTYPES2SCM scm_c_floats2scm
|
||||||
#define CTYPES2UVECT_FN "scm_c_floats2fvect"
|
|
||||||
#define CTYPES2UVECT scm_c_floats2fvect
|
#define CTYPES2UVECT scm_c_floats2fvect
|
||||||
#define UVECTTYPE scm_tc7_fvect
|
#define UVEC_TAG f32
|
||||||
#define SIZEOF_UVECTTYPE 0
|
#define UVEC_CTYPE float
|
||||||
#define ARRAYTYPE scm_tc7_fvect
|
#include "libguile/convert.i.c"
|
||||||
#define SIZEOF_ARRAYTYPE 0
|
|
||||||
#define ARRAYTYPE_OPTIONAL scm_tc7_dvect
|
/* double *scm_c_scm2doubles (SCM obj, double *dst);
|
||||||
#define FLOATTYPE float
|
SCM scm_c_doubles2scm (const double *src, long n);
|
||||||
#define FLOATTYPE_OPTIONAL double
|
SCM scm_c_doubles2dvect (const double *src, long n);
|
||||||
#include "convert.i.c"
|
*/
|
||||||
|
|
||||||
#define CTYPE double
|
#define CTYPE double
|
||||||
#define SIZEOF_CTYPE 0
|
#define FROM_CTYPE scm_from_double
|
||||||
#define SCM2CTYPES_FN "scm_c_scm2doubles"
|
|
||||||
#define SCM2CTYPES scm_c_scm2doubles
|
#define SCM2CTYPES scm_c_scm2doubles
|
||||||
#define CTYPES2SCM_FN "scm_c_doubles2scm"
|
|
||||||
#define CTYPES2SCM scm_c_doubles2scm
|
#define CTYPES2SCM scm_c_doubles2scm
|
||||||
#define CTYPES2UVECT_FN "scm_c_doubles2dvect"
|
|
||||||
#define CTYPES2UVECT scm_c_doubles2dvect
|
#define CTYPES2UVECT scm_c_doubles2dvect
|
||||||
#define UVECTTYPE scm_tc7_dvect
|
#define UVEC_TAG f64
|
||||||
#define SIZEOF_UVECTTYPE 0
|
#define UVEC_CTYPE double
|
||||||
#define ARRAYTYPE scm_tc7_dvect
|
#include "libguile/convert.i.c"
|
||||||
#define SIZEOF_ARRAYTYPE 0
|
|
||||||
#define ARRAYTYPE_OPTIONAL scm_tc7_fvect
|
|
||||||
#define FLOATTYPE double
|
|
||||||
#define FLOATTYPE_OPTIONAL float
|
|
||||||
#include "convert.i.c"
|
|
||||||
|
|
||||||
/*
|
/*
|
||||||
Local Variables:
|
Local Variables:
|
||||||
|
|
|
||||||
|
|
@ -1,346 +1,161 @@
|
||||||
/* this file is #include'd (x times) by convert.c */
|
/* this file is #include'd (x times) by convert.c */
|
||||||
|
|
||||||
/* Convert a vector, weak vector, (if possible string, substring), list
|
/* You need to define the following macros before including this
|
||||||
or uniform vector into an C array. If the result array in argument 2
|
template. They are undefined at the end of this file to give a
|
||||||
is NULL, malloc() a new one. If out of memory, return NULL. */
|
clean slate for the next inclusion.
|
||||||
#define FUNC_NAME SCM2CTYPES_FN
|
|
||||||
|
- CTYPE
|
||||||
|
|
||||||
|
The type of an element of the C array, for example 'char'.
|
||||||
|
|
||||||
|
- FROM_CTYPE
|
||||||
|
|
||||||
|
The function that converts a CTYPE to a SCM, for example
|
||||||
|
scm_from_char.
|
||||||
|
|
||||||
|
- UVEC_TAG
|
||||||
|
|
||||||
|
The tag of a suitable uniform vector that can hold the CTYPE, for
|
||||||
|
example 's8'.
|
||||||
|
|
||||||
|
- UVEC_CTYPE
|
||||||
|
|
||||||
|
The C type of an element of the uniform vector, for example
|
||||||
|
scm_t_int8.
|
||||||
|
|
||||||
|
- SCM2CTYPES
|
||||||
|
|
||||||
|
The name of the 'SCM-to-C' function, for example scm_c_scm2chars.
|
||||||
|
|
||||||
|
- CTYPES2SCM
|
||||||
|
|
||||||
|
The name of the 'C-to-SCM' function, for example, scm_c_chars2scm.
|
||||||
|
|
||||||
|
- CTYPES2UVECT
|
||||||
|
|
||||||
|
The name of the 'C-to-uniform-vector' function, for example
|
||||||
|
scm_c_chars2byvect. It will create a uniform vector of kind
|
||||||
|
UVEC_TAG.
|
||||||
|
|
||||||
|
- CTYPES2UVECT_2
|
||||||
|
|
||||||
|
The name of a second 'C-to-uniform-vector' function. Leave
|
||||||
|
undefined if you want only one such function.
|
||||||
|
|
||||||
|
- CTYPE_2
|
||||||
|
- UVEC_TAG_2
|
||||||
|
- UVEC_CTYPE_2
|
||||||
|
|
||||||
|
The tag and C type of the second kind of uniform vector, for use
|
||||||
|
with the function described above.
|
||||||
|
|
||||||
|
*/
|
||||||
|
|
||||||
|
/* The first level does not expand macros in the arguments. */
|
||||||
|
#define paste(a1,a2,a3) a1##a2##a3
|
||||||
|
#define stringify(a) #a
|
||||||
|
|
||||||
|
/* But the second level does. */
|
||||||
|
#define F(pre,T,suf) paste(pre,T,suf)
|
||||||
|
#define S(T) stringify(T)
|
||||||
|
|
||||||
|
/* Convert a vector, list or uniform vector into a C array. If the
|
||||||
|
result array in argument 2 is NULL, malloc() a new one.
|
||||||
|
*/
|
||||||
|
|
||||||
CTYPE *
|
CTYPE *
|
||||||
SCM2CTYPES (SCM obj, CTYPE *data)
|
SCM2CTYPES (SCM obj, CTYPE *data)
|
||||||
{
|
{
|
||||||
long i, n;
|
size_t len, i;
|
||||||
SCM val;
|
UVEC_CTYPE *uvec_elements;
|
||||||
|
|
||||||
SCM_ASSERT (SCM_NIMP (obj) || scm_is_true (scm_list_p (obj)),
|
obj = F(scm_any_to_,UVEC_TAG,vector) (obj);
|
||||||
obj, SCM_ARG1, FUNC_NAME);
|
len = scm_c_uniform_vector_length (obj);
|
||||||
|
uvec_elements = F(scm_,UVEC_TAG,vector_elements) (obj);
|
||||||
|
|
||||||
/* list conversion */
|
|
||||||
if (scm_is_true (scm_list_p (obj)))
|
|
||||||
{
|
|
||||||
/* traverse the given list and validate the range of each member */
|
|
||||||
SCM list = obj;
|
|
||||||
for (n = 0; scm_is_true (scm_pair_p (list)); list = SCM_CDR (list), n++)
|
|
||||||
{
|
|
||||||
val = SCM_CAR (list);
|
|
||||||
#if SIZEOF_CTYPE && SIZEOF_CTYPE < SIZEOF_SCM_T_BITS
|
|
||||||
/* check integer ranges */
|
|
||||||
if (SCM_I_INUMP (val))
|
|
||||||
{
|
|
||||||
scm_t_signed_bits v = SCM_I_INUM (val);
|
|
||||||
CTYPE c = (CTYPE) v;
|
|
||||||
SCM_ASSERT_RANGE (SCM_ARG1, val, v != (scm_t_signed_bits) c);
|
|
||||||
}
|
|
||||||
/* check big number ranges */
|
|
||||||
else if (SCM_BIGP (val))
|
|
||||||
{
|
|
||||||
scm_t_signed_bits v = scm_to_long (val);
|
|
||||||
CTYPE c = (CTYPE) v;
|
|
||||||
SCM_ASSERT_RANGE (SCM_ARG1, val, v != (scm_t_signed_bits) c);
|
|
||||||
}
|
|
||||||
else
|
|
||||||
/* check float types */
|
|
||||||
#elif defined (FLOATTYPE)
|
|
||||||
/* real values, big numbers and immediate values are valid
|
|
||||||
for float conversions */
|
|
||||||
if (!SCM_REALP (val) && !SCM_BIGP (val) && !SCM_I_INUMP (val))
|
|
||||||
#else
|
|
||||||
if (!SCM_BIGP (val) && !SCM_I_INUMP (val))
|
|
||||||
#endif /* FLOATTYPE */
|
|
||||||
SCM_WRONG_TYPE_ARG (SCM_ARG1, val);
|
|
||||||
}
|
|
||||||
|
|
||||||
/* allocate new memory if necessary */
|
|
||||||
if (data == NULL)
|
if (data == NULL)
|
||||||
if ((data = (CTYPE *) malloc (n * sizeof (CTYPE))) == NULL)
|
data = scm_malloc (len * sizeof (CTYPE));
|
||||||
return NULL;
|
for (i = 0; i < len; i++)
|
||||||
|
data[i] = uvec_elements[i];
|
||||||
|
|
||||||
/* traverse the list once more and convert each member */
|
|
||||||
list = obj;
|
|
||||||
for (i = 0; scm_is_true (scm_pair_p (list)); list = SCM_CDR (list), i++)
|
|
||||||
{
|
|
||||||
val = SCM_CAR (list);
|
|
||||||
if (SCM_I_INUMP (val))
|
|
||||||
data[i] = (CTYPE) SCM_I_INUM (val);
|
|
||||||
else if (SCM_BIGP (val))
|
|
||||||
data[i] = (CTYPE) scm_to_long (val);
|
|
||||||
#if defined (FLOATTYPE)
|
|
||||||
else
|
|
||||||
data[i] = (CTYPE) SCM_REAL_VALUE (val);
|
|
||||||
#endif
|
|
||||||
}
|
|
||||||
return data;
|
|
||||||
}
|
|
||||||
|
|
||||||
/* uniform vectors */
|
|
||||||
#ifdef UVEC_PREDICATE
|
|
||||||
if (scm_is_true (UVEC_PREDICATE (obj)))
|
|
||||||
{
|
|
||||||
n = scm_c_uniform_vector_length (obj);
|
|
||||||
ARRAYCTYPE *elts = (ARRAYCTYPE *)scm_uniform_vector_elements (obj);
|
|
||||||
|
|
||||||
/* allocate new memory if necessary */
|
|
||||||
if (data == NULL)
|
|
||||||
if ((data = (CTYPE *) malloc (n * sizeof (CTYPE))) == NULL)
|
|
||||||
return NULL;
|
|
||||||
|
|
||||||
#if SIZEOF_CTYPE != SIZEOF_ARRAYTYPE
|
|
||||||
/* copy array element by element */
|
|
||||||
for (i = 0; i < n; i++)
|
|
||||||
data[i] = (CTYPE) elts[i];
|
|
||||||
#else
|
|
||||||
/* copy whole array */
|
|
||||||
memcpy (data, (CTYPE *) elts, n * sizeof (CTYPE));
|
|
||||||
#endif
|
|
||||||
scm_uniform_vector_release (obj);
|
scm_uniform_vector_release (obj);
|
||||||
return data;
|
return data;
|
||||||
}
|
|
||||||
#endif
|
|
||||||
|
|
||||||
/* other conversions */
|
|
||||||
switch (SCM_TYP7 (obj))
|
|
||||||
{
|
|
||||||
/* vectors and weak vectors */
|
|
||||||
case scm_tc7_vector:
|
|
||||||
case scm_tc7_wvect:
|
|
||||||
n = SCM_VECTOR_LENGTH (obj);
|
|
||||||
/* traverse the given vector and validate each member */
|
|
||||||
for (i = 0; i < n; i++)
|
|
||||||
{
|
|
||||||
val = SCM_VELTS (obj)[i];
|
|
||||||
#if SIZEOF_CTYPE && SIZEOF_CTYPE < SIZEOF_SCM_T_BITS
|
|
||||||
/* check integer ranges */
|
|
||||||
if (SCM_I_INUMP (val))
|
|
||||||
{
|
|
||||||
scm_t_signed_bits v = SCM_I_INUM (val);
|
|
||||||
CTYPE c = (CTYPE) v;
|
|
||||||
SCM_ASSERT_RANGE (SCM_ARG1, val, v != (scm_t_signed_bits) c);
|
|
||||||
}
|
|
||||||
/* check big number ranges */
|
|
||||||
else if (SCM_BIGP (val))
|
|
||||||
{
|
|
||||||
scm_t_signed_bits v = scm_to_long (val);
|
|
||||||
CTYPE c = (CTYPE) v;
|
|
||||||
SCM_ASSERT_RANGE (SCM_ARG1, val, v != (scm_t_signed_bits) c);
|
|
||||||
}
|
|
||||||
else
|
|
||||||
/* check float types */
|
|
||||||
#elif defined (FLOATTYPE)
|
|
||||||
/* real values, big numbers and immediate values are valid
|
|
||||||
for float conversions */
|
|
||||||
if (!SCM_REALP (val) && !SCM_BIGP (val) && !SCM_I_INUMP (val))
|
|
||||||
#else
|
|
||||||
if (!SCM_BIGP (val) && !SCM_I_INUMP (val))
|
|
||||||
#endif /* FLOATTYPE */
|
|
||||||
SCM_WRONG_TYPE_ARG (SCM_ARG1, val);
|
|
||||||
}
|
|
||||||
|
|
||||||
/* allocate new memory if necessary */
|
|
||||||
if (data == NULL)
|
|
||||||
if ((data = (CTYPE *) malloc (n * sizeof (CTYPE))) == NULL)
|
|
||||||
return NULL;
|
|
||||||
|
|
||||||
/* traverse the vector once more and convert each member */
|
|
||||||
for (i = 0; i < n; i++)
|
|
||||||
{
|
|
||||||
val = SCM_VELTS (obj)[i];
|
|
||||||
if (SCM_I_INUMP (val))
|
|
||||||
data[i] = (CTYPE) SCM_I_INUM (val);
|
|
||||||
else if (SCM_BIGP (val))
|
|
||||||
data[i] = (CTYPE) scm_to_long (val);
|
|
||||||
#if defined (FLOATTYPE)
|
|
||||||
else
|
|
||||||
data[i] = (CTYPE) SCM_REAL_VALUE (val);
|
|
||||||
#endif
|
|
||||||
}
|
|
||||||
break;
|
|
||||||
#ifdef ARRAYTPE
|
|
||||||
#if SCM_HAVE_ARRAYS
|
|
||||||
/* array conversions (uniform vectors) */
|
|
||||||
case ARRAYTYPE:
|
|
||||||
#ifdef ARRAYTYPE_OPTIONAL
|
|
||||||
case ARRAYTYPE_OPTIONAL:
|
|
||||||
#endif
|
|
||||||
n = SCM_UVECTOR_LENGTH (obj);
|
|
||||||
|
|
||||||
/* allocate new memory if necessary */
|
|
||||||
if (data == NULL)
|
|
||||||
if ((data = (CTYPE *) malloc (n * sizeof (CTYPE))) == NULL)
|
|
||||||
return NULL;
|
|
||||||
|
|
||||||
#ifdef FLOATTYPE_OPTIONAL
|
|
||||||
/* float <-> double conversions */
|
|
||||||
if (SCM_TYP7 (obj) == ARRAYTYPE_OPTIONAL)
|
|
||||||
{
|
|
||||||
for (i = 0; i < n; i++)
|
|
||||||
data[i] = ((FLOATTYPE_OPTIONAL *) SCM_UVECTOR_BASE (obj))[i];
|
|
||||||
}
|
|
||||||
else
|
|
||||||
#endif
|
|
||||||
#if SIZEOF_CTYPE != SIZEOF_ARRAYTYPE
|
|
||||||
/* copy array element by element */
|
|
||||||
for (i = 0; i < n; i++)
|
|
||||||
data[i] = (CTYPE) ((ARRAYCTYPE *) SCM_UVECTOR_BASE (obj))[i];
|
|
||||||
#else
|
|
||||||
/* copy whole array */
|
|
||||||
memcpy (data, (CTYPE *) SCM_UVECTOR_BASE (obj), n * sizeof (CTYPE));
|
|
||||||
#endif
|
|
||||||
break;
|
|
||||||
#endif /* SCM_HAVE_ARRAYS */
|
|
||||||
#endif
|
|
||||||
|
|
||||||
#if SIZEOF_CTYPE == 1
|
|
||||||
case scm_tc7_string:
|
|
||||||
n = scm_i_string_length (obj);
|
|
||||||
if (data == NULL)
|
|
||||||
if ((data = (CTYPE *) malloc (n * sizeof (CTYPE))) == NULL)
|
|
||||||
return NULL;
|
|
||||||
memcpy (data, scm_i_string_chars (obj), n * sizeof (CTYPE));
|
|
||||||
break;
|
|
||||||
#endif
|
|
||||||
|
|
||||||
default:
|
|
||||||
SCM_WRONG_TYPE_ARG (SCM_ARG1, obj);
|
|
||||||
}
|
|
||||||
return data;
|
|
||||||
}
|
}
|
||||||
#undef FUNC_NAME
|
|
||||||
|
|
||||||
|
|
||||||
#if SCM_HAVE_ARRAYS
|
|
||||||
|
|
||||||
/* Converts a C array into a uniform vector, returns SCM_UNDEFINED if out
|
|
||||||
of memory. */
|
|
||||||
#define FUNC_NAME CTYPES2UVECT_FN
|
|
||||||
SCM
|
|
||||||
CTYPES2UVECT (const CTYPE *data, long n)
|
|
||||||
{
|
|
||||||
#if SIZEOF_CTYPE != SIZEOF_UVECTTYPE
|
|
||||||
UVECTCTYPE *v;
|
|
||||||
long i;
|
|
||||||
#else
|
|
||||||
char *v;
|
|
||||||
#endif
|
|
||||||
|
|
||||||
SCM_ASSERT_RANGE (SCM_ARG2, scm_from_long (n),
|
|
||||||
n > 0 && n <= SCM_UVECTOR_MAX_LENGTH);
|
|
||||||
#if SIZEOF_CTYPE != SIZEOF_UVECTTYPE
|
|
||||||
v = scm_gc_malloc (n * SIZEOF_UVECTTYPE, "uvect");
|
|
||||||
for (i = 0; i < n; i++)
|
|
||||||
v[i] = (UVECTCTYPE) data[i];
|
|
||||||
#else
|
|
||||||
v = scm_gc_malloc (n * sizeof (CTYPE), "uvect");
|
|
||||||
memcpy (v, data, n * sizeof (CTYPE));
|
|
||||||
#endif
|
|
||||||
|
|
||||||
#ifdef UVEC_CREATOR
|
|
||||||
return UVEC_CREATOR (v, n);
|
|
||||||
#else
|
|
||||||
return scm_cell (SCM_MAKE_UVECTOR_TAG (n, UVECTTYPE), (scm_t_bits) v);
|
|
||||||
#endif
|
|
||||||
}
|
|
||||||
#undef FUNC_NAME
|
|
||||||
|
|
||||||
#if defined(UVECTTYPE_OPTIONAL) || defined(UVEC_CREATOR_OPTIONAL)
|
|
||||||
#define FUNC_NAME CTYPES2UVECT_FN_OPTIONAL
|
|
||||||
SCM
|
|
||||||
CTYPES2UVECT_OPTIONAL (const unsigned CTYPE *data, long n)
|
|
||||||
{
|
|
||||||
#if SIZEOF_CTYPE != SIZEOF_UVECTTYPE
|
|
||||||
unsigned UVECTCTYPE *v;
|
|
||||||
long i;
|
|
||||||
#else
|
|
||||||
char *v;
|
|
||||||
#endif
|
|
||||||
|
|
||||||
SCM_ASSERT_RANGE (SCM_ARG2, scm_from_long (n),
|
|
||||||
n > 0 && n <= SCM_UVECTOR_MAX_LENGTH);
|
|
||||||
#if SIZEOF_CTYPE != SIZEOF_UVECTTYPE
|
|
||||||
v = scm_gc_malloc (n * SIZEOF_UVECTTYPE, "uvect");
|
|
||||||
for (i = 0; i < n; i++)
|
|
||||||
v[i] = (unsigned UVECTCTYPE) data[i];
|
|
||||||
#else
|
|
||||||
v = scm_gc_malloc (n * sizeof (CTYPE), "uvect");
|
|
||||||
memcpy (v, data, n * sizeof (CTYPE));
|
|
||||||
#endif
|
|
||||||
#ifdef UVEC_CREATOR_OPTIONAL
|
|
||||||
return UVEC_CREATOR_OPTIONAL (v, n);
|
|
||||||
#else
|
|
||||||
return scm_cell (SCM_MAKE_UVECTOR_TAG (n, UVECTTYPE_OPTIONAL),
|
|
||||||
(scm_t_bits) v);
|
|
||||||
#endif
|
|
||||||
}
|
|
||||||
#undef FUNC_NAME
|
|
||||||
#endif /* UVECTTYPE_OPTIONAL || UVEC_CREATOR_OPTIONAL */
|
|
||||||
|
|
||||||
#endif /* SCM_HAVE_ARRAYS */
|
|
||||||
|
|
||||||
|
|
||||||
/* Converts a C array into a vector. */
|
/* Converts a C array into a vector. */
|
||||||
#define FUNC_NAME CTYPES2SCM_FN
|
|
||||||
SCM
|
SCM
|
||||||
CTYPES2SCM (const CTYPE *data, long n)
|
CTYPES2SCM (const CTYPE *data, long n)
|
||||||
{
|
{
|
||||||
long i;
|
long i;
|
||||||
SCM v;
|
SCM v;
|
||||||
|
|
||||||
SCM_ASSERT_RANGE (SCM_ARG2, scm_from_long (n),
|
|
||||||
n > 0 && n <= SCM_VECTOR_MAX_LENGTH);
|
|
||||||
v = scm_c_make_vector (n, SCM_UNSPECIFIED);
|
v = scm_c_make_vector (n, SCM_UNSPECIFIED);
|
||||||
|
|
||||||
for (i = 0; i < n; i++)
|
for (i = 0; i < n; i++)
|
||||||
#ifdef FLOATTYPE
|
SCM_VECTOR_SET (v, i, FROM_CTYPE (data[i]));
|
||||||
SCM_VECTOR_SET (v, i, scm_from_double ((double) data[i]));
|
|
||||||
#else
|
|
||||||
SCM_VECTOR_SET (v, i, scm_from_signed_integer (data[i]));
|
|
||||||
#endif
|
|
||||||
return v;
|
return v;
|
||||||
}
|
}
|
||||||
#undef FUNC_NAME
|
|
||||||
|
|
||||||
/* cleanup of conditionals */
|
/* Converts a C array into a uniform vector. */
|
||||||
#undef SCM2CTYPES
|
|
||||||
#undef SCM2CTYPES_FN
|
SCM
|
||||||
#undef CTYPES2SCM
|
CTYPES2UVECT (const CTYPE *data, long n)
|
||||||
#undef CTYPES2SCM_FN
|
{
|
||||||
|
long i;
|
||||||
|
SCM uvec;
|
||||||
|
UVEC_CTYPE *uvec_elements;
|
||||||
|
|
||||||
|
uvec = F(scm_make_,UVEC_TAG,vector) (scm_from_long (n), SCM_UNDEFINED);
|
||||||
|
uvec_elements = F(scm_,UVEC_TAG,vector_elements) (uvec);
|
||||||
|
|
||||||
|
for (i = 0; i < n; i++)
|
||||||
|
uvec_elements[i] = data[i];
|
||||||
|
|
||||||
|
scm_uniform_vector_release (uvec);
|
||||||
|
return uvec;
|
||||||
|
}
|
||||||
|
|
||||||
|
#ifdef CTYPE2UVECT_2
|
||||||
|
|
||||||
|
SCM
|
||||||
|
CTYPES2UVECT_2 (const CTYPE_2 *data, long n)
|
||||||
|
{
|
||||||
|
long i;
|
||||||
|
SCM uvec;
|
||||||
|
UVEC_CTYPE_2 *uvec_elements;
|
||||||
|
|
||||||
|
uvec = F(scm_make_,UVEC_TAG_2,vector) (scm_from_long (n), SCM_UNDEFINED);
|
||||||
|
uvec_elements = F(scm_,UVEC_TAG_2,vector_elements) (obj);
|
||||||
|
|
||||||
|
for (i = 0; i < n; i++)
|
||||||
|
v[i] = data[i];
|
||||||
|
|
||||||
|
scm_uniform_vector_release (uvec);
|
||||||
|
return uvec;
|
||||||
|
}
|
||||||
|
|
||||||
|
#endif
|
||||||
|
|
||||||
|
#undef paste
|
||||||
|
#undef stringify
|
||||||
|
#undef F
|
||||||
|
#undef S
|
||||||
|
|
||||||
#undef CTYPE
|
#undef CTYPE
|
||||||
|
#undef FROM_CTYPE
|
||||||
|
#undef UVEC_TAG
|
||||||
|
#undef UVEC_CTYPE
|
||||||
|
#undef SCM2CTYPES
|
||||||
|
#undef CTYPES2SCM
|
||||||
#undef CTYPES2UVECT
|
#undef CTYPES2UVECT
|
||||||
#undef CTYPES2UVECT_FN
|
#ifdef CTYPES2UVECT_2
|
||||||
#undef UVECTTYPE
|
#undef CTYPES2UVECT_2
|
||||||
#ifdef UVECTTYPE_OPTIONAL
|
#undef CTYPE_2
|
||||||
#undef CTYPES2UVECT_OPTIONAL
|
#undef UVEC_TAG_2
|
||||||
#undef CTYPES2UVECT_FN_OPTIONAL
|
#undef UVEC_CTYPE_2
|
||||||
#undef UVECTTYPE_OPTIONAL
|
|
||||||
#endif
|
#endif
|
||||||
#undef SIZEOF_CTYPE
|
|
||||||
#undef SIZEOF_UVECTTYPE
|
|
||||||
#undef SIZEOF_ARRAYTYPE
|
|
||||||
#ifdef ARRAYTYPE
|
|
||||||
#undef ARRAYTYPE
|
|
||||||
#endif
|
|
||||||
#ifdef ARRAYTYPE_OPTIONAL
|
|
||||||
#undef ARRAYTYPE_OPTIONAL
|
|
||||||
#endif
|
|
||||||
#ifdef FLOATTYPE
|
|
||||||
#undef FLOATTYPE
|
|
||||||
#endif
|
|
||||||
#ifdef FLOATTYPE_OPTIONAL
|
|
||||||
#undef FLOATTYPE_OPTIONAL
|
|
||||||
#endif
|
|
||||||
#ifdef UVECTCTYPE
|
|
||||||
#undef UVECTCTYPE
|
|
||||||
#endif
|
|
||||||
#ifdef ARRAYCTYPE
|
|
||||||
#undef ARRAYCTYPE
|
|
||||||
#endif
|
|
||||||
#ifdef UVEC_PREDICATE
|
|
||||||
#undef UVEC_PREDICATE
|
|
||||||
#endif
|
|
||||||
#ifdef UVEC_CREATOR
|
|
||||||
#undef UVEC_CREATOR
|
|
||||||
#endif
|
|
||||||
#ifdef UVEC_CREATOR_OPTIONAL
|
|
||||||
#undef UVEC_CREATOR_OPTIONAL
|
|
||||||
#endif
|
|
||||||
|
|
||||||
|
|
||||||
/*
|
/*
|
||||||
Local Variables:
|
Local Variables:
|
||||||
|
|
|
||||||
Loading…
Add table
Add a link
Reference in a new issue