summaryrefslogtreecommitdiff
path: root/libguile/unif.c
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2009-07-17 00:58:32 +0200
committerAndy Wingo <wingo@pobox.com>2009-07-19 14:53:03 +0200
commitcf396142405d9076cc20eca9bf53376e80359a56 (patch)
tree946b5097f3913b9a43da758f503102dc3c56e725 /libguile/unif.c
parentc53c0893a3bad3312230003707f71c2f441460d4 (diff)
downloadguile-cf396142405d9076cc20eca9bf53376e80359a56.tar.gz
bitvector exodus from unif.[ch]
* libguile/Makefile.am: * libguile/unif.c: * libguile/unif.h: * libguile/bitvectors.c: * libguile/bitvectors.h: Move bitvector functionality out of unif.[ch]. * libguile/array-handle.c: * libguile/array-map.c: * libguile/init.c: * libguile/read.c: * libguile/srfi-4.c: * libguile/vectors.c: Oh, what a tangled web we weave...
Diffstat (limited to 'libguile/unif.c')
-rw-r--r--libguile/unif.c832
1 files changed, 1 insertions, 831 deletions
diff --git a/libguile/unif.c b/libguile/unif.c
index de8aba381..748eed94b 100644
--- a/libguile/unif.c
+++ b/libguile/unif.c
@@ -47,6 +47,7 @@
#include "libguile/srfi-13.h"
#include "libguile/srfi-4.h"
#include "libguile/vectors.h"
+#include "libguile/bitvectors.h"
#include "libguile/bytevectors.h"
#include "libguile/list.h"
#include "libguile/dynwind.h"
@@ -1122,832 +1123,6 @@ SCM_DEFINE (scm_uniform_array_write, "uniform-array-write", 1, 3, 0,
#undef FUNC_NAME
-/** Bit vectors */
-
-static scm_t_bits scm_tc16_bitvector;
-
-#define IS_BITVECTOR(obj) SCM_SMOB_PREDICATE(scm_tc16_bitvector,(obj))
-#define BITVECTOR_BITS(obj) ((scm_t_uint32 *)SCM_SMOB_DATA(obj))
-#define BITVECTOR_LENGTH(obj) ((size_t)SCM_SMOB_DATA_2(obj))
-
-static size_t
-bitvector_free (SCM vec)
-{
- scm_gc_free (BITVECTOR_BITS (vec),
- sizeof (scm_t_uint32) * ((BITVECTOR_LENGTH (vec)+31)/32),
- "bitvector");
- return 0;
-}
-
-static int
-bitvector_print (SCM vec, SCM port, scm_print_state *pstate)
-{
- size_t bit_len = BITVECTOR_LENGTH (vec);
- size_t word_len = (bit_len+31)/32;
- scm_t_uint32 *bits = BITVECTOR_BITS (vec);
- size_t i, j;
-
- scm_puts ("#*", port);
- for (i = 0; i < word_len; i++, bit_len -= 32)
- {
- scm_t_uint32 mask = 1;
- for (j = 0; j < 32 && j < bit_len; j++, mask <<= 1)
- scm_putc ((bits[i] & mask)? '1' : '0', port);
- }
-
- return 1;
-}
-
-static SCM
-bitvector_equalp (SCM vec1, SCM vec2)
-{
- size_t bit_len = BITVECTOR_LENGTH (vec1);
- size_t word_len = (bit_len + 31) / 32;
- scm_t_uint32 last_mask = ((scm_t_uint32)-1) >> (32*word_len - bit_len);
- scm_t_uint32 *bits1 = BITVECTOR_BITS (vec1);
- scm_t_uint32 *bits2 = BITVECTOR_BITS (vec2);
-
- /* compare lengths */
- if (BITVECTOR_LENGTH (vec2) != bit_len)
- return SCM_BOOL_F;
- /* avoid underflow in word_len-1 below. */
- if (bit_len == 0)
- return SCM_BOOL_T;
- /* compare full words */
- if (memcmp (bits1, bits2, sizeof (scm_t_uint32) * (word_len-1)))
- return SCM_BOOL_F;
- /* compare partial last words */
- if ((bits1[word_len-1] & last_mask) != (bits2[word_len-1] & last_mask))
- return SCM_BOOL_F;
- return SCM_BOOL_T;
-}
-
-int
-scm_is_bitvector (SCM vec)
-{
- return IS_BITVECTOR (vec);
-}
-
-SCM_DEFINE (scm_bitvector_p, "bitvector?", 1, 0, 0,
- (SCM obj),
- "Return @code{#t} when @var{obj} is a bitvector, else\n"
- "return @code{#f}.")
-#define FUNC_NAME s_scm_bitvector_p
-{
- return scm_from_bool (scm_is_bitvector (obj));
-}
-#undef FUNC_NAME
-
-SCM
-scm_c_make_bitvector (size_t len, SCM fill)
-{
- size_t word_len = (len + 31) / 32;
- scm_t_uint32 *bits;
- SCM res;
-
- bits = scm_gc_malloc (sizeof (scm_t_uint32) * word_len,
- "bitvector");
- SCM_NEWSMOB2 (res, scm_tc16_bitvector, bits, len);
-
- if (!SCM_UNBNDP (fill))
- scm_bitvector_fill_x (res, fill);
-
- return res;
-}
-
-SCM_DEFINE (scm_make_bitvector, "make-bitvector", 1, 1, 0,
- (SCM len, SCM fill),
- "Create a new bitvector of length @var{len} and\n"
- "optionally initialize all elements to @var{fill}.")
-#define FUNC_NAME s_scm_make_bitvector
-{
- return scm_c_make_bitvector (scm_to_size_t (len), fill);
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_bitvector, "bitvector", 0, 0, 1,
- (SCM bits),
- "Create a new bitvector with the arguments as elements.")
-#define FUNC_NAME s_scm_bitvector
-{
- return scm_list_to_bitvector (bits);
-}
-#undef FUNC_NAME
-
-size_t
-scm_c_bitvector_length (SCM vec)
-{
- scm_assert_smob_type (scm_tc16_bitvector, vec);
- return BITVECTOR_LENGTH (vec);
-}
-
-SCM_DEFINE (scm_bitvector_length, "bitvector-length", 1, 0, 0,
- (SCM vec),
- "Return the length of the bitvector @var{vec}.")
-#define FUNC_NAME s_scm_bitvector_length
-{
- return scm_from_size_t (scm_c_bitvector_length (vec));
-}
-#undef FUNC_NAME
-
-const scm_t_uint32 *
-scm_array_handle_bit_elements (scm_t_array_handle *h)
-{
- return scm_array_handle_bit_writable_elements (h);
-}
-
-scm_t_uint32 *
-scm_array_handle_bit_writable_elements (scm_t_array_handle *h)
-{
- SCM vec = h->array;
- if (SCM_I_ARRAYP (vec))
- vec = SCM_I_ARRAY_V (vec);
- if (IS_BITVECTOR (vec))
- return BITVECTOR_BITS (vec) + h->base/32;
- scm_wrong_type_arg_msg (NULL, 0, h->array, "bit array");
-}
-
-size_t
-scm_array_handle_bit_elements_offset (scm_t_array_handle *h)
-{
- return h->base % 32;
-}
-
-const scm_t_uint32 *
-scm_bitvector_elements (SCM vec,
- scm_t_array_handle *h,
- size_t *offp,
- size_t *lenp,
- ssize_t *incp)
-{
- return scm_bitvector_writable_elements (vec, h, offp, lenp, incp);
-}
-
-
-scm_t_uint32 *
-scm_bitvector_writable_elements (SCM vec,
- scm_t_array_handle *h,
- size_t *offp,
- size_t *lenp,
- ssize_t *incp)
-{
- scm_generalized_vector_get_handle (vec, h);
- if (offp)
- {
- scm_t_array_dim *dim = scm_array_handle_dims (h);
- *offp = scm_array_handle_bit_elements_offset (h);
- *lenp = dim->ubnd - dim->lbnd + 1;
- *incp = dim->inc;
- }
- return scm_array_handle_bit_writable_elements (h);
-}
-
-SCM
-scm_c_bitvector_ref (SCM vec, size_t idx)
-{
- scm_t_array_handle handle;
- const scm_t_uint32 *bits;
-
- if (IS_BITVECTOR (vec))
- {
- if (idx >= BITVECTOR_LENGTH (vec))
- scm_out_of_range (NULL, scm_from_size_t (idx));
- bits = BITVECTOR_BITS(vec);
- return scm_from_bool (bits[idx/32] & (1L << (idx%32)));
- }
- else
- {
- SCM res;
- size_t len, off;
- ssize_t inc;
-
- bits = scm_bitvector_elements (vec, &handle, &off, &len, &inc);
- if (idx >= len)
- scm_out_of_range (NULL, scm_from_size_t (idx));
- idx = idx*inc + off;
- res = scm_from_bool (bits[idx/32] & (1L << (idx%32)));
- scm_array_handle_release (&handle);
- return res;
- }
-}
-
-SCM_DEFINE (scm_bitvector_ref, "bitvector-ref", 2, 0, 0,
- (SCM vec, SCM idx),
- "Return the element at index @var{idx} of the bitvector\n"
- "@var{vec}.")
-#define FUNC_NAME s_scm_bitvector_ref
-{
- return scm_c_bitvector_ref (vec, scm_to_size_t (idx));
-}
-#undef FUNC_NAME
-
-void
-scm_c_bitvector_set_x (SCM vec, size_t idx, SCM val)
-{
- scm_t_array_handle handle;
- scm_t_uint32 *bits, mask;
-
- if (IS_BITVECTOR (vec))
- {
- if (idx >= BITVECTOR_LENGTH (vec))
- scm_out_of_range (NULL, scm_from_size_t (idx));
- bits = BITVECTOR_BITS(vec);
- }
- else
- {
- size_t len, off;
- ssize_t inc;
-
- bits = scm_bitvector_writable_elements (vec, &handle, &off, &len, &inc);
- if (idx >= len)
- scm_out_of_range (NULL, scm_from_size_t (idx));
- idx = idx*inc + off;
- }
-
- mask = 1L << (idx%32);
- if (scm_is_true (val))
- bits[idx/32] |= mask;
- else
- bits[idx/32] &= ~mask;
-
- if (!IS_BITVECTOR (vec))
- scm_array_handle_release (&handle);
-}
-
-SCM_DEFINE (scm_bitvector_set_x, "bitvector-set!", 3, 0, 0,
- (SCM vec, SCM idx, SCM val),
- "Set the element at index @var{idx} of the bitvector\n"
- "@var{vec} when @var{val} is true, else clear it.")
-#define FUNC_NAME s_scm_bitvector_set_x
-{
- scm_c_bitvector_set_x (vec, scm_to_size_t (idx), val);
- return SCM_UNSPECIFIED;
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_bitvector_fill_x, "bitvector-fill!", 2, 0, 0,
- (SCM vec, SCM val),
- "Set all elements of the bitvector\n"
- "@var{vec} when @var{val} is true, else clear them.")
-#define FUNC_NAME s_scm_bitvector_fill_x
-{
- scm_t_array_handle handle;
- size_t off, len;
- ssize_t inc;
- scm_t_uint32 *bits;
-
- bits = scm_bitvector_writable_elements (vec, &handle,
- &off, &len, &inc);
-
- if (off == 0 && inc == 1 && len > 0)
- {
- /* the usual case
- */
- size_t word_len = (len + 31) / 32;
- scm_t_uint32 last_mask = ((scm_t_uint32)-1) >> (32*word_len - len);
-
- if (scm_is_true (val))
- {
- memset (bits, 0xFF, sizeof(scm_t_uint32)*(word_len-1));
- bits[word_len-1] |= last_mask;
- }
- else
- {
- memset (bits, 0x00, sizeof(scm_t_uint32)*(word_len-1));
- bits[word_len-1] &= ~last_mask;
- }
- }
- else
- {
- size_t i;
- for (i = 0; i < len; i++)
- scm_array_handle_set (&handle, i*inc, val);
- }
-
- scm_array_handle_release (&handle);
-
- return SCM_UNSPECIFIED;
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_list_to_bitvector, "list->bitvector", 1, 0, 0,
- (SCM list),
- "Return a new bitvector initialized with the elements\n"
- "of @var{list}.")
-#define FUNC_NAME s_scm_list_to_bitvector
-{
- size_t bit_len = scm_to_size_t (scm_length (list));
- SCM vec = scm_c_make_bitvector (bit_len, SCM_UNDEFINED);
- size_t word_len = (bit_len+31)/32;
- scm_t_array_handle handle;
- scm_t_uint32 *bits = scm_bitvector_writable_elements (vec, &handle,
- NULL, NULL, NULL);
- size_t i, j;
-
- for (i = 0; i < word_len && scm_is_pair (list); i++, bit_len -= 32)
- {
- scm_t_uint32 mask = 1;
- bits[i] = 0;
- for (j = 0; j < 32 && j < bit_len;
- j++, mask <<= 1, list = SCM_CDR (list))
- if (scm_is_true (SCM_CAR (list)))
- bits[i] |= mask;
- }
-
- scm_array_handle_release (&handle);
-
- return vec;
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_bitvector_to_list, "bitvector->list", 1, 0, 0,
- (SCM vec),
- "Return a new list initialized with the elements\n"
- "of the bitvector @var{vec}.")
-#define FUNC_NAME s_scm_bitvector_to_list
-{
- scm_t_array_handle handle;
- size_t off, len;
- ssize_t inc;
- scm_t_uint32 *bits;
- SCM res = SCM_EOL;
-
- bits = scm_bitvector_writable_elements (vec, &handle,
- &off, &len, &inc);
-
- if (off == 0 && inc == 1)
- {
- /* the usual case
- */
- size_t word_len = (len + 31) / 32;
- size_t i, j;
-
- for (i = 0; i < word_len; i++, len -= 32)
- {
- scm_t_uint32 mask = 1;
- for (j = 0; j < 32 && j < len; j++, mask <<= 1)
- res = scm_cons ((bits[i] & mask)? SCM_BOOL_T : SCM_BOOL_F, res);
- }
- }
- else
- {
- size_t i;
- for (i = 0; i < len; i++)
- res = scm_cons (scm_array_handle_ref (&handle, i*inc), res);
- }
-
- scm_array_handle_release (&handle);
-
- return scm_reverse_x (res, SCM_EOL);
-}
-#undef FUNC_NAME
-
-/* From mmix-arith.w by Knuth.
-
- Here's a fun way to count the number of bits in a tetrabyte.
-
- [This classical trick is called the ``Gillies--Miller method for
- sideways addition'' in {\sl The Preparation of Programs for an
- Electronic Digital Computer\/} by Wilkes, Wheeler, and Gill, second
- edition (Reading, Mass.:\ Addison--Wesley, 1957), 191--193. Some of
- the tricks used here were suggested by Balbir Singh, Peter
- Rossmanith, and Stefan Schwoon.]
-*/
-
-static size_t
-count_ones (scm_t_uint32 x)
-{
- x=x-((x>>1)&0x55555555);
- x=(x&0x33333333)+((x>>2)&0x33333333);
- x=(x+(x>>4))&0x0f0f0f0f;
- x=x+(x>>8);
- return (x+(x>>16)) & 0xff;
-}
-
-SCM_DEFINE (scm_bit_count, "bit-count", 2, 0, 0,
- (SCM b, SCM bitvector),
- "Return the number of occurrences of the boolean @var{b} in\n"
- "@var{bitvector}.")
-#define FUNC_NAME s_scm_bit_count
-{
- scm_t_array_handle handle;
- size_t off, len;
- ssize_t inc;
- scm_t_uint32 *bits;
- int bit = scm_to_bool (b);
- size_t count = 0;
-
- bits = scm_bitvector_writable_elements (bitvector, &handle,
- &off, &len, &inc);
-
- if (off == 0 && inc == 1 && len > 0)
- {
- /* the usual case
- */
- size_t word_len = (len + 31) / 32;
- scm_t_uint32 last_mask = ((scm_t_uint32)-1) >> (32*word_len - len);
- size_t i;
-
- for (i = 0; i < word_len-1; i++)
- count += count_ones (bits[i]);
- count += count_ones (bits[i] & last_mask);
- }
- else
- {
- size_t i;
- for (i = 0; i < len; i++)
- if (scm_is_true (scm_array_handle_ref (&handle, i*inc)))
- count++;
- }
-
- scm_array_handle_release (&handle);
-
- return scm_from_size_t (bit? count : len-count);
-}
-#undef FUNC_NAME
-
-/* returns 32 for x == 0.
-*/
-static size_t
-find_first_one (scm_t_uint32 x)
-{
- size_t pos = 0;
- /* do a binary search in x. */
- if ((x & 0xFFFF) == 0)
- x >>= 16, pos += 16;
- if ((x & 0xFF) == 0)
- x >>= 8, pos += 8;
- if ((x & 0xF) == 0)
- x >>= 4, pos += 4;
- if ((x & 0x3) == 0)
- x >>= 2, pos += 2;
- if ((x & 0x1) == 0)
- pos += 1;
- return pos;
-}
-
-SCM_DEFINE (scm_bit_position, "bit-position", 3, 0, 0,
- (SCM item, SCM v, SCM k),
- "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
-{
- scm_t_array_handle handle;
- size_t off, len, first_bit;
- ssize_t inc;
- const scm_t_uint32 *bits;
- int bit = scm_to_bool (item);
- SCM res = SCM_BOOL_F;
-
- bits = scm_bitvector_elements (v, &handle, &off, &len, &inc);
- first_bit = scm_to_unsigned_integer (k, 0, len);
-
- if (off == 0 && inc == 1 && len > 0)
- {
- size_t i, word_len = (len + 31) / 32;
- scm_t_uint32 last_mask = ((scm_t_uint32)-1) >> (32*word_len - len);
- size_t first_word = first_bit / 32;
- scm_t_uint32 first_mask =
- ((scm_t_uint32)-1) << (first_bit - 32*first_word);
- scm_t_uint32 w;
-
- for (i = first_word; i < word_len; i++)
- {
- w = (bit? bits[i] : ~bits[i]);
- if (i == first_word)
- w &= first_mask;
- if (i == word_len-1)
- w &= last_mask;
- if (w)
- {
- res = scm_from_size_t (32*i + find_first_one (w));
- break;
- }
- }
- }
- else
- {
- size_t i;
- for (i = first_bit; i < len; i++)
- {
- SCM elt = scm_array_handle_ref (&handle, i*inc);
- if ((bit && scm_is_true (elt)) || (!bit && scm_is_false (elt)))
- {
- res = scm_from_size_t (i);
- break;
- }
- }
- }
-
- scm_array_handle_release (&handle);
-
- return res;
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_bit_set_star_x, "bit-set*!", 3, 0, 0,
- (SCM v, SCM kv, SCM obj),
- "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 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 #u32(5 2 7) #t)\n"
- "bv\n"
- "@result{} #*01100111\n"
- "@end example")
-#define FUNC_NAME s_scm_bit_set_star_x
-{
- scm_t_array_handle v_handle;
- size_t v_off, v_len;
- ssize_t v_inc;
- scm_t_uint32 *v_bits;
- int bit;
-
- /* Validate that OBJ is a boolean so this is done even if we don't
- need BIT.
- */
- bit = scm_to_bool (obj);
-
- v_bits = scm_bitvector_writable_elements (v, &v_handle,
- &v_off, &v_len, &v_inc);
-
- if (scm_is_bitvector (kv))
- {
- scm_t_array_handle kv_handle;
- size_t kv_off, kv_len;
- ssize_t kv_inc;
- const scm_t_uint32 *kv_bits;
-
- kv_bits = scm_bitvector_elements (v, &kv_handle,
- &kv_off, &kv_len, &kv_inc);
-
- if (v_len != kv_len)
- scm_misc_error (NULL,
- "bit vectors must have equal length",
- SCM_EOL);
-
- if (v_off == 0 && v_inc == 1 && kv_off == 0 && kv_inc == 1 && kv_len > 0)
- {
- size_t word_len = (kv_len + 31) / 32;
- scm_t_uint32 last_mask = ((scm_t_uint32)-1) >> (32*word_len - kv_len);
- size_t i;
-
- if (bit == 0)
- {
- for (i = 0; i < word_len-1; i++)
- v_bits[i] &= ~kv_bits[i];
- v_bits[i] &= ~(kv_bits[i] & last_mask);
- }
- else
- {
- for (i = 0; i < word_len-1; i++)
- v_bits[i] |= kv_bits[i];
- v_bits[i] |= kv_bits[i] & last_mask;
- }
- }
- else
- {
- size_t i;
- for (i = 0; i < kv_len; i++)
- if (scm_is_true (scm_array_handle_ref (&kv_handle, i*kv_inc)))
- scm_array_handle_set (&v_handle, i*v_inc, obj);
- }
-
- scm_array_handle_release (&kv_handle);
-
- }
- else if (scm_is_true (scm_u32vector_p (kv)))
- {
- scm_t_array_handle kv_handle;
- size_t i, kv_len;
- ssize_t kv_inc;
- const scm_t_uint32 *kv_elts;
-
- kv_elts = scm_u32vector_elements (kv, &kv_handle, &kv_len, &kv_inc);
- for (i = 0; i < kv_len; i++, kv_elts += kv_inc)
- scm_array_handle_set (&v_handle, (*kv_elts)*v_inc, obj);
-
- scm_array_handle_release (&kv_handle);
- }
- else
- scm_wrong_type_arg_msg (NULL, 0, kv, "bitvector or u32vector");
-
- scm_array_handle_release (&v_handle);
-
- return SCM_UNSPECIFIED;
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_bit_count_star, "bit-count*", 3, 0, 0,
- (SCM v, SCM kv, SCM obj),
- "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 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 #u32(7 0 4) #f) @result{} 2\n"
- "@end example")
-#define FUNC_NAME s_scm_bit_count_star
-{
- scm_t_array_handle v_handle;
- size_t v_off, v_len;
- ssize_t v_inc;
- const scm_t_uint32 *v_bits;
- size_t count = 0;
- int bit;
-
- /* Validate that OBJ is a boolean so this is done even if we don't
- need BIT.
- */
- bit = scm_to_bool (obj);
-
- v_bits = scm_bitvector_elements (v, &v_handle,
- &v_off, &v_len, &v_inc);
-
- if (scm_is_bitvector (kv))
- {
- scm_t_array_handle kv_handle;
- size_t kv_off, kv_len;
- ssize_t kv_inc;
- const scm_t_uint32 *kv_bits;
-
- kv_bits = scm_bitvector_elements (v, &kv_handle,
- &kv_off, &kv_len, &kv_inc);
-
- if (v_len != kv_len)
- scm_misc_error (NULL,
- "bit vectors must have equal length",
- SCM_EOL);
-
- if (v_off == 0 && v_inc == 1 && kv_off == 0 && kv_inc == 1 && kv_len > 0)
- {
- size_t i, word_len = (kv_len + 31) / 32;
- scm_t_uint32 last_mask = ((scm_t_uint32)-1) >> (32*word_len - kv_len);
- scm_t_uint32 xor_mask = bit? 0 : ((scm_t_uint32)-1);
-
- for (i = 0; i < word_len-1; i++)
- count += count_ones ((v_bits[i]^xor_mask) & kv_bits[i]);
- count += count_ones ((v_bits[i]^xor_mask) & kv_bits[i] & last_mask);
- }
- else
- {
- size_t i;
- for (i = 0; i < kv_len; i++)
- if (scm_is_true (scm_array_handle_ref (&kv_handle, i)))
- {
- SCM elt = scm_array_handle_ref (&v_handle, i*v_inc);
- if ((bit && scm_is_true (elt)) || (!bit && scm_is_false (elt)))
- count++;
- }
- }
-
- scm_array_handle_release (&kv_handle);
-
- }
- else if (scm_is_true (scm_u32vector_p (kv)))
- {
- scm_t_array_handle kv_handle;
- size_t i, kv_len;
- ssize_t kv_inc;
- const scm_t_uint32 *kv_elts;
-
- kv_elts = scm_u32vector_elements (kv, &kv_handle, &kv_len, &kv_inc);
- for (i = 0; i < kv_len; i++, kv_elts += kv_inc)
- {
- SCM elt = scm_array_handle_ref (&v_handle, (*kv_elts)*v_inc);
- if ((bit && scm_is_true (elt)) || (!bit && scm_is_false (elt)))
- count++;
- }
-
- scm_array_handle_release (&kv_handle);
- }
- else
- scm_wrong_type_arg_msg (NULL, 0, kv, "bitvector or u32vector");
-
- scm_array_handle_release (&v_handle);
-
- return scm_from_size_t (count);
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_bit_invert_x, "bit-invert!", 1, 0, 0,
- (SCM v),
- "Modify the bit vector @var{v} by replacing each element with\n"
- "its negation.")
-#define FUNC_NAME s_scm_bit_invert_x
-{
- scm_t_array_handle handle;
- size_t off, len;
- ssize_t inc;
- scm_t_uint32 *bits;
-
- bits = scm_bitvector_writable_elements (v, &handle, &off, &len, &inc);
-
- if (off == 0 && inc == 1 && len > 0)
- {
- size_t word_len = (len + 31) / 32;
- scm_t_uint32 last_mask = ((scm_t_uint32)-1) >> (32*word_len - len);
- size_t i;
-
- for (i = 0; i < word_len-1; i++)
- bits[i] = ~bits[i];
- bits[i] = bits[i] ^ last_mask;
- }
- else
- {
- size_t i;
- for (i = 0; i < len; i++)
- scm_array_handle_set (&handle, i*inc,
- scm_not (scm_array_handle_ref (&handle, i*inc)));
- }
-
- scm_array_handle_release (&handle);
-
- return SCM_UNSPECIFIED;
-}
-#undef FUNC_NAME
-
-
-SCM
-scm_istr2bve (SCM str)
-{
- scm_t_array_handle handle;
- size_t len = scm_i_string_length (str);
- SCM vec = scm_c_make_bitvector (len, SCM_UNDEFINED);
- SCM res = vec;
-
- scm_t_uint32 mask;
- size_t k, j;
- const char *c_str;
- scm_t_uint32 *data;
-
- data = scm_bitvector_writable_elements (vec, &handle, NULL, NULL, NULL);
- c_str = scm_i_string_chars (str);
-
- for (k = 0; k < (len + 31) / 32; k++)
- {
- data[k] = 0L;
- j = len - k * 32;
- if (j > 32)
- j = 32;
- for (mask = 1L; j--; mask <<= 1)
- switch (*c_str++)
- {
- case '0':
- break;
- case '1':
- data[k] |= mask;
- break;
- default:
- res = SCM_BOOL_F;
- goto exit;
- }
- }
-
- exit:
- scm_array_handle_release (&handle);
- scm_remember_upto_here_1 (str);
- return res;
-}
-
-
-
static SCM
ra2l (SCM ra, unsigned long base, unsigned long k)
{
@@ -2446,11 +1621,6 @@ scm_init_unif ()
scm_add_feature ("array");
- scm_tc16_bitvector = scm_make_smob_type ("bitvector", 0);
- scm_set_smob_free (scm_tc16_bitvector, bitvector_free);
- scm_set_smob_print (scm_tc16_bitvector, bitvector_print);
- scm_set_smob_equalp (scm_tc16_bitvector, bitvector_equalp);
-
init_type_creator_table ();
#include "libguile/unif.x"