path: root/gcc/ada/diagnostics-utils.adb

------------------------------------------------------------------------------
--                                                                          --
--                         GNAT COMPILER COMPONENTS                         --
--                                                                          --
--                     D I A G N O S T I C S . U T I L S                    --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--          Copyright (C) 1992-2025, Free Software Foundation, Inc.         --
--                                                                          --
-- GNAT is free software;  you can  redistribute it  and/or modify it under --
-- terms of the  GNU General Public License as published  by the Free Soft- --
-- ware  Foundation;  either version 3,  or (at your option) any later ver- --
-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
-- for  more details.  You should have  received  a copy of the GNU General --
-- Public License  distributed with GNAT; see file COPYING3.  If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license.          --
--                                                                          --
-- GNAT was originally developed  by the GNAT team at  New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc.      --
--                                                                          --
------------------------------------------------------------------------------

with Diagnostics.Repository;        use Diagnostics.Repository;
with Diagnostics.Switch_Repository; use Diagnostics.Switch_Repository;
with Errout;                        use Errout;
with Erroutc;                       use Erroutc;
with Namet;                         use Namet;
with Opt;                           use Opt;
with Sinput;                        use Sinput;
with Sinfo.Nodes;                   use Sinfo.Nodes;
with Warnsw;                        use Warnsw;

package body Diagnostics.Utils is

   ------------------
   -- Get_Human_Id --
   ------------------

   function Get_Human_Id (D : Diagnostic_Type) return String_Ptr is
   begin
      if D.Switch = No_Switch_Id then
         return Diagnostic_Entries (D.Id).Human_Id;
      else
         return Get_Switch (D).Human_Id;
      end if;
   end Get_Human_Id;

   ------------------
   -- 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;

   --------------------
   -- Sloc_To_String --
   --------------------

   function Sloc_To_String
     (N : Node_Or_Entity_Id; Ref : Source_Ptr) return String
   is

   begin
      return Sloc_To_String (Sloc (N), Ref);
   end Sloc_To_String;

   --------------------
   -- Sloc_To_String --
   --------------------

   function Sloc_To_String (Sptr : Source_Ptr; Ref : Source_Ptr) return String
   is

   begin
      if Sptr = No_Location then
         return "at unknown location";

      elsif Sptr = System_Location then
         return "in package System";

      elsif Sptr = Standard_Location then
         return "in package Standard";

      elsif Sptr = Standard_ASCII_Location then
         return "in package Standard.ASCII";

      else
         if Full_File_Name (Get_Source_File_Index (Sptr))
            /= Full_File_Name (Get_Source_File_Index (Ref))
         then
            return "at " & To_String (Sptr);
         else
            return "at line " & Line_To_String (Sptr);
         end if;
      end if;
   end Sloc_To_String;

   ------------------
   -- To_Full_Span --
   ------------------

   function To_Full_Span (N : Node_Id) return Source_Span
   is
      Fst, Lst : Node_Id;
   begin
      First_And_Last_Nodes (N, Fst, Lst);
      return To_Span (Ptr   => Sloc (N),
                      First => First_Sloc (Fst),
                      Last  => Last_Sloc (Lst));
   end To_Full_Span;

   ---------------
   -- To_String --
   ---------------

   function To_String (Id : Diagnostic_Id) return String is
   begin
      if Id = No_Diagnostic_Id then
         return "GNAT0000";
      else
         return Id'Img;
      end if;
   end To_String;

   -------------
   -- To_Name --
   -------------

   function To_Name (E : Entity_Id) return String is
   begin
      --  The name of the node operator "&" has many special cases. Reuse the
      --  node to name conversion implementation from the errout package for
      --  now.

      Error_Msg_Node_1 := E;
      Set_Msg_Text ("&", Sloc (E));

      return Msg_Buffer (1 .. Msglen);
   end To_Name;

   ------------------
   -- To_Type_Name --
   ------------------

   function To_Type_Name (E : Entity_Id) return String is
   begin
      Error_Msg_Node_1 := E;
      Set_Msg_Text ("}", Sloc (E));

      return Msg_Buffer (1 .. Msglen);
   end To_Type_Name;

   --------------------
   -- Kind_To_String --
   --------------------

   function Kind_To_String
     (D : Sub_Diagnostic_Type;
      Parent : Diagnostic_Type) return String
   is
     (case D.Kind is
        when Continuation => Kind_To_String (Parent),
        when Help => "help",
        when Note => "note",
        when Suggestion => "suggestion");

   --------------------
   -- Kind_To_String --
   --------------------

   function Kind_To_String (D : Diagnostic_Type) return String is
     (if D.Warn_Err then "error"
      else
       (case D.Kind is
        when Diagnostics.Error | Non_Serious_Error => "error",
        when Warning | Restriction_Warning | Default_Warning |
             Tagless_Warning => "warning",
        when Style => "style",
        when Info => "info"));

   ------------------------------
   -- Get_Primary_Labeled_Span --
   ------------------------------

   function Get_Primary_Labeled_Span (Spans : Labeled_Span_List)
                                      return Labeled_Span_Type
   is
      use Labeled_Span_Lists;

      S  : Labeled_Span_Type;
      It : Iterator;
   begin
      if Present (Spans) then
         It := Iterate (Spans);
         while Has_Next (It) loop
            Next (It, S);
            if S.Is_Primary then
               return S;
            end if;
         end loop;
      end if;

      return No_Labeled_Span;
   end Get_Primary_Labeled_Span;

   --------------------
   -- Get_Doc_Switch --
   --------------------

   function Get_Doc_Switch (Diag : Diagnostic_Type) return String is
   begin
      if Warning_Doc_Switch
        and then Diag.Kind in Default_Warning
                            | Info
                            | Restriction_Warning
                            | Style
                            | Warning
      then
         if Diag.Switch = No_Switch_Id then
            if Diag.Kind = Restriction_Warning then
               return "[restriction warning]";

               --  Info messages can have a switch tag but they should not have
               --  a default switch tag.

            elsif Diag.Kind /= Info then

               --  For Default_Warning

               return "[enabled by default]";
            end if;
         else
            declare
               S : constant Switch_Type := Get_Switch (Diag);
            begin
               return "[-" & S.Short_Name.all & "]";
            end;
         end if;
      end if;

      return "";
   end Get_Doc_Switch;

   --------------------
   -- Appears_Before --
   --------------------

   function Appears_Before (D1, D2 : Diagnostic_Type) return Boolean is

   begin
      return Appears_Before (Primary_Location (D1).Span.Ptr,
                             Primary_Location (D2).Span.Ptr);
   end Appears_Before;

   --------------------
   -- Appears_Before --
   --------------------

   function Appears_Before (P1, P2 : Source_Ptr) return Boolean is

   begin
      if Get_Source_File_Index (P1) = Get_Source_File_Index (P2) then
         if Get_Logical_Line_Number (P1) = Get_Logical_Line_Number (P2) then
            return Get_Column_Number (P1) < Get_Column_Number (P2);
         else
            return Get_Logical_Line_Number (P1) < Get_Logical_Line_Number (P2);
         end if;
      else
         return Get_Source_File_Index (P1) < Get_Source_File_Index (P2);
      end if;
   end Appears_Before;

   ------------------------------
   -- Insert_Based_On_Location --
   ------------------------------

   procedure Insert_Based_On_Location
     (List : Diagnostic_List;
      Diagnostic : Diagnostic_Type)
   is
      use Diagnostics_Lists;

      It : Iterator := Iterate (List);
      D  : Diagnostic_Type;
   begin
      --  This is the common scenario where the error is reported at the
      --  natural order the tree is processed. This saves a lot of time when
      --  looking for the correct position in the list when there are a lot of
      --  diagnostics.

      if Present (List) and then
         not Is_Empty (List) and then
         Appears_Before (Last (List), Diagnostic)
      then
         Append (List, Diagnostic);
      else
         while Has_Next (It) loop
            Next (It, D);

            if Appears_Before (Diagnostic, D) then
               Insert_Before (List, D, Diagnostic);
               return;
            end if;
         end loop;

         Append (List, Diagnostic);
      end if;
   end Insert_Based_On_Location;

end Diagnostics.Utils;