https://gcc.gnu.org/g:f6414d2be0944229c0fac376ce4c92027f5cb91d
commit r17-954-gf6414d2be0944229c0fac376ce4c92027f5cb91d Author: Viljar Indus <[email protected]> Date: Sat Mar 21 03:25:05 2026 +0200 ada: Add Delete_Error_And_Continuation_Msgs and refactor duplicate code in errout and errutil Packages errout and errutil were sharing a lot of code. Extract all of the common functionality to erroutc. Extract Delete_Specifically_Suppressed_Warnings and Set_Prev_Pointers. gcc/ada/ChangeLog: * errout.adb (Delete_Warning_And_Continuations): use Delete_Error_And_Continuation_Msgs. (Output_Messages): Call new refactored subprograms. (Delete_Specifically_Suppressed_Warnings): New procedure. * (Set_Prev_Pointers): New procedure. * (Finalize): use Delete_Specifically_Suppressed_Warnigns and Set_Prev_Pointers. (Finalize): use Delete_Error_And_Continuation_Msgs. * erroutc.adb (Delete_Error_And_Continuation_Msgs): New procedure. (Remove_Duplicate_Errors): New_Function. (Write_All_Errors_In_Brief_Format): New function. (Write_All_Errors_In_Verbose_Format): New function. (Write_Error_Summary): New function. * erroutc.ads (Delete_Error_And_Continuation_Msgs): Likewise. (Remove_Duplicate_Errors): Likewise. (Write_All_Errors_In_Brief_Format): Likewise. (Write_All_Errors_In_Verbose_Format): Likewise. (Write_Error_Summary): Likewise. * errutil.adb (Finalize): Call new refactored subprograms. Diff: --- gcc/ada/errout.adb | 261 +++++++++++++++++++--------------------------------- gcc/ada/erroutc.adb | 101 ++++++++++++++++++++ gcc/ada/erroutc.ads | 15 +++ gcc/ada/errutil.adb | 90 ++++++------------ 4 files changed, 242 insertions(+), 225 deletions(-) diff --git a/gcc/ada/errout.adb b/gcc/ada/errout.adb index 8c34cb4eb442..f7fd92e51bd8 100644 --- a/gcc/ada/errout.adb +++ b/gcc/ada/errout.adb @@ -101,6 +101,9 @@ package body Errout is (Printer : in out SARIF_Printer); -- Fill the printer with the unique diagnostic and switch id. + procedure Delete_Specifically_Suppressed_Warnings; + -- Mark any messages suppressed by specific warnings as Deleted + procedure Error_Msg_Internal (Msg : String; Span : Source_Span; @@ -177,6 +180,9 @@ package body Errout is -- in order to guard against cascaded errors. Note that this call has an -- effect for a serious error only. + procedure Set_Prev_Pointers; + -- Set previous pointers for all of the error messages in the error chain + procedure Set_Qualification (N : Nat; E : Entity_Id); -- Outputs up to N levels of qualification for the given entity. For -- example, the entity A.B.C.D will output B.C. if N = 2. @@ -221,6 +227,11 @@ package body Errout is -- " " returns "?" -- other trimmed, prefixed and suffixed with "?". + procedure Write_All_Errors_In_Verbose_Format; + -- Emit all error messages in the errors table using the verbose format + -- activated by -gnatv where the error line is also printed along with the + -- error msg. + ----------------------------------------- -- Add_Unique_Diagnostics_And_Switches -- ----------------------------------------- @@ -342,6 +353,45 @@ package body Errout is end loop; end Add_Unique_Diagnostics_And_Switches; + --------------------------------------------- + -- Delete_Specifically_Suppressed_Warnings -- + --------------------------------------------- + + procedure Delete_Specifically_Suppressed_Warnings is + function Warning_Is_Suppressed (E : Error_Msg_Id) return Boolean; + -- Check if the warning is suppressed in either its posted or original + -- location. + + --------------------------- + -- Warning_Is_Suppressed -- + --------------------------- + + function Warning_Is_Suppressed (E : Error_Msg_Id) return Boolean is + CE : Error_Msg_Object renames Errors.Table (E); + Tag : constant String := Get_Warning_Tag (E); + begin + return + Warning_Is_Suppressed (CE.Sptr.Ptr, CE.Text, Tag) + or else Warning_Is_Suppressed (CE.Optr.Ptr, CE.Text, Tag); + end Warning_Is_Suppressed; + + Cur : Error_Msg_Id := First_Error_Msg; + + -- Start of processing for Delete_Specifically_Suppressed_Warnings + + begin + while Cur /= No_Error_Msg loop + if Errors.Table (Cur).Kind = Warning + and then not Errors.Table (Cur).Deleted + and then Warning_Is_Suppressed (Cur) + then + Delete_Error_And_Continuation_Msgs (Cur); + end if; + + Cur := Errors.Table (Cur).Next; + end loop; + end Delete_Specifically_Suppressed_Warnings; + ----------------------- -- Change_Error_Text -- ----------------------- @@ -388,19 +438,9 @@ package body Errout is -------------------------------------- procedure Delete_Warning_And_Continuations (Msg : Error_Msg_Id) is - Id : Error_Msg_Id; - begin pragma Assert (not Errors.Table (Msg).Msg_Cont); - - Id := Msg; - loop - Delete_Error_Msg (Id); - - Id := Errors.Table (Id).Next; - exit when Id = No_Error_Msg; - exit when not Errors.Table (Id).Msg_Cont; - end loop; + Delete_Error_And_Continuation_Msgs (Msg); end Delete_Warning_And_Continuations; ------------------ @@ -1899,91 +1939,10 @@ package body Errout is -------------- procedure Finalize (Last_Call : Boolean) is - Cur : Error_Msg_Id; - Nxt : Error_Msg_Id; - F : Error_Msg_Id; - - function Warning_Is_Suppressed (E : Error_Msg_Id) return Boolean; - -- Check if the warning is suppressed in either its posted or original - -- location. - - --------------------------- - -- Warning_Is_Suppressed -- - --------------------------- - - function Warning_Is_Suppressed (E : Error_Msg_Id) return Boolean is - CE : Error_Msg_Object renames Errors.Table (E); - Tag : constant String := Get_Warning_Tag (E); - begin - return - Warning_Is_Suppressed (CE.Sptr.Ptr, CE.Text, Tag) - or else Warning_Is_Suppressed (CE.Optr.Ptr, CE.Text, Tag); - end Warning_Is_Suppressed; - - -- Start of processing for Finalize - begin - -- Set Prev pointers - - Cur := First_Error_Msg; - while Cur /= No_Error_Msg loop - Nxt := Errors.Table (Cur).Next; - exit when Nxt = No_Error_Msg; - Errors.Table (Nxt).Prev := Cur; - Cur := Nxt; - end loop; - - -- Eliminate any duplicated error messages from the list. This is - -- done after the fact to avoid problems with Change_Error_Text. - - Cur := First_Error_Msg; - while Cur /= No_Error_Msg loop - Nxt := Errors.Table (Cur).Next; - - F := Nxt; - while F /= No_Error_Msg - and then Errors.Table (F).Sptr.Ptr = Errors.Table (Cur).Sptr.Ptr - loop - Check_Duplicate_Message (Cur, F); - F := Errors.Table (F).Next; - end loop; - - Cur := Nxt; - end loop; - - -- Mark any messages suppressed by specific warnings as Deleted - - Cur := First_Error_Msg; - while Cur /= No_Error_Msg loop - if Errors.Table (Cur).Kind = Warning - and then not Errors.Table (Cur).Deleted - and then Warning_Is_Suppressed (Cur) - then - Delete_Error_Msg (Cur); - - -- If this is a continuation, delete previous parts of message - - F := Cur; - while Errors.Table (F).Msg_Cont loop - F := Errors.Table (F).Prev; - exit when F = No_Error_Msg; - Delete_Error_Msg (F); - end loop; - - -- Delete any following continuations - - F := Cur; - loop - F := Errors.Table (F).Next; - exit when F = No_Error_Msg; - exit when not Errors.Table (F).Msg_Cont; - Delete_Error_Msg (F); - end loop; - end if; - - Cur := Errors.Table (Cur).Next; - end loop; - + Set_Prev_Pointers; + Delete_Duplicate_Errors; + Delete_Specifically_Suppressed_Warnings; Finalize_Called := True; -- Check consistency of specific warnings (may add warnings). We only @@ -2805,39 +2764,9 @@ package body Errout is -- Local subprograms - procedure Emit_Error_Msgs; - -- Emit all error messages in the table use the pretty printed format if - -- -gnatdF is used otherwise use the brief format. - procedure Write_Header (Sfile : Source_File_Index); -- Write header line (compiling or checking given file) - procedure Write_Max_Errors; - -- Write message if max errors reached - - -------------------- - -- Emit_Error_Msgs -- - --------------------- - - procedure Emit_Error_Msgs is - E : Error_Msg_Id; - begin - Set_Standard_Error; - - E := First_Error_Msg; - while E /= No_Error_Msg loop - if not Errors.Table (E).Deleted then - Output_Msg_Location (E); - Output_Msg_Text (E); - Write_Eol; - end if; - - E := Errors.Table (E).Next; - end loop; - - Set_Standard_Output; - end Emit_Error_Msgs; - ------------------ -- Write_Header -- ------------------ @@ -2865,30 +2794,6 @@ package body Errout is end if; end Write_Header; - ---------------------- - -- Write_Max_Errors -- - ---------------------- - - procedure Write_Max_Errors is - begin - if Maximum_Messages /= 0 then - if Warnings_Detected >= Maximum_Messages then - Set_Standard_Error; - Write_Line ("maximum number of warnings output"); - Write_Line ("any further warnings suppressed"); - Set_Standard_Output; - end if; - - -- If too many errors print message - - if Total_Errors_Detected >= Maximum_Messages then - Set_Standard_Error; - Write_Line ("fatal error: maximum number of errors detected"); - Set_Standard_Output; - end if; - end if; - end Write_Max_Errors; - -- Local variables E : Error_Msg_Id; @@ -2999,7 +2904,7 @@ package body Errout is elsif Debug_Flag_FF then Erroutc.Pretty_Emitter.Print_Error_Messages; else - Emit_Error_Msgs; + Write_All_Errors_In_Brief_Format; end if; end if; @@ -3169,20 +3074,7 @@ package body Errout is Write_Header (Main_Source_File); end if; - E := First_Error_Msg; - - -- Loop through error lines - - while E /= No_Error_Msg loop - if Errors.Table (E).Deleted then - E := Errors.Table (E).Next; - else - Write_Eol; - Output_Source_Line - (Errors.Table (E).Line, Errors.Table (E).Sfile, True); - Output_Error_Msgs (E); - end if; - end loop; + Write_All_Errors_In_Verbose_Format; end if; -- Output error summary if verbose or full list mode @@ -4219,6 +4111,24 @@ package body Errout is end if; end Set_Posted; + ----------------------- + -- Set_Prev_Pointers -- + ----------------------- + + procedure Set_Prev_Pointers is + Cur : Error_Msg_Id; + Nxt : Error_Msg_Id; + + begin + Cur := First_Error_Msg; + while Cur /= No_Error_Msg loop + Nxt := Errors.Table (Cur).Next; + exit when Nxt = No_Error_Msg; + Errors.Table (Nxt).Prev := Cur; + Cur := Nxt; + end loop; + end Set_Prev_Pointers; + ----------------------- -- Set_Qualification -- ----------------------- @@ -4536,4 +4446,27 @@ package body Errout is end if; end Warn_Insertion; + ---------------------------------------- + -- Write_All_Errors_In_Verbose_Format -- + ---------------------------------------- + + procedure Write_All_Errors_In_Verbose_Format is + E : Error_Msg_Id; + begin + E := First_Error_Msg; + + -- Loop through error lines + + while E /= No_Error_Msg loop + if Errors.Table (E).Deleted then + E := Errors.Table (E).Next; + else + Write_Eol; + Output_Source_Line + (Errors.Table (E).Line, Errors.Table (E).Sfile, True); + Output_Error_Msgs (E); + end if; + end loop; + end Write_All_Errors_In_Verbose_Format; + end Errout; diff --git a/gcc/ada/erroutc.adb b/gcc/ada/erroutc.adb index ae1f5cce6bf8..b4f136e54651 100644 --- a/gcc/ada/erroutc.adb +++ b/gcc/ada/erroutc.adb @@ -290,6 +290,31 @@ package body Erroutc is end loop; end Filter_And_Delete_Errors; + ----------------------------- + -- Delete_Duplicate_Errors -- + ----------------------------- + + procedure Delete_Duplicate_Errors is + Cur : Error_Msg_Id; + Nxt : Error_Msg_Id; + F : Error_Msg_Id; + begin + Cur := First_Error_Msg; + while Cur /= No_Error_Msg loop + Nxt := Errors.Table (Cur).Next; + + F := Nxt; + while F /= No_Error_Msg + and then Errors.Table (F).Sptr.Ptr = Errors.Table (Cur).Sptr.Ptr + loop + Check_Duplicate_Message (Cur, F); + F := Errors.Table (F).Next; + end loop; + + Cur := Nxt; + end loop; + end Delete_Duplicate_Errors; + ---------------------- -- Delete_Error_Msg -- ---------------------- @@ -329,6 +354,35 @@ package body Erroutc is Delete_Errors; end Delete_Error_Msgs_In_Range; + ---------------------------------------- + -- Delete_Error_And_Continuation_Msgs -- + ---------------------------------------- + + procedure Delete_Error_And_Continuation_Msgs (E : Error_Msg_Id) is + F : Error_Msg_Id; + begin + Delete_Error_Msg (E); + + -- If this is a continuation, delete previous parts of message + + F := E; + while Errors.Table (F).Msg_Cont loop + F := Errors.Table (F).Prev; + exit when F = No_Error_Msg; + Delete_Error_Msg (F); + end loop; + + -- Delete any following continuations + + F := E; + loop + F := Errors.Table (F).Next; + exit when F = No_Error_Msg; + exit when not Errors.Table (F).Msg_Cont; + Delete_Error_Msg (F); + end loop; + end Delete_Error_And_Continuation_Msgs; + ----------- -- dedit -- ----------- @@ -2312,6 +2366,29 @@ package body Erroutc is end if; end Warnings_Suppressed; + -------------------------------------- + -- Write_All_Errors_In_Brief_Format -- + -------------------------------------- + + procedure Write_All_Errors_In_Brief_Format is + E : Error_Msg_Id; + begin + Set_Standard_Error; + + E := First_Error_Msg; + while E /= No_Error_Msg loop + if not Errors.Table (E).Deleted then + Output_Msg_Location (E); + Output_Msg_Text (E); + Write_Eol; + end if; + + E := Errors.Table (E).Next; + end loop; + + Set_Standard_Output; + end Write_All_Errors_In_Brief_Format; + ------------------------- -- Write_Error_Summary -- ------------------------- @@ -2406,4 +2483,28 @@ package body Erroutc is Set_Standard_Output; end Write_Error_Summary; + ---------------------- + -- Write_Max_Errors -- + ---------------------- + + procedure Write_Max_Errors is + begin + if Maximum_Messages /= 0 then + if Warnings_Detected >= Maximum_Messages then + Set_Standard_Error; + Write_Line ("maximum number of warnings output"); + Write_Line ("any further warnings suppressed"); + Set_Standard_Output; + end if; + + -- If too many errors print message + + if Total_Errors_Detected >= Maximum_Messages then + Set_Standard_Error; + Write_Line ("fatal error: maximum number of errors detected"); + Set_Standard_Output; + end if; + end if; + end Write_Max_Errors; + end Erroutc; diff --git a/gcc/ada/erroutc.ads b/gcc/ada/erroutc.ads index 26ffcc0fe6cd..aa49a410590e 100644 --- a/gcc/ada/erroutc.ads +++ b/gcc/ada/erroutc.ads @@ -739,6 +739,10 @@ package Erroutc is -- Tag used at the end of warning messages that were converted by -- pragma Warning_As_Error. + procedure Delete_Duplicate_Errors; + -- Delete dupleicate error messages from the list. This is + -- done after the fact to avoid problems with Change_Error_Text. + procedure Delete_Error_Msg (E : Error_Msg_Id); -- Delete an error msg if not already deleted and adjust message count @@ -747,6 +751,11 @@ package Erroutc is -- including the end points) will be marked as deleted in the error -- listing. + procedure Delete_Error_And_Continuation_Msgs (E : Error_Msg_Id); + -- Delete E and all continuations following E and if E was a continuation + -- then all of the continuations before it and the non-continuation message + -- that it was attached to. + generic with function Filter (E : Error_Msg_Id) return Boolean is <>; procedure Filter_And_Delete_Errors; @@ -922,7 +931,13 @@ package Erroutc is -- Returns true if a Warning_As_Error pragma matches either the error text -- or the warning tag of the message. + procedure Write_All_Errors_In_Brief_Format; + -- Emit all error messages in the errors table using the brief format + procedure Write_Error_Summary; -- Write error summary + procedure Write_Max_Errors; + -- Write message if max errors reached + end Erroutc; diff --git a/gcc/ada/errutil.adb b/gcc/ada/errutil.adb index f1f9f13391b5..0f88f2d4c48d 100644 --- a/gcc/ada/errutil.adb +++ b/gcc/ada/errutil.adb @@ -66,6 +66,11 @@ package body Errutil is -- to determine whether or not the # insertion needs a file name. The -- variables Msg_Buffer, Msglen and Is_Unconditional_Msg are set on return. + procedure Write_All_Errors_In_Verbose_Format (Source_Type : String); + -- Emit all error messages in the errors table using the verbose format + -- activated by -gnatv where the error line is also printed along with the + -- error msg. + ------------------ -- Error_Msg_AP -- ------------------ @@ -318,47 +323,16 @@ package body Errutil is -------------- procedure Finalize (Source_Type : String := "project") is - Cur : Error_Msg_Id; - Nxt : Error_Msg_Id; - E, F : Error_Msg_Id; + E : Error_Msg_Id; Err_Flag : Boolean; begin - -- Eliminate any duplicated error messages from the list. This is - -- done after the fact to avoid problems with Change_Error_Text. - - Cur := First_Error_Msg; - while Cur /= No_Error_Msg loop - Nxt := Errors.Table (Cur).Next; - - F := Nxt; - while F /= No_Error_Msg - and then Errors.Table (F).Sptr = Errors.Table (Cur).Sptr - loop - Check_Duplicate_Message (Cur, F); - F := Errors.Table (F).Next; - end loop; - - Cur := Nxt; - end loop; + Delete_Duplicate_Errors; -- Brief Error mode if Brief_Output or (not Full_List and not Verbose_Mode) then - E := First_Error_Msg; - Set_Standard_Error; - - while E /= No_Error_Msg loop - if not Errors.Table (E).Deleted then - Output_Msg_Location (E); - Output_Msg_Text (E); - Write_Eol; - end if; - - E := Errors.Table (E).Next; - end loop; - - Set_Standard_Output; + Write_All_Errors_In_Brief_Format; end if; -- Full source listing case @@ -404,19 +378,7 @@ package body Errutil is -- Verbose mode (error lines only with error flags) if Verbose_Mode then - E := First_Error_Msg; - - -- Loop through error lines - - while E /= No_Error_Msg loop - Write_Eol; - Output_Source_Line - (Errors.Table (E).Line, - Errors.Table (E).Sfile, - True, - Source_Type); - Output_Error_Msgs (E); - end loop; + Write_All_Errors_In_Verbose_Format (Source_Type); end if; -- Output error summary if verbose or full list mode @@ -425,20 +387,7 @@ package body Errutil is Write_Error_Summary; end if; - if Maximum_Messages /= 0 then - if Warnings_Detected >= Maximum_Messages then - Set_Standard_Error; - Write_Line ("maximum number of warnings detected"); - - Warning_Mode := Suppress; - end if; - - if Total_Errors_Detected >= Maximum_Messages then - Set_Standard_Error; - Write_Line ("fatal error: maximum errors reached"); - Set_Standard_Output; - end if; - end if; + Write_Max_Errors; -- Even though Warning_Info_Messages are a subclass of warnings, they -- must not be treated as errors when -gnatwe is in effect. @@ -645,4 +594,23 @@ package body Errutil is end loop; end Set_Msg_Text; + ---------------------------------------- + -- Write_All_Errors_In_Verbose_Format -- + ---------------------------------------- + + procedure Write_All_Errors_In_Verbose_Format (Source_Type : String) is + E : Error_Msg_Id; + begin + E := First_Error_Msg; + + -- Loop through error lines + + while E /= No_Error_Msg loop + Write_Eol; + Output_Source_Line + (Errors.Table (E).Line, Errors.Table (E).Sfile, True, Source_Type); + Output_Error_Msgs (E); + end loop; + end Write_All_Errors_In_Verbose_Format; + end Errutil;
