1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2007, 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 2, 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 COPYING. If not, write --
19 -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
20 -- Boston, MA 02110-1301, USA. --
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 Errors.Table (D).Style then
119 Warnings_Detected := Warnings_Detected - 1;
121 Total_Errors_Detected := Total_Errors_Detected - 1;
123 if Errors.Table (D).Serious then
124 Serious_Errors_Detected := Serious_Errors_Detected - 1;
128 -- Substitute shorter of the two error messages
130 if Errors.Table (K).Text'Length > Errors.Table (D).Text'Length then
131 Errors.Table (K).Text := Errors.Table (D).Text;
134 D := Errors.Table (D).Next;
135 K := Errors.Table (K).Next;
137 if D = No_Error_Msg or else not Errors.Table (D).Msg_Cont then
143 -- Start of processing for Check_Duplicate_Message
146 -- Both messages must be non-continuation messages and not deleted
148 if Errors.Table (M1).Msg_Cont
149 or else Errors.Table (M2).Msg_Cont
150 or else Errors.Table (M1).Deleted
151 or else Errors.Table (M2).Deleted
156 -- Definitely not equal if message text does not match
158 if not Same_Error (M1, M2) then
162 -- Same text. See if all continuations are also identical
168 N1 := Errors.Table (L1).Next;
169 N2 := Errors.Table (L2).Next;
171 -- If M1 continuations have run out, we delete M1, either the
172 -- messages have the same number of continuations, or M2 has
173 -- more and we prefer the one with more anyway.
175 if N1 = No_Error_Msg or else not Errors.Table (N1).Msg_Cont then
179 -- If M2 continuatins have run out, we delete M2
181 elsif N2 = No_Error_Msg or else not Errors.Table (N2).Msg_Cont then
185 -- Otherwise see if continuations are the same, if not, keep both
186 -- sequences, a curious case, but better to keep everything!
188 elsif not Same_Error (N1, N2) then
191 -- If continuations are the same, continue scan
198 end Check_Duplicate_Message;
200 ------------------------
201 -- Compilation_Errors --
202 ------------------------
204 function Compilation_Errors return Boolean is
206 return Total_Errors_Detected /= 0
207 or else (Warnings_Detected /= 0
208 and then Warning_Mode = Treat_As_Error);
209 end Compilation_Errors;
215 procedure Debug_Output (N : Node_Id) is
218 Write_Str ("*** following error message posted on node id = #");
229 procedure dmsg (Id : Error_Msg_Id) is
230 E : Error_Msg_Object renames Errors.Table (Id);
233 w ("Dumping error message, Id = ", Int (Id));
234 w (" Text = ", E.Text.all);
235 w (" Next = ", Int (E.Next));
236 w (" Sfile = ", Int (E.Sfile));
240 Write_Location (E.Sptr);
245 Write_Location (E.Optr);
248 w (" Line = ", Int (E.Line));
249 w (" Col = ", Int (E.Col));
250 w (" Warn = ", E.Warn);
251 w (" Style = ", E.Style);
252 w (" Serious = ", E.Serious);
253 w (" Uncond = ", E.Uncond);
254 w (" Msg_Cont = ", E.Msg_Cont);
255 w (" Deleted = ", E.Deleted);
264 function Get_Location (E : Error_Msg_Id) return Source_Ptr is
266 return Errors.Table (E).Sptr;
273 function Get_Msg_Id return Error_Msg_Id is
278 -----------------------
279 -- Output_Error_Msgs --
280 -----------------------
282 procedure Output_Error_Msgs (E : in out Error_Msg_Id) is
288 Mult_Flags : Boolean := False;
293 -- Skip deleted messages at start
295 if Errors.Table (S).Deleted then
296 Set_Next_Non_Deleted_Msg (S);
299 -- Figure out if we will place more than one error flag on this line
302 while T /= No_Error_Msg
303 and then Errors.Table (T).Line = Errors.Table (E).Line
304 and then Errors.Table (T).Sfile = Errors.Table (E).Sfile
306 if Errors.Table (T).Sptr > Errors.Table (E).Sptr then
310 Set_Next_Non_Deleted_Msg (T);
313 -- Output the error flags. The circuit here makes sure that the tab
314 -- characters in the original line are properly accounted for. The
315 -- eight blanks at the start are to match the line number.
317 if not Debug_Flag_2 then
319 P := Line_Start (Errors.Table (E).Sptr);
322 -- Loop through error messages for this line to place flags
325 while T /= No_Error_Msg
326 and then Errors.Table (T).Line = Errors.Table (E).Line
327 and then Errors.Table (T).Sfile = Errors.Table (E).Sfile
329 -- Loop to output blanks till current flag position
331 while P < Errors.Table (T).Sptr loop
332 if Source_Text (Errors.Table (T).Sfile) (P) = ASCII.HT then
333 Write_Char (ASCII.HT);
341 -- Output flag (unless already output, this happens if more
342 -- than one error message occurs at the same flag position).
344 if P = Errors.Table (T).Sptr then
345 if (Flag_Num = 1 and then not Mult_Flags)
350 Write_Char (Character'Val (Character'Pos ('0') + Flag_Num));
356 Set_Next_Non_Deleted_Msg (T);
357 Flag_Num := Flag_Num + 1;
363 -- Now output the error messages
366 while T /= No_Error_Msg
367 and then Errors.Table (T).Line = Errors.Table (E).Line
368 and then Errors.Table (T).Sfile = Errors.Table (E).Sfile
374 while Column < 74 loop
382 Set_Next_Non_Deleted_Msg (T);
386 end Output_Error_Msgs;
388 ------------------------
389 -- Output_Line_Number --
390 ------------------------
392 procedure Output_Line_Number (L : Logical_Line_Number) is
393 D : Int; -- next digit
394 C : Character; -- next character
395 Z : Boolean; -- flag for zero suppress
396 N, M : Int; -- temporaries
399 if L = No_Line_Number then
420 C := Character'Val (D + 48);
428 end Output_Line_Number;
430 ---------------------
431 -- Output_Msg_Text --
432 ---------------------
434 procedure Output_Msg_Text (E : Error_Msg_Id) is
435 Offs : constant Nat := Column - 1;
436 -- Offset to start of message, used for continuations
439 -- Maximum characters to output on next line
442 -- Maximum total length of lines
445 if Error_Msg_Line_Length = 0 then
448 Length := Error_Msg_Line_Length;
451 Max := Integer (Length - Column + 1);
453 if Errors.Table (E).Warn then
454 Write_Str ("warning: ");
457 elsif Errors.Table (E).Style then
460 elsif Opt.Unique_Error_Tag then
461 Write_Str ("error: ");
465 -- Here we have to split the message up into multiple lines
468 Txt : constant String_Ptr := Errors.Table (E).Text;
469 Len : constant Natural := Txt'Length;
477 -- Make sure we do not have ludicrously small line
479 Max := Integer'Max (Max, 20);
481 -- If remaining text fits, output it respecting LF and we are done
483 if Len - Ptr < Max then
484 for J in Ptr .. Len loop
485 if Txt (J) = ASCII.LF then
489 Write_Char (Txt (J));
500 -- First scan forward looing for a hard end of line
502 for Scan in Ptr .. Ptr + Max - 1 loop
503 if Txt (Scan) = ASCII.LF then
510 -- Otherwise scan backwards looking for a space
512 for Scan in reverse Ptr .. Ptr + Max - 1 loop
513 if Txt (Scan) = ' ' then
520 -- If we fall through, no space, so split line arbitrarily
522 Split := Ptr + Max - 1;
527 if Start <= Split then
528 Write_Line (Txt (Start .. Split));
532 Max := Integer (Length - Column + 1);
541 procedure Purge_Messages (From : Source_Ptr; To : Source_Ptr) is
544 function To_Be_Purged (E : Error_Msg_Id) return Boolean;
545 -- Returns True for a message that is to be purged. Also adjusts
546 -- error counts appropriately.
552 function To_Be_Purged (E : Error_Msg_Id) return Boolean is
555 and then Errors.Table (E).Sptr > From
556 and then Errors.Table (E).Sptr < To
558 if Errors.Table (E).Warn or Errors.Table (E).Style then
559 Warnings_Detected := Warnings_Detected - 1;
561 Total_Errors_Detected := Total_Errors_Detected - 1;
563 if Errors.Table (E).Serious then
564 Serious_Errors_Detected := Serious_Errors_Detected - 1;
575 -- Start of processing for Purge_Messages
578 while To_Be_Purged (First_Error_Msg) loop
579 First_Error_Msg := Errors.Table (First_Error_Msg).Next;
582 E := First_Error_Msg;
583 while E /= No_Error_Msg loop
584 while To_Be_Purged (Errors.Table (E).Next) loop
585 Errors.Table (E).Next :=
586 Errors.Table (Errors.Table (E).Next).Next;
589 E := Errors.Table (E).Next;
597 function Same_Error (M1, M2 : Error_Msg_Id) return Boolean is
598 Msg1 : constant String_Ptr := Errors.Table (M1).Text;
599 Msg2 : constant String_Ptr := Errors.Table (M2).Text;
601 Msg2_Len : constant Integer := Msg2'Length;
602 Msg1_Len : constant Integer := Msg1'Length;
608 (Msg1_Len - 10 > Msg2_Len
610 Msg2.all = Msg1.all (1 .. Msg2_Len)
612 Msg1 (Msg2_Len + 1 .. Msg2_Len + 10) = ", instance")
614 (Msg2_Len - 10 > Msg1_Len
616 Msg1.all = Msg2.all (1 .. Msg1_Len)
618 Msg2 (Msg1_Len + 1 .. Msg1_Len + 10) = ", instance");
625 procedure Set_Msg_Blank is
628 and then Msg_Buffer (Msglen) /= ' '
629 and then Msg_Buffer (Msglen) /= '('
630 and then Msg_Buffer (Msglen) /= '-'
631 and then not Manual_Quote_Mode
637 -------------------------------
638 -- Set_Msg_Blank_Conditional --
639 -------------------------------
641 procedure Set_Msg_Blank_Conditional is
644 and then Msg_Buffer (Msglen) /= ' '
645 and then Msg_Buffer (Msglen) /= '('
646 and then Msg_Buffer (Msglen) /= '"'
647 and then not Manual_Quote_Mode
651 end Set_Msg_Blank_Conditional;
657 procedure Set_Msg_Char (C : Character) is
660 -- The check for message buffer overflow is needed to deal with cases
661 -- where insertions get too long (in particular a child unit name can
664 if Msglen < Max_Msg_Length then
665 Msglen := Msglen + 1;
666 Msg_Buffer (Msglen) := C;
670 ---------------------------------
671 -- Set_Msg_Insertion_File_Name --
672 ---------------------------------
674 procedure Set_Msg_Insertion_File_Name is
676 if Error_Msg_File_1 = No_File then
679 elsif Error_Msg_File_1 = Error_File_Name then
681 Set_Msg_Str ("<error>");
685 Get_Name_String (Error_Msg_File_1);
691 -- The following assignments ensure that the second and third {
692 -- insertion characters will correspond to the Error_Msg_File_2 and
693 -- Error_Msg_File_3 values and We suppress possible validity checks in
694 -- case operating in -gnatVa mode, and Error_Msg_File_2 or
695 -- Error_Msg_File_3 is not needed and has not been set.
698 pragma Suppress (Range_Check);
700 Error_Msg_File_1 := Error_Msg_File_2;
701 Error_Msg_File_2 := Error_Msg_File_3;
703 end Set_Msg_Insertion_File_Name;
705 -----------------------------------
706 -- Set_Msg_Insertion_Line_Number --
707 -----------------------------------
709 procedure Set_Msg_Insertion_Line_Number (Loc, Flag : Source_Ptr) is
710 Sindex_Loc : Source_File_Index;
711 Sindex_Flag : Source_File_Index;
716 if Loc = No_Location then
717 Set_Msg_Str ("at unknown location");
719 elsif Loc = System_Location then
720 Set_Msg_Str ("in package System");
721 Set_Msg_Insertion_Run_Time_Name;
723 elsif Loc = Standard_Location then
724 Set_Msg_Str ("in package Standard");
726 elsif Loc = Standard_ASCII_Location then
727 Set_Msg_Str ("in package Standard.ASCII");
730 -- Add "at file-name:" if reference is to other than the source
731 -- file in which the error message is placed. Note that we check
732 -- full file names, rather than just the source indexes, to
733 -- deal with generic instantiations from the current file.
735 Sindex_Loc := Get_Source_File_Index (Loc);
736 Sindex_Flag := Get_Source_File_Index (Flag);
738 if Full_File_Name (Sindex_Loc) /= Full_File_Name (Sindex_Flag) then
741 (Reference_Name (Get_Source_File_Index (Loc)));
745 -- If in current file, add text "at line "
748 Set_Msg_Str ("at line ");
751 -- Output line number for reference
753 Set_Msg_Int (Int (Get_Logical_Line_Number (Loc)));
755 -- Deal with the instantiation case. We may have a reference to,
756 -- e.g. a type, that is declared within a generic template, and
757 -- what we are really referring to is the occurrence in an instance.
758 -- In this case, the line number of the instantiation is also of
759 -- interest, and we add a notation:
763 -- where xxx is a line number output using this same routine (and
764 -- the recursion can go further if the instantiation is itself in
765 -- a generic template).
767 -- The flag location passed to us in this situation is indeed the
768 -- line number within the template, but as described in Sinput.L
769 -- (file sinput-l.ads, section "Handling Generic Instantiations")
770 -- we can retrieve the location of the instantiation itself from
771 -- this flag location value.
773 -- Note: this processing is suppressed if Suppress_Instance_Location
774 -- is set True. This is used to prevent redundant annotations of the
775 -- location of the instantiation in the case where we are placing
776 -- the messages on the instantiation in any case.
778 if Instantiation (Sindex_Loc) /= No_Location
779 and then not Suppress_Instance_Location
781 Set_Msg_Str (", instance ");
782 Set_Msg_Insertion_Line_Number (Instantiation (Sindex_Loc), Flag);
785 end Set_Msg_Insertion_Line_Number;
787 ----------------------------
788 -- Set_Msg_Insertion_Name --
789 ----------------------------
791 procedure Set_Msg_Insertion_Name is
793 if Error_Msg_Name_1 = No_Name then
796 elsif Error_Msg_Name_1 = Error_Name then
798 Set_Msg_Str ("<error>");
801 Set_Msg_Blank_Conditional;
802 Get_Unqualified_Decoded_Name_String (Error_Msg_Name_1);
804 -- Remove %s or %b at end. These come from unit names. If the
805 -- caller wanted the (unit) or (body), then they would have used
806 -- the $ insertion character. Certainly no error message should
807 -- ever have %b or %s explicitly occurring.
810 and then Name_Buffer (Name_Len - 1) = '%'
811 and then (Name_Buffer (Name_Len) = 'b'
813 Name_Buffer (Name_Len) = 's')
815 Name_Len := Name_Len - 2;
818 -- Remove upper case letter at end, again, we should not be getting
819 -- such names, and what we hope is that the remainder makes sense.
822 and then Name_Buffer (Name_Len) in 'A' .. 'Z'
824 Name_Len := Name_Len - 1;
827 -- If operator name or character literal name, just print it as is
828 -- Also print as is if it ends in a right paren (case of x'val(nnn))
830 if Name_Buffer (1) = '"'
831 or else Name_Buffer (1) = '''
832 or else Name_Buffer (Name_Len) = ')'
836 -- Else output with surrounding quotes in proper casing mode
839 Set_Casing (Identifier_Casing (Flag_Source), Mixed_Case);
846 -- The following assignments ensure that the second and third percent
847 -- insertion characters will correspond to the Error_Msg_Name_2 and
848 -- Error_Msg_Name_3 as required. We suppress possible validity checks in
849 -- case operating in -gnatVa mode, and Error_Msg_Name_1/2 is not needed
850 -- and has not been set.
853 pragma Suppress (Range_Check);
855 Error_Msg_Name_1 := Error_Msg_Name_2;
856 Error_Msg_Name_2 := Error_Msg_Name_3;
858 end Set_Msg_Insertion_Name;
860 ------------------------------------
861 -- Set_Msg_Insertion_Name_Literal --
862 ------------------------------------
864 procedure Set_Msg_Insertion_Name_Literal is
866 if Error_Msg_Name_1 = No_Name then
869 elsif Error_Msg_Name_1 = Error_Name then
871 Set_Msg_Str ("<error>");
875 Get_Name_String (Error_Msg_Name_1);
881 -- The following assignments ensure that the second and third % or %%
882 -- insertion characters will correspond to the Error_Msg_Name_2 and
883 -- Error_Msg_Name_3 values and We suppress possible validity checks in
884 -- case operating in -gnatVa mode, and Error_Msg_Name_2 or
885 -- Error_Msg_Name_3 is not needed and has not been set.
888 pragma Suppress (Range_Check);
890 Error_Msg_Name_1 := Error_Msg_Name_2;
891 Error_Msg_Name_2 := Error_Msg_Name_3;
893 end Set_Msg_Insertion_Name_Literal;
895 -------------------------------------
896 -- Set_Msg_Insertion_Reserved_Name --
897 -------------------------------------
899 procedure Set_Msg_Insertion_Reserved_Name is
901 Set_Msg_Blank_Conditional;
902 Get_Name_String (Error_Msg_Name_1);
904 Set_Casing (Keyword_Casing (Flag_Source), All_Lower_Case);
907 end Set_Msg_Insertion_Reserved_Name;
909 -------------------------------------
910 -- Set_Msg_Insertion_Reserved_Word --
911 -------------------------------------
913 procedure Set_Msg_Insertion_Reserved_Word
918 Set_Msg_Blank_Conditional;
921 while J <= Text'Last and then Text (J) in 'A' .. 'Z' loop
922 Name_Len := Name_Len + 1;
923 Name_Buffer (Name_Len) := Text (J);
927 -- Here is where we make the special exception for RM
929 if Name_Len = 2 and then Name_Buffer (1 .. 2) = "RM" then
932 -- Not RM: case appropriately and add surrounding quotes
935 Set_Casing (Keyword_Casing (Flag_Source), All_Lower_Case);
940 end Set_Msg_Insertion_Reserved_Word;
942 -------------------------------------
943 -- Set_Msg_Insertion_Run_Time_Name --
944 -------------------------------------
946 procedure Set_Msg_Insertion_Run_Time_Name is
948 if Targparm.Run_Time_Name_On_Target /= No_Name then
949 Set_Msg_Blank_Conditional;
951 Get_Name_String (Targparm.Run_Time_Name_On_Target);
952 Set_Casing (Mixed_Case);
953 Set_Msg_Str (Name_Buffer (1 .. Name_Len));
956 end Set_Msg_Insertion_Run_Time_Name;
958 ----------------------------
959 -- Set_Msg_Insertion_Uint --
960 ----------------------------
962 procedure Set_Msg_Insertion_Uint is
965 UI_Image (Error_Msg_Uint_1);
967 for J in 1 .. UI_Image_Length loop
968 Set_Msg_Char (UI_Image_Buffer (J));
971 -- The following assignment ensures that a second carret insertion
972 -- character will correspond to the Error_Msg_Uint_2 parameter. We
973 -- suppress possible validity checks in case operating in -gnatVa mode,
974 -- and Error_Msg_Uint_2 is not needed and has not been set.
977 pragma Suppress (Range_Check);
979 Error_Msg_Uint_1 := Error_Msg_Uint_2;
981 end Set_Msg_Insertion_Uint;
987 procedure Set_Msg_Int (Line : Int) is
990 Set_Msg_Int (Line / 10);
993 Set_Msg_Char (Character'Val (Character'Pos ('0') + (Line rem 10)));
996 -------------------------
997 -- Set_Msg_Name_Buffer --
998 -------------------------
1000 procedure Set_Msg_Name_Buffer is
1002 for J in 1 .. Name_Len loop
1003 Set_Msg_Char (Name_Buffer (J));
1005 end Set_Msg_Name_Buffer;
1011 procedure Set_Msg_Quote is
1013 if not Manual_Quote_Mode then
1022 procedure Set_Msg_Str (Text : String) is
1024 for J in Text'Range loop
1025 Set_Msg_Char (Text (J));
1029 ------------------------------
1030 -- Set_Next_Non_Deleted_Msg --
1031 ------------------------------
1033 procedure Set_Next_Non_Deleted_Msg (E : in out Error_Msg_Id) is
1035 if E = No_Error_Msg then
1040 E := Errors.Table (E).Next;
1041 exit when E = No_Error_Msg or else not Errors.Table (E).Deleted;
1044 end Set_Next_Non_Deleted_Msg;
1046 ------------------------------
1047 -- Set_Specific_Warning_Off --
1048 ------------------------------
1050 procedure Set_Specific_Warning_Off
1055 pragma Assert (Msg'First = 1);
1057 Pattern : String := Msg;
1058 Patlen : Natural := Msg'Length;
1060 Star_Start : Boolean;
1064 if Pattern (1) = '*' then
1066 Pattern (1 .. Patlen - 1) := Pattern (2 .. Patlen);
1067 Patlen := Patlen - 1;
1069 Star_Start := False;
1072 if Pattern (Patlen) = '*' then
1074 Patlen := Patlen - 1;
1079 Specific_Warnings.Append
1081 Msg => new String'(Msg),
1082 Pattern => new String'(Pattern (1 .. Patlen)),
1084 Stop => Source_Last (Current_Source_File),
1087 Star_Start => Star_Start,
1088 Star_End => Star_End,
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;
1204 and then Msg (Msg'First .. Msg'First + 6) = "(style)");
1206 for J in Msg'Range loop
1208 and then (J = Msg'First or else Msg (J - 1) /= ''')
1210 Is_Warning_Msg := True;
1213 and then (J = Msg'First or else Msg (J - 1) /= ''')
1215 Is_Warning_Msg := Error_Msg_Warn;
1218 and then (J = Msg'First or else Msg (J - 1) /= ''')
1220 Is_Serious_Error := False;
1224 if Is_Warning_Msg or else Is_Style_Msg then
1225 Is_Serious_Error := False;
1227 end Test_Style_Warning_Serious_Msg;
1229 --------------------------------
1230 -- Validate_Specific_Warnings --
1231 --------------------------------
1233 procedure Validate_Specific_Warnings (Eproc : Error_Msg_Proc) is
1235 for J in Specific_Warnings.First .. Specific_Warnings.Last loop
1237 SWE : Specific_Warning_Entry renames Specific_Warnings.Table (J);
1239 if not SWE.Config then
1242 ("?pragma Warnings Off with no matching Warnings On",
1244 elsif not SWE.Used then
1246 ("?no warning suppressed by this pragma", SWE.Start);
1251 end Validate_Specific_Warnings;
1253 -------------------------------------
1254 -- Warning_Specifically_Suppressed --
1255 -------------------------------------
1257 function Warning_Specifically_Suppressed
1259 Msg : String_Ptr) return Boolean
1261 pragma Assert (Msg'First = 1);
1263 Msglen : constant Natural := Msg'Length;
1265 -- Length of message
1267 Pattern : String_Ptr;
1268 -- Pattern itself, excluding initial and final *
1270 Star_Start : Boolean;
1272 -- Indications of * at start and end of original pattern
1276 -- Scan pointers for message and pattern
1279 -- Loop through specific warning suppression entries
1281 for J in Specific_Warnings.First .. Specific_Warnings.Last loop
1283 SWE : Specific_Warning_Entry renames Specific_Warnings.Table (J);
1286 -- Pragma applies if it is a configuration pragma, or if the
1287 -- location is in range of a specific non-configuration pragma.
1290 or else (SWE.Start <= Loc and then Loc <= SWE.Stop)
1292 -- Check if message matches, dealing with * patterns
1294 Patlen := SWE.Patlen;
1295 Pattern := SWE.Pattern;
1296 Star_Start := SWE.Star_Start;
1297 Star_End := SWE.Star_End;
1299 -- Loop through possible starting positions in Msg
1301 Outer : for M in 1 .. 1 + (Msglen - Patlen) loop
1303 -- See if pattern matches string starting at Msg (J)
1309 -- If pattern exhausted, then match if we are at end
1310 -- of message, or if pattern ended with an asterisk,
1311 -- otherwise match failure at this position.
1313 if Patp > Patlen then
1314 if Msgp > Msglen or else Star_End then
1321 -- Otherwise if message exhausted (and we still have
1322 -- pattern characters left), then match failure here.
1324 elsif Msgp > Msglen then
1328 -- Here we have pattern and message characters left
1330 -- Handle "*" pattern match
1332 if Patp < Patlen - 1 and then
1333 Pattern (Patp .. Patp + 2) = """*"""
1337 -- Must have " and at least three chars in msg or we
1338 -- have no match at this position.
1340 exit Inner when Msg (Msgp) /= '"';
1343 -- Scan out " string " in message
1346 exit Inner when Msgp = Msglen;
1348 exit Scan when Msg (Msgp - 1) = '"';
1351 -- If not "*" case, just compare character
1354 exit Inner when Pattern (Patp) /= Msg (Msgp);
1360 -- Advance to next position if star at end of original
1361 -- pattern, otherwise no more match attempts are possible
1363 exit Outer when not Star_Start;
1370 end Warning_Specifically_Suppressed;
1372 -------------------------
1373 -- Warnings_Suppressed --
1374 -------------------------
1376 function Warnings_Suppressed (Loc : Source_Ptr) return Boolean is
1378 -- Loop through table of ON/OFF warnings
1380 for J in Warnings.First .. Warnings.Last loop
1381 if Warnings.Table (J).Start <= Loc
1382 and then Loc <= Warnings.Table (J).Stop
1389 end Warnings_Suppressed;