https://gcc.gnu.org/g:4e67c9b2aab70fa907f0b83ce8850fda971d2058
commit r17-946-g4e67c9b2aab70fa907f0b83ce8850fda971d2058 Author: Viljar Indus <[email protected]> Date: Fri Mar 20 17:23:14 2026 +0200 ada: Improve dmsg Add missing attributes to dmsg. Additionally add support for printing locations and fixes. gcc/ada/ChangeLog: * erroutc-pretty_emitter.adb (To_String): Relocated to erroutc. (To_File_Name): Likewise. (Line_To_String): Likewise. (Column_To_String): Likewise. * erroutc.adb (dedit): New function for debugging edits. (dfix): New function for debuging fixes. (dloc): New function for debugging locations. (dmsg): Print missing Error_Msg_Object attributes. (To_String): New function for printing spans (To_String): Relocated from erroutc-pretty_emitter.adb (To_File_Name): Likewise. * erroutc.ads: Likewise. Diff: --- gcc/ada/erroutc-pretty_emitter.adb | 65 -------------- gcc/ada/erroutc.adb | 179 +++++++++++++++++++++++++++++++++---- gcc/ada/erroutc.ads | 17 ++++ 3 files changed, 180 insertions(+), 81 deletions(-) diff --git a/gcc/ada/erroutc-pretty_emitter.adb b/gcc/ada/erroutc-pretty_emitter.adb index 853036234205..4a9458aa49a5 100644 --- a/gcc/ada/erroutc-pretty_emitter.adb +++ b/gcc/ada/erroutc-pretty_emitter.adb @@ -23,7 +23,6 @@ -- -- ------------------------------------------------------------------------------ -with Namet; use Namet; with Opt; use Opt; with Output; use Output; with Sinput; use Sinput; @@ -304,19 +303,6 @@ package body Erroutc.Pretty_Emitter is procedure Print_Sub_Diagnostic (Sub_Diag : Error_Msg_Object; Diag : Error_Msg_Object; Offset : Integer); - function To_String (Sptr : Source_Ptr) return String; - -- Convert the source pointer to a string of the form: "file:line:column" - - function To_File_Name (Sptr : Source_Ptr) return String; - -- Converts the file name of the Sptr to a string. - - function Line_To_String (Sptr : Source_Ptr) return String; - -- Converts the logical line number of the Sptr to a string. - - function Column_To_String (Sptr : Source_Ptr) return String; - -- Converts the column number of the Sptr to a string. Column values less - -- than 10 are prefixed with a 0. - ------------- -- Destroy -- ------------- @@ -1356,55 +1342,4 @@ package body Erroutc.Pretty_Emitter is Set_Standard_Output; end Print_Error_Messages; - ------------------ - -- To_File_Name -- - ------------------ - - function To_File_Name (Sptr : Source_Ptr) return String is - Sfile : constant Source_File_Index := Get_Source_File_Index (Sptr); - Ref_Name : constant File_Name_Type := - (if Full_Path_Name_For_Brief_Errors then Full_Ref_Name (Sfile) - else Reference_Name (Sfile)); - - begin - return Get_Name_String (Ref_Name); - end To_File_Name; - - -------------------- - -- Line_To_String -- - -------------------- - - function Line_To_String (Sptr : Source_Ptr) return String is - Line : constant Logical_Line_Number := Get_Logical_Line_Number (Sptr); - Img_Raw : constant String := Int'Image (Int (Line)); - - begin - return Img_Raw (Img_Raw'First + 1 .. Img_Raw'Last); - end Line_To_String; - - ---------------------- - -- Column_To_String -- - ---------------------- - - function Column_To_String (Sptr : Source_Ptr) return String is - Col : constant Column_Number := Get_Column_Number (Sptr); - Img_Raw : constant String := Int'Image (Int (Col)); - - begin - return - (if Col < 10 then "0" else "") & - Img_Raw (Img_Raw'First + 1 .. Img_Raw'Last); - end Column_To_String; - - --------------- - -- To_String -- - --------------- - - function To_String (Sptr : Source_Ptr) return String is - begin - return - To_File_Name (Sptr) & ":" & Line_To_String (Sptr) & ":" & - Column_To_String (Sptr); - end To_String; - end Erroutc.Pretty_Emitter; diff --git a/gcc/ada/erroutc.adb b/gcc/ada/erroutc.adb index e8276b45d131..d88c97bbfc8b 100644 --- a/gcc/ada/erroutc.adb +++ b/gcc/ada/erroutc.adb @@ -275,43 +275,117 @@ package body Erroutc is end if; end Debug_Output; + ----------- + -- dedit -- + ----------- + + procedure dedit (Id : Edit_Id) is + E : Edit_Type renames Edits.Table (Id); + begin + w (" Edit, Id = ", Int (Id)); + w (" Next = ", Int (E.Next)); + w (" Text = ", + (if E.Text /= null then E.Text.all else "<>")); + w (" Span = ", To_String (E.Span)); + end dedit; + + ---------- + -- dfix -- + ---------- + + procedure dfix (Id : Fix_Id) is + F : Fix_Type renames Fixes.Table (Id); + E_Id : Edit_Id := F.Edits; + begin + w (" Fix, Id = ", Int (Id)); + w (" Next = ", Int (F.Next)); + w (" Description = ", + (if F.Description /= null then F.Description.all else "<>")); + while E_Id /= No_Edit loop + dedit (E_Id); + E_Id := Edits.Table (E_Id).Next; + end loop; + end dfix; + + ---------- + -- dloc -- + ---------- + + procedure dloc (Id : Labeled_Span_Id) is + L : Labeled_Span_Type renames Locations.Table (Id); + begin + if L.Is_Primary then + w (" Primary location, Id = ", Int (Id)); + else + w (" Secondary location, Id = ", Int (Id)); + end if; + w (" Label = ", + (if L.Label /= null then L.Label.all else "<>")); + w (" Span = ", To_String (L.Span)); + w (" Is_Region = ", L.Is_Region); + w (" Next = ", Int (L.Next)); + end dloc; + ---------- -- dmsg -- ---------- procedure dmsg (Id : Error_Msg_Id) is E : Error_Msg_Object renames Errors.Table (Id); + Loc_Id : Labeled_Span_Id := E.Locations; + F_Id : Fix_Id := E.Fixes; begin w ("Dumping error message, Id = ", Int (Id)); - w (" Text = ", E.Text.all); - w (" Next = ", Int (E.Next)); - w (" Prev = ", Int (E.Prev)); - w (" Sfile = ", Int (E.Sfile)); + w (" Text = ", E.Text.all); + w (" Next = ", Int (E.Next)); + w (" Prev = ", Int (E.Prev)); + w (" Sfile = ", Int (E.Sfile)); Write_Str - (" Sptr = "); - Write_Location (E.Sptr.Ptr); -- ??? Do not write the full span for now + (" Sptr = "); + Write_Location (E.Sptr.Ptr); Write_Eol; + w (" Span = ", To_String (E.Sptr)); Write_Str - (" Optr = "); + (" Optr = "); Write_Location (E.Optr.Ptr); Write_Eol; + w (" Opan = ", To_String (E.Optr)); Write_Str - (" Insertion_Sloc = "); + (" Insertion_Sloc = "); Write_Location (E.Insertion_Sloc); Write_Eol; - w (" Line = ", Int (E.Line)); - w (" Col = ", Int (E.Col)); - w (" Kind = ", E.Kind'Img); - w (" Warn_Err = ", E.Warn_Err'Img); - w (" Warn_Chr = '" & E.Warn_Chr & '''); - w (" Uncond = ", E.Uncond); - w (" Msg_Cont = ", E.Msg_Cont); - w (" Deleted = ", E.Deleted); + while Loc_Id /= No_Labeled_Span loop + dloc (Loc_Id); + Loc_Id := Locations.Table (Loc_Id).Next; + end loop; + + while Loc_Id /= No_Labeled_Span loop + dloc (Loc_Id); + Loc_Id := Locations.Table (Loc_Id).Next; + end loop; + + while F_Id /= No_Fix loop + dfix (F_Id); + F_Id := Fixes.Table (F_Id).Next; + end loop; + + w (" Line = ", Int (E.Line)); + w (" Col = ", Int (E.Col)); + w (" Kind = ", E.Kind'Img); + w (" Warn_Err = ", E.Warn_Err'Img); + w (" Warn_Chr = '" & E.Warn_Chr & '''); + w (" Uncond = ", E.Uncond); + w (" Compile_Time_Pragma = ", E.Compile_Time_Pragma); + w (" Msg_Cont = ", E.Msg_Cont); + w (" Deleted = ", E.Deleted); + w (" Switch = ", E.Switch'Img); + w (" Diag_Id = ", E.Id'Img); + w (" Restriction = ", E.Restriction'Img); Write_Eol; end dmsg; @@ -2072,6 +2146,79 @@ package body Erroutc is return False; end Sloc_In_Range; + ------------------ + -- To_File_Name -- + ------------------ + + function To_File_Name (Sptr : Source_Ptr) return String is + Sfile : constant Source_File_Index := Get_Source_File_Index (Sptr); + Ref_Name : constant File_Name_Type := + (if Full_Path_Name_For_Brief_Errors then Full_Ref_Name (Sfile) + else Reference_Name (Sfile)); + + begin + return Get_Name_String (Ref_Name); + end To_File_Name; + + --------------- + -- To_String -- + --------------- + + function To_String (Sptr : Source_Ptr) return String is + function Line_To_String (Sptr : Source_Ptr) return String; + -- Converts the logical line number of the Sptr to a string. + + function Column_To_String (Sptr : Source_Ptr) return String; + -- Converts the column number of the Sptr to a string. Column values + -- less than 10 are prefixed with a 0. + + -------------------- + -- Line_To_String -- + -------------------- + + function Line_To_String (Sptr : Source_Ptr) return String is + Line : constant Logical_Line_Number := + Get_Logical_Line_Number (Sptr); + Img_Raw : constant String := Int'Image (Int (Line)); + + begin + return Img_Raw (Img_Raw'First + 1 .. Img_Raw'Last); + end Line_To_String; + + ---------------------- + -- Column_To_String -- + ---------------------- + + function Column_To_String (Sptr : Source_Ptr) return String is + Col : constant Column_Number := Get_Column_Number (Sptr); + Img_Raw : constant String := Int'Image (Int (Col)); + + begin + return + (if Col < 10 then "0" else "") + & Img_Raw (Img_Raw'First + 1 .. Img_Raw'Last); + end Column_To_String; + + -- Start of processing for To_String + begin + return + To_File_Name (Sptr) + & ":" + & Line_To_String (Sptr) + & ":" + & Column_To_String (Sptr); + end To_String; + + --------------- + -- To_String -- + --------------- + + function To_String (Span : Source_Span) return String is + begin + return + "[" & To_String (Span.First) & " .. " & To_String (Span.Last) & "]"; + end To_String; + ------------------------------------- -- Warning_Specifically_Suppressed -- ------------------------------------- diff --git a/gcc/ada/erroutc.ads b/gcc/ada/erroutc.ads index a5d26fe78be3..52ff4538a59d 100644 --- a/gcc/ada/erroutc.ads +++ b/gcc/ada/erroutc.ads @@ -617,6 +617,15 @@ package Erroutc is -- Returns true if errors have been detected, or warnings that are treated -- as errors. + procedure dedit (Id : Edit_Id); + -- Debugging routine to dump an edit. Used by dfix. + + procedure dfix (Id : Fix_Id); + -- Debugging routine to dump a fix. Used by dmsg. + + procedure dloc (Id : Labeled_Span_Id); + -- Debugging routine to dump a location. Used by dmsg. + procedure dmsg (Id : Error_Msg_Id); -- Debugging routine to dump an error message @@ -881,6 +890,14 @@ package Erroutc is -- branch of gnat2why, which does not know about tags in the calls but -- which uses the latest version of erroutc. + function To_String (Span : Source_Span) return String; + + function To_String (Sptr : Source_Ptr) return String; + -- Convert the source pointer to a string of the form: "file:line:column" + + function To_File_Name (Sptr : Source_Ptr) return String; + -- Converts the file name of the Sptr to a string. + function Warning_Treated_As_Error (Msg : String) return Boolean; -- Returns True if the warning message Msg matches any of the strings -- given by Warning_As_Error pragmas, as stored in the Warnings_As_Errors
