1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
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. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
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
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;
40 with Output; use Output;
41 with Sinput; use Sinput;
42 with Snames; use Snames;
43 with Stringt; use Stringt;
45 with Uintp; use Uintp;
46 with Widechar; use Widechar;
48 package body Erroutc is
50 -----------------------
51 -- Local Subprograms --
52 -----------------------
54 function Matches (S : String; P : String) return Boolean;
55 -- Returns true if the String S patches the pattern P, which can contain
56 -- wildcard chars (*). The entire pattern must match the entire string.
57 -- Case is ignored in the comparison (so X matches x).
59 function Sloc_In_Range (Loc, Start, Stop : Source_Ptr) return Boolean;
60 -- Return whether Loc is in the range Start .. Stop, taking instantiation
61 -- locations of Loc into account. This is useful for suppressing warnings
62 -- from generic instantiations by using pragma Warnings around generic
63 -- instances, as needed in GNATprove.
69 procedure Add_Class is
74 Get_Name_String (Name_Class);
75 Set_Casing (Identifier_Casing (Flag_Source));
80 ----------------------
81 -- Buffer_Ends_With --
82 ----------------------
84 function Buffer_Ends_With (C : Character) return Boolean is
86 return Msglen > 0 and then Msg_Buffer (Msglen) = C;
89 function Buffer_Ends_With (S : String) return Boolean is
90 Len : constant Natural := S'Length;
93 and then Msg_Buffer (Msglen - Len) = ' '
94 and then Msg_Buffer (Msglen - Len + 1 .. Msglen) = S;
101 procedure Buffer_Remove (C : Character) is
103 if Buffer_Ends_With (C) then
104 Msglen := Msglen - 1;
108 procedure Buffer_Remove (S : String) is
110 if Buffer_Ends_With (S) then
111 Msglen := Msglen - S'Length;
115 -----------------------------
116 -- Check_Duplicate_Message --
117 -----------------------------
119 procedure Check_Duplicate_Message (M1, M2 : Error_Msg_Id) is
120 L1, L2 : Error_Msg_Id;
121 N1, N2 : Error_Msg_Id;
123 procedure Delete_Msg (Delete, Keep : Error_Msg_Id);
124 -- Called to delete message Delete, keeping message Keep. Marks msg
125 -- Delete and all its continuations with deleted flag set to True.
126 -- Also makes sure that for the error messages that are retained the
127 -- preferred message is the one retained (we prefer the shorter one in
128 -- the case where one has an Instance tag). Note that we always know
129 -- that Keep has at least as many continuations as Delete (since we
130 -- always delete the shorter sequence).
136 procedure Delete_Msg (Delete, Keep : Error_Msg_Id) is
144 Errors.Table (D).Deleted := True;
146 -- Adjust error message count
148 if Errors.Table (D).Info then
150 if Errors.Table (D).Warn then
151 Warning_Info_Messages := Warning_Info_Messages - 1;
152 Warnings_Detected := Warnings_Detected - 1;
154 Report_Info_Messages := Report_Info_Messages - 1;
157 elsif Errors.Table (D).Warn or else Errors.Table (D).Style then
158 Warnings_Detected := Warnings_Detected - 1;
160 -- Note: we do not need to decrement Warnings_Treated_As_Errors
161 -- because this only gets incremented if we actually output the
162 -- message, which we won't do if we are deleting it here!
164 elsif Errors.Table (D).Check then
165 Check_Messages := Check_Messages - 1;
168 Total_Errors_Detected := Total_Errors_Detected - 1;
170 if Errors.Table (D).Serious then
171 Serious_Errors_Detected := Serious_Errors_Detected - 1;
175 -- Substitute shorter of the two error messages
177 if Errors.Table (K).Text'Length > Errors.Table (D).Text'Length then
178 Errors.Table (K).Text := Errors.Table (D).Text;
181 D := Errors.Table (D).Next;
182 K := Errors.Table (K).Next;
184 if D = No_Error_Msg or else not Errors.Table (D).Msg_Cont then
190 -- Start of processing for Check_Duplicate_Message
193 -- Both messages must be non-continuation messages and not deleted
195 if Errors.Table (M1).Msg_Cont
196 or else Errors.Table (M2).Msg_Cont
197 or else Errors.Table (M1).Deleted
198 or else Errors.Table (M2).Deleted
203 -- Definitely not equal if message text does not match
205 if not Same_Error (M1, M2) then
209 -- Same text. See if all continuations are also identical
215 N1 := Errors.Table (L1).Next;
216 N2 := Errors.Table (L2).Next;
218 -- If M1 continuations have run out, we delete M1, either the
219 -- messages have the same number of continuations, or M2 has
220 -- more and we prefer the one with more anyway.
222 if N1 = No_Error_Msg or else not Errors.Table (N1).Msg_Cont then
226 -- If M2 continuations have run out, we delete M2
228 elsif N2 = No_Error_Msg or else not Errors.Table (N2).Msg_Cont then
232 -- Otherwise see if continuations are the same, if not, keep both
233 -- sequences, a curious case, but better to keep everything.
235 elsif not Same_Error (N1, N2) then
238 -- If continuations are the same, continue scan
245 end Check_Duplicate_Message;
247 ------------------------
248 -- Compilation_Errors --
249 ------------------------
251 function Compilation_Errors return Boolean is
252 Warnings_Count : constant Int
253 := Warnings_Detected - Warning_Info_Messages;
255 if Total_Errors_Detected /= 0 then
258 elsif Warnings_Treated_As_Errors /= 0 then
261 -- We should never treat warnings that originate from a
262 -- Compile_Time_Warning pragma as an error. Warnings_Count is the sum
263 -- of both "normal" and Compile_Time_Warning warnings. This means
264 -- that there only is one or more non-Compile_Time_Warning warnings
265 -- if Warnings_Count is greater than
266 -- Count_Compile_Time_Pragma_Warnings.
267 elsif Warning_Mode = Treat_As_Error
268 and then Warnings_Count > Count_Compile_Time_Pragma_Warnings
274 end Compilation_Errors;
276 ----------------------------------------
277 -- Count_Compile_Time_Pragma_Warnings --
278 ----------------------------------------
280 function Count_Compile_Time_Pragma_Warnings return Int is
283 for J in 1 .. Errors.Last loop
285 if Errors.Table (J).Warn and Errors.Table (J).Compile_Time_Pragma
287 Result := Result + 1;
292 end Count_Compile_Time_Pragma_Warnings;
298 procedure Debug_Output (N : Node_Id) is
301 Write_Str ("*** following error message posted on node id = #");
312 procedure dmsg (Id : Error_Msg_Id) is
313 E : Error_Msg_Object renames Errors.Table (Id);
316 w ("Dumping error message, Id = ", Int (Id));
317 w (" Text = ", E.Text.all);
318 w (" Next = ", Int (E.Next));
319 w (" Prev = ", Int (E.Prev));
320 w (" Sfile = ", Int (E.Sfile));
324 Write_Location (E.Sptr);
329 Write_Location (E.Optr);
332 w (" Line = ", Int (E.Line));
333 w (" Col = ", Int (E.Col));
334 w (" Warn = ", E.Warn);
335 w (" Warn_Err = ", E.Warn_Err);
336 w (" Warn_Chr = '" & E.Warn_Chr & ''');
337 w (" Style = ", E.Style);
338 w (" Serious = ", E.Serious);
339 w (" Uncond = ", E.Uncond);
340 w (" Msg_Cont = ", E.Msg_Cont);
341 w (" Deleted = ", E.Deleted);
342 w (" Node = ", Int (E.Node));
351 function Get_Location (E : Error_Msg_Id) return Source_Ptr is
353 return Errors.Table (E).Sptr;
360 function Get_Msg_Id return Error_Msg_Id is
365 ---------------------
366 -- Get_Warning_Tag --
367 ---------------------
369 function Get_Warning_Tag (Id : Error_Msg_Id) return String is
370 Warn : constant Boolean := Errors.Table (Id).Warn;
371 Warn_Chr : constant Character := Errors.Table (Id).Warn_Chr;
373 if Warn and then Warn_Chr /= ' ' then
374 if Warn_Chr = '?' then
375 return "[enabled by default]";
376 elsif Warn_Chr = '*' then
377 return "[restriction warning]";
378 elsif Warn_Chr = '$' then
380 elsif Warn_Chr in 'a' .. 'z' then
381 return "[-gnatw" & Warn_Chr & ']';
382 else pragma Assert (Warn_Chr in 'A' .. 'Z');
383 return "[-gnatw." & Fold_Lower (Warn_Chr) & ']';
394 function Matches (S : String; P : String) return Boolean is
395 Slast : constant Natural := S'Last;
396 PLast : constant Natural := P'Last;
398 SPtr : Natural := S'First;
399 PPtr : Natural := P'First;
402 -- Loop advancing through characters of string and pattern
407 -- Return True if pattern is a single asterisk
409 if PPtr = PLast and then P (PPtr) = '*' then
412 -- Return True if both pattern and string exhausted
414 elsif PPtr > PLast and then SPtr > Slast then
417 -- Return False, if one exhausted and not the other
419 elsif PPtr > PLast or else SPtr > Slast then
422 -- Case where pattern starts with asterisk
424 elsif P (PPtr) = '*' then
426 -- Try all possible starting positions in S for match with the
427 -- remaining characters of the pattern. This is the recursive
428 -- call that implements the scanner backup.
430 for J in SPtr .. Slast loop
431 if Matches (S (J .. Slast), P (PPtr + 1 .. PLast)) then
438 -- Dealt with end of string and *, advance if we have a match
440 elsif Fold_Lower (S (SPtr)) = Fold_Lower (P (PPtr)) then
444 -- If first characters do not match, that's decisive
452 -----------------------
453 -- Output_Error_Msgs --
454 -----------------------
456 procedure Output_Error_Msgs (E : in out Error_Msg_Id) is
462 Mult_Flags : Boolean := False;
467 -- Skip deleted messages at start
469 if Errors.Table (S).Deleted then
470 Set_Next_Non_Deleted_Msg (S);
473 -- Figure out if we will place more than one error flag on this line
476 while T /= No_Error_Msg
477 and then Errors.Table (T).Line = Errors.Table (E).Line
478 and then Errors.Table (T).Sfile = Errors.Table (E).Sfile
480 if Errors.Table (T).Sptr > Errors.Table (E).Sptr then
484 Set_Next_Non_Deleted_Msg (T);
487 -- Output the error flags. The circuit here makes sure that the tab
488 -- characters in the original line are properly accounted for. The
489 -- eight blanks at the start are to match the line number.
491 if not Debug_Flag_2 then
493 P := Line_Start (Errors.Table (E).Sptr);
496 -- Loop through error messages for this line to place flags
499 while T /= No_Error_Msg
500 and then Errors.Table (T).Line = Errors.Table (E).Line
501 and then Errors.Table (T).Sfile = Errors.Table (E).Sfile
504 Src : Source_Buffer_Ptr
505 renames Source_Text (Errors.Table (T).Sfile);
508 -- Loop to output blanks till current flag position
510 while P < Errors.Table (T).Sptr loop
512 -- Horizontal tab case, just echo the tab
514 if Src (P) = ASCII.HT then
515 Write_Char (ASCII.HT);
518 -- Deal with wide character case, but don't include brackets
519 -- notation in this circuit, since we know that this will
520 -- display unencoded (no one encodes brackets notation).
523 and then Is_Start_Of_Wide_Char (Src, P)
528 -- Normal non-wide character case (or bracket)
536 -- Output flag (unless already output, this happens if more
537 -- than one error message occurs at the same flag position).
539 if P = Errors.Table (T).Sptr then
540 if (Flag_Num = 1 and then not Mult_Flags)
546 (Character'Val (Character'Pos ('0') + Flag_Num));
549 -- Skip past the corresponding source text character
551 -- Horizontal tab case, we output a flag at the tab position
552 -- so now we output a tab to match up with the text.
554 if Src (P) = ASCII.HT then
555 Write_Char (ASCII.HT);
558 -- Skip wide character other than left bracket
561 and then Is_Start_Of_Wide_Char (Src, P)
565 -- Skip normal non-wide character case (or bracket)
573 Set_Next_Non_Deleted_Msg (T);
574 Flag_Num := Flag_Num + 1;
580 -- Now output the error messages
583 while T /= No_Error_Msg
584 and then Errors.Table (T).Line = Errors.Table (E).Line
585 and then Errors.Table (T).Sfile = Errors.Table (E).Sfile
591 while Column < 74 loop
599 Set_Next_Non_Deleted_Msg (T);
603 end Output_Error_Msgs;
605 ------------------------
606 -- Output_Line_Number --
607 ------------------------
609 procedure Output_Line_Number (L : Logical_Line_Number) is
610 D : Int; -- next digit
611 C : Character; -- next character
612 Z : Boolean; -- flag for zero suppress
613 N, M : Int; -- temporaries
616 if L = No_Line_Number then
637 C := Character'Val (D + 48);
645 end Output_Line_Number;
647 ---------------------
648 -- Output_Msg_Text --
649 ---------------------
651 procedure Output_Msg_Text (E : Error_Msg_Id) is
652 Offs : constant Nat := Column - 1;
653 -- Offset to start of message, used for continuations
656 -- Maximum characters to output on next line
659 -- Maximum total length of lines
661 E_Msg : Error_Msg_Object renames Errors.Table (E);
662 Text : constant String_Ptr := E_Msg.Text;
666 Tag : constant String := Get_Warning_Tag (E);
671 -- Postfix warning tag to message if needed
673 if Tag /= "" and then Warning_Doc_Switch then
674 if Include_Subprogram_In_Messages then
677 (Subprogram_Name_Ptr (E_Msg.Node) &
678 ": " & Text.all & ' ' & Tag);
680 Txt := new String'(Text.all & ' ' & Tag);
683 elsif Include_Subprogram_In_Messages
684 and then (E_Msg.Warn or else E_Msg.Style)
687 new String'(Subprogram_Name_Ptr (E_Msg.Node) & ": " & Text.all);
692 -- For info messages, prefix message with "info: "
695 Txt := new String'("info: " & Txt.all);
697 -- Warning treated as error
699 elsif E_Msg.Warn_Err then
701 -- We prefix with "error:" rather than warning: and postfix
702 -- [warning-as-error] at the end.
704 Warnings_Treated_As_Errors := Warnings_Treated_As_Errors + 1;
705 Txt := new String'("error: " & Txt.all & " [warning-as-error]");
707 -- Normal warning, prefix with "warning: "
709 elsif E_Msg.Warn then
710 Txt := new String'("warning: " & Txt.all);
712 -- No prefix needed for style message, "(style)" is there already
714 elsif E_Msg.Style then
717 -- No prefix needed for check message, severity is there already
719 elsif E_Msg.Check then
722 -- All other cases, add "error: " if unique error tag set
724 elsif Opt.Unique_Error_Tag then
725 Txt := new String'("error: " & Txt.all);
728 -- Set error message line length and length of message
730 if Error_Msg_Line_Length = 0 then
733 Length := Error_Msg_Line_Length;
736 Max := Integer (Length - Column + 1);
739 -- Here we have to split the message up into multiple lines
743 -- Make sure we do not have ludicrously small line
745 Max := Integer'Max (Max, 20);
747 -- If remaining text fits, output it respecting LF and we are done
749 if Len - Ptr < Max then
750 for J in Ptr .. Len loop
751 if Txt (J) = ASCII.LF then
755 Write_Char (Txt (J));
766 -- First scan forward looking for a hard end of line
768 for Scan in Ptr .. Ptr + Max - 1 loop
769 if Txt (Scan) = ASCII.LF then
776 -- Otherwise scan backwards looking for a space
778 for Scan in reverse Ptr .. Ptr + Max - 1 loop
779 if Txt (Scan) = ' ' then
786 -- If we fall through, no space, so split line arbitrarily
788 Split := Ptr + Max - 1;
793 if Start <= Split then
794 Write_Line (Txt (Start .. Split));
798 Max := Integer (Length - Column + 1);
802 ---------------------
803 -- Prescan_Message --
804 ---------------------
806 procedure Prescan_Message (Msg : String) is
810 -- Nothing to do for continuation line
812 if Msg (Msg'First) = '\' then
816 -- Set initial values of globals (may be changed during scan)
818 Is_Serious_Error := True;
819 Is_Unconditional_Msg := False;
820 Is_Warning_Msg := False;
821 Has_Double_Exclam := False;
823 -- Check style message
826 Msg'Length > 7 and then Msg (Msg'First .. Msg'First + 6) = "(style)";
828 -- Check info message
831 Msg'Length > 6 and then Msg (Msg'First .. Msg'First + 5) = "info: ";
833 -- Check check message
836 (Msg'Length > 8 and then Msg (Msg'First .. Msg'First + 7) = "medium: ")
838 (Msg'Length > 6 and then Msg (Msg'First .. Msg'First + 5) = "high: ")
840 (Msg'Length > 5 and then Msg (Msg'First .. Msg'First + 4) = "low: ");
842 -- Loop through message looking for relevant insertion sequences
845 while J <= Msg'Last loop
847 -- If we have a quote, don't look at following character
849 if Msg (J) = ''' then
852 -- Warning message (? or < insertion sequence)
854 elsif Msg (J) = '?' or else Msg (J) = '<' then
855 Is_Warning_Msg := Msg (J) = '?' or else Error_Msg_Warn;
856 Warning_Msg_Char := ' ';
859 if Is_Warning_Msg then
861 C : constant Character := Msg (J - 1);
863 if J <= Msg'Last then
865 Warning_Msg_Char := '?';
868 elsif J < Msg'Last and then Msg (J + 1) = C
869 and then (Msg (J) in 'a' .. 'z' or else
870 Msg (J) in 'A' .. 'Z' or else
871 Msg (J) = '*' or else
874 Warning_Msg_Char := Msg (J);
881 -- Bomb if untagged warning message. This code can be uncommented
882 -- for debugging when looking for untagged warning messages.
884 -- if Is_Warning_Msg and then Warning_Msg_Char = ' ' then
885 -- raise Program_Error;
888 -- Unconditional message (! insertion)
890 elsif Msg (J) = '!' then
891 Is_Unconditional_Msg := True;
894 if J <= Msg'Last and then Msg (J) = '!' then
895 Has_Double_Exclam := True;
899 -- Non-serious error (| insertion)
901 elsif Msg (J) = '|' then
902 Is_Serious_Error := False;
910 if Is_Info_Msg or Is_Warning_Msg or Is_Style_Msg or Is_Check_Msg then
911 Is_Serious_Error := False;
919 procedure Purge_Messages (From : Source_Ptr; To : Source_Ptr) is
922 function To_Be_Purged (E : Error_Msg_Id) return Boolean;
923 -- Returns True for a message that is to be purged. Also adjusts
924 -- error counts appropriately.
930 function To_Be_Purged (E : Error_Msg_Id) return Boolean is
933 and then Errors.Table (E).Sptr > From
934 and then Errors.Table (E).Sptr < To
936 if Errors.Table (E).Warn or else Errors.Table (E).Style then
937 Warnings_Detected := Warnings_Detected - 1;
940 Total_Errors_Detected := Total_Errors_Detected - 1;
942 if Errors.Table (E).Serious then
943 Serious_Errors_Detected := Serious_Errors_Detected - 1;
954 -- Start of processing for Purge_Messages
957 while To_Be_Purged (First_Error_Msg) loop
958 First_Error_Msg := Errors.Table (First_Error_Msg).Next;
961 E := First_Error_Msg;
962 while E /= No_Error_Msg loop
963 while To_Be_Purged (Errors.Table (E).Next) loop
964 Errors.Table (E).Next :=
965 Errors.Table (Errors.Table (E).Next).Next;
968 E := Errors.Table (E).Next;
976 function Same_Error (M1, M2 : Error_Msg_Id) return Boolean is
977 Msg1 : constant String_Ptr := Errors.Table (M1).Text;
978 Msg2 : constant String_Ptr := Errors.Table (M2).Text;
980 Msg2_Len : constant Integer := Msg2'Length;
981 Msg1_Len : constant Integer := Msg1'Length;
987 (Msg1_Len - 10 > Msg2_Len
989 Msg2.all = Msg1.all (1 .. Msg2_Len)
991 Msg1 (Msg2_Len + 1 .. Msg2_Len + 10) = ", instance")
993 (Msg2_Len - 10 > Msg1_Len
995 Msg1.all = Msg2.all (1 .. Msg1_Len)
997 Msg2 (Msg1_Len + 1 .. Msg1_Len + 10) = ", instance");
1004 procedure Set_Msg_Blank is
1007 and then Msg_Buffer (Msglen) /= ' '
1008 and then Msg_Buffer (Msglen) /= '('
1009 and then Msg_Buffer (Msglen) /= '-'
1010 and then not Manual_Quote_Mode
1016 -------------------------------
1017 -- Set_Msg_Blank_Conditional --
1018 -------------------------------
1020 procedure Set_Msg_Blank_Conditional is
1023 and then Msg_Buffer (Msglen) /= ' '
1024 and then Msg_Buffer (Msglen) /= '('
1025 and then Msg_Buffer (Msglen) /= '"'
1026 and then not Manual_Quote_Mode
1030 end Set_Msg_Blank_Conditional;
1036 procedure Set_Msg_Char (C : Character) is
1039 -- The check for message buffer overflow is needed to deal with cases
1040 -- where insertions get too long (in particular a child unit name can
1043 if Msglen < Max_Msg_Length then
1044 Msglen := Msglen + 1;
1045 Msg_Buffer (Msglen) := C;
1049 ---------------------------------
1050 -- Set_Msg_Insertion_File_Name --
1051 ---------------------------------
1053 procedure Set_Msg_Insertion_File_Name is
1055 if Error_Msg_File_1 = No_File then
1058 elsif Error_Msg_File_1 = Error_File_Name then
1060 Set_Msg_Str ("<error>");
1064 Get_Name_String (Error_Msg_File_1);
1066 Set_Msg_Name_Buffer;
1070 -- The following assignments ensure that the second and third {
1071 -- insertion characters will correspond to the Error_Msg_File_2 and
1072 -- Error_Msg_File_3 values and We suppress possible validity checks in
1073 -- case operating in -gnatVa mode, and Error_Msg_File_2 or
1074 -- Error_Msg_File_3 is not needed and has not been set.
1077 pragma Suppress (Range_Check);
1079 Error_Msg_File_1 := Error_Msg_File_2;
1080 Error_Msg_File_2 := Error_Msg_File_3;
1082 end Set_Msg_Insertion_File_Name;
1084 -----------------------------------
1085 -- Set_Msg_Insertion_Line_Number --
1086 -----------------------------------
1088 procedure Set_Msg_Insertion_Line_Number (Loc, Flag : Source_Ptr) is
1089 Sindex_Loc : Source_File_Index;
1090 Sindex_Flag : Source_File_Index;
1091 Fname : File_Name_Type;
1095 -- Outputs "at " unless last characters in buffer are " from ". Certain
1096 -- messages read better with from than at.
1105 or else Msg_Buffer (Msglen - 5 .. Msglen) /= " from "
1107 Set_Msg_Str ("at ");
1111 -- Start of processing for Set_Msg_Insertion_Line_Number
1116 if Loc = No_Location then
1118 Set_Msg_Str ("unknown location");
1120 elsif Loc = System_Location then
1121 Set_Msg_Str ("in package System");
1122 Set_Msg_Insertion_Run_Time_Name;
1124 elsif Loc = Standard_Location then
1125 Set_Msg_Str ("in package Standard");
1127 elsif Loc = Standard_ASCII_Location then
1128 Set_Msg_Str ("in package Standard.ASCII");
1131 -- Add "at file-name:" if reference is to other than the source
1132 -- file in which the error message is placed. Note that we check
1133 -- full file names, rather than just the source indexes, to
1134 -- deal with generic instantiations from the current file.
1136 Sindex_Loc := Get_Source_File_Index (Loc);
1137 Sindex_Flag := Get_Source_File_Index (Flag);
1139 if Full_File_Name (Sindex_Loc) /= Full_File_Name (Sindex_Flag) then
1141 Fname := Reference_Name (Get_Source_File_Index (Loc));
1142 Int_File := Is_Internal_File_Name (Fname);
1143 Get_Name_String (Fname);
1144 Set_Msg_Name_Buffer;
1146 if not (Int_File and Debug_Flag_Dot_K) then
1148 Set_Msg_Int (Int (Get_Logical_Line_Number (Loc)));
1151 -- If in current file, add text "at line "
1155 Set_Msg_Str ("line ");
1157 Set_Msg_Int (Int (Get_Logical_Line_Number (Loc)));
1160 -- Deal with the instantiation case. We may have a reference to,
1161 -- e.g. a type, that is declared within a generic template, and
1162 -- what we are really referring to is the occurrence in an instance.
1163 -- In this case, the line number of the instantiation is also of
1164 -- interest, and we add a notation:
1166 -- , instance at xxx
1168 -- where xxx is a line number output using this same routine (and
1169 -- the recursion can go further if the instantiation is itself in
1170 -- a generic template).
1172 -- The flag location passed to us in this situation is indeed the
1173 -- line number within the template, but as described in Sinput.L
1174 -- (file sinput-l.ads, section "Handling Generic Instantiations")
1175 -- we can retrieve the location of the instantiation itself from
1176 -- this flag location value.
1178 -- Note: this processing is suppressed if Suppress_Instance_Location
1179 -- is set True. This is used to prevent redundant annotations of the
1180 -- location of the instantiation in the case where we are placing
1181 -- the messages on the instantiation in any case.
1183 if Instantiation (Sindex_Loc) /= No_Location
1184 and then not Suppress_Instance_Location
1186 Set_Msg_Str (", instance ");
1187 Set_Msg_Insertion_Line_Number (Instantiation (Sindex_Loc), Flag);
1190 end Set_Msg_Insertion_Line_Number;
1192 ----------------------------
1193 -- Set_Msg_Insertion_Name --
1194 ----------------------------
1196 procedure Set_Msg_Insertion_Name is
1198 if Error_Msg_Name_1 = No_Name then
1201 elsif Error_Msg_Name_1 = Error_Name then
1203 Set_Msg_Str ("<error>");
1206 Set_Msg_Blank_Conditional;
1207 Get_Unqualified_Decoded_Name_String (Error_Msg_Name_1);
1209 -- Remove %s or %b at end. These come from unit names. If the
1210 -- caller wanted the (unit) or (body), then they would have used
1211 -- the $ insertion character. Certainly no error message should
1212 -- ever have %b or %s explicitly occurring.
1215 and then Name_Buffer (Name_Len - 1) = '%'
1216 and then (Name_Buffer (Name_Len) = 'b'
1218 Name_Buffer (Name_Len) = 's')
1220 Name_Len := Name_Len - 2;
1223 -- Remove upper case letter at end, again, we should not be getting
1224 -- such names, and what we hope is that the remainder makes sense.
1226 if Name_Len > 1 and then Name_Buffer (Name_Len) in 'A' .. 'Z' then
1227 Name_Len := Name_Len - 1;
1230 -- If operator name or character literal name, just print it as is
1231 -- Also print as is if it ends in a right paren (case of x'val(nnn))
1233 if Name_Buffer (1) = '"'
1234 or else Name_Buffer (1) = '''
1235 or else Name_Buffer (Name_Len) = ')'
1237 Set_Msg_Name_Buffer;
1239 -- Else output with surrounding quotes in proper casing mode
1242 Set_Casing (Identifier_Casing (Flag_Source));
1244 Set_Msg_Name_Buffer;
1249 -- The following assignments ensure that the second and third percent
1250 -- insertion characters will correspond to the Error_Msg_Name_2 and
1251 -- Error_Msg_Name_3 as required. We suppress possible validity checks in
1252 -- case operating in -gnatVa mode, and Error_Msg_Name_1/2 is not needed
1253 -- and has not been set.
1256 pragma Suppress (Range_Check);
1258 Error_Msg_Name_1 := Error_Msg_Name_2;
1259 Error_Msg_Name_2 := Error_Msg_Name_3;
1261 end Set_Msg_Insertion_Name;
1263 ------------------------------------
1264 -- Set_Msg_Insertion_Name_Literal --
1265 ------------------------------------
1267 procedure Set_Msg_Insertion_Name_Literal is
1269 if Error_Msg_Name_1 = No_Name then
1272 elsif Error_Msg_Name_1 = Error_Name then
1274 Set_Msg_Str ("<error>");
1278 Get_Name_String (Error_Msg_Name_1);
1280 Set_Msg_Name_Buffer;
1284 -- The following assignments ensure that the second and third % or %%
1285 -- insertion characters will correspond to the Error_Msg_Name_2 and
1286 -- Error_Msg_Name_3 values and We suppress possible validity checks in
1287 -- case operating in -gnatVa mode, and Error_Msg_Name_2 or
1288 -- Error_Msg_Name_3 is not needed and has not been set.
1291 pragma Suppress (Range_Check);
1293 Error_Msg_Name_1 := Error_Msg_Name_2;
1294 Error_Msg_Name_2 := Error_Msg_Name_3;
1296 end Set_Msg_Insertion_Name_Literal;
1298 -------------------------------------
1299 -- Set_Msg_Insertion_Reserved_Name --
1300 -------------------------------------
1302 procedure Set_Msg_Insertion_Reserved_Name is
1304 Set_Msg_Blank_Conditional;
1305 Get_Name_String (Error_Msg_Name_1);
1307 Set_Casing (Keyword_Casing (Flag_Source), All_Lower_Case);
1308 Set_Msg_Name_Buffer;
1310 end Set_Msg_Insertion_Reserved_Name;
1312 -------------------------------------
1313 -- Set_Msg_Insertion_Reserved_Word --
1314 -------------------------------------
1316 procedure Set_Msg_Insertion_Reserved_Word
1321 Set_Msg_Blank_Conditional;
1324 while J <= Text'Last and then Text (J) in 'A' .. 'Z' loop
1325 Add_Char_To_Name_Buffer (Text (J));
1329 -- Here is where we make the special exception for RM
1331 if Name_Len = 2 and then Name_Buffer (1 .. 2) = "RM" then
1332 Set_Msg_Name_Buffer;
1334 -- We make a similar exception for SPARK
1336 elsif Name_Len = 5 and then Name_Buffer (1 .. 5) = "SPARK" then
1337 Set_Msg_Name_Buffer;
1339 -- Neither RM nor SPARK: case appropriately and add surrounding quotes
1342 Set_Casing (Keyword_Casing (Flag_Source), All_Lower_Case);
1344 Set_Msg_Name_Buffer;
1347 end Set_Msg_Insertion_Reserved_Word;
1349 -------------------------------------
1350 -- Set_Msg_Insertion_Run_Time_Name --
1351 -------------------------------------
1353 procedure Set_Msg_Insertion_Run_Time_Name is
1355 if Targparm.Run_Time_Name_On_Target /= No_Name then
1356 Set_Msg_Blank_Conditional;
1358 Get_Name_String (Targparm.Run_Time_Name_On_Target);
1359 Set_Casing (Mixed_Case);
1360 Set_Msg_Str (Name_Buffer (1 .. Name_Len));
1363 end Set_Msg_Insertion_Run_Time_Name;
1365 ----------------------------
1366 -- Set_Msg_Insertion_Uint --
1367 ----------------------------
1369 procedure Set_Msg_Insertion_Uint is
1372 UI_Image (Error_Msg_Uint_1);
1374 for J in 1 .. UI_Image_Length loop
1375 Set_Msg_Char (UI_Image_Buffer (J));
1378 -- The following assignment ensures that a second caret insertion
1379 -- character will correspond to the Error_Msg_Uint_2 parameter. We
1380 -- suppress possible validity checks in case operating in -gnatVa mode,
1381 -- and Error_Msg_Uint_2 is not needed and has not been set.
1384 pragma Suppress (Range_Check);
1386 Error_Msg_Uint_1 := Error_Msg_Uint_2;
1388 end Set_Msg_Insertion_Uint;
1394 procedure Set_Msg_Int (Line : Int) is
1397 Set_Msg_Int (Line / 10);
1400 Set_Msg_Char (Character'Val (Character'Pos ('0') + (Line rem 10)));
1403 -------------------------
1404 -- Set_Msg_Name_Buffer --
1405 -------------------------
1407 procedure Set_Msg_Name_Buffer is
1409 Set_Msg_Str (Name_Buffer (1 .. Name_Len));
1410 end Set_Msg_Name_Buffer;
1416 procedure Set_Msg_Quote is
1418 if not Manual_Quote_Mode then
1427 procedure Set_Msg_Str (Text : String) is
1429 -- Do replacement for special x'Class aspect names
1431 if Text = "_Pre" then
1432 Set_Msg_Str ("Pre'Class");
1434 elsif Text = "_Post" then
1435 Set_Msg_Str ("Post'Class");
1437 elsif Text = "_Type_Invariant" then
1438 Set_Msg_Str ("Type_Invariant'Class");
1440 elsif Text = "_pre" then
1441 Set_Msg_Str ("pre'class");
1443 elsif Text = "_post" then
1444 Set_Msg_Str ("post'class");
1446 elsif Text = "_type_invariant" then
1447 Set_Msg_Str ("type_invariant'class");
1449 elsif Text = "_PRE" then
1450 Set_Msg_Str ("PRE'CLASS");
1452 elsif Text = "_POST" then
1453 Set_Msg_Str ("POST'CLASS");
1455 elsif Text = "_TYPE_INVARIANT" then
1456 Set_Msg_Str ("TYPE_INVARIANT'CLASS");
1458 -- Normal case with no replacement
1461 for J in Text'Range loop
1462 Set_Msg_Char (Text (J));
1467 ------------------------------
1468 -- Set_Next_Non_Deleted_Msg --
1469 ------------------------------
1471 procedure Set_Next_Non_Deleted_Msg (E : in out Error_Msg_Id) is
1473 if E = No_Error_Msg then
1478 E := Errors.Table (E).Next;
1479 exit when E = No_Error_Msg or else not Errors.Table (E).Deleted;
1482 end Set_Next_Non_Deleted_Msg;
1484 ------------------------------
1485 -- Set_Specific_Warning_Off --
1486 ------------------------------
1488 procedure Set_Specific_Warning_Off
1493 Used : Boolean := False)
1496 Specific_Warnings.Append
1498 Msg => new String'(Msg),
1499 Stop => Source_Last (Get_Source_File_Index (Loc)),
1504 end Set_Specific_Warning_Off;
1506 -----------------------------
1507 -- Set_Specific_Warning_On --
1508 -----------------------------
1510 procedure Set_Specific_Warning_On
1516 for J in 1 .. Specific_Warnings.Last loop
1518 SWE : Specific_Warning_Entry renames Specific_Warnings.Table (J);
1521 if Msg = SWE.Msg.all
1522 and then Loc > SWE.Start
1524 and then Get_Source_File_Index (SWE.Start) =
1525 Get_Source_File_Index (Loc)
1531 -- If a config pragma is specifically cancelled, consider
1532 -- that it is no longer active as a configuration pragma.
1534 SWE.Config := False;
1541 end Set_Specific_Warning_On;
1543 ---------------------------
1544 -- Set_Warnings_Mode_Off --
1545 ---------------------------
1547 procedure Set_Warnings_Mode_Off (Loc : Source_Ptr; Reason : String_Id) is
1549 -- Don't bother with entries from instantiation copies, since we will
1550 -- already have a copy in the template, which is what matters.
1552 if Instantiation (Get_Source_File_Index (Loc)) /= No_Location then
1556 -- If all warnings are suppressed by command line switch, this can
1557 -- be ignored, unless we are in GNATprove_Mode which requires pragma
1558 -- Warnings to be stored for the formal verification backend.
1560 if Warning_Mode = Suppress
1561 and then not GNATprove_Mode
1566 -- If last entry in table already covers us, this is a redundant pragma
1567 -- Warnings (Off) and can be ignored.
1569 if Warnings.Last >= Warnings.First
1570 and then Warnings.Table (Warnings.Last).Start <= Loc
1571 and then Loc <= Warnings.Table (Warnings.Last).Stop
1576 -- If none of those special conditions holds, establish a new entry,
1577 -- extending from the location of the pragma to the end of the current
1578 -- source file. This ending point will be adjusted by a subsequent
1579 -- corresponding pragma Warnings (On).
1583 Stop => Source_Last (Get_Source_File_Index (Loc)),
1585 end Set_Warnings_Mode_Off;
1587 --------------------------
1588 -- Set_Warnings_Mode_On --
1589 --------------------------
1591 procedure Set_Warnings_Mode_On (Loc : Source_Ptr) is
1593 -- Don't bother with entries from instantiation copies, since we will
1594 -- already have a copy in the template, which is what matters.
1596 if Instantiation (Get_Source_File_Index (Loc)) /= No_Location then
1600 -- If all warnings are suppressed by command line switch, this can
1601 -- be ignored, unless we are in GNATprove_Mode which requires pragma
1602 -- Warnings to be stored for the formal verification backend.
1604 if Warning_Mode = Suppress
1605 and then not GNATprove_Mode
1610 -- If the last entry in the warnings table covers this pragma, then
1611 -- we adjust the end point appropriately.
1613 if Warnings.Last >= Warnings.First
1614 and then Warnings.Table (Warnings.Last).Start <= Loc
1615 and then Loc <= Warnings.Table (Warnings.Last).Stop
1617 Warnings.Table (Warnings.Last).Stop := Loc;
1619 end Set_Warnings_Mode_On;
1625 function Sloc_In_Range (Loc, Start, Stop : Source_Ptr) return Boolean is
1626 Cur_Loc : Source_Ptr := Loc;
1629 while Cur_Loc /= No_Location loop
1630 if Start <= Cur_Loc and then Cur_Loc <= Stop then
1634 Cur_Loc := Instantiation_Location (Cur_Loc);
1640 --------------------------------
1641 -- Validate_Specific_Warnings --
1642 --------------------------------
1644 procedure Validate_Specific_Warnings (Eproc : Error_Msg_Proc) is
1646 if not Warn_On_Warnings_Off then
1650 for J in Specific_Warnings.First .. Specific_Warnings.Last loop
1652 SWE : Specific_Warning_Entry renames Specific_Warnings.Table (J);
1655 if not SWE.Config then
1657 -- Warn for unmatched Warnings (Off, ...)
1661 ("?W?pragma Warnings Off with no matching Warnings On",
1664 -- Warn for ineffective Warnings (Off, ..)
1668 -- Do not issue this warning for -Wxxx messages since the
1669 -- back-end doesn't report the information. Note that there
1670 -- is always an asterisk at the start of every message.
1673 (SWE.Msg'Length > 3 and then SWE.Msg (2 .. 3) = "-W")
1676 ("?W?no warning suppressed by this pragma", SWE.Start);
1681 end Validate_Specific_Warnings;
1683 -------------------------------------
1684 -- Warning_Specifically_Suppressed --
1685 -------------------------------------
1687 function Warning_Specifically_Suppressed
1690 Tag : String := "") return String_Id
1693 -- Loop through specific warning suppression entries
1695 for J in Specific_Warnings.First .. Specific_Warnings.Last loop
1697 SWE : Specific_Warning_Entry renames Specific_Warnings.Table (J);
1700 -- Pragma applies if it is a configuration pragma, or if the
1701 -- location is in range of a specific non-configuration pragma.
1704 or else Sloc_In_Range (Loc, SWE.Start, SWE.Stop)
1706 if Matches (Msg.all, SWE.Msg.all)
1707 or else Matches (Tag, SWE.Msg.all)
1717 end Warning_Specifically_Suppressed;
1719 ------------------------------
1720 -- Warning_Treated_As_Error --
1721 ------------------------------
1723 function Warning_Treated_As_Error (Msg : String) return Boolean is
1725 for J in 1 .. Warnings_As_Errors_Count loop
1726 if Matches (Msg, Warnings_As_Errors (J).all) then
1732 end Warning_Treated_As_Error;
1734 -------------------------
1735 -- Warnings_Suppressed --
1736 -------------------------
1738 function Warnings_Suppressed (Loc : Source_Ptr) return String_Id is
1740 -- Loop through table of ON/OFF warnings
1742 for J in Warnings.First .. Warnings.Last loop
1743 if Sloc_In_Range (Loc, Warnings.Table (J).Start,
1744 Warnings.Table (J).Stop)
1746 return Warnings.Table (J).Reason;
1750 if Warning_Mode = Suppress then
1751 return Null_String_Id;
1755 end Warnings_Suppressed;