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 --git a/gcc/ada/erroutc-pretty_emitter.adb b/gcc/ada/erroutc-pretty_emitter.adb
index 85303623420505062e6166058cc0a2db563fc6d3..4a9458aa49a5bafd3a556a956a2a6b8ab9c99312 100644 (file)
--- 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 e8276b45d1311151b3fdbc80786c3611d6f5c8ac..d88c97bbfc8b22447c13f1c6b3f483c0ea3e0013 100644 (file)
--- 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 a5d26fe78be395e0f078ddfed3aa07418b55e402..52ff4538a59dc39f1aa784d61e417a013208d8fe 100644 (file)
--- 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