|
111
|
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-2017, 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 Namet; use Namet;
|
|
|
34 with Nmake; use Nmake;
|
|
|
35 with Nlists; use Nlists;
|
|
|
36 with Opt; use Opt;
|
|
|
37 with Sem; use Sem;
|
|
|
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;
|
|
|
44
|
|
|
45 package body Exp_Ch8 is
|
|
|
46
|
|
|
47 ---------------------------------------------
|
|
|
48 -- Expand_N_Exception_Renaming_Declaration --
|
|
|
49 ---------------------------------------------
|
|
|
50
|
|
|
51 procedure Expand_N_Exception_Renaming_Declaration (N : Node_Id) is
|
|
|
52 Decl : Node_Id;
|
|
|
53
|
|
|
54 begin
|
|
|
55 Decl := Debug_Renaming_Declaration (N);
|
|
|
56
|
|
|
57 if Present (Decl) then
|
|
|
58 Insert_Action (N, Decl);
|
|
|
59 end if;
|
|
|
60 end Expand_N_Exception_Renaming_Declaration;
|
|
|
61
|
|
|
62 ------------------------------------------
|
|
|
63 -- Expand_N_Object_Renaming_Declaration --
|
|
|
64 ------------------------------------------
|
|
|
65
|
|
|
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.
|
|
|
72
|
|
|
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.
|
|
|
78
|
|
|
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.
|
|
|
88
|
|
|
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 ???
|
|
|
93
|
|
|
94 procedure Expand_N_Object_Renaming_Declaration (N : Node_Id) is
|
|
|
95 Nam : constant Node_Id := Name (N);
|
|
|
96 Decl : Node_Id;
|
|
|
97 T : Entity_Id;
|
|
|
98
|
|
|
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.
|
|
|
109
|
|
|
110 -------------------------
|
|
|
111 -- Evaluation_Required --
|
|
|
112 -------------------------
|
|
|
113
|
|
|
114 function Evaluation_Required (Nam : Node_Id) return Boolean is
|
|
|
115 begin
|
|
|
116 if Modify_Tree_For_C then
|
|
|
117 return True;
|
|
|
118
|
|
|
119 elsif Nkind_In (Nam, N_Indexed_Component, N_Slice) then
|
|
|
120 if Is_Packed (Etype (Prefix (Nam))) then
|
|
|
121 return True;
|
|
|
122 else
|
|
|
123 return Evaluation_Required (Prefix (Nam));
|
|
|
124 end if;
|
|
|
125
|
|
|
126 elsif Nkind (Nam) = N_Selected_Component then
|
|
|
127 declare
|
|
|
128 Rec_Type : constant Entity_Id := Etype (Prefix (Nam));
|
|
|
129
|
|
|
130 begin
|
|
|
131 if Present (Component_Clause (Entity (Selector_Name (Nam))))
|
|
|
132 or else Has_Non_Standard_Rep (Rec_Type)
|
|
|
133 then
|
|
|
134 return True;
|
|
|
135
|
|
|
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)
|
|
|
139 then
|
|
|
140 return True;
|
|
|
141
|
|
|
142 else
|
|
|
143 return Evaluation_Required (Prefix (Nam));
|
|
|
144 end if;
|
|
|
145 end;
|
|
|
146
|
|
|
147 else
|
|
|
148 return False;
|
|
|
149 end if;
|
|
|
150 end Evaluation_Required;
|
|
|
151
|
|
|
152 -- Start of processing for Expand_N_Object_Renaming_Declaration
|
|
|
153
|
|
|
154 begin
|
|
|
155 -- Perform name evaluation if required
|
|
|
156
|
|
|
157 if Evaluation_Required (Nam) then
|
|
|
158 Evaluate_Name (Nam);
|
|
|
159 Set_Is_Renaming_Of_Object (Defining_Identifier (N));
|
|
|
160 end if;
|
|
|
161
|
|
|
162 -- Deal with construction of subtype in class-wide case
|
|
|
163
|
|
|
164 T := Etype (Defining_Identifier (N));
|
|
|
165
|
|
|
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)));
|
|
|
170
|
|
|
171 -- Freeze the class-wide subtype here to ensure that the subtype
|
|
|
172 -- and equivalent type are frozen before the renaming.
|
|
|
173
|
|
|
174 Freeze_Before (N, Entity (Subtype_Mark (N)));
|
|
|
175 end if;
|
|
|
176
|
|
|
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.
|
|
|
180
|
|
|
181 if Is_Build_In_Place_Function_Call (Nam) then
|
|
|
182 Make_Build_In_Place_Call_In_Anonymous_Context (Nam);
|
|
|
183
|
|
|
184 -- Ada 2005 (AI-318-02): Specialization of previous case for renaming
|
|
|
185 -- containing build-in-place function calls whose returned object covers
|
|
|
186 -- interface types.
|
|
|
187
|
|
|
188 elsif Present (Unqual_BIP_Iface_Function_Call (Nam)) then
|
|
|
189 Make_Build_In_Place_Iface_Call_In_Anonymous_Context (Nam);
|
|
|
190 end if;
|
|
|
191
|
|
|
192 -- Create renaming entry for debug information. Mark the entity as
|
|
|
193 -- needing debug info if it comes from sources because the current
|
|
|
194 -- setting in Freeze_Entity occurs too late. ???
|
|
|
195
|
|
|
196 if Comes_From_Source (Defining_Identifier (N)) then
|
|
|
197 Set_Debug_Info_Needed (Defining_Identifier (N));
|
|
|
198 end if;
|
|
|
199
|
|
|
200 Decl := Debug_Renaming_Declaration (N);
|
|
|
201
|
|
|
202 if Present (Decl) then
|
|
|
203 Insert_Action (N, Decl);
|
|
|
204 end if;
|
|
|
205 end Expand_N_Object_Renaming_Declaration;
|
|
|
206
|
|
|
207 -------------------------------------------
|
|
|
208 -- Expand_N_Package_Renaming_Declaration --
|
|
|
209 -------------------------------------------
|
|
|
210
|
|
|
211 procedure Expand_N_Package_Renaming_Declaration (N : Node_Id) is
|
|
|
212 Decl : Node_Id;
|
|
|
213
|
|
|
214 begin
|
|
|
215 Decl := Debug_Renaming_Declaration (N);
|
|
|
216
|
|
|
217 if Present (Decl) then
|
|
|
218
|
|
|
219 -- If we are in a compilation unit, then this is an outer
|
|
|
220 -- level declaration, and must have a scope of Standard
|
|
|
221
|
|
|
222 if Nkind (Parent (N)) = N_Compilation_Unit then
|
|
|
223 declare
|
|
|
224 Aux : constant Node_Id := Aux_Decls_Node (Parent (N));
|
|
|
225
|
|
|
226 begin
|
|
|
227 Push_Scope (Standard_Standard);
|
|
|
228
|
|
|
229 if No (Actions (Aux)) then
|
|
|
230 Set_Actions (Aux, New_List (Decl));
|
|
|
231 else
|
|
|
232 Append (Decl, Actions (Aux));
|
|
|
233 end if;
|
|
|
234
|
|
|
235 Analyze (Decl);
|
|
|
236
|
|
|
237 -- Enter the debug variable in the qualification list, which
|
|
|
238 -- must be done at this point because auxiliary declarations
|
|
|
239 -- occur at the library level and aren't associated with a
|
|
|
240 -- normal scope.
|
|
|
241
|
|
|
242 Qualify_Entity_Names (Decl);
|
|
|
243
|
|
|
244 Pop_Scope;
|
|
|
245 end;
|
|
|
246
|
|
|
247 -- Otherwise, just insert after the package declaration
|
|
|
248
|
|
|
249 else
|
|
|
250 Insert_Action (N, Decl);
|
|
|
251 end if;
|
|
|
252 end if;
|
|
|
253 end Expand_N_Package_Renaming_Declaration;
|
|
|
254
|
|
|
255 ----------------------------------------------
|
|
|
256 -- Expand_N_Subprogram_Renaming_Declaration --
|
|
|
257 ----------------------------------------------
|
|
|
258
|
|
|
259 procedure Expand_N_Subprogram_Renaming_Declaration (N : Node_Id) is
|
|
|
260 Loc : constant Source_Ptr := Sloc (N);
|
|
|
261 Id : constant Entity_Id := Defining_Entity (N);
|
|
|
262
|
|
|
263 function Build_Body_For_Renaming return Node_Id;
|
|
|
264 -- Build and return the body for the renaming declaration of an equality
|
|
|
265 -- or inequality operator.
|
|
|
266
|
|
|
267 -----------------------------
|
|
|
268 -- Build_Body_For_Renaming --
|
|
|
269 -----------------------------
|
|
|
270
|
|
|
271 function Build_Body_For_Renaming return Node_Id is
|
|
|
272 Body_Id : Entity_Id;
|
|
|
273 Decl : Node_Id;
|
|
|
274
|
|
|
275 begin
|
|
|
276 Set_Alias (Id, Empty);
|
|
|
277 Set_Has_Completion (Id, False);
|
|
|
278 Rewrite (N,
|
|
|
279 Make_Subprogram_Declaration (Sloc (N),
|
|
|
280 Specification => Specification (N)));
|
|
|
281 Set_Has_Delayed_Freeze (Id);
|
|
|
282
|
|
|
283 Body_Id := Make_Defining_Identifier (Sloc (N), Chars (Id));
|
|
|
284 Set_Debug_Info_Needed (Body_Id);
|
|
|
285
|
|
|
286 Decl :=
|
|
|
287 Make_Subprogram_Body (Loc,
|
|
|
288 Specification =>
|
|
|
289 Make_Function_Specification (Loc,
|
|
|
290 Defining_Unit_Name => Body_Id,
|
|
|
291 Parameter_Specifications => Copy_Parameter_List (Id),
|
|
|
292 Result_Definition =>
|
|
|
293 New_Occurrence_Of (Standard_Boolean, Loc)),
|
|
|
294 Declarations => Empty_List,
|
|
|
295 Handled_Statement_Sequence => Empty);
|
|
|
296
|
|
|
297 return Decl;
|
|
|
298 end Build_Body_For_Renaming;
|
|
|
299
|
|
|
300 -- Local variables
|
|
|
301
|
|
|
302 Nam : constant Node_Id := Name (N);
|
|
|
303
|
|
|
304 -- Start of processing for Expand_N_Subprogram_Renaming_Declaration
|
|
|
305
|
|
|
306 begin
|
|
|
307 -- When the prefix of the name is a function call, we must force the
|
|
|
308 -- call to be made by removing side effects from the call, since we
|
|
|
309 -- must only call the function once.
|
|
|
310
|
|
|
311 if Nkind (Nam) = N_Selected_Component
|
|
|
312 and then Nkind (Prefix (Nam)) = N_Function_Call
|
|
|
313 then
|
|
|
314 Remove_Side_Effects (Prefix (Nam));
|
|
|
315
|
|
|
316 -- For an explicit dereference, the prefix must be captured to prevent
|
|
|
317 -- reevaluation on calls through the renaming, which could result in
|
|
|
318 -- calling the wrong subprogram if the access value were to be changed.
|
|
|
319
|
|
|
320 elsif Nkind (Nam) = N_Explicit_Dereference then
|
|
|
321 Force_Evaluation (Prefix (Nam));
|
|
|
322 end if;
|
|
|
323
|
|
|
324 -- Handle cases where we build a body for a renamed equality
|
|
|
325
|
|
|
326 if Is_Entity_Name (Nam)
|
|
|
327 and then Chars (Entity (Nam)) = Name_Op_Eq
|
|
|
328 and then Scope (Entity (Nam)) = Standard_Standard
|
|
|
329 then
|
|
|
330 declare
|
|
|
331 Left : constant Entity_Id := First_Formal (Id);
|
|
|
332 Right : constant Entity_Id := Next_Formal (Left);
|
|
|
333 Typ : constant Entity_Id := Etype (Left);
|
|
|
334 Decl : Node_Id;
|
|
|
335
|
|
|
336 begin
|
|
|
337 -- Check whether this is a renaming of a predefined equality on an
|
|
|
338 -- untagged record type (AI05-0123).
|
|
|
339
|
|
|
340 if Ada_Version >= Ada_2012
|
|
|
341 and then Is_Record_Type (Typ)
|
|
|
342 and then not Is_Tagged_Type (Typ)
|
|
|
343 and then not Is_Frozen (Typ)
|
|
|
344 then
|
|
|
345 -- Build body for renamed equality, to capture its current
|
|
|
346 -- meaning. It may be redefined later, but the renaming is
|
|
|
347 -- elaborated where it occurs. This is technically known as
|
|
|
348 -- Squirreling semantics. Renaming is rewritten as a subprogram
|
|
|
349 -- declaration, and the generated body is inserted into the
|
|
|
350 -- freeze actions for the subprogram.
|
|
|
351
|
|
|
352 Decl := Build_Body_For_Renaming;
|
|
|
353
|
|
|
354 Set_Handled_Statement_Sequence (Decl,
|
|
|
355 Make_Handled_Sequence_Of_Statements (Loc,
|
|
|
356 Statements => New_List (
|
|
|
357 Make_Simple_Return_Statement (Loc,
|
|
|
358 Expression =>
|
|
|
359 Expand_Record_Equality
|
|
|
360 (Id,
|
|
|
361 Typ => Typ,
|
|
|
362 Lhs => Make_Identifier (Loc, Chars (Left)),
|
|
|
363 Rhs => Make_Identifier (Loc, Chars (Right)),
|
|
|
364 Bodies => Declarations (Decl))))));
|
|
|
365
|
|
|
366 Append_Freeze_Action (Id, Decl);
|
|
|
367 end if;
|
|
|
368 end;
|
|
|
369 end if;
|
|
|
370 end Expand_N_Subprogram_Renaming_Declaration;
|
|
|
371
|
|
|
372 end Exp_Ch8;
|
