1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2016, 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_Ch4
; use Exp_Ch4
;
29 with Exp_Ch6
; use Exp_Ch6
;
30 with Exp_Dbug
; use Exp_Dbug
;
31 with Exp_Util
; use Exp_Util
;
32 with Freeze
; use Freeze
;
33 with Namet
; use Namet
;
34 with Nmake
; use Nmake
;
35 with Nlists
; use Nlists
;
38 with Sem_Ch8
; use Sem_Ch8
;
39 with Sem_Util
; use Sem_Util
;
40 with Sinfo
; use Sinfo
;
41 with Snames
; use Snames
;
42 with Stand
; use Stand
;
43 with Tbuild
; use Tbuild
;
45 package body Exp_Ch8
is
47 ---------------------------------------------
48 -- Expand_N_Exception_Renaming_Declaration --
49 ---------------------------------------------
51 procedure Expand_N_Exception_Renaming_Declaration
(N
: Node_Id
) is
55 Decl
:= Debug_Renaming_Declaration
(N
);
57 if Present
(Decl
) then
58 Insert_Action
(N
, Decl
);
60 end Expand_N_Exception_Renaming_Declaration
;
62 ------------------------------------------
63 -- Expand_N_Object_Renaming_Declaration --
64 ------------------------------------------
66 -- Most object renaming cases can be done by just capturing the address
67 -- of the renamed object. The cases in which this is not true are when
68 -- this address is not computable, since it involves extraction of a
69 -- packed array element, or of a record component to which a component
70 -- clause applies (that can specify an arbitrary bit boundary), or where
71 -- the enclosing record itself has a non-standard representation.
73 -- In these two cases, we pre-evaluate the renaming expression, by
74 -- extracting and freezing the values of any subscripts, and then we
75 -- set the flag Is_Renaming_Of_Object which means that any reference
76 -- to the object will be handled by macro substitution in the front
77 -- end, and the back end will know to ignore the renaming declaration.
79 -- An additional odd case that requires processing by expansion is
80 -- the renaming of a discriminant of a mutable record type. The object
81 -- is a constant because it renames something that cannot be assigned to,
82 -- but in fact the underlying value can change and must be reevaluated
83 -- at each reference. Gigi does have a notion of a "constant view" of
84 -- an object, and therefore the front-end must perform the expansion.
85 -- For simplicity, and to bypass some obscure code-generation problem,
86 -- we use macro substitution for all renamed discriminants, whether the
87 -- enclosing type is constrained or not.
89 -- The other special processing required is for the case of renaming
90 -- of an object of a class wide type, where it is necessary to build
91 -- the appropriate subtype for the renamed object.
92 -- More comments needed for this para ???
94 procedure Expand_N_Object_Renaming_Declaration
(N
: Node_Id
) is
95 Nam
: constant Node_Id
:= Name
(N
);
99 function Evaluation_Required
(Nam
: Node_Id
) return Boolean;
100 -- Determines whether it is necessary to do static name evaluation for
101 -- renaming of Nam. It is considered necessary if evaluating the name
102 -- involves indexing a packed array, or extracting a component of a
103 -- record to which a component clause applies. Note that we are only
104 -- interested in these operations if they occur as part of the name
105 -- itself, subscripts are just values that are computed as part of the
106 -- evaluation, so their form is unimportant.
107 -- In addition, always return True for Modify_Tree_For_C since the
108 -- code generator doesn't know how to handle renamings.
110 -------------------------
111 -- Evaluation_Required --
112 -------------------------
114 function Evaluation_Required
(Nam
: Node_Id
) return Boolean is
116 if Modify_Tree_For_C
then
119 elsif Nkind_In
(Nam
, N_Indexed_Component
, N_Slice
) then
120 if Is_Packed
(Etype
(Prefix
(Nam
))) then
123 return Evaluation_Required
(Prefix
(Nam
));
126 elsif Nkind
(Nam
) = N_Selected_Component
then
128 Rec_Type
: constant Entity_Id
:= Etype
(Prefix
(Nam
));
131 if Present
(Component_Clause
(Entity
(Selector_Name
(Nam
))))
132 or else Has_Non_Standard_Rep
(Rec_Type
)
136 elsif Ekind
(Entity
(Selector_Name
(Nam
))) = E_Discriminant
137 and then Is_Record_Type
(Rec_Type
)
138 and then not Is_Concurrent_Record_Type
(Rec_Type
)
143 return Evaluation_Required
(Prefix
(Nam
));
150 end Evaluation_Required
;
152 -- Start of processing for Expand_N_Object_Renaming_Declaration
155 -- Perform name evaluation if required
157 if Evaluation_Required
(Nam
) then
159 Set_Is_Renaming_Of_Object
(Defining_Identifier
(N
));
162 -- Deal with construction of subtype in class-wide case
164 T
:= Etype
(Defining_Identifier
(N
));
166 if Is_Class_Wide_Type
(T
) then
167 Expand_Subtype_From_Expr
(N
, T
, Subtype_Mark
(N
), Name
(N
));
168 Find_Type
(Subtype_Mark
(N
));
169 Set_Etype
(Defining_Identifier
(N
), Entity
(Subtype_Mark
(N
)));
171 -- Freeze the class-wide subtype here to ensure that the subtype
172 -- and equivalent type are frozen before the renaming.
174 Freeze_Before
(N
, Entity
(Subtype_Mark
(N
)));
177 -- Ada 2005 (AI-318-02): If the renamed object is a call to a build-in-
178 -- place function, then a temporary return object needs to be created
179 -- and access to it must be passed to the function. Currently we limit
180 -- such functions to those with inherently limited result subtypes, but
181 -- eventually we plan to expand the functions that are treated as
182 -- build-in-place to include other composite result types.
184 if Ada_Version
>= Ada_2005
185 and then Is_Build_In_Place_Function_Call
(Nam
)
187 Make_Build_In_Place_Call_In_Anonymous_Context
(Nam
);
190 -- Create renaming entry for debug information. Mark the entity as
191 -- needing debug info if it comes from sources because the current
192 -- setting in Freeze_Entity occurs too late. ???
194 if Comes_From_Source
(Defining_Identifier
(N
)) then
195 Set_Debug_Info_Needed
(Defining_Identifier
(N
));
198 Decl
:= Debug_Renaming_Declaration
(N
);
200 if Present
(Decl
) then
201 Insert_Action
(N
, Decl
);
203 end Expand_N_Object_Renaming_Declaration
;
205 -------------------------------------------
206 -- Expand_N_Package_Renaming_Declaration --
207 -------------------------------------------
209 procedure Expand_N_Package_Renaming_Declaration
(N
: Node_Id
) is
213 Decl
:= Debug_Renaming_Declaration
(N
);
215 if Present
(Decl
) then
217 -- If we are in a compilation unit, then this is an outer
218 -- level declaration, and must have a scope of Standard
220 if Nkind
(Parent
(N
)) = N_Compilation_Unit
then
222 Aux
: constant Node_Id
:= Aux_Decls_Node
(Parent
(N
));
225 Push_Scope
(Standard_Standard
);
227 if No
(Actions
(Aux
)) then
228 Set_Actions
(Aux
, New_List
(Decl
));
230 Append
(Decl
, Actions
(Aux
));
235 -- Enter the debug variable in the qualification list, which
236 -- must be done at this point because auxiliary declarations
237 -- occur at the library level and aren't associated with a
240 Qualify_Entity_Names
(Decl
);
245 -- Otherwise, just insert after the package declaration
248 Insert_Action
(N
, Decl
);
251 end Expand_N_Package_Renaming_Declaration
;
253 ----------------------------------------------
254 -- Expand_N_Subprogram_Renaming_Declaration --
255 ----------------------------------------------
257 procedure Expand_N_Subprogram_Renaming_Declaration
(N
: Node_Id
) is
258 Loc
: constant Source_Ptr
:= Sloc
(N
);
259 Id
: constant Entity_Id
:= Defining_Entity
(N
);
261 function Build_Body_For_Renaming
return Node_Id
;
262 -- Build and return the body for the renaming declaration of an equality
263 -- or inequality operator.
265 -----------------------------
266 -- Build_Body_For_Renaming --
267 -----------------------------
269 function Build_Body_For_Renaming
return Node_Id
is
274 Set_Alias
(Id
, Empty
);
275 Set_Has_Completion
(Id
, False);
277 Make_Subprogram_Declaration
(Sloc
(N
),
278 Specification
=> Specification
(N
)));
279 Set_Has_Delayed_Freeze
(Id
);
281 Body_Id
:= Make_Defining_Identifier
(Sloc
(N
), Chars
(Id
));
282 Set_Debug_Info_Needed
(Body_Id
);
285 Make_Subprogram_Body
(Loc
,
287 Make_Function_Specification
(Loc
,
288 Defining_Unit_Name
=> Body_Id
,
289 Parameter_Specifications
=> Copy_Parameter_List
(Id
),
291 New_Occurrence_Of
(Standard_Boolean
, Loc
)),
292 Declarations
=> Empty_List
,
293 Handled_Statement_Sequence
=> Empty
);
296 end Build_Body_For_Renaming
;
300 Nam
: constant Node_Id
:= Name
(N
);
302 -- Start of processing for Expand_N_Subprogram_Renaming_Declaration
305 -- When the prefix of the name is a function call, we must force the
306 -- call to be made by removing side effects from the call, since we
307 -- must only call the function once.
309 if Nkind
(Nam
) = N_Selected_Component
310 and then Nkind
(Prefix
(Nam
)) = N_Function_Call
312 Remove_Side_Effects
(Prefix
(Nam
));
314 -- For an explicit dereference, the prefix must be captured to prevent
315 -- reevaluation on calls through the renaming, which could result in
316 -- calling the wrong subprogram if the access value were to be changed.
318 elsif Nkind
(Nam
) = N_Explicit_Dereference
then
319 Force_Evaluation
(Prefix
(Nam
));
322 -- Handle cases where we build a body for a renamed equality
324 if Is_Entity_Name
(Nam
)
325 and then Chars
(Entity
(Nam
)) = Name_Op_Eq
326 and then Scope
(Entity
(Nam
)) = Standard_Standard
329 Left
: constant Entity_Id
:= First_Formal
(Id
);
330 Right
: constant Entity_Id
:= Next_Formal
(Left
);
331 Typ
: constant Entity_Id
:= Etype
(Left
);
335 -- Check whether this is a renaming of a predefined equality on an
336 -- untagged record type (AI05-0123).
338 if Ada_Version
>= Ada_2012
339 and then Is_Record_Type
(Typ
)
340 and then not Is_Tagged_Type
(Typ
)
341 and then not Is_Frozen
(Typ
)
343 -- Build body for renamed equality, to capture its current
344 -- meaning. It may be redefined later, but the renaming is
345 -- elaborated where it occurs. This is technically known as
346 -- Squirreling semantics. Renaming is rewritten as a subprogram
347 -- declaration, and the generated body is inserted into the
348 -- freeze actions for the subprogram.
350 Decl
:= Build_Body_For_Renaming
;
352 Set_Handled_Statement_Sequence
(Decl
,
353 Make_Handled_Sequence_Of_Statements
(Loc
,
354 Statements
=> New_List
(
355 Make_Simple_Return_Statement
(Loc
,
357 Expand_Record_Equality
360 Lhs
=> Make_Identifier
(Loc
, Chars
(Left
)),
361 Rhs
=> Make_Identifier
(Loc
, Chars
(Right
)),
362 Bodies
=> Declarations
(Decl
))))));
364 Append_Freeze_Action
(Id
, Decl
);
368 end Expand_N_Subprogram_Renaming_Declaration
;