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