diff options
Diffstat (limited to 'libguile/srfi-60.c')
-rw-r--r-- | libguile/srfi-60.c | 464 |
1 files changed, 464 insertions, 0 deletions
diff --git a/libguile/srfi-60.c b/libguile/srfi-60.c new file mode 100644 index 000000000..578106e8e --- /dev/null +++ b/libguile/srfi-60.c @@ -0,0 +1,464 @@ +/* srfi-60.c --- Integers as Bits + + Copyright 2005-2006,2008,2010,2014,2018 + Free Software Foundation, Inc. + + This file is part of Guile. + + Guile is free software: you can redistribute it and/or modify it + under the terms of the GNU Lesser General Public License as published + by the Free Software Foundation, either version 3 of the License, or + (at your option) any later version. + + Guile is distributed in the hope that it will be useful, but WITHOUT + ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or + FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public + License for more details. + + You should have received a copy of the GNU Lesser General Public + License along with Guile. If not, see + <https://www.gnu.org/licenses/>. */ + + + +#ifdef HAVE_CONFIG_H +# include <config.h> +#endif + +#include "boolean.h" +#include "eq.h" +#include "extensions.h" +#include "gsubr.h" +#include "list.h" +#include "numbers.h" +#include "pairs.h" +#include "version.h" + +#include "srfi-60.h" + + +SCM_DEFINE (scm_srfi60_log2_binary_factors, "log2-binary-factors", 1, 0, 0, + (SCM n), + "Return a count of how many factors of 2 are present in @var{n}.\n" + "This is also the bit index of the lowest 1 bit in @var{n}. If\n" + "@var{n} is 0, the return is @math{-1}.\n" + "\n" + "@example\n" + "(log2-binary-factors 6) @result{} 1\n" + "(log2-binary-factors -8) @result{} 3\n" + "@end example") +#define FUNC_NAME s_scm_srfi60_log2_binary_factors +{ + SCM ret = SCM_EOL; + + if (SCM_I_INUMP (n)) + { + long nn = SCM_I_INUM (n); + if (nn == 0) + return SCM_I_MAKINUM (-1); + nn = nn ^ (nn-1); /* 1 bits for each low 0 and lowest 1 */ + return scm_logcount (SCM_I_MAKINUM (nn >> 1)); + } + else if (SCM_BIGP (n)) + { + /* no need for scm_remember_upto_here_1 here, mpz_scan1 doesn't do + anything that could result in a gc */ + return SCM_I_MAKINUM (mpz_scan1 (SCM_I_BIG_MPZ (n), 0L)); + } + else + SCM_WRONG_TYPE_ARG (SCM_ARG1, n); + + return ret; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_srfi60_copy_bit, "copy-bit", 3, 0, 0, + (SCM index, SCM n, SCM newbit), + "Return @var{n} with the bit at @var{index} set according to\n" + "@var{newbit}. @var{newbit} should be @code{#t} to set the bit\n" + "to 1, or @code{#f} to set it to 0. Bits other than at\n" + "@var{index} are unchanged in the return.\n" + "\n" + "@example\n" + "(copy-bit 1 #b0101 #t) @result{} 7\n" + "@end example") +#define FUNC_NAME s_scm_srfi60_copy_bit +{ + SCM r; + unsigned long ii; + int bb; + + ii = scm_to_ulong (index); + bb = scm_to_bool (newbit); + + if (SCM_I_INUMP (n)) + { + long nn = SCM_I_INUM (n); + + /* can't set high bit ii==SCM_LONG_BIT-1, that would change the sign, + which is not what's wanted */ + if (ii < SCM_LONG_BIT-1) + { + nn &= ~(1L << ii); /* zap bit at index */ + nn |= ((long) bb << ii); /* insert desired bit */ + return scm_from_long (nn); + } + else + { + /* bits at ii==SCM_LONG_BIT-1 and above are all copies of the sign + bit, if this is already the desired "bit" value then no need to + make a new bignum value */ + if (bb == (nn < 0)) + return n; + + r = scm_i_long2big (nn); + goto big; + } + } + else if (SCM_BIGP (n)) + { + /* if the bit is already what's wanted then no need to make a new + bignum */ + if (bb == mpz_tstbit (SCM_I_BIG_MPZ (n), ii)) + return n; + + r = scm_i_clonebig (n, 1); + big: + if (bb) + mpz_setbit (SCM_I_BIG_MPZ (r), ii); + else + mpz_clrbit (SCM_I_BIG_MPZ (r), ii); + + /* changing a high bit might put the result into range of a fixnum */ + return scm_i_normbig (r); + } + else + SCM_WRONG_TYPE_ARG (SCM_ARG1, n); +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_srfi60_rotate_bit_field, "rotate-bit-field", 4, 0, 0, + (SCM n, SCM count, SCM start, SCM end), + "Return @var{n} with the bit field from @var{start} (inclusive)\n" + "to @var{end} (exclusive) rotated upwards by @var{count} bits.\n" + "\n" + "@var{count} can be positive or negative, and it can be more\n" + "than the field width (it'll be reduced modulo the width).\n" + "\n" + "@example\n" + "(rotate-bit-field #b0110 2 1 4) @result{} #b1010\n" + "@end example") +#define FUNC_NAME s_scm_srfi60_rotate_bit_field +{ + unsigned long ss = scm_to_ulong (start); + unsigned long ee = scm_to_ulong (end); + unsigned long ww, cc; + + SCM_ASSERT_RANGE (3, end, (ee >= ss)); + ww = ee - ss; + + /* we must avoid division by zero, and a field whose width is 0 or 1 + will be left unchanged anyway, so in that case we set cc to 0. */ + if (ww <= 1) + cc = 0; + else + cc = scm_to_ulong (scm_modulo (count, scm_difference (end, start))); + + if (SCM_I_INUMP (n)) + { + long nn = SCM_I_INUM (n); + + if (ee <= SCM_LONG_BIT-1) + { + /* Everything fits within a long. To avoid undefined behavior + when shifting negative numbers, we do all operations using + unsigned values, and then convert to signed at the end. */ + unsigned long unn = nn; + unsigned long below = unn & ((1UL << ss) - 1); /* below start */ + unsigned long above = unn & ~((1UL << ee) - 1); /* above end */ + unsigned long fmask = ((1UL << ww) - 1) << ss; /* field mask */ + unsigned long ff = unn & fmask; /* field */ + unsigned long uresult = (above + | ((ff << cc) & fmask) + | ((ff >> (ww-cc)) & fmask) + | below); + long result; + + if (uresult > LONG_MAX) + /* The high bit is set in uresult, so the result is + negative. We have to handle the conversion to signed + integer carefully, to avoid undefined behavior. First we + compute ~uresult, equivalent to (ULONG_MAX - uresult), + which will be between 0 and LONG_MAX (inclusive): exactly + the set of numbers that can be represented as both signed + and unsigned longs and thus convertible between them. We + cast that difference to a signed long and then substract + it from -1. */ + result = -1 - (long) ~uresult; + else + result = (long) uresult; + + return scm_from_long (result); + } + else + { + /* if there's no movement, avoid creating a bignum. */ + if (cc == 0) + return n; + + n = scm_i_long2big (nn); + goto big; + } + } + else if (SCM_BIGP (n)) + { + mpz_t tmp; + SCM r; + + /* if there's no movement, avoid creating a new bignum. */ + if (cc == 0) + return n; + + big: + r = scm_i_ulong2big (0); + mpz_init (tmp); + + /* portion above end */ + mpz_fdiv_q_2exp (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (n), ee); + mpz_mul_2exp (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (r), ee); + + /* field high part, width-count bits from start go to start+count */ + mpz_fdiv_q_2exp (tmp, SCM_I_BIG_MPZ (n), ss); + mpz_fdiv_r_2exp (tmp, tmp, ww - cc); + mpz_mul_2exp (tmp, tmp, ss + cc); + mpz_ior (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (r), tmp); + + /* field low part, count bits from end-count go to start */ + mpz_fdiv_q_2exp (tmp, SCM_I_BIG_MPZ (n), ee - cc); + mpz_fdiv_r_2exp (tmp, tmp, cc); + mpz_mul_2exp (tmp, tmp, ss); + mpz_ior (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (r), tmp); + + /* portion below start */ + mpz_fdiv_r_2exp (tmp, SCM_I_BIG_MPZ (n), ss); + mpz_ior (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (r), tmp); + + mpz_clear (tmp); + + /* bits moved around might leave us in range of an inum */ + return scm_i_normbig (r); + } + else + SCM_WRONG_TYPE_ARG (SCM_ARG1, n); +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_srfi60_reverse_bit_field, "reverse-bit-field", 3, 0, 0, + (SCM n, SCM start, SCM end), + "Return @var{n} with the bits between @var{start} (inclusive) to\n" + "@var{end} (exclusive) reversed.\n" + "\n" + "@example\n" + "(reverse-bit-field #b101001 2 4) @result{} #b100101\n" + "@end example") +#define FUNC_NAME s_scm_srfi60_reverse_bit_field +{ + long ss = scm_to_long (start); + long ee = scm_to_long (end); + long swaps = (ee - ss) / 2; /* number of swaps */ + SCM b; + + if (SCM_I_INUMP (n)) + { + long nn = SCM_I_INUM (n); + + if (ee <= SCM_LONG_BIT-1) + { + /* all within a long */ + long smask = 1L << ss; + long emask = 1L << (ee-1); + for ( ; swaps > 0; swaps--) + { + long sbit = nn & smask; + long ebit = nn & emask; + nn ^= sbit ^ (ebit ? smask : 0) /* zap sbit, put ebit value */ + ^ ebit ^ (sbit ? emask : 0); /* zap ebit, put sbit value */ + + smask <<= 1; + emask >>= 1; + } + return scm_from_long (nn); + } + else + { + /* avoid creating a new bignum if reversing only 0 or 1 bits */ + if (ee - ss <= 1) + return n; + + b = scm_i_long2big (nn); + goto big; + } + } + else if (SCM_BIGP (n)) + { + /* avoid creating a new bignum if reversing only 0 or 1 bits */ + if (ee - ss <= 1) + return n; + + b = scm_i_clonebig (n, 1); + big: + + ee--; + for ( ; swaps > 0; swaps--) + { + int sbit = mpz_tstbit (SCM_I_BIG_MPZ (b), ss); + int ebit = mpz_tstbit (SCM_I_BIG_MPZ (b), ee); + if (sbit ^ ebit) + { + /* the two bits are different, flip them */ + if (sbit) + { + mpz_clrbit (SCM_I_BIG_MPZ (b), ss); + mpz_setbit (SCM_I_BIG_MPZ (b), ee); + } + else + { + mpz_setbit (SCM_I_BIG_MPZ (b), ss); + mpz_clrbit (SCM_I_BIG_MPZ (b), ee); + } + } + ss++; + ee--; + } + /* swapping zero bits into the high might make us fit a fixnum */ + return scm_i_normbig (b); + } + else + SCM_WRONG_TYPE_ARG (SCM_ARG1, n); +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_srfi60_integer_to_list, "integer->list", 1, 1, 0, + (SCM n, SCM len), + "Return bits from @var{n} in the form of a list of @code{#t} for\n" + "1 and @code{#f} for 0. The least significant @var{len} bits\n" + "are returned, and the first list element is the most\n" + "significant of those bits. If @var{len} is not given, the\n" + "default is @code{(integer-length @var{n})} (@pxref{Bitwise\n" + "Operations}).\n" + "\n" + "@example\n" + "(integer->list 6) @result{} (#t #t #f)\n" + "(integer->list 1 4) @result{} (#f #f #f #t)\n" + "@end example") +#define FUNC_NAME s_scm_srfi60_integer_to_list +{ + SCM ret = SCM_EOL; + unsigned long ll, i; + + if (SCM_UNBNDP (len)) + len = scm_integer_length (n); + ll = scm_to_ulong (len); + + if (SCM_I_INUMP (n)) + { + long nn = SCM_I_INUM (n); + for (i = 0; i < ll; i++) + { + unsigned long shift = + (i < ((unsigned long) SCM_LONG_BIT-1)) + ? i : ((unsigned long) SCM_LONG_BIT-1); + int bit = (nn >> shift) & 1; + ret = scm_cons (scm_from_bool (bit), ret); + } + } + else if (SCM_BIGP (n)) + { + for (i = 0; i < ll; i++) + ret = scm_cons (scm_from_bool (mpz_tstbit (SCM_I_BIG_MPZ (n), i)), + ret); + scm_remember_upto_here_1 (n); + } + else + SCM_WRONG_TYPE_ARG (SCM_ARG1, n); + + return ret; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_srfi60_list_to_integer, "list->integer", 1, 0, 0, + (SCM lst), + "Return an integer formed bitwise from the given @var{lst} list\n" + "of booleans. Each boolean is @code{#t} for a 1 and @code{#f}\n" + "for a 0. The first element becomes the most significant bit in\n" + "the return.\n" + "\n" + "@example\n" + "(list->integer '(#t #f #t #f)) @result{} 10\n" + "@end example") +#define FUNC_NAME s_scm_srfi60_list_to_integer +{ + long len; + + /* strip high zero bits from lst; after this the length tells us whether + an inum or bignum is required */ + while (scm_is_pair (lst) && scm_is_false (SCM_CAR (lst))) + lst = SCM_CDR (lst); + + SCM_VALIDATE_LIST_COPYLEN (SCM_ARG1, lst, len); + + if (len <= SCM_I_FIXNUM_BIT - 1) + { + /* fits an inum (a positive inum) */ + long n = 0; + while (scm_is_pair (lst)) + { + n <<= 1; + if (! scm_is_false (SCM_CAR (lst))) + n++; + lst = SCM_CDR (lst); + } + return SCM_I_MAKINUM (n); + } + else + { + /* need a bignum */ + SCM n = scm_i_ulong2big (0); + while (scm_is_pair (lst)) + { + len--; + if (! scm_is_false (SCM_CAR (lst))) + mpz_setbit (SCM_I_BIG_MPZ (n), len); + lst = SCM_CDR (lst); + } + return n; + } +} +#undef FUNC_NAME + + +/* note: don't put "scm_srfi60_list_to_integer" arg on its own line, a + newline breaks the snarfer */ +SCM_REGISTER_PROC (s_srfi60_booleans_to_integer, "booleans->integer", 0, 0, 1, scm_srfi60_list_to_integer); + + +void +scm_register_srfi_60 (void) +{ + scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION, + "scm_init_srfi_60", + (scm_t_extension_init_func)scm_init_srfi_60, NULL); +} + +void +scm_init_srfi_60 (void) +{ +#ifndef SCM_MAGIC_SNARFER +#include "srfi-60.x" +#endif +} |