1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2019, 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 Exp_Ch3
; use Exp_Ch3
;
29 with Exp_Ch4
; use Exp_Ch4
;
30 with Exp_Ch6
; use Exp_Ch6
;
31 with Exp_Dbug
; use Exp_Dbug
;
32 with Exp_Util
; use Exp_Util
;
33 with Freeze
; use Freeze
;
34 with Namet
; use Namet
;
35 with Nmake
; use Nmake
;
36 with Nlists
; use Nlists
;
39 with Sem_Aux
; use Sem_Aux
;
40 with Sem_Ch8
; use Sem_Ch8
;
41 with Sem_Util
; use Sem_Util
;
42 with Sinfo
; use Sinfo
;
43 with Snames
; use Snames
;
44 with Stand
; use Stand
;
45 with Tbuild
; use Tbuild
;
47 package body Exp_Ch8
is
49 ---------------------------------------------
50 -- Expand_N_Exception_Renaming_Declaration --
51 ---------------------------------------------
53 procedure Expand_N_Exception_Renaming_Declaration
(N
: Node_Id
) is
57 Decl
:= Debug_Renaming_Declaration
(N
);
59 if Present
(Decl
) then
60 Insert_Action
(N
, Decl
);
62 end Expand_N_Exception_Renaming_Declaration
;
64 ------------------------------------------
65 -- Expand_N_Object_Renaming_Declaration --
66 ------------------------------------------
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.
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.
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.
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.
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 ???
103 procedure Expand_N_Object_Renaming_Declaration
(N
: Node_Id
) is
104 Nam
: constant Node_Id
:= Name
(N
);
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_In
(Nam
, N_Indexed_Component
, N_Slice
) then
129 if Is_Packed
(Etype
(Prefix
(Nam
))) then
132 elsif Is_Atomic_Or_VFA_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_Atomic_Or_VFA_Object
(Prefix
(Nam
)) then
159 return Evaluation_Required
(Prefix
(Nam
));
166 end Evaluation_Required
;
168 -- Start of processing for Expand_N_Object_Renaming_Declaration
171 -- Perform name evaluation if required
173 if Evaluation_Required
(Nam
) then
175 Set_Is_Renaming_Of_Object
(Defining_Identifier
(N
));
178 -- Deal with construction of subtype in class-wide case
180 T
:= Etype
(Defining_Identifier
(N
));
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
)));
187 -- Freeze the class-wide subtype here to ensure that the subtype
188 -- and equivalent type are frozen before the renaming.
190 Freeze_Before
(N
, Entity
(Subtype_Mark
(N
)));
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.
197 if Is_Build_In_Place_Function_Call
(Nam
) then
198 Make_Build_In_Place_Call_In_Anonymous_Context
(Nam
);
200 -- Ada 2005 (AI-318-02): Specialization of previous case for renaming
201 -- containing build-in-place function calls whose returned object covers
204 elsif Present
(Unqual_BIP_Iface_Function_Call
(Nam
)) then
205 Make_Build_In_Place_Iface_Call_In_Anonymous_Context
(Nam
);
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. ???
212 if Comes_From_Source
(Defining_Identifier
(N
)) then
213 Set_Debug_Info_Needed
(Defining_Identifier
(N
));
216 Decl
:= Debug_Renaming_Declaration
(N
);
218 if Present
(Decl
) then
219 Insert_Action
(N
, Decl
);
221 end Expand_N_Object_Renaming_Declaration
;
223 -------------------------------------------
224 -- Expand_N_Package_Renaming_Declaration --
225 -------------------------------------------
227 procedure Expand_N_Package_Renaming_Declaration
(N
: Node_Id
) is
231 Decl
:= Debug_Renaming_Declaration
(N
);
233 if Present
(Decl
) then
235 -- If we are in a compilation unit, then this is an outer
236 -- level declaration, and must have a scope of Standard
238 if Nkind
(Parent
(N
)) = N_Compilation_Unit
then
240 Aux
: constant Node_Id
:= Aux_Decls_Node
(Parent
(N
));
243 Push_Scope
(Standard_Standard
);
245 if No
(Actions
(Aux
)) then
246 Set_Actions
(Aux
, New_List
(Decl
));
248 Append
(Decl
, Actions
(Aux
));
253 -- Enter the debug variable in the qualification list, which
254 -- must be done at this point because auxiliary declarations
255 -- occur at the library level and aren't associated with a
258 Qualify_Entity_Names
(Decl
);
263 -- Otherwise, just insert after the package declaration
266 Insert_Action
(N
, Decl
);
269 end Expand_N_Package_Renaming_Declaration
;
271 ----------------------------------------------
272 -- Expand_N_Subprogram_Renaming_Declaration --
273 ----------------------------------------------
275 procedure Expand_N_Subprogram_Renaming_Declaration
(N
: Node_Id
) is
276 Loc
: constant Source_Ptr
:= Sloc
(N
);
277 Id
: constant Entity_Id
:= Defining_Entity
(N
);
279 function Build_Body_For_Renaming
(Typ
: Entity_Id
) return Node_Id
;
280 -- Build and return the body for the renaming declaration of an equality
281 -- or inequality operator of type Typ.
283 -----------------------------
284 -- Build_Body_For_Renaming --
285 -----------------------------
287 function Build_Body_For_Renaming
(Typ
: Entity_Id
) return Node_Id
is
288 Left
: constant Entity_Id
:= First_Formal
(Id
);
289 Right
: constant Entity_Id
:= Next_Formal
(Left
);
294 Set_Alias
(Id
, Empty
);
295 Set_Has_Completion
(Id
, False);
297 Make_Subprogram_Declaration
(Sloc
(N
),
298 Specification
=> Specification
(N
)));
299 Set_Has_Delayed_Freeze
(Id
);
301 Body_Id
:= Make_Defining_Identifier
(Sloc
(N
), Chars
(Id
));
302 Set_Debug_Info_Needed
(Body_Id
);
304 if Has_Variant_Part
(Typ
) then
306 Build_Variant_Record_Equality
309 Param_Specs
=> Copy_Parameter_List
(Id
));
311 -- Build body for renamed equality, to capture its current meaning.
312 -- It may be redefined later, but the renaming is elaborated where
313 -- it occurs. This is technically known as Squirreling semantics.
314 -- Renaming is rewritten as a subprogram declaration, and the
315 -- generated body is inserted into the freeze actions for the
320 Make_Subprogram_Body
(Loc
,
322 Make_Function_Specification
(Loc
,
323 Defining_Unit_Name
=> Body_Id
,
324 Parameter_Specifications
=> Copy_Parameter_List
(Id
),
326 New_Occurrence_Of
(Standard_Boolean
, Loc
)),
327 Declarations
=> Empty_List
,
328 Handled_Statement_Sequence
=> Empty
);
330 Set_Handled_Statement_Sequence
(Decl
,
331 Make_Handled_Sequence_Of_Statements
(Loc
,
332 Statements
=> New_List
(
333 Make_Simple_Return_Statement
(Loc
,
335 Expand_Record_Equality
338 Lhs
=> Make_Identifier
(Loc
, Chars
(Left
)),
339 Rhs
=> Make_Identifier
(Loc
, Chars
(Right
)),
340 Bodies
=> Declarations
(Decl
))))));
344 end Build_Body_For_Renaming
;
348 Nam
: constant Node_Id
:= Name
(N
);
350 -- Start of processing for Expand_N_Subprogram_Renaming_Declaration
353 -- When the prefix of the name is a function call, we must force the
354 -- call to be made by removing side effects from the call, since we
355 -- must only call the function once.
357 if Nkind
(Nam
) = N_Selected_Component
358 and then Nkind
(Prefix
(Nam
)) = N_Function_Call
360 Remove_Side_Effects
(Prefix
(Nam
));
362 -- For an explicit dereference, the prefix must be captured to prevent
363 -- reevaluation on calls through the renaming, which could result in
364 -- calling the wrong subprogram if the access value were to be changed.
366 elsif Nkind
(Nam
) = N_Explicit_Dereference
then
367 Force_Evaluation
(Prefix
(Nam
));
370 -- Handle cases where we build a body for a renamed equality
372 if Is_Entity_Name
(Nam
)
373 and then Chars
(Entity
(Nam
)) = Name_Op_Eq
374 and then Scope
(Entity
(Nam
)) = Standard_Standard
377 Typ
: constant Entity_Id
:= Etype
(First_Formal
(Id
));
380 -- Check whether this is a renaming of a predefined equality on an
381 -- untagged record type (AI05-0123).
383 if Ada_Version
>= Ada_2012
384 and then Is_Record_Type
(Typ
)
385 and then not Is_Tagged_Type
(Typ
)
386 and then not Is_Frozen
(Typ
)
388 Append_Freeze_Action
(Id
, Build_Body_For_Renaming
(Typ
));
392 end Expand_N_Subprogram_Renaming_Declaration
;