diff options
author | Marius Vollmer <mvo@zagadka.de> | 2005-01-14 18:19:13 +0000 |
---|---|---|
committer | Marius Vollmer <mvo@zagadka.de> | 2005-01-14 18:19:13 +0000 |
commit | 00c17d45262defe568a3c628c403cdcdf57fd69a (patch) | |
tree | 142e705a576db6654d98372e5370af2282bf46ac | |
parent | 55fcbb966b95006ce54a5d648f00087c41e802e6 (diff) | |
download | guile-00c17d45262defe568a3c628c403cdcdf57fd69a.tar.gz |
(scm_take_u64vector,
scm_array_handle_u64_elements,
scm_array_handle_u64_writable_elements, scm_u64vector_elements,
scm_u64vector_writable_elements): Do not define when scm_t_uint64
is not available.
(scm_take_s64vector, scm_array_handle_s64_elements,
scm_array_handle_s64_writable_elements, scm_s64vector_elements,
scm_s64vector_writable_elements): Likewise for scm_t_int64.
(uvec_sizes, uvec_print, uvec_equalp): Use SCM bignums when
scm_t_int64/scm_t_uint64 are not available.
(uvec_mark): New, to mark the bignums.
(alloc_uvec): Initialize bignums.
(uvec_fast_ref): Return bignums directly.
(scm_uint64_min, scm_uint64_max, scm_int64_min, scm_int64_max,
assert_exact_integer): New.
(uvec_fast_set): Use them to validate the bignums.
(scm_init_srfi_4): Set mark function of smob when needed.
Initialize scm_uint64_min, scm_uint64_max, scm_int64_min,
scm_int64_max.
-rw-r--r-- | libguile/srfi-4.c | 106 | ||||
-rw-r--r-- | libguile/srfi-4.h | 10 | ||||
-rw-r--r-- | libguile/srfi-4.i.c | 22 |
3 files changed, 127 insertions, 11 deletions
diff --git a/libguile/srfi-4.c b/libguile/srfi-4.c index 2ee65166e..53da9f86f 100644 --- a/libguile/srfi-4.c +++ b/libguile/srfi-4.c @@ -35,6 +35,7 @@ #include "libguile/vectors.h" #include "libguile/unif.h" #include "libguile/strings.h" +#include "libguile/strports.h" #include "libguile/dynwind.h" #include "libguile/deprecation.h" @@ -83,7 +84,11 @@ static const int uvec_sizes[12] = { 1, 1, 2, 2, 4, 4, +#if SCM_HAVE_T_INT64 8, 8, +#else + sizeof (SCM), sizeof (SCM), +#endif sizeof(float), sizeof(double), 2*sizeof(float), 2*sizeof(double) }; @@ -128,6 +133,7 @@ uvec_print (SCM uvec, SCM port, scm_print_state *pstate) #endif float *f32; double *f64; + SCM *fake_64; } np; size_t i = 0; @@ -145,7 +151,10 @@ uvec_print (SCM uvec, SCM port, scm_print_state *pstate) #if SCM_HAVE_T_INT64 case SCM_UVEC_U64: np.u64 = (scm_t_uint64 *) uptr; break; case SCM_UVEC_S64: np.s64 = (scm_t_int64 *) uptr; break; -#endif +#else + case SCM_UVEC_U64: + case SCM_UVEC_S64: np.fake_64 = (SCM *) uptr; break; +#endif case SCM_UVEC_F32: np.f32 = (float *) uptr; break; case SCM_UVEC_F64: np.f64 = (double *) uptr; break; case SCM_UVEC_C32: np.f32 = (float *) uptr; break; @@ -173,6 +182,10 @@ uvec_print (SCM uvec, SCM port, scm_print_state *pstate) #if SCM_HAVE_T_INT64 case SCM_UVEC_U64: scm_uintprint (*np.u64, 10, port); np.u64++; break; case SCM_UVEC_S64: scm_intprint (*np.s64, 10, port); np.s64++; break; +#else + case SCM_UVEC_U64: + case SCM_UVEC_S64: scm_iprin1 (*np.fake_64, port, pstate); + np.fake_64++; break; #endif case SCM_UVEC_F32: scm_i_print_double (*np.f32, port); np.f32++; break; case SCM_UVEC_F64: scm_i_print_double (*np.f64, port); np.f64++; break; @@ -209,6 +222,20 @@ uvec_equalp (SCM a, SCM b) result = SCM_BOOL_F; else if (SCM_UVEC_LENGTH (a) != SCM_UVEC_LENGTH (b)) result = SCM_BOOL_F; +#if SCM_HAVE_T_INT64 == 0 + else if (SCM_UVEC_TYPE (a) == SCM_UVEC_U64 + || SCM_UVEC_TYPE (a) == SCM_UVEC_S64) + { + SCM *aptr = (SCM *)SCM_UVEC_BASE (a), *bptr = (SCM *)SCM_UVEC_BASE (b); + size_t len = SCM_UVEC_LENGTH (a), i; + for (i = 0; i < len; i++) + if (scm_is_false (scm_num_eq_p (*aptr++, *bptr++))) + { + result = SCM_BOOL_F; + break; + } + } +#endif else if (memcmp (SCM_UVEC_BASE (a), SCM_UVEC_BASE (b), SCM_UVEC_LENGTH (a) * uvec_sizes[SCM_UVEC_TYPE(a)]) != 0) result = SCM_BOOL_F; @@ -217,6 +244,24 @@ uvec_equalp (SCM a, SCM b) return result; } +/* Mark hook. Only used when U64 and S64 are implemented as SCMs. */ + +#if SCM_HAVE_T_INT64 == 0 +static SCM +uvec_mark (SCM uvec) +{ + if (SCM_UVEC_TYPE (uvec) == SCM_UVEC_U64 + || SCM_UVEC_TYPE (uvec) == SCM_UVEC_S64) + { + SCM *ptr = (SCM *)SCM_UVEC_BASE (uvec); + size_t len = SCM_UVEC_LENGTH (uvec), i; + for (i = 0; i < len; i++) + scm_gc_mark (*ptr++); + } + return SCM_BOOL_F; +} +#endif + /* Smob free hook for homogeneous numeric vectors. */ static size_t uvec_free (SCM uvec) @@ -273,6 +318,15 @@ alloc_uvec (int type, size_t len) if (len > SCM_I_SIZE_MAX / uvec_sizes[type]) scm_out_of_range (NULL, scm_from_size_t (len)); base = scm_gc_malloc (len * uvec_sizes[type], uvec_names[type]); +#if SCM_HAVE_T_INT64 == 0 + if (type == SCM_UVEC_U64 || type == SCM_UVEC_S64) + { + SCM *ptr = (SCM *)base; + size_t i; + for (i = 0; i < len; i++) + *ptr++ = SCM_UNSPECIFIED; + } +#endif return take_uvec (type, base, len); } @@ -300,6 +354,11 @@ uvec_fast_ref (int type, const void *base, size_t c_idx) return scm_from_uint64 (((scm_t_uint64*)base)[c_idx]); else if (type == SCM_UVEC_S64) return scm_from_int64 (((scm_t_int64*)base)[c_idx]); +#else + else if (type == SCM_UVEC_U64) + return ((SCM *)base)[c_idx]; + else if (type == SCM_UVEC_S64) + return ((SCM *)base)[c_idx]; #endif else if (type == SCM_UVEC_F32) return scm_from_double (((float*)base)[c_idx]); @@ -315,6 +374,22 @@ uvec_fast_ref (int type, const void *base, size_t c_idx) return SCM_BOOL_F; } +#if SCM_HAVE_T_INT64 == 0 +static SCM scm_uint64_min, scm_uint64_max; +static SCM scm_int64_min, scm_int64_max; + +static void +assert_exact_integer_range (SCM val, SCM min, SCM max) +{ + if (!scm_is_integer (val) + || scm_is_false (scm_exact_p (val))) + scm_wrong_type_arg_msg (NULL, 0, val, "exact integer"); + if (scm_is_true (scm_less_p (val, min)) + || scm_is_true (scm_gr_p (val, max))) + scm_out_of_range (NULL, val); +} +#endif + static SCM_C_INLINE void uvec_fast_set_x (int type, void *base, size_t c_idx, SCM val) { @@ -335,6 +410,17 @@ uvec_fast_set_x (int type, void *base, size_t c_idx, SCM val) (((scm_t_uint64*)base)[c_idx]) = scm_to_uint64 (val); else if (type == SCM_UVEC_S64) (((scm_t_int64*)base)[c_idx]) = scm_to_int64 (val); +#else + else if (type == SCM_UVEC_U64) + { + assert_exact_integer_range (val, scm_uint64_min, scm_uint64_max); + ((SCM *)base)[c_idx] = val; + } + else if (type == SCM_UVEC_S64) + { + assert_exact_integer_range (val, scm_int64_min, scm_int64_max); + ((SCM *)base)[c_idx] = val; + } #endif else if (type == SCM_UVEC_F32) (((float*)base)[c_idx]) = scm_to_double (val); @@ -968,12 +1054,16 @@ SCM_DEFINE (scm_uniform_vector_write, "uniform-vector-write", 1, 3, 0, #define TYPE SCM_UVEC_U64 #define TAG u64 +#if SCM_HAVE_T_UINT64 #define CTYPE scm_t_uint64 +#endif #include "libguile/srfi-4.i.c" #define TYPE SCM_UVEC_S64 #define TAG s64 +#if SCM_HAVE_T_INT64 #define CTYPE scm_t_int64 +#endif #include "libguile/srfi-4.i.c" #define TYPE SCM_UVEC_F32 @@ -1031,9 +1121,23 @@ scm_init_srfi_4 (void) { scm_tc16_uvec = scm_make_smob_type ("uvec", 0); scm_set_smob_equalp (scm_tc16_uvec, uvec_equalp); +#if SCM_HAVE_T_INT64 == 0 + scm_set_smob_mark (scm_tc16_uvec, uvec_mark); +#endif scm_set_smob_free (scm_tc16_uvec, uvec_free); scm_set_smob_print (scm_tc16_uvec, uvec_print); +#if SCM_HAVE_T_INT64 == 0 + scm_uint64_min = + scm_permanent_object (scm_from_int (0)); + scm_uint64_max = + scm_permanent_object (scm_c_read_string ("18446744073709551615")); + scm_int64_min = + scm_permanent_object (scm_c_read_string ("-9223372036854775808")); + scm_int64_max = + scm_permanent_object (scm_c_read_string ("9223372036854775807")); +#endif + #include "libguile/srfi-4.x" } diff --git a/libguile/srfi-4.h b/libguile/srfi-4.h index 6bd8fe4bb..311a42e61 100644 --- a/libguile/srfi-4.h +++ b/libguile/srfi-4.h @@ -178,7 +178,6 @@ SCM_API scm_t_int32 *scm_s32vector_writable_elements (SCM uvec, SCM_API SCM scm_u64vector_p (SCM obj); SCM_API SCM scm_make_u64vector (SCM n, SCM fill); -SCM_API SCM scm_take_u64vector (const scm_t_uint64 *data, size_t n); SCM_API SCM scm_u64vector (SCM l); SCM_API SCM scm_u64vector_length (SCM uvec); SCM_API SCM scm_u64vector_ref (SCM uvec, SCM index); @@ -186,6 +185,9 @@ 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 scm_any_to_u64vector (SCM obj); + +#if SCM_HAVE_T_UINT64 +SCM_API SCM scm_take_u64vector (const scm_t_uint64 *data, size_t n); SCM_API const scm_t_uint64 *scm_array_handle_u64_elements (scm_t_array_handle *h); SCM_API scm_t_uint64 *scm_array_handle_u64_writable_elements (scm_t_array_handle *h); SCM_API const scm_t_uint64 *scm_u64vector_elements (SCM uvec, @@ -196,10 +198,10 @@ SCM_API scm_t_uint64 *scm_u64vector_writable_elements (SCM uvec, scm_t_array_handle *h, size_t *lenp, ssize_t *incp); +#endif SCM_API SCM scm_s64vector_p (SCM obj); SCM_API SCM scm_make_s64vector (SCM n, SCM fill); -SCM_API SCM scm_take_s64vector (const scm_t_int64 *data, size_t n); SCM_API SCM scm_s64vector (SCM l); SCM_API SCM scm_s64vector_length (SCM uvec); SCM_API SCM scm_s64vector_ref (SCM uvec, SCM index); @@ -207,6 +209,9 @@ 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 scm_any_to_s64vector (SCM obj); + +#if SCM_HAVE_T_INT64 +SCM_API SCM scm_take_s64vector (const scm_t_int64 *data, size_t n); SCM_API const scm_t_int64 *scm_array_handle_s64_elements (scm_t_array_handle *h); SCM_API scm_t_int64 *scm_array_handle_s64_writable_elements (scm_t_array_handle *h); SCM_API const scm_t_int64 *scm_s64vector_elements (SCM uvec, @@ -216,6 +221,7 @@ SCM_API scm_t_int64 *scm_s64vector_writable_elements (SCM uvec, scm_t_array_handle *h, size_t *lenp, ssize_t *incp); +#endif SCM_API SCM scm_f32vector_p (SCM obj); SCM_API SCM scm_make_f32vector (SCM n, SCM fill); diff --git a/libguile/srfi-4.i.c b/libguile/srfi-4.i.c index e1c3598c4..101eb386c 100644 --- a/libguile/srfi-4.i.c +++ b/libguile/srfi-4.i.c @@ -21,6 +21,8 @@ The C type of the elements, for example scm_t_uint8. The code below will never do sizeof (CTYPE), thus you can use just 'float' for the c32 type, for example. + + When CTYPE is not defined, the functions using it are excluded. */ /* The first level does not expand macros in the arguments. */ @@ -55,14 +57,6 @@ SCM_DEFINE (F(scm_make_,TAG,vector), "make-"S(TAG)"vector", 1, 1, 0, } #undef FUNC_NAME -SCM -F(scm_take_,TAG,vector) (const CTYPE *data, size_t n) -{ - scm_gc_register_collectable_memory ((void *)data, n*uvec_sizes[TYPE], - uvec_names[TYPE]); - return take_uvec (TYPE, data, n); -} - SCM_DEFINE (F(scm_,TAG,vector), S(TAG)"vector", 0, 0, 1, (SCM l), "Return a newly allocated uniform numeric vector containing\n" @@ -138,6 +132,16 @@ SCM_DEFINE (F(scm_any_to_,TAG,vector), "any->"S(TAG)"vector", 1, 0, 0, } #undef FUNC_NAME +#ifdef CTYPE + +SCM +F(scm_take_,TAG,vector) (const CTYPE *data, size_t n) +{ + scm_gc_register_collectable_memory ((void *)data, n*uvec_sizes[TYPE], + uvec_names[TYPE]); + return take_uvec (TYPE, data, n); +} + const CTYPE * F(scm_array_handle_,TAG,_elements) (scm_t_array_handle *h) { @@ -180,6 +184,8 @@ F(scm_,TAG,vector_writable_elements) (SCM uvec, return F(scm_array_handle_,TAG,_writable_elements) (h); } +#endif + static SCM F(,TAG,ref) (scm_t_array_handle *handle, ssize_t pos) { |