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 matches 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 that
264 -- there are only one or more non-Compile_Time_Warning warnings when
265 -- Warnings_Count is greater than 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 -- If -gnatdF is used, continuation messages follow the main message
693 -- with only an indentation of two space characters, without repeating
696 if Debug_Flag_FF and then E_Msg.Msg_Cont then
699 -- For info messages, prefix message with "info: "
701 elsif E_Msg.Info then
702 Txt := new String'("info: " & Txt.all);
704 -- Warning treated as error
706 elsif E_Msg.Warn_Err then
708 -- We prefix with "error:" rather than warning: and postfix
709 -- [warning-as-error] at the end.
711 Warnings_Treated_As_Errors := Warnings_Treated_As_Errors + 1;
712 Txt := new String'("error: " & Txt.all & " [warning-as-error]");
714 -- Normal warning, prefix with "warning: "
716 elsif E_Msg.Warn then
717 Txt := new String'("warning: " & Txt.all);
719 -- No prefix needed for style message, "(style)" is there already
721 elsif E_Msg.Style then
724 -- No prefix needed for check message, severity is there already
726 elsif E_Msg.Check then
729 -- All other cases, add "error: " if unique error tag set
731 elsif Opt.Unique_Error_Tag then
732 Txt := new String'("error: " & Txt.all);
735 -- Set error message line length and length of message
737 if Error_Msg_Line_Length = 0 then
740 Length := Error_Msg_Line_Length;
743 Max := Integer (Length - Column + 1);
746 -- Here we have to split the message up into multiple lines
750 -- Make sure we do not have ludicrously small line
752 Max := Integer'Max (Max, 20);
754 -- If remaining text fits, output it respecting LF and we are done
756 if Len - Ptr < Max then
757 for J in Ptr .. Len loop
758 if Txt (J) = ASCII.LF then
762 Write_Char (Txt (J));
773 -- First scan forward looking for a hard end of line
775 for Scan in Ptr .. Ptr + Max - 1 loop
776 if Txt (Scan) = ASCII.LF then
783 -- Otherwise scan backwards looking for a space
785 for Scan in reverse Ptr .. Ptr + Max - 1 loop
786 if Txt (Scan) = ' ' then
793 -- If we fall through, no space, so split line arbitrarily
795 Split := Ptr + Max - 1;
800 if Start <= Split then
801 Write_Line (Txt (Start .. Split));
805 Max := Integer (Length - Column + 1);
809 ---------------------
810 -- Prescan_Message --
811 ---------------------
813 procedure Prescan_Message (Msg : String) is
817 -- Nothing to do for continuation line, unless -gnatdF is set
819 if not Debug_Flag_FF and then Msg (Msg'First) = '\' then
822 -- Some global variables are not set for continuation messages, as they
823 -- only make sense for the initial mesage.
825 elsif Msg (Msg'First) /= '\' then
827 -- Set initial values of globals (may be changed during scan)
829 Is_Serious_Error := True;
830 Is_Unconditional_Msg := False;
831 Is_Warning_Msg := False;
833 -- Check style message
837 and then Msg (Msg'First .. Msg'First + 6) = "(style)";
839 -- Check info message
843 and then Msg (Msg'First .. Msg'First + 5) = "info: ";
845 -- Check check message
849 and then Msg (Msg'First .. Msg'First + 7) = "medium: ")
852 and then Msg (Msg'First .. Msg'First + 5) = "high: ")
855 and then Msg (Msg'First .. Msg'First + 4) = "low: ");
858 Has_Double_Exclam := False;
859 Has_Insertion_Line := False;
861 -- Loop through message looking for relevant insertion sequences
864 while J <= Msg'Last loop
866 -- If we have a quote, don't look at following character
868 if Msg (J) = ''' then
871 -- Warning message (? or < insertion sequence)
873 elsif Msg (J) = '?' or else Msg (J) = '<' then
874 Is_Warning_Msg := Msg (J) = '?' or else Error_Msg_Warn;
875 Warning_Msg_Char := ' ';
878 if Is_Warning_Msg then
880 C : constant Character := Msg (J - 1);
882 if J <= Msg'Last then
884 Warning_Msg_Char := '?';
887 elsif J < Msg'Last and then Msg (J + 1) = C
888 and then (Msg (J) in 'a' .. 'z' or else
889 Msg (J) in 'A' .. 'Z' or else
890 Msg (J) = '*' or else
893 Warning_Msg_Char := Msg (J);
900 -- Bomb if untagged warning message. This code can be uncommented
901 -- for debugging when looking for untagged warning messages.
903 -- if Is_Warning_Msg and then Warning_Msg_Char = ' ' then
904 -- raise Program_Error;
907 -- Unconditional message (! insertion)
909 elsif Msg (J) = '!' then
910 Is_Unconditional_Msg := True;
913 if J <= Msg'Last and then Msg (J) = '!' then
914 Has_Double_Exclam := True;
918 -- Insertion line (# insertion)
920 elsif Msg (J) = '#' then
921 Has_Insertion_Line := True;
924 -- Non-serious error (| insertion)
926 elsif Msg (J) = '|' then
927 Is_Serious_Error := False;
935 if Is_Info_Msg or Is_Warning_Msg or Is_Style_Msg or Is_Check_Msg then
936 Is_Serious_Error := False;
944 procedure Purge_Messages (From : Source_Ptr; To : Source_Ptr) is
947 function To_Be_Purged (E : Error_Msg_Id) return Boolean;
948 -- Returns True for a message that is to be purged. Also adjusts
949 -- error counts appropriately.
955 function To_Be_Purged (E : Error_Msg_Id) return Boolean is
958 and then Errors.Table (E).Sptr > From
959 and then Errors.Table (E).Sptr < To
961 if Errors.Table (E).Warn or else Errors.Table (E).Style then
962 Warnings_Detected := Warnings_Detected - 1;
965 Total_Errors_Detected := Total_Errors_Detected - 1;
967 if Errors.Table (E).Serious then
968 Serious_Errors_Detected := Serious_Errors_Detected - 1;
979 -- Start of processing for Purge_Messages
982 while To_Be_Purged (First_Error_Msg) loop
983 First_Error_Msg := Errors.Table (First_Error_Msg).Next;
986 E := First_Error_Msg;
987 while E /= No_Error_Msg loop
988 while To_Be_Purged (Errors.Table (E).Next) loop
989 Errors.Table (E).Next :=
990 Errors.Table (Errors.Table (E).Next).Next;
993 E := Errors.Table (E).Next;
1001 function Same_Error (M1, M2 : Error_Msg_Id) return Boolean is
1002 Msg1 : constant String_Ptr := Errors.Table (M1).Text;
1003 Msg2 : constant String_Ptr := Errors.Table (M2).Text;
1005 Msg2_Len : constant Integer := Msg2'Length;
1006 Msg1_Len : constant Integer := Msg1'Length;
1012 (Msg1_Len - 10 > Msg2_Len
1014 Msg2.all = Msg1.all (1 .. Msg2_Len)
1016 Msg1 (Msg2_Len + 1 .. Msg2_Len + 10) = ", instance")
1018 (Msg2_Len - 10 > Msg1_Len
1020 Msg1.all = Msg2.all (1 .. Msg1_Len)
1022 Msg2 (Msg1_Len + 1 .. Msg1_Len + 10) = ", instance");
1029 procedure Set_Msg_Blank is
1032 and then Msg_Buffer (Msglen) /= ' '
1033 and then Msg_Buffer (Msglen) /= '('
1034 and then Msg_Buffer (Msglen) /= '-'
1035 and then not Manual_Quote_Mode
1041 -------------------------------
1042 -- Set_Msg_Blank_Conditional --
1043 -------------------------------
1045 procedure Set_Msg_Blank_Conditional is
1048 and then Msg_Buffer (Msglen) /= ' '
1049 and then Msg_Buffer (Msglen) /= '('
1050 and then Msg_Buffer (Msglen) /= '"'
1051 and then not Manual_Quote_Mode
1055 end Set_Msg_Blank_Conditional;
1061 procedure Set_Msg_Char (C : Character) is
1064 -- The check for message buffer overflow is needed to deal with cases
1065 -- where insertions get too long (in particular a child unit name can
1068 if Msglen < Max_Msg_Length then
1069 Msglen := Msglen + 1;
1070 Msg_Buffer (Msglen) := C;
1074 ---------------------------------
1075 -- Set_Msg_Insertion_File_Name --
1076 ---------------------------------
1078 procedure Set_Msg_Insertion_File_Name is
1080 if Error_Msg_File_1 = No_File then
1083 elsif Error_Msg_File_1 = Error_File_Name then
1085 Set_Msg_Str ("<error>");
1089 Get_Name_String (Error_Msg_File_1);
1091 Set_Msg_Name_Buffer;
1095 -- The following assignments ensure that the second and third {
1096 -- insertion characters will correspond to the Error_Msg_File_2 and
1097 -- Error_Msg_File_3 values and We suppress possible validity checks in
1098 -- case operating in -gnatVa mode, and Error_Msg_File_2 or
1099 -- Error_Msg_File_3 is not needed and has not been set.
1102 pragma Suppress (Range_Check);
1104 Error_Msg_File_1 := Error_Msg_File_2;
1105 Error_Msg_File_2 := Error_Msg_File_3;
1107 end Set_Msg_Insertion_File_Name;
1109 -----------------------------------
1110 -- Set_Msg_Insertion_Line_Number --
1111 -----------------------------------
1113 procedure Set_Msg_Insertion_Line_Number (Loc, Flag : Source_Ptr) is
1114 Sindex_Loc : Source_File_Index;
1115 Sindex_Flag : Source_File_Index;
1116 Fname : File_Name_Type;
1120 -- Outputs "at " unless last characters in buffer are " from ". Certain
1121 -- messages read better with from than at.
1130 or else Msg_Buffer (Msglen - 5 .. Msglen) /= " from "
1132 Set_Msg_Str ("at ");
1136 -- Start of processing for Set_Msg_Insertion_Line_Number
1141 if Loc = No_Location then
1143 Set_Msg_Str ("unknown location");
1145 elsif Loc = System_Location then
1146 Set_Msg_Str ("in package System");
1147 Set_Msg_Insertion_Run_Time_Name;
1149 elsif Loc = Standard_Location then
1150 Set_Msg_Str ("in package Standard");
1152 elsif Loc = Standard_ASCII_Location then
1153 Set_Msg_Str ("in package Standard.ASCII");
1156 -- Add "at file-name:" if reference is to other than the source
1157 -- file in which the error message is placed. Note that we check
1158 -- full file names, rather than just the source indexes, to
1159 -- deal with generic instantiations from the current file.
1161 Sindex_Loc := Get_Source_File_Index (Loc);
1162 Sindex_Flag := Get_Source_File_Index (Flag);
1164 if Full_File_Name (Sindex_Loc) /= Full_File_Name (Sindex_Flag) then
1166 Fname := Reference_Name (Get_Source_File_Index (Loc));
1167 Int_File := Is_Internal_File_Name (Fname);
1168 Get_Name_String (Fname);
1169 Set_Msg_Name_Buffer;
1171 if not (Int_File and Debug_Flag_Dot_K) then
1173 Set_Msg_Int (Int (Get_Logical_Line_Number (Loc)));
1176 -- If in current file, add text "at line "
1180 Set_Msg_Str ("line ");
1182 Set_Msg_Int (Int (Get_Logical_Line_Number (Loc)));
1185 -- Deal with the instantiation case. We may have a reference to,
1186 -- e.g. a type, that is declared within a generic template, and
1187 -- what we are really referring to is the occurrence in an instance.
1188 -- In this case, the line number of the instantiation is also of
1189 -- interest, and we add a notation:
1191 -- , instance at xxx
1193 -- where xxx is a line number output using this same routine (and
1194 -- the recursion can go further if the instantiation is itself in
1195 -- a generic template).
1197 -- The flag location passed to us in this situation is indeed the
1198 -- line number within the template, but as described in Sinput.L
1199 -- (file sinput-l.ads, section "Handling Generic Instantiations")
1200 -- we can retrieve the location of the instantiation itself from
1201 -- this flag location value.
1203 -- Note: this processing is suppressed if Suppress_Instance_Location
1204 -- is set True. This is used to prevent redundant annotations of the
1205 -- location of the instantiation in the case where we are placing
1206 -- the messages on the instantiation in any case.
1208 if Instantiation (Sindex_Loc) /= No_Location
1209 and then not Suppress_Instance_Location
1211 Set_Msg_Str (", instance ");
1212 Set_Msg_Insertion_Line_Number (Instantiation (Sindex_Loc), Flag);
1215 end Set_Msg_Insertion_Line_Number;
1217 ----------------------------
1218 -- Set_Msg_Insertion_Name --
1219 ----------------------------
1221 procedure Set_Msg_Insertion_Name is
1223 if Error_Msg_Name_1 = No_Name then
1226 elsif Error_Msg_Name_1 = Error_Name then
1228 Set_Msg_Str ("<error>");
1231 Set_Msg_Blank_Conditional;
1232 Get_Unqualified_Decoded_Name_String (Error_Msg_Name_1);
1234 -- Remove %s or %b at end. These come from unit names. If the
1235 -- caller wanted the (unit) or (body), then they would have used
1236 -- the $ insertion character. Certainly no error message should
1237 -- ever have %b or %s explicitly occurring.
1240 and then Name_Buffer (Name_Len - 1) = '%'
1241 and then (Name_Buffer (Name_Len) = 'b'
1243 Name_Buffer (Name_Len) = 's')
1245 Name_Len := Name_Len - 2;
1248 -- Remove upper case letter at end, again, we should not be getting
1249 -- such names, and what we hope is that the remainder makes sense.
1251 if Name_Len > 1 and then Name_Buffer (Name_Len) in 'A' .. 'Z' then
1252 Name_Len := Name_Len - 1;
1255 -- If operator name or character literal name, just print it as is
1256 -- Also print as is if it ends in a right paren (case of x'val(nnn))
1258 if Name_Buffer (1) = '"'
1259 or else Name_Buffer (1) = '''
1260 or else Name_Buffer (Name_Len) = ')'
1262 Set_Msg_Name_Buffer;
1264 -- Else output with surrounding quotes in proper casing mode
1267 Set_Casing (Identifier_Casing (Flag_Source));
1269 Set_Msg_Name_Buffer;
1274 -- The following assignments ensure that the second and third percent
1275 -- insertion characters will correspond to the Error_Msg_Name_2 and
1276 -- Error_Msg_Name_3 as required. We suppress possible validity checks in
1277 -- case operating in -gnatVa mode, and Error_Msg_Name_1/2 is not needed
1278 -- and has not been set.
1281 pragma Suppress (Range_Check);
1283 Error_Msg_Name_1 := Error_Msg_Name_2;
1284 Error_Msg_Name_2 := Error_Msg_Name_3;
1286 end Set_Msg_Insertion_Name;
1288 ------------------------------------
1289 -- Set_Msg_Insertion_Name_Literal --
1290 ------------------------------------
1292 procedure Set_Msg_Insertion_Name_Literal is
1294 if Error_Msg_Name_1 = No_Name then
1297 elsif Error_Msg_Name_1 = Error_Name then
1299 Set_Msg_Str ("<error>");
1303 Get_Name_String (Error_Msg_Name_1);
1305 Set_Msg_Name_Buffer;
1309 -- The following assignments ensure that the second and third % or %%
1310 -- insertion characters will correspond to the Error_Msg_Name_2 and
1311 -- Error_Msg_Name_3 values and We suppress possible validity checks in
1312 -- case operating in -gnatVa mode, and Error_Msg_Name_2 or
1313 -- Error_Msg_Name_3 is not needed and has not been set.
1316 pragma Suppress (Range_Check);
1318 Error_Msg_Name_1 := Error_Msg_Name_2;
1319 Error_Msg_Name_2 := Error_Msg_Name_3;
1321 end Set_Msg_Insertion_Name_Literal;
1323 -------------------------------------
1324 -- Set_Msg_Insertion_Reserved_Name --
1325 -------------------------------------
1327 procedure Set_Msg_Insertion_Reserved_Name is
1329 Set_Msg_Blank_Conditional;
1330 Get_Name_String (Error_Msg_Name_1);
1332 Set_Casing (Keyword_Casing (Flag_Source), All_Lower_Case);
1333 Set_Msg_Name_Buffer;
1335 end Set_Msg_Insertion_Reserved_Name;
1337 -------------------------------------
1338 -- Set_Msg_Insertion_Reserved_Word --
1339 -------------------------------------
1341 procedure Set_Msg_Insertion_Reserved_Word
1346 Set_Msg_Blank_Conditional;
1349 while J <= Text'Last and then Text (J) in 'A' .. 'Z' loop
1350 Add_Char_To_Name_Buffer (Text (J));
1354 -- Here is where we make the special exception for RM
1356 if Name_Len = 2 and then Name_Buffer (1 .. 2) = "RM" then
1357 Set_Msg_Name_Buffer;
1359 -- We make a similar exception for SPARK
1361 elsif Name_Len = 5 and then Name_Buffer (1 .. 5) = "SPARK" then
1362 Set_Msg_Name_Buffer;
1364 -- Neither RM nor SPARK: case appropriately and add surrounding quotes
1367 Set_Casing (Keyword_Casing (Flag_Source), All_Lower_Case);
1369 Set_Msg_Name_Buffer;
1372 end Set_Msg_Insertion_Reserved_Word;
1374 -------------------------------------
1375 -- Set_Msg_Insertion_Run_Time_Name --
1376 -------------------------------------
1378 procedure Set_Msg_Insertion_Run_Time_Name is
1380 if Targparm.Run_Time_Name_On_Target /= No_Name then
1381 Set_Msg_Blank_Conditional;
1383 Get_Name_String (Targparm.Run_Time_Name_On_Target);
1384 Set_Casing (Mixed_Case);
1385 Set_Msg_Str (Name_Buffer (1 .. Name_Len));
1388 end Set_Msg_Insertion_Run_Time_Name;
1390 ----------------------------
1391 -- Set_Msg_Insertion_Uint --
1392 ----------------------------
1394 procedure Set_Msg_Insertion_Uint is
1397 UI_Image (Error_Msg_Uint_1);
1399 for J in 1 .. UI_Image_Length loop
1400 Set_Msg_Char (UI_Image_Buffer (J));
1403 -- The following assignment ensures that a second caret insertion
1404 -- character will correspond to the Error_Msg_Uint_2 parameter. We
1405 -- suppress possible validity checks in case operating in -gnatVa mode,
1406 -- and Error_Msg_Uint_2 is not needed and has not been set.
1409 pragma Suppress (Range_Check);
1411 Error_Msg_Uint_1 := Error_Msg_Uint_2;
1413 end Set_Msg_Insertion_Uint;
1419 procedure Set_Msg_Int (Line : Int) is
1422 Set_Msg_Int (Line / 10);
1425 Set_Msg_Char (Character'Val (Character'Pos ('0') + (Line rem 10)));
1428 -------------------------
1429 -- Set_Msg_Name_Buffer --
1430 -------------------------
1432 procedure Set_Msg_Name_Buffer is
1434 Set_Msg_Str (Name_Buffer (1 .. Name_Len));
1435 end Set_Msg_Name_Buffer;
1441 procedure Set_Msg_Quote is
1443 if not Manual_Quote_Mode then
1452 procedure Set_Msg_Str (Text : String) is
1454 -- Do replacement for special x'Class aspect names
1456 if Text = "_Pre" then
1457 Set_Msg_Str ("Pre'Class");
1459 elsif Text = "_Post" then
1460 Set_Msg_Str ("Post'Class");
1462 elsif Text = "_Type_Invariant" then
1463 Set_Msg_Str ("Type_Invariant'Class");
1465 elsif Text = "_pre" then
1466 Set_Msg_Str ("pre'class");
1468 elsif Text = "_post" then
1469 Set_Msg_Str ("post'class");
1471 elsif Text = "_type_invariant" then
1472 Set_Msg_Str ("type_invariant'class");
1474 elsif Text = "_PRE" then
1475 Set_Msg_Str ("PRE'CLASS");
1477 elsif Text = "_POST" then
1478 Set_Msg_Str ("POST'CLASS");
1480 elsif Text = "_TYPE_INVARIANT" then
1481 Set_Msg_Str ("TYPE_INVARIANT'CLASS");
1483 -- Normal case with no replacement
1486 for J in Text'Range loop
1487 Set_Msg_Char (Text (J));
1492 ------------------------------
1493 -- Set_Next_Non_Deleted_Msg --
1494 ------------------------------
1496 procedure Set_Next_Non_Deleted_Msg (E : in out Error_Msg_Id) is
1498 if E = No_Error_Msg then
1503 E := Errors.Table (E).Next;
1504 exit when E = No_Error_Msg or else not Errors.Table (E).Deleted;
1507 end Set_Next_Non_Deleted_Msg;
1509 ------------------------------
1510 -- Set_Specific_Warning_Off --
1511 ------------------------------
1513 procedure Set_Specific_Warning_Off
1518 Used : Boolean := False)
1521 Specific_Warnings.Append
1523 Msg => new String'(Msg),
1524 Stop => Source_Last (Get_Source_File_Index (Loc)),
1529 end Set_Specific_Warning_Off;
1531 -----------------------------
1532 -- Set_Specific_Warning_On --
1533 -----------------------------
1535 procedure Set_Specific_Warning_On
1541 for J in 1 .. Specific_Warnings.Last loop
1543 SWE : Specific_Warning_Entry renames Specific_Warnings.Table (J);
1546 if Msg = SWE.Msg.all
1547 and then Loc > SWE.Start
1549 and then Get_Source_File_Index (SWE.Start) =
1550 Get_Source_File_Index (Loc)
1556 -- If a config pragma is specifically cancelled, consider
1557 -- that it is no longer active as a configuration pragma.
1559 SWE.Config := False;
1566 end Set_Specific_Warning_On;
1568 ---------------------------
1569 -- Set_Warnings_Mode_Off --
1570 ---------------------------
1572 procedure Set_Warnings_Mode_Off (Loc : Source_Ptr; Reason : String_Id) is
1574 -- Don't bother with entries from instantiation copies, since we will
1575 -- already have a copy in the template, which is what matters.
1577 if Instantiation (Get_Source_File_Index (Loc)) /= No_Location then
1581 -- If all warnings are suppressed by command line switch, this can
1582 -- be ignored, unless we are in GNATprove_Mode which requires pragma
1583 -- Warnings to be stored for the formal verification backend.
1585 if Warning_Mode = Suppress
1586 and then not GNATprove_Mode
1591 -- If last entry in table already covers us, this is a redundant pragma
1592 -- Warnings (Off) and can be ignored.
1594 if Warnings.Last >= Warnings.First
1595 and then Warnings.Table (Warnings.Last).Start <= Loc
1596 and then Loc <= Warnings.Table (Warnings.Last).Stop
1601 -- If none of those special conditions holds, establish a new entry,
1602 -- extending from the location of the pragma to the end of the current
1603 -- source file. This ending point will be adjusted by a subsequent
1604 -- corresponding pragma Warnings (On).
1608 Stop => Source_Last (Get_Source_File_Index (Loc)),
1610 end Set_Warnings_Mode_Off;
1612 --------------------------
1613 -- Set_Warnings_Mode_On --
1614 --------------------------
1616 procedure Set_Warnings_Mode_On (Loc : Source_Ptr) is
1618 -- Don't bother with entries from instantiation copies, since we will
1619 -- already have a copy in the template, which is what matters.
1621 if Instantiation (Get_Source_File_Index (Loc)) /= No_Location then
1625 -- If all warnings are suppressed by command line switch, this can
1626 -- be ignored, unless we are in GNATprove_Mode which requires pragma
1627 -- Warnings to be stored for the formal verification backend.
1629 if Warning_Mode = Suppress
1630 and then not GNATprove_Mode
1635 -- If the last entry in the warnings table covers this pragma, then
1636 -- we adjust the end point appropriately.
1638 if Warnings.Last >= Warnings.First
1639 and then Warnings.Table (Warnings.Last).Start <= Loc
1640 and then Loc <= Warnings.Table (Warnings.Last).Stop
1642 Warnings.Table (Warnings.Last).Stop := Loc;
1644 end Set_Warnings_Mode_On;
1650 function Sloc_In_Range (Loc, Start, Stop : Source_Ptr) return Boolean is
1651 Cur_Loc : Source_Ptr := Loc;
1654 while Cur_Loc /= No_Location loop
1655 if Start <= Cur_Loc and then Cur_Loc <= Stop then
1659 Cur_Loc := Instantiation_Location (Cur_Loc);
1665 --------------------------------
1666 -- Validate_Specific_Warnings --
1667 --------------------------------
1669 procedure Validate_Specific_Warnings (Eproc : Error_Msg_Proc) is
1671 if not Warn_On_Warnings_Off then
1675 for J in Specific_Warnings.First .. Specific_Warnings.Last loop
1677 SWE : Specific_Warning_Entry renames Specific_Warnings.Table (J);
1680 if not SWE.Config then
1682 -- Warn for unmatched Warnings (Off, ...)
1686 ("?W?pragma Warnings Off with no matching Warnings On",
1689 -- Warn for ineffective Warnings (Off, ..)
1693 -- Do not issue this warning for -Wxxx messages since the
1694 -- back-end doesn't report the information. Note that there
1695 -- is always an asterisk at the start of every message.
1698 (SWE.Msg'Length > 3 and then SWE.Msg (2 .. 3) = "-W")
1701 ("?W?no warning suppressed by this pragma", SWE.Start);
1706 end Validate_Specific_Warnings;
1708 -------------------------------------
1709 -- Warning_Specifically_Suppressed --
1710 -------------------------------------
1712 function Warning_Specifically_Suppressed
1715 Tag : String := "") return String_Id
1718 -- Loop through specific warning suppression entries
1720 for J in Specific_Warnings.First .. Specific_Warnings.Last loop
1722 SWE : Specific_Warning_Entry renames Specific_Warnings.Table (J);
1725 -- Pragma applies if it is a configuration pragma, or if the
1726 -- location is in range of a specific non-configuration pragma.
1729 or else Sloc_In_Range (Loc, SWE.Start, SWE.Stop)
1731 if Matches (Msg.all, SWE.Msg.all)
1732 or else Matches (Tag, SWE.Msg.all)
1742 end Warning_Specifically_Suppressed;
1744 ------------------------------
1745 -- Warning_Treated_As_Error --
1746 ------------------------------
1748 function Warning_Treated_As_Error (Msg : String) return Boolean is
1750 for J in 1 .. Warnings_As_Errors_Count loop
1751 if Matches (Msg, Warnings_As_Errors (J).all) then
1757 end Warning_Treated_As_Error;
1759 -------------------------
1760 -- Warnings_Suppressed --
1761 -------------------------
1763 function Warnings_Suppressed (Loc : Source_Ptr) return String_Id is
1765 -- Loop through table of ON/OFF warnings
1767 for J in Warnings.First .. Warnings.Last loop
1768 if Sloc_In_Range (Loc, Warnings.Table (J).Start,
1769 Warnings.Table (J).Stop)
1771 return Warnings.Table (J).Reason;
1775 if Warning_Mode = Suppress then
1776 return Null_String_Id;
1780 end Warnings_Suppressed;