Commit | Line | Data |
---|---|---|
cf64dca6 | 1 | /* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004, 2005, 2006, 2009, 2010, 2011, 2012, 2013, 2014 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" | |
cf396142 AW |
30 | #include "libguile/strings.h" |
31 | #include "libguile/array-handle.h" | |
32 | #include "libguile/bitvectors.h" | |
2fa901a5 | 33 | #include "libguile/arrays.h" |
f332e957 | 34 | #include "libguile/generalized-vectors.h" |
943a0a87 | 35 | #include "libguile/srfi-4.h" |
cf396142 AW |
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 | ||
ff1feca9 | 41 | #define IS_BITVECTOR(obj) SCM_TYP16_PREDICATE(scm_tc7_bitvector,(obj)) |
d65514a2 AW |
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)) | |
cf396142 | 44 | |
cf64dca6 AW |
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 | ||
ff1feca9 AW |
52 | int |
53 | scm_i_print_bitvector (SCM vec, SCM port, scm_print_state *pstate) | |
cf396142 AW |
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 | ||
0607ebbf | 60 | scm_puts_unlocked ("#*", port); |
cf396142 AW |
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) | |
0607ebbf | 65 | scm_putc_unlocked ((bits[i] & mask)? '1' : '0', port); |
cf396142 AW |
66 | } |
67 | ||
68 | return 1; | |
69 | } | |
70 | ||
ff1feca9 AW |
71 | SCM |
72 | scm_i_bitvector_equal_p (SCM vec1, SCM vec2) | |
cf396142 AW |
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 | ||
8cf0dd61 LC |
118 | bits = scm_gc_malloc_pointerless (sizeof (scm_t_uint32) * word_len, |
119 | "bitvector"); | |
d65514a2 | 120 | res = scm_double_cell (scm_tc7_bitvector, len, (scm_t_bits)bits, 0); |
cf396142 AW |
121 | |
122 | if (!SCM_UNBNDP (fill)) | |
123 | scm_bitvector_fill_x (res, fill); | |
3ef6650d AW |
124 | else |
125 | memset (bits, 0, sizeof (scm_t_uint32) * word_len); | |
cf396142 AW |
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 | { | |
ff1feca9 AW |
152 | if (!IS_BITVECTOR (vec)) |
153 | scm_wrong_type_arg_msg (NULL, 0, vec, "bitvector"); | |
cf396142 AW |
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), | |
ffb62a43 | 504 | "Return the index of the first occurrence of @var{item} in bit\n" |
cf396142 AW |
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" | |
b7e64f8b | 507 | "@var{v}, then return @code{#f}. For example,\n" |
cf396142 AW |
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" | |
39c5363b | 576 | "@var{v} must be at least as long as @var{kv}. When @var{obj}\n" |
cf396142 AW |
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 | ||
39c5363b | 619 | kv_bits = scm_bitvector_elements (kv, &kv_handle, |
cf396142 AW |
620 | &kv_off, &kv_len, &kv_inc); |
621 | ||
39c5363b | 622 | if (v_len < kv_len) |
cf396142 AW |
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 | ||
d40b0538 | 723 | kv_bits = scm_bitvector_elements (kv, &kv_handle, |
cf396142 AW |
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 | ||
f65e0168 | 862 | SCM_VECTOR_IMPLEMENTATION (SCM_ARRAY_ELEMENT_TYPE_BIT, scm_make_bitvector) |
2a610be5 | 863 | |
cf396142 AW |
864 | void |
865 | scm_init_bitvectors () | |
866 | { | |
cf396142 AW |
867 | #include "libguile/bitvectors.x" |
868 | } | |
869 | ||
870 | /* | |
871 | Local Variables: | |
872 | c-file-style: "gnu" | |
873 | End: | |
874 | */ |