guile/libguile/bitvectors.c

/* Copyright 1995-1998,2000-2006,2009-2014,2018,2020,2025
     Free Software Foundation, Inc.

   This file is part of Guile.

   Guile 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.

   Guile 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 Guile.  If not, see
   <https://www.gnu.org/licenses/>.  */




#ifdef HAVE_CONFIG_H
#  include <config.h>
#endif

#include <string.h>

#include "array-handle.h"
#include "arrays.h"
#include "boolean.h"
#include "deprecation.h"
#include "generalized-vectors.h"
#include "gsubr.h"
#include "list.h"
#include "numbers.h"
#include "pairs.h"
#include "ports.h"
#include "srfi-4.h"

#include "bitvectors.h"


struct scm_bitvector
{
  scm_t_bits tag_and_flags;
  size_t length;
  scm_t_bits bits[];
};

#define SCM_F_BITVECTOR_IMMUTABLE (0x80)

/* To do in Guile 3.1.x:
    - Replace primitives that operator on bitvectors but don't have
      bitvector- prefix.
    - Add Scheme compiler support for bitvector primitives.  */
static inline int
is_bitvector (SCM obj)
{
  return SCM_HAS_TYP7 ((obj), scm_tc7_bitvector);
}

static inline int
is_mutable_bitvector (SCM obj)
{
  return SCM_NIMP (obj) &&
    ((SCM_CELL_TYPE (obj) & (0x7f | SCM_F_BITVECTOR_IMMUTABLE))
     == scm_tc7_bitvector);
}

static inline struct scm_bitvector*
to_bitvector (SCM obj)
{
  if (!is_bitvector (obj))
    abort ();
  return (struct scm_bitvector*) SCM_UNPACK_POINTER (obj);
}

static inline SCM
from_bitvector (struct scm_bitvector *bv)
{
  return SCM_PACK_POINTER (bv);
}

static inline size_t
bitvector_length (struct scm_bitvector *bv)
{
  return bv->length;
}

static inline scm_t_bits*
bitvector_bits (struct scm_bitvector *bv)
{
  return bv->bits;
}

#define VALIDATE_BITVECTOR(_pos, _obj)                                  \
  SCM_ASSERT_TYPE (is_bitvector (_obj), (_obj), (_pos), FUNC_NAME,      \
                   "bitvector")
#define VALIDATE_MUTABLE_BITVECTOR(_pos, _obj)                          \
  SCM_ASSERT_TYPE (is_mutable_bitvector (_obj), (_obj), (_pos),         \
                   FUNC_NAME, "mutable bitvector")

scm_t_bits *
scm_i_bitvector_bits (SCM vec)
{
  return bitvector_bits (to_bitvector (vec));
}

int
scm_i_is_mutable_bitvector (SCM vec)
{
  return is_mutable_bitvector (vec);
}

static const size_t bits_per_word = sizeof (scm_t_bits) * 8;

static const size_t
bit_count_to_word_count (size_t sz)
{
  return (sz + bits_per_word - 1) / bits_per_word;
}

static const size_t
bitvector_word_length (struct scm_bitvector *bv)
{
  return bit_count_to_word_count (bv->length);
}

static const scm_t_bits
bitvector_last_mask (struct scm_bitvector *bv)
{
  size_t rem = bv->length % bits_per_word;
  return rem ? (((scm_t_bits) 1) << rem) - 1 : -1;
}

int
scm_i_print_bitvector (SCM vec, SCM port, scm_print_state *pstate)
{
  struct scm_bitvector *bv = to_bitvector (vec);
  size_t bit_len = bitvector_length (bv);
  size_t word_len = bitvector_word_length (bv);
  scm_t_bits *bits = bitvector_bits (bv);
  size_t i, j;

  scm_puts ("#*", port);
  for (i = 0; i < word_len; i++, bit_len -= bits_per_word)
    for (j = 0; j < bits_per_word && j < bit_len; j++)
      scm_putc ((bits[i] & (((scm_t_bits) 1) << j)) ? '1' : '0', port);
    
  return 1;
}

SCM
scm_i_bitvector_equal_p (SCM vec1, SCM vec2)
{
  struct scm_bitvector *bv1 = to_bitvector (vec1);
  struct scm_bitvector *bv2 = to_bitvector (vec2);
  size_t bit_len = bitvector_length (bv1);
  size_t word_len = bitvector_word_length (bv1);
  scm_t_bits last_mask = bitvector_last_mask (bv1);
  scm_t_bits *bits1 = bitvector_bits (bv1);
  scm_t_bits *bits2 = bitvector_bits (bv2);

  /* compare lengths */
  if (bitvector_length (bv2) != 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_bits) * (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_STATIC (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_bitvector_p
{
  return scm_from_bool (scm_is_bitvector (obj));
}
#undef FUNC_NAME

static struct scm_bitvector *
make_bitvector (size_t len, int fill)
{
  size_t word_len = bit_count_to_word_count (len);
  struct scm_bitvector *bv;

  bv = scm_gc_malloc_pointerless (sizeof (struct scm_bitvector)
                                  + sizeof (scm_t_bits) * word_len,
                                  "bitvector");

  bv->tag_and_flags = scm_tc7_bitvector;
  bv->length = len;
  if (fill)
    memset (bv->bits, -1, word_len * sizeof (scm_t_bits));

  return bv;
}

SCM
scm_c_make_bitvector (size_t len, SCM fill)
{
  int c_fill = !SCM_UNBNDP (fill) && scm_is_true (fill);
  return from_bitvector (make_bitvector (len, c_fill));
}

SCM_DEFINE_STATIC (make_scm_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_make_bitvector
{
  return scm_c_make_bitvector (scm_to_size_t (len), fill);
}
#undef FUNC_NAME

SCM_DEFINE_STATIC (bitvector, "bitvector", 0, 0, 1,
                   (SCM bits),
                   "Create a new bitvector with the arguments as elements.")
#define FUNC_NAME s_bitvector
{
  return scm_list_to_bitvector (bits);
}
#undef FUNC_NAME

size_t
scm_c_bitvector_length (SCM vec)
{
  if (!is_bitvector (vec))
    scm_wrong_type_arg_msg (NULL, 0, vec, "bitvector");
  return bitvector_length (to_bitvector (vec));
}

SCM_DEFINE_STATIC (scm_bitvector_length, "bitvector-length", 1, 0, 0,
                   (SCM vec),
                   "Return the length of the bitvector @var{vec}.")
#define FUNC_NAME s_bitvector_length
{
  return scm_from_size_t (scm_c_bitvector_length (vec));
}
#undef FUNC_NAME

const scm_t_bits *
scm_array_handle_bit_elements (scm_t_array_handle *h)
{
  if (h->element_type != SCM_ARRAY_ELEMENT_TYPE_BIT)
    scm_wrong_type_arg_msg (NULL, 0, h->array, "bit array");
  return ((const scm_t_bits *) h->elements) + h->base/bits_per_word;
}

scm_t_bits *
scm_array_handle_bit_writable_elements (scm_t_array_handle *h)
{
  if (h->writable_elements != h->elements)
    scm_wrong_type_arg_msg (NULL, 0, h->array, "mutable bit array");
  return (scm_t_bits *) scm_array_handle_bit_elements (h);
}

size_t
scm_array_handle_bit_elements_offset (scm_t_array_handle *h)
{
  return h->base % bits_per_word;
}

const scm_t_bits *
scm_bitvector_elements (SCM vec,
			scm_t_array_handle *h,
			size_t *offp,
			size_t *lenp,
			ssize_t *incp)
{
  scm_array_get_handle (vec, h);
  if (1 != scm_array_handle_rank (h))
    {
      scm_array_handle_release (h);
      scm_wrong_type_arg_msg (NULL, 0, vec, "rank 1 bit array");
    }
  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_elements (h);
}


scm_t_bits *
scm_bitvector_writable_elements (SCM vec,
				 scm_t_array_handle *h,
				 size_t *offp,
				 size_t *lenp,
				 ssize_t *incp)
{
  const scm_t_bits *ret = scm_bitvector_elements (vec, h, offp, lenp, incp);

  if (h->writable_elements != h->elements)
    scm_wrong_type_arg_msg (NULL, 0, h->array, "mutable bit array");

  return (scm_t_bits *) ret;
}

int
scm_c_bitvector_bit_is_set (SCM vec, size_t idx)
#define FUNC_NAME "bitvector-bit-set?"
{
  VALIDATE_BITVECTOR (1, vec);
  struct scm_bitvector *bv = to_bitvector (vec);
  if (idx >= bitvector_length (bv))
    SCM_OUT_OF_RANGE (2, scm_from_size_t (idx));

  const scm_t_bits *bits = bitvector_bits (bv);
  return (bits[idx/bits_per_word] & (1L << (idx%bits_per_word))) ? 1 : 0;
}
#undef FUNC_NAME

int
scm_c_bitvector_bit_is_clear (SCM vec, size_t idx)
{
  return !scm_c_bitvector_bit_is_set (vec, idx);
}

SCM_DEFINE_STATIC (scm_bitvector_bit_set_p, "bitvector-bit-set?", 2, 0, 0,
                   (SCM vec, SCM idx),
                   "Return @code{#t} if the bit at index @var{idx} of the \n"
                   "bitvector @var{vec} is set, or @code{#f} otherwise.")
#define FUNC_NAME s_scm_bitvector_bit_set_p
{
  return scm_from_bool (scm_c_bitvector_bit_is_set (vec, scm_to_size_t (idx)));
}
#undef FUNC_NAME

SCM_DEFINE_STATIC (scm_bitvector_bit_clear_p, "bitvector-bit-clear?", 2, 0, 0,
                   (SCM vec, SCM idx),
                   "Return @code{#t} if the bit at index @var{idx} of the \n"
                   "bitvector @var{vec} is clear (unset), or @code{#f} otherwise.")
#define FUNC_NAME s_scm_bitvector_bit_clear_p
{
  return scm_from_bool
    (scm_c_bitvector_bit_is_clear (vec, scm_to_size_t (idx)));
}
#undef FUNC_NAME

void
scm_c_bitvector_set_bit_x (SCM vec, size_t idx)
#define FUNC_NAME "bitvector-set-bit!"
{
  VALIDATE_MUTABLE_BITVECTOR (1, vec);
  struct scm_bitvector *bv = to_bitvector (vec);
  if (idx >= bitvector_length (bv))
    SCM_OUT_OF_RANGE (2, scm_from_size_t (idx));

  scm_t_bits *bits = bitvector_bits (bv);
  scm_t_bits mask = 1LL << (idx%bits_per_word);
  bits[idx/bits_per_word] |= mask;
}
#undef FUNC_NAME

void
scm_c_bitvector_clear_bit_x (SCM vec, size_t idx)
#define FUNC_NAME "bitvector-clear-bit!"
{
  VALIDATE_MUTABLE_BITVECTOR (1, vec);
  struct scm_bitvector *bv = to_bitvector (vec);
  if (idx >= bitvector_length (bv))
    SCM_OUT_OF_RANGE (2, scm_from_size_t (idx));

  scm_t_bits *bits = bitvector_bits (bv);
  scm_t_bits mask = 1L << (idx%bits_per_word);
  bits[idx/bits_per_word] &= ~mask;
}
#undef FUNC_NAME

SCM_DEFINE_STATIC (scm_bitvector_set_bit_x, "bitvector-set-bit!", 2, 0, 0,
                   (SCM vec, SCM idx),
                   "Set the element at index @var{idx} of the bitvector\n"
                   "@var{vec}.")
#define FUNC_NAME s_scm_bitvector_set_bit_x
{
  scm_c_bitvector_set_bit_x (vec, scm_to_size_t (idx));
  return SCM_UNSPECIFIED;
}
#undef FUNC_NAME

SCM_DEFINE_STATIC (scm_bitvector_clear_bit_x, "bitvector-clear-bit!", 2, 0, 0,
                   (SCM vec, SCM idx),
                   "Clear the element at index @var{idx} of the bitvector\n"
                   "@var{vec}.")
#define FUNC_NAME s_scm_bitvector_set_bit_x
{
  scm_c_bitvector_clear_bit_x (vec, scm_to_size_t (idx));
  return SCM_UNSPECIFIED;
}
#undef FUNC_NAME

void
scm_c_bitvector_set_all_bits_x (SCM vec)
#define FUNC_NAME "bitvector-set-all-bits!"
{
  VALIDATE_MUTABLE_BITVECTOR (1, vec);
  struct scm_bitvector *bv = to_bitvector (vec);
  size_t len = bitvector_length (bv);

  if (len > 0)
    {
      scm_t_bits *bits = bitvector_bits (bv);
      size_t word_len = bitvector_word_length (bv);
      scm_t_bits last_mask = bitvector_last_mask (bv);

      memset (bits, 0xFF, sizeof(scm_t_bits)*(word_len-1));
      bits[word_len-1] |= last_mask;
    }
}
#undef FUNC_NAME

void
scm_c_bitvector_clear_all_bits_x (SCM vec)
#define FUNC_NAME "bitvector-clear-all-bits!"
{
  VALIDATE_MUTABLE_BITVECTOR (1, vec);
  struct scm_bitvector *bv = to_bitvector (vec);
  size_t len = bitvector_length (bv);

  if (len > 0)
    {
      scm_t_bits *bits = bitvector_bits (bv);
      size_t word_len = bitvector_word_length (bv);
      scm_t_bits last_mask = bitvector_last_mask (bv);

      memset (bits, 0x00, sizeof(scm_t_bits)*(word_len-1));
      bits[word_len-1] &= ~last_mask;
    }
}
#undef FUNC_NAME

SCM_DEFINE_STATIC (scm_bitvector_set_all_bits_x,
                   "bitvector-set-all-bits!", 1, 0, 0, (SCM vec),
                   "Set all elements of the bitvector @var{vec}.")
{
  scm_c_bitvector_set_all_bits_x (vec);
  return SCM_UNSPECIFIED;
}

SCM_DEFINE_STATIC (scm_bitvector_clear_all_bits_x,
                   "bitvector-clear-all-bits!", 1, 0, 0, (SCM vec),
                   "Clear all elements of the bitvector @var{vec}.")
{
  scm_c_bitvector_clear_all_bits_x (vec);
  return SCM_UNSPECIFIED;
}

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));
  struct scm_bitvector *bv = make_bitvector (bit_len, 0);
  size_t word_len = bitvector_word_length (bv);
  scm_t_bits *bits = bitvector_bits (bv);
  size_t i, j;

  for (i = 0; i < word_len && scm_is_pair (list); i++, bit_len -= bits_per_word)
    {
      scm_t_bits word = 0;
      for (j = 0; j < bits_per_word && j < bit_len; j++, list = SCM_CDR (list))
	if (scm_is_true (SCM_CAR (list)))
	  word |= ((scm_t_bits) 1) << j;
      bits[i] = word;
    }

  return from_bitvector (bv);
}
#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 res = SCM_EOL;

  VALIDATE_BITVECTOR (1, vec);

  struct scm_bitvector *bv = to_bitvector (vec);
  const scm_t_bits *bits = bitvector_bits (bv);
  size_t len = bitvector_length (bv);
  size_t word_len = bitvector_word_length (bv);

  for (size_t i = 0; i < word_len; i++, len -= bits_per_word)
    for (size_t j = 0; j < bits_per_word && j < len; j++)
      res = scm_cons (scm_from_bool (bits[i] & (((scm_t_bits)1)<<j)), res);

  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_bits x)
{
  if (sizeof (x) <= sizeof (int))
    return __builtin_popcount((int) x);
  else if (sizeof (x) <= sizeof (long))
    return __builtin_popcountl((long) x);
  else
    return __builtin_popcountll((long long) x);
}

size_t
scm_c_bitvector_count (SCM vec)
#define FUNC_NAME "bitvector-count"
{
  VALIDATE_BITVECTOR (1, vec);

  struct scm_bitvector *bv = to_bitvector (vec);
  size_t len = bitvector_length (bv);

  if (len == 0)
    return 0;

  const scm_t_bits *bits = bitvector_bits (bv);
  size_t count = 0;

  size_t word_len = bitvector_word_length (bv);
  size_t i;
  for (i = 0; i < word_len-1; i++)
    count += count_ones (bits[i]);
  count += count_ones (bits[i] & bitvector_last_mask (bv));

  return count;
}
#undef FUNC_NAME

SCM_DEFINE_STATIC (scm_bitvector_count, "bitvector-count", 1, 0, 0,
                   (SCM bitvector),
                   "Return the number of set bits in @var{bitvector}.")
#define FUNC_NAME s_scm_bitvector_count
{
  return scm_from_size_t (scm_c_bitvector_count (bitvector));
}
#undef FUNC_NAME

/* returns bits_ for x == 0. 
*/
static size_t
find_first_one (scm_t_bits x)
{
  if (!x) return bits_per_word;
  
  if (sizeof (x) <= sizeof (int))
    return __builtin_ctz((int) x);
  else if (sizeof (x) <= sizeof (long))
    return __builtin_ctzl((long) x);
  else
    return __builtin_ctzll((long long) x);
}

SCM_DEFINE (scm_bitvector_position, "bitvector-position", 2, 1, 0,
            (SCM v, SCM bit, SCM start),
	    "Return the index of the first occurrence of @var{bit} in bit\n"
	    "vector @var{v}, starting from @var{start} (or zero if not given)\n."
	    "If there is no @var{bit} entry between @var{start} and the end of\n"
	    "@var{v}, then return @code{#f}.  For example,\n"
	    "\n"
	    "@example\n"
	    "(bitvector-position #*000101 #t)  @result{} 3\n"
	    "(bitvector-position #*0001111 #f 3) @result{} #f\n"
	    "@end example")
#define FUNC_NAME s_scm_bitvector_position
{
  VALIDATE_BITVECTOR (1, v);

  struct scm_bitvector *bv = to_bitvector (v);
  size_t len = bitvector_length (bv);
  int c_bit = scm_to_bool (bit);
  size_t first_bit =
    SCM_UNBNDP (start) ? 0 : scm_to_unsigned_integer (start, 0, len);
  
  if (first_bit == len)
    return SCM_BOOL_F;

  const scm_t_bits *bits = bitvector_bits (bv);
  size_t word_len = bitvector_word_length (bv);
  scm_t_bits last_mask = bitvector_last_mask (bv);
  size_t first_word = first_bit / bits_per_word;
  scm_t_bits first_mask =
    ((scm_t_bits)-1) << (first_bit - bits_per_word*first_word);
      
  for (size_t i = first_word; i < word_len; i++)
    {
      scm_t_bits w = c_bit ? bits[i] : ~bits[i];
      if (i == first_word)
        w &= first_mask;
      if (i == word_len-1)
        w &= last_mask;
      if (w)
        return scm_from_size_t (bits_per_word*i + find_first_one (w));
    }

  return SCM_BOOL_F;
}
#undef FUNC_NAME

void
scm_c_bitvector_set_bits_x (SCM v, SCM bits)
#define FUNC_NAME "bitvector-set-bits!"
{
  VALIDATE_MUTABLE_BITVECTOR (1, v);
  VALIDATE_BITVECTOR (2, bits);
  struct scm_bitvector *bv = to_bitvector (v);
  struct scm_bitvector *bitsv = to_bitvector (bits);
  size_t v_len = bitvector_length (bv);
  scm_t_bits *v_bits = bitvector_bits (bv);
  size_t kv_len = bitvector_length (bitsv);
  const scm_t_bits *kv_bits = bitvector_bits (bitsv);

  if (v_len < kv_len)
    scm_misc_error (NULL,
                    "selection bitvector longer than target bitvector",
                    SCM_EOL);
      
  if (kv_len > 0)
    {
      size_t word_len = bitvector_word_length (bitsv);
      scm_t_bits last_mask = bitvector_last_mask (bitsv);
      size_t i;
      for (i = 0; i < word_len-1; i++)
        v_bits[i] |= kv_bits[i];
      v_bits[i] |= kv_bits[i] & last_mask;
    }
}
#undef FUNC_NAME

void
scm_c_bitvector_clear_bits_x (SCM v, SCM bits)
#define FUNC_NAME "bitvector-clear-bits!"
{
  VALIDATE_MUTABLE_BITVECTOR (1, v);
  VALIDATE_BITVECTOR (2, bits);
  struct scm_bitvector *bv = to_bitvector (v);
  struct scm_bitvector *bitsv = to_bitvector (bits);
  size_t v_len = bitvector_length (bv);
  scm_t_bits *v_bits = bitvector_bits (bv);
  size_t kv_len = bitvector_length (bitsv);
  const scm_t_bits *kv_bits = bitvector_bits (bitsv);

  if (v_len < kv_len)
    scm_misc_error (NULL,
                    "selection bitvector longer than target bitvector",
                    SCM_EOL);
      
  if (kv_len > 0)
    {
      size_t word_len = bitvector_word_length (bitsv);
      scm_t_bits last_mask = bitvector_last_mask (bitsv);
      size_t i;

      for (i = 0; i < word_len-1; i++)
        v_bits[i] &= ~kv_bits[i];
      v_bits[i] &= ~(kv_bits[i] & last_mask);
    }
}
#undef FUNC_NAME

SCM_DEFINE_STATIC (scm_bitvector_set_bits_x, "bitvector-set-bits!", 2, 0, 0,
                   (SCM v, SCM bits),
                   "Update the bitvector @var{v} in place by performing a\n"
                   "logical OR of its bits with those of @var{bits}.\n"
                   "For example:\n"
                   "\n"
                   "@example\n"
                   "(define bv (bitvector-copy #*11000010))\n"
                   "(bitvector-set-bits! bv #*10010001)\n"
                   "bv\n"
                   "@result{} #*11010011\n"
                   "@end example")
#define FUNC_NAME s_scm_bitvector_set_bits_x
{
  scm_c_bitvector_set_bits_x (v, bits);
  return SCM_UNSPECIFIED;
}
#undef FUNC_NAME

SCM_DEFINE_STATIC (scm_bitvector_clear_bits_x, "bitvector-clear-bits!", 2, 0, 0,
                   (SCM v, SCM bits),
                   "Update the bitvector @var{v} in place by performing a\n"
                   "logical AND of its bits with the complement of those of\n"
                   "@var{bits}.  For example:\n"
                   "\n"
                   "@example\n"
                   "(define bv (bitvector-copy #*11000010))\n"
                   "(bitvector-clear-bits! bv #*10010001)\n"
                   "bv\n"
                   "@result{} #*01000010\n"
                   "@end example")
#define FUNC_NAME s_scm_bitvector_clear_bits_x
{
  scm_c_bitvector_clear_bits_x (v, bits);
  return SCM_UNSPECIFIED;
}
#undef FUNC_NAME

SCM_DEFINE (scm_bitvector_copy, "bitvector-copy", 1, 2, 0,
	    (SCM vec, SCM start, SCM end),
            "Returns a freshly allocated bitvector containing the elements\n"
            "of bitvector @var{vec} between @var{start} and @var{end}.\n\n"
            "@var{start} defaults to 0 and @var{end} defaults to the\n"
            "length of @var{vec}.")
#define FUNC_NAME s_scm_bitvector_copy
{
  VALIDATE_BITVECTOR (1, vec);
  struct scm_bitvector *bv = to_bitvector (vec);

  /* cf scm_vector_copy */

  size_t cstart = 0, cend = bitvector_length (bv);
  if (!SCM_UNBNDP (start))
    {
      cstart = scm_to_size_t (start);
      SCM_ASSERT_RANGE (SCM_ARG2, start, cstart<=cend);

      if (!SCM_UNBNDP (end))
        {
          size_t e = scm_to_size_t (end);
          SCM_ASSERT_RANGE (SCM_ARG3, end, e>=cstart && e<=cend);
          cend = e;
        }
    }

  size_t len = cend-cstart;
  struct scm_bitvector *result = make_bitvector (len, 0);
  const scm_t_bits *kv_bits = bitvector_bits (bv);
  scm_t_bits *v_bits = bitvector_bits (result);

  if (len > 0)
    {
      size_t wlen = bit_count_to_word_count (len);
      size_t wshift = cstart / bits_per_word;
      size_t bshift = cstart % bits_per_word;
      if (0 == bshift)
        memcpy (v_bits, kv_bits + wshift, wlen*sizeof(scm_t_bits));
      else
        for (size_t i = 0; i < wlen; ++i)
          v_bits[i] = ((kv_bits[i + wshift] >> bshift)
                       | (kv_bits[i + wshift + 1] << (bits_per_word-bshift)));
    }

  return from_bitvector (result);
}
#undef FUNC_NAME

size_t
scm_c_bitvector_count_bits (SCM vec, SCM bits)
#define FUNC_NAME "bitvector-count-bits"
{
  VALIDATE_BITVECTOR (1, vec);
  VALIDATE_BITVECTOR (2, bits);
  struct scm_bitvector *bv = to_bitvector (vec);
  struct scm_bitvector *bitsv = to_bitvector (bits);

  size_t v_len = bitvector_length (bv);
  const scm_t_bits *v_bits = bitvector_bits (bv);
  size_t kv_len = bitvector_length (bitsv);
  const scm_t_bits *kv_bits = bitvector_bits (bitsv);

  if (v_len < kv_len)
    SCM_MISC_ERROR ("selection bitvector longer than target bitvector",
                    SCM_EOL);

  size_t i, word_len = bitvector_word_length (bitsv);
  scm_t_bits last_mask = bitvector_last_mask (bitsv);

  size_t count = 0;
  for (i = 0; i < word_len-1; i++)
    count += count_ones (v_bits[i] & kv_bits[i]);
  count += count_ones (v_bits[i] & kv_bits[i] & last_mask);

  return count;
}
#undef FUNC_NAME

SCM_DEFINE_STATIC (scm_bitvector_count_bits, "bitvector-count-bits", 2, 0, 0,
                   (SCM v, SCM kv),
                   "Return a count of how many entries in bit vector @var{v}\n"
                   "are set, with @var{kv} selecting the entries to consider.\n"
                   "\n"
                   "For example,\n"
                   "\n"
                   "@example\n"
                   "(bitvector-count-bits #*01110111 #*11001101) @result{} 3\n"
                   "@end example")
#define FUNC_NAME s_scm_bitvector_count_bits
{
  return scm_from_size_t (scm_c_bitvector_count_bits (v, kv));
}
#undef FUNC_NAME

void
scm_c_bitvector_flip_all_bits_x (SCM v)
#define FUNC_NAME "bitvector-flip-all-bits!"
{
  VALIDATE_MUTABLE_BITVECTOR (1, v);
  struct scm_bitvector *bv = to_bitvector (v);

  scm_t_bits *bits = bitvector_bits (bv);
  size_t word_len = bitvector_word_length (bv);
  scm_t_bits last_mask = bitvector_last_mask (bv);
  size_t i;

  for (i = 0; i < word_len-1; i++)
    bits[i] = ~bits[i];
  bits[i] = bits[i] ^ last_mask;
}
#undef FUNC_NAME

SCM_DEFINE_STATIC (scm_bitvector_flip_all_bits_x,
                   "bitvector-flip-all-bits!", 1, 0, 0, (SCM v),
                   "Modify the bit vector @var{v} in place by setting all\n"
                   "clear bits and clearing all set bits.")
#define FUNC_NAME s_scm_bitvector_flip_all_bits_x
{
  scm_c_bitvector_flip_all_bits_x (v);
  return SCM_UNSPECIFIED;
}
#undef FUNC_NAME

SCM_VECTOR_IMPLEMENTATION (SCM_ARRAY_ELEMENT_TYPE_BIT, make_scm_bitvector)

void
scm_init_bitvectors ()
{
#include "bitvectors.x"
}