ada: Improve Warning_Treated_As_Error

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.

diff --git a/gcc/ada/errout.adb b/gcc/ada/errout.adb
index 58ba6be6189f5d4509288864f5a7cc4fabd0a0fa..ae7df04b91f8674aedebbcbf6bb1d424dfdf3efe 100644 (file)
--- 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 fa4dcb80ff4d2fc785370d678287bbe0f07b6aca..26988dc84886f4faa57bf433e39822a941822068 100644 (file)
--- 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 b5d0578f99f0e4f7f0433e7ecb758ab0df0aa423..94fcddd84a4bfebad6e2b2d67ffb7e6eb1079ee9 100644 (file)
--- 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