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
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
|
------------------------------------------------------------------------------
-- --
-- GNATCHECK COMPONENTS --
-- --
-- G N A T C H E C K . P R O J E C T S --
-- --
-- B o d y --
-- --
-- Copyright (C) 2013-2014, AdaCore --
-- --
-- GNATCHECK 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 3, or ( at your option) any later --
-- version. GNATCHECK 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 COPYING3. If --
-- not, go to http://www.gnu.org/licenses for a complete copy of the --
-- license. --
-- --
-- GNATCHECK is maintained by AdaCore (http://www.adacore.com). --
-- --
------------------------------------------------------------------------------
pragma Ada_2012;
with Ada.Strings.Fixed;
with GNAT.OS_Lib; use GNAT.OS_Lib;
with ASIS_UL.Common; use ASIS_UL.Common;
with ASIS_UL.Compiler_Options;
with ASIS_UL.Environment; use ASIS_UL.Environment;
with ASIS_UL.Options; use ASIS_UL.Options;
with ASIS_UL.Output; use ASIS_UL.Output;
with Gnatcheck.Categories;
with Gnatcheck.Diagnoses_Old;
with Gnatcheck.Options; use Gnatcheck.Options;
with Gnatcheck.Output; use Gnatcheck.Output;
with Gnatcheck.Rules.Rule_Table; use Gnatcheck.Rules.Rule_Table;
package body Gnatcheck.Projects is
----------------------
-- Print_Tool_Usage --
----------------------
procedure Print_Tool_Usage (My_Project : Gnatcheck_Project_Type) is
pragma Unreferenced (My_Project);
begin
Gnatcheck.Output.Print_Gnatcheck_Usage;
end Print_Tool_Usage;
--------------------
-- Scan_Arguments --
--------------------
overriding procedure Scan_Arguments
(My_Project : in out Gnatcheck_Project_Type;
First_Pass : Boolean := False;
Parser : Opt_Parser := Command_Line_Parser;
In_Switches : Boolean := False)
is
In_Project_File : constant Boolean := Parser /= Command_Line_Parser;
Initial_Char : Character;
Common_Arg : Common_Arg_Status;
Success : Boolean;
function Get_Coding_Standard_Kind
(Par : String)
return Coding_Standard_Kinds;
-- Computes the coding standard kind from its Parameter. If the
-- Parametervalue does not correspond to any coding standard kinds,
-- generates the corresponding diagnosis and daises Fatal_Error
function Get_Coding_Standard_Kind
(Par : String)
return Coding_Standard_Kinds
is
Result : Coding_Standard_Kinds;
begin
Result := Coding_Standard_Kinds'Value (Par);
if Result = Not_A_Coding_Standard then
raise Constraint_Error;
end if;
return Result;
exception
when Constraint_Error =>
Error ("unknown coding standard kind specified");
raise Fatal_Error;
end Get_Coding_Standard_Kind;
procedure Process_Sections;
-- Processes option sections. At the moment we have two such sections -
-- 'cargs' for compiler arguments and 'rules' for switching rules ON and
-- OFF and changing the rule status to feature detection.
procedure Process_Sections is
begin
ASIS_UL.Compiler_Options.Process_cargs_Section (Parser => Parser);
-- Processing the 'rules' section
Goto_Section ("rules", Parser => Parser);
loop
case GNAT.Command_Line.Getopt ("* from=", Parser => Parser) is
-- We do not want to depend on the set of the currently
-- implemented rules
when ASCII.NUL =>
exit;
when 'f' =>
Process_Rule_File (Parameter (Parser => Parser));
if not More_Then_One_Rule_File_Set then
Rule_File_Name :=
new String'(Parameter (Parser => Parser));
More_Then_One_Rule_File_Set := True;
else
Free (Rule_File_Name);
end if;
when others =>
Process_Rule_Option
(Ada.Strings.Fixed.Trim
(Full_Switch (Parser => Parser), Ada.Strings.Both));
-- We use the call to Trim here because there can be a rule
-- option in quotation marks
Individual_Rules_Set := True;
end case;
end loop;
end Process_Sections;
-- Start of processing for Scan_Arguments
begin
loop
Initial_Char :=
GNAT.Command_Line.Getopt
("v q t h hc? hx s? " &
"l m? files= a " &
"P: U X! vP! eL " & -- project-specific options
"-subdirs= " &
"-no_objects_dir " &
"j! " &
"d? " & -- debug mode/options
Incremental_Switches &
"o= " & -- See Scan_Common_Arg
"I: " &
"-RTS= " &
"log " &
"-include-file= " & -- specify user-defined
-- part of the report file
"-old-report-format " & -- generate report file
-- using the old format
"-no-column " &
"-exemption " & -- rule exemption ON
"-show-rule " & -- show rule name in diagnosis
"-version -help " & -- print version and usage
"-test " & -- test mode (all rules ON)
"o= " &
"-write-rules= " & -- template rule file name
-- "-dump-code-standard= " & -- coding standard type
"gnat05", -- Ada 2005 mode
Parser => Parser);
Common_Arg := Scan_Common_Arg
(My_Project, First_Pass, Parser, In_Switches,
In_Project_File, Initial_Char);
case Common_Arg is
when Arg_Processed => goto Continue; -- Dealt with above
when Arg_Not_Processed => null; -- Deal with it in 'case' below
when Quit => return; -- Ignore all other args
end case;
case Initial_Char is
when ASCII.NUL =>
exit when not
More_Arguments
(Store_Arguments => In_Project_File or else First_Pass,
In_Switches => In_Switches);
when 'a' =>
if not First_Pass then
if Full_Switch (Parser => Parser) = "a" then
Process_RTL_Units := True;
end if;
end if;
when 'e' =>
if Full_Switch (Parser => Parser) = "eL" then
if First_Pass then
ASIS_UL.Projects.Follow_Symbolic_Links := True;
elsif In_Project_File then
Error ("-eL option cannot be set in a project file");
raise Parameter_Error;
end if;
end if;
when 'h' =>
if not First_Pass then
if Full_Switch (Parser => Parser) = "h" then
Generate_Rules_Help := True;
elsif Full_Switch (Parser => Parser) = "hc" then
Generate_Category_Help := True;
Gnatcheck.Categories.Process_Category_Help_Parameter
(Parameter (Parser => Parser), Success);
if not Success then
raise Parameter_Error;
end if;
elsif Full_Switch (Parser => Parser) = "hx" then
Generate_XML_Help := True;
end if;
end if;
when 'g' =>
null;
pragma Assert (Full_Switch (Parser => Parser) = "gnat05");
-- allow for compatibility
when 'l' =>
if not First_Pass then
if Full_Switch (Parser => Parser) = "l" then
Gnatcheck.Options.Full_Source_Locations := True;
elsif Full_Switch (Parser => Parser) = "log" then
Log_Mode := True;
end if;
end if;
when 'm' =>
if not First_Pass then
begin
Gnatcheck.Options.Max_Diagnoses :=
Natural'Value (Parameter (Parser => Parser));
if Gnatcheck.Options.Max_Diagnoses > 1000 then
Error ("Parameter (Parser => Parser) of '-m' option " &
"too big, max allowed is 1000");
raise Parameter_Error;
end if;
exception
when Constraint_Error =>
Error ("Wrong Parameter of '-m' option: " &
Parameter (Parser => Parser));
raise Parameter_Error;
end;
end if;
when 'o' =>
if not First_Pass then
if Full_Switch (Parser => Parser) = "o" then
Set_Report_File_Name (Parameter (Parser => Parser));
end if;
end if;
when 'P' =>
if Full_Switch (Parser => Parser) = "P" then
if First_Pass then
My_Project.Store_Project_Source (Parameter);
elsif In_Project_File then
Error ("project file should not be specified inside " &
"another project file");
raise Parameter_Error;
end if;
end if;
when 'q' =>
if not First_Pass then
Quiet_Mode := True;
end if;
when 's' =>
if not First_Pass then
Gnatcheck.Diagnoses_Old.Process_Report_File_Format_Parameter
(Parameter (Parser => Parser), Success);
if not Success then
raise Parameter_Error;
end if;
end if;
when 't' =>
if not First_Pass then
Compute_Timing := True;
end if;
when 'v' =>
if Full_Switch (Parser => Parser) = "vP" then
if First_Pass then
begin
ASIS_UL.Projects.Verbosity_Level :=
Verbosity_Levels'Value (Parameter);
exception
when Constraint_Error =>
Error ("wrong switch parameter " &
Parameter & " for -vP");
raise Parameter_Error;
end;
elsif In_Project_File then
Error ("-vP option is not allowed in a project file");
raise Parameter_Error;
end if;
end if;
when 'U' =>
if Full_Switch (Parser => Parser) = "U" then
if First_Pass then
if ASIS_UL.Projects.U_Option_Set then
Error ("-U can be specified only once");
raise Parameter_Error;
end if;
ASIS_UL.Projects.U_Option_Set := True;
elsif In_Project_File then
Error ("-U option is not allowed in a project file");
raise Parameter_Error;
end if;
end if;
when 'X' =>
if Full_Switch (Parser => Parser) = "X" then
if First_Pass then
ASIS_UL.Projects.Store_External_Variable
(Var => Parameter);
elsif In_Project_File then
Error ("external references cannot be set in " &
"a project file");
raise Parameter_Error;
end if;
end if;
when '-' =>
if not First_Pass then
if Full_Switch (Parser => Parser) =
"-dump-code-standard"
then
Coding_Standard_Kind :=
Get_Coding_Standard_Kind (Parameter (Parser => Parser));
elsif Full_Switch (Parser => Parser) = "-no-column" then
Gnatcheck.Options.No_Column_Num_In_Diagnoses := True;
elsif Full_Switch (Parser => Parser) = "-exemption" then
Gnatcheck.Options.Print_Exemption_Section := True;
elsif Full_Switch (Parser => Parser) = "-include-file" then
Gnatcheck.Diagnoses_Old.Process_User_Filename
(Parameter (Parser => Parser));
elsif Full_Switch (Parser => Parser) = "-show-rule" then
Gnatcheck.Options.Mapping_Mode := True;
elsif Full_Switch (Parser => Parser) = "-test" then
ASIS_UL.Options.Test_Mode := True;
ASIS_UL.Options.Warning_Mode := Quiet;
elsif Full_Switch (Parser => Parser) =
"-old-report-format"
then
Gnatcheck.Options.Qualification_Report := False;
elsif Full_Switch (Parser => Parser) = "-write-rules" then
Generate_Coding_Standard := True;
Set_Coding_Standard_File_Name
(Parameter (Parser => Parser));
elsif Full_Switch (Parser => Parser) = "-subdirs" then
Set_Subdir_Name (Parameter (Parser => Parser));
elsif Full_Switch (Parser => Parser) = "-no_objects_dir" then
No_Object_Dir := True;
elsif Full_Switch (Parser => Parser) = "-RTS" then
ASIS_UL.Compiler_Options.Store_Option
("--RTS=" & Parameter (Parser => Parser));
end if;
else
if Full_Switch (Parser => Parser) = "-RTS" then
Store_RTS_Path (Parameter (Parser => Parser));
end if;
end if;
when others =>
if not Mimic_gcc then
-- Ignore unrecognized switches in the inner invocation
Error
("unrecognized switch: " & Full_Switch (Parser => Parser));
raise Parameter_Error;
end if;
end case;
<<Continue>>
-- Go here to skip the above case statement in the case when
-- Scan_Common_Arg already dealt with an argument.
end loop;
-- If there is an -asis-tool-args section (which only happens in the
-- inner invocations of incremental mode), we treat those args like
-- normal args. We do so by going to that section, and recursively
-- calling Scan_Arguments. See also ASIS_UL.Projects.Section_Delimiters.
if Current_Section (Parser => Parser) = "" then
Goto_Section ("asis-tool-args", Parser => Parser);
if Current_Section (Parser => Parser) = "-asis-tool-args" then
Scan_Arguments (My_Project, First_Pass, Parser, In_Switches);
Goto_Section ("", Parser => Parser);
else
pragma Assert (Current_Section (Parser => Parser) = "");
end if;
if not First_Pass then
Process_Sections;
end if;
if Incremental_Mode_By_Default
and then My_Project.Is_Specified
then
pragma Assert (not Mimic_gcc);
Incremental_Mode := True;
end if;
else
-- We're in the recursive call; do nothing
pragma Assert
(Current_Section (Parser => Parser) = "-asis-tool-args");
end if;
exception
when GNAT.Command_Line.Invalid_Switch =>
Error ("invalid switch : " & Full_Switch (Parser => Parser));
raise Parameter_Error;
when GNAT.Command_Line.Invalid_Parameter =>
Error ("missing Parameter (Parser => Parser) for: -" &
Full_Switch (Parser => Parser));
raise Parameter_Error;
end Scan_Arguments;
------------------------
-- Section_Delimiters --
------------------------
function Section_Delimiters
(My_Project : Gnatcheck_Project_Type)
return String
is
pragma Unreferenced (My_Project);
begin
return "cargs rules asis-tool-args";
end Section_Delimiters;
-----------------------
-- Tool_Package_Name --
-----------------------
function Tool_Package_Name
(My_Project : Gnatcheck_Project_Type)
return String
is
pragma Unreferenced (My_Project);
begin
return "check";
end Tool_Package_Name;
end Gnatcheck.Projects;
|
