1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2022, 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
;
48 package body Erroutc
is
50 -----------------------
51 -- Local Subprograms --
52 -----------------------
54 function Sloc_In_Range
(Loc
, Start
, Stop
: Source_Ptr
) return Boolean;
55 -- Return whether Loc is in the range Start .. Stop, taking instantiation
56 -- locations of Loc into account. This is useful for suppressing warnings
57 -- from generic instantiations by using pragma Warnings around generic
58 -- instances, as needed in GNATprove.
64 procedure Add_Class
is
69 Get_Name_String
(Name_Class
);
70 Set_Casing
(Identifier_Casing
(Flag_Source
));
75 ----------------------
76 -- Buffer_Ends_With --
77 ----------------------
79 function Buffer_Ends_With
(C
: Character) return Boolean is
81 return Msglen
> 0 and then Msg_Buffer
(Msglen
) = C
;
84 function Buffer_Ends_With
(S
: String) return Boolean is
85 Len
: constant Natural := S
'Length;
88 and then Msg_Buffer
(Msglen
- Len
) = ' '
89 and then Msg_Buffer
(Msglen
- Len
+ 1 .. Msglen
) = S
;
96 procedure Buffer_Remove
(C
: Character) is
98 if Buffer_Ends_With
(C
) then
103 procedure Buffer_Remove
(S
: String) is
105 if Buffer_Ends_With
(S
) then
106 Msglen
:= Msglen
- S
'Length;
110 -----------------------------
111 -- Check_Duplicate_Message --
112 -----------------------------
114 procedure Check_Duplicate_Message
(M1
, M2
: Error_Msg_Id
) is
115 L1
, L2
: Error_Msg_Id
;
116 N1
, N2
: Error_Msg_Id
;
118 procedure Delete_Msg
(Delete
, Keep
: Error_Msg_Id
);
119 -- Called to delete message Delete, keeping message Keep. Marks msg
120 -- Delete and all its continuations with deleted flag set to True.
121 -- Also makes sure that for the error messages that are retained the
122 -- preferred message is the one retained (we prefer the shorter one in
123 -- the case where one has an Instance tag). Note that we always know
124 -- that Keep has at least as many continuations as Delete (since we
125 -- always delete the shorter sequence).
131 procedure Delete_Msg
(Delete
, Keep
: Error_Msg_Id
) is
139 Errors
.Table
(D
).Deleted
:= True;
141 -- Adjust error message count
143 if Errors
.Table
(D
).Info
then
145 if Errors
.Table
(D
).Warn
then
146 Warning_Info_Messages
:= Warning_Info_Messages
- 1;
147 Warnings_Detected
:= Warnings_Detected
- 1;
149 Report_Info_Messages
:= Report_Info_Messages
- 1;
152 elsif Errors
.Table
(D
).Warn
or else Errors
.Table
(D
).Style
then
153 Warnings_Detected
:= Warnings_Detected
- 1;
155 -- Note: we do not need to decrement Warnings_Treated_As_Errors
156 -- because this only gets incremented if we actually output the
157 -- message, which we won't do if we are deleting it here!
159 elsif Errors
.Table
(D
).Check
then
160 Check_Messages
:= Check_Messages
- 1;
163 Total_Errors_Detected
:= Total_Errors_Detected
- 1;
165 if Errors
.Table
(D
).Serious
then
166 Serious_Errors_Detected
:= Serious_Errors_Detected
- 1;
170 -- Substitute shorter of the two error messages
172 if Errors
.Table
(K
).Text
'Length > Errors
.Table
(D
).Text
'Length then
173 Errors
.Table
(K
).Text
:= Errors
.Table
(D
).Text
;
176 D
:= Errors
.Table
(D
).Next
;
177 K
:= Errors
.Table
(K
).Next
;
179 if D
= No_Error_Msg
or else not Errors
.Table
(D
).Msg_Cont
then
185 -- Start of processing for Check_Duplicate_Message
188 -- Both messages must be non-continuation messages and not deleted
190 if Errors
.Table
(M1
).Msg_Cont
191 or else Errors
.Table
(M2
).Msg_Cont
192 or else Errors
.Table
(M1
).Deleted
193 or else Errors
.Table
(M2
).Deleted
198 -- Definitely not equal if message text does not match
200 if not Same_Error
(M1
, M2
) then
204 -- Same text. See if all continuations are also identical
210 N1
:= Errors
.Table
(L1
).Next
;
211 N2
:= Errors
.Table
(L2
).Next
;
213 -- If M1 continuations have run out, we delete M1, either the
214 -- messages have the same number of continuations, or M2 has
215 -- more and we prefer the one with more anyway.
217 if N1
= No_Error_Msg
or else not Errors
.Table
(N1
).Msg_Cont
then
221 -- If M2 continuations have run out, we delete M2
223 elsif N2
= No_Error_Msg
or else not Errors
.Table
(N2
).Msg_Cont
then
227 -- Otherwise see if continuations are the same, if not, keep both
228 -- sequences, a curious case, but better to keep everything.
230 elsif not Same_Error
(N1
, N2
) then
233 -- If continuations are the same, continue scan
240 end Check_Duplicate_Message
;
242 ------------------------
243 -- Compilation_Errors --
244 ------------------------
246 function Compilation_Errors
return Boolean is
247 Warnings_Count
: constant Int
248 := Warnings_Detected
- Warning_Info_Messages
;
250 if Total_Errors_Detected
/= 0 then
253 elsif Warnings_Treated_As_Errors
/= 0 then
256 -- We should never treat warnings that originate from a
257 -- Compile_Time_Warning pragma as an error. Warnings_Count is the sum
258 -- of both "normal" and Compile_Time_Warning warnings. This means that
259 -- there are only one or more non-Compile_Time_Warning warnings when
260 -- Warnings_Count is greater than Count_Compile_Time_Pragma_Warnings.
262 elsif Warning_Mode
= Treat_As_Error
263 and then Warnings_Count
> Count_Compile_Time_Pragma_Warnings
269 end Compilation_Errors
;
271 ----------------------------------------
272 -- Count_Compile_Time_Pragma_Warnings --
273 ----------------------------------------
275 function Count_Compile_Time_Pragma_Warnings
return Int
is
278 for J
in 1 .. Errors
.Last
loop
280 if Errors
.Table
(J
).Warn
281 and then Errors
.Table
(J
).Compile_Time_Pragma
282 and then not Errors
.Table
(J
).Deleted
284 Result
:= Result
+ 1;
289 end Count_Compile_Time_Pragma_Warnings
;
295 procedure Debug_Output
(N
: Node_Id
) is
298 Write_Str
("*** following error message posted on node id = #");
309 procedure dmsg
(Id
: Error_Msg_Id
) is
310 E
: Error_Msg_Object
renames Errors
.Table
(Id
);
313 w
("Dumping error message, Id = ", Int
(Id
));
314 w
(" Text = ", E
.Text
.all);
315 w
(" Next = ", Int
(E
.Next
));
316 w
(" Prev = ", Int
(E
.Prev
));
317 w
(" Sfile = ", Int
(E
.Sfile
));
321 Write_Location
(E
.Sptr
.Ptr
); -- ??? Do not write the full span for now
326 Write_Location
(E
.Optr
);
329 w
(" Line = ", Int
(E
.Line
));
330 w
(" Col = ", Int
(E
.Col
));
331 w
(" Warn = ", E
.Warn
);
332 w
(" Warn_Err = ", E
.Warn_Err
);
333 w
(" Warn_Chr = '" & E
.Warn_Chr
& ''');
334 w
(" Style = ", E
.Style
);
335 w
(" Serious = ", E
.Serious
);
336 w
(" Uncond = ", E
.Uncond
);
337 w
(" Msg_Cont = ", E
.Msg_Cont
);
338 w
(" Deleted = ", E
.Deleted
);
339 w
(" Node = ", Int
(E
.Node
));
348 function Get_Location
(E
: Error_Msg_Id
) return Source_Ptr
is
350 return Errors
.Table
(E
).Sptr
.Ptr
;
357 function Get_Msg_Id
return Error_Msg_Id
is
362 ------------------------
363 -- Get_Warning_Option --
364 ------------------------
366 function Get_Warning_Option
(Id
: Error_Msg_Id
) return String is
367 Warn
: constant Boolean := Errors
.Table
(Id
).Warn
;
368 Warn_Chr
: constant String (1 .. 2) := Errors
.Table
(Id
).Warn_Chr
;
370 if Warn
and then Warn_Chr
/= " " and then Warn_Chr
(1) /= '?' then
371 if Warn_Chr
= "$ " then
373 elsif Warn_Chr
(2) = ' ' then
374 return "-gnatw" & Warn_Chr
(1);
376 return "-gnatw" & Warn_Chr
;
380 end Get_Warning_Option
;
382 ---------------------
383 -- Get_Warning_Tag --
384 ---------------------
386 function Get_Warning_Tag
(Id
: Error_Msg_Id
) return String is
387 Warn
: constant Boolean := Errors
.Table
(Id
).Warn
;
388 Warn_Chr
: constant String (1 .. 2) := Errors
.Table
(Id
).Warn_Chr
;
389 Option
: constant String := Get_Warning_Option
(Id
);
392 if Warn_Chr
= "? " then
393 return "[enabled by default]";
394 elsif Warn_Chr
= "* " then
395 return "[restriction warning]";
396 elsif Option
/= "" then
397 return "[" & Option
& "]";
408 function Matches
(S
: String; P
: String) return Boolean is
409 Slast
: constant Natural := S
'Last;
410 PLast
: constant Natural := P
'Last;
412 SPtr
: Natural := S
'First;
413 PPtr
: Natural := P
'First;
416 -- Loop advancing through characters of string and pattern
421 -- Return True if pattern is a single asterisk
423 if PPtr
= PLast
and then P
(PPtr
) = '*' then
426 -- Return True if both pattern and string exhausted
428 elsif PPtr
> PLast
and then SPtr
> Slast
then
431 -- Return False, if one exhausted and not the other
433 elsif PPtr
> PLast
or else SPtr
> Slast
then
436 -- Case where pattern starts with asterisk
438 elsif P
(PPtr
) = '*' then
440 -- Try all possible starting positions in S for match with the
441 -- remaining characters of the pattern. This is the recursive
442 -- call that implements the scanner backup.
444 for J
in SPtr
.. Slast
loop
445 if Matches
(S
(J
.. Slast
), P
(PPtr
+ 1 .. PLast
)) then
452 -- Dealt with end of string and *, advance if we have a match
454 elsif Fold_Lower
(S
(SPtr
)) = Fold_Lower
(P
(PPtr
)) then
458 -- If first characters do not match, that's decisive
466 -----------------------
467 -- Output_Error_Msgs --
468 -----------------------
470 procedure Output_Error_Msgs
(E
: in out Error_Msg_Id
) is
476 Mult_Flags
: Boolean := False;
481 -- Skip deleted messages at start
483 if Errors
.Table
(S
).Deleted
then
484 Set_Next_Non_Deleted_Msg
(S
);
487 -- Figure out if we will place more than one error flag on this line
490 while T
/= No_Error_Msg
491 and then Errors
.Table
(T
).Line
= Errors
.Table
(E
).Line
492 and then Errors
.Table
(T
).Sfile
= Errors
.Table
(E
).Sfile
494 if Errors
.Table
(T
).Sptr
.Ptr
> Errors
.Table
(E
).Sptr
.Ptr
then
498 Set_Next_Non_Deleted_Msg
(T
);
501 -- Output the error flags. The circuit here makes sure that the tab
502 -- characters in the original line are properly accounted for. The
503 -- eight blanks at the start are to match the line number.
505 if not Debug_Flag_2
then
507 P
:= Line_Start
(Errors
.Table
(E
).Sptr
.Ptr
);
510 -- Loop through error messages for this line to place flags
513 while T
/= No_Error_Msg
514 and then Errors
.Table
(T
).Line
= Errors
.Table
(E
).Line
515 and then Errors
.Table
(T
).Sfile
= Errors
.Table
(E
).Sfile
518 Src
: Source_Buffer_Ptr
519 renames Source_Text
(Errors
.Table
(T
).Sfile
);
522 -- Loop to output blanks till current flag position
524 while P
< Errors
.Table
(T
).Sptr
.Ptr
loop
526 -- Horizontal tab case, just echo the tab
528 if Src
(P
) = ASCII
.HT
then
529 Write_Char
(ASCII
.HT
);
532 -- Deal with wide character case, but don't include brackets
533 -- notation in this circuit, since we know that this will
534 -- display unencoded (no one encodes brackets notation).
537 and then Is_Start_Of_Wide_Char
(Src
, P
)
542 -- Normal non-wide character case (or bracket)
550 -- Output flag (unless already output, this happens if more
551 -- than one error message occurs at the same flag position).
553 if P
= Errors
.Table
(T
).Sptr
.Ptr
then
554 if (Flag_Num
= 1 and then not Mult_Flags
)
560 (Character'Val (Character'Pos ('0') + Flag_Num
));
563 -- Skip past the corresponding source text character
565 -- Horizontal tab case, we output a flag at the tab position
566 -- so now we output a tab to match up with the text.
568 if Src
(P
) = ASCII
.HT
then
569 Write_Char
(ASCII
.HT
);
572 -- Skip wide character other than left bracket
575 and then Is_Start_Of_Wide_Char
(Src
, P
)
579 -- Skip normal non-wide character case (or bracket)
587 Set_Next_Non_Deleted_Msg
(T
);
588 Flag_Num
:= Flag_Num
+ 1;
594 -- Now output the error messages
597 while T
/= No_Error_Msg
598 and then Errors
.Table
(T
).Line
= Errors
.Table
(E
).Line
599 and then Errors
.Table
(T
).Sfile
= Errors
.Table
(E
).Sfile
605 while Column
< 74 loop
613 Set_Next_Non_Deleted_Msg
(T
);
617 end Output_Error_Msgs
;
619 ------------------------
620 -- Output_Line_Number --
621 ------------------------
623 procedure Output_Line_Number
(L
: Logical_Line_Number
) is
624 D
: Int
; -- next digit
625 C
: Character; -- next character
626 Z
: Boolean; -- flag for zero suppress
627 N
, M
: Int
; -- temporaries
630 if L
= No_Line_Number
then
651 C
:= Character'Val (D
+ 48);
659 end Output_Line_Number
;
661 ---------------------
662 -- Output_Msg_Text --
663 ---------------------
665 procedure Output_Msg_Text
(E
: Error_Msg_Id
) is
666 Offs
: constant Nat
:= Column
- 1;
667 -- Offset to start of message, used for continuations
670 -- Maximum characters to output on next line
673 -- Maximum total length of lines
675 E_Msg
: Error_Msg_Object
renames Errors
.Table
(E
);
676 Text
: constant String_Ptr
:= E_Msg
.Text
;
680 Tag
: constant String := Get_Warning_Tag
(E
);
685 -- Postfix warning tag to message if needed
687 if Tag
/= "" and then Warning_Doc_Switch
then
688 if Include_Subprogram_In_Messages
then
691 (Subprogram_Name_Ptr (E_Msg.Node) &
692 ": " & Text.all & ' ' & Tag);
694 Txt := new String'(Text
.all & ' ' & Tag
);
697 elsif Include_Subprogram_In_Messages
698 and then (E_Msg
.Warn
or else E_Msg
.Style
)
701 new String'(Subprogram_Name_Ptr (E_Msg.Node) & ": " & Text.all);
706 -- If -gnatdF is used, continuation messages follow the main message
707 -- with only an indentation of two space characters, without repeating
710 if Debug_Flag_FF and then E_Msg.Msg_Cont then
713 -- For info messages, prefix message with "info: "
715 elsif E_Msg.Info then
716 Txt := new String'(SGR_Note
& "info: " & SGR_Reset
& Txt
.all);
718 -- Warning treated as error
720 elsif E_Msg
.Warn_Err
then
722 -- We prefix with "error:" rather than warning: and postfix
723 -- [warning-as-error] at the end.
725 Warnings_Treated_As_Errors
:= Warnings_Treated_As_Errors
+ 1;
726 Txt
:= new String'(SGR_Error & "error: " & SGR_Reset
727 & Txt.all & " [warning-as-error]");
729 -- Normal warning, prefix with "warning: "
731 elsif E_Msg.Warn then
732 Txt := new String'(SGR_Warning
& "warning: " & SGR_Reset
& Txt
.all);
734 -- No prefix needed for style message, "(style)" is there already,
735 -- although not necessarily in first position if -gnatdJ is used.
737 elsif E_Msg
.Style
then
738 if Txt
(Txt
'First .. Txt
'First + 6) = "(style)" then
739 Txt
:= new String'(SGR_Warning & "(style)" & SGR_Reset
740 & Txt (Txt'First + 7 .. Txt'Last));
743 -- No prefix needed for check message, severity is there already
745 elsif E_Msg.Check then
747 -- The message format is "severity: ..."
749 -- Enclose the severity with an SGR control string if requested
751 if Use_SGR_Control then
753 Msg : String renames Text.all;
754 Colon : Natural := 0;
758 for J in Msg'Range loop
759 if Msg (J) = ':' then
765 pragma Assert (Colon > 0);
767 Txt := new String'(SGR_Error
768 & Msg
(Msg
'First .. Colon
)
770 & Msg
(Colon
+ 1 .. Msg
'Last));
774 -- All other cases, add "error: " if unique error tag set
776 elsif Opt
.Unique_Error_Tag
then
777 Txt
:= new String'(SGR_Error & "error: " & SGR_Reset & Txt.all);
780 -- Set error message line length and length of message
782 if Error_Msg_Line_Length = 0 then
785 Length := Error_Msg_Line_Length;
788 Max := Integer (Length - Column + 1);
791 -- Here we have to split the message up into multiple lines
795 -- Make sure we do not have ludicrously small line
797 Max := Integer'Max (Max, 20);
799 -- If remaining text fits, output it respecting LF and we are done
801 if Len - Ptr < Max then
802 for J in Ptr .. Len loop
803 if Txt (J) = ASCII.LF then
807 Write_Char (Txt (J));
818 -- First scan forward looking for a hard end of line
820 for Scan in Ptr .. Ptr + Max - 1 loop
821 if Txt (Scan) = ASCII.LF then
828 -- Otherwise scan backwards looking for a space
830 for Scan in reverse Ptr .. Ptr + Max - 1 loop
831 if Txt (Scan) = ' ' then
838 -- If we fall through, no space, so split line arbitrarily
840 Split := Ptr + Max - 1;
845 if Start <= Split then
846 Write_Line (Txt (Start .. Split));
850 Max := Integer (Length - Column + 1);
854 ---------------------
855 -- Prescan_Message --
856 ---------------------
858 procedure Prescan_Message (Msg : String) is
861 function Parse_Message_Class return String;
862 -- Convert the warning insertion sequence to a warning class represented
863 -- as a length-two string padded, if necessary, with spaces.
864 -- Return the Message class and set the iterator J to the character
865 -- following the sequence.
866 -- Raise a Program_Error if the insertion sequence is not valid.
868 -------------------------
869 -- Parse_Message_Class --
870 -------------------------
872 function Parse_Message_Class return String is
873 C : constant Character := Msg (J - 1);
874 Message_Class : String (1 .. 2) := " ";
876 if J <= Msg'Last and then Msg (J) = C then
877 Message_Class := "? ";
880 elsif J < Msg'Last and then Msg (J + 1) = C
881 and then Msg (J) in 'a
' .. 'z
' | '*' | '$
'
883 Message_Class := Msg (J) & " ";
886 elsif J + 1 < Msg'Last and then Msg (J + 2) = C
887 and then Msg (J) in '.' | '_
'
888 and then Msg (J + 1) in 'a
' .. 'z
'
890 Message_Class := Msg (J .. J + 1);
892 elsif (J < Msg'Last and then Msg (J + 1) = C) or else
893 (J + 1 < Msg'Last and then Msg (J + 2) = C)
898 -- In any other cases, this is not a warning insertion sequence
899 -- and the default " " value is returned.
901 return Message_Class;
902 end Parse_Message_Class;
904 -- Start of processing for Prescan_Message
907 -- Nothing to do for continuation line, unless -gnatdF is set
909 if not Debug_Flag_FF and then Msg (Msg'First) = '\
' then
912 -- Some global variables are not set for continuation messages, as they
913 -- only make sense for the initial message.
915 elsif Msg (Msg'First) /= '\
' then
917 -- Set initial values of globals (may be changed during scan)
919 Is_Serious_Error := True;
920 Is_Unconditional_Msg := False;
921 Is_Warning_Msg := False;
922 Is_Runtime_Raise := False;
924 -- Check style message
928 and then Msg (Msg'First .. Msg'First + 6) = "(style)";
930 -- Check info message
934 and then Msg (Msg'First .. Msg'First + 5) = "info: ";
936 -- Check check message
940 and then Msg (Msg'First .. Msg'First + 7) = "medium: ")
943 and then Msg (Msg'First .. Msg'First + 5) = "high: ")
946 and then Msg (Msg'First .. Msg'First + 4) = "low: ");
949 Has_Double_Exclam := False;
950 Has_Insertion_Line := False;
952 -- Loop through message looking for relevant insertion sequences
955 while J <= Msg'Last loop
957 -- If we have a quote, don't look at following character
959 if Msg (J) = ''' then
962 -- Warning message (? or < insertion sequence)
964 elsif Msg (J) = '?
' or else Msg (J) = '<' then
965 Is_Warning_Msg := Msg (J) = '?
' or else Error_Msg_Warn;
968 if Is_Warning_Msg then
969 Warning_Msg_Char := Parse_Message_Class;
972 -- Bomb if untagged warning message. This code can be uncommented
973 -- for debugging when looking for untagged warning messages.
975 -- if Is_Warning_Msg and then Warning_Msg_Char = ' ' then
976 -- raise Program_Error;
979 -- Unconditional message (! insertion)
981 elsif Msg (J) = '!' then
982 Is_Unconditional_Msg := True;
985 if J <= Msg'Last and then Msg (J) = '!' then
986 Has_Double_Exclam := True;
990 -- Insertion line (# insertion)
992 elsif Msg (J) = '#
' then
993 Has_Insertion_Line := True;
996 -- Non-serious error (| insertion)
998 elsif Msg (J) = '|
' then
999 Is_Serious_Error := False;
1007 if Is_Info_Msg or Is_Warning_Msg or Is_Style_Msg or Is_Check_Msg then
1008 Is_Serious_Error := False;
1010 end Prescan_Message;
1012 --------------------
1013 -- Purge_Messages --
1014 --------------------
1016 procedure Purge_Messages (From : Source_Ptr; To : Source_Ptr) is
1019 function To_Be_Purged (E : Error_Msg_Id) return Boolean;
1020 -- Returns True for a message that is to be purged. Also adjusts
1021 -- error counts appropriately.
1027 function To_Be_Purged (E : Error_Msg_Id) return Boolean is
1029 if E /= No_Error_Msg
1030 and then Errors.Table (E).Sptr.Ptr > From
1031 and then Errors.Table (E).Sptr.Ptr < To
1033 if Errors.Table (E).Warn or else Errors.Table (E).Style then
1034 Warnings_Detected := Warnings_Detected - 1;
1037 Total_Errors_Detected := Total_Errors_Detected - 1;
1039 if Errors.Table (E).Serious then
1040 Serious_Errors_Detected := Serious_Errors_Detected - 1;
1051 -- Start of processing for Purge_Messages
1054 while To_Be_Purged (First_Error_Msg) loop
1055 First_Error_Msg := Errors.Table (First_Error_Msg).Next;
1058 E := First_Error_Msg;
1059 while E /= No_Error_Msg loop
1060 while To_Be_Purged (Errors.Table (E).Next) loop
1061 Errors.Table (E).Next :=
1062 Errors.Table (Errors.Table (E).Next).Next;
1065 E := Errors.Table (E).Next;
1073 function Same_Error (M1, M2 : Error_Msg_Id) return Boolean is
1074 Msg1 : constant String_Ptr := Errors.Table (M1).Text;
1075 Msg2 : constant String_Ptr := Errors.Table (M2).Text;
1077 Msg2_Len : constant Integer := Msg2'Length;
1078 Msg1_Len : constant Integer := Msg1'Length;
1084 (Msg1_Len - 10 > Msg2_Len
1086 Msg2.all = Msg1.all (1 .. Msg2_Len)
1088 Msg1 (Msg2_Len + 1 .. Msg2_Len + 10) = ", instance")
1090 (Msg2_Len - 10 > Msg1_Len
1092 Msg1.all = Msg2.all (1 .. Msg1_Len)
1094 Msg2 (Msg1_Len + 1 .. Msg1_Len + 10) = ", instance");
1101 procedure Set_Msg_Blank is
1104 and then Msg_Buffer (Msglen) /= ' '
1105 and then Msg_Buffer (Msglen) /= '('
1106 and then Msg_Buffer (Msglen) /= '-'
1107 and then not Manual_Quote_Mode
1113 -------------------------------
1114 -- Set_Msg_Blank_Conditional --
1115 -------------------------------
1117 procedure Set_Msg_Blank_Conditional is
1120 and then Msg_Buffer (Msglen) /= ' '
1121 and then Msg_Buffer (Msglen) /= '('
1122 and then Msg_Buffer (Msglen) /= '"'
1123 and then not Manual_Quote_Mode
1127 end Set_Msg_Blank_Conditional;
1133 procedure Set_Msg_Char (C : Character) is
1136 -- The check for message buffer overflow is needed to deal with cases
1137 -- where insertions get too long (in particular a child unit name can
1140 if Msglen < Max_Msg_Length then
1141 Msglen := Msglen + 1;
1142 Msg_Buffer (Msglen) := C;
1146 ---------------------------------
1147 -- Set_Msg_Insertion_File_Name --
1148 ---------------------------------
1150 procedure Set_Msg_Insertion_File_Name is
1152 if Error_Msg_File_1 = No_File then
1155 elsif Error_Msg_File_1 = Error_File_Name then
1157 Set_Msg_Str ("<error
>");
1161 Get_Name_String (Error_Msg_File_1);
1163 Set_Msg_Name_Buffer;
1167 -- The following assignments ensure that the second and third {
1168 -- insertion characters will correspond to the Error_Msg_File_2
1169 -- and Error_Msg_File_3 values.
1171 Error_Msg_File_1 := Error_Msg_File_2;
1172 Error_Msg_File_2 := Error_Msg_File_3;
1173 end Set_Msg_Insertion_File_Name;
1175 -----------------------------------
1176 -- Set_Msg_Insertion_Line_Number --
1177 -----------------------------------
1179 procedure Set_Msg_Insertion_Line_Number (Loc, Flag : Source_Ptr) is
1180 Sindex_Loc : Source_File_Index;
1181 Sindex_Flag : Source_File_Index;
1182 Fname : File_Name_Type;
1186 -- Outputs "at " unless last characters in buffer are " from
". Certain
1187 -- messages read better with from than at.
1196 or else Msg_Buffer (Msglen - 5 .. Msglen) /= " from
"
1198 Set_Msg_Str ("at ");
1202 -- Start of processing for Set_Msg_Insertion_Line_Number
1207 if Loc = No_Location then
1209 Set_Msg_Str ("unknown location
");
1211 elsif Loc = System_Location then
1212 Set_Msg_Str ("in package System
");
1213 Set_Msg_Insertion_Run_Time_Name;
1215 elsif Loc = Standard_Location then
1216 Set_Msg_Str ("in package Standard
");
1218 elsif Loc = Standard_ASCII_Location then
1219 Set_Msg_Str ("in package Standard
.ASCII
");
1222 -- Add "at file
-name
:" if reference is to other than the source
1223 -- file in which the error message is placed. Note that we check
1224 -- full file names, rather than just the source indexes, to
1225 -- deal with generic instantiations from the current file.
1227 Sindex_Loc := Get_Source_File_Index (Loc);
1228 Sindex_Flag := Get_Source_File_Index (Flag);
1230 if Full_File_Name (Sindex_Loc) /= Full_File_Name (Sindex_Flag) then
1232 Fname := Reference_Name (Get_Source_File_Index (Loc));
1233 Int_File := Is_Internal_File_Name (Fname);
1234 Get_Name_String (Fname);
1235 Set_Msg_Name_Buffer;
1237 if not (Int_File and Debug_Flag_Dot_K) then
1239 Set_Msg_Int (Int (Get_Logical_Line_Number (Loc)));
1242 -- If in current file, add text "at line
"
1246 Set_Msg_Str ("line
");
1247 Set_Msg_Int (Int (Get_Logical_Line_Number (Loc)));
1250 -- Deal with the instantiation case. We may have a reference to,
1251 -- e.g. a type, that is declared within a generic template, and
1252 -- what we are really referring to is the occurrence in an instance.
1253 -- In this case, the line number of the instantiation is also of
1254 -- interest, and we add a notation:
1256 -- , instance at xxx
1258 -- where xxx is a line number output using this same routine (and
1259 -- the recursion can go further if the instantiation is itself in
1260 -- a generic template).
1262 -- The flag location passed to us in this situation is indeed the
1263 -- line number within the template, but as described in Sinput.L
1264 -- (file sinput-l.ads, section "Handling
Generic Instantiations
")
1265 -- we can retrieve the location of the instantiation itself from
1266 -- this flag location value.
1268 -- Note: this processing is suppressed if Suppress_Instance_Location
1269 -- is set True. This is used to prevent redundant annotations of the
1270 -- location of the instantiation in the case where we are placing
1271 -- the messages on the instantiation in any case.
1273 if Instantiation (Sindex_Loc) /= No_Location
1274 and then not Suppress_Instance_Location
1276 Set_Msg_Str (", instance
");
1277 Set_Msg_Insertion_Line_Number (Instantiation (Sindex_Loc), Flag);
1280 end Set_Msg_Insertion_Line_Number;
1282 ----------------------------
1283 -- Set_Msg_Insertion_Name --
1284 ----------------------------
1286 procedure Set_Msg_Insertion_Name is
1288 if Error_Msg_Name_1 = No_Name then
1291 elsif Error_Msg_Name_1 = Error_Name then
1293 Set_Msg_Str ("<error
>");
1296 Set_Msg_Blank_Conditional;
1297 Get_Unqualified_Decoded_Name_String (Error_Msg_Name_1);
1299 -- Remove %s or %b at end. These come from unit names. If the
1300 -- caller wanted the (unit) or (body), then they would have used
1301 -- the $ insertion character. Certainly no error message should
1302 -- ever have %b or %s explicitly occurring.
1305 and then Name_Buffer (Name_Len - 1) = '%'
1306 and then (Name_Buffer (Name_Len) = 'b'
1308 Name_Buffer (Name_Len) = 's')
1310 Name_Len := Name_Len - 2;
1313 -- Remove upper case letter at end, again, we should not be getting
1314 -- such names, and what we hope is that the remainder makes sense.
1316 if Name_Len > 1 and then Name_Buffer (Name_Len) in 'A' .. 'Z' then
1317 Name_Len := Name_Len - 1;
1320 -- If operator name or character literal name, just print it as is
1321 -- Also print as is if it ends in a right paren (case of x'val(nnn))
1323 if Name_Buffer (1) = '"'
1324 or else Name_Buffer (1) = '''
1325 or else Name_Buffer (Name_Len) = ')'
1327 Set_Msg_Name_Buffer;
1329 -- Else output with surrounding quotes in proper casing mode
1332 Set_Casing (Identifier_Casing (Flag_Source));
1334 Set_Msg_Name_Buffer;
1339 -- The following assignments ensure that other percent insertion
1340 -- characters will correspond to their appropriate Error_Msg_Name_#
1341 -- values as required.
1343 Error_Msg_Name_1 := Error_Msg_Name_2;
1344 Error_Msg_Name_2 := Error_Msg_Name_3;
1345 Error_Msg_Name_3 := Error_Msg_Name_4;
1346 Error_Msg_Name_4 := Error_Msg_Name_5;
1347 Error_Msg_Name_5 := Error_Msg_Name_6;
1348 end Set_Msg_Insertion_Name;
1350 ------------------------------------
1351 -- Set_Msg_Insertion_Name_Literal --
1352 ------------------------------------
1354 procedure Set_Msg_Insertion_Name_Literal is
1356 if Error_Msg_Name_1 = No_Name then
1359 elsif Error_Msg_Name_1 = Error_Name then
1361 Set_Msg_Str ("<error>");
1365 Get_Name_String (Error_Msg_Name_1);
1367 Set_Msg_Name_Buffer;
1371 -- The following assignments ensure that other percent insertion
1372 -- characters will correspond to their appropriate Error_Msg_Name_#
1373 -- values as required.
1375 Error_Msg_Name_1 := Error_Msg_Name_2;
1376 Error_Msg_Name_2 := Error_Msg_Name_3;
1377 Error_Msg_Name_3 := Error_Msg_Name_4;
1378 Error_Msg_Name_4 := Error_Msg_Name_5;
1379 Error_Msg_Name_5 := Error_Msg_Name_6;
1380 end Set_Msg_Insertion_Name_Literal;
1382 -------------------------------------
1383 -- Set_Msg_Insertion_Reserved_Name --
1384 -------------------------------------
1386 procedure Set_Msg_Insertion_Reserved_Name is
1388 Set_Msg_Blank_Conditional;
1389 Get_Name_String (Error_Msg_Name_1);
1391 Set_Casing (Keyword_Casing (Flag_Source), All_Lower_Case);
1392 Set_Msg_Name_Buffer;
1394 end Set_Msg_Insertion_Reserved_Name;
1396 -------------------------------------
1397 -- Set_Msg_Insertion_Reserved_Word --
1398 -------------------------------------
1400 procedure Set_Msg_Insertion_Reserved_Word
1405 Set_Msg_Blank_Conditional;
1408 while J <= Text'Last and then Text (J) in 'A
' .. 'Z
' loop
1409 Add_Char_To_Name_Buffer (Text (J));
1413 -- Here is where we make the special exception for RM
1415 if Name_Len = 2 and then Name_Buffer (1 .. 2) = "RM" then
1416 Set_Msg_Name_Buffer;
1418 -- We make a similar exception for SPARK
1420 elsif Name_Len = 5 and then Name_Buffer (1 .. 5) = "SPARK" then
1421 Set_Msg_Name_Buffer;
1423 -- Neither RM nor SPARK: case appropriately and add surrounding quotes
1426 Set_Casing (Keyword_Casing (Flag_Source), All_Lower_Case);
1428 Set_Msg_Name_Buffer;
1431 end Set_Msg_Insertion_Reserved_Word;
1433 -------------------------------------
1434 -- Set_Msg_Insertion_Run_Time_Name --
1435 -------------------------------------
1437 procedure Set_Msg_Insertion_Run_Time_Name is
1439 if Targparm.Run_Time_Name_On_Target /= No_Name then
1440 Set_Msg_Blank_Conditional;
1442 Get_Name_String (Targparm.Run_Time_Name_On_Target);
1443 Set_Casing (Mixed_Case);
1444 Set_Msg_Str (Name_Buffer (1 .. Name_Len));
1447 end Set_Msg_Insertion_Run_Time_Name;
1449 ----------------------------
1450 -- Set_Msg_Insertion_Uint --
1451 ----------------------------
1453 procedure Set_Msg_Insertion_Uint is
1456 UI_Image (Error_Msg_Uint_1);
1458 for J in 1 .. UI_Image_Length loop
1459 Set_Msg_Char (UI_Image_Buffer (J));
1462 -- The following assignment ensures that a second caret insertion
1463 -- character will correspond to the Error_Msg_Uint_2 parameter.
1465 Error_Msg_Uint_1 := Error_Msg_Uint_2;
1466 end Set_Msg_Insertion_Uint;
1472 procedure Set_Msg_Int (Line : Int) is
1475 Set_Msg_Int (Line / 10);
1478 Set_Msg_Char (Character'Val (Character'Pos ('0') + (Line rem 10)));
1481 -------------------------
1482 -- Set_Msg_Name_Buffer --
1483 -------------------------
1485 procedure Set_Msg_Name_Buffer is
1487 Set_Msg_Str (Name_Buffer (1 .. Name_Len));
1488 Destroy_Global_Name_Buffer;
1489 end Set_Msg_Name_Buffer;
1495 procedure Set_Msg_Quote is
1497 if not Manual_Quote_Mode then
1506 procedure Set_Msg_Str (Text : String) is
1508 -- Do replacement for special x'Class aspect names
1510 if Text = "_Pre
" then
1511 Set_Msg_Str ("Pre
'Class");
1513 elsif Text = "_Post
" then
1514 Set_Msg_Str ("Post
'Class");
1516 elsif Text = "_Type_Invariant
" then
1517 Set_Msg_Str ("Type_Invariant
'Class");
1519 elsif Text = "_pre
" then
1520 Set_Msg_Str ("pre
'class");
1522 elsif Text = "_post
" then
1523 Set_Msg_Str ("post
'class");
1525 elsif Text = "_type_invariant
" then
1526 Set_Msg_Str ("type_invariant
'class");
1528 elsif Text = "_PRE
" then
1529 Set_Msg_Str ("PRE
'CLASS");
1531 elsif Text = "_POST
" then
1532 Set_Msg_Str ("POST
'CLASS");
1534 elsif Text = "_TYPE_INVARIANT
" then
1535 Set_Msg_Str ("TYPE_INVARIANT
'CLASS");
1537 -- Normal case with no replacement
1540 for J in Text'Range loop
1541 Set_Msg_Char (Text (J));
1546 ------------------------------
1547 -- Set_Next_Non_Deleted_Msg --
1548 ------------------------------
1550 procedure Set_Next_Non_Deleted_Msg (E : in out Error_Msg_Id) is
1552 if E = No_Error_Msg then
1557 E := Errors.Table (E).Next;
1558 exit when E = No_Error_Msg or else not Errors.Table (E).Deleted;
1561 end Set_Next_Non_Deleted_Msg;
1563 ------------------------------
1564 -- Set_Specific_Warning_Off --
1565 ------------------------------
1567 procedure Set_Specific_Warning_Off
1572 Used : Boolean := False)
1575 Specific_Warnings.Append
1577 Msg => new String'(Msg),
1578 Stop => Source_Last (Get_Source_File_Index (Loc)),
1583 end Set_Specific_Warning_Off;
1585 -----------------------------
1586 -- Set_Specific_Warning_On --
1587 -----------------------------
1589 procedure Set_Specific_Warning_On
1595 for J in 1 .. Specific_Warnings.Last loop
1597 SWE : Specific_Warning_Entry renames Specific_Warnings.Table (J);
1600 if Msg = SWE.Msg.all
1601 and then Loc > SWE.Start
1603 and then Get_Source_File_Index (SWE.Start) =
1604 Get_Source_File_Index (Loc)
1610 -- If a config pragma is specifically cancelled, consider
1611 -- that it is no longer active as a configuration pragma.
1613 SWE.Config := False;
1620 end Set_Specific_Warning_On;
1622 ---------------------------
1623 -- Set_Warnings_Mode_Off --
1624 ---------------------------
1626 procedure Set_Warnings_Mode_Off (Loc : Source_Ptr; Reason : String_Id) is
1628 -- Don't bother with entries from instantiation copies, since we will
1629 -- already have a copy in the template, which is what matters.
1631 if Instantiation (Get_Source_File_Index (Loc)) /= No_Location then
1635 -- If all warnings are suppressed by command line switch, this can
1636 -- be ignored, unless we are in GNATprove_Mode which requires pragma
1637 -- Warnings to be stored for the formal verification backend.
1639 if Warning_Mode = Suppress
1640 and then not GNATprove_Mode
1645 -- If last entry in table already covers us, this is a redundant pragma
1646 -- Warnings (Off) and can be ignored.
1648 if Warnings.Last >= Warnings.First
1649 and then Warnings.Table (Warnings.Last).Start <= Loc
1650 and then Loc <= Warnings.Table (Warnings.Last).Stop
1655 -- If none of those special conditions holds, establish a new entry,
1656 -- extending from the location of the pragma to the end of the current
1657 -- source file. This ending point will be adjusted by a subsequent
1658 -- corresponding pragma Warnings (On).
1662 Stop => Source_Last (Get_Source_File_Index (Loc)),
1664 end Set_Warnings_Mode_Off;
1666 --------------------------
1667 -- Set_Warnings_Mode_On --
1668 --------------------------
1670 procedure Set_Warnings_Mode_On (Loc : Source_Ptr) is
1672 -- Don't bother with entries from instantiation copies, since we will
1673 -- already have a copy in the template, which is what matters.
1675 if Instantiation (Get_Source_File_Index (Loc)) /= No_Location then
1679 -- If all warnings are suppressed by command line switch, this can
1680 -- be ignored, unless we are in GNATprove_Mode which requires pragma
1681 -- Warnings to be stored for the formal verification backend.
1683 if Warning_Mode = Suppress
1684 and then not GNATprove_Mode
1689 -- If the last entry in the warnings table covers this pragma, then
1690 -- we adjust the end point appropriately.
1692 if Warnings.Last >= Warnings.First
1693 and then Warnings.Table (Warnings.Last).Start <= Loc
1694 and then Loc <= Warnings.Table (Warnings.Last).Stop
1696 Warnings.Table (Warnings.Last).Stop := Loc;
1698 end Set_Warnings_Mode_On;
1704 function Sloc_In_Range (Loc, Start, Stop : Source_Ptr) return Boolean is
1705 Cur_Loc : Source_Ptr := Loc;
1708 while Cur_Loc /= No_Location loop
1709 if Start <= Cur_Loc and then Cur_Loc <= Stop then
1713 Cur_Loc := Instantiation_Location (Cur_Loc);
1719 --------------------------------
1720 -- Validate_Specific_Warnings --
1721 --------------------------------
1723 procedure Validate_Specific_Warnings (Eproc : Error_Msg_Proc) is
1725 if not Warn_On_Warnings_Off then
1729 for J in Specific_Warnings.First .. Specific_Warnings.Last loop
1731 SWE : Specific_Warning_Entry renames Specific_Warnings.Table (J);
1734 if not SWE.Config then
1736 -- Warn for unmatched Warnings (Off, ...)
1740 ("?
.w?
pragma Warnings Off
with no matching Warnings On
",
1743 -- Warn for ineffective Warnings (Off, ..)
1747 -- Do not issue this warning for -Wxxx messages since the
1748 -- back-end doesn't report the information. Note that there
1749 -- is always an asterisk at the start of every message.
1752 (SWE.Msg'Length > 3 and then SWE.Msg (2 .. 3) = "-W
")
1755 ("?
.w?no warning suppressed by this
pragma", SWE.Start);
1760 end Validate_Specific_Warnings;
1762 -------------------------------------
1763 -- Warning_Specifically_Suppressed --
1764 -------------------------------------
1766 function Warning_Specifically_Suppressed
1769 Tag : String := "") return String_Id
1772 -- Loop through specific warning suppression entries
1774 for J in Specific_Warnings.First .. Specific_Warnings.Last loop
1776 SWE : Specific_Warning_Entry renames Specific_Warnings.Table (J);
1779 -- Pragma applies if it is a configuration pragma, or if the
1780 -- location is in range of a specific non-configuration pragma.
1783 or else Sloc_In_Range (Loc, SWE.Start, SWE.Stop)
1785 if Matches (Msg.all, SWE.Msg.all)
1786 or else Matches (Tag, SWE.Msg.all)
1796 end Warning_Specifically_Suppressed;
1798 ------------------------------
1799 -- Warning_Treated_As_Error --
1800 ------------------------------
1802 function Warning_Treated_As_Error (Msg : String) return Boolean is
1804 for J in 1 .. Warnings_As_Errors_Count loop
1805 if Matches (Msg, Warnings_As_Errors (J).all) then
1811 end Warning_Treated_As_Error;
1813 -------------------------
1814 -- Warnings_Suppressed --
1815 -------------------------
1817 function Warnings_Suppressed (Loc : Source_Ptr) return String_Id is
1819 -- Loop through table of ON/OFF warnings
1821 for J in Warnings.First .. Warnings.Last loop
1822 if Sloc_In_Range (Loc, Warnings.Table (J).Start,
1823 Warnings.Table (J).Stop)
1825 return Warnings.Table (J).Reason;
1829 if Warning_Mode = Suppress then
1830 return Null_String_Id;
1834 end Warnings_Suppressed;