Mercurial > hg > CbC > CbC_gcc

comparison gcc/ada/exp_ch8.adb @ 111:04ced10e8804

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
gcc 7
author kono
date Fri, 27 Oct 2017 22:46:09 +0900
parents
children 84e7813d76e9
comparison
equal deleted inserted replaced
68:561a7518be6b 111:04ced10e8804
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;