unikernel/duniverse/Zarith/tests/tofloat.ml

@@ -0,0 +1,134 @@
+(* Testing Z.to_float *)
+
+open Printf
+
+type rounding_mode =
+  FE_DOWNWARD | FE_TONEAREST | FE_TOWARDZERO | FE_UPWARD
+
+external setround: rounding_mode -> bool = "caml_ztest_setround"
+
+external format_float: string -> float -> string = "caml_format_float"
+
+let hex_of_float f = format_float "%a" f
+
+(* For testing, we use randomly-generated integers of the form
+     <signed 64-bit integer> * 2^<exponent>
+   We can predict their FP value by converting the integer part to FP,
+   then scale by the exponent using ldexp. *)
+
+let test1 (mant: int64) (exp: int) =
+  let expected = ldexp (Int64.to_float mant) exp in
+  let actual = Z.to_float (Z.shift_left (Z.of_int64 mant) exp) in
+  if actual = expected then true else begin
+    printf "%Ld * 2^%d: expected %s, got %s\n"
+           mant exp (hex_of_float expected) (hex_of_float actual);
+    false
+  end
+
+let rnd64 () =
+  let m1 = Random.bits() in           (* 30 bits *)
+  let m2 = Random.bits() in           (* 30 bits *)
+  let m3 = Random.bits() in
+  Int64.(logor (of_int m1)
+               (logor (shift_left (of_int m2) 30)
+                      (shift_left (of_int m3) 60)))
+  
+let testN numrounds =
+  printf " (%d tests)... %!" numrounds;
+  let errors = ref 0 in
+  (* Some random int64 values *)
+  for i = 1 to numrounds do
+    let m = Random.int64 Int64.max_int in
+    if not (test1 m 0) then incr errors;
+    if not (test1 (Int64.neg m) 0) then incr errors
+  done;
+  (* Some random int64 values scaled by some random power of 2 *)
+  for i = 1 to numrounds do
+    let m = rnd64() in
+    let exp = Random.int 1100 in        (* sometimes +inf will result *)
+    if not (test1 m exp) then incr errors
+  done;
+  (* Special test close to a rounding point *)
+  for i = 0 to 15 do
+    let m = Int64.(add 0xfffffffffffff0L (of_int i)) in
+    if not (test1 m 32) then incr errors;
+    if not (test1 (Int64.neg m) 32) then incr errors
+  done;
+  if !errors = 0
+  then printf "passed\n%!"
+  else printf "FAILED (%d errors)\n%!" !errors
+
+let testQ1 (mant1: int64) (exp1: int) (mant2: int64) (exp2: int) =
+  let expected =
+    ldexp (Int64.to_float mant1) exp1 /. ldexp (Int64.to_float mant2) exp2 in
+  let actual =
+    Q.to_float (Q.make (Z.shift_left (Z.of_int64 mant1) exp1)
+                       (Z.shift_left (Z.of_int64 mant2) exp2)) in
+  if compare actual expected = 0 then true else begin
+    printf "%Ld * 2^%d / %Ld * 2^%d : expected %s, got %s\n"
+           mant1 exp1 mant2 exp2 (hex_of_float expected) (hex_of_float actual);
+    false
+  end
+
+let testQN numrounds =
+  printf " (%d tests)... %!" numrounds;
+  let errors = ref 0 in
+  (* Some special values *)
+  if not (testQ1 0L 0 1L 0) then incr errors;
+  if not (testQ1 1L 0 0L 0) then incr errors;
+  if not (testQ1 (-1L) 0 0L 0) then incr errors;
+  if not (testQ1 0L 0 0L 0) then incr errors;
+  (* Some random fractions *)
+  for i = 1 to numrounds do
+    let m1 = Random.int64 0x20000000000000L in
+    let m1 = if Random.bool() then m1 else Int64.neg m1 in
+    let exp1 = Random.int 500 in
+    let m2 = Random.int64 0x20000000000000L in
+    let exp2 = Random.int 500 in
+    if not (testQ1 m1 exp1 m2 exp2) then incr errors
+  done;
+  if !errors = 0
+  then printf "passed\n%!"
+  else printf "FAILED (%d errors)\n%!" !errors
+
+let _ =
+  let numrounds =
+    if Array.length Sys.argv >= 2
+    then int_of_string Sys.argv.(1)
+    else 100_000 in
+  printf "Default rounding mode (Z)";
+  testN numrounds;
+  printf "Default rounding mode (Q)";
+  testQN numrounds;
+  if setround FE_TOWARDZERO then begin
+    printf "Round toward zero (Z)";
+    testN numrounds;
+    printf "Round toward zero (Q)";
+    testQN numrounds
+  end else begin
+    printf "Round toward zero not supported, skipping\n"
+  end;
+  if setround FE_DOWNWARD then begin
+    printf "Round downward (Z)";
+    testN numrounds;
+    printf "Round downward (Q)";
+    testQN numrounds
+  end else begin
+    printf "Round downward not supported, skipping\n"
+  end;
+  if setround FE_UPWARD then begin
+    printf "Round upward (Z)";
+    testN numrounds;
+    printf "Round upward (Q)";
+    testQN numrounds
+  end else begin
+    printf "Round upward not supported, skipping\n"
+  end;
+  if setround FE_TONEAREST then begin
+    printf "Round to nearest (Z)";
+    testN numrounds;
+    printf "Round to nearest (Q)";
+    testQN numrounds
+  end else begin
+    printf "Round to nearest not supported, skipping\n"
+  end