]>
Commit | Line | Data |
---|---|---|
01aef5ad | 1 | ------------------------------------------------------------------------------ |
70482933 RK |
2 | -- -- |
3 | -- GNAT COMPILER COMPONENTS -- | |
4 | -- -- | |
5 | -- E X P _ C H 6 -- | |
6 | -- -- | |
7 | -- B o d y -- | |
8 | -- -- | |
ab027d28 | 9 | -- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- |
70482933 RK |
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- -- | |
b5c84c3c | 13 | -- ware Foundation; either version 3, or (at your option) any later ver- -- |
70482933 RK |
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 -- | |
b5c84c3c RD |
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. -- | |
70482933 RK |
20 | -- -- |
21 | -- GNAT was originally developed by the GNAT team at New York University. -- | |
71ff80dc | 22 | -- Extensive contributions were provided by Ada Core Technologies Inc. -- |
70482933 RK |
23 | -- -- |
24 | ------------------------------------------------------------------------------ | |
25 | ||
26 | with Atree; use Atree; | |
27 | with Checks; use Checks; | |
28 | with Debug; use Debug; | |
29 | with Einfo; use Einfo; | |
30 | with Errout; use Errout; | |
31 | with Elists; use Elists; | |
f937473f | 32 | with Exp_Atag; use Exp_Atag; |
70482933 RK |
33 | with Exp_Ch2; use Exp_Ch2; |
34 | with Exp_Ch3; use Exp_Ch3; | |
35 | with Exp_Ch7; use Exp_Ch7; | |
36 | with Exp_Ch9; use Exp_Ch9; | |
70482933 RK |
37 | with Exp_Dbug; use Exp_Dbug; |
38 | with Exp_Disp; use Exp_Disp; | |
39 | with Exp_Dist; use Exp_Dist; | |
40 | with Exp_Intr; use Exp_Intr; | |
41 | with Exp_Pakd; use Exp_Pakd; | |
42 | with Exp_Tss; use Exp_Tss; | |
43 | with Exp_Util; use Exp_Util; | |
c986420e | 44 | with Exp_VFpt; use Exp_VFpt; |
fbf5a39b | 45 | with Fname; use Fname; |
70482933 | 46 | with Freeze; use Freeze; |
70482933 RK |
47 | with Inline; use Inline; |
48 | with Lib; use Lib; | |
7888a6ae | 49 | with Namet; use Namet; |
70482933 RK |
50 | with Nlists; use Nlists; |
51 | with Nmake; use Nmake; | |
52 | with Opt; use Opt; | |
53 | with Restrict; use Restrict; | |
6e937c1c | 54 | with Rident; use Rident; |
70482933 RK |
55 | with Rtsfind; use Rtsfind; |
56 | with Sem; use Sem; | |
a4100e55 | 57 | with Sem_Aux; use Sem_Aux; |
70482933 RK |
58 | with Sem_Ch6; use Sem_Ch6; |
59 | with Sem_Ch8; use Sem_Ch8; | |
60 | with Sem_Ch12; use Sem_Ch12; | |
61 | with Sem_Ch13; use Sem_Ch13; | |
02822a92 | 62 | with Sem_Eval; use Sem_Eval; |
70482933 RK |
63 | with Sem_Disp; use Sem_Disp; |
64 | with Sem_Dist; use Sem_Dist; | |
758c442c | 65 | with Sem_Mech; use Sem_Mech; |
70482933 | 66 | with Sem_Res; use Sem_Res; |
d06b3b1d | 67 | with Sem_SCIL; use Sem_SCIL; |
70482933 RK |
68 | with Sem_Util; use Sem_Util; |
69 | with Sinfo; use Sinfo; | |
70 | with Snames; use Snames; | |
71 | with Stand; use Stand; | |
2b3d67a5 | 72 | with Targparm; use Targparm; |
70482933 RK |
73 | with Tbuild; use Tbuild; |
74 | with Uintp; use Uintp; | |
75 | with Validsw; use Validsw; | |
76 | ||
77 | package body Exp_Ch6 is | |
78 | ||
79 | ----------------------- | |
80 | -- Local Subprograms -- | |
81 | ----------------------- | |
82 | ||
02822a92 RD |
83 | procedure Add_Access_Actual_To_Build_In_Place_Call |
84 | (Function_Call : Node_Id; | |
85 | Function_Id : Entity_Id; | |
f937473f RD |
86 | Return_Object : Node_Id; |
87 | Is_Access : Boolean := False); | |
02822a92 RD |
88 | -- Ada 2005 (AI-318-02): Apply the Unrestricted_Access attribute to the |
89 | -- object name given by Return_Object and add the attribute to the end of | |
90 | -- the actual parameter list associated with the build-in-place function | |
f937473f RD |
91 | -- call denoted by Function_Call. However, if Is_Access is True, then |
92 | -- Return_Object is already an access expression, in which case it's passed | |
93 | -- along directly to the build-in-place function. Finally, if Return_Object | |
94 | -- is empty, then pass a null literal as the actual. | |
95 | ||
96 | procedure Add_Alloc_Form_Actual_To_Build_In_Place_Call | |
97 | (Function_Call : Node_Id; | |
98 | Function_Id : Entity_Id; | |
99 | Alloc_Form : BIP_Allocation_Form := Unspecified; | |
100 | Alloc_Form_Exp : Node_Id := Empty); | |
101 | -- Ada 2005 (AI-318-02): Add an actual indicating the form of allocation, | |
102 | -- if any, to be done by a build-in-place function. If Alloc_Form_Exp is | |
103 | -- present, then use it, otherwise pass a literal corresponding to the | |
104 | -- Alloc_Form parameter (which must not be Unspecified in that case). | |
105 | ||
106 | procedure Add_Extra_Actual_To_Call | |
107 | (Subprogram_Call : Node_Id; | |
108 | Extra_Formal : Entity_Id; | |
109 | Extra_Actual : Node_Id); | |
110 | -- Adds Extra_Actual as a named parameter association for the formal | |
111 | -- Extra_Formal in Subprogram_Call. | |
112 | ||
df3e68b1 HK |
113 | procedure Add_Collection_Actual_To_Build_In_Place_Call |
114 | (Func_Call : Node_Id; | |
115 | Func_Id : Entity_Id; | |
116 | Ptr_Typ : Entity_Id := Empty); | |
117 | -- Ada 2005 (AI-318-02): If the result type of a build-in-place call needs | |
118 | -- finalization actions, add an actual parameter which is a pointer to the | |
119 | -- finalization collection of the caller. If Ptr_Typ is left Empty, this | |
120 | -- will result in an automatic "null" value for the actual. | |
f937473f RD |
121 | |
122 | procedure Add_Task_Actuals_To_Build_In_Place_Call | |
123 | (Function_Call : Node_Id; | |
124 | Function_Id : Entity_Id; | |
125 | Master_Actual : Node_Id); | |
126 | -- Ada 2005 (AI-318-02): For a build-in-place call, if the result type | |
127 | -- contains tasks, add two actual parameters: the master, and a pointer to | |
128 | -- the caller's activation chain. Master_Actual is the actual parameter | |
129 | -- expression to pass for the master. In most cases, this is the current | |
130 | -- master (_master). The two exceptions are: If the function call is the | |
131 | -- initialization expression for an allocator, we pass the master of the | |
6dfc5592 RD |
132 | -- access type. If the function call is the initialization expression for a |
133 | -- return object, we pass along the master passed in by the caller. The | |
134 | -- activation chain to pass is always the local one. Note: Master_Actual | |
dd386db0 | 135 | -- can be Empty, but only if there are no tasks. |
02822a92 | 136 | |
70482933 RK |
137 | procedure Check_Overriding_Operation (Subp : Entity_Id); |
138 | -- Subp is a dispatching operation. Check whether it may override an | |
139 | -- inherited private operation, in which case its DT entry is that of | |
140 | -- the hidden operation, not the one it may have received earlier. | |
141 | -- This must be done before emitting the code to set the corresponding | |
142 | -- DT to the address of the subprogram. The actual placement of Subp in | |
143 | -- the proper place in the list of primitive operations is done in | |
144 | -- Declare_Inherited_Private_Subprograms, which also has to deal with | |
145 | -- implicit operations. This duplication is unavoidable for now??? | |
146 | ||
147 | procedure Detect_Infinite_Recursion (N : Node_Id; Spec : Entity_Id); | |
148 | -- This procedure is called only if the subprogram body N, whose spec | |
149 | -- has the given entity Spec, contains a parameterless recursive call. | |
150 | -- It attempts to generate runtime code to detect if this a case of | |
151 | -- infinite recursion. | |
152 | -- | |
153 | -- The body is scanned to determine dependencies. If the only external | |
154 | -- dependencies are on a small set of scalar variables, then the values | |
155 | -- of these variables are captured on entry to the subprogram, and if | |
156 | -- the values are not changed for the call, we know immediately that | |
157 | -- we have an infinite recursion. | |
158 | ||
159 | procedure Expand_Actuals (N : Node_Id; Subp : Entity_Id); | |
f4d379b8 HK |
160 | -- For each actual of an in-out or out parameter which is a numeric |
161 | -- (view) conversion of the form T (A), where A denotes a variable, | |
162 | -- we insert the declaration: | |
70482933 | 163 | -- |
f4d379b8 | 164 | -- Temp : T[ := T (A)]; |
70482933 RK |
165 | -- |
166 | -- prior to the call. Then we replace the actual with a reference to Temp, | |
167 | -- and append the assignment: | |
168 | -- | |
fbf5a39b | 169 | -- A := TypeA (Temp); |
70482933 | 170 | -- |
1c6b973a AC |
171 | -- after the call. Here TypeA is the actual type of variable A. For out |
172 | -- parameters, the initial declaration has no expression. If A is not an | |
173 | -- entity name, we generate instead: | |
70482933 | 174 | -- |
fbf5a39b | 175 | -- Var : TypeA renames A; |
70482933 RK |
176 | -- Temp : T := Var; -- omitting expression for out parameter. |
177 | -- ... | |
fbf5a39b | 178 | -- Var := TypeA (Temp); |
70482933 RK |
179 | -- |
180 | -- For other in-out parameters, we emit the required constraint checks | |
181 | -- before and/or after the call. | |
fbf5a39b | 182 | -- |
1c6b973a AC |
183 | -- For all parameter modes, actuals that denote components and slices of |
184 | -- packed arrays are expanded into suitable temporaries. | |
f44fe430 RD |
185 | -- |
186 | -- For non-scalar objects that are possibly unaligned, add call by copy | |
187 | -- code (copy in for IN and IN OUT, copy out for OUT and IN OUT). | |
70482933 | 188 | |
df3e68b1 HK |
189 | procedure Expand_Ctrl_Function_Call (N : Node_Id); |
190 | -- N is a function call which returns a controlled object. Transform the | |
191 | -- call into a temporary which retrieves the returned object from the | |
192 | -- secondary stack using 'reference. | |
193 | ||
70482933 RK |
194 | procedure Expand_Inlined_Call |
195 | (N : Node_Id; | |
196 | Subp : Entity_Id; | |
197 | Orig_Subp : Entity_Id); | |
198 | -- If called subprogram can be inlined by the front-end, retrieve the | |
199 | -- analyzed body, replace formals with actuals and expand call in place. | |
200 | -- Generate thunks for actuals that are expressions, and insert the | |
201 | -- corresponding constant declarations before the call. If the original | |
202 | -- call is to a derived operation, the return type is the one of the | |
203 | -- derived operation, but the body is that of the original, so return | |
204 | -- expressions in the body must be converted to the desired type (which | |
205 | -- is simply not noted in the tree without inline expansion). | |
206 | ||
2b3d67a5 AC |
207 | procedure Expand_Non_Function_Return (N : Node_Id); |
208 | -- Called by Expand_N_Simple_Return_Statement in case we're returning from | |
209 | -- a procedure body, entry body, accept statement, or extended return | |
210 | -- statement. Note that all non-function returns are simple return | |
211 | -- statements. | |
212 | ||
70482933 RK |
213 | function Expand_Protected_Object_Reference |
214 | (N : Node_Id; | |
02822a92 | 215 | Scop : Entity_Id) return Node_Id; |
70482933 RK |
216 | |
217 | procedure Expand_Protected_Subprogram_Call | |
218 | (N : Node_Id; | |
219 | Subp : Entity_Id; | |
220 | Scop : Entity_Id); | |
221 | -- A call to a protected subprogram within the protected object may appear | |
222 | -- as a regular call. The list of actuals must be expanded to contain a | |
223 | -- reference to the object itself, and the call becomes a call to the | |
224 | -- corresponding protected subprogram. | |
225 | ||
8dbf3473 AC |
226 | function Is_Null_Procedure (Subp : Entity_Id) return Boolean; |
227 | -- Predicate to recognize stubbed procedures and null procedures, which | |
228 | -- can be inlined unconditionally in all cases. | |
229 | ||
2b3d67a5 AC |
230 | procedure Expand_Simple_Function_Return (N : Node_Id); |
231 | -- Expand simple return from function. In the case where we are returning | |
232 | -- from a function body this is called by Expand_N_Simple_Return_Statement. | |
233 | ||
02822a92 RD |
234 | ---------------------------------------------- |
235 | -- Add_Access_Actual_To_Build_In_Place_Call -- | |
236 | ---------------------------------------------- | |
237 | ||
238 | procedure Add_Access_Actual_To_Build_In_Place_Call | |
239 | (Function_Call : Node_Id; | |
240 | Function_Id : Entity_Id; | |
f937473f RD |
241 | Return_Object : Node_Id; |
242 | Is_Access : Boolean := False) | |
02822a92 RD |
243 | is |
244 | Loc : constant Source_Ptr := Sloc (Function_Call); | |
245 | Obj_Address : Node_Id; | |
f937473f | 246 | Obj_Acc_Formal : Entity_Id; |
02822a92 RD |
247 | |
248 | begin | |
f937473f | 249 | -- Locate the implicit access parameter in the called function |
02822a92 | 250 | |
f937473f | 251 | Obj_Acc_Formal := Build_In_Place_Formal (Function_Id, BIP_Object_Access); |
02822a92 | 252 | |
f937473f RD |
253 | -- If no return object is provided, then pass null |
254 | ||
255 | if not Present (Return_Object) then | |
256 | Obj_Address := Make_Null (Loc); | |
7888a6ae | 257 | Set_Parent (Obj_Address, Function_Call); |
02822a92 | 258 | |
f937473f RD |
259 | -- If Return_Object is already an expression of an access type, then use |
260 | -- it directly, since it must be an access value denoting the return | |
261 | -- object, and couldn't possibly be the return object itself. | |
262 | ||
263 | elsif Is_Access then | |
264 | Obj_Address := Return_Object; | |
7888a6ae | 265 | Set_Parent (Obj_Address, Function_Call); |
02822a92 RD |
266 | |
267 | -- Apply Unrestricted_Access to caller's return object | |
268 | ||
f937473f RD |
269 | else |
270 | Obj_Address := | |
271 | Make_Attribute_Reference (Loc, | |
272 | Prefix => Return_Object, | |
273 | Attribute_Name => Name_Unrestricted_Access); | |
7888a6ae GD |
274 | |
275 | Set_Parent (Return_Object, Obj_Address); | |
276 | Set_Parent (Obj_Address, Function_Call); | |
f937473f | 277 | end if; |
02822a92 RD |
278 | |
279 | Analyze_And_Resolve (Obj_Address, Etype (Obj_Acc_Formal)); | |
280 | ||
281 | -- Build the parameter association for the new actual and add it to the | |
282 | -- end of the function's actuals. | |
283 | ||
f937473f RD |
284 | Add_Extra_Actual_To_Call (Function_Call, Obj_Acc_Formal, Obj_Address); |
285 | end Add_Access_Actual_To_Build_In_Place_Call; | |
286 | ||
287 | -------------------------------------------------- | |
288 | -- Add_Alloc_Form_Actual_To_Build_In_Place_Call -- | |
289 | -------------------------------------------------- | |
290 | ||
291 | procedure Add_Alloc_Form_Actual_To_Build_In_Place_Call | |
292 | (Function_Call : Node_Id; | |
293 | Function_Id : Entity_Id; | |
294 | Alloc_Form : BIP_Allocation_Form := Unspecified; | |
295 | Alloc_Form_Exp : Node_Id := Empty) | |
296 | is | |
297 | Loc : constant Source_Ptr := Sloc (Function_Call); | |
298 | Alloc_Form_Actual : Node_Id; | |
299 | Alloc_Form_Formal : Node_Id; | |
300 | ||
301 | begin | |
7888a6ae GD |
302 | -- The allocation form generally doesn't need to be passed in the case |
303 | -- of a constrained result subtype, since normally the caller performs | |
304 | -- the allocation in that case. However this formal is still needed in | |
305 | -- the case where the function has a tagged result, because generally | |
306 | -- such functions can be called in a dispatching context and such calls | |
307 | -- must be handled like calls to class-wide functions. | |
308 | ||
309 | if Is_Constrained (Underlying_Type (Etype (Function_Id))) | |
310 | and then not Is_Tagged_Type (Underlying_Type (Etype (Function_Id))) | |
311 | then | |
312 | return; | |
313 | end if; | |
314 | ||
f937473f RD |
315 | -- Locate the implicit allocation form parameter in the called function. |
316 | -- Maybe it would be better for each implicit formal of a build-in-place | |
317 | -- function to have a flag or a Uint attribute to identify it. ??? | |
318 | ||
319 | Alloc_Form_Formal := Build_In_Place_Formal (Function_Id, BIP_Alloc_Form); | |
320 | ||
321 | if Present (Alloc_Form_Exp) then | |
322 | pragma Assert (Alloc_Form = Unspecified); | |
323 | ||
324 | Alloc_Form_Actual := Alloc_Form_Exp; | |
325 | ||
326 | else | |
327 | pragma Assert (Alloc_Form /= Unspecified); | |
328 | ||
329 | Alloc_Form_Actual := | |
330 | Make_Integer_Literal (Loc, | |
331 | Intval => UI_From_Int (BIP_Allocation_Form'Pos (Alloc_Form))); | |
332 | end if; | |
333 | ||
334 | Analyze_And_Resolve (Alloc_Form_Actual, Etype (Alloc_Form_Formal)); | |
335 | ||
336 | -- Build the parameter association for the new actual and add it to the | |
337 | -- end of the function's actuals. | |
338 | ||
339 | Add_Extra_Actual_To_Call | |
340 | (Function_Call, Alloc_Form_Formal, Alloc_Form_Actual); | |
341 | end Add_Alloc_Form_Actual_To_Build_In_Place_Call; | |
342 | ||
df3e68b1 HK |
343 | -------------------------------------------------- |
344 | -- Add_Collection_Actual_To_Build_In_Place_Call -- | |
345 | -------------------------------------------------- | |
346 | ||
347 | procedure Add_Collection_Actual_To_Build_In_Place_Call | |
348 | (Func_Call : Node_Id; | |
349 | Func_Id : Entity_Id; | |
350 | Ptr_Typ : Entity_Id := Empty) | |
351 | is | |
352 | begin | |
353 | if not Needs_BIP_Collection (Func_Id) then | |
354 | return; | |
355 | end if; | |
356 | ||
357 | declare | |
358 | Formal : constant Entity_Id := | |
359 | Build_In_Place_Formal (Func_Id, BIP_Collection); | |
360 | Loc : constant Source_Ptr := Sloc (Func_Call); | |
361 | ||
362 | Actual : Node_Id; | |
363 | Desig_Typ : Entity_Id; | |
364 | ||
365 | begin | |
366 | -- Case where the context does not require an actual collection | |
367 | ||
368 | if No (Ptr_Typ) then | |
369 | Actual := Make_Null (Loc); | |
370 | ||
371 | else | |
372 | Desig_Typ := Directly_Designated_Type (Ptr_Typ); | |
373 | ||
374 | -- Check for a library-level access type whose designated type has | |
375 | -- supressed finalization. Such an access types lack a collection. | |
376 | -- Pass a null actual to the callee in order to signal a missing | |
377 | -- collection. | |
378 | ||
379 | if Is_Library_Level_Entity (Ptr_Typ) | |
380 | and then Finalize_Storage_Only (Desig_Typ) | |
381 | then | |
382 | Actual := Make_Null (Loc); | |
383 | ||
384 | -- Types in need of finalization actions | |
385 | ||
386 | elsif Needs_Finalization (Desig_Typ) then | |
387 | ||
388 | -- The general mechanism of creating finalization collections | |
389 | -- for anonymous access types is disabled by default, otherwise | |
390 | -- collections will pop all over the place. Such types use | |
391 | -- context-specific collections. | |
392 | ||
393 | if Ekind (Ptr_Typ) = E_Anonymous_Access_Type | |
394 | and then No (Associated_Collection (Ptr_Typ)) | |
395 | then | |
396 | Build_Finalization_Collection | |
397 | (Typ => Ptr_Typ, | |
398 | Ins_Node => Associated_Node_For_Itype (Ptr_Typ), | |
399 | Encl_Scope => Scope (Ptr_Typ)); | |
400 | end if; | |
401 | ||
402 | -- Access-to-controlled types should always have a collection | |
403 | ||
404 | pragma Assert (Present (Associated_Collection (Ptr_Typ))); | |
405 | ||
406 | Actual := | |
407 | Make_Attribute_Reference (Loc, | |
408 | Prefix => | |
409 | New_Reference_To (Associated_Collection (Ptr_Typ), Loc), | |
410 | Attribute_Name => Name_Unrestricted_Access); | |
411 | ||
412 | -- Tagged types | |
413 | ||
414 | else | |
415 | Actual := Make_Null (Loc); | |
416 | end if; | |
417 | end if; | |
418 | ||
419 | Analyze_And_Resolve (Actual, Etype (Formal)); | |
420 | ||
421 | -- Build the parameter association for the new actual and add it to | |
422 | -- the end of the function's actuals. | |
423 | ||
424 | Add_Extra_Actual_To_Call (Func_Call, Formal, Actual); | |
425 | end; | |
426 | end Add_Collection_Actual_To_Build_In_Place_Call; | |
427 | ||
f937473f RD |
428 | ------------------------------ |
429 | -- Add_Extra_Actual_To_Call -- | |
430 | ------------------------------ | |
431 | ||
432 | procedure Add_Extra_Actual_To_Call | |
433 | (Subprogram_Call : Node_Id; | |
434 | Extra_Formal : Entity_Id; | |
435 | Extra_Actual : Node_Id) | |
436 | is | |
437 | Loc : constant Source_Ptr := Sloc (Subprogram_Call); | |
438 | Param_Assoc : Node_Id; | |
439 | ||
440 | begin | |
02822a92 RD |
441 | Param_Assoc := |
442 | Make_Parameter_Association (Loc, | |
f937473f RD |
443 | Selector_Name => New_Occurrence_Of (Extra_Formal, Loc), |
444 | Explicit_Actual_Parameter => Extra_Actual); | |
02822a92 | 445 | |
f937473f RD |
446 | Set_Parent (Param_Assoc, Subprogram_Call); |
447 | Set_Parent (Extra_Actual, Param_Assoc); | |
02822a92 | 448 | |
f937473f RD |
449 | if Present (Parameter_Associations (Subprogram_Call)) then |
450 | if Nkind (Last (Parameter_Associations (Subprogram_Call))) = | |
02822a92 RD |
451 | N_Parameter_Association |
452 | then | |
f937473f RD |
453 | |
454 | -- Find last named actual, and append | |
455 | ||
456 | declare | |
457 | L : Node_Id; | |
458 | begin | |
459 | L := First_Actual (Subprogram_Call); | |
460 | while Present (L) loop | |
461 | if No (Next_Actual (L)) then | |
462 | Set_Next_Named_Actual (Parent (L), Extra_Actual); | |
463 | exit; | |
464 | end if; | |
465 | Next_Actual (L); | |
466 | end loop; | |
467 | end; | |
468 | ||
02822a92 | 469 | else |
f937473f | 470 | Set_First_Named_Actual (Subprogram_Call, Extra_Actual); |
02822a92 RD |
471 | end if; |
472 | ||
f937473f | 473 | Append (Param_Assoc, To => Parameter_Associations (Subprogram_Call)); |
02822a92 RD |
474 | |
475 | else | |
f937473f RD |
476 | Set_Parameter_Associations (Subprogram_Call, New_List (Param_Assoc)); |
477 | Set_First_Named_Actual (Subprogram_Call, Extra_Actual); | |
02822a92 | 478 | end if; |
f937473f RD |
479 | end Add_Extra_Actual_To_Call; |
480 | ||
f937473f RD |
481 | --------------------------------------------- |
482 | -- Add_Task_Actuals_To_Build_In_Place_Call -- | |
483 | --------------------------------------------- | |
484 | ||
485 | procedure Add_Task_Actuals_To_Build_In_Place_Call | |
486 | (Function_Call : Node_Id; | |
487 | Function_Id : Entity_Id; | |
488 | Master_Actual : Node_Id) | |
f937473f | 489 | is |
44bf8eb0 AC |
490 | Loc : constant Source_Ptr := Sloc (Function_Call); |
491 | Actual : Node_Id := Master_Actual; | |
6dfc5592 | 492 | |
f937473f RD |
493 | begin |
494 | -- No such extra parameters are needed if there are no tasks | |
495 | ||
496 | if not Has_Task (Etype (Function_Id)) then | |
497 | return; | |
498 | end if; | |
499 | ||
44bf8eb0 AC |
500 | -- Use a dummy _master actual in case of No_Task_Hierarchy |
501 | ||
502 | if Restriction_Active (No_Task_Hierarchy) then | |
503 | Actual := New_Occurrence_Of (RTE (RE_Library_Task_Level), Loc); | |
504 | end if; | |
505 | ||
f937473f RD |
506 | -- The master |
507 | ||
508 | declare | |
509 | Master_Formal : Node_Id; | |
510 | begin | |
511 | -- Locate implicit master parameter in the called function | |
512 | ||
513 | Master_Formal := Build_In_Place_Formal (Function_Id, BIP_Master); | |
514 | ||
44bf8eb0 | 515 | Analyze_And_Resolve (Actual, Etype (Master_Formal)); |
f937473f RD |
516 | |
517 | -- Build the parameter association for the new actual and add it to | |
518 | -- the end of the function's actuals. | |
519 | ||
520 | Add_Extra_Actual_To_Call | |
44bf8eb0 | 521 | (Function_Call, Master_Formal, Actual); |
f937473f RD |
522 | end; |
523 | ||
524 | -- The activation chain | |
525 | ||
526 | declare | |
527 | Activation_Chain_Actual : Node_Id; | |
528 | Activation_Chain_Formal : Node_Id; | |
75a64833 | 529 | |
f937473f RD |
530 | begin |
531 | -- Locate implicit activation chain parameter in the called function | |
532 | ||
533 | Activation_Chain_Formal := Build_In_Place_Formal | |
534 | (Function_Id, BIP_Activation_Chain); | |
535 | ||
536 | -- Create the actual which is a pointer to the current activation | |
537 | -- chain | |
538 | ||
539 | Activation_Chain_Actual := | |
540 | Make_Attribute_Reference (Loc, | |
541 | Prefix => Make_Identifier (Loc, Name_uChain), | |
542 | Attribute_Name => Name_Unrestricted_Access); | |
543 | ||
544 | Analyze_And_Resolve | |
545 | (Activation_Chain_Actual, Etype (Activation_Chain_Formal)); | |
546 | ||
547 | -- Build the parameter association for the new actual and add it to | |
548 | -- the end of the function's actuals. | |
549 | ||
550 | Add_Extra_Actual_To_Call | |
551 | (Function_Call, Activation_Chain_Formal, Activation_Chain_Actual); | |
552 | end; | |
553 | end Add_Task_Actuals_To_Build_In_Place_Call; | |
554 | ||
555 | ----------------------- | |
556 | -- BIP_Formal_Suffix -- | |
557 | ----------------------- | |
558 | ||
559 | function BIP_Formal_Suffix (Kind : BIP_Formal_Kind) return String is | |
560 | begin | |
561 | case Kind is | |
562 | when BIP_Alloc_Form => | |
563 | return "BIPalloc"; | |
df3e68b1 HK |
564 | when BIP_Collection => |
565 | return "BIPcollection"; | |
f937473f RD |
566 | when BIP_Master => |
567 | return "BIPmaster"; | |
568 | when BIP_Activation_Chain => | |
569 | return "BIPactivationchain"; | |
570 | when BIP_Object_Access => | |
571 | return "BIPaccess"; | |
572 | end case; | |
573 | end BIP_Formal_Suffix; | |
574 | ||
575 | --------------------------- | |
576 | -- Build_In_Place_Formal -- | |
577 | --------------------------- | |
578 | ||
579 | function Build_In_Place_Formal | |
580 | (Func : Entity_Id; | |
581 | Kind : BIP_Formal_Kind) return Entity_Id | |
582 | is | |
583 | Extra_Formal : Entity_Id := Extra_Formals (Func); | |
584 | ||
585 | begin | |
586 | -- Maybe it would be better for each implicit formal of a build-in-place | |
587 | -- function to have a flag or a Uint attribute to identify it. ??? | |
588 | ||
589 | loop | |
19590d70 | 590 | pragma Assert (Present (Extra_Formal)); |
f937473f RD |
591 | exit when |
592 | Chars (Extra_Formal) = | |
593 | New_External_Name (Chars (Func), BIP_Formal_Suffix (Kind)); | |
594 | Next_Formal_With_Extras (Extra_Formal); | |
595 | end loop; | |
596 | ||
f937473f RD |
597 | return Extra_Formal; |
598 | end Build_In_Place_Formal; | |
02822a92 | 599 | |
c9a4817d RD |
600 | -------------------------------- |
601 | -- Check_Overriding_Operation -- | |
602 | -------------------------------- | |
70482933 RK |
603 | |
604 | procedure Check_Overriding_Operation (Subp : Entity_Id) is | |
605 | Typ : constant Entity_Id := Find_Dispatching_Type (Subp); | |
606 | Op_List : constant Elist_Id := Primitive_Operations (Typ); | |
607 | Op_Elmt : Elmt_Id; | |
608 | Prim_Op : Entity_Id; | |
609 | Par_Op : Entity_Id; | |
610 | ||
611 | begin | |
612 | if Is_Derived_Type (Typ) | |
613 | and then not Is_Private_Type (Typ) | |
614 | and then In_Open_Scopes (Scope (Etype (Typ))) | |
d347f572 | 615 | and then Is_Base_Type (Typ) |
70482933 | 616 | then |
2f1b20a9 ES |
617 | -- Subp overrides an inherited private operation if there is an |
618 | -- inherited operation with a different name than Subp (see | |
619 | -- Derive_Subprogram) whose Alias is a hidden subprogram with the | |
620 | -- same name as Subp. | |
70482933 RK |
621 | |
622 | Op_Elmt := First_Elmt (Op_List); | |
623 | while Present (Op_Elmt) loop | |
624 | Prim_Op := Node (Op_Elmt); | |
625 | Par_Op := Alias (Prim_Op); | |
626 | ||
627 | if Present (Par_Op) | |
628 | and then not Comes_From_Source (Prim_Op) | |
629 | and then Chars (Prim_Op) /= Chars (Par_Op) | |
630 | and then Chars (Par_Op) = Chars (Subp) | |
631 | and then Is_Hidden (Par_Op) | |
632 | and then Type_Conformant (Prim_Op, Subp) | |
633 | then | |
634 | Set_DT_Position (Subp, DT_Position (Prim_Op)); | |
635 | end if; | |
636 | ||
637 | Next_Elmt (Op_Elmt); | |
638 | end loop; | |
639 | end if; | |
640 | end Check_Overriding_Operation; | |
641 | ||
642 | ------------------------------- | |
643 | -- Detect_Infinite_Recursion -- | |
644 | ------------------------------- | |
645 | ||
646 | procedure Detect_Infinite_Recursion (N : Node_Id; Spec : Entity_Id) is | |
647 | Loc : constant Source_Ptr := Sloc (N); | |
648 | ||
fbf5a39b | 649 | Var_List : constant Elist_Id := New_Elmt_List; |
70482933 RK |
650 | -- List of globals referenced by body of procedure |
651 | ||
fbf5a39b | 652 | Call_List : constant Elist_Id := New_Elmt_List; |
70482933 RK |
653 | -- List of recursive calls in body of procedure |
654 | ||
fbf5a39b | 655 | Shad_List : constant Elist_Id := New_Elmt_List; |
2f1b20a9 ES |
656 | -- List of entity id's for entities created to capture the value of |
657 | -- referenced globals on entry to the procedure. | |
70482933 RK |
658 | |
659 | Scop : constant Uint := Scope_Depth (Spec); | |
2f1b20a9 ES |
660 | -- This is used to record the scope depth of the current procedure, so |
661 | -- that we can identify global references. | |
70482933 RK |
662 | |
663 | Max_Vars : constant := 4; | |
664 | -- Do not test more than four global variables | |
665 | ||
666 | Count_Vars : Natural := 0; | |
667 | -- Count variables found so far | |
668 | ||
669 | Var : Entity_Id; | |
670 | Elm : Elmt_Id; | |
671 | Ent : Entity_Id; | |
672 | Call : Elmt_Id; | |
673 | Decl : Node_Id; | |
674 | Test : Node_Id; | |
675 | Elm1 : Elmt_Id; | |
676 | Elm2 : Elmt_Id; | |
677 | Last : Node_Id; | |
678 | ||
679 | function Process (Nod : Node_Id) return Traverse_Result; | |
680 | -- Function to traverse the subprogram body (using Traverse_Func) | |
681 | ||
682 | ------------- | |
683 | -- Process -- | |
684 | ------------- | |
685 | ||
686 | function Process (Nod : Node_Id) return Traverse_Result is | |
687 | begin | |
688 | -- Procedure call | |
689 | ||
690 | if Nkind (Nod) = N_Procedure_Call_Statement then | |
691 | ||
692 | -- Case of one of the detected recursive calls | |
693 | ||
694 | if Is_Entity_Name (Name (Nod)) | |
695 | and then Has_Recursive_Call (Entity (Name (Nod))) | |
696 | and then Entity (Name (Nod)) = Spec | |
697 | then | |
698 | Append_Elmt (Nod, Call_List); | |
699 | return Skip; | |
700 | ||
701 | -- Any other procedure call may have side effects | |
702 | ||
703 | else | |
704 | return Abandon; | |
705 | end if; | |
706 | ||
707 | -- A call to a pure function can always be ignored | |
708 | ||
709 | elsif Nkind (Nod) = N_Function_Call | |
710 | and then Is_Entity_Name (Name (Nod)) | |
711 | and then Is_Pure (Entity (Name (Nod))) | |
712 | then | |
713 | return Skip; | |
714 | ||
715 | -- Case of an identifier reference | |
716 | ||
717 | elsif Nkind (Nod) = N_Identifier then | |
718 | Ent := Entity (Nod); | |
719 | ||
720 | -- If no entity, then ignore the reference | |
721 | ||
722 | -- Not clear why this can happen. To investigate, remove this | |
723 | -- test and look at the crash that occurs here in 3401-004 ??? | |
724 | ||
725 | if No (Ent) then | |
726 | return Skip; | |
727 | ||
728 | -- Ignore entities with no Scope, again not clear how this | |
729 | -- can happen, to investigate, look at 4108-008 ??? | |
730 | ||
731 | elsif No (Scope (Ent)) then | |
732 | return Skip; | |
733 | ||
734 | -- Ignore the reference if not to a more global object | |
735 | ||
736 | elsif Scope_Depth (Scope (Ent)) >= Scop then | |
737 | return Skip; | |
738 | ||
739 | -- References to types, exceptions and constants are always OK | |
740 | ||
741 | elsif Is_Type (Ent) | |
742 | or else Ekind (Ent) = E_Exception | |
743 | or else Ekind (Ent) = E_Constant | |
744 | then | |
745 | return Skip; | |
746 | ||
747 | -- If other than a non-volatile scalar variable, we have some | |
748 | -- kind of global reference (e.g. to a function) that we cannot | |
749 | -- deal with so we forget the attempt. | |
750 | ||
751 | elsif Ekind (Ent) /= E_Variable | |
752 | or else not Is_Scalar_Type (Etype (Ent)) | |
fbf5a39b | 753 | or else Treat_As_Volatile (Ent) |
70482933 RK |
754 | then |
755 | return Abandon; | |
756 | ||
757 | -- Otherwise we have a reference to a global scalar | |
758 | ||
759 | else | |
760 | -- Loop through global entities already detected | |
761 | ||
762 | Elm := First_Elmt (Var_List); | |
763 | loop | |
764 | -- If not detected before, record this new global reference | |
765 | ||
766 | if No (Elm) then | |
767 | Count_Vars := Count_Vars + 1; | |
768 | ||
769 | if Count_Vars <= Max_Vars then | |
770 | Append_Elmt (Entity (Nod), Var_List); | |
771 | else | |
772 | return Abandon; | |
773 | end if; | |
774 | ||
775 | exit; | |
776 | ||
777 | -- If recorded before, ignore | |
778 | ||
779 | elsif Node (Elm) = Entity (Nod) then | |
780 | return Skip; | |
781 | ||
782 | -- Otherwise keep looking | |
783 | ||
784 | else | |
785 | Next_Elmt (Elm); | |
786 | end if; | |
787 | end loop; | |
788 | ||
789 | return Skip; | |
790 | end if; | |
791 | ||
792 | -- For all other node kinds, recursively visit syntactic children | |
793 | ||
794 | else | |
795 | return OK; | |
796 | end if; | |
797 | end Process; | |
798 | ||
02822a92 | 799 | function Traverse_Body is new Traverse_Func (Process); |
70482933 RK |
800 | |
801 | -- Start of processing for Detect_Infinite_Recursion | |
802 | ||
803 | begin | |
2f1b20a9 ES |
804 | -- Do not attempt detection in No_Implicit_Conditional mode, since we |
805 | -- won't be able to generate the code to handle the recursion in any | |
806 | -- case. | |
70482933 | 807 | |
6e937c1c | 808 | if Restriction_Active (No_Implicit_Conditionals) then |
70482933 RK |
809 | return; |
810 | end if; | |
811 | ||
812 | -- Otherwise do traversal and quit if we get abandon signal | |
813 | ||
814 | if Traverse_Body (N) = Abandon then | |
815 | return; | |
816 | ||
2f1b20a9 ES |
817 | -- We must have a call, since Has_Recursive_Call was set. If not just |
818 | -- ignore (this is only an error check, so if we have a funny situation, | |
819 | -- due to bugs or errors, we do not want to bomb!) | |
70482933 RK |
820 | |
821 | elsif Is_Empty_Elmt_List (Call_List) then | |
822 | return; | |
823 | end if; | |
824 | ||
825 | -- Here is the case where we detect recursion at compile time | |
826 | ||
2f1b20a9 ES |
827 | -- Push our current scope for analyzing the declarations and code that |
828 | -- we will insert for the checking. | |
70482933 | 829 | |
7888a6ae | 830 | Push_Scope (Spec); |
70482933 | 831 | |
2f1b20a9 ES |
832 | -- This loop builds temporary variables for each of the referenced |
833 | -- globals, so that at the end of the loop the list Shad_List contains | |
834 | -- these temporaries in one-to-one correspondence with the elements in | |
835 | -- Var_List. | |
70482933 RK |
836 | |
837 | Last := Empty; | |
838 | Elm := First_Elmt (Var_List); | |
839 | while Present (Elm) loop | |
840 | Var := Node (Elm); | |
c12beea0 | 841 | Ent := Make_Temporary (Loc, 'S'); |
70482933 RK |
842 | Append_Elmt (Ent, Shad_List); |
843 | ||
2f1b20a9 ES |
844 | -- Insert a declaration for this temporary at the start of the |
845 | -- declarations for the procedure. The temporaries are declared as | |
846 | -- constant objects initialized to the current values of the | |
847 | -- corresponding temporaries. | |
70482933 RK |
848 | |
849 | Decl := | |
850 | Make_Object_Declaration (Loc, | |
851 | Defining_Identifier => Ent, | |
852 | Object_Definition => New_Occurrence_Of (Etype (Var), Loc), | |
853 | Constant_Present => True, | |
854 | Expression => New_Occurrence_Of (Var, Loc)); | |
855 | ||
856 | if No (Last) then | |
857 | Prepend (Decl, Declarations (N)); | |
858 | else | |
859 | Insert_After (Last, Decl); | |
860 | end if; | |
861 | ||
862 | Last := Decl; | |
863 | Analyze (Decl); | |
864 | Next_Elmt (Elm); | |
865 | end loop; | |
866 | ||
867 | -- Loop through calls | |
868 | ||
869 | Call := First_Elmt (Call_List); | |
870 | while Present (Call) loop | |
871 | ||
872 | -- Build a predicate expression of the form | |
873 | ||
874 | -- True | |
875 | -- and then global1 = temp1 | |
876 | -- and then global2 = temp2 | |
877 | -- ... | |
878 | ||
879 | -- This predicate determines if any of the global values | |
880 | -- referenced by the procedure have changed since the | |
881 | -- current call, if not an infinite recursion is assured. | |
882 | ||
883 | Test := New_Occurrence_Of (Standard_True, Loc); | |
884 | ||
885 | Elm1 := First_Elmt (Var_List); | |
886 | Elm2 := First_Elmt (Shad_List); | |
887 | while Present (Elm1) loop | |
888 | Test := | |
889 | Make_And_Then (Loc, | |
890 | Left_Opnd => Test, | |
891 | Right_Opnd => | |
892 | Make_Op_Eq (Loc, | |
893 | Left_Opnd => New_Occurrence_Of (Node (Elm1), Loc), | |
894 | Right_Opnd => New_Occurrence_Of (Node (Elm2), Loc))); | |
895 | ||
896 | Next_Elmt (Elm1); | |
897 | Next_Elmt (Elm2); | |
898 | end loop; | |
899 | ||
900 | -- Now we replace the call with the sequence | |
901 | ||
902 | -- if no-changes (see above) then | |
903 | -- raise Storage_Error; | |
904 | -- else | |
905 | -- original-call | |
906 | -- end if; | |
907 | ||
908 | Rewrite (Node (Call), | |
909 | Make_If_Statement (Loc, | |
910 | Condition => Test, | |
911 | Then_Statements => New_List ( | |
07fc65c4 GB |
912 | Make_Raise_Storage_Error (Loc, |
913 | Reason => SE_Infinite_Recursion)), | |
70482933 RK |
914 | |
915 | Else_Statements => New_List ( | |
916 | Relocate_Node (Node (Call))))); | |
917 | ||
918 | Analyze (Node (Call)); | |
919 | ||
920 | Next_Elmt (Call); | |
921 | end loop; | |
922 | ||
923 | -- Remove temporary scope stack entry used for analysis | |
924 | ||
925 | Pop_Scope; | |
926 | end Detect_Infinite_Recursion; | |
927 | ||
928 | -------------------- | |
929 | -- Expand_Actuals -- | |
930 | -------------------- | |
931 | ||
932 | procedure Expand_Actuals (N : Node_Id; Subp : Entity_Id) is | |
933 | Loc : constant Source_Ptr := Sloc (N); | |
934 | Actual : Node_Id; | |
935 | Formal : Entity_Id; | |
936 | N_Node : Node_Id; | |
937 | Post_Call : List_Id; | |
938 | E_Formal : Entity_Id; | |
939 | ||
940 | procedure Add_Call_By_Copy_Code; | |
fbf5a39b AC |
941 | -- For cases where the parameter must be passed by copy, this routine |
942 | -- generates a temporary variable into which the actual is copied and | |
943 | -- then passes this as the parameter. For an OUT or IN OUT parameter, | |
944 | -- an assignment is also generated to copy the result back. The call | |
945 | -- also takes care of any constraint checks required for the type | |
946 | -- conversion case (on both the way in and the way out). | |
70482933 | 947 | |
f44fe430 RD |
948 | procedure Add_Simple_Call_By_Copy_Code; |
949 | -- This is similar to the above, but is used in cases where we know | |
950 | -- that all that is needed is to simply create a temporary and copy | |
951 | -- the value in and out of the temporary. | |
70482933 RK |
952 | |
953 | procedure Check_Fortran_Logical; | |
954 | -- A value of type Logical that is passed through a formal parameter | |
955 | -- must be normalized because .TRUE. usually does not have the same | |
956 | -- representation as True. We assume that .FALSE. = False = 0. | |
957 | -- What about functions that return a logical type ??? | |
958 | ||
758c442c GD |
959 | function Is_Legal_Copy return Boolean; |
960 | -- Check that an actual can be copied before generating the temporary | |
961 | -- to be used in the call. If the actual is of a by_reference type then | |
962 | -- the program is illegal (this can only happen in the presence of | |
963 | -- rep. clauses that force an incorrect alignment). If the formal is | |
964 | -- a by_reference parameter imposed by a DEC pragma, emit a warning to | |
965 | -- the effect that this might lead to unaligned arguments. | |
966 | ||
70482933 RK |
967 | function Make_Var (Actual : Node_Id) return Entity_Id; |
968 | -- Returns an entity that refers to the given actual parameter, | |
969 | -- Actual (not including any type conversion). If Actual is an | |
970 | -- entity name, then this entity is returned unchanged, otherwise | |
971 | -- a renaming is created to provide an entity for the actual. | |
972 | ||
973 | procedure Reset_Packed_Prefix; | |
974 | -- The expansion of a packed array component reference is delayed in | |
975 | -- the context of a call. Now we need to complete the expansion, so we | |
976 | -- unmark the analyzed bits in all prefixes. | |
977 | ||
978 | --------------------------- | |
979 | -- Add_Call_By_Copy_Code -- | |
980 | --------------------------- | |
981 | ||
982 | procedure Add_Call_By_Copy_Code is | |
cc335f43 AC |
983 | Expr : Node_Id; |
984 | Init : Node_Id; | |
985 | Temp : Entity_Id; | |
f44fe430 | 986 | Indic : Node_Id; |
cc335f43 | 987 | Var : Entity_Id; |
0da2c8ac | 988 | F_Typ : constant Entity_Id := Etype (Formal); |
cc335f43 AC |
989 | V_Typ : Entity_Id; |
990 | Crep : Boolean; | |
70482933 RK |
991 | |
992 | begin | |
758c442c GD |
993 | if not Is_Legal_Copy then |
994 | return; | |
995 | end if; | |
996 | ||
b086849e | 997 | Temp := Make_Temporary (Loc, 'T', Actual); |
70482933 | 998 | |
f44fe430 RD |
999 | -- Use formal type for temp, unless formal type is an unconstrained |
1000 | -- array, in which case we don't have to worry about bounds checks, | |
758c442c | 1001 | -- and we use the actual type, since that has appropriate bounds. |
f44fe430 RD |
1002 | |
1003 | if Is_Array_Type (F_Typ) and then not Is_Constrained (F_Typ) then | |
1004 | Indic := New_Occurrence_Of (Etype (Actual), Loc); | |
1005 | else | |
1006 | Indic := New_Occurrence_Of (Etype (Formal), Loc); | |
1007 | end if; | |
1008 | ||
70482933 RK |
1009 | if Nkind (Actual) = N_Type_Conversion then |
1010 | V_Typ := Etype (Expression (Actual)); | |
19f0526a AC |
1011 | |
1012 | -- If the formal is an (in-)out parameter, capture the name | |
1013 | -- of the variable in order to build the post-call assignment. | |
81a5b587 AC |
1014 | |
1015 | Var := Make_Var (Expression (Actual)); | |
19f0526a | 1016 | |
08aa9a4a | 1017 | Crep := not Same_Representation |
0da2c8ac | 1018 | (F_Typ, Etype (Expression (Actual))); |
08aa9a4a | 1019 | |
70482933 RK |
1020 | else |
1021 | V_Typ := Etype (Actual); | |
1022 | Var := Make_Var (Actual); | |
1023 | Crep := False; | |
1024 | end if; | |
1025 | ||
1026 | -- Setup initialization for case of in out parameter, or an out | |
1027 | -- parameter where the formal is an unconstrained array (in the | |
1028 | -- latter case, we have to pass in an object with bounds). | |
1029 | ||
cc335f43 AC |
1030 | -- If this is an out parameter, the initial copy is wasteful, so as |
1031 | -- an optimization for the one-dimensional case we extract the | |
1032 | -- bounds of the actual and build an uninitialized temporary of the | |
1033 | -- right size. | |
1034 | ||
70482933 | 1035 | if Ekind (Formal) = E_In_Out_Parameter |
0da2c8ac | 1036 | or else (Is_Array_Type (F_Typ) and then not Is_Constrained (F_Typ)) |
70482933 RK |
1037 | then |
1038 | if Nkind (Actual) = N_Type_Conversion then | |
1039 | if Conversion_OK (Actual) then | |
0da2c8ac | 1040 | Init := OK_Convert_To (F_Typ, New_Occurrence_Of (Var, Loc)); |
70482933 | 1041 | else |
0da2c8ac | 1042 | Init := Convert_To (F_Typ, New_Occurrence_Of (Var, Loc)); |
70482933 | 1043 | end if; |
cc335f43 AC |
1044 | |
1045 | elsif Ekind (Formal) = E_Out_Parameter | |
0da2c8ac AC |
1046 | and then Is_Array_Type (F_Typ) |
1047 | and then Number_Dimensions (F_Typ) = 1 | |
1048 | and then not Has_Non_Null_Base_Init_Proc (F_Typ) | |
cc335f43 AC |
1049 | then |
1050 | -- Actual is a one-dimensional array or slice, and the type | |
1051 | -- requires no initialization. Create a temporary of the | |
f44fe430 | 1052 | -- right size, but do not copy actual into it (optimization). |
cc335f43 AC |
1053 | |
1054 | Init := Empty; | |
1055 | Indic := | |
1056 | Make_Subtype_Indication (Loc, | |
1057 | Subtype_Mark => | |
0da2c8ac | 1058 | New_Occurrence_Of (F_Typ, Loc), |
cc335f43 AC |
1059 | Constraint => |
1060 | Make_Index_Or_Discriminant_Constraint (Loc, | |
1061 | Constraints => New_List ( | |
1062 | Make_Range (Loc, | |
1063 | Low_Bound => | |
1064 | Make_Attribute_Reference (Loc, | |
1065 | Prefix => New_Occurrence_Of (Var, Loc), | |
70f91180 | 1066 | Attribute_Name => Name_First), |
cc335f43 AC |
1067 | High_Bound => |
1068 | Make_Attribute_Reference (Loc, | |
1069 | Prefix => New_Occurrence_Of (Var, Loc), | |
1070 | Attribute_Name => Name_Last))))); | |
1071 | ||
70482933 RK |
1072 | else |
1073 | Init := New_Occurrence_Of (Var, Loc); | |
1074 | end if; | |
1075 | ||
1076 | -- An initialization is created for packed conversions as | |
1077 | -- actuals for out parameters to enable Make_Object_Declaration | |
1078 | -- to determine the proper subtype for N_Node. Note that this | |
1079 | -- is wasteful because the extra copying on the call side is | |
1080 | -- not required for such out parameters. ??? | |
1081 | ||
1082 | elsif Ekind (Formal) = E_Out_Parameter | |
1083 | and then Nkind (Actual) = N_Type_Conversion | |
0da2c8ac | 1084 | and then (Is_Bit_Packed_Array (F_Typ) |
70482933 RK |
1085 | or else |
1086 | Is_Bit_Packed_Array (Etype (Expression (Actual)))) | |
1087 | then | |
1088 | if Conversion_OK (Actual) then | |
f44fe430 | 1089 | Init := OK_Convert_To (F_Typ, New_Occurrence_Of (Var, Loc)); |
70482933 | 1090 | else |
f44fe430 | 1091 | Init := Convert_To (F_Typ, New_Occurrence_Of (Var, Loc)); |
70482933 | 1092 | end if; |
2e071734 AC |
1093 | |
1094 | elsif Ekind (Formal) = E_In_Parameter then | |
02822a92 RD |
1095 | |
1096 | -- Handle the case in which the actual is a type conversion | |
1097 | ||
1098 | if Nkind (Actual) = N_Type_Conversion then | |
1099 | if Conversion_OK (Actual) then | |
1100 | Init := OK_Convert_To (F_Typ, New_Occurrence_Of (Var, Loc)); | |
1101 | else | |
1102 | Init := Convert_To (F_Typ, New_Occurrence_Of (Var, Loc)); | |
1103 | end if; | |
1104 | else | |
1105 | Init := New_Occurrence_Of (Var, Loc); | |
1106 | end if; | |
2e071734 | 1107 | |
70482933 RK |
1108 | else |
1109 | Init := Empty; | |
1110 | end if; | |
1111 | ||
1112 | N_Node := | |
1113 | Make_Object_Declaration (Loc, | |
1114 | Defining_Identifier => Temp, | |
cc335f43 | 1115 | Object_Definition => Indic, |
f44fe430 | 1116 | Expression => Init); |
70482933 RK |
1117 | Set_Assignment_OK (N_Node); |
1118 | Insert_Action (N, N_Node); | |
1119 | ||
1120 | -- Now, normally the deal here is that we use the defining | |
1121 | -- identifier created by that object declaration. There is | |
1122 | -- one exception to this. In the change of representation case | |
1123 | -- the above declaration will end up looking like: | |
1124 | ||
1125 | -- temp : type := identifier; | |
1126 | ||
1127 | -- And in this case we might as well use the identifier directly | |
1128 | -- and eliminate the temporary. Note that the analysis of the | |
1129 | -- declaration was not a waste of time in that case, since it is | |
1130 | -- what generated the necessary change of representation code. If | |
1131 | -- the change of representation introduced additional code, as in | |
1132 | -- a fixed-integer conversion, the expression is not an identifier | |
1133 | -- and must be kept. | |
1134 | ||
1135 | if Crep | |
1136 | and then Present (Expression (N_Node)) | |
1137 | and then Is_Entity_Name (Expression (N_Node)) | |
1138 | then | |
1139 | Temp := Entity (Expression (N_Node)); | |
1140 | Rewrite (N_Node, Make_Null_Statement (Loc)); | |
1141 | end if; | |
1142 | ||
fbf5a39b | 1143 | -- For IN parameter, all we do is to replace the actual |
70482933 | 1144 | |
fbf5a39b AC |
1145 | if Ekind (Formal) = E_In_Parameter then |
1146 | Rewrite (Actual, New_Reference_To (Temp, Loc)); | |
1147 | Analyze (Actual); | |
1148 | ||
1149 | -- Processing for OUT or IN OUT parameter | |
1150 | ||
1151 | else | |
c8ef728f ES |
1152 | -- Kill current value indications for the temporary variable we |
1153 | -- created, since we just passed it as an OUT parameter. | |
1154 | ||
1155 | Kill_Current_Values (Temp); | |
75ba322d | 1156 | Set_Is_Known_Valid (Temp, False); |
c8ef728f | 1157 | |
fbf5a39b AC |
1158 | -- If type conversion, use reverse conversion on exit |
1159 | ||
1160 | if Nkind (Actual) = N_Type_Conversion then | |
1161 | if Conversion_OK (Actual) then | |
1162 | Expr := OK_Convert_To (V_Typ, New_Occurrence_Of (Temp, Loc)); | |
1163 | else | |
1164 | Expr := Convert_To (V_Typ, New_Occurrence_Of (Temp, Loc)); | |
1165 | end if; | |
70482933 | 1166 | else |
fbf5a39b | 1167 | Expr := New_Occurrence_Of (Temp, Loc); |
70482933 | 1168 | end if; |
70482933 | 1169 | |
fbf5a39b AC |
1170 | Rewrite (Actual, New_Reference_To (Temp, Loc)); |
1171 | Analyze (Actual); | |
70482933 | 1172 | |
d766cee3 RD |
1173 | -- If the actual is a conversion of a packed reference, it may |
1174 | -- already have been expanded by Remove_Side_Effects, and the | |
1175 | -- resulting variable is a temporary which does not designate | |
1176 | -- the proper out-parameter, which may not be addressable. In | |
1177 | -- that case, generate an assignment to the original expression | |
b0159fbe | 1178 | -- (before expansion of the packed reference) so that the proper |
d766cee3 | 1179 | -- expansion of assignment to a packed component can take place. |
70482933 | 1180 | |
d766cee3 RD |
1181 | declare |
1182 | Obj : Node_Id; | |
1183 | Lhs : Node_Id; | |
1184 | ||
1185 | begin | |
1186 | if Is_Renaming_Of_Object (Var) | |
1187 | and then Nkind (Renamed_Object (Var)) = N_Selected_Component | |
1188 | and then Is_Entity_Name (Prefix (Renamed_Object (Var))) | |
1189 | and then Nkind (Original_Node (Prefix (Renamed_Object (Var)))) | |
1190 | = N_Indexed_Component | |
1191 | and then | |
1192 | Has_Non_Standard_Rep (Etype (Prefix (Renamed_Object (Var)))) | |
1193 | then | |
1194 | Obj := Renamed_Object (Var); | |
1195 | Lhs := | |
1196 | Make_Selected_Component (Loc, | |
1197 | Prefix => | |
1198 | New_Copy_Tree (Original_Node (Prefix (Obj))), | |
1199 | Selector_Name => New_Copy (Selector_Name (Obj))); | |
1200 | Reset_Analyzed_Flags (Lhs); | |
1201 | ||
1202 | else | |
1203 | Lhs := New_Occurrence_Of (Var, Loc); | |
1204 | end if; | |
1205 | ||
1206 | Set_Assignment_OK (Lhs); | |
1207 | ||
1208 | Append_To (Post_Call, | |
1209 | Make_Assignment_Statement (Loc, | |
1210 | Name => Lhs, | |
1211 | Expression => Expr)); | |
1212 | end; | |
fbf5a39b | 1213 | end if; |
70482933 RK |
1214 | end Add_Call_By_Copy_Code; |
1215 | ||
1216 | ---------------------------------- | |
f44fe430 | 1217 | -- Add_Simple_Call_By_Copy_Code -- |
70482933 RK |
1218 | ---------------------------------- |
1219 | ||
f44fe430 | 1220 | procedure Add_Simple_Call_By_Copy_Code is |
70482933 | 1221 | Temp : Entity_Id; |
758c442c | 1222 | Decl : Node_Id; |
70482933 RK |
1223 | Incod : Node_Id; |
1224 | Outcod : Node_Id; | |
1225 | Lhs : Node_Id; | |
1226 | Rhs : Node_Id; | |
f44fe430 RD |
1227 | Indic : Node_Id; |
1228 | F_Typ : constant Entity_Id := Etype (Formal); | |
70482933 RK |
1229 | |
1230 | begin | |
758c442c GD |
1231 | if not Is_Legal_Copy then |
1232 | return; | |
1233 | end if; | |
1234 | ||
f44fe430 RD |
1235 | -- Use formal type for temp, unless formal type is an unconstrained |
1236 | -- array, in which case we don't have to worry about bounds checks, | |
758c442c | 1237 | -- and we use the actual type, since that has appropriate bounds. |
f44fe430 RD |
1238 | |
1239 | if Is_Array_Type (F_Typ) and then not Is_Constrained (F_Typ) then | |
1240 | Indic := New_Occurrence_Of (Etype (Actual), Loc); | |
1241 | else | |
1242 | Indic := New_Occurrence_Of (Etype (Formal), Loc); | |
1243 | end if; | |
70482933 RK |
1244 | |
1245 | -- Prepare to generate code | |
1246 | ||
f44fe430 RD |
1247 | Reset_Packed_Prefix; |
1248 | ||
b086849e | 1249 | Temp := Make_Temporary (Loc, 'T', Actual); |
70482933 RK |
1250 | Incod := Relocate_Node (Actual); |
1251 | Outcod := New_Copy_Tree (Incod); | |
1252 | ||
1253 | -- Generate declaration of temporary variable, initializing it | |
c73ae90f | 1254 | -- with the input parameter unless we have an OUT formal or |
758c442c | 1255 | -- this is an initialization call. |
70482933 | 1256 | |
c73ae90f GD |
1257 | -- If the formal is an out parameter with discriminants, the |
1258 | -- discriminants must be captured even if the rest of the object | |
1259 | -- is in principle uninitialized, because the discriminants may | |
1260 | -- be read by the called subprogram. | |
1261 | ||
70482933 RK |
1262 | if Ekind (Formal) = E_Out_Parameter then |
1263 | Incod := Empty; | |
758c442c | 1264 | |
c73ae90f GD |
1265 | if Has_Discriminants (Etype (Formal)) then |
1266 | Indic := New_Occurrence_Of (Etype (Actual), Loc); | |
1267 | end if; | |
1268 | ||
758c442c | 1269 | elsif Inside_Init_Proc then |
c73ae90f GD |
1270 | |
1271 | -- Could use a comment here to match comment below ??? | |
1272 | ||
758c442c GD |
1273 | if Nkind (Actual) /= N_Selected_Component |
1274 | or else | |
1275 | not Has_Discriminant_Dependent_Constraint | |
1276 | (Entity (Selector_Name (Actual))) | |
1277 | then | |
1278 | Incod := Empty; | |
1279 | ||
c73ae90f GD |
1280 | -- Otherwise, keep the component in order to generate the proper |
1281 | -- actual subtype, that depends on enclosing discriminants. | |
758c442c | 1282 | |
c73ae90f | 1283 | else |
758c442c GD |
1284 | null; |
1285 | end if; | |
70482933 RK |
1286 | end if; |
1287 | ||
758c442c | 1288 | Decl := |
70482933 RK |
1289 | Make_Object_Declaration (Loc, |
1290 | Defining_Identifier => Temp, | |
f44fe430 | 1291 | Object_Definition => Indic, |
758c442c GD |
1292 | Expression => Incod); |
1293 | ||
1294 | if Inside_Init_Proc | |
1295 | and then No (Incod) | |
1296 | then | |
1297 | -- If the call is to initialize a component of a composite type, | |
1298 | -- and the component does not depend on discriminants, use the | |
1299 | -- actual type of the component. This is required in case the | |
1300 | -- component is constrained, because in general the formal of the | |
1301 | -- initialization procedure will be unconstrained. Note that if | |
1302 | -- the component being initialized is constrained by an enclosing | |
1303 | -- discriminant, the presence of the initialization in the | |
1304 | -- declaration will generate an expression for the actual subtype. | |
1305 | ||
1306 | Set_No_Initialization (Decl); | |
1307 | Set_Object_Definition (Decl, | |
1308 | New_Occurrence_Of (Etype (Actual), Loc)); | |
1309 | end if; | |
1310 | ||
1311 | Insert_Action (N, Decl); | |
70482933 RK |
1312 | |
1313 | -- The actual is simply a reference to the temporary | |
1314 | ||
1315 | Rewrite (Actual, New_Occurrence_Of (Temp, Loc)); | |
1316 | ||
1317 | -- Generate copy out if OUT or IN OUT parameter | |
1318 | ||
1319 | if Ekind (Formal) /= E_In_Parameter then | |
1320 | Lhs := Outcod; | |
1321 | Rhs := New_Occurrence_Of (Temp, Loc); | |
1322 | ||
1323 | -- Deal with conversion | |
1324 | ||
1325 | if Nkind (Lhs) = N_Type_Conversion then | |
1326 | Lhs := Expression (Lhs); | |
1327 | Rhs := Convert_To (Etype (Actual), Rhs); | |
1328 | end if; | |
1329 | ||
1330 | Append_To (Post_Call, | |
1331 | Make_Assignment_Statement (Loc, | |
1332 | Name => Lhs, | |
1333 | Expression => Rhs)); | |
f44fe430 | 1334 | Set_Assignment_OK (Name (Last (Post_Call))); |
70482933 | 1335 | end if; |
f44fe430 | 1336 | end Add_Simple_Call_By_Copy_Code; |
70482933 RK |
1337 | |
1338 | --------------------------- | |
1339 | -- Check_Fortran_Logical -- | |
1340 | --------------------------- | |
1341 | ||
1342 | procedure Check_Fortran_Logical is | |
fbf5a39b | 1343 | Logical : constant Entity_Id := Etype (Formal); |
70482933 RK |
1344 | Var : Entity_Id; |
1345 | ||
1346 | -- Note: this is very incomplete, e.g. it does not handle arrays | |
1347 | -- of logical values. This is really not the right approach at all???) | |
1348 | ||
1349 | begin | |
1350 | if Convention (Subp) = Convention_Fortran | |
1351 | and then Root_Type (Etype (Formal)) = Standard_Boolean | |
1352 | and then Ekind (Formal) /= E_In_Parameter | |
1353 | then | |
1354 | Var := Make_Var (Actual); | |
1355 | Append_To (Post_Call, | |
1356 | Make_Assignment_Statement (Loc, | |
1357 | Name => New_Occurrence_Of (Var, Loc), | |
1358 | Expression => | |
1359 | Unchecked_Convert_To ( | |
1360 | Logical, | |
1361 | Make_Op_Ne (Loc, | |
1362 | Left_Opnd => New_Occurrence_Of (Var, Loc), | |
1363 | Right_Opnd => | |
1364 | Unchecked_Convert_To ( | |
1365 | Logical, | |
1366 | New_Occurrence_Of (Standard_False, Loc)))))); | |
1367 | end if; | |
1368 | end Check_Fortran_Logical; | |
1369 | ||
758c442c GD |
1370 | ------------------- |
1371 | -- Is_Legal_Copy -- | |
1372 | ------------------- | |
1373 | ||
1374 | function Is_Legal_Copy return Boolean is | |
1375 | begin | |
1376 | -- An attempt to copy a value of such a type can only occur if | |
1377 | -- representation clauses give the actual a misaligned address. | |
1378 | ||
1379 | if Is_By_Reference_Type (Etype (Formal)) then | |
1380 | Error_Msg_N | |
1381 | ("misaligned actual cannot be passed by reference", Actual); | |
1382 | return False; | |
1383 | ||
1384 | -- For users of Starlet, we assume that the specification of by- | |
7888a6ae | 1385 | -- reference mechanism is mandatory. This may lead to unaligned |
758c442c GD |
1386 | -- objects but at least for DEC legacy code it is known to work. |
1387 | -- The warning will alert users of this code that a problem may | |
1388 | -- be lurking. | |
1389 | ||
1390 | elsif Mechanism (Formal) = By_Reference | |
1391 | and then Is_Valued_Procedure (Scope (Formal)) | |
1392 | then | |
1393 | Error_Msg_N | |
1394 | ("by_reference actual may be misaligned?", Actual); | |
1395 | return False; | |
1396 | ||
1397 | else | |
1398 | return True; | |
1399 | end if; | |
1400 | end Is_Legal_Copy; | |
1401 | ||
70482933 RK |
1402 | -------------- |
1403 | -- Make_Var -- | |
1404 | -------------- | |
1405 | ||
1406 | function Make_Var (Actual : Node_Id) return Entity_Id is | |
1407 | Var : Entity_Id; | |
1408 | ||
1409 | begin | |
1410 | if Is_Entity_Name (Actual) then | |
1411 | return Entity (Actual); | |
1412 | ||
1413 | else | |
b086849e | 1414 | Var := Make_Temporary (Loc, 'T', Actual); |
70482933 RK |
1415 | |
1416 | N_Node := | |
1417 | Make_Object_Renaming_Declaration (Loc, | |
1418 | Defining_Identifier => Var, | |
1419 | Subtype_Mark => | |
1420 | New_Occurrence_Of (Etype (Actual), Loc), | |
1421 | Name => Relocate_Node (Actual)); | |
1422 | ||
1423 | Insert_Action (N, N_Node); | |
1424 | return Var; | |
1425 | end if; | |
1426 | end Make_Var; | |
1427 | ||
1428 | ------------------------- | |
1429 | -- Reset_Packed_Prefix -- | |
1430 | ------------------------- | |
1431 | ||
1432 | procedure Reset_Packed_Prefix is | |
1433 | Pfx : Node_Id := Actual; | |
70482933 RK |
1434 | begin |
1435 | loop | |
1436 | Set_Analyzed (Pfx, False); | |
ac4d6407 RD |
1437 | exit when |
1438 | not Nkind_In (Pfx, N_Selected_Component, N_Indexed_Component); | |
70482933 RK |
1439 | Pfx := Prefix (Pfx); |
1440 | end loop; | |
1441 | end Reset_Packed_Prefix; | |
1442 | ||
1443 | -- Start of processing for Expand_Actuals | |
1444 | ||
1445 | begin | |
70482933 RK |
1446 | Post_Call := New_List; |
1447 | ||
2f1b20a9 ES |
1448 | Formal := First_Formal (Subp); |
1449 | Actual := First_Actual (N); | |
70482933 RK |
1450 | while Present (Formal) loop |
1451 | E_Formal := Etype (Formal); | |
1452 | ||
1453 | if Is_Scalar_Type (E_Formal) | |
1454 | or else Nkind (Actual) = N_Slice | |
1455 | then | |
1456 | Check_Fortran_Logical; | |
1457 | ||
1458 | -- RM 6.4.1 (11) | |
1459 | ||
1460 | elsif Ekind (Formal) /= E_Out_Parameter then | |
1461 | ||
1462 | -- The unusual case of the current instance of a protected type | |
1463 | -- requires special handling. This can only occur in the context | |
1464 | -- of a call within the body of a protected operation. | |
1465 | ||
1466 | if Is_Entity_Name (Actual) | |
1467 | and then Ekind (Entity (Actual)) = E_Protected_Type | |
1468 | and then In_Open_Scopes (Entity (Actual)) | |
1469 | then | |
1470 | if Scope (Subp) /= Entity (Actual) then | |
1471 | Error_Msg_N ("operation outside protected type may not " | |
1472 | & "call back its protected operations?", Actual); | |
1473 | end if; | |
1474 | ||
1475 | Rewrite (Actual, | |
1476 | Expand_Protected_Object_Reference (N, Entity (Actual))); | |
1477 | end if; | |
1478 | ||
02822a92 RD |
1479 | -- Ada 2005 (AI-318-02): If the actual parameter is a call to a |
1480 | -- build-in-place function, then a temporary return object needs | |
1481 | -- to be created and access to it must be passed to the function. | |
f937473f RD |
1482 | -- Currently we limit such functions to those with inherently |
1483 | -- limited result subtypes, but eventually we plan to expand the | |
1484 | -- functions that are treated as build-in-place to include other | |
1485 | -- composite result types. | |
02822a92 | 1486 | |
95eb8b69 | 1487 | if Is_Build_In_Place_Function_Call (Actual) then |
02822a92 RD |
1488 | Make_Build_In_Place_Call_In_Anonymous_Context (Actual); |
1489 | end if; | |
1490 | ||
70482933 RK |
1491 | Apply_Constraint_Check (Actual, E_Formal); |
1492 | ||
1493 | -- Out parameter case. No constraint checks on access type | |
1494 | -- RM 6.4.1 (13) | |
1495 | ||
1496 | elsif Is_Access_Type (E_Formal) then | |
1497 | null; | |
1498 | ||
1499 | -- RM 6.4.1 (14) | |
1500 | ||
1501 | elsif Has_Discriminants (Base_Type (E_Formal)) | |
1502 | or else Has_Non_Null_Base_Init_Proc (E_Formal) | |
1503 | then | |
1504 | Apply_Constraint_Check (Actual, E_Formal); | |
1505 | ||
1506 | -- RM 6.4.1 (15) | |
1507 | ||
1508 | else | |
1509 | Apply_Constraint_Check (Actual, Base_Type (E_Formal)); | |
1510 | end if; | |
1511 | ||
1512 | -- Processing for IN-OUT and OUT parameters | |
1513 | ||
1514 | if Ekind (Formal) /= E_In_Parameter then | |
1515 | ||
1516 | -- For type conversions of arrays, apply length/range checks | |
1517 | ||
1518 | if Is_Array_Type (E_Formal) | |
1519 | and then Nkind (Actual) = N_Type_Conversion | |
1520 | then | |
1521 | if Is_Constrained (E_Formal) then | |
1522 | Apply_Length_Check (Expression (Actual), E_Formal); | |
1523 | else | |
1524 | Apply_Range_Check (Expression (Actual), E_Formal); | |
1525 | end if; | |
1526 | end if; | |
1527 | ||
1528 | -- If argument is a type conversion for a type that is passed | |
1529 | -- by copy, then we must pass the parameter by copy. | |
1530 | ||
1531 | if Nkind (Actual) = N_Type_Conversion | |
1532 | and then | |
1533 | (Is_Numeric_Type (E_Formal) | |
1534 | or else Is_Access_Type (E_Formal) | |
1535 | or else Is_Enumeration_Type (E_Formal) | |
1536 | or else Is_Bit_Packed_Array (Etype (Formal)) | |
1537 | or else Is_Bit_Packed_Array (Etype (Expression (Actual))) | |
1538 | ||
1539 | -- Also pass by copy if change of representation | |
1540 | ||
1541 | or else not Same_Representation | |
1542 | (Etype (Formal), | |
1543 | Etype (Expression (Actual)))) | |
1544 | then | |
1545 | Add_Call_By_Copy_Code; | |
1546 | ||
1547 | -- References to components of bit packed arrays are expanded | |
1548 | -- at this point, rather than at the point of analysis of the | |
1549 | -- actuals, to handle the expansion of the assignment to | |
1550 | -- [in] out parameters. | |
1551 | ||
1552 | elsif Is_Ref_To_Bit_Packed_Array (Actual) then | |
f44fe430 RD |
1553 | Add_Simple_Call_By_Copy_Code; |
1554 | ||
02822a92 RD |
1555 | -- If a non-scalar actual is possibly bit-aligned, we need a copy |
1556 | -- because the back-end cannot cope with such objects. In other | |
1557 | -- cases where alignment forces a copy, the back-end generates | |
1558 | -- it properly. It should not be generated unconditionally in the | |
1559 | -- front-end because it does not know precisely the alignment | |
1560 | -- requirements of the target, and makes too conservative an | |
1561 | -- estimate, leading to superfluous copies or spurious errors | |
1562 | -- on by-reference parameters. | |
f44fe430 | 1563 | |
02822a92 RD |
1564 | elsif Nkind (Actual) = N_Selected_Component |
1565 | and then | |
1566 | Component_May_Be_Bit_Aligned (Entity (Selector_Name (Actual))) | |
f44fe430 RD |
1567 | and then not Represented_As_Scalar (Etype (Formal)) |
1568 | then | |
1569 | Add_Simple_Call_By_Copy_Code; | |
70482933 RK |
1570 | |
1571 | -- References to slices of bit packed arrays are expanded | |
1572 | ||
1573 | elsif Is_Ref_To_Bit_Packed_Slice (Actual) then | |
1574 | Add_Call_By_Copy_Code; | |
1575 | ||
fbf5a39b AC |
1576 | -- References to possibly unaligned slices of arrays are expanded |
1577 | ||
1578 | elsif Is_Possibly_Unaligned_Slice (Actual) then | |
1579 | Add_Call_By_Copy_Code; | |
1580 | ||
7888a6ae | 1581 | -- Deal with access types where the actual subtype and the |
70482933 RK |
1582 | -- formal subtype are not the same, requiring a check. |
1583 | ||
638e383e | 1584 | -- It is necessary to exclude tagged types because of "downward |
70f91180 | 1585 | -- conversion" errors. |
70482933 RK |
1586 | |
1587 | elsif Is_Access_Type (E_Formal) | |
1588 | and then not Same_Type (E_Formal, Etype (Actual)) | |
1589 | and then not Is_Tagged_Type (Designated_Type (E_Formal)) | |
1590 | then | |
1591 | Add_Call_By_Copy_Code; | |
1592 | ||
faf3cf91 ES |
1593 | -- If the actual is not a scalar and is marked for volatile |
1594 | -- treatment, whereas the formal is not volatile, then pass | |
1595 | -- by copy unless it is a by-reference type. | |
1596 | ||
0386aad1 AC |
1597 | -- Note: we use Is_Volatile here rather than Treat_As_Volatile, |
1598 | -- because this is the enforcement of a language rule that applies | |
1599 | -- only to "real" volatile variables, not e.g. to the address | |
1600 | -- clause overlay case. | |
1601 | ||
70482933 | 1602 | elsif Is_Entity_Name (Actual) |
0386aad1 | 1603 | and then Is_Volatile (Entity (Actual)) |
faf3cf91 | 1604 | and then not Is_By_Reference_Type (Etype (Actual)) |
70482933 | 1605 | and then not Is_Scalar_Type (Etype (Entity (Actual))) |
0386aad1 | 1606 | and then not Is_Volatile (E_Formal) |
70482933 RK |
1607 | then |
1608 | Add_Call_By_Copy_Code; | |
1609 | ||
1610 | elsif Nkind (Actual) = N_Indexed_Component | |
1611 | and then Is_Entity_Name (Prefix (Actual)) | |
1612 | and then Has_Volatile_Components (Entity (Prefix (Actual))) | |
1613 | then | |
1614 | Add_Call_By_Copy_Code; | |
d79e621a GD |
1615 | |
1616 | -- Add call-by-copy code for the case of scalar out parameters | |
1617 | -- when it is not known at compile time that the subtype of the | |
c2369146 AC |
1618 | -- formal is a subrange of the subtype of the actual (or vice |
1619 | -- versa for in out parameters), in order to get range checks | |
1620 | -- on such actuals. (Maybe this case should be handled earlier | |
1621 | -- in the if statement???) | |
d79e621a GD |
1622 | |
1623 | elsif Is_Scalar_Type (E_Formal) | |
c2369146 AC |
1624 | and then |
1625 | (not In_Subrange_Of (E_Formal, Etype (Actual)) | |
1626 | or else | |
1627 | (Ekind (Formal) = E_In_Out_Parameter | |
1628 | and then not In_Subrange_Of (Etype (Actual), E_Formal))) | |
d79e621a GD |
1629 | then |
1630 | -- Perhaps the setting back to False should be done within | |
1631 | -- Add_Call_By_Copy_Code, since it could get set on other | |
1632 | -- cases occurring above??? | |
1633 | ||
1634 | if Do_Range_Check (Actual) then | |
1635 | Set_Do_Range_Check (Actual, False); | |
1636 | end if; | |
1637 | ||
1638 | Add_Call_By_Copy_Code; | |
70482933 RK |
1639 | end if; |
1640 | ||
fbf5a39b | 1641 | -- Processing for IN parameters |
70482933 RK |
1642 | |
1643 | else | |
fbf5a39b AC |
1644 | -- For IN parameters is in the packed array case, we expand an |
1645 | -- indexed component (the circuit in Exp_Ch4 deliberately left | |
1646 | -- indexed components appearing as actuals untouched, so that | |
1647 | -- the special processing above for the OUT and IN OUT cases | |
1648 | -- could be performed. We could make the test in Exp_Ch4 more | |
1649 | -- complex and have it detect the parameter mode, but it is | |
f44fe430 | 1650 | -- easier simply to handle all cases here.) |
fbf5a39b | 1651 | |
70482933 RK |
1652 | if Nkind (Actual) = N_Indexed_Component |
1653 | and then Is_Packed (Etype (Prefix (Actual))) | |
1654 | then | |
1655 | Reset_Packed_Prefix; | |
1656 | Expand_Packed_Element_Reference (Actual); | |
1657 | ||
0386aad1 AC |
1658 | -- If we have a reference to a bit packed array, we copy it, since |
1659 | -- the actual must be byte aligned. | |
70482933 | 1660 | |
fbf5a39b | 1661 | -- Is this really necessary in all cases??? |
70482933 | 1662 | |
fbf5a39b | 1663 | elsif Is_Ref_To_Bit_Packed_Array (Actual) then |
f44fe430 RD |
1664 | Add_Simple_Call_By_Copy_Code; |
1665 | ||
1666 | -- If a non-scalar actual is possibly unaligned, we need a copy | |
1667 | ||
1668 | elsif Is_Possibly_Unaligned_Object (Actual) | |
1669 | and then not Represented_As_Scalar (Etype (Formal)) | |
1670 | then | |
1671 | Add_Simple_Call_By_Copy_Code; | |
70482933 | 1672 | |
fbf5a39b AC |
1673 | -- Similarly, we have to expand slices of packed arrays here |
1674 | -- because the result must be byte aligned. | |
70482933 | 1675 | |
fbf5a39b AC |
1676 | elsif Is_Ref_To_Bit_Packed_Slice (Actual) then |
1677 | Add_Call_By_Copy_Code; | |
70482933 | 1678 | |
fbf5a39b AC |
1679 | -- Only processing remaining is to pass by copy if this is a |
1680 | -- reference to a possibly unaligned slice, since the caller | |
1681 | -- expects an appropriately aligned argument. | |
70482933 | 1682 | |
fbf5a39b AC |
1683 | elsif Is_Possibly_Unaligned_Slice (Actual) then |
1684 | Add_Call_By_Copy_Code; | |
fb468a94 AC |
1685 | |
1686 | -- An unusual case: a current instance of an enclosing task can be | |
1687 | -- an actual, and must be replaced by a reference to self. | |
1688 | ||
1689 | elsif Is_Entity_Name (Actual) | |
1690 | and then Is_Task_Type (Entity (Actual)) | |
1691 | then | |
1692 | if In_Open_Scopes (Entity (Actual)) then | |
1693 | Rewrite (Actual, | |
1694 | (Make_Function_Call (Loc, | |
1695 | Name => New_Reference_To (RTE (RE_Self), Loc)))); | |
1696 | Analyze (Actual); | |
1697 | ||
1698 | -- A task type cannot otherwise appear as an actual | |
1699 | ||
1700 | else | |
1701 | raise Program_Error; | |
1702 | end if; | |
70482933 RK |
1703 | end if; |
1704 | end if; | |
1705 | ||
1706 | Next_Formal (Formal); | |
1707 | Next_Actual (Actual); | |
1708 | end loop; | |
1709 | ||
1710 | -- Find right place to put post call stuff if it is present | |
1711 | ||
1712 | if not Is_Empty_List (Post_Call) then | |
1713 | ||
2f1b20a9 ES |
1714 | -- If call is not a list member, it must be the triggering statement |
1715 | -- of a triggering alternative or an entry call alternative, and we | |
1716 | -- can add the post call stuff to the corresponding statement list. | |
70482933 RK |
1717 | |
1718 | if not Is_List_Member (N) then | |
1719 | declare | |
1720 | P : constant Node_Id := Parent (N); | |
1721 | ||
1722 | begin | |
ac4d6407 RD |
1723 | pragma Assert (Nkind_In (P, N_Triggering_Alternative, |
1724 | N_Entry_Call_Alternative)); | |
70482933 RK |
1725 | |
1726 | if Is_Non_Empty_List (Statements (P)) then | |
1727 | Insert_List_Before_And_Analyze | |
1728 | (First (Statements (P)), Post_Call); | |
1729 | else | |
1730 | Set_Statements (P, Post_Call); | |
1731 | end if; | |
1732 | end; | |
1733 | ||
1734 | -- Otherwise, normal case where N is in a statement sequence, | |
1735 | -- just put the post-call stuff after the call statement. | |
1736 | ||
1737 | else | |
1738 | Insert_Actions_After (N, Post_Call); | |
1739 | end if; | |
1740 | end if; | |
1741 | ||
98f01d53 | 1742 | -- The call node itself is re-analyzed in Expand_Call |
70482933 RK |
1743 | |
1744 | end Expand_Actuals; | |
1745 | ||
1746 | ----------------- | |
1747 | -- Expand_Call -- | |
1748 | ----------------- | |
1749 | ||
1750 | -- This procedure handles expansion of function calls and procedure call | |
1751 | -- statements (i.e. it serves as the body for Expand_N_Function_Call and | |
70f91180 | 1752 | -- Expand_N_Procedure_Call_Statement). Processing for calls includes: |
70482933 | 1753 | |
70f91180 | 1754 | -- Replace call to Raise_Exception by Raise_Exception_Always if possible |
70482933 RK |
1755 | -- Provide values of actuals for all formals in Extra_Formals list |
1756 | -- Replace "call" to enumeration literal function by literal itself | |
1757 | -- Rewrite call to predefined operator as operator | |
1758 | -- Replace actuals to in-out parameters that are numeric conversions, | |
1759 | -- with explicit assignment to temporaries before and after the call. | |
1760 | -- Remove optional actuals if First_Optional_Parameter specified. | |
1761 | ||
1762 | -- Note that the list of actuals has been filled with default expressions | |
1763 | -- during semantic analysis of the call. Only the extra actuals required | |
1764 | -- for the 'Constrained attribute and for accessibility checks are added | |
1765 | -- at this point. | |
1766 | ||
1767 | procedure Expand_Call (N : Node_Id) is | |
1768 | Loc : constant Source_Ptr := Sloc (N); | |
6dfc5592 | 1769 | Call_Node : Node_Id := N; |
70482933 | 1770 | Extra_Actuals : List_Id := No_List; |
fdce4bb7 | 1771 | Prev : Node_Id := Empty; |
758c442c | 1772 | |
70482933 RK |
1773 | procedure Add_Actual_Parameter (Insert_Param : Node_Id); |
1774 | -- Adds one entry to the end of the actual parameter list. Used for | |
2f1b20a9 ES |
1775 | -- default parameters and for extra actuals (for Extra_Formals). The |
1776 | -- argument is an N_Parameter_Association node. | |
70482933 RK |
1777 | |
1778 | procedure Add_Extra_Actual (Expr : Node_Id; EF : Entity_Id); | |
2f1b20a9 ES |
1779 | -- Adds an extra actual to the list of extra actuals. Expr is the |
1780 | -- expression for the value of the actual, EF is the entity for the | |
1781 | -- extra formal. | |
70482933 RK |
1782 | |
1783 | function Inherited_From_Formal (S : Entity_Id) return Entity_Id; | |
1784 | -- Within an instance, a type derived from a non-tagged formal derived | |
70f91180 RD |
1785 | -- type inherits from the original parent, not from the actual. The |
1786 | -- current derivation mechanism has the derived type inherit from the | |
1787 | -- actual, which is only correct outside of the instance. If the | |
1788 | -- subprogram is inherited, we test for this particular case through a | |
1789 | -- convoluted tree traversal before setting the proper subprogram to be | |
1790 | -- called. | |
70482933 | 1791 | |
df3e68b1 HK |
1792 | function Is_Direct_Deep_Call (Subp : Entity_Id) return Boolean; |
1793 | -- Determine whether Subp denotes a non-dispatching call to a Deep | |
1794 | -- routine. | |
1795 | ||
dd386db0 AC |
1796 | function New_Value (From : Node_Id) return Node_Id; |
1797 | -- From is the original Expression. New_Value is equivalent to a call | |
1798 | -- to Duplicate_Subexpr with an explicit dereference when From is an | |
1799 | -- access parameter. | |
1800 | ||
70482933 RK |
1801 | -------------------------- |
1802 | -- Add_Actual_Parameter -- | |
1803 | -------------------------- | |
1804 | ||
1805 | procedure Add_Actual_Parameter (Insert_Param : Node_Id) is | |
1806 | Actual_Expr : constant Node_Id := | |
1807 | Explicit_Actual_Parameter (Insert_Param); | |
1808 | ||
1809 | begin | |
1810 | -- Case of insertion is first named actual | |
1811 | ||
1812 | if No (Prev) or else | |
1813 | Nkind (Parent (Prev)) /= N_Parameter_Association | |
1814 | then | |
6dfc5592 RD |
1815 | Set_Next_Named_Actual |
1816 | (Insert_Param, First_Named_Actual (Call_Node)); | |
1817 | Set_First_Named_Actual (Call_Node, Actual_Expr); | |
70482933 RK |
1818 | |
1819 | if No (Prev) then | |
6dfc5592 RD |
1820 | if No (Parameter_Associations (Call_Node)) then |
1821 | Set_Parameter_Associations (Call_Node, New_List); | |
1822 | Append (Insert_Param, Parameter_Associations (Call_Node)); | |
70482933 RK |
1823 | end if; |
1824 | else | |
1825 | Insert_After (Prev, Insert_Param); | |
1826 | end if; | |
1827 | ||
1828 | -- Case of insertion is not first named actual | |
1829 | ||
1830 | else | |
1831 | Set_Next_Named_Actual | |
1832 | (Insert_Param, Next_Named_Actual (Parent (Prev))); | |
1833 | Set_Next_Named_Actual (Parent (Prev), Actual_Expr); | |
6dfc5592 | 1834 | Append (Insert_Param, Parameter_Associations (Call_Node)); |
70482933 RK |
1835 | end if; |
1836 | ||
1837 | Prev := Actual_Expr; | |
1838 | end Add_Actual_Parameter; | |
1839 | ||
1840 | ---------------------- | |
1841 | -- Add_Extra_Actual -- | |
1842 | ---------------------- | |
1843 | ||
1844 | procedure Add_Extra_Actual (Expr : Node_Id; EF : Entity_Id) is | |
1845 | Loc : constant Source_Ptr := Sloc (Expr); | |
1846 | ||
1847 | begin | |
1848 | if Extra_Actuals = No_List then | |
1849 | Extra_Actuals := New_List; | |
6dfc5592 | 1850 | Set_Parent (Extra_Actuals, Call_Node); |
70482933 RK |
1851 | end if; |
1852 | ||
1853 | Append_To (Extra_Actuals, | |
1854 | Make_Parameter_Association (Loc, | |
9d983bbf AC |
1855 | Selector_Name => Make_Identifier (Loc, Chars (EF)), |
1856 | Explicit_Actual_Parameter => Expr)); | |
70482933 RK |
1857 | |
1858 | Analyze_And_Resolve (Expr, Etype (EF)); | |
75a64833 | 1859 | |
6dfc5592 | 1860 | if Nkind (Call_Node) = N_Function_Call then |
75a64833 AC |
1861 | Set_Is_Accessibility_Actual (Parent (Expr)); |
1862 | end if; | |
70482933 RK |
1863 | end Add_Extra_Actual; |
1864 | ||
1865 | --------------------------- | |
1866 | -- Inherited_From_Formal -- | |
1867 | --------------------------- | |
1868 | ||
1869 | function Inherited_From_Formal (S : Entity_Id) return Entity_Id is | |
1870 | Par : Entity_Id; | |
1871 | Gen_Par : Entity_Id; | |
1872 | Gen_Prim : Elist_Id; | |
1873 | Elmt : Elmt_Id; | |
1874 | Indic : Node_Id; | |
1875 | ||
1876 | begin | |
1877 | -- If the operation is inherited, it is attached to the corresponding | |
1878 | -- type derivation. If the parent in the derivation is a generic | |
1879 | -- actual, it is a subtype of the actual, and we have to recover the | |
1880 | -- original derived type declaration to find the proper parent. | |
1881 | ||
1882 | if Nkind (Parent (S)) /= N_Full_Type_Declaration | |
fbf5a39b | 1883 | or else not Is_Derived_Type (Defining_Identifier (Parent (S))) |
2f1b20a9 ES |
1884 | or else Nkind (Type_Definition (Original_Node (Parent (S)))) /= |
1885 | N_Derived_Type_Definition | |
fbf5a39b | 1886 | or else not In_Instance |
70482933 RK |
1887 | then |
1888 | return Empty; | |
1889 | ||
1890 | else | |
1891 | Indic := | |
e27b834b AC |
1892 | Subtype_Indication |
1893 | (Type_Definition (Original_Node (Parent (S)))); | |
70482933 RK |
1894 | |
1895 | if Nkind (Indic) = N_Subtype_Indication then | |
1896 | Par := Entity (Subtype_Mark (Indic)); | |
1897 | else | |
1898 | Par := Entity (Indic); | |
1899 | end if; | |
1900 | end if; | |
1901 | ||
1902 | if not Is_Generic_Actual_Type (Par) | |
1903 | or else Is_Tagged_Type (Par) | |
1904 | or else Nkind (Parent (Par)) /= N_Subtype_Declaration | |
1905 | or else not In_Open_Scopes (Scope (Par)) | |
70482933 RK |
1906 | then |
1907 | return Empty; | |
70482933 RK |
1908 | else |
1909 | Gen_Par := Generic_Parent_Type (Parent (Par)); | |
1910 | end if; | |
1911 | ||
7888a6ae GD |
1912 | -- If the actual has no generic parent type, the formal is not |
1913 | -- a formal derived type, so nothing to inherit. | |
1914 | ||
1915 | if No (Gen_Par) then | |
1916 | return Empty; | |
1917 | end if; | |
1918 | ||
2f1b20a9 ES |
1919 | -- If the generic parent type is still the generic type, this is a |
1920 | -- private formal, not a derived formal, and there are no operations | |
1921 | -- inherited from the formal. | |
fbf5a39b AC |
1922 | |
1923 | if Nkind (Parent (Gen_Par)) = N_Formal_Type_Declaration then | |
1924 | return Empty; | |
1925 | end if; | |
1926 | ||
70482933 | 1927 | Gen_Prim := Collect_Primitive_Operations (Gen_Par); |
70482933 | 1928 | |
2f1b20a9 | 1929 | Elmt := First_Elmt (Gen_Prim); |
70482933 RK |
1930 | while Present (Elmt) loop |
1931 | if Chars (Node (Elmt)) = Chars (S) then | |
1932 | declare | |
1933 | F1 : Entity_Id; | |
1934 | F2 : Entity_Id; | |
70482933 | 1935 | |
2f1b20a9 | 1936 | begin |
70482933 RK |
1937 | F1 := First_Formal (S); |
1938 | F2 := First_Formal (Node (Elmt)); | |
70482933 RK |
1939 | while Present (F1) |
1940 | and then Present (F2) | |
1941 | loop | |
70482933 RK |
1942 | if Etype (F1) = Etype (F2) |
1943 | or else Etype (F2) = Gen_Par | |
1944 | then | |
1945 | Next_Formal (F1); | |
1946 | Next_Formal (F2); | |
1947 | else | |
1948 | Next_Elmt (Elmt); | |
1949 | exit; -- not the right subprogram | |
1950 | end if; | |
1951 | ||
1952 | return Node (Elmt); | |
1953 | end loop; | |
1954 | end; | |
1955 | ||
1956 | else | |
1957 | Next_Elmt (Elmt); | |
1958 | end if; | |
1959 | end loop; | |
1960 | ||
1961 | raise Program_Error; | |
1962 | end Inherited_From_Formal; | |
1963 | ||
df3e68b1 HK |
1964 | ------------------------- |
1965 | -- Is_Direct_Deep_Call -- | |
1966 | ------------------------- | |
1967 | ||
1968 | function Is_Direct_Deep_Call (Subp : Entity_Id) return Boolean is | |
1969 | begin | |
1970 | if Is_TSS (Subp, TSS_Deep_Adjust) | |
1971 | or else Is_TSS (Subp, TSS_Deep_Finalize) | |
1972 | or else Is_TSS (Subp, TSS_Deep_Initialize) | |
1973 | then | |
1974 | declare | |
1975 | Actual : Node_Id; | |
1976 | Formal : Node_Id; | |
1977 | ||
1978 | begin | |
1979 | Actual := First (Parameter_Associations (N)); | |
1980 | Formal := First_Formal (Subp); | |
1981 | while Present (Actual) | |
1982 | and then Present (Formal) | |
1983 | loop | |
1984 | if Nkind (Actual) = N_Identifier | |
1985 | and then Is_Controlling_Actual (Actual) | |
1986 | and then Etype (Actual) = Etype (Formal) | |
1987 | then | |
1988 | return True; | |
1989 | end if; | |
1990 | ||
1991 | Next (Actual); | |
1992 | Next_Formal (Formal); | |
1993 | end loop; | |
1994 | end; | |
1995 | end if; | |
1996 | ||
1997 | return False; | |
1998 | end Is_Direct_Deep_Call; | |
1999 | ||
dd386db0 AC |
2000 | --------------- |
2001 | -- New_Value -- | |
2002 | --------------- | |
2003 | ||
2004 | function New_Value (From : Node_Id) return Node_Id is | |
2005 | Res : constant Node_Id := Duplicate_Subexpr (From); | |
2006 | begin | |
2007 | if Is_Access_Type (Etype (From)) then | |
2008 | return | |
2009 | Make_Explicit_Dereference (Sloc (From), | |
2010 | Prefix => Res); | |
2011 | else | |
2012 | return Res; | |
2013 | end if; | |
2014 | end New_Value; | |
2015 | ||
fdce4bb7 JM |
2016 | -- Local variables |
2017 | ||
deb8dacc HK |
2018 | Curr_S : constant Entity_Id := Current_Scope; |
2019 | Remote : constant Boolean := Is_Remote_Call (Call_Node); | |
fdce4bb7 JM |
2020 | Actual : Node_Id; |
2021 | Formal : Entity_Id; | |
2022 | Orig_Subp : Entity_Id := Empty; | |
2023 | Param_Count : Natural := 0; | |
2024 | Parent_Formal : Entity_Id; | |
2025 | Parent_Subp : Entity_Id; | |
2026 | Scop : Entity_Id; | |
2027 | Subp : Entity_Id; | |
2028 | ||
e27b834b | 2029 | Prev_Orig : Node_Id; |
fdce4bb7 JM |
2030 | -- Original node for an actual, which may have been rewritten. If the |
2031 | -- actual is a function call that has been transformed from a selected | |
2032 | -- component, the original node is unanalyzed. Otherwise, it carries | |
2033 | -- semantic information used to generate additional actuals. | |
2034 | ||
2035 | CW_Interface_Formals_Present : Boolean := False; | |
2036 | ||
70482933 RK |
2037 | -- Start of processing for Expand_Call |
2038 | ||
2039 | begin | |
07fc65c4 GB |
2040 | -- Ignore if previous error |
2041 | ||
6dfc5592 RD |
2042 | if Nkind (Call_Node) in N_Has_Etype |
2043 | and then Etype (Call_Node) = Any_Type | |
2044 | then | |
07fc65c4 GB |
2045 | return; |
2046 | end if; | |
2047 | ||
70482933 RK |
2048 | -- Call using access to subprogram with explicit dereference |
2049 | ||
6dfc5592 RD |
2050 | if Nkind (Name (Call_Node)) = N_Explicit_Dereference then |
2051 | Subp := Etype (Name (Call_Node)); | |
70482933 RK |
2052 | Parent_Subp := Empty; |
2053 | ||
2054 | -- Case of call to simple entry, where the Name is a selected component | |
2055 | -- whose prefix is the task, and whose selector name is the entry name | |
2056 | ||
6dfc5592 RD |
2057 | elsif Nkind (Name (Call_Node)) = N_Selected_Component then |
2058 | Subp := Entity (Selector_Name (Name (Call_Node))); | |
70482933 RK |
2059 | Parent_Subp := Empty; |
2060 | ||
2061 | -- Case of call to member of entry family, where Name is an indexed | |
2062 | -- component, with the prefix being a selected component giving the | |
2063 | -- task and entry family name, and the index being the entry index. | |
2064 | ||
6dfc5592 RD |
2065 | elsif Nkind (Name (Call_Node)) = N_Indexed_Component then |
2066 | Subp := Entity (Selector_Name (Prefix (Name (Call_Node)))); | |
70482933 RK |
2067 | Parent_Subp := Empty; |
2068 | ||
2069 | -- Normal case | |
2070 | ||
2071 | else | |
6dfc5592 | 2072 | Subp := Entity (Name (Call_Node)); |
70482933 RK |
2073 | Parent_Subp := Alias (Subp); |
2074 | ||
2075 | -- Replace call to Raise_Exception by call to Raise_Exception_Always | |
2076 | -- if we can tell that the first parameter cannot possibly be null. | |
70f91180 | 2077 | -- This improves efficiency by avoiding a run-time test. |
70482933 | 2078 | |
7888a6ae GD |
2079 | -- We do not do this if Raise_Exception_Always does not exist, which |
2080 | -- can happen in configurable run time profiles which provide only a | |
70f91180 | 2081 | -- Raise_Exception. |
7888a6ae GD |
2082 | |
2083 | if Is_RTE (Subp, RE_Raise_Exception) | |
2084 | and then RTE_Available (RE_Raise_Exception_Always) | |
70482933 RK |
2085 | then |
2086 | declare | |
3cae7f14 RD |
2087 | FA : constant Node_Id := |
2088 | Original_Node (First_Actual (Call_Node)); | |
2089 | ||
70482933 RK |
2090 | begin |
2091 | -- The case we catch is where the first argument is obtained | |
2f1b20a9 ES |
2092 | -- using the Identity attribute (which must always be |
2093 | -- non-null). | |
70482933 RK |
2094 | |
2095 | if Nkind (FA) = N_Attribute_Reference | |
2096 | and then Attribute_Name (FA) = Name_Identity | |
2097 | then | |
2098 | Subp := RTE (RE_Raise_Exception_Always); | |
6dfc5592 | 2099 | Set_Name (Call_Node, New_Occurrence_Of (Subp, Loc)); |
70482933 RK |
2100 | end if; |
2101 | end; | |
2102 | end if; | |
2103 | ||
2104 | if Ekind (Subp) = E_Entry then | |
2105 | Parent_Subp := Empty; | |
2106 | end if; | |
2107 | end if; | |
2108 | ||
deb8dacc HK |
2109 | -- Detect the following code in Ada.Finalization.Heap_Management only |
2110 | -- on .NET/JVM targets: | |
2111 | -- | |
2112 | -- procedure Finalize (Collection : in out Finalization_Collection) is | |
2113 | -- begin | |
2114 | -- . . . | |
2115 | -- begin | |
2116 | -- Finalize (Curr_Ptr.all); | |
2117 | -- | |
2118 | -- Since .NET/JVM compilers lack address arithmetic and Deep_Finalize | |
2119 | -- cannot be named in library or user code, the compiler has to install | |
2120 | -- a kludge and transform the call to Finalize into Deep_Finalize. | |
2121 | ||
2122 | if VM_Target /= No_VM | |
2123 | and then Chars (Subp) = Name_Finalize | |
2124 | and then Ekind (Curr_S) = E_Block | |
2125 | and then Ekind (Scope (Curr_S)) = E_Procedure | |
2126 | and then Chars (Scope (Curr_S)) = Name_Finalize | |
2127 | and then Etype (First_Formal (Scope (Curr_S))) = | |
2128 | RTE (RE_Finalization_Collection) | |
2129 | then | |
2130 | declare | |
2131 | Deep_Fin : constant Entity_Id := | |
2132 | Find_Prim_Op (RTE (RE_Root_Controlled), | |
2133 | TSS_Deep_Finalize); | |
2134 | begin | |
2135 | -- Since Root_Controlled is a tagged type, the compiler should | |
2136 | -- always generate Deep_Finalize for it. | |
2137 | ||
2138 | pragma Assert (Present (Deep_Fin)); | |
2139 | ||
2140 | -- Generate: | |
2141 | -- Deep_Finalize (Curr_Ptr.all); | |
2142 | ||
2143 | Rewrite (N, | |
2144 | Make_Procedure_Call_Statement (Loc, | |
2145 | Name => | |
2146 | New_Reference_To (Deep_Fin, Loc), | |
2147 | Parameter_Associations => | |
2148 | New_Copy_List_Tree (Parameter_Associations (N)))); | |
2149 | ||
2150 | Analyze (N); | |
2151 | return; | |
2152 | end; | |
2153 | end if; | |
2154 | ||
f4d379b8 HK |
2155 | -- Ada 2005 (AI-345): We have a procedure call as a triggering |
2156 | -- alternative in an asynchronous select or as an entry call in | |
2157 | -- a conditional or timed select. Check whether the procedure call | |
2158 | -- is a renaming of an entry and rewrite it as an entry call. | |
2159 | ||
0791fbe9 | 2160 | if Ada_Version >= Ada_2005 |
6dfc5592 | 2161 | and then Nkind (Call_Node) = N_Procedure_Call_Statement |
f4d379b8 | 2162 | and then |
6dfc5592 | 2163 | ((Nkind (Parent (Call_Node)) = N_Triggering_Alternative |
3cae7f14 | 2164 | and then Triggering_Statement (Parent (Call_Node)) = Call_Node) |
f4d379b8 | 2165 | or else |
6dfc5592 | 2166 | (Nkind (Parent (Call_Node)) = N_Entry_Call_Alternative |
3cae7f14 | 2167 | and then Entry_Call_Statement (Parent (Call_Node)) = Call_Node)) |
f4d379b8 HK |
2168 | then |
2169 | declare | |
2170 | Ren_Decl : Node_Id; | |
2171 | Ren_Root : Entity_Id := Subp; | |
2172 | ||
2173 | begin | |
2174 | -- This may be a chain of renamings, find the root | |
2175 | ||
2176 | if Present (Alias (Ren_Root)) then | |
2177 | Ren_Root := Alias (Ren_Root); | |
2178 | end if; | |
2179 | ||
2180 | if Present (Original_Node (Parent (Parent (Ren_Root)))) then | |
2181 | Ren_Decl := Original_Node (Parent (Parent (Ren_Root))); | |
2182 | ||
2183 | if Nkind (Ren_Decl) = N_Subprogram_Renaming_Declaration then | |
6dfc5592 | 2184 | Rewrite (Call_Node, |
f4d379b8 HK |
2185 | Make_Entry_Call_Statement (Loc, |
2186 | Name => | |
2187 | New_Copy_Tree (Name (Ren_Decl)), | |
2188 | Parameter_Associations => | |
6dfc5592 RD |
2189 | New_Copy_List_Tree |
2190 | (Parameter_Associations (Call_Node)))); | |
f4d379b8 HK |
2191 | |
2192 | return; | |
2193 | end if; | |
2194 | end if; | |
2195 | end; | |
2196 | end if; | |
2197 | ||
e27b834b AC |
2198 | -- First step, compute extra actuals, corresponding to any Extra_Formals |
2199 | -- present. Note that we do not access Extra_Formals directly, instead | |
2200 | -- we simply note the presence of the extra formals as we process the | |
2201 | -- regular formals collecting corresponding actuals in Extra_Actuals. | |
70482933 | 2202 | |
c2369146 AC |
2203 | -- We also generate any required range checks for actuals for in formals |
2204 | -- as we go through the loop, since this is a convenient place to do it. | |
2205 | -- (Though it seems that this would be better done in Expand_Actuals???) | |
fbf5a39b | 2206 | |
fdce4bb7 | 2207 | Formal := First_Formal (Subp); |
6dfc5592 | 2208 | Actual := First_Actual (Call_Node); |
fdce4bb7 | 2209 | Param_Count := 1; |
70482933 | 2210 | while Present (Formal) loop |
fbf5a39b | 2211 | |
d79e621a | 2212 | -- Generate range check if required |
fbf5a39b | 2213 | |
d79e621a | 2214 | if Do_Range_Check (Actual) |
c2369146 | 2215 | and then Ekind (Formal) = E_In_Parameter |
d79e621a GD |
2216 | then |
2217 | Set_Do_Range_Check (Actual, False); | |
2218 | Generate_Range_Check | |
2219 | (Actual, Etype (Formal), CE_Range_Check_Failed); | |
2220 | end if; | |
fbf5a39b AC |
2221 | |
2222 | -- Prepare to examine current entry | |
2223 | ||
70482933 RK |
2224 | Prev := Actual; |
2225 | Prev_Orig := Original_Node (Prev); | |
2226 | ||
758c442c | 2227 | -- Ada 2005 (AI-251): Check if any formal is a class-wide interface |
2f1b20a9 | 2228 | -- to expand it in a further round. |
758c442c GD |
2229 | |
2230 | CW_Interface_Formals_Present := | |
2231 | CW_Interface_Formals_Present | |
2232 | or else | |
2233 | (Ekind (Etype (Formal)) = E_Class_Wide_Type | |
2234 | and then Is_Interface (Etype (Etype (Formal)))) | |
2235 | or else | |
2236 | (Ekind (Etype (Formal)) = E_Anonymous_Access_Type | |
2237 | and then Is_Interface (Directly_Designated_Type | |
2238 | (Etype (Etype (Formal))))); | |
2239 | ||
2240 | -- Create possible extra actual for constrained case. Usually, the | |
2241 | -- extra actual is of the form actual'constrained, but since this | |
2242 | -- attribute is only available for unconstrained records, TRUE is | |
2243 | -- expanded if the type of the formal happens to be constrained (for | |
2244 | -- instance when this procedure is inherited from an unconstrained | |
2245 | -- record to a constrained one) or if the actual has no discriminant | |
2246 | -- (its type is constrained). An exception to this is the case of a | |
2247 | -- private type without discriminants. In this case we pass FALSE | |
2248 | -- because the object has underlying discriminants with defaults. | |
70482933 RK |
2249 | |
2250 | if Present (Extra_Constrained (Formal)) then | |
2251 | if Ekind (Etype (Prev)) in Private_Kind | |
2252 | and then not Has_Discriminants (Base_Type (Etype (Prev))) | |
2253 | then | |
01aef5ad GD |
2254 | Add_Extra_Actual |
2255 | (New_Occurrence_Of (Standard_False, Loc), | |
2256 | Extra_Constrained (Formal)); | |
70482933 RK |
2257 | |
2258 | elsif Is_Constrained (Etype (Formal)) | |
2259 | or else not Has_Discriminants (Etype (Prev)) | |
2260 | then | |
01aef5ad GD |
2261 | Add_Extra_Actual |
2262 | (New_Occurrence_Of (Standard_True, Loc), | |
2263 | Extra_Constrained (Formal)); | |
70482933 | 2264 | |
5d09245e AC |
2265 | -- Do not produce extra actuals for Unchecked_Union parameters. |
2266 | -- Jump directly to the end of the loop. | |
2267 | ||
2268 | elsif Is_Unchecked_Union (Base_Type (Etype (Actual))) then | |
2269 | goto Skip_Extra_Actual_Generation; | |
2270 | ||
70482933 RK |
2271 | else |
2272 | -- If the actual is a type conversion, then the constrained | |
2273 | -- test applies to the actual, not the target type. | |
2274 | ||
2275 | declare | |
2f1b20a9 | 2276 | Act_Prev : Node_Id; |
70482933 RK |
2277 | |
2278 | begin | |
2f1b20a9 ES |
2279 | -- Test for unchecked conversions as well, which can occur |
2280 | -- as out parameter actuals on calls to stream procedures. | |
70482933 | 2281 | |
2f1b20a9 | 2282 | Act_Prev := Prev; |
ac4d6407 RD |
2283 | while Nkind_In (Act_Prev, N_Type_Conversion, |
2284 | N_Unchecked_Type_Conversion) | |
fbf5a39b | 2285 | loop |
70482933 | 2286 | Act_Prev := Expression (Act_Prev); |
fbf5a39b | 2287 | end loop; |
70482933 | 2288 | |
3563739b AC |
2289 | -- If the expression is a conversion of a dereference, this |
2290 | -- is internally generated code that manipulates addresses, | |
2291 | -- e.g. when building interface tables. No check should | |
2292 | -- occur in this case, and the discriminated object is not | |
2293 | -- directly a hand. | |
f4d379b8 HK |
2294 | |
2295 | if not Comes_From_Source (Actual) | |
2296 | and then Nkind (Actual) = N_Unchecked_Type_Conversion | |
2297 | and then Nkind (Act_Prev) = N_Explicit_Dereference | |
2298 | then | |
2299 | Add_Extra_Actual | |
2300 | (New_Occurrence_Of (Standard_False, Loc), | |
2301 | Extra_Constrained (Formal)); | |
2302 | ||
2303 | else | |
2304 | Add_Extra_Actual | |
2305 | (Make_Attribute_Reference (Sloc (Prev), | |
2306 | Prefix => | |
2307 | Duplicate_Subexpr_No_Checks | |
2308 | (Act_Prev, Name_Req => True), | |
2309 | Attribute_Name => Name_Constrained), | |
2310 | Extra_Constrained (Formal)); | |
2311 | end if; | |
70482933 RK |
2312 | end; |
2313 | end if; | |
2314 | end if; | |
2315 | ||
2316 | -- Create possible extra actual for accessibility level | |
2317 | ||
2318 | if Present (Extra_Accessibility (Formal)) then | |
7888a6ae GD |
2319 | |
2320 | -- Ada 2005 (AI-252): If the actual was rewritten as an Access | |
2321 | -- attribute, then the original actual may be an aliased object | |
2322 | -- occurring as the prefix in a call using "Object.Operation" | |
2323 | -- notation. In that case we must pass the level of the object, | |
2324 | -- so Prev_Orig is reset to Prev and the attribute will be | |
2325 | -- processed by the code for Access attributes further below. | |
2326 | ||
2327 | if Prev_Orig /= Prev | |
2328 | and then Nkind (Prev) = N_Attribute_Reference | |
2329 | and then | |
2330 | Get_Attribute_Id (Attribute_Name (Prev)) = Attribute_Access | |
2331 | and then Is_Aliased_View (Prev_Orig) | |
2332 | then | |
2333 | Prev_Orig := Prev; | |
2334 | end if; | |
2335 | ||
9d983bbf AC |
2336 | -- Ada 2005 (AI-251): Thunks must propagate the extra actuals of |
2337 | -- accessibility levels. | |
fdce4bb7 JM |
2338 | |
2339 | if Ekind (Current_Scope) in Subprogram_Kind | |
2340 | and then Is_Thunk (Current_Scope) | |
2341 | then | |
2342 | declare | |
2343 | Parm_Ent : Entity_Id; | |
2344 | ||
2345 | begin | |
2346 | if Is_Controlling_Actual (Actual) then | |
2347 | ||
2348 | -- Find the corresponding actual of the thunk | |
2349 | ||
2350 | Parm_Ent := First_Entity (Current_Scope); | |
2351 | for J in 2 .. Param_Count loop | |
2352 | Next_Entity (Parm_Ent); | |
2353 | end loop; | |
2354 | ||
2355 | else pragma Assert (Is_Entity_Name (Actual)); | |
2356 | Parm_Ent := Entity (Actual); | |
2357 | end if; | |
2358 | ||
2359 | Add_Extra_Actual | |
2360 | (New_Occurrence_Of (Extra_Accessibility (Parm_Ent), Loc), | |
2361 | Extra_Accessibility (Formal)); | |
2362 | end; | |
2363 | ||
2364 | elsif Is_Entity_Name (Prev_Orig) then | |
70482933 | 2365 | |
d766cee3 RD |
2366 | -- When passing an access parameter, or a renaming of an access |
2367 | -- parameter, as the actual to another access parameter we need | |
2368 | -- to pass along the actual's own access level parameter. This | |
2369 | -- is done if we are within the scope of the formal access | |
2370 | -- parameter (if this is an inlined body the extra formal is | |
2371 | -- irrelevant). | |
2372 | ||
2373 | if (Is_Formal (Entity (Prev_Orig)) | |
2374 | or else | |
2375 | (Present (Renamed_Object (Entity (Prev_Orig))) | |
2376 | and then | |
2377 | Is_Entity_Name (Renamed_Object (Entity (Prev_Orig))) | |
2378 | and then | |
2379 | Is_Formal | |
2380 | (Entity (Renamed_Object (Entity (Prev_Orig)))))) | |
70482933 RK |
2381 | and then Ekind (Etype (Prev_Orig)) = E_Anonymous_Access_Type |
2382 | and then In_Open_Scopes (Scope (Entity (Prev_Orig))) | |
2383 | then | |
2384 | declare | |
2385 | Parm_Ent : constant Entity_Id := Param_Entity (Prev_Orig); | |
2386 | ||
2387 | begin | |
2388 | pragma Assert (Present (Parm_Ent)); | |
2389 | ||
2390 | if Present (Extra_Accessibility (Parm_Ent)) then | |
f4d379b8 HK |
2391 | Add_Extra_Actual |
2392 | (New_Occurrence_Of | |
2393 | (Extra_Accessibility (Parm_Ent), Loc), | |
2394 | Extra_Accessibility (Formal)); | |
70482933 RK |
2395 | |
2396 | -- If the actual access parameter does not have an | |
2397 | -- associated extra formal providing its scope level, | |
2398 | -- then treat the actual as having library-level | |
2399 | -- accessibility. | |
2400 | ||
2401 | else | |
f4d379b8 HK |
2402 | Add_Extra_Actual |
2403 | (Make_Integer_Literal (Loc, | |
01aef5ad | 2404 | Intval => Scope_Depth (Standard_Standard)), |
f4d379b8 | 2405 | Extra_Accessibility (Formal)); |
70482933 RK |
2406 | end if; |
2407 | end; | |
2408 | ||
7888a6ae GD |
2409 | -- The actual is a normal access value, so just pass the level |
2410 | -- of the actual's access type. | |
70482933 RK |
2411 | |
2412 | else | |
f4d379b8 HK |
2413 | Add_Extra_Actual |
2414 | (Make_Integer_Literal (Loc, | |
01aef5ad | 2415 | Intval => Type_Access_Level (Etype (Prev_Orig))), |
f4d379b8 | 2416 | Extra_Accessibility (Formal)); |
70482933 RK |
2417 | end if; |
2418 | ||
01aef5ad GD |
2419 | -- If the actual is an access discriminant, then pass the level |
2420 | -- of the enclosing object (RM05-3.10.2(12.4/2)). | |
2421 | ||
2422 | elsif Nkind (Prev_Orig) = N_Selected_Component | |
2423 | and then Ekind (Entity (Selector_Name (Prev_Orig))) = | |
2424 | E_Discriminant | |
2425 | and then Ekind (Etype (Entity (Selector_Name (Prev_Orig)))) = | |
2426 | E_Anonymous_Access_Type | |
2427 | then | |
2428 | Add_Extra_Actual | |
2429 | (Make_Integer_Literal (Loc, | |
2430 | Intval => Object_Access_Level (Prefix (Prev_Orig))), | |
2431 | Extra_Accessibility (Formal)); | |
2432 | ||
2433 | -- All other cases | |
fdce4bb7 | 2434 | |
70482933 RK |
2435 | else |
2436 | case Nkind (Prev_Orig) is | |
2437 | ||
2438 | when N_Attribute_Reference => | |
70482933 RK |
2439 | case Get_Attribute_Id (Attribute_Name (Prev_Orig)) is |
2440 | ||
75a64833 | 2441 | -- For X'Access, pass on the level of the prefix X |
70482933 RK |
2442 | |
2443 | when Attribute_Access => | |
75a64833 AC |
2444 | Add_Extra_Actual |
2445 | (Make_Integer_Literal (Loc, | |
2446 | Intval => | |
2447 | Object_Access_Level | |
2448 | (Prefix (Prev_Orig))), | |
bac7206d | 2449 | Extra_Accessibility (Formal)); |
70482933 RK |
2450 | |
2451 | -- Treat the unchecked attributes as library-level | |
2452 | ||
2453 | when Attribute_Unchecked_Access | | |
2454 | Attribute_Unrestricted_Access => | |
01aef5ad GD |
2455 | Add_Extra_Actual |
2456 | (Make_Integer_Literal (Loc, | |
2457 | Intval => Scope_Depth (Standard_Standard)), | |
2458 | Extra_Accessibility (Formal)); | |
70482933 RK |
2459 | |
2460 | -- No other cases of attributes returning access | |
9d983bbf | 2461 | -- values that can be passed to access parameters. |
70482933 RK |
2462 | |
2463 | when others => | |
2464 | raise Program_Error; | |
2465 | ||
2466 | end case; | |
2467 | ||
92a745f3 TQ |
2468 | -- For allocators we pass the level of the execution of the |
2469 | -- called subprogram, which is one greater than the current | |
2470 | -- scope level. | |
70482933 RK |
2471 | |
2472 | when N_Allocator => | |
01aef5ad GD |
2473 | Add_Extra_Actual |
2474 | (Make_Integer_Literal (Loc, | |
2475 | Intval => Scope_Depth (Current_Scope) + 1), | |
2476 | Extra_Accessibility (Formal)); | |
70482933 | 2477 | |
8ca3bf91 GD |
2478 | -- For other cases we simply pass the level of the actual's |
2479 | -- access type. The type is retrieved from Prev rather than | |
61549759 | 2480 | -- Prev_Orig, because in some cases Prev_Orig denotes an |
8ca3bf91 | 2481 | -- original expression that has not been analyzed. |
70482933 RK |
2482 | |
2483 | when others => | |
01aef5ad GD |
2484 | Add_Extra_Actual |
2485 | (Make_Integer_Literal (Loc, | |
8ca3bf91 | 2486 | Intval => Type_Access_Level (Etype (Prev))), |
01aef5ad | 2487 | Extra_Accessibility (Formal)); |
70482933 RK |
2488 | end case; |
2489 | end if; | |
2490 | end if; | |
2491 | ||
2f1b20a9 | 2492 | -- Perform the check of 4.6(49) that prevents a null value from being |
b3f48fd4 AC |
2493 | -- passed as an actual to an access parameter. Note that the check |
2494 | -- is elided in the common cases of passing an access attribute or | |
2f1b20a9 ES |
2495 | -- access parameter as an actual. Also, we currently don't enforce |
2496 | -- this check for expander-generated actuals and when -gnatdj is set. | |
70482933 | 2497 | |
0791fbe9 | 2498 | if Ada_Version >= Ada_2005 then |
70482933 | 2499 | |
b3f48fd4 AC |
2500 | -- Ada 2005 (AI-231): Check null-excluding access types. Note that |
2501 | -- the intent of 6.4.1(13) is that null-exclusion checks should | |
2502 | -- not be done for 'out' parameters, even though it refers only | |
308e6f3a | 2503 | -- to constraint checks, and a null_exclusion is not a constraint. |
b3f48fd4 | 2504 | -- Note that AI05-0196-1 corrects this mistake in the RM. |
70482933 | 2505 | |
2f1b20a9 ES |
2506 | if Is_Access_Type (Etype (Formal)) |
2507 | and then Can_Never_Be_Null (Etype (Formal)) | |
b3f48fd4 | 2508 | and then Ekind (Formal) /= E_Out_Parameter |
2f1b20a9 | 2509 | and then Nkind (Prev) /= N_Raise_Constraint_Error |
d766cee3 | 2510 | and then (Known_Null (Prev) |
2f1b20a9 ES |
2511 | or else not Can_Never_Be_Null (Etype (Prev))) |
2512 | then | |
2513 | Install_Null_Excluding_Check (Prev); | |
2514 | end if; | |
70482933 | 2515 | |
0791fbe9 | 2516 | -- Ada_Version < Ada_2005 |
70482933 | 2517 | |
2f1b20a9 ES |
2518 | else |
2519 | if Ekind (Etype (Formal)) /= E_Anonymous_Access_Type | |
2520 | or else Access_Checks_Suppressed (Subp) | |
2521 | then | |
2522 | null; | |
70482933 | 2523 | |
2f1b20a9 ES |
2524 | elsif Debug_Flag_J then |
2525 | null; | |
70482933 | 2526 | |
2f1b20a9 ES |
2527 | elsif not Comes_From_Source (Prev) then |
2528 | null; | |
70482933 | 2529 | |
2f1b20a9 ES |
2530 | elsif Is_Entity_Name (Prev) |
2531 | and then Ekind (Etype (Prev)) = E_Anonymous_Access_Type | |
2532 | then | |
2533 | null; | |
2820d220 | 2534 | |
ac4d6407 | 2535 | elsif Nkind_In (Prev, N_Allocator, N_Attribute_Reference) then |
2f1b20a9 ES |
2536 | null; |
2537 | ||
2538 | -- Suppress null checks when passing to access parameters of Java | |
7888a6ae GD |
2539 | -- and CIL subprograms. (Should this be done for other foreign |
2540 | -- conventions as well ???) | |
2f1b20a9 | 2541 | |
7888a6ae GD |
2542 | elsif Convention (Subp) = Convention_Java |
2543 | or else Convention (Subp) = Convention_CIL | |
2544 | then | |
2f1b20a9 ES |
2545 | null; |
2546 | ||
2547 | else | |
2548 | Install_Null_Excluding_Check (Prev); | |
2549 | end if; | |
70482933 RK |
2550 | end if; |
2551 | ||
fbf5a39b AC |
2552 | -- Perform appropriate validity checks on parameters that |
2553 | -- are entities. | |
70482933 RK |
2554 | |
2555 | if Validity_Checks_On then | |
6cdb2c6e AC |
2556 | if (Ekind (Formal) = E_In_Parameter |
2557 | and then Validity_Check_In_Params) | |
2558 | or else | |
2559 | (Ekind (Formal) = E_In_Out_Parameter | |
2560 | and then Validity_Check_In_Out_Params) | |
70482933 | 2561 | then |
7888a6ae GD |
2562 | -- If the actual is an indexed component of a packed type (or |
2563 | -- is an indexed or selected component whose prefix recursively | |
2564 | -- meets this condition), it has not been expanded yet. It will | |
2565 | -- be copied in the validity code that follows, and has to be | |
2566 | -- expanded appropriately, so reanalyze it. | |
08aa9a4a | 2567 | |
7888a6ae GD |
2568 | -- What we do is just to unset analyzed bits on prefixes till |
2569 | -- we reach something that does not have a prefix. | |
2570 | ||
2571 | declare | |
2572 | Nod : Node_Id; | |
2573 | ||
2574 | begin | |
2575 | Nod := Actual; | |
ac4d6407 RD |
2576 | while Nkind_In (Nod, N_Indexed_Component, |
2577 | N_Selected_Component) | |
7888a6ae GD |
2578 | loop |
2579 | Set_Analyzed (Nod, False); | |
2580 | Nod := Prefix (Nod); | |
2581 | end loop; | |
2582 | end; | |
08aa9a4a | 2583 | |
70482933 | 2584 | Ensure_Valid (Actual); |
70482933 RK |
2585 | end if; |
2586 | end if; | |
2587 | ||
2588 | -- For IN OUT and OUT parameters, ensure that subscripts are valid | |
2589 | -- since this is a left side reference. We only do this for calls | |
2590 | -- from the source program since we assume that compiler generated | |
2591 | -- calls explicitly generate any required checks. We also need it | |
b3f48fd4 AC |
2592 | -- only if we are doing standard validity checks, since clearly it is |
2593 | -- not needed if validity checks are off, and in subscript validity | |
2594 | -- checking mode, all indexed components are checked with a call | |
2595 | -- directly from Expand_N_Indexed_Component. | |
70482933 | 2596 | |
6dfc5592 | 2597 | if Comes_From_Source (Call_Node) |
70482933 RK |
2598 | and then Ekind (Formal) /= E_In_Parameter |
2599 | and then Validity_Checks_On | |
2600 | and then Validity_Check_Default | |
2601 | and then not Validity_Check_Subscripts | |
2602 | then | |
2603 | Check_Valid_Lvalue_Subscripts (Actual); | |
2604 | end if; | |
2605 | ||
c8ef728f ES |
2606 | -- Mark any scalar OUT parameter that is a simple variable as no |
2607 | -- longer known to be valid (unless the type is always valid). This | |
2608 | -- reflects the fact that if an OUT parameter is never set in a | |
2609 | -- procedure, then it can become invalid on the procedure return. | |
fbf5a39b AC |
2610 | |
2611 | if Ekind (Formal) = E_Out_Parameter | |
2612 | and then Is_Entity_Name (Actual) | |
2613 | and then Ekind (Entity (Actual)) = E_Variable | |
2614 | and then not Is_Known_Valid (Etype (Actual)) | |
2615 | then | |
2616 | Set_Is_Known_Valid (Entity (Actual), False); | |
2617 | end if; | |
2618 | ||
c8ef728f ES |
2619 | -- For an OUT or IN OUT parameter, if the actual is an entity, then |
2620 | -- clear current values, since they can be clobbered. We are probably | |
2621 | -- doing this in more places than we need to, but better safe than | |
2622 | -- sorry when it comes to retaining bad current values! | |
fbf5a39b AC |
2623 | |
2624 | if Ekind (Formal) /= E_In_Parameter | |
2625 | and then Is_Entity_Name (Actual) | |
67ce0d7e | 2626 | and then Present (Entity (Actual)) |
fbf5a39b | 2627 | then |
67ce0d7e RD |
2628 | declare |
2629 | Ent : constant Entity_Id := Entity (Actual); | |
2630 | Sav : Node_Id; | |
2631 | ||
2632 | begin | |
ac4d6407 RD |
2633 | -- For an OUT or IN OUT parameter that is an assignable entity, |
2634 | -- we do not want to clobber the Last_Assignment field, since | |
2635 | -- if it is set, it was precisely because it is indeed an OUT | |
75ba322d AC |
2636 | -- or IN OUT parameter! We do reset the Is_Known_Valid flag |
2637 | -- since the subprogram could have returned in invalid value. | |
ac4d6407 RD |
2638 | |
2639 | if (Ekind (Formal) = E_Out_Parameter | |
2640 | or else | |
2641 | Ekind (Formal) = E_In_Out_Parameter) | |
67ce0d7e RD |
2642 | and then Is_Assignable (Ent) |
2643 | then | |
2644 | Sav := Last_Assignment (Ent); | |
2645 | Kill_Current_Values (Ent); | |
2646 | Set_Last_Assignment (Ent, Sav); | |
75ba322d | 2647 | Set_Is_Known_Valid (Ent, False); |
67ce0d7e RD |
2648 | |
2649 | -- For all other cases, just kill the current values | |
2650 | ||
2651 | else | |
2652 | Kill_Current_Values (Ent); | |
2653 | end if; | |
2654 | end; | |
fbf5a39b AC |
2655 | end if; |
2656 | ||
70482933 RK |
2657 | -- If the formal is class wide and the actual is an aggregate, force |
2658 | -- evaluation so that the back end who does not know about class-wide | |
2659 | -- type, does not generate a temporary of the wrong size. | |
2660 | ||
2661 | if not Is_Class_Wide_Type (Etype (Formal)) then | |
2662 | null; | |
2663 | ||
2664 | elsif Nkind (Actual) = N_Aggregate | |
2665 | or else (Nkind (Actual) = N_Qualified_Expression | |
2666 | and then Nkind (Expression (Actual)) = N_Aggregate) | |
2667 | then | |
2668 | Force_Evaluation (Actual); | |
2669 | end if; | |
2670 | ||
2671 | -- In a remote call, if the formal is of a class-wide type, check | |
2672 | -- that the actual meets the requirements described in E.4(18). | |
2673 | ||
7888a6ae | 2674 | if Remote and then Is_Class_Wide_Type (Etype (Formal)) then |
70482933 | 2675 | Insert_Action (Actual, |
7888a6ae GD |
2676 | Make_Transportable_Check (Loc, |
2677 | Duplicate_Subexpr_Move_Checks (Actual))); | |
70482933 RK |
2678 | end if; |
2679 | ||
5d09245e AC |
2680 | -- This label is required when skipping extra actual generation for |
2681 | -- Unchecked_Union parameters. | |
2682 | ||
2683 | <<Skip_Extra_Actual_Generation>> | |
2684 | ||
fdce4bb7 | 2685 | Param_Count := Param_Count + 1; |
70482933 RK |
2686 | Next_Actual (Actual); |
2687 | Next_Formal (Formal); | |
2688 | end loop; | |
2689 | ||
c8ef728f ES |
2690 | -- If we are expanding a rhs of an assignment we need to check if tag |
2691 | -- propagation is needed. You might expect this processing to be in | |
2692 | -- Analyze_Assignment but has to be done earlier (bottom-up) because the | |
2693 | -- assignment might be transformed to a declaration for an unconstrained | |
2694 | -- value if the expression is classwide. | |
70482933 | 2695 | |
6dfc5592 RD |
2696 | if Nkind (Call_Node) = N_Function_Call |
2697 | and then Is_Tag_Indeterminate (Call_Node) | |
2698 | and then Is_Entity_Name (Name (Call_Node)) | |
70482933 RK |
2699 | then |
2700 | declare | |
2701 | Ass : Node_Id := Empty; | |
2702 | ||
2703 | begin | |
6dfc5592 RD |
2704 | if Nkind (Parent (Call_Node)) = N_Assignment_Statement then |
2705 | Ass := Parent (Call_Node); | |
70482933 | 2706 | |
6dfc5592 | 2707 | elsif Nkind (Parent (Call_Node)) = N_Qualified_Expression |
3cae7f14 RD |
2708 | and then Nkind (Parent (Parent (Call_Node))) = |
2709 | N_Assignment_Statement | |
70482933 | 2710 | then |
6dfc5592 | 2711 | Ass := Parent (Parent (Call_Node)); |
02822a92 | 2712 | |
6dfc5592 | 2713 | elsif Nkind (Parent (Call_Node)) = N_Explicit_Dereference |
3cae7f14 RD |
2714 | and then Nkind (Parent (Parent (Call_Node))) = |
2715 | N_Assignment_Statement | |
02822a92 | 2716 | then |
6dfc5592 | 2717 | Ass := Parent (Parent (Call_Node)); |
70482933 RK |
2718 | end if; |
2719 | ||
2720 | if Present (Ass) | |
2721 | and then Is_Class_Wide_Type (Etype (Name (Ass))) | |
2722 | then | |
6dfc5592 RD |
2723 | if Is_Access_Type (Etype (Call_Node)) then |
2724 | if Designated_Type (Etype (Call_Node)) /= | |
02822a92 RD |
2725 | Root_Type (Etype (Name (Ass))) |
2726 | then | |
2727 | Error_Msg_NE | |
2728 | ("tag-indeterminate expression " | |
d766cee3 | 2729 | & " must have designated type& (RM 5.2 (6))", |
3cae7f14 | 2730 | Call_Node, Root_Type (Etype (Name (Ass)))); |
02822a92 | 2731 | else |
6dfc5592 | 2732 | Propagate_Tag (Name (Ass), Call_Node); |
02822a92 RD |
2733 | end if; |
2734 | ||
6dfc5592 | 2735 | elsif Etype (Call_Node) /= Root_Type (Etype (Name (Ass))) then |
fbf5a39b AC |
2736 | Error_Msg_NE |
2737 | ("tag-indeterminate expression must have type&" | |
6dfc5592 RD |
2738 | & "(RM 5.2 (6))", |
2739 | Call_Node, Root_Type (Etype (Name (Ass)))); | |
02822a92 | 2740 | |
fbf5a39b | 2741 | else |
6dfc5592 | 2742 | Propagate_Tag (Name (Ass), Call_Node); |
fbf5a39b AC |
2743 | end if; |
2744 | ||
2745 | -- The call will be rewritten as a dispatching call, and | |
2746 | -- expanded as such. | |
2747 | ||
70482933 RK |
2748 | return; |
2749 | end if; | |
2750 | end; | |
2751 | end if; | |
2752 | ||
758c442c GD |
2753 | -- Ada 2005 (AI-251): If some formal is a class-wide interface, expand |
2754 | -- it to point to the correct secondary virtual table | |
2755 | ||
6dfc5592 | 2756 | if Nkind_In (Call_Node, N_Function_Call, N_Procedure_Call_Statement) |
758c442c GD |
2757 | and then CW_Interface_Formals_Present |
2758 | then | |
6dfc5592 | 2759 | Expand_Interface_Actuals (Call_Node); |
758c442c GD |
2760 | end if; |
2761 | ||
70482933 RK |
2762 | -- Deals with Dispatch_Call if we still have a call, before expanding |
2763 | -- extra actuals since this will be done on the re-analysis of the | |
b3f48fd4 AC |
2764 | -- dispatching call. Note that we do not try to shorten the actual list |
2765 | -- for a dispatching call, it would not make sense to do so. Expansion | |
2766 | -- of dispatching calls is suppressed when VM_Target, because the VM | |
2767 | -- back-ends directly handle the generation of dispatching calls and | |
2768 | -- would have to undo any expansion to an indirect call. | |
70482933 | 2769 | |
6dfc5592 RD |
2770 | if Nkind_In (Call_Node, N_Function_Call, N_Procedure_Call_Statement) |
2771 | and then Present (Controlling_Argument (Call_Node)) | |
70482933 | 2772 | then |
6dfc5592 | 2773 | declare |
dd386db0 | 2774 | Call_Typ : constant Entity_Id := Etype (Call_Node); |
6dfc5592 RD |
2775 | Typ : constant Entity_Id := Find_Dispatching_Type (Subp); |
2776 | Eq_Prim_Op : Entity_Id := Empty; | |
dd386db0 AC |
2777 | New_Call : Node_Id; |
2778 | Param : Node_Id; | |
2779 | Prev_Call : Node_Id; | |
fbf5a39b | 2780 | |
6dfc5592 RD |
2781 | begin |
2782 | if not Is_Limited_Type (Typ) then | |
2783 | Eq_Prim_Op := Find_Prim_Op (Typ, Name_Op_Eq); | |
2784 | end if; | |
fbf5a39b | 2785 | |
6dfc5592 RD |
2786 | if Tagged_Type_Expansion then |
2787 | Expand_Dispatching_Call (Call_Node); | |
70f91180 | 2788 | |
6dfc5592 RD |
2789 | -- The following return is worrisome. Is it really OK to skip |
2790 | -- all remaining processing in this procedure ??? | |
5a1ccfb1 | 2791 | |
6dfc5592 | 2792 | return; |
5a1ccfb1 | 2793 | |
6dfc5592 RD |
2794 | -- VM targets |
2795 | ||
2796 | else | |
2797 | Apply_Tag_Checks (Call_Node); | |
2798 | ||
dd386db0 AC |
2799 | -- If this is a dispatching "=", we must first compare the |
2800 | -- tags so we generate: x.tag = y.tag and then x = y | |
2801 | ||
2802 | if Subp = Eq_Prim_Op then | |
2803 | ||
2804 | -- Mark the node as analyzed to avoid reanalizing this | |
2805 | -- dispatching call (which would cause a never-ending loop) | |
2806 | ||
2807 | Prev_Call := Relocate_Node (Call_Node); | |
2808 | Set_Analyzed (Prev_Call); | |
2809 | ||
2810 | Param := First_Actual (Call_Node); | |
2811 | New_Call := | |
2812 | Make_And_Then (Loc, | |
2813 | Left_Opnd => | |
2814 | Make_Op_Eq (Loc, | |
2815 | Left_Opnd => | |
2816 | Make_Selected_Component (Loc, | |
2817 | Prefix => New_Value (Param), | |
2818 | Selector_Name => | |
2819 | New_Reference_To (First_Tag_Component (Typ), | |
2820 | Loc)), | |
2821 | ||
2822 | Right_Opnd => | |
2823 | Make_Selected_Component (Loc, | |
2824 | Prefix => | |
2825 | Unchecked_Convert_To (Typ, | |
2826 | New_Value (Next_Actual (Param))), | |
2827 | Selector_Name => | |
2828 | New_Reference_To | |
2829 | (First_Tag_Component (Typ), Loc))), | |
2830 | Right_Opnd => Prev_Call); | |
2831 | ||
2832 | Rewrite (Call_Node, New_Call); | |
2833 | ||
2834 | Analyze_And_Resolve | |
2835 | (Call_Node, Call_Typ, Suppress => All_Checks); | |
2836 | end if; | |
2837 | ||
6dfc5592 RD |
2838 | -- Expansion of a dispatching call results in an indirect call, |
2839 | -- which in turn causes current values to be killed (see | |
2840 | -- Resolve_Call), so on VM targets we do the call here to | |
2841 | -- ensure consistent warnings between VM and non-VM targets. | |
2842 | ||
2843 | Kill_Current_Values; | |
2844 | end if; | |
2845 | ||
2846 | -- If this is a dispatching "=" then we must update the reference | |
2847 | -- to the call node because we generated: | |
2848 | -- x.tag = y.tag and then x = y | |
2849 | ||
dd386db0 | 2850 | if Subp = Eq_Prim_Op then |
6dfc5592 RD |
2851 | Call_Node := Right_Opnd (Call_Node); |
2852 | end if; | |
2853 | end; | |
70f91180 | 2854 | end if; |
70482933 RK |
2855 | |
2856 | -- Similarly, expand calls to RCI subprograms on which pragma | |
2857 | -- All_Calls_Remote applies. The rewriting will be reanalyzed | |
b3f48fd4 AC |
2858 | -- later. Do this only when the call comes from source since we |
2859 | -- do not want such a rewriting to occur in expanded code. | |
70482933 | 2860 | |
6dfc5592 RD |
2861 | if Is_All_Remote_Call (Call_Node) then |
2862 | Expand_All_Calls_Remote_Subprogram_Call (Call_Node); | |
70482933 RK |
2863 | |
2864 | -- Similarly, do not add extra actuals for an entry call whose entity | |
2865 | -- is a protected procedure, or for an internal protected subprogram | |
2866 | -- call, because it will be rewritten as a protected subprogram call | |
2867 | -- and reanalyzed (see Expand_Protected_Subprogram_Call). | |
2868 | ||
2869 | elsif Is_Protected_Type (Scope (Subp)) | |
2870 | and then (Ekind (Subp) = E_Procedure | |
2871 | or else Ekind (Subp) = E_Function) | |
2872 | then | |
2873 | null; | |
2874 | ||
2875 | -- During that loop we gathered the extra actuals (the ones that | |
2876 | -- correspond to Extra_Formals), so now they can be appended. | |
2877 | ||
2878 | else | |
2879 | while Is_Non_Empty_List (Extra_Actuals) loop | |
2880 | Add_Actual_Parameter (Remove_Head (Extra_Actuals)); | |
2881 | end loop; | |
2882 | end if; | |
2883 | ||
b3f48fd4 AC |
2884 | -- At this point we have all the actuals, so this is the point at which |
2885 | -- the various expansion activities for actuals is carried out. | |
f44fe430 | 2886 | |
6dfc5592 | 2887 | Expand_Actuals (Call_Node, Subp); |
70482933 | 2888 | |
b3f48fd4 AC |
2889 | -- If the subprogram is a renaming, or if it is inherited, replace it in |
2890 | -- the call with the name of the actual subprogram being called. If this | |
2891 | -- is a dispatching call, the run-time decides what to call. The Alias | |
2892 | -- attribute does not apply to entries. | |
70482933 | 2893 | |
6dfc5592 RD |
2894 | if Nkind (Call_Node) /= N_Entry_Call_Statement |
2895 | and then No (Controlling_Argument (Call_Node)) | |
70482933 | 2896 | and then Present (Parent_Subp) |
df3e68b1 | 2897 | and then not Is_Direct_Deep_Call (Subp) |
70482933 RK |
2898 | then |
2899 | if Present (Inherited_From_Formal (Subp)) then | |
2900 | Parent_Subp := Inherited_From_Formal (Subp); | |
2901 | else | |
b81a5940 | 2902 | Parent_Subp := Ultimate_Alias (Parent_Subp); |
70482933 RK |
2903 | end if; |
2904 | ||
c8ef728f ES |
2905 | -- The below setting of Entity is suspect, see F109-018 discussion??? |
2906 | ||
6dfc5592 | 2907 | Set_Entity (Name (Call_Node), Parent_Subp); |
70482933 | 2908 | |
f937473f | 2909 | if Is_Abstract_Subprogram (Parent_Subp) |
70482933 RK |
2910 | and then not In_Instance |
2911 | then | |
2912 | Error_Msg_NE | |
6dfc5592 RD |
2913 | ("cannot call abstract subprogram &!", |
2914 | Name (Call_Node), Parent_Subp); | |
70482933 RK |
2915 | end if; |
2916 | ||
d4817e3f HK |
2917 | -- Inspect all formals of derived subprogram Subp. Compare parameter |
2918 | -- types with the parent subprogram and check whether an actual may | |
2919 | -- need a type conversion to the corresponding formal of the parent | |
2920 | -- subprogram. | |
70482933 | 2921 | |
d4817e3f | 2922 | -- Not clear whether intrinsic subprograms need such conversions. ??? |
70482933 RK |
2923 | |
2924 | if not Is_Intrinsic_Subprogram (Parent_Subp) | |
2925 | or else Is_Generic_Instance (Parent_Subp) | |
2926 | then | |
d4817e3f HK |
2927 | declare |
2928 | procedure Convert (Act : Node_Id; Typ : Entity_Id); | |
2929 | -- Rewrite node Act as a type conversion of Act to Typ. Analyze | |
2930 | -- and resolve the newly generated construct. | |
70482933 | 2931 | |
d4817e3f HK |
2932 | ------------- |
2933 | -- Convert -- | |
2934 | ------------- | |
70482933 | 2935 | |
d4817e3f HK |
2936 | procedure Convert (Act : Node_Id; Typ : Entity_Id) is |
2937 | begin | |
2938 | Rewrite (Act, OK_Convert_To (Typ, Relocate_Node (Act))); | |
2939 | Analyze (Act); | |
2940 | Resolve (Act, Typ); | |
2941 | end Convert; | |
2942 | ||
2943 | -- Local variables | |
2944 | ||
2945 | Actual_Typ : Entity_Id; | |
2946 | Formal_Typ : Entity_Id; | |
2947 | Parent_Typ : Entity_Id; | |
2948 | ||
2949 | begin | |
6dfc5592 | 2950 | Actual := First_Actual (Call_Node); |
d4817e3f HK |
2951 | Formal := First_Formal (Subp); |
2952 | Parent_Formal := First_Formal (Parent_Subp); | |
2953 | while Present (Formal) loop | |
2954 | Actual_Typ := Etype (Actual); | |
2955 | Formal_Typ := Etype (Formal); | |
2956 | Parent_Typ := Etype (Parent_Formal); | |
2957 | ||
2958 | -- For an IN parameter of a scalar type, the parent formal | |
2959 | -- type and derived formal type differ or the parent formal | |
2960 | -- type and actual type do not match statically. | |
2961 | ||
2962 | if Is_Scalar_Type (Formal_Typ) | |
2963 | and then Ekind (Formal) = E_In_Parameter | |
2964 | and then Formal_Typ /= Parent_Typ | |
2965 | and then | |
2966 | not Subtypes_Statically_Match (Parent_Typ, Actual_Typ) | |
2967 | and then not Raises_Constraint_Error (Actual) | |
2968 | then | |
2969 | Convert (Actual, Parent_Typ); | |
2970 | Enable_Range_Check (Actual); | |
2971 | ||
d79e621a GD |
2972 | -- If the actual has been marked as requiring a range |
2973 | -- check, then generate it here. | |
2974 | ||
2975 | if Do_Range_Check (Actual) then | |
2976 | Set_Do_Range_Check (Actual, False); | |
2977 | Generate_Range_Check | |
2978 | (Actual, Etype (Formal), CE_Range_Check_Failed); | |
2979 | end if; | |
2980 | ||
d4817e3f HK |
2981 | -- For access types, the parent formal type and actual type |
2982 | -- differ. | |
2983 | ||
2984 | elsif Is_Access_Type (Formal_Typ) | |
2985 | and then Base_Type (Parent_Typ) /= Base_Type (Actual_Typ) | |
70482933 | 2986 | then |
d4817e3f HK |
2987 | if Ekind (Formal) /= E_In_Parameter then |
2988 | Convert (Actual, Parent_Typ); | |
2989 | ||
2990 | elsif Ekind (Parent_Typ) = E_Anonymous_Access_Type | |
2991 | and then Designated_Type (Parent_Typ) /= | |
2992 | Designated_Type (Actual_Typ) | |
2993 | and then not Is_Controlling_Formal (Formal) | |
2994 | then | |
2995 | -- This unchecked conversion is not necessary unless | |
2996 | -- inlining is enabled, because in that case the type | |
2997 | -- mismatch may become visible in the body about to be | |
2998 | -- inlined. | |
2999 | ||
3000 | Rewrite (Actual, | |
3001 | Unchecked_Convert_To (Parent_Typ, | |
3002 | Relocate_Node (Actual))); | |
d4817e3f HK |
3003 | Analyze (Actual); |
3004 | Resolve (Actual, Parent_Typ); | |
3005 | end if; | |
70482933 | 3006 | |
d4817e3f HK |
3007 | -- For array and record types, the parent formal type and |
3008 | -- derived formal type have different sizes or pragma Pack | |
3009 | -- status. | |
70482933 | 3010 | |
d4817e3f HK |
3011 | elsif ((Is_Array_Type (Formal_Typ) |
3012 | and then Is_Array_Type (Parent_Typ)) | |
3013 | or else | |
3014 | (Is_Record_Type (Formal_Typ) | |
3015 | and then Is_Record_Type (Parent_Typ))) | |
3016 | and then | |
3017 | (Esize (Formal_Typ) /= Esize (Parent_Typ) | |
3018 | or else Has_Pragma_Pack (Formal_Typ) /= | |
3019 | Has_Pragma_Pack (Parent_Typ)) | |
3020 | then | |
3021 | Convert (Actual, Parent_Typ); | |
70482933 | 3022 | end if; |
70482933 | 3023 | |
d4817e3f HK |
3024 | Next_Actual (Actual); |
3025 | Next_Formal (Formal); | |
3026 | Next_Formal (Parent_Formal); | |
3027 | end loop; | |
3028 | end; | |
70482933 RK |
3029 | end if; |
3030 | ||
3031 | Orig_Subp := Subp; | |
3032 | Subp := Parent_Subp; | |
3033 | end if; | |
3034 | ||
8a36a0cc AC |
3035 | -- Check for violation of No_Abort_Statements |
3036 | ||
273adcdf AC |
3037 | if Restriction_Check_Required (No_Abort_Statements) |
3038 | and then Is_RTE (Subp, RE_Abort_Task) | |
3039 | then | |
6dfc5592 | 3040 | Check_Restriction (No_Abort_Statements, Call_Node); |
8a36a0cc AC |
3041 | |
3042 | -- Check for violation of No_Dynamic_Attachment | |
3043 | ||
273adcdf AC |
3044 | elsif Restriction_Check_Required (No_Dynamic_Attachment) |
3045 | and then RTU_Loaded (Ada_Interrupts) | |
8a36a0cc AC |
3046 | and then (Is_RTE (Subp, RE_Is_Reserved) or else |
3047 | Is_RTE (Subp, RE_Is_Attached) or else | |
3048 | Is_RTE (Subp, RE_Current_Handler) or else | |
3049 | Is_RTE (Subp, RE_Attach_Handler) or else | |
3050 | Is_RTE (Subp, RE_Exchange_Handler) or else | |
3051 | Is_RTE (Subp, RE_Detach_Handler) or else | |
3052 | Is_RTE (Subp, RE_Reference)) | |
3053 | then | |
6dfc5592 | 3054 | Check_Restriction (No_Dynamic_Attachment, Call_Node); |
fbf5a39b AC |
3055 | end if; |
3056 | ||
8a36a0cc AC |
3057 | -- Deal with case where call is an explicit dereference |
3058 | ||
6dfc5592 | 3059 | if Nkind (Name (Call_Node)) = N_Explicit_Dereference then |
70482933 RK |
3060 | |
3061 | -- Handle case of access to protected subprogram type | |
3062 | ||
f937473f | 3063 | if Is_Access_Protected_Subprogram_Type |
6dfc5592 | 3064 | (Base_Type (Etype (Prefix (Name (Call_Node))))) |
70482933 | 3065 | then |
b3f48fd4 AC |
3066 | -- If this is a call through an access to protected operation, the |
3067 | -- prefix has the form (object'address, operation'access). Rewrite | |
3068 | -- as a for other protected calls: the object is the 1st parameter | |
3069 | -- of the list of actuals. | |
70482933 RK |
3070 | |
3071 | declare | |
3072 | Call : Node_Id; | |
3073 | Parm : List_Id; | |
3074 | Nam : Node_Id; | |
3075 | Obj : Node_Id; | |
6dfc5592 | 3076 | Ptr : constant Node_Id := Prefix (Name (Call_Node)); |
fbf5a39b AC |
3077 | |
3078 | T : constant Entity_Id := | |
3079 | Equivalent_Type (Base_Type (Etype (Ptr))); | |
3080 | ||
3081 | D_T : constant Entity_Id := | |
3082 | Designated_Type (Base_Type (Etype (Ptr))); | |
70482933 RK |
3083 | |
3084 | begin | |
f44fe430 RD |
3085 | Obj := |
3086 | Make_Selected_Component (Loc, | |
3087 | Prefix => Unchecked_Convert_To (T, Ptr), | |
3088 | Selector_Name => | |
3089 | New_Occurrence_Of (First_Entity (T), Loc)); | |
3090 | ||
3091 | Nam := | |
3092 | Make_Selected_Component (Loc, | |
3093 | Prefix => Unchecked_Convert_To (T, Ptr), | |
3094 | Selector_Name => | |
3095 | New_Occurrence_Of (Next_Entity (First_Entity (T)), Loc)); | |
70482933 | 3096 | |
02822a92 RD |
3097 | Nam := |
3098 | Make_Explicit_Dereference (Loc, | |
3099 | Prefix => Nam); | |
70482933 | 3100 | |
6dfc5592 RD |
3101 | if Present (Parameter_Associations (Call_Node)) then |
3102 | Parm := Parameter_Associations (Call_Node); | |
70482933 RK |
3103 | else |
3104 | Parm := New_List; | |
3105 | end if; | |
3106 | ||
3107 | Prepend (Obj, Parm); | |
3108 | ||
3109 | if Etype (D_T) = Standard_Void_Type then | |
02822a92 RD |
3110 | Call := |
3111 | Make_Procedure_Call_Statement (Loc, | |
3112 | Name => Nam, | |
3113 | Parameter_Associations => Parm); | |
70482933 | 3114 | else |
02822a92 RD |
3115 | Call := |
3116 | Make_Function_Call (Loc, | |
3117 | Name => Nam, | |
3118 | Parameter_Associations => Parm); | |
70482933 RK |
3119 | end if; |
3120 | ||
6dfc5592 | 3121 | Set_First_Named_Actual (Call, First_Named_Actual (Call_Node)); |
70482933 RK |
3122 | Set_Etype (Call, Etype (D_T)); |
3123 | ||
3124 | -- We do not re-analyze the call to avoid infinite recursion. | |
3125 | -- We analyze separately the prefix and the object, and set | |
3126 | -- the checks on the prefix that would otherwise be emitted | |
3127 | -- when resolving a call. | |
3128 | ||
6dfc5592 | 3129 | Rewrite (Call_Node, Call); |
70482933 RK |
3130 | Analyze (Nam); |
3131 | Apply_Access_Check (Nam); | |
3132 | Analyze (Obj); | |
3133 | return; | |
3134 | end; | |
3135 | end if; | |
3136 | end if; | |
3137 | ||
3138 | -- If this is a call to an intrinsic subprogram, then perform the | |
3139 | -- appropriate expansion to the corresponding tree node and we | |
3140 | -- are all done (since after that the call is gone!) | |
3141 | ||
98f01d53 AC |
3142 | -- In the case where the intrinsic is to be processed by the back end, |
3143 | -- the call to Expand_Intrinsic_Call will do nothing, which is fine, | |
b3f48fd4 AC |
3144 | -- since the idea in this case is to pass the call unchanged. If the |
3145 | -- intrinsic is an inherited unchecked conversion, and the derived type | |
3146 | -- is the target type of the conversion, we must retain it as the return | |
3147 | -- type of the expression. Otherwise the expansion below, which uses the | |
3148 | -- parent operation, will yield the wrong type. | |
98f01d53 | 3149 | |
70482933 | 3150 | if Is_Intrinsic_Subprogram (Subp) then |
6dfc5592 | 3151 | Expand_Intrinsic_Call (Call_Node, Subp); |
d766cee3 | 3152 | |
6dfc5592 | 3153 | if Nkind (Call_Node) = N_Unchecked_Type_Conversion |
d766cee3 RD |
3154 | and then Parent_Subp /= Orig_Subp |
3155 | and then Etype (Parent_Subp) /= Etype (Orig_Subp) | |
3156 | then | |
6dfc5592 | 3157 | Set_Etype (Call_Node, Etype (Orig_Subp)); |
d766cee3 RD |
3158 | end if; |
3159 | ||
70482933 RK |
3160 | return; |
3161 | end if; | |
3162 | ||
b29def53 AC |
3163 | if Ekind_In (Subp, E_Function, E_Procedure) then |
3164 | ||
26a43556 | 3165 | -- We perform two simple optimization on calls: |
8dbf3473 | 3166 | |
3563739b | 3167 | -- a) replace calls to null procedures unconditionally; |
26a43556 | 3168 | |
3563739b | 3169 | -- b) for To_Address, just do an unchecked conversion. Not only is |
26a43556 AC |
3170 | -- this efficient, but it also avoids order of elaboration problems |
3171 | -- when address clauses are inlined (address expression elaborated | |
3172 | -- at the wrong point). | |
3173 | ||
3174 | -- We perform these optimization regardless of whether we are in the | |
3175 | -- main unit or in a unit in the context of the main unit, to ensure | |
3176 | -- that tree generated is the same in both cases, for Inspector use. | |
3177 | ||
3178 | if Is_RTE (Subp, RE_To_Address) then | |
6dfc5592 | 3179 | Rewrite (Call_Node, |
26a43556 | 3180 | Unchecked_Convert_To |
6dfc5592 | 3181 | (RTE (RE_Address), Relocate_Node (First_Actual (Call_Node)))); |
26a43556 AC |
3182 | return; |
3183 | ||
3184 | elsif Is_Null_Procedure (Subp) then | |
6dfc5592 | 3185 | Rewrite (Call_Node, Make_Null_Statement (Loc)); |
8dbf3473 AC |
3186 | return; |
3187 | end if; | |
3188 | ||
70482933 RK |
3189 | if Is_Inlined (Subp) then |
3190 | ||
a41ea816 | 3191 | Inlined_Subprogram : declare |
fbf5a39b AC |
3192 | Bod : Node_Id; |
3193 | Must_Inline : Boolean := False; | |
3194 | Spec : constant Node_Id := Unit_Declaration_Node (Subp); | |
5b4994bc | 3195 | Scop : constant Entity_Id := Scope (Subp); |
70482933 | 3196 | |
a41ea816 | 3197 | function In_Unfrozen_Instance return Boolean; |
26a43556 AC |
3198 | -- If the subprogram comes from an instance in the same unit, |
3199 | -- and the instance is not yet frozen, inlining might trigger | |
3200 | -- order-of-elaboration problems in gigi. | |
a41ea816 AC |
3201 | |
3202 | -------------------------- | |
3203 | -- In_Unfrozen_Instance -- | |
3204 | -------------------------- | |
3205 | ||
3206 | function In_Unfrozen_Instance return Boolean is | |
2f1b20a9 | 3207 | S : Entity_Id; |
a41ea816 AC |
3208 | |
3209 | begin | |
2f1b20a9 | 3210 | S := Scop; |
a41ea816 AC |
3211 | while Present (S) |
3212 | and then S /= Standard_Standard | |
3213 | loop | |
3214 | if Is_Generic_Instance (S) | |
3215 | and then Present (Freeze_Node (S)) | |
3216 | and then not Analyzed (Freeze_Node (S)) | |
3217 | then | |
3218 | return True; | |
3219 | end if; | |
3220 | ||
3221 | S := Scope (S); | |
3222 | end loop; | |
3223 | ||
3224 | return False; | |
3225 | end In_Unfrozen_Instance; | |
3226 | ||
3227 | -- Start of processing for Inlined_Subprogram | |
3228 | ||
70482933 | 3229 | begin |
2f1b20a9 ES |
3230 | -- Verify that the body to inline has already been seen, and |
3231 | -- that if the body is in the current unit the inlining does | |
3232 | -- not occur earlier. This avoids order-of-elaboration problems | |
3233 | -- in the back end. | |
3234 | ||
3235 | -- This should be documented in sinfo/einfo ??? | |
70482933 | 3236 | |
fbf5a39b AC |
3237 | if No (Spec) |
3238 | or else Nkind (Spec) /= N_Subprogram_Declaration | |
3239 | or else No (Body_To_Inline (Spec)) | |
70482933 | 3240 | then |
fbf5a39b AC |
3241 | Must_Inline := False; |
3242 | ||
26a43556 AC |
3243 | -- If this an inherited function that returns a private type, |
3244 | -- do not inline if the full view is an unconstrained array, | |
3245 | -- because such calls cannot be inlined. | |
5b4994bc AC |
3246 | |
3247 | elsif Present (Orig_Subp) | |
3248 | and then Is_Array_Type (Etype (Orig_Subp)) | |
3249 | and then not Is_Constrained (Etype (Orig_Subp)) | |
3250 | then | |
3251 | Must_Inline := False; | |
3252 | ||
a41ea816 | 3253 | elsif In_Unfrozen_Instance then |
5b4994bc AC |
3254 | Must_Inline := False; |
3255 | ||
fbf5a39b AC |
3256 | else |
3257 | Bod := Body_To_Inline (Spec); | |
3258 | ||
6dfc5592 RD |
3259 | if (In_Extended_Main_Code_Unit (Call_Node) |
3260 | or else In_Extended_Main_Code_Unit (Parent (Call_Node)) | |
ac4d6407 | 3261 | or else Has_Pragma_Inline_Always (Subp)) |
fbf5a39b AC |
3262 | and then (not In_Same_Extended_Unit (Sloc (Bod), Loc) |
3263 | or else | |
3264 | Earlier_In_Extended_Unit (Sloc (Bod), Loc)) | |
3265 | then | |
3266 | Must_Inline := True; | |
3267 | ||
3268 | -- If we are compiling a package body that is not the main | |
3269 | -- unit, it must be for inlining/instantiation purposes, | |
3270 | -- in which case we inline the call to insure that the same | |
3271 | -- temporaries are generated when compiling the body by | |
3272 | -- itself. Otherwise link errors can occur. | |
3273 | ||
2820d220 AC |
3274 | -- If the function being called is itself in the main unit, |
3275 | -- we cannot inline, because there is a risk of double | |
3276 | -- elaboration and/or circularity: the inlining can make | |
3277 | -- visible a private entity in the body of the main unit, | |
3278 | -- that gigi will see before its sees its proper definition. | |
3279 | ||
6dfc5592 | 3280 | elsif not (In_Extended_Main_Code_Unit (Call_Node)) |
fbf5a39b AC |
3281 | and then In_Package_Body |
3282 | then | |
2820d220 | 3283 | Must_Inline := not In_Extended_Main_Source_Unit (Subp); |
fbf5a39b AC |
3284 | end if; |
3285 | end if; | |
3286 | ||
3287 | if Must_Inline then | |
6dfc5592 | 3288 | Expand_Inlined_Call (Call_Node, Subp, Orig_Subp); |
70482933 RK |
3289 | |
3290 | else | |
fbf5a39b | 3291 | -- Let the back end handle it |
70482933 RK |
3292 | |
3293 | Add_Inlined_Body (Subp); | |
3294 | ||
3295 | if Front_End_Inlining | |
3296 | and then Nkind (Spec) = N_Subprogram_Declaration | |
6dfc5592 | 3297 | and then (In_Extended_Main_Code_Unit (Call_Node)) |
70482933 RK |
3298 | and then No (Body_To_Inline (Spec)) |
3299 | and then not Has_Completion (Subp) | |
3300 | and then In_Same_Extended_Unit (Sloc (Spec), Loc) | |
70482933 | 3301 | then |
fbf5a39b | 3302 | Cannot_Inline |
6dfc5592 | 3303 | ("cannot inline& (body not seen yet)?", Call_Node, Subp); |
70482933 RK |
3304 | end if; |
3305 | end if; | |
a41ea816 | 3306 | end Inlined_Subprogram; |
70482933 RK |
3307 | end if; |
3308 | end if; | |
3309 | ||
26a43556 AC |
3310 | -- Check for protected subprogram. This is either an intra-object call, |
3311 | -- or a protected function call. Protected procedure calls are rewritten | |
3312 | -- as entry calls and handled accordingly. | |
70482933 | 3313 | |
26a43556 AC |
3314 | -- In Ada 2005, this may be an indirect call to an access parameter that |
3315 | -- is an access_to_subprogram. In that case the anonymous type has a | |
3316 | -- scope that is a protected operation, but the call is a regular one. | |
6f76a257 | 3317 | -- In either case do not expand call if subprogram is eliminated. |
c8ef728f | 3318 | |
70482933 RK |
3319 | Scop := Scope (Subp); |
3320 | ||
6dfc5592 | 3321 | if Nkind (Call_Node) /= N_Entry_Call_Statement |
70482933 | 3322 | and then Is_Protected_Type (Scop) |
c8ef728f | 3323 | and then Ekind (Subp) /= E_Subprogram_Type |
6f76a257 | 3324 | and then not Is_Eliminated (Subp) |
70482933 | 3325 | then |
26a43556 AC |
3326 | -- If the call is an internal one, it is rewritten as a call to the |
3327 | -- corresponding unprotected subprogram. | |
70482933 | 3328 | |
6dfc5592 | 3329 | Expand_Protected_Subprogram_Call (Call_Node, Subp, Scop); |
70482933 RK |
3330 | end if; |
3331 | ||
df3e68b1 HK |
3332 | -- Functions returning controlled objects need special attention. If |
3333 | -- the return type is limited, then the context is initialization and | |
3334 | -- different processing applies. If the call is to a protected function, | |
3335 | -- the expansion above will call Expand_Call recursively. Otherwise the | |
3336 | -- function call is transformed into a temporary which obtains the | |
3337 | -- result from the secondary stack. | |
70482933 | 3338 | |
c768e988 | 3339 | if Needs_Finalization (Etype (Subp)) then |
40f07b4b | 3340 | if not Is_Immutably_Limited_Type (Etype (Subp)) |
c768e988 AC |
3341 | and then |
3342 | (No (First_Formal (Subp)) | |
3343 | or else | |
3344 | not Is_Concurrent_Record_Type (Etype (First_Formal (Subp)))) | |
3345 | then | |
6dfc5592 | 3346 | Expand_Ctrl_Function_Call (Call_Node); |
c768e988 AC |
3347 | |
3348 | -- Build-in-place function calls which appear in anonymous contexts | |
3349 | -- need a transient scope to ensure the proper finalization of the | |
3350 | -- intermediate result after its use. | |
3351 | ||
6dfc5592 RD |
3352 | elsif Is_Build_In_Place_Function_Call (Call_Node) |
3353 | and then Nkind_In (Parent (Call_Node), N_Attribute_Reference, | |
c768e988 AC |
3354 | N_Function_Call, |
3355 | N_Indexed_Component, | |
3356 | N_Object_Renaming_Declaration, | |
3357 | N_Procedure_Call_Statement, | |
3358 | N_Selected_Component, | |
3359 | N_Slice) | |
3360 | then | |
6dfc5592 | 3361 | Establish_Transient_Scope (Call_Node, Sec_Stack => True); |
c768e988 | 3362 | end if; |
70482933 RK |
3363 | end if; |
3364 | ||
26a43556 AC |
3365 | -- Test for First_Optional_Parameter, and if so, truncate parameter list |
3366 | -- if there are optional parameters at the trailing end. | |
3367 | -- Note: we never delete procedures for call via a pointer. | |
70482933 RK |
3368 | |
3369 | if (Ekind (Subp) = E_Procedure or else Ekind (Subp) = E_Function) | |
3370 | and then Present (First_Optional_Parameter (Subp)) | |
3371 | then | |
3372 | declare | |
3373 | Last_Keep_Arg : Node_Id; | |
3374 | ||
3375 | begin | |
26a43556 AC |
3376 | -- Last_Keep_Arg will hold the last actual that should be kept. |
3377 | -- If it remains empty at the end, it means that all parameters | |
3378 | -- are optional. | |
70482933 RK |
3379 | |
3380 | Last_Keep_Arg := Empty; | |
3381 | ||
26a43556 AC |
3382 | -- Find first optional parameter, must be present since we checked |
3383 | -- the validity of the parameter before setting it. | |
70482933 RK |
3384 | |
3385 | Formal := First_Formal (Subp); | |
6dfc5592 | 3386 | Actual := First_Actual (Call_Node); |
70482933 RK |
3387 | while Formal /= First_Optional_Parameter (Subp) loop |
3388 | Last_Keep_Arg := Actual; | |
3389 | Next_Formal (Formal); | |
3390 | Next_Actual (Actual); | |
3391 | end loop; | |
3392 | ||
fbf5a39b AC |
3393 | -- We have Formal and Actual pointing to the first potentially |
3394 | -- droppable argument. We can drop all the trailing arguments | |
3395 | -- whose actual matches the default. Note that we know that all | |
3396 | -- remaining formals have defaults, because we checked that this | |
3397 | -- requirement was met before setting First_Optional_Parameter. | |
70482933 RK |
3398 | |
3399 | -- We use Fully_Conformant_Expressions to check for identity | |
3400 | -- between formals and actuals, which may miss some cases, but | |
3401 | -- on the other hand, this is only an optimization (if we fail | |
3402 | -- to truncate a parameter it does not affect functionality). | |
3403 | -- So if the default is 3 and the actual is 1+2, we consider | |
3404 | -- them unequal, which hardly seems worrisome. | |
3405 | ||
3406 | while Present (Formal) loop | |
3407 | if not Fully_Conformant_Expressions | |
3408 | (Actual, Default_Value (Formal)) | |
3409 | then | |
3410 | Last_Keep_Arg := Actual; | |
3411 | end if; | |
3412 | ||
3413 | Next_Formal (Formal); | |
3414 | Next_Actual (Actual); | |
3415 | end loop; | |
3416 | ||
3417 | -- If no arguments, delete entire list, this is the easy case | |
3418 | ||
3419 | if No (Last_Keep_Arg) then | |
6dfc5592 RD |
3420 | Set_Parameter_Associations (Call_Node, No_List); |
3421 | Set_First_Named_Actual (Call_Node, Empty); | |
70482933 RK |
3422 | |
3423 | -- Case where at the last retained argument is positional. This | |
3424 | -- is also an easy case, since the retained arguments are already | |
3425 | -- in the right form, and we don't need to worry about the order | |
3426 | -- of arguments that get eliminated. | |
3427 | ||
3428 | elsif Is_List_Member (Last_Keep_Arg) then | |
3429 | while Present (Next (Last_Keep_Arg)) loop | |
ac4d6407 | 3430 | Discard_Node (Remove_Next (Last_Keep_Arg)); |
70482933 RK |
3431 | end loop; |
3432 | ||
6dfc5592 | 3433 | Set_First_Named_Actual (Call_Node, Empty); |
70482933 RK |
3434 | |
3435 | -- This is the annoying case where the last retained argument | |
3436 | -- is a named parameter. Since the original arguments are not | |
3437 | -- in declaration order, we may have to delete some fairly | |
3438 | -- random collection of arguments. | |
3439 | ||
3440 | else | |
3441 | declare | |
3442 | Temp : Node_Id; | |
3443 | Passoc : Node_Id; | |
fbf5a39b | 3444 | |
70482933 RK |
3445 | begin |
3446 | -- First step, remove all the named parameters from the | |
3447 | -- list (they are still chained using First_Named_Actual | |
3448 | -- and Next_Named_Actual, so we have not lost them!) | |
3449 | ||
6dfc5592 | 3450 | Temp := First (Parameter_Associations (Call_Node)); |
70482933 RK |
3451 | |
3452 | -- Case of all parameters named, remove them all | |
3453 | ||
3454 | if Nkind (Temp) = N_Parameter_Association then | |
6dfc5592 RD |
3455 | -- Suppress warnings to avoid warning on possible |
3456 | -- infinite loop (because Call_Node is not modified). | |
3457 | ||
3458 | pragma Warnings (Off); | |
3459 | while Is_Non_Empty_List | |
3460 | (Parameter_Associations (Call_Node)) | |
3461 | loop | |
3462 | Temp := | |
3463 | Remove_Head (Parameter_Associations (Call_Node)); | |
70482933 | 3464 | end loop; |
6dfc5592 | 3465 | pragma Warnings (On); |
70482933 RK |
3466 | |
3467 | -- Case of mixed positional/named, remove named parameters | |
3468 | ||
3469 | else | |
3470 | while Nkind (Next (Temp)) /= N_Parameter_Association loop | |
3471 | Next (Temp); | |
3472 | end loop; | |
3473 | ||
3474 | while Present (Next (Temp)) loop | |
7888a6ae | 3475 | Remove (Next (Temp)); |
70482933 RK |
3476 | end loop; |
3477 | end if; | |
3478 | ||
3479 | -- Now we loop through the named parameters, till we get | |
3480 | -- to the last one to be retained, adding them to the list. | |
3481 | -- Note that the Next_Named_Actual list does not need to be | |
3482 | -- touched since we are only reordering them on the actual | |
3483 | -- parameter association list. | |
3484 | ||
6dfc5592 | 3485 | Passoc := Parent (First_Named_Actual (Call_Node)); |
70482933 RK |
3486 | loop |
3487 | Temp := Relocate_Node (Passoc); | |
3488 | Append_To | |
6dfc5592 | 3489 | (Parameter_Associations (Call_Node), Temp); |
70482933 RK |
3490 | exit when |
3491 | Last_Keep_Arg = Explicit_Actual_Parameter (Passoc); | |
3492 | Passoc := Parent (Next_Named_Actual (Passoc)); | |
3493 | end loop; | |
3494 | ||
3495 | Set_Next_Named_Actual (Temp, Empty); | |
3496 | ||
3497 | loop | |
3498 | Temp := Next_Named_Actual (Passoc); | |
3499 | exit when No (Temp); | |
3500 | Set_Next_Named_Actual | |
3501 | (Passoc, Next_Named_Actual (Parent (Temp))); | |
70482933 RK |
3502 | end loop; |
3503 | end; | |
811c6a85 | 3504 | |
70482933 RK |
3505 | end if; |
3506 | end; | |
3507 | end if; | |
70482933 RK |
3508 | end Expand_Call; |
3509 | ||
df3e68b1 HK |
3510 | ------------------------------- |
3511 | -- Expand_Ctrl_Function_Call -- | |
3512 | ------------------------------- | |
3513 | ||
3514 | procedure Expand_Ctrl_Function_Call (N : Node_Id) is | |
3515 | begin | |
3516 | -- Optimization, if the returned value (which is on the sec-stack) is | |
3517 | -- returned again, no need to copy/readjust/finalize, we can just pass | |
3518 | -- the value thru (see Expand_N_Simple_Return_Statement), and thus no | |
3519 | -- attachment is needed | |
3520 | ||
3521 | if Nkind (Parent (N)) = N_Simple_Return_Statement then | |
3522 | return; | |
3523 | end if; | |
3524 | ||
3525 | -- Resolution is now finished, make sure we don't start analysis again | |
3526 | -- because of the duplication. | |
3527 | ||
3528 | Set_Analyzed (N); | |
3529 | ||
3530 | -- A function which returns a controlled object uses the secondary | |
3531 | -- stack. Rewrite the call into a temporary which obtains the result of | |
3532 | -- the function using 'reference. | |
3533 | ||
3534 | Remove_Side_Effects (N); | |
3535 | end Expand_Ctrl_Function_Call; | |
3536 | ||
70482933 RK |
3537 | -------------------------- |
3538 | -- Expand_Inlined_Call -- | |
3539 | -------------------------- | |
3540 | ||
3541 | procedure Expand_Inlined_Call | |
3542 | (N : Node_Id; | |
3543 | Subp : Entity_Id; | |
3544 | Orig_Subp : Entity_Id) | |
3545 | is | |
fbf5a39b AC |
3546 | Loc : constant Source_Ptr := Sloc (N); |
3547 | Is_Predef : constant Boolean := | |
3548 | Is_Predefined_File_Name | |
3549 | (Unit_File_Name (Get_Source_Unit (Subp))); | |
3550 | Orig_Bod : constant Node_Id := | |
3551 | Body_To_Inline (Unit_Declaration_Node (Subp)); | |
3552 | ||
70482933 RK |
3553 | Blk : Node_Id; |
3554 | Bod : Node_Id; | |
3555 | Decl : Node_Id; | |
c8ef728f | 3556 | Decls : constant List_Id := New_List; |
70482933 RK |
3557 | Exit_Lab : Entity_Id := Empty; |
3558 | F : Entity_Id; | |
3559 | A : Node_Id; | |
3560 | Lab_Decl : Node_Id; | |
3561 | Lab_Id : Node_Id; | |
3562 | New_A : Node_Id; | |
3563 | Num_Ret : Int := 0; | |
70482933 RK |
3564 | Ret_Type : Entity_Id; |
3565 | Targ : Node_Id; | |
c8ef728f | 3566 | Targ1 : Node_Id; |
70482933 RK |
3567 | Temp : Entity_Id; |
3568 | Temp_Typ : Entity_Id; | |
3569 | ||
3e2399ba AC |
3570 | Return_Object : Entity_Id := Empty; |
3571 | -- Entity in declaration in an extended_return_statement | |
3572 | ||
c8ef728f ES |
3573 | Is_Unc : constant Boolean := |
3574 | Is_Array_Type (Etype (Subp)) | |
3575 | and then not Is_Constrained (Etype (Subp)); | |
26a43556 AC |
3576 | -- If the type returned by the function is unconstrained and the call |
3577 | -- can be inlined, special processing is required. | |
c8ef728f | 3578 | |
70482933 | 3579 | procedure Make_Exit_Label; |
26a43556 | 3580 | -- Build declaration for exit label to be used in Return statements, |
c12beea0 RD |
3581 | -- sets Exit_Lab (the label node) and Lab_Decl (corresponding implicit |
3582 | -- declaration). Does nothing if Exit_Lab already set. | |
70482933 RK |
3583 | |
3584 | function Process_Formals (N : Node_Id) return Traverse_Result; | |
26a43556 AC |
3585 | -- Replace occurrence of a formal with the corresponding actual, or the |
3586 | -- thunk generated for it. | |
70482933 | 3587 | |
fbf5a39b | 3588 | function Process_Sloc (Nod : Node_Id) return Traverse_Result; |
26a43556 AC |
3589 | -- If the call being expanded is that of an internal subprogram, set the |
3590 | -- sloc of the generated block to that of the call itself, so that the | |
3591 | -- expansion is skipped by the "next" command in gdb. | |
fbf5a39b | 3592 | -- Same processing for a subprogram in a predefined file, e.g. |
26a43556 AC |
3593 | -- Ada.Tags. If Debug_Generated_Code is true, suppress this change to |
3594 | -- simplify our own development. | |
fbf5a39b | 3595 | |
70482933 RK |
3596 | procedure Rewrite_Function_Call (N : Node_Id; Blk : Node_Id); |
3597 | -- If the function body is a single expression, replace call with | |
3598 | -- expression, else insert block appropriately. | |
3599 | ||
3600 | procedure Rewrite_Procedure_Call (N : Node_Id; Blk : Node_Id); | |
3601 | -- If procedure body has no local variables, inline body without | |
02822a92 | 3602 | -- creating block, otherwise rewrite call with block. |
70482933 | 3603 | |
5453d5bd AC |
3604 | function Formal_Is_Used_Once (Formal : Entity_Id) return Boolean; |
3605 | -- Determine whether a formal parameter is used only once in Orig_Bod | |
3606 | ||
70482933 RK |
3607 | --------------------- |
3608 | -- Make_Exit_Label -- | |
3609 | --------------------- | |
3610 | ||
3611 | procedure Make_Exit_Label is | |
c12beea0 | 3612 | Lab_Ent : Entity_Id; |
70482933 | 3613 | begin |
70482933 | 3614 | if No (Exit_Lab) then |
c12beea0 RD |
3615 | Lab_Ent := Make_Temporary (Loc, 'L'); |
3616 | Lab_Id := New_Reference_To (Lab_Ent, Loc); | |
70482933 | 3617 | Exit_Lab := Make_Label (Loc, Lab_Id); |
70482933 RK |
3618 | Lab_Decl := |
3619 | Make_Implicit_Label_Declaration (Loc, | |
c12beea0 | 3620 | Defining_Identifier => Lab_Ent, |
70482933 RK |
3621 | Label_Construct => Exit_Lab); |
3622 | end if; | |
3623 | end Make_Exit_Label; | |
3624 | ||
3625 | --------------------- | |
3626 | -- Process_Formals -- | |
3627 | --------------------- | |
3628 | ||
3629 | function Process_Formals (N : Node_Id) return Traverse_Result is | |
3630 | A : Entity_Id; | |
3631 | E : Entity_Id; | |
3632 | Ret : Node_Id; | |
3633 | ||
3634 | begin | |
3635 | if Is_Entity_Name (N) | |
3636 | and then Present (Entity (N)) | |
3637 | then | |
3638 | E := Entity (N); | |
3639 | ||
3640 | if Is_Formal (E) | |
3641 | and then Scope (E) = Subp | |
3642 | then | |
3643 | A := Renamed_Object (E); | |
3644 | ||
02822a92 RD |
3645 | -- Rewrite the occurrence of the formal into an occurrence of |
3646 | -- the actual. Also establish visibility on the proper view of | |
3647 | -- the actual's subtype for the body's context (if the actual's | |
3648 | -- subtype is private at the call point but its full view is | |
3649 | -- visible to the body, then the inlined tree here must be | |
3650 | -- analyzed with the full view). | |
3651 | ||
70482933 RK |
3652 | if Is_Entity_Name (A) then |
3653 | Rewrite (N, New_Occurrence_Of (Entity (A), Loc)); | |
02822a92 | 3654 | Check_Private_View (N); |
70482933 RK |
3655 | |
3656 | elsif Nkind (A) = N_Defining_Identifier then | |
3657 | Rewrite (N, New_Occurrence_Of (A, Loc)); | |
02822a92 | 3658 | Check_Private_View (N); |
70482933 | 3659 | |
d766cee3 RD |
3660 | -- Numeric literal |
3661 | ||
3662 | else | |
70482933 RK |
3663 | Rewrite (N, New_Copy (A)); |
3664 | end if; | |
3665 | end if; | |
3e2399ba AC |
3666 | return Skip; |
3667 | ||
3668 | elsif Is_Entity_Name (N) | |
9f5b6c7f | 3669 | and then Present (Return_Object) |
3e2399ba AC |
3670 | and then Chars (N) = Chars (Return_Object) |
3671 | then | |
3672 | -- Occurrence within an extended return statement. The return | |
3673 | -- object is local to the body been inlined, and thus the generic | |
3674 | -- copy is not analyzed yet, so we match by name, and replace it | |
3675 | -- with target of call. | |
3676 | ||
3677 | if Nkind (Targ) = N_Defining_Identifier then | |
3678 | Rewrite (N, New_Occurrence_Of (Targ, Loc)); | |
3679 | else | |
3680 | Rewrite (N, New_Copy_Tree (Targ)); | |
3681 | end if; | |
70482933 RK |
3682 | |
3683 | return Skip; | |
3684 | ||
d766cee3 | 3685 | elsif Nkind (N) = N_Simple_Return_Statement then |
70482933 RK |
3686 | if No (Expression (N)) then |
3687 | Make_Exit_Label; | |
d766cee3 | 3688 | Rewrite (N, |
3e2399ba | 3689 | Make_Goto_Statement (Loc, Name => New_Copy (Lab_Id))); |
70482933 RK |
3690 | |
3691 | else | |
3692 | if Nkind (Parent (N)) = N_Handled_Sequence_Of_Statements | |
3693 | and then Nkind (Parent (Parent (N))) = N_Subprogram_Body | |
3694 | then | |
fbf5a39b | 3695 | -- Function body is a single expression. No need for |
70482933 | 3696 | -- exit label. |
fbf5a39b | 3697 | |
70482933 RK |
3698 | null; |
3699 | ||
3700 | else | |
3701 | Num_Ret := Num_Ret + 1; | |
3702 | Make_Exit_Label; | |
3703 | end if; | |
3704 | ||
3705 | -- Because of the presence of private types, the views of the | |
3706 | -- expression and the context may be different, so place an | |
3707 | -- unchecked conversion to the context type to avoid spurious | |
8fc789c8 | 3708 | -- errors, e.g. when the expression is a numeric literal and |
70482933 RK |
3709 | -- the context is private. If the expression is an aggregate, |
3710 | -- use a qualified expression, because an aggregate is not a | |
3711 | -- legal argument of a conversion. | |
3712 | ||
ac4d6407 | 3713 | if Nkind_In (Expression (N), N_Aggregate, N_Null) then |
70482933 RK |
3714 | Ret := |
3715 | Make_Qualified_Expression (Sloc (N), | |
3716 | Subtype_Mark => New_Occurrence_Of (Ret_Type, Sloc (N)), | |
3717 | Expression => Relocate_Node (Expression (N))); | |
3718 | else | |
3719 | Ret := | |
3720 | Unchecked_Convert_To | |
3721 | (Ret_Type, Relocate_Node (Expression (N))); | |
3722 | end if; | |
3723 | ||
3724 | if Nkind (Targ) = N_Defining_Identifier then | |
3725 | Rewrite (N, | |
3726 | Make_Assignment_Statement (Loc, | |
3727 | Name => New_Occurrence_Of (Targ, Loc), | |
3728 | Expression => Ret)); | |
3729 | else | |
3730 | Rewrite (N, | |
3731 | Make_Assignment_Statement (Loc, | |
3732 | Name => New_Copy (Targ), | |
3733 | Expression => Ret)); | |
3734 | end if; | |
3735 | ||
3736 | Set_Assignment_OK (Name (N)); | |
3737 | ||
3738 | if Present (Exit_Lab) then | |
3739 | Insert_After (N, | |
3740 | Make_Goto_Statement (Loc, | |
3741 | Name => New_Copy (Lab_Id))); | |
3742 | end if; | |
3743 | end if; | |
3744 | ||
3745 | return OK; | |
3746 | ||
3e2399ba AC |
3747 | elsif Nkind (N) = N_Extended_Return_Statement then |
3748 | ||
3749 | -- An extended return becomes a block whose first statement is | |
3750 | -- the assignment of the initial expression of the return object | |
3751 | -- to the target of the call itself. | |
3752 | ||
3753 | declare | |
3754 | Return_Decl : constant Entity_Id := | |
3755 | First (Return_Object_Declarations (N)); | |
3756 | Assign : Node_Id; | |
3757 | ||
3758 | begin | |
3759 | Return_Object := Defining_Identifier (Return_Decl); | |
3760 | ||
3761 | if Present (Expression (Return_Decl)) then | |
3762 | if Nkind (Targ) = N_Defining_Identifier then | |
3763 | Assign := | |
3764 | Make_Assignment_Statement (Loc, | |
3765 | Name => New_Occurrence_Of (Targ, Loc), | |
3766 | Expression => Expression (Return_Decl)); | |
3767 | else | |
3768 | Assign := | |
3769 | Make_Assignment_Statement (Loc, | |
3770 | Name => New_Copy (Targ), | |
3771 | Expression => Expression (Return_Decl)); | |
3772 | end if; | |
3773 | ||
3774 | Set_Assignment_OK (Name (Assign)); | |
3775 | Prepend (Assign, | |
3776 | Statements (Handled_Statement_Sequence (N))); | |
3777 | end if; | |
3778 | ||
3779 | Rewrite (N, | |
3780 | Make_Block_Statement (Loc, | |
3781 | Handled_Statement_Sequence => | |
3782 | Handled_Statement_Sequence (N))); | |
3783 | ||
3784 | return OK; | |
3785 | end; | |
3786 | ||
fbf5a39b AC |
3787 | -- Remove pragma Unreferenced since it may refer to formals that |
3788 | -- are not visible in the inlined body, and in any case we will | |
3789 | -- not be posting warnings on the inlined body so it is unneeded. | |
3790 | ||
3791 | elsif Nkind (N) = N_Pragma | |
1923d2d6 | 3792 | and then Pragma_Name (N) = Name_Unreferenced |
fbf5a39b AC |
3793 | then |
3794 | Rewrite (N, Make_Null_Statement (Sloc (N))); | |
3795 | return OK; | |
3796 | ||
70482933 RK |
3797 | else |
3798 | return OK; | |
3799 | end if; | |
3800 | end Process_Formals; | |
3801 | ||
3802 | procedure Replace_Formals is new Traverse_Proc (Process_Formals); | |
3803 | ||
fbf5a39b AC |
3804 | ------------------ |
3805 | -- Process_Sloc -- | |
3806 | ------------------ | |
3807 | ||
3808 | function Process_Sloc (Nod : Node_Id) return Traverse_Result is | |
3809 | begin | |
3810 | if not Debug_Generated_Code then | |
3811 | Set_Sloc (Nod, Sloc (N)); | |
3812 | Set_Comes_From_Source (Nod, False); | |
3813 | end if; | |
3814 | ||
3815 | return OK; | |
3816 | end Process_Sloc; | |
3817 | ||
3818 | procedure Reset_Slocs is new Traverse_Proc (Process_Sloc); | |
3819 | ||
70482933 RK |
3820 | --------------------------- |
3821 | -- Rewrite_Function_Call -- | |
3822 | --------------------------- | |
3823 | ||
3824 | procedure Rewrite_Function_Call (N : Node_Id; Blk : Node_Id) is | |
fbf5a39b AC |
3825 | HSS : constant Node_Id := Handled_Statement_Sequence (Blk); |
3826 | Fst : constant Node_Id := First (Statements (HSS)); | |
70482933 RK |
3827 | |
3828 | begin | |
70482933 RK |
3829 | -- Optimize simple case: function body is a single return statement, |
3830 | -- which has been expanded into an assignment. | |
3831 | ||
3832 | if Is_Empty_List (Declarations (Blk)) | |
3833 | and then Nkind (Fst) = N_Assignment_Statement | |
3834 | and then No (Next (Fst)) | |
3835 | then | |
3836 | ||
3837 | -- The function call may have been rewritten as the temporary | |
3838 | -- that holds the result of the call, in which case remove the | |
3839 | -- now useless declaration. | |
3840 | ||
3841 | if Nkind (N) = N_Identifier | |
3842 | and then Nkind (Parent (Entity (N))) = N_Object_Declaration | |
3843 | then | |
3844 | Rewrite (Parent (Entity (N)), Make_Null_Statement (Loc)); | |
3845 | end if; | |
3846 | ||
3847 | Rewrite (N, Expression (Fst)); | |
3848 | ||
3849 | elsif Nkind (N) = N_Identifier | |
3850 | and then Nkind (Parent (Entity (N))) = N_Object_Declaration | |
3851 | then | |
98f01d53 | 3852 | -- The block assigns the result of the call to the temporary |
70482933 RK |
3853 | |
3854 | Insert_After (Parent (Entity (N)), Blk); | |
3855 | ||
3856 | elsif Nkind (Parent (N)) = N_Assignment_Statement | |
c8ef728f ES |
3857 | and then |
3858 | (Is_Entity_Name (Name (Parent (N))) | |
3859 | or else | |
3860 | (Nkind (Name (Parent (N))) = N_Explicit_Dereference | |
3861 | and then Is_Entity_Name (Prefix (Name (Parent (N)))))) | |
70482933 | 3862 | then |
fbf5a39b | 3863 | -- Replace assignment with the block |
70482933 | 3864 | |
30c20106 AC |
3865 | declare |
3866 | Original_Assignment : constant Node_Id := Parent (N); | |
7324bf49 AC |
3867 | |
3868 | begin | |
2f1b20a9 ES |
3869 | -- Preserve the original assignment node to keep the complete |
3870 | -- assignment subtree consistent enough for Analyze_Assignment | |
3871 | -- to proceed (specifically, the original Lhs node must still | |
3872 | -- have an assignment statement as its parent). | |
7324bf49 | 3873 | |
2f1b20a9 ES |
3874 | -- We cannot rely on Original_Node to go back from the block |
3875 | -- node to the assignment node, because the assignment might | |
3876 | -- already be a rewrite substitution. | |
30c20106 | 3877 | |
7324bf49 | 3878 | Discard_Node (Relocate_Node (Original_Assignment)); |
30c20106 AC |
3879 | Rewrite (Original_Assignment, Blk); |
3880 | end; | |
70482933 RK |
3881 | |
3882 | elsif Nkind (Parent (N)) = N_Object_Declaration then | |
3883 | Set_Expression (Parent (N), Empty); | |
3884 | Insert_After (Parent (N), Blk); | |
c8ef728f ES |
3885 | |
3886 | elsif Is_Unc then | |
3887 | Insert_Before (Parent (N), Blk); | |
70482933 RK |
3888 | end if; |
3889 | end Rewrite_Function_Call; | |
3890 | ||
3891 | ---------------------------- | |
3892 | -- Rewrite_Procedure_Call -- | |
3893 | ---------------------------- | |
3894 | ||
3895 | procedure Rewrite_Procedure_Call (N : Node_Id; Blk : Node_Id) is | |
fbf5a39b | 3896 | HSS : constant Node_Id := Handled_Statement_Sequence (Blk); |
70482933 | 3897 | begin |
02822a92 RD |
3898 | -- If there is a transient scope for N, this will be the scope of the |
3899 | -- actions for N, and the statements in Blk need to be within this | |
3900 | -- scope. For example, they need to have visibility on the constant | |
3901 | -- declarations created for the formals. | |
3902 | ||
3903 | -- If N needs no transient scope, and if there are no declarations in | |
3904 | -- the inlined body, we can do a little optimization and insert the | |
3905 | -- statements for the body directly after N, and rewrite N to a | |
3906 | -- null statement, instead of rewriting N into a full-blown block | |
3907 | -- statement. | |
3908 | ||
3909 | if not Scope_Is_Transient | |
3910 | and then Is_Empty_List (Declarations (Blk)) | |
3911 | then | |
70482933 RK |
3912 | Insert_List_After (N, Statements (HSS)); |
3913 | Rewrite (N, Make_Null_Statement (Loc)); | |
3914 | else | |
3915 | Rewrite (N, Blk); | |
3916 | end if; | |
3917 | end Rewrite_Procedure_Call; | |
3918 | ||
5453d5bd AC |
3919 | ------------------------- |
3920 | -- Formal_Is_Used_Once -- | |
02822a92 | 3921 | ------------------------- |
5453d5bd AC |
3922 | |
3923 | function Formal_Is_Used_Once (Formal : Entity_Id) return Boolean is | |
3924 | Use_Counter : Int := 0; | |
3925 | ||
3926 | function Count_Uses (N : Node_Id) return Traverse_Result; | |
3927 | -- Traverse the tree and count the uses of the formal parameter. | |
3928 | -- In this case, for optimization purposes, we do not need to | |
3929 | -- continue the traversal once more than one use is encountered. | |
3930 | ||
cc335f43 AC |
3931 | ---------------- |
3932 | -- Count_Uses -- | |
3933 | ---------------- | |
3934 | ||
5453d5bd AC |
3935 | function Count_Uses (N : Node_Id) return Traverse_Result is |
3936 | begin | |
5453d5bd AC |
3937 | -- The original node is an identifier |
3938 | ||
3939 | if Nkind (N) = N_Identifier | |
3940 | and then Present (Entity (N)) | |
3941 | ||
2f1b20a9 | 3942 | -- Original node's entity points to the one in the copied body |
5453d5bd AC |
3943 | |
3944 | and then Nkind (Entity (N)) = N_Identifier | |
3945 | and then Present (Entity (Entity (N))) | |
3946 | ||
3947 | -- The entity of the copied node is the formal parameter | |
3948 | ||
3949 | and then Entity (Entity (N)) = Formal | |
3950 | then | |
3951 | Use_Counter := Use_Counter + 1; | |
3952 | ||
3953 | if Use_Counter > 1 then | |
3954 | ||
3955 | -- Denote more than one use and abandon the traversal | |
3956 | ||
3957 | Use_Counter := 2; | |
3958 | return Abandon; | |
3959 | ||
3960 | end if; | |
3961 | end if; | |
3962 | ||
3963 | return OK; | |
3964 | end Count_Uses; | |
3965 | ||
3966 | procedure Count_Formal_Uses is new Traverse_Proc (Count_Uses); | |
3967 | ||
3968 | -- Start of processing for Formal_Is_Used_Once | |
3969 | ||
3970 | begin | |
5453d5bd AC |
3971 | Count_Formal_Uses (Orig_Bod); |
3972 | return Use_Counter = 1; | |
5453d5bd AC |
3973 | end Formal_Is_Used_Once; |
3974 | ||
70482933 RK |
3975 | -- Start of processing for Expand_Inlined_Call |
3976 | ||
3977 | begin | |
8dbf3473 | 3978 | |
f44fe430 RD |
3979 | -- Check for an illegal attempt to inline a recursive procedure. If the |
3980 | -- subprogram has parameters this is detected when trying to supply a | |
3981 | -- binding for parameters that already have one. For parameterless | |
3982 | -- subprograms this must be done explicitly. | |
3983 | ||
3984 | if In_Open_Scopes (Subp) then | |
3985 | Error_Msg_N ("call to recursive subprogram cannot be inlined?", N); | |
3986 | Set_Is_Inlined (Subp, False); | |
3987 | return; | |
3988 | end if; | |
3989 | ||
2ccf2fb3 ES |
3990 | if Nkind (Orig_Bod) = N_Defining_Identifier |
3991 | or else Nkind (Orig_Bod) = N_Defining_Operator_Symbol | |
3992 | then | |
8a45b58c RD |
3993 | -- Subprogram is renaming_as_body. Calls occurring after the renaming |
3994 | -- can be replaced with calls to the renamed entity directly, because | |
3995 | -- the subprograms are subtype conformant. If the renamed subprogram | |
3996 | -- is an inherited operation, we must redo the expansion because | |
3997 | -- implicit conversions may be needed. Similarly, if the renamed | |
3998 | -- entity is inlined, expand the call for further optimizations. | |
70482933 RK |
3999 | |
4000 | Set_Name (N, New_Occurrence_Of (Orig_Bod, Loc)); | |
f44fe430 | 4001 | |
676e8420 | 4002 | if Present (Alias (Orig_Bod)) or else Is_Inlined (Orig_Bod) then |
f44fe430 RD |
4003 | Expand_Call (N); |
4004 | end if; | |
4005 | ||
70482933 RK |
4006 | return; |
4007 | end if; | |
4008 | ||
4009 | -- Use generic machinery to copy body of inlined subprogram, as if it | |
4010 | -- were an instantiation, resetting source locations appropriately, so | |
4011 | -- that nested inlined calls appear in the main unit. | |
4012 | ||
4013 | Save_Env (Subp, Empty); | |
fbf5a39b | 4014 | Set_Copied_Sloc_For_Inlined_Body (N, Defining_Entity (Orig_Bod)); |
70482933 | 4015 | |
fbf5a39b | 4016 | Bod := Copy_Generic_Node (Orig_Bod, Empty, Instantiating => True); |
70482933 RK |
4017 | Blk := |
4018 | Make_Block_Statement (Loc, | |
4019 | Declarations => Declarations (Bod), | |
4020 | Handled_Statement_Sequence => Handled_Statement_Sequence (Bod)); | |
4021 | ||
4022 | if No (Declarations (Bod)) then | |
4023 | Set_Declarations (Blk, New_List); | |
4024 | end if; | |
4025 | ||
c8ef728f | 4026 | -- For the unconstrained case, capture the name of the local |
02822a92 RD |
4027 | -- variable that holds the result. This must be the first declaration |
4028 | -- in the block, because its bounds cannot depend on local variables. | |
4029 | -- Otherwise there is no way to declare the result outside of the | |
4030 | -- block. Needless to say, in general the bounds will depend on the | |
4031 | -- actuals in the call. | |
c8ef728f ES |
4032 | |
4033 | if Is_Unc then | |
02822a92 | 4034 | Targ1 := Defining_Identifier (First (Declarations (Blk))); |
c8ef728f ES |
4035 | end if; |
4036 | ||
98f01d53 | 4037 | -- If this is a derived function, establish the proper return type |
70482933 RK |
4038 | |
4039 | if Present (Orig_Subp) | |
4040 | and then Orig_Subp /= Subp | |
4041 | then | |
4042 | Ret_Type := Etype (Orig_Subp); | |
4043 | else | |
4044 | Ret_Type := Etype (Subp); | |
4045 | end if; | |
4046 | ||
70482933 RK |
4047 | -- Create temporaries for the actuals that are expressions, or that |
4048 | -- are scalars and require copying to preserve semantics. | |
4049 | ||
2f1b20a9 ES |
4050 | F := First_Formal (Subp); |
4051 | A := First_Actual (N); | |
70482933 | 4052 | while Present (F) loop |
70482933 | 4053 | if Present (Renamed_Object (F)) then |
2f1b20a9 | 4054 | Error_Msg_N ("cannot inline call to recursive subprogram", N); |
70482933 RK |
4055 | return; |
4056 | end if; | |
4057 | ||
4058 | -- If the argument may be a controlling argument in a call within | |
f44fe430 RD |
4059 | -- the inlined body, we must preserve its classwide nature to insure |
4060 | -- that dynamic dispatching take place subsequently. If the formal | |
4061 | -- has a constraint it must be preserved to retain the semantics of | |
4062 | -- the body. | |
70482933 RK |
4063 | |
4064 | if Is_Class_Wide_Type (Etype (F)) | |
4065 | or else (Is_Access_Type (Etype (F)) | |
4066 | and then | |
4067 | Is_Class_Wide_Type (Designated_Type (Etype (F)))) | |
4068 | then | |
4069 | Temp_Typ := Etype (F); | |
4070 | ||
4071 | elsif Base_Type (Etype (F)) = Base_Type (Etype (A)) | |
4072 | and then Etype (F) /= Base_Type (Etype (F)) | |
4073 | then | |
4074 | Temp_Typ := Etype (F); | |
4075 | ||
4076 | else | |
4077 | Temp_Typ := Etype (A); | |
4078 | end if; | |
4079 | ||
5b4994bc AC |
4080 | -- If the actual is a simple name or a literal, no need to |
4081 | -- create a temporary, object can be used directly. | |
70482933 | 4082 | |
7888a6ae GD |
4083 | -- If the actual is a literal and the formal has its address taken, |
4084 | -- we cannot pass the literal itself as an argument, so its value | |
4085 | -- must be captured in a temporary. | |
4086 | ||
fbf5a39b AC |
4087 | if (Is_Entity_Name (A) |
4088 | and then | |
4089 | (not Is_Scalar_Type (Etype (A)) | |
4090 | or else Ekind (Entity (A)) = E_Enumeration_Literal)) | |
4091 | ||
5453d5bd AC |
4092 | -- When the actual is an identifier and the corresponding formal |
4093 | -- is used only once in the original body, the formal can be | |
4094 | -- substituted directly with the actual parameter. | |
4095 | ||
4096 | or else (Nkind (A) = N_Identifier | |
4097 | and then Formal_Is_Used_Once (F)) | |
4098 | ||
7888a6ae | 4099 | or else |
ac4d6407 RD |
4100 | (Nkind_In (A, N_Real_Literal, |
4101 | N_Integer_Literal, | |
4102 | N_Character_Literal) | |
4103 | and then not Address_Taken (F)) | |
70482933 | 4104 | then |
fbf5a39b AC |
4105 | if Etype (F) /= Etype (A) then |
4106 | Set_Renamed_Object | |
4107 | (F, Unchecked_Convert_To (Etype (F), Relocate_Node (A))); | |
4108 | else | |
4109 | Set_Renamed_Object (F, A); | |
4110 | end if; | |
4111 | ||
4112 | else | |
c12beea0 | 4113 | Temp := Make_Temporary (Loc, 'C'); |
70482933 RK |
4114 | |
4115 | -- If the actual for an in/in-out parameter is a view conversion, | |
4116 | -- make it into an unchecked conversion, given that an untagged | |
4117 | -- type conversion is not a proper object for a renaming. | |
fbf5a39b | 4118 | |
70482933 RK |
4119 | -- In-out conversions that involve real conversions have already |
4120 | -- been transformed in Expand_Actuals. | |
4121 | ||
4122 | if Nkind (A) = N_Type_Conversion | |
fbf5a39b | 4123 | and then Ekind (F) /= E_In_Parameter |
70482933 | 4124 | then |
02822a92 RD |
4125 | New_A := |
4126 | Make_Unchecked_Type_Conversion (Loc, | |
4127 | Subtype_Mark => New_Occurrence_Of (Etype (F), Loc), | |
4128 | Expression => Relocate_Node (Expression (A))); | |
70482933 RK |
4129 | |
4130 | elsif Etype (F) /= Etype (A) then | |
4131 | New_A := Unchecked_Convert_To (Etype (F), Relocate_Node (A)); | |
4132 | Temp_Typ := Etype (F); | |
4133 | ||
4134 | else | |
4135 | New_A := Relocate_Node (A); | |
4136 | end if; | |
4137 | ||
4138 | Set_Sloc (New_A, Sloc (N)); | |
4139 | ||
02822a92 RD |
4140 | -- If the actual has a by-reference type, it cannot be copied, so |
4141 | -- its value is captured in a renaming declaration. Otherwise | |
7888a6ae | 4142 | -- declare a local constant initialized with the actual. |
02822a92 | 4143 | |
4a3b249c RD |
4144 | -- We also use a renaming declaration for expressions of an array |
4145 | -- type that is not bit-packed, both for efficiency reasons and to | |
4146 | -- respect the semantics of the call: in most cases the original | |
4147 | -- call will pass the parameter by reference, and thus the inlined | |
4148 | -- code will have the same semantics. | |
bafc9e1d | 4149 | |
70482933 RK |
4150 | if Ekind (F) = E_In_Parameter |
4151 | and then not Is_Limited_Type (Etype (A)) | |
02822a92 | 4152 | and then not Is_Tagged_Type (Etype (A)) |
bafc9e1d AC |
4153 | and then |
4154 | (not Is_Array_Type (Etype (A)) | |
f66d46ec | 4155 | or else not Is_Object_Reference (A) |
bafc9e1d | 4156 | or else Is_Bit_Packed_Array (Etype (A))) |
70482933 RK |
4157 | then |
4158 | Decl := | |
4159 | Make_Object_Declaration (Loc, | |
4160 | Defining_Identifier => Temp, | |
4161 | Constant_Present => True, | |
4162 | Object_Definition => New_Occurrence_Of (Temp_Typ, Loc), | |
4163 | Expression => New_A); | |
4164 | else | |
4165 | Decl := | |
4166 | Make_Object_Renaming_Declaration (Loc, | |
4167 | Defining_Identifier => Temp, | |
4168 | Subtype_Mark => New_Occurrence_Of (Temp_Typ, Loc), | |
4169 | Name => New_A); | |
4170 | end if; | |
4171 | ||
c8ef728f | 4172 | Append (Decl, Decls); |
70482933 | 4173 | Set_Renamed_Object (F, Temp); |
70482933 RK |
4174 | end if; |
4175 | ||
4176 | Next_Formal (F); | |
4177 | Next_Actual (A); | |
4178 | end loop; | |
4179 | ||
4180 | -- Establish target of function call. If context is not assignment or | |
4181 | -- declaration, create a temporary as a target. The declaration for | |
4182 | -- the temporary may be subsequently optimized away if the body is a | |
4183 | -- single expression, or if the left-hand side of the assignment is | |
c8ef728f | 4184 | -- simple enough, i.e. an entity or an explicit dereference of one. |
70482933 RK |
4185 | |
4186 | if Ekind (Subp) = E_Function then | |
4187 | if Nkind (Parent (N)) = N_Assignment_Statement | |
4188 | and then Is_Entity_Name (Name (Parent (N))) | |
4189 | then | |
4190 | Targ := Name (Parent (N)); | |
4191 | ||
c8ef728f ES |
4192 | elsif Nkind (Parent (N)) = N_Assignment_Statement |
4193 | and then Nkind (Name (Parent (N))) = N_Explicit_Dereference | |
4194 | and then Is_Entity_Name (Prefix (Name (Parent (N)))) | |
4195 | then | |
4196 | Targ := Name (Parent (N)); | |
4197 | ||
3e2399ba AC |
4198 | elsif Nkind (Parent (N)) = N_Object_Declaration |
4199 | and then Is_Limited_Type (Etype (Subp)) | |
4200 | then | |
4201 | Targ := Defining_Identifier (Parent (N)); | |
4202 | ||
70482933 | 4203 | else |
98f01d53 | 4204 | -- Replace call with temporary and create its declaration |
70482933 | 4205 | |
c12beea0 | 4206 | Temp := Make_Temporary (Loc, 'C'); |
758c442c | 4207 | Set_Is_Internal (Temp); |
70482933 | 4208 | |
30783513 | 4209 | -- For the unconstrained case, the generated temporary has the |
4a3b249c RD |
4210 | -- same constrained declaration as the result variable. It may |
4211 | -- eventually be possible to remove that temporary and use the | |
4212 | -- result variable directly. | |
c8ef728f ES |
4213 | |
4214 | if Is_Unc then | |
4215 | Decl := | |
4216 | Make_Object_Declaration (Loc, | |
4217 | Defining_Identifier => Temp, | |
4218 | Object_Definition => | |
4219 | New_Copy_Tree (Object_Definition (Parent (Targ1)))); | |
4220 | ||
4221 | Replace_Formals (Decl); | |
4222 | ||
4223 | else | |
4224 | Decl := | |
4225 | Make_Object_Declaration (Loc, | |
4226 | Defining_Identifier => Temp, | |
4227 | Object_Definition => | |
4228 | New_Occurrence_Of (Ret_Type, Loc)); | |
4229 | ||
4230 | Set_Etype (Temp, Ret_Type); | |
4231 | end if; | |
70482933 RK |
4232 | |
4233 | Set_No_Initialization (Decl); | |
c8ef728f | 4234 | Append (Decl, Decls); |
70482933 RK |
4235 | Rewrite (N, New_Occurrence_Of (Temp, Loc)); |
4236 | Targ := Temp; | |
4237 | end if; | |
4238 | end if; | |
4239 | ||
c8ef728f ES |
4240 | Insert_Actions (N, Decls); |
4241 | ||
98f01d53 | 4242 | -- Traverse the tree and replace formals with actuals or their thunks. |
70482933 RK |
4243 | -- Attach block to tree before analysis and rewriting. |
4244 | ||
4245 | Replace_Formals (Blk); | |
4246 | Set_Parent (Blk, N); | |
4247 | ||
fbf5a39b AC |
4248 | if not Comes_From_Source (Subp) |
4249 | or else Is_Predef | |
4250 | then | |
4251 | Reset_Slocs (Blk); | |
4252 | end if; | |
4253 | ||
70482933 RK |
4254 | if Present (Exit_Lab) then |
4255 | ||
4256 | -- If the body was a single expression, the single return statement | |
4257 | -- and the corresponding label are useless. | |
4258 | ||
4259 | if Num_Ret = 1 | |
4260 | and then | |
4261 | Nkind (Last (Statements (Handled_Statement_Sequence (Blk)))) = | |
4262 | N_Goto_Statement | |
4263 | then | |
4264 | Remove (Last (Statements (Handled_Statement_Sequence (Blk)))); | |
4265 | else | |
4266 | Append (Lab_Decl, (Declarations (Blk))); | |
4267 | Append (Exit_Lab, Statements (Handled_Statement_Sequence (Blk))); | |
4268 | end if; | |
4269 | end if; | |
4270 | ||
4271 | -- Analyze Blk with In_Inlined_Body set, to avoid spurious errors on | |
4a3b249c | 4272 | -- conflicting private views that Gigi would ignore. If this is a |
fbf5a39b AC |
4273 | -- predefined unit, analyze with checks off, as is done in the non- |
4274 | -- inlined run-time units. | |
70482933 RK |
4275 | |
4276 | declare | |
4277 | I_Flag : constant Boolean := In_Inlined_Body; | |
4278 | ||
4279 | begin | |
4280 | In_Inlined_Body := True; | |
fbf5a39b AC |
4281 | |
4282 | if Is_Predef then | |
4283 | declare | |
4284 | Style : constant Boolean := Style_Check; | |
4285 | begin | |
4286 | Style_Check := False; | |
4287 | Analyze (Blk, Suppress => All_Checks); | |
4288 | Style_Check := Style; | |
4289 | end; | |
4290 | ||
4291 | else | |
4292 | Analyze (Blk); | |
4293 | end if; | |
4294 | ||
70482933 RK |
4295 | In_Inlined_Body := I_Flag; |
4296 | end; | |
4297 | ||
4298 | if Ekind (Subp) = E_Procedure then | |
4299 | Rewrite_Procedure_Call (N, Blk); | |
4300 | else | |
4301 | Rewrite_Function_Call (N, Blk); | |
c8ef728f ES |
4302 | |
4303 | -- For the unconstrained case, the replacement of the call has been | |
4304 | -- made prior to the complete analysis of the generated declarations. | |
4305 | -- Propagate the proper type now. | |
4306 | ||
4307 | if Is_Unc then | |
4308 | if Nkind (N) = N_Identifier then | |
4309 | Set_Etype (N, Etype (Entity (N))); | |
4310 | else | |
4311 | Set_Etype (N, Etype (Targ1)); | |
4312 | end if; | |
4313 | end if; | |
70482933 RK |
4314 | end if; |
4315 | ||
4316 | Restore_Env; | |
4317 | ||
98f01d53 | 4318 | -- Cleanup mapping between formals and actuals for other expansions |
70482933 RK |
4319 | |
4320 | F := First_Formal (Subp); | |
70482933 RK |
4321 | while Present (F) loop |
4322 | Set_Renamed_Object (F, Empty); | |
4323 | Next_Formal (F); | |
4324 | end loop; | |
4325 | end Expand_Inlined_Call; | |
4326 | ||
2b3d67a5 AC |
4327 | ---------------------------------------- |
4328 | -- Expand_N_Extended_Return_Statement -- | |
4329 | ---------------------------------------- | |
4330 | ||
4331 | -- If there is a Handled_Statement_Sequence, we rewrite this: | |
4332 | ||
4333 | -- return Result : T := <expression> do | |
4334 | -- <handled_seq_of_stms> | |
4335 | -- end return; | |
4336 | ||
4337 | -- to be: | |
4338 | ||
4339 | -- declare | |
4340 | -- Result : T := <expression>; | |
4341 | -- begin | |
4342 | -- <handled_seq_of_stms> | |
4343 | -- return Result; | |
4344 | -- end; | |
4345 | ||
4346 | -- Otherwise (no Handled_Statement_Sequence), we rewrite this: | |
4347 | ||
4348 | -- return Result : T := <expression>; | |
4349 | ||
4350 | -- to be: | |
4351 | ||
4352 | -- return <expression>; | |
4353 | ||
4354 | -- unless it's build-in-place or there's no <expression>, in which case | |
4355 | -- we generate: | |
4356 | ||
4357 | -- declare | |
4358 | -- Result : T := <expression>; | |
4359 | -- begin | |
4360 | -- return Result; | |
4361 | -- end; | |
4362 | ||
4363 | -- Note that this case could have been written by the user as an extended | |
4364 | -- return statement, or could have been transformed to this from a simple | |
4365 | -- return statement. | |
4366 | ||
4367 | -- That is, we need to have a reified return object if there are statements | |
4368 | -- (which might refer to it) or if we're doing build-in-place (so we can | |
4369 | -- set its address to the final resting place or if there is no expression | |
4370 | -- (in which case default initial values might need to be set). | |
4371 | ||
4372 | procedure Expand_N_Extended_Return_Statement (N : Node_Id) is | |
4373 | Loc : constant Source_Ptr := Sloc (N); | |
4374 | ||
df3e68b1 HK |
4375 | Par_Func : constant Entity_Id := |
4376 | Return_Applies_To (Return_Statement_Entity (N)); | |
4377 | Ret_Obj_Id : constant Entity_Id := | |
4378 | First_Entity (Return_Statement_Entity (N)); | |
4379 | Ret_Obj_Decl : constant Node_Id := Parent (Ret_Obj_Id); | |
4380 | ||
4381 | Is_Build_In_Place : constant Boolean := | |
4382 | Is_Build_In_Place_Function (Par_Func); | |
4383 | ||
4384 | Exp : Node_Id; | |
4385 | HSS : Node_Id; | |
4386 | Result : Node_Id; | |
4387 | Return_Stmt : Node_Id; | |
4388 | Stmts : List_Id; | |
4389 | ||
4390 | function Build_Heap_Allocator | |
4391 | (Temp_Id : Entity_Id; | |
4392 | Temp_Typ : Entity_Id; | |
4393 | Func_Id : Entity_Id; | |
4394 | Ret_Typ : Entity_Id; | |
4395 | Alloc_Expr : Node_Id) return Node_Id; | |
4396 | -- Create the statements necessary to allocate a return object on the | |
4397 | -- caller's collection. The collection is available through implicit | |
4398 | -- parameter BIPcollection. | |
4399 | -- | |
4400 | -- if BIPcollection /= null then | |
4401 | -- declare | |
4402 | -- type Ptr_Typ is access Ret_Typ; | |
4403 | -- for Ptr_Typ'Storage_Pool use | |
4404 | -- Base_Pool (BIPcollection.all).all; | |
4405 | -- Local : Ptr_Typ; | |
4406 | -- | |
4407 | -- begin | |
4408 | -- procedure Allocate (...) is | |
4409 | -- begin | |
4410 | -- Ada.Finalization.Heap_Management.Allocate (...); | |
4411 | -- end Allocate; | |
4412 | -- | |
4413 | -- Local := <Alloc_Expr>; | |
4414 | -- Temp_Id := Temp_Typ (Local); | |
4415 | -- end; | |
4416 | -- end if; | |
4417 | -- | |
4418 | -- Temp_Id is the temporary which is used to reference the internally | |
4419 | -- created object in all allocation forms. Temp_Typ is the type of the | |
4420 | -- temporary. Func_Id is the enclosing function. Ret_Typ is the return | |
4421 | -- type of Func_Id. Alloc_Expr is the actual allocator. | |
2b3d67a5 | 4422 | |
2b3d67a5 AC |
4423 | function Move_Activation_Chain return Node_Id; |
4424 | -- Construct a call to System.Tasking.Stages.Move_Activation_Chain | |
4425 | -- with parameters: | |
4426 | -- From current activation chain | |
4427 | -- To activation chain passed in by the caller | |
4428 | -- New_Master master passed in by the caller | |
4429 | ||
df3e68b1 HK |
4430 | -------------------------- |
4431 | -- Build_Heap_Allocator -- | |
4432 | -------------------------- | |
4433 | ||
4434 | function Build_Heap_Allocator | |
4435 | (Temp_Id : Entity_Id; | |
4436 | Temp_Typ : Entity_Id; | |
4437 | Func_Id : Entity_Id; | |
4438 | Ret_Typ : Entity_Id; | |
4439 | Alloc_Expr : Node_Id) return Node_Id | |
4440 | is | |
4441 | begin | |
4442 | -- Processing for build-in-place object allocation. This is disabled | |
4443 | -- on .NET/JVM because pools are not supported. | |
4444 | ||
4445 | if VM_Target = No_VM | |
4446 | and then Is_Build_In_Place_Function (Func_Id) | |
4447 | and then Needs_Finalization (Ret_Typ) | |
4448 | then | |
4449 | declare | |
4450 | Collect : constant Entity_Id := | |
4451 | Build_In_Place_Formal (Func_Id, BIP_Collection); | |
4452 | Decls : constant List_Id := New_List; | |
4453 | Stmts : constant List_Id := New_List; | |
4454 | ||
4455 | Local_Id : Entity_Id; | |
4456 | Pool_Id : Entity_Id; | |
4457 | Ptr_Typ : Entity_Id; | |
4458 | ||
4459 | begin | |
4460 | -- Generate: | |
4461 | -- Pool_Id renames Base_Pool (BIPcollection.all).all; | |
4462 | ||
4463 | Pool_Id := Make_Temporary (Loc, 'P'); | |
4464 | ||
4465 | Append_To (Decls, | |
4466 | Make_Object_Renaming_Declaration (Loc, | |
4467 | Defining_Identifier => Pool_Id, | |
4468 | Subtype_Mark => | |
4469 | New_Reference_To (RTE (RE_Root_Storage_Pool), Loc), | |
4470 | Name => | |
4471 | Make_Explicit_Dereference (Loc, | |
4472 | Prefix => | |
4473 | Make_Function_Call (Loc, | |
4474 | Name => | |
4475 | New_Reference_To (RTE (RE_Base_Pool), Loc), | |
4476 | ||
4477 | Parameter_Associations => New_List ( | |
4478 | Make_Explicit_Dereference (Loc, | |
4479 | Prefix => | |
4480 | New_Reference_To (Collect, Loc))))))); | |
4481 | ||
4482 | -- Create an access type which uses the storage pool of the | |
4483 | -- caller's collection. This additional type is necessary | |
4484 | -- because the collection cannot be associated with the type | |
4485 | -- of the temporary. Otherwise the secondary stack allocation | |
4486 | -- will fail. | |
4487 | ||
4488 | -- Generate: | |
4489 | -- type Ptr_Typ is access Ret_Typ; | |
4490 | ||
4491 | Ptr_Typ := Make_Temporary (Loc, 'P'); | |
4492 | ||
4493 | Append_To (Decls, | |
4494 | Make_Full_Type_Declaration (Loc, | |
4495 | Defining_Identifier => Ptr_Typ, | |
4496 | Type_Definition => | |
4497 | Make_Access_To_Object_Definition (Loc, | |
4498 | Subtype_Indication => | |
4499 | New_Reference_To (Ret_Typ, Loc)))); | |
4500 | ||
4501 | -- Perform minor decoration in order to set the collection and | |
4502 | -- the storage pool attributes. | |
4503 | ||
4504 | Set_Ekind (Ptr_Typ, E_Access_Type); | |
4505 | Set_Associated_Collection (Ptr_Typ, Collect); | |
4506 | Set_Associated_Storage_Pool (Ptr_Typ, Pool_Id); | |
4507 | ||
4508 | -- Create the temporary, generate: | |
4509 | -- | |
4510 | -- Local_Id : Ptr_Typ; | |
4511 | ||
4512 | Local_Id := Make_Temporary (Loc, 'T'); | |
4513 | ||
4514 | Append_To (Decls, | |
4515 | Make_Object_Declaration (Loc, | |
4516 | Defining_Identifier => Local_Id, | |
4517 | Object_Definition => | |
4518 | New_Reference_To (Ptr_Typ, Loc))); | |
4519 | ||
4520 | -- Allocate the object, generate: | |
4521 | -- | |
4522 | -- Local_Id := <Alloc_Expr>; | |
4523 | ||
4524 | Append_To (Stmts, | |
4525 | Make_Assignment_Statement (Loc, | |
4526 | Name => | |
4527 | New_Reference_To (Local_Id, Loc), | |
4528 | Expression => Alloc_Expr)); | |
4529 | ||
4530 | -- Generate: | |
4531 | -- Temp_Id := Temp_Typ (Local_Id); | |
4532 | ||
4533 | Append_To (Stmts, | |
4534 | Make_Assignment_Statement (Loc, | |
4535 | Name => | |
4536 | New_Reference_To (Temp_Id, Loc), | |
4537 | Expression => | |
4538 | Unchecked_Convert_To (Temp_Typ, | |
4539 | New_Reference_To (Local_Id, Loc)))); | |
4540 | ||
4541 | -- Wrap the allocation in a block. This is further conditioned | |
4542 | -- by checking the caller collection at runtime. A null value | |
4543 | -- indicates a non-existent collection, most likely due to a | |
4544 | -- Finalize_Storage_Only allocation. | |
4545 | ||
4546 | -- Generate: | |
4547 | -- if BIPcollection /= null then | |
4548 | -- declare | |
4549 | -- <Decls> | |
4550 | -- begin | |
4551 | -- <Stmts> | |
4552 | -- end; | |
4553 | -- end if; | |
4554 | ||
4555 | return | |
4556 | Make_If_Statement (Loc, | |
4557 | Condition => | |
4558 | Make_Op_Ne (Loc, | |
4559 | Left_Opnd => | |
4560 | New_Reference_To (Collect, Loc), | |
4561 | Right_Opnd => | |
4562 | Make_Null (Loc)), | |
4563 | ||
4564 | Then_Statements => New_List ( | |
4565 | Make_Block_Statement (Loc, | |
4566 | Declarations => Decls, | |
4567 | Handled_Statement_Sequence => | |
4568 | Make_Handled_Sequence_Of_Statements (Loc, | |
4569 | Statements => Stmts)))); | |
4570 | end; | |
4571 | ||
4572 | -- For all other cases, generate: | |
4573 | -- | |
4574 | -- Temp_Id := <Alloc_Expr>; | |
4575 | ||
4576 | else | |
4577 | return | |
4578 | Make_Assignment_Statement (Loc, | |
4579 | Name => | |
4580 | New_Reference_To (Temp_Id, Loc), | |
4581 | Expression => Alloc_Expr); | |
4582 | end if; | |
4583 | end Build_Heap_Allocator; | |
2b3d67a5 | 4584 | |
2b3d67a5 AC |
4585 | --------------------------- |
4586 | -- Move_Activation_Chain -- | |
4587 | --------------------------- | |
4588 | ||
4589 | function Move_Activation_Chain return Node_Id is | |
df3e68b1 HK |
4590 | Chain_Formal : constant Entity_Id := |
4591 | Build_In_Place_Formal | |
4592 | (Par_Func, BIP_Activation_Chain); | |
4593 | To : constant Node_Id := | |
4594 | New_Reference_To (Chain_Formal, Loc); | |
4595 | Master_Formal : constant Entity_Id := | |
4596 | Build_In_Place_Formal (Par_Func, BIP_Master); | |
4597 | New_Master : constant Node_Id := | |
4598 | New_Reference_To (Master_Formal, Loc); | |
4599 | ||
4600 | Chain_Id : Entity_Id; | |
4601 | From : Node_Id; | |
2b3d67a5 AC |
4602 | |
4603 | begin | |
df3e68b1 HK |
4604 | Chain_Id := First_Entity (Return_Statement_Entity (N)); |
4605 | while Chars (Chain_Id) /= Name_uChain loop | |
4606 | Chain_Id := Next_Entity (Chain_Id); | |
2b3d67a5 AC |
4607 | end loop; |
4608 | ||
4609 | From := | |
4610 | Make_Attribute_Reference (Loc, | |
df3e68b1 HK |
4611 | Prefix => |
4612 | New_Reference_To (Chain_Id, Loc), | |
2b3d67a5 AC |
4613 | Attribute_Name => Name_Unrestricted_Access); |
4614 | -- ??? Not clear why "Make_Identifier (Loc, Name_uChain)" doesn't | |
df3e68b1 | 4615 | -- work, instead of "New_Reference_To (Chain_Id, Loc)" above. |
2b3d67a5 AC |
4616 | |
4617 | return | |
4618 | Make_Procedure_Call_Statement (Loc, | |
df3e68b1 HK |
4619 | Name => |
4620 | New_Reference_To (RTE (RE_Move_Activation_Chain), Loc), | |
2b3d67a5 AC |
4621 | Parameter_Associations => New_List (From, To, New_Master)); |
4622 | end Move_Activation_Chain; | |
4623 | ||
df3e68b1 | 4624 | -- Start of processing for Expand_N_Extended_Return_Statement |
2b3d67a5 | 4625 | |
df3e68b1 HK |
4626 | begin |
4627 | if Nkind (Ret_Obj_Decl) = N_Object_Declaration then | |
4628 | Exp := Expression (Ret_Obj_Decl); | |
4629 | else | |
4630 | Exp := Empty; | |
4631 | end if; | |
2b3d67a5 | 4632 | |
df3e68b1 | 4633 | HSS := Handled_Statement_Sequence (N); |
2b3d67a5 | 4634 | |
df3e68b1 HK |
4635 | -- If the returned object needs finalization actions, the function must |
4636 | -- perform the appropriate cleanup should it fail to return. The state | |
4637 | -- of the function itself is tracked through a flag which is coupled | |
4638 | -- with the scope finalizer. There is one flag per each return object | |
4639 | -- in case of multiple returns. | |
2b3d67a5 | 4640 | |
df3e68b1 HK |
4641 | if Is_Build_In_Place |
4642 | and then Needs_Finalization (Etype (Ret_Obj_Id)) | |
4643 | then | |
4644 | declare | |
4645 | Flag_Decl : Node_Id; | |
4646 | Flag_Id : Entity_Id; | |
4647 | Func_Bod : Node_Id; | |
2b3d67a5 | 4648 | |
df3e68b1 HK |
4649 | begin |
4650 | -- Recover the function body | |
2b3d67a5 | 4651 | |
df3e68b1 HK |
4652 | Func_Bod := Unit_Declaration_Node (Par_Func); |
4653 | if Nkind (Func_Bod) = N_Subprogram_Declaration then | |
4654 | Func_Bod := Parent (Parent (Corresponding_Body (Func_Bod))); | |
4655 | end if; | |
2b3d67a5 | 4656 | |
df3e68b1 | 4657 | -- Create a flag to track the function state |
2b3d67a5 | 4658 | |
df3e68b1 HK |
4659 | Flag_Id := Make_Temporary (Loc, 'F'); |
4660 | Set_Return_Flag (Ret_Obj_Id, Flag_Id); | |
2b3d67a5 | 4661 | |
df3e68b1 HK |
4662 | -- Insert the flag at the beginning of the function declarations, |
4663 | -- generate: | |
4664 | -- Fnn : Boolean := False; | |
2b3d67a5 | 4665 | |
df3e68b1 HK |
4666 | Flag_Decl := |
4667 | Make_Object_Declaration (Loc, | |
4668 | Defining_Identifier => Flag_Id, | |
4669 | Object_Definition => | |
4670 | New_Reference_To (Standard_Boolean, Loc), | |
4671 | Expression => | |
4672 | New_Reference_To (Standard_False, Loc)); | |
2b3d67a5 | 4673 | |
df3e68b1 HK |
4674 | Prepend_To (Declarations (Func_Bod), Flag_Decl); |
4675 | Analyze (Flag_Decl); | |
4676 | end; | |
4677 | end if; | |
2b3d67a5 AC |
4678 | |
4679 | -- Build a simple_return_statement that returns the return object when | |
4680 | -- there is a statement sequence, or no expression, or the result will | |
4681 | -- be built in place. Note however that we currently do this for all | |
4682 | -- composite cases, even though nonlimited composite results are not yet | |
4683 | -- built in place (though we plan to do so eventually). | |
4684 | ||
df3e68b1 HK |
4685 | if Present (HSS) |
4686 | or else Is_Composite_Type (Etype (Par_Func)) | |
2b3d67a5 AC |
4687 | or else No (Exp) |
4688 | then | |
df3e68b1 HK |
4689 | if No (HSS) then |
4690 | Stmts := New_List; | |
2b3d67a5 AC |
4691 | |
4692 | -- If the extended return has a handled statement sequence, then wrap | |
4693 | -- it in a block and use the block as the first statement. | |
4694 | ||
4695 | else | |
df3e68b1 HK |
4696 | Stmts := New_List ( |
4697 | Make_Block_Statement (Loc, | |
4698 | Declarations => New_List, | |
4699 | Handled_Statement_Sequence => HSS)); | |
2b3d67a5 AC |
4700 | end if; |
4701 | ||
df3e68b1 HK |
4702 | -- If the result type contains tasks, we call Move_Activation_Chain. |
4703 | -- Later, the cleanup code will call Complete_Master, which will | |
4704 | -- terminate any unactivated tasks belonging to the return statement | |
4705 | -- master. But Move_Activation_Chain updates their master to be that | |
4706 | -- of the caller, so they will not be terminated unless the return | |
4707 | -- statement completes unsuccessfully due to exception, abort, goto, | |
4708 | -- or exit. As a formality, we test whether the function requires the | |
4709 | -- result to be built in place, though that's necessarily true for | |
4710 | -- the case of result types with task parts. | |
2b3d67a5 AC |
4711 | |
4712 | if Is_Build_In_Place | |
df3e68b1 | 4713 | and Has_Task (Etype (Par_Func)) |
2b3d67a5 | 4714 | then |
df3e68b1 | 4715 | Append_To (Stmts, Move_Activation_Chain); |
2b3d67a5 AC |
4716 | end if; |
4717 | ||
df3e68b1 HK |
4718 | -- Update the state of the function right before the object is |
4719 | -- returned. | |
4720 | ||
4721 | if Is_Build_In_Place | |
4722 | and then Needs_Finalization (Etype (Ret_Obj_Id)) | |
4723 | then | |
4724 | declare | |
4725 | Flag_Id : constant Entity_Id := Return_Flag (Ret_Obj_Id); | |
4726 | ||
4727 | begin | |
4728 | -- Generate: | |
4729 | -- Fnn := True; | |
4730 | ||
4731 | Append_To (Stmts, | |
4732 | Make_Assignment_Statement (Loc, | |
4733 | Name => | |
4734 | New_Reference_To (Flag_Id, Loc), | |
4735 | Expression => | |
4736 | New_Reference_To (Standard_True, Loc))); | |
4737 | end; | |
2b3d67a5 AC |
4738 | end if; |
4739 | ||
4740 | -- Build a simple_return_statement that returns the return object | |
4741 | ||
df3e68b1 | 4742 | Return_Stmt := |
2b3d67a5 | 4743 | Make_Simple_Return_Statement (Loc, |
df3e68b1 HK |
4744 | Expression => |
4745 | New_Occurrence_Of (Ret_Obj_Id, Loc)); | |
4746 | Append_To (Stmts, Return_Stmt); | |
2b3d67a5 | 4747 | |
df3e68b1 | 4748 | HSS := Make_Handled_Sequence_Of_Statements (Loc, Stmts); |
2b3d67a5 AC |
4749 | end if; |
4750 | ||
df3e68b1 | 4751 | -- Case where we build a return statement block |
2b3d67a5 | 4752 | |
df3e68b1 | 4753 | if Present (HSS) then |
2b3d67a5 AC |
4754 | Result := |
4755 | Make_Block_Statement (Loc, | |
4756 | Declarations => Return_Object_Declarations (N), | |
df3e68b1 | 4757 | Handled_Statement_Sequence => HSS); |
2b3d67a5 AC |
4758 | |
4759 | -- We set the entity of the new block statement to be that of the | |
4760 | -- return statement. This is necessary so that various fields, such | |
4761 | -- as Finalization_Chain_Entity carry over from the return statement | |
4762 | -- to the block. Note that this block is unusual, in that its entity | |
4763 | -- is an E_Return_Statement rather than an E_Block. | |
4764 | ||
4765 | Set_Identifier | |
4766 | (Result, New_Occurrence_Of (Return_Statement_Entity (N), Loc)); | |
4767 | ||
4768 | -- If the object decl was already rewritten as a renaming, then | |
4769 | -- we don't want to do the object allocation and transformation of | |
4770 | -- of the return object declaration to a renaming. This case occurs | |
4771 | -- when the return object is initialized by a call to another | |
4772 | -- build-in-place function, and that function is responsible for the | |
4773 | -- allocation of the return object. | |
4774 | ||
4775 | if Is_Build_In_Place | |
df3e68b1 | 4776 | and then Nkind (Ret_Obj_Decl) = N_Object_Renaming_Declaration |
2b3d67a5 | 4777 | then |
df3e68b1 HK |
4778 | pragma Assert |
4779 | (Nkind (Original_Node (Ret_Obj_Decl)) = N_Object_Declaration | |
4780 | and then Is_Build_In_Place_Function_Call | |
4781 | (Expression (Original_Node (Ret_Obj_Decl)))); | |
4782 | ||
4783 | -- Return the build-in-place result by reference | |
2b3d67a5 | 4784 | |
df3e68b1 | 4785 | Set_By_Ref (Return_Stmt); |
2b3d67a5 AC |
4786 | |
4787 | elsif Is_Build_In_Place then | |
4788 | ||
4789 | -- Locate the implicit access parameter associated with the | |
4790 | -- caller-supplied return object and convert the return | |
4791 | -- statement's return object declaration to a renaming of a | |
4792 | -- dereference of the access parameter. If the return object's | |
4793 | -- declaration includes an expression that has not already been | |
4794 | -- expanded as separate assignments, then add an assignment | |
4795 | -- statement to ensure the return object gets initialized. | |
4796 | ||
df3e68b1 HK |
4797 | -- declare |
4798 | -- Result : T [:= <expression>]; | |
4799 | -- begin | |
4800 | -- ... | |
2b3d67a5 AC |
4801 | |
4802 | -- is converted to | |
4803 | ||
df3e68b1 HK |
4804 | -- declare |
4805 | -- Result : T renames FuncRA.all; | |
4806 | -- [Result := <expression;] | |
4807 | -- begin | |
4808 | -- ... | |
2b3d67a5 AC |
4809 | |
4810 | declare | |
4811 | Return_Obj_Id : constant Entity_Id := | |
df3e68b1 | 4812 | Defining_Identifier (Ret_Obj_Decl); |
2b3d67a5 AC |
4813 | Return_Obj_Typ : constant Entity_Id := Etype (Return_Obj_Id); |
4814 | Return_Obj_Expr : constant Node_Id := | |
df3e68b1 HK |
4815 | Expression (Ret_Obj_Decl); |
4816 | Result_Subt : constant Entity_Id := Etype (Par_Func); | |
2b3d67a5 AC |
4817 | Constr_Result : constant Boolean := |
4818 | Is_Constrained (Result_Subt); | |
4819 | Obj_Alloc_Formal : Entity_Id; | |
4820 | Object_Access : Entity_Id; | |
4821 | Obj_Acc_Deref : Node_Id; | |
4822 | Init_Assignment : Node_Id := Empty; | |
4823 | ||
4824 | begin | |
4825 | -- Build-in-place results must be returned by reference | |
4826 | ||
df3e68b1 | 4827 | Set_By_Ref (Return_Stmt); |
2b3d67a5 AC |
4828 | |
4829 | -- Retrieve the implicit access parameter passed by the caller | |
4830 | ||
4831 | Object_Access := | |
df3e68b1 | 4832 | Build_In_Place_Formal (Par_Func, BIP_Object_Access); |
2b3d67a5 AC |
4833 | |
4834 | -- If the return object's declaration includes an expression | |
4835 | -- and the declaration isn't marked as No_Initialization, then | |
4836 | -- we need to generate an assignment to the object and insert | |
4837 | -- it after the declaration before rewriting it as a renaming | |
4838 | -- (otherwise we'll lose the initialization). The case where | |
4839 | -- the result type is an interface (or class-wide interface) | |
4840 | -- is also excluded because the context of the function call | |
4841 | -- must be unconstrained, so the initialization will always | |
4842 | -- be done as part of an allocator evaluation (storage pool | |
4843 | -- or secondary stack), never to a constrained target object | |
4844 | -- passed in by the caller. Besides the assignment being | |
4845 | -- unneeded in this case, it avoids problems with trying to | |
4846 | -- generate a dispatching assignment when the return expression | |
4847 | -- is a nonlimited descendant of a limited interface (the | |
4848 | -- interface has no assignment operation). | |
4849 | ||
4850 | if Present (Return_Obj_Expr) | |
df3e68b1 | 4851 | and then not No_Initialization (Ret_Obj_Decl) |
2b3d67a5 AC |
4852 | and then not Is_Interface (Return_Obj_Typ) |
4853 | then | |
4854 | Init_Assignment := | |
4855 | Make_Assignment_Statement (Loc, | |
df3e68b1 HK |
4856 | Name => |
4857 | New_Reference_To (Return_Obj_Id, Loc), | |
4858 | Expression => | |
4859 | Relocate_Node (Return_Obj_Expr)); | |
4860 | ||
2b3d67a5 AC |
4861 | Set_Etype (Name (Init_Assignment), Etype (Return_Obj_Id)); |
4862 | Set_Assignment_OK (Name (Init_Assignment)); | |
4863 | Set_No_Ctrl_Actions (Init_Assignment); | |
4864 | ||
4865 | Set_Parent (Name (Init_Assignment), Init_Assignment); | |
4866 | Set_Parent (Expression (Init_Assignment), Init_Assignment); | |
4867 | ||
df3e68b1 | 4868 | Set_Expression (Ret_Obj_Decl, Empty); |
2b3d67a5 AC |
4869 | |
4870 | if Is_Class_Wide_Type (Etype (Return_Obj_Id)) | |
4871 | and then not Is_Class_Wide_Type | |
4872 | (Etype (Expression (Init_Assignment))) | |
4873 | then | |
4874 | Rewrite (Expression (Init_Assignment), | |
4875 | Make_Type_Conversion (Loc, | |
4876 | Subtype_Mark => | |
df3e68b1 | 4877 | New_Occurrence_Of (Etype (Return_Obj_Id), Loc), |
2b3d67a5 AC |
4878 | Expression => |
4879 | Relocate_Node (Expression (Init_Assignment)))); | |
4880 | end if; | |
4881 | ||
4882 | -- In the case of functions where the calling context can | |
4883 | -- determine the form of allocation needed, initialization | |
4884 | -- is done with each part of the if statement that handles | |
4885 | -- the different forms of allocation (this is true for | |
4886 | -- unconstrained and tagged result subtypes). | |
4887 | ||
4888 | if Constr_Result | |
4889 | and then not Is_Tagged_Type (Underlying_Type (Result_Subt)) | |
4890 | then | |
df3e68b1 | 4891 | Insert_After (Ret_Obj_Decl, Init_Assignment); |
2b3d67a5 AC |
4892 | end if; |
4893 | end if; | |
4894 | ||
4895 | -- When the function's subtype is unconstrained, a run-time | |
4896 | -- test is needed to determine the form of allocation to use | |
4897 | -- for the return object. The function has an implicit formal | |
4898 | -- parameter indicating this. If the BIP_Alloc_Form formal has | |
4899 | -- the value one, then the caller has passed access to an | |
4900 | -- existing object for use as the return object. If the value | |
4901 | -- is two, then the return object must be allocated on the | |
4902 | -- secondary stack. Otherwise, the object must be allocated in | |
4903 | -- a storage pool (currently only supported for the global | |
4904 | -- heap, user-defined storage pools TBD ???). We generate an | |
4905 | -- if statement to test the implicit allocation formal and | |
4906 | -- initialize a local access value appropriately, creating | |
4907 | -- allocators in the secondary stack and global heap cases. | |
4908 | -- The special formal also exists and must be tested when the | |
4909 | -- function has a tagged result, even when the result subtype | |
4910 | -- is constrained, because in general such functions can be | |
4911 | -- called in dispatching contexts and must be handled similarly | |
4912 | -- to functions with a class-wide result. | |
4913 | ||
4914 | if not Constr_Result | |
4915 | or else Is_Tagged_Type (Underlying_Type (Result_Subt)) | |
4916 | then | |
4917 | Obj_Alloc_Formal := | |
df3e68b1 | 4918 | Build_In_Place_Formal (Par_Func, BIP_Alloc_Form); |
2b3d67a5 AC |
4919 | |
4920 | declare | |
4921 | Ref_Type : Entity_Id; | |
4922 | Ptr_Type_Decl : Node_Id; | |
4923 | Alloc_Obj_Id : Entity_Id; | |
4924 | Alloc_Obj_Decl : Node_Id; | |
4925 | Alloc_If_Stmt : Node_Id; | |
2b3d67a5 | 4926 | Heap_Allocator : Node_Id; |
df3e68b1 | 4927 | SS_Allocator : Node_Id; |
2b3d67a5 AC |
4928 | |
4929 | begin | |
4930 | -- Reuse the itype created for the function's implicit | |
4931 | -- access formal. This avoids the need to create a new | |
4932 | -- access type here, plus it allows assigning the access | |
4933 | -- formal directly without applying a conversion. | |
4934 | ||
df3e68b1 | 4935 | -- Ref_Type := Etype (Object_Access); |
2b3d67a5 AC |
4936 | |
4937 | -- Create an access type designating the function's | |
4938 | -- result subtype. | |
4939 | ||
4940 | Ref_Type := Make_Temporary (Loc, 'A'); | |
4941 | ||
4942 | Ptr_Type_Decl := | |
4943 | Make_Full_Type_Declaration (Loc, | |
4944 | Defining_Identifier => Ref_Type, | |
4945 | Type_Definition => | |
4946 | Make_Access_To_Object_Definition (Loc, | |
4947 | All_Present => True, | |
4948 | Subtype_Indication => | |
4949 | New_Reference_To (Return_Obj_Typ, Loc))); | |
4950 | ||
df3e68b1 | 4951 | Insert_Before (Ret_Obj_Decl, Ptr_Type_Decl); |
2b3d67a5 AC |
4952 | |
4953 | -- Create an access object that will be initialized to an | |
4954 | -- access value denoting the return object, either coming | |
4955 | -- from an implicit access value passed in by the caller | |
4956 | -- or from the result of an allocator. | |
4957 | ||
4958 | Alloc_Obj_Id := Make_Temporary (Loc, 'R'); | |
4959 | Set_Etype (Alloc_Obj_Id, Ref_Type); | |
4960 | ||
4961 | Alloc_Obj_Decl := | |
4962 | Make_Object_Declaration (Loc, | |
4963 | Defining_Identifier => Alloc_Obj_Id, | |
df3e68b1 HK |
4964 | Object_Definition => |
4965 | New_Reference_To (Ref_Type, Loc)); | |
2b3d67a5 | 4966 | |
df3e68b1 | 4967 | Insert_Before (Ret_Obj_Decl, Alloc_Obj_Decl); |
2b3d67a5 AC |
4968 | |
4969 | -- Create allocators for both the secondary stack and | |
4970 | -- global heap. If there's an initialization expression, | |
4971 | -- then create these as initialized allocators. | |
4972 | ||
4973 | if Present (Return_Obj_Expr) | |
df3e68b1 | 4974 | and then not No_Initialization (Ret_Obj_Decl) |
2b3d67a5 AC |
4975 | then |
4976 | -- Always use the type of the expression for the | |
4977 | -- qualified expression, rather than the result type. | |
4978 | -- In general we cannot always use the result type | |
4979 | -- for the allocator, because the expression might be | |
4980 | -- of a specific type, such as in the case of an | |
4981 | -- aggregate or even a nonlimited object when the | |
4982 | -- result type is a limited class-wide interface type. | |
4983 | ||
4984 | Heap_Allocator := | |
4985 | Make_Allocator (Loc, | |
4986 | Expression => | |
4987 | Make_Qualified_Expression (Loc, | |
4988 | Subtype_Mark => | |
4989 | New_Reference_To | |
4990 | (Etype (Return_Obj_Expr), Loc), | |
4991 | Expression => | |
4992 | New_Copy_Tree (Return_Obj_Expr))); | |
4993 | ||
4994 | else | |
4995 | -- If the function returns a class-wide type we cannot | |
4996 | -- use the return type for the allocator. Instead we | |
4997 | -- use the type of the expression, which must be an | |
4998 | -- aggregate of a definite type. | |
4999 | ||
5000 | if Is_Class_Wide_Type (Return_Obj_Typ) then | |
5001 | Heap_Allocator := | |
5002 | Make_Allocator (Loc, | |
5003 | Expression => | |
5004 | New_Reference_To | |
5005 | (Etype (Return_Obj_Expr), Loc)); | |
5006 | else | |
5007 | Heap_Allocator := | |
5008 | Make_Allocator (Loc, | |
5009 | Expression => | |
5010 | New_Reference_To (Return_Obj_Typ, Loc)); | |
5011 | end if; | |
5012 | ||
5013 | -- If the object requires default initialization then | |
5014 | -- that will happen later following the elaboration of | |
5015 | -- the object renaming. If we don't turn it off here | |
5016 | -- then the object will be default initialized twice. | |
5017 | ||
5018 | Set_No_Initialization (Heap_Allocator); | |
5019 | end if; | |
5020 | ||
5021 | -- If the No_Allocators restriction is active, then only | |
5022 | -- an allocator for secondary stack allocation is needed. | |
5023 | -- It's OK for such allocators to have Comes_From_Source | |
5024 | -- set to False, because gigi knows not to flag them as | |
5025 | -- being a violation of No_Implicit_Heap_Allocations. | |
5026 | ||
5027 | if Restriction_Active (No_Allocators) then | |
5028 | SS_Allocator := Heap_Allocator; | |
5029 | Heap_Allocator := Make_Null (Loc); | |
5030 | ||
5031 | -- Otherwise the heap allocator may be needed, so we make | |
5032 | -- another allocator for secondary stack allocation. | |
5033 | ||
5034 | else | |
5035 | SS_Allocator := New_Copy_Tree (Heap_Allocator); | |
5036 | ||
5037 | -- The heap allocator is marked Comes_From_Source | |
5038 | -- since it corresponds to an explicit user-written | |
5039 | -- allocator (that is, it will only be executed on | |
5040 | -- behalf of callers that call the function as | |
5041 | -- initialization for such an allocator). This | |
5042 | -- prevents errors when No_Implicit_Heap_Allocations | |
5043 | -- is in force. | |
5044 | ||
5045 | Set_Comes_From_Source (Heap_Allocator, True); | |
5046 | end if; | |
5047 | ||
5048 | -- The allocator is returned on the secondary stack. We | |
5049 | -- don't do this on VM targets, since the SS is not used. | |
5050 | ||
5051 | if VM_Target = No_VM then | |
5052 | Set_Storage_Pool (SS_Allocator, RTE (RE_SS_Pool)); | |
5053 | Set_Procedure_To_Call | |
5054 | (SS_Allocator, RTE (RE_SS_Allocate)); | |
5055 | ||
5056 | -- The allocator is returned on the secondary stack, | |
5057 | -- so indicate that the function return, as well as | |
5058 | -- the block that encloses the allocator, must not | |
5059 | -- release it. The flags must be set now because the | |
5060 | -- decision to use the secondary stack is done very | |
5061 | -- late in the course of expanding the return | |
5062 | -- statement, past the point where these flags are | |
5063 | -- normally set. | |
5064 | ||
df3e68b1 | 5065 | Set_Sec_Stack_Needed_For_Return (Par_Func); |
2b3d67a5 AC |
5066 | Set_Sec_Stack_Needed_For_Return |
5067 | (Return_Statement_Entity (N)); | |
df3e68b1 | 5068 | Set_Uses_Sec_Stack (Par_Func); |
2b3d67a5 AC |
5069 | Set_Uses_Sec_Stack (Return_Statement_Entity (N)); |
5070 | end if; | |
5071 | ||
5072 | -- Create an if statement to test the BIP_Alloc_Form | |
5073 | -- formal and initialize the access object to either the | |
5074 | -- BIP_Object_Access formal (BIP_Alloc_Form = 0), the | |
5075 | -- result of allocating the object in the secondary stack | |
5076 | -- (BIP_Alloc_Form = 1), or else an allocator to create | |
5077 | -- the return object in the heap (BIP_Alloc_Form = 2). | |
5078 | ||
5079 | -- ??? An unchecked type conversion must be made in the | |
5080 | -- case of assigning the access object formal to the | |
5081 | -- local access object, because a normal conversion would | |
5082 | -- be illegal in some cases (such as converting access- | |
5083 | -- to-unconstrained to access-to-constrained), but the | |
5084 | -- the unchecked conversion will presumably fail to work | |
5085 | -- right in just such cases. It's not clear at all how to | |
5086 | -- handle this. ??? | |
5087 | ||
5088 | Alloc_If_Stmt := | |
5089 | Make_If_Statement (Loc, | |
df3e68b1 | 5090 | Condition => |
2b3d67a5 AC |
5091 | Make_Op_Eq (Loc, |
5092 | Left_Opnd => | |
5093 | New_Reference_To (Obj_Alloc_Formal, Loc), | |
5094 | Right_Opnd => | |
5095 | Make_Integer_Literal (Loc, | |
5096 | UI_From_Int (BIP_Allocation_Form'Pos | |
5097 | (Caller_Allocation)))), | |
df3e68b1 HK |
5098 | |
5099 | Then_Statements => New_List ( | |
5100 | Make_Assignment_Statement (Loc, | |
5101 | Name => | |
5102 | New_Reference_To (Alloc_Obj_Id, Loc), | |
5103 | Expression => | |
5104 | Make_Unchecked_Type_Conversion (Loc, | |
5105 | Subtype_Mark => | |
5106 | New_Reference_To (Ref_Type, Loc), | |
5107 | Expression => | |
5108 | New_Reference_To (Object_Access, Loc)))), | |
5109 | ||
5110 | Elsif_Parts => New_List ( | |
5111 | Make_Elsif_Part (Loc, | |
5112 | Condition => | |
5113 | Make_Op_Eq (Loc, | |
5114 | Left_Opnd => | |
5115 | New_Reference_To (Obj_Alloc_Formal, Loc), | |
5116 | Right_Opnd => | |
5117 | Make_Integer_Literal (Loc, | |
5118 | UI_From_Int (BIP_Allocation_Form'Pos | |
2b3d67a5 | 5119 | (Secondary_Stack)))), |
df3e68b1 HK |
5120 | |
5121 | Then_Statements => New_List ( | |
5122 | Make_Assignment_Statement (Loc, | |
5123 | Name => | |
5124 | New_Reference_To (Alloc_Obj_Id, Loc), | |
5125 | Expression => SS_Allocator)))), | |
5126 | ||
5127 | Else_Statements => New_List ( | |
5128 | Build_Heap_Allocator | |
5129 | (Temp_Id => Alloc_Obj_Id, | |
5130 | Temp_Typ => Ref_Type, | |
5131 | Func_Id => Par_Func, | |
5132 | Ret_Typ => Return_Obj_Typ, | |
5133 | Alloc_Expr => Heap_Allocator))); | |
2b3d67a5 AC |
5134 | |
5135 | -- If a separate initialization assignment was created | |
5136 | -- earlier, append that following the assignment of the | |
5137 | -- implicit access formal to the access object, to ensure | |
5138 | -- that the return object is initialized in that case. | |
5139 | -- In this situation, the target of the assignment must | |
5140 | -- be rewritten to denote a dereference of the access to | |
5141 | -- the return object passed in by the caller. | |
5142 | ||
5143 | if Present (Init_Assignment) then | |
5144 | Rewrite (Name (Init_Assignment), | |
5145 | Make_Explicit_Dereference (Loc, | |
df3e68b1 HK |
5146 | Prefix => |
5147 | New_Reference_To (Alloc_Obj_Id, Loc))); | |
5148 | ||
2b3d67a5 AC |
5149 | Set_Etype |
5150 | (Name (Init_Assignment), Etype (Return_Obj_Id)); | |
5151 | ||
5152 | Append_To | |
5153 | (Then_Statements (Alloc_If_Stmt), | |
5154 | Init_Assignment); | |
5155 | end if; | |
5156 | ||
df3e68b1 | 5157 | Insert_Before (Ret_Obj_Decl, Alloc_If_Stmt); |
2b3d67a5 AC |
5158 | |
5159 | -- Remember the local access object for use in the | |
5160 | -- dereference of the renaming created below. | |
5161 | ||
5162 | Object_Access := Alloc_Obj_Id; | |
5163 | end; | |
5164 | end if; | |
5165 | ||
5166 | -- Replace the return object declaration with a renaming of a | |
5167 | -- dereference of the access value designating the return | |
5168 | -- object. | |
5169 | ||
5170 | Obj_Acc_Deref := | |
5171 | Make_Explicit_Dereference (Loc, | |
df3e68b1 HK |
5172 | Prefix => |
5173 | New_Reference_To (Object_Access, Loc)); | |
2b3d67a5 | 5174 | |
df3e68b1 | 5175 | Rewrite (Ret_Obj_Decl, |
2b3d67a5 AC |
5176 | Make_Object_Renaming_Declaration (Loc, |
5177 | Defining_Identifier => Return_Obj_Id, | |
df3e68b1 HK |
5178 | Access_Definition => Empty, |
5179 | Subtype_Mark => | |
5180 | New_Occurrence_Of (Return_Obj_Typ, Loc), | |
5181 | Name => Obj_Acc_Deref)); | |
2b3d67a5 AC |
5182 | |
5183 | Set_Renamed_Object (Return_Obj_Id, Obj_Acc_Deref); | |
5184 | end; | |
5185 | end if; | |
5186 | ||
5187 | -- Case where we do not build a block | |
5188 | ||
5189 | else | |
df3e68b1 HK |
5190 | -- We're about to drop Return_Object_Declarations on the floor, so |
5191 | -- we need to insert it, in case it got expanded into useful code. | |
2b3d67a5 AC |
5192 | -- Remove side effects from expression, which may be duplicated in |
5193 | -- subsequent checks (see Expand_Simple_Function_Return). | |
5194 | ||
df3e68b1 | 5195 | Insert_List_Before (N, Return_Object_Declarations (N)); |
2b3d67a5 AC |
5196 | Remove_Side_Effects (Exp); |
5197 | ||
5198 | -- Build simple_return_statement that returns the expression directly | |
5199 | ||
df3e68b1 HK |
5200 | Return_Stmt := Make_Simple_Return_Statement (Loc, Expression => Exp); |
5201 | Result := Return_Stmt; | |
2b3d67a5 AC |
5202 | end if; |
5203 | ||
5204 | -- Set the flag to prevent infinite recursion | |
5205 | ||
df3e68b1 | 5206 | Set_Comes_From_Extended_Return_Statement (Return_Stmt); |
2b3d67a5 AC |
5207 | |
5208 | Rewrite (N, Result); | |
5209 | Analyze (N); | |
5210 | end Expand_N_Extended_Return_Statement; | |
5211 | ||
70482933 RK |
5212 | ---------------------------- |
5213 | -- Expand_N_Function_Call -- | |
5214 | ---------------------------- | |
5215 | ||
5216 | procedure Expand_N_Function_Call (N : Node_Id) is | |
70482933 | 5217 | begin |
ac4d6407 | 5218 | Expand_Call (N); |
c986420e | 5219 | |
4a3b249c RD |
5220 | -- If the return value of a foreign compiled function is VAX Float, then |
5221 | -- expand the return (adjusts the location of the return value on | |
5222 | -- Alpha/VMS, no-op everywhere else). | |
612c5336 | 5223 | -- Comes_From_Source intercepts recursive expansion. |
2acde248 | 5224 | |
c986420e DR |
5225 | if Vax_Float (Etype (N)) |
5226 | and then Nkind (N) = N_Function_Call | |
c986420e DR |
5227 | and then Present (Name (N)) |
5228 | and then Present (Entity (Name (N))) | |
5229 | and then Has_Foreign_Convention (Entity (Name (N))) | |
612c5336 | 5230 | and then Comes_From_Source (Parent (N)) |
c986420e DR |
5231 | then |
5232 | Expand_Vax_Foreign_Return (N); | |
5233 | end if; | |
70482933 RK |
5234 | end Expand_N_Function_Call; |
5235 | ||
5236 | --------------------------------------- | |
5237 | -- Expand_N_Procedure_Call_Statement -- | |
5238 | --------------------------------------- | |
5239 | ||
5240 | procedure Expand_N_Procedure_Call_Statement (N : Node_Id) is | |
5241 | begin | |
5242 | Expand_Call (N); | |
5243 | end Expand_N_Procedure_Call_Statement; | |
5244 | ||
2b3d67a5 AC |
5245 | -------------------------------------- |
5246 | -- Expand_N_Simple_Return_Statement -- | |
5247 | -------------------------------------- | |
5248 | ||
5249 | procedure Expand_N_Simple_Return_Statement (N : Node_Id) is | |
5250 | begin | |
5251 | -- Defend against previous errors (i.e. the return statement calls a | |
5252 | -- function that is not available in configurable runtime). | |
5253 | ||
5254 | if Present (Expression (N)) | |
5255 | and then Nkind (Expression (N)) = N_Empty | |
5256 | then | |
5257 | return; | |
5258 | end if; | |
5259 | ||
5260 | -- Distinguish the function and non-function cases: | |
5261 | ||
5262 | case Ekind (Return_Applies_To (Return_Statement_Entity (N))) is | |
5263 | ||
5264 | when E_Function | | |
5265 | E_Generic_Function => | |
5266 | Expand_Simple_Function_Return (N); | |
5267 | ||
5268 | when E_Procedure | | |
5269 | E_Generic_Procedure | | |
5270 | E_Entry | | |
5271 | E_Entry_Family | | |
5272 | E_Return_Statement => | |
5273 | Expand_Non_Function_Return (N); | |
5274 | ||
5275 | when others => | |
5276 | raise Program_Error; | |
5277 | end case; | |
5278 | ||
5279 | exception | |
5280 | when RE_Not_Available => | |
5281 | return; | |
5282 | end Expand_N_Simple_Return_Statement; | |
5283 | ||
70482933 RK |
5284 | ------------------------------ |
5285 | -- Expand_N_Subprogram_Body -- | |
5286 | ------------------------------ | |
5287 | ||
4a3b249c RD |
5288 | -- Add poll call if ATC polling is enabled, unless the body will be inlined |
5289 | -- by the back-end. | |
70482933 | 5290 | |
7888a6ae | 5291 | -- Add dummy push/pop label nodes at start and end to clear any local |
4a3b249c | 5292 | -- exception indications if local-exception-to-goto optimization is active. |
7888a6ae | 5293 | |
f44fe430 RD |
5294 | -- Add return statement if last statement in body is not a return statement |
5295 | -- (this makes things easier on Gigi which does not want to have to handle | |
5296 | -- a missing return). | |
70482933 RK |
5297 | |
5298 | -- Add call to Activate_Tasks if body is a task activator | |
5299 | ||
5300 | -- Deal with possible detection of infinite recursion | |
5301 | ||
5302 | -- Eliminate body completely if convention stubbed | |
5303 | ||
5304 | -- Encode entity names within body, since we will not need to reference | |
5305 | -- these entities any longer in the front end. | |
5306 | ||
5307 | -- Initialize scalar out parameters if Initialize/Normalize_Scalars | |
5308 | ||
c9a4817d | 5309 | -- Reset Pure indication if any parameter has root type System.Address |
199c6a10 AC |
5310 | -- or has any parameters of limited types, where limited means that the |
5311 | -- run-time view is limited (i.e. the full type is limited). | |
c9a4817d | 5312 | |
12e0c41c AC |
5313 | -- Wrap thread body |
5314 | ||
70482933 RK |
5315 | procedure Expand_N_Subprogram_Body (N : Node_Id) is |
5316 | Loc : constant Source_Ptr := Sloc (N); | |
5317 | H : constant Node_Id := Handled_Statement_Sequence (N); | |
c9a4817d | 5318 | Body_Id : Entity_Id; |
70482933 | 5319 | Except_H : Node_Id; |
70482933 | 5320 | L : List_Id; |
70f91180 | 5321 | Spec_Id : Entity_Id; |
70482933 RK |
5322 | |
5323 | procedure Add_Return (S : List_Id); | |
5324 | -- Append a return statement to the statement sequence S if the last | |
5325 | -- statement is not already a return or a goto statement. Note that | |
4a3b249c RD |
5326 | -- the latter test is not critical, it does not matter if we add a few |
5327 | -- extra returns, since they get eliminated anyway later on. | |
70482933 RK |
5328 | |
5329 | ---------------- | |
5330 | -- Add_Return -- | |
5331 | ---------------- | |
5332 | ||
5333 | procedure Add_Return (S : List_Id) is | |
7888a6ae GD |
5334 | Last_Stm : Node_Id; |
5335 | Loc : Source_Ptr; | |
12e0c41c AC |
5336 | |
5337 | begin | |
7888a6ae GD |
5338 | -- Get last statement, ignoring any Pop_xxx_Label nodes, which are |
5339 | -- not relevant in this context since they are not executable. | |
12e0c41c | 5340 | |
7888a6ae GD |
5341 | Last_Stm := Last (S); |
5342 | while Nkind (Last_Stm) in N_Pop_xxx_Label loop | |
5343 | Prev (Last_Stm); | |
5344 | end loop; | |
12e0c41c | 5345 | |
7888a6ae | 5346 | -- Now insert return unless last statement is a transfer |
12e0c41c | 5347 | |
7888a6ae | 5348 | if not Is_Transfer (Last_Stm) then |
12e0c41c | 5349 | |
7888a6ae GD |
5350 | -- The source location for the return is the end label of the |
5351 | -- procedure if present. Otherwise use the sloc of the last | |
5352 | -- statement in the list. If the list comes from a generated | |
5353 | -- exception handler and we are not debugging generated code, | |
5354 | -- all the statements within the handler are made invisible | |
5355 | -- to the debugger. | |
12e0c41c | 5356 | |
7888a6ae GD |
5357 | if Nkind (Parent (S)) = N_Exception_Handler |
5358 | and then not Comes_From_Source (Parent (S)) | |
5359 | then | |
5360 | Loc := Sloc (Last_Stm); | |
12e0c41c | 5361 | |
7888a6ae GD |
5362 | elsif Present (End_Label (H)) then |
5363 | Loc := Sloc (End_Label (H)); | |
12e0c41c | 5364 | |
7888a6ae GD |
5365 | else |
5366 | Loc := Sloc (Last_Stm); | |
5367 | end if; | |
12e0c41c | 5368 | |
5334d18f BD |
5369 | declare |
5370 | Rtn : constant Node_Id := Make_Simple_Return_Statement (Loc); | |
5371 | ||
5372 | begin | |
4a3b249c RD |
5373 | -- Append return statement, and set analyzed manually. We can't |
5374 | -- call Analyze on this return since the scope is wrong. | |
5334d18f BD |
5375 | |
5376 | -- Note: it almost works to push the scope and then do the | |
4a3b249c | 5377 | -- Analyze call, but something goes wrong in some weird cases |
5334d18f BD |
5378 | -- and it is not worth worrying about ??? |
5379 | ||
5380 | Append_To (S, Rtn); | |
5381 | Set_Analyzed (Rtn); | |
5382 | ||
5383 | -- Call _Postconditions procedure if appropriate. We need to | |
5384 | -- do this explicitly because we did not analyze the generated | |
5385 | -- return statement above, so the call did not get inserted. | |
5386 | ||
5387 | if Ekind (Spec_Id) = E_Procedure | |
5388 | and then Has_Postconditions (Spec_Id) | |
5389 | then | |
5390 | pragma Assert (Present (Postcondition_Proc (Spec_Id))); | |
5391 | Insert_Action (Rtn, | |
5392 | Make_Procedure_Call_Statement (Loc, | |
5393 | Name => | |
5394 | New_Reference_To (Postcondition_Proc (Spec_Id), Loc))); | |
5395 | end if; | |
5396 | end; | |
12e0c41c | 5397 | end if; |
7888a6ae | 5398 | end Add_Return; |
12e0c41c | 5399 | |
70482933 RK |
5400 | -- Start of processing for Expand_N_Subprogram_Body |
5401 | ||
5402 | begin | |
ab027d28 RD |
5403 | -- If this is the main compilation unit, and we are generating code for |
5404 | -- VM targets, we now generate the Type Specific Data record of all the | |
5405 | -- enclosing tagged type declarations. | |
9732e886 | 5406 | |
e8374e7a AC |
5407 | -- If the runtime package Ada_Tags has not been loaded then this |
5408 | -- subprogram does not have tagged type declarations and there is no | |
5409 | -- need to search for tagged types to generate their TSDs. | |
5410 | ||
9732e886 JM |
5411 | if not Tagged_Type_Expansion |
5412 | and then Unit (Cunit (Main_Unit)) = N | |
e8374e7a | 5413 | and then RTU_Loaded (Ada_Tags) |
9732e886 JM |
5414 | then |
5415 | Build_VM_TSDs (N); | |
5416 | end if; | |
5417 | ||
4a3b249c RD |
5418 | -- Set L to either the list of declarations if present, or to the list |
5419 | -- of statements if no declarations are present. This is used to insert | |
5420 | -- new stuff at the start. | |
70482933 RK |
5421 | |
5422 | if Is_Non_Empty_List (Declarations (N)) then | |
5423 | L := Declarations (N); | |
5424 | else | |
7888a6ae GD |
5425 | L := Statements (H); |
5426 | end if; | |
5427 | ||
5428 | -- If local-exception-to-goto optimization active, insert dummy push | |
5429 | -- statements at start, and dummy pop statements at end. | |
5430 | ||
5431 | if (Debug_Flag_Dot_G | |
5432 | or else Restriction_Active (No_Exception_Propagation)) | |
5433 | and then Is_Non_Empty_List (L) | |
5434 | then | |
5435 | declare | |
5436 | FS : constant Node_Id := First (L); | |
5437 | FL : constant Source_Ptr := Sloc (FS); | |
5438 | LS : Node_Id; | |
5439 | LL : Source_Ptr; | |
5440 | ||
5441 | begin | |
5442 | -- LS points to either last statement, if statements are present | |
5443 | -- or to the last declaration if there are no statements present. | |
5444 | -- It is the node after which the pop's are generated. | |
5445 | ||
5446 | if Is_Non_Empty_List (Statements (H)) then | |
5447 | LS := Last (Statements (H)); | |
5448 | else | |
5449 | LS := Last (L); | |
5450 | end if; | |
5451 | ||
5452 | LL := Sloc (LS); | |
5453 | ||
5454 | Insert_List_Before_And_Analyze (FS, New_List ( | |
5455 | Make_Push_Constraint_Error_Label (FL), | |
5456 | Make_Push_Program_Error_Label (FL), | |
5457 | Make_Push_Storage_Error_Label (FL))); | |
5458 | ||
5459 | Insert_List_After_And_Analyze (LS, New_List ( | |
5460 | Make_Pop_Constraint_Error_Label (LL), | |
5461 | Make_Pop_Program_Error_Label (LL), | |
5462 | Make_Pop_Storage_Error_Label (LL))); | |
5463 | end; | |
70482933 RK |
5464 | end if; |
5465 | ||
70482933 RK |
5466 | -- Find entity for subprogram |
5467 | ||
c9a4817d RD |
5468 | Body_Id := Defining_Entity (N); |
5469 | ||
70482933 RK |
5470 | if Present (Corresponding_Spec (N)) then |
5471 | Spec_Id := Corresponding_Spec (N); | |
5472 | else | |
c9a4817d RD |
5473 | Spec_Id := Body_Id; |
5474 | end if; | |
5475 | ||
7888a6ae GD |
5476 | -- Need poll on entry to subprogram if polling enabled. We only do this |
5477 | -- for non-empty subprograms, since it does not seem necessary to poll | |
4a3b249c | 5478 | -- for a dummy null subprogram. |
c885d7a1 AC |
5479 | |
5480 | if Is_Non_Empty_List (L) then | |
4a3b249c RD |
5481 | |
5482 | -- Do not add a polling call if the subprogram is to be inlined by | |
5483 | -- the back-end, to avoid repeated calls with multiple inlinings. | |
5484 | ||
c885d7a1 AC |
5485 | if Is_Inlined (Spec_Id) |
5486 | and then Front_End_Inlining | |
5487 | and then Optimization_Level > 1 | |
5488 | then | |
5489 | null; | |
5490 | else | |
5491 | Generate_Poll_Call (First (L)); | |
5492 | end if; | |
5493 | end if; | |
5494 | ||
4a3b249c RD |
5495 | -- If this is a Pure function which has any parameters whose root type |
5496 | -- is System.Address, reset the Pure indication, since it will likely | |
5497 | -- cause incorrect code to be generated as the parameter is probably | |
5498 | -- a pointer, and the fact that the same pointer is passed does not mean | |
5499 | -- that the same value is being referenced. | |
91b1417d AC |
5500 | |
5501 | -- Note that if the programmer gave an explicit Pure_Function pragma, | |
5502 | -- then we believe the programmer, and leave the subprogram Pure. | |
5503 | ||
4a3b249c RD |
5504 | -- This code should probably be at the freeze point, so that it happens |
5505 | -- even on a -gnatc (or more importantly -gnatt) compile, so that the | |
5506 | -- semantic tree has Is_Pure set properly ??? | |
c9a4817d RD |
5507 | |
5508 | if Is_Pure (Spec_Id) | |
5509 | and then Is_Subprogram (Spec_Id) | |
5510 | and then not Has_Pragma_Pure_Function (Spec_Id) | |
5511 | then | |
5512 | declare | |
2f1b20a9 | 5513 | F : Entity_Id; |
c9a4817d RD |
5514 | |
5515 | begin | |
2f1b20a9 | 5516 | F := First_Formal (Spec_Id); |
c9a4817d | 5517 | while Present (F) loop |
e5dc610e | 5518 | if Is_Descendent_Of_Address (Etype (F)) |
199c6a10 AC |
5519 | |
5520 | -- Note that this test is being made in the body of the | |
5521 | -- subprogram, not the spec, so we are testing the full | |
5522 | -- type for being limited here, as required. | |
5523 | ||
e5dc610e AC |
5524 | or else Is_Limited_Type (Etype (F)) |
5525 | then | |
c9a4817d RD |
5526 | Set_Is_Pure (Spec_Id, False); |
5527 | ||
5528 | if Spec_Id /= Body_Id then | |
5529 | Set_Is_Pure (Body_Id, False); | |
5530 | end if; | |
5531 | ||
5532 | exit; | |
5533 | end if; | |
5534 | ||
5535 | Next_Formal (F); | |
5536 | end loop; | |
5537 | end; | |
70482933 RK |
5538 | end if; |
5539 | ||
5540 | -- Initialize any scalar OUT args if Initialize/Normalize_Scalars | |
5541 | ||
5542 | if Init_Or_Norm_Scalars and then Is_Subprogram (Spec_Id) then | |
5543 | declare | |
2f1b20a9 | 5544 | F : Entity_Id; |
70482933 RK |
5545 | |
5546 | begin | |
70482933 RK |
5547 | -- Loop through formals |
5548 | ||
2f1b20a9 | 5549 | F := First_Formal (Spec_Id); |
70482933 RK |
5550 | while Present (F) loop |
5551 | if Is_Scalar_Type (Etype (F)) | |
5552 | and then Ekind (F) = E_Out_Parameter | |
5553 | then | |
70f91180 RD |
5554 | Check_Restriction (No_Default_Initialization, F); |
5555 | ||
02822a92 RD |
5556 | -- Insert the initialization. We turn off validity checks |
5557 | -- for this assignment, since we do not want any check on | |
5558 | -- the initial value itself (which may well be invalid). | |
5559 | ||
70482933 RK |
5560 | Insert_Before_And_Analyze (First (L), |
5561 | Make_Assignment_Statement (Loc, | |
02822a92 | 5562 | Name => New_Occurrence_Of (F, Loc), |
70f91180 | 5563 | Expression => Get_Simple_Init_Val (Etype (F), N)), |
02822a92 | 5564 | Suppress => Validity_Check); |
70482933 RK |
5565 | end if; |
5566 | ||
5567 | Next_Formal (F); | |
5568 | end loop; | |
70482933 RK |
5569 | end; |
5570 | end if; | |
5571 | ||
5572 | -- Clear out statement list for stubbed procedure | |
5573 | ||
5574 | if Present (Corresponding_Spec (N)) then | |
5575 | Set_Elaboration_Flag (N, Spec_Id); | |
5576 | ||
5577 | if Convention (Spec_Id) = Convention_Stubbed | |
5578 | or else Is_Eliminated (Spec_Id) | |
5579 | then | |
5580 | Set_Declarations (N, Empty_List); | |
5581 | Set_Handled_Statement_Sequence (N, | |
5582 | Make_Handled_Sequence_Of_Statements (Loc, | |
5583 | Statements => New_List ( | |
5584 | Make_Null_Statement (Loc)))); | |
5585 | return; | |
5586 | end if; | |
5587 | end if; | |
5588 | ||
70f91180 RD |
5589 | -- Create a set of discriminals for the next protected subprogram body |
5590 | ||
5591 | if Is_List_Member (N) | |
5592 | and then Present (Parent (List_Containing (N))) | |
5593 | and then Nkind (Parent (List_Containing (N))) = N_Protected_Body | |
5594 | and then Present (Next_Protected_Operation (N)) | |
5595 | then | |
5596 | Set_Discriminals (Parent (Base_Type (Scope (Spec_Id)))); | |
5597 | end if; | |
5598 | ||
4a3b249c RD |
5599 | -- Returns_By_Ref flag is normally set when the subprogram is frozen but |
5600 | -- subprograms with no specs are not frozen. | |
70482933 RK |
5601 | |
5602 | declare | |
5603 | Typ : constant Entity_Id := Etype (Spec_Id); | |
5604 | Utyp : constant Entity_Id := Underlying_Type (Typ); | |
5605 | ||
5606 | begin | |
5607 | if not Acts_As_Spec (N) | |
5608 | and then Nkind (Parent (Parent (Spec_Id))) /= | |
5609 | N_Subprogram_Body_Stub | |
5610 | then | |
5611 | null; | |
5612 | ||
40f07b4b | 5613 | elsif Is_Immutably_Limited_Type (Typ) then |
70482933 RK |
5614 | Set_Returns_By_Ref (Spec_Id); |
5615 | ||
048e5cef | 5616 | elsif Present (Utyp) and then CW_Or_Has_Controlled_Part (Utyp) then |
70482933 RK |
5617 | Set_Returns_By_Ref (Spec_Id); |
5618 | end if; | |
5619 | end; | |
5620 | ||
4a3b249c RD |
5621 | -- For a procedure, we add a return for all possible syntactic ends of |
5622 | -- the subprogram. | |
70482933 | 5623 | |
b29def53 | 5624 | if Ekind_In (Spec_Id, E_Procedure, E_Generic_Procedure) then |
70482933 RK |
5625 | Add_Return (Statements (H)); |
5626 | ||
5627 | if Present (Exception_Handlers (H)) then | |
5628 | Except_H := First_Non_Pragma (Exception_Handlers (H)); | |
70482933 RK |
5629 | while Present (Except_H) loop |
5630 | Add_Return (Statements (Except_H)); | |
5631 | Next_Non_Pragma (Except_H); | |
5632 | end loop; | |
5633 | end if; | |
5634 | ||
98f01d53 AC |
5635 | -- For a function, we must deal with the case where there is at least |
5636 | -- one missing return. What we do is to wrap the entire body of the | |
5637 | -- function in a block: | |
70482933 RK |
5638 | |
5639 | -- begin | |
5640 | -- ... | |
5641 | -- end; | |
5642 | ||
5643 | -- becomes | |
5644 | ||
5645 | -- begin | |
5646 | -- begin | |
5647 | -- ... | |
5648 | -- end; | |
5649 | ||
5650 | -- raise Program_Error; | |
5651 | -- end; | |
5652 | ||
4a3b249c RD |
5653 | -- This approach is necessary because the raise must be signalled to the |
5654 | -- caller, not handled by any local handler (RM 6.4(11)). | |
70482933 | 5655 | |
4a3b249c RD |
5656 | -- Note: we do not need to analyze the constructed sequence here, since |
5657 | -- it has no handler, and an attempt to analyze the handled statement | |
5658 | -- sequence twice is risky in various ways (e.g. the issue of expanding | |
5659 | -- cleanup actions twice). | |
70482933 RK |
5660 | |
5661 | elsif Has_Missing_Return (Spec_Id) then | |
5662 | declare | |
5663 | Hloc : constant Source_Ptr := Sloc (H); | |
5664 | Blok : constant Node_Id := | |
5665 | Make_Block_Statement (Hloc, | |
5666 | Handled_Statement_Sequence => H); | |
5667 | Rais : constant Node_Id := | |
07fc65c4 GB |
5668 | Make_Raise_Program_Error (Hloc, |
5669 | Reason => PE_Missing_Return); | |
70482933 RK |
5670 | |
5671 | begin | |
5672 | Set_Handled_Statement_Sequence (N, | |
5673 | Make_Handled_Sequence_Of_Statements (Hloc, | |
5674 | Statements => New_List (Blok, Rais))); | |
5675 | ||
7888a6ae | 5676 | Push_Scope (Spec_Id); |
70482933 RK |
5677 | Analyze (Blok); |
5678 | Analyze (Rais); | |
5679 | Pop_Scope; | |
5680 | end; | |
5681 | end if; | |
5682 | ||
70482933 RK |
5683 | -- If subprogram contains a parameterless recursive call, then we may |
5684 | -- have an infinite recursion, so see if we can generate code to check | |
5685 | -- for this possibility if storage checks are not suppressed. | |
5686 | ||
5687 | if Ekind (Spec_Id) = E_Procedure | |
5688 | and then Has_Recursive_Call (Spec_Id) | |
5689 | and then not Storage_Checks_Suppressed (Spec_Id) | |
5690 | then | |
5691 | Detect_Infinite_Recursion (N, Spec_Id); | |
5692 | end if; | |
5693 | ||
70482933 RK |
5694 | -- Set to encode entity names in package body before gigi is called |
5695 | ||
5696 | Qualify_Entity_Names (N); | |
5697 | end Expand_N_Subprogram_Body; | |
5698 | ||
5699 | ----------------------------------- | |
5700 | -- Expand_N_Subprogram_Body_Stub -- | |
5701 | ----------------------------------- | |
5702 | ||
5703 | procedure Expand_N_Subprogram_Body_Stub (N : Node_Id) is | |
5704 | begin | |
5705 | if Present (Corresponding_Body (N)) then | |
5706 | Expand_N_Subprogram_Body ( | |
5707 | Unit_Declaration_Node (Corresponding_Body (N))); | |
5708 | end if; | |
70482933 RK |
5709 | end Expand_N_Subprogram_Body_Stub; |
5710 | ||
5711 | ------------------------------------- | |
5712 | -- Expand_N_Subprogram_Declaration -- | |
5713 | ------------------------------------- | |
5714 | ||
70482933 RK |
5715 | -- If the declaration appears within a protected body, it is a private |
5716 | -- operation of the protected type. We must create the corresponding | |
5717 | -- protected subprogram an associated formals. For a normal protected | |
5718 | -- operation, this is done when expanding the protected type declaration. | |
5719 | ||
758c442c GD |
5720 | -- If the declaration is for a null procedure, emit null body |
5721 | ||
70482933 | 5722 | procedure Expand_N_Subprogram_Declaration (N : Node_Id) is |
fbf5a39b AC |
5723 | Loc : constant Source_Ptr := Sloc (N); |
5724 | Subp : constant Entity_Id := Defining_Entity (N); | |
5725 | Scop : constant Entity_Id := Scope (Subp); | |
5726 | Prot_Decl : Node_Id; | |
5727 | Prot_Bod : Node_Id; | |
5728 | Prot_Id : Entity_Id; | |
70482933 RK |
5729 | |
5730 | begin | |
2ba431e5 YM |
5731 | -- In SPARK, subprogram declarations are only allowed in package |
5732 | -- specifications. | |
7ff2d234 | 5733 | |
fe5d3068 YM |
5734 | if Nkind (Parent (N)) /= N_Package_Specification then |
5735 | if Nkind (Parent (N)) = N_Compilation_Unit then | |
2ba431e5 | 5736 | Check_SPARK_Restriction |
fe5d3068 YM |
5737 | ("subprogram declaration is not a library item", N); |
5738 | ||
5739 | elsif Present (Next (N)) | |
7ff2d234 AC |
5740 | and then Nkind (Next (N)) = N_Pragma |
5741 | and then Get_Pragma_Id (Pragma_Name (Next (N))) = Pragma_Import | |
5742 | then | |
2ba431e5 | 5743 | -- In SPARK, subprogram declarations are also permitted in |
7ff2d234 AC |
5744 | -- declarative parts when immediately followed by a corresponding |
5745 | -- pragma Import. We only check here that there is some pragma | |
5746 | -- Import. | |
5747 | ||
5748 | null; | |
5749 | else | |
2ba431e5 | 5750 | Check_SPARK_Restriction |
fe5d3068 | 5751 | ("subprogram declaration is not allowed here", N); |
7ff2d234 AC |
5752 | end if; |
5753 | end if; | |
5754 | ||
2f1b20a9 ES |
5755 | -- Deal with case of protected subprogram. Do not generate protected |
5756 | -- operation if operation is flagged as eliminated. | |
70482933 RK |
5757 | |
5758 | if Is_List_Member (N) | |
5759 | and then Present (Parent (List_Containing (N))) | |
5760 | and then Nkind (Parent (List_Containing (N))) = N_Protected_Body | |
5761 | and then Is_Protected_Type (Scop) | |
5762 | then | |
6871ba5f AC |
5763 | if No (Protected_Body_Subprogram (Subp)) |
5764 | and then not Is_Eliminated (Subp) | |
5765 | then | |
fbf5a39b | 5766 | Prot_Decl := |
70482933 RK |
5767 | Make_Subprogram_Declaration (Loc, |
5768 | Specification => | |
5769 | Build_Protected_Sub_Specification | |
2f1b20a9 | 5770 | (N, Scop, Unprotected_Mode)); |
70482933 RK |
5771 | |
5772 | -- The protected subprogram is declared outside of the protected | |
5773 | -- body. Given that the body has frozen all entities so far, we | |
fbf5a39b | 5774 | -- analyze the subprogram and perform freezing actions explicitly. |
19590d70 GD |
5775 | -- including the generation of an explicit freeze node, to ensure |
5776 | -- that gigi has the proper order of elaboration. | |
fbf5a39b AC |
5777 | -- If the body is a subunit, the insertion point is before the |
5778 | -- stub in the parent. | |
70482933 RK |
5779 | |
5780 | Prot_Bod := Parent (List_Containing (N)); | |
5781 | ||
5782 | if Nkind (Parent (Prot_Bod)) = N_Subunit then | |
5783 | Prot_Bod := Corresponding_Stub (Parent (Prot_Bod)); | |
5784 | end if; | |
5785 | ||
fbf5a39b AC |
5786 | Insert_Before (Prot_Bod, Prot_Decl); |
5787 | Prot_Id := Defining_Unit_Name (Specification (Prot_Decl)); | |
19590d70 | 5788 | Set_Has_Delayed_Freeze (Prot_Id); |
70482933 | 5789 | |
7888a6ae | 5790 | Push_Scope (Scope (Scop)); |
fbf5a39b | 5791 | Analyze (Prot_Decl); |
6b958cec | 5792 | Freeze_Before (N, Prot_Id); |
fbf5a39b | 5793 | Set_Protected_Body_Subprogram (Subp, Prot_Id); |
47bfea3a AC |
5794 | |
5795 | -- Create protected operation as well. Even though the operation | |
5796 | -- is only accessible within the body, it is possible to make it | |
5797 | -- available outside of the protected object by using 'Access to | |
3d923671 | 5798 | -- provide a callback, so build protected version in all cases. |
47bfea3a AC |
5799 | |
5800 | Prot_Decl := | |
3d923671 AC |
5801 | Make_Subprogram_Declaration (Loc, |
5802 | Specification => | |
5803 | Build_Protected_Sub_Specification (N, Scop, Protected_Mode)); | |
47bfea3a AC |
5804 | Insert_Before (Prot_Bod, Prot_Decl); |
5805 | Analyze (Prot_Decl); | |
5806 | ||
70482933 RK |
5807 | Pop_Scope; |
5808 | end if; | |
758c442c | 5809 | |
e1f3cb58 AC |
5810 | -- Ada 2005 (AI-348): Generate body for a null procedure. |
5811 | -- In most cases this is superfluous because calls to it | |
5812 | -- will be automatically inlined, but we definitely need | |
5813 | -- the body if preconditions for the procedure are present. | |
02822a92 | 5814 | |
758c442c GD |
5815 | elsif Nkind (Specification (N)) = N_Procedure_Specification |
5816 | and then Null_Present (Specification (N)) | |
5817 | then | |
5818 | declare | |
e1f3cb58 | 5819 | Bod : constant Node_Id := Body_To_Inline (N); |
d6533e74 | 5820 | |
758c442c | 5821 | begin |
e1f3cb58 AC |
5822 | Set_Has_Completion (Subp, False); |
5823 | Append_Freeze_Action (Subp, Bod); | |
c73ae90f | 5824 | |
e1f3cb58 AC |
5825 | -- The body now contains raise statements, so calls to it will |
5826 | -- not be inlined. | |
c73ae90f | 5827 | |
e1f3cb58 | 5828 | Set_Is_Inlined (Subp, False); |
758c442c | 5829 | end; |
70482933 RK |
5830 | end if; |
5831 | end Expand_N_Subprogram_Declaration; | |
5832 | ||
2b3d67a5 AC |
5833 | -------------------------------- |
5834 | -- Expand_Non_Function_Return -- | |
5835 | -------------------------------- | |
5836 | ||
5837 | procedure Expand_Non_Function_Return (N : Node_Id) is | |
5838 | pragma Assert (No (Expression (N))); | |
5839 | ||
5840 | Loc : constant Source_Ptr := Sloc (N); | |
5841 | Scope_Id : Entity_Id := | |
5842 | Return_Applies_To (Return_Statement_Entity (N)); | |
5843 | Kind : constant Entity_Kind := Ekind (Scope_Id); | |
5844 | Call : Node_Id; | |
5845 | Acc_Stat : Node_Id; | |
5846 | Goto_Stat : Node_Id; | |
5847 | Lab_Node : Node_Id; | |
5848 | ||
5849 | begin | |
5850 | -- Call _Postconditions procedure if procedure with active | |
5851 | -- postconditions. Here, we use the Postcondition_Proc attribute, which | |
5852 | -- is needed for implicitly-generated returns. Functions never | |
5853 | -- have implicitly-generated returns, and there's no room for | |
5854 | -- Postcondition_Proc in E_Function, so we look up the identifier | |
5855 | -- Name_uPostconditions for function returns (see | |
5856 | -- Expand_Simple_Function_Return). | |
5857 | ||
5858 | if Ekind (Scope_Id) = E_Procedure | |
5859 | and then Has_Postconditions (Scope_Id) | |
5860 | then | |
5861 | pragma Assert (Present (Postcondition_Proc (Scope_Id))); | |
5862 | Insert_Action (N, | |
5863 | Make_Procedure_Call_Statement (Loc, | |
5864 | Name => New_Reference_To (Postcondition_Proc (Scope_Id), Loc))); | |
5865 | end if; | |
5866 | ||
5867 | -- If it is a return from a procedure do no extra steps | |
5868 | ||
5869 | if Kind = E_Procedure or else Kind = E_Generic_Procedure then | |
5870 | return; | |
5871 | ||
5872 | -- If it is a nested return within an extended one, replace it with a | |
5873 | -- return of the previously declared return object. | |
5874 | ||
5875 | elsif Kind = E_Return_Statement then | |
5876 | Rewrite (N, | |
5877 | Make_Simple_Return_Statement (Loc, | |
5878 | Expression => | |
5879 | New_Occurrence_Of (First_Entity (Scope_Id), Loc))); | |
5880 | Set_Comes_From_Extended_Return_Statement (N); | |
5881 | Set_Return_Statement_Entity (N, Scope_Id); | |
5882 | Expand_Simple_Function_Return (N); | |
5883 | return; | |
5884 | end if; | |
5885 | ||
5886 | pragma Assert (Is_Entry (Scope_Id)); | |
5887 | ||
5888 | -- Look at the enclosing block to see whether the return is from an | |
5889 | -- accept statement or an entry body. | |
5890 | ||
5891 | for J in reverse 0 .. Scope_Stack.Last loop | |
5892 | Scope_Id := Scope_Stack.Table (J).Entity; | |
5893 | exit when Is_Concurrent_Type (Scope_Id); | |
5894 | end loop; | |
5895 | ||
5896 | -- If it is a return from accept statement it is expanded as call to | |
5897 | -- RTS Complete_Rendezvous and a goto to the end of the accept body. | |
5898 | ||
5899 | -- (cf : Expand_N_Accept_Statement, Expand_N_Selective_Accept, | |
5900 | -- Expand_N_Accept_Alternative in exp_ch9.adb) | |
5901 | ||
5902 | if Is_Task_Type (Scope_Id) then | |
5903 | ||
5904 | Call := | |
5905 | Make_Procedure_Call_Statement (Loc, | |
5906 | Name => New_Reference_To (RTE (RE_Complete_Rendezvous), Loc)); | |
5907 | Insert_Before (N, Call); | |
5908 | -- why not insert actions here??? | |
5909 | Analyze (Call); | |
5910 | ||
5911 | Acc_Stat := Parent (N); | |
5912 | while Nkind (Acc_Stat) /= N_Accept_Statement loop | |
5913 | Acc_Stat := Parent (Acc_Stat); | |
5914 | end loop; | |
5915 | ||
5916 | Lab_Node := Last (Statements | |
5917 | (Handled_Statement_Sequence (Acc_Stat))); | |
5918 | ||
5919 | Goto_Stat := Make_Goto_Statement (Loc, | |
5920 | Name => New_Occurrence_Of | |
5921 | (Entity (Identifier (Lab_Node)), Loc)); | |
5922 | ||
5923 | Set_Analyzed (Goto_Stat); | |
5924 | ||
5925 | Rewrite (N, Goto_Stat); | |
5926 | Analyze (N); | |
5927 | ||
5928 | -- If it is a return from an entry body, put a Complete_Entry_Body call | |
5929 | -- in front of the return. | |
5930 | ||
5931 | elsif Is_Protected_Type (Scope_Id) then | |
5932 | Call := | |
5933 | Make_Procedure_Call_Statement (Loc, | |
5934 | Name => | |
5935 | New_Reference_To (RTE (RE_Complete_Entry_Body), Loc), | |
5936 | Parameter_Associations => New_List ( | |
5937 | Make_Attribute_Reference (Loc, | |
5938 | Prefix => | |
5939 | New_Reference_To | |
5940 | (Find_Protection_Object (Current_Scope), Loc), | |
5941 | Attribute_Name => | |
5942 | Name_Unchecked_Access))); | |
5943 | ||
5944 | Insert_Before (N, Call); | |
5945 | Analyze (Call); | |
5946 | end if; | |
5947 | end Expand_Non_Function_Return; | |
5948 | ||
70482933 RK |
5949 | --------------------------------------- |
5950 | -- Expand_Protected_Object_Reference -- | |
5951 | --------------------------------------- | |
5952 | ||
5953 | function Expand_Protected_Object_Reference | |
5954 | (N : Node_Id; | |
02822a92 | 5955 | Scop : Entity_Id) return Node_Id |
70482933 RK |
5956 | is |
5957 | Loc : constant Source_Ptr := Sloc (N); | |
5958 | Corr : Entity_Id; | |
5959 | Rec : Node_Id; | |
5960 | Param : Entity_Id; | |
5961 | Proc : Entity_Id; | |
5962 | ||
5963 | begin | |
7675ad4f | 5964 | Rec := Make_Identifier (Loc, Name_uObject); |
70482933 RK |
5965 | Set_Etype (Rec, Corresponding_Record_Type (Scop)); |
5966 | ||
2f1b20a9 ES |
5967 | -- Find enclosing protected operation, and retrieve its first parameter, |
5968 | -- which denotes the enclosing protected object. If the enclosing | |
5969 | -- operation is an entry, we are immediately within the protected body, | |
5970 | -- and we can retrieve the object from the service entries procedure. A | |
16b05213 | 5971 | -- barrier function has the same signature as an entry. A barrier |
2f1b20a9 ES |
5972 | -- function is compiled within the protected object, but unlike |
5973 | -- protected operations its never needs locks, so that its protected | |
5974 | -- body subprogram points to itself. | |
70482933 RK |
5975 | |
5976 | Proc := Current_Scope; | |
70482933 RK |
5977 | while Present (Proc) |
5978 | and then Scope (Proc) /= Scop | |
5979 | loop | |
5980 | Proc := Scope (Proc); | |
5981 | end loop; | |
5982 | ||
5983 | Corr := Protected_Body_Subprogram (Proc); | |
5984 | ||
5985 | if No (Corr) then | |
5986 | ||
5987 | -- Previous error left expansion incomplete. | |
5988 | -- Nothing to do on this call. | |
5989 | ||
5990 | return Empty; | |
5991 | end if; | |
5992 | ||
5993 | Param := | |
5994 | Defining_Identifier | |
5995 | (First (Parameter_Specifications (Parent (Corr)))); | |
5996 | ||
5997 | if Is_Subprogram (Proc) | |
5998 | and then Proc /= Corr | |
5999 | then | |
98f01d53 | 6000 | -- Protected function or procedure |
70482933 RK |
6001 | |
6002 | Set_Entity (Rec, Param); | |
6003 | ||
2f1b20a9 ES |
6004 | -- Rec is a reference to an entity which will not be in scope when |
6005 | -- the call is reanalyzed, and needs no further analysis. | |
70482933 RK |
6006 | |
6007 | Set_Analyzed (Rec); | |
6008 | ||
6009 | else | |
2f1b20a9 ES |
6010 | -- Entry or barrier function for entry body. The first parameter of |
6011 | -- the entry body procedure is pointer to the object. We create a | |
6012 | -- local variable of the proper type, duplicating what is done to | |
6013 | -- define _object later on. | |
70482933 RK |
6014 | |
6015 | declare | |
c12beea0 RD |
6016 | Decls : List_Id; |
6017 | Obj_Ptr : constant Entity_Id := Make_Temporary (Loc, 'T'); | |
fbf5a39b | 6018 | |
70482933 RK |
6019 | begin |
6020 | Decls := New_List ( | |
6021 | Make_Full_Type_Declaration (Loc, | |
6022 | Defining_Identifier => Obj_Ptr, | |
6023 | Type_Definition => | |
6024 | Make_Access_To_Object_Definition (Loc, | |
6025 | Subtype_Indication => | |
6026 | New_Reference_To | |
c12beea0 | 6027 | (Corresponding_Record_Type (Scop), Loc)))); |
70482933 RK |
6028 | |
6029 | Insert_Actions (N, Decls); | |
6b958cec | 6030 | Freeze_Before (N, Obj_Ptr); |
70482933 RK |
6031 | |
6032 | Rec := | |
6033 | Make_Explicit_Dereference (Loc, | |
6034 | Unchecked_Convert_To (Obj_Ptr, | |
6035 | New_Occurrence_Of (Param, Loc))); | |
6036 | ||
2f1b20a9 | 6037 | -- Analyze new actual. Other actuals in calls are already analyzed |
7888a6ae | 6038 | -- and the list of actuals is not reanalyzed after rewriting. |
70482933 RK |
6039 | |
6040 | Set_Parent (Rec, N); | |
6041 | Analyze (Rec); | |
6042 | end; | |
6043 | end if; | |
6044 | ||
6045 | return Rec; | |
6046 | end Expand_Protected_Object_Reference; | |
6047 | ||
6048 | -------------------------------------- | |
6049 | -- Expand_Protected_Subprogram_Call -- | |
6050 | -------------------------------------- | |
6051 | ||
6052 | procedure Expand_Protected_Subprogram_Call | |
6053 | (N : Node_Id; | |
6054 | Subp : Entity_Id; | |
6055 | Scop : Entity_Id) | |
6056 | is | |
6057 | Rec : Node_Id; | |
6058 | ||
6059 | begin | |
6060 | -- If the protected object is not an enclosing scope, this is | |
6061 | -- an inter-object function call. Inter-object procedure | |
6062 | -- calls are expanded by Exp_Ch9.Build_Simple_Entry_Call. | |
6063 | -- The call is intra-object only if the subprogram being | |
6064 | -- called is in the protected body being compiled, and if the | |
6065 | -- protected object in the call is statically the enclosing type. | |
6066 | -- The object may be an component of some other data structure, | |
6067 | -- in which case this must be handled as an inter-object call. | |
6068 | ||
6069 | if not In_Open_Scopes (Scop) | |
6070 | or else not Is_Entity_Name (Name (N)) | |
6071 | then | |
6072 | if Nkind (Name (N)) = N_Selected_Component then | |
6073 | Rec := Prefix (Name (N)); | |
6074 | ||
6075 | else | |
6076 | pragma Assert (Nkind (Name (N)) = N_Indexed_Component); | |
6077 | Rec := Prefix (Prefix (Name (N))); | |
6078 | end if; | |
6079 | ||
6080 | Build_Protected_Subprogram_Call (N, | |
6081 | Name => New_Occurrence_Of (Subp, Sloc (N)), | |
6082 | Rec => Convert_Concurrent (Rec, Etype (Rec)), | |
6083 | External => True); | |
6084 | ||
6085 | else | |
6086 | Rec := Expand_Protected_Object_Reference (N, Scop); | |
6087 | ||
6088 | if No (Rec) then | |
6089 | return; | |
6090 | end if; | |
6091 | ||
6092 | Build_Protected_Subprogram_Call (N, | |
6093 | Name => Name (N), | |
6094 | Rec => Rec, | |
6095 | External => False); | |
6096 | ||
6097 | end if; | |
6098 | ||
70482933 RK |
6099 | -- If it is a function call it can appear in elaboration code and |
6100 | -- the called entity must be frozen here. | |
6101 | ||
6102 | if Ekind (Subp) = E_Function then | |
6103 | Freeze_Expression (Name (N)); | |
6104 | end if; | |
811c6a85 AC |
6105 | |
6106 | -- Analyze and resolve the new call. The actuals have already been | |
b0159fbe | 6107 | -- resolved, but expansion of a function call will add extra actuals |
811c6a85 AC |
6108 | -- if needed. Analysis of a procedure call already includes resolution. |
6109 | ||
6110 | Analyze (N); | |
6111 | ||
6112 | if Ekind (Subp) = E_Function then | |
6113 | Resolve (N, Etype (Subp)); | |
6114 | end if; | |
70482933 RK |
6115 | end Expand_Protected_Subprogram_Call; |
6116 | ||
2b3d67a5 AC |
6117 | ----------------------------------- |
6118 | -- Expand_Simple_Function_Return -- | |
6119 | ----------------------------------- | |
6120 | ||
6121 | -- The "simple" comes from the syntax rule simple_return_statement. | |
6122 | -- The semantics are not at all simple! | |
6123 | ||
6124 | procedure Expand_Simple_Function_Return (N : Node_Id) is | |
6125 | Loc : constant Source_Ptr := Sloc (N); | |
6126 | ||
6127 | Scope_Id : constant Entity_Id := | |
6128 | Return_Applies_To (Return_Statement_Entity (N)); | |
6129 | -- The function we are returning from | |
6130 | ||
6131 | R_Type : constant Entity_Id := Etype (Scope_Id); | |
6132 | -- The result type of the function | |
6133 | ||
6134 | Utyp : constant Entity_Id := Underlying_Type (R_Type); | |
6135 | ||
6136 | Exp : constant Node_Id := Expression (N); | |
6137 | pragma Assert (Present (Exp)); | |
6138 | ||
6139 | Exptyp : constant Entity_Id := Etype (Exp); | |
6140 | -- The type of the expression (not necessarily the same as R_Type) | |
6141 | ||
6142 | Subtype_Ind : Node_Id; | |
6143 | -- If the result type of the function is class-wide and the | |
6144 | -- expression has a specific type, then we use the expression's | |
6145 | -- type as the type of the return object. In cases where the | |
6146 | -- expression is an aggregate that is built in place, this avoids | |
6147 | -- the need for an expensive conversion of the return object to | |
6148 | -- the specific type on assignments to the individual components. | |
6149 | ||
6150 | begin | |
6151 | if Is_Class_Wide_Type (R_Type) | |
6152 | and then not Is_Class_Wide_Type (Etype (Exp)) | |
6153 | then | |
6154 | Subtype_Ind := New_Occurrence_Of (Etype (Exp), Loc); | |
6155 | else | |
6156 | Subtype_Ind := New_Occurrence_Of (R_Type, Loc); | |
6157 | end if; | |
6158 | ||
6159 | -- For the case of a simple return that does not come from an extended | |
6160 | -- return, in the case of Ada 2005 where we are returning a limited | |
6161 | -- type, we rewrite "return <expression>;" to be: | |
6162 | ||
6163 | -- return _anon_ : <return_subtype> := <expression> | |
6164 | ||
6165 | -- The expansion produced by Expand_N_Extended_Return_Statement will | |
6166 | -- contain simple return statements (for example, a block containing | |
6167 | -- simple return of the return object), which brings us back here with | |
6168 | -- Comes_From_Extended_Return_Statement set. The reason for the barrier | |
6169 | -- checking for a simple return that does not come from an extended | |
6170 | -- return is to avoid this infinite recursion. | |
6171 | ||
6172 | -- The reason for this design is that for Ada 2005 limited returns, we | |
6173 | -- need to reify the return object, so we can build it "in place", and | |
6174 | -- we need a block statement to hang finalization and tasking stuff. | |
6175 | ||
6176 | -- ??? In order to avoid disruption, we avoid translating to extended | |
6177 | -- return except in the cases where we really need to (Ada 2005 for | |
6178 | -- inherently limited). We might prefer to do this translation in all | |
6179 | -- cases (except perhaps for the case of Ada 95 inherently limited), | |
6180 | -- in order to fully exercise the Expand_N_Extended_Return_Statement | |
6181 | -- code. This would also allow us to do the build-in-place optimization | |
6182 | -- for efficiency even in cases where it is semantically not required. | |
6183 | ||
6184 | -- As before, we check the type of the return expression rather than the | |
6185 | -- return type of the function, because the latter may be a limited | |
6186 | -- class-wide interface type, which is not a limited type, even though | |
6187 | -- the type of the expression may be. | |
6188 | ||
6189 | if not Comes_From_Extended_Return_Statement (N) | |
6190 | and then Is_Immutably_Limited_Type (Etype (Expression (N))) | |
0791fbe9 | 6191 | and then Ada_Version >= Ada_2005 |
2b3d67a5 AC |
6192 | and then not Debug_Flag_Dot_L |
6193 | then | |
6194 | declare | |
6195 | Return_Object_Entity : constant Entity_Id := | |
6196 | Make_Temporary (Loc, 'R', Exp); | |
6197 | Obj_Decl : constant Node_Id := | |
6198 | Make_Object_Declaration (Loc, | |
6199 | Defining_Identifier => Return_Object_Entity, | |
6200 | Object_Definition => Subtype_Ind, | |
6201 | Expression => Exp); | |
6202 | ||
6203 | Ext : constant Node_Id := Make_Extended_Return_Statement (Loc, | |
6204 | Return_Object_Declarations => New_List (Obj_Decl)); | |
6205 | -- Do not perform this high-level optimization if the result type | |
6206 | -- is an interface because the "this" pointer must be displaced. | |
6207 | ||
6208 | begin | |
6209 | Rewrite (N, Ext); | |
6210 | Analyze (N); | |
6211 | return; | |
6212 | end; | |
6213 | end if; | |
6214 | ||
6215 | -- Here we have a simple return statement that is part of the expansion | |
6216 | -- of an extended return statement (either written by the user, or | |
6217 | -- generated by the above code). | |
6218 | ||
6219 | -- Always normalize C/Fortran boolean result. This is not always needed, | |
6220 | -- but it seems a good idea to minimize the passing around of non- | |
6221 | -- normalized values, and in any case this handles the processing of | |
6222 | -- barrier functions for protected types, which turn the condition into | |
6223 | -- a return statement. | |
6224 | ||
6225 | if Is_Boolean_Type (Exptyp) | |
6226 | and then Nonzero_Is_True (Exptyp) | |
6227 | then | |
6228 | Adjust_Condition (Exp); | |
6229 | Adjust_Result_Type (Exp, Exptyp); | |
6230 | end if; | |
6231 | ||
6232 | -- Do validity check if enabled for returns | |
6233 | ||
6234 | if Validity_Checks_On | |
6235 | and then Validity_Check_Returns | |
6236 | then | |
6237 | Ensure_Valid (Exp); | |
6238 | end if; | |
6239 | ||
6240 | -- Check the result expression of a scalar function against the subtype | |
6241 | -- of the function by inserting a conversion. This conversion must | |
6242 | -- eventually be performed for other classes of types, but for now it's | |
6243 | -- only done for scalars. | |
6244 | -- ??? | |
6245 | ||
6246 | if Is_Scalar_Type (Exptyp) then | |
6247 | Rewrite (Exp, Convert_To (R_Type, Exp)); | |
6248 | ||
6249 | -- The expression is resolved to ensure that the conversion gets | |
6250 | -- expanded to generate a possible constraint check. | |
6251 | ||
6252 | Analyze_And_Resolve (Exp, R_Type); | |
6253 | end if; | |
6254 | ||
6255 | -- Deal with returning variable length objects and controlled types | |
6256 | ||
6257 | -- Nothing to do if we are returning by reference, or this is not a | |
6258 | -- type that requires special processing (indicated by the fact that | |
6259 | -- it requires a cleanup scope for the secondary stack case). | |
6260 | ||
6261 | if Is_Immutably_Limited_Type (Exptyp) | |
6262 | or else Is_Limited_Interface (Exptyp) | |
6263 | then | |
6264 | null; | |
6265 | ||
6266 | elsif not Requires_Transient_Scope (R_Type) then | |
6267 | ||
6268 | -- Mutable records with no variable length components are not | |
6269 | -- returned on the sec-stack, so we need to make sure that the | |
6270 | -- backend will only copy back the size of the actual value, and not | |
6271 | -- the maximum size. We create an actual subtype for this purpose. | |
6272 | ||
6273 | declare | |
6274 | Ubt : constant Entity_Id := Underlying_Type (Base_Type (Exptyp)); | |
6275 | Decl : Node_Id; | |
6276 | Ent : Entity_Id; | |
6277 | begin | |
6278 | if Has_Discriminants (Ubt) | |
6279 | and then not Is_Constrained (Ubt) | |
6280 | and then not Has_Unchecked_Union (Ubt) | |
6281 | then | |
6282 | Decl := Build_Actual_Subtype (Ubt, Exp); | |
6283 | Ent := Defining_Identifier (Decl); | |
6284 | Insert_Action (Exp, Decl); | |
6285 | Rewrite (Exp, Unchecked_Convert_To (Ent, Exp)); | |
6286 | Analyze_And_Resolve (Exp); | |
6287 | end if; | |
6288 | end; | |
6289 | ||
6290 | -- Here if secondary stack is used | |
6291 | ||
6292 | else | |
6293 | -- Make sure that no surrounding block will reclaim the secondary | |
6294 | -- stack on which we are going to put the result. Not only may this | |
6295 | -- introduce secondary stack leaks but worse, if the reclamation is | |
6296 | -- done too early, then the result we are returning may get | |
6297 | -- clobbered. | |
6298 | ||
6299 | declare | |
6300 | S : Entity_Id; | |
6301 | begin | |
6302 | S := Current_Scope; | |
6303 | while Ekind (S) = E_Block or else Ekind (S) = E_Loop loop | |
6304 | Set_Sec_Stack_Needed_For_Return (S, True); | |
6305 | S := Enclosing_Dynamic_Scope (S); | |
6306 | end loop; | |
6307 | end; | |
6308 | ||
6309 | -- Optimize the case where the result is a function call. In this | |
6310 | -- case either the result is already on the secondary stack, or is | |
6311 | -- already being returned with the stack pointer depressed and no | |
6312 | -- further processing is required except to set the By_Ref flag to | |
6313 | -- ensure that gigi does not attempt an extra unnecessary copy. | |
6314 | -- (actually not just unnecessary but harmfully wrong in the case | |
6315 | -- of a controlled type, where gigi does not know how to do a copy). | |
6316 | -- To make up for a gcc 2.8.1 deficiency (???), we perform | |
6317 | -- the copy for array types if the constrained status of the | |
6318 | -- target type is different from that of the expression. | |
6319 | ||
6320 | if Requires_Transient_Scope (Exptyp) | |
6321 | and then | |
6322 | (not Is_Array_Type (Exptyp) | |
6323 | or else Is_Constrained (Exptyp) = Is_Constrained (R_Type) | |
6324 | or else CW_Or_Has_Controlled_Part (Utyp)) | |
6325 | and then Nkind (Exp) = N_Function_Call | |
6326 | then | |
6327 | Set_By_Ref (N); | |
6328 | ||
6329 | -- Remove side effects from the expression now so that other parts | |
6330 | -- of the expander do not have to reanalyze this node without this | |
6331 | -- optimization | |
6332 | ||
6333 | Rewrite (Exp, Duplicate_Subexpr_No_Checks (Exp)); | |
6334 | ||
6335 | -- For controlled types, do the allocation on the secondary stack | |
6336 | -- manually in order to call adjust at the right time: | |
6337 | ||
6338 | -- type Anon1 is access R_Type; | |
6339 | -- for Anon1'Storage_pool use ss_pool; | |
6340 | -- Anon2 : anon1 := new R_Type'(expr); | |
6341 | -- return Anon2.all; | |
6342 | ||
6343 | -- We do the same for classwide types that are not potentially | |
6344 | -- controlled (by the virtue of restriction No_Finalization) because | |
6345 | -- gigi is not able to properly allocate class-wide types. | |
6346 | ||
6347 | elsif CW_Or_Has_Controlled_Part (Utyp) then | |
6348 | declare | |
6349 | Loc : constant Source_Ptr := Sloc (N); | |
6350 | Acc_Typ : constant Entity_Id := Make_Temporary (Loc, 'A'); | |
6351 | Alloc_Node : Node_Id; | |
6352 | Temp : Entity_Id; | |
6353 | ||
6354 | begin | |
6355 | Set_Ekind (Acc_Typ, E_Access_Type); | |
6356 | ||
6357 | Set_Associated_Storage_Pool (Acc_Typ, RTE (RE_SS_Pool)); | |
6358 | ||
6359 | -- This is an allocator for the secondary stack, and it's fine | |
6360 | -- to have Comes_From_Source set False on it, as gigi knows not | |
6361 | -- to flag it as a violation of No_Implicit_Heap_Allocations. | |
6362 | ||
6363 | Alloc_Node := | |
6364 | Make_Allocator (Loc, | |
6365 | Expression => | |
6366 | Make_Qualified_Expression (Loc, | |
6367 | Subtype_Mark => New_Reference_To (Etype (Exp), Loc), | |
6368 | Expression => Relocate_Node (Exp))); | |
6369 | ||
6370 | -- We do not want discriminant checks on the declaration, | |
6371 | -- given that it gets its value from the allocator. | |
6372 | ||
6373 | Set_No_Initialization (Alloc_Node); | |
6374 | ||
6375 | Temp := Make_Temporary (Loc, 'R', Alloc_Node); | |
6376 | ||
6377 | Insert_List_Before_And_Analyze (N, New_List ( | |
6378 | Make_Full_Type_Declaration (Loc, | |
6379 | Defining_Identifier => Acc_Typ, | |
6380 | Type_Definition => | |
6381 | Make_Access_To_Object_Definition (Loc, | |
6382 | Subtype_Indication => Subtype_Ind)), | |
6383 | ||
6384 | Make_Object_Declaration (Loc, | |
6385 | Defining_Identifier => Temp, | |
6386 | Object_Definition => New_Reference_To (Acc_Typ, Loc), | |
6387 | Expression => Alloc_Node))); | |
6388 | ||
6389 | Rewrite (Exp, | |
6390 | Make_Explicit_Dereference (Loc, | |
6391 | Prefix => New_Reference_To (Temp, Loc))); | |
6392 | ||
6393 | Analyze_And_Resolve (Exp, R_Type); | |
6394 | end; | |
6395 | ||
6396 | -- Otherwise use the gigi mechanism to allocate result on the | |
6397 | -- secondary stack. | |
6398 | ||
6399 | else | |
6400 | Check_Restriction (No_Secondary_Stack, N); | |
6401 | Set_Storage_Pool (N, RTE (RE_SS_Pool)); | |
6402 | ||
6403 | -- If we are generating code for the VM do not use | |
6404 | -- SS_Allocate since everything is heap-allocated anyway. | |
6405 | ||
6406 | if VM_Target = No_VM then | |
6407 | Set_Procedure_To_Call (N, RTE (RE_SS_Allocate)); | |
6408 | end if; | |
6409 | end if; | |
6410 | end if; | |
6411 | ||
6412 | -- Implement the rules of 6.5(8-10), which require a tag check in the | |
6413 | -- case of a limited tagged return type, and tag reassignment for | |
6414 | -- nonlimited tagged results. These actions are needed when the return | |
6415 | -- type is a specific tagged type and the result expression is a | |
6416 | -- conversion or a formal parameter, because in that case the tag of the | |
6417 | -- expression might differ from the tag of the specific result type. | |
6418 | ||
6419 | if Is_Tagged_Type (Utyp) | |
6420 | and then not Is_Class_Wide_Type (Utyp) | |
6421 | and then (Nkind_In (Exp, N_Type_Conversion, | |
6422 | N_Unchecked_Type_Conversion) | |
6423 | or else (Is_Entity_Name (Exp) | |
6424 | and then Ekind (Entity (Exp)) in Formal_Kind)) | |
6425 | then | |
6426 | -- When the return type is limited, perform a check that the | |
6427 | -- tag of the result is the same as the tag of the return type. | |
6428 | ||
6429 | if Is_Limited_Type (R_Type) then | |
6430 | Insert_Action (Exp, | |
6431 | Make_Raise_Constraint_Error (Loc, | |
6432 | Condition => | |
6433 | Make_Op_Ne (Loc, | |
6434 | Left_Opnd => | |
6435 | Make_Selected_Component (Loc, | |
7675ad4f AC |
6436 | Prefix => Duplicate_Subexpr (Exp), |
6437 | Selector_Name => Make_Identifier (Loc, Name_uTag)), | |
2b3d67a5 AC |
6438 | Right_Opnd => |
6439 | Make_Attribute_Reference (Loc, | |
6440 | Prefix => New_Occurrence_Of (Base_Type (Utyp), Loc), | |
6441 | Attribute_Name => Name_Tag)), | |
6442 | Reason => CE_Tag_Check_Failed)); | |
6443 | ||
6444 | -- If the result type is a specific nonlimited tagged type, then we | |
6445 | -- have to ensure that the tag of the result is that of the result | |
6446 | -- type. This is handled by making a copy of the expression in the | |
6447 | -- case where it might have a different tag, namely when the | |
6448 | -- expression is a conversion or a formal parameter. We create a new | |
6449 | -- object of the result type and initialize it from the expression, | |
6450 | -- which will implicitly force the tag to be set appropriately. | |
6451 | ||
6452 | else | |
6453 | declare | |
6454 | ExpR : constant Node_Id := Relocate_Node (Exp); | |
6455 | Result_Id : constant Entity_Id := | |
6456 | Make_Temporary (Loc, 'R', ExpR); | |
6457 | Result_Exp : constant Node_Id := | |
6458 | New_Reference_To (Result_Id, Loc); | |
6459 | Result_Obj : constant Node_Id := | |
6460 | Make_Object_Declaration (Loc, | |
6461 | Defining_Identifier => Result_Id, | |
6462 | Object_Definition => | |
6463 | New_Reference_To (R_Type, Loc), | |
6464 | Constant_Present => True, | |
6465 | Expression => ExpR); | |
6466 | ||
6467 | begin | |
6468 | Set_Assignment_OK (Result_Obj); | |
6469 | Insert_Action (Exp, Result_Obj); | |
6470 | ||
6471 | Rewrite (Exp, Result_Exp); | |
6472 | Analyze_And_Resolve (Exp, R_Type); | |
6473 | end; | |
6474 | end if; | |
6475 | ||
6476 | -- Ada 2005 (AI-344): If the result type is class-wide, then insert | |
6477 | -- a check that the level of the return expression's underlying type | |
6478 | -- is not deeper than the level of the master enclosing the function. | |
6479 | -- Always generate the check when the type of the return expression | |
6480 | -- is class-wide, when it's a type conversion, or when it's a formal | |
6481 | -- parameter. Otherwise, suppress the check in the case where the | |
6482 | -- return expression has a specific type whose level is known not to | |
6483 | -- be statically deeper than the function's result type. | |
6484 | ||
6485 | -- Note: accessibility check is skipped in the VM case, since there | |
6486 | -- does not seem to be any practical way to implement this check. | |
6487 | ||
0791fbe9 | 6488 | elsif Ada_Version >= Ada_2005 |
2b3d67a5 AC |
6489 | and then Tagged_Type_Expansion |
6490 | and then Is_Class_Wide_Type (R_Type) | |
6491 | and then not Scope_Suppress (Accessibility_Check) | |
6492 | and then | |
6493 | (Is_Class_Wide_Type (Etype (Exp)) | |
6494 | or else Nkind_In (Exp, N_Type_Conversion, | |
6495 | N_Unchecked_Type_Conversion) | |
6496 | or else (Is_Entity_Name (Exp) | |
6497 | and then Ekind (Entity (Exp)) in Formal_Kind) | |
6498 | or else Scope_Depth (Enclosing_Dynamic_Scope (Etype (Exp))) > | |
6499 | Scope_Depth (Enclosing_Dynamic_Scope (Scope_Id))) | |
6500 | then | |
6501 | declare | |
6502 | Tag_Node : Node_Id; | |
6503 | ||
6504 | begin | |
6505 | -- Ada 2005 (AI-251): In class-wide interface objects we displace | |
6506 | -- "this" to reference the base of the object --- required to get | |
6507 | -- access to the TSD of the object. | |
6508 | ||
6509 | if Is_Class_Wide_Type (Etype (Exp)) | |
6510 | and then Is_Interface (Etype (Exp)) | |
6511 | and then Nkind (Exp) = N_Explicit_Dereference | |
6512 | then | |
6513 | Tag_Node := | |
6514 | Make_Explicit_Dereference (Loc, | |
6515 | Unchecked_Convert_To (RTE (RE_Tag_Ptr), | |
6516 | Make_Function_Call (Loc, | |
6517 | Name => New_Reference_To (RTE (RE_Base_Address), Loc), | |
6518 | Parameter_Associations => New_List ( | |
6519 | Unchecked_Convert_To (RTE (RE_Address), | |
6520 | Duplicate_Subexpr (Prefix (Exp))))))); | |
6521 | else | |
6522 | Tag_Node := | |
6523 | Make_Attribute_Reference (Loc, | |
6524 | Prefix => Duplicate_Subexpr (Exp), | |
6525 | Attribute_Name => Name_Tag); | |
6526 | end if; | |
6527 | ||
6528 | Insert_Action (Exp, | |
6529 | Make_Raise_Program_Error (Loc, | |
6530 | Condition => | |
6531 | Make_Op_Gt (Loc, | |
6532 | Left_Opnd => | |
6533 | Build_Get_Access_Level (Loc, Tag_Node), | |
6534 | Right_Opnd => | |
6535 | Make_Integer_Literal (Loc, | |
6536 | Scope_Depth (Enclosing_Dynamic_Scope (Scope_Id)))), | |
6537 | Reason => PE_Accessibility_Check_Failed)); | |
6538 | end; | |
6539 | ||
6540 | -- AI05-0073: If function has a controlling access result, check that | |
6541 | -- the tag of the return value, if it is not null, matches designated | |
6542 | -- type of return type. | |
6543 | -- The return expression is referenced twice in the code below, so | |
6544 | -- it must be made free of side effects. Given that different compilers | |
6545 | -- may evaluate these parameters in different order, both occurrences | |
6546 | -- perform a copy. | |
6547 | ||
6548 | elsif Ekind (R_Type) = E_Anonymous_Access_Type | |
6549 | and then Has_Controlling_Result (Scope_Id) | |
6550 | then | |
6551 | Insert_Action (N, | |
6552 | Make_Raise_Constraint_Error (Loc, | |
6553 | Condition => | |
6554 | Make_And_Then (Loc, | |
6555 | Left_Opnd => | |
6556 | Make_Op_Ne (Loc, | |
6557 | Left_Opnd => Duplicate_Subexpr (Exp), | |
6558 | Right_Opnd => Make_Null (Loc)), | |
6559 | Right_Opnd => Make_Op_Ne (Loc, | |
6560 | Left_Opnd => | |
6561 | Make_Selected_Component (Loc, | |
6562 | Prefix => Duplicate_Subexpr (Exp), | |
7675ad4f | 6563 | Selector_Name => Make_Identifier (Loc, Name_uTag)), |
2b3d67a5 AC |
6564 | Right_Opnd => |
6565 | Make_Attribute_Reference (Loc, | |
6566 | Prefix => | |
6567 | New_Occurrence_Of (Designated_Type (R_Type), Loc), | |
6568 | Attribute_Name => Name_Tag))), | |
6569 | Reason => CE_Tag_Check_Failed), | |
6570 | Suppress => All_Checks); | |
6571 | end if; | |
6572 | ||
6573 | -- If we are returning an object that may not be bit-aligned, then copy | |
6574 | -- the value into a temporary first. This copy may need to expand to a | |
6575 | -- loop of component operations. | |
6576 | ||
6577 | if Is_Possibly_Unaligned_Slice (Exp) | |
6578 | or else Is_Possibly_Unaligned_Object (Exp) | |
6579 | then | |
6580 | declare | |
6581 | ExpR : constant Node_Id := Relocate_Node (Exp); | |
6582 | Tnn : constant Entity_Id := Make_Temporary (Loc, 'T', ExpR); | |
6583 | begin | |
6584 | Insert_Action (Exp, | |
6585 | Make_Object_Declaration (Loc, | |
6586 | Defining_Identifier => Tnn, | |
6587 | Constant_Present => True, | |
6588 | Object_Definition => New_Occurrence_Of (R_Type, Loc), | |
6589 | Expression => ExpR), | |
6590 | Suppress => All_Checks); | |
6591 | Rewrite (Exp, New_Occurrence_Of (Tnn, Loc)); | |
6592 | end; | |
6593 | end if; | |
6594 | ||
6595 | -- Generate call to postcondition checks if they are present | |
6596 | ||
6597 | if Ekind (Scope_Id) = E_Function | |
6598 | and then Has_Postconditions (Scope_Id) | |
6599 | then | |
6600 | -- We are going to reference the returned value twice in this case, | |
6601 | -- once in the call to _Postconditions, and once in the actual return | |
6602 | -- statement, but we can't have side effects happening twice, and in | |
6603 | -- any case for efficiency we don't want to do the computation twice. | |
6604 | ||
6605 | -- If the returned expression is an entity name, we don't need to | |
6606 | -- worry since it is efficient and safe to reference it twice, that's | |
6607 | -- also true for literals other than string literals, and for the | |
6608 | -- case of X.all where X is an entity name. | |
6609 | ||
6610 | if Is_Entity_Name (Exp) | |
6611 | or else Nkind_In (Exp, N_Character_Literal, | |
6612 | N_Integer_Literal, | |
6613 | N_Real_Literal) | |
6614 | or else (Nkind (Exp) = N_Explicit_Dereference | |
6615 | and then Is_Entity_Name (Prefix (Exp))) | |
6616 | then | |
6617 | null; | |
6618 | ||
6619 | -- Otherwise we are going to need a temporary to capture the value | |
6620 | ||
6621 | else | |
6622 | declare | |
6623 | ExpR : constant Node_Id := Relocate_Node (Exp); | |
6624 | Tnn : constant Entity_Id := Make_Temporary (Loc, 'T', ExpR); | |
6625 | ||
6626 | begin | |
6627 | -- For a complex expression of an elementary type, capture | |
6628 | -- value in the temporary and use it as the reference. | |
6629 | ||
6630 | if Is_Elementary_Type (R_Type) then | |
6631 | Insert_Action (Exp, | |
6632 | Make_Object_Declaration (Loc, | |
6633 | Defining_Identifier => Tnn, | |
6634 | Constant_Present => True, | |
6635 | Object_Definition => New_Occurrence_Of (R_Type, Loc), | |
6636 | Expression => ExpR), | |
6637 | Suppress => All_Checks); | |
6638 | ||
6639 | Rewrite (Exp, New_Occurrence_Of (Tnn, Loc)); | |
6640 | ||
6641 | -- If we have something we can rename, generate a renaming of | |
6642 | -- the object and replace the expression with a reference | |
6643 | ||
6644 | elsif Is_Object_Reference (Exp) then | |
6645 | Insert_Action (Exp, | |
6646 | Make_Object_Renaming_Declaration (Loc, | |
6647 | Defining_Identifier => Tnn, | |
6648 | Subtype_Mark => New_Occurrence_Of (R_Type, Loc), | |
6649 | Name => ExpR), | |
6650 | Suppress => All_Checks); | |
6651 | ||
6652 | Rewrite (Exp, New_Occurrence_Of (Tnn, Loc)); | |
6653 | ||
6654 | -- Otherwise we have something like a string literal or an | |
6655 | -- aggregate. We could copy the value, but that would be | |
6656 | -- inefficient. Instead we make a reference to the value and | |
6657 | -- capture this reference with a renaming, the expression is | |
6658 | -- then replaced by a dereference of this renaming. | |
6659 | ||
6660 | else | |
6661 | -- For now, copy the value, since the code below does not | |
6662 | -- seem to work correctly ??? | |
6663 | ||
6664 | Insert_Action (Exp, | |
6665 | Make_Object_Declaration (Loc, | |
6666 | Defining_Identifier => Tnn, | |
6667 | Constant_Present => True, | |
6668 | Object_Definition => New_Occurrence_Of (R_Type, Loc), | |
6669 | Expression => Relocate_Node (Exp)), | |
6670 | Suppress => All_Checks); | |
6671 | ||
6672 | Rewrite (Exp, New_Occurrence_Of (Tnn, Loc)); | |
6673 | ||
6674 | -- Insert_Action (Exp, | |
6675 | -- Make_Object_Renaming_Declaration (Loc, | |
6676 | -- Defining_Identifier => Tnn, | |
6677 | -- Access_Definition => | |
6678 | -- Make_Access_Definition (Loc, | |
6679 | -- All_Present => True, | |
6680 | -- Subtype_Mark => New_Occurrence_Of (R_Type, Loc)), | |
6681 | -- Name => | |
6682 | -- Make_Reference (Loc, | |
6683 | -- Prefix => Relocate_Node (Exp))), | |
6684 | -- Suppress => All_Checks); | |
6685 | ||
6686 | -- Rewrite (Exp, | |
6687 | -- Make_Explicit_Dereference (Loc, | |
6688 | -- Prefix => New_Occurrence_Of (Tnn, Loc))); | |
6689 | end if; | |
6690 | end; | |
6691 | end if; | |
6692 | ||
6693 | -- Generate call to _postconditions | |
6694 | ||
6695 | Insert_Action (Exp, | |
6696 | Make_Procedure_Call_Statement (Loc, | |
6697 | Name => Make_Identifier (Loc, Name_uPostconditions), | |
6698 | Parameter_Associations => New_List (Duplicate_Subexpr (Exp)))); | |
6699 | end if; | |
6700 | ||
6701 | -- Ada 2005 (AI-251): If this return statement corresponds with an | |
6702 | -- simple return statement associated with an extended return statement | |
6703 | -- and the type of the returned object is an interface then generate an | |
6704 | -- implicit conversion to force displacement of the "this" pointer. | |
6705 | ||
0791fbe9 | 6706 | if Ada_Version >= Ada_2005 |
2b3d67a5 AC |
6707 | and then Comes_From_Extended_Return_Statement (N) |
6708 | and then Nkind (Expression (N)) = N_Identifier | |
6709 | and then Is_Interface (Utyp) | |
6710 | and then Utyp /= Underlying_Type (Exptyp) | |
6711 | then | |
6712 | Rewrite (Exp, Convert_To (Utyp, Relocate_Node (Exp))); | |
6713 | Analyze_And_Resolve (Exp); | |
6714 | end if; | |
6715 | end Expand_Simple_Function_Return; | |
6716 | ||
02822a92 RD |
6717 | -------------------------------- |
6718 | -- Is_Build_In_Place_Function -- | |
6719 | -------------------------------- | |
70482933 | 6720 | |
02822a92 RD |
6721 | function Is_Build_In_Place_Function (E : Entity_Id) return Boolean is |
6722 | begin | |
5087048c AC |
6723 | -- This function is called from Expand_Subtype_From_Expr during |
6724 | -- semantic analysis, even when expansion is off. In those cases | |
6725 | -- the build_in_place expansion will not take place. | |
b0256cb6 AC |
6726 | |
6727 | if not Expander_Active then | |
6728 | return False; | |
6729 | end if; | |
6730 | ||
02822a92 | 6731 | -- For now we test whether E denotes a function or access-to-function |
f937473f RD |
6732 | -- type whose result subtype is inherently limited. Later this test may |
6733 | -- be revised to allow composite nonlimited types. Functions with a | |
6734 | -- foreign convention or whose result type has a foreign convention | |
02822a92 RD |
6735 | -- never qualify. |
6736 | ||
b29def53 | 6737 | if Ekind_In (E, E_Function, E_Generic_Function) |
02822a92 RD |
6738 | or else (Ekind (E) = E_Subprogram_Type |
6739 | and then Etype (E) /= Standard_Void_Type) | |
6740 | then | |
f937473f RD |
6741 | -- Note: If you have Convention (C) on an inherently limited type, |
6742 | -- you're on your own. That is, the C code will have to be carefully | |
6743 | -- written to know about the Ada conventions. | |
6744 | ||
02822a92 RD |
6745 | if Has_Foreign_Convention (E) |
6746 | or else Has_Foreign_Convention (Etype (E)) | |
3ca505dc | 6747 | then |
02822a92 | 6748 | return False; |
c8ef728f | 6749 | |
2a31c32b AC |
6750 | -- In Ada 2005 all functions with an inherently limited return type |
6751 | -- must be handled using a build-in-place profile, including the case | |
6752 | -- of a function with a limited interface result, where the function | |
6753 | -- may return objects of nonlimited descendants. | |
7888a6ae | 6754 | |
02822a92 | 6755 | else |
40f07b4b | 6756 | return Is_Immutably_Limited_Type (Etype (E)) |
0791fbe9 | 6757 | and then Ada_Version >= Ada_2005 |
f937473f | 6758 | and then not Debug_Flag_Dot_L; |
c8ef728f ES |
6759 | end if; |
6760 | ||
02822a92 RD |
6761 | else |
6762 | return False; | |
6763 | end if; | |
6764 | end Is_Build_In_Place_Function; | |
f4d379b8 | 6765 | |
02822a92 RD |
6766 | ------------------------------------- |
6767 | -- Is_Build_In_Place_Function_Call -- | |
6768 | ------------------------------------- | |
f4d379b8 | 6769 | |
02822a92 RD |
6770 | function Is_Build_In_Place_Function_Call (N : Node_Id) return Boolean is |
6771 | Exp_Node : Node_Id := N; | |
6772 | Function_Id : Entity_Id; | |
f4d379b8 | 6773 | |
02822a92 | 6774 | begin |
19590d70 GD |
6775 | -- Step past qualification or unchecked conversion (the latter can occur |
6776 | -- in cases of calls to 'Input). | |
6777 | ||
ac4d6407 RD |
6778 | if Nkind_In |
6779 | (Exp_Node, N_Qualified_Expression, N_Unchecked_Type_Conversion) | |
19590d70 | 6780 | then |
02822a92 RD |
6781 | Exp_Node := Expression (N); |
6782 | end if; | |
758c442c | 6783 | |
02822a92 RD |
6784 | if Nkind (Exp_Node) /= N_Function_Call then |
6785 | return False; | |
3ca505dc | 6786 | |
02822a92 RD |
6787 | else |
6788 | if Is_Entity_Name (Name (Exp_Node)) then | |
6789 | Function_Id := Entity (Name (Exp_Node)); | |
758c442c | 6790 | |
02822a92 RD |
6791 | elsif Nkind (Name (Exp_Node)) = N_Explicit_Dereference then |
6792 | Function_Id := Etype (Name (Exp_Node)); | |
6793 | end if; | |
758c442c | 6794 | |
02822a92 RD |
6795 | return Is_Build_In_Place_Function (Function_Id); |
6796 | end if; | |
6797 | end Is_Build_In_Place_Function_Call; | |
758c442c | 6798 | |
02822a92 RD |
6799 | ----------------------- |
6800 | -- Freeze_Subprogram -- | |
6801 | ----------------------- | |
758c442c | 6802 | |
02822a92 RD |
6803 | procedure Freeze_Subprogram (N : Node_Id) is |
6804 | Loc : constant Source_Ptr := Sloc (N); | |
3ca505dc | 6805 | |
02822a92 RD |
6806 | procedure Register_Predefined_DT_Entry (Prim : Entity_Id); |
6807 | -- (Ada 2005): Register a predefined primitive in all the secondary | |
6808 | -- dispatch tables of its primitive type. | |
3ca505dc | 6809 | |
f4d379b8 HK |
6810 | ---------------------------------- |
6811 | -- Register_Predefined_DT_Entry -- | |
6812 | ---------------------------------- | |
6813 | ||
6814 | procedure Register_Predefined_DT_Entry (Prim : Entity_Id) is | |
6815 | Iface_DT_Ptr : Elmt_Id; | |
02822a92 | 6816 | Tagged_Typ : Entity_Id; |
f4d379b8 | 6817 | Thunk_Id : Entity_Id; |
7888a6ae | 6818 | Thunk_Code : Node_Id; |
f4d379b8 HK |
6819 | |
6820 | begin | |
02822a92 | 6821 | Tagged_Typ := Find_Dispatching_Type (Prim); |
f4d379b8 | 6822 | |
02822a92 | 6823 | if No (Access_Disp_Table (Tagged_Typ)) |
ce2b6ba5 | 6824 | or else not Has_Interfaces (Tagged_Typ) |
c8ef728f | 6825 | or else not RTE_Available (RE_Interface_Tag) |
f937473f | 6826 | or else Restriction_Active (No_Dispatching_Calls) |
f4d379b8 HK |
6827 | then |
6828 | return; | |
6829 | end if; | |
6830 | ||
1923d2d6 JM |
6831 | -- Skip the first two access-to-dispatch-table pointers since they |
6832 | -- leads to the primary dispatch table (predefined DT and user | |
6833 | -- defined DT). We are only concerned with the secondary dispatch | |
6834 | -- table pointers. Note that the access-to- dispatch-table pointer | |
6835 | -- corresponds to the first implemented interface retrieved below. | |
f4d379b8 | 6836 | |
02822a92 | 6837 | Iface_DT_Ptr := |
1923d2d6 | 6838 | Next_Elmt (Next_Elmt (First_Elmt (Access_Disp_Table (Tagged_Typ)))); |
f937473f | 6839 | |
7888a6ae | 6840 | while Present (Iface_DT_Ptr) |
df3e68b1 | 6841 | and then Ekind (Node (Iface_DT_Ptr)) = E_Constant |
7888a6ae | 6842 | loop |
ac4d6407 | 6843 | pragma Assert (Has_Thunks (Node (Iface_DT_Ptr))); |
d766cee3 | 6844 | Expand_Interface_Thunk (Prim, Thunk_Id, Thunk_Code); |
7888a6ae GD |
6845 | |
6846 | if Present (Thunk_Code) then | |
ac4d6407 | 6847 | Insert_Actions_After (N, New_List ( |
7888a6ae GD |
6848 | Thunk_Code, |
6849 | ||
6850 | Build_Set_Predefined_Prim_Op_Address (Loc, | |
1923d2d6 JM |
6851 | Tag_Node => |
6852 | New_Reference_To (Node (Next_Elmt (Iface_DT_Ptr)), Loc), | |
7888a6ae GD |
6853 | Position => DT_Position (Prim), |
6854 | Address_Node => | |
70f91180 | 6855 | Unchecked_Convert_To (RTE (RE_Prim_Ptr), |
1923d2d6 JM |
6856 | Make_Attribute_Reference (Loc, |
6857 | Prefix => New_Reference_To (Thunk_Id, Loc), | |
6858 | Attribute_Name => Name_Unrestricted_Access))), | |
ac4d6407 RD |
6859 | |
6860 | Build_Set_Predefined_Prim_Op_Address (Loc, | |
1923d2d6 JM |
6861 | Tag_Node => |
6862 | New_Reference_To | |
6863 | (Node (Next_Elmt (Next_Elmt (Next_Elmt (Iface_DT_Ptr)))), | |
6864 | Loc), | |
ac4d6407 RD |
6865 | Position => DT_Position (Prim), |
6866 | Address_Node => | |
70f91180 | 6867 | Unchecked_Convert_To (RTE (RE_Prim_Ptr), |
1923d2d6 JM |
6868 | Make_Attribute_Reference (Loc, |
6869 | Prefix => New_Reference_To (Prim, Loc), | |
6870 | Attribute_Name => Name_Unrestricted_Access))))); | |
7888a6ae | 6871 | end if; |
f4d379b8 | 6872 | |
1923d2d6 JM |
6873 | -- Skip the tag of the predefined primitives dispatch table |
6874 | ||
6875 | Next_Elmt (Iface_DT_Ptr); | |
6876 | pragma Assert (Has_Thunks (Node (Iface_DT_Ptr))); | |
6877 | ||
6878 | -- Skip the tag of the no-thunks dispatch table | |
6879 | ||
6880 | Next_Elmt (Iface_DT_Ptr); | |
6881 | pragma Assert (not Has_Thunks (Node (Iface_DT_Ptr))); | |
6882 | ||
6883 | -- Skip the tag of the predefined primitives no-thunks dispatch | |
df3e68b1 | 6884 | -- table. |
1923d2d6 | 6885 | |
ac4d6407 RD |
6886 | Next_Elmt (Iface_DT_Ptr); |
6887 | pragma Assert (not Has_Thunks (Node (Iface_DT_Ptr))); | |
6888 | ||
f4d379b8 | 6889 | Next_Elmt (Iface_DT_Ptr); |
f4d379b8 HK |
6890 | end loop; |
6891 | end Register_Predefined_DT_Entry; | |
6892 | ||
7888a6ae | 6893 | -- Local variables |
3ca505dc | 6894 | |
df3e68b1 | 6895 | Subp : constant Entity_Id := Entity (N); |
3ca505dc | 6896 | |
ac4d6407 RD |
6897 | -- Start of processing for Freeze_Subprogram |
6898 | ||
7888a6ae | 6899 | begin |
d766cee3 RD |
6900 | -- We suppress the initialization of the dispatch table entry when |
6901 | -- VM_Target because the dispatching mechanism is handled internally | |
6902 | -- by the VM. | |
6903 | ||
6904 | if Is_Dispatching_Operation (Subp) | |
6905 | and then not Is_Abstract_Subprogram (Subp) | |
6906 | and then Present (DTC_Entity (Subp)) | |
6907 | and then Present (Scope (DTC_Entity (Subp))) | |
1f110335 | 6908 | and then Tagged_Type_Expansion |
d766cee3 RD |
6909 | and then not Restriction_Active (No_Dispatching_Calls) |
6910 | and then RTE_Available (RE_Tag) | |
6911 | then | |
7888a6ae | 6912 | declare |
d766cee3 | 6913 | Typ : constant Entity_Id := Scope (DTC_Entity (Subp)); |
c8ef728f | 6914 | |
7888a6ae | 6915 | begin |
8fc789c8 | 6916 | -- Handle private overridden primitives |
c8ef728f | 6917 | |
d766cee3 RD |
6918 | if not Is_CPP_Class (Typ) then |
6919 | Check_Overriding_Operation (Subp); | |
7888a6ae | 6920 | end if; |
c8ef728f | 6921 | |
d766cee3 RD |
6922 | -- We assume that imported CPP primitives correspond with objects |
6923 | -- whose constructor is in the CPP side; therefore we don't need | |
6924 | -- to generate code to register them in the dispatch table. | |
c8ef728f | 6925 | |
d766cee3 RD |
6926 | if Is_CPP_Class (Typ) then |
6927 | null; | |
3ca505dc | 6928 | |
d766cee3 RD |
6929 | -- Handle CPP primitives found in derivations of CPP_Class types. |
6930 | -- These primitives must have been inherited from some parent, and | |
6931 | -- there is no need to register them in the dispatch table because | |
6932 | -- Build_Inherit_Prims takes care of the initialization of these | |
6933 | -- slots. | |
3ca505dc | 6934 | |
d766cee3 RD |
6935 | elsif Is_Imported (Subp) |
6936 | and then (Convention (Subp) = Convention_CPP | |
6937 | or else Convention (Subp) = Convention_C) | |
6938 | then | |
6939 | null; | |
6940 | ||
6941 | -- Generate code to register the primitive in non statically | |
6942 | -- allocated dispatch tables | |
6943 | ||
bfae1846 AC |
6944 | elsif not Building_Static_DT (Scope (DTC_Entity (Subp))) then |
6945 | ||
d766cee3 RD |
6946 | -- When a primitive is frozen, enter its name in its dispatch |
6947 | -- table slot. | |
f4d379b8 | 6948 | |
d766cee3 | 6949 | if not Is_Interface (Typ) |
ce2b6ba5 | 6950 | or else Present (Interface_Alias (Subp)) |
d766cee3 RD |
6951 | then |
6952 | if Is_Predefined_Dispatching_Operation (Subp) then | |
6953 | Register_Predefined_DT_Entry (Subp); | |
7888a6ae | 6954 | end if; |
d766cee3 | 6955 | |
991395ab AC |
6956 | Insert_Actions_After (N, |
6957 | Register_Primitive (Loc, Prim => Subp)); | |
7888a6ae GD |
6958 | end if; |
6959 | end if; | |
6960 | end; | |
70482933 RK |
6961 | end if; |
6962 | ||
7888a6ae GD |
6963 | -- Mark functions that return by reference. Note that it cannot be part |
6964 | -- of the normal semantic analysis of the spec since the underlying | |
6965 | -- returned type may not be known yet (for private types). | |
70482933 | 6966 | |
d766cee3 RD |
6967 | declare |
6968 | Typ : constant Entity_Id := Etype (Subp); | |
6969 | Utyp : constant Entity_Id := Underlying_Type (Typ); | |
6970 | begin | |
40f07b4b | 6971 | if Is_Immutably_Limited_Type (Typ) then |
d766cee3 | 6972 | Set_Returns_By_Ref (Subp); |
048e5cef | 6973 | elsif Present (Utyp) and then CW_Or_Has_Controlled_Part (Utyp) then |
d766cee3 RD |
6974 | Set_Returns_By_Ref (Subp); |
6975 | end if; | |
6976 | end; | |
70482933 RK |
6977 | end Freeze_Subprogram; |
6978 | ||
8dbf3473 AC |
6979 | ----------------------- |
6980 | -- Is_Null_Procedure -- | |
6981 | ----------------------- | |
6982 | ||
6983 | function Is_Null_Procedure (Subp : Entity_Id) return Boolean is | |
6984 | Decl : constant Node_Id := Unit_Declaration_Node (Subp); | |
6985 | ||
6986 | begin | |
6987 | if Ekind (Subp) /= E_Procedure then | |
6988 | return False; | |
6989 | ||
6990 | -- Check if this is a declared null procedure | |
6991 | ||
6992 | elsif Nkind (Decl) = N_Subprogram_Declaration then | |
e1f3cb58 AC |
6993 | if not Null_Present (Specification (Decl)) then |
6994 | return False; | |
8dbf3473 AC |
6995 | |
6996 | elsif No (Body_To_Inline (Decl)) then | |
6997 | return False; | |
6998 | ||
6999 | -- Check if the body contains only a null statement, followed by | |
7000 | -- the return statement added during expansion. | |
7001 | ||
7002 | else | |
7003 | declare | |
7004 | Orig_Bod : constant Node_Id := Body_To_Inline (Decl); | |
7005 | ||
7006 | Stat : Node_Id; | |
7007 | Stat2 : Node_Id; | |
7008 | ||
7009 | begin | |
7010 | if Nkind (Orig_Bod) /= N_Subprogram_Body then | |
7011 | return False; | |
7012 | else | |
327503f1 JM |
7013 | -- We must skip SCIL nodes because they are currently |
7014 | -- implemented as special N_Null_Statement nodes. | |
7015 | ||
8dbf3473 | 7016 | Stat := |
327503f1 | 7017 | First_Non_SCIL_Node |
8dbf3473 | 7018 | (Statements (Handled_Statement_Sequence (Orig_Bod))); |
327503f1 | 7019 | Stat2 := Next_Non_SCIL_Node (Stat); |
8dbf3473 AC |
7020 | |
7021 | return | |
e1f3cb58 AC |
7022 | Is_Empty_List (Declarations (Orig_Bod)) |
7023 | and then Nkind (Stat) = N_Null_Statement | |
7024 | and then | |
8dbf3473 AC |
7025 | (No (Stat2) |
7026 | or else | |
7027 | (Nkind (Stat2) = N_Simple_Return_Statement | |
7028 | and then No (Next (Stat2)))); | |
7029 | end if; | |
7030 | end; | |
7031 | end if; | |
7032 | ||
7033 | else | |
7034 | return False; | |
7035 | end if; | |
7036 | end Is_Null_Procedure; | |
7037 | ||
02822a92 RD |
7038 | ------------------------------------------- |
7039 | -- Make_Build_In_Place_Call_In_Allocator -- | |
7040 | ------------------------------------------- | |
7041 | ||
7042 | procedure Make_Build_In_Place_Call_In_Allocator | |
7043 | (Allocator : Node_Id; | |
7044 | Function_Call : Node_Id) | |
7045 | is | |
7046 | Loc : Source_Ptr; | |
7047 | Func_Call : Node_Id := Function_Call; | |
7048 | Function_Id : Entity_Id; | |
7049 | Result_Subt : Entity_Id; | |
7050 | Acc_Type : constant Entity_Id := Etype (Allocator); | |
7051 | New_Allocator : Node_Id; | |
7052 | Return_Obj_Access : Entity_Id; | |
7053 | ||
7054 | begin | |
19590d70 GD |
7055 | -- Step past qualification or unchecked conversion (the latter can occur |
7056 | -- in cases of calls to 'Input). | |
7057 | ||
ac4d6407 RD |
7058 | if Nkind_In (Func_Call, |
7059 | N_Qualified_Expression, | |
7060 | N_Unchecked_Type_Conversion) | |
19590d70 | 7061 | then |
02822a92 RD |
7062 | Func_Call := Expression (Func_Call); |
7063 | end if; | |
7064 | ||
fdce4bb7 JM |
7065 | -- If the call has already been processed to add build-in-place actuals |
7066 | -- then return. This should not normally occur in an allocator context, | |
7067 | -- but we add the protection as a defensive measure. | |
7068 | ||
7069 | if Is_Expanded_Build_In_Place_Call (Func_Call) then | |
7070 | return; | |
7071 | end if; | |
7072 | ||
7073 | -- Mark the call as processed as a build-in-place call | |
7074 | ||
7075 | Set_Is_Expanded_Build_In_Place_Call (Func_Call); | |
7076 | ||
02822a92 RD |
7077 | Loc := Sloc (Function_Call); |
7078 | ||
7079 | if Is_Entity_Name (Name (Func_Call)) then | |
7080 | Function_Id := Entity (Name (Func_Call)); | |
7081 | ||
7082 | elsif Nkind (Name (Func_Call)) = N_Explicit_Dereference then | |
7083 | Function_Id := Etype (Name (Func_Call)); | |
7084 | ||
7085 | else | |
7086 | raise Program_Error; | |
7087 | end if; | |
7088 | ||
7089 | Result_Subt := Etype (Function_Id); | |
7090 | ||
f937473f RD |
7091 | -- When the result subtype is constrained, the return object must be |
7092 | -- allocated on the caller side, and access to it is passed to the | |
7093 | -- function. | |
02822a92 | 7094 | |
7888a6ae GD |
7095 | -- Here and in related routines, we must examine the full view of the |
7096 | -- type, because the view at the point of call may differ from that | |
7097 | -- that in the function body, and the expansion mechanism depends on | |
7098 | -- the characteristics of the full view. | |
7099 | ||
7100 | if Is_Constrained (Underlying_Type (Result_Subt)) then | |
02822a92 | 7101 | |
f937473f RD |
7102 | -- Replace the initialized allocator of form "new T'(Func (...))" |
7103 | -- with an uninitialized allocator of form "new T", where T is the | |
7104 | -- result subtype of the called function. The call to the function | |
7105 | -- is handled separately further below. | |
02822a92 | 7106 | |
f937473f | 7107 | New_Allocator := |
fad0600d AC |
7108 | Make_Allocator (Loc, |
7109 | Expression => New_Reference_To (Result_Subt, Loc)); | |
7110 | Set_No_Initialization (New_Allocator); | |
7111 | ||
7112 | -- Copy attributes to new allocator. Note that the new allocator | |
7113 | -- logically comes from source if the original one did, so copy the | |
7114 | -- relevant flag. This ensures proper treatment of the restriction | |
7115 | -- No_Implicit_Heap_Allocations in this case. | |
02822a92 | 7116 | |
fad0600d | 7117 | Set_Storage_Pool (New_Allocator, Storage_Pool (Allocator)); |
f937473f | 7118 | Set_Procedure_To_Call (New_Allocator, Procedure_To_Call (Allocator)); |
fad0600d | 7119 | Set_Comes_From_Source (New_Allocator, Comes_From_Source (Allocator)); |
02822a92 | 7120 | |
f937473f | 7121 | Rewrite (Allocator, New_Allocator); |
02822a92 | 7122 | |
f937473f | 7123 | -- Create a new access object and initialize it to the result of the |
b0b7b57d | 7124 | -- new uninitialized allocator. Note: we do not use Allocator as the |
f104fca1 AC |
7125 | -- Related_Node of Return_Obj_Access in call to Make_Temporary below |
7126 | -- as this would create a sort of infinite "recursion". | |
02822a92 | 7127 | |
f104fca1 | 7128 | Return_Obj_Access := Make_Temporary (Loc, 'R'); |
f937473f RD |
7129 | Set_Etype (Return_Obj_Access, Acc_Type); |
7130 | ||
7131 | Insert_Action (Allocator, | |
7132 | Make_Object_Declaration (Loc, | |
7133 | Defining_Identifier => Return_Obj_Access, | |
7134 | Object_Definition => New_Reference_To (Acc_Type, Loc), | |
7135 | Expression => Relocate_Node (Allocator))); | |
7136 | ||
7888a6ae GD |
7137 | -- When the function has a controlling result, an allocation-form |
7138 | -- parameter must be passed indicating that the caller is allocating | |
7139 | -- the result object. This is needed because such a function can be | |
7140 | -- called as a dispatching operation and must be treated similarly | |
7141 | -- to functions with unconstrained result subtypes. | |
7142 | ||
7143 | Add_Alloc_Form_Actual_To_Build_In_Place_Call | |
7144 | (Func_Call, Function_Id, Alloc_Form => Caller_Allocation); | |
7145 | ||
df3e68b1 | 7146 | Add_Collection_Actual_To_Build_In_Place_Call |
7888a6ae GD |
7147 | (Func_Call, Function_Id, Acc_Type); |
7148 | ||
7149 | Add_Task_Actuals_To_Build_In_Place_Call | |
7150 | (Func_Call, Function_Id, Master_Actual => Master_Id (Acc_Type)); | |
7151 | ||
f937473f RD |
7152 | -- Add an implicit actual to the function call that provides access |
7153 | -- to the allocated object. An unchecked conversion to the (specific) | |
7154 | -- result subtype of the function is inserted to handle cases where | |
7155 | -- the access type of the allocator has a class-wide designated type. | |
7156 | ||
f937473f RD |
7157 | Add_Access_Actual_To_Build_In_Place_Call |
7158 | (Func_Call, | |
7159 | Function_Id, | |
7160 | Make_Unchecked_Type_Conversion (Loc, | |
7161 | Subtype_Mark => New_Reference_To (Result_Subt, Loc), | |
7162 | Expression => | |
7163 | Make_Explicit_Dereference (Loc, | |
7164 | Prefix => New_Reference_To (Return_Obj_Access, Loc)))); | |
7165 | ||
7166 | -- When the result subtype is unconstrained, the function itself must | |
7167 | -- perform the allocation of the return object, so we pass parameters | |
7168 | -- indicating that. We don't yet handle the case where the allocation | |
7169 | -- must be done in a user-defined storage pool, which will require | |
7170 | -- passing another actual or two to provide allocation/deallocation | |
7171 | -- operations. ??? | |
7172 | ||
7173 | else | |
7174 | -- Pass an allocation parameter indicating that the function should | |
7175 | -- allocate its result on the heap. | |
7176 | ||
7177 | Add_Alloc_Form_Actual_To_Build_In_Place_Call | |
7178 | (Func_Call, Function_Id, Alloc_Form => Global_Heap); | |
7179 | ||
df3e68b1 | 7180 | Add_Collection_Actual_To_Build_In_Place_Call |
7888a6ae | 7181 | (Func_Call, Function_Id, Acc_Type); |
f937473f | 7182 | |
f937473f RD |
7183 | Add_Task_Actuals_To_Build_In_Place_Call |
7184 | (Func_Call, Function_Id, Master_Actual => Master_Id (Acc_Type)); | |
7888a6ae GD |
7185 | |
7186 | -- The caller does not provide the return object in this case, so we | |
7187 | -- have to pass null for the object access actual. | |
7188 | ||
f937473f RD |
7189 | Add_Access_Actual_To_Build_In_Place_Call |
7190 | (Func_Call, Function_Id, Return_Object => Empty); | |
7191 | end if; | |
02822a92 | 7192 | |
df3e68b1 HK |
7193 | -- If the build-in-place function call returns a controlled object, the |
7194 | -- finalization collection will require a reference to routine Finalize_ | |
7195 | -- Address of the designated type. Setting this attribute is done in the | |
7196 | -- same manner to expansion of allocators. | |
7197 | ||
7198 | if Needs_Finalization (Result_Subt) then | |
7199 | ||
7200 | -- Controlled types with supressed finalization do not need to | |
7201 | -- associate the address of their Finalize_Address primitives with a | |
7202 | -- collection since they do not need a collection to begin with. | |
7203 | ||
7204 | if Is_Library_Level_Entity (Acc_Type) | |
7205 | and then Finalize_Storage_Only (Result_Subt) | |
7206 | then | |
7207 | null; | |
7208 | ||
7209 | else | |
7210 | Insert_Action (Allocator, | |
7211 | Make_Set_Finalize_Address_Ptr_Call (Loc, | |
7212 | Typ => Etype (Function_Id), | |
7213 | Ptr_Typ => Acc_Type)); | |
7214 | end if; | |
7215 | end if; | |
7216 | ||
02822a92 RD |
7217 | -- Finally, replace the allocator node with a reference to the result |
7218 | -- of the function call itself (which will effectively be an access | |
7219 | -- to the object created by the allocator). | |
7220 | ||
7221 | Rewrite (Allocator, Make_Reference (Loc, Relocate_Node (Function_Call))); | |
7222 | Analyze_And_Resolve (Allocator, Acc_Type); | |
7223 | end Make_Build_In_Place_Call_In_Allocator; | |
7224 | ||
7225 | --------------------------------------------------- | |
7226 | -- Make_Build_In_Place_Call_In_Anonymous_Context -- | |
7227 | --------------------------------------------------- | |
7228 | ||
7229 | procedure Make_Build_In_Place_Call_In_Anonymous_Context | |
7230 | (Function_Call : Node_Id) | |
7231 | is | |
7232 | Loc : Source_Ptr; | |
7233 | Func_Call : Node_Id := Function_Call; | |
7234 | Function_Id : Entity_Id; | |
7235 | Result_Subt : Entity_Id; | |
7236 | Return_Obj_Id : Entity_Id; | |
7237 | Return_Obj_Decl : Entity_Id; | |
7238 | ||
7239 | begin | |
19590d70 GD |
7240 | -- Step past qualification or unchecked conversion (the latter can occur |
7241 | -- in cases of calls to 'Input). | |
7242 | ||
ac4d6407 RD |
7243 | if Nkind_In (Func_Call, N_Qualified_Expression, |
7244 | N_Unchecked_Type_Conversion) | |
19590d70 | 7245 | then |
02822a92 RD |
7246 | Func_Call := Expression (Func_Call); |
7247 | end if; | |
7248 | ||
fdce4bb7 JM |
7249 | -- If the call has already been processed to add build-in-place actuals |
7250 | -- then return. One place this can occur is for calls to build-in-place | |
7251 | -- functions that occur within a call to a protected operation, where | |
7252 | -- due to rewriting and expansion of the protected call there can be | |
7253 | -- more than one call to Expand_Actuals for the same set of actuals. | |
7254 | ||
7255 | if Is_Expanded_Build_In_Place_Call (Func_Call) then | |
7256 | return; | |
7257 | end if; | |
7258 | ||
7259 | -- Mark the call as processed as a build-in-place call | |
7260 | ||
7261 | Set_Is_Expanded_Build_In_Place_Call (Func_Call); | |
7262 | ||
02822a92 RD |
7263 | Loc := Sloc (Function_Call); |
7264 | ||
7265 | if Is_Entity_Name (Name (Func_Call)) then | |
7266 | Function_Id := Entity (Name (Func_Call)); | |
7267 | ||
7268 | elsif Nkind (Name (Func_Call)) = N_Explicit_Dereference then | |
7269 | Function_Id := Etype (Name (Func_Call)); | |
7270 | ||
7271 | else | |
7272 | raise Program_Error; | |
7273 | end if; | |
7274 | ||
7275 | Result_Subt := Etype (Function_Id); | |
7276 | ||
df3e68b1 HK |
7277 | -- If the build-in-place function returns a controlled object, then the |
7278 | -- object needs to be finalized immediately after the context. Since | |
7279 | -- this case produces a transient scope, the servicing finalizer needs | |
7280 | -- to name the returned object. Create a temporary which is initialized | |
7281 | -- with the function call: | |
7282 | -- | |
7283 | -- Temp_Id : Func_Type := BIP_Func_Call; | |
7284 | -- | |
7285 | -- The initialization expression of the temporary will be rewritten by | |
7286 | -- the expander using the appropriate mechanism in Make_Build_In_Place_ | |
7287 | -- Call_In_Object_Declaration. | |
7288 | ||
7289 | if Needs_Finalization (Result_Subt) then | |
7290 | declare | |
7291 | Temp_Id : constant Entity_Id := Make_Temporary (Loc, 'R'); | |
7292 | Temp_Decl : Node_Id; | |
7293 | ||
7294 | begin | |
7295 | -- Reset the guard on the function call since the following does | |
7296 | -- not perform actual call expansion. | |
7297 | ||
7298 | Set_Is_Expanded_Build_In_Place_Call (Func_Call, False); | |
7299 | ||
7300 | Temp_Decl := | |
7301 | Make_Object_Declaration (Loc, | |
7302 | Defining_Identifier => Temp_Id, | |
7303 | Object_Definition => | |
7304 | New_Reference_To (Result_Subt, Loc), | |
7305 | Expression => | |
7306 | New_Copy_Tree (Function_Call)); | |
7307 | ||
7308 | Insert_Action (Function_Call, Temp_Decl); | |
7309 | ||
7310 | Rewrite (Function_Call, New_Reference_To (Temp_Id, Loc)); | |
7311 | Analyze (Function_Call); | |
7312 | end; | |
7313 | ||
f937473f RD |
7314 | -- When the result subtype is constrained, an object of the subtype is |
7315 | -- declared and an access value designating it is passed as an actual. | |
02822a92 | 7316 | |
df3e68b1 | 7317 | elsif Is_Constrained (Underlying_Type (Result_Subt)) then |
02822a92 | 7318 | |
f937473f RD |
7319 | -- Create a temporary object to hold the function result |
7320 | ||
c12beea0 | 7321 | Return_Obj_Id := Make_Temporary (Loc, 'R'); |
f937473f | 7322 | Set_Etype (Return_Obj_Id, Result_Subt); |
02822a92 | 7323 | |
f937473f RD |
7324 | Return_Obj_Decl := |
7325 | Make_Object_Declaration (Loc, | |
7326 | Defining_Identifier => Return_Obj_Id, | |
7327 | Aliased_Present => True, | |
7328 | Object_Definition => New_Reference_To (Result_Subt, Loc)); | |
02822a92 | 7329 | |
f937473f | 7330 | Set_No_Initialization (Return_Obj_Decl); |
02822a92 | 7331 | |
f937473f | 7332 | Insert_Action (Func_Call, Return_Obj_Decl); |
02822a92 | 7333 | |
7888a6ae GD |
7334 | -- When the function has a controlling result, an allocation-form |
7335 | -- parameter must be passed indicating that the caller is allocating | |
7336 | -- the result object. This is needed because such a function can be | |
7337 | -- called as a dispatching operation and must be treated similarly | |
7338 | -- to functions with unconstrained result subtypes. | |
7339 | ||
7340 | Add_Alloc_Form_Actual_To_Build_In_Place_Call | |
7341 | (Func_Call, Function_Id, Alloc_Form => Caller_Allocation); | |
7342 | ||
df3e68b1 HK |
7343 | Add_Collection_Actual_To_Build_In_Place_Call |
7344 | (Func_Call, Function_Id); | |
f937473f | 7345 | |
f937473f RD |
7346 | Add_Task_Actuals_To_Build_In_Place_Call |
7347 | (Func_Call, Function_Id, Make_Identifier (Loc, Name_uMaster)); | |
7888a6ae GD |
7348 | |
7349 | -- Add an implicit actual to the function call that provides access | |
7350 | -- to the caller's return object. | |
7351 | ||
f937473f RD |
7352 | Add_Access_Actual_To_Build_In_Place_Call |
7353 | (Func_Call, Function_Id, New_Reference_To (Return_Obj_Id, Loc)); | |
7354 | ||
7355 | -- When the result subtype is unconstrained, the function must allocate | |
7356 | -- the return object in the secondary stack, so appropriate implicit | |
7357 | -- parameters are added to the call to indicate that. A transient | |
7358 | -- scope is established to ensure eventual cleanup of the result. | |
7359 | ||
7360 | else | |
7361 | -- Pass an allocation parameter indicating that the function should | |
7362 | -- allocate its result on the secondary stack. | |
7363 | ||
7364 | Add_Alloc_Form_Actual_To_Build_In_Place_Call | |
7365 | (Func_Call, Function_Id, Alloc_Form => Secondary_Stack); | |
7366 | ||
df3e68b1 HK |
7367 | Add_Collection_Actual_To_Build_In_Place_Call |
7368 | (Func_Call, Function_Id); | |
f937473f | 7369 | |
f937473f RD |
7370 | Add_Task_Actuals_To_Build_In_Place_Call |
7371 | (Func_Call, Function_Id, Make_Identifier (Loc, Name_uMaster)); | |
7888a6ae GD |
7372 | |
7373 | -- Pass a null value to the function since no return object is | |
7374 | -- available on the caller side. | |
7375 | ||
f937473f RD |
7376 | Add_Access_Actual_To_Build_In_Place_Call |
7377 | (Func_Call, Function_Id, Empty); | |
f937473f | 7378 | end if; |
02822a92 RD |
7379 | end Make_Build_In_Place_Call_In_Anonymous_Context; |
7380 | ||
ce2798e8 | 7381 | -------------------------------------------- |
02822a92 | 7382 | -- Make_Build_In_Place_Call_In_Assignment -- |
ce2798e8 | 7383 | -------------------------------------------- |
02822a92 RD |
7384 | |
7385 | procedure Make_Build_In_Place_Call_In_Assignment | |
7386 | (Assign : Node_Id; | |
7387 | Function_Call : Node_Id) | |
7388 | is | |
3a69b5ff AC |
7389 | Lhs : constant Node_Id := Name (Assign); |
7390 | Func_Call : Node_Id := Function_Call; | |
7391 | Func_Id : Entity_Id; | |
7392 | Loc : Source_Ptr; | |
7393 | Obj_Decl : Node_Id; | |
7394 | Obj_Id : Entity_Id; | |
7395 | Ptr_Typ : Entity_Id; | |
7396 | Ptr_Typ_Decl : Node_Id; | |
7397 | Result_Subt : Entity_Id; | |
7398 | Target : Node_Id; | |
02822a92 RD |
7399 | |
7400 | begin | |
19590d70 GD |
7401 | -- Step past qualification or unchecked conversion (the latter can occur |
7402 | -- in cases of calls to 'Input). | |
7403 | ||
ac4d6407 RD |
7404 | if Nkind_In (Func_Call, N_Qualified_Expression, |
7405 | N_Unchecked_Type_Conversion) | |
19590d70 | 7406 | then |
02822a92 RD |
7407 | Func_Call := Expression (Func_Call); |
7408 | end if; | |
7409 | ||
fdce4bb7 JM |
7410 | -- If the call has already been processed to add build-in-place actuals |
7411 | -- then return. This should not normally occur in an assignment context, | |
7412 | -- but we add the protection as a defensive measure. | |
7413 | ||
7414 | if Is_Expanded_Build_In_Place_Call (Func_Call) then | |
7415 | return; | |
7416 | end if; | |
7417 | ||
7418 | -- Mark the call as processed as a build-in-place call | |
7419 | ||
7420 | Set_Is_Expanded_Build_In_Place_Call (Func_Call); | |
7421 | ||
02822a92 RD |
7422 | Loc := Sloc (Function_Call); |
7423 | ||
7424 | if Is_Entity_Name (Name (Func_Call)) then | |
3a69b5ff | 7425 | Func_Id := Entity (Name (Func_Call)); |
02822a92 RD |
7426 | |
7427 | elsif Nkind (Name (Func_Call)) = N_Explicit_Dereference then | |
3a69b5ff | 7428 | Func_Id := Etype (Name (Func_Call)); |
02822a92 RD |
7429 | |
7430 | else | |
7431 | raise Program_Error; | |
7432 | end if; | |
7433 | ||
3a69b5ff | 7434 | Result_Subt := Etype (Func_Id); |
02822a92 | 7435 | |
f937473f RD |
7436 | -- When the result subtype is unconstrained, an additional actual must |
7437 | -- be passed to indicate that the caller is providing the return object. | |
7888a6ae GD |
7438 | -- This parameter must also be passed when the called function has a |
7439 | -- controlling result, because dispatching calls to the function needs | |
7440 | -- to be treated effectively the same as calls to class-wide functions. | |
f937473f | 7441 | |
7888a6ae | 7442 | Add_Alloc_Form_Actual_To_Build_In_Place_Call |
3a69b5ff | 7443 | (Func_Call, Func_Id, Alloc_Form => Caller_Allocation); |
f937473f | 7444 | |
df3e68b1 HK |
7445 | Add_Collection_Actual_To_Build_In_Place_Call |
7446 | (Func_Call, Func_Id); | |
02822a92 | 7447 | |
f937473f | 7448 | Add_Task_Actuals_To_Build_In_Place_Call |
3a69b5ff | 7449 | (Func_Call, Func_Id, Make_Identifier (Loc, Name_uMaster)); |
7888a6ae GD |
7450 | |
7451 | -- Add an implicit actual to the function call that provides access to | |
7452 | -- the caller's return object. | |
7453 | ||
02822a92 RD |
7454 | Add_Access_Actual_To_Build_In_Place_Call |
7455 | (Func_Call, | |
3a69b5ff | 7456 | Func_Id, |
02822a92 RD |
7457 | Make_Unchecked_Type_Conversion (Loc, |
7458 | Subtype_Mark => New_Reference_To (Result_Subt, Loc), | |
7459 | Expression => Relocate_Node (Lhs))); | |
7460 | ||
7461 | -- Create an access type designating the function's result subtype | |
7462 | ||
c12beea0 | 7463 | Ptr_Typ := Make_Temporary (Loc, 'A'); |
02822a92 RD |
7464 | |
7465 | Ptr_Typ_Decl := | |
7466 | Make_Full_Type_Declaration (Loc, | |
3a69b5ff | 7467 | Defining_Identifier => Ptr_Typ, |
02822a92 RD |
7468 | Type_Definition => |
7469 | Make_Access_To_Object_Definition (Loc, | |
7470 | All_Present => True, | |
7471 | Subtype_Indication => | |
7472 | New_Reference_To (Result_Subt, Loc))); | |
02822a92 RD |
7473 | Insert_After_And_Analyze (Assign, Ptr_Typ_Decl); |
7474 | ||
7475 | -- Finally, create an access object initialized to a reference to the | |
7476 | -- function call. | |
7477 | ||
c12beea0 | 7478 | Obj_Id := Make_Temporary (Loc, 'R'); |
3a69b5ff | 7479 | Set_Etype (Obj_Id, Ptr_Typ); |
02822a92 | 7480 | |
3a69b5ff | 7481 | Obj_Decl := |
02822a92 | 7482 | Make_Object_Declaration (Loc, |
3a69b5ff AC |
7483 | Defining_Identifier => Obj_Id, |
7484 | Object_Definition => | |
7485 | New_Reference_To (Ptr_Typ, Loc), | |
7486 | Expression => | |
7487 | Make_Reference (Loc, | |
7488 | Prefix => Relocate_Node (Func_Call))); | |
7489 | Insert_After_And_Analyze (Ptr_Typ_Decl, Obj_Decl); | |
02822a92 RD |
7490 | |
7491 | Rewrite (Assign, Make_Null_Statement (Loc)); | |
3a69b5ff AC |
7492 | |
7493 | -- Retrieve the target of the assignment | |
7494 | ||
7495 | if Nkind (Lhs) = N_Selected_Component then | |
7496 | Target := Selector_Name (Lhs); | |
7497 | elsif Nkind (Lhs) = N_Type_Conversion then | |
7498 | Target := Expression (Lhs); | |
7499 | else | |
7500 | Target := Lhs; | |
7501 | end if; | |
7502 | ||
7503 | -- If we are assigning to a return object or this is an expression of | |
7504 | -- an extension aggregate, the target should either be an identifier | |
7505 | -- or a simple expression. All other cases imply a different scenario. | |
7506 | ||
7507 | if Nkind (Target) in N_Has_Entity then | |
7508 | Target := Entity (Target); | |
7509 | else | |
7510 | return; | |
7511 | end if; | |
02822a92 RD |
7512 | end Make_Build_In_Place_Call_In_Assignment; |
7513 | ||
7514 | ---------------------------------------------------- | |
7515 | -- Make_Build_In_Place_Call_In_Object_Declaration -- | |
7516 | ---------------------------------------------------- | |
7517 | ||
7518 | procedure Make_Build_In_Place_Call_In_Object_Declaration | |
7519 | (Object_Decl : Node_Id; | |
7520 | Function_Call : Node_Id) | |
7521 | is | |
f937473f RD |
7522 | Loc : Source_Ptr; |
7523 | Obj_Def_Id : constant Entity_Id := | |
7524 | Defining_Identifier (Object_Decl); | |
7888a6ae | 7525 | |
f937473f RD |
7526 | Func_Call : Node_Id := Function_Call; |
7527 | Function_Id : Entity_Id; | |
7528 | Result_Subt : Entity_Id; | |
7529 | Caller_Object : Node_Id; | |
7530 | Call_Deref : Node_Id; | |
7531 | Ref_Type : Entity_Id; | |
7532 | Ptr_Typ_Decl : Node_Id; | |
7533 | Def_Id : Entity_Id; | |
7534 | New_Expr : Node_Id; | |
7535 | Enclosing_Func : Entity_Id; | |
7536 | Pass_Caller_Acc : Boolean := False; | |
02822a92 RD |
7537 | |
7538 | begin | |
19590d70 GD |
7539 | -- Step past qualification or unchecked conversion (the latter can occur |
7540 | -- in cases of calls to 'Input). | |
7541 | ||
ac4d6407 RD |
7542 | if Nkind_In (Func_Call, N_Qualified_Expression, |
7543 | N_Unchecked_Type_Conversion) | |
19590d70 | 7544 | then |
02822a92 RD |
7545 | Func_Call := Expression (Func_Call); |
7546 | end if; | |
7547 | ||
fdce4bb7 JM |
7548 | -- If the call has already been processed to add build-in-place actuals |
7549 | -- then return. This should not normally occur in an object declaration, | |
7550 | -- but we add the protection as a defensive measure. | |
7551 | ||
7552 | if Is_Expanded_Build_In_Place_Call (Func_Call) then | |
7553 | return; | |
7554 | end if; | |
7555 | ||
7556 | -- Mark the call as processed as a build-in-place call | |
7557 | ||
7558 | Set_Is_Expanded_Build_In_Place_Call (Func_Call); | |
7559 | ||
02822a92 RD |
7560 | Loc := Sloc (Function_Call); |
7561 | ||
7562 | if Is_Entity_Name (Name (Func_Call)) then | |
7563 | Function_Id := Entity (Name (Func_Call)); | |
7564 | ||
7565 | elsif Nkind (Name (Func_Call)) = N_Explicit_Dereference then | |
7566 | Function_Id := Etype (Name (Func_Call)); | |
7567 | ||
7568 | else | |
7569 | raise Program_Error; | |
7570 | end if; | |
7571 | ||
7572 | Result_Subt := Etype (Function_Id); | |
7573 | ||
f937473f RD |
7574 | -- In the constrained case, add an implicit actual to the function call |
7575 | -- that provides access to the declared object. An unchecked conversion | |
7576 | -- to the (specific) result type of the function is inserted to handle | |
7577 | -- the case where the object is declared with a class-wide type. | |
7578 | ||
7888a6ae | 7579 | if Is_Constrained (Underlying_Type (Result_Subt)) then |
f937473f RD |
7580 | Caller_Object := |
7581 | Make_Unchecked_Type_Conversion (Loc, | |
7582 | Subtype_Mark => New_Reference_To (Result_Subt, Loc), | |
7583 | Expression => New_Reference_To (Obj_Def_Id, Loc)); | |
02822a92 | 7584 | |
7888a6ae GD |
7585 | -- When the function has a controlling result, an allocation-form |
7586 | -- parameter must be passed indicating that the caller is allocating | |
7587 | -- the result object. This is needed because such a function can be | |
7588 | -- called as a dispatching operation and must be treated similarly | |
7589 | -- to functions with unconstrained result subtypes. | |
7590 | ||
7591 | Add_Alloc_Form_Actual_To_Build_In_Place_Call | |
7592 | (Func_Call, Function_Id, Alloc_Form => Caller_Allocation); | |
7593 | ||
f937473f RD |
7594 | -- If the function's result subtype is unconstrained and the object is |
7595 | -- a return object of an enclosing build-in-place function, then the | |
7596 | -- implicit build-in-place parameters of the enclosing function must be | |
ce14c577 AC |
7597 | -- passed along to the called function. (Unfortunately, this won't cover |
7598 | -- the case of extension aggregates where the ancestor part is a build- | |
7599 | -- in-place unconstrained function call that should be passed along the | |
7600 | -- caller's parameters. Currently those get mishandled by reassigning | |
7601 | -- the result of the call to the aggregate return object, when the call | |
7602 | -- result should really be directly built in place in the aggregate and | |
7603 | -- not built in a temporary. ???) | |
7604 | ||
7605 | elsif Is_Return_Object (Defining_Identifier (Object_Decl)) then | |
f937473f RD |
7606 | Pass_Caller_Acc := True; |
7607 | ||
7608 | Enclosing_Func := Enclosing_Subprogram (Obj_Def_Id); | |
7609 | ||
7610 | -- If the enclosing function has a constrained result type, then | |
7611 | -- caller allocation will be used. | |
7612 | ||
7613 | if Is_Constrained (Etype (Enclosing_Func)) then | |
7614 | Add_Alloc_Form_Actual_To_Build_In_Place_Call | |
7615 | (Func_Call, Function_Id, Alloc_Form => Caller_Allocation); | |
7616 | ||
7617 | -- Otherwise, when the enclosing function has an unconstrained result | |
7618 | -- type, the BIP_Alloc_Form formal of the enclosing function must be | |
7888a6ae | 7619 | -- passed along to the callee. |
f937473f RD |
7620 | |
7621 | else | |
7622 | Add_Alloc_Form_Actual_To_Build_In_Place_Call | |
7623 | (Func_Call, | |
7624 | Function_Id, | |
7625 | Alloc_Form_Exp => | |
7626 | New_Reference_To | |
7627 | (Build_In_Place_Formal (Enclosing_Func, BIP_Alloc_Form), | |
7628 | Loc)); | |
7629 | end if; | |
7630 | ||
7631 | -- Retrieve the BIPacc formal from the enclosing function and convert | |
7632 | -- it to the access type of the callee's BIP_Object_Access formal. | |
7633 | ||
7634 | Caller_Object := | |
7635 | Make_Unchecked_Type_Conversion (Loc, | |
7636 | Subtype_Mark => | |
7637 | New_Reference_To | |
7638 | (Etype | |
7639 | (Build_In_Place_Formal (Function_Id, BIP_Object_Access)), | |
7640 | Loc), | |
7641 | Expression => | |
7642 | New_Reference_To | |
7643 | (Build_In_Place_Formal (Enclosing_Func, BIP_Object_Access), | |
7644 | Loc)); | |
7645 | ||
7646 | -- In other unconstrained cases, pass an indication to do the allocation | |
7647 | -- on the secondary stack and set Caller_Object to Empty so that a null | |
7648 | -- value will be passed for the caller's object address. A transient | |
7649 | -- scope is established to ensure eventual cleanup of the result. | |
7650 | ||
7651 | else | |
7652 | Add_Alloc_Form_Actual_To_Build_In_Place_Call | |
7653 | (Func_Call, | |
7654 | Function_Id, | |
7655 | Alloc_Form => Secondary_Stack); | |
7656 | Caller_Object := Empty; | |
7657 | ||
7658 | Establish_Transient_Scope (Object_Decl, Sec_Stack => True); | |
7659 | end if; | |
7660 | ||
df3e68b1 HK |
7661 | Add_Collection_Actual_To_Build_In_Place_Call |
7662 | (Func_Call, Function_Id); | |
7888a6ae | 7663 | |
f937473f RD |
7664 | if Nkind (Parent (Object_Decl)) = N_Extended_Return_Statement |
7665 | and then Has_Task (Result_Subt) | |
7666 | then | |
7667 | Enclosing_Func := Enclosing_Subprogram (Obj_Def_Id); | |
7888a6ae GD |
7668 | |
7669 | -- Here we're passing along the master that was passed in to this | |
7670 | -- function. | |
7671 | ||
f937473f RD |
7672 | Add_Task_Actuals_To_Build_In_Place_Call |
7673 | (Func_Call, Function_Id, | |
7674 | Master_Actual => | |
7675 | New_Reference_To | |
7676 | (Build_In_Place_Formal (Enclosing_Func, BIP_Master), Loc)); | |
7888a6ae | 7677 | |
f937473f RD |
7678 | else |
7679 | Add_Task_Actuals_To_Build_In_Place_Call | |
7680 | (Func_Call, Function_Id, Make_Identifier (Loc, Name_uMaster)); | |
7681 | end if; | |
7888a6ae | 7682 | |
02822a92 | 7683 | Add_Access_Actual_To_Build_In_Place_Call |
f937473f | 7684 | (Func_Call, Function_Id, Caller_Object, Is_Access => Pass_Caller_Acc); |
02822a92 | 7685 | |
b0b7b57d AC |
7686 | -- Create an access type designating the function's result subtype. We |
7687 | -- use the type of the original expression because it may be a call to | |
7688 | -- an inherited operation, which the expansion has replaced with the | |
7689 | -- parent operation that yields the parent type. | |
02822a92 | 7690 | |
c12beea0 | 7691 | Ref_Type := Make_Temporary (Loc, 'A'); |
02822a92 RD |
7692 | |
7693 | Ptr_Typ_Decl := | |
7694 | Make_Full_Type_Declaration (Loc, | |
7695 | Defining_Identifier => Ref_Type, | |
7696 | Type_Definition => | |
7697 | Make_Access_To_Object_Definition (Loc, | |
7698 | All_Present => True, | |
7699 | Subtype_Indication => | |
b0b7b57d | 7700 | New_Reference_To (Etype (Function_Call), Loc))); |
02822a92 | 7701 | |
f937473f RD |
7702 | -- The access type and its accompanying object must be inserted after |
7703 | -- the object declaration in the constrained case, so that the function | |
7704 | -- call can be passed access to the object. In the unconstrained case, | |
7705 | -- the access type and object must be inserted before the object, since | |
7706 | -- the object declaration is rewritten to be a renaming of a dereference | |
7707 | -- of the access object. | |
7708 | ||
7888a6ae | 7709 | if Is_Constrained (Underlying_Type (Result_Subt)) then |
f937473f RD |
7710 | Insert_After_And_Analyze (Object_Decl, Ptr_Typ_Decl); |
7711 | else | |
4f6e2c24 | 7712 | Insert_Action (Object_Decl, Ptr_Typ_Decl); |
f937473f | 7713 | end if; |
02822a92 RD |
7714 | |
7715 | -- Finally, create an access object initialized to a reference to the | |
7716 | -- function call. | |
7717 | ||
02822a92 RD |
7718 | New_Expr := |
7719 | Make_Reference (Loc, | |
7720 | Prefix => Relocate_Node (Func_Call)); | |
7721 | ||
c12beea0 RD |
7722 | Def_Id := Make_Temporary (Loc, 'R', New_Expr); |
7723 | Set_Etype (Def_Id, Ref_Type); | |
7724 | ||
02822a92 RD |
7725 | Insert_After_And_Analyze (Ptr_Typ_Decl, |
7726 | Make_Object_Declaration (Loc, | |
7727 | Defining_Identifier => Def_Id, | |
7728 | Object_Definition => New_Reference_To (Ref_Type, Loc), | |
7729 | Expression => New_Expr)); | |
7730 | ||
7888a6ae | 7731 | if Is_Constrained (Underlying_Type (Result_Subt)) then |
f937473f RD |
7732 | Set_Expression (Object_Decl, Empty); |
7733 | Set_No_Initialization (Object_Decl); | |
7734 | ||
7735 | -- In case of an unconstrained result subtype, rewrite the object | |
7736 | -- declaration as an object renaming where the renamed object is a | |
7737 | -- dereference of <function_Call>'reference: | |
7738 | -- | |
7739 | -- Obj : Subt renames <function_call>'Ref.all; | |
7740 | ||
7741 | else | |
7742 | Call_Deref := | |
7743 | Make_Explicit_Dereference (Loc, | |
7744 | Prefix => New_Reference_To (Def_Id, Loc)); | |
7745 | ||
f00c5f52 | 7746 | Loc := Sloc (Object_Decl); |
f937473f RD |
7747 | Rewrite (Object_Decl, |
7748 | Make_Object_Renaming_Declaration (Loc, | |
c12beea0 | 7749 | Defining_Identifier => Make_Temporary (Loc, 'D'), |
f937473f RD |
7750 | Access_Definition => Empty, |
7751 | Subtype_Mark => New_Occurrence_Of (Result_Subt, Loc), | |
7752 | Name => Call_Deref)); | |
7753 | ||
7754 | Set_Renamed_Object (Defining_Identifier (Object_Decl), Call_Deref); | |
7755 | ||
7756 | Analyze (Object_Decl); | |
7757 | ||
7758 | -- Replace the internal identifier of the renaming declaration's | |
7759 | -- entity with identifier of the original object entity. We also have | |
7760 | -- to exchange the entities containing their defining identifiers to | |
7761 | -- ensure the correct replacement of the object declaration by the | |
7762 | -- object renaming declaration to avoid homograph conflicts (since | |
7763 | -- the object declaration's defining identifier was already entered | |
67ce0d7e RD |
7764 | -- in current scope). The Next_Entity links of the two entities also |
7765 | -- have to be swapped since the entities are part of the return | |
7766 | -- scope's entity list and the list structure would otherwise be | |
7e8ed0a6 | 7767 | -- corrupted. Finally, the homonym chain must be preserved as well. |
67ce0d7e RD |
7768 | |
7769 | declare | |
7770 | Renaming_Def_Id : constant Entity_Id := | |
7771 | Defining_Identifier (Object_Decl); | |
7772 | Next_Entity_Temp : constant Entity_Id := | |
7773 | Next_Entity (Renaming_Def_Id); | |
7774 | begin | |
7775 | Set_Chars (Renaming_Def_Id, Chars (Obj_Def_Id)); | |
7776 | ||
7777 | -- Swap next entity links in preparation for exchanging entities | |
f937473f | 7778 | |
67ce0d7e RD |
7779 | Set_Next_Entity (Renaming_Def_Id, Next_Entity (Obj_Def_Id)); |
7780 | Set_Next_Entity (Obj_Def_Id, Next_Entity_Temp); | |
7e8ed0a6 | 7781 | Set_Homonym (Renaming_Def_Id, Homonym (Obj_Def_Id)); |
67ce0d7e RD |
7782 | |
7783 | Exchange_Entities (Renaming_Def_Id, Obj_Def_Id); | |
f00c5f52 AC |
7784 | |
7785 | -- Preserve source indication of original declaration, so that | |
7786 | -- xref information is properly generated for the right entity. | |
7787 | ||
7788 | Preserve_Comes_From_Source | |
7789 | (Object_Decl, Original_Node (Object_Decl)); | |
7790 | Set_Comes_From_Source (Obj_Def_Id, True); | |
7791 | Set_Comes_From_Source (Renaming_Def_Id, False); | |
67ce0d7e | 7792 | end; |
f937473f | 7793 | end if; |
02822a92 RD |
7794 | |
7795 | -- If the object entity has a class-wide Etype, then we need to change | |
7796 | -- it to the result subtype of the function call, because otherwise the | |
53b308f6 AC |
7797 | -- object will be class-wide without an explicit initialization and |
7798 | -- won't be allocated properly by the back end. It seems unclean to make | |
7799 | -- such a revision to the type at this point, and we should try to | |
7800 | -- improve this treatment when build-in-place functions with class-wide | |
7801 | -- results are implemented. ??? | |
02822a92 RD |
7802 | |
7803 | if Is_Class_Wide_Type (Etype (Defining_Identifier (Object_Decl))) then | |
7804 | Set_Etype (Defining_Identifier (Object_Decl), Result_Subt); | |
7805 | end if; | |
7806 | end Make_Build_In_Place_Call_In_Object_Declaration; | |
7807 | ||
8fb68c56 | 7808 | -------------------------- |
df3e68b1 | 7809 | -- Needs_BIP_Collection -- |
8fb68c56 RD |
7810 | -------------------------- |
7811 | ||
df3e68b1 HK |
7812 | function Needs_BIP_Collection (Func_Id : Entity_Id) return Boolean is |
7813 | pragma Assert (Is_Build_In_Place_Function (Func_Id)); | |
7814 | Func_Typ : constant Entity_Id := Underlying_Type (Etype (Func_Id)); | |
8fb68c56 | 7815 | |
048e5cef | 7816 | begin |
df3e68b1 HK |
7817 | return |
7818 | not Restriction_Active (No_Finalization) | |
7819 | and then Needs_Finalization (Func_Typ); | |
7820 | end Needs_BIP_Collection; | |
048e5cef | 7821 | |
70482933 | 7822 | end Exp_Ch6; |