1------------------------------------------------------------------------------
2--                                                                          --
3--                         GNAT COMPILER COMPONENTS                         --
4--                                                                          --
5--                                S T R U B                                 --
6--                                                                          --
7--                                 B o d y                                  --
8--                                                                          --
9--            Copyright (C) 2021, 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
28with Atree;          use Atree;
29with Einfo;          use Einfo;
30with Einfo.Entities; use Einfo.Entities;
31with Errout;         use Errout;
32with Namet;          use Namet;
33with Nlists;         use Nlists;
34with Sem_Eval;       use Sem_Eval;
35with Sinfo;          use Sinfo;
36with Sinfo.Nodes;    use Sinfo.Nodes;
37with Sinfo.Utils;    use Sinfo.Utils;
38with Snames;         use Snames;
39with Stringt;        use Stringt;
40
41package 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
301end Strub;
302