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

revert the ill-considered part of the 2001-05-24 changes

Browse source
This commit is contained in:
Michael Livshin 2001-05-26 20:51:22 +00:00
parent f3f70257a3
commit c014a02eec
63 changed files with 723 additions and 813 deletions
Download patch file Download diff file Expand all files Collapse all files

311
libguile/unif.c
View file

@ -101,8 +101,6 @@ scm_uniform_element_size (SCM obj)
switch (SCM_TYP7 (obj))
{
case scm_tc7_bvect:
result = sizeof (scm_bits_t);
break;
case scm_tc7_uvect:
case scm_tc7_ivect:
result = sizeof (long);
@ -156,32 +154,20 @@ singp (SCM obj)
}
}
#if (SIZEOF_SIZE_T < SCM_SIZEOF_BITS_T)
# define CHECK_BYTE_SIZE(s,k) SCM_ASSERT_RANGE (1, scm_bits2num (k), k <= (size_t)(~(size_t)0))
#else
# define CHECK_BYTE_SIZE(s,k)
#endif
SCM
scm_make_uve (scm_bits_t k, SCM prot)
scm_make_uve (long k, SCM prot)
#define FUNC_NAME "scm_make_uve"
{
SCM v;
size_t i;
scm_bits_t type;
scm_ubits_t size_in_bytes;
long i, type;
if (SCM_EQ_P (prot, SCM_BOOL_T))
{
SCM_NEWCELL (v);
if (k > 0)
{
SCM_ASSERT_RANGE (1, scm_bits2num (k),
k <= SCM_BITVECTOR_MAX_LENGTH);
size_in_bytes = sizeof (scm_bits_t) * ((k + SCM_BITS_LENGTH - 1) /
SCM_BITS_LENGTH);
CHECK_BYTE_SIZE (size_in_bytes, k);
i = (size_t) size_in_bytes;
SCM_ASSERT_RANGE (1, scm_long2num (k), k <= SCM_BITVECTOR_MAX_LENGTH);
i = sizeof (long) * ((k + SCM_LONG_BIT - 1) / SCM_LONG_BIT);
SCM_SET_BITVECTOR_BASE (v, (char *) scm_must_malloc (i, "vector"));
SCM_SET_BITVECTOR_LENGTH (v, k);
}
@ -194,19 +180,17 @@ scm_make_uve (scm_bits_t k, SCM prot)
}
else if (SCM_CHARP (prot) && (SCM_CHAR (prot) == '\0'))
{
size_in_bytes = sizeof (char) * k;
i = sizeof (char) * k;
type = scm_tc7_byvect;
}
else if (SCM_CHARP (prot))
{
size_in_bytes = sizeof (char) * k;
CHECK_BYTE_SIZE (size_in_bytes, k);
i = (size_t) size_in_bytes;
i = sizeof (char) * k;
return scm_allocate_string (i);
}
else if (SCM_INUMP (prot))
{
size_in_bytes = sizeof (long) * k;
i = sizeof (long) * k;
if (SCM_INUM (prot) > 0)
type = scm_tc7_uvect;
else
@ -219,13 +203,13 @@ scm_make_uve (scm_bits_t k, SCM prot)
s = SCM_SYMBOL_CHARS (prot)[0];
if (s == 's')
{
size_in_bytes = sizeof (short) * k;
i = sizeof (short) * k;
type = scm_tc7_svect;
}
#ifdef HAVE_LONG_LONGS
else if (s == 'l')
{
size_in_bytes = sizeof (long long) * k;
i = sizeof (long long) * k;
type = scm_tc7_llvect;
}
#endif
@ -233,7 +217,6 @@ scm_make_uve (scm_bits_t k, SCM prot)
{
return scm_c_make_vector (k, SCM_UNDEFINED);
}
}
else if (!SCM_INEXACTP (prot))
/* Huge non-unif vectors are NOT supported. */
@ -241,24 +224,21 @@ scm_make_uve (scm_bits_t k, SCM prot)
return scm_c_make_vector (k, SCM_UNDEFINED);
else if (singp (prot))
{
size_in_bytes = sizeof (float) * k;
i = sizeof (float) * k;
type = scm_tc7_fvect;
}
else if (SCM_COMPLEXP (prot))
{
size_in_bytes = 2 * sizeof (double) * k;
i = 2 * sizeof (double) * k;
type = scm_tc7_cvect;
}
else
{
size_in_bytes = sizeof (double) * k;
i = sizeof (double) * k;
type = scm_tc7_dvect;
}
CHECK_BYTE_SIZE (size_in_bytes, k);
i = (size_t) size_in_bytes;
SCM_ASSERT_RANGE (1, scm_bits2num (k), k <= SCM_UVECTOR_MAX_LENGTH);
SCM_ASSERT_RANGE (1, scm_long2num (k), k <= SCM_UVECTOR_MAX_LENGTH);
SCM_NEWCELL (v);
SCM_DEFER_INTS;
@ -503,14 +483,14 @@ SCM_DEFINE (scm_shared_array_increments, "shared-array-increments", 1, 0, 0,
static char s_bad_ind[] = "Bad scm_array index";
scm_bits_t
long
scm_aind (SCM ra, SCM args, const char *what)
#define FUNC_NAME what
{
SCM ind;
register scm_bits_t j;
register scm_bits_t pos = SCM_ARRAY_BASE (ra);
register size_t k = SCM_ARRAY_NDIM (ra);
register long j;
register unsigned long pos = SCM_ARRAY_BASE (ra);
register unsigned long k = SCM_ARRAY_NDIM (ra);
scm_array_dim_t *s = SCM_ARRAY_DIMS (ra);
if (SCM_INUMP (args))
{
@ -608,7 +588,7 @@ SCM_DEFINE (scm_dimensions_to_uniform_array, "dimensions->uniform-array", 2, 1,
#define FUNC_NAME s_scm_dimensions_to_uniform_array
{
size_t k;
scm_bits_t rlen = 1;
unsigned long rlen = 1;
scm_array_dim_t *s;
SCM ra;
@ -634,7 +614,6 @@ SCM_DEFINE (scm_dimensions_to_uniform_array, "dimensions->uniform-array", 2, 1,
while (k--)
{
s[k].inc = rlen;
SCM_ASSERT_RANGE (1, dims, s[k].inc >= 0);
SCM_ASSERT_RANGE (1, dims, s[k].lbnd <= s[k].ubnd);
rlen = (s[k].ubnd - s[k].lbnd + 1) * s[k].inc;
}
@ -649,7 +628,7 @@ SCM_DEFINE (scm_dimensions_to_uniform_array, "dimensions->uniform-array", 2, 1,
scm_array_fill_x (ra, prot);
if (1 == SCM_ARRAY_NDIM (ra) && 0 == SCM_ARRAY_BASE (ra))
if (s[0].ubnd < s[0].lbnd || (0 == s[0].lbnd && 1 == s[0].inc))
if (s->ubnd < s->lbnd || (0 == s->lbnd && 1 == s->inc))
return SCM_ARRAY_V (ra);
return ra;
}
@ -662,7 +641,7 @@ scm_ra_set_contp (SCM ra)
size_t k = SCM_ARRAY_NDIM (ra);
if (k)
{
scm_bits_t inc = SCM_ARRAY_DIMS (ra)[k - 1].inc; /*??*/
long inc = SCM_ARRAY_DIMS (ra)[k - 1].inc;
while (k--)
{
if (inc != SCM_ARRAY_DIMS (ra)[k].inc)
@ -700,9 +679,8 @@ SCM_DEFINE (scm_make_shared_array, "make-shared-array", 2, 0, 1,
SCM ra;
SCM inds, indptr;
SCM imap;
size_t k;
scm_bits_t i;
scm_bits_t old_min, new_min, old_max, new_max;
size_t k, i;
long old_min, new_min, old_max, new_max;
scm_array_dim_t *s;
SCM_VALIDATE_REST_ARGUMENT (dims);
@ -745,7 +723,7 @@ SCM_DEFINE (scm_make_shared_array, "make-shared-array", 2, 0, 1,
}
imap = scm_apply (mapfunc, scm_reverse (inds), SCM_EOL);
if (SCM_ARRAYP (oldra))
i = scm_aind (oldra, imap, FUNC_NAME);
i = (size_t) scm_aind (oldra, imap, FUNC_NAME);
else
{
if (SCM_NINUMP (imap))
@ -794,7 +772,7 @@ SCM_DEFINE (scm_make_shared_array, "make-shared-array", 2, 0, 1,
if (1 == SCM_ARRAY_NDIM (ra) && 0 == SCM_ARRAY_BASE (ra))
{
SCM v = SCM_ARRAY_V (ra);
scm_bits_t length = SCM_INUM (scm_uniform_vector_length (v));
unsigned long int length = SCM_INUM (scm_uniform_vector_length (v));
if (1 == s->inc && 0 == s->lbnd && length == 1 + s->ubnd)
return v;
if (s->ubnd < s->lbnd)
@ -1024,9 +1002,9 @@ SCM_DEFINE (scm_array_in_bounds_p, "array-in-bounds?", 1, 0, 1,
#define FUNC_NAME s_scm_array_in_bounds_p
{
SCM ind = SCM_EOL;
scm_bits_t pos = 0;
long pos = 0;
register size_t k;
register scm_bits_t j;
register long j;
scm_array_dim_t *s;
SCM_VALIDATE_REST_ARGUMENT (args);
@ -1090,7 +1068,7 @@ tail:
case scm_tc7_vector:
case scm_tc7_wvect:
{
scm_bits_t length = SCM_INUM (scm_uniform_vector_length (v));
unsigned long int length = SCM_INUM (scm_uniform_vector_length (v));
SCM_ASRTGO (SCM_NULLP (args) && SCM_INUMP (ind), wna);
return SCM_BOOL(pos >= 0 && pos < length);
}
@ -1109,7 +1087,7 @@ SCM_DEFINE (scm_uniform_vector_ref, "uniform-vector-ref", 2, 0, 0,
"@var{array}.")
#define FUNC_NAME s_scm_uniform_vector_ref
{
scm_bits_t pos;
long pos;
if (SCM_IMP (v))
{
@ -1123,7 +1101,7 @@ SCM_DEFINE (scm_uniform_vector_ref, "uniform-vector-ref", 2, 0, 0,
}
else
{
scm_bits_t length;
unsigned long int length;
if (SCM_NIMP (args))
{
SCM_ASSERT (SCM_CONSP (args) && SCM_INUMP (SCM_CAR (args)), args, SCM_ARG2, FUNC_NAME);
@ -1204,7 +1182,7 @@ SCM_DEFINE (scm_uniform_vector_ref, "uniform-vector-ref", 2, 0, 0,
tries to recycle conses. (Make *sure* you want them recycled.) */
SCM
scm_cvref (SCM v, scm_bits_t pos, SCM last)
scm_cvref (SCM v, unsigned long pos, SCM last)
#define FUNC_NAME "scm_cvref"
{
switch SCM_TYP7 (v)
@ -1287,7 +1265,7 @@ SCM_DEFINE (scm_array_set_x, "array-set!", 2, 0, 1,
"@var{new-value}. The value returned by array-set! is unspecified.")
#define FUNC_NAME s_scm_array_set_x
{
scm_bits_t pos = 0;
long pos = 0;
SCM_VALIDATE_REST_ARGUMENT (args);
SCM_ASRTGO (SCM_NIMP (v), badarg1);
@ -1298,7 +1276,7 @@ SCM_DEFINE (scm_array_set_x, "array-set!", 2, 0, 1,
}
else
{
scm_bits_t length;
unsigned long int length;
if (SCM_NIMP (args))
{
SCM_ASSERT (SCM_CONSP(args) && SCM_INUMP (SCM_CAR (args)), args,
@ -1426,8 +1404,7 @@ SCM_DEFINE (scm_array_contents, "array-contents", 1, 1, 0,
return ra;
case scm_tc7_smob:
{
size_t k, ndim = SCM_ARRAY_NDIM (ra);
scm_bits_t len = 1;
size_t k, ndim = SCM_ARRAY_NDIM (ra), len = 1;
if (!SCM_ARRAYP (ra) || !SCM_ARRAY_CONTP (ra))
return SCM_BOOL_F;
for (k = 0; k < ndim; k++)
@ -1439,15 +1416,15 @@ SCM_DEFINE (scm_array_contents, "array-contents", 1, 1, 0,
if (scm_tc7_bvect == SCM_TYP7 (SCM_ARRAY_V (ra)))
{
if (len != SCM_BITVECTOR_LENGTH (SCM_ARRAY_V (ra)) ||
SCM_ARRAY_BASE (ra) % SCM_BITS_LENGTH ||
len % SCM_BITS_LENGTH)
SCM_ARRAY_BASE (ra) % SCM_LONG_BIT ||
len % SCM_LONG_BIT)
return SCM_BOOL_F;
}
}
{
SCM v = SCM_ARRAY_V (ra);
scm_bits_t length = SCM_INUM (scm_uniform_vector_length (v));
unsigned long int length = SCM_INUM (scm_uniform_vector_length (v));
if ((len == length) && 0 == SCM_ARRAY_BASE (ra) && SCM_ARRAY_DIMS (ra)->inc)
return v;
}
@ -1469,9 +1446,8 @@ SCM
scm_ra2contig (SCM ra, int copy)
{
SCM ret;
scm_bits_t inc = 1;
size_t k;
scm_bits_t len = 1;
long inc = 1;
size_t k, len = 1;
for (k = SCM_ARRAY_NDIM (ra); k--;)
len *= SCM_ARRAY_DIMS (ra)[k].ubnd - SCM_ARRAY_DIMS (ra)[k].lbnd + 1;
k = SCM_ARRAY_NDIM (ra);
@ -1480,8 +1456,8 @@ scm_ra2contig (SCM ra, int copy)
if (scm_tc7_bvect != SCM_TYP7 (SCM_ARRAY_V (ra)))
return ra;
if ((len == SCM_BITVECTOR_LENGTH (SCM_ARRAY_V (ra)) &&
0 == SCM_ARRAY_BASE (ra) % SCM_BITS_LENGTH &&
0 == len % SCM_BITS_LENGTH))
0 == SCM_ARRAY_BASE (ra) % SCM_LONG_BIT &&
0 == len % SCM_LONG_BIT))
return ra;
}
ret = scm_make_ra (k);
@ -1519,10 +1495,10 @@ SCM_DEFINE (scm_uniform_array_read_x, "uniform-array-read!", 1, 3, 0,
#define FUNC_NAME s_scm_uniform_array_read_x
{
SCM cra = SCM_UNDEFINED, v = ra;
int sz;
scm_bits_t vlen, ans;
scm_bits_t cstart = 0, cend = 0;
scm_bits_t offset = 0;
long sz, vlen, ans;
long cstart = 0;
long cend;
long offset = 0;
char *base;
SCM_ASRTGO (SCM_NIMP (v), badarg1);
@ -1553,9 +1529,9 @@ loop:
break;
case scm_tc7_bvect:
base = (char *) SCM_BITVECTOR_BASE (v);
vlen = (vlen + SCM_BITS_LENGTH - 1) / SCM_BITS_LENGTH;
cstart /= SCM_BITS_LENGTH;
sz = sizeof (scm_bits_t);
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);
@ -1594,15 +1570,15 @@ loop:
if (!SCM_UNBNDP (start))
{
offset =
SCM_NUM2BITS (3, start);
SCM_NUM2LONG (3, start);
if (offset < 0 || offset >= cend)
scm_out_of_range (FUNC_NAME, start);
if (!SCM_UNBNDP (end))
{
scm_bits_t tend =
SCM_NUM2BITS (4, end);
long tend =
SCM_NUM2LONG (4, end);
if (tend <= offset || tend > cend)
scm_out_of_range (FUNC_NAME, end);
@ -1658,7 +1634,7 @@ loop:
SCM_SYSERROR;
}
if (SCM_TYP7 (v) == scm_tc7_bvect)
ans *= SCM_BITS_LENGTH;
ans *= SCM_LONG_BIT;
if (!SCM_EQ_P (v, ra) && !SCM_EQ_P (cra, ra))
scm_array_copy_x (cra, ra);
@ -1681,9 +1657,10 @@ SCM_DEFINE (scm_uniform_array_write, "uniform-array-write", 1, 3, 0,
"@code{(current-output-port)}.")
#define FUNC_NAME s_scm_uniform_array_write
{
int sz;
scm_bits_t vlen, ans;
scm_bits_t offset = 0, cstart = 0, cend;
long sz, vlen, ans;
long offset = 0;
long cstart = 0;
long cend;
char *base;
port_or_fd = SCM_COERCE_OUTPORT (port_or_fd);
@ -1716,9 +1693,9 @@ loop:
break;
case scm_tc7_bvect:
base = (char *) SCM_BITVECTOR_BASE (v);
vlen = (vlen + SCM_BITS_LENGTH - 1) / SCM_BITS_LENGTH;
cstart /= SCM_BITS_LENGTH;
sz = sizeof (scm_bits_t);
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);
@ -1757,15 +1734,15 @@ loop:
if (!SCM_UNBNDP (start))
{
offset =
SCM_NUM2BITS (3, start);
SCM_NUM2LONG (3, start);
if (offset < 0 || offset >= cend)
scm_out_of_range (FUNC_NAME, start);
if (!SCM_UNBNDP (end))
{
scm_bits_t tend =
SCM_NUM2BITS (4, end);
long tend =
SCM_NUM2LONG (4, end);
if (tend <= offset || tend > cend)
scm_out_of_range (FUNC_NAME, end);
@ -1789,7 +1766,7 @@ loop:
SCM_SYSERROR;
}
if (SCM_TYP7 (v) == scm_tc7_bvect)
ans *= SCM_BITS_LENGTH;
ans *= SCM_LONG_BIT;
return SCM_MAKINUM (ans);
}
@ -1810,13 +1787,13 @@ SCM_DEFINE (scm_bit_count, "bit-count", 2, 0, 0,
if (SCM_BITVECTOR_LENGTH (bitvector) == 0) {
return SCM_INUM0;
} else {
scm_bits_t count = 0;
size_t i = (SCM_BITVECTOR_LENGTH (bitvector) - 1) / SCM_BITS_LENGTH;
scm_ubits_t w = SCM_UNPACK (SCM_VELTS (bitvector)[i]);
unsigned long int count = 0;
unsigned long int i = (SCM_BITVECTOR_LENGTH (bitvector) - 1) / SCM_LONG_BIT;
unsigned long int w = SCM_UNPACK (SCM_VELTS (bitvector)[i]);
if (SCM_FALSEP (b)) {
w = ~w;
};
w <<= SCM_BITS_LENGTH - 1 - ((SCM_BITVECTOR_LENGTH (bitvector) - 1) % SCM_BITS_LENGTH);
w <<= SCM_LONG_BIT - 1 - ((SCM_BITVECTOR_LENGTH (bitvector) - 1) % SCM_LONG_BIT);
while (1) {
while (w) {
count += cnt_tab[w & 0x0f];
@ -1844,11 +1821,8 @@ SCM_DEFINE (scm_bit_position, "bit-position", 3, 0, 0,
"within the specified range @code{#f} is returned.")
#define FUNC_NAME s_scm_bit_position
{
size_t i;
scm_bits_t pos;
size_t lenw;
int xbits;
register scm_ubits_t w;
long i, lenw, xbits, pos;
register unsigned long w;
SCM_VALIDATE_BOOL (1, item);
SCM_ASSERT (SCM_BITVECTOR_P (v), v, SCM_ARG2, FUNC_NAME);
@ -1858,15 +1832,15 @@ SCM_DEFINE (scm_bit_position, "bit-position", 3, 0, 0,
if (pos == SCM_BITVECTOR_LENGTH (v))
return SCM_BOOL_F;
lenw = (SCM_BITVECTOR_LENGTH (v) - 1) / SCM_BITS_LENGTH; /* watch for part words */
i = pos / SCM_BITS_LENGTH;
lenw = (SCM_BITVECTOR_LENGTH (v) - 1) / SCM_LONG_BIT; /* watch for part words */
i = pos / SCM_LONG_BIT;
w = SCM_UNPACK (SCM_VELTS (v)[i]);
if (SCM_FALSEP (item))
w = ~w;
xbits = (pos % SCM_BITS_LENGTH);
xbits = (pos % SCM_LONG_BIT);
pos -= xbits;
w = ((w >> xbits) << xbits);
xbits = SCM_BITS_LENGTH - 1 - (SCM_BITVECTOR_LENGTH (v) - 1) % SCM_BITS_LENGTH;
xbits = SCM_LONG_BIT - 1 - (SCM_BITVECTOR_LENGTH (v) - 1) % SCM_LONG_BIT;
while (!0)
{
if (w && (i == lenw))
@ -1893,7 +1867,7 @@ SCM_DEFINE (scm_bit_position, "bit-position", 3, 0, 0,
}
if (++i > lenw)
break;
pos += SCM_BITS_LENGTH;
pos += SCM_LONG_BIT;
w = SCM_UNPACK (SCM_VELTS (v)[i]);
if (SCM_FALSEP (item))
w = ~w;
@ -1915,8 +1889,7 @@ SCM_DEFINE (scm_bit_set_star_x, "bit-set*!", 3, 0, 0,
"@var{bool}. The return value is unspecified.")
#define FUNC_NAME s_scm_bit_set_star_x
{
register size_t i;
scm_bits_t vlen;
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)
@ -1924,13 +1897,11 @@ SCM_DEFINE (scm_bit_set_star_x, "bit-set*!", 3, 0, 0,
default:
badarg2:SCM_WRONG_TYPE_ARG (2, kv);
case scm_tc7_uvect:
{
unsigned long k;
vlen = SCM_BITVECTOR_LENGTH (v);
if (SCM_FALSEP (obj))
for (i = SCM_UVECTOR_LENGTH (kv); i;)
{
k = ((unsigned long *) SCM_VELTS (kv))[--i];
k = SCM_UNPACK (SCM_VELTS (kv)[--i]);
if (k >= vlen)
scm_out_of_range (FUNC_NAME, SCM_MAKINUM (k));
SCM_BITVEC_CLR(v,k);
@ -1938,7 +1909,7 @@ SCM_DEFINE (scm_bit_set_star_x, "bit-set*!", 3, 0, 0,
else if (SCM_EQ_P (obj, SCM_BOOL_T))
for (i = SCM_UVECTOR_LENGTH (kv); i;)
{
k = ((unsigned long *) SCM_VELTS (kv))[--i];
k = SCM_UNPACK (SCM_VELTS (kv)[--i]);
if (k >= vlen)
scm_out_of_range (FUNC_NAME, SCM_MAKINUM (k));
SCM_BITVEC_SET(v,k);
@ -1946,22 +1917,18 @@ SCM_DEFINE (scm_bit_set_star_x, "bit-set*!", 3, 0, 0,
else
badarg3:SCM_WRONG_TYPE_ARG (3, obj);
break;
}
case scm_tc7_bvect:
{
scm_ubits_t k;
SCM_ASSERT (SCM_BITVECTOR_LENGTH (v) == SCM_BITVECTOR_LENGTH (kv), v, SCM_ARG1, FUNC_NAME);
if (SCM_FALSEP (obj))
for (k = (SCM_BITVECTOR_LENGTH (v) + SCM_BITS_LENGTH - 1) / SCM_BITS_LENGTH; k--;)
((scm_ubits_t *) SCM_VELTS (v))[k] &= ~ ((scm_ubits_t *) SCM_VELTS (kv))[k];
for (k = (SCM_BITVECTOR_LENGTH (v) + SCM_LONG_BIT - 1) / SCM_LONG_BIT; k--;)
SCM_UNPACK (SCM_VELTS (v)[k]) &= ~ SCM_UNPACK(SCM_VELTS (kv)[k]);
else if (SCM_EQ_P (obj, SCM_BOOL_T))
for (k = (SCM_BITVECTOR_LENGTH (v) + SCM_BITS_LENGTH - 1) / SCM_BITS_LENGTH; k--;)
((scm_ubits_t *) SCM_VELTS (v))[k] |= ((scm_ubits_t *) SCM_VELTS (kv))[k];
for (k = (SCM_BITVECTOR_LENGTH (v) + SCM_LONG_BIT - 1) / SCM_LONG_BIT; k--;)
SCM_UNPACK (SCM_VELTS (v)[k]) |= SCM_UNPACK (SCM_VELTS (kv)[k]);
else
goto badarg3;
break;
}
}
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
@ -1976,8 +1943,8 @@ SCM_DEFINE (scm_bit_count_star, "bit-count*", 3, 0, 0,
"@var{bv} is not modified.")
#define FUNC_NAME s_scm_bit_count_star
{
register size_t i;
scm_bits_t vlen, count = 0;
register long i, vlen, count = 0;
register unsigned long k;
int fObj = 0;
SCM_ASSERT (SCM_BITVECTOR_P (v), v, SCM_ARG1, FUNC_NAME);
@ -1988,13 +1955,11 @@ SCM_DEFINE (scm_bit_count_star, "bit-count*", 3, 0, 0,
badarg2:
SCM_WRONG_TYPE_ARG (2, kv);
case scm_tc7_uvect:
{
unsigned long k;
vlen = SCM_BITVECTOR_LENGTH (v);
if (SCM_FALSEP (obj))
for (i = SCM_UVECTOR_LENGTH (kv); i;)
{
k = ((unsigned long *) SCM_VELTS (kv))[--i];
k = SCM_UNPACK (SCM_VELTS (kv)[--i]);
if (k >= vlen)
scm_out_of_range (FUNC_NAME, SCM_MAKINUM (k));
if (!SCM_BITVEC_REF(v,k))
@ -2003,7 +1968,7 @@ SCM_DEFINE (scm_bit_count_star, "bit-count*", 3, 0, 0,
else if (SCM_EQ_P (obj, SCM_BOOL_T))
for (i = SCM_UVECTOR_LENGTH (kv); i;)
{
k = ((unsigned long *) SCM_VELTS (kv))[--i];
k = SCM_UNPACK (SCM_VELTS (kv)[--i]);
if (k >= vlen)
scm_out_of_range (FUNC_NAME, SCM_MAKINUM (k));
if (SCM_BITVEC_REF (v,k))
@ -2012,20 +1977,15 @@ SCM_DEFINE (scm_bit_count_star, "bit-count*", 3, 0, 0,
else
badarg3:SCM_WRONG_TYPE_ARG (3, obj);
break;
}
case scm_tc7_bvect:
{
scm_ubits_t k;
SCM_ASSERT (SCM_BITVECTOR_LENGTH (v) == SCM_BITVECTOR_LENGTH (kv), v, SCM_ARG1, FUNC_NAME);
if (0 == SCM_BITVECTOR_LENGTH (v))
return SCM_INUM0;
SCM_ASRTGO (SCM_BOOLP (obj), badarg3);
fObj = SCM_EQ_P (obj, SCM_BOOL_T);
i = (SCM_BITVECTOR_LENGTH (v) - 1) / SCM_BITS_LENGTH;
k =
((scm_ubits_t *) SCM_VELTS (kv))[i]
& (fObj ? ((scm_ubits_t *) SCM_VELTS (v))[i] : ~ ((scm_ubits_t *) SCM_VELTS (v))[i]);
k <<= SCM_BITS_LENGTH - 1 - ((SCM_BITVECTOR_LENGTH (v) - 1) % SCM_BITS_LENGTH);
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);
while (1)
{
for (; k; k >>= 4)
@ -2034,10 +1994,7 @@ SCM_DEFINE (scm_bit_count_star, "bit-count*", 3, 0, 0,
return SCM_MAKINUM (count);
/* urg. repetitive (see above.) */
k =
((scm_ubits_t *) SCM_VELTS (kv))[i]
& (fObj ? ((scm_ubits_t *) SCM_VELTS (v))[i] : ~ ((scm_ubits_t *) SCM_VELTS (v))[i]);
}
k = SCM_UNPACK (SCM_VELTS (kv)[i]) & (fObj ? SCM_UNPACK(SCM_VELTS (v)[i]) : ~SCM_UNPACK (SCM_VELTS (v)[i]));
}
}
return SCM_MAKINUM (count);
@ -2050,13 +2007,13 @@ SCM_DEFINE (scm_bit_invert_x, "bit-invert!", 1, 0, 0,
"Modifies @var{bv} by replacing each element with its negation.")
#define FUNC_NAME s_scm_bit_invert_x
{
scm_bits_t k;
long int k;
SCM_ASSERT (SCM_BITVECTOR_P (v), v, SCM_ARG1, FUNC_NAME);
k = SCM_BITVECTOR_LENGTH (v);
for (k = (k + SCM_BITS_LENGTH - 1) / SCM_BITS_LENGTH; k--;)
((scm_ubits_t *) SCM_VELTS (v))[k] = ~((scm_ubits_t *) SCM_VELTS (v))[k];
for (k = (k + SCM_LONG_BIT - 1) / SCM_LONG_BIT; k--;)
SCM_UNPACK (SCM_VELTS (v)[k]) = ~SCM_UNPACK (SCM_VELTS (v)[k]);
return SCM_UNSPECIFIED;
}
@ -2064,19 +2021,19 @@ SCM_DEFINE (scm_bit_invert_x, "bit-invert!", 1, 0, 0,
SCM
scm_istr2bve (char *str, scm_bits_t len)
scm_istr2bve (char *str, long len)
{
SCM v = scm_make_uve (len, SCM_BOOL_T);
scm_ubits_t *data = (scm_ubits_t *) SCM_VELTS (v);
register scm_bits_t mask;
register size_t k;
register int j;
for (k = 0; k < (len + SCM_BITS_LENGTH - 1) / SCM_BITS_LENGTH; k++)
long *data = (long *) SCM_VELTS (v);
register unsigned long mask;
register long k;
register long j;
for (k = 0; k < (len + SCM_LONG_BIT - 1) / SCM_LONG_BIT; k++)
{
data[k] = 0L;
j = len - k * SCM_BITS_LENGTH;
if (j > SCM_BITS_LENGTH)
j = SCM_BITS_LENGTH;
j = len - k * SCM_LONG_BIT;
if (j > SCM_LONG_BIT)
j = SCM_LONG_BIT;
for (mask = 1L; j--; mask <<= 1)
switch (*str++)
{
@ -2095,11 +2052,11 @@ scm_istr2bve (char *str, scm_bits_t len)
static SCM
ra2l (SCM ra, scm_bits_t base, size_t k)
ra2l (SCM ra,unsigned long base,unsigned long k)
{
register SCM res = SCM_EOL;
register scm_bits_t inc = SCM_ARRAY_DIMS (ra)[k].inc;
register scm_bits_t i;
register long inc = SCM_ARRAY_DIMS (ra)[k].inc;
register size_t i;
if (SCM_ARRAY_DIMS (ra)[k].ubnd < SCM_ARRAY_DIMS (ra)[k].lbnd)
return SCM_EOL;
i = base + (1 + SCM_ARRAY_DIMS (ra)[k].ubnd - SCM_ARRAY_DIMS (ra)[k].lbnd) * inc;
@ -2130,7 +2087,7 @@ SCM_DEFINE (scm_array_to_list, "array->list", 1, 0, 0,
#define FUNC_NAME s_scm_array_to_list
{
SCM res = SCM_EOL;
register size_t k;
register long k;
SCM_ASRTGO (SCM_NIMP (v), badarg1);
switch SCM_TYP7 (v)
{
@ -2146,35 +2103,35 @@ SCM_DEFINE (scm_array_to_list, "array->list", 1, 0, 0,
return scm_string_to_list (v);
case scm_tc7_bvect:
{
scm_ubits_t *data = (scm_ubits_t *) SCM_VELTS (v);
register scm_ubits_t mask;
for (k = (SCM_BITVECTOR_LENGTH (v) - 1) / SCM_BITS_LENGTH; k > 0; k--)
for (mask = 1UL << (SCM_BITS_LENGTH - 1); mask; mask >>= 1)
res = scm_cons (SCM_BOOL(data[k] & mask), res);
for (mask = 1L << ((SCM_BITVECTOR_LENGTH (v) % SCM_BITS_LENGTH) - 1); mask; mask >>= 1)
res = scm_cons (SCM_BOOL(data[k] & mask), res);
long *data = (long *) SCM_VELTS (v);
register unsigned long mask;
for (k = (SCM_BITVECTOR_LENGTH (v) - 1) / SCM_LONG_BIT; k > 0; k--)
for (mask = 1UL << (SCM_LONG_BIT - 1); mask; mask >>= 1)
res = scm_cons (SCM_BOOL(((long *) data)[k] & mask), res);
for (mask = 1L << ((SCM_BITVECTOR_LENGTH (v) % SCM_LONG_BIT) - 1); mask; mask >>= 1)
res = scm_cons (SCM_BOOL(((long *) data)[k] & mask), res);
return res;
}
case scm_tc7_byvect:
{
signed char *data = (signed char *) SCM_VELTS (v);
scm_bits_t k = SCM_UVECTOR_LENGTH (v);
unsigned long k = SCM_UVECTOR_LENGTH (v);
while (k != 0)
res = scm_cons (SCM_MAKINUM (data[--k]), res);
return res;
}
case scm_tc7_uvect:
{
scm_ubits_t *data = (scm_ubits_t *) SCM_VELTS(v);
long *data = (long *)SCM_VELTS(v);
for (k = SCM_UVECTOR_LENGTH(v) - 1; k >= 0; k--)
res = scm_cons(scm_ubits2num(data[k]), res);
res = scm_cons(scm_ulong2num(data[k]), res);
return res;
}
case scm_tc7_ivect:
{
scm_bits_t *data = (scm_bits_t *) SCM_VELTS(v);
long *data = (long *)SCM_VELTS(v);
for (k = SCM_UVECTOR_LENGTH(v) - 1; k >= 0; k--)
res = scm_cons(scm_bits2num(data[k]), res);
res = scm_cons(scm_long2num(data[k]), res);
return res;
}
case scm_tc7_svect:
@ -2219,7 +2176,7 @@ SCM_DEFINE (scm_array_to_list, "array->list", 1, 0, 0,
#undef FUNC_NAME
static int l2ra (SCM lst, SCM ra, scm_bits_t base, size_t k);
static int l2ra(SCM lst, SCM ra, unsigned long base, unsigned long k);
SCM_DEFINE (scm_list_to_uniform_array, "list->uniform-array", 3, 0, 0,
(SCM ndim, SCM prot, SCM lst),
@ -2233,7 +2190,7 @@ SCM_DEFINE (scm_list_to_uniform_array, "list->uniform-array", 3, 0, 0,
SCM shp = SCM_EOL;
SCM row = lst;
SCM ra;
scm_bits_t k;
unsigned long k;
long n;
SCM_VALIDATE_INUM_COPY (1,ndim,k);
while (k--)
@ -2254,7 +2211,7 @@ SCM_DEFINE (scm_list_to_uniform_array, "list->uniform-array", 3, 0, 0,
}
if (!SCM_ARRAYP (ra))
{
scm_bits_t length = SCM_INUM (scm_uniform_vector_length (ra));
unsigned long int length = SCM_INUM (scm_uniform_vector_length (ra));
for (k = 0; k < length; k++, lst = SCM_CDR (lst))
scm_array_set_x (ra, SCM_CAR (lst), SCM_MAKINUM (k));
return ra;
@ -2267,10 +2224,10 @@ SCM_DEFINE (scm_list_to_uniform_array, "list->uniform-array", 3, 0, 0,
#undef FUNC_NAME
static int
l2ra (SCM lst, SCM ra, scm_bits_t base, size_t k)
l2ra (SCM lst, SCM ra, unsigned long base, unsigned long k)
{
register scm_bits_t inc = SCM_ARRAY_DIMS (ra)[k].inc;
register scm_bits_t n = (1 + SCM_ARRAY_DIMS (ra)[k].ubnd - SCM_ARRAY_DIMS (ra)[k].lbnd);
register long inc = SCM_ARRAY_DIMS (ra)[k].inc;
register long n = (1 + SCM_ARRAY_DIMS (ra)[k].ubnd - SCM_ARRAY_DIMS (ra)[k].lbnd);
int ok = 1;
if (n <= 0)
return (SCM_NULLP (lst));
@ -2305,10 +2262,10 @@ l2ra (SCM lst, SCM ra, scm_bits_t base, size_t k)
static void
rapr1 (SCM ra, scm_bits_t j, size_t k, SCM port, scm_print_state *pstate)
rapr1 (SCM ra,unsigned long j,unsigned long k,SCM port,scm_print_state *pstate)
{
scm_bits_t inc = 1;
scm_bits_t n = (SCM_TYP7 (ra) == scm_tc7_smob
long inc = 1;
long n = (SCM_TYP7 (ra) == scm_tc7_smob
? 0
: SCM_INUM (scm_uniform_vector_length (ra)));
int enclosed = 0;
@ -2331,7 +2288,7 @@ tail:
}
if (k + 1 < SCM_ARRAY_NDIM (ra))
{
scm_bits_t i;
long i;
inc = SCM_ARRAY_DIMS (ra)[k].inc;
for (i = SCM_ARRAY_DIMS (ra)[k].lbnd; i < SCM_ARRAY_DIMS (ra)[k].ubnd; i++)
{
@ -2484,7 +2441,7 @@ int
scm_raprin1 (SCM exp, SCM port, scm_print_state *pstate)
{
SCM v = exp;
scm_bits_t base = 0;
unsigned long base = 0;
scm_putc ('#', port);
tail:
switch SCM_TYP7 (v)
@ -2511,23 +2468,21 @@ tail:
case scm_tc7_bvect:
if (SCM_EQ_P (exp, v))
{ /* a uve, not an scm_array */
register size_t i;
register int j;
scm_ubits_t w;
register long i, j, w;
scm_putc ('*', port);
for (i = 0; i < (SCM_BITVECTOR_LENGTH (exp) / SCM_BITS_LENGTH); i++)
for (i = 0; i < (SCM_BITVECTOR_LENGTH (exp)) / SCM_LONG_BIT; i++)
{
w = SCM_UNPACK (SCM_VELTS (exp)[i]);
for (j = SCM_BITS_LENGTH; j; j--)
scm_bits_t w = SCM_UNPACK (SCM_VELTS (exp)[i]);
for (j = SCM_LONG_BIT; j; j--)
{
scm_putc (w & 1 ? '1' : '0', port);
w >>= 1;
}
}
j = SCM_BITVECTOR_LENGTH (exp) % SCM_BITS_LENGTH;
j = SCM_BITVECTOR_LENGTH (exp) % SCM_LONG_BIT;
if (j)
{
w = SCM_UNPACK (SCM_VELTS (exp)[SCM_BITVECTOR_LENGTH (exp) / SCM_BITS_LENGTH]);
w = SCM_UNPACK (SCM_VELTS (exp)[SCM_BITVECTOR_LENGTH (exp) / SCM_LONG_BIT]);
for (; j; j--)
{
scm_putc (w & 1 ? '1' : '0', port);