summaryrefslogtreecommitdiff
path: root/libguile/unif.c
diff options
context:
space:
mode:
authorMarius Vollmer <mvo@zagadka.de>2004-11-02 19:50:11 +0000
committerMarius Vollmer <mvo@zagadka.de>2004-11-02 19:50:11 +0000
commit85368844371fd1ca90617e1847d76e7c0a02a14f (patch)
tree1f1e4a778a921538466f2d54024212de18afc7d5 /libguile/unif.c
parentb7a7750adf5f96c46005e1a97503aa3a105d532d (diff)
downloadguile-85368844371fd1ca90617e1847d76e7c0a02a14f.tar.gz
* eq.c, evalext.c, gc-card.c, gc-mark.c, objects.c, print.c,
ramap.c, unif.c: Do no longer handle old-style uniform vectors. * unif.c (scm_bit_set_star_x, scm_bit_count_star_x): Use u32vectors instead of old-sytle uvectors.
Diffstat (limited to 'libguile/unif.c')
-rw-r--r--libguile/unif.c591
1 files changed, 98 insertions, 493 deletions
diff --git a/libguile/unif.c b/libguile/unif.c
index ab4948353..ff041cb55 100644
--- a/libguile/unif.c
+++ b/libguile/unif.c
@@ -67,13 +67,13 @@
/* The set of uniform scm_vector types is:
* Vector of: Called: Replaced by:
* unsigned char string
- * char byvect s8
+ * char byvect s8 or u8, depending on signedness of 'char'
* boolean bvect
* signed long ivect s32
* unsigned long uvect u32
* float fvect f32
* double dvect d32
- * complex double cvect
+ * complex double cvect c64
* short svect s16
* long long llvect s64
*/
@@ -81,6 +81,7 @@
scm_t_bits scm_tc16_array;
static SCM exactly_one_third;
+#if 0
/* Silly function used not to modify the semantics of the silly
* prototype system in order to be backward compatible.
*/
@@ -96,6 +97,7 @@ singp (SCM obj)
return (- SCM_FLTMAX < x) && (x < SCM_FLTMAX) && (fx == x);
}
}
+#endif
static SCM scm_i_proc_make_vector;
static SCM scm_i_proc_make_string;
@@ -269,15 +271,6 @@ SCM_DEFINE (scm_array_p, "array?", 1, 1, 0,
{
case scm_tc7_bvect:
case scm_tc7_string:
- case scm_tc7_uvect:
- case scm_tc7_ivect:
- case scm_tc7_svect:
-#if SCM_SIZEOF_LONG_LONG != 0
- case scm_tc7_llvect:
-#endif
- case scm_tc7_fvect:
- case scm_tc7_dvect:
- case scm_tc7_cvect:
case scm_tc7_vector:
case scm_tc7_wvect:
return SCM_BOOL_T;
@@ -297,35 +290,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_uvect:
- protp = SCM_I_INUMP(prot) && SCM_I_INUM(prot)>0;
- break;
- case scm_tc7_ivect:
- protp = SCM_I_INUMP(prot) && SCM_I_INUM(prot)<=0;
- break;
- case scm_tc7_svect:
- protp = scm_is_symbol (prot)
- && (1 == scm_i_symbol_length (prot))
- && ('s' == scm_i_symbol_chars (prot)[0]);
- break;
-#if SCM_SIZEOF_LONG_LONG != 0
- case scm_tc7_llvect:
- protp = scm_is_symbol (prot)
- && (1 == scm_i_symbol_length (prot))
- && ('l' == scm_i_symbol_chars (prot)[0]);
- break;
-#endif
- case scm_tc7_fvect:
- protp = singp (prot);
- break;
- case scm_tc7_dvect:
- protp = ((SCM_REALP(prot) && ! singp (prot))
- || (SCM_FRACTIONP (prot)
- && scm_num_eq_p (exactly_one_third, prot)));
- break;
- case scm_tc7_cvect:
- protp = SCM_COMPLEXP(prot);
- break;
case scm_tc7_vector:
case scm_tc7_wvect:
protp = scm_is_null(prot);
@@ -358,15 +322,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_uvect:
- case scm_tc7_ivect:
- case scm_tc7_fvect:
- case scm_tc7_cvect:
- case scm_tc7_dvect:
-#if SCM_SIZEOF_LONG_LONG != 0
- case scm_tc7_llvect:
-#endif
- case scm_tc7_svect:
return scm_from_int (1);
case scm_tc7_smob:
if (SCM_ARRAYP (ra))
@@ -403,15 +358,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_uvect:
- case scm_tc7_ivect:
- case scm_tc7_fvect:
- case scm_tc7_cvect:
- case scm_tc7_dvect:
- case scm_tc7_svect:
-#if SCM_SIZEOF_LONG_LONG != 0
- case scm_tc7_llvect:
-#endif
return scm_cons (scm_uniform_vector_length (ra), SCM_EOL);
case scm_tc7_smob:
if (!SCM_ARRAYP (ra))
@@ -823,15 +769,6 @@ SCM_DEFINE (scm_transpose_array, "transpose-array", 1, 0, 1,
badarg:SCM_WRONG_TYPE_ARG (1, ra);
case scm_tc7_bvect:
case scm_tc7_string:
- 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
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);
@@ -937,17 +874,8 @@ SCM_DEFINE (scm_enclose_array, "enclose-array", 1, 0, 1,
badarg1:SCM_WRONG_TYPE_ARG (1, ra);
case scm_tc7_string:
case scm_tc7_bvect:
- case scm_tc7_uvect:
- case scm_tc7_ivect:
- case scm_tc7_fvect:
- case scm_tc7_dvect:
- case scm_tc7_cvect:
case scm_tc7_vector:
case scm_tc7_wvect:
- case scm_tc7_svect:
-#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;
@@ -1062,15 +990,6 @@ tail:
goto tail;
case scm_tc7_bvect:
case scm_tc7_string:
- 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
case scm_tc7_vector:
case scm_tc7_wvect:
uniform_vector:
@@ -1156,25 +1075,6 @@ SCM_DEFINE (scm_array_ref, "array-ref", 1, 0, 1,
return SCM_BOOL_F;
case scm_tc7_string:
return scm_c_string_ref (v, pos);
- 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_svect:
- return scm_from_short (((short *) SCM_CELL_WORD_1 (v))[pos]);
-#if SCM_SIZEOF_LONG_LONG != 0
- case scm_tc7_llvect:
- return scm_from_long_long (((long long *) SCM_CELL_WORD_1 (v))[pos]);
-#endif
-
- case scm_tc7_fvect:
- return scm_from_double (((float *) SCM_CELL_WORD_1 (v))[pos]);
- case scm_tc7_dvect:
- return scm_from_double (((double *) SCM_CELL_WORD_1 (v))[pos]);
- case scm_tc7_cvect:
- return scm_c_make_rectangular (((double *) SCM_CELL_WORD_1(v))[2*pos],
- ((double *) SCM_CELL_WORD_1(v))[2*pos+1]);
case scm_tc7_vector:
case scm_tc7_wvect:
return SCM_VELTS (v)[pos];
@@ -1203,39 +1103,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_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_svect:
- return scm_from_short (((short *) SCM_CELL_WORD_1 (v))[pos]);
-#if SCM_SIZEOF_LONG_LONG != 0
- case scm_tc7_llvect:
- return scm_from_long_long (((long long *) SCM_CELL_WORD_1 (v))[pos]);
-#endif
- case scm_tc7_fvect:
- if (SCM_REALP (last) && !scm_is_eq (last, scm_flo0))
- {
- SCM_REAL_VALUE (last) = ((float *) SCM_CELL_WORD_1 (v))[pos];
- return last;
- }
- return scm_from_double (((float *) SCM_CELL_WORD_1 (v))[pos]);
- case scm_tc7_dvect:
- if (SCM_REALP (last) && !scm_is_eq (last, scm_flo0))
- {
- SCM_REAL_VALUE (last) = ((double *) SCM_CELL_WORD_1 (v))[pos];
- return last;
- }
- return scm_from_double (((double *) SCM_CELL_WORD_1 (v))[pos]);
- case scm_tc7_cvect:
- if (SCM_COMPLEXP (last))
- {
- SCM_COMPLEX_REAL (last) = ((double *) SCM_CELL_WORD_1 (v))[2 * pos];
- SCM_COMPLEX_IMAG (last) = ((double *) SCM_CELL_WORD_1 (v))[2 * pos + 1];
- return last;
- }
- return scm_c_make_rectangular (((double *) SCM_CELL_WORD_1(v))[2*pos],
- ((double *) SCM_CELL_WORD_1(v))[2*pos+1]);
case scm_tc7_vector:
case scm_tc7_wvect:
return SCM_VELTS (v)[pos];
@@ -1320,36 +1187,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_uvect:
- ((unsigned long *) SCM_UVECTOR_BASE (v))[pos] = scm_to_ulong (obj);
- break;
- case scm_tc7_ivect:
- ((long *) SCM_UVECTOR_BASE (v))[pos] = scm_to_long (obj);
- break;
- case scm_tc7_svect:
- ((short *) SCM_UVECTOR_BASE (v))[pos] = scm_to_short (obj);
- break;
-#if SCM_SIZEOF_LONG_LONG != 0
- case scm_tc7_llvect:
- ((long long *) SCM_UVECTOR_BASE (v))[pos] = scm_to_long_long (obj);
- break;
-#endif
- case scm_tc7_fvect:
- ((float *) SCM_UVECTOR_BASE (v))[pos] = scm_to_double (obj);
- break;
- case scm_tc7_dvect:
- ((double *) SCM_UVECTOR_BASE (v))[pos] = scm_to_double (obj);
- break;
- case scm_tc7_cvect:
- SCM_ASRTGO (SCM_INEXACTP (obj), badobj);
- if (SCM_REALP (obj)) {
- ((double *) SCM_UVECTOR_BASE (v))[2 * pos] = SCM_REAL_VALUE (obj);
- ((double *) SCM_UVECTOR_BASE (v))[2 * pos + 1] = 0.0;
- } else {
- ((double *) SCM_UVECTOR_BASE (v))[2 * pos] = SCM_COMPLEX_REAL (obj);
- ((double *) SCM_UVECTOR_BASE (v))[2 * pos + 1] = SCM_COMPLEX_IMAG (obj);
- }
- break;
case scm_tc7_vector:
case scm_tc7_wvect:
SCM_VECTOR_SET (v, pos, obj);
@@ -1392,15 +1229,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_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 ra;
case scm_tc7_smob:
{
@@ -1541,33 +1369,6 @@ loop:
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;
@@ -1727,33 +1528,6 @@ loop:
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;
@@ -1928,57 +1702,71 @@ SCM_DEFINE (scm_bit_set_star_x, "bit-set*!", 3, 0, 0,
"@result{} #*11010011\n"
"@end example\n"
"\n"
- "If @var{kv} is a uniform vector of unsigned long integers, then\n"
- "they're indexes into @var{v} which are set to @var{obj}.\n"
+ "If @var{kv} is a u32vector, then its elements are\n"
+ "indices into @var{v} which are set to @var{obj}.\n"
"\n"
"@example\n"
"(define bv #*01000010)\n"
- "(bit-set*! bv #u(5 2 7) #t)\n"
+ "(bit-set*! bv #u32(5 2 7) #t)\n"
"bv\n"
"@result{} #*01100111\n"
"@end example")
#define FUNC_NAME s_scm_bit_set_star_x
{
- register long i, k, vlen;
SCM_ASSERT (SCM_BITVECTOR_P (v), v, SCM_ARG1, FUNC_NAME);
- SCM_ASRTGO (SCM_NIMP (kv), badarg2);
- switch SCM_TYP7 (kv)
+
+ if (SCM_BITVECTOR_P (kv))
{
- default:
- badarg2:SCM_WRONG_TYPE_ARG (2, kv);
- case scm_tc7_uvect:
- vlen = SCM_BITVECTOR_LENGTH (v);
+ long k;
+
+ if (SCM_BITVECTOR_LENGTH (v) != SCM_BITVECTOR_LENGTH (kv))
+ scm_misc_error (NULL,
+ "bit vectors must have equal length",
+ SCM_EOL);
+
if (scm_is_false (obj))
- for (i = SCM_UVECTOR_LENGTH (kv); i;)
+ for (k = (SCM_BITVECTOR_LENGTH (v) + SCM_LONG_BIT - 1) / SCM_LONG_BIT;
+ k--;)
+ SCM_BITVECTOR_BASE (v) [k] &= ~SCM_BITVECTOR_BASE (kv) [k];
+ else if (scm_is_eq (obj, SCM_BOOL_T))
+ for (k = (SCM_BITVECTOR_LENGTH (v) + SCM_LONG_BIT - 1) / SCM_LONG_BIT;
+ k--;)
+ SCM_BITVECTOR_BASE (v) [k] |= SCM_BITVECTOR_BASE (kv) [k];
+ else
+ scm_wrong_type_arg_msg (NULL, 0, obj, "boolean");
+ }
+ else if (scm_is_true (scm_u32vector_p (kv)))
+ {
+ size_t vlen = SCM_BITVECTOR_LENGTH (v);
+ size_t ulen = scm_c_uniform_vector_length (kv);
+ size_t i;
+ scm_t_uint32 k;
+
+ if (scm_to_bool (obj) == 0)
+ for (i = 0; i < ulen; i++)
{
- k = SCM_UNPACK (SCM_VELTS (kv)[--i]);
+ /* XXX - poof, there goes the uniform vector efficiency
+ advantage.
+ */
+ k = scm_to_uint32 (scm_uniform_vector_ref (kv,
+ scm_from_size_t (i)));
if (k >= vlen)
- scm_out_of_range (FUNC_NAME, scm_from_long (k));
+ scm_out_of_range (FUNC_NAME, scm_from_uint32 (k));
SCM_BITVEC_CLR(v, k);
}
- else if (scm_is_eq (obj, SCM_BOOL_T))
- for (i = SCM_UVECTOR_LENGTH (kv); i;)
+ else
+ for (i = 0; i < ulen; i++)
{
- k = SCM_UNPACK (SCM_VELTS (kv)[--i]);
+ k = scm_to_uint32 (scm_uniform_vector_ref (kv,
+ scm_from_size_t (i)));
if (k >= vlen)
- scm_out_of_range (FUNC_NAME, scm_from_long (k));
+ scm_out_of_range (FUNC_NAME, scm_from_uint32 (k));
SCM_BITVEC_SET(v, k);
}
- else
- badarg3:SCM_WRONG_TYPE_ARG (3, obj);
- break;
- case scm_tc7_bvect:
- SCM_ASSERT (SCM_BITVECTOR_LENGTH (v) == SCM_BITVECTOR_LENGTH (kv), v, SCM_ARG1, FUNC_NAME);
- if (scm_is_false (obj))
- for (k = (SCM_BITVECTOR_LENGTH (v) + SCM_LONG_BIT - 1) / SCM_LONG_BIT; k--;)
- SCM_BITVECTOR_BASE (v) [k] &= ~SCM_BITVECTOR_BASE (kv) [k];
- else if (scm_is_eq (obj, SCM_BOOL_T))
- for (k = (SCM_BITVECTOR_LENGTH (v) + SCM_LONG_BIT - 1) / SCM_LONG_BIT; k--;)
- SCM_BITVECTOR_BASE (v) [k] |= SCM_BITVECTOR_BASE (kv) [k];
- else
- goto badarg3;
- break;
}
+ else
+ scm_wrong_type_arg_msg (NULL, 0, kv, "bitvector or u32vector");
+
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
@@ -1994,57 +1782,36 @@ SCM_DEFINE (scm_bit_count_star, "bit-count*", 3, 0, 0,
"@code{#t} are the ones in @var{v} which are considered.\n"
"@var{kv} and @var{v} must be the same length.\n"
"\n"
- "If @var{kv} is a uniform vector of unsigned long integers, then\n"
- "it's the indexes in @var{v} to consider.\n"
+ "If @var{kv} is a u32vector, then it contains\n"
+ "the indexes in @var{v} to consider.\n"
"\n"
"For example,\n"
"\n"
"@example\n"
"(bit-count* #*01110111 #*11001101 #t) @result{} 3\n"
- "(bit-count* #*01110111 #u(7 0 4) #f) @result{} 2\n"
+ "(bit-count* #*01110111 #u32(7 0 4) #f) @result{} 2\n"
"@end example")
#define FUNC_NAME s_scm_bit_count_star
{
- register long i, vlen, count = 0;
- register unsigned long k;
- int fObj = 0;
+ size_t count = 0;
SCM_ASSERT (SCM_BITVECTOR_P (v), v, SCM_ARG1, FUNC_NAME);
- SCM_ASRTGO (SCM_NIMP (kv), badarg2);
- switch SCM_TYP7 (kv)
+
+ if (SCM_BITVECTOR_P (kv))
{
- default:
- badarg2:
- SCM_WRONG_TYPE_ARG (2, kv);
- case scm_tc7_uvect:
- vlen = SCM_BITVECTOR_LENGTH (v);
- if (scm_is_false (obj))
- for (i = SCM_UVECTOR_LENGTH (kv); i;)
- {
- k = SCM_UNPACK (SCM_VELTS (kv)[--i]);
- if (k >= vlen)
- scm_out_of_range (FUNC_NAME, scm_from_long (k));
- if (!SCM_BITVEC_REF(v, k))
- count++;
- }
- else if (scm_is_eq (obj, SCM_BOOL_T))
- for (i = SCM_UVECTOR_LENGTH (kv); i;)
- {
- k = SCM_UNPACK (SCM_VELTS (kv)[--i]);
- if (k >= vlen)
- scm_out_of_range (FUNC_NAME, scm_from_long (k));
- if (SCM_BITVEC_REF (v, k))
- count++;
- }
- else
- badarg3:SCM_WRONG_TYPE_ARG (3, obj);
- break;
- case scm_tc7_bvect:
- SCM_ASSERT (SCM_BITVECTOR_LENGTH (v) == SCM_BITVECTOR_LENGTH (kv), v, SCM_ARG1, FUNC_NAME);
+ unsigned long k, i;
+ int fObj = 0;
+
+ if (SCM_BITVECTOR_LENGTH (v) != SCM_BITVECTOR_LENGTH (kv))
+ scm_misc_error (NULL,
+ "bit vectors must have equal length",
+ SCM_EOL);
+
if (0 == SCM_BITVECTOR_LENGTH (v))
return SCM_INUM0;
- SCM_ASRTGO (scm_is_bool (obj), badarg3);
- fObj = scm_is_eq (obj, SCM_BOOL_T);
+
+ fObj = scm_to_bool (obj);
+
i = (SCM_BITVECTOR_LENGTH (v) - 1) / SCM_LONG_BIT;
k = SCM_UNPACK (SCM_VELTS (kv)[i]) & (fObj ? SCM_UNPACK (SCM_VELTS (v)[i]) : ~ SCM_UNPACK (SCM_VELTS (v)[i]));
k <<= SCM_LONG_BIT - 1 - ((SCM_BITVECTOR_LENGTH (v) - 1) % SCM_LONG_BIT);
@@ -2059,6 +1826,37 @@ SCM_DEFINE (scm_bit_count_star, "bit-count*", 3, 0, 0,
k = SCM_UNPACK (SCM_VELTS (kv)[i]) & (fObj ? SCM_UNPACK(SCM_VELTS (v)[i]) : ~SCM_UNPACK (SCM_VELTS (v)[i]));
}
}
+ else if (scm_is_true (scm_u32vector_p (kv)))
+ {
+ size_t vlen = SCM_BITVECTOR_LENGTH (v);
+ size_t ulen = scm_c_uniform_vector_length (kv);
+ size_t i;
+ scm_t_uint32 k;
+
+ if (scm_to_bool (obj) == 0)
+ for (i = 0; i < ulen; i++)
+ {
+ k = scm_to_uint32 (scm_uniform_vector_ref (kv,
+ scm_from_size_t (i)));
+ if (k >= vlen)
+ scm_out_of_range (FUNC_NAME, scm_from_long (k));
+ if (!SCM_BITVEC_REF(v, k))
+ count++;
+ }
+ else
+ for (i = 0; i < ulen; i++)
+ {
+ k = scm_to_uint32 (scm_uniform_vector_ref (kv,
+ scm_from_size_t (i)));
+ if (k >= vlen)
+ scm_out_of_range (FUNC_NAME, scm_from_long (k));
+ if (SCM_BITVEC_REF (v, k))
+ count++;
+ }
+ }
+ else
+ scm_wrong_type_arg_msg (NULL, 0, kv, "bitvector or u32vector");
+
return scm_from_long (count);
}
#undef FUNC_NAME
@@ -2087,7 +1885,7 @@ SCM
scm_istr2bve (SCM str)
{
size_t len = scm_i_string_length (str);
- SCM v = scm_make_uve (len, SCM_BOOL_T);
+ SCM v = scm_make_u1vector (scm_from_size_t (len), SCM_UNDEFINED);
long *data = (long *) SCM_VELTS (v);
register unsigned long mask;
register long k;
@@ -2182,58 +1980,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_uvect:
- {
- unsigned long *data = (unsigned long *)SCM_VELTS(v);
- for (k = SCM_UVECTOR_LENGTH(v) - 1; k >= 0; k--)
- res = scm_cons(scm_from_ulong (data[k]), res);
- return res;
- }
- case scm_tc7_ivect:
- {
- long *data = (long *)SCM_VELTS(v);
- for (k = SCM_UVECTOR_LENGTH(v) - 1; k >= 0; k--)
- res = scm_cons(scm_from_long (data[k]), res);
- return res;
- }
- case scm_tc7_svect:
- {
- short *data = (short *)SCM_VELTS(v);
- for (k = SCM_UVECTOR_LENGTH(v) - 1; k >= 0; k--)
- res = scm_cons (scm_from_short (data[k]), res);
- return res;
- }
-#if SCM_SIZEOF_LONG_LONG != 0
- case scm_tc7_llvect:
- {
- long long *data = (long long *)SCM_VELTS(v);
- for (k = SCM_UVECTOR_LENGTH(v) - 1; k >= 0; k--)
- res = scm_cons(scm_from_long_long (data[k]), res);
- return res;
- }
-#endif
- case scm_tc7_fvect:
- {
- float *data = (float *) SCM_VELTS (v);
- for (k = SCM_UVECTOR_LENGTH (v) - 1; k >= 0; k--)
- res = scm_cons (scm_from_double (data[k]), res);
- return res;
- }
- case scm_tc7_dvect:
- {
- double *data = (double *) SCM_VELTS (v);
- for (k = SCM_UVECTOR_LENGTH (v) - 1; k >= 0; k--)
- res = scm_cons (scm_from_double (data[k]), res);
- return res;
- }
- case scm_tc7_cvect:
- {
- double (*data)[2] = (double (*)[2]) SCM_VELTS (v);
- for (k = SCM_UVECTOR_LENGTH (v) - 1; k >= 0; k--)
- res = scm_cons (scm_c_make_rectangular (data[k][0], data[k][1]),
- res);
- return res;
- }
}
}
#undef FUNC_NAME
@@ -2432,92 +2178,6 @@ tail:
}
break;
- case scm_tc7_uvect:
- {
- char str[11];
-
- if (n-- > 0)
- {
- /* intprint can't handle >= 2^31. */
- sprintf (str, "%lu", ((unsigned long *) SCM_VELTS (ra))[j]);
- scm_puts (str, port);
- }
- for (j += inc; n-- > 0; j += inc)
- {
- scm_putc (' ', port);
- sprintf (str, "%lu", ((unsigned long *) SCM_VELTS (ra))[j]);
- scm_puts (str, port);
- }
- }
- case scm_tc7_ivect:
- if (n-- > 0)
- scm_intprint (((signed long *) SCM_VELTS (ra))[j], 10, port);
- for (j += inc; n-- > 0; j += inc)
- {
- scm_putc (' ', port);
- 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);
- for (j += inc; n-- > 0; j += inc)
- {
- scm_putc (' ', port);
- scm_intprint (((short *) SCM_CELL_WORD_1 (ra))[j], 10, port);
- }
- break;
-
- case scm_tc7_fvect:
- if (n-- > 0)
- {
- SCM z = scm_from_double (1.0);
- SCM_REAL_VALUE (z) = ((float *) SCM_VELTS (ra))[j];
- scm_print_real (z, port, pstate);
- for (j += inc; n-- > 0; j += inc)
- {
- scm_putc (' ', port);
- SCM_REAL_VALUE (z) = ((float *) SCM_VELTS (ra))[j];
- scm_print_real (z, port, pstate);
- }
- }
- break;
- case scm_tc7_dvect:
- if (n-- > 0)
- {
- SCM z = scm_from_double (1.0 / 3.0);
- SCM_REAL_VALUE (z) = ((double *) SCM_VELTS (ra))[j];
- scm_print_real (z, port, pstate);
- for (j += inc; n-- > 0; j += inc)
- {
- scm_putc (' ', port);
- SCM_REAL_VALUE (z) = ((double *) SCM_VELTS (ra))[j];
- scm_print_real (z, port, pstate);
- }
- }
- break;
- case scm_tc7_cvect:
- if (n-- > 0)
- {
- SCM cz = scm_c_make_rectangular (0.0, 1.0);
- SCM z = scm_from_double (1.0/3.0);
- SCM_REAL_VALUE (z) =
- SCM_COMPLEX_REAL (cz) = ((double *) SCM_VELTS (ra))[2 * j];
- SCM_COMPLEX_IMAG (cz) = ((double *) SCM_VELTS (ra))[2 * j + 1];
- scm_print_complex ((0.0 == SCM_COMPLEX_IMAG (cz) ? z : cz),
- port, pstate);
- for (j += inc; n-- > 0; j += inc)
- {
- scm_putc (' ', port);
- SCM_REAL_VALUE (z)
- = SCM_COMPLEX_REAL (cz) = ((double *) SCM_VELTS (ra))[2 * j];
- SCM_COMPLEX_IMAG (cz) = ((double *) SCM_VELTS (ra))[2 * j + 1];
- scm_print_complex ((0.0 == SCM_COMPLEX_IMAG (cz) ? z : cz),
- port, pstate);
- }
- }
- break;
}
}
@@ -2568,22 +2228,6 @@ scm_i_legacy_tag (SCM v)
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 "";
@@ -2941,29 +2585,6 @@ tail:
case scm_tc7_string:
scm_putc ('a', port);
break;
- case scm_tc7_uvect:
- scm_putc ('u', port);
- break;
- case scm_tc7_ivect:
- scm_putc ('e', port);
- break;
- case scm_tc7_svect:
- scm_putc ('h', port);
- break;
-#if SCM_SIZEOF_LONG_LONG != 0
- case scm_tc7_llvect:
- scm_putc ('l', port);
- break;
-#endif
- case scm_tc7_fvect:
- scm_putc ('s', port);
- break;
- case scm_tc7_dvect:
- scm_putc ('i', port);
- break;
- case scm_tc7_cvect:
- scm_putc ('c', port);
- break;
}
scm_putc ('(', port);
rapr1 (exp, base, 0, port, pstate);
@@ -3042,22 +2663,6 @@ loop:
return SCM_BOOL_T;
case scm_tc7_string:
return SCM_MAKE_CHAR ('a');
- case scm_tc7_uvect:
- return scm_from_int (1);
- case scm_tc7_ivect:
- return scm_from_int (-1);
- case scm_tc7_svect:
- return scm_from_locale_symbol ("s");
-#if SCM_SIZEOF_LONG_LONG != 0
- case scm_tc7_llvect:
- return scm_from_locale_symbol ("l");
-#endif
- case scm_tc7_fvect:
- return scm_from_double (1.0);
- case scm_tc7_dvect:
- return exactly_one_third;
- case scm_tc7_cvect:
- return scm_c_make_rectangular (0.0, 1.0);
}
}
#undef FUNC_NAME