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

@@ -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

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. *)

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)
-

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"

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)),

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

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;;

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);;