Upstream port: new ocamltest language

ocaml/ocamltest/.depend

@@ -94,6 +94,7 @@ main.cmo : \
     tsl_semantics.cmi \
     tsl_parser.cmi \
     tsl_lexer.cmi \
+    translate.cmi \
     tests.cmi \
     result.cmi \
     options.cmi \
@@ -107,6 +108,7 @@ main.cmx : \
     tsl_semantics.cmx \
     tsl_parser.cmx \
     tsl_lexer.cmx \
+    translate.cmx \
     tests.cmx \
     result.cmx \
     options.cmx \
@@ -366,15 +368,18 @@ ocamltest_unix.cmx : \
 ocamltest_unix.cmi :
 options.cmo : \
     variables.cmi \
+    translate.cmi \
     tests.cmi \
     actions.cmi \
     options.cmi
 options.cmx : \
     variables.cmx \
+    translate.cmx \
     tests.cmx \
     actions.cmx \
     options.cmi
-options.cmi :
+options.cmi : \
+    translate.cmi
 result.cmo : \
     result.cmi
 result.cmx : \
@@ -407,6 +412,19 @@ tests.cmi : \
     result.cmi \
     environments.cmi \
     actions.cmi
+translate.cmo : \
+    tsl_semantics.cmi \
+    tsl_parser.cmi \
+    tsl_lexer.cmi \
+    tsl_ast.cmi \
+    translate.cmi
+translate.cmx : \
+    tsl_semantics.cmx \
+    tsl_parser.cmx \
+    tsl_lexer.cmx \
+    tsl_ast.cmx \
+    translate.cmi
+translate.cmi :
 tsl_ast.cmo : \
     tsl_ast.cmi
 tsl_ast.cmx : \

ocaml/ocamltest/Makefile

@@ -46,7 +46,8 @@ core := \
   tsl_semantics.mli tsl_semantics.ml \
   builtin_variables.mli builtin_variables.ml \
   actions_helpers.mli actions_helpers.ml \
-  builtin_actions.mli builtin_actions.ml
+  builtin_actions.mli builtin_actions.ml \
+  translate.mli translate.ml
 
 ocaml_plugin := \
   ocaml_backends.mli ocaml_backends.ml \

ocaml/ocamltest/main.ml

@@ -22,46 +22,36 @@ type behavior =
   | Skip_all_tests
   | Run of Environments.t
 
-(*
-let first_token filename =
-  let input_channel = open_in filename in
-  let lexbuf = Lexing.from_channel input_channel in
-  Location.init lexbuf filename;
-  let token =
-    try Tsl_lexer.token lexbuf with e -> close_in input_channel; raise e
-  in close_in input_channel; token
-
-let is_test filename =
-  match first_token filename with
-    | exception _ -> false
-    | Tsl_parser.TSL_BEGIN_C_STYLE | TSL_BEGIN_OCAML_STYLE -> true
-    | _ -> false
-*)
-
 (* this primitive announce should be used for tests
    that were aborted on system error before ocamltest
    could parse them *)
 let announce_test_error test_filename error =
   Printf.printf " ... testing '%s' => unexpected error (%s)\n%!"
     (Filename.basename test_filename) error
 
-let tsl_block_of_file test_filename =
+exception Syntax_error of Lexing.position
+
+let tsl_parse_file test_filename =
   let input_channel = open_in test_filename in
   let lexbuf = Lexing.from_channel input_channel in
   Location.init lexbuf test_filename;
-  match Tsl_parser.tsl_block Tsl_lexer.token lexbuf with
+  match Tsl_parser.tsl_script Tsl_lexer.token lexbuf with
+    | exception Parsing.Parse_error ->
+      raise (Syntax_error lexbuf.Lexing.lex_start_p)
     | exception e -> close_in input_channel; raise e
     | _ as tsl_block -> close_in input_channel; tsl_block
 
-let tsl_block_of_file_safe test_filename =
-  try tsl_block_of_file test_filename with
+let tsl_parse_file_safe test_filename =
+  try tsl_parse_file test_filename with
   | Sys_error message ->
     Printf.eprintf "%s\n%!" message;
     announce_test_error test_filename message;
     exit 1
-  | Parsing.Parse_error ->
-    Printf.eprintf "Could not read test block in %s\n%!" test_filename;
-    announce_test_error test_filename "could not read test block";
+  | Syntax_error p ->
+    let open Lexing in
+    Printf.eprintf "%s:%d.%d: syntax error in test script\n%!"
+      test_filename p.pos_lnum (p.pos_cnum - p.pos_bol);
+    announce_test_error test_filename "could not read test script";
     exit 1
 
 let print_usage () =
@@ -131,8 +121,8 @@ let init_tests_to_skip () =
 let test_file test_filename =
   let start = if Options.show_timings then Unix.gettimeofday () else 0.0 in
   let skip_test = List.mem test_filename !tests_to_skip in
-  let tsl_block = tsl_block_of_file_safe test_filename in
-  let (rootenv_statements, test_trees) = test_trees_of_tsl_block tsl_block in
+  let tsl_ast = tsl_parse_file_safe test_filename in
+  let (rootenv_statements, test_trees) = test_trees_of_tsl_ast tsl_ast in
   let test_trees = match test_trees with
     | [] ->
       let default_tests = Tests.default_tests() in
@@ -221,10 +211,12 @@ let test_file test_filename =
     Printf.eprintf "Wall clock: %s took %.02fs\n%!"
                    test_filename wall_clock_duration
 
-let is_test s =
-  match tsl_block_of_file s with
-  | _ -> true
-  | exception _ -> false
+let is_test filename =
+  let input_channel = open_in filename in
+  let lexbuf = Lexing.from_channel input_channel in
+  Fun.protect ~finally:(fun () -> close_in input_channel) begin fun () ->
+    Tsl_lexer.is_test lexbuf
+  end
 
 let ignored s =
   s = "" || s.[0] = '_' || s.[0] = '.'
@@ -277,6 +269,12 @@ let () =
   let doit f x = work_done := true; f x in
   List.iter (doit find_test_dirs) Options.find_test_dirs;
   List.iter (doit list_tests) Options.list_tests;
-  List.iter (doit test_file) Options.files_to_test;
+  let do_file =
+    if Options.translate then
+      Translate.file ~style:Options.style ~compact:Options.compact
+    else
+      test_file
+  in
+  List.iter (doit do_file) Options.files_to_test;
   if not !work_done then print_usage();
   if !failed || not !work_done then exit 1