l4/pkg/ocaml/contrib/otherlibs/num/test/test.ml

   1 open Printf;;
   2
   3 let flush_all () = flush stdout; flush stderr;;
   4
   5 let message s = print_string s; print_newline ();;
   6
   7 let error_occurred = ref false;;
   8 let immediate_failure = ref true;;
   9
  10 let error () =
  11  if !immediate_failure then exit 2 else begin
  12    error_occurred := true;
  13    flush_all ();
  14    false
  15  end;;
  16
  17 let success () = flush_all (); true;;
  18
  19 let function_tested = ref "";;
  20
  21 let testing_function s =
  22     flush_all ();
  23     function_tested := s;
  24     print_newline();
  25     message s;;
  26
  27 let test test_number eq_fun (answer, correct_answer) =
  28  flush_all ();
  29  if not (eq_fun answer correct_answer) then begin
  30    fprintf stderr ">>> Bad result (%s, test %d)\n" !function_tested test_number;
  31    error ()
  32  end else begin
  33    printf " %d..." test_number;
  34    success ()
  35  end;;
  36
  37 let failure_test test_number fun_to_test arg =
  38  flush_all ();
  39  try
  40    fun_to_test arg;
  41    fprintf stderr ">>> Failure expected (%s, test %d)\n"
  42                   !function_tested test_number;
  43    error ()
  44   with _ ->
  45    printf " %d..." test_number;
  46    success ();;
  47
  48 let failwith_test test_number fun_to_test arg correct_failure =
  49  flush_all ();
  50  try
  51    fun_to_test arg;
  52    fprintf stderr ">>> Failure expected (%s, test %d)\n"
  53                   !function_tested test_number;
  54    error ()
  55   with x ->
  56    if x = correct_failure then begin
  57      printf " %d..." test_number;
  58      success ()
  59    end else begin
  60      fprintf stderr ">>> Bad failure (%s, test %d)\n"
  61                     !function_tested test_number;
  62      error ()
  63    end;;
  64
  65 let end_tests () =
  66  flush_all ();
  67  print_newline ();
  68  if !error_occurred then begin
  69    prerr_endline "************* TESTS FAILED ****************"; exit 2
  70  end else begin
  71    prerr_endline "************* TESTS COMPLETED SUCCESSFULLY ****************";
  72    exit 0
  73  end;;
  74
  75 let eq = (==);;
  76 let eq_int (i: int) (j: int) = (i = j);;
  77 let eq_string (i: string) (j: string) = (i = j);;
  78 let eq_nativeint (i: nativeint) (j: nativeint) = (i = j);;
  79 let eq_int32 (i: int32) (j: int32) = (i = j);;
  80 let eq_int64 (i: int64) (j: int64) = (i = j);;
  81
  82 let sixtyfour = (1 lsl 31) <> 0;;