gcc/ada/strub.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                                S T R U B                                 --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --            Copyright (C) 2021-2023, Free Software Foundation, Inc.       --
  10 --                                                                          --
  11 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  12 -- terms of the  GNU General Public License as published  by the Free Soft- --
  13 -- ware  Foundation;  either version 3,  or (at your option) any later ver- --
  14 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  15 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  16 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  17 -- for  more details.  You should have  received  a copy of the GNU General --
  18 -- Public License  distributed with GNAT; see file COPYING3.  If not, go to --
  19 -- http://www.gnu.org/licenses for a complete copy of the license.          --
  20 --                                                                          --
  21 -- GNAT was originally developed  by the GNAT team at  New York University. --
  22 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  23 --                                                                          --
  24 ------------------------------------------------------------------------------
  25
  26 --  Package containing utility procedures related to Stack Scrubbing
  27
  28 with Atree;          use Atree;
  29 with Einfo;          use Einfo;
  30 with Einfo.Entities; use Einfo.Entities;
  31 with Errout;         use Errout;
  32 with Namet;          use Namet;
  33 with Nlists;         use Nlists;
  34 with Sem_Eval;       use Sem_Eval;
  35 with Sinfo;          use Sinfo;
  36 with Sinfo.Nodes;    use Sinfo.Nodes;
  37 with Sinfo.Utils;    use Sinfo.Utils;
  38 with Snames;         use Snames;
  39 with Stringt;        use Stringt;
  40
  41 package body Strub is
  42    -----------------------
  43    -- Local Subprograms --
  44    -----------------------
  45
  46    function Find_Explicit_Strub_Pragma (Id : Entity_Id) return Node_Id;
  47    --  Return a pragma Machine_Attribute (Id, "strub"[, "mode"]) node
  48    --  if Id has one.
  49
  50    function Strub_Pragma_Arg (Item : Node_Id) return Node_Id is
  51       (Get_Pragma_Arg
  52          (Next (Next (First (Pragma_Argument_Associations (Item))))));
  53    --  Return the pragma argument holding the strub mode associated
  54    --  with Item, a subprogram, variable, constant, or type. Bear in
  55    --  mind that strub pragmas with an explicit strub mode argument,
  56    --  naming access-to-subprogram types, are applied to the
  57    --  designated subprogram type.
  58
  59    function Strub_Pragma_Arg_To_String (Item : Node_Id) return String is
  60       (To_String (Strval (Expr_Value_S (Item))));
  61    --  Extract and return as a String the strub mode held in a node
  62    --  returned by Strub_Pragma_Arg.
  63
  64    function Strub_Pragma_Mode
  65      (Id   : Entity_Id;
  66       Item : Node_Id) return Strub_Mode;
  67    --  Return the strub mode associated with Item expressed in Id.
  68    --  Strub_Pragma_P (Id) must hold.
  69
  70    ---------------------------
  71    -- Check_Same_Strub_Mode --
  72    ---------------------------
  73
  74    procedure Check_Same_Strub_Mode
  75      (Dest, Src : Entity_Id;
  76       Report    : Boolean := True)
  77    is
  78       Src_Strub_Mode  : constant Strub_Mode := Explicit_Strub_Mode (Src);
  79       Dest_Strub_Mode : constant Strub_Mode := Explicit_Strub_Mode (Dest);
  80
  81    begin
  82       if Dest_Strub_Mode = Src_Strub_Mode then
  83          return;
  84       end if;
  85
  86       --  Internal is not part of the interface, it's an *internal*
  87       --  implementation detail, so consider it equivalent to unspecified here.
  88       --  ??? -fstrub=relaxed|strict makes them interface-equivalent to
  89       --  Callable or Disabled, respectively, but we don't look at that flag in
  90       --  the front-end, and it seems undesirable for that flag to affect
  91       --  whether specifications are conformant. Maybe there should be some
  92       --  means to specify Callable or Disabled along with Internal?
  93
  94       if Dest_Strub_Mode in Unspecified | Internal
  95         and then Src_Strub_Mode in Unspecified | Internal
  96       then
  97          return;
  98       end if;
  99
 100       if not Report then
 101          return;
 102       end if;
 103
 104       if Src_Strub_Mode /= Unspecified then
 105          Error_Msg_Sloc := Sloc (Find_Explicit_Strub_Pragma (Src));
 106       else
 107          Error_Msg_Sloc := Sloc (Src);
 108       end if;
 109       Error_Msg_Node_2 := Src;
 110       Error_Msg_NE ("& requires the same `strub` mode as &#",
 111                     (if Dest_Strub_Mode /= Unspecified
 112                        then Find_Explicit_Strub_Pragma (Dest)
 113                        else Dest),
 114                     Dest);
 115    end Check_Same_Strub_Mode;
 116
 117    ----------------------------
 118    -- Compatible_Strub_Modes --
 119    ----------------------------
 120
 121    function Compatible_Strub_Modes
 122      (Dest, Src : Entity_Id) return Boolean
 123    is
 124       Src_Strub_Mode : constant Strub_Mode := Explicit_Strub_Mode (Src);
 125       Dest_Strub_Mode : constant Strub_Mode := Explicit_Strub_Mode (Dest);
 126
 127    begin
 128       return Src_Strub_Mode = Dest_Strub_Mode
 129         or else At_Calls not in Src_Strub_Mode | Dest_Strub_Mode;
 130    end Compatible_Strub_Modes;
 131
 132    ---------------------
 133    -- Copy_Strub_Mode --
 134    ---------------------
 135
 136    procedure Copy_Strub_Mode (Dest, Src : Entity_Id) is
 137       Strub : Node_Id := Find_Explicit_Strub_Pragma (Src);
 138       Src_Strub_Mode : constant Strub_Mode := Strub_Pragma_Mode (Src, Strub);
 139
 140    begin
 141       pragma Assert (Explicit_Strub_Mode (Dest) = Unspecified);
 142
 143       --  Refrain from copying Internal to subprogram types.
 144       --  It affects code generation for the subprogram,
 145       --  but it has no effect on its type or interface.
 146
 147       if Src_Strub_Mode = Unspecified
 148         or else (Ekind (Dest) = E_Subprogram_Type
 149                    and then Src_Strub_Mode = Internal)
 150       then
 151          return;
 152       end if;
 153
 154       Strub := New_Copy (Strub);
 155       Set_Next_Rep_Item (Strub, First_Rep_Item (Dest));
 156       Set_First_Rep_Item (Dest, Strub);
 157       Set_Has_Gigi_Rep_Item (Dest);
 158    end Copy_Strub_Mode;
 159
 160    -------------------------
 161    -- Explicit_Strub_Mode --
 162    -------------------------
 163
 164    function Explicit_Strub_Mode (Id : Entity_Id) return Strub_Mode is
 165       Item : constant Node_Id := Find_Explicit_Strub_Pragma (Id);
 166
 167    begin
 168       return Strub_Pragma_Mode (Id, Item);
 169    end Explicit_Strub_Mode;
 170
 171    --------------------------------
 172    -- Find_Explicit_Strub_Pragma --
 173    --------------------------------
 174
 175    function Find_Explicit_Strub_Pragma (Id : Entity_Id) return Node_Id is
 176       Item : Node_Id;
 177
 178    begin
 179       if not Has_Gigi_Rep_Item (Id) then
 180          return Empty;
 181       end if;
 182
 183       Item := First_Rep_Item (Id);
 184       while Present (Item) loop
 185          if Strub_Pragma_P (Item) then
 186             return Item;
 187          end if;
 188          Item := Next_Rep_Item (Item);
 189       end loop;
 190
 191       return Empty;
 192    end Find_Explicit_Strub_Pragma;
 193
 194    -----------------------
 195    -- Strub_Pragma_Mode --
 196    -----------------------
 197
 198    function Strub_Pragma_Mode
 199      (Id   : Entity_Id;
 200       Item : Node_Id) return Strub_Mode
 201    is
 202       Arg : Node_Id := Empty;
 203
 204    begin
 205       --  ??? Enumeration literals, despite being conceptually functions, have
 206       --  neither bodies nor stack frames, and it's not clear whether it would
 207       --  make more sense to treat them as subprograms or as constants, but
 208       --  they can be renamed as functions.  Should we require all literals of
 209       --  a type to have the same strub mode?  Rule out their annotation?
 210
 211       if Ekind (Id) in E_Subprogram_Type
 212                      | Overloadable_Kind
 213                      | Generic_Subprogram_Kind
 214       then
 215          if Item = Empty then
 216             return Unspecified;
 217          end if;
 218
 219          Arg := Strub_Pragma_Arg (Item);
 220          if Arg = Empty then
 221             return At_Calls;
 222          end if;
 223
 224          declare
 225             Str : constant String := Strub_Pragma_Arg_To_String (Arg);
 226          begin
 227             if Str'Length /= 8 then
 228                return Unspecified;
 229             end if;
 230
 231             case Str (Str'First) is
 232                when 'a' =>
 233                   if Str = "at-calls" then
 234                      return At_Calls;
 235                   end if;
 236
 237                when 'i' =>
 238                   if Str = "internal" then
 239                      return Internal;
 240                   end if;
 241
 242                when 'c' =>
 243                   if Str = "callable" then
 244                      return Callable;
 245                   end if;
 246
 247                when 'd' =>
 248                   if Str = "disabled" then
 249                      return Disabled;
 250                   end if;
 251
 252                when others =>
 253                   null;
 254             end case;
 255             return Unspecified;
 256          end;
 257
 258       --  Access-to-subprogram types and variables can be treated just like
 259       --  other access types, because the pragma logic has already promoted to
 260       --  subprogram types any annotations applicable to them.
 261
 262       elsif Ekind (Id) in Type_Kind -- except E_Subprogram_Type, covered above
 263                         | Scalar_Kind
 264                         | Object_Kind
 265                         | Named_Kind
 266       then
 267          if Item = Empty then
 268             return Unspecified;
 269          end if;
 270
 271          Arg := Strub_Pragma_Arg (Item);
 272          if Arg /= Empty then
 273             --  A strub parameter is not applicable to variables,
 274             --  and will be ignored.
 275
 276             return Unspecified;
 277          end if;
 278
 279          return Enabled;
 280
 281       else
 282          pragma Assert (Item = Empty);
 283          return Not_Applicable;
 284       end if;
 285    end Strub_Pragma_Mode;
 286
 287    --------------------
 288    -- Strub_Pragma_P --
 289    --------------------
 290
 291    function Strub_Pragma_P
 292      (Item : Node_Id) return Boolean is
 293       (Nkind (Item) = N_Pragma
 294          and then Pragma_Name (Item) = Name_Machine_Attribute
 295          and then
 296            Strub_Pragma_Arg_To_String
 297              (Get_Pragma_Arg
 298                 (Next (First (Pragma_Argument_Associations (Item)))))
 299              = "strub");
 300
 301 end Strub;