1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2023, 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 Fname
; use Fname
;
38 with Namet
; use Namet
;
40 with Output
; use Output
;
41 with Sinput
; use Sinput
;
42 with Snames
; use Snames
;
43 with Stringt
; use Stringt
;
45 with Uintp
; use Uintp
;
46 with Widechar
; use Widechar
;
47 with Warnsw
; use Warnsw
;
49 package body Erroutc
is
51 -----------------------
52 -- Local Subprograms --
53 -----------------------
55 function Sloc_In_Range
(Loc
, Start
, Stop
: Source_Ptr
) return Boolean;
56 -- Return whether Loc is in the range Start .. Stop, taking instantiation
57 -- locations of Loc into account. This is useful for suppressing warnings
58 -- from generic instantiations by using pragma Warnings around generic
59 -- instances, as needed in GNATprove.
65 procedure Add_Class
is
70 Get_Name_String
(Name_Class
);
71 Set_Casing
(Identifier_Casing
(Flag_Source
));
76 ----------------------
77 -- Buffer_Ends_With --
78 ----------------------
80 function Buffer_Ends_With
(C
: Character) return Boolean is
82 return Msglen
> 0 and then Msg_Buffer
(Msglen
) = C
;
85 function Buffer_Ends_With
(S
: String) return Boolean is
86 Len
: constant Natural := S
'Length;
89 and then Msg_Buffer
(Msglen
- Len
) = ' '
90 and then Msg_Buffer
(Msglen
- Len
+ 1 .. Msglen
) = S
;
97 procedure Buffer_Remove
(C
: Character) is
99 if Buffer_Ends_With
(C
) then
100 Msglen
:= Msglen
- 1;
104 procedure Buffer_Remove
(S
: String) is
106 if Buffer_Ends_With
(S
) then
107 Msglen
:= Msglen
- S
'Length;
111 -----------------------------
112 -- Check_Duplicate_Message --
113 -----------------------------
115 procedure Check_Duplicate_Message
(M1
, M2
: Error_Msg_Id
) is
116 L1
, L2
: Error_Msg_Id
;
117 N1
, N2
: Error_Msg_Id
;
119 procedure Delete_Msg
(Delete
, Keep
: Error_Msg_Id
);
120 -- Called to delete message Delete, keeping message Keep. Marks msg
121 -- Delete and all its continuations with deleted flag set to True.
122 -- Also makes sure that for the error messages that are retained the
123 -- preferred message is the one retained (we prefer the shorter one in
124 -- the case where one has an Instance tag). Note that we always know
125 -- that Keep has at least as many continuations as Delete (since we
126 -- always delete the shorter sequence).
132 procedure Delete_Msg
(Delete
, Keep
: Error_Msg_Id
) is
140 Errors
.Table
(D
).Deleted
:= True;
142 -- Adjust error message count
144 if Errors
.Table
(D
).Info
then
146 if Errors
.Table
(D
).Warn
then
147 Warning_Info_Messages
:= Warning_Info_Messages
- 1;
148 Warnings_Detected
:= Warnings_Detected
- 1;
150 Report_Info_Messages
:= Report_Info_Messages
- 1;
153 elsif Errors
.Table
(D
).Warn
or else Errors
.Table
(D
).Style
then
154 Warnings_Detected
:= Warnings_Detected
- 1;
156 -- Note: we do not need to decrement Warnings_Treated_As_Errors
157 -- because this only gets incremented if we actually output the
158 -- message, which we won't do if we are deleting it here!
160 elsif Errors
.Table
(D
).Check
then
161 Check_Messages
:= Check_Messages
- 1;
164 Total_Errors_Detected
:= Total_Errors_Detected
- 1;
166 if Errors
.Table
(D
).Serious
then
167 Serious_Errors_Detected
:= Serious_Errors_Detected
- 1;
171 -- Substitute shorter of the two error messages
173 if Errors
.Table
(K
).Text
'Length > Errors
.Table
(D
).Text
'Length then
174 Errors
.Table
(K
).Text
:= Errors
.Table
(D
).Text
;
177 D
:= Errors
.Table
(D
).Next
;
178 K
:= Errors
.Table
(K
).Next
;
180 if D
= No_Error_Msg
or else not Errors
.Table
(D
).Msg_Cont
then
186 -- Start of processing for Check_Duplicate_Message
189 -- Both messages must be non-continuation messages and not deleted
191 if Errors
.Table
(M1
).Msg_Cont
192 or else Errors
.Table
(M2
).Msg_Cont
193 or else Errors
.Table
(M1
).Deleted
194 or else Errors
.Table
(M2
).Deleted
199 -- Definitely not equal if message text does not match
201 if not Same_Error
(M1
, M2
) then
205 -- Same text. See if all continuations are also identical
211 N1
:= Errors
.Table
(L1
).Next
;
212 N2
:= Errors
.Table
(L2
).Next
;
214 -- If M1 continuations have run out, we delete M1, either the
215 -- messages have the same number of continuations, or M2 has
216 -- more and we prefer the one with more anyway.
218 if N1
= No_Error_Msg
or else not Errors
.Table
(N1
).Msg_Cont
then
222 -- If M2 continuations have run out, we delete M2
224 elsif N2
= No_Error_Msg
or else not Errors
.Table
(N2
).Msg_Cont
then
228 -- Otherwise see if continuations are the same, if not, keep both
229 -- sequences, a curious case, but better to keep everything.
231 elsif not Same_Error
(N1
, N2
) then
234 -- If continuations are the same, continue scan
241 end Check_Duplicate_Message
;
243 ------------------------
244 -- Compilation_Errors --
245 ------------------------
247 function Compilation_Errors
return Boolean is
248 Warnings_Count
: constant Int
249 := Warnings_Detected
- Warning_Info_Messages
;
251 if Total_Errors_Detected
/= 0 then
254 elsif Warnings_Treated_As_Errors
/= 0 then
257 -- We should never treat warnings that originate from a
258 -- Compile_Time_Warning pragma as an error. Warnings_Count is the sum
259 -- of both "normal" and Compile_Time_Warning warnings. This means that
260 -- there are only one or more non-Compile_Time_Warning warnings when
261 -- Warnings_Count is greater than Count_Compile_Time_Pragma_Warnings.
263 elsif Warning_Mode
= Treat_As_Error
264 and then Warnings_Count
> Count_Compile_Time_Pragma_Warnings
270 end Compilation_Errors
;
272 ----------------------------------------
273 -- Count_Compile_Time_Pragma_Warnings --
274 ----------------------------------------
276 function Count_Compile_Time_Pragma_Warnings
return Int
is
279 for J
in 1 .. Errors
.Last
loop
281 if Errors
.Table
(J
).Warn
282 and then Errors
.Table
(J
).Compile_Time_Pragma
283 and then not Errors
.Table
(J
).Deleted
285 Result
:= Result
+ 1;
290 end Count_Compile_Time_Pragma_Warnings
;
296 procedure Debug_Output
(N
: Node_Id
) is
299 Write_Str
("*** following error message posted on node id = #");
310 procedure dmsg
(Id
: Error_Msg_Id
) is
311 E
: Error_Msg_Object
renames Errors
.Table
(Id
);
314 w
("Dumping error message, Id = ", Int
(Id
));
315 w
(" Text = ", E
.Text
.all);
316 w
(" Next = ", Int
(E
.Next
));
317 w
(" Prev = ", Int
(E
.Prev
));
318 w
(" Sfile = ", Int
(E
.Sfile
));
322 Write_Location
(E
.Sptr
.Ptr
); -- ??? Do not write the full span for now
327 Write_Location
(E
.Optr
.Ptr
);
330 w
(" Line = ", Int
(E
.Line
));
331 w
(" Col = ", Int
(E
.Col
));
332 w
(" Warn = ", E
.Warn
);
333 w
(" Warn_Err = ", E
.Warn_Err
);
334 w
(" Warn_Runtime_Raise = ", E
.Warn_Runtime_Raise
);
335 w
(" Warn_Chr = '" & E
.Warn_Chr
& ''');
336 w
(" Style = ", E
.Style
);
337 w
(" Serious = ", E
.Serious
);
338 w
(" Uncond = ", E
.Uncond
);
339 w
(" Msg_Cont = ", E
.Msg_Cont
);
340 w
(" Deleted = ", E
.Deleted
);
341 w
(" Node = ", Int
(E
.Node
));
350 function Get_Location
(E
: Error_Msg_Id
) return Source_Ptr
is
352 return Errors
.Table
(E
).Sptr
.Ptr
;
359 function Get_Msg_Id
return Error_Msg_Id
is
364 ------------------------
365 -- Get_Warning_Option --
366 ------------------------
368 function Get_Warning_Option
(Id
: Error_Msg_Id
) return String is
369 Warn
: constant Boolean := Errors
.Table
(Id
).Warn
;
370 Style
: constant Boolean := Errors
.Table
(Id
).Style
;
371 Warn_Chr
: constant String (1 .. 2) := Errors
.Table
(Id
).Warn_Chr
;
375 and then Warn_Chr
/= " "
376 and then Warn_Chr
(1) /= '?'
378 if Warn_Chr
= "$ " then
381 return "-gnaty" & Warn_Chr
(1);
382 elsif Warn_Chr
(2) = ' ' then
383 return "-gnatw" & Warn_Chr
(1);
385 return "-gnatw" & Warn_Chr
;
390 end Get_Warning_Option
;
392 ---------------------
393 -- Get_Warning_Tag --
394 ---------------------
396 function Get_Warning_Tag
(Id
: Error_Msg_Id
) return String is
397 Warn
: constant Boolean := Errors
.Table
(Id
).Warn
;
398 Style
: constant Boolean := Errors
.Table
(Id
).Style
;
399 Warn_Chr
: constant String (1 .. 2) := Errors
.Table
(Id
).Warn_Chr
;
400 Option
: constant String := Get_Warning_Option
(Id
);
403 if Warn
or Style
then
404 if Warn_Chr
= "? " then
405 return "[enabled by default]";
406 elsif Warn_Chr
= "* " then
407 return "[restriction warning]";
408 elsif Option
/= "" then
409 return "[" & Option
& "]";
420 function Matches
(S
: String; P
: String) return Boolean is
421 Slast
: constant Natural := S
'Last;
422 PLast
: constant Natural := P
'Last;
424 SPtr
: Natural := S
'First;
425 PPtr
: Natural := P
'First;
428 -- Loop advancing through characters of string and pattern
433 -- Return True if pattern is a single asterisk
435 if PPtr
= PLast
and then P
(PPtr
) = '*' then
438 -- Return True if both pattern and string exhausted
440 elsif PPtr
> PLast
and then SPtr
> Slast
then
443 -- Return False, if one exhausted and not the other
445 elsif PPtr
> PLast
or else SPtr
> Slast
then
448 -- Case where pattern starts with asterisk
450 elsif P
(PPtr
) = '*' then
452 -- Try all possible starting positions in S for match with the
453 -- remaining characters of the pattern. This is the recursive
454 -- call that implements the scanner backup.
456 for J
in SPtr
.. Slast
loop
457 if Matches
(S
(J
.. Slast
), P
(PPtr
+ 1 .. PLast
)) then
464 -- Dealt with end of string and *, advance if we have a match
466 elsif Fold_Lower
(S
(SPtr
)) = Fold_Lower
(P
(PPtr
)) then
470 -- If first characters do not match, that's decisive
478 -----------------------
479 -- Output_Error_Msgs --
480 -----------------------
482 procedure Output_Error_Msgs
(E
: in out Error_Msg_Id
) is
488 Mult_Flags
: Boolean := False;
493 -- Skip deleted messages at start
495 if Errors
.Table
(S
).Deleted
then
496 Set_Next_Non_Deleted_Msg
(S
);
499 -- Figure out if we will place more than one error flag on this line
502 while T
/= No_Error_Msg
503 and then Errors
.Table
(T
).Line
= Errors
.Table
(E
).Line
504 and then Errors
.Table
(T
).Sfile
= Errors
.Table
(E
).Sfile
506 if Errors
.Table
(T
).Sptr
.Ptr
> Errors
.Table
(E
).Sptr
.Ptr
then
510 Set_Next_Non_Deleted_Msg
(T
);
513 -- Output the error flags. The circuit here makes sure that the tab
514 -- characters in the original line are properly accounted for. The
515 -- eight blanks at the start are to match the line number.
517 if not Debug_Flag_2
then
519 P
:= Line_Start
(Errors
.Table
(E
).Sptr
.Ptr
);
522 -- Loop through error messages for this line to place flags
525 while T
/= No_Error_Msg
526 and then Errors
.Table
(T
).Line
= Errors
.Table
(E
).Line
527 and then Errors
.Table
(T
).Sfile
= Errors
.Table
(E
).Sfile
530 Src
: Source_Buffer_Ptr
531 renames Source_Text
(Errors
.Table
(T
).Sfile
);
534 -- Loop to output blanks till current flag position
536 while P
< Errors
.Table
(T
).Sptr
.Ptr
loop
538 -- Horizontal tab case, just echo the tab
540 if Src
(P
) = ASCII
.HT
then
541 Write_Char
(ASCII
.HT
);
544 -- Deal with wide character case, but don't include brackets
545 -- notation in this circuit, since we know that this will
546 -- display unencoded (no one encodes brackets notation).
549 and then Is_Start_Of_Wide_Char
(Src
, P
)
554 -- Normal non-wide character case (or bracket)
562 -- Output flag (unless already output, this happens if more
563 -- than one error message occurs at the same flag position).
565 if P
= Errors
.Table
(T
).Sptr
.Ptr
then
566 if (Flag_Num
= 1 and then not Mult_Flags
)
572 (Character'Val (Character'Pos ('0') + Flag_Num
));
575 -- Skip past the corresponding source text character
577 -- Horizontal tab case, we output a flag at the tab position
578 -- so now we output a tab to match up with the text.
580 if Src
(P
) = ASCII
.HT
then
581 Write_Char
(ASCII
.HT
);
584 -- Skip wide character other than left bracket
587 and then Is_Start_Of_Wide_Char
(Src
, P
)
591 -- Skip normal non-wide character case (or bracket)
599 Set_Next_Non_Deleted_Msg
(T
);
600 Flag_Num
:= Flag_Num
+ 1;
606 -- Now output the error messages
609 while T
/= No_Error_Msg
610 and then Errors
.Table
(T
).Line
= Errors
.Table
(E
).Line
611 and then Errors
.Table
(T
).Sfile
= Errors
.Table
(E
).Sfile
617 while Column
< 74 loop
625 Set_Next_Non_Deleted_Msg
(T
);
629 end Output_Error_Msgs
;
631 ------------------------
632 -- Output_Line_Number --
633 ------------------------
635 procedure Output_Line_Number
(L
: Logical_Line_Number
) is
636 D
: Int
; -- next digit
637 C
: Character; -- next character
638 Z
: Boolean; -- flag for zero suppress
639 N
, M
: Int
; -- temporaries
642 if L
= No_Line_Number
then
663 C
:= Character'Val (D
+ 48);
671 end Output_Line_Number
;
673 ---------------------
674 -- Output_Msg_Text --
675 ---------------------
677 procedure Output_Msg_Text
(E
: Error_Msg_Id
) is
678 Offs
: constant Nat
:= Column
- 1;
679 -- Offset to start of message, used for continuations
682 -- Maximum characters to output on next line
685 -- Maximum total length of lines
687 E_Msg
: Error_Msg_Object
renames Errors
.Table
(E
);
688 Text
: constant String_Ptr
:= E_Msg
.Text
;
692 Tag
: constant String := Get_Warning_Tag
(E
);
697 -- Postfix warning tag to message if needed
699 if Tag
/= "" and then Warning_Doc_Switch
then
700 if Include_Subprogram_In_Messages
then
703 (Subprogram_Name_Ptr (E_Msg.Node) &
704 ": " & Text.all & ' ' & Tag);
706 Txt := new String'(Text
.all & ' ' & Tag
);
709 elsif Include_Subprogram_In_Messages
710 and then (E_Msg
.Warn
or else E_Msg
.Style
)
713 new String'(Subprogram_Name_Ptr (E_Msg.Node) & ": " & Text.all);
718 -- If -gnatdF is used, continuation messages follow the main message
719 -- with only an indentation of two space characters, without repeating
722 if Debug_Flag_FF and then E_Msg.Msg_Cont then
725 -- For info messages, prefix message with "info: "
727 elsif E_Msg.Info then
728 Txt := new String'(SGR_Note
& "info: " & SGR_Reset
& Txt
.all);
730 -- Warning treated as error
732 elsif E_Msg
.Warn_Err
then
734 -- We prefix with "error:" rather than warning: and postfix
735 -- [warning-as-error] at the end.
737 Warnings_Treated_As_Errors
:= Warnings_Treated_As_Errors
+ 1;
738 Txt
:= new String'(SGR_Error & "error: " & SGR_Reset
739 & Txt.all & " [warning-as-error]");
741 -- Normal warning, prefix with "warning: "
743 elsif E_Msg.Warn then
744 Txt := new String'(SGR_Warning
& "warning: " & SGR_Reset
& Txt
.all);
746 -- No prefix needed for style message, "(style)" is there already,
747 -- although not necessarily in first position if -gnatdJ is used.
749 elsif E_Msg
.Style
then
750 if Txt
(Txt
'First .. Txt
'First + 6) = "(style)" then
751 Txt
:= new String'(SGR_Warning & "(style)" & SGR_Reset
752 & Txt (Txt'First + 7 .. Txt'Last));
755 -- No prefix needed for check message, severity is there already
757 elsif E_Msg.Check then
759 -- The message format is "severity: ..."
761 -- Enclose the severity with an SGR control string if requested
763 if Use_SGR_Control then
765 Msg : String renames Text.all;
766 Colon : Natural := 0;
770 for J in Msg'Range loop
771 if Msg (J) = ':' then
777 pragma Assert (Colon > 0);
779 Txt := new String'(SGR_Error
780 & Msg
(Msg
'First .. Colon
)
782 & Msg
(Colon
+ 1 .. Msg
'Last));
786 -- All other cases, add "error: " if unique error tag set
788 elsif Opt
.Unique_Error_Tag
then
789 Txt
:= new String'(SGR_Error & "error: " & SGR_Reset & Txt.all);
792 -- Set error message line length and length of message
794 if Error_Msg_Line_Length = 0 then
797 Length := Error_Msg_Line_Length;
800 Max := Integer (Length - Column + 1);
803 -- Here we have to split the message up into multiple lines
807 -- Make sure we do not have ludicrously small line
809 Max := Integer'Max (Max, 20);
811 -- If remaining text fits, output it respecting LF and we are done
813 if Len - Ptr < Max then
814 for J in Ptr .. Len loop
815 if Txt (J) = ASCII.LF then
819 Write_Char (Txt (J));
830 -- First scan forward looking for a hard end of line
832 for Scan in Ptr .. Ptr + Max - 1 loop
833 if Txt (Scan) = ASCII.LF then
840 -- Otherwise scan backwards looking for a space
842 for Scan in reverse Ptr .. Ptr + Max - 1 loop
843 if Txt (Scan) = ' ' then
850 -- If we fall through, no space, so split line arbitrarily
852 Split := Ptr + Max - 1;
857 if Start <= Split then
858 Write_Line (Txt (Start .. Split));
862 Max := Integer (Length - Column + 1);
866 ---------------------
867 -- Prescan_Message --
868 ---------------------
870 procedure Prescan_Message (Msg : String) is
873 function Parse_Message_Class return String;
874 -- Convert the warning insertion sequence to a warning class represented
875 -- as a length-two string padded, if necessary, with spaces.
876 -- Return the Message class and set the iterator J to the character
877 -- following the sequence.
878 -- Raise a Program_Error if the insertion sequence is not valid.
880 -------------------------
881 -- Parse_Message_Class --
882 -------------------------
884 function Parse_Message_Class return String is
885 C : constant Character := Msg (J - 1);
886 Message_Class : String (1 .. 2) := " ";
888 if J <= Msg'Last and then Msg (J) = C then
889 Message_Class := "? ";
892 elsif J < Msg'Last and then Msg (J + 1) = C
893 and then Msg (J) in 'a
' .. 'z
' | 'A
' .. 'Z
' | '0' .. '9' | '*' | '$
'
895 Message_Class := Msg (J) & " ";
898 elsif J + 1 < Msg'Last and then Msg (J + 2) = C
899 and then Msg (J) in '.' | '_
'
900 and then Msg (J + 1) in 'a
' .. 'z
'
902 Message_Class := Msg (J .. J + 1);
904 elsif (J < Msg'Last and then Msg (J + 1) = C) or else
905 (J + 1 < Msg'Last and then Msg (J + 2) = C)
910 -- In any other cases, this is not a warning insertion sequence
911 -- and the default " " value is returned.
913 return Message_Class;
914 end Parse_Message_Class;
916 -- Start of processing for Prescan_Message
919 -- Nothing to do for continuation line, unless -gnatdF is set
921 if not Debug_Flag_FF and then Msg (Msg'First) = '\
' then
924 -- Some global variables are not set for continuation messages, as they
925 -- only make sense for the initial message.
927 elsif Msg (Msg'First) /= '\
' then
929 -- Set initial values of globals (may be changed during scan)
931 Is_Serious_Error := True;
932 Is_Unconditional_Msg := False;
933 Is_Warning_Msg := False;
934 Is_Runtime_Raise := False;
936 -- Check style message
940 and then Msg (Msg'First .. Msg'First + 6) = "(style)";
942 -- Check info message
946 and then Msg (Msg'First .. Msg'First + 5) = "info: ";
948 -- Check check message
952 and then Msg (Msg'First .. Msg'First + 7) = "medium: ")
955 and then Msg (Msg'First .. Msg'First + 5) = "high: ")
958 and then Msg (Msg'First .. Msg'First + 4) = "low: ");
961 Has_Double_Exclam := False;
962 Has_Error_Code := False;
963 Has_Insertion_Line := False;
965 -- Loop through message looking for relevant insertion sequences
968 while J <= Msg'Last loop
970 -- If we have a quote, don't look at following character
972 if Msg (J) = ''' then
975 -- Warning message (? or < insertion sequence)
977 elsif Msg (J) = '?
' or else Msg (J) = '<' then
978 if Msg (J) = '?
' or else Error_Msg_Warn then
979 Is_Warning_Msg := not Is_Style_Msg;
981 Warning_Msg_Char := Parse_Message_Class;
983 -- Bomb if untagged warning message. This code can be
984 -- uncommented for debugging when looking for untagged warning
987 -- pragma Assert (Warning_Msg_Char /= " ");
993 -- Unconditional message (! insertion)
995 elsif Msg (J) = '!' then
996 Is_Unconditional_Msg := True;
999 if J <= Msg'Last and then Msg (J) = '!' then
1000 Has_Double_Exclam := True;
1004 -- Insertion line (# insertion)
1006 elsif Msg (J) = '#
' then
1007 Has_Insertion_Line := True;
1010 -- Non-serious error (| insertion)
1012 elsif Msg (J) = '|
' then
1013 Is_Serious_Error := False;
1016 -- Error code ([] insertion)
1019 and then J < Msg'Last
1020 and then Msg (J + 1) = ']'
1022 Has_Error_Code := True;
1030 if Is_Info_Msg or Is_Warning_Msg or Is_Style_Msg or Is_Check_Msg then
1031 Is_Serious_Error := False;
1033 end Prescan_Message;
1035 --------------------
1036 -- Purge_Messages --
1037 --------------------
1039 procedure Purge_Messages (From : Source_Ptr; To : Source_Ptr) is
1042 function To_Be_Purged (E : Error_Msg_Id) return Boolean;
1043 -- Returns True for a message that is to be purged. Also adjusts
1044 -- error counts appropriately.
1050 function To_Be_Purged (E : Error_Msg_Id) return Boolean is
1052 if E /= No_Error_Msg
1053 and then Errors.Table (E).Sptr.Ptr > From
1054 and then Errors.Table (E).Sptr.Ptr < To
1056 if Errors.Table (E).Warn or else Errors.Table (E).Style then
1057 Warnings_Detected := Warnings_Detected - 1;
1060 Total_Errors_Detected := Total_Errors_Detected - 1;
1062 if Errors.Table (E).Serious then
1063 Serious_Errors_Detected := Serious_Errors_Detected - 1;
1074 -- Start of processing for Purge_Messages
1077 while To_Be_Purged (First_Error_Msg) loop
1078 First_Error_Msg := Errors.Table (First_Error_Msg).Next;
1081 E := First_Error_Msg;
1082 while E /= No_Error_Msg loop
1083 while To_Be_Purged (Errors.Table (E).Next) loop
1084 Errors.Table (E).Next :=
1085 Errors.Table (Errors.Table (E).Next).Next;
1088 E := Errors.Table (E).Next;
1096 function Same_Error (M1, M2 : Error_Msg_Id) return Boolean is
1097 Msg1 : constant String_Ptr := Errors.Table (M1).Text;
1098 Msg2 : constant String_Ptr := Errors.Table (M2).Text;
1100 Msg2_Len : constant Integer := Msg2'Length;
1101 Msg1_Len : constant Integer := Msg1'Length;
1107 (Msg1_Len - 10 > Msg2_Len
1109 Msg2.all = Msg1.all (1 .. Msg2_Len)
1111 Msg1 (Msg2_Len + 1 .. Msg2_Len + 10) = ", instance")
1113 (Msg2_Len - 10 > Msg1_Len
1115 Msg1.all = Msg2.all (1 .. Msg1_Len)
1117 Msg2 (Msg1_Len + 1 .. Msg1_Len + 10) = ", instance");
1124 procedure Set_Msg_Blank is
1127 and then Msg_Buffer (Msglen) /= ' '
1128 and then Msg_Buffer (Msglen) /= '('
1129 and then Msg_Buffer (Msglen) /= '-'
1130 and then not Manual_Quote_Mode
1136 -------------------------------
1137 -- Set_Msg_Blank_Conditional --
1138 -------------------------------
1140 procedure Set_Msg_Blank_Conditional is
1143 and then Msg_Buffer (Msglen) /= ' '
1144 and then Msg_Buffer (Msglen) /= '('
1145 and then Msg_Buffer (Msglen) /= '"'
1146 and then not Manual_Quote_Mode
1150 end Set_Msg_Blank_Conditional;
1156 procedure Set_Msg_Char (C : Character) is
1159 -- The check for message buffer overflow is needed to deal with cases
1160 -- where insertions get too long (in particular a child unit name can
1163 if Msglen < Max_Msg_Length then
1164 Msglen := Msglen + 1;
1165 Msg_Buffer (Msglen) := C;
1169 ----------------------------
1170 -- Set_Msg_Insertion_Code --
1171 ----------------------------
1173 procedure Set_Msg_Insertion_Code is
1174 H : constant array (Nat range 0 .. 9) of Character := "0123456789";
1175 P10 : constant array (Natural range 0 .. 3) of Nat :=
1181 Code_Len : constant Natural :=
1182 (case Error_Msg_Code is
1186 when 100 .. 999 => 3,
1187 when 1000 .. 9999 => 4);
1188 Code_Rest : Nat := Error_Msg_Code;
1194 for J in 1 .. Error_Msg_Code_Digits - Code_Len loop
1198 for J in 1 .. Code_Len loop
1199 Code_Digit := Code_Rest / P10 (Code_Len - J);
1200 Set_Msg_Char (H (Code_Digit));
1201 Code_Rest := Code_Rest - Code_Digit * P10 (Code_Len - J);
1203 end Set_Msg_Insertion_Code;
1205 ---------------------------------
1206 -- Set_Msg_Insertion_File_Name --
1207 ---------------------------------
1209 procedure Set_Msg_Insertion_File_Name is
1211 if Error_Msg_File_1 = No_File then
1214 elsif Error_Msg_File_1 = Error_File_Name then
1216 Set_Msg_Str ("<error
>");
1220 Get_Name_String (Error_Msg_File_1);
1222 Set_Msg_Name_Buffer;
1226 -- The following assignments ensure that the second and third {
1227 -- insertion characters will correspond to the Error_Msg_File_2
1228 -- and Error_Msg_File_3 values.
1230 Error_Msg_File_1 := Error_Msg_File_2;
1231 Error_Msg_File_2 := Error_Msg_File_3;
1232 end Set_Msg_Insertion_File_Name;
1234 -----------------------------------
1235 -- Set_Msg_Insertion_Line_Number --
1236 -----------------------------------
1238 procedure Set_Msg_Insertion_Line_Number (Loc, Flag : Source_Ptr) is
1239 Sindex_Loc : Source_File_Index;
1240 Sindex_Flag : Source_File_Index;
1241 Fname : File_Name_Type;
1245 -- Outputs "at " unless last characters in buffer are " from
". Certain
1246 -- messages read better with from than at.
1255 or else Msg_Buffer (Msglen - 5 .. Msglen) /= " from
"
1257 Set_Msg_Str ("at ");
1261 -- Start of processing for Set_Msg_Insertion_Line_Number
1266 if Loc = No_Location then
1268 Set_Msg_Str ("unknown location
");
1270 elsif Loc = System_Location then
1271 Set_Msg_Str ("in package System
");
1272 Set_Msg_Insertion_Run_Time_Name;
1274 elsif Loc = Standard_Location then
1275 Set_Msg_Str ("in package Standard
");
1277 elsif Loc = Standard_ASCII_Location then
1278 Set_Msg_Str ("in package Standard
.ASCII
");
1281 -- Add "at file
-name
:" if reference is to other than the source
1282 -- file in which the error message is placed. Note that we check
1283 -- full file names, rather than just the source indexes, to
1284 -- deal with generic instantiations from the current file.
1286 Sindex_Loc := Get_Source_File_Index (Loc);
1287 Sindex_Flag := Get_Source_File_Index (Flag);
1289 if Full_File_Name (Sindex_Loc) /= Full_File_Name (Sindex_Flag) then
1291 Fname := Reference_Name (Get_Source_File_Index (Loc));
1292 Int_File := Is_Internal_File_Name (Fname);
1293 Get_Name_String (Fname);
1294 Set_Msg_Name_Buffer;
1296 if not (Int_File and Debug_Flag_Dot_K) then
1298 Set_Msg_Int (Int (Get_Logical_Line_Number (Loc)));
1301 -- If in current file, add text "at line
"
1305 Set_Msg_Str ("line
");
1306 Set_Msg_Int (Int (Get_Logical_Line_Number (Loc)));
1309 -- Deal with the instantiation case. We may have a reference to,
1310 -- e.g. a type, that is declared within a generic template, and
1311 -- what we are really referring to is the occurrence in an instance.
1312 -- In this case, the line number of the instantiation is also of
1313 -- interest, and we add a notation:
1315 -- , instance at xxx
1317 -- where xxx is a line number output using this same routine (and
1318 -- the recursion can go further if the instantiation is itself in
1319 -- a generic template).
1321 -- The flag location passed to us in this situation is indeed the
1322 -- line number within the template, but as described in Sinput.L
1323 -- (file sinput-l.ads, section "Handling
Generic Instantiations
")
1324 -- we can retrieve the location of the instantiation itself from
1325 -- this flag location value.
1327 -- Note: this processing is suppressed if Suppress_Instance_Location
1328 -- is set True. This is used to prevent redundant annotations of the
1329 -- location of the instantiation in the case where we are placing
1330 -- the messages on the instantiation in any case.
1332 if Instantiation (Sindex_Loc) /= No_Location
1333 and then not Suppress_Instance_Location
1335 Set_Msg_Str (", instance
");
1336 Set_Msg_Insertion_Line_Number (Instantiation (Sindex_Loc), Flag);
1339 end Set_Msg_Insertion_Line_Number;
1341 ----------------------------
1342 -- Set_Msg_Insertion_Name --
1343 ----------------------------
1345 procedure Set_Msg_Insertion_Name is
1347 if Error_Msg_Name_1 = No_Name then
1350 elsif Error_Msg_Name_1 = Error_Name then
1352 Set_Msg_Str ("<error
>");
1355 Set_Msg_Blank_Conditional;
1356 Get_Unqualified_Decoded_Name_String (Error_Msg_Name_1);
1358 -- Remove %s or %b at end. These come from unit names. If the
1359 -- caller wanted the (unit) or (body), then they would have used
1360 -- the $ insertion character. Certainly no error message should
1361 -- ever have %b or %s explicitly occurring.
1364 and then Name_Buffer (Name_Len - 1) = '%'
1365 and then (Name_Buffer (Name_Len) = 'b'
1367 Name_Buffer (Name_Len) = 's')
1369 Name_Len := Name_Len - 2;
1372 -- Remove upper case letter at end, again, we should not be getting
1373 -- such names, and what we hope is that the remainder makes sense.
1375 if Name_Len > 1 and then Name_Buffer (Name_Len) in 'A' .. 'Z' then
1376 Name_Len := Name_Len - 1;
1379 -- If operator name or character literal name, just print it as is.
1380 -- Also print as is if it ends in a right paren (case of x'val(nnn)).
1382 if Name_Buffer (1) = '"'
1383 or else Name_Buffer (1) = '''
1384 or else Name_Buffer (Name_Len) = ')'
1386 Set_Msg_Name_Buffer;
1388 -- Else output with surrounding quotes in proper casing mode
1391 Set_Casing (Identifier_Casing (Flag_Source));
1393 Set_Msg_Name_Buffer;
1398 -- The following assignments ensure that other percent insertion
1399 -- characters will correspond to their appropriate Error_Msg_Name_#
1400 -- values as required.
1402 Error_Msg_Name_1 := Error_Msg_Name_2;
1403 Error_Msg_Name_2 := Error_Msg_Name_3;
1404 Error_Msg_Name_3 := Error_Msg_Name_4;
1405 Error_Msg_Name_4 := Error_Msg_Name_5;
1406 Error_Msg_Name_5 := Error_Msg_Name_6;
1407 end Set_Msg_Insertion_Name;
1409 ------------------------------------
1410 -- Set_Msg_Insertion_Name_Literal --
1411 ------------------------------------
1413 procedure Set_Msg_Insertion_Name_Literal is
1415 if Error_Msg_Name_1 = No_Name then
1418 elsif Error_Msg_Name_1 = Error_Name then
1420 Set_Msg_Str ("<error>");
1424 Get_Name_String (Error_Msg_Name_1);
1426 Set_Msg_Name_Buffer;
1430 -- The following assignments ensure that other percent insertion
1431 -- characters will correspond to their appropriate Error_Msg_Name_#
1432 -- values as required.
1434 Error_Msg_Name_1 := Error_Msg_Name_2;
1435 Error_Msg_Name_2 := Error_Msg_Name_3;
1436 Error_Msg_Name_3 := Error_Msg_Name_4;
1437 Error_Msg_Name_4 := Error_Msg_Name_5;
1438 Error_Msg_Name_5 := Error_Msg_Name_6;
1439 end Set_Msg_Insertion_Name_Literal;
1441 -------------------------------------
1442 -- Set_Msg_Insertion_Reserved_Name --
1443 -------------------------------------
1445 procedure Set_Msg_Insertion_Reserved_Name is
1447 Set_Msg_Blank_Conditional;
1448 Get_Name_String (Error_Msg_Name_1);
1450 Set_Casing (Keyword_Casing (Flag_Source), All_Lower_Case);
1451 Set_Msg_Name_Buffer;
1453 end Set_Msg_Insertion_Reserved_Name;
1455 -------------------------------------
1456 -- Set_Msg_Insertion_Reserved_Word --
1457 -------------------------------------
1459 procedure Set_Msg_Insertion_Reserved_Word
1464 Set_Msg_Blank_Conditional;
1467 while J <= Text'Last and then Text (J) in 'A
' .. 'Z
' loop
1468 Add_Char_To_Name_Buffer (Text (J));
1472 -- Here is where we make the special exception for RM
1474 if Name_Len = 2 and then Name_Buffer (1 .. 2) = "RM" then
1475 Set_Msg_Name_Buffer;
1477 -- We make a similar exception for SPARK
1479 elsif Name_Len = 5 and then Name_Buffer (1 .. 5) = "SPARK" then
1480 Set_Msg_Name_Buffer;
1482 -- Neither RM nor SPARK: case appropriately and add surrounding quotes
1485 Set_Casing (Keyword_Casing (Flag_Source), All_Lower_Case);
1487 Set_Msg_Name_Buffer;
1490 end Set_Msg_Insertion_Reserved_Word;
1492 -------------------------------------
1493 -- Set_Msg_Insertion_Run_Time_Name --
1494 -------------------------------------
1496 procedure Set_Msg_Insertion_Run_Time_Name is
1498 if Targparm.Run_Time_Name_On_Target /= No_Name then
1499 Set_Msg_Blank_Conditional;
1501 Get_Name_String (Targparm.Run_Time_Name_On_Target);
1502 Set_Casing (Mixed_Case);
1503 Set_Msg_Str (Name_Buffer (1 .. Name_Len));
1506 end Set_Msg_Insertion_Run_Time_Name;
1508 ----------------------------
1509 -- Set_Msg_Insertion_Uint --
1510 ----------------------------
1512 procedure Set_Msg_Insertion_Uint is
1515 UI_Image (Error_Msg_Uint_1);
1517 for J in 1 .. UI_Image_Length loop
1518 Set_Msg_Char (UI_Image_Buffer (J));
1521 -- The following assignment ensures that a second caret insertion
1522 -- character will correspond to the Error_Msg_Uint_2 parameter.
1524 Error_Msg_Uint_1 := Error_Msg_Uint_2;
1525 end Set_Msg_Insertion_Uint;
1531 procedure Set_Msg_Int (Line : Int) is
1534 Set_Msg_Int (Line / 10);
1537 Set_Msg_Char (Character'Val (Character'Pos ('0') + (Line rem 10)));
1540 -------------------------
1541 -- Set_Msg_Name_Buffer --
1542 -------------------------
1544 procedure Set_Msg_Name_Buffer is
1546 Set_Msg_Str (Name_Buffer (1 .. Name_Len));
1547 Destroy_Global_Name_Buffer;
1548 end Set_Msg_Name_Buffer;
1554 procedure Set_Msg_Quote is
1556 if not Manual_Quote_Mode then
1565 procedure Set_Msg_Str (Text : String) is
1567 -- Do replacement for special x'Class aspect names
1569 if Text = "_Pre
" then
1570 Set_Msg_Str ("Pre
'Class");
1572 elsif Text = "_Post
" then
1573 Set_Msg_Str ("Post
'Class");
1575 elsif Text = "_Type_Invariant
" then
1576 Set_Msg_Str ("Type_Invariant
'Class");
1578 elsif Text = "_pre
" then
1579 Set_Msg_Str ("pre
'class");
1581 elsif Text = "_post
" then
1582 Set_Msg_Str ("post
'class");
1584 elsif Text = "_type_invariant
" then
1585 Set_Msg_Str ("type_invariant
'class");
1587 elsif Text = "_PRE
" then
1588 Set_Msg_Str ("PRE
'CLASS");
1590 elsif Text = "_POST
" then
1591 Set_Msg_Str ("POST
'CLASS");
1593 elsif Text = "_TYPE_INVARIANT
" then
1594 Set_Msg_Str ("TYPE_INVARIANT
'CLASS");
1596 -- Preserve casing for names that include acronyms
1598 elsif Text = "Cpp_Class
" then
1599 Set_Msg_Str ("CPP_Class
");
1601 elsif Text = "Cpp_Constructor
" then
1602 Set_Msg_Str ("CPP_Constructor
");
1604 elsif Text = "Cpp_Virtual
" then
1605 Set_Msg_Str ("CPP_Virtual
");
1607 elsif Text = "Cpp_Vtable
" then
1608 Set_Msg_Str ("CPP_Vtable
");
1610 elsif Text = "Persistent_Bss
" then
1611 Set_Msg_Str ("Persistent_BSS
");
1613 elsif Text = "Spark_Mode
" then
1614 Set_Msg_Str ("SPARK_Mode
");
1616 elsif Text = "Use_Vads_Size
" then
1617 Set_Msg_Str ("Use_VADS_Size
");
1619 elsif Text = "Vads_Size
" then
1620 Set_Msg_Str ("VADS_size
");
1622 -- Normal case with no replacement
1625 for J in Text'Range loop
1626 Set_Msg_Char (Text (J));
1631 ------------------------------
1632 -- Set_Next_Non_Deleted_Msg --
1633 ------------------------------
1635 procedure Set_Next_Non_Deleted_Msg (E : in out Error_Msg_Id) is
1637 if E = No_Error_Msg then
1642 E := Errors.Table (E).Next;
1643 exit when E = No_Error_Msg or else not Errors.Table (E).Deleted;
1646 end Set_Next_Non_Deleted_Msg;
1648 ------------------------------
1649 -- Set_Specific_Warning_Off --
1650 ------------------------------
1652 procedure Set_Specific_Warning_Off
1657 Used : Boolean := False)
1660 Specific_Warnings.Append
1662 Msg => new String'(Msg),
1663 Stop => Source_Last (Get_Source_File_Index (Loc)),
1668 end Set_Specific_Warning_Off;
1670 -----------------------------
1671 -- Set_Specific_Warning_On --
1672 -----------------------------
1674 procedure Set_Specific_Warning_On
1680 for J in 1 .. Specific_Warnings.Last loop
1682 SWE : Specific_Warning_Entry renames Specific_Warnings.Table (J);
1685 if Msg = SWE.Msg.all
1686 and then Loc > SWE.Start
1688 and then Get_Source_File_Index (SWE.Start) =
1689 Get_Source_File_Index (Loc)
1695 -- If a config pragma is specifically cancelled, consider
1696 -- that it is no longer active as a configuration pragma.
1698 SWE.Config := False;
1705 end Set_Specific_Warning_On;
1707 ---------------------------
1708 -- Set_Warnings_Mode_Off --
1709 ---------------------------
1711 procedure Set_Warnings_Mode_Off (Loc : Source_Ptr; Reason : String_Id) is
1713 -- Don't bother with entries from instantiation copies, since we will
1714 -- already have a copy in the template, which is what matters.
1716 if Instantiation (Get_Source_File_Index (Loc)) /= No_Location then
1720 -- If all warnings are suppressed by command line switch, this can
1721 -- be ignored, unless we are in GNATprove_Mode which requires pragma
1722 -- Warnings to be stored for the formal verification backend.
1724 if Warning_Mode = Suppress
1725 and then not GNATprove_Mode
1730 -- If last entry in table already covers us, this is a redundant pragma
1731 -- Warnings (Off) and can be ignored.
1733 if Warnings.Last >= Warnings.First
1734 and then Warnings.Table (Warnings.Last).Start <= Loc
1735 and then Loc <= Warnings.Table (Warnings.Last).Stop
1740 -- If none of those special conditions holds, establish a new entry,
1741 -- extending from the location of the pragma to the end of the current
1742 -- source file. This ending point will be adjusted by a subsequent
1743 -- corresponding pragma Warnings (On).
1747 Stop => Source_Last (Get_Source_File_Index (Loc)),
1749 end Set_Warnings_Mode_Off;
1751 --------------------------
1752 -- Set_Warnings_Mode_On --
1753 --------------------------
1755 procedure Set_Warnings_Mode_On (Loc : Source_Ptr) is
1757 -- Don't bother with entries from instantiation copies, since we will
1758 -- already have a copy in the template, which is what matters.
1760 if Instantiation (Get_Source_File_Index (Loc)) /= No_Location then
1764 -- If all warnings are suppressed by command line switch, this can
1765 -- be ignored, unless we are in GNATprove_Mode which requires pragma
1766 -- Warnings to be stored for the formal verification backend.
1768 if Warning_Mode = Suppress
1769 and then not GNATprove_Mode
1774 -- If the last entry in the warnings table covers this pragma, then
1775 -- we adjust the end point appropriately.
1777 if Warnings.Last >= Warnings.First
1778 and then Warnings.Table (Warnings.Last).Start <= Loc
1779 and then Loc <= Warnings.Table (Warnings.Last).Stop
1781 Warnings.Table (Warnings.Last).Stop := Loc;
1783 end Set_Warnings_Mode_On;
1789 function Sloc_In_Range (Loc, Start, Stop : Source_Ptr) return Boolean is
1790 Cur_Loc : Source_Ptr := Loc;
1793 while Cur_Loc /= No_Location loop
1794 if Start <= Cur_Loc and then Cur_Loc <= Stop then
1798 Cur_Loc := Instantiation_Location (Cur_Loc);
1804 --------------------------------
1805 -- Validate_Specific_Warnings --
1806 --------------------------------
1808 procedure Validate_Specific_Warnings (Eproc : Error_Msg_Proc) is
1810 if not Warn_On_Warnings_Off then
1814 for J in Specific_Warnings.First .. Specific_Warnings.Last loop
1816 SWE : Specific_Warning_Entry renames Specific_Warnings.Table (J);
1819 if not SWE.Config then
1821 -- Warn for unmatched Warnings (Off, ...)
1825 ("?
.w?
pragma Warnings Off
with no matching Warnings On
",
1828 -- Warn for ineffective Warnings (Off, ..)
1832 -- Do not issue this warning for -Wxxx messages since the
1833 -- back-end doesn't report the information. Note that there
1834 -- is always an asterisk at the start of every message.
1837 (SWE.Msg'Length > 3 and then SWE.Msg (2 .. 3) = "-W
")
1840 ("?
.w?no warning suppressed by this
pragma", SWE.Start);
1845 end Validate_Specific_Warnings;
1847 -------------------------------------
1848 -- Warning_Specifically_Suppressed --
1849 -------------------------------------
1851 function Warning_Specifically_Suppressed
1854 Tag : String := "") return String_Id
1857 -- Loop through specific warning suppression entries
1859 for J in Specific_Warnings.First .. Specific_Warnings.Last loop
1861 SWE : Specific_Warning_Entry renames Specific_Warnings.Table (J);
1864 -- Pragma applies if it is a configuration pragma, or if the
1865 -- location is in range of a specific non-configuration pragma.
1868 or else Sloc_In_Range (Loc, SWE.Start, SWE.Stop)
1870 if Matches (Msg.all, SWE.Msg.all)
1871 or else Matches (Tag, SWE.Msg.all)
1881 end Warning_Specifically_Suppressed;
1883 ------------------------------
1884 -- Warning_Treated_As_Error --
1885 ------------------------------
1887 function Warning_Treated_As_Error (Msg : String) return Boolean is
1889 for J in 1 .. Warnings_As_Errors_Count loop
1890 if Matches (Msg, Warnings_As_Errors (J).all) then
1896 end Warning_Treated_As_Error;
1898 -------------------------
1899 -- Warnings_Suppressed --
1900 -------------------------
1902 function Warnings_Suppressed (Loc : Source_Ptr) return String_Id is
1904 -- Loop through table of ON/OFF warnings
1906 for J in Warnings.First .. Warnings.Last loop
1907 if Sloc_In_Range (Loc, Warnings.Table (J).Start,
1908 Warnings.Table (J).Stop)
1910 return Warnings.Table (J).Reason;
1914 if Warning_Mode = Suppress then
1915 return Null_String_Id;
1919 end Warnings_Suppressed;