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