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