From bd7fc99c4381f7494ea1433afdf87d4e52650685 Mon Sep 17 00:00:00 2001 From: Xavier Leroy Date: Fri, 4 Jan 2008 13:15:52 +0000 Subject: [PATCH] PR#4371: added conversions between big_int and int32/int64/nativeint git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@8751 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02 --- otherlibs/num/big_int.ml | 66 ++++++++++++++++++++ otherlibs/num/big_int.mli | 20 ++++++ otherlibs/num/nat.ml | 3 +- otherlibs/num/nat.mli | 2 + otherlibs/num/nat_stubs.c | 11 ++++ otherlibs/num/test/Makefile | 4 +- otherlibs/num/test/test.ml | 7 ++- otherlibs/num/test/test_big_ints.ml | 97 +++++++++++++++++++++++++++++ 8 files changed, 205 insertions(+), 5 deletions(-) diff --git a/otherlibs/num/big_int.ml b/otherlibs/num/big_int.ml index 2d744f7ca..f9c04e443 100644 --- a/otherlibs/num/big_int.ml +++ b/otherlibs/num/big_int.ml @@ -327,6 +327,72 @@ let int_of_big_int bi = if eq_big_int bi monster_big_int then monster_int else failwith "int_of_big_int";; +let big_int_of_nativeint i = + if i = 0n then + zero_big_int + else if i > 0n then begin + let res = create_nat 1 in + set_digit_nat_native res 0 i; + { sign = 1; abs_value = res } + end else begin + let res = create_nat 1 in + set_digit_nat_native res 0 (Nativeint.neg i); + { sign = -1; abs_value = res } + end + +let nativeint_of_big_int bi = + if num_digits_big_int bi > 1 then failwith "nativeint_of_big_int"; + let i = nth_digit_nat_native bi.abs_value 0 in + if bi.sign >= 0 then + if i >= 0n then i else failwith "nativeint_of_big_int" + else + if i >= 0n || i = Nativeint.min_int + then Nativeint.neg i + else failwith "nativeint_of_big_int" + +let big_int_of_int32 i = big_int_of_nativeint (Nativeint.of_int32 i) + +let int32_of_big_int bi = + let i = nativeint_of_big_int bi in + if i <= 0x7FFF_FFFFn && i >= -0x8000_0000n + then Nativeint.to_int32 i + else failwith "int32_of_big_int" + +let big_int_of_int64 i = + if Sys.word_size = 64 then + big_int_of_nativeint (Int64.to_nativeint i) + else begin + let (sg, absi) = + if i = 0L then (0, 0L) + else if i > 0L then (1, i) + else (-1, Int64.neg i) in + let res = create_nat 2 in + set_digit_nat_native res 0 (Int64.to_nativeint i); + set_digit_nat_native res 1 (Int64.to_nativeint (Int64.shift_left i 32)); + { sign = sg; abs_value = res } + end + +let int64_of_big_int bi = + if Sys.word_size = 64 then + Int64.of_nativeint (nativeint_of_big_int bi) + else begin + let i = + match num_digits_big_int bi with + | 1 -> Int64.of_nativeint (nth_digit_nat_native bi.abs_value 0) + | 2 -> Int64.logor + (Int64.of_nativeint (nth_digit_nat_native bi.abs_value 0)) + (Int64.shift_left + (Int64.of_nativeint (nth_digit_nat_native bi.abs_value 1)) + 32) + | _ -> failwith "int64_of_big_int" in + if bi.sign >= 0 then + if i >= 0L then i else failwith "int64_of_big_int" + else + if i >= 0L || i = Int64.min_int + then Int64.neg i + else failwith "int64_of_big_int" + end + (* Coercion with nat type *) let nat_of_big_int bi = if bi.sign = -1 diff --git a/otherlibs/num/big_int.mli b/otherlibs/num/big_int.mli index 9b140abf2..11561b605 100644 --- a/otherlibs/num/big_int.mli +++ b/otherlibs/num/big_int.mli @@ -128,6 +128,26 @@ val int_of_big_int : big_int -> int (** Convert a big integer to a small integer (type [int]). Raises [Failure "int_of_big_int"] if the big integer is not representable as a small integer. *) + +val big_int_of_int32 : int32 -> big_int + (** Convert a 32-bit integer to a big integer. *) +val big_int_of_nativeint : nativeint -> big_int + (** Convert a native integer to a big integer. *) +val big_int_of_int64 : int64 -> big_int + (** Convert a 64-bit integer to a big integer. *) +val int32_of_big_int : big_int -> int32 + (** Convert a big integer to a 32-bit integer. + Raises [Failure] if the big integer is outside the + range [[-2{^31}, 2{^31}-1]]. *) +val nativeint_of_big_int : big_int -> nativeint + (** Convert a big integer to a native integer. + Raises [Failure] if the big integer is outside the + range [[Nativeint.min_int, Nativeint.max_int]]. *) +val int64_of_big_int : big_int -> int64 + (** Convert a big integer to a 64-bit integer. + Raises [Failure] if the big integer is outside the + range [[-2{^63}, 2{^63}-1]]. *) + val float_of_big_int : big_int -> float (** Returns a floating-point number approximating the given big integer. *) diff --git a/otherlibs/num/nat.ml b/otherlibs/num/nat.ml index a77bc2072..0fb65fa28 100644 --- a/otherlibs/num/nat.ml +++ b/otherlibs/num/nat.ml @@ -22,6 +22,8 @@ external set_to_zero_nat: nat -> int -> int -> unit = "set_to_zero_nat" external blit_nat: nat -> int -> nat -> int -> int -> unit = "blit_nat" external set_digit_nat: nat -> int -> int -> unit = "set_digit_nat" external nth_digit_nat: nat -> int -> int = "nth_digit_nat" +external set_digit_nat_native: nat -> int -> nativeint -> unit = "set_digit_nat_native" +external nth_digit_nat_native: nat -> int -> nativeint = "nth_digit_nat_native" external num_digits_nat: nat -> int -> int -> int = "num_digits_nat" external num_leading_zero_bits_in_digit: nat -> int -> int = "num_leading_zero_bits_in_digit" external is_digit_int: nat -> int -> bool = "is_digit_int" @@ -568,4 +570,3 @@ let sys_nat_of_string base s off len = let nat_of_string s = sys_nat_of_string 10 s 0 (String.length s) let float_of_nat nat = float_of_string(string_of_nat nat) - diff --git a/otherlibs/num/nat.mli b/otherlibs/num/nat.mli index 18cd81201..a220eb221 100644 --- a/otherlibs/num/nat.mli +++ b/otherlibs/num/nat.mli @@ -27,6 +27,8 @@ external blit_nat: nat -> int -> nat -> int -> int -> unit = "blit_nat" val copy_nat: nat -> int -> int -> nat external set_digit_nat: nat -> int -> int -> unit = "set_digit_nat" external nth_digit_nat: nat -> int -> int = "nth_digit_nat" +external set_digit_nat_native: nat -> int -> nativeint -> unit = "set_digit_nat_native" +external nth_digit_nat_native: nat -> int -> nativeint = "nth_digit_nat_native" val length_nat : nat -> int external num_digits_nat: nat -> int -> int -> int = "num_digits_nat" external num_leading_zero_bits_in_digit: nat -> int -> int = "num_leading_zero_bits_in_digit" diff --git a/otherlibs/num/nat_stubs.c b/otherlibs/num/nat_stubs.c index 50cda6584..f5e101548 100644 --- a/otherlibs/num/nat_stubs.c +++ b/otherlibs/num/nat_stubs.c @@ -84,6 +84,17 @@ CAMLprim value nth_digit_nat(value nat, value ofs) return Val_long(Digit_val(nat, Long_val(ofs))); } +CAMLprim value set_digit_nat_native(value nat, value ofs, value digit) +{ + Digit_val(nat, Long_val(ofs)) = Nativeint_val(digit); + return Val_unit; +} + +CAMLprim value nth_digit_nat_native(value nat, value ofs) +{ + return caml_copy_nativeint(Digit_val(nat, Long_val(ofs))); +} + CAMLprim value num_digits_nat(value nat, value ofs, value len) { return Val_long(bng_num_digits(&Digit_val(nat, Long_val(ofs)), diff --git a/otherlibs/num/test/Makefile b/otherlibs/num/test/Makefile index feafae198..34735c2a6 100644 --- a/otherlibs/num/test/Makefile +++ b/otherlibs/num/test/Makefile @@ -31,10 +31,10 @@ TESTFILES=test.cmo \ TESTOPTFILES=$(TESTFILES:.cmo=.cmx) test.byt: $(TESTFILES) ../nums.cma ../libnums.a - $(CAMLC) -ccopt -L.. -o test.byt ../nums.cma $(TESTFILES) + $(CAMLC) -ccopt -L.. -I .. -o test.byt ../nums.cma $(TESTFILES) test.opt: $(TESTOPTFILES) ../nums.cmxa ../libnums.a - $(CAMLOPT) -ccopt -L.. -o test.opt ../nums.cmxa $(TESTOPTFILES) + $(CAMLOPT) -ccopt -L.. -I .. -o test.opt ../nums.cmxa $(TESTOPTFILES) test_bng: test_bng.o $(CC) $(CFLAGS) -o test_bng ../bng.o test_bng.o -lbignum diff --git a/otherlibs/num/test/test.ml b/otherlibs/num/test/test.ml index 8426e0ae8..031648a7a 100644 --- a/otherlibs/num/test/test.ml +++ b/otherlibs/num/test/test.ml @@ -71,7 +71,10 @@ let end_tests () = end;; let eq = (==);; -let eq_int = (==);; -let eq_string = (=);; +let eq_int (i: int) (j: int) = (i = j);; +let eq_string (i: string) (j: string) = (i = j);; +let eq_nativeint (i: nativeint) (j: nativeint) = (i = j);; +let eq_int32 (i: int32) (j: int32) = (i = j);; +let eq_int64 (i: int64) (j: int64) = (i = j);; let sixtyfour = (1 lsl 31) <> 0;; diff --git a/otherlibs/num/test/test_big_ints.ml b/otherlibs/num/test/test_big_ints.ml index 9d699bd04..225491840 100644 --- a/otherlibs/num/test/test_big_ints.ml +++ b/otherlibs/num/test/test_big_ints.ml @@ -299,6 +299,24 @@ testing_function "int_of_big_int";; test 1 eq_int (int_of_big_int (big_int_of_int 1), 1);; +test 2 +eq_int (int_of_big_int (big_int_of_int(-1)), -1);; +test 3 +eq_int (int_of_big_int zero_big_int, 0);; +test 4 +eq_int (int_of_big_int (big_int_of_int max_int), max_int);; +test 5 +eq_int (int_of_big_int (big_int_of_int min_int), min_int);; +failwith_test 6 + (fun () -> int_of_big_int (succ_big_int (big_int_of_int max_int))) + () (Failure "int_of_big_int");; +failwith_test 7 + (fun () -> int_of_big_int (pred_big_int (big_int_of_int min_int))) + () (Failure "int_of_big_int");; +failwith_test 8 + (fun () -> int_of_big_int (mult_big_int (big_int_of_int min_int) + (big_int_of_int 2))) + () (Failure "int_of_big_int");; testing_function "is_int_big_int";; @@ -673,3 +691,82 @@ test 3 eq_big_int (square_big_int (big_int_of_string "-1"), big_int_of_string "1");; test 4 eq_big_int (square_big_int (big_int_of_string "-7"), big_int_of_string "49");; + + +testing_function "big_int_of_nativeint";; + +test 1 eq_big_int + (big_int_of_nativeint 0n, zero_big_int);; +test 2 eq_big_int + (big_int_of_nativeint 1234n, big_int_of_string "1234");; +test 3 eq_big_int + (big_int_of_nativeint (-1234n), big_int_of_string "-1234");; + +testing_function "nativeint_of_big_int";; + +test 1 eq_nativeint + (nativeint_of_big_int zero_big_int, 0n);; +test 2 eq_nativeint + (nativeint_of_big_int (big_int_of_string "1234"), 1234n);; +test 2 eq_nativeint + (nativeint_of_big_int (big_int_of_string "-1234"), -1234n);; + +testing_function "big_int_of_int32";; + +test 1 eq_big_int + (big_int_of_int32 0l, zero_big_int);; +test 2 eq_big_int + (big_int_of_int32 2147483647l, big_int_of_string "2147483647");; +test 3 eq_big_int + (big_int_of_int32 (-2147483648l), big_int_of_string "-2147483648");; + +testing_function "int32_of_big_int";; + +test 1 eq_int32 + (int32_of_big_int zero_big_int, 0l);; +test 2 eq_int32 + (int32_of_big_int (big_int_of_string "2147483647"), 2147483647l);; +test 3 eq_int32 + (int32_of_big_int (big_int_of_string "-2147483648"), -2147483648l);; +test 4 eq_int32 + (int32_of_big_int (big_int_of_string "-2147"), -2147l);; +let should_fail s = + try ignore (int32_of_big_int (big_int_of_string s)); 0 + with Failure _ -> 1;; +test 5 eq_int + (should_fail "2147483648", 1);; +test 6 eq_int + (should_fail "-2147483649", 1);; +test 7 eq_int + (should_fail "4294967296", 1);; +test 8 eq_int + (should_fail "18446744073709551616", 1);; + +testing_function "big_int_of_int64";; + +test 1 eq_big_int + (big_int_of_int64 0L, zero_big_int);; +test 2 eq_big_int + (big_int_of_int64 9223372036854775807L, big_int_of_string "9223372036854775807");; +test 3 eq_big_int + (big_int_of_int64 (-9223372036854775808L), big_int_of_string "-9223372036854775808");; + +testing_function "int64_of_big_int";; + +test 1 eq_int64 + (int64_of_big_int zero_big_int, 0L);; +test 2 eq_int64 + (int64_of_big_int (big_int_of_string "9223372036854775807"), 9223372036854775807L);; +test 2 eq_int64 + (int64_of_big_int (big_int_of_string "-9223372036854775808"), -9223372036854775808L);; +test 3 eq_int64 + (int64_of_big_int (big_int_of_string "-9223372036854775"), -9223372036854775L);; +let should_fail s = + try ignore (int64_of_big_int (big_int_of_string s)); 0 + with Failure _ -> 1;; +test 4 eq_int + (should_fail "9223372036854775808", 1);; +test 5 eq_int + (should_fail "-9223372036854775809", 1);; +test 6 eq_int + (should_fail "18446744073709551616", 1);;