From: Viljar Indus <in...@adacore.com>
gcc/ada/ChangeLog:
* errout.adb (Error_Msg_Internal): Use the new
Warning_Treated_As_Error function.
* erroutc.adb (Get_Warning_Option): Add new version of this
function that operates on the Error_Msg_Object directly instead
of the Error_Id. Update the existing function to call the new
version interanlly.
(Get_Warning_Tag): Likewise.
(Warning_Treated_As_Error): Add a new method that combines the
checks for the error message itself and its tag.
* erroutc.ads (Get_Warning_Option): Add new spec.
(Get_Warning_Option): Likewise.
(Get_Warning_Option): Likewise.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/errout.adb | 3 +--
gcc/ada/erroutc.adb | 30 ++++++++++++++++++++++++------
gcc/ada/erroutc.ads | 8 +++++++-
3 files changed, 32 insertions(+), 9 deletions(-)
diff --git a/gcc/ada/errout.adb b/gcc/ada/errout.adb
index 58ba6be6189..ae7df04b91f 100644
--- a/gcc/ada/errout.adb
+++ b/gcc/ada/errout.adb
@@ -1417,8 +1417,7 @@ package body Errout is
Errors.Table (Cur_Msg).Warn_Err :=
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))
+ and then (Warning_Treated_As_Error (Errors.Table (Cur_Msg))
or else Is_Runtime_Raise);
-- If immediate errors mode set, output error message now. Also output
diff --git a/gcc/ada/erroutc.adb b/gcc/ada/erroutc.adb
index fa4dcb80ff4..26988dc8488 100644
--- a/gcc/ada/erroutc.adb
+++ b/gcc/ada/erroutc.adb
@@ -361,11 +361,16 @@ package body Erroutc is
------------------------
function Get_Warning_Option (Id : Error_Msg_Id) return String is
- Is_Style : constant Boolean := Errors.Table (Id).Kind in Style;
- Warn_Chr : constant String (1 .. 2) := Errors.Table (Id).Warn_Chr;
+ begin
+ return Get_Warning_Option (Errors.Table (Id));
+ end Get_Warning_Option;
+
+ function Get_Warning_Option (E : Error_Msg_Object) return String is
+ Is_Style : constant Boolean := E.Kind in Style;
+ Warn_Chr : constant String (1 .. 2) := E.Warn_Chr;
begin
- if Has_Switch_Tag (Errors.Table (Id))
+ if Has_Switch_Tag (E)
and then Warn_Chr (1) /= '?'
then
if Warn_Chr = "$ " then
@@ -387,11 +392,16 @@ package body Erroutc is
---------------------
function Get_Warning_Tag (Id : Error_Msg_Id) return String is
- Warn_Chr : constant String (1 .. 2) := Errors.Table (Id).Warn_Chr;
- Option : constant String := Get_Warning_Option (Id);
+ begin
+ return Get_Warning_Tag (Errors.Table (Id));
+ end Get_Warning_Tag;
+
+ function Get_Warning_Tag (E : Error_Msg_Object) return String is
+ Warn_Chr : constant String (1 .. 2) := E.Warn_Chr;
+ Option : constant String := Get_Warning_Option (E);
begin
- if Has_Switch_Tag (Id) then
+ if Has_Switch_Tag (E) then
if Warn_Chr = "? " then
return "[enabled by default]";
elsif Warn_Chr = "* " then
@@ -2117,6 +2127,14 @@ package body Erroutc is
return False;
end Warning_Treated_As_Error;
+ function Warning_Treated_As_Error (E : Error_Msg_Object) return Boolean is
+
+ begin
+ return
+ Warning_Treated_As_Error (E.Text.all)
+ or else Warning_Treated_As_Error (Get_Warning_Tag (E));
+ end Warning_Treated_As_Error;
+
-------------------------
-- Warnings_Suppressed --
-------------------------
diff --git a/gcc/ada/erroutc.ads b/gcc/ada/erroutc.ads
index b5d0578f99f..94fcddd84a4 100644
--- a/gcc/ada/erroutc.ads
+++ b/gcc/ada/erroutc.ads
@@ -626,11 +626,13 @@ package Erroutc is
-- are marked with the Deleted flag set to True.
function Get_Warning_Option (Id : Error_Msg_Id) return String;
+ function Get_Warning_Option (E : Error_Msg_Object) return String;
-- Returns the warning switch causing this warning message or an empty
-- string is there is none..
function Get_Warning_Tag (Id : Error_Msg_Id) return String;
- -- Given an error message ID, return tag showing warning message class, or
+ function Get_Warning_Tag (E : Error_Msg_Object) return String;
+ -- Given an error message, 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);
@@ -872,6 +874,10 @@ package Erroutc is
-- given by Warning_As_Error pragmas, as stored in the Warnings_As_Errors
-- table.
+ function Warning_Treated_As_Error (E : Error_Msg_Object) return Boolean;
+ -- Returns true if a Warning_As_Error pragma matches either the error text
+ -- or the warning tag of the message.
+
procedure Write_Error_Summary;
-- Write error summary
--
2.43.0
