------------------------------------------------------------------------------ -- -- -- Libadalang Tools -- -- -- -- Copyright (C) 2015-2023, 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 -- -- . -- ------------------------------------------------------------------------------ pragma Ada_2012; with Ada.Containers.Doubly_Linked_Lists; with Ada.Containers.Indefinite_Ordered_Maps; with GNAT.OS_Lib; use GNAT.OS_Lib; package Test.Mapping is ------------------- -- Tests mapping -- ------------------- type Test_Case_Origin_Type is (Test_Case_Pragma, Test_Case_Generated, Gnattest_Generated); -- GNATtest generates test cases in 3 different ways: -- -- * The subprogram under test has one or several Test_Case pragma(s) -- specifying the test name and other adequate information. In that -- specific case, the origin is Test_Case_Pragma. -- -- * If it does not, GNATtest generates a single test case for the SuT, -- in which case the test case origin is Gnattest_Generated. -- -- * Tools (such as GNATfuzz, or TGen) can also automatically generate -- test case values, that GNATtest then integrates in the testing -- campaign. In that case, the test case origin is -- Test_Case_Generated. type TC_Mapping is record Origin : Test_Case_Origin_Type; TC_Name : String_Access; -- Name of the test case, as specified per the Test_Case.Name attribute Line : Natural; Column : Natural; -- Sloc for the test case pragma Test : String_Access; -- Name of the file holding the test case Test_Time : String_Access; -- Timestamp for the test case T_Name : String_Access; -- Name of the test routine (generated by gnattest) TR_Line : Natural; -- Line number for the generated test routine in the gnattest harness end record; -- Stores info on individual test cases of subprogram under test. package TC_Mapping_List is new Ada.Containers.Doubly_Linked_Lists (TC_Mapping); use TC_Mapping_List; type TR_Mapping is record TR_Name : String_Access; -- Name of subprogram under test. Line : Natural; Column : Natural; -- Sloc for the subprogram under test TC_List : TC_Mapping_List.List; -- List of testcases holding the information above, if there are -- several. Decl_Line : Natural; -- Unlike Line, that is pointing to name of the tested routine, -- 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. end record; -- Stores info on individual subprogram under test and collection of -- corresponding test cases (if any). package TR_Mapping_List is new Ada.Containers.Doubly_Linked_Lists (TR_Mapping); use TR_Mapping_List; type DT_Mapping is record File : String_Access; Line : Natural; Column : Natural; end record; -- Stores info on individual dangling test. package DT_Mapping_List is new Ada.Containers.Doubly_Linked_Lists (DT_Mapping); use DT_Mapping_List; type TP_Mapping is record TP_Name : String_Access; -- Name of the tested package SetUp_Name : String_Access; SetUp_Line : Natural; SetUp_Column : Natural; TearDown_Name : String_Access; TearDown_Line : Natural; TearDown_Column : Natural; TR_List : TR_Mapping_List.List; DT_List : DT_Mapping_List.List; end record; -- Stores info on individual test package, all it's test routines and -- dangling tests. package TP_Mapping_List is new Ada.Containers.Doubly_Linked_Lists (TP_Mapping); use TP_Mapping_List; ------------------- -- Stubs mapping -- ------------------- type Entity_Sloc is record Line : Natural; Column : Natural; end record; -- Sloc info Nil_Entity_Sloc : constant Entity_Sloc := (0, 0); package ES_List is new Ada.Containers.Doubly_Linked_Lists (Entity_Sloc); use ES_List; type Entity_Stub_Mapping is record Name : String_Access; Line : Natural; Column : Natural; Stub_Body : Entity_Sloc; Setter : Entity_Sloc; end record; -- Mapping info of entity from stubbed unit. function "=" (L, R : Entity_Stub_Mapping) return Boolean is (L.Name.all = R.Name.all and then L.Line = R.Line and then L.Column = R.Column); package Entity_Stub_Mapping_List is new Ada.Containers.Doubly_Linked_Lists (Entity_Stub_Mapping); use Entity_Stub_Mapping_List; type Stub_Unit_Mapping is record Stub_Data_File_Name : String_Access; Orig_Body_File_Name : String_Access; Stub_Body_File_Name : String_Access; Entities : Entity_Stub_Mapping_List.List; D_Setters : ES_List.List; D_Bodies : ES_List.List; end record; -- Mapping info for a whole stubbed unit. Nil_Stub_Unit_Mapping : constant Stub_Unit_Mapping := (null, null, null, Entity_Stub_Mapping_List.Empty_List, ES_List.Empty_List, ES_List.Empty_List); procedure Clone (From : Stub_Unit_Mapping; To : in out Stub_Unit_Mapping); ------------------------ -- User Tests Mapping -- ------------------------ type User_Test_Package is record Name : String_Access; Type_Name : String_Access; Type_Sloc : Entity_Sloc := Nil_Entity_Sloc; SetUp_Sloc : Entity_Sloc := Nil_Entity_Sloc; TearDown_Sloc : Entity_Sloc := Nil_Entity_Sloc; TR_List : TR_Mapping_List.List := TR_Mapping_List.Empty_List; end record; package UTP_Mapping_List is new Ada.Containers.Doubly_Linked_Lists (User_Test_Package); use UTP_Mapping_List; type Mapping_Type is record Test_Info : TP_Mapping_List.List := TP_Mapping_List.Empty_List; Stub_Info : Stub_Unit_Mapping := Nil_Stub_Unit_Mapping; end record; package SP_Mapping is new Ada.Containers.Indefinite_Ordered_Maps (String, Mapping_Type); use SP_Mapping; Mapping : SP_Mapping.Map; Additional_Mapping : UTP_Mapping_List.List := UTP_Mapping_List.Empty_List; procedure Add_Test_List (Name : String; List : TP_Mapping_List.List); procedure Add_Stub_List (Name : String; Info : Stub_Unit_Mapping); -- Add test/stub mapping info for given unit. function New_Line_Counter return Natural; -- Returns current value of the counter procedure Reset_Line_Counter; -- Resets the counter to 1. procedure New_Line_Count; -- Wrapper that increases the counter of new lines in generated package. procedure Generate_Mapping_File; -- Creates a mapping file for tested suprograms and tests. procedure Generate_Set_Active_For_Filter; -- Generates set of IF statements for -- Gnattest_Generated..Mapping.Set_From_SLOC. procedure Generate_Is_Active_For_Filter; -- Generates set of IF statements for -- Gnattest_Generated..Mapping.Is_Active. end Test.Mapping;