Commit | Line | Data |
---|---|---|
d65514a2 | 1 | /* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004, 2005, 2006, 2009, 2010, 2011, 2012, 2013 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 | |
ff1feca9 AW |
45 | int |
46 | scm_i_print_bitvector (SCM vec, SCM port, scm_print_state *pstate) | |
cf396142 AW |
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 | ||
0607ebbf | 53 | scm_puts_unlocked ("#*", port); |
cf396142 AW |
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) | |
0607ebbf | 58 | scm_putc_unlocked ((bits[i] & mask)? '1' : '0', port); |
cf396142 AW |
59 | } |
60 | ||
61 | return 1; | |
62 | } | |
63 | ||
ff1feca9 AW |
64 | SCM |
65 | scm_i_bitvector_equal_p (SCM vec1, SCM vec2) | |
cf396142 AW |
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 | ||
8cf0dd61 LC |
111 | bits = scm_gc_malloc_pointerless (sizeof (scm_t_uint32) * word_len, |
112 | "bitvector"); | |
d65514a2 | 113 | res = scm_double_cell (scm_tc7_bitvector, len, (scm_t_bits)bits, 0); |
cf396142 AW |
114 | |
115 | if (!SCM_UNBNDP (fill)) | |
116 | scm_bitvector_fill_x (res, fill); | |
3ef6650d AW |
117 | else |
118 | memset (bits, 0, sizeof (scm_t_uint32) * word_len); | |
cf396142 AW |
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 | { | |
ff1feca9 AW |
145 | if (!IS_BITVECTOR (vec)) |
146 | scm_wrong_type_arg_msg (NULL, 0, vec, "bitvector"); | |
cf396142 AW |
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), | |
ffb62a43 | 497 | "Return the index of the first occurrence of @var{item} in bit\n" |
cf396142 AW |
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" | |
b7e64f8b | 500 | "@var{v}, then return @code{#f}. For example,\n" |
cf396142 AW |
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" | |
39c5363b | 569 | "@var{v} must be at least as long as @var{kv}. When @var{obj}\n" |
cf396142 AW |
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 | ||
39c5363b | 612 | kv_bits = scm_bitvector_elements (kv, &kv_handle, |
cf396142 AW |
613 | &kv_off, &kv_len, &kv_inc); |
614 | ||
39c5363b | 615 | if (v_len < kv_len) |
cf396142 AW |
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 | ||
2a610be5 AW |
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 | ||
ff1feca9 AW |
881 | SCM_ARRAY_IMPLEMENTATION (scm_tc7_bitvector, |
882 | 0x7f, | |
2a610be5 | 883 | bitvector_handle_ref, bitvector_handle_set, |
f65e0168 LC |
884 | bitvector_get_handle) |
885 | SCM_VECTOR_IMPLEMENTATION (SCM_ARRAY_ELEMENT_TYPE_BIT, scm_make_bitvector) | |
2a610be5 | 886 | |
cf396142 AW |
887 | void |
888 | scm_init_bitvectors () | |
889 | { | |
cf396142 AW |
890 | #include "libguile/bitvectors.x" |
891 | } | |
892 | ||
893 | /* | |
894 | Local Variables: | |
895 | c-file-style: "gnu" | |
896 | End: | |
897 | */ |