diff options
| -rw-r--r-- | otherlibs/num/big_int.ml | 179 | ||||
| -rw-r--r-- | otherlibs/num/big_int.mli | 26 | ||||
| -rw-r--r-- | otherlibs/num/test/test_big_ints.ml | 129 |
3 files changed, 334 insertions, 0 deletions
diff --git a/otherlibs/num/big_int.ml b/otherlibs/num/big_int.ml index d742c595b..9465bcd6c 100644 --- a/otherlibs/num/big_int.ml +++ b/otherlibs/num/big_int.ml @@ -656,3 +656,182 @@ let approx_big_int prec bi = else (sign^(String.sub s off 1)^"."^ (String.sub s (succ off) (pred prec)) ^"e"^(string_of_int (n - succ off + String.length s))) + +(* Logical operations *) + +(* Shift left by N bits *) + +let shift_left_big_int bi n = + if n < 0 then invalid_arg "shift_left_big_int" + else if n = 0 then bi + else if bi.sign = 0 then bi + else begin + let size_bi = num_digits_big_int bi in + let size_res = size_bi + ((n + length_of_digit - 1) / length_of_digit) in + let res = create_nat size_res in + let ndigits = n / length_of_digit in + set_to_zero_nat res 0 ndigits; + blit_nat res ndigits bi.abs_value 0 size_bi; + let nbits = n mod length_of_digit in + if nbits > 0 then + shift_left_nat res ndigits size_bi res (ndigits + size_bi) nbits; + { sign = bi.sign; abs_value = res } + end + +(* Shift right by N bits (rounds toward zero) *) + +let shift_right_big_int bi n = + if n < 0 then invalid_arg "shift_right_big_int" + else if n = 0 then bi + else if bi.sign = 0 then bi + else begin + let size_bi = num_digits_big_int bi in + let ndigits = n / length_of_digit in + let nbits = n mod length_of_digit in + if ndigits >= size_bi then zero_big_int else begin + let size_res = size_bi - ndigits in + let res = create_nat size_res in + blit_nat res 0 bi.abs_value ndigits size_res; + if nbits > 0 then begin + let tmp = create_nat 1 in + shift_right_nat res 0 size_res tmp 0 nbits + end; + { sign = bi.sign; abs_value = res } + end + end + +(************************************* +(* Compute 2^n *) + +let two_power_big_int n = + if n < 0 then invalid_arg "two_power_big_int"; + let size_res = (n + length_of_digit - 1) / length_of_digit in + let res = make_nat n in + set_digit_nat_native res (n / length_of_digit) + (Nativeint.shift_left 1n (n mod length_of_digit)); + { sign = 1; abs_value = res } + +(* Compute 2^n - 1 *) + +let two_power_m1_big_int n = + if n < 0 then invalid_arg "two_power_m1_big_int" + else if n = 0 then zero_big_int + else begin + let size_res = (n + length_of_digit - 1) / length_of_digit in + let res = make_nat n in + set_digit_nat_native res (n / length_of_digit) + (Nativeint.shift_left 1n (n mod length_of_digit)); + ignore (decr_nat res 0 size_res 0); + { sign = 1; abs_value = res } + end + +(* Shift right logical by N bits (rounds toward minus infinity) *) + +let lsr_big_int bi n = + if n < 0 then invalid_arg "asr_big_int" + else if bi.sign >= 0 then asr_big_int bi n + else asr_big_int (sub_big_int bi (two_power_m1_big_int n)) n +**************************) + +(* Extract N bits starting at ofs. + Treats bi in two's complement. + Result is always positive. *) + +let extract_big_int bi ofs n = + if ofs < 0 || n < 0 then invalid_arg "extract_big_int" + else if bi.sign = 0 then bi + else begin + let size_bi = num_digits_big_int bi in + let size_res = (n + length_of_digit - 1) / length_of_digit in + let ndigits = ofs / length_of_digit in + let nbits = ofs mod length_of_digit in + let res = make_nat size_res in + if ndigits < size_bi then + blit_nat res 0 bi.abs_value ndigits (min size_res (size_bi - ndigits)); + if bi.sign < 0 then begin + (* Two's complement *) + complement_nat res 0 size_res; + ignore (incr_nat res 0 size_res 1) + end; + if nbits > 0 then begin + let tmp = create_nat 1 in + shift_right_nat res 0 size_res tmp 0 nbits + end; + let n' = n mod length_of_digit in + if n' > 0 then begin + let tmp = create_nat 1 in + set_digit_nat_native tmp 0 + (Nativeint.shift_right_logical (-1n) (length_of_digit - n')); + land_digit_nat res (size_res - 1) tmp 0 + end; + if is_zero_nat res 0 size_res + then zero_big_int + else { sign = 1; abs_value = res } + end + +(* Bitwise logical operations. Arguments must be >= 0. *) + +let and_big_int a b = + if a.sign < 0 || b.sign < 0 then invalid_arg "and_big_int" + else if a.sign = 0 || b.sign = 0 then zero_big_int + else begin + let size_a = num_digits_big_int a + and size_b = num_digits_big_int b in + let size_res = min size_a size_b in + let res = create_nat size_res in + blit_nat res 0 a.abs_value 0 size_res; + for i = 0 to size_res - 1 do + land_digit_nat res i b.abs_value i + done; + if is_zero_nat res 0 size_res + then zero_big_int + else { sign = 1; abs_value = res } + end + +let or_big_int a b = + if a.sign < 0 || b.sign < 0 then invalid_arg "or_big_int" + else if a.sign = 0 then b + else if b.sign = 0 then a + else begin + let size_a = num_digits_big_int a + and size_b = num_digits_big_int b in + let size_res = max size_a size_b in + let res = create_nat size_res in + let or_aux a' b' size_b' = + blit_nat res 0 a'.abs_value 0 size_res; + for i = 0 to size_b' - 1 do + lor_digit_nat res i b'.abs_value i + done in + if size_a >= size_b + then or_aux a b size_b + else or_aux b a size_a; + if is_zero_nat res 0 size_res + then zero_big_int + else { sign = 1; abs_value = res } + end + +let xor_big_int a b = + if a.sign < 0 || b.sign < 0 then invalid_arg "xor_big_int" + else if a.sign = 0 then b + else if b.sign = 0 then a + else begin + let size_a = num_digits_big_int a + and size_b = num_digits_big_int b in + let size_res = max size_a size_b in + let res = create_nat size_res in + let xor_aux a' b' size_b' = + blit_nat res 0 a'.abs_value 0 size_res; + for i = 0 to size_b' - 1 do + lxor_digit_nat res i b'.abs_value i + done in + if size_a >= size_b + then xor_aux a b size_b + else xor_aux b a size_a; + if is_zero_nat res 0 size_res + then zero_big_int + else { sign = 1; abs_value = res } + end + + + + diff --git a/otherlibs/num/big_int.mli b/otherlibs/num/big_int.mli index 11561b605..e6b50b1df 100644 --- a/otherlibs/num/big_int.mli +++ b/otherlibs/num/big_int.mli @@ -152,6 +152,32 @@ val float_of_big_int : big_int -> float (** Returns a floating-point number approximating the given big integer. *) +(** {6 Bit-oriented operations} *) + +val and_big_int : big_int -> big_int -> big_int + (** Bitwise logical ``and''. + The arguments must be positive or zero. *) +val or_big_int : big_int -> big_int -> big_int + (** Bitwise logical ``or''. + The arguments must be positive or zero. *) +val xor_big_int : big_int -> big_int -> big_int + (** Bitwise logical ``exclusive or''. + The arguments must be positive or zero. *) +val shift_left_big_int : big_int -> int -> big_int + (** [shift_left_big_int b n] returns [b] shifted left by [n] bits. + Equivalent to multiplication by [2^n]. *) +val shift_right_big_int : big_int -> int -> big_int + (** [shift_right_big_int b n] returns [b] shifted right by [n] bits. + The shift is performed on the absolute value of [b]. + The result has the same sign as [b]. + Equivalent to division by [2^n] with the result being + rounded towards zero. *) +val extract_big_int : big_int -> int -> int -> big_int + (** [extract_big_int bi ofs n] returns a nonnegative number + corresponding to bits [ofs] to [ofs + n - 1] of the + binary representation of [bi]. If [bi] is negative, + a two's complement representation is used. *) + (**/**) (** {6 For internal use} *) diff --git a/otherlibs/num/test/test_big_ints.ml b/otherlibs/num/test/test_big_ints.ml index f3080e5d1..e1e4b88b0 100644 --- a/otherlibs/num/test/test_big_ints.ml +++ b/otherlibs/num/test/test_big_ints.ml @@ -770,3 +770,132 @@ test 5 eq_int (should_fail "-9223372036854775809", 1);; test 6 eq_int (should_fail "18446744073709551616", 1);; + +(* build a 128-bit big int from two int64 *) + +let big_int_128 hi lo = + add_big_int (mult_big_int (big_int_of_int64 hi) + (big_int_of_string "18446744073709551616")) + (big_int_of_int64 lo);; +let h1 = 0x7fd05b7ee46a29f8L +and h2 = 0x64b28b8ee70b6e6dL +and h3 = 0x58546e563f5b44f0L +and h4 = 0x1db72f6377ff3ec6L +and h5 = 0x4f9bb0a19c543cb1L;; + +testing_function "and_big_int";; + +test 1 eq_big_int + (and_big_int unit_big_int zero_big_int, zero_big_int);; +test 2 eq_big_int + (and_big_int zero_big_int unit_big_int, zero_big_int);; +test 3 eq_big_int + (and_big_int unit_big_int unit_big_int, unit_big_int);; +test 4 eq_big_int + (and_big_int (big_int_128 h1 h2) (big_int_128 h3 h4), + big_int_128 (Int64.logand h1 h3) (Int64.logand h2 h4));; +test 5 eq_big_int + (and_big_int (big_int_128 h1 h2) (big_int_of_int64 h5), + big_int_of_int64 (Int64.logand h2 h5));; +test 6 eq_big_int + (and_big_int (big_int_of_int64 h5) (big_int_128 h3 h4) , + big_int_of_int64 (Int64.logand h5 h4));; + +testing_function "or_big_int";; + +test 1 eq_big_int + (or_big_int unit_big_int zero_big_int, unit_big_int);; +test 2 eq_big_int + (or_big_int zero_big_int unit_big_int, unit_big_int);; +test 3 eq_big_int + (or_big_int unit_big_int unit_big_int, unit_big_int);; +test 4 eq_big_int + (or_big_int (big_int_128 h1 h2) (big_int_128 h3 h4), + big_int_128 (Int64.logor h1 h3) (Int64.logor h2 h4));; +test 5 eq_big_int + (or_big_int (big_int_128 h1 h2) (big_int_of_int64 h5), + big_int_128 h1 (Int64.logor h2 h5));; +test 6 eq_big_int + (or_big_int (big_int_of_int64 h5) (big_int_128 h3 h4) , + big_int_128 h3 (Int64.logor h5 h4));; + +testing_function "xor_big_int";; + +test 1 eq_big_int + (xor_big_int unit_big_int zero_big_int, unit_big_int);; +test 2 eq_big_int + (xor_big_int zero_big_int unit_big_int, unit_big_int);; +test 3 eq_big_int + (xor_big_int unit_big_int unit_big_int, zero_big_int);; +test 4 eq_big_int + (xor_big_int (big_int_128 h1 h2) (big_int_128 h3 h4), + big_int_128 (Int64.logxor h1 h3) (Int64.logxor h2 h4));; +test 5 eq_big_int + (xor_big_int (big_int_128 h1 h2) (big_int_of_int64 h5), + big_int_128 h1 (Int64.logxor h2 h5));; +test 6 eq_big_int + (xor_big_int (big_int_of_int64 h5) (big_int_128 h3 h4) , + big_int_128 h3 (Int64.logxor h5 h4));; + +testing_function "shift_left_big_int";; + +test 1 eq_big_int + (shift_left_big_int unit_big_int 0, + unit_big_int);; +test 2 eq_big_int + (shift_left_big_int unit_big_int 1, + big_int_of_int 2);; +test 2 eq_big_int + (shift_left_big_int unit_big_int 31, + big_int_of_string "2147483648");; +test 3 eq_big_int + (shift_left_big_int unit_big_int 64, + big_int_of_string "18446744073709551616");; +test 4 eq_big_int + (shift_left_big_int unit_big_int 95, + big_int_of_string "39614081257132168796771975168");; +test 5 eq_big_int + (shift_left_big_int (big_int_of_string "39614081257132168796771975168") 67, + big_int_of_string "5846006549323611672814739330865132078623730171904");; +test 6 eq_big_int + (shift_left_big_int (big_int_of_string "-39614081257132168796771975168") 67, + big_int_of_string "-5846006549323611672814739330865132078623730171904");; + +testing_function "shift_right_big_int";; + +test 1 eq_big_int + (shift_right_big_int unit_big_int 0, + unit_big_int);; +test 2 eq_big_int + (shift_right_big_int (big_int_of_int 12345678) 3, + big_int_of_int 1543209);; +test 3 eq_big_int + (shift_right_big_int (big_int_of_string "5299989648942") 32, + big_int_of_int 1234);; +test 4 eq_big_int + (shift_right_big_int (big_int_of_string "5846006549323611672814739330865132078623730171904") 67, + big_int_of_string "39614081257132168796771975168");; +test 5 eq_big_int + (shift_right_big_int (big_int_of_string "-5299989648942") 32, + big_int_of_int (-1234));; + +testing_function "extract_big_int";; + +test 1 eq_big_int + (extract_big_int (big_int_of_int64 0x123456789ABCDEFL) 3 13, + big_int_of_int 6589);; +test 2 eq_big_int + (extract_big_int (big_int_128 h1 h2) 67 12, + big_int_of_int 1343);; +test 3 eq_big_int + (extract_big_int (big_int_of_string "-1844674407370955178") 37 9, + big_int_of_int 307);; +test 4 eq_big_int + (extract_big_int unit_big_int 2048 254, + zero_big_int);; +test 5 eq_big_int + (extract_big_int (big_int_of_int64 0x123456789ABCDEFL) 0 32, + big_int_of_int64 2309737967L);; +test 6 eq_big_int + (extract_big_int (big_int_of_int (-1)) 2048 254, + zero_big_int);; |