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.