libguile/bitvectors.c

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