1------------------------------------------------------------------------------
2--                                                                          --
3--                         GNAT COMPILER COMPONENTS                         --
4--                                                                          --
5--                              E X P _ C H 8                               --
6--                                                                          --
7--                                 B o d y                                  --
8--                                                                          --
9--          Copyright (C) 1992-2020, 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
26with Atree;    use Atree;
27with Einfo;    use Einfo;
28with Exp_Ch3;  use Exp_Ch3;
29with Exp_Ch4;  use Exp_Ch4;
30with Exp_Ch6;  use Exp_Ch6;
31with Exp_Dbug; use Exp_Dbug;
32with Exp_Util; use Exp_Util;
33with Freeze;   use Freeze;
34with Namet;    use Namet;
35with Nmake;    use Nmake;
36with Nlists;   use Nlists;
37with Opt;      use Opt;
38with Sem;      use Sem;
39with Sem_Aux;  use Sem_Aux;
40with Sem_Ch8;  use Sem_Ch8;
41with Sem_Util; use Sem_Util;
42with Sinfo;    use Sinfo;
43with Snames;   use Snames;
44with Stand;    use Stand;
45with Tbuild;   use Tbuild;
46
47package body Exp_Ch8 is
48
49   ---------------------------------------------
50   -- Expand_N_Exception_Renaming_Declaration --
51   ---------------------------------------------
52
53   procedure Expand_N_Exception_Renaming_Declaration (N : Node_Id) is
54      Decl : Node_Id;
55
56   begin
57      Decl := Debug_Renaming_Declaration (N);
58
59      if Present (Decl) then
60         Insert_Action (N, Decl);
61      end if;
62   end Expand_N_Exception_Renaming_Declaration;
63
64   ------------------------------------------
65   -- Expand_N_Object_Renaming_Declaration --
66   ------------------------------------------
67
68   --  Most object renaming cases can be done by just capturing the address
69   --  of the renamed object. The cases in which this is not true are when
70   --  this address is not computable, since it involves extraction of a
71   --  packed array element, or of a record component to which a component
72   --  clause applies (that can specify an arbitrary bit boundary), or where
73   --  the enclosing record itself has a non-standard representation.
74
75   --  In Ada 2020, a third case arises when the renamed object is a nonatomic
76   --  subcomponent of an atomic object, because reads of or writes to it must
77   --  access the enclosing atomic object. That's also the case for an object
78   --  subject to the Volatile_Full_Access GNAT aspect/pragma in any language
79   --  version. For the sake of simplicity, we treat any subcomponent of an
80   --  atomic or Volatile_Full_Access object in any language version this way.
81
82   --  In these three cases, we pre-evaluate the renaming expression, by
83   --  extracting and freezing the values of any subscripts, and then we
84   --  set the flag Is_Renaming_Of_Object which means that any reference
85   --  to the object will be handled by macro substitution in the front
86   --  end, and the back end will know to ignore the renaming declaration.
87
88   --  An additional odd case that requires processing by expansion is
89   --  the renaming of a discriminant of a mutable record type. The object
90   --  is a constant because it renames something that cannot be assigned to,
91   --  but in fact the underlying value can change and must be reevaluated
92   --  at each reference. Gigi does have a notion of a "constant view" of
93   --  an object, and therefore the front-end must perform the expansion.
94   --  For simplicity, and to bypass some obscure code-generation problem,
95   --  we use macro substitution for all renamed discriminants, whether the
96   --  enclosing type is constrained or not.
97
98   --  The other special processing required is for the case of renaming
99   --  of an object of a class wide type, where it is necessary to build
100   --  the appropriate subtype for the renamed object.
101   --  More comments needed for this para ???
102
103   procedure Expand_N_Object_Renaming_Declaration (N : Node_Id) is
104      function Evaluation_Required (Nam : Node_Id) return Boolean;
105      --  Determines whether it is necessary to do static name evaluation for
106      --  renaming of Nam. It is considered necessary if evaluating the name
107      --  involves indexing a packed array, or extracting a component of a
108      --  record to which a component clause applies, or a subcomponent of an
109      --  atomic object. Note that we are only interested in these operations
110      --  if they occur as part of the name itself, subscripts are just values
111      --  that are computed as part of the evaluation, so they are unimportant.
112      --  In addition, always return True for Modify_Tree_For_C since the
113      --  code generator doesn't know how to handle renamings.
114
115      -------------------------
116      -- Evaluation_Required --
117      -------------------------
118
119      function Evaluation_Required (Nam : Node_Id) return Boolean is
120      begin
121         if Modify_Tree_For_C then
122            return True;
123
124         elsif Nkind (Nam) in N_Indexed_Component | N_Slice then
125            if Is_Packed (Etype (Prefix (Nam))) then
126               return True;
127
128            elsif Is_Full_Access_Object (Prefix (Nam)) then
129               return True;
130
131            else
132               return Evaluation_Required (Prefix (Nam));
133            end if;
134
135         elsif Nkind (Nam) = N_Selected_Component then
136            declare
137               Rec_Type : constant Entity_Id := Etype (Prefix (Nam));
138
139            begin
140               if Present (Component_Clause (Entity (Selector_Name (Nam))))
141                 or else Has_Non_Standard_Rep (Rec_Type)
142               then
143                  return True;
144
145               elsif Ekind (Entity (Selector_Name (Nam))) = E_Discriminant
146                 and then Is_Record_Type (Rec_Type)
147                 and then not Is_Concurrent_Record_Type (Rec_Type)
148               then
149                  return True;
150
151               elsif Is_Full_Access_Object (Prefix (Nam)) then
152                  return True;
153
154               else
155                  return Evaluation_Required (Prefix (Nam));
156               end if;
157            end;
158
159         else
160            return False;
161         end if;
162      end Evaluation_Required;
163
164      --  Local variables
165
166      Decl : Node_Id;
167      Nam  : constant Node_Id   := Name (N);
168      T    : constant Entity_Id := Etype (Defining_Identifier (N));
169
170   --  Start of processing for Expand_N_Object_Renaming_Declaration
171
172   begin
173      --  Perform name evaluation if required
174
175      if Evaluation_Required (Nam) then
176         Evaluate_Name (Nam);
177         Set_Is_Renaming_Of_Object (Defining_Identifier (N));
178      end if;
179
180      --  Deal with construction of subtype in class-wide case
181
182      if Is_Class_Wide_Type (T) then
183         Expand_Subtype_From_Expr (N, T, Subtype_Mark (N), Name (N));
184         Find_Type (Subtype_Mark (N));
185         Set_Etype (Defining_Identifier (N), Entity (Subtype_Mark (N)));
186
187         --  Freeze the class-wide subtype here to ensure that the subtype
188         --  and equivalent type are frozen before the renaming.
189
190         Freeze_Before (N, Entity (Subtype_Mark (N)));
191      end if;
192
193      --  Ada 2005 (AI-318-02): If the renamed object is a call to a build-in-
194      --  place function, then a temporary return object needs to be created
195      --  and access to it must be passed to the function.
196
197      if Is_Build_In_Place_Function_Call (Nam) then
198         Make_Build_In_Place_Call_In_Anonymous_Context (Nam);
199
200      --  Ada 2005 (AI-318-02): Specialization of previous case for renaming
201      --  containing build-in-place function calls whose returned object covers
202      --  interface types.
203
204      elsif Present (Unqual_BIP_Iface_Function_Call (Nam)) then
205         Make_Build_In_Place_Iface_Call_In_Anonymous_Context (Nam);
206      end if;
207
208      --  Create renaming entry for debug information. Mark the entity as
209      --  needing debug info if it comes from sources because the current
210      --  setting in Freeze_Entity occurs too late. ???
211
212      Set_Debug_Info_Defining_Id (N);
213      Decl := Debug_Renaming_Declaration (N);
214
215      if Present (Decl) then
216         Insert_Action (N, Decl);
217      end if;
218   end Expand_N_Object_Renaming_Declaration;
219
220   -------------------------------------------
221   -- Expand_N_Package_Renaming_Declaration --
222   -------------------------------------------
223
224   procedure Expand_N_Package_Renaming_Declaration (N : Node_Id) is
225      Decl : Node_Id;
226
227   begin
228      Decl := Debug_Renaming_Declaration (N);
229
230      if Present (Decl) then
231
232         --  If we are in a compilation unit, then this is an outer
233         --  level declaration, and must have a scope of Standard
234
235         if Nkind (Parent (N)) = N_Compilation_Unit then
236            declare
237               Aux : constant Node_Id := Aux_Decls_Node (Parent (N));
238
239            begin
240               Push_Scope (Standard_Standard);
241
242               if No (Actions (Aux)) then
243                  Set_Actions (Aux, New_List (Decl));
244               else
245                  Append (Decl, Actions (Aux));
246               end if;
247
248               Analyze (Decl);
249
250               --  Enter the debug variable in the qualification list, which
251               --  must be done at this point because auxiliary declarations
252               --  occur at the library level and aren't associated with a
253               --  normal scope.
254
255               Qualify_Entity_Names (Decl);
256
257               Pop_Scope;
258            end;
259
260         --  Otherwise, just insert after the package declaration
261
262         else
263            Insert_Action (N, Decl);
264         end if;
265      end if;
266   end Expand_N_Package_Renaming_Declaration;
267
268   ----------------------------------------------
269   -- Expand_N_Subprogram_Renaming_Declaration --
270   ----------------------------------------------
271
272   procedure Expand_N_Subprogram_Renaming_Declaration (N : Node_Id) is
273      Loc : constant Source_Ptr := Sloc (N);
274      Id  : constant Entity_Id  := Defining_Entity (N);
275
276      function Build_Body_For_Renaming (Typ : Entity_Id) return Node_Id;
277      --  Build and return the body for the renaming declaration of an equality
278      --  or inequality operator of type Typ.
279
280      -----------------------------
281      -- Build_Body_For_Renaming --
282      -----------------------------
283
284      function Build_Body_For_Renaming (Typ : Entity_Id) return Node_Id is
285         Left    : constant Entity_Id := First_Formal (Id);
286         Right   : constant Entity_Id := Next_Formal (Left);
287         Body_Id : Entity_Id;
288         Decl    : Node_Id;
289
290      begin
291         Set_Alias (Id, Empty);
292         Set_Has_Completion (Id, False);
293         Rewrite (N,
294           Make_Subprogram_Declaration (Sloc (N),
295             Specification => Specification (N)));
296         Set_Has_Delayed_Freeze (Id);
297
298         Body_Id := Make_Defining_Identifier (Sloc (N), Chars (Id));
299         Set_Debug_Info_Needed (Body_Id);
300
301         if Has_Variant_Part (Typ) then
302            Decl :=
303              Build_Variant_Record_Equality
304                (Typ         => Typ,
305                 Body_Id     => Body_Id,
306                 Param_Specs => Copy_Parameter_List (Id));
307
308         --  Build body for renamed equality, to capture its current meaning.
309         --  It may be redefined later, but the renaming is elaborated where
310         --  it occurs. This is technically known as Squirreling semantics.
311         --  Renaming is rewritten as a subprogram declaration, and the
312         --  generated body is inserted into the freeze actions for the
313         --  subprogram.
314
315         else
316            Decl :=
317              Make_Subprogram_Body (Loc,
318                Specification              =>
319                  Make_Function_Specification (Loc,
320                    Defining_Unit_Name       => Body_Id,
321                    Parameter_Specifications => Copy_Parameter_List (Id),
322                    Result_Definition        =>
323                      New_Occurrence_Of (Standard_Boolean, Loc)),
324                Declarations               => Empty_List,
325                Handled_Statement_Sequence => Empty);
326
327            Set_Handled_Statement_Sequence (Decl,
328              Make_Handled_Sequence_Of_Statements (Loc,
329                Statements => New_List (
330                  Make_Simple_Return_Statement (Loc,
331                    Expression =>
332                      Expand_Record_Equality
333                        (Id,
334                         Typ    => Typ,
335                         Lhs    => Make_Identifier (Loc, Chars (Left)),
336                         Rhs    => Make_Identifier (Loc, Chars (Right)),
337                         Bodies => Declarations (Decl))))));
338         end if;
339
340         return Decl;
341      end Build_Body_For_Renaming;
342
343      --  Local variables
344
345      Nam : constant Node_Id := Name (N);
346
347   --  Start of processing for Expand_N_Subprogram_Renaming_Declaration
348
349   begin
350      --  When the prefix of the name is a function call, we must force the
351      --  call to be made by removing side effects from the call, since we
352      --  must only call the function once.
353
354      if Nkind (Nam) = N_Selected_Component
355        and then Nkind (Prefix (Nam)) = N_Function_Call
356      then
357         Remove_Side_Effects (Prefix (Nam));
358
359      --  For an explicit dereference, the prefix must be captured to prevent
360      --  reevaluation on calls through the renaming, which could result in
361      --  calling the wrong subprogram if the access value were to be changed.
362
363      elsif Nkind (Nam) = N_Explicit_Dereference then
364         Force_Evaluation (Prefix (Nam));
365      end if;
366
367      --  Handle cases where we build a body for a renamed equality
368
369      if Is_Entity_Name (Nam)
370        and then Chars (Entity (Nam)) = Name_Op_Eq
371        and then Scope (Entity (Nam)) = Standard_Standard
372      then
373         declare
374            Typ  : constant Entity_Id := Etype (First_Formal (Id));
375
376         begin
377            --  Check whether this is a renaming of a predefined equality on an
378            --  untagged record type (AI05-0123).
379
380            if Ada_Version >= Ada_2012
381              and then Is_Record_Type (Typ)
382              and then not Is_Tagged_Type (Typ)
383              and then not Is_Frozen (Typ)
384            then
385               Append_Freeze_Action (Id, Build_Body_For_Renaming (Typ));
386            end if;
387         end;
388      end if;
389   end Expand_N_Subprogram_Renaming_Declaration;
390
391end Exp_Ch8;
392