From: Viljar Indus <in...@adacore.com>
Simplify the storage for the kind of error message under a single
enumerator. This replaces the existing attributes with the following
enumeration values.
* Is_Warning_Msg => Warning
* Is_Style_Msg => Style
* Is_Info_Msg => Info
* Is_Check_Msg => Low_Check, Medium_Check, High_Check
* Is_Serious_Error => Error, if the attribute was false then
Non_Serious_Error.
gcc/ada/ChangeLog:
* diagnostics-converter.adb: Use new enum values instead
of the old attributes.
* diagnostics-switch_repository.adb: Same as above.
* diagnostics-utils.adb: Same as above.
* diagnostics.adb: Same as above.
* diagnostics.ads: Same as above.
* errout.adb: Same as above.
* erroutc.adb: Same as above.
* erroutc.ads: Remove old attriubtes and replace them
with Error_Msg_Kind.
* errutil.adb: Same as others.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/diagnostics-converter.adb | 11 +-
gcc/ada/diagnostics-switch_repository.adb | 16 +-
gcc/ada/diagnostics-utils.adb | 2 +-
gcc/ada/diagnostics.adb | 38 ++--
gcc/ada/diagnostics.ads | 11 +-
gcc/ada/errout.adb | 208 +++++++++-------------
gcc/ada/erroutc.adb | 176 ++++++++++--------
gcc/ada/erroutc.ads | 84 ++++-----
gcc/ada/errutil.adb | 63 ++-----
9 files changed, 279 insertions(+), 330 deletions(-)
diff --git a/gcc/ada/diagnostics-converter.adb
b/gcc/ada/diagnostics-converter.adb
index e1613f674c6..f02c2130d7e 100644
--- a/gcc/ada/diagnostics-converter.adb
+++ b/gcc/ada/diagnostics-converter.adb
@@ -51,9 +51,10 @@ package body Diagnostics.Converter is
function Get_Diagnostics_Kind (E_Msg : Error_Msg_Object)
return Diagnostic_Kind
- is (if E_Msg.Warn then Get_Warning_Kind (E_Msg)
- elsif E_Msg.Style then Style
- elsif E_Msg.Info then Info
+ is (if E_Msg.Kind = Erroutc.Warning then Get_Warning_Kind (E_Msg)
+ elsif E_Msg.Kind = Erroutc.Style then Style
+ elsif E_Msg.Kind = Erroutc.Info then Info
+ elsif E_Msg.Kind = Erroutc.Non_Serious_Error then Non_Serious_Error
else Error);
-----------------------------------
@@ -126,14 +127,12 @@ package body Diagnostics.Converter is
D.Kind := Get_Diagnostics_Kind (E_Msg);
- if E_Msg.Warn or E_Msg.Style or E_Msg.Info then
+ if E_Msg.Kind in Erroutc.Warning | Erroutc.Style | Erroutc.Info then
D.Switch := Get_Switch_Id (E_Msg);
end if;
D.Warn_Err := E_Msg.Warn_Err;
- D.Serious := E_Msg.Serious;
-
-- Convert the primary location
Add_Location (D, Primary_Labeled_Span (E_Msg.Sptr));
diff --git a/gcc/ada/diagnostics-switch_repository.adb
b/gcc/ada/diagnostics-switch_repository.adb
index d60990192f2..1795663e615 100644
--- a/gcc/ada/diagnostics-switch_repository.adb
+++ b/gcc/ada/diagnostics-switch_repository.adb
@@ -582,14 +582,16 @@ package body Diagnostics.Switch_Repository is
-------------------
function Get_Switch_Id (E : Error_Msg_Object) return Switch_Id is
-
+ Switch_Name : constant String :=
+ (if E.Warn_Chr = "$ " then "gnatel"
+ elsif E.Warn_Chr in "? " | " " then ""
+ elsif E.Kind in Erroutc.Warning | Erroutc.Info
+ then "gnatw" & E.Warn_Chr
+ elsif E.Kind in Erroutc.Style then "gnatw" & E.Warn_Chr
+ else "");
begin
- if E.Warn_Chr = "$ " then
- return Get_Switch_Id ("gnatel");
- elsif E.Warn or E.Info then
- return Get_Switch_Id ("gnatw" & E.Warn_Chr);
- elsif E.Style then
- return Get_Switch_Id ("gnaty" & E.Warn_Chr);
+ if Switch_Name /= "" then
+ return Get_Switch_Id (Switch_Name);
else
return No_Switch_Id;
end if;
diff --git a/gcc/ada/diagnostics-utils.adb b/gcc/ada/diagnostics-utils.adb
index a590536d917..11649ccf40e 100644
--- a/gcc/ada/diagnostics-utils.adb
+++ b/gcc/ada/diagnostics-utils.adb
@@ -219,7 +219,7 @@ package body Diagnostics.Utils is
(if D.Warn_Err then "error"
else
(case D.Kind is
- when Diagnostics.Error => "error",
+ when Diagnostics.Error | Non_Serious_Error => "error",
when Warning | Restriction_Warning | Default_Warning |
Tagless_Warning => "warning",
when Style => "style",
diff --git a/gcc/ada/diagnostics.adb b/gcc/ada/diagnostics.adb
index c9c5483693c..d45279f5107 100644
--- a/gcc/ada/diagnostics.adb
+++ b/gcc/ada/diagnostics.adb
@@ -197,21 +197,29 @@ package body Diagnostics is
procedure Update_Diagnostic_Count (Diagnostic : Diagnostic_Type) is
begin
- if Diagnostic.Kind = Error then
- Total_Errors_Detected := Total_Errors_Detected + 1;
-
- if Diagnostic.Serious then
+ case Diagnostic.Kind is
+ when Error =>
+ Total_Errors_Detected := Total_Errors_Detected + 1;
Serious_Errors_Detected := Serious_Errors_Detected + 1;
- end if;
- elsif Diagnostic.Kind in Warning | Style then
- Warnings_Detected := Warnings_Detected + 1;
-
- if Diagnostic.Warn_Err then
- Warnings_Treated_As_Errors := Warnings_Treated_As_Errors + 1;
- end if;
- elsif Diagnostic.Kind in Info then
- Info_Messages := Info_Messages + 1;
- end if;
+
+ when Non_Serious_Error =>
+ Total_Errors_Detected := Total_Errors_Detected + 1;
+
+ when Warning
+ | Default_Warning
+ | Tagless_Warning
+ | Restriction_Warning
+ | Style
+ =>
+ Warnings_Detected := Warnings_Detected + 1;
+
+ if Diagnostic.Warn_Err then
+ Warnings_Treated_As_Errors := Warnings_Treated_As_Errors + 1;
+ end if;
+
+ when Info =>
+ Info_Messages := Info_Messages + 1;
+ end case;
end Update_Diagnostic_Count;
procedure Handle_Serious_Error;
@@ -265,7 +273,7 @@ package body Diagnostics is
Update_Diagnostic_Count (Diagnostic);
end if;
- if Diagnostic.Kind = Error and then Diagnostic.Serious then
+ if Diagnostic.Kind = Error then
Handle_Serious_Error;
end if;
end Record_Diagnostic;
diff --git a/gcc/ada/diagnostics.ads b/gcc/ada/diagnostics.ads
index 67800d93fc2..0df0382422f 100644
--- a/gcc/ada/diagnostics.ads
+++ b/gcc/ada/diagnostics.ads
@@ -305,6 +305,11 @@ package Diagnostics is
type Diagnostic_Kind is
(Error,
+ Non_Serious_Error,
+ -- Typically all errors are considered serious and the compiler should
+ -- stop its processing since the tree is essentially invalid. However,
+ -- some errors are not serious and the compiler can continue its
+ -- processing to discover more critical errors.
Warning,
Default_Warning,
-- Warning representing the old warnings created with the '??' insertion
@@ -349,12 +354,6 @@ package Diagnostics is
-- error. This needs to be set during the message emission as this
-- behavior depends on the context of the code.
- Serious : Boolean := True;
- -- Typically all errors are considered serious and the compiler should
- -- stop its processing since the tree is essentially invalid. However,
- -- some errors are not serious and the compiler can continue its
- -- processing to discover more critical errors.
-
Locations : Labeled_Span_List := Labeled_Span_Lists.Nil;
Sub_Diagnostics : Sub_Diagnostic_List := Sub_Diagnostic_Lists.Nil;
diff --git a/gcc/ada/errout.adb b/gcc/ada/errout.adb
index de2413a8f15..a569b61c43f 100644
--- a/gcc/ada/errout.adb
+++ b/gcc/ada/errout.adb
@@ -411,21 +411,21 @@ package body Errout is
-- No duplicate, so error/warning will be posted on instance
- Warn_On_Instance := Is_Warning_Msg;
+ Warn_On_Instance := Error_Msg_Kind = Warning;
end if;
-- Ignore warning message that is suppressed for this location. Note
-- that style checks are not considered warning messages for this
-- purpose.
- if Is_Warning_Msg
+ if Error_Msg_Kind = Warning
and then Warnings_Suppressed (Orig_Loc) /= No_String
then
return;
-- For style messages, check too many messages so far
- elsif Is_Style_Msg
+ elsif Error_Msg_Kind = Style
and then Maximum_Messages /= 0
and then Warnings_Detected >= Maximum_Messages
then
@@ -435,7 +435,7 @@ package body Errout is
-- probably null (i.e. when loop executes only if invalid values
-- present). In either case warnings in the loop are likely to be junk.
- elsif Is_Warning_Msg and then Present (N) then
+ elsif Error_Msg_Kind = Warning and then Present (N) then
declare
P : Node_Id;
@@ -556,21 +556,21 @@ package body Errout is
-- Case of inlined body
if Inlined_Body (X) then
- if Is_Info_Msg then
+ if Error_Msg_Kind = Info then
Error_Msg_Internal
(Msg => "info: in inlined body #",
Span => To_Span (Actual_Error_Loc),
Opan => Flag_Span,
Msg_Cont => Msg_Cont_Status);
- elsif Is_Warning_Msg then
+ elsif Error_Msg_Kind = Warning then
Error_Msg_Internal
(Msg => Warn_Insertion & "in inlined body #",
Span => To_Span (Actual_Error_Loc),
Opan => Flag_Span,
Msg_Cont => Msg_Cont_Status);
- elsif Is_Style_Msg then
+ elsif Error_Msg_Kind = Style then
Error_Msg_Internal
(Msg => "style: in inlined body #",
Span => To_Span (Actual_Error_Loc),
@@ -588,21 +588,21 @@ package body Errout is
-- Case of generic instantiation
else
- if Is_Info_Msg then
+ if Error_Msg_Kind = Info then
Error_Msg_Internal
(Msg => "info: in instantiation #",
Span => To_Span (Actual_Error_Loc),
Opan => Flag_Span,
Msg_Cont => Msg_Cont_Status);
- elsif Is_Warning_Msg then
+ elsif Error_Msg_Kind = Warning then
Error_Msg_Internal
(Msg => Warn_Insertion & "in instantiation #",
Span => To_Span (Actual_Error_Loc),
Opan => Flag_Span,
Msg_Cont => Msg_Cont_Status);
- elsif Is_Style_Msg then
+ elsif Error_Msg_Kind = Style then
Error_Msg_Internal
(Msg => "style: in instantiation #",
Span => To_Span (Actual_Error_Loc),
@@ -1016,7 +1016,7 @@ package body Errout is
if Suppress_Message
and then not All_Errors_Mode
- and then not Is_Warning_Msg
+ and then Error_Msg_Kind /= Warning
and then not Is_Unconditional_Msg
then
if not Continuation then
@@ -1042,7 +1042,7 @@ package body Errout is
return;
end if;
- if Is_Info_Msg then
+ if Error_Msg_Kind = Info then
-- Immediate return if info messages are suppressed
@@ -1074,17 +1074,14 @@ package body Errout is
return;
end if;
- end if;
-
-- Special check for warning message to see if it should be output
- if Is_Warning_Msg then
+ elsif Error_Msg_Kind = Warning then
-- Immediate return if warning message and warnings are suppressed
if Warnings_Suppressed (Optr) /= No_String
- or else
- Warnings_Suppressed (Sptr) /= No_String
+ or else Warnings_Suppressed (Sptr) /= No_String
then
Cur_Msg := No_Error_Msg;
return;
@@ -1137,7 +1134,7 @@ package body Errout is
-- where we do this special processing, bypassing message output.
if Ignore_Errors_Enable > 0 then
- if Is_Serious_Error then
+ if Error_Msg_Kind = Erroutc.Error then
Handle_Serious_Error;
end if;
@@ -1223,9 +1220,9 @@ package body Errout is
-- Update warning msg flag and message doc char if needed
- if Is_Warning_Msg then
- if not Errors.Table (Cur_Msg).Warn then
- Errors.Table (Cur_Msg).Warn := True;
+ if Error_Msg_Kind = Warning then
+ if Errors.Table (Cur_Msg).Kind /= Warning then
+ Errors.Table (Cur_Msg).Kind := Warning;
Errors.Table (Cur_Msg).Warn_Chr := Warning_Msg_Char;
elsif Warning_Msg_Char /= " " then
@@ -1237,11 +1234,6 @@ package body Errout is
return;
end if;
- -- Warning, Style and Info attributes are mutually exclusive
-
- pragma Assert (Boolean'Pos (Is_Warning_Msg) + Boolean'Pos (Is_Info_Msg) +
- Boolean'Pos (Is_Style_Msg) <= 1);
-
-- Here we build a new error object
Errors.Append
@@ -1250,42 +1242,40 @@ package body Errout is
Prev => No_Error_Msg,
Sptr => Span,
Optr => Opan,
- Insertion_Sloc => (if Has_Insertion_Line then Error_Msg_Sloc
- else No_Location),
+ Insertion_Sloc =>
+ (if Has_Insertion_Line then Error_Msg_Sloc else No_Location),
Sfile => Get_Source_File_Index (Sptr),
Line => Get_Physical_Line_Number (Sptr),
Col => Get_Column_Number (Sptr),
Compile_Time_Pragma => Is_Compile_Time_Msg,
- Warn => Is_Warning_Msg,
- Info => Is_Info_Msg,
- Check => Is_Check_Msg,
Warn_Err => False, -- reset below
Warn_Chr => Warning_Msg_Char,
Warn_Runtime_Raise => Is_Runtime_Raise,
- Style => Is_Style_Msg,
- Serious => Is_Serious_Error,
Uncond => Is_Unconditional_Msg,
Msg_Cont => Continuation,
- Deleted => False));
+ Deleted => False,
+ Kind => Error_Msg_Kind));
Cur_Msg := Errors.Last;
-- Test if warning to be treated as error
Warn_Err :=
- (Is_Warning_Msg or Is_Style_Msg)
- and then (Warning_Treated_As_Error (Msg_Buffer (1 .. Msglen))
- or else
- Warning_Treated_As_Error (Get_Warning_Tag (Cur_Msg)));
+ Error_Msg_Kind in Warning | Style
+ and then (Warning_Treated_As_Error (Msg_Buffer (1 .. Msglen))
+ or else Warning_Treated_As_Error
+ (Get_Warning_Tag (Cur_Msg)));
-- Propagate Warn_Err to this message and preceding continuations.
- -- Likewise, propagate Is_Warning_Msg and Is_Runtime_Raise, because the
+ -- Likewise, propagate Error_Msg_Kind and Is_Runtime_Raise, because the
-- current continued message could have been escalated from warning to
-- error.
for J in reverse 1 .. Errors.Last loop
- Errors.Table (J).Warn_Err := Warn_Err;
- Errors.Table (J).Warn := Is_Warning_Msg;
+ Errors.Table (J).Warn_Err := Warn_Err;
+
+ Errors.Table (J).Kind := Error_Msg_Kind;
Errors.Table (J).Warn_Runtime_Raise := Is_Runtime_Raise;
+
exit when not Errors.Table (J).Msg_Cont;
end loop;
@@ -1311,13 +1301,14 @@ package body Errout is
-- there are lots of messages.
if Last_Error_Msg /= No_Error_Msg
- and then Errors.Table (Cur_Msg).Sfile =
- Errors.Table (Last_Error_Msg).Sfile
+ and then Errors.Table (Cur_Msg).Sfile
+ = Errors.Table (Last_Error_Msg).Sfile
and then (Sptr > Errors.Table (Last_Error_Msg).Sptr.Ptr
- or else
- (Sptr = Errors.Table (Last_Error_Msg).Sptr.Ptr
- and then
- Optr > Errors.Table (Last_Error_Msg).Optr.Ptr))
+ or else (Sptr = Errors.Table (Last_Error_Msg).Sptr.Ptr
+ and then Optr
+ > Errors.Table (Last_Error_Msg)
+ .Optr
+ .Ptr))
then
Prev_Msg := Last_Error_Msg;
Next_Msg := No_Error_Msg;
@@ -1333,10 +1324,10 @@ package body Errout is
if Errors.Table (Cur_Msg).Sfile = Errors.Table (Next_Msg).Sfile
then
- exit when Sptr < Errors.Table (Next_Msg).Sptr.Ptr
+ exit when
+ Sptr < Errors.Table (Next_Msg).Sptr.Ptr
or else (Sptr = Errors.Table (Next_Msg).Sptr.Ptr
- and then
- Optr < Errors.Table (Next_Msg).Optr.Ptr);
+ and then Optr < Errors.Table (Next_Msg).Optr.Ptr);
end if;
Prev_Msg := Next_Msg;
@@ -1354,10 +1345,9 @@ package body Errout is
-- deletion, but otherwise such messages are discarded at this stage.
if Prev_Msg /= No_Error_Msg
- and then Errors.Table (Prev_Msg).Line =
- Errors.Table (Cur_Msg).Line
- and then Errors.Table (Prev_Msg).Sfile =
- Errors.Table (Cur_Msg).Sfile
+ and then Errors.Table (Prev_Msg).Line = Errors.Table (Cur_Msg).Line
+ and then Errors.Table (Prev_Msg).Sfile
+ = Errors.Table (Cur_Msg).Sfile
and then Compiler_State = Parsing
and then not All_Errors_Mode
then
@@ -1365,9 +1355,7 @@ package body Errout is
-- delete continuation lines; we attempted to delete those earlier
-- if the parent message was deleted.
- if not Errors.Table (Cur_Msg).Uncond
- and then not Continuation
- then
+ if not Errors.Table (Cur_Msg).Uncond and then not Continuation then
-- Don't delete if prev msg is warning and new msg is an error.
-- This is because we don't want a real error masked by a
-- warning. In all other cases (that is parse errors for the
@@ -1375,13 +1363,8 @@ package body Errout is
-- message. This helps to avoid junk extra messages from
-- cascaded parsing errors
- if not (Errors.Table (Prev_Msg).Warn
- or else
- Errors.Table (Prev_Msg).Style)
- or else
- (Errors.Table (Cur_Msg).Warn
- or else
- Errors.Table (Cur_Msg).Style)
+ if Errors.Table (Prev_Msg).Kind not in Warning | Style
+ or else Errors.Table (Cur_Msg).Kind in Warning | Style
then
-- All tests passed, delete the message by simply returning
-- without any further processing.
@@ -1413,42 +1396,26 @@ package body Errout is
end if;
end if;
- -- Bump appropriate statistics counts
-
- if Errors.Table (Cur_Msg).Info then
- Info_Messages := Info_Messages + 1;
-
- elsif Errors.Table (Cur_Msg).Warn
- or else Errors.Table (Cur_Msg).Style
- then
- Warnings_Detected := Warnings_Detected + 1;
+ Increase_Error_Msg_Count (Errors.Table (Cur_Msg));
- elsif Errors.Table (Cur_Msg).Check then
- Check_Messages := Check_Messages + 1;
+ if Errors.Table (Cur_Msg).Kind = Erroutc.Error then
+ Handle_Serious_Error;
- else
- Total_Errors_Detected := Total_Errors_Detected + 1;
-
- if Errors.Table (Cur_Msg).Serious then
- Serious_Errors_Detected := Serious_Errors_Detected + 1;
- Handle_Serious_Error;
+ -- If not serious error, set Fatal_Error to indicate ignored error
- -- If not serious error, set Fatal_Error to indicate ignored error
-
- else
- declare
- U : constant Unit_Number_Type := Get_Source_Unit (Sptr);
- begin
- if Fatal_Error (U) = None then
- Set_Fatal_Error (U, Error_Ignored);
- end if;
- end;
- end if;
+ elsif Errors.Table (Cur_Msg).Kind = Non_Serious_Error then
+ declare
+ U : constant Unit_Number_Type := Get_Source_Unit (Sptr);
+ begin
+ if Fatal_Error (U) = None then
+ Set_Fatal_Error (U, Error_Ignored);
+ end if;
+ end;
end if;
-- Record warning message issued
- if Errors.Table (Cur_Msg).Warn
+ if Errors.Table (Cur_Msg).Kind = Warning
and then not Errors.Table (Cur_Msg).Msg_Cont
then
Warning_Msg := Cur_Msg;
@@ -1478,10 +1445,7 @@ package body Errout is
Has_Insertion_Line := False;
Error_Msg_Internal
- (Msg => Msg,
- Span => Span,
- Opan => Opan,
- Msg_Cont => True);
+ (Msg => Msg, Span => Span, Opan => Opan, Msg_Cont => True);
end;
end if;
end Error_Msg_Internal;
@@ -1553,7 +1517,7 @@ package body Errout is
-- Special handling for warning messages
- if Is_Warning_Msg then
+ if Error_Msg_Kind = Warning then
-- Suppress if no warnings set for either entity or node
@@ -1570,7 +1534,7 @@ package body Errout is
if All_Errors_Mode
or else Is_Unconditional_Msg
- or else Is_Warning_Msg
+ or else Error_Msg_Kind = Warning
or else OK_Node (N)
or else (Msg (Msg'First) = '\' and then not Last_Killed)
then
@@ -1715,7 +1679,7 @@ package body Errout is
Tag : constant String := Get_Warning_Tag (Cur);
begin
- if CE.Warn
+ if CE.Kind = Warning
and then not CE.Deleted
and then
(Warning_Specifically_Suppressed (CE.Sptr.Ptr, CE.Text, Tag)
@@ -2498,9 +2462,15 @@ package body Errout is
Write_Str ("{""kind"":");
- if Errors.Table (E).Warn and then not Errors.Table (E).Warn_Err then
+ if Errors.Table (E).Kind = Warning and then not Errors.Table (E).Warn_Err
+ then
Write_Str ("""warning""");
- elsif Errors.Table (E).Info or else Errors.Table (E).Check then
+ elsif Errors.Table (E).Kind in
+ Info
+ | High_Check
+ | Medium_Check
+ | Low_Check
+ then
Write_Str ("""note""");
else
Write_Str ("""error""");
@@ -2629,7 +2599,7 @@ package body Errout is
if Debug_Flag_FF then
if Errors.Table (E).Msg_Cont then
Write_Str (" ");
- elsif not Errors.Table (E).Info then
+ elsif Errors.Table (E).Kind /= Info then
Write_Eol;
end if;
end if;
@@ -2648,7 +2618,7 @@ package body Errout is
-- continuation messages.
if Debug_Flag_FF
- and then not Errors.Table (E).Info
+ and then Errors.Table (E).Kind /= Info
then
if Errors.Table (E).Msg_Cont then
declare
@@ -2664,8 +2634,8 @@ package body Errout is
else
declare
SGR_Span : constant String :=
- (if Errors.Table (E).Info then SGR_Note
- elsif Errors.Table (E).Warn
+ (if Errors.Table (E).Kind = Info then SGR_Note
+ elsif Errors.Table (E).Kind = Warning
and then not Errors.Table (E).Warn_Err
then SGR_Warning
else SGR_Error);
@@ -3644,7 +3614,7 @@ package body Errout is
-- not remove style messages here. They are warning messages
-- but not ones we want removed in this context.
- and then (Errors.Table (E).Warn
+ and then (Errors.Table (E).Kind = Warning
or else
Errors.Table (E).Warn_Runtime_Raise)
@@ -3652,7 +3622,7 @@ package body Errout is
and then not Errors.Table (E).Uncond
then
- if Errors.Table (E).Warn then
+ if Errors.Table (E).Kind = Warning then
Warnings_Detected := Warnings_Detected - 1;
end if;
@@ -3876,9 +3846,9 @@ package body Errout is
K : Node_Kind;
begin
- Suppress_Message := Error_Msg_Node_1 in Error | Any_Type;
+ Suppress_Message := Error_Msg_Node_1 in Types.Error | Any_Type;
- if Error_Msg_Node_1 = Error then
+ if Error_Msg_Node_1 = Types.Error then
Set_Msg_Blank;
Set_Msg_Str ("<error>");
@@ -4291,9 +4261,9 @@ package body Errout is
Msglen := 0;
Flag_Source := Get_Source_File_Index (Flag);
- -- Skip info: at start, we have recorded this in Is_Info_Msg, and this
- -- will be used (Info field in error message object) to put back the
- -- string when it is printed. We need to do this, or we get confused
+ -- Skip info: at start, we have recorded this in Error_Msg_Kind, and
+ -- this will be used (Info field in error message object) to put back
+ -- the string when it is printed. We need to do this, or we get confused
-- with instantiation continuations.
if Text'Length > 6
@@ -4413,16 +4383,16 @@ package body Errout is
else
-- Switch the message from a warning to an error if the flag
-- -gnatwE is specified to treat run-time exception warnings
- -- as errors.
+ -- as non-serious errors.
- if Is_Warning_Msg
+ if Error_Msg_Kind = Warning
and then Warning_Mode = Treat_Run_Time_Warnings_As_Errors
then
- Is_Warning_Msg := False;
+ Error_Msg_Kind := Non_Serious_Error;
Is_Runtime_Raise := True;
end if;
- if Is_Warning_Msg then
+ if Error_Msg_Kind = Warning then
Set_Msg_Str ("will be raised at run time");
else
Set_Msg_Str ("would have been raised at run time");
@@ -4432,7 +4402,7 @@ package body Errout is
-- ']' (may be/might have been raised at run time)
when ']' =>
- if Is_Warning_Msg then
+ if Error_Msg_Kind = Warning then
Set_Msg_Str ("may be raised at run time");
else
Set_Msg_Str ("might have been raised at run time");
@@ -4454,7 +4424,7 @@ package body Errout is
P : Node_Id;
begin
- if Is_Serious_Error then
+ if Error_Msg_Kind = Erroutc.Error then
-- We always set Error_Posted on the node itself
diff --git a/gcc/ada/erroutc.adb b/gcc/ada/erroutc.adb
index 606600c613b..32197ad7884 100644
--- a/gcc/ada/erroutc.adb
+++ b/gcc/ada/erroutc.adb
@@ -145,29 +145,7 @@ package body Erroutc is
loop
Errors.Table (D).Deleted := True;
- -- Adjust error message count
-
- if Errors.Table (D).Info then
-
- Info_Messages := Info_Messages - 1;
-
- elsif Errors.Table (D).Warn or else Errors.Table (D).Style then
- Warnings_Detected := Warnings_Detected - 1;
-
- -- Note: we do not need to decrement Warnings_Treated_As_Errors
- -- because this only gets incremented if we actually output the
- -- message, which we won't do if we are deleting it here!
-
- elsif Errors.Table (D).Check then
- Check_Messages := Check_Messages - 1;
-
- else
- Total_Errors_Detected := Total_Errors_Detected - 1;
-
- if Errors.Table (D).Serious then
- Serious_Errors_Detected := Serious_Errors_Detected - 1;
- end if;
- end if;
+ Decrease_Error_Msg_Count (Errors.Table (D));
-- Substitute shorter of the two error messages
@@ -278,7 +256,7 @@ package body Erroutc is
begin
for J in 1 .. Errors.Last loop
begin
- if Errors.Table (J).Warn
+ if Errors.Table (J).Kind = Warning
and then Errors.Table (J).Compile_Time_Pragma
and then not Errors.Table (J).Deleted
then
@@ -289,6 +267,32 @@ package body Erroutc is
return Result;
end Count_Compile_Time_Pragma_Warnings;
+ ------------------------------
+ -- Decrease_Error_Msg_Count --
+ ------------------------------
+
+ procedure Decrease_Error_Msg_Count (E : Error_Msg_Object) is
+
+ begin
+ case E.Kind is
+ when Info =>
+ Info_Messages := Info_Messages - 1;
+
+ when Warning | Style =>
+ Warnings_Detected := Warnings_Detected - 1;
+
+ when High_Check | Medium_Check | Low_Check =>
+ Check_Messages := Check_Messages - 1;
+
+ when Error =>
+ Total_Errors_Detected := Total_Errors_Detected - 1;
+ Serious_Errors_Detected := Serious_Errors_Detected - 1;
+
+ when Non_Serious_Error =>
+ Total_Errors_Detected := Total_Errors_Detected - 1;
+ end case;
+ end Decrease_Error_Msg_Count;
+
------------------
-- Debug_Output --
------------------
@@ -334,13 +338,10 @@ package body Erroutc is
w (" Line = ", Int (E.Line));
w (" Col = ", Int (E.Col));
- w (" Info = ", E.Info);
- w (" Warn = ", E.Warn);
+ w (" Kind = ", E.Kind'Img);
w (" Warn_Err = ", E.Warn_Err);
w (" Warn_Runtime_Raise = ", E.Warn_Runtime_Raise);
w (" Warn_Chr = '" & E.Warn_Chr & ''');
- w (" Style = ", E.Style);
- w (" Serious = ", E.Serious);
w (" Uncond = ", E.Uncond);
w (" Msg_Cont = ", E.Msg_Cont);
w (" Deleted = ", E.Deleted);
@@ -371,7 +372,7 @@ package body Erroutc is
------------------------
function Get_Warning_Option (Id : Error_Msg_Id) return String is
- Style : constant Boolean := Errors.Table (Id).Style;
+ Is_Style : constant Boolean := Errors.Table (Id).Kind in Style;
Warn_Chr : constant String (1 .. 2) := Errors.Table (Id).Warn_Chr;
begin
@@ -380,7 +381,7 @@ package body Erroutc is
then
if Warn_Chr = "$ " then
return "-gnatel";
- elsif Style then
+ elsif Is_Style then
return "-gnaty" & Warn_Chr (1);
elsif Warn_Chr (2) = ' ' then
return "-gnatw" & Warn_Chr (1);
@@ -414,6 +415,32 @@ package body Erroutc is
return "";
end Get_Warning_Tag;
+ ------------------------------
+ -- Increase_Error_Msg_Count --
+ ------------------------------
+
+ procedure Increase_Error_Msg_Count (E : Error_Msg_Object) is
+
+ begin
+ case E.Kind is
+ when Info =>
+ Info_Messages := Info_Messages + 1;
+
+ when Warning | Style =>
+ Warnings_Detected := Warnings_Detected + 1;
+
+ when High_Check | Medium_Check | Low_Check =>
+ Check_Messages := Check_Messages + 1;
+
+ when Error =>
+ Total_Errors_Detected := Total_Errors_Detected + 1;
+ Serious_Errors_Detected := Serious_Errors_Detected + 1;
+
+ when Non_Serious_Error =>
+ Total_Errors_Detected := Total_Errors_Detected + 1;
+ end case;
+ end Increase_Error_Msg_Count;
+
--------------------
-- Has_Switch_Tag --
--------------------
@@ -421,14 +448,10 @@ package body Erroutc is
function Has_Switch_Tag (Id : Error_Msg_Id) return Boolean
is (Has_Switch_Tag (Errors.Table (Id)));
- function Has_Switch_Tag (E_Msg : Error_Msg_Object) return Boolean
- is
- Warn : constant Boolean := E_Msg.Warn;
- Style : constant Boolean := E_Msg.Style;
- Info : constant Boolean := E_Msg.Info;
- Warn_Chr : constant String (1 .. 2) := E_Msg.Warn_Chr;
+ function Has_Switch_Tag (E_Msg : Error_Msg_Object) return Boolean is
begin
- return (Warn or Style or Info) and then Warn_Chr /= " ";
+ return
+ E_Msg.Kind in Warning | Info | Style and then E_Msg.Warn_Chr /= " ";
end Has_Switch_Tag;
-------------
@@ -836,7 +859,7 @@ package body Erroutc is
-- For info messages, prefix message with "info: "
- elsif E_Msg.Info then
+ elsif E_Msg.Kind = Info then
Txt := new String'(SGR_Note & "info: " & SGR_Reset & Txt.all);
-- Warning treated as error
@@ -852,12 +875,12 @@ package body Erroutc is
-- Normal warning, prefix with "warning: "
- elsif E_Msg.Warn then
+ elsif E_Msg.Kind = Warning then
Txt := new String'(SGR_Warning & "warning: " & SGR_Reset & Txt.all);
-- No prefix needed for style message, "(style)" is there already
- elsif E_Msg.Style then
+ elsif E_Msg.Kind = Style then
if Txt (Txt'First .. Txt'First + 6) = "(style)" then
Txt := new String'(SGR_Warning & "(style)" & SGR_Reset
& Txt (Txt'First + 7 .. Txt'Last));
@@ -865,7 +888,7 @@ package body Erroutc is
-- No prefix needed for check message, severity is there already
- elsif E_Msg.Check then
+ elsif E_Msg.Kind in High_Check | Medium_Check | Low_Check then
-- The message format is "severity: ..."
--
@@ -989,35 +1012,46 @@ package body Erroutc is
-- Set initial values of globals (may be changed during scan)
- Is_Serious_Error := True;
+ Error_Msg_Kind := Error;
Is_Unconditional_Msg := False;
- Is_Warning_Msg := False;
Is_Runtime_Raise := False;
Warning_Msg_Char := " ";
-- Check style message
- Is_Style_Msg :=
- Msg'Length > 7
- and then Msg (Msg'First .. Msg'First + 6) = "(style)";
+ if Msg'Length > 7
+ and then Msg (Msg'First .. Msg'First + 6) = "(style)"
+ then
+ Error_Msg_Kind := Style;
- -- Check info message
+ -- Check info message
- Is_Info_Msg :=
- Msg'Length > 6
- and then Msg (Msg'First .. Msg'First + 5) = "info: ";
+ elsif Msg'Length > 6
+ and then Msg (Msg'First .. Msg'First + 5) = "info: "
+ then
+ Error_Msg_Kind := Info;
+
+ -- Check high check message
+
+ elsif Msg'Length > 6
+ and then Msg (Msg'First .. Msg'First + 5) = "high: "
+ then
+ Error_Msg_Kind := High_Check;
+
+ -- Check medium check message
- -- Check check message
+ elsif Msg'Length > 8
+ and then Msg (Msg'First .. Msg'First + 7) = "medium: "
+ then
+ Error_Msg_Kind := Medium_Check;
- Is_Check_Msg :=
- (Msg'Length > 8
- and then Msg (Msg'First .. Msg'First + 7) = "medium: ")
- or else
- (Msg'Length > 6
- and then Msg (Msg'First .. Msg'First + 5) = "high: ")
- or else
- (Msg'Length > 5
- and then Msg (Msg'First .. Msg'First + 4) = "low: ");
+ -- Check low check message
+
+ elsif Msg'Length > 5
+ and then Msg (Msg'First .. Msg'First + 4) = "low: "
+ then
+ Error_Msg_Kind := Low_Check;
+ end if;
end if;
Has_Double_Exclam := False;
@@ -1045,7 +1079,10 @@ package body Erroutc is
-- characters and not the generic ? or ?? warning insertion
-- characters.
- Is_Warning_Msg := not (Is_Style_Msg or else Is_Info_Msg);
+ if Error_Msg_Kind not in Style | Info then
+ Error_Msg_Kind := Warning;
+ end if;
+
J := J + 1;
Warning_Msg_Char := Parse_Message_Class;
@@ -1079,7 +1116,7 @@ package body Erroutc is
-- Non-serious error (| insertion)
elsif Msg (J) = '|' then
- Is_Serious_Error := False;
+ Error_Msg_Kind := Non_Serious_Error;
J := J + 1;
-- Error code ([] insertion)
@@ -1095,10 +1132,6 @@ package body Erroutc is
J := J + 1;
end if;
end loop;
-
- if Is_Info_Msg or Is_Warning_Msg or Is_Style_Msg or Is_Check_Msg then
- Is_Serious_Error := False;
- end if;
end Prescan_Message;
--------------------
@@ -1122,16 +1155,7 @@ package body Erroutc is
and then Errors.Table (E).Sptr.Ptr > From
and then Errors.Table (E).Sptr.Ptr < To
then
- if Errors.Table (E).Warn or else Errors.Table (E).Style then
- Warnings_Detected := Warnings_Detected - 1;
-
- else
- Total_Errors_Detected := Total_Errors_Detected - 1;
-
- if Errors.Table (E).Serious then
- Serious_Errors_Detected := Serious_Errors_Detected - 1;
- end if;
- end if;
+ Decrease_Error_Msg_Count (Errors.Table (E));
return True;
diff --git a/gcc/ada/erroutc.ads b/gcc/ada/erroutc.ads
index 6c3b9daef34..dac47725aae 100644
--- a/gcc/ada/erroutc.ads
+++ b/gcc/ada/erroutc.ads
@@ -31,6 +31,19 @@ with Types; use Types;
package Erroutc is
+ type Error_Msg_Type is
+ (Error, -- Default value
+ Non_Serious_Error,
+ -- An error message that is not considered fatal an the analys of
+ -- the source file can resume.
+ Warning,
+ Style, -- A special kind of warning only triggered by a style check
+ Info,
+ Low_Check, -- A type of GNATProve Check messages
+ Medium_Check, -- A type of GNATProve Check messages
+ High_Check -- A type of GNATProve Check messages
+ );
+
Class_Flag : Boolean := False;
-- This flag is set True when outputting a reference to a class-wide
-- type, and is used by Add_Class to insert 'Class at the proper point
@@ -63,34 +76,19 @@ package Erroutc is
-- Set true to indicate that the current message originates from a
-- Compile_Time_Warning or Compile_Time_Error pragma.
- Is_Serious_Error : Boolean := False;
- -- Set True for a serious error (i.e. any message that is not a warning
- -- or style message, and that does not contain a | insertion character).
-
Is_Unconditional_Msg : Boolean := False;
-- Set True to indicate that the current message contains the insertion
-- character ! and is thus to be treated as an unconditional message.
- Is_Warning_Msg : Boolean := False;
- -- Set True to indicate if current message is warning message (contains ?
- -- or contains < and Error_Msg_Warn is True).
-
Is_Runtime_Raise : Boolean := False;
-- Set to True to indicate that the current message is a warning about a
-- constraint error that will be raised at runtime (contains [ and switch
- -- -gnatwE was given).
+ -- -gnatwE was given)..
- Is_Info_Msg : Boolean := False;
- -- Set True to indicate that the current message starts with the characters
- -- "info: " and is to be treated as an information message. This string
- -- will be prepended to the message and all its continuations.
-
- Is_Check_Msg : Boolean := False;
- -- Set True to indicate that the current message starts with one of
- -- "high: ", "medium: ", "low: " and is to be treated as a check message.
+ Error_Msg_Kind : Error_Msg_Type := Error;
Warning_Msg_Char : String (1 .. 2);
- -- Warning switch, valid only if Is_Warning_Msg is True
+ -- Diagnostics switch:
-- " " -- ? or < appeared on its own in message
-- "? " -- ?? or << appeared in message
-- "x " -- ?x? or <x< appeared in message
@@ -100,10 +98,6 @@ package Erroutc is
-- In the case of the < sequences, this is set only if the message is
-- actually a warning, i.e. if Error_Msg_Warn is True
- Is_Style_Msg : Boolean := False;
- -- Set True to indicate if the current message is a style message
- -- (i.e. a message whose text starts with the characters "(style)").
-
Kill_Message : Boolean := False;
-- A flag used to kill weird messages (e.g. those containing uninterpreted
-- implicit type references) if we have already seen at least one message
@@ -230,15 +224,6 @@ package Erroutc is
-- True if the message originates from a Compile_Time_Warning or
-- Compile_Time_Error pragma
- Warn : Boolean;
- -- True if warning message
-
- Info : Boolean;
- -- True if info message
-
- Check : Boolean;
- -- True if check message
-
Warn_Err : Boolean;
-- True if this is a warning message which is to be treated as an error
-- as a result of a match with a Warning_As_Error pragma.
@@ -250,12 +235,6 @@ package Erroutc is
Warn_Chr : String (1 .. 2);
-- See Warning_Msg_Char
- Style : Boolean;
- -- True if style message (starts with "(style)")
-
- Serious : Boolean;
- -- True if serious error message (not a warning and no | character)
-
Uncond : Boolean;
-- True if unconditional message (i.e. insertion character ! appeared)
@@ -271,6 +250,8 @@ package Erroutc is
Deleted : Boolean;
-- If this flag is set, the message is not printed. This is used
-- in the circuit for deleting duplicate/redundant error messages.
+
+ Kind : Error_Msg_Type;
end record;
package Errors is new Table.Table (
@@ -472,6 +453,8 @@ package Erroutc is
procedure dmsg (Id : Error_Msg_Id);
-- Debugging routine to dump an error message
+ procedure Decrease_Error_Msg_Count (E : Error_Msg_Object);
+
procedure Debug_Output (N : Node_Id);
-- Called from Error_Msg_N and Error_Msg_NE to generate line of debug
-- output giving node number (of node N) if the debug X switch is set.
@@ -495,6 +478,9 @@ package Erroutc is
-- Given an error message ID, return tag showing warning message class, or
-- the null string if this option is not enabled or this is not a warning.
+ procedure Increase_Error_Msg_Count (E : Error_Msg_Object);
+ -- Increase the error count for the given kind of error message
+
function Matches (S : String; P : String) return Boolean;
-- Returns true if the String S matches the pattern P, which can contain
-- wildcard chars (*). The entire pattern must match the entire string.
@@ -533,19 +519,6 @@ package Erroutc is
procedure Prescan_Message (Msg : String);
-- Scans message text and sets the following variables:
--
- -- Is_Warning_Msg is set True if Msg is a warning message (contains a
- -- question mark character), and False otherwise.
- --
- -- Is_Style_Msg is set True if Msg is a style message (starts with
- -- "(style)") and False otherwise.
- --
- -- Is_Info_Msg is set True if Msg is an information message (starts
- -- with "info: ". Such messages must contain a ? sequence since they
- -- are also considered to be warning messages, and get a tag.
- --
- -- Is_Serious_Error is set to True unless the message is a warning or
- -- style message or contains the character | (non-serious error).
- --
-- Is_Unconditional_Msg is set True if the message contains the character
-- ! and is otherwise set False.
--
@@ -558,6 +531,17 @@ package Erroutc is
-- Has_Insertion_Line is set True if the message contains the character #
-- and is otherwise set False.
--
+ -- Error_Msg_Kind is set to one of the following values:
+ -- * Style - if the message starts with "(style)"
+ -- * Info - if the message starts with "info: "
+ -- * Warning - if the message contains a "?" and they
+ -- are neither Info or Style messages.
+ -- * Low_Check - if the message starts with "low: "
+ -- * Medium_Check - if the message starts with "medium: "
+ -- * High_Check - if the message starts with "high: "
+ -- * Non_Serious_Error - if the message contains "|"
+ -- * Error - otherwise
+ --
-- We need to know right away these aspects of a message, since we will
-- test these values before doing the full error scan.
--
diff --git a/gcc/ada/errutil.adb b/gcc/ada/errutil.adb
index 795b2f21962..450be6b9302 100644
--- a/gcc/ada/errutil.adb
+++ b/gcc/ada/errutil.adb
@@ -66,8 +66,7 @@ package body Errutil is
-- be one of the special insertion characters (see documentation in spec).
-- Flag is the location at which the error is to be posted, which is used
-- to determine whether or not the # insertion needs a file name. The
- -- variables Msg_Buffer, Msglen, Is_Style_Msg, Is_Warning_Msg, and
- -- Is_Unconditional_Msg are set on return.
+ -- variables Msg_Buffer, Msglen and Is_Unconditional_Msg are set on return.
------------------
-- Error_Msg_AP --
@@ -194,16 +193,13 @@ package body Errutil is
-- Immediate return if warning message and warnings are suppressed.
-- Note that style messages are not warnings for this purpose.
- if Is_Warning_Msg and then Warnings_Suppressed (Sptr) /= No_String then
+ if Error_Msg_Kind = Warning
+ and then Warnings_Suppressed (Sptr) /= No_String
+ then
Cur_Msg := No_Error_Msg;
return;
end if;
- -- Warning, Style and Info attributes are mutually exclusive
-
- pragma Assert (Boolean'Pos (Is_Warning_Msg) + Boolean'Pos (Is_Info_Msg) +
- Boolean'Pos (Is_Style_Msg) <= 1);
-
-- Otherwise build error message object for new message
Errors.Append
@@ -218,19 +214,15 @@ package body Errutil is
Line => Get_Physical_Line_Number (Sptr),
Col => Get_Column_Number (Sptr),
Compile_Time_Pragma => Is_Compile_Time_Msg,
- Warn => Is_Warning_Msg,
- Info => Is_Info_Msg,
- Check => Is_Check_Msg,
Warn_Err => Warning_Mode = Treat_As_Error,
Warn_Runtime_Raise => Is_Runtime_Raise,
Warn_Chr => Warning_Msg_Char,
- Style => Is_Style_Msg,
- Serious => Is_Serious_Error,
Uncond => Is_Unconditional_Msg,
Msg_Cont => Continuation,
- Deleted => False));
+ Deleted => False,
+ Kind => Error_Msg_Kind));
- Cur_Msg := Errors.Last;
+ Cur_Msg := Errors.Last;
Prev_Msg := No_Error_Msg;
Next_Msg := First_Error_Msg;
@@ -257,18 +249,14 @@ package body Errutil is
-- deletion, but otherwise such messages are discarded at this stage.
if Prev_Msg /= No_Error_Msg
- and then Errors.Table (Prev_Msg).Line =
- Errors.Table (Cur_Msg).Line
- and then Errors.Table (Prev_Msg).Sfile =
- Errors.Table (Cur_Msg).Sfile
+ and then Errors.Table (Prev_Msg).Line = Errors.Table (Cur_Msg).Line
+ and then Errors.Table (Prev_Msg).Sfile = Errors.Table (Cur_Msg).Sfile
then
-- Don't delete unconditional messages and at this stage, don't
-- delete continuation lines (we attempted to delete those earlier
-- if the parent message was deleted.
- if not Errors.Table (Cur_Msg).Uncond
- and then not Continuation
- then
+ if not Errors.Table (Cur_Msg).Uncond and then not Continuation then
-- Don't delete if prev msg is warning and new msg is an error.
-- This is because we don't want a real error masked by a warning.
@@ -276,13 +264,8 @@ package body Errutil is
-- are not unconditional) we do delete the message. This helps to
-- avoid junk extra messages from cascaded parsing errors
- if not (Errors.Table (Prev_Msg).Warn
- or else
- Errors.Table (Prev_Msg).Style)
- or else
- (Errors.Table (Cur_Msg).Warn
- or else
- Errors.Table (Cur_Msg).Style)
+ if Errors.Table (Prev_Msg).Kind not in Warning | Erroutc.Style
+ or else Errors.Table (Cur_Msg).Kind in Warning | Erroutc.Style
then
-- All tests passed, delete the message by simply returning
-- without any further processing.
@@ -310,27 +293,7 @@ package body Errutil is
Errors.Table (Cur_Msg).Next := Next_Msg;
- -- Bump appropriate statistics counts
-
- if Errors.Table (Cur_Msg).Info then
- Info_Messages := Info_Messages + 1;
-
- elsif Errors.Table (Cur_Msg).Warn
- or else Errors.Table (Cur_Msg).Style
- then
- Warnings_Detected := Warnings_Detected + 1;
-
- elsif Errors.Table (Cur_Msg).Check then
- Check_Messages := Check_Messages + 1;
-
- else
- Total_Errors_Detected := Total_Errors_Detected + 1;
-
- if Errors.Table (Cur_Msg).Serious then
- Serious_Errors_Detected := Serious_Errors_Detected + 1;
- end if;
- end if;
-
+ Increase_Error_Msg_Count (Errors.Table (Cur_Msg));
end Error_Msg;
-----------------
--
2.43.0
