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