mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-16 16:50:21 +02:00
Code Activity

bitvector exodus from unif.[ch]

Browse source 
* 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...
This commit is contained in:
Andy Wingo 2009-07-17 00:58:32 +02:00
parent c53c0893a3
commit cf39614240
11 changed files with 972 additions and 870 deletions
Download patch file Download diff file Expand all files Collapse all files

4
libguile/Makefile.am
View file

@ -113,6 +113,7 @@ libguile_la_SOURCES = \
async.c \ async.c \
backtrace.c \ backtrace.c \
boolean.c \ boolean.c \
bitvectors.c \
bytevectors.c \ bytevectors.c \
chars.c \ chars.c \
continuations.c \ continuations.c \
@ -222,6 +223,7 @@ DOT_X_FILES = \
async.x \ async.x \
backtrace.x \ backtrace.x \
boolean.x \ boolean.x \
bitvectors.x \
bytevectors.x \ bytevectors.x \
chars.x \ chars.x \
continuations.x \ continuations.x \
@ -319,6 +321,7 @@ DOT_DOC_FILES = \
async.doc \ async.doc \
backtrace.doc \ backtrace.doc \
boolean.doc \ boolean.doc \
bitvectors.doc \
bytevectors.doc \ bytevectors.doc \
chars.doc \ chars.doc \
continuations.doc \ continuations.doc \
@ -460,6 +463,7 @@ modinclude_HEADERS = \
async.h \ async.h \
backtrace.h \ backtrace.h \
boolean.h \ boolean.h \
bitvectors.h \
bytevectors.h \ bytevectors.h \
chars.h \ chars.h \
continuations.h \ continuations.h \

1
libguile/array-handle.c
View file

@ -31,6 +31,7 @@
#include "libguile/strings.h" #include "libguile/strings.h"
#include "libguile/vectors.h" #include "libguile/vectors.h"
#include "libguile/srfi-4.h" #include "libguile/srfi-4.h"
#include "libguile/bitvectors.h"
#include "libguile/bytevectors.h" #include "libguile/bytevectors.h"

1
libguile/array-map.c
View file

@ -35,6 +35,7 @@
#include "libguile/feature.h" #include "libguile/feature.h"
#include "libguile/root.h" #include "libguile/root.h"
#include "libguile/vectors.h" #include "libguile/vectors.h"
#include "libguile/bitvectors.h"
#include "libguile/srfi-4.h" #include "libguile/srfi-4.h"
#include "libguile/dynwind.h" #include "libguile/dynwind.h"

879
libguile/bitvectors.c Normal file
View file

@ -0,0 +1,879 @@
/* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004, 2005, 2006, 2009 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 License
* as published by the Free Software Foundation; either version 3 of
* the License, or (at your option) any later version.
*
* This library is distributed in the hope that it will be useful, but
* WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
* Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
* 02110-1301 USA
*/
#ifdef HAVE_CONFIG_H
# include <config.h>
#endif
#include <string.h>
#include "libguile/_scm.h"
#include "libguile/__scm.h"
#include "libguile/smob.h"
#include "libguile/strings.h"
#include "libguile/array-handle.h"
#include "libguile/bitvectors.h"
#include "libguile/unif.h"
#include "libguile/vectors.h"
#include "libguile/srfi-4.h"
/* Bit vectors. Would be nice if they were implemented on top of bytevectors,
* but alack, all we have is this crufty C.
*/
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;
}
void
scm_init_bitvectors ()
{
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);
#include "libguile/bitvectors.x"
}
/*
Local Variables:
c-file-style: "gnu"
End:
*/

81
libguile/bitvectors.h Normal file
View file

@ -0,0 +1,81 @@
/* classes: h_files */
#ifndef SCM_BITVECTORS_H
#define SCM_BITVECTORS_H
/* Copyright (C) 1995,1996,1997,1999,2000,2001, 2004, 2006, 2008, 2009 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 License
* as published by the Free Software Foundation; either version 3 of
* the License, or (at your option) any later version.
*
* This library is distributed in the hope that it will be useful, but
* WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
* Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
* 02110-1301 USA
*/
#include "libguile/__scm.h"
#include "libguile/array-handle.h"
/* Bitvectors. Exciting stuff, maybe!
*/
/** Bit vectors */
SCM_API SCM scm_bitvector_p (SCM vec);
SCM_API SCM scm_bitvector (SCM bits);
SCM_API SCM scm_make_bitvector (SCM len, SCM fill);
SCM_API SCM scm_bitvector_length (SCM vec);
SCM_API SCM scm_bitvector_ref (SCM vec, SCM idx);
SCM_API SCM scm_bitvector_set_x (SCM vec, SCM idx, SCM val);
SCM_API SCM scm_list_to_bitvector (SCM list);
SCM_API SCM scm_bitvector_to_list (SCM vec);
SCM_API SCM scm_bitvector_fill_x (SCM vec, SCM val);
SCM_API SCM scm_bit_count (SCM item, SCM seq);
SCM_API SCM scm_bit_position (SCM item, SCM v, SCM k);
SCM_API SCM scm_bit_set_star_x (SCM v, SCM kv, SCM obj);
SCM_API SCM scm_bit_count_star (SCM v, SCM kv, SCM obj);
SCM_API SCM scm_bit_invert_x (SCM v);
SCM_API SCM scm_istr2bve (SCM str);
SCM_API int scm_is_bitvector (SCM obj);
SCM_API SCM scm_c_make_bitvector (size_t len, SCM fill);
SCM_API size_t scm_c_bitvector_length (SCM vec);
SCM_API SCM scm_c_bitvector_ref (SCM vec, size_t idx);
SCM_API void scm_c_bitvector_set_x (SCM vec, size_t idx, SCM val);
SCM_API const scm_t_uint32 *scm_array_handle_bit_elements (scm_t_array_handle *h);
SCM_API scm_t_uint32 *scm_array_handle_bit_writable_elements (scm_t_array_handle *h);
SCM_API size_t scm_array_handle_bit_elements_offset (scm_t_array_handle *h);
SCM_API const scm_t_uint32 *scm_bitvector_elements (SCM vec,
scm_t_array_handle *h,
size_t *offp,
size_t *lenp,
ssize_t *incp);
SCM_API scm_t_uint32 *scm_bitvector_writable_elements (SCM vec,
scm_t_array_handle *h,
size_t *offp,
size_t *lenp,
ssize_t *incp);
SCM_INTERNAL void scm_init_bitvectors (void);
#endif /* SCM_BITVECTORS_H */
/*
Local Variables:
c-file-style: "gnu"
End:
*/

2
libguile/init.c
View file

@ -37,6 +37,7 @@
#include "libguile/arbiters.h" #include "libguile/arbiters.h"
#include "libguile/async.h" #include "libguile/async.h"
#include "libguile/backtrace.h" #include "libguile/backtrace.h"
#include "libguile/bitvectors.h"
#include "libguile/boolean.h" #include "libguile/boolean.h"
#include "libguile/bytevectors.h" #include "libguile/bytevectors.h"
#include "libguile/chars.h" #include "libguile/chars.h"
@ -541,6 +542,7 @@ scm_i_init_guile (SCM_STACKITEM *base)
scm_init_debug (); /* Requires macro smobs */ scm_init_debug (); /* Requires macro smobs */
scm_init_random (); scm_init_random ();
scm_init_array_handle (); scm_init_array_handle ();
scm_init_bitvectors ();
scm_init_array_map (); scm_init_array_map ();
scm_init_unif (); scm_init_unif ();
scm_init_simpos (); scm_init_simpos ();

1
libguile/read.c
View file

@ -33,6 +33,7 @@
#include "libguile/chars.h" #include "libguile/chars.h"
#include "libguile/eval.h" #include "libguile/eval.h"
#include "libguile/unif.h" #include "libguile/unif.h"
#include "libguile/bitvectors.h"
#include "libguile/keywords.h" #include "libguile/keywords.h"
#include "libguile/alist.h" #include "libguile/alist.h"
#include "libguile/srcprop.h" #include "libguile/srcprop.h"

1
libguile/srfi-4.c
View file

@ -29,6 +29,7 @@
#include "libguile/_scm.h" #include "libguile/_scm.h"
#include "libguile/__scm.h" #include "libguile/__scm.h"
#include "libguile/srfi-4.h" #include "libguile/srfi-4.h"
#include "libguile/bitvectors.h"
#include "libguile/bytevectors.h" #include "libguile/bytevectors.h"
#include "libguile/error.h" #include "libguile/error.h"
#include "libguile/read.h" #include "libguile/read.h"

832
libguile/unif.c
View file

@ -47,6 +47,7 @@
#include "libguile/srfi-13.h" #include "libguile/srfi-13.h"
#include "libguile/srfi-4.h" #include "libguile/srfi-4.h"
#include "libguile/vectors.h" #include "libguile/vectors.h"
#include "libguile/bitvectors.h"
#include "libguile/bytevectors.h" #include "libguile/bytevectors.h"
#include "libguile/list.h" #include "libguile/list.h"
#include "libguile/dynwind.h" #include "libguile/dynwind.h"
@ -1122,832 +1123,6 @@ SCM_DEFINE (scm_uniform_array_write, "uniform-array-write", 1, 3, 0,
#undef FUNC_NAME #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 static SCM
ra2l (SCM ra, unsigned long base, unsigned long k) ra2l (SCM ra, unsigned long base, unsigned long k)
{ {
@ -2446,11 +1621,6 @@ scm_init_unif ()
scm_add_feature ("array"); 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 (); init_type_creator_table ();
#include "libguile/unif.x" #include "libguile/unif.x"

39
libguile/unif.h
View file

@ -70,45 +70,6 @@ SCM_API int scm_is_typed_array (SCM obj, SCM type);
SCM_API SCM scm_ra2contig (SCM ra, int copy); SCM_API SCM scm_ra2contig (SCM ra, int copy);
/** Bit vectors */
SCM_API SCM scm_bitvector_p (SCM vec);
SCM_API SCM scm_bitvector (SCM bits);
SCM_API SCM scm_make_bitvector (SCM len, SCM fill);
SCM_API SCM scm_bitvector_length (SCM vec);
SCM_API SCM scm_bitvector_ref (SCM vec, SCM idx);
SCM_API SCM scm_bitvector_set_x (SCM vec, SCM idx, SCM val);
SCM_API SCM scm_list_to_bitvector (SCM list);
SCM_API SCM scm_bitvector_to_list (SCM vec);
SCM_API SCM scm_bitvector_fill_x (SCM vec, SCM val);
SCM_API SCM scm_bit_count (SCM item, SCM seq);
SCM_API SCM scm_bit_position (SCM item, SCM v, SCM k);
SCM_API SCM scm_bit_set_star_x (SCM v, SCM kv, SCM obj);
SCM_API SCM scm_bit_count_star (SCM v, SCM kv, SCM obj);
SCM_API SCM scm_bit_invert_x (SCM v);
SCM_API SCM scm_istr2bve (SCM str);
SCM_API int scm_is_bitvector (SCM obj);
SCM_API SCM scm_c_make_bitvector (size_t len, SCM fill);
SCM_API size_t scm_c_bitvector_length (SCM vec);
SCM_API SCM scm_c_bitvector_ref (SCM vec, size_t idx);
SCM_API void scm_c_bitvector_set_x (SCM vec, size_t idx, SCM val);
SCM_API const scm_t_uint32 *scm_array_handle_bit_elements (scm_t_array_handle *h);
SCM_API scm_t_uint32 *scm_array_handle_bit_writable_elements (scm_t_array_handle *h);
SCM_API size_t scm_array_handle_bit_elements_offset (scm_t_array_handle *h);
SCM_API const scm_t_uint32 *scm_bitvector_elements (SCM vec,
scm_t_array_handle *h,
size_t *offp,
size_t *lenp,
ssize_t *incp);
SCM_API scm_t_uint32 *scm_bitvector_writable_elements (SCM vec,
scm_t_array_handle *h,
size_t *offp,
size_t *lenp,
ssize_t *incp);
/* internal. */ /* internal. */
typedef struct scm_i_t_array typedef struct scm_i_t_array

1
libguile/vectors.c
View file

@ -31,6 +31,7 @@
#include "libguile/validate.h" #include "libguile/validate.h"
#include "libguile/vectors.h" #include "libguile/vectors.h"
#include "libguile/unif.h" #include "libguile/unif.h"
#include "libguile/bitvectors.h"
#include "libguile/bytevectors.h" #include "libguile/bytevectors.h"
#include "libguile/array-map.h" #include "libguile/array-map.h"
#include "libguile/srfi-4.h" #include "libguile/srfi-4.h"