/* Arithmetic Utilities */
#include "scheme.h"
+#include "bits.h"
\f
/* Conversions between Scheme types and C types. */
}
{
SCHEME_OBJECT result = (bignum_quotient (n, d));
- return
- ((result == SHARP_F)
- ? SHARP_F
- : (bignum_to_integer (result)));
+ return ((result == SHARP_F) ? SHARP_F : (bignum_to_integer (result)));
}
}
}
}
\f
-static unsigned long
-unsigned_long_length_in_bits (unsigned long n)
+/* Length and Bit Counts */
+
+/* Ones-complement length. */
+
+SCHEME_OBJECT
+integer_length_in_bits (SCHEME_OBJECT n)
{
- unsigned long result = 0;
- while (n > 0xff) { result += 8; n >>= 8; }
- while (n > 0) { result += 1; n >>= 1; }
- return (result);
+ if (FIXNUM_P (n))
+ {
+ long n1 = (FIXNUM_TO_LONG (n));
+ return (ULONG_TO_FIXNUM (ulong_length_in_bits ((n1 < 0) ? (- n1) : n1)));
+ }
+ else
+ return (ulong_to_integer (bignum_length_in_bits (n)));
}
+/* Two's-complement length. */
+
SCHEME_OBJECT
-integer_length_in_bits (SCHEME_OBJECT n)
+integer_length (SCHEME_OBJECT n)
+{
+ if (FIXNUM_P (n))
+ {
+ long n1 = (FIXNUM_TO_LONG (n));
+ return (ULONG_TO_FIXNUM (ulong_length_in_bits ((n1 < 0) ? (~n1) : n1)));
+ }
+ else
+ return (ulong_to_integer (bignum_integer_length (n)));
+}
+
+SCHEME_OBJECT
+integer_first_set_bit (SCHEME_OBJECT n)
+{
+ if (FIXNUM_P (n))
+ {
+ long n1 = (FIXNUM_TO_LONG (n));
+ return
+ (LONG_TO_FIXNUM
+ (ulong_first_set_bit ((n1 < 0) ? (~ ((unsigned long) (~n1))) : n1)));
+ }
+ else
+ return (long_to_integer (bignum_first_set_bit (n)));
+}
+
+SCHEME_OBJECT
+integer_bit_count (SCHEME_OBJECT n)
{
if (FIXNUM_P (n))
{
long n1 = (FIXNUM_TO_LONG (n));
- return (LONG_TO_UNSIGNED_FIXNUM
- (unsigned_long_length_in_bits ((n1 < 0) ? (- n1) : n1)));
+ return (ULONG_TO_FIXNUM (ulong_bit_count ((n1 < 0) ? (~n1) : n1)));
}
else
- return (bignum_to_integer (bignum_length_in_bits (n)));
+ return (ulong_to_integer (bignum_bit_count (n)));
}
+SCHEME_OBJECT
+integer_hamming_distance (SCHEME_OBJECT n, SCHEME_OBJECT m)
+{
+ if ((FIXNUM_P (n)) && (FIXNUM_P (m)))
+ {
+ long x = ((FIXNUM_TO_LONG (n)) ^ (FIXNUM_TO_LONG (m)));
+ return
+ ((x < 0)
+ ? (LONG_TO_FIXNUM (-1))
+ : (ULONG_TO_FIXNUM (ulong_bit_count (x))));
+ }
+ else
+ return
+ (long_to_integer
+ (bignum_hamming_distance
+ (((FIXNUM_P (n)) ? (FIXNUM_TO_BIGNUM (n)) : n),
+ ((FIXNUM_P (m)) ? (FIXNUM_TO_BIGNUM (m)) : m))));
+}
+\f
+/* Bitwise Operations */
+
+SCHEME_OBJECT
+integer_bitwise_not (SCHEME_OBJECT n)
+{
+ if (FIXNUM_P (n))
+ return (LONG_TO_FIXNUM (~ (FIXNUM_TO_LONG (n))));
+ else
+ return (bignum_bitwise_not (n));
+}
+
+#define DEFINE_BITWISE(NAME, OP) \
+SCHEME_OBJECT \
+NAME (SCHEME_OBJECT n, SCHEME_OBJECT m) \
+{ \
+ if ((FIXNUM_P (n)) && (FIXNUM_P (m))) \
+ return \
+ (LONG_TO_FIXNUM \
+ (BITWISE_##OP ((FIXNUM_TO_LONG (n)), (FIXNUM_TO_LONG (m))))); \
+ else \
+ return \
+ (bignum_to_integer \
+ (bignum_bitwise_##OP \
+ (((FIXNUM_P (n)) ? (FIXNUM_TO_BIGNUM (n)) : n), \
+ ((FIXNUM_P (m)) ? (FIXNUM_TO_BIGNUM (m)) : m)))); \
+}
+
+#define BITWISE_and(x, y) ((x) & (y))
+#define BITWISE_andc2(x, y) ((x) &~ (y))
+#define BITWISE_andc1(x, y) ((y) &~ (x))
+#define BITWISE_xor(x, y) ((x) ^ (y))
+#define BITWISE_ior(x, y) ((x) | (y))
+#define BITWISE_nor(x, y) (~ ((x) | (y)))
+#define BITWISE_eqv(x, y) (~ ((x) ^ (y)))
+#define BITWISE_orc2(x, y) ((x) |~ (y))
+#define BITWISE_orc1(x, y) ((y) |~ (x))
+#define BITWISE_nand(x, y) (~ ((x) & (y)))
+
+DEFINE_BITWISE (integer_bitwise_and, and)
+DEFINE_BITWISE (integer_bitwise_andc2, andc2)
+DEFINE_BITWISE (integer_bitwise_andc1, andc1)
+DEFINE_BITWISE (integer_bitwise_xor, xor)
+DEFINE_BITWISE (integer_bitwise_ior, ior)
+DEFINE_BITWISE (integer_bitwise_nor, nor)
+DEFINE_BITWISE (integer_bitwise_eqv, eqv)
+DEFINE_BITWISE (integer_bitwise_orc2, orc2)
+DEFINE_BITWISE (integer_bitwise_orc1, orc1)
+DEFINE_BITWISE (integer_bitwise_nand, nand)
+\f
+SCHEME_OBJECT
+integer_nonnegative_one_bits (unsigned long n, unsigned long m)
+{
+ if (n == 0)
+ return (LONG_TO_FIXNUM (0));
+ else if ((n + m) <= FIXNUM_LENGTH)
+ return (ULONG_TO_FIXNUM ((~ ((~ ((unsigned long) 0)) << n)) << m));
+ else
+ return (bignum_nonnegative_one_bits (n, m));
+}
+
+SCHEME_OBJECT
+integer_negative_zero_bits (unsigned long n, unsigned long m)
+{
+ if (n == 0)
+ return (LONG_TO_FIXNUM (-1));
+ else if ((n + m) <= FIXNUM_LENGTH)
+ return
+ (LONG_TO_FIXNUM (~ ((long) ((~ ((~ ((unsigned long) 0)) << n)) << m))));
+ else
+ return (bignum_negative_zero_bits (n, m));
+}
+
+/* Shift: multiplication and Euclidean division by 2^m */
+
SCHEME_OBJECT
integer_shift_left (SCHEME_OBJECT n, unsigned long m)
{
- if ((m == 0) || (!integer_positive_p (n)))
+ if (m == 0)
return (n);
if (FIXNUM_P (n))
{
- unsigned long n1 = (UNSIGNED_FIXNUM_TO_LONG (n));
- unsigned long ln = (unsigned_long_length_in_bits (n1));
- unsigned long lr = (ln + m);
- return
- ((lr <= FIXNUM_LENGTH)
- ? (LONG_TO_UNSIGNED_FIXNUM (n1 << m))
- : (unsigned_long_to_shifted_bignum (n1, m, 0)));
+ long n1 = (FIXNUM_TO_LONG (n));
+ if (n1 < 0)
+ {
+ if ((m + (ulong_length_in_bits (~n1))) < FIXNUM_LENGTH)
+ /* The behaviour of shifting a negative integer is
+ undefined in C. */
+ return (LONG_TO_FIXNUM (- ((-n1) << m)));
+ else
+ return
+ (bignum_negate (unsigned_long_to_shifted_bignum ((-n1), m, 0)));
+ }
+ else if (0 < n1)
+ {
+ if ((m + (ulong_length_in_bits (n1))) < FIXNUM_LENGTH)
+ return (LONG_TO_FIXNUM (n1 << m));
+ else
+ return (unsigned_long_to_shifted_bignum (n1, m, 0));
+ }
+ else
+ return (LONG_TO_FIXNUM (0));
}
else
return (bignum_shift_left (n, m));
}
+
+SCHEME_OBJECT
+integer_shift_right (SCHEME_OBJECT n, unsigned long m)
+{
+ if (m == 0)
+ return (n);
+ if (FIXNUM_P (n))
+ {
+ long n1 = (FIXNUM_TO_LONG (n));
+ return (LONG_TO_FIXNUM ((n1 < 0) ? (~ ((~n1) >> m)) : (n1 >> m)));
+ }
+ else
+ return (bignum_to_integer (bignum_shift_right (n, m)));
+}
#define BIGNUM_DIGIT_MASK (BIGNUM_RADIX - 1UL)
#define BIGNUM_HALF_DIGIT_MASK (BIGNUM_RADIX_ROOT - 1UL)
+/* This limit guarantees that the number of bits in a bignum (in ones-
+ or two's-complement) fits in a long. Practically speaking, we won't
+ reach this limit even on a 32-bit machine because the heap can hold
+ at most 2^26 bytes, and thus 2^24 digits -- which is already less
+ than this value, a little under 2^25. The same applies to 64-bit
+ machines; it doesn't cease to apply until 128-bit machines, but
+ we're not going to worry about those. */
+#define BIGNUM_LENGTH_MAX \
+ ((BIGNUM_RADIX / BIGNUM_DIGIT_LENGTH) - BIGNUM_DIGIT_LENGTH)
+
+#define BIGNUM_DIGIT(c) ((bignum_digit_type) (c))
+#define BIGNUM_DIGIT_ONES(n) (~ ((~ (BIGNUM_DIGIT (0))) << (n)))
+
#define BIGNUM_START_PTR(bignum) \
((BIGNUM_TO_POINTER (bignum)) + 1)
#endif
#include "bignmint.h"
+#include "bits.h"
\f
#ifndef MIT_SCHEME
static bignum_type bignum_new_sign (bignum_type, int);
static bignum_type bignum_maybe_new_sign (bignum_type, int);
static void bignum_destructive_copy (bignum_type, bignum_type);
-
-#define ULONG_LENGTH_IN_BITS(digit, len) do \
-{ \
- unsigned long w = digit; \
- len = 0; \
- while (w > 0xff) { len += 8; w >>= 8; } \
- while (w > 0) { len += 1; w >>= 1; } \
-} while (0)
\f
/* Exports */
# include "error: must have FLT_RADIX==2"
#endif
double value = 0;
- bignum_digit_type mask = 0;
bignum_digit_type guard_bit_mask = BIGNUM_RADIX>>1;
bignum_digit_type rounding_correction = 0;
- int current_digit_bit_count = 0;
-
- ULONG_LENGTH_IN_BITS (msd, current_digit_bit_count);
- mask = ((1UL << current_digit_bit_count) - 1UL);
+ int current_digit_bit_count = (ulong_length_in_bits (msd));
+ bignum_digit_type mask = (BIGNUM_DIGIT_ONES (current_digit_bit_count));
while (1) {
if (current_digit_bit_count > bits_to_get) {
}
}
}
+\f
+/* All these bitwise operations are complicated because they interpret
+ integers as their two's-complement representations, whereas bignums
+ are stored in a ones-complement representation. */
bignum_type
+bignum_bitwise_not (bignum_type bignum)
+{
+ return (bignum_subtract ((BIGNUM_ONE (1)), bignum));
+}
+
+#define DEFINE_BITWISE_UNSIGNED(NAME, COMMUTE, OP, POSTOP) \
+static bignum_type \
+NAME (bignum_type x, bignum_type y) \
+{ \
+ if ((BIGNUM_LENGTH (x)) < (BIGNUM_LENGTH (y))) \
+ COMMUTE (y, x); \
+ { \
+ bignum_length_type x_length = (BIGNUM_LENGTH (x)); \
+ bignum_length_type y_length = (BIGNUM_LENGTH (y)); \
+ bignum_length_type r_length = x_length; \
+ bignum_type r = (bignum_allocate (r_length, 0)); \
+ bignum_digit_type *x_scan = (BIGNUM_START_PTR (x)); \
+ bignum_digit_type *x_end = (x_scan + x_length); \
+ bignum_digit_type *y_scan = (BIGNUM_START_PTR (y)); \
+ bignum_digit_type *y_end = (y_scan + y_length); \
+ bignum_digit_type *r_scan = (BIGNUM_START_PTR (r)); \
+ BIGNUM_ASSERT (x_length >= y_length); \
+ while (y_scan < y_end) \
+ (*r_scan++) = (BITWISE_##OP ((*x_scan++), (*y_scan++))); \
+ while (x_scan < x_end) \
+ (*r_scan++) = (BITWISE_##OP ((*x_scan++), 0)); \
+ return (POSTOP (bignum_trim (r))); \
+ } \
+}
+
+#define BITWISE_AND(x, y) ((x) & (y))
+#define BITWISE_ANDC2(x, y) ((x) &~ (y))
+#define BITWISE_ANDC1(x, y) ((y) &~ (x))
+#define BITWISE_XOR(x, y) ((x) ^ (y))
+#define BITWISE_IOR(x, y) ((x) | (y))
+
+/* These don't work, because they set the high bits. */
+/* #define BITWISE_ORC2(x, y) (BIGNUM_DIGIT_MASK & ((x) |~ (y))) */
+/* #define BITWISE_ORC1(x, y) (BIGNUM_DIGIT_MASK & ((y) |~ (x))) */
+\f
+/* Kludgey syntactic hack! */
+#define COMMUTE(name) return bignum_bitwise_##name##_unsigned
+#define SWAP(x, y) do { bignum_type t = x; x = y; y = t; } while (0)
+
+static bignum_type bignum_bitwise_andc1_unsigned (bignum_type, bignum_type);
+static bignum_type bignum_bitwise_orc1_unsigned (bignum_type, bignum_type);
+
+/* These definitions are ordered by their truth tables. */
+
+/* DEFINE_BITWISE_UNSIGNED (bignum_bitwise_clear_unsigned, SWAP, CLEAR,) */
+DEFINE_BITWISE_UNSIGNED (bignum_bitwise_and_unsigned, SWAP, AND,)
+DEFINE_BITWISE_UNSIGNED (bignum_bitwise_andc2_unsigned, COMMUTE(andc1), ANDC2,)
+/* DEFINE_BITWISE_UNSIGNED (bignum_bitwise_arg1_unsigned, COMMUTE(ARG2), ARG1,) */
+DEFINE_BITWISE_UNSIGNED (bignum_bitwise_andc1_unsigned, COMMUTE(andc2), ANDC1,)
+/* DEFINE_BITWISE_UNSIGNED (bignum_bitwise_arg2_unsigned, ARG2,) */
+DEFINE_BITWISE_UNSIGNED (bignum_bitwise_xor_unsigned, SWAP, XOR,)
+DEFINE_BITWISE_UNSIGNED (bignum_bitwise_ior_unsigned, SWAP, IOR,)
+DEFINE_BITWISE_UNSIGNED (bignum_bitwise_nor_unsigned, SWAP, IOR, bignum_bitwise_not)
+DEFINE_BITWISE_UNSIGNED (bignum_bitwise_eqv_unsigned, SWAP, XOR, bignum_bitwise_not)
+/* DEFINE_BITWISE_UNSIGNED (bignum_bitwise_not2_unsigned, COMMUTE(not1), ARG1, bignum_bitwise_not) */
+/* DEFINE_BITWISE_UNSIGNED (bignum_bitwise_orc2_unsigned, COMMUTE(orc1), ORC2,) */
+/* DEFINE_BITWISE_UNSIGNED (bignum_bitwise_not1_unsigned, COMMUTE(not1), ARG2, bignum_bitwise_not) */
+/* DEFINE_BITWISE_UNSIGNED (bignum_bitwise_orc1_unsigned, COMMUTE(orc2), ORC2,) */
+DEFINE_BITWISE_UNSIGNED (bignum_bitwise_nand_unsigned, SWAP, AND, bignum_bitwise_not)
+/* DEFINE_BITWISE_UNSIGNED (bignum_bitwise_set_unsigned, SWAP, CLEAR, bignum_bitwise_not) */
+
+static bignum_type
+bignum_bitwise_orc2_unsigned (bignum_type x, bignum_type y)
+{
+ return (bignum_bitwise_not (bignum_bitwise_andc1 (x, y)));
+}
+
+static bignum_type
+bignum_bitwise_orc1_unsigned (bignum_type x, bignum_type y)
+{
+ return (bignum_bitwise_not (bignum_bitwise_andc2 (x, y)));
+}
+
+#undef SWAP
+#undef COMMUTE
+#undef DEFINE_BITWISE_UNSIGNED
+\f
+#define DEFINE_BITWISE(NAME, X0, Y0, PP, PN, NP, NN) \
+bignum_type \
+NAME (bignum_type x, bignum_type y) \
+{ \
+ if (BIGNUM_ZERO_P (x)) return (Y0); \
+ if (BIGNUM_ZERO_P (y)) return (X0); \
+ return \
+ ((BIGNUM_POSITIVE_P (x)) \
+ ? ((BIGNUM_POSITIVE_P (y)) \
+ ? (bignum_bitwise_##PP##_unsigned (x, y)) \
+ : (bignum_bitwise_##PN##_unsigned (x, (bignum_bitwise_not (y))))) \
+ : ((BIGNUM_POSITIVE_P (y)) \
+ ? (bignum_bitwise_##NP##_unsigned ((bignum_bitwise_not (x)), y)) \
+ : (bignum_bitwise_##NN##_unsigned \
+ ((bignum_bitwise_not (x)), (bignum_bitwise_not (y)))))); \
+}
+
+DEFINE_BITWISE (bignum_bitwise_and, (BIGNUM_ZERO ()), (BIGNUM_ZERO ()),
+ and, andc2, andc1, nor)
+
+DEFINE_BITWISE (bignum_bitwise_andc2, x, (BIGNUM_ZERO ()),
+ andc2, and, nor, andc1)
+
+DEFINE_BITWISE (bignum_bitwise_andc1, (BIGNUM_ZERO ()), y,
+ andc1, nor, and, andc2)
+
+DEFINE_BITWISE (bignum_bitwise_xor, x, y, xor, eqv, eqv, xor)
+
+DEFINE_BITWISE (bignum_bitwise_ior, x, y, ior, orc2, orc1, nand)
+
+DEFINE_BITWISE (bignum_bitwise_nor,
+ (bignum_bitwise_not (x)),
+ (bignum_bitwise_not (y)),
+ nor, andc1, andc2, and)
+
+DEFINE_BITWISE (bignum_bitwise_eqv,
+ (bignum_bitwise_not (x)),
+ (bignum_bitwise_not (y)),
+ eqv, xor, xor, eqv)
+
+DEFINE_BITWISE (bignum_bitwise_orc2,
+ (BIGNUM_ONE (1)), (bignum_bitwise_not (y)),
+ orc2, ior, nand, orc1)
+
+DEFINE_BITWISE (bignum_bitwise_orc1,
+ (bignum_bitwise_not (x)), (BIGNUM_ONE (1)),
+ orc1, nand, ior, orc2)
+
+DEFINE_BITWISE (bignum_bitwise_nand, (BIGNUM_ONE (1)), (BIGNUM_ONE (1)),
+ nand, orc1, orc2, ior)
+
+#undef DEFINE_BITWISE
+\f
+/* General bit-twiddlers. */
+
+/* (edit a a-pos b b-pos selector size)
+ = (ior (and a (shift-left selector a-pos))
+ (shift-left (and (shift-right b b-pos) (not selector)) a-pos))
+
+ In other words, replace a[a-pos + i] by b[b-pos + i] if selector[i]
+ is zero, and shift the result right by pos (which can be negative).
+ For example, (extract size pos x) = (edit x pos 0 0 (mask size 0)). */
+
+#if 0
+bignum_type
+bignum_edit_bit_field (bignum_type x, unsigned long x_position,
+ bignum_type y, unsigned long y_position,
+ bignum_type selector, unsigned long size)
+{
+ BIGNUM_ASSERT (!BIGNUM_NEGATIVE_P (x));
+ BIGNUM_ASSERT (!BIGNUM_NEGATIVE_P (y));
+ BIGNUM_ASSERT (!BIGNUM_NEGATIVE_P (selector));
+ if (BIGNUM_ZERO_P (selector))
+ return (x);
+ {
+ bignum_length_type x_length = (BIGNUM_LENGTH (x));
+ bignum_length_type y_length = (BIGNUM_LENGTH (y));
+ bignum_length_type selector_length = (BIGNUM_LENGTH (selector));
+ bignum_length_type r_length = (MAX (x_length, (y_position + size)));
+ bignum_type r = (bignum_allocate (r_length, (BIGNUM_NEGATIVE_P (x))));
+ bignum_length_type x_digit_position = (x_position / BIGNUM_DIGIT_LENGTH);
+ bignum_length_type y_digit_position = (y_position / BIGNUM_DIGIT_LENGTH);
+ bignum_length_type x_bit_position = (x_position % BIGNUM_DIGIT_LENGTH);
+ bignum_length_type y_bit_position = (y_position % BIGNUM_DIGIT_LENGTH);
+ bignum_digit_type *x_scan = (BIGNUM_START_PTR (x));
+ bignum_digit_type *y_scan = (BIGNUM_START_PTR (y));
+ bignum_digit_type *selector_scan = (BIGNUM_START_PTR (selector));
+ bignum_digit_type *r_scan = (BIGNUM_START_PTR (r));
+ bignum_digit_type *x_end = (x_scan + x_length);
+ bignum_digit_type *y_end = (y_scan + y_length);
+ bignum_digit_type *selector_end = (selector_scan + selector_length);
+ {
+ bignum_digit_type *stop = (x_scan + (MIN (x_digit_position, x_length)));
+ while (x_scan < stop)
+ (*r_scan++) = (*x_scan++);
+ }
+ /* Four cases to deal with, depending on whether or not x and y
+ have more digits. */
+ y_scan += (MIN (y_digit_position, (y_end - y_scan)));
+ if ((x_scan < x_end) && (y_scan < y_end))
+ {
+ bignum_digit_type x_low_mask = (BIGNUM_DIGIT_ONES (x_bit_position));
+ bignum_digit_type x_high_mask
+ = (BIGNUM_DIGIT_ONES (BIGNUM_DIGIT_LENGTH - x_bit_position));
+ bignum_digit_type y_low_mask = (BIGNUM_DIGIT_ONES (y_bit_position));
+ bignum_digit_type y_high_mask
+ = (BIGNUM_DIGIT_ONES (BIGNUM_DIGIT_LENGTH - y_bit_position));
+ bignum_digit_type r_carry = ((*x_scan) & x_low_mask);
+ bignum_digit_type x_carry
+ = (((*x_scan++) >> x_bit_position) & x_high_mask);
+ bignum_digit_type y_carry
+ = (((*y_scan++) >> y_bit_position) & y_high_mask);
+ while ((x_scan < x_end) && (y_scan < y_end))
+ {
+ bignum_digit_type selector = (*selector_scan++);
+ bignum_digit_type x = (*x_scan++);
+ bignum_digit_type y = (*y_scan++);
+ (*r_scan++)
+ = (r_carry
+ | ((x_carry ) << x_bit_position)
+
+
+ | ((((x >> x_bit_position) & x_high_mask &~ selector)
+ | (high_y & selector))
+ << x_bit_position));
+ carry = ...;
+ }
+ }
+ else if (x_scan < x_end)
+ {
+ }
+ else if (y_scan < y_end)
+ {
+ }
+ else
+ {
+ }
+ }
+}
+#endif /* 0 */
+
+/* (splice a a-pos b b-pos size)
+ = (edit a a-pos b b-pos (mask size) size)
+
+ Thus, e.g., (extract size pos x) = (splice x pos 0 0 size). */
+
+#if 0
+bignum_type
+bignum_splice_bit_field (bignum_type x, unsigned long x_position,
+ bignum_type y, unsigned long y_position,
+ unsigned long size)
+{
+ ...
+}
+#endif /* 0 */
+\f
+/* Ones-complement length. */
+
+unsigned long
bignum_length_in_bits (bignum_type bignum)
{
if (BIGNUM_ZERO_P (bignum))
- return (BIGNUM_ZERO ());
+ return (0);
{
bignum_length_type index = ((BIGNUM_LENGTH (bignum)) - 1);
- bignum_digit_type digit = (BIGNUM_REF (bignum, index));
- bignum_digit_type delta = 0;
- bignum_type result = (bignum_allocate (2, 0));
- (BIGNUM_REF (result, 0)) = index;
- (BIGNUM_REF (result, 1)) = 0;
- bignum_destructive_scale_up (result, BIGNUM_DIGIT_LENGTH);
- ULONG_LENGTH_IN_BITS (digit, delta);
- bignum_destructive_add (result, ((bignum_digit_type) delta));
- return (bignum_trim (result));
+ return
+ ((ulong_length_in_bits (BIGNUM_REF (bignum, index)))
+ + (BIGNUM_DIGIT_LENGTH * index));
+ }
+}
+
+/* Two's-complement length. */
+
+unsigned long
+bignum_integer_length (bignum_type bignum)
+{
+ unsigned long length_in_bits = (bignum_length_in_bits (bignum));
+ if ((BIGNUM_ZERO_P (bignum)) || (BIGNUM_POSITIVE_P (bignum)))
+ return (length_in_bits);
+ /* else if (BIGNUM_NEGATIVE_P (bignum)) */
+ {
+ /* We have to test whether it is a negative power of two. If so,
+ we treat its length as one less than bignum_length_in_bits,
+ because we are really measuring the length of the finite
+ sequence of bits before the infinite sequence of zero bits (for
+ nonnegative integers) or one bits (for negative integers) in the
+ integer's general two's-complement representation. Thus,
+ negative powers of two appear to have one fewer bit. */
+ bignum_digit_type *scan = (BIGNUM_START_PTR (bignum));
+ bignum_digit_type *end = (scan + (BIGNUM_LENGTH (bignum)) - 1);
+ while (scan < end)
+ if (0 != (*scan++))
+ return (length_in_bits);
+ return (length_in_bits - (0 == ((*end) & ((*end) - 1))));
+ }
+}
+
+long
+bignum_first_set_bit (bignum_type bignum)
+{
+ if (BIGNUM_ZERO_P (bignum))
+ return (-1);
+ {
+ bignum_digit_type *start = (BIGNUM_START_PTR (bignum));
+ bignum_digit_type *scan = start;
+ bignum_digit_type *end = (scan + (BIGNUM_LENGTH (bignum)));
+ while (scan < end)
+ {
+ if ((*scan) != 0) break;
+ scan += 1;
+ }
+ BIGNUM_ASSERT (scan < end);
+ return
+ ((ulong_bit_count (((*scan) ^ ((*scan) - 1)) >> 1))
+ + ((scan - start) * BIGNUM_DIGIT_LENGTH));
+ }
+}
+\f
+static inline unsigned long
+digits_bit_count (bignum_digit_type **scan_loc, unsigned long count)
+{
+ unsigned long bit_count = 0;
+ bignum_digit_type *end = ((*scan_loc) + count);
+ while ((*scan_loc) < end)
+ bit_count += (ulong_bit_count (* ((*scan_loc) ++)));
+ return (bit_count);
+}
+
+static inline unsigned long
+digits_hamming_distance (bignum_digit_type **x_scan_loc,
+ bignum_digit_type **y_scan_loc,
+ unsigned long count)
+{
+ unsigned long hamming_distance = 0;
+ bignum_digit_type *end = ((*x_scan_loc) + count);
+ while ((*x_scan_loc) < end)
+ hamming_distance
+ += (ulong_bit_count ((* ((*x_scan_loc) ++)) ^ (* ((*y_scan_loc) ++))));
+ return (hamming_distance);
+}
+
+/* Hamming distance: the easy case. */
+
+static unsigned long
+bignum_positive_hamming_distance (bignum_type x, bignum_type y)
+{
+ BIGNUM_ASSERT (!BIGNUM_ZERO_P (x));
+ BIGNUM_ASSERT (!BIGNUM_ZERO_P (y));
+ BIGNUM_ASSERT (BIGNUM_POSITIVE_P (x));
+ BIGNUM_ASSERT (BIGNUM_POSITIVE_P (y));
+ if ((BIGNUM_LENGTH (x)) < (BIGNUM_LENGTH (y)))
+ {
+ bignum_type t = x; x = y; y = t;
+ }
+ {
+ bignum_digit_type *x_scan = (BIGNUM_START_PTR (x));
+ bignum_digit_type *y_scan = (BIGNUM_START_PTR (y));
+ unsigned long hamming_distance
+ = (digits_hamming_distance
+ ((&x_scan), (&y_scan), (BIGNUM_LENGTH (y))));
+ hamming_distance
+ += (digits_bit_count
+ ((&x_scan), ((BIGNUM_LENGTH (x)) - (BIGNUM_LENGTH (y)))));
+ return (hamming_distance);
}
}
+\f
+/* Hamming distance: the hard case. */
+
+#if 0
+/* Is this actually faster than (hamming-distance (not x) (not y))? */
+
+#define MIN(A,B) (((A) < (B)) ? (A) : (B))
+
+static unsigned long
+bignum_negative_hamming_distance (bignum_type x, bignum_type y)
+{
+ BIGNUM_ASSERT (!BIGNUM_ZERO_P (x));
+ BIGNUM_ASSERT (!BIGNUM_ZERO_P (y));
+ BIGNUM_ASSERT (BIGNUM_NEGATIVE_P (x));
+ BIGNUM_ASSERT (BIGNUM_NEGATIVE_P (y));
+ {
+ bignum_digit_type *x_scan = (BIGNUM_START_PTR (x));
+ bignum_digit_type *y_scan = (BIGNUM_START_PTR (y));
+ bignum_digit_type *x_end = (x_scan + (BIGNUM_LENGTH (x)));
+ bignum_digit_type *y_end = (y_scan + (BIGNUM_LENGTH (y)));
+ bignum_digit_type x_digit, y_digit;
+ unsigned long hamming_distance;
+ /* Find the position of the first nonzero digit of x or y, and
+ maybe exchange x and y to guarantee that x's is nonzero. */
+ while (1)
+ {
+ BIGNUM_ASSERT (x_scan < x_end);
+ BIGNUM_ASSERT (y_scan < y_end);
+ x_digit = (*x_scan++);
+ y_digit = (*y_scan++);
+ if (x_digit != 0) break;
+ if (y_digit != 0)
+ {
+ bignum_digit_type *t;
+ t = x_scan; x_scan = y_scan; y_scan = t;
+ t = x_end; x_end = y_end; y_end = t;
+ x_digit = y_digit;
+ y_digit = 0;
+ break;
+ }
+ }
+ /* Convert the first nonzero digit of x and the corresponding digit
+ (possibly zero) of y to two's-complement. */
+ x_digit = (-x_digit);
+ y_digit = (-y_digit);
+ hamming_distance
+ = (ulong_bit_count ((x_digit ^ y_digit) & BIGNUM_DIGIT_MASK));
+ /* Skip over zeroes in y. */
+ if (y_digit == 0)
+ {
+ bignum_digit_type *y_ptr = y_scan;
+ bignum_length_type zeroes;
+ do {
+ BIGNUM_ASSERT (y_scan < y_end);
+ y_digit = (*y_scan++);
+ } while (y_digit == 0);
+ /* If we any more zeroes, compute the Hamming distance of that
+ segment as if all corresponding digits of x were ones. */
+ zeroes = (y_scan - y_ptr - 1);
+ hamming_distance += (zeroes * BIGNUM_DIGIT_LENGTH);
+ /* Then subtract the amount by which this overestimated. */
+ hamming_distance
+ -= (digits_bit_count ((&x_scan), (MIN ((x_end - x_scan), zeroes))));
+ /* Convert the first nonzero digit of y to two's-complement --
+ we can subtract 1 because it is nonzero and (semantically,
+ if not in the type system) unsigned, and hence positive. */
+ hamming_distance
+ += (ulong_bit_count
+ ((y_digit - 1) ^ ((x_scan < x_end) ? (*x_scan++) : 0)));
+ }
+ /* Finally, scan over the overlapping parts of x and y and then the
+ non-overlapping high part of whichever is longer. */
+ hamming_distance
+ += (digits_hamming_distance
+ ((&x_scan), (&y_scan), (MIN ((x_end - x_scan), (y_end - y_scan)))));
+ hamming_distance
+ += ((x_scan < x_end)
+ ? (digits_bit_count ((&x_scan), (x_end - x_scan)))
+ : (digits_bit_count ((&y_scan), (y_end - y_scan))));
+ return (hamming_distance);
+ }
+}
+#endif /* 0 */
+\f
+static unsigned long
+bignum_bit_count_unsigned (bignum_type x)
+{
+ bignum_digit_type *scan = (BIGNUM_START_PTR (x));
+ return (digits_bit_count ((&scan), (BIGNUM_LENGTH (x))));
+}
+
+static unsigned long
+bignum_negative_hamming_distance (bignum_type x, bignum_type y)
+{
+ x = (bignum_bitwise_not (x));
+ y = (bignum_bitwise_not (y));
+ if (BIGNUM_ZERO_P (x)) return (bignum_bit_count_unsigned (y));
+ if (BIGNUM_ZERO_P (y)) return (bignum_bit_count_unsigned (x));
+ return (bignum_positive_hamming_distance (x, y));
+}
+
+unsigned long
+bignum_bit_count (bignum_type x) /* a.k.a. Hamming weight, pop count */
+{
+ if (BIGNUM_ZERO_P (x))
+ return (0);
+ if (BIGNUM_NEGATIVE_P (x))
+ /* return (bignum_negative_hamming_distance (x, (BIGNUM_ONE (1)))); */
+ return (bignum_bit_count_unsigned (bignum_bitwise_not (x)));
+ else
+ return (bignum_bit_count_unsigned (x));
+}
+
+long
+bignum_hamming_distance (bignum_type x, bignum_type y)
+{
+ if (x == y)
+ return (0);
+ if (BIGNUM_ZERO_P (x))
+ return ((BIGNUM_NEGATIVE_P (y)) ? (-1) : (bignum_bit_count_unsigned (y)));
+ if (BIGNUM_ZERO_P (y))
+ return ((BIGNUM_NEGATIVE_P (x)) ? (-1) : (bignum_bit_count_unsigned (x)));
+ return
+ ((BIGNUM_POSITIVE_P (x))
+ ? ((BIGNUM_POSITIVE_P (y))
+ ? (bignum_positive_hamming_distance (x, y))
+ : (-1))
+ : ((BIGNUM_POSITIVE_P (y))
+ ? (-1)
+ : (bignum_negative_hamming_distance (x, y))));
+}
+\f
+#if 0
bignum_type
-bignum_length_upper_limit (void)
+bignum_nonnegative_one_bits (unsigned long size, unsigned long position)
{
- bignum_type result = (bignum_allocate (2, 0));
- (BIGNUM_REF (result, 0)) = 0;
- (BIGNUM_REF (result, 1)) = BIGNUM_DIGIT_LENGTH;
- return (result);
+ if (size == 0)
+ return (BIGNUM_ZERO ());
+ {
+ unsigned long total = (size + position);
+ bignum_length_type total_digits = (total / BIGNUM_DIGIT_LENGTH);
+ bignum_length_type total_bits = (total % BIGNUM_DIGIT_LENGTH);
+ bignum_length_type zero_digits = (position / BIGNUM_DIGIT_LENGTH);
+ bignum_length_type zero_bits = (position % BIGNUM_DIGIT_LENGTH);
+ bignum_length_type one_digits = (size / BIGNUM_DIGIT_LENGTH);
+ bignum_length_type one_bits = (size % BIGNUM_DIGIT_LENGTH);
+ bignum_length_type first_nonzero_bits
+ = (BIGNUM_DIGIT_LENGTH - zero_bits);
+ bignum_length_type first_one_bits
+ = ((one_bits < first_nonzero_bits) ? one_bits
+ : (one_bits - first_nonzero_bits));
+ bignum_length_type last_one_bits = (one_bits - first_one_bits);
+ bignum_length_type length = (total_digits + (0 != total_bits));
+ bignum_type r = (bignum_allocate (length, 0));
+ bignum_digit_type *r_scan = (BIGNUM_START_PTR (r));
+ bignum_digit_type *r_zero_end = (r_scan + zero_digits);
+ bignum_digit_type *r_one_end
+ = (r_zero_end + (first_one_bits != 0) + one_digits);
+ BIGNUM_ASSERT ((r_one_end + (last_one_bits != 0)) == (r_scan + length));
+ while (r_scan < r_zero_end)
+ (*r_scan++) = 0;
+ if (first_one_bits != 0)
+ (*r_scan++) = ((BIGNUM_DIGIT_ONES (first_one_bits)) << zero_bits);
+ while (r_scan < r_one_end)
+ (*r_scan++) = BIGNUM_DIGIT_MASK;
+ if (last_one_bits != 0)
+ (*r_scan++) = (BIGNUM_DIGIT_ONES (last_one_bits));
+ return (r);
+ }
+}
+
+#endif
+
+bignum_type
+bignum_nonnegative_one_bits (unsigned long size, unsigned long position)
+{
+ return
+ (bignum_shift_left
+ ((bignum_bitwise_not (bignum_shift_left ((BIGNUM_ONE (1)), size))),
+ position));
+}
+
+bignum_type
+bignum_negative_zero_bits (unsigned long n, unsigned long m)
+{
+ return (bignum_bitwise_not (bignum_nonnegative_one_bits (n, m)));
+}
+\f
+static bignum_type
+bignum_shift_right_unsigned (bignum_type n,
+ unsigned long digits,
+ unsigned long bits)
+{
+ bignum_length_type n_length = (BIGNUM_LENGTH (n));
+ bignum_digit_type *n_start = (BIGNUM_START_PTR (n));
+ bignum_digit_type *n_scan = (n_start + digits);
+ bignum_digit_type *n_end = (n_start + n_length);
+ bignum_length_type r_length
+ = (n_length - digits
+ - ((n_start < n_end) && (0 == ((n_end[-1]) >> bits))));
+ bignum_type r = (bignum_allocate (r_length, 0));
+ bignum_digit_type *r_scan = (BIGNUM_START_PTR (r));
+ if (bits == 0)
+ while (n_scan < n_end)
+ (*r_scan++) = (*n_scan++);
+ else
+ {
+ bignum_digit_type mask = (BIGNUM_DIGIT_ONES (bits));
+ bignum_digit_type shift = (BIGNUM_DIGIT_LENGTH - bits);
+ bignum_digit_type extra = ((*n_scan++) >> bits);
+ while (n_scan < n_end)
+ {
+ bignum_digit_type digit = (*n_scan++);
+ (*r_scan++) = (((digit & mask) << shift) | extra);
+ extra = (digit >> bits);
+ }
+ if (extra != 0)
+ (*r_scan++) = extra;
+ BIGNUM_ASSERT (r_scan == ((BIGNUM_START_PTR (r)) + r_length));
+ }
+ return (r);
+}
+
+bignum_type
+bignum_shift_right (bignum_type n, unsigned long m)
+{
+ unsigned long digits = (m / BIGNUM_DIGIT_LENGTH);
+ unsigned long bits = (m % BIGNUM_DIGIT_LENGTH);
+
+ if (digits >= (BIGNUM_LENGTH (n)))
+ return ((BIGNUM_NEGATIVE_P (n)) ? (BIGNUM_ONE (1)) : (BIGNUM_ZERO ()));
+
+ if (BIGNUM_NEGATIVE_P (n))
+ return
+ (bignum_bitwise_not
+ (bignum_shift_right_unsigned ((bignum_bitwise_not (n)), digits, bits)));
+ else
+ return (bignum_shift_right_unsigned (n, digits, bits));
}
\f
bignum_type
{
unsigned long ln = (BIGNUM_LENGTH (n));
unsigned long delta = 0;
- if (m == 0)
+ if ((m == 0) || (BIGNUM_ZERO_P (n)))
return (n);
- ULONG_LENGTH_IN_BITS ((BIGNUM_REF (n, (ln - 1))), delta);
+ delta = (ulong_length_in_bits (BIGNUM_REF (n, (ln - 1))));
{
unsigned long zeroes = (m / BIGNUM_DIGIT_LENGTH);
if (n == 0)
return (BIGNUM_ZERO ());
- ULONG_LENGTH_IN_BITS (n, delta);
+ delta = (ulong_length_in_bits (n));
{
unsigned long zeroes = (m / BIGNUM_DIGIT_LENGTH);
return (long_to_bignum (negative_p ? (- digit) : digit));
}
{
- bignum_length_type length;
- {
- unsigned int log_radix = 0;
- ULONG_LENGTH_IN_BITS (radix, log_radix);
- /* This length will be at least as large as needed. */
- length = (BIGNUM_BITS_TO_DIGITS (n_digits * log_radix));
- }
+ /* This length will be at least as large as needed. */
+ bignum_length_type length
+ = (BIGNUM_BITS_TO_DIGITS
+ (n_digits * (ulong_length_in_bits (radix))));
{
bignum_type result = (bignum_allocate_zeroed (length, negative_p));
while ((n_digits--) > 0)
static bignum_type
bignum_allocate (bignum_length_type length, int negative_p)
{
- BIGNUM_ASSERT ((length >= 0) || (length < BIGNUM_RADIX));
+ BIGNUM_ASSERT ((0 <= length) && (length <= BIGNUM_LENGTH_MAX));
{
bignum_type result = (BIGNUM_ALLOCATE (length));
BIGNUM_SET_HEADER (result, length, negative_p);
static bignum_type
bignum_allocate_zeroed (bignum_length_type length, int negative_p)
{
- BIGNUM_ASSERT ((length >= 0) || (length < BIGNUM_RADIX));
+ BIGNUM_ASSERT ((0 <= length) && (length <= BIGNUM_LENGTH_MAX));
{
bignum_type result = (BIGNUM_ALLOCATE (length));
bignum_digit_type * scan = (BIGNUM_START_PTR (result));
bignum_shorten_length (bignum_type bignum, bignum_length_type length)
{
bignum_length_type current_length = (BIGNUM_LENGTH (bignum));
- BIGNUM_ASSERT ((length >= 0) || (length <= current_length));
+ BIGNUM_ASSERT ((0 <= length) && (length <= current_length));
if (length < current_length)
{
BIGNUM_SET_HEADER
extern uintmax_t bignum_to_uintmax (bignum_type);
extern bignum_type double_to_bignum (double);
extern double bignum_to_double (bignum_type);
-extern int bignum_fits_in_word_p
- (bignum_type,
- long word_length,
- int twos_complement_p);
-extern bignum_type bignum_length_in_bits (bignum_type);
-extern bignum_type bignum_length_upper_limit (void);
+extern int bignum_fits_in_word_p (bignum_type, long, int);
+extern unsigned long bignum_length_in_bits (bignum_type);
+extern unsigned long bignum_integer_length (bignum_type);
+extern long bignum_first_set_bit (bignum_type);
+extern unsigned long bignum_bit_count (bignum_type);
+extern long bignum_hamming_distance (bignum_type, bignum_type);
+extern bignum_type bignum_bitwise_not (bignum_type);
+extern bignum_type bignum_bitwise_and (bignum_type, bignum_type);
+extern bignum_type bignum_bitwise_andc2 (bignum_type, bignum_type);
+extern bignum_type bignum_bitwise_andc1 (bignum_type, bignum_type);
+extern bignum_type bignum_bitwise_xor (bignum_type, bignum_type);
+extern bignum_type bignum_bitwise_ior (bignum_type, bignum_type);
+extern bignum_type bignum_bitwise_nor (bignum_type, bignum_type);
+extern bignum_type bignum_bitwise_eqv (bignum_type, bignum_type);
+extern bignum_type bignum_bitwise_orc2 (bignum_type, bignum_type);
+extern bignum_type bignum_bitwise_orc1 (bignum_type, bignum_type);
+extern bignum_type bignum_bitwise_nand (bignum_type, bignum_type);
+#if 0
+extern bignum_type bignum_edit_bit_field
+ (bignum_type, unsigned long,
+ bignum_type, unsigned long,
+ bignum_type, unsigned long);
+extern bignum_type bignum_splice_bit_field
+ (bignum_type, unsigned long,
+ bignum_type, unsigned long,
+ unsigned long);
+#endif
+extern bignum_type bignum_nonnegative_one_bits (unsigned long, unsigned long);
+extern bignum_type bignum_negative_zero_bits (unsigned long, unsigned long);
+extern bignum_type bignum_shift_right (bignum_type, unsigned long);
extern bignum_type bignum_shift_left (bignum_type, unsigned long);
extern bignum_type unsigned_long_to_shifted_bignum
(unsigned long, unsigned long, int);
--- /dev/null
+/* -*-C-*-
+
+Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+ 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+ 2006, 2007, 2008, 2009, 2010 Massachusetts Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme 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
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+*/
+
+#ifndef SCM_BITS_H_INCLUDED
+#define SCM_BITS_H_INCLUDED
+
+#include "config.h"
+\f
+#define DEFINE_BIT_COUNT(NAME, TYPE) \
+static inline unsigned int \
+NAME (TYPE x) \
+{ \
+ /* #b01010101... */ \
+ static const uintmax_t two_bit_mask = ((~ ((TYPE) 0)) / (1 + (1 << 1))); \
+ \
+ /* #b00110011... */ \
+ static const uintmax_t four_bit_mask = ((~ ((TYPE) 0)) / (1 + (1 << 2))); \
+ \
+ /* #b00001111... */ \
+ static const uintmax_t eight_bit_mask = ((~ ((TYPE) 0)) / (1 + (1 << 4))); \
+ \
+ /* Assumption: The number of bits in a uintmax_t fits in eight bits \
+ (unsigned); that is, the number of bits is less than 256. */ \
+ \
+ /* This is a bit mask covering the total number of bits we need. */ \
+ static const uintmax_t final_mask \
+ = (((CHAR_BIT * (sizeof (TYPE))) << 1) - 1); \
+ \
+ int i; \
+ \
+ /* Compute a two-bit population count for each two-bit group in x. \
+ #b00 -> #b00, #b01 -> #b01, #b10 -> #b01, #b11 -> #b10 */ \
+ x -= ((x >> 1) & two_bit_mask); \
+ \
+ /* For successive pairs of two-bit groups, add them up into a \
+ four-bit bit count for both two-bit groups. Each four-bit group \
+ is now either #b0000, #b0001, #b0010, #b0011, or #b0100. Thus \
+ there is always a high-order zero bit, which is safe for storing \
+ carries of addition. */ \
+ x = (((x >> 2) & four_bit_mask) + (x & four_bit_mask)); \
+ \
+ /* Add up the four-bit groups, yielding eight-bit groups whose lower \
+ half is the sum of two four-bit groups and whose upper half is \
+ garbage; mask off the garbage. */ \
+ x = (((x >> 4) + x) & eight_bit_mask); \
+ \
+ /* Add everything up in larger and larger chunks until done. */ \
+ for (i = 8; i < (CHAR_BIT * (sizeof (TYPE))); i <<= 1) \
+ x += (x >> i); \
+ \
+ return (x & final_mask); \
+}
+
+DEFINE_BIT_COUNT (uintmax_bit_count, uintmax_t)
+DEFINE_BIT_COUNT (ulong_bit_count, unsigned long)
+
+#define DEFINE_LENGTH_IN_BITS(NAME, TYPE, BIT_COUNT) \
+static inline unsigned int \
+NAME (TYPE x) \
+{ \
+ /* Round up to a power of two minus one; i.e., set all bits in x \
+ below and including its most significant set bit. */ \
+ int i, limit = (CHAR_BIT * (sizeof (TYPE))); \
+ /* Unrolling this loop substantially improves performance. The `for' \
+ at the end is for completeness; a good compiler should realize \
+ that it is dead code on just about any system. */ \
+ if (1 < limit) x |= (x >> 1); \
+ if (2 < limit) x |= (x >> 2); \
+ if (4 < limit) x |= (x >> 4); \
+ if (8 < limit) x |= (x >> 8); \
+ if (0x10 < limit) x |= (x >> 0x10); \
+ if (0x20 < limit) x |= (x >> 0x20); \
+ for (i = 0x40; i < limit; i <<= 1) \
+ x |= (x >> i); \
+ return (BIT_COUNT (x)); \
+}
+
+DEFINE_LENGTH_IN_BITS (uintmax_length_in_bits, uintmax_t, uintmax_bit_count)
+DEFINE_LENGTH_IN_BITS (ulong_length_in_bits, unsigned long, ulong_bit_count)
+
+#define DEFINE_FIRST_SET_BIT(NAME, TYPE, LENGTH_IN_BITS) \
+static inline int \
+NAME (TYPE x) \
+{ \
+ if (x == 0) return (-1); \
+ return (LENGTH_IN_BITS ((x ^ (x - 1)) >> 1)); \
+}
+
+DEFINE_FIRST_SET_BIT (uintmax_first_set_bit, uintmax_t, uintmax_length_in_bits)
+DEFINE_FIRST_SET_BIT (ulong_first_set_bit, unsigned long, ulong_length_in_bits)
+
+#endif /* !defined(SCM_BITS_H_INCLUDED) */
extern SCHEME_OBJECT integer_quotient (SCHEME_OBJECT, SCHEME_OBJECT);
extern SCHEME_OBJECT integer_remainder (SCHEME_OBJECT, SCHEME_OBJECT);
extern SCHEME_OBJECT integer_length_in_bits (SCHEME_OBJECT);
+extern SCHEME_OBJECT integer_length (SCHEME_OBJECT);
+extern SCHEME_OBJECT integer_first_set_bit (SCHEME_OBJECT);
+extern SCHEME_OBJECT integer_bit_count (SCHEME_OBJECT);
+extern SCHEME_OBJECT integer_hamming_distance (SCHEME_OBJECT, SCHEME_OBJECT);
+extern SCHEME_OBJECT integer_bitwise_not (SCHEME_OBJECT);
+extern SCHEME_OBJECT integer_bitwise_and (SCHEME_OBJECT, SCHEME_OBJECT);
+extern SCHEME_OBJECT integer_bitwise_andc2 (SCHEME_OBJECT, SCHEME_OBJECT);
+extern SCHEME_OBJECT integer_bitwise_andc1 (SCHEME_OBJECT, SCHEME_OBJECT);
+extern SCHEME_OBJECT integer_bitwise_xor (SCHEME_OBJECT, SCHEME_OBJECT);
+extern SCHEME_OBJECT integer_bitwise_ior (SCHEME_OBJECT, SCHEME_OBJECT);
+extern SCHEME_OBJECT integer_bitwise_nor (SCHEME_OBJECT, SCHEME_OBJECT);
+extern SCHEME_OBJECT integer_bitwise_eqv (SCHEME_OBJECT, SCHEME_OBJECT);
+extern SCHEME_OBJECT integer_bitwise_orc2 (SCHEME_OBJECT, SCHEME_OBJECT);
+extern SCHEME_OBJECT integer_bitwise_orc1 (SCHEME_OBJECT, SCHEME_OBJECT);
+extern SCHEME_OBJECT integer_bitwise_nand (SCHEME_OBJECT, SCHEME_OBJECT);
+extern SCHEME_OBJECT integer_nonnegative_one_bits (unsigned long, unsigned long);
+extern SCHEME_OBJECT integer_negative_zero_bits (unsigned long, unsigned long);
extern SCHEME_OBJECT integer_shift_left (SCHEME_OBJECT, unsigned long);
+extern SCHEME_OBJECT integer_shift_right (SCHEME_OBJECT, unsigned long);
extern bool double_is_finite_p (double);
extern SCHEME_OBJECT double_to_flonum (double);
INTEGER_BINARY_OPERATION (integer_subtract)
DEFINE_PRIMITIVE ("INTEGER-MULTIPLY", Prim_integer_multiply, 2, 2, 0)
INTEGER_BINARY_OPERATION (integer_multiply)
-
+DEFINE_PRIMITIVE ("INTEGER-HAMMING-DISTANCE", Prim_integer_hamming_distance, 2, 2, 0)
+ INTEGER_BINARY_OPERATION (integer_hamming_distance)
+DEFINE_PRIMITIVE ("INTEGER-BITWISE-AND", Prim_integer_bitwise_and, 2, 2, 0)
+ INTEGER_BINARY_OPERATION (integer_bitwise_and)
+DEFINE_PRIMITIVE ("INTEGER-BITWISE-ANDC2", Prim_integer_bitwise_andc2, 2, 2, 0)
+ INTEGER_BINARY_OPERATION (integer_bitwise_andc2)
+DEFINE_PRIMITIVE ("INTEGER-BITWISE-ANDC1", Prim_integer_bitwise_andc1, 2, 2, 0)
+ INTEGER_BINARY_OPERATION (integer_bitwise_andc1)
+DEFINE_PRIMITIVE ("INTEGER-BITWISE-XOR", Prim_integer_bitwise_xor, 2, 2, 0)
+ INTEGER_BINARY_OPERATION (integer_bitwise_xor)
+DEFINE_PRIMITIVE ("INTEGER-BITWISE-IOR", Prim_integer_bitwise_ior, 2, 2, 0)
+ INTEGER_BINARY_OPERATION (integer_bitwise_ior)
+DEFINE_PRIMITIVE ("INTEGER-BITWISE-NOR", Prim_integer_bitwise_nor, 2, 2, 0)
+ INTEGER_BINARY_OPERATION (integer_bitwise_nor)
+DEFINE_PRIMITIVE ("INTEGER-BITWISE-EQV", Prim_integer_bitwise_eqv, 2, 2, 0)
+ INTEGER_BINARY_OPERATION (integer_bitwise_eqv)
+DEFINE_PRIMITIVE ("INTEGER-BITWISE-ORC2", Prim_integer_bitwise_orc2, 2, 2, 0)
+ INTEGER_BINARY_OPERATION (integer_bitwise_orc2)
+DEFINE_PRIMITIVE ("INTEGER-BITWISE-ORC1", Prim_integer_bitwise_orc1, 2, 2, 0)
+ INTEGER_BINARY_OPERATION (integer_bitwise_orc1)
+DEFINE_PRIMITIVE ("INTEGER-BITWISE-NAND", Prim_integer_bitwise_nand, 2, 2, 0)
+ INTEGER_BINARY_OPERATION (integer_bitwise_nand)
+\f
#define INTEGER_UNARY_OPERATION(operator) \
{ \
PRIMITIVE_HEADER (1); \
INTEGER_UNARY_OPERATION (integer_subtract_1)
DEFINE_PRIMITIVE ("INTEGER-LENGTH-IN-BITS", Prim_integer_length_in_bits, 1, 1, 0)
INTEGER_UNARY_OPERATION (integer_length_in_bits)
+DEFINE_PRIMITIVE ("INTEGER-LENGTH", Prim_integer_length, 1, 1, 0)
+ INTEGER_UNARY_OPERATION (integer_length)
+DEFINE_PRIMITIVE ("INTEGER-FIRST-SET-BIT", Prim_integer_first_set_bit, 1, 1, 0)
+ INTEGER_UNARY_OPERATION (integer_first_set_bit)
+DEFINE_PRIMITIVE ("INTEGER-BIT-COUNT", Prim_integer_bit_count, 1, 1, 0)
+ INTEGER_UNARY_OPERATION (integer_bit_count)
+DEFINE_PRIMITIVE ("INTEGER-BITWISE-NOT", Prim_integer_bitwise_not, 1, 1, 0)
+ INTEGER_UNARY_OPERATION (integer_bitwise_not)
\f
DEFINE_PRIMITIVE ("INTEGER-DIVIDE", Prim_integer_divide, 2, 2, 0)
{
}
}
\f
+DEFINE_PRIMITIVE ("INTEGER-NONNEGATIVE-ONE-BITS", Prim_integer_nonnegative_one_bits, 2, 2, 0)
+{
+ PRIMITIVE_HEADER (2);
+ PRIMITIVE_RETURN
+ (integer_nonnegative_one_bits
+ ((arg_ulong_integer (1)), (arg_ulong_integer (2))));
+}
+
+DEFINE_PRIMITIVE ("INTEGER-NEGATIVE-ZERO-BITS", Prim_integer_negative_zero_bits, 2, 2, 0)
+{
+ PRIMITIVE_HEADER (2);
+ PRIMITIVE_RETURN
+ (integer_negative_zero_bits
+ ((arg_ulong_integer (1)), (arg_ulong_integer (2))));
+}
+
DEFINE_PRIMITIVE ("INTEGER-SHIFT-LEFT", Prim_integer_shift_left, 2, 2, 0)
+{
+ PRIMITIVE_HEADER (2);
+ CHECK_ARG (1, INTEGER_P);
+ PRIMITIVE_RETURN
+ (integer_shift_left ((ARG_REF (1)), (arg_ulong_integer (2))));
+}
+
+DEFINE_PRIMITIVE ("INTEGER-SHIFT-RIGHT", Prim_integer_shift_right, 2, 2, 0)
{
PRIMITIVE_HEADER (2);
CHECK_ARG (1, INTEGER_P);
{
SCHEME_OBJECT n = (ARG_REF (1));
- if (integer_negative_p (n))
- error_bad_range_arg (1);
- PRIMITIVE_RETURN (integer_shift_left (n, (arg_ulong_integer (2))));
+ SCHEME_OBJECT m = (ARG_REF (2));
+ if (FIXNUM_P (m))
+ {
+ if (FIXNUM_NEGATIVE_P (m))
+ error_bad_range_arg (2);
+ PRIMITIVE_RETURN (integer_shift_right (n, (FIXNUM_TO_ULONG (m))));
+ }
+ else if (BIGNUM_P (m))
+ {
+ if (BIGNUM_NEGATIVE_P (m))
+ error_bad_range_arg (2);
+ PRIMITIVE_RETURN (FIXNUM_ZERO);
+ }
+ else
+ error_wrong_type_arg (2);
}
}
-
+\f
static unsigned int
list_to_integer_producer (void * context)
{
--- /dev/null
+#| -*-Scheme-*-
+
+Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+ 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+ 2006, 2007, 2008, 2009, 2010 Massachusetts Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme 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
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
+;;;; Operations on the Two's-Complement Representation of Integers
+;;; package: (runtime integer-bits)
+
+(declare (usual-integrations))
+\f
+(define-primitives
+ ;; Alphabetical order
+ (bit-antimask integer-negative-zero-bits 2)
+ (bit-count integer-bit-count 1)
+ (bit-mask integer-nonnegative-one-bits 2)
+ (bitwise-not integer-bitwise-not 1)
+ (first-set-bit integer-first-set-bit 1)
+ (hamming-distance integer-hamming-distance 2)
+ (integer-length 1)
+ (shift-left integer-shift-left 2)
+ (shift-right integer-shift-right 2)
+
+ ;; Truth table order
+ (bitwise-and integer-bitwise-and 2)
+ (bitwise-andc2 integer-bitwise-andc2 2)
+ (bitwise-andc1 integer-bitwise-andc1 2)
+ (bitwise-xor integer-bitwise-xor 2)
+ (bitwise-ior integer-bitwise-ior 2)
+ (bitwise-nor integer-bitwise-nor 2)
+ (bitwise-eqv integer-bitwise-eqv 2)
+ (bitwise-orc2 integer-bitwise-orc2 2)
+ (bitwise-orc1 integer-bitwise-orc1 2)
+ (bitwise-nand integer-bitwise-nand 2))
+
+(define (arithmetic-shift integer shift)
+ (if (negative? shift)
+ (shift-right integer (- 0 shift))
+ (shift-left integer shift)))
+
+;; (define (shift number amount)
+;; (cond ((exact-integer? number) (arithmetic-shift number amount))
+;; ((flonum? number) (flonum-denormalize number amount))
+;; ...))
+\f
+;;; Eventually the next two should be primitives with nice definitions
+;;; on bignums requiring only a single copy and nice open-codings for
+;;; the fixnum case.
+
+(define (edit-bit-field selector size a-position a b-position b)
+ (bitwise-merge (shift-left (extract-bit-field size 0 selector) a-position)
+ a
+ (shift-left (extract-bit-field size b-position b)
+ a-position)))
+
+(define (splice-bit-field size a-position a b-position b)
+ ;; (edit-bit-field (bit-mask size 0) size a-position a b-position b)
+ (bitwise-merge (bit-mask size a-position)
+ a
+ (shift-left (extract-bit-field size b-position b)
+ a-position)))
+
+(define-integrable (extract-bit-field size position integer)
+ ;; (splice-bit-field size 0 0 position integer)
+ (bitwise-and (bit-mask size 0) (shift-right integer position)))
+
+(define (replace-bit-field size position integer field)
+ ;; (splice-bit-field size position integer 0 field)
+ (bitwise-ior (shift-left (extract-bit-field size 0 field) position)
+ (bitwise-andc2 integer (bit-mask size position))))
+
+(declare (integrate-operator test-bit-field))
+(define (test-bit-field size position integer mask)
+ (declare (integrate position integer mask))
+ (bitwise-and (extract-bit-field size 0 mask)
+ (extract-bit-field size position integer)))
+
+(define-integrable (any-bits-set? size position integer mask)
+ (not (zero? (test-bit-field size position integer mask))))
+
+(declare (integrate-operator all-bits-set?))
+(define (all-bits-set? size position integer mask)
+ (declare (integrate size position integer))
+ (= mask (test-bit-field size position integer mask)))
+
+(declare (integrate-operator bitwise-merge))
+(define (bitwise-merge mask a b)
+ (declare (integrate a b))
+ (bitwise-ior (bitwise-and a mask)
+ (bitwise-andc2 b mask)))
+
+(define-integrable (set-bit bit integer)
+ (bitwise-ior integer (shift-left 1 bit)))
+
+(define-integrable (clear-bit bit integer)
+ (bitwise-andc2 integer (shift-left 1 bit)))
+
+(define-integrable (toggle-bit bit integer)
+ (bitwise-xor integer (shift-left 1 bit)))
+
+(define-integrable (extract-bit bit integer)
+ (extract-bit-field 1 bit integer))
+
+(define-integrable (bit-set? bit integer)
+ (zero? (extract-bit-field 1 bit integer)))
+\f
+;;; SRFI 60 operations
+
+(define (copy-bit index integer set?)
+ (if set?
+ (set-bit index integer)
+ (clear-bit index integer)))
+
+(define (bit-field integer start end)
+ (extract-bit-field (- end start) start integer))
+
+(define (copy-bit-field to from start end)
+ (replace-bit-field (- end start) start to from))
+
+(define (rotate-bit-field integer count start end)
+ (let ((size (- end start)))
+ (replace-bit-field size start integer
+ (let ((count (remainder count size))
+ (bit-field (extract-bit-field size start integer)))
+ (bitwise-ior (shift-left bit-field count)
+ (shift-right bit-field (- size count)))))))
+
+(define (bit-reverse size integer)
+ (define (loop size integer result)
+ (if (positive? size)
+ (loop (- size 1)
+ (shift-right integer 1)
+ (bitwise-ior (shift-left result 1) (bitwise-and integer 1)))
+ result))
+ (if (negative? integer)
+ (bitwise-not (loop size (bitwise-not integer) 0))
+ (loop size integer 0)))
+
+(define (reverse-bit-field integer start end)
+ (let ((size (- end start)))
+ (replace-bit-field size start
+ (bit-reverse (extract-bit-field size start integer)))))
+
+(define (integer->list integer #!optional length)
+ (if (default-object? length)
+ (do ((integer integer (shift-right integer 1))
+ (bits '() (cons (odd? integer) bits)))
+ ((zero? integer) bits))
+ (begin
+ (guarantee-index-fixnum length 'INTEGER->LIST)
+ (do ((length length (- length 1))
+ (integer integer (shift-right integer 1))
+ (bits '() (cons (odd? integer) bits)))
+ ((zero? length) bits)))))
+
+(define (list->integer bits)
+ (do ((bits bits (cdr bits))
+ (integer 0 (bitwise-ior (shift-left integer 1) (if (car bits) 1 0))))
+ ((not (pair? bits)) integer)))
non-positive-fixnum?
positive-fixnum?))
+(define-package (runtime integer-bits)
+ (files "integer-bits")
+ (parent (runtime))
+ (export ()
+ all-bits-set?
+ any-bits-set?
+ arithmetic-shift
+ bit-antimask
+ bit-count
+ bit-mask
+ bit-set?
+ bitwise-merge
+ bitwise-not
+ clear-bit
+ edit-bit-field
+ extract-bit
+ extract-bit-field
+ first-set-bit
+ hamming-distance
+ integer-length
+ replace-bit-field
+ set-bit
+ shift-left
+ shift-right
+ splice-bit-field
+ test-bit-field
+
+ ;; Truth table order
+ bitwise-and
+ bitwise-andc1
+ bitwise-andc2
+ bitwise-xor
+ bitwise-ior
+ bitwise-nor
+ bitwise-eqv
+ bitwise-orc2
+ bitwise-orc1
+ bitwise-nand))
+
(define-package (runtime keyword)
(files "keyword")
(parent (runtime))
--- /dev/null
+#| -*-Scheme-*-
+
+Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+ 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+ 2006, 2007, 2008, 2009, 2010 Massachusetts Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme 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
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
+;;;; Tests of integer bit operations
+
+(declare (usual-integrations))
+\f
+(define (random-integer-of-weight w n)
+ (let ((bit-string (make-bit-string n #f)))
+ (do ((i 0 (+ i 1))) ((>= i w)) (bit-string-set! bit-string i))
+ (do ((i 1 (+ i 1))) ((>= i n))
+ (let ((j (random-integer (+ i 1))))
+ (let ((t (bit-string-ref bit-string i)))
+ ((if (bit-string-ref bit-string j) bit-string-set! bit-string-clear!)
+ bit-string i)
+ ((if t bit-string-set! bit-string-clear!) bit-string j))))
+ (let ((integer (bit-string->unsigned-integer bit-string)))
+ (if (zero? (random-integer 2))
+ (- -1 integer)
+ integer))))
+
+(define (random-fixnum)
+ (+ (smallest-fixnum)
+ (random-integer (- (+ 1 (largest-fixnum)) (smallest-fixnum)))))
+
+(define (random-large-integer)
+ (let ((n (random-integer #x100)))
+ (random-integer-of-weight (random-integer (+ n 1)) n)))
+
+(define (randomly-generate-integers procedure)
+ (do ((i 0 (+ i 1))) ((= i #x100))
+ (procedure (random-large-integer))))
+
+(define (randomly-generate-fixnums procedure)
+ (do ((i 0 (+ i 1))) ((= i #x1000))
+ (procedure (random-fixnum))))
+
+(define (randomly-generate-integer-pairs procedure)
+ (do ((i 0 (+ i 1))) ((= i #x100))
+ (procedure (random-large-integer) (random-large-integer))))
+
+(define (randomly-generate-fixnum-pairs procedure)
+ (do ((i 0 (+ i 1))) ((= i #x1000))
+ (procedure (random-fixnum) (random-fixnum))))
+
+(define (define-random-unary-fixnum-test name procedure)
+ (define-test name
+ (lambda ()
+ (randomly-generate-fixnums procedure))))
+
+(define (define-random-unary-integer-test name procedure)
+ (define-test name
+ (lambda ()
+ (randomly-generate-integers procedure))))
+
+(define (define-random-binary-fixnum-test name procedure)
+ (define-test name
+ (lambda ()
+ (randomly-generate-fixnum-pairs procedure))))
+
+(define (define-random-binary-integer-test name procedure)
+ (define-test name
+ (lambda ()
+ (randomly-generate-integer-pairs procedure))))
+\f
+;;;; Shift
+
+(define-test 'SHIFT-LEFT:0
+ (lambda ()
+ (do ((i 0 (+ i 1))) ((>= i #x1000))
+ (assert-eqv (shift-left 0 i) 0))))
+
+(define-test 'SHIFT-LEFT:+1
+ (lambda ()
+ (do ((i 0 (+ i 1))) ((>= i #x1000))
+ (assert-eqv (shift-left 1 i) (expt 2 i)))))
+
+(define-test 'SHIFT-LEFT:-1
+ (lambda ()
+ (do ((i 0 (+ i 1))) ((>= i #x1000))
+ (assert-eqv (shift-left -1 i) (* -1 (expt 2 i))))))
+
+(define-test 'SHIFT-LEFT:POSITIVE
+ (lambda ()
+ (do ((i 0 (+ i 1))) ((>= i #x10))
+ (let ((n (random-integer #x1000)))
+ (do ((i 0 (+ i 1))) ((>= i #x100))
+ (assert-eqv (shift-left n i) (* n (expt 2 i))))))))
+
+(define-test 'SHIFT-LEFT:NEGATIVE
+ (lambda ()
+ (do ((i 0 (+ i 1))) ((>= i #x10))
+ (let ((n (- -1 (random-integer #x1000))))
+ (do ((i 0 (+ i 1))) ((>= i #x100))
+ (assert-eqv (shift-left n i) (* n (expt 2 i))))))))
+
+(define-test 'SHIFT-RIGHT:0
+ (lambda ()
+ (do ((i 0 (+ i 1))) ((>= i #x1000))
+ (assert-eqv (shift-right 0 i) 0))))
+
+(define-test 'SHIFT-RIGHT:1
+ (lambda ()
+ (assert-eqv (shift-right 1 0) 1)
+ (do ((i 1 (+ i 1))) ((>= i #x1000))
+ (assert-eqv (shift-right 0 i) 0))))
+
+(define-test 'SHIFT-RIGHT:-1
+ (lambda ()
+ (do ((i 0 (+ i 1))) ((>= i #x1000))
+ (assert-eqv (shift-right -1 i) -1))))
+
+(define-test 'SHIFT-LEFT-THEN-RIGHT:POSITIVE
+ (lambda ()
+ (do ((i 0 (+ i 1))) ((>= i #x10))
+ (let ((n (random-integer #x1000)))
+ (do ((i 0 (+ i 1))) ((>= i #x100))
+ (assert-eqv (shift-right (shift-left n i) i) n))))))
+
+(define-test 'SHIFT-LEFT-THEN-RIGHT:NEGATIVE
+ (lambda ()
+ (do ((i 0 (+ i 1))) ((>= i #x10))
+ (let ((n (- -1 (random-integer #x1000))))
+ (do ((i 0 (+ i 1))) ((>= i #x100))
+ (assert-eqv (shift-right (shift-left n i) i) n))))))
+\f
+;;;; Bitwise NOT
+
+(define-test 'BITWISE-NOT:0
+ (lambda ()
+ (assert-eqv (bitwise-not 0) -1)
+ (assert-eqv (bitwise-not -1) 0)))
+
+(define-test 'BITWISE-NOT:1
+ (lambda ()
+ (assert-eqv (bitwise-not 1) -2)
+ (assert-eqv (bitwise-not -2) 1)))
+
+(define-test 'BITWISE-NOT:EXTREME-FIXNUM
+ (lambda ()
+ (assert-eqv (bitwise-not (largest-fixnum)) (smallest-fixnum))
+ (assert-eqv (bitwise-not (smallest-fixnum)) (largest-fixnum))))
+
+(define-random-unary-fixnum-test 'BITWISE-NOT:FIXNUM
+ (lambda (n)
+ (assert-eqv (bitwise-not n) (- -1 n))
+ (assert-eqv (bitwise-not (bitwise-not n)) n)
+ (assert-eqv (bitwise-not n) (fix:not n))
+ (assert-eqv (bitwise-not (fix:not n)) n)))
+
+(define-random-unary-integer-test 'BITWISE-NOT
+ (lambda (n)
+ (assert-eqv (bitwise-not n) (- -1 n))
+ (assert-eqv (bitwise-not (bitwise-not n)) n)))
+\f
+;;;; Binary Bitwise Operators
+
+(define (define-bitwise/fixnum-test name general-operator fixnum-operator)
+ (define-random-binary-fixnum-test (symbol name ': 'FIXNUM)
+ (lambda (a b)
+ (assert-eqv (general-operator a b) (fixnum-operator a b)))))
+
+(define-bitwise/fixnum-test 'BITWISE-AND bitwise-and fix:and)
+(define-bitwise/fixnum-test 'BITWISE-ANDC2 bitwise-andc2 fix:andc)
+(define-bitwise/fixnum-test 'BITWISE-IOR bitwise-ior fix:or)
+(define-bitwise/fixnum-test 'BITWISE-XOR bitwise-xor fix:xor)
+
+(define (euclidean-divide n d)
+ (let ((q ((if (negative? d) ceiling floor) (/ n d))))
+ (values q (- n (* d q)))))
+
+(define (define-binary-bitwise-test name operator ff ft tf tt)
+ (define (bit a b)
+ (vector-ref (vector ff ft tf tt) (+ (* a 2) b)))
+ (define (result? object)
+ (or (= object -1) (= object 0)))
+ (define (result-bit result)
+ (case result ((-1) 1) ((0) 0) (else -1)))
+ (define (check-integer a b)
+ (let ((a*b (operator a b)))
+ (define (check-bit a0 b0 a*b0)
+ (if (not (eqv? a*b0 (bit a0 b0)))
+ (error "Failed:" `(,name ,a ,b) '=> a*b)))
+ (let loop ((a a) (b b) (a*b a*b))
+ (if (and (result? a) (result? b))
+ (check-bit (result-bit a) (result-bit b) (result-bit a*b))
+ (receive (a a0) (euclidean-divide a 2)
+ (receive (b b0) (euclidean-divide b 2)
+ (receive (a*b a*b0) (euclidean-divide a*b 2)
+ (check-bit a0 b0 a*b0)
+ (loop a b a*b))))))))
+ (define (define-trivial-test subname a b)
+ (define (signum x) (cond ((< x 0) -1) ((< 0 x) +1) (else 0)))
+ (define-test (symbol name ': subname ': (signum a) ': (signum b))
+ (lambda ()
+ (check-integer a b))))
+ (define-trivial-test 'TRIVIAL-FIXNUM 0 0)
+ (define-trivial-test 'TRIVIAL-FIXNUM 0 1)
+ (define-trivial-test 'TRIVIAL-FIXNUM 1 0)
+ (define-trivial-test 'TRIVIAL-FIXNUM 1 1)
+ (define-trivial-test 'TRIVIAL-FIXNUM 0 -1)
+ (define-trivial-test 'TRIVIAL-FIXNUM -1 0)
+ (define-trivial-test 'TRIVIAL-FIXNUM -1 -1)
+ (let ((s (expt 2 100)))
+ (define-trivial-test 'TRIVIAL-BIGNUM 0 s)
+ (define-trivial-test 'TRIVIAL-BIGNUM s 0)
+ (define-trivial-test 'TRIVIAL-BIGNUM s s))
+ (define-random-binary-integer-test (symbol name ': 'RANDOM) check-integer))
+
+;; (define-binary-bitwise-test 'BITWISE-CLEAR bitwise-clear 0 0 0 0)
+(define-binary-bitwise-test 'BITWISE-AND bitwise-and 0 0 0 1)
+(define-binary-bitwise-test 'BITWISE-ANDC2 bitwise-andc2 0 0 1 0)
+;; (define-binary-bitwise-test 'BITWISE-ARG1 bitwise-arg1 0 0 1 1)
+(define-binary-bitwise-test 'BITWISE-ANDC1 bitwise-andc1 0 1 0 0)
+;; (define-binary-bitwise-test 'BITWISE-ARG2 bitwise-arg2 0 1 0 1)
+(define-binary-bitwise-test 'BITWISE-XOR bitwise-xor 0 1 1 0)
+(define-binary-bitwise-test 'BITWISE-IOR bitwise-ior 0 1 1 1)
+(define-binary-bitwise-test 'BITWISE-NOR bitwise-nor 1 0 0 0)
+(define-binary-bitwise-test 'BITWISE-EQV bitwise-eqv 1 0 0 1)
+;; (define-binary-bitwise-test 'BITWISE-NOT2 bitwise-not2 1 0 1 0)
+(define-binary-bitwise-test 'BITWISE-ORC2 bitwise-orc2 1 0 1 1)
+;; (define-binary-bitwise-test 'BITWISE-NOT1 bitwise-not2 1 1 0 0)
+(define-binary-bitwise-test 'BITWISE-ORC1 bitwise-orc1 1 1 0 1)
+(define-binary-bitwise-test 'BITWISE-NAND bitwise-nand 1 1 1 0)
+;; (define-binary-bitwise-test 'BITWISE-SET bitwise-set 1 1 1 1)
+\f
+;;;;; Binary Bitwise Identities
+
+(define (define-bitwise-identity-test name operator identity)
+ (define-random-unary-integer-test (symbol name ': 'IDENTITY)
+ (lambda (n)
+ (assert-eqv (operator n identity) n)
+ (assert-eqv (operator identity n) n))))
+
+(define-bitwise-identity-test 'BITWISE-AND bitwise-and -1)
+(define-bitwise-identity-test 'BITWISE-XOR bitwise-xor 0)
+(define-bitwise-identity-test 'BITWISE-IOR bitwise-ior 0)
+(define-bitwise-identity-test 'BITWISE-EQV bitwise-eqv -1)
+
+(define (define-bitwise-commutativity-test name operator)
+ (define-random-binary-integer-test (symbol name ': 'COMMUTATIVITY)
+ (lambda (a b)
+ (assert-eqv (operator a b) (operator b a)))))
+
+(define-bitwise-commutativity-test 'BITWISE-AND bitwise-and)
+(define-bitwise-commutativity-test 'BITWISE-XOR bitwise-xor)
+(define-bitwise-commutativity-test 'BITWISE-IOR bitwise-ior)
+(define-bitwise-commutativity-test 'BITWISE-NOR bitwise-nor)
+(define-bitwise-commutativity-test 'BITWISE-EQV bitwise-eqv)
+(define-bitwise-commutativity-test 'BITWISE-NAND bitwise-nand)
+
+(define-random-binary-integer-test 'BITWISE-AND:DEMORGAN
+ (lambda (a b)
+ (assert-eqv (bitwise-and a b)
+ (bitwise-not (bitwise-ior (bitwise-not a) (bitwise-not b))))))
+
+(define-random-binary-integer-test 'BITWISE-ANDC2:AND-NOT2
+ (lambda (a b)
+ (assert-eqv (bitwise-andc2 a b) (bitwise-and a (bitwise-not b)))))
+
+(define-random-binary-integer-test 'BITWISE-ANDC1:AND-NOT1
+ (lambda (a b)
+ (assert-eqv (bitwise-andc1 a b) (bitwise-and (bitwise-not a) b))))
+
+(define-random-binary-integer-test 'BITWISE-NOR:NOT-IOR
+ (lambda (a b)
+ (assert-eqv (bitwise-nor a b) (bitwise-not (bitwise-ior a b)))))
+
+(define-random-binary-integer-test 'BITWISE-XOR:AND-NAND-IOR
+ (lambda (a b)
+ (assert-eqv (bitwise-xor a b)
+ (bitwise-and (bitwise-nand a b) (bitwise-ior a b)))))
+
+(define-random-binary-integer-test 'BITWISE-EQV:NOT-XOR
+ (lambda (a b)
+ (assert-eqv (bitwise-eqv a b) (bitwise-not (bitwise-xor a b)))))
+
+(define-random-binary-integer-test 'BITWISE-ORC1:IOR-NOT1
+ (lambda (a b)
+ (assert-eqv (bitwise-orc1 a b) (bitwise-ior (bitwise-not a) b))))
+
+(define-random-binary-integer-test 'BITWISE-ORC2:IOR-NOT2
+ (lambda (a b)
+ (assert-eqv (bitwise-orc2 a b) (bitwise-ior a (bitwise-not b)))))
+
+(define-random-binary-integer-test 'BITWISE-NAND:NOT-AND
+ (lambda (a b)
+ (assert-eqv (bitwise-nand a b) (bitwise-not (bitwise-and a b)))))
+\f
+(define-test 'BIT-COUNT
+ (lambda ()
+ (do ((i 0 (+ i 1))) ((= i #x100))
+ (let* ((w (random-integer #x1000))
+ (n (random-integer-of-weight w #x1000))
+ (c (bit-count n)))
+ (if (not (eqv? c w))
+ (error "Failed:" `(BIT-COUNT ,n) '=> c 'EXPECTED w))))))
+
+(define-test 'BIT-COUNT/COMPLEMENT
+ (lambda ()
+ (do ((i 0 (+ i 1))) ((= i #x100))
+ (let* ((w (random-integer #x1000))
+ (n (random-integer-of-weight w #x1000))
+ (c (bit-count (bitwise-not n))))
+ (if (not (eqv? c w))
+ (error "Failed:" `(BIT-COUNT (BITWISE-NOT ,n))
+ '=> c
+ 'EXPECTED w))))))
+
+(define-random-unary-integer-test 'INTEGER-LENGTH
+ (let ((integer-length-in-bits
+ (make-primitive-procedure 'INTEGER-LENGTH-IN-BITS 1)))
+ (lambda (n)
+ (assert-eqv (integer-length n)
+ (integer-length-in-bits
+ (if (negative? n) (bitwise-not n) n))))))
+
+(define-test 'FIRST-SET-BIT:0 (lambda () (assert-eqv (first-set-bit 0) -1)))
+(define-test 'FIRST-SET-BIT:+1 (lambda () (assert-eqv (first-set-bit +1) 0)))
+(define-test 'FIRST-SET-BIT:-1 (lambda () (assert-eqv (first-set-bit -1) 0)))
+
+(define-random-unary-integer-test 'FIRST-SET-BIT:ODD
+ (lambda (n)
+ (if (not (zero? n))
+ (let ((i (random-integer #x1000)))
+ (assert-eqv (first-set-bit (shift-left (bitwise-ior n 1) i)) i)))))
+
+(define-random-unary-integer-test 'FIRST-SET-BIT:RANDOM
+ (lambda (n)
+ (if (not (zero? n))
+ (let ((i (random-integer #x1000)))
+ (assert-eqv (first-set-bit (shift-left n i))
+ (+ i (first-set-bit n)))))))
+
+((lambda (procedure)
+ (for-each (lambda (entry) (procedure (car entry) (cadr entry) (cddr entry)))
+ '((0 0 . 0)
+ (0 -1 . -1)
+ (-1 0 . -1)
+ (-1 -1 . 0))))
+ (lambda (a b a*b)
+ (define-test (symbol 'HAMMING-DISTANCE ': a ': b)
+ (lambda ()
+ (assert-eqv (hamming-distance a b) a*b)))))
+
+(define-random-binary-integer-test 'HAMMING-DISTANCE
+ (lambda (a b)
+ (if (not (eqv? (hamming-distance a b)
+ (if (eqv? (negative? a) (negative? b))
+ (bit-count (bitwise-xor a b))
+ -1)))
+ (error "Failed:" `(HAMMING-DISTANCE ,a ,b)
+ '=> (hamming-distance a b)))))
+
+(define-test 'BIT-MASK
+ (lambda ()
+ (do ((i 0 (+ i 1))) ((>= i #x1000))
+ (let ((size (random-integer #x1000))
+ (position (random-integer #x1000)))
+ (assert-eqv (bit-mask size position)
+ (shift-left
+ (bitwise-not (shift-left -1 size))
+ position))))))
+
+(define-test 'BIT-ANTIMASK
+ (lambda ()
+ (do ((i 0 (+ i 1))) ((>= i #x1000))
+ (let ((size (random-integer #x1000))
+ (position (random-integer #x1000)))
+ (assert-eqv (bit-antimask size position)
+ (bitwise-not
+ (shift-left (bitwise-not (shift-left -1 size))
+ position)))))))
projects / mit-scheme.git / commitdiff