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