path: root/testsuite/tests/translprim/comparison_table.ml

(* TEST
   * setup-ocamlc.byte-build-env
   ** ocamlc.byte
      flags = "-dlambda -dno-unique-ids"
   *** check-ocamlc.byte-output
*)

external cmp : 'a -> 'a -> int = "%compare";;
external eq : 'a -> 'a -> bool = "%equal";;
external ne : 'a -> 'a -> bool = "%notequal";;
external lt : 'a -> 'a -> bool = "%lessthan";;
external gt : 'a -> 'a -> bool = "%greaterthan";;
external le : 'a -> 'a -> bool = "%lessequal";;
external ge : 'a -> 'a -> bool = "%greaterequal";;

type intlike = A | B | C | D

(* Check specialization in explicit application *)

let gen_cmp x y = cmp x y;;
let int_cmp (x : int) y = cmp x y;;
let bool_cmp (x : bool) y = cmp x y;;
let intlike_cmp (x : intlike) y = cmp x y;;
let float_cmp (x : float) y = cmp x y;;
let string_cmp (x : string) y = cmp x y;;
let int32_cmp (x : int32) y = cmp x y;;
let int64_cmp (x : int64) y = cmp x y;;
let nativeint_cmp (x : nativeint) y = cmp x y;;

let gen_eq x y = eq x y;;
let int_eq (x : int) y = eq x y;;
let bool_eq (x : bool) y = eq x y;;
let intlike_eq (x : intlike) y = eq x y;;
let float_eq (x : float) y = eq x y;;
let string_eq (x : string) y = eq x y;;
let int32_eq (x : int32) y = eq x y;;
let int64_eq (x : int64) y = eq x y;;
let nativeint_eq (x : nativeint) y = eq x y;;

let gen_ne x y = ne x y;;
let int_ne (x : int) y = ne x y;;
let bool_ne (x : bool) y = ne x y;;
let intlike_ne (x : intlike) y = ne x y;;
let float_ne (x : float) y = ne x y;;
let string_ne (x : string) y = ne x y;;
let int32_ne (x : int32) y = ne x y;;
let int64_ne (x : int64) y = ne x y;;
let nativeint_ne (x : nativeint) y = ne x y;;

let gen_lt x y = lt x y;;
let int_lt (x : int) y = lt x y;;
let bool_lt (x : bool) y = lt x y;;
let intlike_lt (x : intlike) y = lt x y;;
let float_lt (x : float) y = lt x y;;
let string_lt (x : string) y = lt x y;;
let int32_lt (x : int32) y = lt x y;;
let int64_lt (x : int64) y = lt x y;;
let nativeint_lt (x : nativeint) y = lt x y;;

let gen_gt x y = gt x y;;
let int_gt (x : int) y = gt x y;;
let bool_gt (x : bool) y = gt x y;;
let intlike_gt (x : intlike) y = gt x y;;
let float_gt (x : float) y = gt x y;;
let string_gt (x : string) y = gt x y;;
let int32_gt (x : int32) y = gt x y;;
let int64_gt (x : int64) y = gt x y;;
let nativeint_gt (x : nativeint) y = gt x y;;

let gen_le x y = le x y;;
let int_le (x : int) y = le x y;;
let bool_le (x : bool) y = le x y;;
let intlike_le (x : intlike) y = le x y;;
let float_le (x : float) y = le x y;;
let string_le (x : string) y = le x y;;
let int32_le (x : int32) y = le x y;;
let int64_le (x : int64) y = le x y;;
let nativeint_le (x : nativeint) y = le x y;;

let gen_ge x y = ge x y;;
let int_ge (x : int) y = ge x y;;
let bool_ge (x : bool) y = ge x y;;
let intlike_ge (x : intlike) y = ge x y;;
let float_ge (x : float) y = ge x y;;
let string_ge (x : string) y = ge x y;;
let int32_ge (x : int32) y = ge x y;;
let int64_ge (x : int64) y = ge x y;;
let nativeint_ge (x : nativeint) y = ge x y;;

(* Check specialization in eta-expansion *)

let eta_gen_cmp : 'a -> _ = cmp;;
let eta_int_cmp : int -> _ = cmp;;
let eta_bool_cmp : bool -> _ = cmp;;
let eta_intlike_cmp : intlike -> _ = cmp;;
let eta_float_cmp : float -> _ = cmp;;
let eta_string_cmp : string -> _ = cmp;;
let eta_int32_cmp : int32 -> _ = cmp;;
let eta_int64_cmp : int64 -> _ = cmp;;
let eta_nativeint_cmp : nativeint -> _ = cmp;;

let eta_gen_eq : 'a -> _ = eq;;
let eta_int_eq : int -> _ = eq;;
let eta_bool_eq : bool -> _ = eq;;
let eta_intlike_eq : intlike -> _ = eq;;
let eta_float_eq : float -> _ = eq;;
let eta_string_eq : string -> _ = eq;;
let eta_int32_eq : int32 -> _ = eq;;
let eta_int64_eq : int64 -> _ = eq;;
let eta_nativeint_eq : nativeint -> _ = eq;;

let eta_gen_ne : 'a -> _ = ne;;
let eta_int_ne : int -> _ = ne;;
let eta_bool_ne : bool -> _ = ne;;
let eta_intlike_ne : intlike -> _ = ne;;
let eta_float_ne : float -> _ = ne;;
let eta_string_ne : string -> _ = ne;;
let eta_int32_ne : int32 -> _ = ne;;
let eta_int64_ne : int64 -> _ = ne;;
let eta_nativeint_ne : nativeint -> _ = ne;;

let eta_gen_lt : 'a -> _ = lt;;
let eta_int_lt : int -> _ = lt;;
let eta_bool_lt : bool -> _ = lt;;
let eta_intlike_lt : intlike -> _ = lt;;
let eta_float_lt : float -> _ = lt;;
let eta_string_lt : string -> _ = lt;;
let eta_int32_lt : int32 -> _ = lt;;
let eta_int64_lt : int64 -> _ = lt;;
let eta_nativeint_lt : nativeint -> _ = lt;;

let eta_gen_gt : 'a -> _ = gt;;
let eta_int_gt : int -> _ = gt;;
let eta_bool_gt : bool -> _ = gt;;
let eta_intlike_gt : intlike -> _ = gt;;
let eta_float_gt : float -> _ = gt;;
let eta_string_gt : string -> _ = gt;;
let eta_int32_gt : int32 -> _ = gt;;
let eta_int64_gt : int64 -> _ = gt;;
let eta_nativeint_gt : nativeint -> _ = gt;;

let eta_gen_le : 'a -> _ = le;;
let eta_int_le : int -> _ = le;;
let eta_bool_le : bool -> _ = le;;
let eta_intlike_le : intlike -> _ = le;;
let eta_float_le : float -> _ = le;;
let eta_string_le : string -> _ = le;;
let eta_int32_le : int32 -> _ = le;;
let eta_int64_le : int64 -> _ = le;;
let eta_nativeint_le : nativeint -> _ = le;;

let eta_gen_ge : 'a -> _ = ge;;
let eta_int_ge : int -> _ = ge;;
let eta_bool_ge : bool -> _ = ge;;
let eta_intlike_ge : intlike -> _ = ge;;
let eta_float_ge : float -> _ = ge;;
let eta_string_ge : string -> _ = ge;;
let eta_int32_ge : int32 -> _ = ge;;
let eta_int64_ge : int64 -> _ = ge;;
let eta_nativeint_ge : nativeint -> _ = ge;;

(* Check results of computations *)

let int_vec = [(1,1);(1,2);(2,1)];;
let bool_vec = [(false,false);(false,true);(true,false)];;
let intlike_vec = [(A,A);(A,B);(B,A)];;
let float_vec = [(1.,1.);(1.,2.);(2.,1.)];;
let string_vec = [("1","1");("1","2");("2","1")];;
let int32_vec = [(1l,1l);(1l,2l);(2l,1l)];;
let int64_vec = [(1L,1L);(1L,2L);(2L,1L)];;
let nativeint_vec = [(1n,1n);(1n,2n);(2n,1n)];;

let test_vec cmp eq ne lt gt le ge vec =
  let uncurry f (x,y) = f x y in
  let map f l = List.map (uncurry f) l in
  (map gen_cmp vec, map cmp vec),
  (map (fun gen spec -> map gen vec, map spec vec)
     [gen_eq,eq; gen_ne,ne; gen_lt,lt; gen_gt,gt; gen_le,le; gen_ge,ge])
;;

test_vec
  int_cmp int_eq int_ne int_lt int_gt int_le int_ge
  int_vec;;
test_vec
  bool_cmp bool_eq bool_ne bool_lt bool_gt bool_le bool_ge
  bool_vec;;
test_vec
  intlike_cmp intlike_eq intlike_ne intlike_lt intlike_gt intlike_le intlike_ge
  intlike_vec;;
test_vec
  float_cmp float_eq float_ne float_lt float_gt float_le float_ge
  float_vec;;
test_vec
  string_cmp string_eq string_ne string_lt string_gt string_le string_ge
  string_vec;;
test_vec
  int32_cmp int32_eq int32_ne int32_lt int32_gt int32_le int32_ge
  int32_vec;;
test_vec
  int64_cmp int64_eq int64_ne int64_lt int64_gt int64_le int64_ge
  int64_vec;;
test_vec
  nativeint_cmp nativeint_eq nativeint_ne
  nativeint_lt nativeint_gt nativeint_le nativeint_ge
  nativeint_vec;;

let eta_test_vec cmp eq ne lt gt le ge vec =
  let uncurry f (x,y) = f x y in
  let map f l = List.map (uncurry f) l in
  (map eta_gen_cmp vec, map cmp vec),
  (map (fun gen spec -> map gen vec, map spec vec)
     [eta_gen_eq,eq; eta_gen_ne,ne; eta_gen_lt,lt;
      eta_gen_gt,gt; eta_gen_le,le; eta_gen_ge,ge])
;;

eta_test_vec
  eta_int_cmp eta_int_eq eta_int_ne eta_int_lt eta_int_gt eta_int_le eta_int_ge
  int_vec;;
eta_test_vec
  eta_bool_cmp eta_bool_eq eta_bool_ne eta_bool_lt eta_bool_gt
  eta_bool_le eta_bool_ge
  bool_vec;;
eta_test_vec
  eta_intlike_cmp eta_intlike_eq eta_intlike_ne eta_intlike_lt eta_intlike_gt
  eta_intlike_le eta_intlike_ge
  intlike_vec;;
eta_test_vec
  eta_float_cmp eta_float_eq eta_float_ne eta_float_lt eta_float_gt
  eta_float_le eta_float_ge
  float_vec;;
eta_test_vec
  eta_string_cmp eta_string_eq eta_string_ne eta_string_lt eta_string_gt
  eta_string_le eta_string_ge
  string_vec;;
eta_test_vec
  eta_int32_cmp eta_int32_eq eta_int32_ne eta_int32_lt eta_int32_gt
  eta_int32_le eta_int32_ge
  int32_vec;;
eta_test_vec
  eta_int64_cmp eta_int64_eq eta_int64_ne eta_int64_lt eta_int64_gt
  eta_int64_le eta_int64_ge
  int64_vec;;
eta_test_vec
  eta_nativeint_cmp eta_nativeint_eq eta_nativeint_ne
  eta_nativeint_lt eta_nativeint_gt eta_nativeint_le eta_nativeint_ge
  nativeint_vec;;