1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2013, 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 Namet; use Namet;
39 with Output; use Output;
40 with Sinput; use Sinput;
41 with Snames; use Snames;
42 with Stringt; use Stringt;
43 with Targparm; use Targparm;
44 with Uintp; use Uintp;
46 package body Erroutc is
48 -----------------------
49 -- Local Subprograms --
50 -----------------------
52 function Matches (S : String; P : String) return Boolean;
53 -- Returns true if the String S patches the pattern P, which can contain
54 -- wild card chars (*). The entire pattern must match the entire string.
55 -- Case is ignored in the comparison (so X matches x).
61 procedure Add_Class is
66 Get_Name_String (Name_Class);
67 Set_Casing (Identifier_Casing (Flag_Source), Mixed_Case);
72 ----------------------
73 -- Buffer_Ends_With --
74 ----------------------
76 function Buffer_Ends_With (C : Character) return Boolean is
78 return Msglen > 0 and then Msg_Buffer (Msglen) = C;
81 function Buffer_Ends_With (S : String) return Boolean is
82 Len : constant Natural := S'Length;
85 and then Msg_Buffer (Msglen - Len) = ' '
86 and then Msg_Buffer (Msglen - Len + 1 .. Msglen) = S;
93 procedure Buffer_Remove (C : Character) is
95 if Buffer_Ends_With (C) then
100 procedure Buffer_Remove (S : String) is
102 if Buffer_Ends_With (S) then
103 Msglen := Msglen - S'Length;
107 -----------------------------
108 -- Check_Duplicate_Message --
109 -----------------------------
111 procedure Check_Duplicate_Message (M1, M2 : Error_Msg_Id) is
112 L1, L2 : Error_Msg_Id;
113 N1, N2 : Error_Msg_Id;
115 procedure Delete_Msg (Delete, Keep : Error_Msg_Id);
116 -- Called to delete message Delete, keeping message Keep. Marks all
117 -- messages of Delete with deleted flag set to True, and also makes sure
118 -- that for the error messages that are retained the preferred message
119 -- is the one retained (we prefer the shorter one in the case where one
120 -- has an Instance tag). Note that we always know that Keep has at least
121 -- as many continuations as Delete (since we always delete the shorter
128 procedure Delete_Msg (Delete, Keep : Error_Msg_Id) is
136 Errors.Table (D).Deleted := True;
138 -- Adjust error message count
140 if Errors.Table (D).Warn or else Errors.Table (D).Style then
141 Warnings_Detected := Warnings_Detected - 1;
144 Total_Errors_Detected := Total_Errors_Detected - 1;
146 if Errors.Table (D).Serious then
147 Serious_Errors_Detected := Serious_Errors_Detected - 1;
151 -- Substitute shorter of the two error messages
153 if Errors.Table (K).Text'Length > Errors.Table (D).Text'Length then
154 Errors.Table (K).Text := Errors.Table (D).Text;
157 D := Errors.Table (D).Next;
158 K := Errors.Table (K).Next;
160 if D = No_Error_Msg or else not Errors.Table (D).Msg_Cont then
166 -- Start of processing for Check_Duplicate_Message
169 -- Both messages must be non-continuation messages and not deleted
171 if Errors.Table (M1).Msg_Cont
172 or else Errors.Table (M2).Msg_Cont
173 or else Errors.Table (M1).Deleted
174 or else Errors.Table (M2).Deleted
179 -- Definitely not equal if message text does not match
181 if not Same_Error (M1, M2) then
185 -- Same text. See if all continuations are also identical
191 N1 := Errors.Table (L1).Next;
192 N2 := Errors.Table (L2).Next;
194 -- If M1 continuations have run out, we delete M1, either the
195 -- messages have the same number of continuations, or M2 has
196 -- more and we prefer the one with more anyway.
198 if N1 = No_Error_Msg or else not Errors.Table (N1).Msg_Cont then
202 -- If M2 continuations have run out, we delete M2
204 elsif N2 = No_Error_Msg or else not Errors.Table (N2).Msg_Cont then
208 -- Otherwise see if continuations are the same, if not, keep both
209 -- sequences, a curious case, but better to keep everything.
211 elsif not Same_Error (N1, N2) then
214 -- If continuations are the same, continue scan
221 end Check_Duplicate_Message;
223 ------------------------
224 -- Compilation_Errors --
225 ------------------------
227 function Compilation_Errors return Boolean is
229 return Total_Errors_Detected /= 0
230 or else (Warnings_Detected /= 0
231 and then Warning_Mode = Treat_As_Error)
232 or else Warnings_Treated_As_Errors /= 0;
233 end Compilation_Errors;
239 procedure Debug_Output (N : Node_Id) is
242 Write_Str ("*** following error message posted on node id = #");
253 procedure dmsg (Id : Error_Msg_Id) is
254 E : Error_Msg_Object renames Errors.Table (Id);
257 w ("Dumping error message, Id = ", Int (Id));
258 w (" Text = ", E.Text.all);
259 w (" Next = ", Int (E.Next));
260 w (" Sfile = ", Int (E.Sfile));
264 Write_Location (E.Sptr);
269 Write_Location (E.Optr);
272 w (" Line = ", Int (E.Line));
273 w (" Col = ", Int (E.Col));
274 w (" Warn = ", E.Warn);
275 w (" Style = ", E.Style);
276 w (" Serious = ", E.Serious);
277 w (" Uncond = ", E.Uncond);
278 w (" Msg_Cont = ", E.Msg_Cont);
279 w (" Deleted = ", E.Deleted);
288 function Get_Location (E : Error_Msg_Id) return Source_Ptr is
290 return Errors.Table (E).Sptr;
297 function Get_Msg_Id return Error_Msg_Id is
302 ---------------------
303 -- Get_Warning_Tag --
304 ---------------------
306 function Get_Warning_Tag (Id : Error_Msg_Id) return String is
307 Warn : constant Boolean := Errors.Table (Id).Warn;
308 Warn_Chr : constant Character := Errors.Table (Id).Warn_Chr;
310 if Warn and then Warn_Chr /= ' ' then
311 if Warn_Chr = '?' then
312 return " [enabled by default]";
313 elsif Warn_Chr in 'a' .. 'z' then
314 return " [-gnatw" & Warn_Chr & ']';
315 else pragma Assert (Warn_Chr in 'A' .. 'Z');
316 return " [-gnatw." & Fold_Lower (Warn_Chr) & ']';
327 function Matches (S : String; P : String) return Boolean is
328 Slast : constant Natural := S'Last;
329 PLast : constant Natural := P'Last;
331 SPtr : Natural := S'First;
332 PPtr : Natural := P'First;
335 -- Loop advancing through characters of string and pattern
340 -- Return True if pattern is a single asterisk
342 if PPtr = PLast and then P (PPtr) = '*' then
345 -- Return True if both pattern and string exhausted
347 elsif PPtr > PLast and then SPtr > Slast then
350 -- Return False, if one exhausted and not the other
352 elsif PPtr > PLast or else SPtr > Slast then
355 -- Case where pattern starts with asterisk
357 elsif P (PPtr) = '*' then
359 -- Try all possible starting positions in S for match with the
360 -- remaining characters of the pattern. This is the recursive
361 -- call that implements the scanner backup.
363 for J in SPtr .. Slast loop
364 if Matches (S (J .. Slast), P (PPtr + 1 .. PLast)) then
371 -- Dealt with end of string and *, advance if we have a match
373 elsif Fold_Lower (S (SPtr)) = Fold_Lower (P (PPtr)) then
377 -- If first characters do not match, that's decisive
385 -----------------------
386 -- Output_Error_Msgs --
387 -----------------------
389 procedure Output_Error_Msgs (E : in out Error_Msg_Id) is
395 Mult_Flags : Boolean := False;
400 -- Skip deleted messages at start
402 if Errors.Table (S).Deleted then
403 Set_Next_Non_Deleted_Msg (S);
406 -- Figure out if we will place more than one error flag on this line
409 while T /= No_Error_Msg
410 and then Errors.Table (T).Line = Errors.Table (E).Line
411 and then Errors.Table (T).Sfile = Errors.Table (E).Sfile
413 if Errors.Table (T).Sptr > Errors.Table (E).Sptr then
417 Set_Next_Non_Deleted_Msg (T);
420 -- Output the error flags. The circuit here makes sure that the tab
421 -- characters in the original line are properly accounted for. The
422 -- eight blanks at the start are to match the line number.
424 if not Debug_Flag_2 then
426 P := Line_Start (Errors.Table (E).Sptr);
429 -- Loop through error messages for this line to place flags
432 while T /= No_Error_Msg
433 and then Errors.Table (T).Line = Errors.Table (E).Line
434 and then Errors.Table (T).Sfile = Errors.Table (E).Sfile
436 -- Loop to output blanks till current flag position
438 while P < Errors.Table (T).Sptr loop
439 if Source_Text (Errors.Table (T).Sfile) (P) = ASCII.HT then
440 Write_Char (ASCII.HT);
448 -- Output flag (unless already output, this happens if more
449 -- than one error message occurs at the same flag position).
451 if P = Errors.Table (T).Sptr then
452 if (Flag_Num = 1 and then not Mult_Flags)
457 Write_Char (Character'Val (Character'Pos ('0') + Flag_Num));
463 Set_Next_Non_Deleted_Msg (T);
464 Flag_Num := Flag_Num + 1;
470 -- Now output the error messages
473 while T /= No_Error_Msg
474 and then Errors.Table (T).Line = Errors.Table (E).Line
475 and then Errors.Table (T).Sfile = Errors.Table (E).Sfile
481 while Column < 74 loop
489 Set_Next_Non_Deleted_Msg (T);
493 end Output_Error_Msgs;
495 ------------------------
496 -- Output_Line_Number --
497 ------------------------
499 procedure Output_Line_Number (L : Logical_Line_Number) is
500 D : Int; -- next digit
501 C : Character; -- next character
502 Z : Boolean; -- flag for zero suppress
503 N, M : Int; -- temporaries
506 if L = No_Line_Number then
527 C := Character'Val (D + 48);
535 end Output_Line_Number;
537 ---------------------
538 -- Output_Msg_Text --
539 ---------------------
541 procedure Output_Msg_Text (E : Error_Msg_Id) is
542 Offs : constant Nat := Column - 1;
543 -- Offset to start of message, used for continuations
546 -- Maximum characters to output on next line
549 -- Maximum total length of lines
551 Text : constant String_Ptr := Errors.Table (E).Text;
557 -- Set error message line length
559 if Error_Msg_Line_Length = 0 then
562 Length := Error_Msg_Line_Length;
565 Max := Integer (Length - Column + 1);
568 Txt : constant String := Text.all & Get_Warning_Tag (E);
569 Len : constant Natural := Txt'Length;
572 -- For warning, add "warning: " unless msg starts with "info: "
574 if Errors.Table (E).Warn then
576 or else Txt (Txt'First .. Txt'First + 5) /= "info: "
578 -- One more check, if warning is to be treated as error, then
579 -- here is where we deal with that.
581 if Errors.Table (E).Warn_Err then
582 Write_Str ("warning(error): ");
583 Warnings_Treated_As_Errors := Warnings_Treated_As_Errors + 1;
589 Write_Str ("warning: ");
594 -- No prefix needed for style message, "(style)" is there already
596 elsif Errors.Table (E).Style then
599 -- All other cases, add "error: "
601 elsif Opt.Unique_Error_Tag then
602 Write_Str ("error: ");
606 -- Here we have to split the message up into multiple lines
610 -- Make sure we do not have ludicrously small line
612 Max := Integer'Max (Max, 20);
614 -- If remaining text fits, output it respecting LF and we are done
616 if Len - Ptr < Max then
617 for J in Ptr .. Len loop
618 if Txt (J) = ASCII.LF then
622 Write_Char (Txt (J));
633 -- First scan forward looking for a hard end of line
635 for Scan in Ptr .. Ptr + Max - 1 loop
636 if Txt (Scan) = ASCII.LF then
643 -- Otherwise scan backwards looking for a space
645 for Scan in reverse Ptr .. Ptr + Max - 1 loop
646 if Txt (Scan) = ' ' then
653 -- If we fall through, no space, so split line arbitrarily
655 Split := Ptr + Max - 1;
660 if Start <= Split then
661 Write_Line (Txt (Start .. Split));
665 Max := Integer (Length - Column + 1);
674 procedure Purge_Messages (From : Source_Ptr; To : Source_Ptr) is
677 function To_Be_Purged (E : Error_Msg_Id) return Boolean;
678 -- Returns True for a message that is to be purged. Also adjusts
679 -- error counts appropriately.
685 function To_Be_Purged (E : Error_Msg_Id) return Boolean is
688 and then Errors.Table (E).Sptr > From
689 and then Errors.Table (E).Sptr < To
691 if Errors.Table (E).Warn or else Errors.Table (E).Style then
692 Warnings_Detected := Warnings_Detected - 1;
695 Total_Errors_Detected := Total_Errors_Detected - 1;
697 if Errors.Table (E).Serious then
698 Serious_Errors_Detected := Serious_Errors_Detected - 1;
709 -- Start of processing for Purge_Messages
712 while To_Be_Purged (First_Error_Msg) loop
713 First_Error_Msg := Errors.Table (First_Error_Msg).Next;
716 E := First_Error_Msg;
717 while E /= No_Error_Msg loop
718 while To_Be_Purged (Errors.Table (E).Next) loop
719 Errors.Table (E).Next :=
720 Errors.Table (Errors.Table (E).Next).Next;
723 E := Errors.Table (E).Next;
731 function Same_Error (M1, M2 : Error_Msg_Id) return Boolean is
732 Msg1 : constant String_Ptr := Errors.Table (M1).Text;
733 Msg2 : constant String_Ptr := Errors.Table (M2).Text;
735 Msg2_Len : constant Integer := Msg2'Length;
736 Msg1_Len : constant Integer := Msg1'Length;
742 (Msg1_Len - 10 > Msg2_Len
744 Msg2.all = Msg1.all (1 .. Msg2_Len)
746 Msg1 (Msg2_Len + 1 .. Msg2_Len + 10) = ", instance")
748 (Msg2_Len - 10 > Msg1_Len
750 Msg1.all = Msg2.all (1 .. Msg1_Len)
752 Msg2 (Msg1_Len + 1 .. Msg1_Len + 10) = ", instance");
759 procedure Set_Msg_Blank is
762 and then Msg_Buffer (Msglen) /= ' '
763 and then Msg_Buffer (Msglen) /= '('
764 and then Msg_Buffer (Msglen) /= '-'
765 and then not Manual_Quote_Mode
771 -------------------------------
772 -- Set_Msg_Blank_Conditional --
773 -------------------------------
775 procedure Set_Msg_Blank_Conditional is
778 and then Msg_Buffer (Msglen) /= ' '
779 and then Msg_Buffer (Msglen) /= '('
780 and then Msg_Buffer (Msglen) /= '"'
781 and then not Manual_Quote_Mode
785 end Set_Msg_Blank_Conditional;
791 procedure Set_Msg_Char (C : Character) is
794 -- The check for message buffer overflow is needed to deal with cases
795 -- where insertions get too long (in particular a child unit name can
798 if Msglen < Max_Msg_Length then
799 Msglen := Msglen + 1;
800 Msg_Buffer (Msglen) := C;
804 ---------------------------------
805 -- Set_Msg_Insertion_File_Name --
806 ---------------------------------
808 procedure Set_Msg_Insertion_File_Name is
810 if Error_Msg_File_1 = No_File then
813 elsif Error_Msg_File_1 = Error_File_Name then
815 Set_Msg_Str ("<error>");
819 Get_Name_String (Error_Msg_File_1);
825 -- The following assignments ensure that the second and third {
826 -- insertion characters will correspond to the Error_Msg_File_2 and
827 -- Error_Msg_File_3 values and We suppress possible validity checks in
828 -- case operating in -gnatVa mode, and Error_Msg_File_2 or
829 -- Error_Msg_File_3 is not needed and has not been set.
832 pragma Suppress (Range_Check);
834 Error_Msg_File_1 := Error_Msg_File_2;
835 Error_Msg_File_2 := Error_Msg_File_3;
837 end Set_Msg_Insertion_File_Name;
839 -----------------------------------
840 -- Set_Msg_Insertion_Line_Number --
841 -----------------------------------
843 procedure Set_Msg_Insertion_Line_Number (Loc, Flag : Source_Ptr) is
844 Sindex_Loc : Source_File_Index;
845 Sindex_Flag : Source_File_Index;
848 -- Outputs "at " unless last characters in buffer are " from ". Certain
849 -- messages read better with from than at.
858 or else Msg_Buffer (Msglen - 5 .. Msglen) /= " from "
864 -- Start of processing for Set_Msg_Insertion_Line_Number
869 if Loc = No_Location then
871 Set_Msg_Str ("unknown location");
873 elsif Loc = System_Location then
874 Set_Msg_Str ("in package System");
875 Set_Msg_Insertion_Run_Time_Name;
877 elsif Loc = Standard_Location then
878 Set_Msg_Str ("in package Standard");
880 elsif Loc = Standard_ASCII_Location then
881 Set_Msg_Str ("in package Standard.ASCII");
884 -- Add "at file-name:" if reference is to other than the source
885 -- file in which the error message is placed. Note that we check
886 -- full file names, rather than just the source indexes, to
887 -- deal with generic instantiations from the current file.
889 Sindex_Loc := Get_Source_File_Index (Loc);
890 Sindex_Flag := Get_Source_File_Index (Flag);
892 if Full_File_Name (Sindex_Loc) /= Full_File_Name (Sindex_Flag) then
895 (Reference_Name (Get_Source_File_Index (Loc)));
899 -- If in current file, add text "at line "
903 Set_Msg_Str ("line ");
906 -- Output line number for reference
908 Set_Msg_Int (Int (Get_Logical_Line_Number (Loc)));
910 -- Deal with the instantiation case. We may have a reference to,
911 -- e.g. a type, that is declared within a generic template, and
912 -- what we are really referring to is the occurrence in an instance.
913 -- In this case, the line number of the instantiation is also of
914 -- interest, and we add a notation:
918 -- where xxx is a line number output using this same routine (and
919 -- the recursion can go further if the instantiation is itself in
920 -- a generic template).
922 -- The flag location passed to us in this situation is indeed the
923 -- line number within the template, but as described in Sinput.L
924 -- (file sinput-l.ads, section "Handling Generic Instantiations")
925 -- we can retrieve the location of the instantiation itself from
926 -- this flag location value.
928 -- Note: this processing is suppressed if Suppress_Instance_Location
929 -- is set True. This is used to prevent redundant annotations of the
930 -- location of the instantiation in the case where we are placing
931 -- the messages on the instantiation in any case.
933 if Instantiation (Sindex_Loc) /= No_Location
934 and then not Suppress_Instance_Location
936 Set_Msg_Str (", instance ");
937 Set_Msg_Insertion_Line_Number (Instantiation (Sindex_Loc), Flag);
940 end Set_Msg_Insertion_Line_Number;
942 ----------------------------
943 -- Set_Msg_Insertion_Name --
944 ----------------------------
946 procedure Set_Msg_Insertion_Name is
948 if Error_Msg_Name_1 = No_Name then
951 elsif Error_Msg_Name_1 = Error_Name then
953 Set_Msg_Str ("<error>");
956 Set_Msg_Blank_Conditional;
957 Get_Unqualified_Decoded_Name_String (Error_Msg_Name_1);
959 -- Remove %s or %b at end. These come from unit names. If the
960 -- caller wanted the (unit) or (body), then they would have used
961 -- the $ insertion character. Certainly no error message should
962 -- ever have %b or %s explicitly occurring.
965 and then Name_Buffer (Name_Len - 1) = '%'
966 and then (Name_Buffer (Name_Len) = 'b'
968 Name_Buffer (Name_Len) = 's')
970 Name_Len := Name_Len - 2;
973 -- Remove upper case letter at end, again, we should not be getting
974 -- such names, and what we hope is that the remainder makes sense.
976 if Name_Len > 1 and then Name_Buffer (Name_Len) in 'A' .. 'Z' then
977 Name_Len := Name_Len - 1;
980 -- If operator name or character literal name, just print it as is
981 -- Also print as is if it ends in a right paren (case of x'val(nnn))
983 if Name_Buffer (1) = '"'
984 or else Name_Buffer (1) = '''
985 or else Name_Buffer (Name_Len) = ')'
989 -- Else output with surrounding quotes in proper casing mode
992 Set_Casing (Identifier_Casing (Flag_Source), Mixed_Case);
999 -- The following assignments ensure that the second and third percent
1000 -- insertion characters will correspond to the Error_Msg_Name_2 and
1001 -- Error_Msg_Name_3 as required. We suppress possible validity checks in
1002 -- case operating in -gnatVa mode, and Error_Msg_Name_1/2 is not needed
1003 -- and has not been set.
1006 pragma Suppress (Range_Check);
1008 Error_Msg_Name_1 := Error_Msg_Name_2;
1009 Error_Msg_Name_2 := Error_Msg_Name_3;
1011 end Set_Msg_Insertion_Name;
1013 ------------------------------------
1014 -- Set_Msg_Insertion_Name_Literal --
1015 ------------------------------------
1017 procedure Set_Msg_Insertion_Name_Literal is
1019 if Error_Msg_Name_1 = No_Name then
1022 elsif Error_Msg_Name_1 = Error_Name then
1024 Set_Msg_Str ("<error>");
1028 Get_Name_String (Error_Msg_Name_1);
1030 Set_Msg_Name_Buffer;
1034 -- The following assignments ensure that the second and third % or %%
1035 -- insertion characters will correspond to the Error_Msg_Name_2 and
1036 -- Error_Msg_Name_3 values and We suppress possible validity checks in
1037 -- case operating in -gnatVa mode, and Error_Msg_Name_2 or
1038 -- Error_Msg_Name_3 is not needed and has not been set.
1041 pragma Suppress (Range_Check);
1043 Error_Msg_Name_1 := Error_Msg_Name_2;
1044 Error_Msg_Name_2 := Error_Msg_Name_3;
1046 end Set_Msg_Insertion_Name_Literal;
1048 -------------------------------------
1049 -- Set_Msg_Insertion_Reserved_Name --
1050 -------------------------------------
1052 procedure Set_Msg_Insertion_Reserved_Name is
1054 Set_Msg_Blank_Conditional;
1055 Get_Name_String (Error_Msg_Name_1);
1057 Set_Casing (Keyword_Casing (Flag_Source), All_Lower_Case);
1058 Set_Msg_Name_Buffer;
1060 end Set_Msg_Insertion_Reserved_Name;
1062 -------------------------------------
1063 -- Set_Msg_Insertion_Reserved_Word --
1064 -------------------------------------
1066 procedure Set_Msg_Insertion_Reserved_Word
1071 Set_Msg_Blank_Conditional;
1074 while J <= Text'Last and then Text (J) in 'A' .. 'Z' loop
1075 Add_Char_To_Name_Buffer (Text (J));
1079 -- Here is where we make the special exception for RM
1081 if Name_Len = 2 and then Name_Buffer (1 .. 2) = "RM" then
1082 Set_Msg_Name_Buffer;
1084 -- We make a similar exception for SPARK
1086 elsif Name_Len = 5 and then Name_Buffer (1 .. 5) = "SPARK" then
1087 Set_Msg_Name_Buffer;
1089 -- Neither RM nor SPARK: case appropriately and add surrounding quotes
1092 Set_Casing (Keyword_Casing (Flag_Source), All_Lower_Case);
1094 Set_Msg_Name_Buffer;
1097 end Set_Msg_Insertion_Reserved_Word;
1099 -------------------------------------
1100 -- Set_Msg_Insertion_Run_Time_Name --
1101 -------------------------------------
1103 procedure Set_Msg_Insertion_Run_Time_Name is
1105 if Targparm.Run_Time_Name_On_Target /= No_Name then
1106 Set_Msg_Blank_Conditional;
1108 Get_Name_String (Targparm.Run_Time_Name_On_Target);
1109 Set_Casing (Mixed_Case);
1110 Set_Msg_Str (Name_Buffer (1 .. Name_Len));
1113 end Set_Msg_Insertion_Run_Time_Name;
1115 ----------------------------
1116 -- Set_Msg_Insertion_Uint --
1117 ----------------------------
1119 procedure Set_Msg_Insertion_Uint is
1122 UI_Image (Error_Msg_Uint_1);
1124 for J in 1 .. UI_Image_Length loop
1125 Set_Msg_Char (UI_Image_Buffer (J));
1128 -- The following assignment ensures that a second caret insertion
1129 -- character will correspond to the Error_Msg_Uint_2 parameter. We
1130 -- suppress possible validity checks in case operating in -gnatVa mode,
1131 -- and Error_Msg_Uint_2 is not needed and has not been set.
1134 pragma Suppress (Range_Check);
1136 Error_Msg_Uint_1 := Error_Msg_Uint_2;
1138 end Set_Msg_Insertion_Uint;
1144 procedure Set_Msg_Int (Line : Int) is
1147 Set_Msg_Int (Line / 10);
1150 Set_Msg_Char (Character'Val (Character'Pos ('0') + (Line rem 10)));
1153 -------------------------
1154 -- Set_Msg_Name_Buffer --
1155 -------------------------
1157 procedure Set_Msg_Name_Buffer is
1159 for J in 1 .. Name_Len loop
1160 Set_Msg_Char (Name_Buffer (J));
1162 end Set_Msg_Name_Buffer;
1168 procedure Set_Msg_Quote is
1170 if not Manual_Quote_Mode then
1179 procedure Set_Msg_Str (Text : String) is
1181 for J in Text'Range loop
1182 Set_Msg_Char (Text (J));
1186 ------------------------------
1187 -- Set_Next_Non_Deleted_Msg --
1188 ------------------------------
1190 procedure Set_Next_Non_Deleted_Msg (E : in out Error_Msg_Id) is
1192 if E = No_Error_Msg then
1197 E := Errors.Table (E).Next;
1198 exit when E = No_Error_Msg or else not Errors.Table (E).Deleted;
1201 end Set_Next_Non_Deleted_Msg;
1203 ------------------------------
1204 -- Set_Specific_Warning_Off --
1205 ------------------------------
1207 procedure Set_Specific_Warning_Off
1212 Used : Boolean := False)
1215 Specific_Warnings.Append
1217 Msg => new String'(Msg),
1218 Stop => Source_Last (Current_Source_File),
1223 end Set_Specific_Warning_Off;
1225 -----------------------------
1226 -- Set_Specific_Warning_On --
1227 -----------------------------
1229 procedure Set_Specific_Warning_On
1235 for J in 1 .. Specific_Warnings.Last loop
1237 SWE : Specific_Warning_Entry renames Specific_Warnings.Table (J);
1239 if Msg = SWE.Msg.all
1240 and then Loc > SWE.Start
1242 and then Get_Source_File_Index (SWE.Start) =
1243 Get_Source_File_Index (Loc)
1249 -- If a config pragma is specifically cancelled, consider
1250 -- that it is no longer active as a configuration pragma.
1252 SWE.Config := False;
1259 end Set_Specific_Warning_On;
1261 ---------------------------
1262 -- Set_Warnings_Mode_Off --
1263 ---------------------------
1265 procedure Set_Warnings_Mode_Off (Loc : Source_Ptr; Reason : String_Id) is
1267 -- Don't bother with entries from instantiation copies, since we will
1268 -- already have a copy in the template, which is what matters.
1270 if Instantiation (Get_Source_File_Index (Loc)) /= No_Location then
1274 -- If all warnings are suppressed by command line switch, this can
1275 -- be ignored, unless we are in GNATprove_Mode which requires pragma
1276 -- Warnings to be stored for the formal verification backend.
1278 if Warning_Mode = Suppress
1279 and then not GNATprove_Mode
1284 -- If last entry in table already covers us, this is a redundant pragma
1285 -- Warnings (Off) and can be ignored.
1287 if Warnings.Last >= Warnings.First
1288 and then Warnings.Table (Warnings.Last).Start <= Loc
1289 and then Loc <= Warnings.Table (Warnings.Last).Stop
1294 -- If none of those special conditions holds, establish a new entry,
1295 -- extending from the location of the pragma to the end of the current
1296 -- source file. This ending point will be adjusted by a subsequent
1297 -- corresponding pragma Warnings (On).
1301 Stop => Source_Last (Current_Source_File),
1303 end Set_Warnings_Mode_Off;
1305 --------------------------
1306 -- Set_Warnings_Mode_On --
1307 --------------------------
1309 procedure Set_Warnings_Mode_On (Loc : Source_Ptr) is
1311 -- Don't bother with entries from instantiation copies, since we will
1312 -- already have a copy in the template, which is what matters.
1314 if Instantiation (Get_Source_File_Index (Loc)) /= No_Location then
1318 -- If all warnings are suppressed by command line switch, this can
1319 -- be ignored, unless we are in GNATprove_Mode which requires pragma
1320 -- Warnings to be stored for the formal verification backend.
1322 if Warning_Mode = Suppress
1323 and then not GNATprove_Mode
1328 -- If the last entry in the warnings table covers this pragma, then
1329 -- we adjust the end point appropriately.
1331 if Warnings.Last >= Warnings.First
1332 and then Warnings.Table (Warnings.Last).Start <= Loc
1333 and then Loc <= Warnings.Table (Warnings.Last).Stop
1335 Warnings.Table (Warnings.Last).Stop := Loc;
1337 end Set_Warnings_Mode_On;
1339 ------------------------------------
1340 -- Test_Style_Warning_Serious_Msg --
1341 ------------------------------------
1343 procedure Test_Style_Warning_Serious_Unconditional_Msg (Msg : String) is
1345 -- Nothing to do for continuation line
1347 if Msg (Msg'First) = '\' then
1351 -- Set initial values of globals (may be changed during scan)
1353 Is_Serious_Error := True;
1354 Is_Unconditional_Msg := False;
1355 Is_Warning_Msg := False;
1356 Has_Double_Exclam := False;
1359 (Msg'Length > 7 and then Msg (Msg'First .. Msg'First + 6) = "(style)");
1361 for J in Msg'Range loop
1363 and then (J = Msg'First or else Msg (J - 1) /= ''')
1365 Is_Warning_Msg := True;
1366 Warning_Msg_Char := ' ';
1369 and then (J = Msg'First or else Msg (J - 1) /= ''')
1371 Is_Unconditional_Msg := True;
1372 Warning_Msg_Char := ' ';
1374 if J < Msg'Last and then Msg (J + 1) = '!' then
1375 Has_Double_Exclam := True;
1379 and then (J = Msg'First or else Msg (J - 1) /= ''')
1381 Is_Warning_Msg := Error_Msg_Warn;
1382 Warning_Msg_Char := ' ';
1385 and then (J = Msg'First or else Msg (J - 1) /= ''')
1387 Is_Serious_Error := False;
1391 if Is_Warning_Msg or Is_Style_Msg then
1392 Is_Serious_Error := False;
1394 end Test_Style_Warning_Serious_Unconditional_Msg;
1396 --------------------------------
1397 -- Validate_Specific_Warnings --
1398 --------------------------------
1400 procedure Validate_Specific_Warnings (Eproc : Error_Msg_Proc) is
1402 if not Warn_On_Warnings_Off then
1406 for J in Specific_Warnings.First .. Specific_Warnings.Last loop
1408 SWE : Specific_Warning_Entry renames Specific_Warnings.Table (J);
1411 if not SWE.Config then
1413 -- Warn for unmatched Warnings (Off, ...)
1417 ("?W?pragma Warnings Off with no matching Warnings On",
1420 -- Warn for ineffective Warnings (Off, ..)
1424 -- Do not issue this warning for -Wxxx messages since the
1425 -- back-end doesn't report the information.
1428 (SWE.Msg'Length > 2 and then SWE.Msg (1 .. 2) = "-W")
1431 ("?W?no warning suppressed by this pragma", SWE.Start);
1436 end Validate_Specific_Warnings;
1438 -------------------------------------
1439 -- Warning_Specifically_Suppressed --
1440 -------------------------------------
1442 function Warning_Specifically_Suppressed
1444 Msg : String_Ptr) return String_Id
1447 -- Loop through specific warning suppression entries
1449 for J in Specific_Warnings.First .. Specific_Warnings.Last loop
1451 SWE : Specific_Warning_Entry renames Specific_Warnings.Table (J);
1454 -- Pragma applies if it is a configuration pragma, or if the
1455 -- location is in range of a specific non-configuration pragma.
1458 or else (SWE.Start <= Loc and then Loc <= SWE.Stop)
1460 if Matches (Msg.all, SWE.Msg.all) then
1469 end Warning_Specifically_Suppressed;
1471 ------------------------------
1472 -- Warning_Treated_As_Error --
1473 ------------------------------
1475 function Warning_Treated_As_Error (Msg : String) return Boolean is
1477 for J in 1 .. Warnings_As_Errors_Count loop
1478 if Matches (Msg, Warnings_As_Errors (J).all) then
1484 end Warning_Treated_As_Error;
1486 -------------------------
1487 -- Warnings_Suppressed --
1488 -------------------------
1490 function Warnings_Suppressed (Loc : Source_Ptr) return String_Id is
1492 -- Loop through table of ON/OFF warnings
1494 for J in Warnings.First .. Warnings.Last loop
1495 if Warnings.Table (J).Start <= Loc
1496 and then Loc <= Warnings.Table (J).Stop
1498 return Warnings.Table (J).Reason;
1502 if Warning_Mode = Suppress then
1503 return Null_String_Id;
1507 end Warnings_Suppressed;