From 2630db6966a02c2465ff4abdafce529666159324 Mon Sep 17 00:00:00 2001 From: Mark Shinwell Date: Fri, 6 Dec 2024 15:21:11 +0000 Subject: [PATCH] Fix for PR2755 (ocamltest fail-if-test-does-nothing) (#3340) * Fix for PR2755, ocamltest * test * Restrict DLS_thread_safety to runtime5 --- ocamltest/main.ml | 32 ++++++++++++++++--- ocamltest/tests.ml | 10 ++---- ocamltest/tests.mli | 4 +-- ocamltest/tsl_semantics.ml | 28 ---------------- .../tests/lib-domain/DLS_thread_safety.ml | 3 ++ testsuite/tests/lib-unix/common/bigarrays.ml | 2 ++ 6 files changed, 38 insertions(+), 41 deletions(-) diff --git a/ocamltest/main.ml b/ocamltest/main.ml index 2422c86dd58..56b804f3200 100644 --- a/ocamltest/main.ml +++ b/ocamltest/main.ml @@ -107,12 +107,14 @@ let join_summaries sa sb = | No_failure, (No_failure | All_skipped) | All_skipped, No_failure -> No_failure -let rec run_test_tree log common_prefix behavior env summ ast = +let rec run_test_tree log common_prefix behavior env summ ast + ~must_do_something = match ast with | Ast (Environment_statement s :: stmts, subs) -> begin match interpret_environment_statement env s with | env -> run_test_tree log common_prefix behavior env summ (Ast (stmts, subs)) + ~must_do_something | exception e -> let line = s.loc.Location.loc_start.Lexing.pos_lnum in Printf.printf "%s line %d %!" common_prefix line; @@ -133,27 +135,49 @@ let rec run_test_tree log common_prefix behavior env summ ast = in if not skip_all then Printf.printf "%s %s (%s) %!" common_prefix locstr name.node; + let test = lookup_test name in + let must_do_something = + must_do_something && not (Tests.does_something test) + in let (msg, children_behavior, newenv, result) = match behavior with | Skip_all -> ("", Skip_all, env, Result.skip) | Run -> begin try let testenv = List.fold_left apply_modifiers env mods in - let test = lookup_test name in let (result, newenv) = Tests.run log testenv test in let msg = Result.string_of_result result in let sub_behavior = if Result.is_pass result then Run else Skip_all in (msg, sub_behavior, newenv, result) - with e -> (report_error name.loc e, Skip_all, env, Result.fail) + with e -> + (report_error name.loc e, Skip_all, env, Result.fail) end in if not skip_all then Printf.printf "%s\n%!" msg; let newsumm = join_result summ result in let newast = Ast (stmts, subs) in run_test_tree log common_prefix children_behavior newenv newsumm newast + ~must_do_something + | Ast ([], []) -> + if not must_do_something then summ + else ( + match summ with + | No_failure -> + Printf.printf "%s: does the test tree do something? => failed\n%!" + common_prefix; + Some_failure + | All_skipped | Some_failure -> summ + ) | Ast ([], subs) -> + (* CR mshinwell/xclerc: maybe sequences of actions that "do something" and + then have further actions that do not "do something" should be + flagged *) List.fold_left join_summaries summ - (List.map (run_test_tree log common_prefix behavior env All_skipped) subs) + (List.map (run_test_tree log common_prefix behavior env All_skipped + ~must_do_something) subs) + +let run_test_tree log common_prefix behavior env summ ast = + run_test_tree log common_prefix behavior env summ ast ~must_do_something:true let get_test_source_directory test_dirname = if (Filename.is_relative test_dirname) then diff --git a/ocamltest/tests.ml b/ocamltest/tests.ml index b5660100045..d83a42d370e 100644 --- a/ocamltest/tests.ml +++ b/ocamltest/tests.ml @@ -29,13 +29,6 @@ let null = { test_description = "dummy test inserted by parser; always pass" } -let does_nothing = { - test_name = "test does nothing"; - test_run_by_default = false; - test_actions = [Actions_helpers.fail_with_reason "test does nothing"]; - test_description = "inserted when a test does not do any substantive action" -} - let compare t1 t2 = String.compare t1.test_name t2.test_name let (tests: (string, t) Hashtbl.t) = Hashtbl.create 20 @@ -98,3 +91,6 @@ module TestSet = Set.Make type nonrec t = t let compare = compare end) + +let does_something t = + List.exists Actions.does_something t.test_actions diff --git a/ocamltest/tests.mli b/ocamltest/tests.mli index 9ecf535e41b..9d60b367603 100644 --- a/ocamltest/tests.mli +++ b/ocamltest/tests.mli @@ -24,8 +24,6 @@ type t = { val null : t -val does_nothing : t - val compare : t -> t -> int val register : t -> unit @@ -41,3 +39,5 @@ val run : out_channel -> Environments.t -> t -> Result.t * Environments.t val test_of_action : Actions.t -> t module TestSet : Set.S with type elt = t + +val does_something : t -> bool diff --git a/ocamltest/tsl_semantics.ml b/ocamltest/tsl_semantics.ml index 375c2b02a3c..244a2ce51b7 100644 --- a/ocamltest/tsl_semantics.ml +++ b/ocamltest/tsl_semantics.ml @@ -74,19 +74,6 @@ type test_tree = string located list * (test_tree list) -let tests_do_something (tests : Tests.t) = - List.exists Actions.does_something tests.test_actions - -(* CR mshinwell/xclerc: maybe sequences of actions that "do something" and - then have further actions that do not "do something" should be - flagged *) -let rec test_tree_does_something_on_all_branches tree = - match tree with - | Node (_, tests, _, []) -> tests_do_something tests - | Node (_, tests, _, children) -> - tests_do_something tests - || List.for_all test_tree_does_something_on_all_branches children - let too_deep testname max_level real_level = Printf.eprintf "Test %s should have depth atmost %d but has depth %d\n%!" testname max_level real_level; @@ -153,21 +140,6 @@ let test_trees_of_tsl_block tsl_block = | (Environment_statement s)::_ -> unexpected_environment_statement s | _ -> assert false -let test_trees_of_tsl_block tsl_block = - let (env, trees) = test_trees_of_tsl_block tsl_block in - let does_something = - List.for_all test_tree_does_something_on_all_branches trees - in - if does_something then env, trees - else - let tree = - match trees with - | [] -> [] - | Node (_, _, name, _) :: _ -> - [Node ([], Tests.does_nothing, name, [])] - in - env, tree - let tests_in_stmt set stmt = match stmt with | Environment_statement _ -> set diff --git a/testsuite/tests/lib-domain/DLS_thread_safety.ml b/testsuite/tests/lib-domain/DLS_thread_safety.ml index b04d7a133d0..f8812ee9595 100644 --- a/testsuite/tests/lib-domain/DLS_thread_safety.ml +++ b/testsuite/tests/lib-domain/DLS_thread_safety.ml @@ -1,6 +1,9 @@ (* TEST include systhreads; hassysthreads; + runtime5; + { bytecode; } + { native; } *) (* This test creates [nb_keys] DLS keys, each storing an atomic integer. diff --git a/testsuite/tests/lib-unix/common/bigarrays.ml b/testsuite/tests/lib-unix/common/bigarrays.ml index f8214eb6c38..b0c073d0025 100644 --- a/testsuite/tests/lib-unix/common/bigarrays.ml +++ b/testsuite/tests/lib-unix/common/bigarrays.ml @@ -1,6 +1,8 @@ (* TEST include unix; hasunix; +{ bytecode; } +{ native; } *) let filename = "test.out"