ada: Add Filter_And_Delete_Errors

gcc/ada/ChangeLog:

	* errout.adb (Remove_Warning_Messages): Use
	Filter_And_Delete_Errors.
	* errout.ads (Purge_Messages): Renamed to
	Delete_Error_Msgs_In_Range.
	* erroutc.adb (Filter_And_Delete_Errors): New procedure.
	(Purge_Messages): Renamed to Delete_Error_Msgs_In_Range.
	* erroutc.ads (Filter_And_Delete_Errors): New procedure.
	(Purge_Messages): Renamed to Delete_Error_Msgs_In_Range.
	* par-ch5.adb (Missing_Begin): call Delete_Error_Msgs_In_Range.

diff --git a/gcc/ada/errout.adb b/gcc/ada/errout.adb
index 61fb845ea0865c99db61eae0d277caf2b321e146..8c34cb4eb4425a552edcedf36a7e10a3357dec5f 100644 (file)
--- a/gcc/ada/errout.adb
+++ b/gcc/ada/errout.adb
@@ -3360,12 +3360,14 @@ package body Errout is
 
       function Check_For_Warning (N : Node_Id) return Traverse_Result is
          Loc : constant Source_Ptr := Sloc (N);
-         E   : Error_Msg_Id;
 
          function To_Be_Removed (E : Error_Msg_Id) return Boolean;
          --  Returns True for a message that is to be removed. Also adjusts
          --  warning count appropriately.
 
+         procedure Remove_Errors is new
+           Filter_And_Delete_Errors (To_Be_Removed);
+
          -------------------
          -- To_Be_Removed --
          -------------------
@@ -3400,33 +3402,7 @@ package body Errout is
       --  Start of processing for Check_For_Warnings
 
       begin
-         --  Remove the first messages from the error chain.
-         --  ??? Why not delete them like the others?
-
-         while To_Be_Removed (First_Error_Msg) loop
-            Decrease_Error_Msg_Count (Errors.Table (First_Error_Msg));
-            First_Error_Msg := Errors.Table (First_Error_Msg).Next;
-         end loop;
-
-         if First_Error_Msg = No_Error_Msg then
-            Last_Error_Msg := No_Error_Msg;
-         end if;
-
-         E := First_Error_Msg;
-         while E /= No_Error_Msg loop
-            while To_Be_Removed (Errors.Table (E).Next) loop
-               Delete_Error_Msg (Errors.Table (E).Next);
-
-               Errors.Table (E).Next :=
-                 Errors.Table (Errors.Table (E).Next).Next;
-
-               if Errors.Table (E).Next = No_Error_Msg then
-                  Last_Error_Msg := E;
-               end if;
-            end loop;
-
-            E := Errors.Table (E).Next;
-         end loop;
+         Remove_Errors;
 
          --  Warnings may have been posted on subexpressions of original tree
 

diff --git a/gcc/ada/errout.ads b/gcc/ada/errout.ads
index 4c906686b874e02add37bfa96f34594b3bb91ea2..be828d55c6972861fa49e6dd6dbe7dabc287c337 100644 (file)
--- a/gcc/ada/errout.ads
+++ b/gcc/ada/errout.ads
@@ -907,8 +907,8 @@ package Errout is
    --  where the expression is parenthesized, an attempt is made to include
    --  the parentheses (i.e. to return the location of the final paren).
 
-   procedure Purge_Messages (From : Source_Ptr; To : Source_Ptr)
-     renames Erroutc.Purge_Messages;
+   procedure Delete_Error_Msgs_In_Range (From : Source_Ptr; To : Source_Ptr)
+   renames Erroutc.Delete_Error_Msgs_In_Range;
    --  All error messages whose location is in the range From .. To (not
    --  including the end points) will be deleted from the error listing.
 

diff --git a/gcc/ada/erroutc.adb b/gcc/ada/erroutc.adb
index 91bb30f0a582b827532e2ab447d2616c41fa48bd..ae1f5cce6bf8a90d6a69b14244ea1b01695dd9f4 100644 (file)
--- a/gcc/ada/erroutc.adb
+++ b/gcc/ada/erroutc.adb
@@ -273,6 +273,23 @@ package body Erroutc is
       end if;
    end Debug_Output;
 
+   ------------------------------
+   -- Filter_And_Delete_Errors --
+   ------------------------------
+
+   procedure Filter_And_Delete_Errors is
+      E : Error_Msg_Id;
+   begin
+      E := First_Error_Msg;
+      while E /= No_Error_Msg loop
+         if Filter (E) then
+            Delete_Error_Msg (E);
+         end if;
+
+         E := Errors.Table (E).Next;
+      end loop;
+   end Filter_And_Delete_Errors;
+
    ----------------------
    -- Delete_Error_Msg --
    ----------------------
@@ -285,6 +302,33 @@ package body Erroutc is
       end if;
    end Delete_Error_Msg;
 
+   --------------------------------
+   -- Delete_Error_Msgs_In_Range --
+   --------------------------------
+
+   procedure Delete_Error_Msgs_In_Range (From : Source_Ptr; To : Source_Ptr) is
+
+      function Error_in_Range (E : Error_Msg_Id) return Boolean;
+      --  Returns True for a message that is to be purged. Also adjusts
+      --  error counts appropriately.
+
+      procedure Delete_Errors is new Filter_And_Delete_Errors (Error_in_Range);
+
+      --------------------
+      -- Error_in_Range --
+      --------------------
+
+      function Error_in_Range (E : Error_Msg_Id) return Boolean
+      is (E /= No_Error_Msg
+          and then Errors.Table (E).Sptr.Ptr > From
+          and then Errors.Table (E).Sptr.Ptr < To);
+
+   --  Start of processing for Delete_Error_Msgs_In_Range
+
+   begin
+      Delete_Errors;
+   end Delete_Error_Msgs_In_Range;
+
    -----------
    -- dedit --
    -----------
@@ -1324,58 +1368,6 @@ package body Erroutc is
       end loop;
    end Prescan_Message;
 
-   --------------------
-   -- Purge_Messages --
-   --------------------
-
-   procedure Purge_Messages (From : Source_Ptr; To : Source_Ptr) is
-      E : Error_Msg_Id;
-
-      function To_Be_Purged (E : Error_Msg_Id) return Boolean;
-      --  Returns True for a message that is to be purged. Also adjusts
-      --  error counts appropriately.
-
-      ------------------
-      -- To_Be_Purged --
-      ------------------
-
-      function To_Be_Purged (E : Error_Msg_Id) return Boolean is
-      begin
-         if E /= No_Error_Msg
-           and then Errors.Table (E).Sptr.Ptr > From
-           and then Errors.Table (E).Sptr.Ptr < To
-         then
-            return True;
-
-         else
-            return False;
-         end if;
-      end To_Be_Purged;
-
-   --  Start of processing for Purge_Messages
-
-   begin
-      --  Remove the first messages from the error chain.
-      --  ??? Why not delete them like the others?
-
-      while To_Be_Purged (First_Error_Msg) loop
-         Decrease_Error_Msg_Count (Errors.Table (First_Error_Msg));
-         First_Error_Msg := Errors.Table (First_Error_Msg).Next;
-      end loop;
-
-      E := First_Error_Msg;
-      while E /= No_Error_Msg loop
-         while To_Be_Purged (Errors.Table (E).Next) loop
-            Delete_Error_Msg (Errors.Table (E).Next);
-
-            Errors.Table (E).Next :=
-              Errors.Table (Errors.Table (E).Next).Next;
-         end loop;
-
-         E := Errors.Table (E).Next;
-      end loop;
-   end Purge_Messages;
-
    ----------------
    -- Same_Error --
    ----------------

diff --git a/gcc/ada/erroutc.ads b/gcc/ada/erroutc.ads
index 5efc64feeff9e973b312e6e04a286b1e2673b2a2..26ffcc0fe6cdd0f6cfb0ab747df6c6f6144a6d30 100644 (file)
--- a/gcc/ada/erroutc.ads
+++ b/gcc/ada/erroutc.ads
@@ -742,9 +742,17 @@ package Erroutc is
    procedure Delete_Error_Msg (E : Error_Msg_Id);
    --  Delete an error msg if not already deleted and adjust message count
 
-   procedure Purge_Messages (From : Source_Ptr; To : Source_Ptr);
+   procedure Delete_Error_Msgs_In_Range (From : Source_Ptr; To : Source_Ptr);
    --  All error messages whose location is in the range From .. To (not
-   --  including the end points) will be deleted from the error listing.
+   --  including the end points) will be marked as deleted in the error
+   --  listing.
+
+   generic
+      with function Filter (E : Error_Msg_Id) return Boolean is <>;
+   procedure Filter_And_Delete_Errors;
+   pragma Inline (Filter_And_Delete_Errors);
+   --  Iterate over all of the errors in the error chain and mark all messages
+   --  as deleted if they match the Filter.
 
    function Same_Error (M1, M2 : Error_Msg_Id) return Boolean;
    --  See if two messages have the same text. Returns true if the text of the

diff --git a/gcc/ada/par-ch5.adb b/gcc/ada/par-ch5.adb
index e9dfec36d8f673a03255afc1d239c1dd037bae87..f66d77314f32141b987de6a479e556004a911a18 100644 (file)
--- a/gcc/ada/par-ch5.adb
+++ b/gcc/ada/par-ch5.adb
@@ -2137,7 +2137,8 @@ package body Ch5 is
             --  can cause a lot of havoc, and it is better not to dump these
             --  cascaded messages on the user.
 
-            Purge_Messages (Get_Location (Missing_Begin_Msg), Prev_Token_Ptr);
+            Delete_Error_Msgs_In_Range
+              (Get_Location (Missing_Begin_Msg), Prev_Token_Ptr);
          end if;
       end Missing_Begin;