From: Taylor R Campbell Date: Sun, 17 Oct 2010 20:00:34 +0000 (+0000) Subject: New operations on the two's-complement representation of integers. X-Git-Tag: 20101212-Gtk~33 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=f175e3ee886e7fbef84661c9a3618ed68bd4479f;p=mit-scheme.git New operations on the two's-complement representation of integers. These include the SRFI 33 operations, as well as some other useful operations. Although these are implemented as primitives with native definitions for bignums, the primitives are not yet open-coded for the fixnum case. Eventually they should be open-coded, so that you don't need to make a choice between safe code using the integer operations and fast code using FIX:AND, FIX:LSH, &c. Some operations are easy to open-code for the fixnum case, such as all the bitwise operations. Others are not so easy, such as SHIFT-LEFT, and it would be better to open-code common aggregate operations such as EXTRACT-BIT-FIELD for the fixnum case. In any case, at least we now have names for the safe operations. --- diff --git a/src/microcode/artutl.c b/src/microcode/artutl.c index a709c0db0..e7bf7eac3 100644 --- a/src/microcode/artutl.c +++ b/src/microcode/artutl.c @@ -26,6 +26,7 @@ USA. /* Arithmetic Utilities */ #include "scheme.h" +#include "bits.h" /* Conversions between Scheme types and C types. */ @@ -477,10 +478,7 @@ integer_quotient (SCHEME_OBJECT n, SCHEME_OBJECT d) } { 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))); } } @@ -517,43 +515,197 @@ integer_remainder (SCHEME_OBJECT n, SCHEME_OBJECT d) } } -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)))); +} + +/* 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) + +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))); +} diff --git a/src/microcode/bignmint.h b/src/microcode/bignmint.h index f3d62c186..42727ac97 100644 --- a/src/microcode/bignmint.h +++ b/src/microcode/bignmint.h @@ -95,6 +95,19 @@ extern void abort (); #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) diff --git a/src/microcode/bignum.c b/src/microcode/bignum.c index c06735539..072e16ee5 100644 --- a/src/microcode/bignum.c +++ b/src/microcode/bignum.c @@ -32,6 +32,7 @@ USA. #endif #include "bignmint.h" +#include "bits.h" #ifndef MIT_SCHEME @@ -100,14 +101,6 @@ static bignum_type bignum_copy (bignum_type); 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) /* Exports */ @@ -622,13 +615,10 @@ bignum_to_double (bignum_type bignum) # 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) { @@ -781,33 +771,599 @@ bignum_fits_in_word_p (bignum_type bignum, long word_length, } } } + +/* 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))) */ + +/* 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 + +#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 + +/* 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 */ + +/* 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)); + } +} + +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); } } + +/* 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 */ + +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)))); +} + +#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))); +} + +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)); } bignum_type @@ -815,10 +1371,10 @@ bignum_shift_left (bignum_type n, unsigned long m) { 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); @@ -858,7 +1414,7 @@ unsigned_long_to_shifted_bignum (unsigned long n, unsigned long m, int sign) 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); @@ -897,13 +1453,10 @@ digit_stream_to_bignum (unsigned int n_digits, 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) @@ -1797,7 +2350,7 @@ bignum_digit_to_bignum (bignum_digit_type digit, int negative_p) 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); @@ -1808,7 +2361,7 @@ bignum_allocate (bignum_length_type length, int 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)); @@ -1824,7 +2377,7 @@ static bignum_type 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 diff --git a/src/microcode/bignum.h b/src/microcode/bignum.h index 0779b5c7f..b7a471c07 100644 --- a/src/microcode/bignum.h +++ b/src/microcode/bignum.h @@ -73,12 +73,36 @@ extern intmax_t bignum_to_intmax (bignum_type); 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); diff --git a/src/microcode/bits.h b/src/microcode/bits.h new file mode 100644 index 000000000..6c8c92c12 --- /dev/null +++ b/src/microcode/bits.h @@ -0,0 +1,114 @@ +/* -*-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" + +#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) */ diff --git a/src/microcode/extern.h b/src/microcode/extern.h index 3b2b48e86..50e0f20c7 100644 --- a/src/microcode/extern.h +++ b/src/microcode/extern.h @@ -245,7 +245,25 @@ extern bool integer_divide 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); diff --git a/src/microcode/intprm.c b/src/microcode/intprm.c index 22d40bfca..ea196c184 100644 --- a/src/microcode/intprm.c +++ b/src/microcode/intprm.c @@ -79,7 +79,29 @@ DEFINE_PRIMITIVE ("INTEGER-SUBTRACT", Prim_integer_subtract, 2, 2, 0) 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) + #define INTEGER_UNARY_OPERATION(operator) \ { \ PRIMITIVE_HEADER (1); \ @@ -95,6 +117,14 @@ DEFINE_PRIMITIVE ("INTEGER-SUBTRACT-1", Prim_integer_subtract_1, 1, 1, 0) 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) DEFINE_PRIMITIVE ("INTEGER-DIVIDE", Prim_integer_divide, 2, 2, 0) { @@ -162,18 +192,54 @@ DEFINE_PRIMITIVE ("INTEGER->FLONUM", Prim_integer_to_flonum, 2, 2, 0) } } +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); } } - + static unsigned int list_to_integer_producer (void * context) { diff --git a/src/runtime/integer-bits.scm b/src/runtime/integer-bits.scm new file mode 100644 index 000000000..a0313df25 --- /dev/null +++ b/src/runtime/integer-bits.scm @@ -0,0 +1,178 @@ +#| -*-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)) + +(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)) +;; ...)) + +;;; 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))) + +;;; 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))) diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg index 0a735f42c..4caf653ab 100644 --- a/src/runtime/runtime.pkg +++ b/src/runtime/runtime.pkg @@ -288,6 +288,45 @@ USA. 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)) diff --git a/tests/runtime/test-integer-bits.scm b/tests/runtime/test-integer-bits.scm new file mode 100644 index 000000000..8b71f9ef3 --- /dev/null +++ b/tests/runtime/test-integer-bits.scm @@ -0,0 +1,395 @@ +#| -*-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)) + +(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)))) + +;;;; 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)))))) + +;;;; 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))) + +;;;; 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) + +;;;;; 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))))) + +(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)))))))