path: root/gcc/ada/diagnostics.adb

------------------------------------------------------------------------------
--                                                                          --
--                         GNAT COMPILER COMPONENTS                         --
--                                                                          --
--                          D I A G N O S T I C S                           --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--          Copyright (C) 1992-2024, 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 Atree;                  use Atree;
with Debug;                  use Debug;
with Diagnostics.Brief_Emitter;
with Diagnostics.Pretty_Emitter;
with Diagnostics.Repository; use Diagnostics.Repository;
with Diagnostics.Utils;      use Diagnostics.Utils;
with Lib;                    use Lib;
with Opt;                    use Opt;
with Sinput;                 use Sinput;
with Warnsw;

package body Diagnostics is

   -------------
   -- Destroy --
   -------------

   procedure Destroy (Elem : in out Labeled_Span_Type) is
   begin
      Free (Elem.Label);
   end Destroy;

   -------------
   -- Destroy --
   -------------

   procedure Destroy (Elem : in out Sub_Diagnostic_Type) is
   begin
      Free (Elem.Message);
      if Labeled_Span_Lists.Present (Elem.Locations) then
         Labeled_Span_Lists.Destroy (Elem.Locations);
      end if;
   end Destroy;

   -------------
   -- Destroy --
   -------------

   procedure Destroy (Elem : in out Edit_Type) is
   begin
      Free (Elem.Text);
   end Destroy;

   -------------
   -- Destroy --
   -------------

   procedure Destroy (Elem : in out Fix_Type) is
   begin
      Free (Elem.Description);
      if Edit_Lists.Present (Elem.Edits) then
         Edit_Lists.Destroy (Elem.Edits);
      end if;
   end Destroy;

   -------------
   -- Destroy --
   -------------

   procedure Destroy (Elem : in out Diagnostic_Type) is
   begin
      Free (Elem.Message);
      if Labeled_Span_Lists.Present (Elem.Locations) then
         Labeled_Span_Lists.Destroy (Elem.Locations);
      end if;
      if Sub_Diagnostic_Lists.Present (Elem.Sub_Diagnostics) then
         Sub_Diagnostic_Lists.Destroy (Elem.Sub_Diagnostics);
      end if;
      if Fix_Lists.Present (Elem.Fixes) then
         Fix_Lists.Destroy (Elem.Fixes);
      end if;
   end Destroy;

   ------------------
   -- Add_Location --
   ------------------

   procedure Add_Location
     (Diagnostic : in out Sub_Diagnostic_Type; Location : Labeled_Span_Type)
   is
      use Labeled_Span_Lists;
   begin
      if not Present (Diagnostic.Locations) then
         Diagnostic.Locations := Create;
      end if;

      Append (Diagnostic.Locations, Location);
   end Add_Location;

   ----------------------
   -- Primary_Location --
   ----------------------

   function Primary_Location
     (Diagnostic : Sub_Diagnostic_Type) return Labeled_Span_Type
   is
   begin
      return Get_Primary_Labeled_Span (Diagnostic.Locations);
   end Primary_Location;

   ------------------
   -- Add_Location --
   ------------------

   procedure Add_Location
     (Diagnostic : in out Diagnostic_Type; Location : Labeled_Span_Type)
   is
      use Labeled_Span_Lists;
   begin
      if not Present (Diagnostic.Locations) then
         Diagnostic.Locations := Create;
      end if;

      Append (Diagnostic.Locations, Location);
   end Add_Location;

   ------------------------
   -- Add_Sub_Diagnostic --
   ------------------------

   procedure Add_Sub_Diagnostic
     (Diagnostic     : in out Diagnostic_Type;
      Sub_Diagnostic :        Sub_Diagnostic_Type)
   is
      use Sub_Diagnostic_Lists;
   begin
      if not Present (Diagnostic.Sub_Diagnostics) then
         Diagnostic.Sub_Diagnostics := Create;
      end if;

      Append (Diagnostic.Sub_Diagnostics, Sub_Diagnostic);
   end Add_Sub_Diagnostic;

   procedure Add_Edit (Fix : in out Fix_Type; Edit : Edit_Type) is
      use Edit_Lists;
   begin
      if not Present (Fix.Edits) then
         Fix.Edits := Create;
      end if;

      Append (Fix.Edits, Edit);
   end Add_Edit;

   -------------
   -- Add_Fix --
   -------------

   procedure Add_Fix (Diagnostic : in out Diagnostic_Type; Fix : Fix_Type) is
      use Fix_Lists;
   begin
      if not Present (Diagnostic.Fixes) then
         Diagnostic.Fixes := Create;
      end if;

      Append (Diagnostic.Fixes, Fix);
   end Add_Fix;

   -----------------------
   -- Record_Diagnostic --
   -----------------------

   procedure Record_Diagnostic (Diagnostic : Diagnostic_Type;
                                Update_Count : Boolean := True)
   is

      procedure Update_Diagnostic_Count (Diagnostic : Diagnostic_Type);

      -----------------------------
      -- Update_Diagnostic_Count --
      -----------------------------

      procedure Update_Diagnostic_Count (Diagnostic : Diagnostic_Type) is

      begin
         if Diagnostic.Kind = Error then
            Total_Errors_Detected := Total_Errors_Detected + 1;

            if Diagnostic.Serious then
               Serious_Errors_Detected := Serious_Errors_Detected + 1;
            end if;
         elsif Diagnostic.Kind in Warning | Style then
            Warnings_Detected := Warnings_Detected + 1;

            if Diagnostic.Warn_Err then
               Warnings_Treated_As_Errors := Warnings_Treated_As_Errors + 1;
            end if;
         elsif Diagnostic.Kind in Info then
            Info_Messages := Info_Messages + 1;
         end if;
      end Update_Diagnostic_Count;

      procedure Handle_Serious_Error;
      --  Internal procedure to do all error message handling for a serious
      --  error message, other than bumping the error counts and arranging
      --  for the message to be output.

      procedure Handle_Serious_Error is
      begin
         --  Turn off code generation if not done already

         if Operating_Mode = Generate_Code then
            Operating_Mode := Check_Semantics;
            Expander_Active := False;
         end if;

         --  Set the fatal error flag in the unit table unless we are in
         --  Try_Semantics mode (in which case we set ignored mode if not
         --  currently set. This stops the semantics from being performed
         --  if we find a serious error. This is skipped if we are currently
         --  dealing with the configuration pragma file.

         if Current_Source_Unit /= No_Unit then
            declare
               U : constant Unit_Number_Type :=
                 Get_Source_Unit
                   (Primary_Location (Diagnostic).Span.Ptr);
            begin
               if Try_Semantics then
                  if Fatal_Error (U) = None then
                     Set_Fatal_Error (U, Error_Ignored);
                  end if;
               else
                  Set_Fatal_Error (U, Error_Detected);
               end if;
            end;
         end if;

         --  Disable warnings on unused use clauses and the like. Otherwise, an
         --  error might hide a reference to an entity in a used package, so
         --  after fixing the error, the use clause no longer looks like it was
         --  unused.

         Warnsw.Check_Unreferenced := False;
         Warnsw.Check_Unreferenced_Formals := False;
      end Handle_Serious_Error;
   begin
      Insert_Based_On_Location (All_Diagnostics, Diagnostic);

      if Update_Count then
         Update_Diagnostic_Count (Diagnostic);
      end if;

      if Diagnostic.Kind = Error and then Diagnostic.Serious then
         Handle_Serious_Error;
      end if;
   end Record_Diagnostic;

   ----------------------
   -- Print_Diagnostic --
   ----------------------

   procedure Print_Diagnostic (Diagnostic : Diagnostic_Type) is

   begin
      if Debug_Flag_FF then
         Diagnostics.Pretty_Emitter.Print_Diagnostic (Diagnostic);
      else
         Diagnostics.Brief_Emitter.Print_Diagnostic (Diagnostic);
      end if;
   end Print_Diagnostic;

   ----------------------
   -- Primary_Location --
   ----------------------

   function Primary_Location
     (Diagnostic : Diagnostic_Type) return Labeled_Span_Type
   is
   begin
      return Get_Primary_Labeled_Span (Diagnostic.Locations);
   end Primary_Location;

   ---------------------
   -- Make_Diagnostic --
   ---------------------

   function Make_Diagnostic
     (Msg       : String;
      Location  : Labeled_Span_Type;
      Id        : Diagnostic_Id        := No_Diagnostic_Id;
      Kind      : Diagnostic_Kind      := Diagnostics.Error;
      Switch    : Switch_Id            := No_Switch_Id;
      Spans     : Labeled_Span_Array   := No_Locations;
      Sub_Diags : Sub_Diagnostic_Array := No_Sub_Diags;
      Fixes     : Fix_Array            := No_Fixes)
      return Diagnostic_Type
   is
      D : Diagnostic_Type;
   begin
      D.Message := new String'(Msg);
      D.Id      := Id;
      D.Kind    := Kind;

      if Id /= No_Diagnostic_Id then
         pragma Assert (Switch = Diagnostic_Entries (Id).Switch,
            "Provided switch must be the same as in the registry");
      end if;
      D.Switch  := Switch;

      pragma Assert (Location.Is_Primary, "Main location must be primary");
      Add_Location (D, Location);

      for I in Spans'Range loop
         Add_Location (D, Spans (I));
      end loop;

      for I in Sub_Diags'Range loop
         Add_Sub_Diagnostic (D, Sub_Diags (I));
      end loop;

      for I in Fixes'Range loop
         Add_Fix (D, Fixes (I));
      end loop;

      return D;
   end Make_Diagnostic;

   -----------------------
   -- Record_Diagnostic --
   -----------------------

   procedure Record_Diagnostic
     (Msg       : String;
      Location  : Labeled_Span_Type;
      Id        : Diagnostic_Id        := No_Diagnostic_Id;
      Kind      : Diagnostic_Kind      := Diagnostics.Error;
      Switch    : Switch_Id            := No_Switch_Id;
      Spans     : Labeled_Span_Array   := No_Locations;
      Sub_Diags : Sub_Diagnostic_Array := No_Sub_Diags;
      Fixes     : Fix_Array            := No_Fixes)
   is

   begin
      Record_Diagnostic
        (Make_Diagnostic
           (Msg       => Msg,
            Location  => Location,
            Id        => Id,
            Kind      => Kind,
            Switch    => Switch,
            Spans     => Spans,
            Sub_Diags => Sub_Diags,
            Fixes     => Fixes));
   end Record_Diagnostic;

   ------------------
   -- Labeled_Span --
   ------------------

   function Labeled_Span (Span       : Source_Span;
                          Label      : String := "";
                          Is_Primary : Boolean := True;
                          Is_Region  : Boolean := False)
                          return Labeled_Span_Type
   is
      L : Labeled_Span_Type;
   begin
      L.Span       := Span;
      if Label /= "" then
         L.Label      := new String'(Label);
      end if;
      L.Is_Primary := Is_Primary;
      L.Is_Region  := Is_Region;

      return L;
   end Labeled_Span;

   --------------------------
   -- Primary_Labeled_Span --
   --------------------------

   function Primary_Labeled_Span (Span  : Source_Span;
                                  Label : String  := "")
                                  return Labeled_Span_Type
   is begin
      return Labeled_Span (Span => Span, Label => Label, Is_Primary => True);
   end Primary_Labeled_Span;

   --------------------------
   -- Primary_Labeled_Span --
   --------------------------

   function Primary_Labeled_Span (N     : Node_Or_Entity_Id;
                                  Label : String := "")
                                  return Labeled_Span_Type
   is
   begin
      return Primary_Labeled_Span (To_Full_Span (N), Label);
   end Primary_Labeled_Span;

   ----------------------------
   -- Secondary_Labeled_Span --
   ----------------------------

   function Secondary_Labeled_Span
     (Span  : Source_Span;
      Label : String := "")
      return Labeled_Span_Type
   is
   begin
      return Labeled_Span (Span => Span, Label => Label, Is_Primary => False);
   end Secondary_Labeled_Span;

   ----------------------------
   -- Secondary_Labeled_Span --
   ----------------------------

   function Secondary_Labeled_Span (N     : Node_Or_Entity_Id;
                                    Label : String  := "")
                                    return Labeled_Span_Type
   is
   begin
      return Secondary_Labeled_Span (To_Full_Span (N), Label);
   end Secondary_Labeled_Span;

   --------------
   -- Sub_Diag --
   --------------

   function Sub_Diag (Msg       : String;
                      Kind      : Sub_Diagnostic_Kind :=
                        Diagnostics.Continuation;
                      Locations : Labeled_Span_Array  := No_Locations)
                      return Sub_Diagnostic_Type
   is
      S : Sub_Diagnostic_Type;
   begin
      S.Message := new String'(Msg);
      S.Kind    := Kind;

      for I in Locations'Range loop
         Add_Location (S, Locations (I));
      end loop;

      return S;
   end Sub_Diag;

   ------------------
   -- Continuation --
   ------------------

   function Continuation (Msg       : String;
                          Locations : Labeled_Span_Array := No_Locations)
                          return Sub_Diagnostic_Type
   is
   begin
      return Sub_Diag (Msg, Diagnostics.Continuation, Locations);
   end Continuation;

   ----------
   -- Help --
   ----------

   function Help (Msg       : String;
                  Locations : Labeled_Span_Array := No_Locations)
                  return Sub_Diagnostic_Type
   is
   begin
      return Sub_Diag (Msg, Diagnostics.Help, Locations);
   end Help;

   ----------------
   -- Suggestion --
   ----------------

   function Suggestion (Msg       : String;
                        Locations : Labeled_Span_Array := No_Locations)
                        return Sub_Diagnostic_Type
   is
   begin
      return Sub_Diag (Msg, Diagnostics.Suggestion, Locations);
   end Suggestion;

   ---------
   -- Fix --
   ---------

   function Fix
     (Description   : String;
      Edits         : Edit_Array;
      Applicability : Applicability_Type := Unspecified) return Fix_Type
   is
      F : Fix_Type;
   begin
      F.Description   := new String'(Description);

      for I in Edits'Range loop
         Add_Edit (F, Edits (I));
      end loop;

      F.Applicability := Applicability;

      return F;
   end Fix;

   ----------
   -- Edit --
   ----------

   function Edit (Text : String; Span : Source_Span) return Edit_Type is

   begin
      return (Text => new String'(Text), Span => Span);
   end Edit;

end Diagnostics;