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 Targparm; use Targparm;
43 with Uintp; use Uintp;
45 package body Erroutc is
51 procedure Add_Class is
56 Get_Name_String (Name_Class);
57 Set_Casing (Identifier_Casing (Flag_Source), Mixed_Case);
62 ----------------------
63 -- Buffer_Ends_With --
64 ----------------------
66 function Buffer_Ends_With (S : String) return Boolean is
67 Len : constant Natural := S'Length;
71 and then Msg_Buffer (Msglen - Len) = ' '
72 and then Msg_Buffer (Msglen - Len + 1 .. Msglen) = S;
79 procedure Buffer_Remove (S : String) is
81 if Buffer_Ends_With (S) then
82 Msglen := Msglen - S'Length;
86 -----------------------------
87 -- Check_Duplicate_Message --
88 -----------------------------
90 procedure Check_Duplicate_Message (M1, M2 : Error_Msg_Id) is
91 L1, L2 : Error_Msg_Id;
92 N1, N2 : Error_Msg_Id;
94 procedure Delete_Msg (Delete, Keep : Error_Msg_Id);
95 -- Called to delete message Delete, keeping message Keep. Marks
96 -- all messages of Delete with deleted flag set to True, and also
97 -- makes sure that for the error messages that are retained the
98 -- preferred message is the one retained (we prefer the shorter
99 -- one in the case where one has an Instance tag). Note that we
100 -- always know that Keep has at least as many continuations as
101 -- Delete (since we always delete the shorter sequence).
107 procedure Delete_Msg (Delete, Keep : Error_Msg_Id) is
115 Errors.Table (D).Deleted := True;
117 -- Adjust error message count
119 if Errors.Table (D).Warn or else Errors.Table (D).Style then
120 Warnings_Detected := Warnings_Detected - 1;
123 Total_Errors_Detected := Total_Errors_Detected - 1;
125 if Errors.Table (D).Serious then
126 Serious_Errors_Detected := Serious_Errors_Detected - 1;
130 -- Substitute shorter of the two error messages
132 if Errors.Table (K).Text'Length > Errors.Table (D).Text'Length then
133 Errors.Table (K).Text := Errors.Table (D).Text;
136 D := Errors.Table (D).Next;
137 K := Errors.Table (K).Next;
139 if D = No_Error_Msg or else not Errors.Table (D).Msg_Cont then
145 -- Start of processing for Check_Duplicate_Message
148 -- Both messages must be non-continuation messages and not deleted
150 if Errors.Table (M1).Msg_Cont
151 or else Errors.Table (M2).Msg_Cont
152 or else Errors.Table (M1).Deleted
153 or else Errors.Table (M2).Deleted
158 -- Definitely not equal if message text does not match
160 if not Same_Error (M1, M2) then
164 -- Same text. See if all continuations are also identical
170 N1 := Errors.Table (L1).Next;
171 N2 := Errors.Table (L2).Next;
173 -- If M1 continuations have run out, we delete M1, either the
174 -- messages have the same number of continuations, or M2 has
175 -- more and we prefer the one with more anyway.
177 if N1 = No_Error_Msg or else not Errors.Table (N1).Msg_Cont then
181 -- If M2 continuations have run out, we delete M2
183 elsif N2 = No_Error_Msg or else not Errors.Table (N2).Msg_Cont then
187 -- Otherwise see if continuations are the same, if not, keep both
188 -- sequences, a curious case, but better to keep everything.
190 elsif not Same_Error (N1, N2) then
193 -- If continuations are the same, continue scan
200 end Check_Duplicate_Message;
202 ------------------------
203 -- Compilation_Errors --
204 ------------------------
206 function Compilation_Errors return Boolean is
208 return Total_Errors_Detected /= 0
209 or else (Warnings_Detected /= 0
210 and then Warning_Mode = Treat_As_Error);
211 end Compilation_Errors;
217 procedure Debug_Output (N : Node_Id) is
220 Write_Str ("*** following error message posted on node id = #");
231 procedure dmsg (Id : Error_Msg_Id) is
232 E : Error_Msg_Object renames Errors.Table (Id);
235 w ("Dumping error message, Id = ", Int (Id));
236 w (" Text = ", E.Text.all);
237 w (" Next = ", Int (E.Next));
238 w (" Sfile = ", Int (E.Sfile));
242 Write_Location (E.Sptr);
247 Write_Location (E.Optr);
250 w (" Line = ", Int (E.Line));
251 w (" Col = ", Int (E.Col));
252 w (" Warn = ", E.Warn);
253 w (" Style = ", E.Style);
254 w (" Serious = ", E.Serious);
255 w (" Uncond = ", E.Uncond);
256 w (" Msg_Cont = ", E.Msg_Cont);
257 w (" Deleted = ", E.Deleted);
266 function Get_Location (E : Error_Msg_Id) return Source_Ptr is
268 return Errors.Table (E).Sptr;
275 function Get_Msg_Id return Error_Msg_Id is
280 -----------------------
281 -- Output_Error_Msgs --
282 -----------------------
284 procedure Output_Error_Msgs (E : in out Error_Msg_Id) is
290 Mult_Flags : Boolean := False;
295 -- Skip deleted messages at start
297 if Errors.Table (S).Deleted then
298 Set_Next_Non_Deleted_Msg (S);
301 -- Figure out if we will place more than one error flag on this line
304 while T /= No_Error_Msg
305 and then Errors.Table (T).Line = Errors.Table (E).Line
306 and then Errors.Table (T).Sfile = Errors.Table (E).Sfile
308 if Errors.Table (T).Sptr > Errors.Table (E).Sptr then
312 Set_Next_Non_Deleted_Msg (T);
315 -- Output the error flags. The circuit here makes sure that the tab
316 -- characters in the original line are properly accounted for. The
317 -- eight blanks at the start are to match the line number.
319 if not Debug_Flag_2 then
321 P := Line_Start (Errors.Table (E).Sptr);
324 -- Loop through error messages for this line to place flags
327 while T /= No_Error_Msg
328 and then Errors.Table (T).Line = Errors.Table (E).Line
329 and then Errors.Table (T).Sfile = Errors.Table (E).Sfile
331 -- Loop to output blanks till current flag position
333 while P < Errors.Table (T).Sptr loop
334 if Source_Text (Errors.Table (T).Sfile) (P) = ASCII.HT then
335 Write_Char (ASCII.HT);
343 -- Output flag (unless already output, this happens if more
344 -- than one error message occurs at the same flag position).
346 if P = Errors.Table (T).Sptr then
347 if (Flag_Num = 1 and then not Mult_Flags)
352 Write_Char (Character'Val (Character'Pos ('0') + Flag_Num));
358 Set_Next_Non_Deleted_Msg (T);
359 Flag_Num := Flag_Num + 1;
365 -- Now output the error messages
368 while T /= No_Error_Msg
369 and then Errors.Table (T).Line = Errors.Table (E).Line
370 and then Errors.Table (T).Sfile = Errors.Table (E).Sfile
376 while Column < 74 loop
384 Set_Next_Non_Deleted_Msg (T);
388 end Output_Error_Msgs;
390 ------------------------
391 -- Output_Line_Number --
392 ------------------------
394 procedure Output_Line_Number (L : Logical_Line_Number) is
395 D : Int; -- next digit
396 C : Character; -- next character
397 Z : Boolean; -- flag for zero suppress
398 N, M : Int; -- temporaries
401 if L = No_Line_Number then
422 C := Character'Val (D + 48);
430 end Output_Line_Number;
432 ---------------------
433 -- Output_Msg_Text --
434 ---------------------
436 procedure Output_Msg_Text (E : Error_Msg_Id) is
437 Offs : constant Nat := Column - 1;
438 -- Offset to start of message, used for continuations
441 -- Maximum characters to output on next line
444 -- Maximum total length of lines
446 Text : constant String_Ptr := Errors.Table (E).Text;
447 Warn : constant Boolean := Errors.Table (E).Warn;
448 Warn_Chr : constant Character := Errors.Table (E).Warn_Chr;
449 Warn_Tag : String_Ptr;
455 -- Add warning doc tag if needed
457 if Warn and then Warn_Chr /= ' ' then
458 if Warn_Chr = '?' then
459 Warn_Tag := new String'(" [enabled by default]");
461 elsif Warn_Chr in 'a' .. 'z' then
462 Warn_Tag := new String'(" [-gnatw" & Warn_Chr & ']');
464 else pragma Assert (Warn_Chr in 'A' .. 'Z');
465 Warn_Tag := new String'(" [-gnatw." & Fold_Lower (Warn_Chr) & ']');
469 Warn_Tag := new String'("");
472 -- Set error message line length
474 if Error_Msg_Line_Length = 0 then
477 Length := Error_Msg_Line_Length;
480 Max := Integer (Length - Column + 1);
483 Txt : constant String := Text.all & Warn_Tag.all;
484 Len : constant Natural := Txt'Length;
487 -- For warning, add "warning: " unless msg starts with "info: "
489 if Errors.Table (E).Warn then
491 or else Txt (Txt'First .. Txt'First + 5) /= "info: "
493 Write_Str ("warning: ");
497 -- No prefix needed for style message, "(style)" is there already
499 elsif Errors.Table (E).Style then
502 -- All other cases, add "error: "
504 elsif Opt.Unique_Error_Tag then
505 Write_Str ("error: ");
509 -- Here we have to split the message up into multiple lines
513 -- Make sure we do not have ludicrously small line
515 Max := Integer'Max (Max, 20);
517 -- If remaining text fits, output it respecting LF and we are done
519 if Len - Ptr < Max then
520 for J in Ptr .. Len loop
521 if Txt (J) = ASCII.LF then
525 Write_Char (Txt (J));
536 -- First scan forward looking for a hard end of line
538 for Scan in Ptr .. Ptr + Max - 1 loop
539 if Txt (Scan) = ASCII.LF then
546 -- Otherwise scan backwards looking for a space
548 for Scan in reverse Ptr .. Ptr + Max - 1 loop
549 if Txt (Scan) = ' ' then
556 -- If we fall through, no space, so split line arbitrarily
558 Split := Ptr + Max - 1;
563 if Start <= Split then
564 Write_Line (Txt (Start .. Split));
568 Max := Integer (Length - Column + 1);
577 procedure Purge_Messages (From : Source_Ptr; To : Source_Ptr) is
580 function To_Be_Purged (E : Error_Msg_Id) return Boolean;
581 -- Returns True for a message that is to be purged. Also adjusts
582 -- error counts appropriately.
588 function To_Be_Purged (E : Error_Msg_Id) return Boolean is
591 and then Errors.Table (E).Sptr > From
592 and then Errors.Table (E).Sptr < To
594 if Errors.Table (E).Warn or else Errors.Table (E).Style then
595 Warnings_Detected := Warnings_Detected - 1;
598 Total_Errors_Detected := Total_Errors_Detected - 1;
600 if Errors.Table (E).Serious then
601 Serious_Errors_Detected := Serious_Errors_Detected - 1;
612 -- Start of processing for Purge_Messages
615 while To_Be_Purged (First_Error_Msg) loop
616 First_Error_Msg := Errors.Table (First_Error_Msg).Next;
619 E := First_Error_Msg;
620 while E /= No_Error_Msg loop
621 while To_Be_Purged (Errors.Table (E).Next) loop
622 Errors.Table (E).Next :=
623 Errors.Table (Errors.Table (E).Next).Next;
626 E := Errors.Table (E).Next;
634 function Same_Error (M1, M2 : Error_Msg_Id) return Boolean is
635 Msg1 : constant String_Ptr := Errors.Table (M1).Text;
636 Msg2 : constant String_Ptr := Errors.Table (M2).Text;
638 Msg2_Len : constant Integer := Msg2'Length;
639 Msg1_Len : constant Integer := Msg1'Length;
645 (Msg1_Len - 10 > Msg2_Len
647 Msg2.all = Msg1.all (1 .. Msg2_Len)
649 Msg1 (Msg2_Len + 1 .. Msg2_Len + 10) = ", instance")
651 (Msg2_Len - 10 > Msg1_Len
653 Msg1.all = Msg2.all (1 .. Msg1_Len)
655 Msg2 (Msg1_Len + 1 .. Msg1_Len + 10) = ", instance");
662 procedure Set_Msg_Blank is
665 and then Msg_Buffer (Msglen) /= ' '
666 and then Msg_Buffer (Msglen) /= '('
667 and then Msg_Buffer (Msglen) /= '-'
668 and then not Manual_Quote_Mode
674 -------------------------------
675 -- Set_Msg_Blank_Conditional --
676 -------------------------------
678 procedure Set_Msg_Blank_Conditional is
681 and then Msg_Buffer (Msglen) /= ' '
682 and then Msg_Buffer (Msglen) /= '('
683 and then Msg_Buffer (Msglen) /= '"'
684 and then not Manual_Quote_Mode
688 end Set_Msg_Blank_Conditional;
694 procedure Set_Msg_Char (C : Character) is
697 -- The check for message buffer overflow is needed to deal with cases
698 -- where insertions get too long (in particular a child unit name can
701 if Msglen < Max_Msg_Length then
702 Msglen := Msglen + 1;
703 Msg_Buffer (Msglen) := C;
707 ---------------------------------
708 -- Set_Msg_Insertion_File_Name --
709 ---------------------------------
711 procedure Set_Msg_Insertion_File_Name is
713 if Error_Msg_File_1 = No_File then
716 elsif Error_Msg_File_1 = Error_File_Name then
718 Set_Msg_Str ("<error>");
722 Get_Name_String (Error_Msg_File_1);
728 -- The following assignments ensure that the second and third {
729 -- insertion characters will correspond to the Error_Msg_File_2 and
730 -- Error_Msg_File_3 values and We suppress possible validity checks in
731 -- case operating in -gnatVa mode, and Error_Msg_File_2 or
732 -- Error_Msg_File_3 is not needed and has not been set.
735 pragma Suppress (Range_Check);
737 Error_Msg_File_1 := Error_Msg_File_2;
738 Error_Msg_File_2 := Error_Msg_File_3;
740 end Set_Msg_Insertion_File_Name;
742 -----------------------------------
743 -- Set_Msg_Insertion_Line_Number --
744 -----------------------------------
746 procedure Set_Msg_Insertion_Line_Number (Loc, Flag : Source_Ptr) is
747 Sindex_Loc : Source_File_Index;
748 Sindex_Flag : Source_File_Index;
751 -- Outputs "at " unless last characters in buffer are " from ". Certain
752 -- messages read better with from than at.
761 or else Msg_Buffer (Msglen - 5 .. Msglen) /= " from "
767 -- Start of processing for Set_Msg_Insertion_Line_Number
772 if Loc = No_Location then
774 Set_Msg_Str ("unknown location");
776 elsif Loc = System_Location then
777 Set_Msg_Str ("in package System");
778 Set_Msg_Insertion_Run_Time_Name;
780 elsif Loc = Standard_Location then
781 Set_Msg_Str ("in package Standard");
783 elsif Loc = Standard_ASCII_Location then
784 Set_Msg_Str ("in package Standard.ASCII");
787 -- Add "at file-name:" if reference is to other than the source
788 -- file in which the error message is placed. Note that we check
789 -- full file names, rather than just the source indexes, to
790 -- deal with generic instantiations from the current file.
792 Sindex_Loc := Get_Source_File_Index (Loc);
793 Sindex_Flag := Get_Source_File_Index (Flag);
795 if Full_File_Name (Sindex_Loc) /= Full_File_Name (Sindex_Flag) then
798 (Reference_Name (Get_Source_File_Index (Loc)));
802 -- If in current file, add text "at line "
806 Set_Msg_Str ("line ");
809 -- Output line number for reference
811 Set_Msg_Int (Int (Get_Logical_Line_Number (Loc)));
813 -- Deal with the instantiation case. We may have a reference to,
814 -- e.g. a type, that is declared within a generic template, and
815 -- what we are really referring to is the occurrence in an instance.
816 -- In this case, the line number of the instantiation is also of
817 -- interest, and we add a notation:
821 -- where xxx is a line number output using this same routine (and
822 -- the recursion can go further if the instantiation is itself in
823 -- a generic template).
825 -- The flag location passed to us in this situation is indeed the
826 -- line number within the template, but as described in Sinput.L
827 -- (file sinput-l.ads, section "Handling Generic Instantiations")
828 -- we can retrieve the location of the instantiation itself from
829 -- this flag location value.
831 -- Note: this processing is suppressed if Suppress_Instance_Location
832 -- is set True. This is used to prevent redundant annotations of the
833 -- location of the instantiation in the case where we are placing
834 -- the messages on the instantiation in any case.
836 if Instantiation (Sindex_Loc) /= No_Location
837 and then not Suppress_Instance_Location
839 Set_Msg_Str (", instance ");
840 Set_Msg_Insertion_Line_Number (Instantiation (Sindex_Loc), Flag);
843 end Set_Msg_Insertion_Line_Number;
845 ----------------------------
846 -- Set_Msg_Insertion_Name --
847 ----------------------------
849 procedure Set_Msg_Insertion_Name is
851 if Error_Msg_Name_1 = No_Name then
854 elsif Error_Msg_Name_1 = Error_Name then
856 Set_Msg_Str ("<error>");
859 Set_Msg_Blank_Conditional;
860 Get_Unqualified_Decoded_Name_String (Error_Msg_Name_1);
862 -- Remove %s or %b at end. These come from unit names. If the
863 -- caller wanted the (unit) or (body), then they would have used
864 -- the $ insertion character. Certainly no error message should
865 -- ever have %b or %s explicitly occurring.
868 and then Name_Buffer (Name_Len - 1) = '%'
869 and then (Name_Buffer (Name_Len) = 'b'
871 Name_Buffer (Name_Len) = 's')
873 Name_Len := Name_Len - 2;
876 -- Remove upper case letter at end, again, we should not be getting
877 -- such names, and what we hope is that the remainder makes sense.
879 if Name_Len > 1 and then Name_Buffer (Name_Len) in 'A' .. 'Z' then
880 Name_Len := Name_Len - 1;
883 -- If operator name or character literal name, just print it as is
884 -- Also print as is if it ends in a right paren (case of x'val(nnn))
886 if Name_Buffer (1) = '"'
887 or else Name_Buffer (1) = '''
888 or else Name_Buffer (Name_Len) = ')'
892 -- Else output with surrounding quotes in proper casing mode
895 Set_Casing (Identifier_Casing (Flag_Source), Mixed_Case);
902 -- The following assignments ensure that the second and third percent
903 -- insertion characters will correspond to the Error_Msg_Name_2 and
904 -- Error_Msg_Name_3 as required. We suppress possible validity checks in
905 -- case operating in -gnatVa mode, and Error_Msg_Name_1/2 is not needed
906 -- and has not been set.
909 pragma Suppress (Range_Check);
911 Error_Msg_Name_1 := Error_Msg_Name_2;
912 Error_Msg_Name_2 := Error_Msg_Name_3;
914 end Set_Msg_Insertion_Name;
916 ------------------------------------
917 -- Set_Msg_Insertion_Name_Literal --
918 ------------------------------------
920 procedure Set_Msg_Insertion_Name_Literal is
922 if Error_Msg_Name_1 = No_Name then
925 elsif Error_Msg_Name_1 = Error_Name then
927 Set_Msg_Str ("<error>");
931 Get_Name_String (Error_Msg_Name_1);
937 -- The following assignments ensure that the second and third % or %%
938 -- insertion characters will correspond to the Error_Msg_Name_2 and
939 -- Error_Msg_Name_3 values and We suppress possible validity checks in
940 -- case operating in -gnatVa mode, and Error_Msg_Name_2 or
941 -- Error_Msg_Name_3 is not needed and has not been set.
944 pragma Suppress (Range_Check);
946 Error_Msg_Name_1 := Error_Msg_Name_2;
947 Error_Msg_Name_2 := Error_Msg_Name_3;
949 end Set_Msg_Insertion_Name_Literal;
951 -------------------------------------
952 -- Set_Msg_Insertion_Reserved_Name --
953 -------------------------------------
955 procedure Set_Msg_Insertion_Reserved_Name is
957 Set_Msg_Blank_Conditional;
958 Get_Name_String (Error_Msg_Name_1);
960 Set_Casing (Keyword_Casing (Flag_Source), All_Lower_Case);
963 end Set_Msg_Insertion_Reserved_Name;
965 -------------------------------------
966 -- Set_Msg_Insertion_Reserved_Word --
967 -------------------------------------
969 procedure Set_Msg_Insertion_Reserved_Word
974 Set_Msg_Blank_Conditional;
977 while J <= Text'Last and then Text (J) in 'A' .. 'Z' loop
978 Add_Char_To_Name_Buffer (Text (J));
982 -- Here is where we make the special exception for RM
984 if Name_Len = 2 and then Name_Buffer (1 .. 2) = "RM" then
987 -- We make a similar exception for SPARK
989 elsif Name_Len = 5 and then Name_Buffer (1 .. 5) = "SPARK" then
992 -- Neither RM nor SPARK: case appropriately and add surrounding quotes
995 Set_Casing (Keyword_Casing (Flag_Source), All_Lower_Case);
1000 end Set_Msg_Insertion_Reserved_Word;
1002 -------------------------------------
1003 -- Set_Msg_Insertion_Run_Time_Name --
1004 -------------------------------------
1006 procedure Set_Msg_Insertion_Run_Time_Name is
1008 if Targparm.Run_Time_Name_On_Target /= No_Name then
1009 Set_Msg_Blank_Conditional;
1011 Get_Name_String (Targparm.Run_Time_Name_On_Target);
1012 Set_Casing (Mixed_Case);
1013 Set_Msg_Str (Name_Buffer (1 .. Name_Len));
1016 end Set_Msg_Insertion_Run_Time_Name;
1018 ----------------------------
1019 -- Set_Msg_Insertion_Uint --
1020 ----------------------------
1022 procedure Set_Msg_Insertion_Uint is
1025 UI_Image (Error_Msg_Uint_1);
1027 for J in 1 .. UI_Image_Length loop
1028 Set_Msg_Char (UI_Image_Buffer (J));
1031 -- The following assignment ensures that a second caret insertion
1032 -- character will correspond to the Error_Msg_Uint_2 parameter. We
1033 -- suppress possible validity checks in case operating in -gnatVa mode,
1034 -- and Error_Msg_Uint_2 is not needed and has not been set.
1037 pragma Suppress (Range_Check);
1039 Error_Msg_Uint_1 := Error_Msg_Uint_2;
1041 end Set_Msg_Insertion_Uint;
1047 procedure Set_Msg_Int (Line : Int) is
1050 Set_Msg_Int (Line / 10);
1053 Set_Msg_Char (Character'Val (Character'Pos ('0') + (Line rem 10)));
1056 -------------------------
1057 -- Set_Msg_Name_Buffer --
1058 -------------------------
1060 procedure Set_Msg_Name_Buffer is
1062 for J in 1 .. Name_Len loop
1063 Set_Msg_Char (Name_Buffer (J));
1065 end Set_Msg_Name_Buffer;
1071 procedure Set_Msg_Quote is
1073 if not Manual_Quote_Mode then
1082 procedure Set_Msg_Str (Text : String) is
1084 for J in Text'Range loop
1085 Set_Msg_Char (Text (J));
1089 ------------------------------
1090 -- Set_Next_Non_Deleted_Msg --
1091 ------------------------------
1093 procedure Set_Next_Non_Deleted_Msg (E : in out Error_Msg_Id) is
1095 if E = No_Error_Msg then
1100 E := Errors.Table (E).Next;
1101 exit when E = No_Error_Msg or else not Errors.Table (E).Deleted;
1104 end Set_Next_Non_Deleted_Msg;
1106 ------------------------------
1107 -- Set_Specific_Warning_Off --
1108 ------------------------------
1110 procedure Set_Specific_Warning_Off
1114 Used : Boolean := False)
1117 Specific_Warnings.Append
1119 Msg => new String'(Msg),
1120 Stop => Source_Last (Current_Source_File),
1124 end Set_Specific_Warning_Off;
1126 -----------------------------
1127 -- Set_Specific_Warning_On --
1128 -----------------------------
1130 procedure Set_Specific_Warning_On
1136 for J in 1 .. Specific_Warnings.Last loop
1138 SWE : Specific_Warning_Entry renames Specific_Warnings.Table (J);
1140 if Msg = SWE.Msg.all
1141 and then Loc > SWE.Start
1143 and then Get_Source_File_Index (SWE.Start) =
1144 Get_Source_File_Index (Loc)
1150 -- If a config pragma is specifically cancelled, consider
1151 -- that it is no longer active as a configuration pragma.
1153 SWE.Config := False;
1160 end Set_Specific_Warning_On;
1162 ---------------------------
1163 -- Set_Warnings_Mode_Off --
1164 ---------------------------
1166 procedure Set_Warnings_Mode_Off (Loc : Source_Ptr) is
1168 -- Don't bother with entries from instantiation copies, since we will
1169 -- already have a copy in the template, which is what matters.
1171 if Instantiation (Get_Source_File_Index (Loc)) /= No_Location then
1175 -- If all warnings are suppressed by command line switch, this can
1176 -- be ignored, unless we are in GNATprove_Mode which requires pragma
1177 -- Warnings to be stored for the formal verification backend.
1179 if Warning_Mode = Suppress
1180 and then not GNATprove_Mode
1185 -- If last entry in table already covers us, this is a redundant pragma
1186 -- Warnings (Off) and can be ignored.
1188 if Warnings.Last >= Warnings.First
1189 and then Warnings.Table (Warnings.Last).Start <= Loc
1190 and then Loc <= Warnings.Table (Warnings.Last).Stop
1195 -- If none of those special conditions holds, establish a new entry,
1196 -- extending from the location of the pragma to the end of the current
1197 -- source file. This ending point will be adjusted by a subsequent
1198 -- corresponding pragma Warnings (On).
1200 Warnings.Increment_Last;
1201 Warnings.Table (Warnings.Last).Start := Loc;
1202 Warnings.Table (Warnings.Last).Stop :=
1203 Source_Last (Current_Source_File);
1204 end Set_Warnings_Mode_Off;
1206 --------------------------
1207 -- Set_Warnings_Mode_On --
1208 --------------------------
1210 procedure Set_Warnings_Mode_On (Loc : Source_Ptr) is
1212 -- Don't bother with entries from instantiation copies, since we will
1213 -- already have a copy in the template, which is what matters.
1215 if Instantiation (Get_Source_File_Index (Loc)) /= No_Location then
1219 -- If all warnings are suppressed by command line switch, this can
1220 -- be ignored, unless we are in GNATprove_Mode which requires pragma
1221 -- Warnings to be stored for the formal verification backend.
1223 if Warning_Mode = Suppress
1224 and then not GNATprove_Mode
1229 -- If the last entry in the warnings table covers this pragma, then
1230 -- we adjust the end point appropriately.
1232 if Warnings.Last >= Warnings.First
1233 and then Warnings.Table (Warnings.Last).Start <= Loc
1234 and then Loc <= Warnings.Table (Warnings.Last).Stop
1236 Warnings.Table (Warnings.Last).Stop := Loc;
1238 end Set_Warnings_Mode_On;
1240 ------------------------------------
1241 -- Test_Style_Warning_Serious_Msg --
1242 ------------------------------------
1244 procedure Test_Style_Warning_Serious_Unconditional_Msg (Msg : String) is
1246 -- Nothing to do for continuation line
1248 if Msg (Msg'First) = '\' then
1252 -- Set initial values of globals (may be changed during scan)
1254 Is_Serious_Error := True;
1255 Is_Unconditional_Msg := False;
1256 Is_Warning_Msg := False;
1257 Has_Double_Exclam := False;
1260 (Msg'Length > 7 and then Msg (Msg'First .. Msg'First + 6) = "(style)");
1262 for J in Msg'Range loop
1264 and then (J = Msg'First or else Msg (J - 1) /= ''')
1266 Is_Warning_Msg := True;
1267 Warning_Msg_Char := ' ';
1270 and then (J = Msg'First or else Msg (J - 1) /= ''')
1272 Is_Unconditional_Msg := True;
1273 Warning_Msg_Char := ' ';
1275 if J < Msg'Last and then Msg (J + 1) = '!' then
1276 Has_Double_Exclam := True;
1280 and then (J = Msg'First or else Msg (J - 1) /= ''')
1282 Is_Warning_Msg := Error_Msg_Warn;
1283 Warning_Msg_Char := ' ';
1286 and then (J = Msg'First or else Msg (J - 1) /= ''')
1288 Is_Serious_Error := False;
1292 if Is_Warning_Msg or Is_Style_Msg then
1293 Is_Serious_Error := False;
1295 end Test_Style_Warning_Serious_Unconditional_Msg;
1297 --------------------------------
1298 -- Validate_Specific_Warnings --
1299 --------------------------------
1301 procedure Validate_Specific_Warnings (Eproc : Error_Msg_Proc) is
1303 for J in Specific_Warnings.First .. Specific_Warnings.Last loop
1305 SWE : Specific_Warning_Entry renames Specific_Warnings.Table (J);
1308 if not SWE.Config then
1310 -- Warn for unmatched Warnings (Off, ...)
1314 ("?pragma Warnings Off with no matching Warnings On",
1317 -- Warn for ineffective Warnings (Off, ..)
1321 -- Do not issue this warning in GNATprove_Mode, as not
1322 -- all warnings may be generated in this mode, and pragma
1323 -- Warnings(Off) may correspond to warnings generated by the
1324 -- formal verification backend instead of frontend warnings.
1326 and then not GNATprove_Mode
1328 -- Do not issue this warning for -Wxxx messages since the
1329 -- back-end doesn't report the information.
1332 (SWE.Msg'Length > 2 and then SWE.Msg (1 .. 2) = "-W")
1335 ("?no warning suppressed by this pragma", SWE.Start);
1340 end Validate_Specific_Warnings;
1342 -------------------------------------
1343 -- Warning_Specifically_Suppressed --
1344 -------------------------------------
1346 function Warning_Specifically_Suppressed
1348 Msg : String_Ptr) return Boolean
1350 function Matches (S : String; P : String) return Boolean;
1351 -- Returns true if the String S patches the pattern P, which can contain
1352 -- wild card chars (*). The entire pattern must match the entire string.
1358 function Matches (S : String; P : String) return Boolean is
1359 Slast : constant Natural := S'Last;
1360 PLast : constant Natural := P'Last;
1362 SPtr : Natural := S'First;
1363 PPtr : Natural := P'First;
1366 -- Loop advancing through characters of string and pattern
1371 -- Return True if pattern is a single asterisk
1373 if PPtr = PLast and then P (PPtr) = '*' then
1376 -- Return True if both pattern and string exhausted
1378 elsif PPtr > PLast and then SPtr > Slast then
1381 -- Return False, if one exhausted and not the other
1383 elsif PPtr > PLast or else SPtr > Slast then
1386 -- Case where pattern starts with asterisk
1388 elsif P (PPtr) = '*' then
1390 -- Try all possible starting positions in S for match with
1391 -- the remaining characters of the pattern. This is the
1392 -- recursive call that implements the scanner backup.
1394 for J in SPtr .. Slast loop
1395 if Matches (S (J .. Slast), P (PPtr + 1 .. PLast)) then
1402 -- Dealt with end of string and *, advance if we have a match
1404 elsif S (SPtr) = P (PPtr) then
1408 -- If first characters do not match, that's decisive
1416 -- Start of processing for Warning_Specifically_Suppressed
1419 -- Loop through specific warning suppression entries
1421 for J in Specific_Warnings.First .. Specific_Warnings.Last loop
1423 SWE : Specific_Warning_Entry renames Specific_Warnings.Table (J);
1426 -- Pragma applies if it is a configuration pragma, or if the
1427 -- location is in range of a specific non-configuration pragma.
1430 or else (SWE.Start <= Loc and then Loc <= SWE.Stop)
1432 if Matches (Msg.all, SWE.Msg.all) then
1441 end Warning_Specifically_Suppressed;
1443 -------------------------
1444 -- Warnings_Suppressed --
1445 -------------------------
1447 function Warnings_Suppressed (Loc : Source_Ptr) return Boolean is
1449 if Warning_Mode = Suppress then
1453 -- Loop through table of ON/OFF warnings
1455 for J in Warnings.First .. Warnings.Last loop
1456 if Warnings.Table (J).Start <= Loc
1457 and then Loc <= Warnings.Table (J).Stop
1464 end Warnings_Suppressed;