1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
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. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 with Atree; use Atree;
27 with Einfo; use Einfo;
28 with Einfo.Entities; use Einfo.Entities;
29 with Einfo.Utils; use Einfo.Utils;
30 with Exp_Ch3; use Exp_Ch3;
31 with Exp_Ch4; use Exp_Ch4;
32 with Exp_Ch6; use Exp_Ch6;
33 with Exp_Dbug; use Exp_Dbug;
34 with Exp_Util; use Exp_Util;
35 with Freeze; use Freeze;
36 with Namet; use Namet;
37 with Nmake; use Nmake;
38 with Nlists; use Nlists;
41 with Sem_Aux; use Sem_Aux;
42 with Sem_Ch8; use Sem_Ch8;
43 with Sem_Util; use Sem_Util;
44 with Sinfo; use Sinfo;
45 with Sinfo.Nodes; use Sinfo.Nodes;
46 with Sinfo.Utils; use Sinfo.Utils;
47 with Snames; use Snames;
48 with Stand; use Stand;
49 with Tbuild; use Tbuild;
51 package body Exp_Ch8 is
53 ---------------------------------------------
54 -- Expand_N_Exception_Renaming_Declaration --
55 ---------------------------------------------
57 procedure Expand_N_Exception_Renaming_Declaration (N : Node_Id) is
61 Decl := Debug_Renaming_Declaration (N);
63 if Present (Decl) then
64 Insert_Action (N, Decl);
66 end Expand_N_Exception_Renaming_Declaration;
68 ------------------------------------------
69 -- Expand_N_Object_Renaming_Declaration --
70 ------------------------------------------
72 -- Most object renaming cases can be done by just capturing the address
73 -- of the renamed object. The cases in which this is not true are when
74 -- this address is not computable, since it involves extraction of a
75 -- packed array element, or of a record component to which a component
76 -- clause applies (that can specify an arbitrary bit boundary), or where
77 -- the enclosing record itself has a non-standard representation.
79 -- In Ada 2022, a third case arises when the renamed object is a nonatomic
80 -- subcomponent of an atomic object, because reads of or writes to it must
81 -- access the enclosing atomic object. That's also the case for an object
82 -- subject to the Volatile_Full_Access GNAT aspect/pragma in any language
83 -- version. For the sake of simplicity, we treat any subcomponent of an
84 -- atomic or Volatile_Full_Access object in any language version this way.
86 -- In these three cases, we pre-evaluate the renaming expression, by
87 -- extracting and freezing the values of any subscripts, and then we
88 -- set the flag Is_Renaming_Of_Object which means that any reference
89 -- to the object will be handled by macro substitution in the front
90 -- end, and the back end will know to ignore the renaming declaration.
92 -- An additional odd case that requires processing by expansion is
93 -- the renaming of a discriminant of a mutable record type. The object
94 -- is a constant because it renames something that cannot be assigned to,
95 -- but in fact the underlying value can change and must be reevaluated
96 -- at each reference. Gigi does have a notion of a "constant view" of
97 -- an object, and therefore the front-end must perform the expansion.
98 -- For simplicity, and to bypass some obscure code-generation problem,
99 -- we use macro substitution for all renamed discriminants, whether the
100 -- enclosing type is constrained or not.
102 -- The other special processing required is for the case of renaming
103 -- of an object of a class wide type, where it is necessary to build
104 -- the appropriate subtype for the renamed object.
105 -- More comments needed for this para ???
107 procedure Expand_N_Object_Renaming_Declaration (N : Node_Id) is
108 function Evaluation_Required (Nam : Node_Id) return Boolean;
109 -- Determines whether it is necessary to do static name evaluation for
110 -- renaming of Nam. It is considered necessary if evaluating the name
111 -- involves indexing a packed array, or extracting a component of a
112 -- record to which a component clause applies, or a subcomponent of an
113 -- atomic object. Note that we are only interested in these operations
114 -- if they occur as part of the name itself, subscripts are just values
115 -- that are computed as part of the evaluation, so they are unimportant.
116 -- In addition, always return True for Modify_Tree_For_C since the
117 -- code generator doesn't know how to handle renamings.
119 -------------------------
120 -- Evaluation_Required --
121 -------------------------
123 function Evaluation_Required (Nam : Node_Id) return Boolean is
125 if Modify_Tree_For_C then
128 elsif Nkind (Nam) in N_Indexed_Component | N_Slice then
129 if Is_Packed (Etype (Prefix (Nam))) then
132 elsif Is_Full_Access_Object (Prefix (Nam)) then
136 return Evaluation_Required (Prefix (Nam));
139 elsif Nkind (Nam) = N_Selected_Component then
141 Rec_Type : constant Entity_Id := Etype (Prefix (Nam));
144 if Present (Component_Clause (Entity (Selector_Name (Nam))))
145 or else Has_Non_Standard_Rep (Rec_Type)
149 elsif Ekind (Entity (Selector_Name (Nam))) = E_Discriminant
150 and then Is_Record_Type (Rec_Type)
151 and then not Is_Concurrent_Record_Type (Rec_Type)
155 elsif Is_Full_Access_Object (Prefix (Nam)) then
159 return Evaluation_Required (Prefix (Nam));
166 end Evaluation_Required;
171 Nam : constant Node_Id := Name (N);
172 T : constant Entity_Id := Etype (Defining_Identifier (N));
174 -- Start of processing for Expand_N_Object_Renaming_Declaration
177 -- Perform name evaluation if required
179 if Evaluation_Required (Nam) then
181 Set_Is_Renaming_Of_Object (Defining_Identifier (N));
184 -- Deal with construction of subtype in class-wide case
186 if Is_Class_Wide_Type (T) then
187 Expand_Subtype_From_Expr (N, T, Subtype_Mark (N), Name (N));
188 Find_Type (Subtype_Mark (N));
189 Set_Etype (Defining_Identifier (N), Entity (Subtype_Mark (N)));
191 -- Freeze the class-wide subtype here to ensure that the subtype
192 -- and equivalent type are frozen before the renaming.
194 Freeze_Before (N, Entity (Subtype_Mark (N)));
197 -- Ada 2005 (AI-318-02): If the renamed object is a call to a build-in-
198 -- place function, then a temporary return object needs to be created
199 -- and access to it must be passed to the function.
201 if Is_Build_In_Place_Function_Call (Nam) then
202 Make_Build_In_Place_Call_In_Anonymous_Context (Nam);
204 -- Ada 2005 (AI-318-02): Specialization of previous case for renaming
205 -- containing build-in-place function calls whose returned object covers
208 elsif Present (Unqual_BIP_Iface_Function_Call (Nam)) then
209 Make_Build_In_Place_Iface_Call_In_Anonymous_Context (Nam);
212 -- Create renaming entry for debug information. Mark the entity as
213 -- needing debug info if it comes from sources because the current
214 -- setting in Freeze_Entity occurs too late. ???
216 Set_Debug_Info_Defining_Id (N);
217 Decl := Debug_Renaming_Declaration (N);
219 if Present (Decl) then
220 Insert_Action (N, Decl);
222 end Expand_N_Object_Renaming_Declaration;
224 -------------------------------------------
225 -- Expand_N_Package_Renaming_Declaration --
226 -------------------------------------------
228 procedure Expand_N_Package_Renaming_Declaration (N : Node_Id) is
232 Decl := Debug_Renaming_Declaration (N);
234 if Present (Decl) then
236 -- If we are in a compilation unit, then this is an outer
237 -- level declaration, and must have a scope of Standard
239 if Nkind (Parent (N)) = N_Compilation_Unit then
241 Aux : constant Node_Id := Aux_Decls_Node (Parent (N));
244 Push_Scope (Standard_Standard);
246 if No (Actions (Aux)) then
247 Set_Actions (Aux, New_List (Decl));
249 Append (Decl, Actions (Aux));
254 -- Enter the debug variable in the qualification list, which
255 -- must be done at this point because auxiliary declarations
256 -- occur at the library level and aren't associated with a
259 Qualify_Entity_Names (Decl);
264 -- Otherwise, just insert after the package declaration
267 Insert_Action (N, Decl);
270 end Expand_N_Package_Renaming_Declaration;
272 ----------------------------------------------
273 -- Expand_N_Subprogram_Renaming_Declaration --
274 ----------------------------------------------
276 procedure Expand_N_Subprogram_Renaming_Declaration (N : Node_Id) is
277 Loc : constant Source_Ptr := Sloc (N);
278 Id : constant Entity_Id := Defining_Entity (N);
280 function Build_Body_For_Renaming (Typ : Entity_Id) return Node_Id;
281 -- Build and return the body for the renaming declaration of an equality
282 -- or inequality operator of type Typ.
284 -----------------------------
285 -- Build_Body_For_Renaming --
286 -----------------------------
288 function Build_Body_For_Renaming (Typ : Entity_Id) return Node_Id is
289 Left : constant Entity_Id := First_Formal (Id);
290 Right : constant Entity_Id := Next_Formal (Left);
295 Set_Alias (Id, Empty);
296 Set_Has_Completion (Id, False);
298 Make_Subprogram_Declaration (Sloc (N),
299 Specification => Specification (N)));
300 Set_Has_Delayed_Freeze (Id);
302 Body_Id := Make_Defining_Identifier (Sloc (N), Chars (Id));
303 Set_Debug_Info_Needed (Body_Id);
305 if Has_Variant_Part (Typ) then
307 Build_Variant_Record_Equality
310 Param_Specs => Copy_Parameter_List (Id));
312 -- Build body for renamed equality, to capture its current meaning.
313 -- It may be redefined later, but the renaming is elaborated where
314 -- it occurs. This is technically known as Squirreling semantics.
315 -- Renaming is rewritten as a subprogram declaration, and the
316 -- generated body is inserted into the freeze actions for the
321 Make_Subprogram_Body (Loc,
323 Make_Function_Specification (Loc,
324 Defining_Unit_Name => Body_Id,
325 Parameter_Specifications => Copy_Parameter_List (Id),
327 New_Occurrence_Of (Standard_Boolean, Loc)),
328 Declarations => Empty_List,
329 Handled_Statement_Sequence => Empty);
331 Set_Handled_Statement_Sequence (Decl,
332 Make_Handled_Sequence_Of_Statements (Loc,
333 Statements => New_List (
334 Make_Simple_Return_Statement (Loc,
336 Expand_Record_Equality
339 Lhs => Make_Identifier (Loc, Chars (Left)),
340 Rhs => Make_Identifier (Loc, Chars (Right)),
341 Bodies => Declarations (Decl))))));
345 end Build_Body_For_Renaming;
349 Nam : constant Node_Id := Name (N);
351 -- Start of processing for Expand_N_Subprogram_Renaming_Declaration
354 -- When the prefix of the name is a function call, we must force the
355 -- call to be made by removing side effects from the call, since we
356 -- must only call the function once.
358 if Nkind (Nam) = N_Selected_Component
359 and then Nkind (Prefix (Nam)) = N_Function_Call
361 Remove_Side_Effects (Prefix (Nam));
363 -- For an explicit dereference, the prefix must be captured to prevent
364 -- reevaluation on calls through the renaming, which could result in
365 -- calling the wrong subprogram if the access value were to be changed.
367 elsif Nkind (Nam) = N_Explicit_Dereference then
368 Force_Evaluation (Prefix (Nam));
371 -- Handle cases where we build a body for a renamed equality
373 if Is_Entity_Name (Nam)
374 and then Chars (Entity (Nam)) = Name_Op_Eq
375 and then Scope (Entity (Nam)) = Standard_Standard
378 Typ : constant Entity_Id := Etype (First_Formal (Id));
381 -- Check whether this is a renaming of a predefined equality on an
382 -- untagged record type (AI05-0123).
384 if Ada_Version >= Ada_2012
385 and then Is_Record_Type (Typ)
386 and then not Is_Tagged_Type (Typ)
387 and then not Is_Frozen (Typ)
389 Append_Freeze_Action (Id, Build_Body_For_Renaming (Typ));
393 end Expand_N_Subprogram_Renaming_Declaration;