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
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
|
------------------------------------------------------------------------------
-- --
-- GCH COMPONENTS --
-- --
-- G C H . SOURCE_CHECK --
-- --
-- B o d y --
-- --
-- Copyright (c) 1999, Vitali Sh.Kaufman. --
-- --
-- Gch is distributed as free software; that is with full sources --
-- and 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. You can freely copy, modify and redistribute --
-- this software, provided that full sources are available for the version --
-- being distribute (original and modified), and for a modified version, --
-- any changes that you have made are clearly indicated. --
-- --
-- Gch was developed by Vitali Sh. Kaufman using a prototype --
-- and consultations by Sergey I. Rybin. --
------------------------------------------------------------------------------
-- This package implements all the high-level actions needed to check a
-- single source file in an ASIS Context
with Ada.Text_IO; use Ada.Text_IO;
with Ada.Wide_Text_IO;
with Ada.Characters.Handling; use Ada.Characters.Handling;
with Ada.Exceptions; use Ada.Exceptions;
with GNAT.OS_Lib; use GNAT.OS_Lib;
with Asis; use Asis;
with Asis.Implementation;
with Asis.Ada_Environments; use Asis.Ada_Environments;
with Asis.Compilation_Units; use Asis.Compilation_Units;
with Gch.Options; use Gch.Options;
with Gch.Init; use Gch.Init;
with Gch.Globals; use Gch.Globals;
with Gch.Output; use Gch.Output;
with Gch.Unit_Checker;
package body Gch.Source_Check is
-- VK### to debug only
package Boolean_IO is new Ada.Text_IO.Enumeration_IO (Boolean);
use Boolean_IO;
-----------------------
-- Local subprograms --
-----------------------
function Short_File_Name (File_Name : String) return String;
-- If File_Name contains directory information, this function
-- cuts this information out and returns a short file name, otherwise
-- it returns its argument
function Short_File_To_Unit_Name (File_Name : String) return String;
-- Taking the short name of the source file, this function returns the
-- full expanded Ada name of the corresponding Ada compilation unit.
-- This function supposes, that File_Name follows the GNAT file name
-- conventions with no krunching.
-- ??? The two functions above look to be of general interest for GNAT
-- tools built on top of ASIS-for-GNAT (see for example the gnatstub code)
-- Should we move them into some "library" ???
-----------------
-- Check_Rules --
-----------------
procedure Check_Rules
(Checking_File_Name : String;
Tree_Name : String_Access;
Success : in out Boolean;
Needs_Object : out Boolean)
is
Unit_To_Check : Asis.Compilation_Unit;
Unit_To_Check_Class : Asis.Unit_Classes;
Unit_Name : String_Access;
Is_Spec : Boolean;
begin
Unit_Name := new String' (Short_File_To_Unit_Name (Tree_Name.all));
Is_Spec := Checking_File_Name (Checking_File_Name'Last) = 's'; -- ???
if Is_Spec then
Unit_To_Check := Asis.Compilation_Units.Library_Unit_Declaration
(To_Wide_String (Unit_Name.all), Checking_Context);
else
Unit_To_Check := Asis.Compilation_Units.Compilation_Unit_Body
(To_Wide_String (Unit_Name.all), Checking_Context);
end if;
if Asis.Compilation_Units.Exists (Unit_To_Check) then
Reset_Unit_Statistics;
Success := True; -- ???
if Verbose_Mode or else
(not Gnat_Mode and then not Verbose_Mode)
then
New_Line;
Put (">>> Checking rules for " &
Checking_File_Name & "<<<");
end if;
Gch.Unit_Checker.Unit_Checker (Unit_To_Check, Success); -- ???
-- ??? do we need Success as a parameter of Unit_Checker ???
Update_Global_Statistics;
if Errors_Per_Unit > 0 then -- ###VK what about warnings ?
Success := False;
end if;
if not (Errors_Per_Unit = 0 and Warnings_Per_Unit = 0) then
Not_Passed_Units := Not_Passed_Units + 1;
Output_Diagnostics (Checking_File_Name);
if not Gnat_Mode and then
Verbose_Mode
then
Output_Statistics;
end if;
else
Passed_Units := Passed_Units + 1;
end if;
if Verbose_Mode or else
(not Gnat_Mode and then not Verbose_Mode)
then
New_Line;
Put (">>> End of Checking rules for "
& Checking_File_Name & "<<<");
New_Line;
end if;
else
if not Hide_Rejected_Files or else Verbose_Mode then
New_Line;
Put ("Gch: can't check ");
Put (Checking_File_Name);
Put_Line ("; may be naming of the file is not acceptable");
Put_Line ("or it is not a legal Ada source");
end if;
Success := False;
Needs_Object := False;
Rejected_Units := Rejected_Units + 1;
end if;
if Success then
Unit_To_Check_Class :=
Asis.Compilation_Units.Unit_Class (Unit_To_Check);
if Unit_To_Check_Class = A_Separate_Body
or else
((Unit_To_Check_Class = A_Public_Declaration or else
Unit_To_Check_Class = A_Private_Declaration)
and then
Asis.Compilation_Units.Is_Body_Required (Unit_To_Check))
then
Needs_Object := False;
else
Needs_Object := True;
end if;
else
Needs_Object := False;
end if;
exception
when Ex: others =>
-- just in case
Success := False;
Needs_Object := False;
if not Hide_Rejected_Files or else Verbose_Mode then
New_Line;
Put ("Gch: can't check ");
Put (Checking_File_Name);
Put ("; ");
Put (Exception_Name (Ex));
Put (" was raised ");
Put_Line (Exception_Message (Ex));
end if;
Rejected_Units := Rejected_Units + 1;
end Check_Rules;
------------------
-- Check_Source --
------------------
procedure Check_Source (Source_File : File_Id) is
Success : Boolean;
Needs_Object : Boolean;
Execute : String_Access :=
GNAT.OS_Lib.Locate_Exec_On_Path (Gcc);
Checking_File_Name : String := Sources (Source_File).File_Name.all;
Tree_Name : String_Access := new String'
(Short_File_Name (Checking_File_Name));
begin
Total_Units := Total_Units + 1;
-- check if the checking file name has a correct extension
-- this should be change for a newest compiler version
if not (Tree_Name.all (Tree_Name'Last - 3 .. Tree_Name'Last) = ".adb" or else
Tree_Name.all (Tree_Name'Last - 3 .. Tree_Name'Last) = ".ads")
then
return;
end if;
if False then
-- ###VK the commented version serves a new compiler version (24.4.99)
-- Tree_Name (Tree_Name'Last) := 't';
Tree_Name (Tree_Name'Last - 1) := 't';
else
-- TQ: As of 3.11p the /new/ behaviour is correct. (1999-09-14)
-- ... but Vitali's comments cannot be changed due to
-- a bug in dpkg-source.
Tree_Name (Tree_Name'Last) := 't';
end if;
Check_Rules (Checking_File_Name, Tree_Name, Success, Needs_Object);
Clean_Tree (Tree_Name);
if Success and then Create_Object and then Needs_Object then
-- Creating an object file:
Create_Obj_Args (Create_Obj_Args'Last) :=
Sources (Source_File).File_Name;
GNAT.OS_Lib.Spawn (Execute.all, Create_Obj_Args.all, Success);
end if;
exception
when others =>
-- just in case
Success := False;
Needs_Object := False;
if not Hide_Rejected_Files or else Verbose_Mode then
New_Line;
Put ("Gch: GNAT fails to build a tree for source file ");
Put (Checking_File_Name);
Put ("; not a legal Ada source");
Put_Line (" or withed files are out");
end if;
Rejected_Units := Rejected_Units + 1;
Clean_Tree (Tree_Name);
end Check_Source;
---------------------
-- Short_File_Name --
---------------------
function Short_File_Name (File_Name : String) return String is
Res_Start : Positive := File_Name'First;
begin
for I in reverse File_Name'Range loop
if File_Name (I) = '/' or else
File_Name (I) = '\'
then
Res_Start := I;
exit;
end if;
end loop;
return File_Name (Res_Start .. File_Name'Last);
end Short_File_Name;
-----------------------------
-- Short_File_To_Unit_Name --
-----------------------------
function Short_File_To_Unit_Name (File_Name : String) return String is
Result : String (1 .. File_Name'Length - 4) :=
File_Name (File_Name'First .. File_Name'Last - 4);
-- ??? We are under the GNAT file name conventions!
-- "-4" means ".a[d|t][b|s]"
begin
for I in Result'Range loop
if Result (I) = '-' then
Result (I) := '.';
end if;
end loop;
return Result;
end Short_File_To_Unit_Name;
end Gch.Source_Check;
|
