-/* Copyright (C) 1995,1996,1997,1998,2000,2001 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public
*/
scm_t_bits scm_tc16_array;
+static SCM exactly_one_third;
/* return the size of an element in a uniform array or 0 if type not
found. */
}
}
+static SCM
+make_uve (long type, long k, size_t size)
+#define FUNC_NAME "scm_make_uve"
+{
+ SCM_ASSERT_RANGE (1, scm_long2num (k), k <= SCM_UVECTOR_MAX_LENGTH);
+
+ return scm_cell (SCM_MAKE_UVECTOR_TAG (k, type),
+ (scm_t_bits) scm_gc_malloc (k * size, "vector"));
+}
+#undef FUNC_NAME
+
SCM
scm_make_uve (long k, SCM prot)
#define FUNC_NAME "scm_make_uve"
{
- SCM v;
- long i, type;
-
if (SCM_EQ_P (prot, SCM_BOOL_T))
{
if (k > 0)
{
+ long i;
SCM_ASSERT_RANGE (1,
scm_long2num (k), k <= SCM_BITVECTOR_MAX_LENGTH);
i = sizeof (long) * ((k + SCM_LONG_BIT - 1) / SCM_LONG_BIT);
- v = scm_cell (SCM_MAKE_BITVECTOR_TAG (k),
- (scm_t_bits) scm_gc_malloc (i, "vector"));
+ return scm_cell (SCM_MAKE_BITVECTOR_TAG (k),
+ (scm_t_bits) scm_gc_malloc (i, "vector"));
}
else
- v = scm_cell (SCM_MAKE_BITVECTOR_TAG (0), 0);
- return v;
+ return scm_cell (SCM_MAKE_BITVECTOR_TAG (0), 0);
}
else if (SCM_CHARP (prot) && (SCM_CHAR (prot) == '\0'))
- {
- i = sizeof (char) * k;
- type = scm_tc7_byvect;
- }
+ return make_uve (scm_tc7_byvect, k, sizeof (char));
else if (SCM_CHARP (prot))
- {
- i = sizeof (char) * k;
- return scm_allocate_string (i);
- }
+ return scm_allocate_string (sizeof (char) * k);
else if (SCM_INUMP (prot))
+ return make_uve (SCM_INUM (prot) > 0 ? scm_tc7_uvect : scm_tc7_ivect,
+ k,
+ sizeof (long));
+ else if (SCM_FRACTIONP (prot))
{
- i = sizeof (long) * k;
- if (SCM_INUM (prot) > 0)
- type = scm_tc7_uvect;
- else
- type = scm_tc7_ivect;
+ if (scm_num_eq_p (exactly_one_third, prot))
+ goto dvect;
}
else if (SCM_SYMBOLP (prot) && (1 == SCM_SYMBOL_LENGTH (prot)))
{
s = SCM_SYMBOL_CHARS (prot)[0];
if (s == 's')
- {
- i = sizeof (short) * k;
- type = scm_tc7_svect;
- }
+ return make_uve (scm_tc7_svect, k, sizeof (short));
#if SCM_SIZEOF_LONG_LONG != 0
else if (s == 'l')
- {
- i = sizeof (long long) * k;
- type = scm_tc7_llvect;
- }
+ return make_uve (scm_tc7_llvect, k, sizeof (long long));
#endif
else
- {
- return scm_c_make_vector (k, SCM_UNDEFINED);
- }
+ return scm_c_make_vector (k, SCM_UNDEFINED);
}
else if (!SCM_INEXACTP (prot))
/* Huge non-unif vectors are NOT supported. */
/* no special scm_vector */
return scm_c_make_vector (k, SCM_UNDEFINED);
else if (singp (prot))
- {
- i = sizeof (float) * k;
- type = scm_tc7_fvect;
- }
+ return make_uve (scm_tc7_fvect, k, sizeof (float));
else if (SCM_COMPLEXP (prot))
- {
- i = 2 * sizeof (double) * k;
- type = scm_tc7_cvect;
- }
- else
- {
- i = sizeof (double) * k;
- type = scm_tc7_dvect;
- }
-
- SCM_ASSERT_RANGE (1, scm_long2num (k), k <= SCM_UVECTOR_MAX_LENGTH);
-
- return scm_cell (SCM_MAKE_UVECTOR_TAG (k, type),
- (scm_t_bits) scm_gc_malloc (i, "vector"));
+ return make_uve (scm_tc7_cvect, k, 2 * sizeof (double));
+ dvect:
+ return make_uve (scm_tc7_dvect, k, sizeof (double));
}
#undef FUNC_NAME
-
SCM_DEFINE (scm_uniform_vector_length, "uniform-vector-length", 1, 0, 0,
(SCM v),
"Return the number of elements in @var{uve}.")
v = SCM_ARRAY_V (v);
}
if (nprot)
- return SCM_BOOL(nprot);
+ return scm_from_bool(nprot);
else
{
int protp = 0;
{
case scm_tc7_bvect:
protp = (SCM_EQ_P (prot, SCM_BOOL_T));
+ break;
case scm_tc7_string:
protp = SCM_CHARP(prot) && (SCM_CHAR (prot) != '\0');
+ break;
case scm_tc7_byvect:
protp = SCM_EQ_P (prot, SCM_MAKE_CHAR ('\0'));
+ break;
case scm_tc7_uvect:
protp = SCM_INUMP(prot) && SCM_INUM(prot)>0;
+ break;
case scm_tc7_ivect:
protp = SCM_INUMP(prot) && SCM_INUM(prot)<=0;
-
+ break;
case scm_tc7_svect:
protp = SCM_SYMBOLP (prot)
&& (1 == SCM_SYMBOL_LENGTH (prot))
&& ('s' == SCM_SYMBOL_CHARS (prot)[0]);
+ break;
#if SCM_SIZEOF_LONG_LONG != 0
case scm_tc7_llvect:
protp = SCM_SYMBOLP (prot)
&& (1 == SCM_SYMBOL_LENGTH (prot))
- && ('s' == SCM_SYMBOL_CHARS (prot)[0]);
+ && ('l' == SCM_SYMBOL_CHARS (prot)[0]);
+ break;
#endif
case scm_tc7_fvect:
protp = singp (prot);
+ break;
case scm_tc7_dvect:
- protp = SCM_REALP(prot);
+ 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_NULLP(prot);
+ break;
default:
/* no default */
;
}
- return SCM_BOOL(protp);
+ return scm_from_bool(protp);
}
}
#undef FUNC_NAME
scm_error_num_args_subr (what);
return pos + (SCM_INUM (args) - s->lbnd) * (s->inc);
}
- while (k && !SCM_NULLP (args))
+ while (k && SCM_CONSP (args))
{
ind = SCM_CAR (args);
args = SCM_CDR (args);
{
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);
+ return scm_from_bool(pos >= 0 && pos < length);
}
}
}
case scm_tc7_smob: /* enclosed */
goto badarg1;
case scm_tc7_bvect:
- if (SCM_FALSEP (obj))
+ if (scm_is_false (obj))
SCM_BITVEC_CLR(v, pos);
else if (SCM_EQ_P (obj, SCM_BOOL_T))
SCM_BITVEC_SET(v, pos);
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)) {
+ if (scm_is_false (b)) {
w = ~w;
};
w <<= SCM_LONG_BIT - 1 - ((SCM_BITVECTOR_LENGTH (bitvector) - 1) % SCM_LONG_BIT);
} else {
--i;
w = SCM_UNPACK (SCM_VELTS (bitvector)[i]);
- if (SCM_FALSEP (b)) {
+ if (scm_is_false (b)) {
w = ~w;
}
}
SCM_DEFINE (scm_bit_position, "bit-position", 3, 0, 0,
(SCM item, SCM v, SCM k),
- "Return the minimum index of an occurrence of @var{bool} in\n"
- "@var{bv} which is at least @var{k}. If no @var{bool} occurs\n"
- "within the specified range @code{#f} is returned.")
+ "Return the index of the first occurrance of @var{item} in bit\n"
+ "vector @var{v}, starting from @var{k}. If there is no\n"
+ "@var{item} entry between @var{k} and the end of\n"
+ "@var{bitvector}, then return @code{#f}. For example,\n"
+ "\n"
+ "@example\n"
+ "(bit-position #t #*000101 0) @result{} 3\n"
+ "(bit-position #f #*0001111 3) @result{} #f\n"
+ "@end example")
#define FUNC_NAME s_scm_bit_position
{
long i, lenw, xbits, pos;
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))
+ if (scm_is_false (item))
w = ~w;
xbits = (pos % SCM_LONG_BIT);
pos -= xbits;
break;
pos += SCM_LONG_BIT;
w = SCM_UNPACK (SCM_VELTS (v)[i]);
- if (SCM_FALSEP (item))
+ if (scm_is_false (item))
w = ~w;
}
return SCM_BOOL_F;
SCM_DEFINE (scm_bit_set_star_x, "bit-set*!", 3, 0, 0,
(SCM v, SCM kv, SCM obj),
- "If uve is a bit-vector @var{bv} and uve must be of the same\n"
- "length. If @var{bool} is @code{#t}, uve is OR'ed into\n"
- "@var{bv}; If @var{bool} is @code{#f}, the inversion of uve is\n"
- "AND'ed into @var{bv}.\n\n"
- "If uve is a unsigned long integer vector all the elements of uve\n"
- "must be between 0 and the @code{length} of @var{bv}. The bits\n"
- "of @var{bv} corresponding to the indexes in uve are set to\n"
- "@var{bool}. The return value is unspecified.")
+ "Set entries of bit vector @var{v} to @var{obj}, with @var{kv}\n"
+ "selecting the entries to change. The return value is\n"
+ "unspecified.\n"
+ "\n"
+ "If @var{kv} is a bit vector, then those entries where it has\n"
+ "@code{#t} are the ones in @var{v} which are set to @var{obj}.\n"
+ "@var{kv} and @var{v} must be the same length. When @var{obj}\n"
+ "is @code{#t} it's like @var{kv} is OR'ed into @var{v}. Or when\n"
+ "@var{obj} is @code{#f} it can be seen as an ANDNOT.\n"
+ "\n"
+ "@example\n"
+ "(define bv #*01000010)\n"
+ "(bit-set*! bv #*10010001 #t)\n"
+ "bv\n"
+ "@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"
+ "\n"
+ "@example\n"
+ "(define bv #*01000010)\n"
+ "(bit-set*! bv #u(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;
badarg2:SCM_WRONG_TYPE_ARG (2, kv);
case scm_tc7_uvect:
vlen = SCM_BITVECTOR_LENGTH (v);
- if (SCM_FALSEP (obj))
+ if (scm_is_false (obj))
for (i = SCM_UVECTOR_LENGTH (kv); i;)
{
k = SCM_UNPACK (SCM_VELTS (kv)[--i]);
break;
case scm_tc7_bvect:
SCM_ASSERT (SCM_BITVECTOR_LENGTH (v) == SCM_BITVECTOR_LENGTH (kv), v, SCM_ARG1, FUNC_NAME);
- if (SCM_FALSEP (obj))
+ 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_EQ_P (obj, SCM_BOOL_T))
SCM_DEFINE (scm_bit_count_star, "bit-count*", 3, 0, 0,
(SCM v, SCM kv, SCM obj),
- "Return\n"
- "@lisp\n"
- "(bit-count (bit-set*! (if bool bv (bit-invert! bv)) uve #t) #t).\n"
- "@end lisp\n"
- "@var{bv} is not modified.")
+ "Return a count of how many entries in bit vector @var{v} are\n"
+ "equal to @var{obj}, with @var{kv} selecting the entries to\n"
+ "consider.\n"
+ "\n"
+ "If @var{kv} is a bit vector, then those entries where it has\n"
+ "@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"
+ "\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"
+ "@end example")
#define FUNC_NAME s_scm_bit_count_star
{
register long i, vlen, count = 0;
SCM_WRONG_TYPE_ARG (2, kv);
case scm_tc7_uvect:
vlen = SCM_BITVECTOR_LENGTH (v);
- if (SCM_FALSEP (obj))
+ if (scm_is_false (obj))
for (i = SCM_UVECTOR_LENGTH (kv); i;)
{
k = SCM_UNPACK (SCM_VELTS (kv)[--i]);
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);
+ SCM_ASRTGO (scm_is_bool (obj), badarg3);
fObj = SCM_EQ_P (obj, SCM_BOOL_T);
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]));
SCM_DEFINE (scm_bit_invert_x, "bit-invert!", 1, 0, 0,
(SCM v),
- "Modify @var{bv} by replacing each element with its negation.")
+ "Modify the bit vector @var{v} by replacing each element with\n"
+ "its negation.")
#define FUNC_NAME s_scm_bit_invert_x
{
long int k;
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);
+ res = scm_cons (scm_from_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);
+ res = scm_cons (scm_from_bool(((long *) data)[k] & mask), res);
return res;
}
case scm_tc7_byvect:
case scm_tc7_fvect:
return scm_make_real (1.0);
case scm_tc7_dvect:
- return scm_make_real (1.0 / 3.0);
+ return exactly_one_third;
case scm_tc7_cvect:
return scm_make_complex (0.0, 1.0);
}
scm_set_smob_free (scm_tc16_array, array_free);
scm_set_smob_print (scm_tc16_array, scm_raprin1);
scm_set_smob_equalp (scm_tc16_array, scm_array_equal_p);
+ exactly_one_third = scm_permanent_object (scm_make_ratio (SCM_MAKINUM (1),
+ SCM_MAKINUM (3)));
scm_add_feature ("array");
#include "libguile/unif.x"
}
HCoop / bpt / guile.git / blobdiff