diff --git a/src/test-actions.adb b/src/test-actions.adb index 384f620e..885506b5 100644 --- a/src/test-actions.adb +++ b/src/test-actions.adb @@ -55,6 +55,7 @@ with Test.Common; with Test.Skeleton.Source_Table; with Test.Harness.Source_Table; with Test.Generation; +with Test.Suite_Min; with Ada.Directories; use Ada.Directories; with Utils.Projects; use Utils.Projects; @@ -1038,6 +1039,20 @@ package body Test.Actions is Test.Harness.Generate_Makefile (Src_Prj); Test.Harness.Generate_Config; Test.Common.Generate_Common_File; + + -- We need to minimize the testsuite before generating the mapping + -- file, as the generation of this file clears the mapping data + -- structure. + + if Arg (Cmd, Minimize) then + if Test.Common.Harness_Has_Gen_Tests then + Test.Suite_Min.Minimize_Suite (Cmd); + else + Test.Common.Report_Err + ("No generated tests found in the harness," + & " nothing to do in the minimization phase."); + end if; + end if; Test.Mapping.Generate_Mapping_File; end if; diff --git a/src/test-command_lines.ads b/src/test-command_lines.ads index 33ee90a1..593bc54e 100644 --- a/src/test-command_lines.ads +++ b/src/test-command_lines.ads @@ -52,7 +52,8 @@ package Test.Command_Lines is Serialized_Test_Dir, Dump_Test_Inputs, Unparse, - Enum_Strat); + Enum_Strat, + Minimize); package Test_Boolean_Switches is new Boolean_Switches (Descriptor, @@ -91,7 +92,8 @@ package Test.Command_Lines is Copy_Environment, Reporter, Gen_Test_Num, - Serialized_Test_Dir); + Serialized_Test_Dir, + Cov_Level); package Test_String_Switches is new String_Switches (Descriptor, @@ -110,7 +112,8 @@ package Test.Command_Lines is Copy_Environment => '=', Reporter => '=', Gen_Test_Num => '=', - Serialized_Test_Dir => '=']); + Serialized_Test_Dir => '=', + Cov_Level => '=']); type Test_String_Seqs is (Exclude_From_Stubbing); diff --git a/src/test-common.adb b/src/test-common.adb index 14bc1a77..c3f2273f 100755 --- a/src/test-common.adb +++ b/src/test-common.adb @@ -23,6 +23,7 @@ with Libadalang.Common; use Libadalang.Common; +with Ada.Directories; with Ada.Text_IO; use Ada.Text_IO; with Ada.IO_Exceptions; with Ada.Exceptions; use Ada.Exceptions; @@ -1253,4 +1254,16 @@ package body Test.Common is Need_Lib_Support := Generated; end Mark_Lib_Support_Generated; + --------------------------- + -- Harness_Has_Gen_Tests -- + --------------------------- + + function Harness_Has_Gen_Tests return Boolean is + (Need_Lib_Support = Generated + and then JSON_Test_Dir /= null + and then Ada.Directories.Exists (JSON_Test_Dir.all)); + + -- The harness can only have generated tests if the support library has + -- been generated, and the JSON_Test dir exists. + end Test.Common; diff --git a/src/test-common.ads b/src/test-common.ads index 681292e7..841ac612 100755 --- a/src/test-common.ads +++ b/src/test-common.ads @@ -407,6 +407,9 @@ package Test.Common is procedure Mark_Lib_Support_Generated; -- Flag that the TGen support library has already been generated + function Harness_Has_Gen_Tests return Boolean; + -- Return whether the harness contains any generated tests + TGen_Num_Tests : Natural := 5; -- Number of tests to be generated for each procedure (or upper limit if -- using enumerative strategies). diff --git a/src/test-generation.adb b/src/test-generation.adb index 30e94255..d752eeee 100644 --- a/src/test-generation.adb +++ b/src/test-generation.adb @@ -26,12 +26,12 @@ with Ada.Strings.Unbounded; use Ada.Strings.Unbounded; with GNAT.OS_Lib; with Test.Actions; -with Test.Common; use Test.Common; +with Test.Common; use Test.Common; with Test.Command_Lines; -with Utils.Command_Lines.Common; use Utils.Command_Lines.Common; -with Utils_Debug; use Utils_Debug; -with Utils.Drivers; use Utils.Drivers; -with Utils.Environment; use Utils.Environment; +with Test.Subprocess; use Test.Subprocess; +with Utils_Debug; use Utils_Debug; +with Utils.Drivers; use Utils.Drivers; +with Utils.Environment; use Utils.Environment; with GNATCOLL.OS.Process; @@ -128,34 +128,16 @@ package body Test.Generation is procedure Generate_Build_And_Run (Cmd : Command_Line) is use GNATCOLL.OS.Process; - use Common_String_Seq_Switches; Directory_Separator : Character renames GNAT.OS_Lib.Directory_Separator; - type Arg_List_Acc is access all Argument_List; - Build_Args : aliased Argument_List; - Run_Args : aliased Argument_List; + + Build_Args : Argument_List; + Run_Args : Argument_List; Harness_Dir : constant String := Tool_Temp_Dir.all & Directory_Separator & "tgen_Harness"; - Ext_Vars : constant String_Ref_Array := Arg (Cmd, External_Variable); - Ret_Status : Integer; Ext_Acc : GNAT.OS_Lib.String_Access := GNAT.OS_Lib.Get_Executable_Suffix; Ext : constant String := Ext_Acc.all; - procedure PP_Cmd (Cmd : Arg_List_Acc); - - ------------ - -- PP_Cmd -- - ------------ - - procedure PP_Cmd (Cmd : Arg_List_Acc) is - Result : Unbounded_String; - begin - for Arg of Cmd.all loop - Result := Result & Arg & " "; - end loop; - Report_Err ("Running " & To_String (Result)); - end PP_Cmd; - begin GNAT.OS_Lib.Free (Ext_Acc); @@ -178,11 +160,7 @@ package body Test.Generation is Build_Args.Append ("-P"); Build_Args.Append (Harness_Dir & Directory_Separator & "tgen_generation_harness.gpr"); - for Var of Ext_Vars loop - if Var not in null then - Build_Args.Append ("-X" & Var.all); - end if; - end loop; + Populate_X_Vars (Build_Args, Cmd); -- Suppress all warning/info messages and style checks @@ -193,30 +171,13 @@ package body Test.Generation is if Debug_Flag_1 then Build_Args.Append ("-g"); Build_Args.Append ("-O0"); - PP_Cmd (Build_Args'Access); - end if; - Ret_Status := Run (Build_Args); - if Ret_Status /= 0 then - Report_Err ("Build of generation harness exited with status" - & Ret_Status'Image); - Clean_Up; - GNAT.OS_Lib.OS_Exit (1); end if; + Run (Build_Args, "Build of the test generation harness"); Run_Args.Append (Harness_Dir & Directory_Separator & "obj" & Directory_Separator & "generation_main" & Ext); - - if Debug_Flag_1 then - PP_Cmd (Run_Args'Access); - end if; - Ret_Status := Run (Run_Args); - if Ret_Status /= 0 then - Report_Err ("Run of generation harness exited with status" - & Ret_Status'Image); - Clean_Up; - GNAT.OS_Lib.OS_Exit (1); - end if; + Run (Run_Args, "Execution of the test generation harness"); end Generate_Build_And_Run; end Test.Generation; diff --git a/src/test-harness.adb b/src/test-harness.adb index 3ad25e5f..ff69a433 100755 --- a/src/test-harness.adb +++ b/src/test-harness.adb @@ -1145,15 +1145,22 @@ package body Test.Harness is S_Put (0, "project Test_Driver is"); Put_New_Line; Put_New_Line; - S_Put - (3, - "for Origin_Project use """ - & (+Relative_Path - (Create (+Source_Prj), - Create (+Harness_Dir.all))) - & """;"); - Put_New_Line; - Put_New_Line; + + -- When using the test generation features, do not emit an origin + -- project attribute, otherwise gnatcov will not process the harness + -- project at all. + + if not Test.Common.Harness_Has_Gen_Tests then + S_Put + (3, + "for Origin_Project use """ + & (+Relative_Path + (Create (+Source_Prj), + Create (+Harness_Dir.all))) + & """;"); + Put_New_Line; + Put_New_Line; + end if; S_Put (3, "for Target use Gnattest_Common'Target;"); Put_New_Line; Put_New_Line; @@ -2813,21 +2820,29 @@ package body Test.Harness is & " is"); Put_New_Line; Put_New_Line; - if Relocatable_Harness then - S_Put - (3, - "for Origin_Project use external " - & "(""ORIGIN_PROJECT_DIR"", """") & """ - & Base_Name (Source_Prj) - & """;"); - else - S_Put - (3, - "for Origin_Project use """ - & (+Relative_Path - (Create (+Source_Prj), - Create (+Normalize_Pathname (Dir_Name (P.Path_TD.all))))) - & """;"); + + -- When using the test generation features, do not emit an origin + -- project attribute, otherwise gnatcov will not process the harness + -- project at all. + + if not Test.Common.Harness_Has_Gen_Tests then + if Relocatable_Harness then + S_Put + (3, + "for Origin_Project use external " + & "(""ORIGIN_PROJECT_DIR"", """") & """ + & Base_Name (Source_Prj) + & """;"); + else + S_Put + (3, + "for Origin_Project use """ + & (+Relative_Path + (Create (+Source_Prj), + Create + (+Normalize_Pathname (Dir_Name (P.Path_TD.all))))) + & """;"); + end if; end if; Put_New_Line; Put_New_Line; @@ -3255,21 +3270,29 @@ package body Test.Harness is & P.Name_TD.all & " is"); Put_New_Line; - if Relocatable_Harness then - S_Put - (3, - "for Origin_Project use external " - & "(""ORIGIN_PROJECT_DIR"", """") & """ - & Base_Name (P.Path_Of_Extended.all) - & """;"); - else - S_Put - (3, - "for Origin_Project use """ - & (+Relative_Path - (Create (+P.Path_Of_Extended.all), - Create (+Normalize_Pathname (Dir_Name (P.Path_TD.all))))) - & """;"); + + -- When using the test generation features, do not emit an origin + -- project attribute, otherwise gnatcov will not process the harness + -- project at all. + + if not Test.Common.Harness_Has_Gen_Tests then + if Relocatable_Harness then + S_Put + (3, + "for Origin_Project use external " + & "(""ORIGIN_PROJECT_DIR"", """") & """ + & Base_Name (P.Path_Of_Extended.all) + & """;"); + else + S_Put + (3, + "for Origin_Project use """ + & (+Relative_Path + (Create (+P.Path_Of_Extended.all), + Create + (+Normalize_Pathname (Dir_Name (P.Path_TD.all))))) + & """;"); + end if; end if; Put_New_Line; Put_New_Line; @@ -3560,22 +3583,28 @@ package body Test.Harness is end loop; end if; - Put_New_Line; - if Relocatable_Harness then - S_Put - (3, - "for Origin_Project use external " - & "(""ORIGIN_PROJECT_DIR"", """") & """ - & Base_Name (Source_Prj) - & """;"); - else - S_Put - (3, - "for Origin_Project use """ - & (+Relative_Path - (Create (+Source_Prj), - Create (+Normalize_Pathname (Harness_Dir.all)))) - & """;"); + -- When using the test generation features, do not emit an origin + -- project attribute, otherwise gnatcov will not process the harness + -- project at all. + + if not Test.Common.Harness_Has_Gen_Tests then + Put_New_Line; + if Relocatable_Harness then + S_Put + (3, + "for Origin_Project use external " + & "(""ORIGIN_PROJECT_DIR"", """") & """ + & Base_Name (Source_Prj) + & """;"); + else + S_Put + (3, + "for Origin_Project use """ + & (+Relative_Path + (Create (+Source_Prj), + Create (+Normalize_Pathname (Harness_Dir.all)))) + & """;"); + end if; end if; Put_New_Line; Put_New_Line; diff --git a/src/test-mapping.ads b/src/test-mapping.ads index 5af1a8e4..3adfdb49 100755 --- a/src/test-mapping.ads +++ b/src/test-mapping.ads @@ -86,6 +86,9 @@ package Test.Mapping is Column : Natural; -- Sloc for the subprogram under test + TR_Hash : String_Access; + -- Full hash for the subprogram under test + TC_List : TC_Mapping_List.List; -- List of testcases holding the information above, if there are -- several. @@ -95,6 +98,9 @@ package Test.Mapping is -- this one points at the first line of declaration. This is needed -- to properly support cases with "overriding/not overriding" decorators -- in test filtering, as decorator usually takes an extra line. + + Decl_File : String_Access; + -- Full filename in which the subprogram under test is declared end record; -- Stores info on individual subprogram under test and collection of -- corresponding test cases (if any). @@ -126,6 +132,7 @@ package Test.Mapping is TearDown_Column : Natural; TR_List : TR_Mapping_List.List; DT_List : DT_Mapping_List.List; + Has_Gen_Tests : Boolean := False; end record; -- Stores info on individual test package, all it's test routines and -- dangling tests. diff --git a/src/test-skeleton.adb b/src/test-skeleton.adb index a916ee31..16706d92 100755 --- a/src/test-skeleton.adb +++ b/src/test-skeleton.adb @@ -198,6 +198,10 @@ package body Test.Skeleton is Unit_File_Name : String_Access; -- Full name of the file, containing the CU + Has_Gen_Tests : Boolean := False; + -- Whether this unit has generated tests that were expanded into + -- a test unit. + case Data_Kind is -- Indicates which data storing structures are used, determines the -- way of suite generation. @@ -435,13 +439,16 @@ package body Test.Skeleton is -- Generates test package spec and body. Save in TP_List information about -- generated tests. - procedure Output_Generated_Tests + function Output_Generated_Tests (Data : Data_Holder; Suite_Data_List : in out Suites_Data_Type; - TP_List : in out TP_Mapping_List.List); + TP_List : in out TP_Mapping_List.List) return Boolean; -- Create test packages containing all the generated tests from TGen, -- loading them from file. Fill the suite info as we create new test cases, -- and save in TP_List information about generated tests. + -- + -- Return True if a test package was created and at least one test was + -- generated. procedure Generate_Procedure_Wrapper (Current_Subp : Subp_Info); -- Prints a test-case specific wrapper for tested procedure @@ -465,13 +472,15 @@ package body Test.Skeleton is Overloading_N : Natural; Commented_Out : Boolean := False; Use_Short_Name : Boolean := True; - Type_Name : String := ""); + Type_Name : String := ""; + Add_Cov_Dump : Boolean := False); procedure Put_Closing_Comment_Section (Subp : Subp_Info; Overloading_N : Natural; Commented_Out : Boolean := False; - Use_Short_Name : Boolean := True); + Use_Short_Name : Boolean := True; + Add_Cov_Dump : Boolean := False); function Sanitize_TC_Name (TC_Name : String) return String; -- Processes the name of the test case in such a way that it could be used @@ -765,11 +774,17 @@ package body Test.Skeleton is -- Save information about generated test cases begin - Generate_Nested_Hierarchy (Data); - Generate_Test_Package (Data, TP_List); + -- Output generated JSON tests first, to determine whether at + -- least one was found for the unit. If not, there is no point + -- in dumping the traces for user-written test. + -- This is recorded in the Data holder. + if Ada.Directories.Exists (Test.Common.JSON_Test_Dir.all) then - Output_Generated_Tests (Data, Suite_Data_List, TP_List); + Data.Has_Gen_Tests := + Output_Generated_Tests (Data, Suite_Data_List, TP_List); end if; + Generate_Nested_Hierarchy (Data); + Generate_Test_Package (Data, TP_List); Add_Test_List (Data.Unit_File_Name.all, TP_List); TP_List.Clear; end; @@ -5324,7 +5339,8 @@ package body Test.Skeleton is Elem_Numbers.Element (Current_Subp.Subp_Declaration), Use_Short_Name => MD.Short_Name_Used, - Type_Name => Current_Type.Main_Type_Text_Name.all); + Type_Name => Current_Type.Main_Type_Text_Name.all, + Add_Cov_Dump => Data.Has_Gen_Tests); if Is_Unimplemented_Test (MD.TR_Text) then TR_SLOC_Buffer.Append @@ -5429,7 +5445,8 @@ package body Test.Skeleton is (Subp_Data_List.Element (Subp_Cur), Elem_Numbers.Element (Current_Subp.Subp_Declaration), - Use_Short_Name => MD.Short_Name_Used); + Use_Short_Name => MD.Short_Name_Used, + Add_Cov_Dump => Data.Has_Gen_Tests); New_Line_Count; end if; @@ -5484,7 +5501,8 @@ package body Test.Skeleton is Put_Opening_Comment_Section (Stub, 0, True, False, - Current_Type.Main_Type_Text_Name.all); + Current_Type.Main_Type_Text_Name.all, + Add_Cov_Dump => Data.Has_Gen_Tests); Add_DT (TP_List, @@ -5508,7 +5526,8 @@ package body Test.Skeleton is (Stub, 0, True, - False); + False, + Add_Cov_Dump => Data.Has_Gen_Tests); New_Line_Count; end; end if; @@ -6508,7 +6527,8 @@ package body Test.Skeleton is (Subp_Data_List.Element (Subp_Cur), Elem_Numbers.Element (Current_Subp.Subp_Declaration), - Use_Short_Name => MD.Short_Name_Used); + Use_Short_Name => MD.Short_Name_Used, + Add_Cov_Dump => Data.Has_Gen_Tests); if Is_Unimplemented_Test (MD.TR_Text) then TR_SLOC_Buffer.Append @@ -6612,7 +6632,8 @@ package body Test.Skeleton is (Subp_Data_List.Element (Subp_Cur), Elem_Numbers.Element (Current_Subp.Subp_Declaration), - Use_Short_Name => MD.Short_Name_Used); + Use_Short_Name => MD.Short_Name_Used, + Add_Cov_Dump => Data.Has_Gen_Tests); New_Line_Count; end if; @@ -6679,7 +6700,8 @@ package body Test.Skeleton is end if; Put_Opening_Comment_Section - (Stub, 0, True, MD.Short_Name_Used); + (Stub, 0, True, MD.Short_Name_Used, + Add_Cov_Dump => Data.Has_Gen_Tests); Add_DT (TP_List, @@ -6700,7 +6722,11 @@ package body Test.Skeleton is end loop; Put_Closing_Comment_Section - (Stub, 0, True, MD.Short_Name_Used); + (Stub, + 0, + True, + MD.Short_Name_Used, + Add_Cov_Dump => Data.Has_Gen_Tests); New_Line_Count; end; end if; @@ -6781,10 +6807,10 @@ package body Test.Skeleton is -- Output_Generated_Tests -- ---------------------------- - procedure Output_Generated_Tests + function Output_Generated_Tests (Data : Data_Holder; Suite_Data_List : in out Suites_Data_Type; - TP_List : in out TP_Mapping_List.List) + TP_List : in out TP_Mapping_List.List) return Boolean is use TGen.Strings; @@ -6832,19 +6858,19 @@ package body Test.Skeleton is begin -- We do not support non-instanciated generic packages if Data.Data_Kind /= Declaration_Data or else Data.Is_Generic then - return; + return False; end if; -- Skip if there's no JSON file for this unit if not JSON_Unit_File.Is_Regular_File and then not Is_Readable (JSON_Unit_File) then - return; + return False; end if; Unit_Raw_Content := GNATCOLL.VFS.Read_File (JSON_Unit_File); if Unit_Raw_Content in null then - return; + return False; end if; Unit_Content := Read @@ -7265,6 +7291,12 @@ package body Test.Skeleton is end; end if; end loop; + + -- Add marker to reset coverage buffers + + Put_Line + (Body_Kind, + Com & " pragma Annotate (Xcov, Reset_Buffers);"); if Is_Function then Put_Line (Body_Kind, Com & " declare"); Put_Line (Body_Kind, Com & " Ret_Val : " @@ -7284,8 +7316,29 @@ package body Test.Skeleton is Pp_Subp_Call (Files (Body_Kind), 3); end if; New_Line (Body_Kind); + + -- Dump the coverage buffers + + Put_Line + (Body_Kind, + Com & " pragma Annotate (Xcov, Dump_Buffers, """ + & Subp.Subp_Full_Hash.all & "-gen-" + & Trim (Integer'Image (Test_Count - 1), Both) & """);"); + New_Line (Body_Kind); + Put_Line (Body_Kind, Com & "exception"); Put_Line (Body_Kind, Com & " when Exc : others =>"); + + -- Also dump the trace in case something crashed in the test. + -- It remains interesting coverage input. + + Put_Line + (Body_Kind, + Com & " pragma Annotate (Xcov, Dump_Buffers, """ + & Subp.Subp_Full_Hash.all & "-gen-" + & Trim (Integer'Image (Test_Count - 1), Both) & """);"); + New_Line (Body_Kind); + Put_Line (Body_Kind, Com & " AUnit.Assertions.Assert"); Put_Line (Body_Kind, Com & " (False,"); Put_Line @@ -7356,7 +7409,7 @@ package body Test.Skeleton is end loop; GNAT.Strings.Free (Unit_Raw_Content); - + return True; end Output_Generated_Tests; ------------ @@ -7476,7 +7529,10 @@ package body Test.Skeleton is (TR_Name => new String'(Subp.Subp_Text_Name.all), Line => Natural (Subp_Name_Span.Start_Line), Column => Natural (Subp_Name_Span.Start_Column), + TR_Hash => new String'(Subp.Subp_Full_Hash.all), Decl_Line => Natural (Subp_Span.Start_Line), + Decl_File => + new String'(Subp.Subp_Declaration.Unit.Get_Filename), others => <>)); TR := TP_Mapping_List.Reference (TP_List, TP).TR_List.Last; end if; @@ -7493,6 +7549,12 @@ package body Test.Skeleton is begin TR_Ref.TC_List.Append (TC); end; + + -- Record whether this test package contains any generated tests + + if Origin = Test_Case_Generated then + TP_List.Reference (TP).Has_Gen_Tests := True; + end if; end Add_TR; ------------ @@ -8254,7 +8316,8 @@ package body Test.Skeleton is (Subp : Subp_Info; Overloading_N : Natural; Commented_Out : Boolean := False; - Use_Short_Name : Boolean := True) + Use_Short_Name : Boolean := True; + Add_Cov_Dump : Boolean := False) is Overloading_Prefix : String_Access; begin @@ -8275,6 +8338,13 @@ package body Test.Skeleton is S_Put (0, "-- begin read only"); New_Line_Count; + if Add_Cov_Dump then + S_Put + (6, "pragma Annotate (Xcov, Dump_Buffers, """ + & Subp.Subp_Full_Hash.all & """);"); + New_Line_Count; + end if; + if Commented_Out then S_Put (3, @@ -8312,7 +8382,8 @@ package body Test.Skeleton is Overloading_N : Natural; Commented_Out : Boolean := False; Use_Short_Name : Boolean := True; - Type_Name : String := "") + Type_Name : String := ""; + Add_Cov_Dump : Boolean := False) is Hash_Length_Used : constant := 15; Hash_First : constant Integer := Subp.Subp_Full_Hash'First; @@ -8582,6 +8653,23 @@ package body Test.Skeleton is Put_New_Line; end if; + if Add_Cov_Dump then + S_Put (6, "function GNATTEST_Reset_Cov return Boolean is"); + New_Line_Count; + S_Put (6, "begin"); + New_Line_Count; + S_Put (9, "pragma Annotate (Xcov, Reset_Buffers);"); + New_Line_Count; + S_Put (9, "return True;"); + New_Line_Count; + S_Put (6, "end GNATTEST_Reset_Cov;"); + New_Line_Count; + New_Line_Count; + S_Put (6, "Dummy_GNATTEST_Reset_Cov : constant Boolean :=" + & " GNATTEST_Reset_Cov;"); + New_Line_Count; + end if; + S_Put (0, "-- end read only"); New_Line_Count; diff --git a/src/test-subprocess.adb b/src/test-subprocess.adb new file mode 100644 index 00000000..672c63b7 --- /dev/null +++ b/src/test-subprocess.adb @@ -0,0 +1,113 @@ +------------------------------------------------------------------------------ +-- -- +-- Libadalang Tools -- +-- -- +-- Copyright (C) 2014-2024, AdaCore -- +-- -- +-- Libadalang Tools is free software; you can redistribute it and/or modi- -- +-- fy it under terms of the GNU General Public License as published by -- +-- the Free Software Foundation; either version 3, or (at your option) any -- +-- later version. This software is distributed in the hope that it will be -- +-- useful but WITHOUT ANY WARRANTY; without even the implied warranty of -- +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are -- +-- granted additional permissions described in the GCC Runtime Library -- +-- Exception, version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and a -- +-- copy of the GCC Runtime Library Exception along with this program; see -- +-- the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +------------------------------------------------------------------------------ + +with Ada.Exceptions; +with Ada.Strings.Unbounded; use Ada.Strings.Unbounded; + +with GNAT.OS_Lib; + +with Test.Common; use Test.Common; +with Utils.Command_Lines.Common; use Utils.Command_Lines.Common; +with Utils_Debug; +with Utils.Environment; + +with GNATCOLL.OS.FS; + +package body Test.Subprocess is + + ------------ + -- PP_Cmd -- + ------------ + + procedure PP_Cmd (Cmd : Argument_List; Prefix : String := "") is + Result : Unbounded_String; + begin + for Arg of Cmd loop + Result := Result & Arg & " "; + end loop; + Report_Err + ((if Prefix /= "" then Prefix & " " else "") & To_String (Result)); + end PP_Cmd; + + --------- + -- Run -- + --------- + + procedure Run + (Cmd : Argument_List; + What : String := ""; + Out_To_Null : Boolean := False) + is + use GNATCOLL.OS.FS; + Return_Status : Integer; + Out_FD : constant File_Descriptor := + (if Out_To_Null then Null_FD else Standout); + begin + if Utils_Debug.Debug_Flag_2 + or else Utils_Debug.Debug_Flag_1 + or else Test.Common.Verbose + then + PP_Cmd (Cmd, "Running"); + end if; + Return_Status := + Run (Cmd, Stdout => Out_FD, Stderr => Out_FD); + if Return_Status /= 0 then + Report_Err + ((if What = "" then Cmd.First_Element else What) & " failed."); + PP_Cmd (Cmd, "Command was: "); + Utils.Environment.Clean_Up; + GNAT.OS_Lib.OS_Exit (1); + end if; + exception + when Exc : GNATCOLL.OS.OS_Error => + PP_Cmd (Cmd, "Exception raised while running the following command:"); + if Test.Common.Verbose then + Report_Err (Ada.Exceptions.Exception_Information (Exc)); + else + Report_Err + (Ada.Exceptions.Exception_Name (Exc) & ": " + & Ada.Exceptions.Exception_Message (Exc)); + end if; + Utils.Environment.Clean_Up; + GNAT.OS_Lib.OS_Exit (1); + end Run; + + --------------------- + -- Populate_X_Vars -- + --------------------- + + procedure Populate_X_Vars + (Cmd : in out Argument_List; Gnattest_Cmd : Command_Line) + is + use Common_String_Seq_Switches; + Ext_Vars : constant String_Ref_Array := + Arg (Gnattest_Cmd, External_Variable); + begin + for Var of Ext_Vars loop + if Present (Var) then + Cmd.Append ("-X" & Var.all); + end if; + end loop; + end Populate_X_Vars; + +end Test.Subprocess; diff --git a/src/test-subprocess.ads b/src/test-subprocess.ads new file mode 100644 index 00000000..615d08bc --- /dev/null +++ b/src/test-subprocess.ads @@ -0,0 +1,54 @@ +------------------------------------------------------------------------------ +-- -- +-- Libadalang Tools -- +-- -- +-- Copyright (C) 2014-2024, AdaCore -- +-- -- +-- Libadalang Tools is free software; you can redistribute it and/or modi- -- +-- fy it under terms of the GNU General Public License as published by -- +-- the Free Software Foundation; either version 3, or (at your option) any -- +-- later version. This software is distributed in the hope that it will be -- +-- useful but WITHOUT ANY WARRANTY; without even the implied warranty of -- +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are -- +-- granted additional permissions described in the GCC Runtime Library -- +-- Exception, version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and a -- +-- copy of the GCC Runtime Library Exception along with this program; see -- +-- the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +------------------------------------------------------------------------------ + +-- This package provides utility types and subprograms to manipulate +-- GNATCOLL.OS.Subprocess commands. + +with GNATCOLL.OS.Process; use GNATCOLL.OS.Process; + +with Utils.Command_Lines; use Utils.Command_Lines; + +package Test.Subprocess is + + procedure PP_Cmd (Cmd : Argument_List; Prefix : String := ""); + -- Pretty-print Cmd on standard error + + procedure Run + (Cmd : Argument_List; + What : String := ""; + Out_To_Null : Boolean := False); + -- Run the command in Cmd. If the exit status is not zero, print an + -- error message, cleanup and exit. + -- + -- If What is not the empty string, it is used as the command name in + -- the error message. + -- + -- If Out_To_Null is True, the process standard output is redirected to + -- null. Otherwise it is forwarded. The standard error of the subprocess + -- is forwarded to Stdout or null based on Out_To_Null. + + procedure Populate_X_Vars + (Cmd : in out Argument_List; Gnattest_Cmd : Command_Line); + -- Copy all the -X arguments from Gnattest_Cmd to Cmd + +end Test.Subprocess; diff --git a/src/test-suite_min.adb b/src/test-suite_min.adb new file mode 100644 index 00000000..830ffb53 --- /dev/null +++ b/src/test-suite_min.adb @@ -0,0 +1,562 @@ +------------------------------------------------------------------------------ +-- -- +-- Libadalang Tools -- +-- -- +-- Copyright (C) 2014-2024, AdaCore -- +-- -- +-- Libadalang Tools is free software; you can redistribute it and/or modi- -- +-- fy it under terms of the GNU General Public License as published by -- +-- the Free Software Foundation; either version 3, or (at your option) any -- +-- later version. This software is distributed in the hope that it will be -- +-- useful but WITHOUT ANY WARRANTY; without even the implied warranty of -- +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are -- +-- granted additional permissions described in the GCC Runtime Library -- +-- Exception, version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and a -- +-- copy of the GCC Runtime Library Exception along with this program; see -- +-- the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +------------------------------------------------------------------------------ + +with Ada.Command_Line; use Ada.Command_Line; +with Ada.Text_IO; + +with GNAT.OS_Lib; +with GNAT.Regpat; +with GNAT.Strings; + +with Test.Command_Lines; +with Test.Mapping; use Test.Mapping; +with Test.Subprocess; use Test.Subprocess; +with Utils_Debug; use Utils_Debug; +with Utils.Environment; use Utils.Environment; +with Utils.String_Utilities; use Utils.String_Utilities; + +with TGen.JSON; use TGen.JSON; +with TGen.Strings; use TGen.Strings; + +with GNATCOLL.OS.FS; +with GNATCOLL.OS.Process; +with GNATCOLL.VFS; use GNATCOLL.VFS; + +package body Test.Suite_Min is + + Dir_Sep : Character renames + GNAT.OS_Lib.Directory_Separator; + + procedure Minimize_Unit + (Unit_Mapping : TP_Mapping; + Cov_Cmd : GNATCOLL.OS.Process.Argument_List; + Covered, Total : out Natural); + -- Minimize all the generated tests for all the procedures that have + -- at least one such test. Use Cov_Cmd as base "gnatcov coverage" command. + -- Total and Covered correspond to the number of obligations respectively + -- covered by all the traces and in total for the subprograms that have + -- generated tests in the unit. + + procedure Minimize_Subp + (Subp_Mapping : TR_Mapping; + Subp_JSON : TGen.JSON.JSON_Value; + Cov_Cmd : GNATCOLL.OS.Process.Argument_List; + Covered, Total : out Natural); + -- Minimize the generated tests for the given subprogram. These are present + -- in the Subp_JSON object. Use Cov_Cmd as base "gnatcov coverage" command. + -- Total and Covered correspond to the number of obligations respectively + -- covered by all the traces and in total for the subprogram. + + procedure Get_Cov_For_Trace + (Trace : String; + Subp_Sloc : String; + Subp_UID : String; + Cov_Cmd : GNATCOLL.OS.Process.Argument_List; + Load_Ckpt : Boolean; + Covered : out Natural; + Total : out Natural); + -- Generate a coverage report from Trace, for the subprogram for which the + -- declaration is at Subp_Sloc, and from a subprogram specific checkpoint + -- if Load_Ckpt is True. Create or overwrite the checkpoint with the new + -- coverage information in all cases. + -- + -- Cov_Cmd contains the base arguments to be used (command name, + -- project related switches, level) in the "gnatcov coverage" invocation. + -- + -- Total corresponds to the total number of obligations to be + -- covered, and Covered corresponds to the number of such obligations that + -- were covered by the trace, and the coverage data in the checkpoint. + + -------------------- + -- Minimize_Suite -- + -------------------- + + procedure Minimize_Suite (Cmd : Command_Line) is + use GNATCOLL.OS.Process; + use Test.Command_Lines.Test_String_Switches; + + Setup_Cmd : Argument_List; + Instr_Cmd : Argument_List; + Build_Cmd : Argument_List; + Run_Cmd : Argument_List; + Cov_Cmd : Argument_List; + Harness_Cmd : Argument_List; + Trace_Dir : constant String := + Tool_Temp_Dir.all & Dir_Sep & "harness_traces" & Dir_Sep; + Trace_Arr : aliased File_Array_Access; + GCVRT_Dir : constant String := + Tool_Temp_Dir.all & Dir_Sep & "gcvrt"; + GCVRT_Prj : constant String := + GCVRT_Dir & Dir_Sep & "share" & Dir_Sep & "gpr" & Dir_Sep + & "gnatcov_rts.gpr"; + Ext_Acc : GNAT.OS_Lib.String_Access := + GNAT.OS_Lib.Get_Executable_Suffix; + Ext : constant String := Ext_Acc.all; + Cov_Lev_Sw : constant String_Ref := + Arg (Cmd, Test.Command_Lines.Cov_Level); + Ret_Status : Integer; + Env : Environment_Dict; + + Real_Verbose : constant Boolean := + Test.Common.Verbose or else Debug_Flag_1 or else Debug_Flag_2; + -- -d1 can be used as a verbose switch, but which does not print other + -- harness processing information. + -- -d2 also instructs gnatcov to keep temporary files around, useful + -- to investigate crashes. + + Covered, Total : Natural := 0; + -- Resp. number of obligations covered and in total (in the subprograms + -- that have generated tests), for the whole testsuite. + begin + GNAT.OS_Lib.Free (Ext_Acc); + + -- First, setup the coverage runtime. As gnatfuzz currently setups their + -- own coverage runtime and does not work when gnatcov_rts is already in + -- the GPR_PROJECT_PATH, we can assume that there won't be a prebuilt + -- coverage runtime, and instead must install our own. + + Report_Std ("Minimizing testsuite:"); + Report_Std ("Instrument test harness for coverage"); + + -- TODO??? Remove this as soon as we figure out a plan to have this only + -- done once for both gnatfuzz and gnattest. + -- See eng/ide/libadalang-tools#144 + + Setup_Cmd.Append ("gnatcov" & Ext); + Setup_Cmd.Append ("setup"); + Setup_Cmd.Append ("--prefix=" & GCVRT_Dir); + if not Real_Verbose then + Setup_Cmd.Append ("-q"); + end if; + Run + (Setup_Cmd, + "gnatcov setup invocation", + Out_To_Null => not Real_Verbose); + + -- Then, instrument the harness project for coverage, instructing + -- gnatcov to use the manual dump/reset indications present in the + -- harness. + + Instr_Cmd.Append ("gnatcov" & Ext); + Instr_Cmd.Append ("instrument"); + Instr_Cmd.Append ("-P" & Harness_Dir_Str.all & "test_driver.gpr"); + Populate_X_Vars (Instr_Cmd, Cmd); + Instr_Cmd.Append ("--dump-trigger=manual"); + Instr_Cmd.Append ("--dump-filename-simple"); + Instr_Cmd.Append ("--runtime-project=" & GCVRT_Prj); + if not Real_Verbose then + Instr_Cmd.Append ("-q"); + end if; + + if Debug_Flag_2 then + Instr_Cmd.Append ("--save-temps"); + end if; + + -- TODO ??? Deal with Origin_Project & coverage level shenanigans later + -- + -- Origin_Project was introduced so that gnattest does not need to + -- somehow propagate the contents of the Coverage package to the + -- test_harness project. We can't use it as otherwise the manual dump + -- indication in this project are not parsed, but then gnatcov can't + -- pick up the coverage level from the project file... + -- + -- We either have to inspect the package to propagate the coverage level + -- on the command line, or modify gnatcov to disregard the + -- Origin_Project attribute when searching for manual indications. + + if Present (Cov_Lev_Sw) then + Instr_Cmd.Append ("-c" & Cov_Lev_Sw.all); + end if; + Run + (Instr_Cmd, + "Harness instrumentation", + Out_To_Null => not Real_Verbose); + + -- Build the instrumented harness + + Report_Std ("Build test harness"); + + Build_Cmd.Append ("gprbuild" & Ext); + Build_Cmd.Append ("-P" & Harness_Dir_Str.all & "test_driver.gpr"); + Populate_X_Vars (Build_Cmd, Cmd); + Build_Cmd.Append ("--src-subdirs=gnatcov-instr"); + Build_Cmd.Append ("--implicit-with=" & GCVRT_Prj); + if not Real_Verbose then + Build_Cmd.Append ("-q"); + end if; + Run + (Build_Cmd, + What => "Instrumented test harness build", + Out_To_Null => not Real_Verbose); + + Append (Trace_Arr, Create (+Trace_Dir)); + Create_Dirs (Trace_Arr); + Unchecked_Free (Trace_Arr); + + -- Run the instrumented harness. Put the traces in the Trace_Dir through + -- the env variable. Since we need to pass down some environment + -- variable we can't use our Run wrapper. + + Report_Std ("Execute testsuite"); + + Run_Cmd.Append + (Harness_Dir_Str.all & Dir_Sep & "test_runner" & Ext); + Env.Insert ("GNATCOV_TRACE_FILE", Trace_Dir); + if Real_Verbose then + PP_Cmd (Run_Cmd, "Running"); + end if; + + Ret_Status := Run + (Run_Cmd, + Stdout => + (if Real_Verbose + then GNATCOLL.OS.FS.Standout + else GNATCOLL.OS.FS.Null_FD), + Env => Env, + Inherit_Env => True); + if Ret_Status /= 0 then + Report_Err + ("Harness execution failed."); + PP_Cmd (Run_Cmd, "Command was"); + Utils.Environment.Clean_Up; + GNAT.OS_Lib.OS_Exit (1); + end if; + + Report_Std ("Remove tests based on coverage"); + + Cov_Cmd.Append ("gnatcov" & Ext); + Cov_Cmd.Append ("coverage"); + Cov_Cmd.Append ("-P" & Harness_Dir_Str.all & "test_driver.gpr"); + Populate_X_Vars (Cov_Cmd, Cmd); + Cov_Cmd.Append + ((if Present (Cov_Lev_Sw) then "-c" & Cov_Lev_Sw.all else "")); + + -- Use the report format to extract a synthetic coverage metric, as + -- parsing the XML document seems a bit overkill for what we are trying + -- to do. + + Cov_Cmd.Append ("-areport"); + Cov_Cmd.Append ("--all-messages"); + for Mapping of Test.Mapping.Mapping loop + for Unit_Mapping of Mapping.Test_Info loop + declare + Unit_Cov, Unit_Tot : Natural; + begin + Minimize_Unit (Unit_Mapping, Cov_Cmd, Unit_Cov, Unit_Tot); + Covered := Covered + Unit_Cov; + Total := Total + Unit_Tot; + end; + end loop; + end loop; + + if Real_Verbose then + Report_Std + ("Covered" & Covered'Image & " out of" & Total'Image + & " obligation" + & (if Total /= 0 + then "s (" & Image (Integer'(Covered * 100 / Total)) & "%)" + else "")); + end if; + + Report_Std ("Re-generating harness from minimized suite"); + + Harness_Cmd.Append ("gnattest" & Ext); + + -- Copy the command line of the current gnattest invocation, filtering + -- out the --gen-test-vectors and --minimize arguments. + + for J in 1 .. Argument_Count loop + declare + Sw : constant String := Argument (J); + begin + if not Has_Prefix (Sw, "--gen-test-vectors") + and then not Has_Prefix (Sw, "--minimize") + then + Harness_Cmd.Append (Sw); + end if; + end; + end loop; + Run + (Harness_Cmd, + What => "Harness re-generation", + Out_To_Null => not Real_Verbose); + end Minimize_Suite; + + ------------------- + -- Minimize_Unit -- + ------------------- + + procedure Minimize_Unit + (Unit_Mapping : TP_Mapping; + Cov_Cmd : GNATCOLL.OS.Process.Argument_List; + Covered, Total : out Natural) + is + use GNAT.Strings; + Unit_JSON : JSON_Value; + Unit_JSON_Str : GNAT.OS_Lib.String_Access; + Unit_Name : constant Ada_Qualified_Name := + To_Qualified_Name (Unit_Mapping.TP_Name.all); + Unit_Test_VF : constant Virtual_File := + Create (+(JSON_Test_Dir.all & Dir_Sep & To_JSON_filename (Unit_Name))); + Unit_Write_F : Writable_File; + Unit_Cmd : GNATCOLL.OS.Process.Argument_List := Cov_Cmd; + + begin + Covered := 0; + Total := 0; + + -- No JSON tests found for this unit, skip it + + if not Unit_Mapping.Has_Gen_Tests then + return; + end if; + + -- Load the JSON tests for the whole unit + + Unit_JSON_Str := GNATCOLL.VFS.Read_File (Unit_Test_VF); + if Unit_JSON_Str = null then + return; + end if; + + Unit_JSON := Read (Unit_JSON_Str.all, +Unit_Test_VF.Full_Name); + Free (Unit_JSON_Str); + + -- Reduce each subprogram, if it has tests + + if Test.Common.Verbose or else Debug_Flag_1 then + Report_Std ("Minimizing tests for " & To_Ada (Unit_Name)); + end if; + + Unit_Cmd.Append ("--units=" & To_Ada (Unit_Name)); + + for TR_Mapping of Unit_Mapping.TR_List loop + declare + Subp_UID : String renames TR_Mapping.TR_Hash.all; + Subp_JSON : constant JSON_Value := Unit_JSON.Get (Subp_UID); + Subp_Cov, Subp_Tot : Natural; + begin + if not Subp_JSON.Is_Empty then + + -- JSON_Value has a by-reference semantic, so the underlying + -- JSON tree will get modified. + + Minimize_Subp + (TR_Mapping, Subp_JSON, Unit_Cmd, Subp_Cov, Subp_Tot); + Covered := Covered + Subp_Cov; + Total := Total + Subp_Tot; + end if; + end; + end loop; + + -- Write back the minimized tests + + Unit_Write_F := Write_File (Unit_Test_VF); + if Unit_Write_F = Invalid_File then + Report_Err ("Warning: could not write to " & (+Unit_Test_VF.Full_Name) + & ". Tests were not minimized."); + return; + end if; + begin + Write (Unit_Write_F, Unit_JSON.Write (Compact => True)); + Close (Unit_Write_F); + exception + when Ada.Text_IO.Use_Error => + Report_Err + ("Error while writing the minimized tests in " + & (+Unit_Test_VF.Full_Name) & ":" & ASCII.LF + & (+Error_String (Unit_Write_F))); + end; + end Minimize_Unit; + + ------------------- + -- Minimize_Subp -- + ------------------- + + procedure Minimize_Subp + (Subp_Mapping : TR_Mapping; + Subp_JSON : TGen.JSON.JSON_Value; + Cov_Cmd : GNATCOLL.OS.Process.Argument_List; + Covered, Total : out Natural) + is + Trace_Dir : constant String := + Tool_Temp_Dir.all & Dir_Sep & "harness_traces" & Dir_Sep; + Subp_UID : String renames Subp_Mapping.TR_Hash.all; + Current_Trace_Idx : Natural := 0; + First_Cov : Boolean := True; + Origin_Test_Vec : constant JSON_Array := + Subp_JSON.Get ("test_vectors"); + Filtered_Tests : JSON_Array; + Subp_Sloc : constant String := + Subp_Mapping.Decl_File.all & ":" & Image (Subp_Mapping.Line); + begin + Covered := 0; + Total := 0; + + -- First get a baseline coverage from the single trace originating from + -- user written test. Those will never get minimized. + -- The trace is named .srctrace. + + declare + User_Test_Trace : constant Virtual_File := + Create (+(Trace_Dir & Dir_Sep & Subp_UID & ".srctrace")); + begin + if GNATCOLL.VFS.Is_Regular_File (User_Test_Trace) then + Get_Cov_For_Trace + (+User_Test_Trace.Full_Name, + Subp_Sloc, + Subp_UID, + Cov_Cmd, + False, + Covered, + Total); + First_Cov := False; + end if; + end; + + -- Then iterate through all the JSON tests. The strong assumption here + -- is that the traces were created in the same order as the tests are + -- present in the JSON file. This should be the case in practice as the + -- generation of the test harness simply iterates on the JSON test + -- cases, but it is a bit fragile. + -- + -- TODO??? Add single test case identifiers so that we can better track + -- duplicates and keep test-to-trace consistency. + -- + -- If there are more test cases than traces, do not remove the extra + -- test cases as they could cover more obligations. + + while Current_Trace_Idx < Length (Origin_Test_Vec) loop + declare + Trace_Name : constant Virtual_File := + Create (+(Trace_Dir & Dir_Sep & Subp_UID & "-gen-" + & Image (Current_Trace_Idx) & ".srctrace")); + Old_Covered : constant Natural := Covered; + begin + if not Is_Regular_File (Trace_Name) then + Report_Err + (Subp_Mapping.TR_Name.all & " found" + & Integer'Image (Current_Trace_Idx) & " traces but there are" + & Integer'Image (Length (Origin_Test_Vec)) & + " tests. Remaining tests will not be reduced."); + exit; + end if; + Get_Cov_For_Trace + (+Trace_Name.Full_Name, + Subp_Sloc, + Subp_UID, + Cov_Cmd, + not First_Cov, + Covered, + Total); + First_Cov := False; + + if Covered > Old_Covered then + Append + (Filtered_Tests, + Get (Origin_Test_Vec, Current_Trace_Idx + 1)); + elsif Test.Common.Verbose or else Debug_Flag_1 then + Report_Std + (Subp_Mapping.TR_Name.all & ": Removing test" + & Current_Trace_Idx'Image); + end if; + end; + Current_Trace_Idx := Current_Trace_Idx + 1; + end loop; + + -- Replace the original test vector by the filtered one + + Subp_JSON.Set_Field ("test_vectors", Filtered_Tests); + end Minimize_Subp; + + ----------------------- + -- Get_Cov_For_Trace -- + ----------------------- + + procedure Get_Cov_For_Trace + (Trace : String; + Subp_Sloc : String; + Subp_UID : String; + Cov_Cmd : GNATCOLL.OS.Process.Argument_List; + Load_Ckpt : Boolean; + Covered : out Natural; + Total : out Natural) + is + use GNATCOLL.OS.Process; + use Ada.Text_IO; + use GNAT.Regpat; + Cmd_Line : Argument_List := Cov_Cmd; + Output_Dir : constant String := + Utils.Environment.Tool_Temp_Dir.all & Dir_Sep & "cov_report"; + Output_Filename : constant String := + Output_Dir & Dir_Sep & Subp_UID & ".txt"; + Checkpoint : constant String := + Output_Dir & Dir_Sep & Subp_UID & ".ckpt"; + Output_File : File_Type; + Obligations_Regexp : constant Pattern_Matcher := + Compile + ("((?:No)|[0-9]+) coverage obligations? covered out of ([0-9]+)\."); + Suppress_Out : constant Boolean := + not (Test.Common.Verbose or else Debug_Flag_1); + begin + Total := 0; + Covered := 0; + Cmd_Line.Append ("-T" & Trace); + Cmd_Line.Append ("--output-dir=" & Output_Dir); + Cmd_Line.Append ("--output=" & Output_Filename); + Cmd_Line.Append ("--subprograms=" & Subp_Sloc); + if Load_Ckpt then + Cmd_Line.Append ("-C" & Checkpoint); + end if; + Cmd_Line.Append ("--save-checkpoint=" & Checkpoint); + Run + (Cmd_Line, + What => "Coverage report creation for " & Trace, + Out_To_Null => Suppress_Out); + Open (Output_File, In_File, Output_Filename); + while not End_Of_File (Output_File) loop + declare + Line : constant String := Get_Line (Output_File); + Matches : Match_Array (0 .. 2); + begin + Match (Obligations_Regexp, Line, Matches); + if Matches (0) /= No_Match then + if Line (1 .. 2) /= "No" then + Covered := + Covered + Natural'Value + (Line (Matches (1).First .. Matches (1).Last)); + end if; + Total := + Total + Natural'Value + (Line (Matches (2).First .. Matches (2).Last)); + end if; + end; + end loop; + Close (Output_File); + if not Suppress_Out then + Report_Std + ("Trace " & Trace & " covered " & Image (Covered) + & " obligation" & (if Covered > 1 then "s" else "")); + end if; + end Get_Cov_For_Trace; + +end Test.Suite_Min; diff --git a/src/test-suite_min.ads b/src/test-suite_min.ads new file mode 100644 index 00000000..dd823704 --- /dev/null +++ b/src/test-suite_min.ads @@ -0,0 +1,47 @@ +------------------------------------------------------------------------------ +-- -- +-- Libadalang Tools -- +-- -- +-- Copyright (C) 2014-2024, AdaCore -- +-- -- +-- Libadalang Tools is free software; you can redistribute it and/or modi- -- +-- fy it under terms of the GNU General Public License as published by -- +-- the Free Software Foundation; either version 3, or (at your option) any -- +-- later version. This software is distributed in the hope that it will be -- +-- useful but WITHOUT ANY WARRANTY; without even the implied warranty of -- +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are -- +-- granted additional permissions described in the GCC Runtime Library -- +-- Exception, version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and a -- +-- copy of the GCC Runtime Library Exception along with this program; see -- +-- the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +------------------------------------------------------------------------------ + +-- This package provides various utilities to minimize a testsuite in JSON +-- format. + +with Ada.Strings.Unbounded; use Ada.Strings.Unbounded; + +with Test.Common; use Test.Common; +with Utils.Command_Lines; use Utils.Command_Lines; + +package Test.Suite_Min is + + procedure Minimize_Suite (Cmd : Command_Line) with + Pre => Test.Common.Harness_Has_Gen_Tests; + -- Instrument, build and run the gnattest harness, in order to produce + -- coverage traces for all the subprograms which have at least one + -- generated test. + -- + -- The minimize the testsuite in the gnattest harness. This only removes + -- tests that are encoded as JSON values in the Test.Common.JSON_Test_Dir, + -- but uses the user written tests as a baseline for coverage. + -- + -- Use the support lib generation status as a proxy to indicate whether the + -- test harness is generated and contains JSON tests. + +end Test.Suite_Min; diff --git a/src/tgen/tgen-libgen.adb b/src/tgen/tgen-libgen.adb index 3ef79616..6323dde4 100644 --- a/src/tgen/tgen-libgen.adb +++ b/src/tgen/tgen-libgen.adb @@ -912,6 +912,14 @@ package body TGen.Libgen is & " (""-gnatg"", ""-gnatyN"", ""-gnatws"");"); Put_Line (Prj_File, " end case;"); Put_Line (Prj_File, " end Compiler;"); + New_Line (Prj_File); + + -- Exclude all units from coverage analysis. Only the units from the + -- user project are of interest, the rest are testing artifacts. + + Put_Line (Prj_File, " package Coverage is"); + Put_Line (Prj_File, " for Units use ();"); + Put_Line (Prj_File, " end Coverage;"); Put_Line (Prj_File, "end TGen_support;"); Close (Prj_File); end; diff --git a/testsuite/tests/test/32-basic_enum/test.out b/testsuite/tests/test/32-basic_enum/test.out index 91d07881..42d2abcb 100644 --- a/testsuite/tests/test/32-basic_enum/test.out +++ b/testsuite/tests/test/32-basic_enum/test.out @@ -127,14 +127,14 @@ pkg.ads:13:4: info: corresponding test PASSED pkg.ads:41:4: info: corresponding test PASSED pkg.ads:41:4: info: corresponding test PASSED pkg.ads:41:4: info: corresponding test PASSED -pkg.ads:13:4: error: corresponding test FAILED: Test not implemented. (pkg-test_data-tests.adb:45) -pkg.ads:23:4: error: corresponding test FAILED: Test not implemented. (pkg-test_data-tests.adb:66) -pkg.ads:27:4: error: corresponding test FAILED: Test not implemented. (pkg-test_data-tests.adb:87) -pkg.ads:31:4: error: corresponding test FAILED: Test not implemented. (pkg-test_data-tests.adb:108) -pkg.ads:36:4: error: corresponding test FAILED: Test not implemented. (pkg-test_data-tests.adb:129) -pkg.ads:41:4: error: corresponding test FAILED: Test not implemented. (pkg-test_data-tests.adb:150) -pkg.ads:47:4: error: corresponding test FAILED: Test not implemented. (pkg-test_data-tests.adb:171) -pkg.ads:58:4: error: corresponding test FAILED: Test not implemented. (pkg-test_data-tests.adb:192) -pkg.ads:64:4: error: corresponding test FAILED: Test not implemented. (pkg-test_data-tests.adb:213) -pkg.ads:70:4: error: corresponding test FAILED: Test not implemented. (pkg-test_data-tests.adb:234) +pkg.ads:13:4: error: corresponding test FAILED: Test not implemented. (pkg-test_data-tests.adb:52) +pkg.ads:23:4: error: corresponding test FAILED: Test not implemented. (pkg-test_data-tests.adb:81) +pkg.ads:27:4: error: corresponding test FAILED: Test not implemented. (pkg-test_data-tests.adb:110) +pkg.ads:31:4: error: corresponding test FAILED: Test not implemented. (pkg-test_data-tests.adb:139) +pkg.ads:36:4: error: corresponding test FAILED: Test not implemented. (pkg-test_data-tests.adb:168) +pkg.ads:41:4: error: corresponding test FAILED: Test not implemented. (pkg-test_data-tests.adb:197) +pkg.ads:47:4: error: corresponding test FAILED: Test not implemented. (pkg-test_data-tests.adb:226) +pkg.ads:58:4: error: corresponding test FAILED: Test not implemented. (pkg-test_data-tests.adb:255) +pkg.ads:64:4: error: corresponding test FAILED: Test not implemented. (pkg-test_data-tests.adb:284) +pkg.ads:70:4: error: corresponding test FAILED: Test not implemented. (pkg-test_data-tests.adb:313) 139 tests run: 129 passed; 10 failed; 0 crashed. diff --git a/testsuite/tests/test/98-long-json/test.out b/testsuite/tests/test/98-long-json/test.out index b0012c99..a8fba224 100644 --- a/testsuite/tests/test/98-long-json/test.out +++ b/testsuite/tests/test/98-long-json/test.out @@ -3,5 +3,5 @@ pkg.ads:20:4: info: corresponding test PASSED pkg.ads:20:4: info: corresponding test PASSED pkg.ads:20:4: info: corresponding test PASSED pkg.ads:20:4: info: corresponding test PASSED -pkg.ads:20:4: error: corresponding test FAILED: Test not implemented. (pkg-test_data-tests.adb:45) +pkg.ads:20:4: error: corresponding test FAILED: Test not implemented. (pkg-test_data-tests.adb:52) 6 tests run: 5 passed; 1 failed; 0 crashed. diff --git a/testsuite/tests/test/marshalling_full_private/test.out b/testsuite/tests/test/marshalling_full_private/test.out index de43398e..0769d1b1 100644 --- a/testsuite/tests/test/marshalling_full_private/test.out +++ b/testsuite/tests/test/marshalling_full_private/test.out @@ -13,7 +13,7 @@ pkg.ads:5:4: info: corresponding test PASSED pkg.ads:5:4: info: corresponding test PASSED pkg.ads:5:4: info: corresponding test PASSED pkg.ads:5:4: info: corresponding test PASSED -pkg.ads:5:4: error: corresponding test FAILED: Test not implemented. (pkg-test_data-tests.adb:45) -pkg.ads:7:4: error: corresponding test FAILED: Test not implemented. (pkg-test_data-tests.adb:66) -pkg.ads:8:4: error: corresponding test FAILED: Test not implemented. (pkg-test_data-tests.adb:87) +pkg.ads:5:4: error: corresponding test FAILED: Test not implemented. (pkg-test_data-tests.adb:52) +pkg.ads:7:4: error: corresponding test FAILED: Test not implemented. (pkg-test_data-tests.adb:81) +pkg.ads:8:4: error: corresponding test FAILED: Test not implemented. (pkg-test_data-tests.adb:110) 18 tests run: 15 passed; 3 failed; 0 crashed. diff --git a/testsuite/tests/test/tc_json_dump_no_gen/test.out b/testsuite/tests/test/tc_json_dump_no_gen/test.out index 99b8e184..fb7ac9a4 100644 --- a/testsuite/tests/test/tc_json_dump_no_gen/test.out +++ b/testsuite/tests/test/tc_json_dump_no_gen/test.out @@ -3,7 +3,7 @@ my_file.ads:72:4: info: corresponding test PASSED my_file.ads:72:4: info: corresponding test PASSED my_file.ads:86:4: info: corresponding test PASSED my_file.ads:86:4: info: corresponding test PASSED -my_file.ads:14:4: error: corresponding test FAILED: Test not implemented. (my_file-test_data-tests.adb:44) -my_file.ads:72:4: error: corresponding test FAILED: Test not implemented. (my_file-test_data-tests.adb:65) -my_file.ads:86:4: error: corresponding test FAILED: Test not implemented. (my_file-test_data-tests.adb:86) +my_file.ads:14:4: error: corresponding test FAILED: Test not implemented. (my_file-test_data-tests.adb:51) +my_file.ads:72:4: error: corresponding test FAILED: Test not implemented. (my_file-test_data-tests.adb:80) +my_file.ads:86:4: error: corresponding test FAILED: Test not implemented. (my_file-test_data-tests.adb:109) 7 tests run: 4 passed; 3 failed; 0 crashed. diff --git a/testsuite/tests/test/tc_json_dump_with_gen/test.out b/testsuite/tests/test/tc_json_dump_with_gen/test.out index 422ef15c..1ef1dbb0 100644 --- a/testsuite/tests/test/tc_json_dump_with_gen/test.out +++ b/testsuite/tests/test/tc_json_dump_with_gen/test.out @@ -18,7 +18,7 @@ my_file.ads:86:4: info: corresponding test PASSED my_file.ads:86:4: info: corresponding test PASSED my_file.ads:86:4: info: corresponding test PASSED my_file.ads:86:4: info: corresponding test PASSED -my_file.ads:14:4: error: corresponding test FAILED: Test not implemented. (my_file-test_data-tests.adb:45) -my_file.ads:72:4: error: corresponding test FAILED: Test not implemented. (my_file-test_data-tests.adb:66) -my_file.ads:86:4: error: corresponding test FAILED: Test not implemented. (my_file-test_data-tests.adb:87) +my_file.ads:14:4: error: corresponding test FAILED: Test not implemented. (my_file-test_data-tests.adb:52) +my_file.ads:72:4: error: corresponding test FAILED: Test not implemented. (my_file-test_data-tests.adb:81) +my_file.ads:86:4: error: corresponding test FAILED: Test not implemented. (my_file-test_data-tests.adb:110) 22 tests run: 19 passed; 3 failed; 0 crashed. diff --git a/testsuite/tests/test/tgen_diagnostics/test.out b/testsuite/tests/test/tgen_diagnostics/test.out index 4d2731be..27531596 100644 --- a/testsuite/tests/test/tgen_diagnostics/test.out +++ b/testsuite/tests/test/tgen_diagnostics/test.out @@ -24,10 +24,10 @@ pkg.ads:36:4: info: corresponding test PASSED pkg.ads:36:4: info: corresponding test PASSED pkg.ads:36:4: info: corresponding test PASSED pkg.ads:36:4: info: corresponding test PASSED -pkg.ads:24:4: error: corresponding test FAILED: Test not implemented. (pkg-test_data-tests.adb:45) -pkg.ads:27:4: error: corresponding test FAILED: Test not implemented. (pkg-test_data-tests.adb:66) -pkg.ads:29:4: error: corresponding test FAILED: Test not implemented. (pkg-test_data-tests.adb:87) -pkg.ads:31:4: error: corresponding test FAILED: Test not implemented. (pkg-test_data-tests.adb:108) -pkg.ads:33:4: error: corresponding test FAILED: Test not implemented. (pkg-test_data-tests.adb:129) -pkg.ads:36:4: error: corresponding test FAILED: Test not implemented. (pkg-test_data-tests.adb:150) +pkg.ads:24:4: error: corresponding test FAILED: Test not implemented. (pkg-test_data-tests.adb:52) +pkg.ads:27:4: error: corresponding test FAILED: Test not implemented. (pkg-test_data-tests.adb:81) +pkg.ads:29:4: error: corresponding test FAILED: Test not implemented. (pkg-test_data-tests.adb:110) +pkg.ads:31:4: error: corresponding test FAILED: Test not implemented. (pkg-test_data-tests.adb:139) +pkg.ads:33:4: error: corresponding test FAILED: Test not implemented. (pkg-test_data-tests.adb:168) +pkg.ads:36:4: error: corresponding test FAILED: Test not implemented. (pkg-test_data-tests.adb:197) 11 tests run: 5 passed; 6 failed; 0 crashed. diff --git a/testsuite/tests/test/tgen_globals/test.out b/testsuite/tests/test/tgen_globals/test.out index 87a0beb4..26f7006a 100644 --- a/testsuite/tests/test/tgen_globals/test.out +++ b/testsuite/tests/test/tgen_globals/test.out @@ -58,10 +58,10 @@ pkg.ads:16:4: info: corresponding test PASSED pkg.ads:16:4: info: corresponding test PASSED pkg.ads:16:4: info: corresponding test PASSED pkg.ads:16:4: info: corresponding test PASSED -pkg.ads:12:4: error: corresponding test FAILED: Test not implemented. (pkg-test_data-tests.adb:45) -pkg.ads:14:4: error: corresponding test FAILED: Test not implemented. (pkg-test_data-tests.adb:66) -pkg.ads:16:4: error: corresponding test FAILED: Test not implemented. (pkg-test_data-tests.adb:87) -pkg.ads:18:4: error: corresponding test FAILED: Test not implemented. (pkg-test_data-tests.adb:108) -pkg.ads:21:4: error: corresponding test FAILED: Test not implemented. (pkg-test_data-tests.adb:129) -pkg.ads:24:4: error: corresponding test FAILED: Test not implemented. (pkg-test_data-tests.adb:150) +pkg.ads:12:4: error: corresponding test FAILED: Test not implemented. (pkg-test_data-tests.adb:52) +pkg.ads:14:4: error: corresponding test FAILED: Test not implemented. (pkg-test_data-tests.adb:81) +pkg.ads:16:4: error: corresponding test FAILED: Test not implemented. (pkg-test_data-tests.adb:110) +pkg.ads:18:4: error: corresponding test FAILED: Test not implemented. (pkg-test_data-tests.adb:139) +pkg.ads:21:4: error: corresponding test FAILED: Test not implemented. (pkg-test_data-tests.adb:168) +pkg.ads:24:4: error: corresponding test FAILED: Test not implemented. (pkg-test_data-tests.adb:197) 41 tests run: 35 passed; 6 failed; 0 crashed. diff --git a/testsuite/tests/test/uninit_str_marshalling/test.out b/testsuite/tests/test/uninit_str_marshalling/test.out index c7154dca..1b453cd6 100644 --- a/testsuite/tests/test/uninit_str_marshalling/test.out +++ b/testsuite/tests/test/uninit_str_marshalling/test.out @@ -1,5 +1,5 @@ Units remaining: 2 Units remaining: 1 my_file.ads:3:4: info: corresponding test PASSED my_file.ads:3:4: info: corresponding test PASSED -my_file.ads:3:4: error: corresponding test FAILED: Test not implemented. (my_file-test_data-tests.adb:44) +my_file.ads:3:4: error: corresponding test FAILED: Test not implemented. (my_file-test_data-tests.adb:51) 3 tests run: 2 passed; 1 failed; 0 crashed.