|
111
|
1 ------------------------------------------------------------------------------
|
|
|
2 -- --
|
|
|
3 -- GNAT COMPILER COMPONENTS --
|
|
|
4 -- --
|
|
|
5 -- E R R O U T C --
|
|
|
6 -- --
|
|
|
7 -- B o d y --
|
|
|
8 -- --
|
|
131
|
9 -- Copyright (C) 1992-2018, Free Software Foundation, Inc. --
|
|
111
|
10 -- --
|
|
|
11 -- GNAT is free software; you can redistribute it and/or modify it under --
|
|
|
12 -- terms of the GNU General Public License as published by the Free Soft- --
|
|
|
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
|
|
|
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
|
|
|
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
|
|
|
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
|
|
|
17 -- for more details. You should have received a copy of the GNU General --
|
|
|
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
|
|
|
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
|
|
|
20 -- --
|
|
|
21 -- GNAT was originally developed by the GNAT team at New York University. --
|
|
|
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
|
|
|
23 -- --
|
|
|
24 ------------------------------------------------------------------------------
|
|
|
25
|
|
|
26 -- Warning: Error messages can be generated during Gigi processing by direct
|
|
|
27 -- calls to error message routines, so it is essential that the processing
|
|
|
28 -- in this body be consistent with the requirements for the Gigi processing
|
|
|
29 -- environment, and that in particular, no disallowed table expansion is
|
|
|
30 -- allowed to occur.
|
|
|
31
|
|
|
32 with Atree; use Atree;
|
|
|
33 with Casing; use Casing;
|
|
|
34 with Csets; use Csets;
|
|
|
35 with Debug; use Debug;
|
|
|
36 with Err_Vars; use Err_Vars;
|
|
|
37 with Fname; use Fname;
|
|
|
38 with Namet; use Namet;
|
|
|
39 with Opt; use Opt;
|
|
|
40 with Output; use Output;
|
|
|
41 with Sinput; use Sinput;
|
|
|
42 with Snames; use Snames;
|
|
|
43 with Stringt; use Stringt;
|
|
|
44 with Targparm;
|
|
|
45 with Uintp; use Uintp;
|
|
|
46 with Widechar; use Widechar;
|
|
|
47
|
|
|
48 package body Erroutc is
|
|
|
49
|
|
|
50 -----------------------
|
|
|
51 -- Local Subprograms --
|
|
|
52 -----------------------
|
|
|
53
|
|
|
54 function Matches (S : String; P : String) return Boolean;
|
|
|
55 -- Returns true if the String S patches the pattern P, which can contain
|
|
|
56 -- wild card chars (*). The entire pattern must match the entire string.
|
|
|
57 -- Case is ignored in the comparison (so X matches x).
|
|
|
58
|
|
|
59 ---------------
|
|
|
60 -- Add_Class --
|
|
|
61 ---------------
|
|
|
62
|
|
|
63 procedure Add_Class is
|
|
|
64 begin
|
|
|
65 if Class_Flag then
|
|
|
66 Class_Flag := False;
|
|
|
67 Set_Msg_Char (''');
|
|
|
68 Get_Name_String (Name_Class);
|
|
|
69 Set_Casing (Identifier_Casing (Flag_Source));
|
|
|
70 Set_Msg_Name_Buffer;
|
|
|
71 end if;
|
|
|
72 end Add_Class;
|
|
|
73
|
|
|
74 ----------------------
|
|
|
75 -- Buffer_Ends_With --
|
|
|
76 ----------------------
|
|
|
77
|
|
|
78 function Buffer_Ends_With (C : Character) return Boolean is
|
|
|
79 begin
|
|
|
80 return Msglen > 0 and then Msg_Buffer (Msglen) = C;
|
|
|
81 end Buffer_Ends_With;
|
|
|
82
|
|
|
83 function Buffer_Ends_With (S : String) return Boolean is
|
|
|
84 Len : constant Natural := S'Length;
|
|
|
85 begin
|
|
|
86 return Msglen > Len
|
|
|
87 and then Msg_Buffer (Msglen - Len) = ' '
|
|
|
88 and then Msg_Buffer (Msglen - Len + 1 .. Msglen) = S;
|
|
|
89 end Buffer_Ends_With;
|
|
|
90
|
|
|
91 -------------------
|
|
|
92 -- Buffer_Remove --
|
|
|
93 -------------------
|
|
|
94
|
|
|
95 procedure Buffer_Remove (C : Character) is
|
|
|
96 begin
|
|
|
97 if Buffer_Ends_With (C) then
|
|
|
98 Msglen := Msglen - 1;
|
|
|
99 end if;
|
|
|
100 end Buffer_Remove;
|
|
|
101
|
|
|
102 procedure Buffer_Remove (S : String) is
|
|
|
103 begin
|
|
|
104 if Buffer_Ends_With (S) then
|
|
|
105 Msglen := Msglen - S'Length;
|
|
|
106 end if;
|
|
|
107 end Buffer_Remove;
|
|
|
108
|
|
|
109 -----------------------------
|
|
|
110 -- Check_Duplicate_Message --
|
|
|
111 -----------------------------
|
|
|
112
|
|
|
113 procedure Check_Duplicate_Message (M1, M2 : Error_Msg_Id) is
|
|
|
114 L1, L2 : Error_Msg_Id;
|
|
|
115 N1, N2 : Error_Msg_Id;
|
|
|
116
|
|
|
117 procedure Delete_Msg (Delete, Keep : Error_Msg_Id);
|
|
|
118 -- Called to delete message Delete, keeping message Keep. Marks msg
|
|
|
119 -- Delete and all its continuations with deleted flag set to True.
|
|
|
120 -- Also makes sure that for the error messages that are retained the
|
|
|
121 -- preferred message is the one retained (we prefer the shorter one in
|
|
|
122 -- the case where one has an Instance tag). Note that we always know
|
|
|
123 -- that Keep has at least as many continuations as Delete (since we
|
|
|
124 -- always delete the shorter sequence).
|
|
|
125
|
|
|
126 ----------------
|
|
|
127 -- Delete_Msg --
|
|
|
128 ----------------
|
|
|
129
|
|
|
130 procedure Delete_Msg (Delete, Keep : Error_Msg_Id) is
|
|
|
131 D, K : Error_Msg_Id;
|
|
|
132
|
|
|
133 begin
|
|
|
134 D := Delete;
|
|
|
135 K := Keep;
|
|
|
136
|
|
|
137 loop
|
|
|
138 Errors.Table (D).Deleted := True;
|
|
|
139
|
|
|
140 -- Adjust error message count
|
|
|
141
|
|
|
142 if Errors.Table (D).Info then
|
|
|
143
|
|
|
144 if Errors.Table (D).Warn then
|
|
|
145 Warning_Info_Messages := Warning_Info_Messages - 1;
|
|
|
146 Warnings_Detected := Warnings_Detected - 1;
|
|
|
147 else
|
|
|
148 Report_Info_Messages := Report_Info_Messages - 1;
|
|
|
149 end if;
|
|
|
150
|
|
|
151 elsif Errors.Table (D).Warn or else Errors.Table (D).Style then
|
|
|
152 Warnings_Detected := Warnings_Detected - 1;
|
|
|
153
|
|
|
154 -- Note: we do not need to decrement Warnings_Treated_As_Errors
|
|
|
155 -- because this only gets incremented if we actually output the
|
|
|
156 -- message, which we won't do if we are deleting it here!
|
|
|
157
|
|
|
158 elsif Errors.Table (D).Check then
|
|
|
159 Check_Messages := Check_Messages - 1;
|
|
|
160
|
|
|
161 else
|
|
|
162 Total_Errors_Detected := Total_Errors_Detected - 1;
|
|
|
163
|
|
|
164 if Errors.Table (D).Serious then
|
|
|
165 Serious_Errors_Detected := Serious_Errors_Detected - 1;
|
|
|
166 end if;
|
|
|
167 end if;
|
|
|
168
|
|
|
169 -- Substitute shorter of the two error messages
|
|
|
170
|
|
|
171 if Errors.Table (K).Text'Length > Errors.Table (D).Text'Length then
|
|
|
172 Errors.Table (K).Text := Errors.Table (D).Text;
|
|
|
173 end if;
|
|
|
174
|
|
|
175 D := Errors.Table (D).Next;
|
|
|
176 K := Errors.Table (K).Next;
|
|
|
177
|
|
|
178 if D = No_Error_Msg or else not Errors.Table (D).Msg_Cont then
|
|
|
179 return;
|
|
|
180 end if;
|
|
|
181 end loop;
|
|
|
182 end Delete_Msg;
|
|
|
183
|
|
|
184 -- Start of processing for Check_Duplicate_Message
|
|
|
185
|
|
|
186 begin
|
|
|
187 -- Both messages must be non-continuation messages and not deleted
|
|
|
188
|
|
|
189 if Errors.Table (M1).Msg_Cont
|
|
|
190 or else Errors.Table (M2).Msg_Cont
|
|
|
191 or else Errors.Table (M1).Deleted
|
|
|
192 or else Errors.Table (M2).Deleted
|
|
|
193 then
|
|
|
194 return;
|
|
|
195 end if;
|
|
|
196
|
|
|
197 -- Definitely not equal if message text does not match
|
|
|
198
|
|
|
199 if not Same_Error (M1, M2) then
|
|
|
200 return;
|
|
|
201 end if;
|
|
|
202
|
|
|
203 -- Same text. See if all continuations are also identical
|
|
|
204
|
|
|
205 L1 := M1;
|
|
|
206 L2 := M2;
|
|
|
207
|
|
|
208 loop
|
|
|
209 N1 := Errors.Table (L1).Next;
|
|
|
210 N2 := Errors.Table (L2).Next;
|
|
|
211
|
|
|
212 -- If M1 continuations have run out, we delete M1, either the
|
|
|
213 -- messages have the same number of continuations, or M2 has
|
|
|
214 -- more and we prefer the one with more anyway.
|
|
|
215
|
|
|
216 if N1 = No_Error_Msg or else not Errors.Table (N1).Msg_Cont then
|
|
|
217 Delete_Msg (M1, M2);
|
|
|
218 return;
|
|
|
219
|
|
|
220 -- If M2 continuations have run out, we delete M2
|
|
|
221
|
|
|
222 elsif N2 = No_Error_Msg or else not Errors.Table (N2).Msg_Cont then
|
|
|
223 Delete_Msg (M2, M1);
|
|
|
224 return;
|
|
|
225
|
|
|
226 -- Otherwise see if continuations are the same, if not, keep both
|
|
|
227 -- sequences, a curious case, but better to keep everything.
|
|
|
228
|
|
|
229 elsif not Same_Error (N1, N2) then
|
|
|
230 return;
|
|
|
231
|
|
|
232 -- If continuations are the same, continue scan
|
|
|
233
|
|
|
234 else
|
|
|
235 L1 := N1;
|
|
|
236 L2 := N2;
|
|
|
237 end if;
|
|
|
238 end loop;
|
|
|
239 end Check_Duplicate_Message;
|
|
|
240
|
|
|
241 ------------------------
|
|
|
242 -- Compilation_Errors --
|
|
|
243 ------------------------
|
|
|
244
|
|
|
245 function Compilation_Errors return Boolean is
|
|
|
246 begin
|
|
|
247 return
|
|
|
248 Total_Errors_Detected /= 0
|
|
|
249 or else (Warnings_Detected - Warning_Info_Messages /= 0
|
|
|
250 and then Warning_Mode = Treat_As_Error)
|
|
|
251 or else Warnings_Treated_As_Errors /= 0;
|
|
|
252 end Compilation_Errors;
|
|
|
253
|
|
|
254 ------------------
|
|
|
255 -- Debug_Output --
|
|
|
256 ------------------
|
|
|
257
|
|
|
258 procedure Debug_Output (N : Node_Id) is
|
|
|
259 begin
|
|
|
260 if Debug_Flag_1 then
|
|
|
261 Write_Str ("*** following error message posted on node id = #");
|
|
|
262 Write_Int (Int (N));
|
|
|
263 Write_Str (" ***");
|
|
|
264 Write_Eol;
|
|
|
265 end if;
|
|
|
266 end Debug_Output;
|
|
|
267
|
|
|
268 ----------
|
|
|
269 -- dmsg --
|
|
|
270 ----------
|
|
|
271
|
|
|
272 procedure dmsg (Id : Error_Msg_Id) is
|
|
|
273 E : Error_Msg_Object renames Errors.Table (Id);
|
|
|
274
|
|
|
275 begin
|
|
|
276 w ("Dumping error message, Id = ", Int (Id));
|
|
|
277 w (" Text = ", E.Text.all);
|
|
|
278 w (" Next = ", Int (E.Next));
|
|
|
279 w (" Prev = ", Int (E.Prev));
|
|
|
280 w (" Sfile = ", Int (E.Sfile));
|
|
|
281
|
|
|
282 Write_Str
|
|
|
283 (" Sptr = ");
|
|
|
284 Write_Location (E.Sptr);
|
|
|
285 Write_Eol;
|
|
|
286
|
|
|
287 Write_Str
|
|
|
288 (" Optr = ");
|
|
|
289 Write_Location (E.Optr);
|
|
|
290 Write_Eol;
|
|
|
291
|
|
|
292 w (" Line = ", Int (E.Line));
|
|
|
293 w (" Col = ", Int (E.Col));
|
|
|
294 w (" Warn = ", E.Warn);
|
|
|
295 w (" Warn_Err = ", E.Warn_Err);
|
|
|
296 w (" Warn_Chr = '" & E.Warn_Chr & ''');
|
|
|
297 w (" Style = ", E.Style);
|
|
|
298 w (" Serious = ", E.Serious);
|
|
|
299 w (" Uncond = ", E.Uncond);
|
|
|
300 w (" Msg_Cont = ", E.Msg_Cont);
|
|
|
301 w (" Deleted = ", E.Deleted);
|
|
|
302 w (" Node = ", Int (E.Node));
|
|
|
303
|
|
|
304 Write_Eol;
|
|
|
305 end dmsg;
|
|
|
306
|
|
|
307 ------------------
|
|
|
308 -- Get_Location --
|
|
|
309 ------------------
|
|
|
310
|
|
|
311 function Get_Location (E : Error_Msg_Id) return Source_Ptr is
|
|
|
312 begin
|
|
|
313 return Errors.Table (E).Sptr;
|
|
|
314 end Get_Location;
|
|
|
315
|
|
|
316 ----------------
|
|
|
317 -- Get_Msg_Id --
|
|
|
318 ----------------
|
|
|
319
|
|
|
320 function Get_Msg_Id return Error_Msg_Id is
|
|
|
321 begin
|
|
|
322 return Cur_Msg;
|
|
|
323 end Get_Msg_Id;
|
|
|
324
|
|
|
325 ---------------------
|
|
|
326 -- Get_Warning_Tag --
|
|
|
327 ---------------------
|
|
|
328
|
|
|
329 function Get_Warning_Tag (Id : Error_Msg_Id) return String is
|
|
|
330 Warn : constant Boolean := Errors.Table (Id).Warn;
|
|
|
331 Warn_Chr : constant Character := Errors.Table (Id).Warn_Chr;
|
|
|
332 begin
|
|
|
333 if Warn and then Warn_Chr /= ' ' then
|
|
|
334 if Warn_Chr = '?' then
|
|
|
335 return "[enabled by default]";
|
|
|
336 elsif Warn_Chr = '*' then
|
|
|
337 return "[restriction warning]";
|
|
|
338 elsif Warn_Chr = '$' then
|
|
|
339 return "[-gnatel]";
|
|
|
340 elsif Warn_Chr in 'a' .. 'z' then
|
|
|
341 return "[-gnatw" & Warn_Chr & ']';
|
|
|
342 else pragma Assert (Warn_Chr in 'A' .. 'Z');
|
|
|
343 return "[-gnatw." & Fold_Lower (Warn_Chr) & ']';
|
|
|
344 end if;
|
|
|
345 else
|
|
|
346 return "";
|
|
|
347 end if;
|
|
|
348 end Get_Warning_Tag;
|
|
|
349
|
|
|
350 -------------
|
|
|
351 -- Matches --
|
|
|
352 -------------
|
|
|
353
|
|
|
354 function Matches (S : String; P : String) return Boolean is
|
|
|
355 Slast : constant Natural := S'Last;
|
|
|
356 PLast : constant Natural := P'Last;
|
|
|
357
|
|
|
358 SPtr : Natural := S'First;
|
|
|
359 PPtr : Natural := P'First;
|
|
|
360
|
|
|
361 begin
|
|
|
362 -- Loop advancing through characters of string and pattern
|
|
|
363
|
|
|
364 SPtr := S'First;
|
|
|
365 PPtr := P'First;
|
|
|
366 loop
|
|
|
367 -- Return True if pattern is a single asterisk
|
|
|
368
|
|
|
369 if PPtr = PLast and then P (PPtr) = '*' then
|
|
|
370 return True;
|
|
|
371
|
|
|
372 -- Return True if both pattern and string exhausted
|
|
|
373
|
|
|
374 elsif PPtr > PLast and then SPtr > Slast then
|
|
|
375 return True;
|
|
|
376
|
|
|
377 -- Return False, if one exhausted and not the other
|
|
|
378
|
|
|
379 elsif PPtr > PLast or else SPtr > Slast then
|
|
|
380 return False;
|
|
|
381
|
|
|
382 -- Case where pattern starts with asterisk
|
|
|
383
|
|
|
384 elsif P (PPtr) = '*' then
|
|
|
385
|
|
|
386 -- Try all possible starting positions in S for match with the
|
|
|
387 -- remaining characters of the pattern. This is the recursive
|
|
|
388 -- call that implements the scanner backup.
|
|
|
389
|
|
|
390 for J in SPtr .. Slast loop
|
|
|
391 if Matches (S (J .. Slast), P (PPtr + 1 .. PLast)) then
|
|
|
392 return True;
|
|
|
393 end if;
|
|
|
394 end loop;
|
|
|
395
|
|
|
396 return False;
|
|
|
397
|
|
|
398 -- Dealt with end of string and *, advance if we have a match
|
|
|
399
|
|
|
400 elsif Fold_Lower (S (SPtr)) = Fold_Lower (P (PPtr)) then
|
|
|
401 SPtr := SPtr + 1;
|
|
|
402 PPtr := PPtr + 1;
|
|
|
403
|
|
|
404 -- If first characters do not match, that's decisive
|
|
|
405
|
|
|
406 else
|
|
|
407 return False;
|
|
|
408 end if;
|
|
|
409 end loop;
|
|
|
410 end Matches;
|
|
|
411
|
|
|
412 -----------------------
|
|
|
413 -- Output_Error_Msgs --
|
|
|
414 -----------------------
|
|
|
415
|
|
|
416 procedure Output_Error_Msgs (E : in out Error_Msg_Id) is
|
|
|
417 P : Source_Ptr;
|
|
|
418 T : Error_Msg_Id;
|
|
|
419 S : Error_Msg_Id;
|
|
|
420
|
|
|
421 Flag_Num : Pos;
|
|
|
422 Mult_Flags : Boolean := False;
|
|
|
423
|
|
|
424 begin
|
|
|
425 S := E;
|
|
|
426
|
|
|
427 -- Skip deleted messages at start
|
|
|
428
|
|
|
429 if Errors.Table (S).Deleted then
|
|
|
430 Set_Next_Non_Deleted_Msg (S);
|
|
|
431 end if;
|
|
|
432
|
|
|
433 -- Figure out if we will place more than one error flag on this line
|
|
|
434
|
|
|
435 T := S;
|
|
|
436 while T /= No_Error_Msg
|
|
|
437 and then Errors.Table (T).Line = Errors.Table (E).Line
|
|
|
438 and then Errors.Table (T).Sfile = Errors.Table (E).Sfile
|
|
|
439 loop
|
|
|
440 if Errors.Table (T).Sptr > Errors.Table (E).Sptr then
|
|
|
441 Mult_Flags := True;
|
|
|
442 end if;
|
|
|
443
|
|
|
444 Set_Next_Non_Deleted_Msg (T);
|
|
|
445 end loop;
|
|
|
446
|
|
|
447 -- Output the error flags. The circuit here makes sure that the tab
|
|
|
448 -- characters in the original line are properly accounted for. The
|
|
|
449 -- eight blanks at the start are to match the line number.
|
|
|
450
|
|
|
451 if not Debug_Flag_2 then
|
|
|
452 Write_Str (" ");
|
|
|
453 P := Line_Start (Errors.Table (E).Sptr);
|
|
|
454 Flag_Num := 1;
|
|
|
455
|
|
|
456 -- Loop through error messages for this line to place flags
|
|
|
457
|
|
|
458 T := S;
|
|
|
459 while T /= No_Error_Msg
|
|
|
460 and then Errors.Table (T).Line = Errors.Table (E).Line
|
|
|
461 and then Errors.Table (T).Sfile = Errors.Table (E).Sfile
|
|
|
462 loop
|
|
|
463 declare
|
|
|
464 Src : Source_Buffer_Ptr
|
|
|
465 renames Source_Text (Errors.Table (T).Sfile);
|
|
|
466
|
|
|
467 begin
|
|
|
468 -- Loop to output blanks till current flag position
|
|
|
469
|
|
|
470 while P < Errors.Table (T).Sptr loop
|
|
|
471
|
|
|
472 -- Horizontal tab case, just echo the tab
|
|
|
473
|
|
|
474 if Src (P) = ASCII.HT then
|
|
|
475 Write_Char (ASCII.HT);
|
|
|
476 P := P + 1;
|
|
|
477
|
|
|
478 -- Deal with wide character case, but don't include brackets
|
|
|
479 -- notation in this circuit, since we know that this will
|
|
|
480 -- display unencoded (no one encodes brackets notation).
|
|
|
481
|
|
|
482 elsif Src (P) /= '['
|
|
|
483 and then Is_Start_Of_Wide_Char (Src, P)
|
|
|
484 then
|
|
|
485 Skip_Wide (Src, P);
|
|
|
486 Write_Char (' ');
|
|
|
487
|
|
|
488 -- Normal non-wide character case (or bracket)
|
|
|
489
|
|
|
490 else
|
|
|
491 P := P + 1;
|
|
|
492 Write_Char (' ');
|
|
|
493 end if;
|
|
|
494 end loop;
|
|
|
495
|
|
|
496 -- Output flag (unless already output, this happens if more
|
|
|
497 -- than one error message occurs at the same flag position).
|
|
|
498
|
|
|
499 if P = Errors.Table (T).Sptr then
|
|
|
500 if (Flag_Num = 1 and then not Mult_Flags)
|
|
|
501 or else Flag_Num > 9
|
|
|
502 then
|
|
|
503 Write_Char ('|');
|
|
|
504 else
|
|
|
505 Write_Char
|
|
|
506 (Character'Val (Character'Pos ('0') + Flag_Num));
|
|
|
507 end if;
|
|
|
508
|
|
|
509 -- Skip past the corresponding source text character
|
|
|
510
|
|
|
511 -- Horizontal tab case, we output a flag at the tab position
|
|
|
512 -- so now we output a tab to match up with the text.
|
|
|
513
|
|
|
514 if Src (P) = ASCII.HT then
|
|
|
515 Write_Char (ASCII.HT);
|
|
|
516 P := P + 1;
|
|
|
517
|
|
|
518 -- Skip wide character other than left bracket
|
|
|
519
|
|
|
520 elsif Src (P) /= '['
|
|
|
521 and then Is_Start_Of_Wide_Char (Src, P)
|
|
|
522 then
|
|
|
523 Skip_Wide (Src, P);
|
|
|
524
|
|
|
525 -- Skip normal non-wide character case (or bracket)
|
|
|
526
|
|
|
527 else
|
|
|
528 P := P + 1;
|
|
|
529 end if;
|
|
|
530 end if;
|
|
|
531 end;
|
|
|
532
|
|
|
533 Set_Next_Non_Deleted_Msg (T);
|
|
|
534 Flag_Num := Flag_Num + 1;
|
|
|
535 end loop;
|
|
|
536
|
|
|
537 Write_Eol;
|
|
|
538 end if;
|
|
|
539
|
|
|
540 -- Now output the error messages
|
|
|
541
|
|
|
542 T := S;
|
|
|
543 while T /= No_Error_Msg
|
|
|
544 and then Errors.Table (T).Line = Errors.Table (E).Line
|
|
|
545 and then Errors.Table (T).Sfile = Errors.Table (E).Sfile
|
|
|
546 loop
|
|
|
547 Write_Str (" >>> ");
|
|
|
548 Output_Msg_Text (T);
|
|
|
549
|
|
|
550 if Debug_Flag_2 then
|
|
|
551 while Column < 74 loop
|
|
|
552 Write_Char (' ');
|
|
|
553 end loop;
|
|
|
554
|
|
|
555 Write_Str (" <<<");
|
|
|
556 end if;
|
|
|
557
|
|
|
558 Write_Eol;
|
|
|
559 Set_Next_Non_Deleted_Msg (T);
|
|
|
560 end loop;
|
|
|
561
|
|
|
562 E := T;
|
|
|
563 end Output_Error_Msgs;
|
|
|
564
|
|
|
565 ------------------------
|
|
|
566 -- Output_Line_Number --
|
|
|
567 ------------------------
|
|
|
568
|
|
|
569 procedure Output_Line_Number (L : Logical_Line_Number) is
|
|
|
570 D : Int; -- next digit
|
|
|
571 C : Character; -- next character
|
|
|
572 Z : Boolean; -- flag for zero suppress
|
|
|
573 N, M : Int; -- temporaries
|
|
|
574
|
|
|
575 begin
|
|
|
576 if L = No_Line_Number then
|
|
|
577 Write_Str (" ");
|
|
|
578
|
|
|
579 else
|
|
|
580 Z := False;
|
|
|
581 N := Int (L);
|
|
|
582
|
|
|
583 M := 100_000;
|
|
|
584 while M /= 0 loop
|
|
|
585 D := Int (N / M);
|
|
|
586 N := N rem M;
|
|
|
587 M := M / 10;
|
|
|
588
|
|
|
589 if D = 0 then
|
|
|
590 if Z then
|
|
|
591 C := '0';
|
|
|
592 else
|
|
|
593 C := ' ';
|
|
|
594 end if;
|
|
|
595 else
|
|
|
596 Z := True;
|
|
|
597 C := Character'Val (D + 48);
|
|
|
598 end if;
|
|
|
599
|
|
|
600 Write_Char (C);
|
|
|
601 end loop;
|
|
|
602
|
|
|
603 Write_Str (". ");
|
|
|
604 end if;
|
|
|
605 end Output_Line_Number;
|
|
|
606
|
|
|
607 ---------------------
|
|
|
608 -- Output_Msg_Text --
|
|
|
609 ---------------------
|
|
|
610
|
|
|
611 procedure Output_Msg_Text (E : Error_Msg_Id) is
|
|
|
612 Offs : constant Nat := Column - 1;
|
|
|
613 -- Offset to start of message, used for continuations
|
|
|
614
|
|
|
615 Max : Integer;
|
|
|
616 -- Maximum characters to output on next line
|
|
|
617
|
|
|
618 Length : Nat;
|
|
|
619 -- Maximum total length of lines
|
|
|
620
|
|
|
621 Text : constant String_Ptr := Errors.Table (E).Text;
|
|
|
622 Ptr : Natural;
|
|
|
623 Split : Natural;
|
|
|
624 Start : Natural;
|
|
|
625
|
|
|
626 begin
|
|
|
627 declare
|
|
|
628 Tag : constant String := Get_Warning_Tag (E);
|
|
|
629 Txt : String_Ptr;
|
|
|
630 Len : Natural;
|
|
|
631
|
|
|
632 begin
|
|
|
633 -- Postfix warning tag to message if needed
|
|
|
634
|
|
|
635 if Tag /= "" and then Warning_Doc_Switch then
|
|
|
636 if Include_Subprogram_In_Messages then
|
|
|
637 Txt :=
|
|
|
638 new String'
|
|
|
639 (Subprogram_Name_Ptr (Errors.Table (E).Node) &
|
|
|
640 ": " & Text.all & ' ' & Tag);
|
|
|
641 else
|
|
|
642 Txt := new String'(Text.all & ' ' & Tag);
|
|
|
643 end if;
|
|
|
644
|
|
|
645 elsif Include_Subprogram_In_Messages
|
|
|
646 and then (Errors.Table (E).Warn or else Errors.Table (E).Style)
|
|
|
647 then
|
|
|
648 Txt :=
|
|
|
649 new String'
|
|
|
650 (Subprogram_Name_Ptr (Errors.Table (E).Node) &
|
|
|
651 ": " & Text.all);
|
|
|
652 else
|
|
|
653 Txt := Text;
|
|
|
654 end if;
|
|
|
655
|
|
|
656 -- Deal with warning case
|
|
|
657
|
|
|
658 if Errors.Table (E).Warn or else Errors.Table (E).Info then
|
|
|
659
|
|
|
660 -- For info messages, prefix message with "info: "
|
|
|
661
|
|
|
662 if Errors.Table (E).Info then
|
|
|
663 Txt := new String'("info: " & Txt.all);
|
|
|
664
|
|
|
665 -- Warning treated as error
|
|
|
666
|
|
|
667 elsif Errors.Table (E).Warn_Err then
|
|
|
668
|
|
|
669 -- We prefix with "error:" rather than warning: and postfix
|
|
|
670 -- [warning-as-error] at the end.
|
|
|
671
|
|
|
672 Warnings_Treated_As_Errors := Warnings_Treated_As_Errors + 1;
|
|
|
673 Txt := new String'("error: " & Txt.all & " [warning-as-error]");
|
|
|
674
|
|
|
675 -- Normal case, prefix with "warning: "
|
|
|
676
|
|
|
677 else
|
|
|
678 Txt := new String'("warning: " & Txt.all);
|
|
|
679 end if;
|
|
|
680
|
|
|
681 -- No prefix needed for style message, "(style)" is there already
|
|
|
682
|
|
|
683 elsif Errors.Table (E).Style then
|
|
|
684 null;
|
|
|
685
|
|
|
686 -- No prefix needed for check message, severity is there already
|
|
|
687
|
|
|
688 elsif Errors.Table (E).Check then
|
|
|
689 null;
|
|
|
690
|
|
|
691 -- All other cases, add "error: " if unique error tag set
|
|
|
692
|
|
|
693 elsif Opt.Unique_Error_Tag then
|
|
|
694 Txt := new String'("error: " & Txt.all);
|
|
|
695 end if;
|
|
|
696
|
|
|
697 -- Set error message line length and length of message
|
|
|
698
|
|
|
699 if Error_Msg_Line_Length = 0 then
|
|
|
700 Length := Nat'Last;
|
|
|
701 else
|
|
|
702 Length := Error_Msg_Line_Length;
|
|
|
703 end if;
|
|
|
704
|
|
|
705 Max := Integer (Length - Column + 1);
|
|
|
706 Len := Txt'Length;
|
|
|
707
|
|
|
708 -- Here we have to split the message up into multiple lines
|
|
|
709
|
|
|
710 Ptr := 1;
|
|
|
711 loop
|
|
|
712 -- Make sure we do not have ludicrously small line
|
|
|
713
|
|
|
714 Max := Integer'Max (Max, 20);
|
|
|
715
|
|
|
716 -- If remaining text fits, output it respecting LF and we are done
|
|
|
717
|
|
|
718 if Len - Ptr < Max then
|
|
|
719 for J in Ptr .. Len loop
|
|
|
720 if Txt (J) = ASCII.LF then
|
|
|
721 Write_Eol;
|
|
|
722 Write_Spaces (Offs);
|
|
|
723 else
|
|
|
724 Write_Char (Txt (J));
|
|
|
725 end if;
|
|
|
726 end loop;
|
|
|
727
|
|
|
728 return;
|
|
|
729
|
|
|
730 -- Line does not fit
|
|
|
731
|
|
|
732 else
|
|
|
733 Start := Ptr;
|
|
|
734
|
|
|
735 -- First scan forward looking for a hard end of line
|
|
|
736
|
|
|
737 for Scan in Ptr .. Ptr + Max - 1 loop
|
|
|
738 if Txt (Scan) = ASCII.LF then
|
|
|
739 Split := Scan - 1;
|
|
|
740 Ptr := Scan + 1;
|
|
|
741 goto Continue;
|
|
|
742 end if;
|
|
|
743 end loop;
|
|
|
744
|
|
|
745 -- Otherwise scan backwards looking for a space
|
|
|
746
|
|
|
747 for Scan in reverse Ptr .. Ptr + Max - 1 loop
|
|
|
748 if Txt (Scan) = ' ' then
|
|
|
749 Split := Scan - 1;
|
|
|
750 Ptr := Scan + 1;
|
|
|
751 goto Continue;
|
|
|
752 end if;
|
|
|
753 end loop;
|
|
|
754
|
|
|
755 -- If we fall through, no space, so split line arbitrarily
|
|
|
756
|
|
|
757 Split := Ptr + Max - 1;
|
|
|
758 Ptr := Split + 1;
|
|
|
759 end if;
|
|
|
760
|
|
|
761 <<Continue>>
|
|
|
762 if Start <= Split then
|
|
|
763 Write_Line (Txt (Start .. Split));
|
|
|
764 Write_Spaces (Offs);
|
|
|
765 end if;
|
|
|
766
|
|
|
767 Max := Integer (Length - Column + 1);
|
|
|
768 end loop;
|
|
|
769 end;
|
|
|
770 end Output_Msg_Text;
|
|
|
771
|
|
|
772 ---------------------
|
|
|
773 -- Prescan_Message --
|
|
|
774 ---------------------
|
|
|
775
|
|
|
776 procedure Prescan_Message (Msg : String) is
|
|
|
777 J : Natural;
|
|
|
778
|
|
|
779 begin
|
|
|
780 -- Nothing to do for continuation line
|
|
|
781
|
|
|
782 if Msg (Msg'First) = '\' then
|
|
|
783 return;
|
|
|
784 end if;
|
|
|
785
|
|
|
786 -- Set initial values of globals (may be changed during scan)
|
|
|
787
|
|
|
788 Is_Serious_Error := True;
|
|
|
789 Is_Unconditional_Msg := False;
|
|
|
790 Is_Warning_Msg := False;
|
|
|
791 Has_Double_Exclam := False;
|
|
|
792
|
|
|
793 -- Check style message
|
|
|
794
|
|
|
795 Is_Style_Msg :=
|
|
|
796 Msg'Length > 7 and then Msg (Msg'First .. Msg'First + 6) = "(style)";
|
|
|
797
|
|
|
798 -- Check info message
|
|
|
799
|
|
|
800 Is_Info_Msg :=
|
|
|
801 Msg'Length > 6 and then Msg (Msg'First .. Msg'First + 5) = "info: ";
|
|
|
802
|
|
|
803 -- Check check message
|
|
|
804
|
|
|
805 Is_Check_Msg :=
|
|
|
806 (Msg'Length > 8 and then Msg (Msg'First .. Msg'First + 7) = "medium: ")
|
|
|
807 or else
|
|
|
808 (Msg'Length > 6 and then Msg (Msg'First .. Msg'First + 5) = "high: ")
|
|
|
809 or else
|
|
|
810 (Msg'Length > 5 and then Msg (Msg'First .. Msg'First + 4) = "low: ");
|
|
|
811
|
|
|
812 -- Loop through message looking for relevant insertion sequences
|
|
|
813
|
|
|
814 J := Msg'First;
|
|
|
815 while J <= Msg'Last loop
|
|
|
816
|
|
|
817 -- If we have a quote, don't look at following character
|
|
|
818
|
|
|
819 if Msg (J) = ''' then
|
|
|
820 J := J + 2;
|
|
|
821
|
|
|
822 -- Warning message (? or < insertion sequence)
|
|
|
823
|
|
|
824 elsif Msg (J) = '?' or else Msg (J) = '<' then
|
|
|
825 Is_Warning_Msg := Msg (J) = '?' or else Error_Msg_Warn;
|
|
|
826 Warning_Msg_Char := ' ';
|
|
|
827 J := J + 1;
|
|
|
828
|
|
|
829 if Is_Warning_Msg then
|
|
|
830 declare
|
|
|
831 C : constant Character := Msg (J - 1);
|
|
|
832 begin
|
|
|
833 if J <= Msg'Last then
|
|
|
834 if Msg (J) = C then
|
|
|
835 Warning_Msg_Char := '?';
|
|
|
836 J := J + 1;
|
|
|
837
|
|
|
838 elsif J < Msg'Last and then Msg (J + 1) = C
|
|
|
839 and then (Msg (J) in 'a' .. 'z' or else
|
|
|
840 Msg (J) in 'A' .. 'Z' or else
|
|
|
841 Msg (J) = '*' or else
|
|
|
842 Msg (J) = '$')
|
|
|
843 then
|
|
|
844 Warning_Msg_Char := Msg (J);
|
|
|
845 J := J + 2;
|
|
|
846 end if;
|
|
|
847 end if;
|
|
|
848 end;
|
|
|
849 end if;
|
|
|
850
|
|
|
851 -- Bomb if untagged warning message. This code can be uncommented
|
|
|
852 -- for debugging when looking for untagged warning messages.
|
|
|
853
|
|
|
854 -- if Is_Warning_Msg and then Warning_Msg_Char = ' ' then
|
|
|
855 -- raise Program_Error;
|
|
|
856 -- end if;
|
|
|
857
|
|
|
858 -- Unconditional message (! insertion)
|
|
|
859
|
|
|
860 elsif Msg (J) = '!' then
|
|
|
861 Is_Unconditional_Msg := True;
|
|
|
862 J := J + 1;
|
|
|
863
|
|
|
864 if J <= Msg'Last and then Msg (J) = '!' then
|
|
|
865 Has_Double_Exclam := True;
|
|
|
866 J := J + 1;
|
|
|
867 end if;
|
|
|
868
|
|
|
869 -- Non-serious error (| insertion)
|
|
|
870
|
|
|
871 elsif Msg (J) = '|' then
|
|
|
872 Is_Serious_Error := False;
|
|
|
873 J := J + 1;
|
|
|
874
|
|
|
875 else
|
|
|
876 J := J + 1;
|
|
|
877 end if;
|
|
|
878 end loop;
|
|
|
879
|
|
|
880 if Is_Info_Msg or Is_Warning_Msg or Is_Style_Msg or Is_Check_Msg then
|
|
|
881 Is_Serious_Error := False;
|
|
|
882 end if;
|
|
|
883 end Prescan_Message;
|
|
|
884
|
|
|
885 --------------------
|
|
|
886 -- Purge_Messages --
|
|
|
887 --------------------
|
|
|
888
|
|
|
889 procedure Purge_Messages (From : Source_Ptr; To : Source_Ptr) is
|
|
|
890 E : Error_Msg_Id;
|
|
|
891
|
|
|
892 function To_Be_Purged (E : Error_Msg_Id) return Boolean;
|
|
|
893 -- Returns True for a message that is to be purged. Also adjusts
|
|
|
894 -- error counts appropriately.
|
|
|
895
|
|
|
896 ------------------
|
|
|
897 -- To_Be_Purged --
|
|
|
898 ------------------
|
|
|
899
|
|
|
900 function To_Be_Purged (E : Error_Msg_Id) return Boolean is
|
|
|
901 begin
|
|
|
902 if E /= No_Error_Msg
|
|
|
903 and then Errors.Table (E).Sptr > From
|
|
|
904 and then Errors.Table (E).Sptr < To
|
|
|
905 then
|
|
|
906 if Errors.Table (E).Warn or else Errors.Table (E).Style then
|
|
|
907 Warnings_Detected := Warnings_Detected - 1;
|
|
|
908
|
|
|
909 else
|
|
|
910 Total_Errors_Detected := Total_Errors_Detected - 1;
|
|
|
911
|
|
|
912 if Errors.Table (E).Serious then
|
|
|
913 Serious_Errors_Detected := Serious_Errors_Detected - 1;
|
|
|
914 end if;
|
|
|
915 end if;
|
|
|
916
|
|
|
917 return True;
|
|
|
918
|
|
|
919 else
|
|
|
920 return False;
|
|
|
921 end if;
|
|
|
922 end To_Be_Purged;
|
|
|
923
|
|
|
924 -- Start of processing for Purge_Messages
|
|
|
925
|
|
|
926 begin
|
|
|
927 while To_Be_Purged (First_Error_Msg) loop
|
|
|
928 First_Error_Msg := Errors.Table (First_Error_Msg).Next;
|
|
|
929 end loop;
|
|
|
930
|
|
|
931 E := First_Error_Msg;
|
|
|
932 while E /= No_Error_Msg loop
|
|
|
933 while To_Be_Purged (Errors.Table (E).Next) loop
|
|
|
934 Errors.Table (E).Next :=
|
|
|
935 Errors.Table (Errors.Table (E).Next).Next;
|
|
|
936 end loop;
|
|
|
937
|
|
|
938 E := Errors.Table (E).Next;
|
|
|
939 end loop;
|
|
|
940 end Purge_Messages;
|
|
|
941
|
|
|
942 ----------------
|
|
|
943 -- Same_Error --
|
|
|
944 ----------------
|
|
|
945
|
|
|
946 function Same_Error (M1, M2 : Error_Msg_Id) return Boolean is
|
|
|
947 Msg1 : constant String_Ptr := Errors.Table (M1).Text;
|
|
|
948 Msg2 : constant String_Ptr := Errors.Table (M2).Text;
|
|
|
949
|
|
|
950 Msg2_Len : constant Integer := Msg2'Length;
|
|
|
951 Msg1_Len : constant Integer := Msg1'Length;
|
|
|
952
|
|
|
953 begin
|
|
|
954 return
|
|
|
955 Msg1.all = Msg2.all
|
|
|
956 or else
|
|
|
957 (Msg1_Len - 10 > Msg2_Len
|
|
|
958 and then
|
|
|
959 Msg2.all = Msg1.all (1 .. Msg2_Len)
|
|
|
960 and then
|
|
|
961 Msg1 (Msg2_Len + 1 .. Msg2_Len + 10) = ", instance")
|
|
|
962 or else
|
|
|
963 (Msg2_Len - 10 > Msg1_Len
|
|
|
964 and then
|
|
|
965 Msg1.all = Msg2.all (1 .. Msg1_Len)
|
|
|
966 and then
|
|
|
967 Msg2 (Msg1_Len + 1 .. Msg1_Len + 10) = ", instance");
|
|
|
968 end Same_Error;
|
|
|
969
|
|
|
970 -------------------
|
|
|
971 -- Set_Msg_Blank --
|
|
|
972 -------------------
|
|
|
973
|
|
|
974 procedure Set_Msg_Blank is
|
|
|
975 begin
|
|
|
976 if Msglen > 0
|
|
|
977 and then Msg_Buffer (Msglen) /= ' '
|
|
|
978 and then Msg_Buffer (Msglen) /= '('
|
|
|
979 and then Msg_Buffer (Msglen) /= '-'
|
|
|
980 and then not Manual_Quote_Mode
|
|
|
981 then
|
|
|
982 Set_Msg_Char (' ');
|
|
|
983 end if;
|
|
|
984 end Set_Msg_Blank;
|
|
|
985
|
|
|
986 -------------------------------
|
|
|
987 -- Set_Msg_Blank_Conditional --
|
|
|
988 -------------------------------
|
|
|
989
|
|
|
990 procedure Set_Msg_Blank_Conditional is
|
|
|
991 begin
|
|
|
992 if Msglen > 0
|
|
|
993 and then Msg_Buffer (Msglen) /= ' '
|
|
|
994 and then Msg_Buffer (Msglen) /= '('
|
|
|
995 and then Msg_Buffer (Msglen) /= '"'
|
|
|
996 and then not Manual_Quote_Mode
|
|
|
997 then
|
|
|
998 Set_Msg_Char (' ');
|
|
|
999 end if;
|
|
|
1000 end Set_Msg_Blank_Conditional;
|
|
|
1001
|
|
|
1002 ------------------
|
|
|
1003 -- Set_Msg_Char --
|
|
|
1004 ------------------
|
|
|
1005
|
|
|
1006 procedure Set_Msg_Char (C : Character) is
|
|
|
1007 begin
|
|
|
1008
|
|
|
1009 -- The check for message buffer overflow is needed to deal with cases
|
|
|
1010 -- where insertions get too long (in particular a child unit name can
|
|
|
1011 -- be very long).
|
|
|
1012
|
|
|
1013 if Msglen < Max_Msg_Length then
|
|
|
1014 Msglen := Msglen + 1;
|
|
|
1015 Msg_Buffer (Msglen) := C;
|
|
|
1016 end if;
|
|
|
1017 end Set_Msg_Char;
|
|
|
1018
|
|
|
1019 ---------------------------------
|
|
|
1020 -- Set_Msg_Insertion_File_Name --
|
|
|
1021 ---------------------------------
|
|
|
1022
|
|
|
1023 procedure Set_Msg_Insertion_File_Name is
|
|
|
1024 begin
|
|
|
1025 if Error_Msg_File_1 = No_File then
|
|
|
1026 null;
|
|
|
1027
|
|
|
1028 elsif Error_Msg_File_1 = Error_File_Name then
|
|
|
1029 Set_Msg_Blank;
|
|
|
1030 Set_Msg_Str ("<error>");
|
|
|
1031
|
|
|
1032 else
|
|
|
1033 Set_Msg_Blank;
|
|
|
1034 Get_Name_String (Error_Msg_File_1);
|
|
|
1035 Set_Msg_Quote;
|
|
|
1036 Set_Msg_Name_Buffer;
|
|
|
1037 Set_Msg_Quote;
|
|
|
1038 end if;
|
|
|
1039
|
|
|
1040 -- The following assignments ensure that the second and third {
|
|
|
1041 -- insertion characters will correspond to the Error_Msg_File_2 and
|
|
|
1042 -- Error_Msg_File_3 values and We suppress possible validity checks in
|
|
|
1043 -- case operating in -gnatVa mode, and Error_Msg_File_2 or
|
|
|
1044 -- Error_Msg_File_3 is not needed and has not been set.
|
|
|
1045
|
|
|
1046 declare
|
|
|
1047 pragma Suppress (Range_Check);
|
|
|
1048 begin
|
|
|
1049 Error_Msg_File_1 := Error_Msg_File_2;
|
|
|
1050 Error_Msg_File_2 := Error_Msg_File_3;
|
|
|
1051 end;
|
|
|
1052 end Set_Msg_Insertion_File_Name;
|
|
|
1053
|
|
|
1054 -----------------------------------
|
|
|
1055 -- Set_Msg_Insertion_Line_Number --
|
|
|
1056 -----------------------------------
|
|
|
1057
|
|
|
1058 procedure Set_Msg_Insertion_Line_Number (Loc, Flag : Source_Ptr) is
|
|
|
1059 Sindex_Loc : Source_File_Index;
|
|
|
1060 Sindex_Flag : Source_File_Index;
|
|
|
1061 Fname : File_Name_Type;
|
|
|
1062 Int_File : Boolean;
|
|
|
1063
|
|
|
1064 procedure Set_At;
|
|
|
1065 -- Outputs "at " unless last characters in buffer are " from ". Certain
|
|
|
1066 -- messages read better with from than at.
|
|
|
1067
|
|
|
1068 ------------
|
|
|
1069 -- Set_At --
|
|
|
1070 ------------
|
|
|
1071
|
|
|
1072 procedure Set_At is
|
|
|
1073 begin
|
|
|
1074 if Msglen < 6
|
|
|
1075 or else Msg_Buffer (Msglen - 5 .. Msglen) /= " from "
|
|
|
1076 then
|
|
|
1077 Set_Msg_Str ("at ");
|
|
|
1078 end if;
|
|
|
1079 end Set_At;
|
|
|
1080
|
|
|
1081 -- Start of processing for Set_Msg_Insertion_Line_Number
|
|
|
1082
|
|
|
1083 begin
|
|
|
1084 Set_Msg_Blank;
|
|
|
1085
|
|
|
1086 if Loc = No_Location then
|
|
|
1087 Set_At;
|
|
|
1088 Set_Msg_Str ("unknown location");
|
|
|
1089
|
|
|
1090 elsif Loc = System_Location then
|
|
|
1091 Set_Msg_Str ("in package System");
|
|
|
1092 Set_Msg_Insertion_Run_Time_Name;
|
|
|
1093
|
|
|
1094 elsif Loc = Standard_Location then
|
|
|
1095 Set_Msg_Str ("in package Standard");
|
|
|
1096
|
|
|
1097 elsif Loc = Standard_ASCII_Location then
|
|
|
1098 Set_Msg_Str ("in package Standard.ASCII");
|
|
|
1099
|
|
|
1100 else
|
|
|
1101 -- Add "at file-name:" if reference is to other than the source
|
|
|
1102 -- file in which the error message is placed. Note that we check
|
|
|
1103 -- full file names, rather than just the source indexes, to
|
|
|
1104 -- deal with generic instantiations from the current file.
|
|
|
1105
|
|
|
1106 Sindex_Loc := Get_Source_File_Index (Loc);
|
|
|
1107 Sindex_Flag := Get_Source_File_Index (Flag);
|
|
|
1108
|
|
|
1109 if Full_File_Name (Sindex_Loc) /= Full_File_Name (Sindex_Flag) then
|
|
|
1110 Set_At;
|
|
|
1111 Fname := Reference_Name (Get_Source_File_Index (Loc));
|
|
|
1112 Int_File := Is_Internal_File_Name (Fname);
|
|
|
1113 Get_Name_String (Fname);
|
|
|
1114 Set_Msg_Name_Buffer;
|
|
|
1115
|
|
|
1116 if not (Int_File and Debug_Flag_Dot_K) then
|
|
|
1117 Set_Msg_Char (':');
|
|
|
1118 Set_Msg_Int (Int (Get_Logical_Line_Number (Loc)));
|
|
|
1119 end if;
|
|
|
1120
|
|
|
1121 -- If in current file, add text "at line "
|
|
|
1122
|
|
|
1123 else
|
|
|
1124 Set_At;
|
|
|
1125 Set_Msg_Str ("line ");
|
|
|
1126 Int_File := False;
|
|
|
1127 Set_Msg_Int (Int (Get_Logical_Line_Number (Loc)));
|
|
|
1128 end if;
|
|
|
1129
|
|
|
1130 -- Deal with the instantiation case. We may have a reference to,
|
|
|
1131 -- e.g. a type, that is declared within a generic template, and
|
|
|
1132 -- what we are really referring to is the occurrence in an instance.
|
|
|
1133 -- In this case, the line number of the instantiation is also of
|
|
|
1134 -- interest, and we add a notation:
|
|
|
1135
|
|
|
1136 -- , instance at xxx
|
|
|
1137
|
|
|
1138 -- where xxx is a line number output using this same routine (and
|
|
|
1139 -- the recursion can go further if the instantiation is itself in
|
|
|
1140 -- a generic template).
|
|
|
1141
|
|
|
1142 -- The flag location passed to us in this situation is indeed the
|
|
|
1143 -- line number within the template, but as described in Sinput.L
|
|
|
1144 -- (file sinput-l.ads, section "Handling Generic Instantiations")
|
|
|
1145 -- we can retrieve the location of the instantiation itself from
|
|
|
1146 -- this flag location value.
|
|
|
1147
|
|
|
1148 -- Note: this processing is suppressed if Suppress_Instance_Location
|
|
|
1149 -- is set True. This is used to prevent redundant annotations of the
|
|
|
1150 -- location of the instantiation in the case where we are placing
|
|
|
1151 -- the messages on the instantiation in any case.
|
|
|
1152
|
|
|
1153 if Instantiation (Sindex_Loc) /= No_Location
|
|
|
1154 and then not Suppress_Instance_Location
|
|
|
1155 then
|
|
|
1156 Set_Msg_Str (", instance ");
|
|
|
1157 Set_Msg_Insertion_Line_Number (Instantiation (Sindex_Loc), Flag);
|
|
|
1158 end if;
|
|
|
1159 end if;
|
|
|
1160 end Set_Msg_Insertion_Line_Number;
|
|
|
1161
|
|
|
1162 ----------------------------
|
|
|
1163 -- Set_Msg_Insertion_Name --
|
|
|
1164 ----------------------------
|
|
|
1165
|
|
|
1166 procedure Set_Msg_Insertion_Name is
|
|
|
1167 begin
|
|
|
1168 if Error_Msg_Name_1 = No_Name then
|
|
|
1169 null;
|
|
|
1170
|
|
|
1171 elsif Error_Msg_Name_1 = Error_Name then
|
|
|
1172 Set_Msg_Blank;
|
|
|
1173 Set_Msg_Str ("<error>");
|
|
|
1174
|
|
|
1175 else
|
|
|
1176 Set_Msg_Blank_Conditional;
|
|
|
1177 Get_Unqualified_Decoded_Name_String (Error_Msg_Name_1);
|
|
|
1178
|
|
|
1179 -- Remove %s or %b at end. These come from unit names. If the
|
|
|
1180 -- caller wanted the (unit) or (body), then they would have used
|
|
|
1181 -- the $ insertion character. Certainly no error message should
|
|
|
1182 -- ever have %b or %s explicitly occurring.
|
|
|
1183
|
|
|
1184 if Name_Len > 2
|
|
|
1185 and then Name_Buffer (Name_Len - 1) = '%'
|
|
|
1186 and then (Name_Buffer (Name_Len) = 'b'
|
|
|
1187 or else
|
|
|
1188 Name_Buffer (Name_Len) = 's')
|
|
|
1189 then
|
|
|
1190 Name_Len := Name_Len - 2;
|
|
|
1191 end if;
|
|
|
1192
|
|
|
1193 -- Remove upper case letter at end, again, we should not be getting
|
|
|
1194 -- such names, and what we hope is that the remainder makes sense.
|
|
|
1195
|
|
|
1196 if Name_Len > 1 and then Name_Buffer (Name_Len) in 'A' .. 'Z' then
|
|
|
1197 Name_Len := Name_Len - 1;
|
|
|
1198 end if;
|
|
|
1199
|
|
|
1200 -- If operator name or character literal name, just print it as is
|
|
|
1201 -- Also print as is if it ends in a right paren (case of x'val(nnn))
|
|
|
1202
|
|
|
1203 if Name_Buffer (1) = '"'
|
|
|
1204 or else Name_Buffer (1) = '''
|
|
|
1205 or else Name_Buffer (Name_Len) = ')'
|
|
|
1206 then
|
|
|
1207 Set_Msg_Name_Buffer;
|
|
|
1208
|
|
|
1209 -- Else output with surrounding quotes in proper casing mode
|
|
|
1210
|
|
|
1211 else
|
|
|
1212 Set_Casing (Identifier_Casing (Flag_Source));
|
|
|
1213 Set_Msg_Quote;
|
|
|
1214 Set_Msg_Name_Buffer;
|
|
|
1215 Set_Msg_Quote;
|
|
|
1216 end if;
|
|
|
1217 end if;
|
|
|
1218
|
|
|
1219 -- The following assignments ensure that the second and third percent
|
|
|
1220 -- insertion characters will correspond to the Error_Msg_Name_2 and
|
|
|
1221 -- Error_Msg_Name_3 as required. We suppress possible validity checks in
|
|
|
1222 -- case operating in -gnatVa mode, and Error_Msg_Name_1/2 is not needed
|
|
|
1223 -- and has not been set.
|
|
|
1224
|
|
|
1225 declare
|
|
|
1226 pragma Suppress (Range_Check);
|
|
|
1227 begin
|
|
|
1228 Error_Msg_Name_1 := Error_Msg_Name_2;
|
|
|
1229 Error_Msg_Name_2 := Error_Msg_Name_3;
|
|
|
1230 end;
|
|
|
1231 end Set_Msg_Insertion_Name;
|
|
|
1232
|
|
|
1233 ------------------------------------
|
|
|
1234 -- Set_Msg_Insertion_Name_Literal --
|
|
|
1235 ------------------------------------
|
|
|
1236
|
|
|
1237 procedure Set_Msg_Insertion_Name_Literal is
|
|
|
1238 begin
|
|
|
1239 if Error_Msg_Name_1 = No_Name then
|
|
|
1240 null;
|
|
|
1241
|
|
|
1242 elsif Error_Msg_Name_1 = Error_Name then
|
|
|
1243 Set_Msg_Blank;
|
|
|
1244 Set_Msg_Str ("<error>");
|
|
|
1245
|
|
|
1246 else
|
|
|
1247 Set_Msg_Blank;
|
|
|
1248 Get_Name_String (Error_Msg_Name_1);
|
|
|
1249 Set_Msg_Quote;
|
|
|
1250 Set_Msg_Name_Buffer;
|
|
|
1251 Set_Msg_Quote;
|
|
|
1252 end if;
|
|
|
1253
|
|
|
1254 -- The following assignments ensure that the second and third % or %%
|
|
|
1255 -- insertion characters will correspond to the Error_Msg_Name_2 and
|
|
|
1256 -- Error_Msg_Name_3 values and We suppress possible validity checks in
|
|
|
1257 -- case operating in -gnatVa mode, and Error_Msg_Name_2 or
|
|
|
1258 -- Error_Msg_Name_3 is not needed and has not been set.
|
|
|
1259
|
|
|
1260 declare
|
|
|
1261 pragma Suppress (Range_Check);
|
|
|
1262 begin
|
|
|
1263 Error_Msg_Name_1 := Error_Msg_Name_2;
|
|
|
1264 Error_Msg_Name_2 := Error_Msg_Name_3;
|
|
|
1265 end;
|
|
|
1266 end Set_Msg_Insertion_Name_Literal;
|
|
|
1267
|
|
|
1268 -------------------------------------
|
|
|
1269 -- Set_Msg_Insertion_Reserved_Name --
|
|
|
1270 -------------------------------------
|
|
|
1271
|
|
|
1272 procedure Set_Msg_Insertion_Reserved_Name is
|
|
|
1273 begin
|
|
|
1274 Set_Msg_Blank_Conditional;
|
|
|
1275 Get_Name_String (Error_Msg_Name_1);
|
|
|
1276 Set_Msg_Quote;
|
|
|
1277 Set_Casing (Keyword_Casing (Flag_Source), All_Lower_Case);
|
|
|
1278 Set_Msg_Name_Buffer;
|
|
|
1279 Set_Msg_Quote;
|
|
|
1280 end Set_Msg_Insertion_Reserved_Name;
|
|
|
1281
|
|
|
1282 -------------------------------------
|
|
|
1283 -- Set_Msg_Insertion_Reserved_Word --
|
|
|
1284 -------------------------------------
|
|
|
1285
|
|
|
1286 procedure Set_Msg_Insertion_Reserved_Word
|
|
|
1287 (Text : String;
|
|
|
1288 J : in out Integer)
|
|
|
1289 is
|
|
|
1290 begin
|
|
|
1291 Set_Msg_Blank_Conditional;
|
|
|
1292 Name_Len := 0;
|
|
|
1293
|
|
|
1294 while J <= Text'Last and then Text (J) in 'A' .. 'Z' loop
|
|
|
1295 Add_Char_To_Name_Buffer (Text (J));
|
|
|
1296 J := J + 1;
|
|
|
1297 end loop;
|
|
|
1298
|
|
|
1299 -- Here is where we make the special exception for RM
|
|
|
1300
|
|
|
1301 if Name_Len = 2 and then Name_Buffer (1 .. 2) = "RM" then
|
|
|
1302 Set_Msg_Name_Buffer;
|
|
|
1303
|
|
|
1304 -- We make a similar exception for SPARK
|
|
|
1305
|
|
|
1306 elsif Name_Len = 5 and then Name_Buffer (1 .. 5) = "SPARK" then
|
|
|
1307 Set_Msg_Name_Buffer;
|
|
|
1308
|
|
|
1309 -- Neither RM nor SPARK: case appropriately and add surrounding quotes
|
|
|
1310
|
|
|
1311 else
|
|
|
1312 Set_Casing (Keyword_Casing (Flag_Source), All_Lower_Case);
|
|
|
1313 Set_Msg_Quote;
|
|
|
1314 Set_Msg_Name_Buffer;
|
|
|
1315 Set_Msg_Quote;
|
|
|
1316 end if;
|
|
|
1317 end Set_Msg_Insertion_Reserved_Word;
|
|
|
1318
|
|
|
1319 -------------------------------------
|
|
|
1320 -- Set_Msg_Insertion_Run_Time_Name --
|
|
|
1321 -------------------------------------
|
|
|
1322
|
|
|
1323 procedure Set_Msg_Insertion_Run_Time_Name is
|
|
|
1324 begin
|
|
|
1325 if Targparm.Run_Time_Name_On_Target /= No_Name then
|
|
|
1326 Set_Msg_Blank_Conditional;
|
|
|
1327 Set_Msg_Char ('(');
|
|
|
1328 Get_Name_String (Targparm.Run_Time_Name_On_Target);
|
|
|
1329 Set_Casing (Mixed_Case);
|
|
|
1330 Set_Msg_Str (Name_Buffer (1 .. Name_Len));
|
|
|
1331 Set_Msg_Char (')');
|
|
|
1332 end if;
|
|
|
1333 end Set_Msg_Insertion_Run_Time_Name;
|
|
|
1334
|
|
|
1335 ----------------------------
|
|
|
1336 -- Set_Msg_Insertion_Uint --
|
|
|
1337 ----------------------------
|
|
|
1338
|
|
|
1339 procedure Set_Msg_Insertion_Uint is
|
|
|
1340 begin
|
|
|
1341 Set_Msg_Blank;
|
|
|
1342 UI_Image (Error_Msg_Uint_1);
|
|
|
1343
|
|
|
1344 for J in 1 .. UI_Image_Length loop
|
|
|
1345 Set_Msg_Char (UI_Image_Buffer (J));
|
|
|
1346 end loop;
|
|
|
1347
|
|
|
1348 -- The following assignment ensures that a second caret insertion
|
|
|
1349 -- character will correspond to the Error_Msg_Uint_2 parameter. We
|
|
|
1350 -- suppress possible validity checks in case operating in -gnatVa mode,
|
|
|
1351 -- and Error_Msg_Uint_2 is not needed and has not been set.
|
|
|
1352
|
|
|
1353 declare
|
|
|
1354 pragma Suppress (Range_Check);
|
|
|
1355 begin
|
|
|
1356 Error_Msg_Uint_1 := Error_Msg_Uint_2;
|
|
|
1357 end;
|
|
|
1358 end Set_Msg_Insertion_Uint;
|
|
|
1359
|
|
|
1360 -----------------
|
|
|
1361 -- Set_Msg_Int --
|
|
|
1362 -----------------
|
|
|
1363
|
|
|
1364 procedure Set_Msg_Int (Line : Int) is
|
|
|
1365 begin
|
|
|
1366 if Line > 9 then
|
|
|
1367 Set_Msg_Int (Line / 10);
|
|
|
1368 end if;
|
|
|
1369
|
|
|
1370 Set_Msg_Char (Character'Val (Character'Pos ('0') + (Line rem 10)));
|
|
|
1371 end Set_Msg_Int;
|
|
|
1372
|
|
|
1373 -------------------------
|
|
|
1374 -- Set_Msg_Name_Buffer --
|
|
|
1375 -------------------------
|
|
|
1376
|
|
|
1377 procedure Set_Msg_Name_Buffer is
|
|
|
1378 begin
|
|
|
1379 Set_Msg_Str (Name_Buffer (1 .. Name_Len));
|
|
|
1380 end Set_Msg_Name_Buffer;
|
|
|
1381
|
|
|
1382 -------------------
|
|
|
1383 -- Set_Msg_Quote --
|
|
|
1384 -------------------
|
|
|
1385
|
|
|
1386 procedure Set_Msg_Quote is
|
|
|
1387 begin
|
|
|
1388 if not Manual_Quote_Mode then
|
|
|
1389 Set_Msg_Char ('"');
|
|
|
1390 end if;
|
|
|
1391 end Set_Msg_Quote;
|
|
|
1392
|
|
|
1393 -----------------
|
|
|
1394 -- Set_Msg_Str --
|
|
|
1395 -----------------
|
|
|
1396
|
|
|
1397 procedure Set_Msg_Str (Text : String) is
|
|
|
1398 begin
|
|
|
1399 -- Do replacement for special x'Class aspect names
|
|
|
1400
|
|
|
1401 if Text = "_Pre" then
|
|
|
1402 Set_Msg_Str ("Pre'Class");
|
|
|
1403
|
|
|
1404 elsif Text = "_Post" then
|
|
|
1405 Set_Msg_Str ("Post'Class");
|
|
|
1406
|
|
|
1407 elsif Text = "_Type_Invariant" then
|
|
|
1408 Set_Msg_Str ("Type_Invariant'Class");
|
|
|
1409
|
|
|
1410 elsif Text = "_pre" then
|
|
|
1411 Set_Msg_Str ("pre'class");
|
|
|
1412
|
|
|
1413 elsif Text = "_post" then
|
|
|
1414 Set_Msg_Str ("post'class");
|
|
|
1415
|
|
|
1416 elsif Text = "_type_invariant" then
|
|
|
1417 Set_Msg_Str ("type_invariant'class");
|
|
|
1418
|
|
|
1419 elsif Text = "_PRE" then
|
|
|
1420 Set_Msg_Str ("PRE'CLASS");
|
|
|
1421
|
|
|
1422 elsif Text = "_POST" then
|
|
|
1423 Set_Msg_Str ("POST'CLASS");
|
|
|
1424
|
|
|
1425 elsif Text = "_TYPE_INVARIANT" then
|
|
|
1426 Set_Msg_Str ("TYPE_INVARIANT'CLASS");
|
|
|
1427
|
|
|
1428 -- Normal case with no replacement
|
|
|
1429
|
|
|
1430 else
|
|
|
1431 for J in Text'Range loop
|
|
|
1432 Set_Msg_Char (Text (J));
|
|
|
1433 end loop;
|
|
|
1434 end if;
|
|
|
1435 end Set_Msg_Str;
|
|
|
1436
|
|
|
1437 ------------------------------
|
|
|
1438 -- Set_Next_Non_Deleted_Msg --
|
|
|
1439 ------------------------------
|
|
|
1440
|
|
|
1441 procedure Set_Next_Non_Deleted_Msg (E : in out Error_Msg_Id) is
|
|
|
1442 begin
|
|
|
1443 if E = No_Error_Msg then
|
|
|
1444 return;
|
|
|
1445
|
|
|
1446 else
|
|
|
1447 loop
|
|
|
1448 E := Errors.Table (E).Next;
|
|
|
1449 exit when E = No_Error_Msg or else not Errors.Table (E).Deleted;
|
|
|
1450 end loop;
|
|
|
1451 end if;
|
|
|
1452 end Set_Next_Non_Deleted_Msg;
|
|
|
1453
|
|
|
1454 ------------------------------
|
|
|
1455 -- Set_Specific_Warning_Off --
|
|
|
1456 ------------------------------
|
|
|
1457
|
|
|
1458 procedure Set_Specific_Warning_Off
|
|
|
1459 (Loc : Source_Ptr;
|
|
|
1460 Msg : String;
|
|
|
1461 Reason : String_Id;
|
|
|
1462 Config : Boolean;
|
|
|
1463 Used : Boolean := False)
|
|
|
1464 is
|
|
|
1465 begin
|
|
|
1466 Specific_Warnings.Append
|
|
|
1467 ((Start => Loc,
|
|
|
1468 Msg => new String'(Msg),
|
|
|
1469 Stop => Source_Last (Get_Source_File_Index (Loc)),
|
|
|
1470 Reason => Reason,
|
|
|
1471 Open => True,
|
|
|
1472 Used => Used,
|
|
|
1473 Config => Config));
|
|
|
1474 end Set_Specific_Warning_Off;
|
|
|
1475
|
|
|
1476 -----------------------------
|
|
|
1477 -- Set_Specific_Warning_On --
|
|
|
1478 -----------------------------
|
|
|
1479
|
|
|
1480 procedure Set_Specific_Warning_On
|
|
|
1481 (Loc : Source_Ptr;
|
|
|
1482 Msg : String;
|
|
|
1483 Err : out Boolean)
|
|
|
1484 is
|
|
|
1485 begin
|
|
|
1486 for J in 1 .. Specific_Warnings.Last loop
|
|
|
1487 declare
|
|
|
1488 SWE : Specific_Warning_Entry renames Specific_Warnings.Table (J);
|
|
|
1489
|
|
|
1490 begin
|
|
|
1491 if Msg = SWE.Msg.all
|
|
|
1492 and then Loc > SWE.Start
|
|
|
1493 and then SWE.Open
|
|
|
1494 and then Get_Source_File_Index (SWE.Start) =
|
|
|
1495 Get_Source_File_Index (Loc)
|
|
|
1496 then
|
|
|
1497 SWE.Stop := Loc;
|
|
|
1498 SWE.Open := False;
|
|
|
1499 Err := False;
|
|
|
1500
|
|
|
1501 -- If a config pragma is specifically cancelled, consider
|
|
|
1502 -- that it is no longer active as a configuration pragma.
|
|
|
1503
|
|
|
1504 SWE.Config := False;
|
|
|
1505 return;
|
|
|
1506 end if;
|
|
|
1507 end;
|
|
|
1508 end loop;
|
|
|
1509
|
|
|
1510 Err := True;
|
|
|
1511 end Set_Specific_Warning_On;
|
|
|
1512
|
|
|
1513 ---------------------------
|
|
|
1514 -- Set_Warnings_Mode_Off --
|
|
|
1515 ---------------------------
|
|
|
1516
|
|
|
1517 procedure Set_Warnings_Mode_Off (Loc : Source_Ptr; Reason : String_Id) is
|
|
|
1518 begin
|
|
|
1519 -- Don't bother with entries from instantiation copies, since we will
|
|
|
1520 -- already have a copy in the template, which is what matters.
|
|
|
1521
|
|
|
1522 if Instantiation (Get_Source_File_Index (Loc)) /= No_Location then
|
|
|
1523 return;
|
|
|
1524 end if;
|
|
|
1525
|
|
|
1526 -- If all warnings are suppressed by command line switch, this can
|
|
|
1527 -- be ignored, unless we are in GNATprove_Mode which requires pragma
|
|
|
1528 -- Warnings to be stored for the formal verification backend.
|
|
|
1529
|
|
|
1530 if Warning_Mode = Suppress
|
|
|
1531 and then not GNATprove_Mode
|
|
|
1532 then
|
|
|
1533 return;
|
|
|
1534 end if;
|
|
|
1535
|
|
|
1536 -- If last entry in table already covers us, this is a redundant pragma
|
|
|
1537 -- Warnings (Off) and can be ignored.
|
|
|
1538
|
|
|
1539 if Warnings.Last >= Warnings.First
|
|
|
1540 and then Warnings.Table (Warnings.Last).Start <= Loc
|
|
|
1541 and then Loc <= Warnings.Table (Warnings.Last).Stop
|
|
|
1542 then
|
|
|
1543 return;
|
|
|
1544 end if;
|
|
|
1545
|
|
|
1546 -- If none of those special conditions holds, establish a new entry,
|
|
|
1547 -- extending from the location of the pragma to the end of the current
|
|
|
1548 -- source file. This ending point will be adjusted by a subsequent
|
|
|
1549 -- corresponding pragma Warnings (On).
|
|
|
1550
|
|
|
1551 Warnings.Append
|
|
|
1552 ((Start => Loc,
|
|
|
1553 Stop => Source_Last (Get_Source_File_Index (Loc)),
|
|
|
1554 Reason => Reason));
|
|
|
1555 end Set_Warnings_Mode_Off;
|
|
|
1556
|
|
|
1557 --------------------------
|
|
|
1558 -- Set_Warnings_Mode_On --
|
|
|
1559 --------------------------
|
|
|
1560
|
|
|
1561 procedure Set_Warnings_Mode_On (Loc : Source_Ptr) is
|
|
|
1562 begin
|
|
|
1563 -- Don't bother with entries from instantiation copies, since we will
|
|
|
1564 -- already have a copy in the template, which is what matters.
|
|
|
1565
|
|
|
1566 if Instantiation (Get_Source_File_Index (Loc)) /= No_Location then
|
|
|
1567 return;
|
|
|
1568 end if;
|
|
|
1569
|
|
|
1570 -- If all warnings are suppressed by command line switch, this can
|
|
|
1571 -- be ignored, unless we are in GNATprove_Mode which requires pragma
|
|
|
1572 -- Warnings to be stored for the formal verification backend.
|
|
|
1573
|
|
|
1574 if Warning_Mode = Suppress
|
|
|
1575 and then not GNATprove_Mode
|
|
|
1576 then
|
|
|
1577 return;
|
|
|
1578 end if;
|
|
|
1579
|
|
|
1580 -- If the last entry in the warnings table covers this pragma, then
|
|
|
1581 -- we adjust the end point appropriately.
|
|
|
1582
|
|
|
1583 if Warnings.Last >= Warnings.First
|
|
|
1584 and then Warnings.Table (Warnings.Last).Start <= Loc
|
|
|
1585 and then Loc <= Warnings.Table (Warnings.Last).Stop
|
|
|
1586 then
|
|
|
1587 Warnings.Table (Warnings.Last).Stop := Loc;
|
|
|
1588 end if;
|
|
|
1589 end Set_Warnings_Mode_On;
|
|
|
1590
|
|
|
1591 --------------------------------
|
|
|
1592 -- Validate_Specific_Warnings --
|
|
|
1593 --------------------------------
|
|
|
1594
|
|
|
1595 procedure Validate_Specific_Warnings (Eproc : Error_Msg_Proc) is
|
|
|
1596 begin
|
|
|
1597 if not Warn_On_Warnings_Off then
|
|
|
1598 return;
|
|
|
1599 end if;
|
|
|
1600
|
|
|
1601 for J in Specific_Warnings.First .. Specific_Warnings.Last loop
|
|
|
1602 declare
|
|
|
1603 SWE : Specific_Warning_Entry renames Specific_Warnings.Table (J);
|
|
|
1604
|
|
|
1605 begin
|
|
|
1606 if not SWE.Config then
|
|
|
1607
|
|
|
1608 -- Warn for unmatched Warnings (Off, ...)
|
|
|
1609
|
|
|
1610 if SWE.Open then
|
|
|
1611 Eproc.all
|
|
|
1612 ("?W?pragma Warnings Off with no matching Warnings On",
|
|
|
1613 SWE.Start);
|
|
|
1614
|
|
|
1615 -- Warn for ineffective Warnings (Off, ..)
|
|
|
1616
|
|
|
1617 elsif not SWE.Used
|
|
|
1618
|
|
|
1619 -- Do not issue this warning for -Wxxx messages since the
|
|
|
1620 -- back-end doesn't report the information. Note that there
|
|
|
1621 -- is always an asterisk at the start of every message.
|
|
|
1622
|
|
|
1623 and then not
|
|
|
1624 (SWE.Msg'Length > 3 and then SWE.Msg (2 .. 3) = "-W")
|
|
|
1625 then
|
|
|
1626 Eproc.all
|
|
|
1627 ("?W?no warning suppressed by this pragma", SWE.Start);
|
|
|
1628 end if;
|
|
|
1629 end if;
|
|
|
1630 end;
|
|
|
1631 end loop;
|
|
|
1632 end Validate_Specific_Warnings;
|
|
|
1633
|
|
|
1634 -------------------------------------
|
|
|
1635 -- Warning_Specifically_Suppressed --
|
|
|
1636 -------------------------------------
|
|
|
1637
|
|
|
1638 function Warning_Specifically_Suppressed
|
|
|
1639 (Loc : Source_Ptr;
|
|
|
1640 Msg : String_Ptr;
|
|
|
1641 Tag : String := "") return String_Id
|
|
|
1642 is
|
|
|
1643 begin
|
|
|
1644 -- Loop through specific warning suppression entries
|
|
|
1645
|
|
|
1646 for J in Specific_Warnings.First .. Specific_Warnings.Last loop
|
|
|
1647 declare
|
|
|
1648 SWE : Specific_Warning_Entry renames Specific_Warnings.Table (J);
|
|
|
1649
|
|
|
1650 begin
|
|
|
1651 -- Pragma applies if it is a configuration pragma, or if the
|
|
|
1652 -- location is in range of a specific non-configuration pragma.
|
|
|
1653
|
|
|
1654 if SWE.Config
|
|
|
1655 or else (SWE.Start <= Loc and then Loc <= SWE.Stop)
|
|
|
1656 then
|
|
|
1657 if Matches (Msg.all, SWE.Msg.all)
|
|
|
1658 or else Matches (Tag, SWE.Msg.all)
|
|
|
1659 then
|
|
|
1660 SWE.Used := True;
|
|
|
1661 return SWE.Reason;
|
|
|
1662 end if;
|
|
|
1663 end if;
|
|
|
1664 end;
|
|
|
1665 end loop;
|
|
|
1666
|
|
|
1667 return No_String;
|
|
|
1668 end Warning_Specifically_Suppressed;
|
|
|
1669
|
|
|
1670 ------------------------------
|
|
|
1671 -- Warning_Treated_As_Error --
|
|
|
1672 ------------------------------
|
|
|
1673
|
|
|
1674 function Warning_Treated_As_Error (Msg : String) return Boolean is
|
|
|
1675 begin
|
|
|
1676 for J in 1 .. Warnings_As_Errors_Count loop
|
|
|
1677 if Matches (Msg, Warnings_As_Errors (J).all) then
|
|
|
1678 return True;
|
|
|
1679 end if;
|
|
|
1680 end loop;
|
|
|
1681
|
|
|
1682 return False;
|
|
|
1683 end Warning_Treated_As_Error;
|
|
|
1684
|
|
|
1685 -------------------------
|
|
|
1686 -- Warnings_Suppressed --
|
|
|
1687 -------------------------
|
|
|
1688
|
|
|
1689 function Warnings_Suppressed (Loc : Source_Ptr) return String_Id is
|
|
|
1690 begin
|
|
|
1691 -- Loop through table of ON/OFF warnings
|
|
|
1692
|
|
|
1693 for J in Warnings.First .. Warnings.Last loop
|
|
|
1694 if Warnings.Table (J).Start <= Loc
|
|
|
1695 and then Loc <= Warnings.Table (J).Stop
|
|
|
1696 then
|
|
|
1697 return Warnings.Table (J).Reason;
|
|
|
1698 end if;
|
|
|
1699 end loop;
|
|
|
1700
|
|
|
1701 if Warning_Mode = Suppress then
|
|
|
1702 return Null_String_Id;
|
|
|
1703 else
|
|
|
1704 return No_String;
|
|
|
1705 end if;
|
|
|
1706 end Warnings_Suppressed;
|
|
|
1707
|
|
|
1708 end Erroutc;
|
