1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
|
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- E X P _ C H 8 --
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING3. If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
with Atree; use Atree;
with Einfo; use Einfo;
with Exp_Ch4; use Exp_Ch4;
with Exp_Ch6; use Exp_Ch6;
with Exp_Dbug; use Exp_Dbug;
with Exp_Util; use Exp_Util;
with Freeze; use Freeze;
with Namet; use Namet;
with Nmake; use Nmake;
with Nlists; use Nlists;
with Opt; use Opt;
with Sem; use Sem;
with Sem_Ch8; use Sem_Ch8;
with Sem_Util; use Sem_Util;
with Sinfo; use Sinfo;
with Snames; use Snames;
with Stand; use Stand;
with Tbuild; use Tbuild;
package body Exp_Ch8 is
---------------------------------------------
-- Expand_N_Exception_Renaming_Declaration --
---------------------------------------------
procedure Expand_N_Exception_Renaming_Declaration (N : Node_Id) is
Decl : Node_Id;
begin
Decl := Debug_Renaming_Declaration (N);
if Present (Decl) then
Insert_Action (N, Decl);
end if;
end Expand_N_Exception_Renaming_Declaration;
------------------------------------------
-- Expand_N_Object_Renaming_Declaration --
------------------------------------------
-- Most object renaming cases can be done by just capturing the address
-- of the renamed object. The cases in which this is not true are when
-- this address is not computable, since it involves extraction of a
-- packed array element, or of a record component to which a component
-- clause applies (that can specify an arbitrary bit boundary), or where
-- the enclosing record itself has a non-standard representation.
-- In these two cases, we pre-evaluate the renaming expression, by
-- extracting and freezing the values of any subscripts, and then we
-- set the flag Is_Renaming_Of_Object which means that any reference
-- to the object will be handled by macro substitution in the front
-- end, and the back end will know to ignore the renaming declaration.
-- An additional odd case that requires processing by expansion is
-- the renaming of a discriminant of a mutable record type. The object
-- is a constant because it renames something that cannot be assigned to,
-- but in fact the underlying value can change and must be reevaluated
-- at each reference. Gigi does have a notion of a "constant view" of
-- an object, and therefore the front-end must perform the expansion.
-- For simplicity, and to bypass some obscure code-generation problem,
-- we use macro substitution for all renamed discriminants, whether the
-- enclosing type is constrained or not.
-- The other special processing required is for the case of renaming
-- of an object of a class wide type, where it is necessary to build
-- the appropriate subtype for the renamed object.
-- More comments needed for this para ???
procedure Expand_N_Object_Renaming_Declaration (N : Node_Id) is
Nam : constant Node_Id := Name (N);
Decl : Node_Id;
T : Entity_Id;
function Evaluation_Required (Nam : Node_Id) return Boolean;
-- Determines whether it is necessary to do static name evaluation for
-- renaming of Nam. It is considered necessary if evaluating the name
-- involves indexing a packed array, or extracting a component of a
-- record to which a component clause applies. Note that we are only
-- interested in these operations if they occur as part of the name
-- itself, subscripts are just values that are computed as part of the
-- evaluation, so their form is unimportant.
-- In addition, always return True for Modify_Tree_For_C since the
-- code generator doesn't know how to handle renamings.
-------------------------
-- Evaluation_Required --
-------------------------
function Evaluation_Required (Nam : Node_Id) return Boolean is
begin
if Modify_Tree_For_C then
return True;
elsif Nkind_In (Nam, N_Indexed_Component, N_Slice) then
if Is_Packed (Etype (Prefix (Nam))) then
return True;
else
return Evaluation_Required (Prefix (Nam));
end if;
elsif Nkind (Nam) = N_Selected_Component then
declare
Rec_Type : constant Entity_Id := Etype (Prefix (Nam));
begin
if Present (Component_Clause (Entity (Selector_Name (Nam))))
or else Has_Non_Standard_Rep (Rec_Type)
then
return True;
elsif Ekind (Entity (Selector_Name (Nam))) = E_Discriminant
and then Is_Record_Type (Rec_Type)
and then not Is_Concurrent_Record_Type (Rec_Type)
then
return True;
else
return Evaluation_Required (Prefix (Nam));
end if;
end;
else
return False;
end if;
end Evaluation_Required;
-- Start of processing for Expand_N_Object_Renaming_Declaration
begin
-- Perform name evaluation if required
if Evaluation_Required (Nam) then
Evaluate_Name (Nam);
Set_Is_Renaming_Of_Object (Defining_Identifier (N));
end if;
-- Deal with construction of subtype in class-wide case
T := Etype (Defining_Identifier (N));
if Is_Class_Wide_Type (T) then
Expand_Subtype_From_Expr (N, T, Subtype_Mark (N), Name (N));
Find_Type (Subtype_Mark (N));
Set_Etype (Defining_Identifier (N), Entity (Subtype_Mark (N)));
-- Freeze the class-wide subtype here to ensure that the subtype
-- and equivalent type are frozen before the renaming.
Freeze_Before (N, Entity (Subtype_Mark (N)));
end if;
-- Ada 2005 (AI-318-02): If the renamed object is a call to a build-in-
-- place function, then a temporary return object needs to be created
-- and access to it must be passed to the function. Currently we limit
-- such functions to those with inherently limited result subtypes, but
-- eventually we plan to expand the functions that are treated as
-- build-in-place to include other composite result types.
if Ada_Version >= Ada_2005
and then Is_Build_In_Place_Function_Call (Nam)
then
Make_Build_In_Place_Call_In_Anonymous_Context (Nam);
end if;
-- Create renaming entry for debug information
Decl := Debug_Renaming_Declaration (N);
if Present (Decl) then
Insert_Action (N, Decl);
end if;
end Expand_N_Object_Renaming_Declaration;
-------------------------------------------
-- Expand_N_Package_Renaming_Declaration --
-------------------------------------------
procedure Expand_N_Package_Renaming_Declaration (N : Node_Id) is
Decl : Node_Id;
begin
Decl := Debug_Renaming_Declaration (N);
if Present (Decl) then
-- If we are in a compilation unit, then this is an outer
-- level declaration, and must have a scope of Standard
if Nkind (Parent (N)) = N_Compilation_Unit then
declare
Aux : constant Node_Id := Aux_Decls_Node (Parent (N));
begin
Push_Scope (Standard_Standard);
if No (Actions (Aux)) then
Set_Actions (Aux, New_List (Decl));
else
Append (Decl, Actions (Aux));
end if;
Analyze (Decl);
-- Enter the debug variable in the qualification list, which
-- must be done at this point because auxiliary declarations
-- occur at the library level and aren't associated with a
-- normal scope.
Qualify_Entity_Names (Decl);
Pop_Scope;
end;
-- Otherwise, just insert after the package declaration
else
Insert_Action (N, Decl);
end if;
end if;
end Expand_N_Package_Renaming_Declaration;
----------------------------------------------
-- Expand_N_Subprogram_Renaming_Declaration --
----------------------------------------------
procedure Expand_N_Subprogram_Renaming_Declaration (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Id : constant Entity_Id := Defining_Entity (N);
function Build_Body_For_Renaming return Node_Id;
-- Build and return the body for the renaming declaration of an equality
-- or inequality operator.
-----------------------------
-- Build_Body_For_Renaming --
-----------------------------
function Build_Body_For_Renaming return Node_Id is
Body_Id : Entity_Id;
Decl : Node_Id;
begin
Set_Alias (Id, Empty);
Set_Has_Completion (Id, False);
Rewrite (N,
Make_Subprogram_Declaration (Sloc (N),
Specification => Specification (N)));
Set_Has_Delayed_Freeze (Id);
Body_Id := Make_Defining_Identifier (Sloc (N), Chars (Id));
Set_Debug_Info_Needed (Body_Id);
Decl :=
Make_Subprogram_Body (Loc,
Specification =>
Make_Function_Specification (Loc,
Defining_Unit_Name => Body_Id,
Parameter_Specifications => Copy_Parameter_List (Id),
Result_Definition =>
New_Occurrence_Of (Standard_Boolean, Loc)),
Declarations => Empty_List,
Handled_Statement_Sequence => Empty);
return Decl;
end Build_Body_For_Renaming;
-- Local variables
Nam : constant Node_Id := Name (N);
-- Start of processing for Expand_N_Subprogram_Renaming_Declaration
begin
-- When the prefix of the name is a function call, we must force the
-- call to be made by removing side effects from the call, since we
-- must only call the function once.
if Nkind (Nam) = N_Selected_Component
and then Nkind (Prefix (Nam)) = N_Function_Call
then
Remove_Side_Effects (Prefix (Nam));
-- For an explicit dereference, the prefix must be captured to prevent
-- reevaluation on calls through the renaming, which could result in
-- calling the wrong subprogram if the access value were to be changed.
elsif Nkind (Nam) = N_Explicit_Dereference then
Force_Evaluation (Prefix (Nam));
end if;
-- Handle cases where we build a body for a renamed equality
if Is_Entity_Name (Nam)
and then Chars (Entity (Nam)) = Name_Op_Eq
and then Scope (Entity (Nam)) = Standard_Standard
then
declare
Left : constant Entity_Id := First_Formal (Id);
Right : constant Entity_Id := Next_Formal (Left);
Typ : constant Entity_Id := Etype (Left);
Decl : Node_Id;
begin
-- Check whether this is a renaming of a predefined equality on an
-- untagged record type (AI05-0123).
if Ada_Version >= Ada_2012
and then Is_Record_Type (Typ)
and then not Is_Tagged_Type (Typ)
and then not Is_Frozen (Typ)
then
-- Build body for renamed equality, to capture its current
-- meaning. It may be redefined later, but the renaming is
-- elaborated where it occurs. This is technically known as
-- Squirreling semantics. Renaming is rewritten as a subprogram
-- declaration, and the generated body is inserted into the
-- freeze actions for the subprogram.
Decl := Build_Body_For_Renaming;
Set_Handled_Statement_Sequence (Decl,
Make_Handled_Sequence_Of_Statements (Loc,
Statements => New_List (
Make_Simple_Return_Statement (Loc,
Expression =>
Expand_Record_Equality
(Id,
Typ => Typ,
Lhs => Make_Identifier (Loc, Chars (Left)),
Rhs => Make_Identifier (Loc, Chars (Right)),
Bodies => Declarations (Decl))))));
Append_Freeze_Action (Id, Decl);
end if;
end;
end if;
end Expand_N_Subprogram_Renaming_Declaration;
end Exp_Ch8;
|
