libguile/bitvectors.c

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