Commit | Line | Data |
---|---|---|
8884a084 KR |
1 | /* srfi-60.c --- Integers as Bits |
2 | * | |
7f8ad91b | 3 | * Copyright (C) 2005, 2006, 2008, 2010, 2014 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 | ||
7f8ad91b MW |
158 | /* we must avoid division by zero, and a field whose width is 0 or 1 |
159 | will be left unchanged anyway, so in that case we set cc to 0. */ | |
160 | if (ww <= 1) | |
161 | cc = 0; | |
162 | else | |
163 | cc = scm_to_ulong (scm_modulo (count, scm_difference (end, start))); | |
8884a084 | 164 | |
ba48957b | 165 | if (SCM_I_INUMP (n)) |
8884a084 | 166 | { |
ba48957b | 167 | long nn = SCM_I_INUM (n); |
8884a084 KR |
168 | |
169 | if (ee <= SCM_LONG_BIT-1) | |
170 | { | |
7f8ad91b MW |
171 | /* Everything fits within a long. To avoid undefined behavior |
172 | when shifting negative numbers, we do all operations using | |
173 | unsigned values, and then convert to signed at the end. */ | |
174 | unsigned long unn = nn; | |
175 | unsigned long below = unn & ((1UL << ss) - 1); /* below start */ | |
176 | unsigned long above = unn & ~((1UL << ee) - 1); /* above end */ | |
177 | unsigned long fmask = ((1UL << ww) - 1) << ss; /* field mask */ | |
178 | unsigned long ff = unn & fmask; /* field */ | |
179 | unsigned long uresult = (above | |
180 | | ((ff << cc) & fmask) | |
181 | | ((ff >> (ww-cc)) & fmask) | |
182 | | below); | |
183 | long result; | |
184 | ||
185 | if (uresult > LONG_MAX) | |
186 | /* The high bit is set in uresult, so the result is | |
187 | negative. We have to handle the conversion to signed | |
188 | integer carefully, to avoid undefined behavior. First we | |
189 | compute ~uresult, equivalent to (ULONG_MAX - uresult), | |
190 | which will be between 0 and LONG_MAX (inclusive): exactly | |
191 | the set of numbers that can be represented as both signed | |
192 | and unsigned longs and thus convertible between them. We | |
193 | cast that difference to a signed long and then substract | |
194 | it from -1. */ | |
195 | result = -1 - (long) ~uresult; | |
196 | else | |
197 | result = (long) uresult; | |
198 | ||
199 | return scm_from_long (result); | |
8884a084 KR |
200 | } |
201 | else | |
202 | { | |
7f8ad91b MW |
203 | /* if there's no movement, avoid creating a bignum. */ |
204 | if (cc == 0) | |
8884a084 KR |
205 | return n; |
206 | ||
207 | n = scm_i_long2big (nn); | |
208 | goto big; | |
209 | } | |
210 | } | |
211 | else if (SCM_BIGP (n)) | |
212 | { | |
213 | mpz_t tmp; | |
214 | SCM r; | |
215 | ||
7f8ad91b MW |
216 | /* if there's no movement, avoid creating a new bignum. */ |
217 | if (cc == 0) | |
8884a084 KR |
218 | return n; |
219 | ||
220 | big: | |
221 | r = scm_i_ulong2big (0); | |
222 | mpz_init (tmp); | |
223 | ||
224 | /* portion above end */ | |
225 | mpz_fdiv_q_2exp (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (n), ee); | |
226 | mpz_mul_2exp (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (r), ee); | |
227 | ||
228 | /* field high part, width-count bits from start go to start+count */ | |
229 | mpz_fdiv_q_2exp (tmp, SCM_I_BIG_MPZ (n), ss); | |
230 | mpz_fdiv_r_2exp (tmp, tmp, ww - cc); | |
231 | mpz_mul_2exp (tmp, tmp, ss + cc); | |
232 | mpz_ior (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (r), tmp); | |
233 | ||
7f8ad91b | 234 | /* field low part, count bits from end-count go to start */ |
8884a084 KR |
235 | mpz_fdiv_q_2exp (tmp, SCM_I_BIG_MPZ (n), ee - cc); |
236 | mpz_fdiv_r_2exp (tmp, tmp, cc); | |
237 | mpz_mul_2exp (tmp, tmp, ss); | |
238 | mpz_ior (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (r), tmp); | |
239 | ||
240 | /* portion below start */ | |
241 | mpz_fdiv_r_2exp (tmp, SCM_I_BIG_MPZ (n), ss); | |
242 | mpz_ior (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (r), tmp); | |
243 | ||
244 | mpz_clear (tmp); | |
245 | ||
246 | /* bits moved around might leave us in range of an inum */ | |
247 | return scm_i_normbig (r); | |
248 | } | |
249 | else | |
250 | SCM_WRONG_TYPE_ARG (SCM_ARG1, n); | |
251 | } | |
252 | #undef FUNC_NAME | |
253 | ||
254 | ||
255 | SCM_DEFINE (scm_srfi60_reverse_bit_field, "reverse-bit-field", 3, 0, 0, | |
256 | (SCM n, SCM start, SCM end), | |
257 | "Return @var{n} with the bits between @var{start} (inclusive) to\n" | |
258 | "@var{end} (exclusive) reversed.\n" | |
259 | "\n" | |
260 | "@example\n" | |
261 | "(reverse-bit-field #b101001 2 4) @result{} #b100101\n" | |
262 | "@end example") | |
263 | #define FUNC_NAME s_scm_srfi60_reverse_bit_field | |
264 | { | |
265 | long ss = scm_to_long (start); | |
266 | long ee = scm_to_long (end); | |
267 | long swaps = (ee - ss) / 2; /* number of swaps */ | |
268 | SCM b; | |
269 | ||
ba48957b | 270 | if (SCM_I_INUMP (n)) |
8884a084 | 271 | { |
ba48957b | 272 | long nn = SCM_I_INUM (n); |
8884a084 KR |
273 | |
274 | if (ee <= SCM_LONG_BIT-1) | |
275 | { | |
276 | /* all within a long */ | |
277 | long smask = 1L << ss; | |
278 | long emask = 1L << (ee-1); | |
279 | for ( ; swaps > 0; swaps--) | |
280 | { | |
281 | long sbit = nn & smask; | |
282 | long ebit = nn & emask; | |
283 | nn ^= sbit ^ (ebit ? smask : 0) /* zap sbit, put ebit value */ | |
284 | ^ ebit ^ (sbit ? emask : 0); /* zap ebit, put sbit value */ | |
285 | ||
286 | smask <<= 1; | |
287 | emask >>= 1; | |
288 | } | |
289 | return scm_from_long (nn); | |
290 | } | |
291 | else | |
292 | { | |
293 | /* avoid creating a new bignum if reversing only 0 or 1 bits */ | |
294 | if (ee - ss <= 1) | |
295 | return n; | |
296 | ||
297 | b = scm_i_long2big (nn); | |
298 | goto big; | |
299 | } | |
300 | } | |
301 | else if (SCM_BIGP (n)) | |
302 | { | |
303 | /* avoid creating a new bignum if reversing only 0 or 1 bits */ | |
304 | if (ee - ss <= 1) | |
305 | return n; | |
306 | ||
307 | b = scm_i_clonebig (n, 1); | |
308 | big: | |
309 | ||
310 | ee--; | |
311 | for ( ; swaps > 0; swaps--) | |
312 | { | |
313 | int sbit = mpz_tstbit (SCM_I_BIG_MPZ (b), ss); | |
314 | int ebit = mpz_tstbit (SCM_I_BIG_MPZ (b), ee); | |
315 | if (sbit ^ ebit) | |
316 | { | |
317 | /* the two bits are different, flip them */ | |
318 | if (sbit) | |
319 | { | |
320 | mpz_clrbit (SCM_I_BIG_MPZ (b), ss); | |
321 | mpz_setbit (SCM_I_BIG_MPZ (b), ee); | |
322 | } | |
323 | else | |
324 | { | |
325 | mpz_setbit (SCM_I_BIG_MPZ (b), ss); | |
326 | mpz_clrbit (SCM_I_BIG_MPZ (b), ee); | |
327 | } | |
328 | } | |
329 | ss++; | |
330 | ee--; | |
331 | } | |
332 | /* swapping zero bits into the high might make us fit a fixnum */ | |
333 | return scm_i_normbig (b); | |
334 | } | |
335 | else | |
336 | SCM_WRONG_TYPE_ARG (SCM_ARG1, n); | |
337 | } | |
338 | #undef FUNC_NAME | |
339 | ||
340 | ||
341 | SCM_DEFINE (scm_srfi60_integer_to_list, "integer->list", 1, 1, 0, | |
342 | (SCM n, SCM len), | |
343 | "Return bits from @var{n} in the form of a list of @code{#t} for\n" | |
344 | "1 and @code{#f} for 0. The least significant @var{len} bits\n" | |
345 | "are returned, and the first list element is the most\n" | |
346 | "significant of those bits. If @var{len} is not given, the\n" | |
347 | "default is @code{(integer-length @var{n})} (@pxref{Bitwise\n" | |
348 | "Operations}).\n" | |
349 | "\n" | |
350 | "@example\n" | |
351 | "(integer->list 6) @result{} (#t #t #f)\n" | |
352 | "(integer->list 1 4) @result{} (#f #f #f #t)\n" | |
353 | "@end example") | |
354 | #define FUNC_NAME s_scm_srfi60_integer_to_list | |
355 | { | |
356 | SCM ret = SCM_EOL; | |
357 | unsigned long ll, i; | |
358 | ||
359 | if (SCM_UNBNDP (len)) | |
360 | len = scm_integer_length (n); | |
361 | ll = scm_to_ulong (len); | |
362 | ||
ba48957b | 363 | if (SCM_I_INUMP (n)) |
8884a084 KR |
364 | { |
365 | long nn = SCM_I_INUM (n); | |
366 | for (i = 0; i < ll; i++) | |
367 | { | |
b61b5d0e HWN |
368 | unsigned long shift = |
369 | (i < ((unsigned long) SCM_LONG_BIT-1)) | |
370 | ? i : ((unsigned long) SCM_LONG_BIT-1); | |
8884a084 KR |
371 | int bit = (nn >> shift) & 1; |
372 | ret = scm_cons (scm_from_bool (bit), ret); | |
373 | } | |
374 | } | |
375 | else if (SCM_BIGP (n)) | |
376 | { | |
377 | for (i = 0; i < ll; i++) | |
378 | ret = scm_cons (scm_from_bool (mpz_tstbit (SCM_I_BIG_MPZ (n), i)), | |
379 | ret); | |
380 | scm_remember_upto_here_1 (n); | |
381 | } | |
382 | else | |
383 | SCM_WRONG_TYPE_ARG (SCM_ARG1, n); | |
384 | ||
385 | return ret; | |
386 | } | |
387 | #undef FUNC_NAME | |
388 | ||
389 | ||
390 | SCM_DEFINE (scm_srfi60_list_to_integer, "list->integer", 1, 0, 0, | |
391 | (SCM lst), | |
392 | "Return an integer formed bitwise from the given @var{lst} list\n" | |
393 | "of booleans. Each boolean is @code{#t} for a 1 and @code{#f}\n" | |
394 | "for a 0. The first element becomes the most significant bit in\n" | |
395 | "the return.\n" | |
396 | "\n" | |
397 | "@example\n" | |
398 | "(list->integer '(#t #f #t #f)) @result{} 10\n" | |
399 | "@end example") | |
400 | #define FUNC_NAME s_scm_srfi60_list_to_integer | |
401 | { | |
402 | long len; | |
403 | ||
404 | /* strip high zero bits from lst; after this the length tells us whether | |
405 | an inum or bignum is required */ | |
406 | while (scm_is_pair (lst) && scm_is_false (SCM_CAR (lst))) | |
407 | lst = SCM_CDR (lst); | |
408 | ||
409 | SCM_VALIDATE_LIST_COPYLEN (SCM_ARG1, lst, len); | |
410 | ||
411 | if (len <= SCM_I_FIXNUM_BIT - 1) | |
412 | { | |
413 | /* fits an inum (a positive inum) */ | |
414 | long n = 0; | |
415 | while (scm_is_pair (lst)) | |
416 | { | |
417 | n <<= 1; | |
418 | if (! scm_is_false (SCM_CAR (lst))) | |
419 | n++; | |
420 | lst = SCM_CDR (lst); | |
421 | } | |
422 | return SCM_I_MAKINUM (n); | |
423 | } | |
424 | else | |
425 | { | |
426 | /* need a bignum */ | |
427 | SCM n = scm_i_ulong2big (0); | |
428 | while (scm_is_pair (lst)) | |
429 | { | |
430 | len--; | |
431 | if (! scm_is_false (SCM_CAR (lst))) | |
432 | mpz_setbit (SCM_I_BIG_MPZ (n), len); | |
433 | lst = SCM_CDR (lst); | |
434 | } | |
435 | return n; | |
436 | } | |
437 | } | |
438 | #undef FUNC_NAME | |
439 | ||
440 | ||
ad250b8d KR |
441 | /* note: don't put "scm_srfi60_list_to_integer" arg on its own line, a |
442 | newline breaks the snarfer */ | |
443 | SCM_REGISTER_PROC (s_srfi60_booleans_to_integer, "booleans->integer", 0, 0, 1, scm_srfi60_list_to_integer); | |
8884a084 KR |
444 | |
445 | ||
37710f7e AW |
446 | void |
447 | scm_register_srfi_60 (void) | |
448 | { | |
449 | scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION, | |
450 | "scm_init_srfi_60", | |
451 | (scm_t_extension_init_func)scm_init_srfi_60, NULL); | |
452 | } | |
453 | ||
8884a084 KR |
454 | void |
455 | scm_init_srfi_60 (void) | |
456 | { | |
457 | #ifndef SCM_MAGIC_SNARFER | |
37710f7e | 458 | #include "libguile/srfi-60.x" |
8884a084 KR |
459 | #endif |
460 | } |