libguile/bitvectors.c

   1 /* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004, 2005, 2006, 2009, 2010, 2011 Free Software Foundation, Inc.
   2  *
   3  * This library is free software; you can redistribute it and/or
   4  * modify it under the terms of the GNU Lesser General Public License
   5  * as published by the Free Software Foundation; either version 3 of
   6  * the License, or (at your option) any later version.
   7  *
   8  * This library is distributed in the hope that it will be useful, but
   9  * WITHOUT ANY WARRANTY; without even the implied warranty of
  10  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  11  * Lesser General Public License for more details.
  12  *
  13  * You should have received a copy of the GNU Lesser General Public
  14  * License along with this library; if not, write to the Free Software
  15  * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
  16  * 02110-1301 USA
  17  */
  18
  19
  20 \f
  21
  22 #ifdef HAVE_CONFIG_H
  23 #  include <config.h>
  24 #endif
  25
  26 #include <string.h>
  27
  28 #include "libguile/_scm.h"
  29 #include "libguile/__scm.h"
  30 #include "libguile/smob.h"
  31 #include "libguile/strings.h"
  32 #include "libguile/array-handle.h"
  33 #include "libguile/bitvectors.h"
  34 #include "libguile/arrays.h"
  35 #include "libguile/generalized-vectors.h"
  36 #include "libguile/srfi-4.h"
  37
  38 /* Bit vectors. Would be nice if they were implemented on top of bytevectors,
  39  * but alack, all we have is this crufty C.
  40  */
  41
  42 static scm_t_bits scm_tc16_bitvector;
  43
  44 #define IS_BITVECTOR(obj)       SCM_SMOB_PREDICATE(scm_tc16_bitvector,(obj))
  45 #define BITVECTOR_BITS(obj)     ((scm_t_uint32 *)SCM_SMOB_DATA(obj))
  46 #define BITVECTOR_LENGTH(obj)   ((size_t)SCM_SMOB_DATA_2(obj))
  47
  48 static int
  49 bitvector_print (SCM vec, SCM port, scm_print_state *pstate)
  50 {
  51   size_t bit_len = BITVECTOR_LENGTH (vec);
  52   size_t word_len = (bit_len+31)/32;
  53   scm_t_uint32 *bits = BITVECTOR_BITS (vec);
  54   size_t i, j;
  55
  56   scm_puts_unlocked ("#*", port);
  57   for (i = 0; i < word_len; i++, bit_len -= 32)
  58     {
  59       scm_t_uint32 mask = 1;
  60       for (j = 0; j < 32 && j < bit_len; j++, mask <<= 1)
  61         scm_putc_unlocked ((bits[i] & mask)? '1' : '0', port);
  62     }
  63
  64   return 1;
  65 }
  66
  67 static SCM
  68 bitvector_equalp (SCM vec1, SCM vec2)
  69 {
  70   size_t bit_len = BITVECTOR_LENGTH (vec1);
  71   size_t word_len = (bit_len + 31) / 32;
  72   scm_t_uint32 last_mask =  ((scm_t_uint32)-1) >> (32*word_len - bit_len);
  73   scm_t_uint32 *bits1 = BITVECTOR_BITS (vec1);
  74   scm_t_uint32 *bits2 = BITVECTOR_BITS (vec2);
  75
  76   /* compare lengths */
  77   if (BITVECTOR_LENGTH (vec2) != bit_len)
  78     return SCM_BOOL_F;
  79   /* avoid underflow in word_len-1 below. */
  80   if (bit_len == 0)
  81     return SCM_BOOL_T;
  82   /* compare full words */
  83   if (memcmp (bits1, bits2, sizeof (scm_t_uint32) * (word_len-1)))
  84     return SCM_BOOL_F;
  85   /* compare partial last words */
  86   if ((bits1[word_len-1] & last_mask) != (bits2[word_len-1] & last_mask))
  87     return SCM_BOOL_F;
  88   return SCM_BOOL_T;
  89 }
  90
  91 int
  92 scm_is_bitvector (SCM vec)
  93 {
  94   return IS_BITVECTOR (vec);
  95 }
  96
  97 SCM_DEFINE (scm_bitvector_p, "bitvector?", 1, 0, 0,
  98             (SCM obj),
  99             "Return @code{#t} when @var{obj} is a bitvector, else\n"
 100             "return @code{#f}.")
 101 #define FUNC_NAME s_scm_bitvector_p
 102 {
 103   return scm_from_bool (scm_is_bitvector (obj));
 104 }
 105 #undef FUNC_NAME
 106
 107 SCM
 108 scm_c_make_bitvector (size_t len, SCM fill)
 109 {
 110   size_t word_len = (len + 31) / 32;
 111   scm_t_uint32 *bits;
 112   SCM res;
 113
 114   bits = scm_gc_malloc_pointerless (sizeof (scm_t_uint32) * word_len,
 115                                     "bitvector");
 116   SCM_NEWSMOB2 (res, scm_tc16_bitvector, bits, len);
 117
 118   if (!SCM_UNBNDP (fill))
 119     scm_bitvector_fill_x (res, fill);
 120   else
 121     memset (bits, 0, sizeof (scm_t_uint32) * word_len);
 122
 123   return res;
 124 }
 125
 126 SCM_DEFINE (scm_make_bitvector, "make-bitvector", 1, 1, 0,
 127             (SCM len, SCM fill),
 128             "Create a new bitvector of length @var{len} and\n"
 129             "optionally initialize all elements to @var{fill}.")
 130 #define FUNC_NAME s_scm_make_bitvector
 131 {
 132   return scm_c_make_bitvector (scm_to_size_t (len), fill);
 133 }
 134 #undef FUNC_NAME
 135
 136 SCM_DEFINE (scm_bitvector, "bitvector", 0, 0, 1,
 137             (SCM bits),
 138             "Create a new bitvector with the arguments as elements.")
 139 #define FUNC_NAME s_scm_bitvector
 140 {
 141   return scm_list_to_bitvector (bits);
 142 }
 143 #undef FUNC_NAME
 144
 145 size_t
 146 scm_c_bitvector_length (SCM vec)
 147 {
 148   scm_assert_smob_type (scm_tc16_bitvector, vec);
 149   return BITVECTOR_LENGTH (vec);
 150 }
 151
 152 SCM_DEFINE (scm_bitvector_length, "bitvector-length", 1, 0, 0,
 153             (SCM vec),
 154             "Return the length of the bitvector @var{vec}.")
 155 #define FUNC_NAME s_scm_bitvector_length
 156 {
 157   return scm_from_size_t (scm_c_bitvector_length (vec));
 158 }
 159 #undef FUNC_NAME
 160
 161 const scm_t_uint32 *
 162 scm_array_handle_bit_elements (scm_t_array_handle *h)
 163 {
 164   return scm_array_handle_bit_writable_elements (h);
 165 }
 166
 167 scm_t_uint32 *
 168 scm_array_handle_bit_writable_elements (scm_t_array_handle *h)
 169 {
 170   SCM vec = h->array;
 171   if (SCM_I_ARRAYP (vec))
 172     vec = SCM_I_ARRAY_V (vec);
 173   if (IS_BITVECTOR (vec))
 174     return BITVECTOR_BITS (vec) + h->base/32;
 175   scm_wrong_type_arg_msg (NULL, 0, h->array, "bit array");
 176 }
 177
 178 size_t
 179 scm_array_handle_bit_elements_offset (scm_t_array_handle *h)
 180 {
 181   return h->base % 32;
 182 }
 183
 184 const scm_t_uint32 *
 185 scm_bitvector_elements (SCM vec,
 186                         scm_t_array_handle *h,
 187                         size_t *offp,
 188                         size_t *lenp,
 189                         ssize_t *incp)
 190 {
 191   return scm_bitvector_writable_elements (vec, h, offp, lenp, incp);
 192 }
 193
 194
 195 scm_t_uint32 *
 196 scm_bitvector_writable_elements (SCM vec,
 197                                  scm_t_array_handle *h,
 198                                  size_t *offp,
 199                                  size_t *lenp,
 200                                  ssize_t *incp)
 201 {
 202   scm_generalized_vector_get_handle (vec, h);
 203   if (offp)
 204     {
 205       scm_t_array_dim *dim = scm_array_handle_dims (h);
 206       *offp = scm_array_handle_bit_elements_offset (h);
 207       *lenp = dim->ubnd - dim->lbnd + 1;
 208       *incp = dim->inc;
 209     }
 210   return scm_array_handle_bit_writable_elements (h);
 211 }
 212
 213 SCM
 214 scm_c_bitvector_ref (SCM vec, size_t idx)
 215 {
 216   scm_t_array_handle handle;
 217   const scm_t_uint32 *bits;
 218
 219   if (IS_BITVECTOR (vec))
 220     {
 221       if (idx >= BITVECTOR_LENGTH (vec))
 222         scm_out_of_range (NULL, scm_from_size_t (idx));
 223       bits = BITVECTOR_BITS(vec);
 224       return scm_from_bool (bits[idx/32] & (1L << (idx%32)));
 225     }
 226   else
 227     {
 228       SCM res;
 229       size_t len, off;
 230       ssize_t inc;
 231
 232       bits = scm_bitvector_elements (vec, &handle, &off, &len, &inc);
 233       if (idx >= len)
 234         scm_out_of_range (NULL, scm_from_size_t (idx));
 235       idx = idx*inc + off;
 236       res = scm_from_bool (bits[idx/32] & (1L << (idx%32)));
 237       scm_array_handle_release (&handle);
 238       return res;
 239     }
 240 }
 241
 242 SCM_DEFINE (scm_bitvector_ref, "bitvector-ref", 2, 0, 0,
 243             (SCM vec, SCM idx),
 244             "Return the element at index @var{idx} of the bitvector\n"
 245             "@var{vec}.")
 246 #define FUNC_NAME s_scm_bitvector_ref
 247 {
 248   return scm_c_bitvector_ref (vec, scm_to_size_t (idx));
 249 }
 250 #undef FUNC_NAME
 251
 252 void
 253 scm_c_bitvector_set_x (SCM vec, size_t idx, SCM val)
 254 {
 255   scm_t_array_handle handle;
 256   scm_t_uint32 *bits, mask;
 257
 258   if (IS_BITVECTOR (vec))
 259     {
 260       if (idx >= BITVECTOR_LENGTH (vec))
 261         scm_out_of_range (NULL, scm_from_size_t (idx));
 262       bits = BITVECTOR_BITS(vec);
 263     }
 264   else
 265     {
 266       size_t len, off;
 267       ssize_t inc;
 268
 269       bits = scm_bitvector_writable_elements (vec, &handle, &off, &len, &inc);
 270       if (idx >= len)
 271         scm_out_of_range (NULL, scm_from_size_t (idx));
 272       idx = idx*inc + off;
 273     }
 274
 275   mask = 1L << (idx%32);
 276   if (scm_is_true (val))
 277     bits[idx/32] |= mask;
 278   else
 279     bits[idx/32] &= ~mask;
 280
 281   if (!IS_BITVECTOR (vec))
 282       scm_array_handle_release (&handle);
 283 }
 284
 285 SCM_DEFINE (scm_bitvector_set_x, "bitvector-set!", 3, 0, 0,
 286             (SCM vec, SCM idx, SCM val),
 287             "Set the element at index @var{idx} of the bitvector\n"
 288             "@var{vec} when @var{val} is true, else clear it.")
 289 #define FUNC_NAME s_scm_bitvector_set_x
 290 {
 291   scm_c_bitvector_set_x (vec, scm_to_size_t (idx), val);
 292   return SCM_UNSPECIFIED;
 293 }
 294 #undef FUNC_NAME
 295
 296 SCM_DEFINE (scm_bitvector_fill_x, "bitvector-fill!", 2, 0, 0,
 297             (SCM vec, SCM val),
 298             "Set all elements of the bitvector\n"
 299             "@var{vec} when @var{val} is true, else clear them.")
 300 #define FUNC_NAME s_scm_bitvector_fill_x
 301 {
 302   scm_t_array_handle handle;
 303   size_t off, len;
 304   ssize_t inc;
 305   scm_t_uint32 *bits;
 306
 307   bits = scm_bitvector_writable_elements (vec, &handle,
 308                                           &off, &len, &inc);
 309
 310   if (off == 0 && inc == 1 && len > 0)
 311     {
 312       /* the usual case
 313        */
 314       size_t word_len = (len + 31) / 32;
 315       scm_t_uint32 last_mask =  ((scm_t_uint32)-1) >> (32*word_len - len);
 316
 317       if (scm_is_true (val))
 318         {
 319           memset (bits, 0xFF, sizeof(scm_t_uint32)*(word_len-1));
 320           bits[word_len-1] |= last_mask;
 321         }
 322       else
 323         {
 324           memset (bits, 0x00, sizeof(scm_t_uint32)*(word_len-1));
 325           bits[word_len-1] &= ~last_mask;
 326         }
 327     }
 328   else
 329     {
 330       size_t i;
 331       for (i = 0; i < len; i++)
 332         scm_array_handle_set (&handle, i*inc, val);
 333     }
 334
 335   scm_array_handle_release (&handle);
 336
 337   return SCM_UNSPECIFIED;
 338 }
 339 #undef FUNC_NAME
 340
 341 SCM_DEFINE (scm_list_to_bitvector, "list->bitvector", 1, 0, 0,
 342             (SCM list),
 343             "Return a new bitvector initialized with the elements\n"
 344             "of @var{list}.")
 345 #define FUNC_NAME s_scm_list_to_bitvector
 346 {
 347   size_t bit_len = scm_to_size_t (scm_length (list));
 348   SCM vec = scm_c_make_bitvector (bit_len, SCM_UNDEFINED);
 349   size_t word_len = (bit_len+31)/32;
 350   scm_t_array_handle handle;
 351   scm_t_uint32 *bits = scm_bitvector_writable_elements (vec, &handle,
 352                                                         NULL, NULL, NULL);
 353   size_t i, j;
 354
 355   for (i = 0; i < word_len && scm_is_pair (list); i++, bit_len -= 32)
 356     {
 357       scm_t_uint32 mask = 1;
 358       bits[i] = 0;
 359       for (j = 0; j < 32 && j < bit_len;
 360            j++, mask <<= 1, list = SCM_CDR (list))
 361         if (scm_is_true (SCM_CAR (list)))
 362           bits[i] |= mask;
 363     }
 364
 365   scm_array_handle_release (&handle);
 366
 367   return vec;
 368 }
 369 #undef FUNC_NAME
 370
 371 SCM_DEFINE (scm_bitvector_to_list, "bitvector->list", 1, 0, 0,
 372             (SCM vec),
 373             "Return a new list initialized with the elements\n"
 374             "of the bitvector @var{vec}.")
 375 #define FUNC_NAME s_scm_bitvector_to_list
 376 {
 377   scm_t_array_handle handle;
 378   size_t off, len;
 379   ssize_t inc;
 380   scm_t_uint32 *bits;
 381   SCM res = SCM_EOL;
 382
 383   bits = scm_bitvector_writable_elements (vec, &handle,
 384                                           &off, &len, &inc);
 385
 386   if (off == 0 && inc == 1)
 387     {
 388       /* the usual case
 389        */
 390       size_t word_len = (len + 31) / 32;
 391       size_t i, j;
 392
 393       for (i = 0; i < word_len; i++, len -= 32)
 394         {
 395           scm_t_uint32 mask = 1;
 396           for (j = 0; j < 32 && j < len; j++, mask <<= 1)
 397             res = scm_cons ((bits[i] & mask)? SCM_BOOL_T : SCM_BOOL_F, res);
 398         }
 399     }
 400   else
 401     {
 402       size_t i;
 403       for (i = 0; i < len; i++)
 404         res = scm_cons (scm_array_handle_ref (&handle, i*inc), res);
 405     }
 406
 407   scm_array_handle_release (&handle);
 408
 409   return scm_reverse_x (res, SCM_EOL);
 410 }
 411 #undef FUNC_NAME
 412
 413 /* From mmix-arith.w by Knuth.
 414
 415   Here's a fun way to count the number of bits in a tetrabyte.
 416
 417   [This classical trick is called the ``Gillies--Miller method for
 418   sideways addition'' in {\sl The Preparation of Programs for an
 419   Electronic Digital Computer\/} by Wilkes, Wheeler, and Gill, second
 420   edition (Reading, Mass.:\ Addison--Wesley, 1957), 191--193. Some of
 421   the tricks used here were suggested by Balbir Singh, Peter
 422   Rossmanith, and Stefan Schwoon.]
 423 */
 424
 425 static size_t
 426 count_ones (scm_t_uint32 x)
 427 {
 428   x=x-((x>>1)&0x55555555);
 429   x=(x&0x33333333)+((x>>2)&0x33333333);
 430   x=(x+(x>>4))&0x0f0f0f0f;
 431   x=x+(x>>8);
 432   return (x+(x>>16)) & 0xff;
 433 }
 434
 435 SCM_DEFINE (scm_bit_count, "bit-count", 2, 0, 0,
 436             (SCM b, SCM bitvector),
 437             "Return the number of occurrences of the boolean @var{b} in\n"
 438             "@var{bitvector}.")
 439 #define FUNC_NAME s_scm_bit_count
 440 {
 441   scm_t_array_handle handle;
 442   size_t off, len;
 443   ssize_t inc;
 444   scm_t_uint32 *bits;
 445   int bit = scm_to_bool (b);
 446   size_t count = 0;
 447
 448   bits = scm_bitvector_writable_elements (bitvector, &handle,
 449                                           &off, &len, &inc);
 450
 451   if (off == 0 && inc == 1 && len > 0)
 452     {
 453       /* the usual case
 454        */
 455       size_t word_len = (len + 31) / 32;
 456       scm_t_uint32 last_mask =  ((scm_t_uint32)-1) >> (32*word_len - len);
 457       size_t i;
 458
 459       for (i = 0; i < word_len-1; i++)
 460         count += count_ones (bits[i]);
 461       count += count_ones (bits[i] & last_mask);
 462     }
 463   else
 464     {
 465       size_t i;
 466       for (i = 0; i < len; i++)
 467         if (scm_is_true (scm_array_handle_ref (&handle, i*inc)))
 468           count++;
 469     }
 470
 471   scm_array_handle_release (&handle);
 472
 473   return scm_from_size_t (bit? count : len-count);
 474 }
 475 #undef FUNC_NAME
 476
 477 /* returns 32 for x == 0.
 478 */
 479 static size_t
 480 find_first_one (scm_t_uint32 x)
 481 {
 482   size_t pos = 0;
 483   /* do a binary search in x. */
 484   if ((x & 0xFFFF) == 0)
 485     x >>= 16, pos += 16;
 486   if ((x & 0xFF) == 0)
 487     x >>= 8, pos += 8;
 488   if ((x & 0xF) == 0)
 489     x >>= 4, pos += 4;
 490   if ((x & 0x3) == 0)
 491     x >>= 2, pos += 2;
 492   if ((x & 0x1) == 0)
 493     pos += 1;
 494   return pos;
 495 }
 496
 497 SCM_DEFINE (scm_bit_position, "bit-position", 3, 0, 0,
 498            (SCM item, SCM v, SCM k),
 499             "Return the index of the first occurrence of @var{item} in bit\n"
 500             "vector @var{v}, starting from @var{k}.  If there is no\n"
 501             "@var{item} entry between @var{k} and the end of\n"
 502             "@var{bitvector}, then return @code{#f}.  For example,\n"
 503             "\n"
 504             "@example\n"
 505             "(bit-position #t #*000101 0)  @result{} 3\n"
 506             "(bit-position #f #*0001111 3) @result{} #f\n"
 507             "@end example")
 508 #define FUNC_NAME s_scm_bit_position
 509 {
 510   scm_t_array_handle handle;
 511   size_t off, len, first_bit;
 512   ssize_t inc;
 513   const scm_t_uint32 *bits;
 514   int bit = scm_to_bool (item);
 515   SCM res = SCM_BOOL_F;
 516
 517   bits = scm_bitvector_elements (v, &handle, &off, &len, &inc);
 518   first_bit = scm_to_unsigned_integer (k, 0, len);
 519
 520   if (off == 0 && inc == 1 && len > 0)
 521     {
 522       size_t i, word_len = (len + 31) / 32;
 523       scm_t_uint32 last_mask =  ((scm_t_uint32)-1) >> (32*word_len - len);
 524       size_t first_word = first_bit / 32;
 525       scm_t_uint32 first_mask =
 526         ((scm_t_uint32)-1) << (first_bit - 32*first_word);
 527       scm_t_uint32 w;
 528
 529       for (i = first_word; i < word_len; i++)
 530         {
 531           w = (bit? bits[i] : ~bits[i]);
 532           if (i == first_word)
 533             w &= first_mask;
 534           if (i == word_len-1)
 535             w &= last_mask;
 536           if (w)
 537             {
 538               res = scm_from_size_t (32*i + find_first_one (w));
 539               break;
 540             }
 541         }
 542     }
 543   else
 544     {
 545       size_t i;
 546       for (i = first_bit; i < len; i++)
 547         {
 548           SCM elt = scm_array_handle_ref (&handle, i*inc);
 549           if ((bit && scm_is_true (elt)) || (!bit && scm_is_false (elt)))
 550             {
 551               res = scm_from_size_t (i);
 552               break;
 553             }
 554         }
 555     }
 556
 557   scm_array_handle_release (&handle);
 558
 559   return res;
 560 }
 561 #undef FUNC_NAME
 562
 563 SCM_DEFINE (scm_bit_set_star_x, "bit-set*!", 3, 0, 0,
 564             (SCM v, SCM kv, SCM obj),
 565             "Set entries of bit vector @var{v} to @var{obj}, with @var{kv}\n"
 566             "selecting the entries to change.  The return value is\n"
 567             "unspecified.\n"
 568             "\n"
 569             "If @var{kv} is a bit vector, then those entries where it has\n"
 570             "@code{#t} are the ones in @var{v} which are set to @var{obj}.\n"
 571             "@var{v} must be at least as long as @var{kv}.  When @var{obj}\n"
 572             "is @code{#t} it's like @var{kv} is OR'ed into @var{v}.  Or when\n"
 573             "@var{obj} is @code{#f} it can be seen as an ANDNOT.\n"
 574             "\n"
 575             "@example\n"
 576             "(define bv #*01000010)\n"
 577             "(bit-set*! bv #*10010001 #t)\n"
 578             "bv\n"
 579             "@result{} #*11010011\n"
 580             "@end example\n"
 581             "\n"
 582             "If @var{kv} is a u32vector, then its elements are\n"
 583             "indices into @var{v} which are set to @var{obj}.\n"
 584             "\n"
 585             "@example\n"
 586             "(define bv #*01000010)\n"
 587             "(bit-set*! bv #u32(5 2 7) #t)\n"
 588             "bv\n"
 589             "@result{} #*01100111\n"
 590             "@end example")
 591 #define FUNC_NAME s_scm_bit_set_star_x
 592 {
 593   scm_t_array_handle v_handle;
 594   size_t v_off, v_len;
 595   ssize_t v_inc;
 596   scm_t_uint32 *v_bits;
 597   int bit;
 598
 599   /* Validate that OBJ is a boolean so this is done even if we don't
 600      need BIT.
 601   */
 602   bit = scm_to_bool (obj);
 603
 604   v_bits = scm_bitvector_writable_elements (v, &v_handle,
 605                                             &v_off, &v_len, &v_inc);
 606
 607   if (scm_is_bitvector (kv))
 608     {
 609       scm_t_array_handle kv_handle;
 610       size_t kv_off, kv_len;
 611       ssize_t kv_inc;
 612       const scm_t_uint32 *kv_bits;
 613
 614       kv_bits = scm_bitvector_elements (kv, &kv_handle,
 615                                         &kv_off, &kv_len, &kv_inc);
 616
 617       if (v_len < kv_len)
 618         scm_misc_error (NULL,
 619                         "bit vectors must have equal length",
 620                         SCM_EOL);
 621
 622       if (v_off == 0 && v_inc == 1 && kv_off == 0 && kv_inc == 1 && kv_len > 0)
 623         {
 624           size_t word_len = (kv_len + 31) / 32;
 625           scm_t_uint32 last_mask = ((scm_t_uint32)-1) >> (32*word_len - kv_len);
 626           size_t i;
 627
 628           if (bit == 0)
 629             {
 630               for (i = 0; i < word_len-1; i++)
 631                 v_bits[i] &= ~kv_bits[i];
 632               v_bits[i] &= ~(kv_bits[i] & last_mask);
 633             }
 634           else
 635             {
 636               for (i = 0; i < word_len-1; i++)
 637                 v_bits[i] |= kv_bits[i];
 638               v_bits[i] |= kv_bits[i] & last_mask;
 639             }
 640         }
 641       else
 642         {
 643           size_t i;
 644           for (i = 0; i < kv_len; i++)
 645             if (scm_is_true (scm_array_handle_ref (&kv_handle, i*kv_inc)))
 646               scm_array_handle_set (&v_handle, i*v_inc, obj);
 647         }
 648
 649       scm_array_handle_release (&kv_handle);
 650
 651     }
 652   else if (scm_is_true (scm_u32vector_p (kv)))
 653     {
 654       scm_t_array_handle kv_handle;
 655       size_t i, kv_len;
 656       ssize_t kv_inc;
 657       const scm_t_uint32 *kv_elts;
 658
 659       kv_elts = scm_u32vector_elements (kv, &kv_handle, &kv_len, &kv_inc);
 660       for (i = 0; i < kv_len; i++, kv_elts += kv_inc)
 661         scm_array_handle_set (&v_handle, (*kv_elts)*v_inc, obj);
 662
 663       scm_array_handle_release (&kv_handle);
 664     }
 665   else
 666     scm_wrong_type_arg_msg (NULL, 0, kv, "bitvector or u32vector");
 667
 668   scm_array_handle_release (&v_handle);
 669
 670   return SCM_UNSPECIFIED;
 671 }
 672 #undef FUNC_NAME
 673
 674
 675 SCM_DEFINE (scm_bit_count_star, "bit-count*", 3, 0, 0,
 676            (SCM v, SCM kv, SCM obj),
 677             "Return a count of how many entries in bit vector @var{v} are\n"
 678             "equal to @var{obj}, with @var{kv} selecting the entries to\n"
 679             "consider.\n"
 680             "\n"
 681             "If @var{kv} is a bit vector, then those entries where it has\n"
 682             "@code{#t} are the ones in @var{v} which are considered.\n"
 683             "@var{kv} and @var{v} must be the same length.\n"
 684             "\n"
 685             "If @var{kv} is a u32vector, then it contains\n"
 686             "the indexes in @var{v} to consider.\n"
 687             "\n"
 688             "For example,\n"
 689             "\n"
 690             "@example\n"
 691             "(bit-count* #*01110111 #*11001101 #t) @result{} 3\n"
 692             "(bit-count* #*01110111 #u32(7 0 4) #f)  @result{} 2\n"
 693             "@end example")
 694 #define FUNC_NAME s_scm_bit_count_star
 695 {
 696   scm_t_array_handle v_handle;
 697   size_t v_off, v_len;
 698   ssize_t v_inc;
 699   const scm_t_uint32 *v_bits;
 700   size_t count = 0;
 701   int bit;
 702
 703   /* Validate that OBJ is a boolean so this is done even if we don't
 704      need BIT.
 705   */
 706   bit = scm_to_bool (obj);
 707
 708   v_bits = scm_bitvector_elements (v, &v_handle,
 709                                    &v_off, &v_len, &v_inc);
 710
 711   if (scm_is_bitvector (kv))
 712     {
 713       scm_t_array_handle kv_handle;
 714       size_t kv_off, kv_len;
 715       ssize_t kv_inc;
 716       const scm_t_uint32 *kv_bits;
 717
 718       kv_bits = scm_bitvector_elements (v, &kv_handle,
 719                                         &kv_off, &kv_len, &kv_inc);
 720
 721       if (v_len != kv_len)
 722         scm_misc_error (NULL,
 723                         "bit vectors must have equal length",
 724                         SCM_EOL);
 725
 726       if (v_off == 0 && v_inc == 1 && kv_off == 0 && kv_inc == 1 && kv_len > 0)
 727         {
 728           size_t i, word_len = (kv_len + 31) / 32;
 729           scm_t_uint32 last_mask = ((scm_t_uint32)-1) >> (32*word_len - kv_len);
 730           scm_t_uint32 xor_mask = bit? 0 : ((scm_t_uint32)-1);
 731
 732           for (i = 0; i < word_len-1; i++)
 733             count += count_ones ((v_bits[i]^xor_mask) & kv_bits[i]);
 734           count += count_ones ((v_bits[i]^xor_mask) & kv_bits[i] & last_mask);
 735         }
 736       else
 737         {
 738           size_t i;
 739           for (i = 0; i < kv_len; i++)
 740             if (scm_is_true (scm_array_handle_ref (&kv_handle, i)))
 741               {
 742                 SCM elt = scm_array_handle_ref (&v_handle, i*v_inc);
 743                 if ((bit && scm_is_true (elt)) || (!bit && scm_is_false (elt)))
 744                   count++;
 745               }
 746         }
 747
 748       scm_array_handle_release (&kv_handle);
 749
 750     }
 751   else if (scm_is_true (scm_u32vector_p (kv)))
 752     {
 753       scm_t_array_handle kv_handle;
 754       size_t i, kv_len;
 755       ssize_t kv_inc;
 756       const scm_t_uint32 *kv_elts;
 757
 758       kv_elts = scm_u32vector_elements (kv, &kv_handle, &kv_len, &kv_inc);
 759       for (i = 0; i < kv_len; i++, kv_elts += kv_inc)
 760         {
 761           SCM elt = scm_array_handle_ref (&v_handle, (*kv_elts)*v_inc);
 762           if ((bit && scm_is_true (elt)) || (!bit && scm_is_false (elt)))
 763             count++;
 764         }
 765
 766       scm_array_handle_release (&kv_handle);
 767     }
 768   else
 769     scm_wrong_type_arg_msg (NULL, 0, kv, "bitvector or u32vector");
 770
 771   scm_array_handle_release (&v_handle);
 772
 773   return scm_from_size_t (count);
 774 }
 775 #undef FUNC_NAME
 776
 777 SCM_DEFINE (scm_bit_invert_x, "bit-invert!", 1, 0, 0,
 778            (SCM v),
 779             "Modify the bit vector @var{v} by replacing each element with\n"
 780             "its negation.")
 781 #define FUNC_NAME s_scm_bit_invert_x
 782 {
 783   scm_t_array_handle handle;
 784   size_t off, len;
 785   ssize_t inc;
 786   scm_t_uint32 *bits;
 787
 788   bits = scm_bitvector_writable_elements (v, &handle, &off, &len, &inc);
 789
 790   if (off == 0 && inc == 1 && len > 0)
 791     {
 792       size_t word_len = (len + 31) / 32;
 793       scm_t_uint32 last_mask = ((scm_t_uint32)-1) >> (32*word_len - len);
 794       size_t i;
 795
 796       for (i = 0; i < word_len-1; i++)
 797         bits[i] = ~bits[i];
 798       bits[i] = bits[i] ^ last_mask;
 799     }
 800   else
 801     {
 802       size_t i;
 803       for (i = 0; i < len; i++)
 804         scm_array_handle_set (&handle, i*inc,
 805                               scm_not (scm_array_handle_ref (&handle, i*inc)));
 806     }
 807
 808   scm_array_handle_release (&handle);
 809
 810   return SCM_UNSPECIFIED;
 811 }
 812 #undef FUNC_NAME
 813
 814
 815 SCM
 816 scm_istr2bve (SCM str)
 817 {
 818   scm_t_array_handle handle;
 819   size_t len = scm_i_string_length (str);
 820   SCM vec = scm_c_make_bitvector (len, SCM_UNDEFINED);
 821   SCM res = vec;
 822
 823   scm_t_uint32 mask;
 824   size_t k, j;
 825   const char *c_str;
 826   scm_t_uint32 *data;
 827
 828   data = scm_bitvector_writable_elements (vec, &handle, NULL, NULL, NULL);
 829   c_str = scm_i_string_chars (str);
 830
 831   for (k = 0; k < (len + 31) / 32; k++)
 832     {
 833       data[k] = 0L;
 834       j = len - k * 32;
 835       if (j > 32)
 836         j = 32;
 837       for (mask = 1L; j--; mask <<= 1)
 838         switch (*c_str++)
 839           {
 840           case '0':
 841             break;
 842           case '1':
 843             data[k] |= mask;
 844             break;
 845           default:
 846             res = SCM_BOOL_F;
 847             goto exit;
 848           }
 849     }
 850
 851  exit:
 852   scm_array_handle_release (&handle);
 853   scm_remember_upto_here_1 (str);
 854   return res;
 855 }
 856
 857 /* FIXME: h->array should be h->vector */
 858 static SCM
 859 bitvector_handle_ref (scm_t_array_handle *h, size_t pos)
 860 {
 861   return scm_c_bitvector_ref (h->array, pos);
 862 }
 863
 864 static void
 865 bitvector_handle_set (scm_t_array_handle *h, size_t pos, SCM val)
 866 {
 867   scm_c_bitvector_set_x (h->array, pos, val);
 868 }
 869
 870 static void
 871 bitvector_get_handle (SCM bv, scm_t_array_handle *h)
 872 {
 873   h->array = bv;
 874   h->ndims = 1;
 875   h->dims = &h->dim0;
 876   h->dim0.lbnd = 0;
 877   h->dim0.ubnd = BITVECTOR_LENGTH (bv) - 1;
 878   h->dim0.inc = 1;
 879   h->element_type = SCM_ARRAY_ELEMENT_TYPE_BIT;
 880   h->elements = h->writable_elements = BITVECTOR_BITS (bv);
 881 }
 882
 883 SCM_ARRAY_IMPLEMENTATION (SCM_SMOB_TYPE_BITS (scm_tc16_bitvector),
 884                           SCM_SMOB_TYPE_MASK,
 885                           bitvector_handle_ref, bitvector_handle_set,
 886                           bitvector_get_handle)
 887 SCM_VECTOR_IMPLEMENTATION (SCM_ARRAY_ELEMENT_TYPE_BIT, scm_make_bitvector)
 888
 889 void
 890 scm_init_bitvectors ()
 891 {
 892   scm_tc16_bitvector = scm_make_smob_type ("bitvector", 0);
 893   scm_set_smob_print (scm_tc16_bitvector, bitvector_print);
 894   scm_set_smob_equalp (scm_tc16_bitvector, bitvector_equalp);
 895
 896 #include "libguile/bitvectors.x"
 897 }
 898
 899 /*
 900   Local Variables:
 901   c-file-style: "gnu"
 902   End:
 903 */