1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2010, 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;
721 -- Outputs "at " unless last characters in buffer are " from ". Certain
722 -- messages read better with from than at.
731 or else Msg_Buffer (Msglen - 5 .. Msglen) /= " from "
737 -- Start of processing for Set_Msg_Insertion_Line_Number
742 if Loc = No_Location then
744 Set_Msg_Str ("unknown location");
746 elsif Loc = System_Location then
747 Set_Msg_Str ("in package System");
748 Set_Msg_Insertion_Run_Time_Name;
750 elsif Loc = Standard_Location then
751 Set_Msg_Str ("in package Standard");
753 elsif Loc = Standard_ASCII_Location then
754 Set_Msg_Str ("in package Standard.ASCII");
757 -- Add "at file-name:" if reference is to other than the source
758 -- file in which the error message is placed. Note that we check
759 -- full file names, rather than just the source indexes, to
760 -- deal with generic instantiations from the current file.
762 Sindex_Loc := Get_Source_File_Index (Loc);
763 Sindex_Flag := Get_Source_File_Index (Flag);
765 if Full_File_Name (Sindex_Loc) /= Full_File_Name (Sindex_Flag) then
768 (Reference_Name (Get_Source_File_Index (Loc)));
772 -- If in current file, add text "at line "
776 Set_Msg_Str ("line ");
779 -- Output line number for reference
781 Set_Msg_Int (Int (Get_Logical_Line_Number (Loc)));
783 -- Deal with the instantiation case. We may have a reference to,
784 -- e.g. a type, that is declared within a generic template, and
785 -- what we are really referring to is the occurrence in an instance.
786 -- In this case, the line number of the instantiation is also of
787 -- interest, and we add a notation:
791 -- where xxx is a line number output using this same routine (and
792 -- the recursion can go further if the instantiation is itself in
793 -- a generic template).
795 -- The flag location passed to us in this situation is indeed the
796 -- line number within the template, but as described in Sinput.L
797 -- (file sinput-l.ads, section "Handling Generic Instantiations")
798 -- we can retrieve the location of the instantiation itself from
799 -- this flag location value.
801 -- Note: this processing is suppressed if Suppress_Instance_Location
802 -- is set True. This is used to prevent redundant annotations of the
803 -- location of the instantiation in the case where we are placing
804 -- the messages on the instantiation in any case.
806 if Instantiation (Sindex_Loc) /= No_Location
807 and then not Suppress_Instance_Location
809 Set_Msg_Str (", instance ");
810 Set_Msg_Insertion_Line_Number (Instantiation (Sindex_Loc), Flag);
813 end Set_Msg_Insertion_Line_Number;
815 ----------------------------
816 -- Set_Msg_Insertion_Name --
817 ----------------------------
819 procedure Set_Msg_Insertion_Name is
821 if Error_Msg_Name_1 = No_Name then
824 elsif Error_Msg_Name_1 = Error_Name then
826 Set_Msg_Str ("<error>");
829 Set_Msg_Blank_Conditional;
830 Get_Unqualified_Decoded_Name_String (Error_Msg_Name_1);
832 -- Remove %s or %b at end. These come from unit names. If the
833 -- caller wanted the (unit) or (body), then they would have used
834 -- the $ insertion character. Certainly no error message should
835 -- ever have %b or %s explicitly occurring.
838 and then Name_Buffer (Name_Len - 1) = '%'
839 and then (Name_Buffer (Name_Len) = 'b'
841 Name_Buffer (Name_Len) = 's')
843 Name_Len := Name_Len - 2;
846 -- Remove upper case letter at end, again, we should not be getting
847 -- such names, and what we hope is that the remainder makes sense.
850 and then Name_Buffer (Name_Len) in 'A' .. 'Z'
852 Name_Len := Name_Len - 1;
855 -- If operator name or character literal name, just print it as is
856 -- Also print as is if it ends in a right paren (case of x'val(nnn))
858 if Name_Buffer (1) = '"'
859 or else Name_Buffer (1) = '''
860 or else Name_Buffer (Name_Len) = ')'
864 -- Else output with surrounding quotes in proper casing mode
867 Set_Casing (Identifier_Casing (Flag_Source), Mixed_Case);
874 -- The following assignments ensure that the second and third percent
875 -- insertion characters will correspond to the Error_Msg_Name_2 and
876 -- Error_Msg_Name_3 as required. We suppress possible validity checks in
877 -- case operating in -gnatVa mode, and Error_Msg_Name_1/2 is not needed
878 -- and has not been set.
881 pragma Suppress (Range_Check);
883 Error_Msg_Name_1 := Error_Msg_Name_2;
884 Error_Msg_Name_2 := Error_Msg_Name_3;
886 end Set_Msg_Insertion_Name;
888 ------------------------------------
889 -- Set_Msg_Insertion_Name_Literal --
890 ------------------------------------
892 procedure Set_Msg_Insertion_Name_Literal is
894 if Error_Msg_Name_1 = No_Name then
897 elsif Error_Msg_Name_1 = Error_Name then
899 Set_Msg_Str ("<error>");
903 Get_Name_String (Error_Msg_Name_1);
909 -- The following assignments ensure that the second and third % or %%
910 -- insertion characters will correspond to the Error_Msg_Name_2 and
911 -- Error_Msg_Name_3 values and We suppress possible validity checks in
912 -- case operating in -gnatVa mode, and Error_Msg_Name_2 or
913 -- Error_Msg_Name_3 is not needed and has not been set.
916 pragma Suppress (Range_Check);
918 Error_Msg_Name_1 := Error_Msg_Name_2;
919 Error_Msg_Name_2 := Error_Msg_Name_3;
921 end Set_Msg_Insertion_Name_Literal;
923 -------------------------------------
924 -- Set_Msg_Insertion_Reserved_Name --
925 -------------------------------------
927 procedure Set_Msg_Insertion_Reserved_Name is
929 Set_Msg_Blank_Conditional;
930 Get_Name_String (Error_Msg_Name_1);
932 Set_Casing (Keyword_Casing (Flag_Source), All_Lower_Case);
935 end Set_Msg_Insertion_Reserved_Name;
937 -------------------------------------
938 -- Set_Msg_Insertion_Reserved_Word --
939 -------------------------------------
941 procedure Set_Msg_Insertion_Reserved_Word
946 Set_Msg_Blank_Conditional;
949 while J <= Text'Last and then Text (J) in 'A' .. 'Z' loop
950 Add_Char_To_Name_Buffer (Text (J));
954 -- Here is where we make the special exception for RM
956 if Name_Len = 2 and then Name_Buffer (1 .. 2) = "RM" then
959 -- Not RM: case appropriately and add surrounding quotes
962 Set_Casing (Keyword_Casing (Flag_Source), All_Lower_Case);
967 end Set_Msg_Insertion_Reserved_Word;
969 -------------------------------------
970 -- Set_Msg_Insertion_Run_Time_Name --
971 -------------------------------------
973 procedure Set_Msg_Insertion_Run_Time_Name is
975 if Targparm.Run_Time_Name_On_Target /= No_Name then
976 Set_Msg_Blank_Conditional;
978 Get_Name_String (Targparm.Run_Time_Name_On_Target);
979 Set_Casing (Mixed_Case);
980 Set_Msg_Str (Name_Buffer (1 .. Name_Len));
983 end Set_Msg_Insertion_Run_Time_Name;
985 ----------------------------
986 -- Set_Msg_Insertion_Uint --
987 ----------------------------
989 procedure Set_Msg_Insertion_Uint is
992 UI_Image (Error_Msg_Uint_1);
994 for J in 1 .. UI_Image_Length loop
995 Set_Msg_Char (UI_Image_Buffer (J));
998 -- The following assignment ensures that a second caret insertion
999 -- character will correspond to the Error_Msg_Uint_2 parameter. We
1000 -- suppress possible validity checks in case operating in -gnatVa mode,
1001 -- and Error_Msg_Uint_2 is not needed and has not been set.
1004 pragma Suppress (Range_Check);
1006 Error_Msg_Uint_1 := Error_Msg_Uint_2;
1008 end Set_Msg_Insertion_Uint;
1014 procedure Set_Msg_Int (Line : Int) is
1017 Set_Msg_Int (Line / 10);
1020 Set_Msg_Char (Character'Val (Character'Pos ('0') + (Line rem 10)));
1023 -------------------------
1024 -- Set_Msg_Name_Buffer --
1025 -------------------------
1027 procedure Set_Msg_Name_Buffer is
1029 for J in 1 .. Name_Len loop
1030 Set_Msg_Char (Name_Buffer (J));
1032 end Set_Msg_Name_Buffer;
1038 procedure Set_Msg_Quote is
1040 if not Manual_Quote_Mode then
1049 procedure Set_Msg_Str (Text : String) is
1051 for J in Text'Range loop
1052 Set_Msg_Char (Text (J));
1056 ------------------------------
1057 -- Set_Next_Non_Deleted_Msg --
1058 ------------------------------
1060 procedure Set_Next_Non_Deleted_Msg (E : in out Error_Msg_Id) is
1062 if E = No_Error_Msg then
1067 E := Errors.Table (E).Next;
1068 exit when E = No_Error_Msg or else not Errors.Table (E).Deleted;
1071 end Set_Next_Non_Deleted_Msg;
1073 ------------------------------
1074 -- Set_Specific_Warning_Off --
1075 ------------------------------
1077 procedure Set_Specific_Warning_Off
1083 Specific_Warnings.Append
1085 Msg => new String'(Msg),
1086 Stop => Source_Last (Current_Source_File),
1090 end Set_Specific_Warning_Off;
1092 -----------------------------
1093 -- Set_Specific_Warning_On --
1094 -----------------------------
1096 procedure Set_Specific_Warning_On
1102 for J in 1 .. Specific_Warnings.Last loop
1104 SWE : Specific_Warning_Entry renames Specific_Warnings.Table (J);
1106 if Msg = SWE.Msg.all
1107 and then Loc > SWE.Start
1109 and then Get_Source_File_Index (SWE.Start) =
1110 Get_Source_File_Index (Loc)
1116 -- If a config pragma is specifically cancelled, consider
1117 -- that it is no longer active as a configuration pragma.
1119 SWE.Config := False;
1126 end Set_Specific_Warning_On;
1128 ---------------------------
1129 -- Set_Warnings_Mode_Off --
1130 ---------------------------
1132 procedure Set_Warnings_Mode_Off (Loc : Source_Ptr) is
1134 -- Don't bother with entries from instantiation copies, since we
1135 -- will already have a copy in the template, which is what matters
1137 if Instantiation (Get_Source_File_Index (Loc)) /= No_Location then
1141 -- If last entry in table already covers us, this is a redundant
1142 -- pragma Warnings (Off) and can be ignored. This also handles the
1143 -- case where all warnings are suppressed by command line switch.
1145 if Warnings.Last >= Warnings.First
1146 and then Warnings.Table (Warnings.Last).Start <= Loc
1147 and then Loc <= Warnings.Table (Warnings.Last).Stop
1151 -- Otherwise establish a new entry, extending from the location of
1152 -- the pragma to the end of the current source file. This ending
1153 -- point will be adjusted by a subsequent pragma Warnings (On).
1156 Warnings.Increment_Last;
1157 Warnings.Table (Warnings.Last).Start := Loc;
1158 Warnings.Table (Warnings.Last).Stop :=
1159 Source_Last (Current_Source_File);
1161 end Set_Warnings_Mode_Off;
1163 --------------------------
1164 -- Set_Warnings_Mode_On --
1165 --------------------------
1167 procedure Set_Warnings_Mode_On (Loc : Source_Ptr) is
1169 -- Don't bother with entries from instantiation copies, since we
1170 -- will already have a copy in the template, which is what matters
1172 if Instantiation (Get_Source_File_Index (Loc)) /= No_Location then
1176 -- Nothing to do unless command line switch to suppress all warnings
1177 -- is off, and the last entry in the warnings table covers this
1178 -- pragma Warnings (On), in which case adjust the end point.
1180 if (Warnings.Last >= Warnings.First
1181 and then Warnings.Table (Warnings.Last).Start <= Loc
1182 and then Loc <= Warnings.Table (Warnings.Last).Stop)
1183 and then Warning_Mode /= Suppress
1185 Warnings.Table (Warnings.Last).Stop := Loc;
1187 end Set_Warnings_Mode_On;
1189 ------------------------------------
1190 -- Test_Style_Warning_Serious_Msg --
1191 ------------------------------------
1193 procedure Test_Style_Warning_Serious_Msg (Msg : String) is
1195 if Msg (Msg'First) = '\' then
1199 Is_Serious_Error := True;
1200 Is_Warning_Msg := False;
1203 (Msg'Length > 7 and then Msg (Msg'First .. Msg'First + 6) = "(style)");
1205 if Is_Style_Msg then
1206 Is_Serious_Error := False;
1209 for J in Msg'Range loop
1211 and then (J = Msg'First or else Msg (J - 1) /= ''')
1213 Is_Warning_Msg := True;
1216 and then (J = Msg'First or else Msg (J - 1) /= ''')
1218 Is_Warning_Msg := Error_Msg_Warn;
1221 and then (J = Msg'First or else Msg (J - 1) /= ''')
1223 Is_Serious_Error := False;
1227 if Is_Warning_Msg or Is_Style_Msg then
1228 Is_Serious_Error := False;
1230 end Test_Style_Warning_Serious_Msg;
1232 --------------------------------
1233 -- Validate_Specific_Warnings --
1234 --------------------------------
1236 procedure Validate_Specific_Warnings (Eproc : Error_Msg_Proc) is
1238 for J in Specific_Warnings.First .. Specific_Warnings.Last loop
1240 SWE : Specific_Warning_Entry renames Specific_Warnings.Table (J);
1242 if not SWE.Config then
1245 ("?pragma Warnings Off with no matching Warnings On",
1247 elsif not SWE.Used then
1249 ("?no warning suppressed by this pragma", SWE.Start);
1254 end Validate_Specific_Warnings;
1256 -------------------------------------
1257 -- Warning_Specifically_Suppressed --
1258 -------------------------------------
1260 function Warning_Specifically_Suppressed
1262 Msg : String_Ptr) return Boolean
1264 function Matches (S : String; P : String) return Boolean;
1265 -- Returns true if the String S patches the pattern P, which can contain
1266 -- wild card chars (*). The entire pattern must match the entire string.
1272 function Matches (S : String; P : String) return Boolean is
1273 Slast : constant Natural := S'Last;
1274 PLast : constant Natural := P'Last;
1276 SPtr : Natural := S'First;
1277 PPtr : Natural := P'First;
1280 -- Loop advancing through characters of string and pattern
1285 -- Return True if pattern is a single asterisk
1287 if PPtr = PLast and then P (PPtr) = '*' then
1290 -- Return True if both pattern and string exhausted
1292 elsif PPtr > PLast and then SPtr > Slast then
1295 -- Return False, if one exhausted and not the other
1297 elsif PPtr > PLast or else SPtr > Slast then
1300 -- Case where pattern starts with asterisk
1302 elsif P (PPtr) = '*' then
1304 -- Try all possible starting positions in S for match with
1305 -- the remaining characters of the pattern. This is the
1306 -- recursive call that implements the scanner backup.
1308 for J in SPtr .. Slast loop
1309 if Matches (S (J .. Slast), P (PPtr + 1 .. PLast)) then
1316 -- Dealt with end of string and *, advance if we have a match
1318 elsif S (SPtr) = P (PPtr) then
1322 -- If first characters do not match, that's decisive
1330 -- Start of processing for Warning_Specifically_Suppressed
1333 -- Loop through specific warning suppression entries
1335 for J in Specific_Warnings.First .. Specific_Warnings.Last loop
1337 SWE : Specific_Warning_Entry renames Specific_Warnings.Table (J);
1340 -- Pragma applies if it is a configuration pragma, or if the
1341 -- location is in range of a specific non-configuration pragma.
1344 or else (SWE.Start <= Loc and then Loc <= SWE.Stop)
1346 if Matches (Msg.all, SWE.Msg.all) then
1355 end Warning_Specifically_Suppressed;
1357 -------------------------
1358 -- Warnings_Suppressed --
1359 -------------------------
1361 function Warnings_Suppressed (Loc : Source_Ptr) return Boolean is
1363 if Warning_Mode = Suppress then
1367 -- Loop through table of ON/OFF warnings
1369 for J in Warnings.First .. Warnings.Last loop
1370 if Warnings.Table (J).Start <= Loc
1371 and then Loc <= Warnings.Table (J).Stop
1378 end Warnings_Suppressed;