mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-30 03:40:34 +02:00
7f8ad91b99
* libguile/srfi-60.c (scm_srfi60_rotate_bit_field): Avoid division by
zero in the (start == end) case. Rewrite inum case to work with
unsigned integers in two's complement format.
* test-suite/tests/srfi-60.test ("rotate-bit-field"): Add more tests.
460 lines
13 KiB
C
460 lines
13 KiB
C
/* srfi-60.c --- Integers as Bits
|
||
*
|
||
* Copyright (C) 2005, 2006, 2008, 2010, 2014 Free Software Foundation, Inc.
|
||
*
|
||
* This library 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.
|
||
*
|
||
* This library 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 this library; if not, write to the Free Software
|
||
* Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
|
||
* 02110-1301 USA
|
||
*/
|
||
|
||
|
||
|
||
#ifdef HAVE_CONFIG_H
|
||
# include <config.h>
|
||
#endif
|
||
|
||
#include "libguile/_scm.h"
|
||
#include "libguile/eq.h"
|
||
|
||
#include "libguile/validate.h"
|
||
#include "libguile/numbers.h"
|
||
|
||
#include "libguile/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 "libguile/srfi-60.x"
|
||
#endif
|
||
}
|