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