https://gcc.gnu.org/g:b3d8599685cb8e018b636c99d29f32b1c5ef9431
commit r17-953-gb3d8599685cb8e018b636c99d29f32b1c5ef9431 Author: Viljar Indus <[email protected]> Date: Sat Mar 21 03:01:33 2026 +0200 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: --- gcc/ada/errout.adb | 32 +++--------------- gcc/ada/errout.ads | 4 +-- gcc/ada/erroutc.adb | 96 ++++++++++++++++++++++++----------------------------- gcc/ada/erroutc.ads | 12 +++++-- gcc/ada/par-ch5.adb | 3 +- 5 files changed, 62 insertions(+), 85 deletions(-) diff --git a/gcc/ada/errout.adb b/gcc/ada/errout.adb index 61fb845ea086..8c34cb4eb442 100644 --- 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 4c906686b874..be828d55c697 100644 --- 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 91bb30f0a582..ae1f5cce6bf8 100644 --- 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 5efc64feeff9..26ffcc0fe6cd 100644 --- 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 e9dfec36d8f6..f66d77314f32 100644 --- 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;
