Commit | Line | Data |
---|---|---|
8884a084 KR |
1 | /* srfi-60.c --- Integers as Bits |
2 | * | |
37710f7e | 3 | * Copyright (C) 2005, 2006, 2008, 2010 Free Software Foundation, Inc. |
8884a084 KR |
4 | * |
5 | * This library is free software; you can redistribute it and/or | |
53befeb7 NJ |
6 | * modify it under the terms of the GNU Lesser General Public License |
7 | * as published by the Free Software Foundation; either version 3 of | |
8 | * the License, or (at your option) any later version. | |
8884a084 | 9 | * |
53befeb7 NJ |
10 | * This library is distributed in the hope that it will be useful, but |
11 | * WITHOUT ANY WARRANTY; without even the implied warranty of | |
8884a084 KR |
12 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU |
13 | * Lesser General Public License for more details. | |
14 | * | |
15 | * You should have received a copy of the GNU Lesser General Public | |
16 | * License along with this library; if not, write to the Free Software | |
53befeb7 NJ |
17 | * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA |
18 | * 02110-1301 USA | |
8884a084 KR |
19 | */ |
20 | ||
37710f7e AW |
21 | |
22 | \f | |
dbb605f5 LC |
23 | #ifdef HAVE_CONFIG_H |
24 | # include <config.h> | |
25 | #endif | |
26 | ||
37710f7e AW |
27 | #include "libguile/_scm.h" |
28 | #include "libguile/eq.h" | |
29 | ||
30 | #include "libguile/validate.h" | |
31 | #include "libguile/numbers.h" | |
32 | ||
33 | #include "libguile/srfi-60.h" | |
8884a084 KR |
34 | |
35 | ||
36 | SCM_DEFINE (scm_srfi60_log2_binary_factors, "log2-binary-factors", 1, 0, 0, | |
37 | (SCM n), | |
38 | "Return a count of how many factors of 2 are present in @var{n}.\n" | |
39 | "This is also the bit index of the lowest 1 bit in @var{n}. If\n" | |
40 | "@var{n} is 0, the return is @math{-1}.\n" | |
41 | "\n" | |
42 | "@example\n" | |
43 | "(log2-binary-factors 6) @result{} 1\n" | |
44 | "(log2-binary-factors -8) @result{} 3\n" | |
45 | "@end example") | |
46 | #define FUNC_NAME s_scm_srfi60_log2_binary_factors | |
47 | { | |
48 | SCM ret = SCM_EOL; | |
49 | ||
ba48957b | 50 | if (SCM_I_INUMP (n)) |
8884a084 KR |
51 | { |
52 | long nn = SCM_I_INUM (n); | |
53 | if (nn == 0) | |
54 | return SCM_I_MAKINUM (-1); | |
55 | nn = nn ^ (nn-1); /* 1 bits for each low 0 and lowest 1 */ | |
56 | return scm_logcount (SCM_I_MAKINUM (nn >> 1)); | |
57 | } | |
58 | else if (SCM_BIGP (n)) | |
59 | { | |
60 | /* no need for scm_remember_upto_here_1 here, mpz_scan1 doesn't do | |
61 | anything that could result in a gc */ | |
62 | return SCM_I_MAKINUM (mpz_scan1 (SCM_I_BIG_MPZ (n), 0L)); | |
63 | } | |
64 | else | |
65 | SCM_WRONG_TYPE_ARG (SCM_ARG1, n); | |
66 | ||
67 | return ret; | |
68 | } | |
69 | #undef FUNC_NAME | |
70 | ||
71 | ||
72 | SCM_DEFINE (scm_srfi60_copy_bit, "copy-bit", 3, 0, 0, | |
7b87f5de | 73 | (SCM index, SCM n, SCM newbit), |
8884a084 KR |
74 | "Return @var{n} with the bit at @var{index} set according to\n" |
75 | "@var{newbit}. @var{newbit} should be @code{#t} to set the bit\n" | |
76 | "to 1, or @code{#f} to set it to 0. Bits other than at\n" | |
77 | "@var{index} are unchanged in the return.\n" | |
78 | "\n" | |
79 | "@example\n" | |
80 | "(copy-bit 1 #b0101 #t) @result{} 7\n" | |
81 | "@end example") | |
82 | #define FUNC_NAME s_scm_srfi60_copy_bit | |
83 | { | |
84 | SCM r; | |
85 | unsigned long ii; | |
86 | int bb; | |
87 | ||
88 | ii = scm_to_ulong (index); | |
7b87f5de | 89 | bb = scm_to_bool (newbit); |
8884a084 | 90 | |
ba48957b | 91 | if (SCM_I_INUMP (n)) |
8884a084 | 92 | { |
ba48957b | 93 | long nn = SCM_I_INUM (n); |
8884a084 KR |
94 | |
95 | /* can't set high bit ii==SCM_LONG_BIT-1, that would change the sign, | |
96 | which is not what's wanted */ | |
97 | if (ii < SCM_LONG_BIT-1) | |
98 | { | |
99 | nn &= ~(1L << ii); /* zap bit at index */ | |
23d72566 | 100 | nn |= ((long) bb << ii); /* insert desired bit */ |
8884a084 KR |
101 | return scm_from_long (nn); |
102 | } | |
103 | else | |
104 | { | |
105 | /* bits at ii==SCM_LONG_BIT-1 and above are all copies of the sign | |
106 | bit, if this is already the desired "bit" value then no need to | |
107 | make a new bignum value */ | |
108 | if (bb == (nn < 0)) | |
109 | return n; | |
110 | ||
111 | r = scm_i_long2big (nn); | |
112 | goto big; | |
113 | } | |
114 | } | |
115 | else if (SCM_BIGP (n)) | |
116 | { | |
117 | /* if the bit is already what's wanted then no need to make a new | |
118 | bignum */ | |
119 | if (bb == mpz_tstbit (SCM_I_BIG_MPZ (n), ii)) | |
120 | return n; | |
121 | ||
122 | r = scm_i_clonebig (n, 1); | |
123 | big: | |
124 | if (bb) | |
125 | mpz_setbit (SCM_I_BIG_MPZ (r), ii); | |
126 | else | |
127 | mpz_clrbit (SCM_I_BIG_MPZ (r), ii); | |
128 | ||
129 | /* changing a high bit might put the result into range of a fixnum */ | |
130 | return scm_i_normbig (r); | |
131 | } | |
132 | else | |
133 | SCM_WRONG_TYPE_ARG (SCM_ARG1, n); | |
134 | } | |
135 | #undef FUNC_NAME | |
136 | ||
137 | ||
138 | SCM_DEFINE (scm_srfi60_rotate_bit_field, "rotate-bit-field", 4, 0, 0, | |
139 | (SCM n, SCM count, SCM start, SCM end), | |
140 | "Return @var{n} with the bit field from @var{start} (inclusive)\n" | |
141 | "to @var{end} (exclusive) rotated upwards by @var{count} bits.\n" | |
142 | "\n" | |
143 | "@var{count} can be positive or negative, and it can be more\n" | |
144 | "than the field width (it'll be reduced modulo the width).\n" | |
145 | "\n" | |
146 | "@example\n" | |
147 | "(rotate-bit-field #b0110 2 1 4) @result{} #b1010\n" | |
148 | "@end example") | |
149 | #define FUNC_NAME s_scm_srfi60_rotate_bit_field | |
150 | { | |
151 | unsigned long ss = scm_to_ulong (start); | |
152 | unsigned long ee = scm_to_ulong (end); | |
153 | unsigned long ww, cc; | |
154 | ||
155 | SCM_ASSERT_RANGE (3, end, (ee >= ss)); | |
156 | ww = ee - ss; | |
157 | ||
158 | cc = scm_to_ulong (scm_modulo (count, scm_difference (end, start))); | |
159 | ||
ba48957b | 160 | if (SCM_I_INUMP (n)) |
8884a084 | 161 | { |
ba48957b | 162 | long nn = SCM_I_INUM (n); |
8884a084 KR |
163 | |
164 | if (ee <= SCM_LONG_BIT-1) | |
165 | { | |
166 | /* all within a long */ | |
167 | long below = nn & ((1L << ss) - 1); /* before start */ | |
168 | long above = nn & (-1L << ee); /* above end */ | |
169 | long fmask = (-1L << ss) & ((1L << ee) - 1); /* field mask */ | |
170 | long ff = nn & fmask; /* field */ | |
171 | ||
172 | return scm_from_long (above | |
173 | | ((ff << cc) & fmask) | |
174 | | ((ff >> (ww-cc)) & fmask) | |
175 | | below); | |
176 | } | |
177 | else | |
178 | { | |
179 | /* either no movement, or a field of only 0 or 1 bits, result | |
180 | unchanged, avoid creating a bignum */ | |
181 | if (cc == 0 || ww <= 1) | |
182 | return n; | |
183 | ||
184 | n = scm_i_long2big (nn); | |
185 | goto big; | |
186 | } | |
187 | } | |
188 | else if (SCM_BIGP (n)) | |
189 | { | |
190 | mpz_t tmp; | |
191 | SCM r; | |
192 | ||
193 | /* either no movement, or in a field of only 0 or 1 bits, result | |
194 | unchanged, avoid creating a new bignum */ | |
195 | if (cc == 0 || ww <= 1) | |
196 | return n; | |
197 | ||
198 | big: | |
199 | r = scm_i_ulong2big (0); | |
200 | mpz_init (tmp); | |
201 | ||
202 | /* portion above end */ | |
203 | mpz_fdiv_q_2exp (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (n), ee); | |
204 | mpz_mul_2exp (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (r), ee); | |
205 | ||
206 | /* field high part, width-count bits from start go to start+count */ | |
207 | mpz_fdiv_q_2exp (tmp, SCM_I_BIG_MPZ (n), ss); | |
208 | mpz_fdiv_r_2exp (tmp, tmp, ww - cc); | |
209 | mpz_mul_2exp (tmp, tmp, ss + cc); | |
210 | mpz_ior (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (r), tmp); | |
211 | ||
212 | /* field high part, count bits from end-count go to start */ | |
213 | mpz_fdiv_q_2exp (tmp, SCM_I_BIG_MPZ (n), ee - cc); | |
214 | mpz_fdiv_r_2exp (tmp, tmp, cc); | |
215 | mpz_mul_2exp (tmp, tmp, ss); | |
216 | mpz_ior (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (r), tmp); | |
217 | ||
218 | /* portion below start */ | |
219 | mpz_fdiv_r_2exp (tmp, SCM_I_BIG_MPZ (n), ss); | |
220 | mpz_ior (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (r), tmp); | |
221 | ||
222 | mpz_clear (tmp); | |
223 | ||
224 | /* bits moved around might leave us in range of an inum */ | |
225 | return scm_i_normbig (r); | |
226 | } | |
227 | else | |
228 | SCM_WRONG_TYPE_ARG (SCM_ARG1, n); | |
229 | } | |
230 | #undef FUNC_NAME | |
231 | ||
232 | ||
233 | SCM_DEFINE (scm_srfi60_reverse_bit_field, "reverse-bit-field", 3, 0, 0, | |
234 | (SCM n, SCM start, SCM end), | |
235 | "Return @var{n} with the bits between @var{start} (inclusive) to\n" | |
236 | "@var{end} (exclusive) reversed.\n" | |
237 | "\n" | |
238 | "@example\n" | |
239 | "(reverse-bit-field #b101001 2 4) @result{} #b100101\n" | |
240 | "@end example") | |
241 | #define FUNC_NAME s_scm_srfi60_reverse_bit_field | |
242 | { | |
243 | long ss = scm_to_long (start); | |
244 | long ee = scm_to_long (end); | |
245 | long swaps = (ee - ss) / 2; /* number of swaps */ | |
246 | SCM b; | |
247 | ||
ba48957b | 248 | if (SCM_I_INUMP (n)) |
8884a084 | 249 | { |
ba48957b | 250 | long nn = SCM_I_INUM (n); |
8884a084 KR |
251 | |
252 | if (ee <= SCM_LONG_BIT-1) | |
253 | { | |
254 | /* all within a long */ | |
255 | long smask = 1L << ss; | |
256 | long emask = 1L << (ee-1); | |
257 | for ( ; swaps > 0; swaps--) | |
258 | { | |
259 | long sbit = nn & smask; | |
260 | long ebit = nn & emask; | |
261 | nn ^= sbit ^ (ebit ? smask : 0) /* zap sbit, put ebit value */ | |
262 | ^ ebit ^ (sbit ? emask : 0); /* zap ebit, put sbit value */ | |
263 | ||
264 | smask <<= 1; | |
265 | emask >>= 1; | |
266 | } | |
267 | return scm_from_long (nn); | |
268 | } | |
269 | else | |
270 | { | |
271 | /* avoid creating a new bignum if reversing only 0 or 1 bits */ | |
272 | if (ee - ss <= 1) | |
273 | return n; | |
274 | ||
275 | b = scm_i_long2big (nn); | |
276 | goto big; | |
277 | } | |
278 | } | |
279 | else if (SCM_BIGP (n)) | |
280 | { | |
281 | /* avoid creating a new bignum if reversing only 0 or 1 bits */ | |
282 | if (ee - ss <= 1) | |
283 | return n; | |
284 | ||
285 | b = scm_i_clonebig (n, 1); | |
286 | big: | |
287 | ||
288 | ee--; | |
289 | for ( ; swaps > 0; swaps--) | |
290 | { | |
291 | int sbit = mpz_tstbit (SCM_I_BIG_MPZ (b), ss); | |
292 | int ebit = mpz_tstbit (SCM_I_BIG_MPZ (b), ee); | |
293 | if (sbit ^ ebit) | |
294 | { | |
295 | /* the two bits are different, flip them */ | |
296 | if (sbit) | |
297 | { | |
298 | mpz_clrbit (SCM_I_BIG_MPZ (b), ss); | |
299 | mpz_setbit (SCM_I_BIG_MPZ (b), ee); | |
300 | } | |
301 | else | |
302 | { | |
303 | mpz_setbit (SCM_I_BIG_MPZ (b), ss); | |
304 | mpz_clrbit (SCM_I_BIG_MPZ (b), ee); | |
305 | } | |
306 | } | |
307 | ss++; | |
308 | ee--; | |
309 | } | |
310 | /* swapping zero bits into the high might make us fit a fixnum */ | |
311 | return scm_i_normbig (b); | |
312 | } | |
313 | else | |
314 | SCM_WRONG_TYPE_ARG (SCM_ARG1, n); | |
315 | } | |
316 | #undef FUNC_NAME | |
317 | ||
318 | ||
319 | SCM_DEFINE (scm_srfi60_integer_to_list, "integer->list", 1, 1, 0, | |
320 | (SCM n, SCM len), | |
321 | "Return bits from @var{n} in the form of a list of @code{#t} for\n" | |
322 | "1 and @code{#f} for 0. The least significant @var{len} bits\n" | |
323 | "are returned, and the first list element is the most\n" | |
324 | "significant of those bits. If @var{len} is not given, the\n" | |
325 | "default is @code{(integer-length @var{n})} (@pxref{Bitwise\n" | |
326 | "Operations}).\n" | |
327 | "\n" | |
328 | "@example\n" | |
329 | "(integer->list 6) @result{} (#t #t #f)\n" | |
330 | "(integer->list 1 4) @result{} (#f #f #f #t)\n" | |
331 | "@end example") | |
332 | #define FUNC_NAME s_scm_srfi60_integer_to_list | |
333 | { | |
334 | SCM ret = SCM_EOL; | |
335 | unsigned long ll, i; | |
336 | ||
337 | if (SCM_UNBNDP (len)) | |
338 | len = scm_integer_length (n); | |
339 | ll = scm_to_ulong (len); | |
340 | ||
ba48957b | 341 | if (SCM_I_INUMP (n)) |
8884a084 KR |
342 | { |
343 | long nn = SCM_I_INUM (n); | |
344 | for (i = 0; i < ll; i++) | |
345 | { | |
b61b5d0e HWN |
346 | unsigned long shift = |
347 | (i < ((unsigned long) SCM_LONG_BIT-1)) | |
348 | ? i : ((unsigned long) SCM_LONG_BIT-1); | |
8884a084 KR |
349 | int bit = (nn >> shift) & 1; |
350 | ret = scm_cons (scm_from_bool (bit), ret); | |
351 | } | |
352 | } | |
353 | else if (SCM_BIGP (n)) | |
354 | { | |
355 | for (i = 0; i < ll; i++) | |
356 | ret = scm_cons (scm_from_bool (mpz_tstbit (SCM_I_BIG_MPZ (n), i)), | |
357 | ret); | |
358 | scm_remember_upto_here_1 (n); | |
359 | } | |
360 | else | |
361 | SCM_WRONG_TYPE_ARG (SCM_ARG1, n); | |
362 | ||
363 | return ret; | |
364 | } | |
365 | #undef FUNC_NAME | |
366 | ||
367 | ||
368 | SCM_DEFINE (scm_srfi60_list_to_integer, "list->integer", 1, 0, 0, | |
369 | (SCM lst), | |
370 | "Return an integer formed bitwise from the given @var{lst} list\n" | |
371 | "of booleans. Each boolean is @code{#t} for a 1 and @code{#f}\n" | |
372 | "for a 0. The first element becomes the most significant bit in\n" | |
373 | "the return.\n" | |
374 | "\n" | |
375 | "@example\n" | |
376 | "(list->integer '(#t #f #t #f)) @result{} 10\n" | |
377 | "@end example") | |
378 | #define FUNC_NAME s_scm_srfi60_list_to_integer | |
379 | { | |
380 | long len; | |
381 | ||
382 | /* strip high zero bits from lst; after this the length tells us whether | |
383 | an inum or bignum is required */ | |
384 | while (scm_is_pair (lst) && scm_is_false (SCM_CAR (lst))) | |
385 | lst = SCM_CDR (lst); | |
386 | ||
387 | SCM_VALIDATE_LIST_COPYLEN (SCM_ARG1, lst, len); | |
388 | ||
389 | if (len <= SCM_I_FIXNUM_BIT - 1) | |
390 | { | |
391 | /* fits an inum (a positive inum) */ | |
392 | long n = 0; | |
393 | while (scm_is_pair (lst)) | |
394 | { | |
395 | n <<= 1; | |
396 | if (! scm_is_false (SCM_CAR (lst))) | |
397 | n++; | |
398 | lst = SCM_CDR (lst); | |
399 | } | |
400 | return SCM_I_MAKINUM (n); | |
401 | } | |
402 | else | |
403 | { | |
404 | /* need a bignum */ | |
405 | SCM n = scm_i_ulong2big (0); | |
406 | while (scm_is_pair (lst)) | |
407 | { | |
408 | len--; | |
409 | if (! scm_is_false (SCM_CAR (lst))) | |
410 | mpz_setbit (SCM_I_BIG_MPZ (n), len); | |
411 | lst = SCM_CDR (lst); | |
412 | } | |
413 | return n; | |
414 | } | |
415 | } | |
416 | #undef FUNC_NAME | |
417 | ||
418 | ||
ad250b8d KR |
419 | /* note: don't put "scm_srfi60_list_to_integer" arg on its own line, a |
420 | newline breaks the snarfer */ | |
421 | SCM_REGISTER_PROC (s_srfi60_booleans_to_integer, "booleans->integer", 0, 0, 1, scm_srfi60_list_to_integer); | |
8884a084 KR |
422 | |
423 | ||
37710f7e AW |
424 | void |
425 | scm_register_srfi_60 (void) | |
426 | { | |
427 | scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION, | |
428 | "scm_init_srfi_60", | |
429 | (scm_t_extension_init_func)scm_init_srfi_60, NULL); | |
430 | } | |
431 | ||
8884a084 KR |
432 | void |
433 | scm_init_srfi_60 (void) | |
434 | { | |
435 | #ifndef SCM_MAGIC_SNARFER | |
37710f7e | 436 | #include "libguile/srfi-60.x" |
8884a084 KR |
437 | #endif |
438 | } |