mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-18 01:30:27 +02:00
Code Activity

* Replaced some calls to SCM_LENGTH.

Browse source 
* Use scm_uniform_vector_length to determine lengths generically.
* Eliminate some dummy type dispatch code.
* Fix an array access but in scm_ra2contig.
This commit is contained in:
Dirk Herrmann 2000-10-11 12:24:43 +00:00
parent b5c2579a34
commit 74014c46ff
2 changed files with 216 additions and 192 deletions
Download patch file Download diff file Expand all files Collapse all files

21
libguile/ChangeLog
View file

@ -1,3 +1,24 @@
2000-10-11 Dirk Herrmann <D.Herrmann@tu-bs.de>
* unif.c (scm_make_uve, scm_uniform_vector_length, scm_array_p,
scm_transpose_array, scm_array_contents, scm_ra2contig,
scm_uniform_array_read_x, scm_uniform_array_write, scm_bit_count,
scm_bit_position, scm_bit_set_star_x, scm_bit_count_star,
scm_bit_invert_x, scm_array_to_list, scm_raprin1): Replace
SCM_LENGTH with the appropriate SCM_<type>_LENGTH macro.
(scm_array_dimensions, scm_make_shared_array, scm_enclose_array,
scm_array_in_bounds_p, scm_uniform_vector_ref, scm_array_set_x,
scm_array_contents, scm_uniform_array_read_x,
scm_uniform_array_write, scm_list_to_uniform_array, rapr1): Use
scm_uniform_vector_length to determine the length of a vector
object generically.
(scm_bit_count, scm_bit_set_star_x, scm_bit_count_star,
scm_bit_invert_x): Eliminated dummy type dispatch.
(scm_ra2contig): Fixed array vector access.
2000-10-10 Dirk Herrmann <D.Herrmann@tu-bs.de> 2000-10-10 Dirk Herrmann <D.Herrmann@tu-bs.de>
* unif.h (SCM_BITVECTOR_P, SCM_BITVECTOR_BASE): Added. * unif.h (SCM_BITVECTOR_P, SCM_BITVECTOR_BASE): Added.

247
libguile/unif.c
View file

@ -179,7 +179,7 @@ scm_make_uve (long k, SCM prot)
else else
type = scm_tc7_ivect; type = scm_tc7_ivect;
} }
else if (SCM_SYMBOLP (prot) && (1 == SCM_LENGTH (prot))) else if (SCM_SYMBOLP (prot) && (1 == SCM_SYMBOL_LENGTH (prot)))
{ {
char s; char s;
@ -236,26 +236,28 @@ SCM_DEFINE (scm_uniform_vector_length, "uniform-vector-length", 1, 0, 0,
#define FUNC_NAME s_scm_uniform_vector_length #define FUNC_NAME s_scm_uniform_vector_length
{ {
SCM_ASRTGO (SCM_NIMP (v), badarg1); SCM_ASRTGO (SCM_NIMP (v), badarg1);
switch SCM_TYP7 switch SCM_TYP7 (v)
(v)
{ {
default: default:
badarg1:SCM_WTA(1,v); badarg1:SCM_WTA(1,v);
case scm_tc7_bvect: case scm_tc7_vector:
case scm_tc7_wvect:
return SCM_MAKINUM (SCM_VECTOR_LENGTH (v));
case scm_tc7_string: case scm_tc7_string:
return SCM_MAKINUM (SCM_STRING_LENGTH (v));
case scm_tc7_bvect:
return SCM_MAKINUM (SCM_BITVECTOR_LENGTH (v));
case scm_tc7_byvect: case scm_tc7_byvect:
case scm_tc7_uvect: case scm_tc7_uvect:
case scm_tc7_ivect: case scm_tc7_ivect:
case scm_tc7_fvect: case scm_tc7_fvect:
case scm_tc7_dvect: case scm_tc7_dvect:
case scm_tc7_cvect: case scm_tc7_cvect:
case scm_tc7_vector:
case scm_tc7_wvect:
case scm_tc7_svect: case scm_tc7_svect:
#ifdef HAVE_LONG_LONGS #ifdef HAVE_LONG_LONGS
case scm_tc7_llvect: case scm_tc7_llvect:
#endif #endif
return SCM_MAKINUM (SCM_LENGTH (v)); return SCM_MAKINUM (SCM_UVECTOR_LENGTH (v));
} }
} }
#undef FUNC_NAME #undef FUNC_NAME
@ -305,12 +307,12 @@ SCM_DEFINE (scm_array_p, "array?", 1, 1, 0,
case scm_tc7_svect: case scm_tc7_svect:
protp = SCM_SYMBOLP (prot) protp = SCM_SYMBOLP (prot)
&& (1 == SCM_LENGTH (prot)) && (1 == SCM_SYMBOL_LENGTH (prot))
&& ('s' == SCM_SYMBOL_CHARS (prot)[0]); && ('s' == SCM_SYMBOL_CHARS (prot)[0]);
#ifdef HAVE_LONG_LONGS #ifdef HAVE_LONG_LONGS
case scm_tc7_llvect: case scm_tc7_llvect:
protp = SCM_SYMBOLP (prot) protp = SCM_SYMBOLP (prot)
&& (1 == SCM_LENGTH (prot)) && (1 == SCM_SYMBOL_LENGTH (prot))
&& ('s' == SCM_SYMBOL_CHARS (prot)[0]); && ('s' == SCM_SYMBOL_CHARS (prot)[0]);
#endif #endif
case scm_tc7_fvect: case scm_tc7_fvect:
@ -399,7 +401,7 @@ SCM_DEFINE (scm_array_dimensions, "array-dimensions", 1, 0, 0,
#ifdef HAVE_LONG_LONGS #ifdef HAVE_LONG_LONGS
case scm_tc7_llvect: case scm_tc7_llvect:
#endif #endif
return scm_cons (SCM_MAKINUM (SCM_LENGTH (ra)), SCM_EOL); return scm_cons (scm_uniform_vector_length (ra), SCM_EOL);
case scm_tc7_smob: case scm_tc7_smob:
if (!SCM_ARRAYP (ra)) if (!SCM_ARRAYP (ra))
return SCM_BOOL_F; return SCM_BOOL_F;
@ -706,7 +708,7 @@ SCM_DEFINE (scm_make_shared_array, "make-shared-array", 2, 0, 1,
{ {
SCM_ARRAY_V (ra) = oldra; SCM_ARRAY_V (ra) = oldra;
old_min = 0; old_min = 0;
old_max = (long) SCM_LENGTH (oldra) - 1; old_max = SCM_INUM (scm_uniform_vector_length (oldra)) - 1;
} }
inds = SCM_EOL; inds = SCM_EOL;
s = SCM_ARRAY_DIMS (ra); s = SCM_ARRAY_DIMS (ra);
@ -773,9 +775,10 @@ SCM_DEFINE (scm_make_shared_array, "make-shared-array", 2, 0, 1,
"mapping out of range", FUNC_NAME); "mapping out of range", FUNC_NAME);
if (1 == SCM_ARRAY_NDIM (ra) && 0 == SCM_ARRAY_BASE (ra)) if (1 == SCM_ARRAY_NDIM (ra) && 0 == SCM_ARRAY_BASE (ra))
{ {
if (1 == s->inc && 0 == s->lbnd SCM v = SCM_ARRAY_V (ra);
&& SCM_LENGTH (SCM_ARRAY_V (ra)) == 1 + s->ubnd) unsigned long int length = SCM_INUM (scm_uniform_vector_length (v));
return SCM_ARRAY_V (ra); if (1 == s->inc && 0 == s->lbnd && length == 1 + s->ubnd)
return v;
if (s->ubnd < s->lbnd) if (s->ubnd < s->lbnd)
return scm_make_uve (0L, scm_array_prototype (ra)); return scm_make_uve (0L, scm_array_prototype (ra));
} }
@ -838,7 +841,7 @@ SCM_DEFINE (scm_transpose_array, "transpose-array", 1, 0, 1,
case scm_tc7_smob: case scm_tc7_smob:
SCM_ASRTGO (SCM_ARRAYP (ra), badarg); SCM_ASRTGO (SCM_ARRAYP (ra), badarg);
vargs = scm_vector (args); vargs = scm_vector (args);
SCM_ASSERT (SCM_LENGTH (vargs) == SCM_ARRAY_NDIM (ra), SCM_ASSERT (SCM_VECTOR_LENGTH (vargs) == SCM_ARRAY_NDIM (ra),
scm_makfrom0str (FUNC_NAME), SCM_WNA, NULL); scm_makfrom0str (FUNC_NAME), SCM_WNA, NULL);
ve = SCM_VELTS (vargs); ve = SCM_VELTS (vargs);
ndim = 0; ndim = 0;
@ -925,8 +928,7 @@ SCM_DEFINE (scm_enclose_array, "enclose-array", 1, 0, 1,
SCM_ASSERT (0 <= ninr, scm_makfrom0str (FUNC_NAME), SCM_WNA, NULL); SCM_ASSERT (0 <= ninr, scm_makfrom0str (FUNC_NAME), SCM_WNA, NULL);
ra_inr = scm_make_ra (ninr); ra_inr = scm_make_ra (ninr);
SCM_ASRTGO (SCM_NIMP (ra), badarg1); SCM_ASRTGO (SCM_NIMP (ra), badarg1);
switch SCM_TYP7 switch SCM_TYP7 (ra)
(ra)
{ {
default: default:
badarg1:SCM_WTA (1,ra); badarg1:SCM_WTA (1,ra);
@ -945,7 +947,7 @@ SCM_DEFINE (scm_enclose_array, "enclose-array", 1, 0, 1,
case scm_tc7_llvect: case scm_tc7_llvect:
#endif #endif
s->lbnd = 0; s->lbnd = 0;
s->ubnd = SCM_LENGTH (ra) - 1; s->ubnd = SCM_INUM (scm_uniform_vector_length (ra)) - 1;
s->inc = 1; s->inc = 1;
SCM_ARRAY_V (ra_inr) = ra; SCM_ARRAY_V (ra_inr) = ra;
SCM_ARRAY_BASE (ra_inr) = 0; SCM_ARRAY_BASE (ra_inr) = 0;
@ -1011,8 +1013,7 @@ SCM_DEFINE (scm_array_in_bounds_p, "array-in-bounds?", 1, 0, 1,
pos = SCM_INUM (ind); pos = SCM_INUM (ind);
} }
tail: tail:
switch SCM_TYP7 switch SCM_TYP7 (v)
(v)
{ {
default: default:
badarg1:SCM_WTA (1,v); badarg1:SCM_WTA (1,v);
@ -1060,8 +1061,11 @@ tail:
#endif #endif
case scm_tc7_vector: case scm_tc7_vector:
case scm_tc7_wvect: case scm_tc7_wvect:
{
unsigned long int length = SCM_INUM (scm_uniform_vector_length (v));
SCM_ASRTGO (SCM_NULLP (args) && SCM_INUMP (ind), wna); SCM_ASRTGO (SCM_NULLP (args) && SCM_INUMP (ind), wna);
return SCM_BOOL(pos >= 0 && pos < SCM_LENGTH (v)); return SCM_BOOL(pos >= 0 && pos < length);
}
} }
} }
#undef FUNC_NAME #undef FUNC_NAME
@ -1090,8 +1094,8 @@ SCM_DEFINE (scm_uniform_vector_ref, "uniform-vector-ref", 2, 0, 0,
} }
else else
{ {
unsigned long int length;
if (SCM_NIMP (args)) if (SCM_NIMP (args))
{ {
SCM_ASSERT (SCM_CONSP (args) && SCM_INUMP (SCM_CAR (args)), args, SCM_ARG2, FUNC_NAME); SCM_ASSERT (SCM_CONSP (args) && SCM_INUMP (SCM_CAR (args)), args, SCM_ARG2, FUNC_NAME);
pos = SCM_INUM (SCM_CAR (args)); pos = SCM_INUM (SCM_CAR (args));
@ -1102,10 +1106,10 @@ SCM_DEFINE (scm_uniform_vector_ref, "uniform-vector-ref", 2, 0, 0,
SCM_VALIDATE_INUM (2,args); SCM_VALIDATE_INUM (2,args);
pos = SCM_INUM (args); pos = SCM_INUM (args);
} }
SCM_ASRTGO (pos >= 0 && pos < SCM_LENGTH (v), outrng); length = SCM_INUM (scm_uniform_vector_length (v));
SCM_ASRTGO (pos >= 0 && pos < length, outrng);
} }
switch SCM_TYP7 switch SCM_TYP7 (v)
(v)
{ {
default: default:
if (SCM_NULLP (args)) if (SCM_NULLP (args))
@ -1260,6 +1264,7 @@ SCM_DEFINE (scm_array_set_x, "array-set!", 2, 0, 1,
} }
else else
{ {
unsigned long int length;
if (SCM_NIMP (args)) if (SCM_NIMP (args))
{ {
SCM_ASSERT (SCM_CONSP(args) && SCM_INUMP (SCM_CAR (args)), args, SCM_ASSERT (SCM_CONSP(args) && SCM_INUMP (SCM_CAR (args)), args,
@ -1271,7 +1276,8 @@ SCM_DEFINE (scm_array_set_x, "array-set!", 2, 0, 1,
{ {
SCM_VALIDATE_INUM_COPY (3,args,pos); SCM_VALIDATE_INUM_COPY (3,args,pos);
} }
SCM_ASRTGO (pos >= 0 && pos < SCM_LENGTH (v), outrng); length = SCM_INUM (scm_uniform_vector_length (v));
SCM_ASRTGO (pos >= 0 && pos < length, outrng);
} }
switch (SCM_TYP7 (v)) switch (SCM_TYP7 (v))
{ {
@ -1397,14 +1403,20 @@ SCM_DEFINE (scm_array_contents, "array-contents", 1, 1, 0,
return SCM_BOOL_F; return SCM_BOOL_F;
if (scm_tc7_bvect == SCM_TYP7 (SCM_ARRAY_V (ra))) if (scm_tc7_bvect == SCM_TYP7 (SCM_ARRAY_V (ra)))
{ {
if (len != SCM_LENGTH (SCM_ARRAY_V (ra)) || if (len != SCM_BITVECTOR_LENGTH (SCM_ARRAY_V (ra)) ||
SCM_ARRAY_BASE (ra) % SCM_LONG_BIT || SCM_ARRAY_BASE (ra) % SCM_LONG_BIT ||
len % SCM_LONG_BIT) len % SCM_LONG_BIT)
return SCM_BOOL_F; return SCM_BOOL_F;
} }
} }
if ((len == SCM_LENGTH (SCM_ARRAY_V (ra))) && 0 == SCM_ARRAY_BASE (ra) && SCM_ARRAY_DIMS (ra)->inc)
return SCM_ARRAY_V (ra); {
SCM v = SCM_ARRAY_V (ra);
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;
}
sra = scm_make_ra (1); sra = scm_make_ra (1);
SCM_ARRAY_DIMS (sra)->lbnd = 0; SCM_ARRAY_DIMS (sra)->lbnd = 0;
SCM_ARRAY_DIMS (sra)->ubnd = len - 1; SCM_ARRAY_DIMS (sra)->ubnd = len - 1;
@ -1429,9 +1441,9 @@ scm_ra2contig (SCM ra, int copy)
k = SCM_ARRAY_NDIM (ra); k = SCM_ARRAY_NDIM (ra);
if (SCM_ARRAY_CONTP (ra) && ((0 == k) || (1 == SCM_ARRAY_DIMS (ra)[k - 1].inc))) if (SCM_ARRAY_CONTP (ra) && ((0 == k) || (1 == SCM_ARRAY_DIMS (ra)[k - 1].inc)))
{ {
if (scm_tc7_bvect != SCM_TYP7 (ra)) if (scm_tc7_bvect != SCM_TYP7 (SCM_ARRAY_V (ra)))
return ra; return ra;
if ((len == SCM_LENGTH (SCM_ARRAY_V (ra)) && if ((len == SCM_BITVECTOR_LENGTH (SCM_ARRAY_V (ra)) &&
0 == SCM_ARRAY_BASE (ra) % SCM_LONG_BIT && 0 == SCM_ARRAY_BASE (ra) % SCM_LONG_BIT &&
0 == len % SCM_LONG_BIT)) 0 == len % SCM_LONG_BIT))
return ra; return ra;
@ -1484,7 +1496,7 @@ SCM_DEFINE (scm_uniform_array_read_x, "uniform-array-read!", 1, 3, 0,
SCM_ASSERT (SCM_INUMP (port_or_fd) SCM_ASSERT (SCM_INUMP (port_or_fd)
|| (SCM_OPINPORTP (port_or_fd)), || (SCM_OPINPORTP (port_or_fd)),
port_or_fd, SCM_ARG2, FUNC_NAME); port_or_fd, SCM_ARG2, FUNC_NAME);
vlen = SCM_LENGTH (v); vlen = SCM_INUM (scm_uniform_vector_length (v));
loop: loop:
switch SCM_TYP7 (v) switch SCM_TYP7 (v)
@ -1500,40 +1512,48 @@ loop:
v = SCM_ARRAY_V (cra); v = SCM_ARRAY_V (cra);
goto loop; goto loop;
case scm_tc7_string: case scm_tc7_string:
case scm_tc7_byvect: base = SCM_STRING_CHARS (v);
sz = sizeof (char); sz = sizeof (char);
break; break;
case scm_tc7_bvect: case scm_tc7_bvect:
base = (char *) SCM_BITVECTOR_BASE (v);
vlen = (vlen + SCM_LONG_BIT - 1) / SCM_LONG_BIT; vlen = (vlen + SCM_LONG_BIT - 1) / SCM_LONG_BIT;
cstart /= 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_uvect:
case scm_tc7_ivect: case scm_tc7_ivect:
base = (char *) SCM_UVECTOR_BASE (v);
sz = sizeof (long); sz = sizeof (long);
break; break;
case scm_tc7_svect: case scm_tc7_svect:
base = (char *) SCM_UVECTOR_BASE (v);
sz = sizeof (short); sz = sizeof (short);
break; break;
#ifdef HAVE_LONG_LONGS #ifdef HAVE_LONG_LONGS
case scm_tc7_llvect: case scm_tc7_llvect:
base = (char *) SCM_UVECTOR_BASE (v);
sz = sizeof (long_long); sz = sizeof (long_long);
break; break;
#endif #endif
case scm_tc7_fvect: case scm_tc7_fvect:
base = (char *) SCM_UVECTOR_BASE (v);
sz = sizeof (float); sz = sizeof (float);
break; break;
case scm_tc7_dvect: case scm_tc7_dvect:
base = (char *) SCM_UVECTOR_BASE (v);
sz = sizeof (double); sz = sizeof (double);
break; break;
case scm_tc7_cvect: case scm_tc7_cvect:
base = (char *) SCM_UVECTOR_BASE (v);
sz = 2 * sizeof (double); sz = 2 * sizeof (double);
break; break;
} }
if (SCM_STRINGP (v))
base = SCM_STRING_CHARS (v);
else
base = (char *) SCM_UVECTOR_BASE (v);
cend = vlen; cend = vlen;
if (!SCM_UNBNDP (start)) if (!SCM_UNBNDP (start))
{ {
@ -1640,7 +1660,7 @@ SCM_DEFINE (scm_uniform_array_write, "uniform-array-write", 1, 3, 0,
SCM_ASSERT (SCM_INUMP (port_or_fd) SCM_ASSERT (SCM_INUMP (port_or_fd)
|| (SCM_OPOUTPORTP (port_or_fd)), || (SCM_OPOUTPORTP (port_or_fd)),
port_or_fd, SCM_ARG2, FUNC_NAME); port_or_fd, SCM_ARG2, FUNC_NAME);
vlen = SCM_LENGTH (v); vlen = SCM_INUM (scm_uniform_vector_length (v));
loop: loop:
switch SCM_TYP7 (v) switch SCM_TYP7 (v)
@ -1656,40 +1676,48 @@ loop:
v = SCM_ARRAY_V (v); v = SCM_ARRAY_V (v);
goto loop; goto loop;
case scm_tc7_string: case scm_tc7_string:
case scm_tc7_byvect: base = SCM_STRING_CHARS (v);
sz = sizeof (char); sz = sizeof (char);
break; break;
case scm_tc7_bvect: case scm_tc7_bvect:
base = (char *) SCM_BITVECTOR_BASE (v);
vlen = (vlen + SCM_LONG_BIT - 1) / SCM_LONG_BIT; vlen = (vlen + SCM_LONG_BIT - 1) / SCM_LONG_BIT;
cstart /= 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_uvect:
case scm_tc7_ivect: case scm_tc7_ivect:
base = (char *) SCM_UVECTOR_BASE (v);
sz = sizeof (long); sz = sizeof (long);
break; break;
case scm_tc7_svect: case scm_tc7_svect:
base = (char *) SCM_UVECTOR_BASE (v);
sz = sizeof (short); sz = sizeof (short);
break; break;
#ifdef HAVE_LONG_LONGS #ifdef HAVE_LONG_LONGS
case scm_tc7_llvect: case scm_tc7_llvect:
base = (char *) SCM_UVECTOR_BASE (v);
sz = sizeof (long_long); sz = sizeof (long_long);
break; break;
#endif #endif
case scm_tc7_fvect: case scm_tc7_fvect:
base = (char *) SCM_UVECTOR_BASE (v);
sz = sizeof (float); sz = sizeof (float);
break; break;
case scm_tc7_dvect: case scm_tc7_dvect:
base = (char *) SCM_UVECTOR_BASE (v);
sz = sizeof (double); sz = sizeof (double);
break; break;
case scm_tc7_cvect: case scm_tc7_cvect:
base = (char *) SCM_UVECTOR_BASE (v);
sz = 2 * sizeof (double); sz = 2 * sizeof (double);
break; break;
} }
if (SCM_STRINGP (v))
base = SCM_STRING_CHARS (v);
else
base = (char *) SCM_UVECTOR_BASE (v);
cend = vlen; cend = vlen;
if (!SCM_UNBNDP (start)) if (!SCM_UNBNDP (start))
{ {
@ -1742,18 +1770,17 @@ SCM_DEFINE (scm_bit_count, "bit-count", 2, 0, 0,
#define FUNC_NAME s_scm_bit_count #define FUNC_NAME s_scm_bit_count
{ {
SCM_VALIDATE_BOOL (1, b); SCM_VALIDATE_BOOL (1, b);
SCM_ASSERT (!SCM_IMP (bitvector) && SCM_TYP7 (bitvector) == scm_tc7_bvect, SCM_ASSERT (SCM_BITVECTOR_P (bitvector), bitvector, 2, FUNC_NAME);
bitvector, 2, FUNC_NAME); if (SCM_BITVECTOR_LENGTH (bitvector) == 0) {
if (SCM_LENGTH (bitvector) == 0) {
return SCM_INUM0; return SCM_INUM0;
} else { } else {
unsigned long int count = 0; unsigned long int count = 0;
unsigned long int i = (SCM_LENGTH (bitvector) - 1) / SCM_LONG_BIT; unsigned long int i = (SCM_BITVECTOR_LENGTH (bitvector) - 1) / SCM_LONG_BIT;
unsigned long int w = SCM_UNPACK (SCM_VELTS (bitvector)[i]); unsigned long int w = SCM_UNPACK (SCM_VELTS (bitvector)[i]);
if (SCM_FALSEP (b)) { if (SCM_FALSEP (b)) {
w = ~w; w = ~w;
}; };
w <<= SCM_LONG_BIT - 1 - ((SCM_LENGTH (bitvector) - 1) % SCM_LONG_BIT); w <<= SCM_LONG_BIT - 1 - ((SCM_BITVECTOR_LENGTH (bitvector) - 1) % SCM_LONG_BIT);
while (1) { while (1) {
while (w) { while (w) {
count += cnt_tab[w & 0x0f]; count += cnt_tab[w & 0x0f];
@ -1783,19 +1810,16 @@ SCM_DEFINE (scm_bit_position, "bit-position", 3, 0, 0,
{ {
long i, lenw, xbits, pos; long i, lenw, xbits, pos;
register unsigned long w; register unsigned long w;
SCM_VALIDATE_NIM (2,v);
SCM_VALIDATE_BOOL (1, item);
SCM_ASSERT (SCM_BITVECTOR_P (v), v, SCM_ARG2, FUNC_NAME);
SCM_VALIDATE_INUM_COPY (3,k,pos); SCM_VALIDATE_INUM_COPY (3,k,pos);
SCM_ASSERT_RANGE (3, k, (pos <= SCM_LENGTH (v)) && (pos >= 0)); SCM_ASSERT_RANGE (3, k, (pos <= SCM_BITVECTOR_LENGTH (v)) && (pos >= 0));
if (pos == SCM_LENGTH (v))
if (pos == SCM_BITVECTOR_LENGTH (v))
return SCM_BOOL_F; return SCM_BOOL_F;
switch SCM_TYP7 (v)
{ lenw = (SCM_BITVECTOR_LENGTH (v) - 1) / SCM_LONG_BIT; /* watch for part words */
default:
SCM_WTA (2,v);
case scm_tc7_bvect:
if (0 == SCM_LENGTH (v))
return SCM_MAKINUM (-1L);
lenw = (SCM_LENGTH (v) - 1) / SCM_LONG_BIT; /* watch for part words */
i = pos / SCM_LONG_BIT; i = pos / SCM_LONG_BIT;
w = SCM_UNPACK (SCM_VELTS (v)[i]); w = SCM_UNPACK (SCM_VELTS (v)[i]);
if (SCM_FALSEP (item)) if (SCM_FALSEP (item))
@ -1803,7 +1827,7 @@ SCM_DEFINE (scm_bit_position, "bit-position", 3, 0, 0,
xbits = (pos % SCM_LONG_BIT); xbits = (pos % SCM_LONG_BIT);
pos -= xbits; pos -= xbits;
w = ((w >> xbits) << xbits); w = ((w >> xbits) << xbits);
xbits = SCM_LONG_BIT - 1 - (SCM_LENGTH (v) - 1) % SCM_LONG_BIT; xbits = SCM_LONG_BIT - 1 - (SCM_BITVECTOR_LENGTH (v) - 1) % SCM_LONG_BIT;
while (!0) while (!0)
{ {
if (w && (i == lenw)) if (w && (i == lenw))
@ -1836,7 +1860,6 @@ SCM_DEFINE (scm_bit_position, "bit-position", 3, 0, 0,
w = ~w; w = ~w;
} }
return SCM_BOOL_F; return SCM_BOOL_F;
}
} }
#undef FUNC_NAME #undef FUNC_NAME
@ -1853,21 +1876,16 @@ SCM_DEFINE (scm_bit_set_star_x, "bit-set*!", 3, 0, 0,
#define FUNC_NAME s_scm_bit_set_star_x #define FUNC_NAME s_scm_bit_set_star_x
{ {
register long i, k, vlen; register long i, k, vlen;
SCM_ASRTGO (SCM_NIMP (v), badarg1); SCM_ASSERT (SCM_BITVECTOR_P (v), v, SCM_ARG1, FUNC_NAME);
SCM_ASRTGO (SCM_NIMP (kv), badarg2); SCM_ASRTGO (SCM_NIMP (kv), badarg2);
switch SCM_TYP7 (kv) switch SCM_TYP7 (kv)
{ {
default: default:
badarg2:SCM_WTA (2,kv); badarg2:SCM_WTA (2,kv);
case scm_tc7_uvect: case scm_tc7_uvect:
switch SCM_TYP7 (v) vlen = SCM_BITVECTOR_LENGTH (v);
{
default:
badarg1: SCM_WTA (1,v);
case scm_tc7_bvect:
vlen = SCM_LENGTH (v);
if (SCM_FALSEP (obj)) if (SCM_FALSEP (obj))
for (i = SCM_LENGTH (kv); i;) for (i = SCM_UVECTOR_LENGTH (kv); i;)
{ {
k = SCM_UNPACK (SCM_VELTS (kv)[--i]); k = SCM_UNPACK (SCM_VELTS (kv)[--i]);
if (k >= vlen) if (k >= vlen)
@ -1875,7 +1893,7 @@ SCM_DEFINE (scm_bit_set_star_x, "bit-set*!", 3, 0, 0,
SCM_BITVEC_CLR(v,k); SCM_BITVEC_CLR(v,k);
} }
else if (SCM_EQ_P (obj, SCM_BOOL_T)) else if (SCM_EQ_P (obj, SCM_BOOL_T))
for (i = SCM_LENGTH (kv); i;) for (i = SCM_UVECTOR_LENGTH (kv); i;)
{ {
k = SCM_UNPACK (SCM_VELTS (kv)[--i]); k = SCM_UNPACK (SCM_VELTS (kv)[--i]);
if (k >= vlen) if (k >= vlen)
@ -1884,15 +1902,14 @@ SCM_DEFINE (scm_bit_set_star_x, "bit-set*!", 3, 0, 0,
} }
else else
badarg3:SCM_WTA (3,obj); badarg3:SCM_WTA (3,obj);
}
break; break;
case scm_tc7_bvect: case scm_tc7_bvect:
SCM_ASRTGO (SCM_TYP7 (v) == scm_tc7_bvect && SCM_LENGTH (v) == SCM_LENGTH (kv), badarg1); SCM_ASSERT (SCM_BITVECTOR_LENGTH (v) == SCM_BITVECTOR_LENGTH (kv), v, SCM_ARG1, FUNC_NAME);
if (SCM_FALSEP (obj)) if (SCM_FALSEP (obj))
for (k = (SCM_LENGTH (v) + SCM_LONG_BIT - 1) / SCM_LONG_BIT; 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]); SCM_UNPACK (SCM_VELTS (v)[k]) &= ~ SCM_UNPACK(SCM_VELTS (kv)[k]);
else if (SCM_EQ_P (obj, SCM_BOOL_T)) else if (SCM_EQ_P (obj, SCM_BOOL_T))
for (k = (SCM_LENGTH (v) + SCM_LONG_BIT - 1) / SCM_LONG_BIT; 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]); SCM_UNPACK (SCM_VELTS (v)[k]) |= SCM_UNPACK (SCM_VELTS (kv)[k]);
else else
goto badarg3; goto badarg3;
@ -1916,7 +1933,7 @@ SCM_DEFINE (scm_bit_count_star, "bit-count*", 3, 0, 0,
register unsigned long k; register unsigned long k;
int fObj = 0; int fObj = 0;
SCM_ASRTGO (SCM_NIMP (v), badarg1); SCM_ASSERT (SCM_BITVECTOR_P (v), v, SCM_ARG1, FUNC_NAME);
SCM_ASRTGO (SCM_NIMP (kv), badarg2); SCM_ASRTGO (SCM_NIMP (kv), badarg2);
switch SCM_TYP7 (kv) switch SCM_TYP7 (kv)
{ {
@ -1924,16 +1941,9 @@ SCM_DEFINE (scm_bit_count_star, "bit-count*", 3, 0, 0,
badarg2: badarg2:
SCM_WTA (2,kv); SCM_WTA (2,kv);
case scm_tc7_uvect: case scm_tc7_uvect:
switch SCM_TYP7 vlen = SCM_BITVECTOR_LENGTH (v);
(v)
{
default:
badarg1:
SCM_WTA (1,v);
case scm_tc7_bvect:
vlen = SCM_LENGTH (v);
if (SCM_FALSEP (obj)) if (SCM_FALSEP (obj))
for (i = SCM_LENGTH (kv); i;) for (i = SCM_UVECTOR_LENGTH (kv); i;)
{ {
k = SCM_UNPACK (SCM_VELTS (kv)[--i]); k = SCM_UNPACK (SCM_VELTS (kv)[--i]);
if (k >= vlen) if (k >= vlen)
@ -1942,7 +1952,7 @@ SCM_DEFINE (scm_bit_count_star, "bit-count*", 3, 0, 0,
count++; count++;
} }
else if (SCM_EQ_P (obj, SCM_BOOL_T)) else if (SCM_EQ_P (obj, SCM_BOOL_T))
for (i = SCM_LENGTH (kv); i;) for (i = SCM_UVECTOR_LENGTH (kv); i;)
{ {
k = SCM_UNPACK (SCM_VELTS (kv)[--i]); k = SCM_UNPACK (SCM_VELTS (kv)[--i]);
if (k >= vlen) if (k >= vlen)
@ -1952,17 +1962,16 @@ SCM_DEFINE (scm_bit_count_star, "bit-count*", 3, 0, 0,
} }
else else
badarg3:SCM_WTA (3,obj); badarg3:SCM_WTA (3,obj);
}
break; break;
case scm_tc7_bvect: case scm_tc7_bvect:
SCM_ASRTGO (SCM_TYP7 (v) == scm_tc7_bvect && SCM_LENGTH (v) == SCM_LENGTH (kv), badarg1); SCM_ASSERT (SCM_BITVECTOR_LENGTH (v) == SCM_BITVECTOR_LENGTH (kv), v, SCM_ARG1, FUNC_NAME);
if (0 == SCM_LENGTH (v)) if (0 == SCM_BITVECTOR_LENGTH (v))
return SCM_INUM0; return SCM_INUM0;
SCM_ASRTGO (SCM_BOOLP (obj), badarg3); SCM_ASRTGO (SCM_BOOLP (obj), badarg3);
fObj = SCM_EQ_P (obj, SCM_BOOL_T); fObj = SCM_EQ_P (obj, SCM_BOOL_T);
i = (SCM_LENGTH (v) - 1) / SCM_LONG_BIT; 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_UNPACK (SCM_VELTS (kv)[i]) & (fObj ? SCM_UNPACK (SCM_VELTS (v)[i]) : ~ SCM_UNPACK (SCM_VELTS (v)[i]));
k <<= SCM_LONG_BIT - 1 - ((SCM_LENGTH (v) - 1) % SCM_LONG_BIT); k <<= SCM_LONG_BIT - 1 - ((SCM_BITVECTOR_LENGTH (v) - 1) % SCM_LONG_BIT);
while (1) while (1)
{ {
for (; k; k >>= 4) for (; k; k >>= 4)
@ -1984,19 +1993,14 @@ SCM_DEFINE (scm_bit_invert_x, "bit-invert!", 1, 0, 0,
"Modifies @var{bv} by replacing each element with its negation.") "Modifies @var{bv} by replacing each element with its negation.")
#define FUNC_NAME s_scm_bit_invert_x #define FUNC_NAME s_scm_bit_invert_x
{ {
register long k; long int k;
SCM_ASRTGO (SCM_NIMP (v), badarg1);
k = SCM_LENGTH (v); SCM_ASSERT (SCM_BITVECTOR_P (v), v, SCM_ARG1, FUNC_NAME);
switch SCM_TYP7
(v) k = SCM_BITVECTOR_LENGTH (v);
{
case scm_tc7_bvect:
for (k = (k + SCM_LONG_BIT - 1) / SCM_LONG_BIT; k--;) for (k = (k + SCM_LONG_BIT - 1) / SCM_LONG_BIT; k--;)
SCM_UNPACK (SCM_VELTS (v)[k]) = ~SCM_UNPACK(SCM_VELTS (v)[k]); SCM_UNPACK (SCM_VELTS (v)[k]) = ~SCM_UNPACK (SCM_VELTS (v)[k]);
break;
default:
badarg1:SCM_WTA (1,v);
}
return SCM_UNSPECIFIED; return SCM_UNSPECIFIED;
} }
#undef FUNC_NAME #undef FUNC_NAME
@ -2070,8 +2074,7 @@ SCM_DEFINE (scm_array_to_list, "array->list", 1, 0, 0,
SCM res = SCM_EOL; SCM res = SCM_EOL;
register long k; register long k;
SCM_ASRTGO (SCM_NIMP (v), badarg1); SCM_ASRTGO (SCM_NIMP (v), badarg1);
switch SCM_TYP7 switch SCM_TYP7 (v)
(v)
{ {
default: default:
badarg1:SCM_WTA (1,v); badarg1:SCM_WTA (1,v);
@ -2087,29 +2090,29 @@ SCM_DEFINE (scm_array_to_list, "array->list", 1, 0, 0,
{ {
long *data = (long *) SCM_VELTS (v); long *data = (long *) SCM_VELTS (v);
register unsigned long mask; register unsigned long mask;
for (k = (SCM_LENGTH (v) - 1) / SCM_LONG_BIT; k > 0; k--) for (k = (SCM_BITVECTOR_LENGTH (v) - 1) / SCM_LONG_BIT; k > 0; k--)
for (mask = 1UL << (SCM_LONG_BIT - 1); mask; mask >>= 1) for (mask = 1UL << (SCM_LONG_BIT - 1); mask; mask >>= 1)
res = scm_cons (SCM_BOOL(((long *) data)[k] & mask), res); res = scm_cons (SCM_BOOL(((long *) data)[k] & mask), res);
for (mask = 1L << ((SCM_LENGTH (v) % SCM_LONG_BIT) - 1); mask; mask >>= 1) for (mask = 1L << ((SCM_BITVECTOR_LENGTH (v) % SCM_LONG_BIT) - 1); mask; mask >>= 1)
res = scm_cons (SCM_BOOL(((long *) data)[k] & mask), res); res = scm_cons (SCM_BOOL(((long *) data)[k] & mask), res);
return res; return res;
} }
case scm_tc7_uvect: { case scm_tc7_uvect: {
long *data = (long *)SCM_VELTS(v); long *data = (long *)SCM_VELTS(v);
for (k = SCM_LENGTH(v) - 1; k >= 0; k--) for (k = SCM_UVECTOR_LENGTH(v) - 1; k >= 0; k--)
res = scm_cons(scm_ulong2num(data[k]), res); res = scm_cons(scm_ulong2num(data[k]), res);
return res; return res;
} }
case scm_tc7_ivect: { case scm_tc7_ivect: {
long *data = (long *)SCM_VELTS(v); long *data = (long *)SCM_VELTS(v);
for (k = SCM_LENGTH(v) - 1; k >= 0; k--) for (k = SCM_UVECTOR_LENGTH(v) - 1; k >= 0; k--)
res = scm_cons(scm_long2num(data[k]), res); res = scm_cons(scm_long2num(data[k]), res);
return res; return res;
} }
case scm_tc7_svect: { case scm_tc7_svect: {
short *data; short *data;
data = (short *)SCM_VELTS(v); data = (short *)SCM_VELTS(v);
for (k = SCM_LENGTH(v) - 1; k >= 0; k--) for (k = SCM_UVECTOR_LENGTH(v) - 1; k >= 0; k--)
res = scm_cons(SCM_MAKINUM (data[k]), res); res = scm_cons(SCM_MAKINUM (data[k]), res);
return res; return res;
} }
@ -2117,7 +2120,7 @@ SCM_DEFINE (scm_array_to_list, "array->list", 1, 0, 0,
case scm_tc7_llvect: { case scm_tc7_llvect: {
long_long *data; long_long *data;
data = (long_long *)SCM_VELTS(v); data = (long_long *)SCM_VELTS(v);
for (k = SCM_LENGTH(v) - 1; k >= 0; k--) for (k = SCM_UVECTOR_LENGTH(v) - 1; k >= 0; k--)
res = scm_cons(scm_long_long2num(data[k]), res); res = scm_cons(scm_long_long2num(data[k]), res);
return res; return res;
} }
@ -2127,21 +2130,21 @@ SCM_DEFINE (scm_array_to_list, "array->list", 1, 0, 0,
case scm_tc7_fvect: case scm_tc7_fvect:
{ {
float *data = (float *) SCM_VELTS (v); float *data = (float *) SCM_VELTS (v);
for (k = SCM_LENGTH (v) - 1; k >= 0; k--) for (k = SCM_UVECTOR_LENGTH (v) - 1; k >= 0; k--)
res = scm_cons (scm_make_real (data[k]), res); res = scm_cons (scm_make_real (data[k]), res);
return res; return res;
} }
case scm_tc7_dvect: case scm_tc7_dvect:
{ {
double *data = (double *) SCM_VELTS (v); double *data = (double *) SCM_VELTS (v);
for (k = SCM_LENGTH (v) - 1; k >= 0; k--) for (k = SCM_UVECTOR_LENGTH (v) - 1; k >= 0; k--)
res = scm_cons (scm_make_real (data[k]), res); res = scm_cons (scm_make_real (data[k]), res);
return res; return res;
} }
case scm_tc7_cvect: case scm_tc7_cvect:
{ {
double (*data)[2] = (double (*)[2]) SCM_VELTS (v); double (*data)[2] = (double (*)[2]) SCM_VELTS (v);
for (k = SCM_LENGTH (v) - 1; k >= 0; k--) for (k = SCM_UVECTOR_LENGTH (v) - 1; k >= 0; k--)
res = scm_cons (scm_make_complex (data[k][0], data[k][1]), res); res = scm_cons (scm_make_complex (data[k][0], data[k][1]), res);
return res; return res;
} }
@ -2187,7 +2190,8 @@ SCM_DEFINE (scm_list_to_uniform_array, "list->uniform-array", 3, 0, 0,
} }
if (!SCM_ARRAYP (ra)) if (!SCM_ARRAYP (ra))
{ {
for (k = 0; k < SCM_LENGTH (ra); k++, lst = SCM_CDR (lst)) 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)); scm_array_set_x (ra, SCM_CAR (lst), SCM_MAKINUM (k));
return ra; return ra;
} }
@ -2241,7 +2245,7 @@ static void
rapr1 (SCM ra,scm_sizet j,scm_sizet k,SCM port,scm_print_state *pstate) rapr1 (SCM ra,scm_sizet j,scm_sizet k,SCM port,scm_print_state *pstate)
{ {
long inc = 1; long inc = 1;
long n = SCM_LENGTH (ra); long n = SCM_INUM (scm_uniform_vector_length (ra));
int enclosed = 0; int enclosed = 0;
tail: tail:
switch SCM_TYP7 (ra) switch SCM_TYP7 (ra)
@ -2445,7 +2449,7 @@ tail:
{ /* a uve, not an scm_array */ { /* a uve, not an scm_array */
register long i, j, w; register long i, j, w;
scm_putc ('*', port); scm_putc ('*', port);
for (i = 0; i < (SCM_LENGTH (exp)) / SCM_LONG_BIT; i++) for (i = 0; i < (SCM_BITVECTOR_LENGTH (exp)) / SCM_LONG_BIT; i++)
{ {
scm_bits_t w = SCM_UNPACK (SCM_VELTS (exp)[i]); scm_bits_t w = SCM_UNPACK (SCM_VELTS (exp)[i]);
for (j = SCM_LONG_BIT; j; j--) for (j = SCM_LONG_BIT; j; j--)
@ -2454,10 +2458,10 @@ tail:
w >>= 1; w >>= 1;
} }
} }
j = SCM_LENGTH (exp) % SCM_LONG_BIT; j = SCM_BITVECTOR_LENGTH (exp) % SCM_LONG_BIT;
if (j) if (j)
{ {
w = SCM_UNPACK (SCM_VELTS (exp)[SCM_LENGTH (exp) / SCM_LONG_BIT]); w = SCM_UNPACK (SCM_VELTS (exp)[SCM_BITVECTOR_LENGTH (exp) / SCM_LONG_BIT]);
for (; j; j--) for (; j; j--)
{ {
scm_putc (w & 1 ? '1' : '0', port); scm_putc (w & 1 ? '1' : '0', port);
@ -2515,8 +2519,7 @@ SCM_DEFINE (scm_array_prototype, "array-prototype", 1, 0, 0,
int enclosed = 0; int enclosed = 0;
SCM_ASRTGO (SCM_NIMP (ra), badarg); SCM_ASRTGO (SCM_NIMP (ra), badarg);
loop: loop:
switch SCM_TYP7 switch SCM_TYP7 (ra)
(ra)
{ {
default: default:
badarg:SCM_WTA (1,ra); badarg:SCM_WTA (1,ra);