------------------------------------------------------------------------------
--                                                                          --
--                         GNAT COMPILER COMPONENTS                         --
--                                                                          --
--                                S T R U B                                 --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--            Copyright (C) 2021-2022, 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.      --
--                                                                          --
------------------------------------------------------------------------------

--  Package containing utility procedures related to Stack Scrubbing

with Atree;          use Atree;
with Einfo;          use Einfo;
with Einfo.Entities; use Einfo.Entities;
with Errout;         use Errout;
with Namet;          use Namet;
with Nlists;         use Nlists;
with Sem_Eval;       use Sem_Eval;
with Sinfo;          use Sinfo;
with Sinfo.Nodes;    use Sinfo.Nodes;
with Sinfo.Utils;    use Sinfo.Utils;
with Snames;         use Snames;
with Stringt;        use Stringt;

package body Strub is
   -----------------------
   -- Local Subprograms --
   -----------------------

   function Find_Explicit_Strub_Pragma (Id : Entity_Id) return Node_Id;
   --  Return a pragma Machine_Attribute (Id, "strub"[, "mode"]) node
   --  if Id has one.

   function Strub_Pragma_Arg (Item : Node_Id) return Node_Id is
      (Get_Pragma_Arg
         (Next (Next (First (Pragma_Argument_Associations (Item))))));
   --  Return the pragma argument holding the strub mode associated
   --  with Item, a subprogram, variable, constant, or type. Bear in
   --  mind that strub pragmas with an explicit strub mode argument,
   --  naming access-to-subprogram types, are applied to the
   --  designated subprogram type.

   function Strub_Pragma_Arg_To_String (Item : Node_Id) return String is
      (To_String (Strval (Expr_Value_S (Item))));
   --  Extract and return as a String the strub mode held in a node
   --  returned by Strub_Pragma_Arg.

   function Strub_Pragma_Mode
     (Id   : Entity_Id;
      Item : Node_Id) return Strub_Mode;
   --  Return the strub mode associated with Item expressed in Id.
   --  Strub_Pragma_P (Id) must hold.

   ---------------------------
   -- Check_Same_Strub_Mode --
   ---------------------------

   procedure Check_Same_Strub_Mode
     (Dest, Src : Entity_Id;
      Report    : Boolean := True)
   is
      Src_Strub_Mode  : constant Strub_Mode := Explicit_Strub_Mode (Src);
      Dest_Strub_Mode : constant Strub_Mode := Explicit_Strub_Mode (Dest);

   begin
      if Dest_Strub_Mode = Src_Strub_Mode then
         return;
      end if;

      --  Internal is not part of the interface, it's an *internal*
      --  implementation detail, so consider it equivalent to unspecified here.
      --  ??? -fstrub=relaxed|strict makes them interface-equivalent to
      --  Callable or Disabled, respectively, but we don't look at that flag in
      --  the front-end, and it seems undesirable for that flag to affect
      --  whether specifications are conformant. Maybe there should be some
      --  means to specify Callable or Disabled along with Internal?

      if Dest_Strub_Mode in Unspecified | Internal
        and then Src_Strub_Mode in Unspecified | Internal
      then
         return;
      end if;

      if not Report then
         return;
      end if;

      if Src_Strub_Mode /= Unspecified then
         Error_Msg_Sloc := Sloc (Find_Explicit_Strub_Pragma (Src));
      else
         Error_Msg_Sloc := Sloc (Src);
      end if;
      Error_Msg_Node_2 := Src;
      Error_Msg_NE ("& requires the same `strub` mode as &#",
                    (if Dest_Strub_Mode /= Unspecified
                       then Find_Explicit_Strub_Pragma (Dest)
                       else Dest),
                    Dest);
   end Check_Same_Strub_Mode;

   ----------------------------
   -- Compatible_Strub_Modes --
   ----------------------------

   function Compatible_Strub_Modes
     (Dest, Src : Entity_Id) return Boolean
   is
      Src_Strub_Mode : constant Strub_Mode := Explicit_Strub_Mode (Src);
      Dest_Strub_Mode : constant Strub_Mode := Explicit_Strub_Mode (Dest);

   begin
      return Src_Strub_Mode = Dest_Strub_Mode
        or else At_Calls not in Src_Strub_Mode | Dest_Strub_Mode;
   end Compatible_Strub_Modes;

   ---------------------
   -- Copy_Strub_Mode --
   ---------------------

   procedure Copy_Strub_Mode (Dest, Src : Entity_Id) is
      Strub : Node_Id := Find_Explicit_Strub_Pragma (Src);
      Src_Strub_Mode : constant Strub_Mode := Strub_Pragma_Mode (Src, Strub);

   begin
      pragma Assert (Explicit_Strub_Mode (Dest) = Unspecified);

      --  Refrain from copying Internal to subprogram types.
      --  It affects code generation for the subprogram,
      --  but it has no effect on its type or interface.

      if Src_Strub_Mode = Unspecified
        or else (Ekind (Dest) = E_Subprogram_Type
                   and then Src_Strub_Mode = Internal)
      then
         return;
      end if;

      Strub := New_Copy (Strub);
      Set_Next_Rep_Item (Strub, First_Rep_Item (Dest));
      Set_First_Rep_Item (Dest, Strub);
      Set_Has_Gigi_Rep_Item (Dest);
   end Copy_Strub_Mode;

   -------------------------
   -- Explicit_Strub_Mode --
   -------------------------

   function Explicit_Strub_Mode (Id : Entity_Id) return Strub_Mode is
      Item : constant Node_Id := Find_Explicit_Strub_Pragma (Id);

   begin
      return Strub_Pragma_Mode (Id, Item);
   end Explicit_Strub_Mode;

   --------------------------------
   -- Find_Explicit_Strub_Pragma --
   --------------------------------

   function Find_Explicit_Strub_Pragma (Id : Entity_Id) return Node_Id is
      Item : Node_Id;

   begin
      if not Has_Gigi_Rep_Item (Id) then
         return Empty;
      end if;

      Item := First_Rep_Item (Id);
      while Present (Item) loop
         if Strub_Pragma_P (Item) then
            return Item;
         end if;
         Item := Next_Rep_Item (Item);
      end loop;

      return Empty;
   end Find_Explicit_Strub_Pragma;

   -----------------------
   -- Strub_Pragma_Mode --
   -----------------------

   function Strub_Pragma_Mode
     (Id   : Entity_Id;
      Item : Node_Id) return Strub_Mode
   is
      Arg : Node_Id := Empty;

   begin
      --  ??? Enumeration literals, despite being conceptually functions, have
      --  neither bodies nor stack frames, and it's not clear whether it would
      --  make more sense to treat them as subprograms or as constants, but
      --  they can be renamed as functions.  Should we require all literals of
      --  a type to have the same strub mode?  Rule out their annotation?

      if Ekind (Id) in E_Subprogram_Type
                     | Overloadable_Kind
                     | Generic_Subprogram_Kind
      then
         if Item = Empty then
            return Unspecified;
         end if;

         Arg := Strub_Pragma_Arg (Item);
         if Arg = Empty then
            return At_Calls;
         end if;

         declare
            Str : constant String := Strub_Pragma_Arg_To_String (Arg);
         begin
            if Str'Length /= 8 then
               return Unspecified;
            end if;

            case Str (Str'First) is
               when 'a' =>
                  if Str = "at-calls" then
                     return At_Calls;
                  end if;

               when 'i' =>
                  if Str = "internal" then
                     return Internal;
                  end if;

               when 'c' =>
                  if Str = "callable" then
                     return Callable;
                  end if;

               when 'd' =>
                  if Str = "disabled" then
                     return Disabled;
                  end if;

               when others =>
                  null;
            end case;
            return Unspecified;
         end;

      --  Access-to-subprogram types and variables can be treated just like
      --  other access types, because the pragma logic has already promoted to
      --  subprogram types any annotations applicable to them.

      elsif Ekind (Id) in Type_Kind -- except E_Subprogram_Type, covered above
                        | Scalar_Kind
                        | Object_Kind
                        | Named_Kind
      then
         if Item = Empty then
            return Unspecified;
         end if;

         Arg := Strub_Pragma_Arg (Item);
         if Arg /= Empty then
            --  A strub parameter is not applicable to variables,
            --  and will be ignored.

            return Unspecified;
         end if;

         return Enabled;

      else
         pragma Assert (Item = Empty);
         return Not_Applicable;
      end if;
   end Strub_Pragma_Mode;

   --------------------
   -- Strub_Pragma_P --
   --------------------

   function Strub_Pragma_P
     (Item : Node_Id) return Boolean is
      (Nkind (Item) = N_Pragma
         and then Pragma_Name (Item) = Name_Machine_Attribute
         and then
           Strub_Pragma_Arg_To_String
             (Get_Pragma_Arg
                (Next (First (Pragma_Argument_Associations (Item)))))
             = "strub");

end Strub;