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