From ace7c974297e179cda82318c399e84a10e49d43b Mon Sep 17 00:00:00 2001 From: Olivier Nicole Date: Thu, 26 Sep 2024 14:15:26 +0200 Subject: [PATCH] Add Int31 tests --- compiler/tests-num/dune | 8 ++ compiler/tests-num/test_int31.ml | 185 +++++++++++++++++++++++++++++++ dune-project | 1 + js_of_ocaml-compiler.opam | 1 + 4 files changed, 195 insertions(+) create mode 100644 compiler/tests-num/test_int31.ml diff --git a/compiler/tests-num/dune b/compiler/tests-num/dune index 6cb923a8d5..606671484a 100644 --- a/compiler/tests-num/dune +++ b/compiler/tests-num/dune @@ -1,5 +1,6 @@ (executable (name main) + (modules main test_nats test test_big_ints test_ratios test_nums test_io) (libraries num) (modes js @@ -7,6 +8,13 @@ (flags (:standard -linkall -w -3-7-33-35-37 -safe-string -no-strict-sequence))) +(library + (name test_int31) + (modules test_int31) + (inline_tests) + (preprocess (pps ppx_expect)) + (libraries js_of_ocaml-compiler qcheck)) + (rule (target main.referencejs) (deps main.bc.js) diff --git a/compiler/tests-num/test_int31.ml b/compiler/tests-num/test_int31.ml new file mode 100644 index 0000000000..4654810ed6 --- /dev/null +++ b/compiler/tests-num/test_int31.ml @@ -0,0 +1,185 @@ +open! Js_of_ocaml_compiler.Stdlib +open QCheck2 + +let () = Printexc.record_backtrace false + +let min_int31 = Int32.(neg (shift_left 1l 30)) +let max_int31 = Int32.(sub (shift_left 1l 30) 1l) + +let in_range i = + Int32.(min_int31 <= i && i <= max_int31) + +let in_range_int31 i = + in_range (Int31.to_int32 i) + +let (-->) p q = not p || q + +let in_range_i32 = + Gen.(Int32.of_int <$> int_range (- (1 lsl 30)) (1 lsl 30 - 1)) + +let out_of_range_int = + let open Gen in + oneof [ int_range (- (1 lsl 31)) (- (1 lsl 30) - 1); + int_range (1 lsl 30) (1 lsl 31 - 1) ] + +let out_of_range_i32 = + out_of_range_int |> Gen.map Int32.of_int + +let t_corner = + let open Gen in + graft_corners in_range_i32 [min_int31; max_int31] () + |> map Int31.of_int32_warning_on_overflow + +let print_t t = + Format.sprintf "%ld" (Int31.to_int32 t) + +let%expect_test _ = + Test.check_exn @@ Test.make ~count:1000 ~name:"Int31.of_int32_warning_on_overflow: normal" + in_range_i32 + (fun i -> + Int32.equal Int31.(to_int32 (of_int32_warning_on_overflow i)) i); + [%expect ""] + +let%expect_test _ = + Test.check_exn @@ Test.make ~count:1000 ~name:"Int31.of_int_warning_on_overflow: normal" + (Gen.map Int32.to_int in_range_i32) + (fun i -> + Int.equal (Int31.(to_int32 (of_int_warning_on_overflow i)) |> Int32.to_int) i); + [%expect ""] + +let%expect_test _ = + Test.check_exn @@ Test.make ~count:1000 ~name:"Int31.of_nativeint_warning_on_overflow: normal" + (Gen.map Nativeint.of_int32 in_range_i32) + (fun i -> + Nativeint.equal + (Int31.(to_int32 (of_nativeint_warning_on_overflow i)) |> Nativeint.of_int32) + i); + [%expect ""] + +let%expect_test _ = + let i = Gen.(generate1 (no_shrink out_of_range_i32)) in + let i_trunc = Int32.(shift_right (shift_left i 1) 1) in + ignore (Int31.of_int32_warning_on_overflow i); + let output = [%expect.output] in + let expected = + Format.sprintf "Warning: integer overflow: integer 0x%lx (%ld) truncated to 0x%lx (%ld); the generated code might be incorrect.@." i i i_trunc i_trunc + in + if not (String.equal output expected) then + Format.printf "Unexpected output string@.%s@.Expected:@.%s@." output expected; + [%expect ""] + +let%expect_test _ = + let i = Gen.(generate1 (no_shrink out_of_range_int)) in + let i_trunc = Int32.(shift_right (shift_left (of_int i) 1) 1) in + ignore (Int31.of_int_warning_on_overflow i); + let output = [%expect.output] in + let expected = + Format.sprintf "Warning: integer overflow: integer 0x%x (%d) truncated to 0x%lx (%ld); the generated code might be incorrect.@." i i i_trunc i_trunc + in + if not (String.equal output expected) then + Format.printf "Unexpected output string@.%s@.Expected:@.%s@." output expected; + [%expect ""] + +let%expect_test _ = + let i = Gen.(generate1 (no_shrink (Nativeint.of_int <$> out_of_range_int))) in + let i_trunc = Int32.(shift_right (shift_left (Nativeint.to_int32 i) 1) 1) in + ignore (Int31.of_nativeint_warning_on_overflow i); + let output = [%expect.output] in + let expected = + Format.sprintf "Warning: integer overflow: integer 0x%nx (%nd) truncated to 0x%lx (%ld); the generated code might be incorrect.@." i i i_trunc i_trunc + in + if not (String.equal output expected) then + Format.printf "Unexpected output string@.%s@.Expected:@.%s@." output expected; + [%expect ""] + +let modulus = Int32.(shift_left 1l 31) + +let canonicalize x = + if in_range x then x else Int32.(sub x modulus) + +let canon_equal x y = + Int32.(=) (canonicalize x) (canonicalize y) + +let%expect_test _ = + Test.check_exn @@ Test.make ~count:1000 ~name:"Int31.neg" + t_corner + ~print:print_t + (fun i -> + let r_int31 = Int31.(neg i |> to_int32) in + let r_int32 = Int32.neg (Int31.to_int32 i) in + in_range r_int31 && canon_equal r_int31 r_int32); + [%expect ""] + +let binop_prop op_i31 op_i32 i j = + let r_int31 = op_i31 i j |> Int31.to_int32 in + let r_int32 = op_i32 (Int31.to_int32 i) (Int31.to_int32 j) in + in_range r_int31 && canon_equal r_int31 r_int32 + +let binop_check ~count ~name op_i31 op_i32 = + Test.check_exn @@ Test.make ~count ~name + Gen.(tup2 t_corner t_corner) + ~print:(Print.tup2 print_t print_t) + (fun (i, j) -> binop_prop op_i31 op_i32 i j) + +let%expect_test _ = + binop_check ~count:1000 ~name:"Int31.add" Int31.add Int32.add; + [%expect ""] + +let%expect_test _ = + binop_check ~count:1000 ~name:"Int31.sub" Int31.sub Int32.sub; + [%expect ""] + +let%expect_test _ = + binop_check ~count:1000 ~name:"Int31.mul" Int31.mul Int32.mul; + [%expect ""] + +let%expect_test _ = + Test.check_exn @@ Test.make ~count:1000 ~name:"Int31.div" + Gen.(tup2 t_corner t_corner) + ~print:(Print.tup2 print_t print_t) + (fun (i, j) -> + try binop_prop Int31.div Int32.div i j + with Division_by_zero -> Int32.equal (Int31.to_int32 j) 0l) + +let%expect_test _ = + Test.check_exn @@ Test.make ~count:1000 ~name:"Int31.rem" + Gen.(tup2 t_corner t_corner) + ~print:(Print.tup2 print_t print_t) + (fun (i, j) -> + try binop_prop Int31.rem Int32.rem i j + with Division_by_zero -> Int32.equal (Int31.to_int32 j) 0l) + +let%expect_test _ = + binop_check ~count:1000 ~name:"Int31.logand" Int31.logand Int32.logand; + [%expect ""] + +let%expect_test _ = + binop_check ~count:1000 ~name:"Int31.logor" Int31.logor Int32.logor; + [%expect ""] + +let%expect_test _ = + binop_check ~count:1000 ~name:"Int31.logxor" Int31.logxor Int32.logxor; + [%expect ""] + +let shift_op_prop op_i31 op_i32 x i = + let r_int31 = op_i31 x i |> Int31.to_int32 in + let r_int32 = op_i32 (Int31.to_int32 x) i in + in_range r_int31 && canon_equal r_int31 r_int32 + +let%expect_test _ = + Test.check_exn @@ Test.make ~count:1000 ~name:"Int31.shift_left" + Gen.(tup2 t_corner (int_bound 31)) + ~print:Print.(tup2 print_t int) + (fun (x, i) -> shift_op_prop Int31.shift_left Int32.shift_left x i) + +let%expect_test _ = + Test.check_exn @@ Test.make ~count:1000 ~name:"Int31.shift_right" + Gen.(tup2 t_corner (int_bound 31)) + ~print:Print.(tup2 print_t int) + (fun (x, i) -> shift_op_prop Int31.shift_right Int32.shift_right x i) + +let%expect_test _ = + Test.check_exn @@ Test.make ~count:1000 ~name:"Int31.shift_right_logical" + Gen.(tup2 t_corner (int_bound 31)) + ~print:Print.(tup2 print_t int) + (fun (x, i) -> shift_op_prop Int31.shift_right_logical Int32.shift_right_logical x i) diff --git a/dune-project b/dune-project index 39d190fe65..92fc0c470b 100644 --- a/dune-project +++ b/dune-project @@ -25,6 +25,7 @@ (re :with-test) (cmdliner (>= 1.1.0)) (sedlex (>= 2.3)) + (qcheck :with-test) menhir menhirLib menhirSdk diff --git a/js_of_ocaml-compiler.opam b/js_of_ocaml-compiler.opam index 6c9ba412f2..7cea43512c 100644 --- a/js_of_ocaml-compiler.opam +++ b/js_of_ocaml-compiler.opam @@ -20,6 +20,7 @@ depends: [ "re" {with-test} "cmdliner" {>= "1.1.0"} "sedlex" {>= "2.3"} + "qcheck" {with-test} "menhir" "menhirLib" "menhirSdk"