1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 -- Warning: Error messages can be generated during Gigi processing by direct
27 -- calls to error message routines, so it is essential that the processing
28 -- in this body be consistent with the requirements for the Gigi processing
29 -- environment, and that in particular, no disallowed table expansion is
32 with Atree; use Atree;
33 with Casing; use Casing;
34 with Csets; use Csets;
35 with Debug; use Debug;
36 with Err_Vars; use Err_Vars;
37 with Namet; use Namet;
39 with Output; use Output;
40 with Sinput; use Sinput;
41 with Snames; use Snames;
42 with Stringt; use Stringt;
43 with Targparm; use Targparm;
44 with Uintp; use Uintp;
46 package body Erroutc is
48 -----------------------
49 -- Local Subprograms --
50 -----------------------
52 function Matches (S : String; P : String) return Boolean;
53 -- Returns true if the String S patches the pattern P, which can contain
54 -- wild card chars (*). The entire pattern must match the entire string.
55 -- Case is ignored in the comparison (so X matches x).
61 procedure Add_Class is
66 Get_Name_String (Name_Class);
67 Set_Casing (Identifier_Casing (Flag_Source), Mixed_Case);
72 ----------------------
73 -- Buffer_Ends_With --
74 ----------------------
76 function Buffer_Ends_With (C : Character) return Boolean is
78 return Msglen > 0 and then Msg_Buffer (Msglen) = C;
81 function Buffer_Ends_With (S : String) return Boolean is
82 Len : constant Natural := S'Length;
85 and then Msg_Buffer (Msglen - Len) = ' '
86 and then Msg_Buffer (Msglen - Len + 1 .. Msglen) = S;
93 procedure Buffer_Remove (C : Character) is
95 if Buffer_Ends_With (C) then
100 procedure Buffer_Remove (S : String) is
102 if Buffer_Ends_With (S) then
103 Msglen := Msglen - S'Length;
107 -----------------------------
108 -- Check_Duplicate_Message --
109 -----------------------------
111 procedure Check_Duplicate_Message (M1, M2 : Error_Msg_Id) is
112 L1, L2 : Error_Msg_Id;
113 N1, N2 : Error_Msg_Id;
115 procedure Delete_Msg (Delete, Keep : Error_Msg_Id);
116 -- Called to delete message Delete, keeping message Keep. Marks all
117 -- messages of Delete with deleted flag set to True, and also makes sure
118 -- that for the error messages that are retained the preferred message
119 -- is the one retained (we prefer the shorter one in the case where one
120 -- has an Instance tag). Note that we always know that Keep has at least
121 -- as many continuations as Delete (since we always delete the shorter
128 procedure Delete_Msg (Delete, Keep : Error_Msg_Id) is
136 Errors.Table (D).Deleted := True;
138 -- Adjust error message count
140 if Errors.Table (D).Warn or else Errors.Table (D).Style then
141 Warnings_Detected := Warnings_Detected - 1;
144 Total_Errors_Detected := Total_Errors_Detected - 1;
146 if Errors.Table (D).Serious then
147 Serious_Errors_Detected := Serious_Errors_Detected - 1;
151 -- Substitute shorter of the two error messages
153 if Errors.Table (K).Text'Length > Errors.Table (D).Text'Length then
154 Errors.Table (K).Text := Errors.Table (D).Text;
157 D := Errors.Table (D).Next;
158 K := Errors.Table (K).Next;
160 if D = No_Error_Msg or else not Errors.Table (D).Msg_Cont then
166 -- Start of processing for Check_Duplicate_Message
169 -- Both messages must be non-continuation messages and not deleted
171 if Errors.Table (M1).Msg_Cont
172 or else Errors.Table (M2).Msg_Cont
173 or else Errors.Table (M1).Deleted
174 or else Errors.Table (M2).Deleted
179 -- Definitely not equal if message text does not match
181 if not Same_Error (M1, M2) then
185 -- Same text. See if all continuations are also identical
191 N1 := Errors.Table (L1).Next;
192 N2 := Errors.Table (L2).Next;
194 -- If M1 continuations have run out, we delete M1, either the
195 -- messages have the same number of continuations, or M2 has
196 -- more and we prefer the one with more anyway.
198 if N1 = No_Error_Msg or else not Errors.Table (N1).Msg_Cont then
202 -- If M2 continuations have run out, we delete M2
204 elsif N2 = No_Error_Msg or else not Errors.Table (N2).Msg_Cont then
208 -- Otherwise see if continuations are the same, if not, keep both
209 -- sequences, a curious case, but better to keep everything.
211 elsif not Same_Error (N1, N2) then
214 -- If continuations are the same, continue scan
221 end Check_Duplicate_Message;
223 ------------------------
224 -- Compilation_Errors --
225 ------------------------
227 function Compilation_Errors return Boolean is
229 return Total_Errors_Detected /= 0
230 or else (Warnings_Detected /= 0
231 and then Warning_Mode = Treat_As_Error)
232 or else Warnings_Treated_As_Errors /= 0;
233 end Compilation_Errors;
239 procedure Debug_Output (N : Node_Id) is
242 Write_Str ("*** following error message posted on node id = #");
253 procedure dmsg (Id : Error_Msg_Id) is
254 E : Error_Msg_Object renames Errors.Table (Id);
257 w ("Dumping error message, Id = ", Int (Id));
258 w (" Text = ", E.Text.all);
259 w (" Next = ", Int (E.Next));
260 w (" Sfile = ", Int (E.Sfile));
264 Write_Location (E.Sptr);
269 Write_Location (E.Optr);
272 w (" Line = ", Int (E.Line));
273 w (" Col = ", Int (E.Col));
274 w (" Warn = ", E.Warn);
275 w (" Style = ", E.Style);
276 w (" Serious = ", E.Serious);
277 w (" Uncond = ", E.Uncond);
278 w (" Msg_Cont = ", E.Msg_Cont);
279 w (" Deleted = ", E.Deleted);
288 function Get_Location (E : Error_Msg_Id) return Source_Ptr is
290 return Errors.Table (E).Sptr;
297 function Get_Msg_Id return Error_Msg_Id is
302 ---------------------
303 -- Get_Warning_Tag --
304 ---------------------
306 function Get_Warning_Tag (Id : Error_Msg_Id) return String is
307 Warn : constant Boolean := Errors.Table (Id).Warn;
308 Warn_Chr : constant Character := Errors.Table (Id).Warn_Chr;
310 if Warn and then Warn_Chr /= ' ' then
311 if Warn_Chr = '?' then
312 return "[enabled by default]";
313 elsif Warn_Chr in 'a' .. 'z' then
314 return "[-gnatw" & Warn_Chr & ']';
315 else pragma Assert (Warn_Chr in 'A' .. 'Z');
316 return "[-gnatw." & Fold_Lower (Warn_Chr) & ']';
327 function Matches (S : String; P : String) return Boolean is
328 Slast : constant Natural := S'Last;
329 PLast : constant Natural := P'Last;
331 SPtr : Natural := S'First;
332 PPtr : Natural := P'First;
335 -- Loop advancing through characters of string and pattern
340 -- Return True if pattern is a single asterisk
342 if PPtr = PLast and then P (PPtr) = '*' then
345 -- Return True if both pattern and string exhausted
347 elsif PPtr > PLast and then SPtr > Slast then
350 -- Return False, if one exhausted and not the other
352 elsif PPtr > PLast or else SPtr > Slast then
355 -- Case where pattern starts with asterisk
357 elsif P (PPtr) = '*' then
359 -- Try all possible starting positions in S for match with the
360 -- remaining characters of the pattern. This is the recursive
361 -- call that implements the scanner backup.
363 for J in SPtr .. Slast loop
364 if Matches (S (J .. Slast), P (PPtr + 1 .. PLast)) then
371 -- Dealt with end of string and *, advance if we have a match
373 elsif Fold_Lower (S (SPtr)) = Fold_Lower (P (PPtr)) then
377 -- If first characters do not match, that's decisive
385 -----------------------
386 -- Output_Error_Msgs --
387 -----------------------
389 procedure Output_Error_Msgs (E : in out Error_Msg_Id) is
395 Mult_Flags : Boolean := False;
400 -- Skip deleted messages at start
402 if Errors.Table (S).Deleted then
403 Set_Next_Non_Deleted_Msg (S);
406 -- Figure out if we will place more than one error flag on this line
409 while T /= No_Error_Msg
410 and then Errors.Table (T).Line = Errors.Table (E).Line
411 and then Errors.Table (T).Sfile = Errors.Table (E).Sfile
413 if Errors.Table (T).Sptr > Errors.Table (E).Sptr then
417 Set_Next_Non_Deleted_Msg (T);
420 -- Output the error flags. The circuit here makes sure that the tab
421 -- characters in the original line are properly accounted for. The
422 -- eight blanks at the start are to match the line number.
424 if not Debug_Flag_2 then
426 P := Line_Start (Errors.Table (E).Sptr);
429 -- Loop through error messages for this line to place flags
432 while T /= No_Error_Msg
433 and then Errors.Table (T).Line = Errors.Table (E).Line
434 and then Errors.Table (T).Sfile = Errors.Table (E).Sfile
436 -- Loop to output blanks till current flag position
438 while P < Errors.Table (T).Sptr loop
439 if Source_Text (Errors.Table (T).Sfile) (P) = ASCII.HT then
440 Write_Char (ASCII.HT);
448 -- Output flag (unless already output, this happens if more
449 -- than one error message occurs at the same flag position).
451 if P = Errors.Table (T).Sptr then
452 if (Flag_Num = 1 and then not Mult_Flags)
457 Write_Char (Character'Val (Character'Pos ('0') + Flag_Num));
463 Set_Next_Non_Deleted_Msg (T);
464 Flag_Num := Flag_Num + 1;
470 -- Now output the error messages
473 while T /= No_Error_Msg
474 and then Errors.Table (T).Line = Errors.Table (E).Line
475 and then Errors.Table (T).Sfile = Errors.Table (E).Sfile
481 while Column < 74 loop
489 Set_Next_Non_Deleted_Msg (T);
493 end Output_Error_Msgs;
495 ------------------------
496 -- Output_Line_Number --
497 ------------------------
499 procedure Output_Line_Number (L : Logical_Line_Number) is
500 D : Int; -- next digit
501 C : Character; -- next character
502 Z : Boolean; -- flag for zero suppress
503 N, M : Int; -- temporaries
506 if L = No_Line_Number then
527 C := Character'Val (D + 48);
535 end Output_Line_Number;
537 ---------------------
538 -- Output_Msg_Text --
539 ---------------------
541 procedure Output_Msg_Text (E : Error_Msg_Id) is
542 Offs : constant Nat := Column - 1;
543 -- Offset to start of message, used for continuations
546 -- Maximum characters to output on next line
549 -- Maximum total length of lines
551 Text : constant String_Ptr := Errors.Table (E).Text;
558 Tag : constant String := Get_Warning_Tag (E);
563 -- Postfix warning tag to message if needed
565 if Tag /= "" and then Warning_Doc_Switch then
566 Txt := new String'(Text.all & ' ' & Tag);
571 -- Deal with warning case
573 if Errors.Table (E).Warn then
575 -- Nothing to do with info messages, "info " already set
578 and then Txt (Txt'First .. Txt'First + 5) = "info: "
582 -- Warning treated as error
584 elsif Errors.Table (E).Warn_Err then
586 -- We prefix the tag error: rather than warning: and postfix
587 -- [warning-as-error] at the end.
589 Warnings_Treated_As_Errors := Warnings_Treated_As_Errors + 1;
590 Txt := new String'("error: " & Txt.all & " [warning-as-error]");
592 -- Normal case, prefix
595 Txt := new String'("warning: " & Txt.all);
598 -- No prefix needed for style message, "(style)" is there already
600 elsif Errors.Table (E).Style then
603 -- All other cases, add "error: " if unique error tag set
605 elsif Opt.Unique_Error_Tag then
606 Txt := new String'("error: " & Txt.all);
609 -- Set error message line length and length of message
611 if Error_Msg_Line_Length = 0 then
614 Length := Error_Msg_Line_Length;
617 Max := Integer (Length - Column + 1);
620 -- Here we have to split the message up into multiple lines
624 -- Make sure we do not have ludicrously small line
626 Max := Integer'Max (Max, 20);
628 -- If remaining text fits, output it respecting LF and we are done
630 if Len - Ptr < Max then
631 for J in Ptr .. Len loop
632 if Txt (J) = ASCII.LF then
636 Write_Char (Txt (J));
647 -- First scan forward looking for a hard end of line
649 for Scan in Ptr .. Ptr + Max - 1 loop
650 if Txt (Scan) = ASCII.LF then
657 -- Otherwise scan backwards looking for a space
659 for Scan in reverse Ptr .. Ptr + Max - 1 loop
660 if Txt (Scan) = ' ' then
667 -- If we fall through, no space, so split line arbitrarily
669 Split := Ptr + Max - 1;
674 if Start <= Split then
675 Write_Line (Txt (Start .. Split));
679 Max := Integer (Length - Column + 1);
688 procedure Purge_Messages (From : Source_Ptr; To : Source_Ptr) is
691 function To_Be_Purged (E : Error_Msg_Id) return Boolean;
692 -- Returns True for a message that is to be purged. Also adjusts
693 -- error counts appropriately.
699 function To_Be_Purged (E : Error_Msg_Id) return Boolean is
702 and then Errors.Table (E).Sptr > From
703 and then Errors.Table (E).Sptr < To
705 if Errors.Table (E).Warn or else Errors.Table (E).Style then
706 Warnings_Detected := Warnings_Detected - 1;
709 Total_Errors_Detected := Total_Errors_Detected - 1;
711 if Errors.Table (E).Serious then
712 Serious_Errors_Detected := Serious_Errors_Detected - 1;
723 -- Start of processing for Purge_Messages
726 while To_Be_Purged (First_Error_Msg) loop
727 First_Error_Msg := Errors.Table (First_Error_Msg).Next;
730 E := First_Error_Msg;
731 while E /= No_Error_Msg loop
732 while To_Be_Purged (Errors.Table (E).Next) loop
733 Errors.Table (E).Next :=
734 Errors.Table (Errors.Table (E).Next).Next;
737 E := Errors.Table (E).Next;
745 function Same_Error (M1, M2 : Error_Msg_Id) return Boolean is
746 Msg1 : constant String_Ptr := Errors.Table (M1).Text;
747 Msg2 : constant String_Ptr := Errors.Table (M2).Text;
749 Msg2_Len : constant Integer := Msg2'Length;
750 Msg1_Len : constant Integer := Msg1'Length;
756 (Msg1_Len - 10 > Msg2_Len
758 Msg2.all = Msg1.all (1 .. Msg2_Len)
760 Msg1 (Msg2_Len + 1 .. Msg2_Len + 10) = ", instance")
762 (Msg2_Len - 10 > Msg1_Len
764 Msg1.all = Msg2.all (1 .. Msg1_Len)
766 Msg2 (Msg1_Len + 1 .. Msg1_Len + 10) = ", instance");
773 procedure Set_Msg_Blank is
776 and then Msg_Buffer (Msglen) /= ' '
777 and then Msg_Buffer (Msglen) /= '('
778 and then Msg_Buffer (Msglen) /= '-'
779 and then not Manual_Quote_Mode
785 -------------------------------
786 -- Set_Msg_Blank_Conditional --
787 -------------------------------
789 procedure Set_Msg_Blank_Conditional is
792 and then Msg_Buffer (Msglen) /= ' '
793 and then Msg_Buffer (Msglen) /= '('
794 and then Msg_Buffer (Msglen) /= '"'
795 and then not Manual_Quote_Mode
799 end Set_Msg_Blank_Conditional;
805 procedure Set_Msg_Char (C : Character) is
808 -- The check for message buffer overflow is needed to deal with cases
809 -- where insertions get too long (in particular a child unit name can
812 if Msglen < Max_Msg_Length then
813 Msglen := Msglen + 1;
814 Msg_Buffer (Msglen) := C;
818 ---------------------------------
819 -- Set_Msg_Insertion_File_Name --
820 ---------------------------------
822 procedure Set_Msg_Insertion_File_Name is
824 if Error_Msg_File_1 = No_File then
827 elsif Error_Msg_File_1 = Error_File_Name then
829 Set_Msg_Str ("<error>");
833 Get_Name_String (Error_Msg_File_1);
839 -- The following assignments ensure that the second and third {
840 -- insertion characters will correspond to the Error_Msg_File_2 and
841 -- Error_Msg_File_3 values and We suppress possible validity checks in
842 -- case operating in -gnatVa mode, and Error_Msg_File_2 or
843 -- Error_Msg_File_3 is not needed and has not been set.
846 pragma Suppress (Range_Check);
848 Error_Msg_File_1 := Error_Msg_File_2;
849 Error_Msg_File_2 := Error_Msg_File_3;
851 end Set_Msg_Insertion_File_Name;
853 -----------------------------------
854 -- Set_Msg_Insertion_Line_Number --
855 -----------------------------------
857 procedure Set_Msg_Insertion_Line_Number (Loc, Flag : Source_Ptr) is
858 Sindex_Loc : Source_File_Index;
859 Sindex_Flag : Source_File_Index;
862 -- Outputs "at " unless last characters in buffer are " from ". Certain
863 -- messages read better with from than at.
872 or else Msg_Buffer (Msglen - 5 .. Msglen) /= " from "
878 -- Start of processing for Set_Msg_Insertion_Line_Number
883 if Loc = No_Location then
885 Set_Msg_Str ("unknown location");
887 elsif Loc = System_Location then
888 Set_Msg_Str ("in package System");
889 Set_Msg_Insertion_Run_Time_Name;
891 elsif Loc = Standard_Location then
892 Set_Msg_Str ("in package Standard");
894 elsif Loc = Standard_ASCII_Location then
895 Set_Msg_Str ("in package Standard.ASCII");
898 -- Add "at file-name:" if reference is to other than the source
899 -- file in which the error message is placed. Note that we check
900 -- full file names, rather than just the source indexes, to
901 -- deal with generic instantiations from the current file.
903 Sindex_Loc := Get_Source_File_Index (Loc);
904 Sindex_Flag := Get_Source_File_Index (Flag);
906 if Full_File_Name (Sindex_Loc) /= Full_File_Name (Sindex_Flag) then
909 (Reference_Name (Get_Source_File_Index (Loc)));
913 -- If in current file, add text "at line "
917 Set_Msg_Str ("line ");
920 -- Output line number for reference
922 Set_Msg_Int (Int (Get_Logical_Line_Number (Loc)));
924 -- Deal with the instantiation case. We may have a reference to,
925 -- e.g. a type, that is declared within a generic template, and
926 -- what we are really referring to is the occurrence in an instance.
927 -- In this case, the line number of the instantiation is also of
928 -- interest, and we add a notation:
932 -- where xxx is a line number output using this same routine (and
933 -- the recursion can go further if the instantiation is itself in
934 -- a generic template).
936 -- The flag location passed to us in this situation is indeed the
937 -- line number within the template, but as described in Sinput.L
938 -- (file sinput-l.ads, section "Handling Generic Instantiations")
939 -- we can retrieve the location of the instantiation itself from
940 -- this flag location value.
942 -- Note: this processing is suppressed if Suppress_Instance_Location
943 -- is set True. This is used to prevent redundant annotations of the
944 -- location of the instantiation in the case where we are placing
945 -- the messages on the instantiation in any case.
947 if Instantiation (Sindex_Loc) /= No_Location
948 and then not Suppress_Instance_Location
950 Set_Msg_Str (", instance ");
951 Set_Msg_Insertion_Line_Number (Instantiation (Sindex_Loc), Flag);
954 end Set_Msg_Insertion_Line_Number;
956 ----------------------------
957 -- Set_Msg_Insertion_Name --
958 ----------------------------
960 procedure Set_Msg_Insertion_Name is
962 if Error_Msg_Name_1 = No_Name then
965 elsif Error_Msg_Name_1 = Error_Name then
967 Set_Msg_Str ("<error>");
970 Set_Msg_Blank_Conditional;
971 Get_Unqualified_Decoded_Name_String (Error_Msg_Name_1);
973 -- Remove %s or %b at end. These come from unit names. If the
974 -- caller wanted the (unit) or (body), then they would have used
975 -- the $ insertion character. Certainly no error message should
976 -- ever have %b or %s explicitly occurring.
979 and then Name_Buffer (Name_Len - 1) = '%'
980 and then (Name_Buffer (Name_Len) = 'b'
982 Name_Buffer (Name_Len) = 's')
984 Name_Len := Name_Len - 2;
987 -- Remove upper case letter at end, again, we should not be getting
988 -- such names, and what we hope is that the remainder makes sense.
990 if Name_Len > 1 and then Name_Buffer (Name_Len) in 'A' .. 'Z' then
991 Name_Len := Name_Len - 1;
994 -- If operator name or character literal name, just print it as is
995 -- Also print as is if it ends in a right paren (case of x'val(nnn))
997 if Name_Buffer (1) = '"'
998 or else Name_Buffer (1) = '''
999 or else Name_Buffer (Name_Len) = ')'
1001 Set_Msg_Name_Buffer;
1003 -- Else output with surrounding quotes in proper casing mode
1006 Set_Casing (Identifier_Casing (Flag_Source), Mixed_Case);
1008 Set_Msg_Name_Buffer;
1013 -- The following assignments ensure that the second and third percent
1014 -- insertion characters will correspond to the Error_Msg_Name_2 and
1015 -- Error_Msg_Name_3 as required. We suppress possible validity checks in
1016 -- case operating in -gnatVa mode, and Error_Msg_Name_1/2 is not needed
1017 -- and has not been set.
1020 pragma Suppress (Range_Check);
1022 Error_Msg_Name_1 := Error_Msg_Name_2;
1023 Error_Msg_Name_2 := Error_Msg_Name_3;
1025 end Set_Msg_Insertion_Name;
1027 ------------------------------------
1028 -- Set_Msg_Insertion_Name_Literal --
1029 ------------------------------------
1031 procedure Set_Msg_Insertion_Name_Literal is
1033 if Error_Msg_Name_1 = No_Name then
1036 elsif Error_Msg_Name_1 = Error_Name then
1038 Set_Msg_Str ("<error>");
1042 Get_Name_String (Error_Msg_Name_1);
1044 Set_Msg_Name_Buffer;
1048 -- The following assignments ensure that the second and third % or %%
1049 -- insertion characters will correspond to the Error_Msg_Name_2 and
1050 -- Error_Msg_Name_3 values and We suppress possible validity checks in
1051 -- case operating in -gnatVa mode, and Error_Msg_Name_2 or
1052 -- Error_Msg_Name_3 is not needed and has not been set.
1055 pragma Suppress (Range_Check);
1057 Error_Msg_Name_1 := Error_Msg_Name_2;
1058 Error_Msg_Name_2 := Error_Msg_Name_3;
1060 end Set_Msg_Insertion_Name_Literal;
1062 -------------------------------------
1063 -- Set_Msg_Insertion_Reserved_Name --
1064 -------------------------------------
1066 procedure Set_Msg_Insertion_Reserved_Name is
1068 Set_Msg_Blank_Conditional;
1069 Get_Name_String (Error_Msg_Name_1);
1071 Set_Casing (Keyword_Casing (Flag_Source), All_Lower_Case);
1072 Set_Msg_Name_Buffer;
1074 end Set_Msg_Insertion_Reserved_Name;
1076 -------------------------------------
1077 -- Set_Msg_Insertion_Reserved_Word --
1078 -------------------------------------
1080 procedure Set_Msg_Insertion_Reserved_Word
1085 Set_Msg_Blank_Conditional;
1088 while J <= Text'Last and then Text (J) in 'A' .. 'Z' loop
1089 Add_Char_To_Name_Buffer (Text (J));
1093 -- Here is where we make the special exception for RM
1095 if Name_Len = 2 and then Name_Buffer (1 .. 2) = "RM" then
1096 Set_Msg_Name_Buffer;
1098 -- We make a similar exception for SPARK
1100 elsif Name_Len = 5 and then Name_Buffer (1 .. 5) = "SPARK" then
1101 Set_Msg_Name_Buffer;
1103 -- Neither RM nor SPARK: case appropriately and add surrounding quotes
1106 Set_Casing (Keyword_Casing (Flag_Source), All_Lower_Case);
1108 Set_Msg_Name_Buffer;
1111 end Set_Msg_Insertion_Reserved_Word;
1113 -------------------------------------
1114 -- Set_Msg_Insertion_Run_Time_Name --
1115 -------------------------------------
1117 procedure Set_Msg_Insertion_Run_Time_Name is
1119 if Targparm.Run_Time_Name_On_Target /= No_Name then
1120 Set_Msg_Blank_Conditional;
1122 Get_Name_String (Targparm.Run_Time_Name_On_Target);
1123 Set_Casing (Mixed_Case);
1124 Set_Msg_Str (Name_Buffer (1 .. Name_Len));
1127 end Set_Msg_Insertion_Run_Time_Name;
1129 ----------------------------
1130 -- Set_Msg_Insertion_Uint --
1131 ----------------------------
1133 procedure Set_Msg_Insertion_Uint is
1136 UI_Image (Error_Msg_Uint_1);
1138 for J in 1 .. UI_Image_Length loop
1139 Set_Msg_Char (UI_Image_Buffer (J));
1142 -- The following assignment ensures that a second caret insertion
1143 -- character will correspond to the Error_Msg_Uint_2 parameter. We
1144 -- suppress possible validity checks in case operating in -gnatVa mode,
1145 -- and Error_Msg_Uint_2 is not needed and has not been set.
1148 pragma Suppress (Range_Check);
1150 Error_Msg_Uint_1 := Error_Msg_Uint_2;
1152 end Set_Msg_Insertion_Uint;
1158 procedure Set_Msg_Int (Line : Int) is
1161 Set_Msg_Int (Line / 10);
1164 Set_Msg_Char (Character'Val (Character'Pos ('0') + (Line rem 10)));
1167 -------------------------
1168 -- Set_Msg_Name_Buffer --
1169 -------------------------
1171 procedure Set_Msg_Name_Buffer is
1173 for J in 1 .. Name_Len loop
1174 Set_Msg_Char (Name_Buffer (J));
1176 end Set_Msg_Name_Buffer;
1182 procedure Set_Msg_Quote is
1184 if not Manual_Quote_Mode then
1193 procedure Set_Msg_Str (Text : String) is
1195 for J in Text'Range loop
1196 Set_Msg_Char (Text (J));
1200 ------------------------------
1201 -- Set_Next_Non_Deleted_Msg --
1202 ------------------------------
1204 procedure Set_Next_Non_Deleted_Msg (E : in out Error_Msg_Id) is
1206 if E = No_Error_Msg then
1211 E := Errors.Table (E).Next;
1212 exit when E = No_Error_Msg or else not Errors.Table (E).Deleted;
1215 end Set_Next_Non_Deleted_Msg;
1217 ------------------------------
1218 -- Set_Specific_Warning_Off --
1219 ------------------------------
1221 procedure Set_Specific_Warning_Off
1226 Used : Boolean := False)
1229 Specific_Warnings.Append
1231 Msg => new String'(Msg),
1232 Stop => Source_Last (Current_Source_File),
1237 end Set_Specific_Warning_Off;
1239 -----------------------------
1240 -- Set_Specific_Warning_On --
1241 -----------------------------
1243 procedure Set_Specific_Warning_On
1249 for J in 1 .. Specific_Warnings.Last loop
1251 SWE : Specific_Warning_Entry renames Specific_Warnings.Table (J);
1253 if Msg = SWE.Msg.all
1254 and then Loc > SWE.Start
1256 and then Get_Source_File_Index (SWE.Start) =
1257 Get_Source_File_Index (Loc)
1263 -- If a config pragma is specifically cancelled, consider
1264 -- that it is no longer active as a configuration pragma.
1266 SWE.Config := False;
1273 end Set_Specific_Warning_On;
1275 ---------------------------
1276 -- Set_Warnings_Mode_Off --
1277 ---------------------------
1279 procedure Set_Warnings_Mode_Off (Loc : Source_Ptr; Reason : String_Id) is
1281 -- Don't bother with entries from instantiation copies, since we will
1282 -- already have a copy in the template, which is what matters.
1284 if Instantiation (Get_Source_File_Index (Loc)) /= No_Location then
1288 -- If all warnings are suppressed by command line switch, this can
1289 -- be ignored, unless we are in GNATprove_Mode which requires pragma
1290 -- Warnings to be stored for the formal verification backend.
1292 if Warning_Mode = Suppress
1293 and then not GNATprove_Mode
1298 -- If last entry in table already covers us, this is a redundant pragma
1299 -- Warnings (Off) and can be ignored.
1301 if Warnings.Last >= Warnings.First
1302 and then Warnings.Table (Warnings.Last).Start <= Loc
1303 and then Loc <= Warnings.Table (Warnings.Last).Stop
1308 -- If none of those special conditions holds, establish a new entry,
1309 -- extending from the location of the pragma to the end of the current
1310 -- source file. This ending point will be adjusted by a subsequent
1311 -- corresponding pragma Warnings (On).
1315 Stop => Source_Last (Current_Source_File),
1317 end Set_Warnings_Mode_Off;
1319 --------------------------
1320 -- Set_Warnings_Mode_On --
1321 --------------------------
1323 procedure Set_Warnings_Mode_On (Loc : Source_Ptr) is
1325 -- Don't bother with entries from instantiation copies, since we will
1326 -- already have a copy in the template, which is what matters.
1328 if Instantiation (Get_Source_File_Index (Loc)) /= No_Location then
1332 -- If all warnings are suppressed by command line switch, this can
1333 -- be ignored, unless we are in GNATprove_Mode which requires pragma
1334 -- Warnings to be stored for the formal verification backend.
1336 if Warning_Mode = Suppress
1337 and then not GNATprove_Mode
1342 -- If the last entry in the warnings table covers this pragma, then
1343 -- we adjust the end point appropriately.
1345 if Warnings.Last >= Warnings.First
1346 and then Warnings.Table (Warnings.Last).Start <= Loc
1347 and then Loc <= Warnings.Table (Warnings.Last).Stop
1349 Warnings.Table (Warnings.Last).Stop := Loc;
1351 end Set_Warnings_Mode_On;
1353 ------------------------------------
1354 -- Test_Style_Warning_Serious_Msg --
1355 ------------------------------------
1357 procedure Test_Style_Warning_Serious_Unconditional_Msg (Msg : String) is
1359 -- Nothing to do for continuation line
1361 if Msg (Msg'First) = '\' then
1365 -- Set initial values of globals (may be changed during scan)
1367 Is_Serious_Error := True;
1368 Is_Unconditional_Msg := False;
1369 Is_Warning_Msg := False;
1370 Has_Double_Exclam := False;
1373 (Msg'Length > 7 and then Msg (Msg'First .. Msg'First + 6) = "(style)");
1375 for J in Msg'Range loop
1377 and then (J = Msg'First or else Msg (J - 1) /= ''')
1379 Is_Warning_Msg := True;
1380 Warning_Msg_Char := ' ';
1383 and then (J = Msg'First or else Msg (J - 1) /= ''')
1385 Is_Unconditional_Msg := True;
1386 Warning_Msg_Char := ' ';
1388 if J < Msg'Last and then Msg (J + 1) = '!' then
1389 Has_Double_Exclam := True;
1393 and then (J = Msg'First or else Msg (J - 1) /= ''')
1395 Is_Warning_Msg := Error_Msg_Warn;
1396 Warning_Msg_Char := ' ';
1399 and then (J = Msg'First or else Msg (J - 1) /= ''')
1401 Is_Serious_Error := False;
1405 if Is_Warning_Msg or Is_Style_Msg then
1406 Is_Serious_Error := False;
1408 end Test_Style_Warning_Serious_Unconditional_Msg;
1410 --------------------------------
1411 -- Validate_Specific_Warnings --
1412 --------------------------------
1414 procedure Validate_Specific_Warnings (Eproc : Error_Msg_Proc) is
1416 if not Warn_On_Warnings_Off then
1420 for J in Specific_Warnings.First .. Specific_Warnings.Last loop
1422 SWE : Specific_Warning_Entry renames Specific_Warnings.Table (J);
1425 if not SWE.Config then
1427 -- Warn for unmatched Warnings (Off, ...)
1431 ("?W?pragma Warnings Off with no matching Warnings On",
1434 -- Warn for ineffective Warnings (Off, ..)
1438 -- Do not issue this warning for -Wxxx messages since the
1439 -- back-end doesn't report the information.
1442 (SWE.Msg'Length > 2 and then SWE.Msg (1 .. 2) = "-W")
1445 ("?W?no warning suppressed by this pragma", SWE.Start);
1450 end Validate_Specific_Warnings;
1452 -------------------------------------
1453 -- Warning_Specifically_Suppressed --
1454 -------------------------------------
1456 function Warning_Specifically_Suppressed
1458 Msg : String_Ptr) return String_Id
1461 -- Loop through specific warning suppression entries
1463 for J in Specific_Warnings.First .. Specific_Warnings.Last loop
1465 SWE : Specific_Warning_Entry renames Specific_Warnings.Table (J);
1468 -- Pragma applies if it is a configuration pragma, or if the
1469 -- location is in range of a specific non-configuration pragma.
1472 or else (SWE.Start <= Loc and then Loc <= SWE.Stop)
1474 if Matches (Msg.all, SWE.Msg.all) then
1483 end Warning_Specifically_Suppressed;
1485 ------------------------------
1486 -- Warning_Treated_As_Error --
1487 ------------------------------
1489 function Warning_Treated_As_Error (Msg : String) return Boolean is
1491 for J in 1 .. Warnings_As_Errors_Count loop
1492 if Matches (Msg, Warnings_As_Errors (J).all) then
1498 end Warning_Treated_As_Error;
1500 -------------------------
1501 -- Warnings_Suppressed --
1502 -------------------------
1504 function Warnings_Suppressed (Loc : Source_Ptr) return String_Id is
1506 -- Loop through table of ON/OFF warnings
1508 for J in Warnings.First .. Warnings.Last loop
1509 if Warnings.Table (J).Start <= Loc
1510 and then Loc <= Warnings.Table (J).Stop
1512 return Warnings.Table (J).Reason;
1516 if Warning_Mode = Suppress then
1517 return Null_String_Id;
1521 end Warnings_Suppressed;