1------------------------------------------------------------------------------ 2-- -- 3-- GNATTEST COMPONENTS -- 4-- -- 5-- G N A T T E S T . C O M M O N -- 6-- -- 7-- S p e c -- 8-- -- 9-- Copyright (C) 2011-2016, AdaCore -- 10-- -- 11-- GNATTEST is free software; you can redistribute it and/or modify it -- 12-- under terms of the GNU General Public License as published by the Free -- 13-- Software Foundation; either version 2, or (at your option) any later -- 14-- version. GNATTEST is distributed in the hope that it will be useful, -- 15-- but WITHOUT ANY WARRANTY; without even the implied warranty of -- 16-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General -- 17-- Public License for more details. You should have received a copy of the -- 18-- GNU General Public License distributed with GNAT; see file COPYING. If -- 19-- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- 20-- Floor, Boston, MA 02110-1301, USA., -- 21-- -- 22-- GNATTEST is maintained by AdaCore (http://www.adacore.com). -- 23-- -- 24------------------------------------------------------------------------------ 25 26-- This package contains some general-purpose entities that are used by many 27-- GNATtest components 28 29pragma Ada_2012; 30 31with Asis; 32with Asis.Text; use Asis.Text; 33with Asis.Elements; use Asis.Elements; 34 35with Ada.Exceptions; use Ada.Exceptions; 36with GNAT.OS_Lib; use GNAT.OS_Lib; 37with Ada.Sequential_IO; 38 39with GNATCOLL.Projects; 40with GNATCOLL.VFS; use GNATCOLL.VFS; 41 42with Ada.Containers.Indefinite_Doubly_Linked_Lists; 43with Ada.Containers.Doubly_Linked_Lists; 44with Ada.Containers.Indefinite_Ordered_Sets; 45with Ada.Containers.Indefinite_Ordered_Maps; 46 47package GNATtest.Common is 48 49 procedure Report_Err (Message : String); 50 -- Prints it's argument to the standard error output 51 52 procedure Report_AUnit_Usage; 53 -- Shows a message about AUnit being among the source files 54 55 procedure Report_Std (Message : String; Offset : Integer := 0); 56 -- Prints it's argument to the standard output with Offset spaces before. 57 58 procedure Report_Unhandled_ASIS_Exception (Ex : Exception_Occurrence); 59 -- Reports an unhandled ASIS exception 60 61 procedure Report_Unhandled_Exception (Ex : Exception_Occurrence); 62 -- Reports an unhandled non-ASIS exception 63 64 procedure Generate_Common_File; 65 -- Creates a file with package gnattest_generated which denotes the default 66 -- skeletons behavior and declares renamins necessary to avoid name 67 -- conflicts with tested sources. 68 69 function Get_Subp_Name (Subp : Asis.Element) return String; 70 -- if Subp is a subprigram declaration it will return subprogram's name; 71 -- if Subp is an overloaded operator - it's text name 72 73 Source_Project_Tree : GNATCOLL.Projects.Project_Tree; 74 -- Source project file name. Used for extraction of source files and 75 -- paths for compiler. 76 77 The_Context : Asis.Context; 78 -- The Context for all the processing. May be associated, opened, closed 79 -- and dissociated several times during one tool run. 80 81 Fatal_Error : exception; 82 83 Tmp_Test_Prj : String_Access := null; 84 85 package Char_Sequential_IO is new Ada.Sequential_IO (Character); 86 Output_File : Char_Sequential_IO.File_Type; 87 88 procedure Create_Dirs (Target_Dirs : File_Array_Access); 89 -- Creates given directories. 90 91 procedure S_Put (Span : Natural; Text : String); 92 -- Adds Span number spaces before the Text and prints it to Output_File 93 94 procedure Create (Name : String); 95 procedure Close_File; 96 -- Wrappers for creating and closing output files. 97 98 procedure Put_New_Line; 99 -- Puts a unix-style terminator to the Output_File disregard from the 100 -- current actual platform. 101 102 function Unit_To_File_Name (Old : String) return String; 103 -- Replaces dots with "-" and lowers the case of the letters. 104 105 package List_Of_Strings is new 106 Ada.Containers.Indefinite_Doubly_Linked_Lists (String); 107 use List_Of_Strings; 108 109 package Asis_Element_List is new 110 Ada.Containers.Doubly_Linked_Lists (Asis.Element, Is_Equal); 111 use Asis_Element_List; 112 113 package String_Set is new 114 Ada.Containers.Indefinite_Ordered_Sets (String); 115 use String_Set; 116 117 package String_To_String_Map is new 118 Ada.Containers.Indefinite_Ordered_Maps (String, String); 119 use String_To_String_Map; 120 121 -------------------- 122 -- Stub exclusion -- 123 -------------------- 124 125 Default_Stub_Exclusion_List : String_Set.Set := 126 String_Set.Empty_Set; 127 package String_To_String_Set is new 128 Ada.Containers.Indefinite_Ordered_Maps (String, String_Set.Set); 129 use String_To_String_Set; 130 Stub_Exclusion_Lists : String_To_String_Set.Map := 131 String_To_String_Set.Empty_Map; 132 133 procedure Store_Default_Excluded_Stub (Excluded : String); 134 -- Store data on units that should not be stubbed for all UUTs. 135 procedure Store_Excluded_Stub (Source : String; Excluded : String); 136 -- Store data on units that should not be stubbed for given UUT. 137 138 function Get_Next_Infix return String; 139 -- Returns a numbered infix ("1_", "2_",..), increasing the number for 140 -- each call. 141 142 Inherited_Switches : List_Of_Strings.List; 143 144 Excluded_Test_Package_Bodies : String_Set.Set; 145 Excluded_Test_Data_Files : String_Set.Set; 146 147 function Get_Nesting (Elem : Asis.Element) return String; 148 -- Returns the full package & protected prefix if the element. 149 150 function Parent_Type_Declaration 151 (Type_Dec : Asis.Element) return Asis.Element; 152 -- Returns a corresponding parent type declaration for a given tagged type 153 -- extension declaration. 154 155 function First_Column_Number (Element : Asis.Element) return Line_Number; 156 -- Returns the number on the first column of the first line of the element. 157 158 procedure Put_Harness_Header; 159 160 function Mangle_Hash_Full 161 (Subp : Asis.Declaration; 162 Case_Sensitive : Boolean := False; 163 N_Controlling : Boolean := False; 164 For_Stubs : Boolean := False) 165 return String; 166 -- Returns full hash for given subprogram. 167 168 function To_String_First_Name (Elem : Asis.Element) return String; 169 170 function Substring_16 (S : String) return String is 171 (S (S'First .. S'First + 15)); 172 function Substring_6 (S : String) return String is 173 (S (S'First .. S'First + 5)); 174 175 function "<" (Left, Right : Asis.Element) return Boolean; 176 177 ------------------------ 178 -- String constants -- 179 ------------------------ 180 181 Test_Routine_Prefix : constant String := "Test_"; 182 -- Prefix to each test routine 183 184 Wrapper_Prefix : constant String := "Wrap_"; 185 186 Stub_Type_Prefix : constant String := "Stub_Data_Type_"; 187 188 Stub_Object_Prefix : constant String := "Stub_Data_"; 189 190 Setter_Prefix : constant String := "Set_Stub_"; 191 192 Stub_Result_Suffix : constant String := "_Result"; 193 194 Stub_Counter_Var : constant String := "Stub_Counter"; 195 196 Test_Unit_Name : constant String := "Tests"; 197 -- Name of test child package for non-primitive tests. 198 199 Test_Unit_Name_Suff : constant String := "_Tests"; 200 -- Suffix for test packages that correspond to tagged record types. 201 202 Gen_Test_Unit_Name : constant String := "Gen_Tests"; 203 -- Name of generic test child package for non-primitive tests. 204 205 Gen_Test_Unit_Name_Suff : constant String := "_Gen_Tests"; 206 -- Suffix for generic test packages that correspond to tagged record types. 207 208 Inst_Test_Unit_Name : constant String := "Inst_Tests"; 209 -- Name of instatiation test child package. 210 211 Test_Prj_Prefix : constant String := "test_"; 212 -- Prefix of the output project file name. 213 214 Test_Data_Unit_Name : constant String := "Test_Data"; 215 216 Test_Data_Unit_Name_Suff : constant String := "_Test_Data"; 217 218 Stub_Data_Unit_Name : constant String := "Stub_Data"; 219 220 Stub_Project_Prefix : constant String := "Stub_"; 221 222 TD_Prefix : constant String := "Driver_"; 223 TD_Prefix_Overriden : constant String := "VTE_Driver_"; 224 225 Hash_Version : constant String := "2.2"; 226 227 GT_Marker_Begin : constant String := "-- begin read only"; 228 GT_Marker_End : constant String := "-- end read only"; 229 230end GNATtest.Common; 231