Commit | Line | Data |
---|---|---|
3ef6650d | 1 | /* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004, 2005, 2006, 2009, 2010 Free Software Foundation, Inc. |
cf396142 AW |
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" | |
2fa901a5 | 34 | #include "libguile/arrays.h" |
f332e957 | 35 | #include "libguile/generalized-vectors.h" |
943a0a87 | 36 | #include "libguile/srfi-4.h" |
cf396142 AW |
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 | ||
cf396142 AW |
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 ("#*", 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 ((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 | ||
8cf0dd61 LC |
114 | bits = scm_gc_malloc_pointerless (sizeof (scm_t_uint32) * word_len, |
115 | "bitvector"); | |
cf396142 AW |
116 | SCM_NEWSMOB2 (res, scm_tc16_bitvector, bits, len); |
117 | ||
118 | if (!SCM_UNBNDP (fill)) | |
119 | scm_bitvector_fill_x (res, fill); | |
3ef6650d AW |
120 | else |
121 | memset (bits, 0, sizeof (scm_t_uint32) * word_len); | |
cf396142 AW |
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), | |
ffb62a43 | 499 | "Return the index of the first occurrence of @var{item} in bit\n" |
cf396142 AW |
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{kv} and @var{v} must be the same length. 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 (v, &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 | ||
2a610be5 AW |
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 | ||
735bcfe5 AW |
883 | SCM_ARRAY_IMPLEMENTATION (SCM_SMOB_TYPE_BITS (scm_tc16_bitvector), |
884 | SCM_SMOB_TYPE_MASK, | |
2a610be5 | 885 | bitvector_handle_ref, bitvector_handle_set, |
f65e0168 LC |
886 | bitvector_get_handle) |
887 | SCM_VECTOR_IMPLEMENTATION (SCM_ARRAY_ELEMENT_TYPE_BIT, scm_make_bitvector) | |
2a610be5 | 888 | |
cf396142 AW |
889 | void |
890 | scm_init_bitvectors () | |
891 | { | |
892 | scm_tc16_bitvector = scm_make_smob_type ("bitvector", 0); | |
cf396142 AW |
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 | */ |