1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2009, 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. --
18 -- You should have received a copy of the GNU General Public License along --
19 -- with this program; see file COPYING3. If not see --
20 -- <http://www.gnu.org/licenses/>. --
22 -- GNAT was originally developed by the GNAT team at New York University. --
23 -- Extensive contributions were provided by Ada Core Technologies Inc. --
25 ------------------------------------------------------------------------------
27 -- Warning! Error messages can be generated during Gigi processing by direct
28 -- calls to error message routines, so it is essential that the processing
29 -- in this body be consistent with the requirements for the Gigi processing
30 -- environment, and that in particular, no disallowed table expansion is
33 with Casing; use Casing;
34 with Debug; use Debug;
35 with Err_Vars; use Err_Vars;
36 with Namet; use Namet;
38 with Output; use Output;
39 with Sinput; use Sinput;
40 with Snames; use Snames;
41 with Targparm; use Targparm;
42 with Uintp; use Uintp;
44 package body Erroutc is
50 procedure Add_Class is
55 Get_Name_String (Name_Class);
56 Set_Casing (Identifier_Casing (Flag_Source), Mixed_Case);
61 ----------------------
62 -- Buffer_Ends_With --
63 ----------------------
65 function Buffer_Ends_With (S : String) return Boolean is
66 Len : constant Natural := S'Length;
70 and then Msg_Buffer (Msglen - Len) = ' '
71 and then Msg_Buffer (Msglen - Len + 1 .. Msglen) = S;
78 procedure Buffer_Remove (S : String) is
80 if Buffer_Ends_With (S) then
81 Msglen := Msglen - S'Length;
85 -----------------------------
86 -- Check_Duplicate_Message --
87 -----------------------------
89 procedure Check_Duplicate_Message (M1, M2 : Error_Msg_Id) is
90 L1, L2 : Error_Msg_Id;
91 N1, N2 : Error_Msg_Id;
93 procedure Delete_Msg (Delete, Keep : Error_Msg_Id);
94 -- Called to delete message Delete, keeping message Keep. Marks
95 -- all messages of Delete with deleted flag set to True, and also
96 -- makes sure that for the error messages that are retained the
97 -- preferred message is the one retained (we prefer the shorter
98 -- one in the case where one has an Instance tag). Note that we
99 -- always know that Keep has at least as many continuations as
100 -- Delete (since we always delete the shorter sequence).
106 procedure Delete_Msg (Delete, Keep : Error_Msg_Id) is
114 Errors.Table (D).Deleted := True;
116 -- Adjust error message count
118 if Errors.Table (D).Warn or else Errors.Table (D).Style then
119 Warnings_Detected := Warnings_Detected - 1;
122 Total_Errors_Detected := Total_Errors_Detected - 1;
124 if Errors.Table (D).Serious then
125 Serious_Errors_Detected := Serious_Errors_Detected - 1;
129 -- Substitute shorter of the two error messages
131 if Errors.Table (K).Text'Length > Errors.Table (D).Text'Length then
132 Errors.Table (K).Text := Errors.Table (D).Text;
135 D := Errors.Table (D).Next;
136 K := Errors.Table (K).Next;
138 if D = No_Error_Msg or else not Errors.Table (D).Msg_Cont then
144 -- Start of processing for Check_Duplicate_Message
147 -- Both messages must be non-continuation messages and not deleted
149 if Errors.Table (M1).Msg_Cont
150 or else Errors.Table (M2).Msg_Cont
151 or else Errors.Table (M1).Deleted
152 or else Errors.Table (M2).Deleted
157 -- Definitely not equal if message text does not match
159 if not Same_Error (M1, M2) then
163 -- Same text. See if all continuations are also identical
169 N1 := Errors.Table (L1).Next;
170 N2 := Errors.Table (L2).Next;
172 -- If M1 continuations have run out, we delete M1, either the
173 -- messages have the same number of continuations, or M2 has
174 -- more and we prefer the one with more anyway.
176 if N1 = No_Error_Msg or else not Errors.Table (N1).Msg_Cont then
180 -- If M2 continuations have run out, we delete M2
182 elsif N2 = No_Error_Msg or else not Errors.Table (N2).Msg_Cont then
186 -- Otherwise see if continuations are the same, if not, keep both
187 -- sequences, a curious case, but better to keep everything!
189 elsif not Same_Error (N1, N2) then
192 -- If continuations are the same, continue scan
199 end Check_Duplicate_Message;
201 ------------------------
202 -- Compilation_Errors --
203 ------------------------
205 function Compilation_Errors return Boolean is
207 return Total_Errors_Detected /= 0
208 or else (Warnings_Detected /= 0
209 and then Warning_Mode = Treat_As_Error);
210 end Compilation_Errors;
216 procedure Debug_Output (N : Node_Id) is
219 Write_Str ("*** following error message posted on node id = #");
230 procedure dmsg (Id : Error_Msg_Id) is
231 E : Error_Msg_Object renames Errors.Table (Id);
234 w ("Dumping error message, Id = ", Int (Id));
235 w (" Text = ", E.Text.all);
236 w (" Next = ", Int (E.Next));
237 w (" Sfile = ", Int (E.Sfile));
241 Write_Location (E.Sptr);
246 Write_Location (E.Optr);
249 w (" Line = ", Int (E.Line));
250 w (" Col = ", Int (E.Col));
251 w (" Warn = ", E.Warn);
252 w (" Style = ", E.Style);
253 w (" Serious = ", E.Serious);
254 w (" Uncond = ", E.Uncond);
255 w (" Msg_Cont = ", E.Msg_Cont);
256 w (" Deleted = ", E.Deleted);
265 function Get_Location (E : Error_Msg_Id) return Source_Ptr is
267 return Errors.Table (E).Sptr;
274 function Get_Msg_Id return Error_Msg_Id is
279 -----------------------
280 -- Output_Error_Msgs --
281 -----------------------
283 procedure Output_Error_Msgs (E : in out Error_Msg_Id) is
289 Mult_Flags : Boolean := False;
294 -- Skip deleted messages at start
296 if Errors.Table (S).Deleted then
297 Set_Next_Non_Deleted_Msg (S);
300 -- Figure out if we will place more than one error flag on this line
303 while T /= No_Error_Msg
304 and then Errors.Table (T).Line = Errors.Table (E).Line
305 and then Errors.Table (T).Sfile = Errors.Table (E).Sfile
307 if Errors.Table (T).Sptr > Errors.Table (E).Sptr then
311 Set_Next_Non_Deleted_Msg (T);
314 -- Output the error flags. The circuit here makes sure that the tab
315 -- characters in the original line are properly accounted for. The
316 -- eight blanks at the start are to match the line number.
318 if not Debug_Flag_2 then
320 P := Line_Start (Errors.Table (E).Sptr);
323 -- Loop through error messages for this line to place flags
326 while T /= No_Error_Msg
327 and then Errors.Table (T).Line = Errors.Table (E).Line
328 and then Errors.Table (T).Sfile = Errors.Table (E).Sfile
330 -- Loop to output blanks till current flag position
332 while P < Errors.Table (T).Sptr loop
333 if Source_Text (Errors.Table (T).Sfile) (P) = ASCII.HT then
334 Write_Char (ASCII.HT);
342 -- Output flag (unless already output, this happens if more
343 -- than one error message occurs at the same flag position).
345 if P = Errors.Table (T).Sptr then
346 if (Flag_Num = 1 and then not Mult_Flags)
351 Write_Char (Character'Val (Character'Pos ('0') + Flag_Num));
357 Set_Next_Non_Deleted_Msg (T);
358 Flag_Num := Flag_Num + 1;
364 -- Now output the error messages
367 while T /= No_Error_Msg
368 and then Errors.Table (T).Line = Errors.Table (E).Line
369 and then Errors.Table (T).Sfile = Errors.Table (E).Sfile
375 while Column < 74 loop
383 Set_Next_Non_Deleted_Msg (T);
387 end Output_Error_Msgs;
389 ------------------------
390 -- Output_Line_Number --
391 ------------------------
393 procedure Output_Line_Number (L : Logical_Line_Number) is
394 D : Int; -- next digit
395 C : Character; -- next character
396 Z : Boolean; -- flag for zero suppress
397 N, M : Int; -- temporaries
400 if L = No_Line_Number then
421 C := Character'Val (D + 48);
429 end Output_Line_Number;
431 ---------------------
432 -- Output_Msg_Text --
433 ---------------------
435 procedure Output_Msg_Text (E : Error_Msg_Id) is
436 Offs : constant Nat := Column - 1;
437 -- Offset to start of message, used for continuations
440 -- Maximum characters to output on next line
443 -- Maximum total length of lines
445 Txt : constant String_Ptr := Errors.Table (E).Text;
446 Len : constant Natural := Txt'Length;
452 if Error_Msg_Line_Length = 0 then
455 Length := Error_Msg_Line_Length;
458 Max := Integer (Length - Column + 1);
460 -- For warning message, add "warning: " unless msg starts with "info: "
462 if Errors.Table (E).Warn then
463 if Len < 6 or else Txt (Txt'First .. Txt'First + 5) /= "info: " then
464 Write_Str ("warning: ");
468 -- No prefix needed for style message, since "(style)" is there already
470 elsif Errors.Table (E).Style then
473 -- All other cases, add "error: "
475 elsif Opt.Unique_Error_Tag then
476 Write_Str ("error: ");
480 -- Here we have to split the message up into multiple lines
484 -- Make sure we do not have ludicrously small line
486 Max := Integer'Max (Max, 20);
488 -- If remaining text fits, output it respecting LF and we are done
490 if Len - Ptr < Max then
491 for J in Ptr .. Len loop
492 if Txt (J) = ASCII.LF then
496 Write_Char (Txt (J));
507 -- First scan forward looking for a hard end of line
509 for Scan in Ptr .. Ptr + Max - 1 loop
510 if Txt (Scan) = ASCII.LF then
517 -- Otherwise scan backwards looking for a space
519 for Scan in reverse Ptr .. Ptr + Max - 1 loop
520 if Txt (Scan) = ' ' then
527 -- If we fall through, no space, so split line arbitrarily
529 Split := Ptr + Max - 1;
534 if Start <= Split then
535 Write_Line (Txt (Start .. Split));
539 Max := Integer (Length - Column + 1);
547 procedure Purge_Messages (From : Source_Ptr; To : Source_Ptr) is
550 function To_Be_Purged (E : Error_Msg_Id) return Boolean;
551 -- Returns True for a message that is to be purged. Also adjusts
552 -- error counts appropriately.
558 function To_Be_Purged (E : Error_Msg_Id) return Boolean is
561 and then Errors.Table (E).Sptr > From
562 and then Errors.Table (E).Sptr < To
564 if Errors.Table (E).Warn or else Errors.Table (E).Style then
565 Warnings_Detected := Warnings_Detected - 1;
568 Total_Errors_Detected := Total_Errors_Detected - 1;
570 if Errors.Table (E).Serious then
571 Serious_Errors_Detected := Serious_Errors_Detected - 1;
582 -- Start of processing for Purge_Messages
585 while To_Be_Purged (First_Error_Msg) loop
586 First_Error_Msg := Errors.Table (First_Error_Msg).Next;
589 E := First_Error_Msg;
590 while E /= No_Error_Msg loop
591 while To_Be_Purged (Errors.Table (E).Next) loop
592 Errors.Table (E).Next :=
593 Errors.Table (Errors.Table (E).Next).Next;
596 E := Errors.Table (E).Next;
604 function Same_Error (M1, M2 : Error_Msg_Id) return Boolean is
605 Msg1 : constant String_Ptr := Errors.Table (M1).Text;
606 Msg2 : constant String_Ptr := Errors.Table (M2).Text;
608 Msg2_Len : constant Integer := Msg2'Length;
609 Msg1_Len : constant Integer := Msg1'Length;
615 (Msg1_Len - 10 > Msg2_Len
617 Msg2.all = Msg1.all (1 .. Msg2_Len)
619 Msg1 (Msg2_Len + 1 .. Msg2_Len + 10) = ", instance")
621 (Msg2_Len - 10 > Msg1_Len
623 Msg1.all = Msg2.all (1 .. Msg1_Len)
625 Msg2 (Msg1_Len + 1 .. Msg1_Len + 10) = ", instance");
632 procedure Set_Msg_Blank is
635 and then Msg_Buffer (Msglen) /= ' '
636 and then Msg_Buffer (Msglen) /= '('
637 and then Msg_Buffer (Msglen) /= '-'
638 and then not Manual_Quote_Mode
644 -------------------------------
645 -- Set_Msg_Blank_Conditional --
646 -------------------------------
648 procedure Set_Msg_Blank_Conditional is
651 and then Msg_Buffer (Msglen) /= ' '
652 and then Msg_Buffer (Msglen) /= '('
653 and then Msg_Buffer (Msglen) /= '"'
654 and then not Manual_Quote_Mode
658 end Set_Msg_Blank_Conditional;
664 procedure Set_Msg_Char (C : Character) is
667 -- The check for message buffer overflow is needed to deal with cases
668 -- where insertions get too long (in particular a child unit name can
671 if Msglen < Max_Msg_Length then
672 Msglen := Msglen + 1;
673 Msg_Buffer (Msglen) := C;
677 ---------------------------------
678 -- Set_Msg_Insertion_File_Name --
679 ---------------------------------
681 procedure Set_Msg_Insertion_File_Name is
683 if Error_Msg_File_1 = No_File then
686 elsif Error_Msg_File_1 = Error_File_Name then
688 Set_Msg_Str ("<error>");
692 Get_Name_String (Error_Msg_File_1);
698 -- The following assignments ensure that the second and third {
699 -- insertion characters will correspond to the Error_Msg_File_2 and
700 -- Error_Msg_File_3 values and We suppress possible validity checks in
701 -- case operating in -gnatVa mode, and Error_Msg_File_2 or
702 -- Error_Msg_File_3 is not needed and has not been set.
705 pragma Suppress (Range_Check);
707 Error_Msg_File_1 := Error_Msg_File_2;
708 Error_Msg_File_2 := Error_Msg_File_3;
710 end Set_Msg_Insertion_File_Name;
712 -----------------------------------
713 -- Set_Msg_Insertion_Line_Number --
714 -----------------------------------
716 procedure Set_Msg_Insertion_Line_Number (Loc, Flag : Source_Ptr) is
717 Sindex_Loc : Source_File_Index;
718 Sindex_Flag : Source_File_Index;
723 if Loc = No_Location then
724 Set_Msg_Str ("at unknown location");
726 elsif Loc = System_Location then
727 Set_Msg_Str ("in package System");
728 Set_Msg_Insertion_Run_Time_Name;
730 elsif Loc = Standard_Location then
731 Set_Msg_Str ("in package Standard");
733 elsif Loc = Standard_ASCII_Location then
734 Set_Msg_Str ("in package Standard.ASCII");
737 -- Add "at file-name:" if reference is to other than the source
738 -- file in which the error message is placed. Note that we check
739 -- full file names, rather than just the source indexes, to
740 -- deal with generic instantiations from the current file.
742 Sindex_Loc := Get_Source_File_Index (Loc);
743 Sindex_Flag := Get_Source_File_Index (Flag);
745 if Full_File_Name (Sindex_Loc) /= Full_File_Name (Sindex_Flag) then
748 (Reference_Name (Get_Source_File_Index (Loc)));
752 -- If in current file, add text "at line "
755 Set_Msg_Str ("at line ");
758 -- Output line number for reference
760 Set_Msg_Int (Int (Get_Logical_Line_Number (Loc)));
762 -- Deal with the instantiation case. We may have a reference to,
763 -- e.g. a type, that is declared within a generic template, and
764 -- what we are really referring to is the occurrence in an instance.
765 -- In this case, the line number of the instantiation is also of
766 -- interest, and we add a notation:
770 -- where xxx is a line number output using this same routine (and
771 -- the recursion can go further if the instantiation is itself in
772 -- a generic template).
774 -- The flag location passed to us in this situation is indeed the
775 -- line number within the template, but as described in Sinput.L
776 -- (file sinput-l.ads, section "Handling Generic Instantiations")
777 -- we can retrieve the location of the instantiation itself from
778 -- this flag location value.
780 -- Note: this processing is suppressed if Suppress_Instance_Location
781 -- is set True. This is used to prevent redundant annotations of the
782 -- location of the instantiation in the case where we are placing
783 -- the messages on the instantiation in any case.
785 if Instantiation (Sindex_Loc) /= No_Location
786 and then not Suppress_Instance_Location
788 Set_Msg_Str (", instance ");
789 Set_Msg_Insertion_Line_Number (Instantiation (Sindex_Loc), Flag);
792 end Set_Msg_Insertion_Line_Number;
794 ----------------------------
795 -- Set_Msg_Insertion_Name --
796 ----------------------------
798 procedure Set_Msg_Insertion_Name is
800 if Error_Msg_Name_1 = No_Name then
803 elsif Error_Msg_Name_1 = Error_Name then
805 Set_Msg_Str ("<error>");
808 Set_Msg_Blank_Conditional;
809 Get_Unqualified_Decoded_Name_String (Error_Msg_Name_1);
811 -- Remove %s or %b at end. These come from unit names. If the
812 -- caller wanted the (unit) or (body), then they would have used
813 -- the $ insertion character. Certainly no error message should
814 -- ever have %b or %s explicitly occurring.
817 and then Name_Buffer (Name_Len - 1) = '%'
818 and then (Name_Buffer (Name_Len) = 'b'
820 Name_Buffer (Name_Len) = 's')
822 Name_Len := Name_Len - 2;
825 -- Remove upper case letter at end, again, we should not be getting
826 -- such names, and what we hope is that the remainder makes sense.
829 and then Name_Buffer (Name_Len) in 'A' .. 'Z'
831 Name_Len := Name_Len - 1;
834 -- If operator name or character literal name, just print it as is
835 -- Also print as is if it ends in a right paren (case of x'val(nnn))
837 if Name_Buffer (1) = '"'
838 or else Name_Buffer (1) = '''
839 or else Name_Buffer (Name_Len) = ')'
843 -- Else output with surrounding quotes in proper casing mode
846 Set_Casing (Identifier_Casing (Flag_Source), Mixed_Case);
853 -- The following assignments ensure that the second and third percent
854 -- insertion characters will correspond to the Error_Msg_Name_2 and
855 -- Error_Msg_Name_3 as required. We suppress possible validity checks in
856 -- case operating in -gnatVa mode, and Error_Msg_Name_1/2 is not needed
857 -- and has not been set.
860 pragma Suppress (Range_Check);
862 Error_Msg_Name_1 := Error_Msg_Name_2;
863 Error_Msg_Name_2 := Error_Msg_Name_3;
865 end Set_Msg_Insertion_Name;
867 ------------------------------------
868 -- Set_Msg_Insertion_Name_Literal --
869 ------------------------------------
871 procedure Set_Msg_Insertion_Name_Literal is
873 if Error_Msg_Name_1 = No_Name then
876 elsif Error_Msg_Name_1 = Error_Name then
878 Set_Msg_Str ("<error>");
882 Get_Name_String (Error_Msg_Name_1);
888 -- The following assignments ensure that the second and third % or %%
889 -- insertion characters will correspond to the Error_Msg_Name_2 and
890 -- Error_Msg_Name_3 values and We suppress possible validity checks in
891 -- case operating in -gnatVa mode, and Error_Msg_Name_2 or
892 -- Error_Msg_Name_3 is not needed and has not been set.
895 pragma Suppress (Range_Check);
897 Error_Msg_Name_1 := Error_Msg_Name_2;
898 Error_Msg_Name_2 := Error_Msg_Name_3;
900 end Set_Msg_Insertion_Name_Literal;
902 -------------------------------------
903 -- Set_Msg_Insertion_Reserved_Name --
904 -------------------------------------
906 procedure Set_Msg_Insertion_Reserved_Name is
908 Set_Msg_Blank_Conditional;
909 Get_Name_String (Error_Msg_Name_1);
911 Set_Casing (Keyword_Casing (Flag_Source), All_Lower_Case);
914 end Set_Msg_Insertion_Reserved_Name;
916 -------------------------------------
917 -- Set_Msg_Insertion_Reserved_Word --
918 -------------------------------------
920 procedure Set_Msg_Insertion_Reserved_Word
925 Set_Msg_Blank_Conditional;
928 while J <= Text'Last and then Text (J) in 'A' .. 'Z' loop
929 Add_Char_To_Name_Buffer (Text (J));
933 -- Here is where we make the special exception for RM
935 if Name_Len = 2 and then Name_Buffer (1 .. 2) = "RM" then
938 -- Not RM: case appropriately and add surrounding quotes
941 Set_Casing (Keyword_Casing (Flag_Source), All_Lower_Case);
946 end Set_Msg_Insertion_Reserved_Word;
948 -------------------------------------
949 -- Set_Msg_Insertion_Run_Time_Name --
950 -------------------------------------
952 procedure Set_Msg_Insertion_Run_Time_Name is
954 if Targparm.Run_Time_Name_On_Target /= No_Name then
955 Set_Msg_Blank_Conditional;
957 Get_Name_String (Targparm.Run_Time_Name_On_Target);
958 Set_Casing (Mixed_Case);
959 Set_Msg_Str (Name_Buffer (1 .. Name_Len));
962 end Set_Msg_Insertion_Run_Time_Name;
964 ----------------------------
965 -- Set_Msg_Insertion_Uint --
966 ----------------------------
968 procedure Set_Msg_Insertion_Uint is
971 UI_Image (Error_Msg_Uint_1);
973 for J in 1 .. UI_Image_Length loop
974 Set_Msg_Char (UI_Image_Buffer (J));
977 -- The following assignment ensures that a second caret insertion
978 -- character will correspond to the Error_Msg_Uint_2 parameter. We
979 -- suppress possible validity checks in case operating in -gnatVa mode,
980 -- and Error_Msg_Uint_2 is not needed and has not been set.
983 pragma Suppress (Range_Check);
985 Error_Msg_Uint_1 := Error_Msg_Uint_2;
987 end Set_Msg_Insertion_Uint;
993 procedure Set_Msg_Int (Line : Int) is
996 Set_Msg_Int (Line / 10);
999 Set_Msg_Char (Character'Val (Character'Pos ('0') + (Line rem 10)));
1002 -------------------------
1003 -- Set_Msg_Name_Buffer --
1004 -------------------------
1006 procedure Set_Msg_Name_Buffer is
1008 for J in 1 .. Name_Len loop
1009 Set_Msg_Char (Name_Buffer (J));
1011 end Set_Msg_Name_Buffer;
1017 procedure Set_Msg_Quote is
1019 if not Manual_Quote_Mode then
1028 procedure Set_Msg_Str (Text : String) is
1030 for J in Text'Range loop
1031 Set_Msg_Char (Text (J));
1035 ------------------------------
1036 -- Set_Next_Non_Deleted_Msg --
1037 ------------------------------
1039 procedure Set_Next_Non_Deleted_Msg (E : in out Error_Msg_Id) is
1041 if E = No_Error_Msg then
1046 E := Errors.Table (E).Next;
1047 exit when E = No_Error_Msg or else not Errors.Table (E).Deleted;
1050 end Set_Next_Non_Deleted_Msg;
1052 ------------------------------
1053 -- Set_Specific_Warning_Off --
1054 ------------------------------
1056 procedure Set_Specific_Warning_Off
1062 Specific_Warnings.Append
1064 Msg => new String'(Msg),
1065 Stop => Source_Last (Current_Source_File),
1069 end Set_Specific_Warning_Off;
1071 -----------------------------
1072 -- Set_Specific_Warning_On --
1073 -----------------------------
1075 procedure Set_Specific_Warning_On
1081 for J in 1 .. Specific_Warnings.Last loop
1083 SWE : Specific_Warning_Entry renames Specific_Warnings.Table (J);
1085 if Msg = SWE.Msg.all
1086 and then Loc > SWE.Start
1088 and then Get_Source_File_Index (SWE.Start) =
1089 Get_Source_File_Index (Loc)
1095 -- If a config pragma is specifically cancelled, consider
1096 -- that it is no longer active as a configuration pragma.
1098 SWE.Config := False;
1105 end Set_Specific_Warning_On;
1107 ---------------------------
1108 -- Set_Warnings_Mode_Off --
1109 ---------------------------
1111 procedure Set_Warnings_Mode_Off (Loc : Source_Ptr) is
1113 -- Don't bother with entries from instantiation copies, since we
1114 -- will already have a copy in the template, which is what matters
1116 if Instantiation (Get_Source_File_Index (Loc)) /= No_Location then
1120 -- If last entry in table already covers us, this is a redundant
1121 -- pragma Warnings (Off) and can be ignored. This also handles the
1122 -- case where all warnings are suppressed by command line switch.
1124 if Warnings.Last >= Warnings.First
1125 and then Warnings.Table (Warnings.Last).Start <= Loc
1126 and then Loc <= Warnings.Table (Warnings.Last).Stop
1130 -- Otherwise establish a new entry, extending from the location of
1131 -- the pragma to the end of the current source file. This ending
1132 -- point will be adjusted by a subsequent pragma Warnings (On).
1135 Warnings.Increment_Last;
1136 Warnings.Table (Warnings.Last).Start := Loc;
1137 Warnings.Table (Warnings.Last).Stop :=
1138 Source_Last (Current_Source_File);
1140 end Set_Warnings_Mode_Off;
1142 --------------------------
1143 -- Set_Warnings_Mode_On --
1144 --------------------------
1146 procedure Set_Warnings_Mode_On (Loc : Source_Ptr) is
1148 -- Don't bother with entries from instantiation copies, since we
1149 -- will already have a copy in the template, which is what matters
1151 if Instantiation (Get_Source_File_Index (Loc)) /= No_Location then
1155 -- Nothing to do unless command line switch to suppress all warnings
1156 -- is off, and the last entry in the warnings table covers this
1157 -- pragma Warnings (On), in which case adjust the end point.
1159 if (Warnings.Last >= Warnings.First
1160 and then Warnings.Table (Warnings.Last).Start <= Loc
1161 and then Loc <= Warnings.Table (Warnings.Last).Stop)
1162 and then Warning_Mode /= Suppress
1164 Warnings.Table (Warnings.Last).Stop := Loc;
1166 end Set_Warnings_Mode_On;
1168 ------------------------------------
1169 -- Test_Style_Warning_Serious_Msg --
1170 ------------------------------------
1172 procedure Test_Style_Warning_Serious_Msg (Msg : String) is
1174 if Msg (Msg'First) = '\' then
1178 Is_Serious_Error := True;
1179 Is_Warning_Msg := False;
1182 (Msg'Length > 7 and then Msg (Msg'First .. Msg'First + 6) = "(style)");
1184 if Is_Style_Msg then
1185 Is_Serious_Error := False;
1188 for J in Msg'Range loop
1190 and then (J = Msg'First or else Msg (J - 1) /= ''')
1192 Is_Warning_Msg := True;
1195 and then (J = Msg'First or else Msg (J - 1) /= ''')
1197 Is_Warning_Msg := Error_Msg_Warn;
1200 and then (J = Msg'First or else Msg (J - 1) /= ''')
1202 Is_Serious_Error := False;
1206 if Is_Warning_Msg or Is_Style_Msg then
1207 Is_Serious_Error := False;
1209 end Test_Style_Warning_Serious_Msg;
1211 --------------------------------
1212 -- Validate_Specific_Warnings --
1213 --------------------------------
1215 procedure Validate_Specific_Warnings (Eproc : Error_Msg_Proc) is
1217 for J in Specific_Warnings.First .. Specific_Warnings.Last loop
1219 SWE : Specific_Warning_Entry renames Specific_Warnings.Table (J);
1221 if not SWE.Config then
1224 ("?pragma Warnings Off with no matching Warnings On",
1226 elsif not SWE.Used then
1228 ("?no warning suppressed by this pragma", SWE.Start);
1233 end Validate_Specific_Warnings;
1235 -------------------------------------
1236 -- Warning_Specifically_Suppressed --
1237 -------------------------------------
1239 function Warning_Specifically_Suppressed
1241 Msg : String_Ptr) return Boolean
1243 function Matches (S : String; P : String) return Boolean;
1244 -- Returns true if the String S patches the pattern P, which can contain
1245 -- wild card chars (*). The entire pattern must match the entire string.
1251 function Matches (S : String; P : String) return Boolean is
1252 Slast : constant Natural := S'Last;
1253 PLast : constant Natural := P'Last;
1255 SPtr : Natural := S'First;
1256 PPtr : Natural := P'First;
1259 -- Loop advancing through characters of string and pattern
1264 -- Return True if pattern is a single asterisk
1266 if PPtr = PLast and then P (PPtr) = '*' then
1269 -- Return True if both pattern and string exhausted
1271 elsif PPtr > PLast and then SPtr > Slast then
1274 -- Return False, if one exhausted and not the other
1276 elsif PPtr > PLast or else SPtr > Slast then
1279 -- Case where pattern starts with asterisk
1281 elsif P (PPtr) = '*' then
1283 -- Try all possible starting positions in S for match with
1284 -- the remaining characters of the pattern. This is the
1285 -- recursive call that implements the scanner backup.
1287 for J in SPtr .. Slast loop
1288 if Matches (S (J .. Slast), P (PPtr + 1 .. PLast)) then
1295 -- Dealt with end of string and *, advance if we have a match
1297 elsif S (SPtr) = P (PPtr) then
1301 -- If first characters do not match, that's decisive
1309 -- Start of processing for Warning_Specifically_Suppressed
1312 -- Loop through specific warning suppression entries
1314 for J in Specific_Warnings.First .. Specific_Warnings.Last loop
1316 SWE : Specific_Warning_Entry renames Specific_Warnings.Table (J);
1319 -- Pragma applies if it is a configuration pragma, or if the
1320 -- location is in range of a specific non-configuration pragma.
1323 or else (SWE.Start <= Loc and then Loc <= SWE.Stop)
1325 if Matches (Msg.all, SWE.Msg.all) then
1334 end Warning_Specifically_Suppressed;
1336 -------------------------
1337 -- Warnings_Suppressed --
1338 -------------------------
1340 function Warnings_Suppressed (Loc : Source_Ptr) return Boolean is
1342 if Warning_Mode = Suppress then
1346 -- Loop through table of ON/OFF warnings
1348 for J in Warnings.First .. Warnings.Last loop
1349 if Warnings.Table (J).Start <= Loc
1350 and then Loc <= Warnings.Table (J).Stop
1357 end Warnings_Suppressed;