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