]>
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 | -- -- | |
3a69b5ff | 9 | -- Copyright (C) 1992-2009, 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; | |
72 | with Tbuild; use Tbuild; | |
73 | with Uintp; use Uintp; | |
74 | with Validsw; use Validsw; | |
75 | ||
76 | package body Exp_Ch6 is | |
77 | ||
78 | ----------------------- | |
79 | -- Local Subprograms -- | |
80 | ----------------------- | |
81 | ||
02822a92 RD |
82 | procedure Add_Access_Actual_To_Build_In_Place_Call |
83 | (Function_Call : Node_Id; | |
84 | Function_Id : Entity_Id; | |
f937473f RD |
85 | Return_Object : Node_Id; |
86 | Is_Access : Boolean := False); | |
02822a92 RD |
87 | -- Ada 2005 (AI-318-02): Apply the Unrestricted_Access attribute to the |
88 | -- object name given by Return_Object and add the attribute to the end of | |
89 | -- the actual parameter list associated with the build-in-place function | |
f937473f RD |
90 | -- call denoted by Function_Call. However, if Is_Access is True, then |
91 | -- Return_Object is already an access expression, in which case it's passed | |
92 | -- along directly to the build-in-place function. Finally, if Return_Object | |
93 | -- is empty, then pass a null literal as the actual. | |
94 | ||
95 | procedure Add_Alloc_Form_Actual_To_Build_In_Place_Call | |
96 | (Function_Call : Node_Id; | |
97 | Function_Id : Entity_Id; | |
98 | Alloc_Form : BIP_Allocation_Form := Unspecified; | |
99 | Alloc_Form_Exp : Node_Id := Empty); | |
100 | -- Ada 2005 (AI-318-02): Add an actual indicating the form of allocation, | |
101 | -- if any, to be done by a build-in-place function. If Alloc_Form_Exp is | |
102 | -- present, then use it, otherwise pass a literal corresponding to the | |
103 | -- Alloc_Form parameter (which must not be Unspecified in that case). | |
104 | ||
105 | procedure Add_Extra_Actual_To_Call | |
106 | (Subprogram_Call : Node_Id; | |
107 | Extra_Formal : Entity_Id; | |
108 | Extra_Actual : Node_Id); | |
109 | -- Adds Extra_Actual as a named parameter association for the formal | |
110 | -- Extra_Formal in Subprogram_Call. | |
111 | ||
112 | procedure Add_Final_List_Actual_To_Build_In_Place_Call | |
113 | (Function_Call : Node_Id; | |
7888a6ae | 114 | Function_Id : Entity_Id; |
70f91180 RD |
115 | Acc_Type : Entity_Id; |
116 | Sel_Comp : Node_Id := Empty); | |
f937473f | 117 | -- Ada 2005 (AI-318-02): For a build-in-place call, if the result type has |
7888a6ae GD |
118 | -- controlled parts, add an actual parameter that is a pointer to |
119 | -- appropriate finalization list. The finalization list is that of the | |
120 | -- current scope, except for "new Acc'(F(...))" in which case it's the | |
121 | -- finalization list of the access type returned by the allocator. Acc_Type | |
70f91180 RD |
122 | -- is that type in the allocator case; Empty otherwise. If Sel_Comp is |
123 | -- not Empty, then it denotes a selected component and the finalization | |
124 | -- list is obtained from the _controller list of the prefix object. | |
f937473f RD |
125 | |
126 | procedure Add_Task_Actuals_To_Build_In_Place_Call | |
127 | (Function_Call : Node_Id; | |
128 | Function_Id : Entity_Id; | |
129 | Master_Actual : Node_Id); | |
130 | -- Ada 2005 (AI-318-02): For a build-in-place call, if the result type | |
131 | -- contains tasks, add two actual parameters: the master, and a pointer to | |
132 | -- the caller's activation chain. Master_Actual is the actual parameter | |
133 | -- expression to pass for the master. In most cases, this is the current | |
134 | -- master (_master). The two exceptions are: If the function call is the | |
135 | -- initialization expression for an allocator, we pass the master of the | |
136 | -- access type. If the function call is the initialization expression for | |
137 | -- a return object, we pass along the master passed in by the caller. The | |
138 | -- activation chain to pass is always the local one. | |
02822a92 | 139 | |
70482933 RK |
140 | procedure Check_Overriding_Operation (Subp : Entity_Id); |
141 | -- Subp is a dispatching operation. Check whether it may override an | |
142 | -- inherited private operation, in which case its DT entry is that of | |
143 | -- the hidden operation, not the one it may have received earlier. | |
144 | -- This must be done before emitting the code to set the corresponding | |
145 | -- DT to the address of the subprogram. The actual placement of Subp in | |
146 | -- the proper place in the list of primitive operations is done in | |
147 | -- Declare_Inherited_Private_Subprograms, which also has to deal with | |
148 | -- implicit operations. This duplication is unavoidable for now??? | |
149 | ||
150 | procedure Detect_Infinite_Recursion (N : Node_Id; Spec : Entity_Id); | |
151 | -- This procedure is called only if the subprogram body N, whose spec | |
152 | -- has the given entity Spec, contains a parameterless recursive call. | |
153 | -- It attempts to generate runtime code to detect if this a case of | |
154 | -- infinite recursion. | |
155 | -- | |
156 | -- The body is scanned to determine dependencies. If the only external | |
157 | -- dependencies are on a small set of scalar variables, then the values | |
158 | -- of these variables are captured on entry to the subprogram, and if | |
159 | -- the values are not changed for the call, we know immediately that | |
160 | -- we have an infinite recursion. | |
161 | ||
162 | procedure Expand_Actuals (N : Node_Id; Subp : Entity_Id); | |
f4d379b8 HK |
163 | -- For each actual of an in-out or out parameter which is a numeric |
164 | -- (view) conversion of the form T (A), where A denotes a variable, | |
165 | -- we insert the declaration: | |
70482933 | 166 | -- |
f4d379b8 | 167 | -- Temp : T[ := T (A)]; |
70482933 RK |
168 | -- |
169 | -- prior to the call. Then we replace the actual with a reference to Temp, | |
170 | -- and append the assignment: | |
171 | -- | |
fbf5a39b | 172 | -- A := TypeA (Temp); |
70482933 | 173 | -- |
1c6b973a AC |
174 | -- after the call. Here TypeA is the actual type of variable A. For out |
175 | -- parameters, the initial declaration has no expression. If A is not an | |
176 | -- entity name, we generate instead: | |
70482933 | 177 | -- |
fbf5a39b | 178 | -- Var : TypeA renames A; |
70482933 RK |
179 | -- Temp : T := Var; -- omitting expression for out parameter. |
180 | -- ... | |
fbf5a39b | 181 | -- Var := TypeA (Temp); |
70482933 RK |
182 | -- |
183 | -- For other in-out parameters, we emit the required constraint checks | |
184 | -- before and/or after the call. | |
fbf5a39b | 185 | -- |
1c6b973a AC |
186 | -- For all parameter modes, actuals that denote components and slices of |
187 | -- packed arrays are expanded into suitable temporaries. | |
f44fe430 RD |
188 | -- |
189 | -- For non-scalar objects that are possibly unaligned, add call by copy | |
190 | -- code (copy in for IN and IN OUT, copy out for OUT and IN OUT). | |
70482933 RK |
191 | |
192 | procedure Expand_Inlined_Call | |
193 | (N : Node_Id; | |
194 | Subp : Entity_Id; | |
195 | Orig_Subp : Entity_Id); | |
196 | -- If called subprogram can be inlined by the front-end, retrieve the | |
197 | -- analyzed body, replace formals with actuals and expand call in place. | |
198 | -- Generate thunks for actuals that are expressions, and insert the | |
199 | -- corresponding constant declarations before the call. If the original | |
200 | -- call is to a derived operation, the return type is the one of the | |
201 | -- derived operation, but the body is that of the original, so return | |
202 | -- expressions in the body must be converted to the desired type (which | |
203 | -- is simply not noted in the tree without inline expansion). | |
204 | ||
205 | function Expand_Protected_Object_Reference | |
206 | (N : Node_Id; | |
02822a92 | 207 | Scop : Entity_Id) return Node_Id; |
70482933 RK |
208 | |
209 | procedure Expand_Protected_Subprogram_Call | |
210 | (N : Node_Id; | |
211 | Subp : Entity_Id; | |
212 | Scop : Entity_Id); | |
213 | -- A call to a protected subprogram within the protected object may appear | |
214 | -- as a regular call. The list of actuals must be expanded to contain a | |
215 | -- reference to the object itself, and the call becomes a call to the | |
216 | -- corresponding protected subprogram. | |
217 | ||
8dbf3473 AC |
218 | function Is_Null_Procedure (Subp : Entity_Id) return Boolean; |
219 | -- Predicate to recognize stubbed procedures and null procedures, which | |
220 | -- can be inlined unconditionally in all cases. | |
221 | ||
02822a92 RD |
222 | ---------------------------------------------- |
223 | -- Add_Access_Actual_To_Build_In_Place_Call -- | |
224 | ---------------------------------------------- | |
225 | ||
226 | procedure Add_Access_Actual_To_Build_In_Place_Call | |
227 | (Function_Call : Node_Id; | |
228 | Function_Id : Entity_Id; | |
f937473f RD |
229 | Return_Object : Node_Id; |
230 | Is_Access : Boolean := False) | |
02822a92 RD |
231 | is |
232 | Loc : constant Source_Ptr := Sloc (Function_Call); | |
233 | Obj_Address : Node_Id; | |
f937473f | 234 | Obj_Acc_Formal : Entity_Id; |
02822a92 RD |
235 | |
236 | begin | |
f937473f | 237 | -- Locate the implicit access parameter in the called function |
02822a92 | 238 | |
f937473f | 239 | Obj_Acc_Formal := Build_In_Place_Formal (Function_Id, BIP_Object_Access); |
02822a92 | 240 | |
f937473f RD |
241 | -- If no return object is provided, then pass null |
242 | ||
243 | if not Present (Return_Object) then | |
244 | Obj_Address := Make_Null (Loc); | |
7888a6ae | 245 | Set_Parent (Obj_Address, Function_Call); |
02822a92 | 246 | |
f937473f RD |
247 | -- If Return_Object is already an expression of an access type, then use |
248 | -- it directly, since it must be an access value denoting the return | |
249 | -- object, and couldn't possibly be the return object itself. | |
250 | ||
251 | elsif Is_Access then | |
252 | Obj_Address := Return_Object; | |
7888a6ae | 253 | Set_Parent (Obj_Address, Function_Call); |
02822a92 RD |
254 | |
255 | -- Apply Unrestricted_Access to caller's return object | |
256 | ||
f937473f RD |
257 | else |
258 | Obj_Address := | |
259 | Make_Attribute_Reference (Loc, | |
260 | Prefix => Return_Object, | |
261 | Attribute_Name => Name_Unrestricted_Access); | |
7888a6ae GD |
262 | |
263 | Set_Parent (Return_Object, Obj_Address); | |
264 | Set_Parent (Obj_Address, Function_Call); | |
f937473f | 265 | end if; |
02822a92 RD |
266 | |
267 | Analyze_And_Resolve (Obj_Address, Etype (Obj_Acc_Formal)); | |
268 | ||
269 | -- Build the parameter association for the new actual and add it to the | |
270 | -- end of the function's actuals. | |
271 | ||
f937473f RD |
272 | Add_Extra_Actual_To_Call (Function_Call, Obj_Acc_Formal, Obj_Address); |
273 | end Add_Access_Actual_To_Build_In_Place_Call; | |
274 | ||
275 | -------------------------------------------------- | |
276 | -- Add_Alloc_Form_Actual_To_Build_In_Place_Call -- | |
277 | -------------------------------------------------- | |
278 | ||
279 | procedure Add_Alloc_Form_Actual_To_Build_In_Place_Call | |
280 | (Function_Call : Node_Id; | |
281 | Function_Id : Entity_Id; | |
282 | Alloc_Form : BIP_Allocation_Form := Unspecified; | |
283 | Alloc_Form_Exp : Node_Id := Empty) | |
284 | is | |
285 | Loc : constant Source_Ptr := Sloc (Function_Call); | |
286 | Alloc_Form_Actual : Node_Id; | |
287 | Alloc_Form_Formal : Node_Id; | |
288 | ||
289 | begin | |
7888a6ae GD |
290 | -- The allocation form generally doesn't need to be passed in the case |
291 | -- of a constrained result subtype, since normally the caller performs | |
292 | -- the allocation in that case. However this formal is still needed in | |
293 | -- the case where the function has a tagged result, because generally | |
294 | -- such functions can be called in a dispatching context and such calls | |
295 | -- must be handled like calls to class-wide functions. | |
296 | ||
297 | if Is_Constrained (Underlying_Type (Etype (Function_Id))) | |
298 | and then not Is_Tagged_Type (Underlying_Type (Etype (Function_Id))) | |
299 | then | |
300 | return; | |
301 | end if; | |
302 | ||
f937473f RD |
303 | -- Locate the implicit allocation form parameter in the called function. |
304 | -- Maybe it would be better for each implicit formal of a build-in-place | |
305 | -- function to have a flag or a Uint attribute to identify it. ??? | |
306 | ||
307 | Alloc_Form_Formal := Build_In_Place_Formal (Function_Id, BIP_Alloc_Form); | |
308 | ||
309 | if Present (Alloc_Form_Exp) then | |
310 | pragma Assert (Alloc_Form = Unspecified); | |
311 | ||
312 | Alloc_Form_Actual := Alloc_Form_Exp; | |
313 | ||
314 | else | |
315 | pragma Assert (Alloc_Form /= Unspecified); | |
316 | ||
317 | Alloc_Form_Actual := | |
318 | Make_Integer_Literal (Loc, | |
319 | Intval => UI_From_Int (BIP_Allocation_Form'Pos (Alloc_Form))); | |
320 | end if; | |
321 | ||
322 | Analyze_And_Resolve (Alloc_Form_Actual, Etype (Alloc_Form_Formal)); | |
323 | ||
324 | -- Build the parameter association for the new actual and add it to the | |
325 | -- end of the function's actuals. | |
326 | ||
327 | Add_Extra_Actual_To_Call | |
328 | (Function_Call, Alloc_Form_Formal, Alloc_Form_Actual); | |
329 | end Add_Alloc_Form_Actual_To_Build_In_Place_Call; | |
330 | ||
331 | ------------------------------ | |
332 | -- Add_Extra_Actual_To_Call -- | |
333 | ------------------------------ | |
334 | ||
335 | procedure Add_Extra_Actual_To_Call | |
336 | (Subprogram_Call : Node_Id; | |
337 | Extra_Formal : Entity_Id; | |
338 | Extra_Actual : Node_Id) | |
339 | is | |
340 | Loc : constant Source_Ptr := Sloc (Subprogram_Call); | |
341 | Param_Assoc : Node_Id; | |
342 | ||
343 | begin | |
02822a92 RD |
344 | Param_Assoc := |
345 | Make_Parameter_Association (Loc, | |
f937473f RD |
346 | Selector_Name => New_Occurrence_Of (Extra_Formal, Loc), |
347 | Explicit_Actual_Parameter => Extra_Actual); | |
02822a92 | 348 | |
f937473f RD |
349 | Set_Parent (Param_Assoc, Subprogram_Call); |
350 | Set_Parent (Extra_Actual, Param_Assoc); | |
02822a92 | 351 | |
f937473f RD |
352 | if Present (Parameter_Associations (Subprogram_Call)) then |
353 | if Nkind (Last (Parameter_Associations (Subprogram_Call))) = | |
02822a92 RD |
354 | N_Parameter_Association |
355 | then | |
f937473f RD |
356 | |
357 | -- Find last named actual, and append | |
358 | ||
359 | declare | |
360 | L : Node_Id; | |
361 | begin | |
362 | L := First_Actual (Subprogram_Call); | |
363 | while Present (L) loop | |
364 | if No (Next_Actual (L)) then | |
365 | Set_Next_Named_Actual (Parent (L), Extra_Actual); | |
366 | exit; | |
367 | end if; | |
368 | Next_Actual (L); | |
369 | end loop; | |
370 | end; | |
371 | ||
02822a92 | 372 | else |
f937473f | 373 | Set_First_Named_Actual (Subprogram_Call, Extra_Actual); |
02822a92 RD |
374 | end if; |
375 | ||
f937473f | 376 | Append (Param_Assoc, To => Parameter_Associations (Subprogram_Call)); |
02822a92 RD |
377 | |
378 | else | |
f937473f RD |
379 | Set_Parameter_Associations (Subprogram_Call, New_List (Param_Assoc)); |
380 | Set_First_Named_Actual (Subprogram_Call, Extra_Actual); | |
02822a92 | 381 | end if; |
f937473f RD |
382 | end Add_Extra_Actual_To_Call; |
383 | ||
384 | -------------------------------------------------- | |
385 | -- Add_Final_List_Actual_To_Build_In_Place_Call -- | |
386 | -------------------------------------------------- | |
387 | ||
388 | procedure Add_Final_List_Actual_To_Build_In_Place_Call | |
389 | (Function_Call : Node_Id; | |
7888a6ae | 390 | Function_Id : Entity_Id; |
70f91180 RD |
391 | Acc_Type : Entity_Id; |
392 | Sel_Comp : Node_Id := Empty) | |
f937473f RD |
393 | is |
394 | Loc : constant Source_Ptr := Sloc (Function_Call); | |
395 | Final_List : Node_Id; | |
396 | Final_List_Actual : Node_Id; | |
397 | Final_List_Formal : Node_Id; | |
70f91180 | 398 | Is_Ctrl_Result : constant Boolean := |
048e5cef | 399 | Needs_Finalization |
70f91180 | 400 | (Underlying_Type (Etype (Function_Id))); |
f937473f RD |
401 | |
402 | begin | |
7888a6ae | 403 | -- No such extra parameter is needed if there are no controlled parts. |
048e5cef BD |
404 | -- The test for Needs_Finalization accounts for class-wide results |
405 | -- (which potentially have controlled parts, even if the root type | |
406 | -- doesn't), and the test for a tagged result type is needed because | |
407 | -- calls to such a function can in general occur in dispatching | |
408 | -- contexts, which must be treated the same as a call to class-wide | |
409 | -- functions. Both of these situations require that a finalization list | |
410 | -- be passed. | |
411 | ||
412 | if not Needs_BIP_Final_List (Function_Id) then | |
f937473f RD |
413 | return; |
414 | end if; | |
415 | ||
416 | -- Locate implicit finalization list parameter in the called function | |
417 | ||
418 | Final_List_Formal := Build_In_Place_Formal (Function_Id, BIP_Final_List); | |
419 | ||
7888a6ae GD |
420 | -- Create the actual which is a pointer to the appropriate finalization |
421 | -- list. Acc_Type is present if and only if this call is the | |
1c6b973a AC |
422 | -- initialization of an allocator. Use the Current_Scope or the |
423 | -- Acc_Type as appropriate. | |
7888a6ae GD |
424 | |
425 | if Present (Acc_Type) | |
426 | and then (Ekind (Acc_Type) = E_Anonymous_Access_Type | |
427 | or else | |
428 | Present (Associated_Final_Chain (Base_Type (Acc_Type)))) | |
429 | then | |
430 | Final_List := Find_Final_List (Acc_Type); | |
70f91180 RD |
431 | |
432 | -- If Sel_Comp is present and the function result is controlled, then | |
433 | -- the finalization list will be obtained from the _controller list of | |
434 | -- the selected component's prefix object. | |
435 | ||
436 | elsif Present (Sel_Comp) and then Is_Ctrl_Result then | |
437 | Final_List := Find_Final_List (Current_Scope, Sel_Comp); | |
438 | ||
7888a6ae GD |
439 | else |
440 | Final_List := Find_Final_List (Current_Scope); | |
441 | end if; | |
f937473f | 442 | |
f937473f RD |
443 | Final_List_Actual := |
444 | Make_Attribute_Reference (Loc, | |
445 | Prefix => Final_List, | |
446 | Attribute_Name => Name_Unrestricted_Access); | |
447 | ||
448 | Analyze_And_Resolve (Final_List_Actual, Etype (Final_List_Formal)); | |
449 | ||
450 | -- Build the parameter association for the new actual and add it to the | |
451 | -- end of the function's actuals. | |
452 | ||
453 | Add_Extra_Actual_To_Call | |
454 | (Function_Call, Final_List_Formal, Final_List_Actual); | |
455 | end Add_Final_List_Actual_To_Build_In_Place_Call; | |
456 | ||
457 | --------------------------------------------- | |
458 | -- Add_Task_Actuals_To_Build_In_Place_Call -- | |
459 | --------------------------------------------- | |
460 | ||
461 | procedure Add_Task_Actuals_To_Build_In_Place_Call | |
462 | (Function_Call : Node_Id; | |
463 | Function_Id : Entity_Id; | |
464 | Master_Actual : Node_Id) | |
465 | -- Note: Master_Actual can be Empty, but only if there are no tasks | |
466 | is | |
467 | Loc : constant Source_Ptr := Sloc (Function_Call); | |
468 | ||
469 | begin | |
470 | -- No such extra parameters are needed if there are no tasks | |
471 | ||
472 | if not Has_Task (Etype (Function_Id)) then | |
473 | return; | |
474 | end if; | |
475 | ||
476 | -- The master | |
477 | ||
478 | declare | |
479 | Master_Formal : Node_Id; | |
480 | begin | |
481 | -- Locate implicit master parameter in the called function | |
482 | ||
483 | Master_Formal := Build_In_Place_Formal (Function_Id, BIP_Master); | |
484 | ||
485 | Analyze_And_Resolve (Master_Actual, Etype (Master_Formal)); | |
486 | ||
487 | -- Build the parameter association for the new actual and add it to | |
488 | -- the end of the function's actuals. | |
489 | ||
490 | Add_Extra_Actual_To_Call | |
491 | (Function_Call, Master_Formal, Master_Actual); | |
492 | end; | |
493 | ||
494 | -- The activation chain | |
495 | ||
496 | declare | |
497 | Activation_Chain_Actual : Node_Id; | |
498 | Activation_Chain_Formal : Node_Id; | |
75a64833 | 499 | |
f937473f RD |
500 | begin |
501 | -- Locate implicit activation chain parameter in the called function | |
502 | ||
503 | Activation_Chain_Formal := Build_In_Place_Formal | |
504 | (Function_Id, BIP_Activation_Chain); | |
505 | ||
506 | -- Create the actual which is a pointer to the current activation | |
507 | -- chain | |
508 | ||
509 | Activation_Chain_Actual := | |
510 | Make_Attribute_Reference (Loc, | |
511 | Prefix => Make_Identifier (Loc, Name_uChain), | |
512 | Attribute_Name => Name_Unrestricted_Access); | |
513 | ||
514 | Analyze_And_Resolve | |
515 | (Activation_Chain_Actual, Etype (Activation_Chain_Formal)); | |
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 | |
521 | (Function_Call, Activation_Chain_Formal, Activation_Chain_Actual); | |
522 | end; | |
523 | end Add_Task_Actuals_To_Build_In_Place_Call; | |
524 | ||
525 | ----------------------- | |
526 | -- BIP_Formal_Suffix -- | |
527 | ----------------------- | |
528 | ||
529 | function BIP_Formal_Suffix (Kind : BIP_Formal_Kind) return String is | |
530 | begin | |
531 | case Kind is | |
532 | when BIP_Alloc_Form => | |
533 | return "BIPalloc"; | |
534 | when BIP_Final_List => | |
535 | return "BIPfinallist"; | |
536 | when BIP_Master => | |
537 | return "BIPmaster"; | |
538 | when BIP_Activation_Chain => | |
539 | return "BIPactivationchain"; | |
540 | when BIP_Object_Access => | |
541 | return "BIPaccess"; | |
542 | end case; | |
543 | end BIP_Formal_Suffix; | |
544 | ||
545 | --------------------------- | |
546 | -- Build_In_Place_Formal -- | |
547 | --------------------------- | |
548 | ||
549 | function Build_In_Place_Formal | |
550 | (Func : Entity_Id; | |
551 | Kind : BIP_Formal_Kind) return Entity_Id | |
552 | is | |
553 | Extra_Formal : Entity_Id := Extra_Formals (Func); | |
554 | ||
555 | begin | |
556 | -- Maybe it would be better for each implicit formal of a build-in-place | |
557 | -- function to have a flag or a Uint attribute to identify it. ??? | |
558 | ||
559 | loop | |
19590d70 | 560 | pragma Assert (Present (Extra_Formal)); |
f937473f RD |
561 | exit when |
562 | Chars (Extra_Formal) = | |
563 | New_External_Name (Chars (Func), BIP_Formal_Suffix (Kind)); | |
564 | Next_Formal_With_Extras (Extra_Formal); | |
565 | end loop; | |
566 | ||
f937473f RD |
567 | return Extra_Formal; |
568 | end Build_In_Place_Formal; | |
02822a92 | 569 | |
c9a4817d RD |
570 | -------------------------------- |
571 | -- Check_Overriding_Operation -- | |
572 | -------------------------------- | |
70482933 RK |
573 | |
574 | procedure Check_Overriding_Operation (Subp : Entity_Id) is | |
575 | Typ : constant Entity_Id := Find_Dispatching_Type (Subp); | |
576 | Op_List : constant Elist_Id := Primitive_Operations (Typ); | |
577 | Op_Elmt : Elmt_Id; | |
578 | Prim_Op : Entity_Id; | |
579 | Par_Op : Entity_Id; | |
580 | ||
581 | begin | |
582 | if Is_Derived_Type (Typ) | |
583 | and then not Is_Private_Type (Typ) | |
584 | and then In_Open_Scopes (Scope (Etype (Typ))) | |
585 | and then Typ = Base_Type (Typ) | |
586 | then | |
2f1b20a9 ES |
587 | -- Subp overrides an inherited private operation if there is an |
588 | -- inherited operation with a different name than Subp (see | |
589 | -- Derive_Subprogram) whose Alias is a hidden subprogram with the | |
590 | -- same name as Subp. | |
70482933 RK |
591 | |
592 | Op_Elmt := First_Elmt (Op_List); | |
593 | while Present (Op_Elmt) loop | |
594 | Prim_Op := Node (Op_Elmt); | |
595 | Par_Op := Alias (Prim_Op); | |
596 | ||
597 | if Present (Par_Op) | |
598 | and then not Comes_From_Source (Prim_Op) | |
599 | and then Chars (Prim_Op) /= Chars (Par_Op) | |
600 | and then Chars (Par_Op) = Chars (Subp) | |
601 | and then Is_Hidden (Par_Op) | |
602 | and then Type_Conformant (Prim_Op, Subp) | |
603 | then | |
604 | Set_DT_Position (Subp, DT_Position (Prim_Op)); | |
605 | end if; | |
606 | ||
607 | Next_Elmt (Op_Elmt); | |
608 | end loop; | |
609 | end if; | |
610 | end Check_Overriding_Operation; | |
611 | ||
612 | ------------------------------- | |
613 | -- Detect_Infinite_Recursion -- | |
614 | ------------------------------- | |
615 | ||
616 | procedure Detect_Infinite_Recursion (N : Node_Id; Spec : Entity_Id) is | |
617 | Loc : constant Source_Ptr := Sloc (N); | |
618 | ||
fbf5a39b | 619 | Var_List : constant Elist_Id := New_Elmt_List; |
70482933 RK |
620 | -- List of globals referenced by body of procedure |
621 | ||
fbf5a39b | 622 | Call_List : constant Elist_Id := New_Elmt_List; |
70482933 RK |
623 | -- List of recursive calls in body of procedure |
624 | ||
fbf5a39b | 625 | Shad_List : constant Elist_Id := New_Elmt_List; |
2f1b20a9 ES |
626 | -- List of entity id's for entities created to capture the value of |
627 | -- referenced globals on entry to the procedure. | |
70482933 RK |
628 | |
629 | Scop : constant Uint := Scope_Depth (Spec); | |
2f1b20a9 ES |
630 | -- This is used to record the scope depth of the current procedure, so |
631 | -- that we can identify global references. | |
70482933 RK |
632 | |
633 | Max_Vars : constant := 4; | |
634 | -- Do not test more than four global variables | |
635 | ||
636 | Count_Vars : Natural := 0; | |
637 | -- Count variables found so far | |
638 | ||
639 | Var : Entity_Id; | |
640 | Elm : Elmt_Id; | |
641 | Ent : Entity_Id; | |
642 | Call : Elmt_Id; | |
643 | Decl : Node_Id; | |
644 | Test : Node_Id; | |
645 | Elm1 : Elmt_Id; | |
646 | Elm2 : Elmt_Id; | |
647 | Last : Node_Id; | |
648 | ||
649 | function Process (Nod : Node_Id) return Traverse_Result; | |
650 | -- Function to traverse the subprogram body (using Traverse_Func) | |
651 | ||
652 | ------------- | |
653 | -- Process -- | |
654 | ------------- | |
655 | ||
656 | function Process (Nod : Node_Id) return Traverse_Result is | |
657 | begin | |
658 | -- Procedure call | |
659 | ||
660 | if Nkind (Nod) = N_Procedure_Call_Statement then | |
661 | ||
662 | -- Case of one of the detected recursive calls | |
663 | ||
664 | if Is_Entity_Name (Name (Nod)) | |
665 | and then Has_Recursive_Call (Entity (Name (Nod))) | |
666 | and then Entity (Name (Nod)) = Spec | |
667 | then | |
668 | Append_Elmt (Nod, Call_List); | |
669 | return Skip; | |
670 | ||
671 | -- Any other procedure call may have side effects | |
672 | ||
673 | else | |
674 | return Abandon; | |
675 | end if; | |
676 | ||
677 | -- A call to a pure function can always be ignored | |
678 | ||
679 | elsif Nkind (Nod) = N_Function_Call | |
680 | and then Is_Entity_Name (Name (Nod)) | |
681 | and then Is_Pure (Entity (Name (Nod))) | |
682 | then | |
683 | return Skip; | |
684 | ||
685 | -- Case of an identifier reference | |
686 | ||
687 | elsif Nkind (Nod) = N_Identifier then | |
688 | Ent := Entity (Nod); | |
689 | ||
690 | -- If no entity, then ignore the reference | |
691 | ||
692 | -- Not clear why this can happen. To investigate, remove this | |
693 | -- test and look at the crash that occurs here in 3401-004 ??? | |
694 | ||
695 | if No (Ent) then | |
696 | return Skip; | |
697 | ||
698 | -- Ignore entities with no Scope, again not clear how this | |
699 | -- can happen, to investigate, look at 4108-008 ??? | |
700 | ||
701 | elsif No (Scope (Ent)) then | |
702 | return Skip; | |
703 | ||
704 | -- Ignore the reference if not to a more global object | |
705 | ||
706 | elsif Scope_Depth (Scope (Ent)) >= Scop then | |
707 | return Skip; | |
708 | ||
709 | -- References to types, exceptions and constants are always OK | |
710 | ||
711 | elsif Is_Type (Ent) | |
712 | or else Ekind (Ent) = E_Exception | |
713 | or else Ekind (Ent) = E_Constant | |
714 | then | |
715 | return Skip; | |
716 | ||
717 | -- If other than a non-volatile scalar variable, we have some | |
718 | -- kind of global reference (e.g. to a function) that we cannot | |
719 | -- deal with so we forget the attempt. | |
720 | ||
721 | elsif Ekind (Ent) /= E_Variable | |
722 | or else not Is_Scalar_Type (Etype (Ent)) | |
fbf5a39b | 723 | or else Treat_As_Volatile (Ent) |
70482933 RK |
724 | then |
725 | return Abandon; | |
726 | ||
727 | -- Otherwise we have a reference to a global scalar | |
728 | ||
729 | else | |
730 | -- Loop through global entities already detected | |
731 | ||
732 | Elm := First_Elmt (Var_List); | |
733 | loop | |
734 | -- If not detected before, record this new global reference | |
735 | ||
736 | if No (Elm) then | |
737 | Count_Vars := Count_Vars + 1; | |
738 | ||
739 | if Count_Vars <= Max_Vars then | |
740 | Append_Elmt (Entity (Nod), Var_List); | |
741 | else | |
742 | return Abandon; | |
743 | end if; | |
744 | ||
745 | exit; | |
746 | ||
747 | -- If recorded before, ignore | |
748 | ||
749 | elsif Node (Elm) = Entity (Nod) then | |
750 | return Skip; | |
751 | ||
752 | -- Otherwise keep looking | |
753 | ||
754 | else | |
755 | Next_Elmt (Elm); | |
756 | end if; | |
757 | end loop; | |
758 | ||
759 | return Skip; | |
760 | end if; | |
761 | ||
762 | -- For all other node kinds, recursively visit syntactic children | |
763 | ||
764 | else | |
765 | return OK; | |
766 | end if; | |
767 | end Process; | |
768 | ||
02822a92 | 769 | function Traverse_Body is new Traverse_Func (Process); |
70482933 RK |
770 | |
771 | -- Start of processing for Detect_Infinite_Recursion | |
772 | ||
773 | begin | |
2f1b20a9 ES |
774 | -- Do not attempt detection in No_Implicit_Conditional mode, since we |
775 | -- won't be able to generate the code to handle the recursion in any | |
776 | -- case. | |
70482933 | 777 | |
6e937c1c | 778 | if Restriction_Active (No_Implicit_Conditionals) then |
70482933 RK |
779 | return; |
780 | end if; | |
781 | ||
782 | -- Otherwise do traversal and quit if we get abandon signal | |
783 | ||
784 | if Traverse_Body (N) = Abandon then | |
785 | return; | |
786 | ||
2f1b20a9 ES |
787 | -- We must have a call, since Has_Recursive_Call was set. If not just |
788 | -- ignore (this is only an error check, so if we have a funny situation, | |
789 | -- due to bugs or errors, we do not want to bomb!) | |
70482933 RK |
790 | |
791 | elsif Is_Empty_Elmt_List (Call_List) then | |
792 | return; | |
793 | end if; | |
794 | ||
795 | -- Here is the case where we detect recursion at compile time | |
796 | ||
2f1b20a9 ES |
797 | -- Push our current scope for analyzing the declarations and code that |
798 | -- we will insert for the checking. | |
70482933 | 799 | |
7888a6ae | 800 | Push_Scope (Spec); |
70482933 | 801 | |
2f1b20a9 ES |
802 | -- This loop builds temporary variables for each of the referenced |
803 | -- globals, so that at the end of the loop the list Shad_List contains | |
804 | -- these temporaries in one-to-one correspondence with the elements in | |
805 | -- Var_List. | |
70482933 RK |
806 | |
807 | Last := Empty; | |
808 | Elm := First_Elmt (Var_List); | |
809 | while Present (Elm) loop | |
810 | Var := Node (Elm); | |
811 | Ent := | |
812 | Make_Defining_Identifier (Loc, | |
813 | Chars => New_Internal_Name ('S')); | |
814 | Append_Elmt (Ent, Shad_List); | |
815 | ||
2f1b20a9 ES |
816 | -- Insert a declaration for this temporary at the start of the |
817 | -- declarations for the procedure. The temporaries are declared as | |
818 | -- constant objects initialized to the current values of the | |
819 | -- corresponding temporaries. | |
70482933 RK |
820 | |
821 | Decl := | |
822 | Make_Object_Declaration (Loc, | |
823 | Defining_Identifier => Ent, | |
824 | Object_Definition => New_Occurrence_Of (Etype (Var), Loc), | |
825 | Constant_Present => True, | |
826 | Expression => New_Occurrence_Of (Var, Loc)); | |
827 | ||
828 | if No (Last) then | |
829 | Prepend (Decl, Declarations (N)); | |
830 | else | |
831 | Insert_After (Last, Decl); | |
832 | end if; | |
833 | ||
834 | Last := Decl; | |
835 | Analyze (Decl); | |
836 | Next_Elmt (Elm); | |
837 | end loop; | |
838 | ||
839 | -- Loop through calls | |
840 | ||
841 | Call := First_Elmt (Call_List); | |
842 | while Present (Call) loop | |
843 | ||
844 | -- Build a predicate expression of the form | |
845 | ||
846 | -- True | |
847 | -- and then global1 = temp1 | |
848 | -- and then global2 = temp2 | |
849 | -- ... | |
850 | ||
851 | -- This predicate determines if any of the global values | |
852 | -- referenced by the procedure have changed since the | |
853 | -- current call, if not an infinite recursion is assured. | |
854 | ||
855 | Test := New_Occurrence_Of (Standard_True, Loc); | |
856 | ||
857 | Elm1 := First_Elmt (Var_List); | |
858 | Elm2 := First_Elmt (Shad_List); | |
859 | while Present (Elm1) loop | |
860 | Test := | |
861 | Make_And_Then (Loc, | |
862 | Left_Opnd => Test, | |
863 | Right_Opnd => | |
864 | Make_Op_Eq (Loc, | |
865 | Left_Opnd => New_Occurrence_Of (Node (Elm1), Loc), | |
866 | Right_Opnd => New_Occurrence_Of (Node (Elm2), Loc))); | |
867 | ||
868 | Next_Elmt (Elm1); | |
869 | Next_Elmt (Elm2); | |
870 | end loop; | |
871 | ||
872 | -- Now we replace the call with the sequence | |
873 | ||
874 | -- if no-changes (see above) then | |
875 | -- raise Storage_Error; | |
876 | -- else | |
877 | -- original-call | |
878 | -- end if; | |
879 | ||
880 | Rewrite (Node (Call), | |
881 | Make_If_Statement (Loc, | |
882 | Condition => Test, | |
883 | Then_Statements => New_List ( | |
07fc65c4 GB |
884 | Make_Raise_Storage_Error (Loc, |
885 | Reason => SE_Infinite_Recursion)), | |
70482933 RK |
886 | |
887 | Else_Statements => New_List ( | |
888 | Relocate_Node (Node (Call))))); | |
889 | ||
890 | Analyze (Node (Call)); | |
891 | ||
892 | Next_Elmt (Call); | |
893 | end loop; | |
894 | ||
895 | -- Remove temporary scope stack entry used for analysis | |
896 | ||
897 | Pop_Scope; | |
898 | end Detect_Infinite_Recursion; | |
899 | ||
900 | -------------------- | |
901 | -- Expand_Actuals -- | |
902 | -------------------- | |
903 | ||
904 | procedure Expand_Actuals (N : Node_Id; Subp : Entity_Id) is | |
905 | Loc : constant Source_Ptr := Sloc (N); | |
906 | Actual : Node_Id; | |
907 | Formal : Entity_Id; | |
908 | N_Node : Node_Id; | |
909 | Post_Call : List_Id; | |
910 | E_Formal : Entity_Id; | |
911 | ||
912 | procedure Add_Call_By_Copy_Code; | |
fbf5a39b AC |
913 | -- For cases where the parameter must be passed by copy, this routine |
914 | -- generates a temporary variable into which the actual is copied and | |
915 | -- then passes this as the parameter. For an OUT or IN OUT parameter, | |
916 | -- an assignment is also generated to copy the result back. The call | |
917 | -- also takes care of any constraint checks required for the type | |
918 | -- conversion case (on both the way in and the way out). | |
70482933 | 919 | |
f44fe430 RD |
920 | procedure Add_Simple_Call_By_Copy_Code; |
921 | -- This is similar to the above, but is used in cases where we know | |
922 | -- that all that is needed is to simply create a temporary and copy | |
923 | -- the value in and out of the temporary. | |
70482933 RK |
924 | |
925 | procedure Check_Fortran_Logical; | |
926 | -- A value of type Logical that is passed through a formal parameter | |
927 | -- must be normalized because .TRUE. usually does not have the same | |
928 | -- representation as True. We assume that .FALSE. = False = 0. | |
929 | -- What about functions that return a logical type ??? | |
930 | ||
758c442c GD |
931 | function Is_Legal_Copy return Boolean; |
932 | -- Check that an actual can be copied before generating the temporary | |
933 | -- to be used in the call. If the actual is of a by_reference type then | |
934 | -- the program is illegal (this can only happen in the presence of | |
935 | -- rep. clauses that force an incorrect alignment). If the formal is | |
936 | -- a by_reference parameter imposed by a DEC pragma, emit a warning to | |
937 | -- the effect that this might lead to unaligned arguments. | |
938 | ||
70482933 RK |
939 | function Make_Var (Actual : Node_Id) return Entity_Id; |
940 | -- Returns an entity that refers to the given actual parameter, | |
941 | -- Actual (not including any type conversion). If Actual is an | |
942 | -- entity name, then this entity is returned unchanged, otherwise | |
943 | -- a renaming is created to provide an entity for the actual. | |
944 | ||
945 | procedure Reset_Packed_Prefix; | |
946 | -- The expansion of a packed array component reference is delayed in | |
947 | -- the context of a call. Now we need to complete the expansion, so we | |
948 | -- unmark the analyzed bits in all prefixes. | |
949 | ||
950 | --------------------------- | |
951 | -- Add_Call_By_Copy_Code -- | |
952 | --------------------------- | |
953 | ||
954 | procedure Add_Call_By_Copy_Code is | |
cc335f43 AC |
955 | Expr : Node_Id; |
956 | Init : Node_Id; | |
957 | Temp : Entity_Id; | |
f44fe430 | 958 | Indic : Node_Id; |
cc335f43 | 959 | Var : Entity_Id; |
0da2c8ac | 960 | F_Typ : constant Entity_Id := Etype (Formal); |
cc335f43 AC |
961 | V_Typ : Entity_Id; |
962 | Crep : Boolean; | |
70482933 RK |
963 | |
964 | begin | |
758c442c GD |
965 | if not Is_Legal_Copy then |
966 | return; | |
967 | end if; | |
968 | ||
02822a92 RD |
969 | Temp := |
970 | Make_Defining_Identifier (Loc, | |
971 | Chars => New_Internal_Name ('T')); | |
70482933 | 972 | |
f44fe430 RD |
973 | -- Use formal type for temp, unless formal type is an unconstrained |
974 | -- array, in which case we don't have to worry about bounds checks, | |
758c442c | 975 | -- and we use the actual type, since that has appropriate bounds. |
f44fe430 RD |
976 | |
977 | if Is_Array_Type (F_Typ) and then not Is_Constrained (F_Typ) then | |
978 | Indic := New_Occurrence_Of (Etype (Actual), Loc); | |
979 | else | |
980 | Indic := New_Occurrence_Of (Etype (Formal), Loc); | |
981 | end if; | |
982 | ||
70482933 RK |
983 | if Nkind (Actual) = N_Type_Conversion then |
984 | V_Typ := Etype (Expression (Actual)); | |
19f0526a AC |
985 | |
986 | -- If the formal is an (in-)out parameter, capture the name | |
987 | -- of the variable in order to build the post-call assignment. | |
81a5b587 AC |
988 | |
989 | Var := Make_Var (Expression (Actual)); | |
19f0526a | 990 | |
08aa9a4a | 991 | Crep := not Same_Representation |
0da2c8ac | 992 | (F_Typ, Etype (Expression (Actual))); |
08aa9a4a | 993 | |
70482933 RK |
994 | else |
995 | V_Typ := Etype (Actual); | |
996 | Var := Make_Var (Actual); | |
997 | Crep := False; | |
998 | end if; | |
999 | ||
1000 | -- Setup initialization for case of in out parameter, or an out | |
1001 | -- parameter where the formal is an unconstrained array (in the | |
1002 | -- latter case, we have to pass in an object with bounds). | |
1003 | ||
cc335f43 AC |
1004 | -- If this is an out parameter, the initial copy is wasteful, so as |
1005 | -- an optimization for the one-dimensional case we extract the | |
1006 | -- bounds of the actual and build an uninitialized temporary of the | |
1007 | -- right size. | |
1008 | ||
70482933 | 1009 | if Ekind (Formal) = E_In_Out_Parameter |
0da2c8ac | 1010 | or else (Is_Array_Type (F_Typ) and then not Is_Constrained (F_Typ)) |
70482933 RK |
1011 | then |
1012 | if Nkind (Actual) = N_Type_Conversion then | |
1013 | if Conversion_OK (Actual) then | |
0da2c8ac | 1014 | Init := OK_Convert_To (F_Typ, New_Occurrence_Of (Var, Loc)); |
70482933 | 1015 | else |
0da2c8ac | 1016 | Init := Convert_To (F_Typ, New_Occurrence_Of (Var, Loc)); |
70482933 | 1017 | end if; |
cc335f43 AC |
1018 | |
1019 | elsif Ekind (Formal) = E_Out_Parameter | |
0da2c8ac AC |
1020 | and then Is_Array_Type (F_Typ) |
1021 | and then Number_Dimensions (F_Typ) = 1 | |
1022 | and then not Has_Non_Null_Base_Init_Proc (F_Typ) | |
cc335f43 AC |
1023 | then |
1024 | -- Actual is a one-dimensional array or slice, and the type | |
1025 | -- requires no initialization. Create a temporary of the | |
f44fe430 | 1026 | -- right size, but do not copy actual into it (optimization). |
cc335f43 AC |
1027 | |
1028 | Init := Empty; | |
1029 | Indic := | |
1030 | Make_Subtype_Indication (Loc, | |
1031 | Subtype_Mark => | |
0da2c8ac | 1032 | New_Occurrence_Of (F_Typ, Loc), |
cc335f43 AC |
1033 | Constraint => |
1034 | Make_Index_Or_Discriminant_Constraint (Loc, | |
1035 | Constraints => New_List ( | |
1036 | Make_Range (Loc, | |
1037 | Low_Bound => | |
1038 | Make_Attribute_Reference (Loc, | |
1039 | Prefix => New_Occurrence_Of (Var, Loc), | |
70f91180 | 1040 | Attribute_Name => Name_First), |
cc335f43 AC |
1041 | High_Bound => |
1042 | Make_Attribute_Reference (Loc, | |
1043 | Prefix => New_Occurrence_Of (Var, Loc), | |
1044 | Attribute_Name => Name_Last))))); | |
1045 | ||
70482933 RK |
1046 | else |
1047 | Init := New_Occurrence_Of (Var, Loc); | |
1048 | end if; | |
1049 | ||
1050 | -- An initialization is created for packed conversions as | |
1051 | -- actuals for out parameters to enable Make_Object_Declaration | |
1052 | -- to determine the proper subtype for N_Node. Note that this | |
1053 | -- is wasteful because the extra copying on the call side is | |
1054 | -- not required for such out parameters. ??? | |
1055 | ||
1056 | elsif Ekind (Formal) = E_Out_Parameter | |
1057 | and then Nkind (Actual) = N_Type_Conversion | |
0da2c8ac | 1058 | and then (Is_Bit_Packed_Array (F_Typ) |
70482933 RK |
1059 | or else |
1060 | Is_Bit_Packed_Array (Etype (Expression (Actual)))) | |
1061 | then | |
1062 | if Conversion_OK (Actual) then | |
f44fe430 | 1063 | Init := OK_Convert_To (F_Typ, New_Occurrence_Of (Var, Loc)); |
70482933 | 1064 | else |
f44fe430 | 1065 | Init := Convert_To (F_Typ, New_Occurrence_Of (Var, Loc)); |
70482933 | 1066 | end if; |
2e071734 AC |
1067 | |
1068 | elsif Ekind (Formal) = E_In_Parameter then | |
02822a92 RD |
1069 | |
1070 | -- Handle the case in which the actual is a type conversion | |
1071 | ||
1072 | if Nkind (Actual) = N_Type_Conversion then | |
1073 | if Conversion_OK (Actual) then | |
1074 | Init := OK_Convert_To (F_Typ, New_Occurrence_Of (Var, Loc)); | |
1075 | else | |
1076 | Init := Convert_To (F_Typ, New_Occurrence_Of (Var, Loc)); | |
1077 | end if; | |
1078 | else | |
1079 | Init := New_Occurrence_Of (Var, Loc); | |
1080 | end if; | |
2e071734 | 1081 | |
70482933 RK |
1082 | else |
1083 | Init := Empty; | |
1084 | end if; | |
1085 | ||
1086 | N_Node := | |
1087 | Make_Object_Declaration (Loc, | |
1088 | Defining_Identifier => Temp, | |
cc335f43 | 1089 | Object_Definition => Indic, |
f44fe430 | 1090 | Expression => Init); |
70482933 RK |
1091 | Set_Assignment_OK (N_Node); |
1092 | Insert_Action (N, N_Node); | |
1093 | ||
1094 | -- Now, normally the deal here is that we use the defining | |
1095 | -- identifier created by that object declaration. There is | |
1096 | -- one exception to this. In the change of representation case | |
1097 | -- the above declaration will end up looking like: | |
1098 | ||
1099 | -- temp : type := identifier; | |
1100 | ||
1101 | -- And in this case we might as well use the identifier directly | |
1102 | -- and eliminate the temporary. Note that the analysis of the | |
1103 | -- declaration was not a waste of time in that case, since it is | |
1104 | -- what generated the necessary change of representation code. If | |
1105 | -- the change of representation introduced additional code, as in | |
1106 | -- a fixed-integer conversion, the expression is not an identifier | |
1107 | -- and must be kept. | |
1108 | ||
1109 | if Crep | |
1110 | and then Present (Expression (N_Node)) | |
1111 | and then Is_Entity_Name (Expression (N_Node)) | |
1112 | then | |
1113 | Temp := Entity (Expression (N_Node)); | |
1114 | Rewrite (N_Node, Make_Null_Statement (Loc)); | |
1115 | end if; | |
1116 | ||
fbf5a39b | 1117 | -- For IN parameter, all we do is to replace the actual |
70482933 | 1118 | |
fbf5a39b AC |
1119 | if Ekind (Formal) = E_In_Parameter then |
1120 | Rewrite (Actual, New_Reference_To (Temp, Loc)); | |
1121 | Analyze (Actual); | |
1122 | ||
1123 | -- Processing for OUT or IN OUT parameter | |
1124 | ||
1125 | else | |
c8ef728f ES |
1126 | -- Kill current value indications for the temporary variable we |
1127 | -- created, since we just passed it as an OUT parameter. | |
1128 | ||
1129 | Kill_Current_Values (Temp); | |
75ba322d | 1130 | Set_Is_Known_Valid (Temp, False); |
c8ef728f | 1131 | |
fbf5a39b AC |
1132 | -- If type conversion, use reverse conversion on exit |
1133 | ||
1134 | if Nkind (Actual) = N_Type_Conversion then | |
1135 | if Conversion_OK (Actual) then | |
1136 | Expr := OK_Convert_To (V_Typ, New_Occurrence_Of (Temp, Loc)); | |
1137 | else | |
1138 | Expr := Convert_To (V_Typ, New_Occurrence_Of (Temp, Loc)); | |
1139 | end if; | |
70482933 | 1140 | else |
fbf5a39b | 1141 | Expr := New_Occurrence_Of (Temp, Loc); |
70482933 | 1142 | end if; |
70482933 | 1143 | |
fbf5a39b AC |
1144 | Rewrite (Actual, New_Reference_To (Temp, Loc)); |
1145 | Analyze (Actual); | |
70482933 | 1146 | |
d766cee3 RD |
1147 | -- If the actual is a conversion of a packed reference, it may |
1148 | -- already have been expanded by Remove_Side_Effects, and the | |
1149 | -- resulting variable is a temporary which does not designate | |
1150 | -- the proper out-parameter, which may not be addressable. In | |
1151 | -- that case, generate an assignment to the original expression | |
b0159fbe | 1152 | -- (before expansion of the packed reference) so that the proper |
d766cee3 | 1153 | -- expansion of assignment to a packed component can take place. |
70482933 | 1154 | |
d766cee3 RD |
1155 | declare |
1156 | Obj : Node_Id; | |
1157 | Lhs : Node_Id; | |
1158 | ||
1159 | begin | |
1160 | if Is_Renaming_Of_Object (Var) | |
1161 | and then Nkind (Renamed_Object (Var)) = N_Selected_Component | |
1162 | and then Is_Entity_Name (Prefix (Renamed_Object (Var))) | |
1163 | and then Nkind (Original_Node (Prefix (Renamed_Object (Var)))) | |
1164 | = N_Indexed_Component | |
1165 | and then | |
1166 | Has_Non_Standard_Rep (Etype (Prefix (Renamed_Object (Var)))) | |
1167 | then | |
1168 | Obj := Renamed_Object (Var); | |
1169 | Lhs := | |
1170 | Make_Selected_Component (Loc, | |
1171 | Prefix => | |
1172 | New_Copy_Tree (Original_Node (Prefix (Obj))), | |
1173 | Selector_Name => New_Copy (Selector_Name (Obj))); | |
1174 | Reset_Analyzed_Flags (Lhs); | |
1175 | ||
1176 | else | |
1177 | Lhs := New_Occurrence_Of (Var, Loc); | |
1178 | end if; | |
1179 | ||
1180 | Set_Assignment_OK (Lhs); | |
1181 | ||
1182 | Append_To (Post_Call, | |
1183 | Make_Assignment_Statement (Loc, | |
1184 | Name => Lhs, | |
1185 | Expression => Expr)); | |
1186 | end; | |
fbf5a39b | 1187 | end if; |
70482933 RK |
1188 | end Add_Call_By_Copy_Code; |
1189 | ||
1190 | ---------------------------------- | |
f44fe430 | 1191 | -- Add_Simple_Call_By_Copy_Code -- |
70482933 RK |
1192 | ---------------------------------- |
1193 | ||
f44fe430 | 1194 | procedure Add_Simple_Call_By_Copy_Code is |
70482933 | 1195 | Temp : Entity_Id; |
758c442c | 1196 | Decl : Node_Id; |
70482933 RK |
1197 | Incod : Node_Id; |
1198 | Outcod : Node_Id; | |
1199 | Lhs : Node_Id; | |
1200 | Rhs : Node_Id; | |
f44fe430 RD |
1201 | Indic : Node_Id; |
1202 | F_Typ : constant Entity_Id := Etype (Formal); | |
70482933 RK |
1203 | |
1204 | begin | |
758c442c GD |
1205 | if not Is_Legal_Copy then |
1206 | return; | |
1207 | end if; | |
1208 | ||
f44fe430 RD |
1209 | -- Use formal type for temp, unless formal type is an unconstrained |
1210 | -- array, in which case we don't have to worry about bounds checks, | |
758c442c | 1211 | -- and we use the actual type, since that has appropriate bounds. |
f44fe430 RD |
1212 | |
1213 | if Is_Array_Type (F_Typ) and then not Is_Constrained (F_Typ) then | |
1214 | Indic := New_Occurrence_Of (Etype (Actual), Loc); | |
1215 | else | |
1216 | Indic := New_Occurrence_Of (Etype (Formal), Loc); | |
1217 | end if; | |
70482933 RK |
1218 | |
1219 | -- Prepare to generate code | |
1220 | ||
f44fe430 RD |
1221 | Reset_Packed_Prefix; |
1222 | ||
02822a92 RD |
1223 | Temp := |
1224 | Make_Defining_Identifier (Loc, | |
1225 | Chars => New_Internal_Name ('T')); | |
70482933 RK |
1226 | Incod := Relocate_Node (Actual); |
1227 | Outcod := New_Copy_Tree (Incod); | |
1228 | ||
1229 | -- Generate declaration of temporary variable, initializing it | |
c73ae90f | 1230 | -- with the input parameter unless we have an OUT formal or |
758c442c | 1231 | -- this is an initialization call. |
70482933 | 1232 | |
c73ae90f GD |
1233 | -- If the formal is an out parameter with discriminants, the |
1234 | -- discriminants must be captured even if the rest of the object | |
1235 | -- is in principle uninitialized, because the discriminants may | |
1236 | -- be read by the called subprogram. | |
1237 | ||
70482933 RK |
1238 | if Ekind (Formal) = E_Out_Parameter then |
1239 | Incod := Empty; | |
758c442c | 1240 | |
c73ae90f GD |
1241 | if Has_Discriminants (Etype (Formal)) then |
1242 | Indic := New_Occurrence_Of (Etype (Actual), Loc); | |
1243 | end if; | |
1244 | ||
758c442c | 1245 | elsif Inside_Init_Proc then |
c73ae90f GD |
1246 | |
1247 | -- Could use a comment here to match comment below ??? | |
1248 | ||
758c442c GD |
1249 | if Nkind (Actual) /= N_Selected_Component |
1250 | or else | |
1251 | not Has_Discriminant_Dependent_Constraint | |
1252 | (Entity (Selector_Name (Actual))) | |
1253 | then | |
1254 | Incod := Empty; | |
1255 | ||
c73ae90f GD |
1256 | -- Otherwise, keep the component in order to generate the proper |
1257 | -- actual subtype, that depends on enclosing discriminants. | |
758c442c | 1258 | |
c73ae90f | 1259 | else |
758c442c GD |
1260 | null; |
1261 | end if; | |
70482933 RK |
1262 | end if; |
1263 | ||
758c442c | 1264 | Decl := |
70482933 RK |
1265 | Make_Object_Declaration (Loc, |
1266 | Defining_Identifier => Temp, | |
f44fe430 | 1267 | Object_Definition => Indic, |
758c442c GD |
1268 | Expression => Incod); |
1269 | ||
1270 | if Inside_Init_Proc | |
1271 | and then No (Incod) | |
1272 | then | |
1273 | -- If the call is to initialize a component of a composite type, | |
1274 | -- and the component does not depend on discriminants, use the | |
1275 | -- actual type of the component. This is required in case the | |
1276 | -- component is constrained, because in general the formal of the | |
1277 | -- initialization procedure will be unconstrained. Note that if | |
1278 | -- the component being initialized is constrained by an enclosing | |
1279 | -- discriminant, the presence of the initialization in the | |
1280 | -- declaration will generate an expression for the actual subtype. | |
1281 | ||
1282 | Set_No_Initialization (Decl); | |
1283 | Set_Object_Definition (Decl, | |
1284 | New_Occurrence_Of (Etype (Actual), Loc)); | |
1285 | end if; | |
1286 | ||
1287 | Insert_Action (N, Decl); | |
70482933 RK |
1288 | |
1289 | -- The actual is simply a reference to the temporary | |
1290 | ||
1291 | Rewrite (Actual, New_Occurrence_Of (Temp, Loc)); | |
1292 | ||
1293 | -- Generate copy out if OUT or IN OUT parameter | |
1294 | ||
1295 | if Ekind (Formal) /= E_In_Parameter then | |
1296 | Lhs := Outcod; | |
1297 | Rhs := New_Occurrence_Of (Temp, Loc); | |
1298 | ||
1299 | -- Deal with conversion | |
1300 | ||
1301 | if Nkind (Lhs) = N_Type_Conversion then | |
1302 | Lhs := Expression (Lhs); | |
1303 | Rhs := Convert_To (Etype (Actual), Rhs); | |
1304 | end if; | |
1305 | ||
1306 | Append_To (Post_Call, | |
1307 | Make_Assignment_Statement (Loc, | |
1308 | Name => Lhs, | |
1309 | Expression => Rhs)); | |
f44fe430 | 1310 | Set_Assignment_OK (Name (Last (Post_Call))); |
70482933 | 1311 | end if; |
f44fe430 | 1312 | end Add_Simple_Call_By_Copy_Code; |
70482933 RK |
1313 | |
1314 | --------------------------- | |
1315 | -- Check_Fortran_Logical -- | |
1316 | --------------------------- | |
1317 | ||
1318 | procedure Check_Fortran_Logical is | |
fbf5a39b | 1319 | Logical : constant Entity_Id := Etype (Formal); |
70482933 RK |
1320 | Var : Entity_Id; |
1321 | ||
1322 | -- Note: this is very incomplete, e.g. it does not handle arrays | |
1323 | -- of logical values. This is really not the right approach at all???) | |
1324 | ||
1325 | begin | |
1326 | if Convention (Subp) = Convention_Fortran | |
1327 | and then Root_Type (Etype (Formal)) = Standard_Boolean | |
1328 | and then Ekind (Formal) /= E_In_Parameter | |
1329 | then | |
1330 | Var := Make_Var (Actual); | |
1331 | Append_To (Post_Call, | |
1332 | Make_Assignment_Statement (Loc, | |
1333 | Name => New_Occurrence_Of (Var, Loc), | |
1334 | Expression => | |
1335 | Unchecked_Convert_To ( | |
1336 | Logical, | |
1337 | Make_Op_Ne (Loc, | |
1338 | Left_Opnd => New_Occurrence_Of (Var, Loc), | |
1339 | Right_Opnd => | |
1340 | Unchecked_Convert_To ( | |
1341 | Logical, | |
1342 | New_Occurrence_Of (Standard_False, Loc)))))); | |
1343 | end if; | |
1344 | end Check_Fortran_Logical; | |
1345 | ||
758c442c GD |
1346 | ------------------- |
1347 | -- Is_Legal_Copy -- | |
1348 | ------------------- | |
1349 | ||
1350 | function Is_Legal_Copy return Boolean is | |
1351 | begin | |
1352 | -- An attempt to copy a value of such a type can only occur if | |
1353 | -- representation clauses give the actual a misaligned address. | |
1354 | ||
1355 | if Is_By_Reference_Type (Etype (Formal)) then | |
1356 | Error_Msg_N | |
1357 | ("misaligned actual cannot be passed by reference", Actual); | |
1358 | return False; | |
1359 | ||
1360 | -- For users of Starlet, we assume that the specification of by- | |
7888a6ae | 1361 | -- reference mechanism is mandatory. This may lead to unaligned |
758c442c GD |
1362 | -- objects but at least for DEC legacy code it is known to work. |
1363 | -- The warning will alert users of this code that a problem may | |
1364 | -- be lurking. | |
1365 | ||
1366 | elsif Mechanism (Formal) = By_Reference | |
1367 | and then Is_Valued_Procedure (Scope (Formal)) | |
1368 | then | |
1369 | Error_Msg_N | |
1370 | ("by_reference actual may be misaligned?", Actual); | |
1371 | return False; | |
1372 | ||
1373 | else | |
1374 | return True; | |
1375 | end if; | |
1376 | end Is_Legal_Copy; | |
1377 | ||
70482933 RK |
1378 | -------------- |
1379 | -- Make_Var -- | |
1380 | -------------- | |
1381 | ||
1382 | function Make_Var (Actual : Node_Id) return Entity_Id is | |
1383 | Var : Entity_Id; | |
1384 | ||
1385 | begin | |
1386 | if Is_Entity_Name (Actual) then | |
1387 | return Entity (Actual); | |
1388 | ||
1389 | else | |
02822a92 RD |
1390 | Var := |
1391 | Make_Defining_Identifier (Loc, | |
1392 | Chars => New_Internal_Name ('T')); | |
70482933 RK |
1393 | |
1394 | N_Node := | |
1395 | Make_Object_Renaming_Declaration (Loc, | |
1396 | Defining_Identifier => Var, | |
1397 | Subtype_Mark => | |
1398 | New_Occurrence_Of (Etype (Actual), Loc), | |
1399 | Name => Relocate_Node (Actual)); | |
1400 | ||
1401 | Insert_Action (N, N_Node); | |
1402 | return Var; | |
1403 | end if; | |
1404 | end Make_Var; | |
1405 | ||
1406 | ------------------------- | |
1407 | -- Reset_Packed_Prefix -- | |
1408 | ------------------------- | |
1409 | ||
1410 | procedure Reset_Packed_Prefix is | |
1411 | Pfx : Node_Id := Actual; | |
70482933 RK |
1412 | begin |
1413 | loop | |
1414 | Set_Analyzed (Pfx, False); | |
ac4d6407 RD |
1415 | exit when |
1416 | not Nkind_In (Pfx, N_Selected_Component, N_Indexed_Component); | |
70482933 RK |
1417 | Pfx := Prefix (Pfx); |
1418 | end loop; | |
1419 | end Reset_Packed_Prefix; | |
1420 | ||
1421 | -- Start of processing for Expand_Actuals | |
1422 | ||
1423 | begin | |
70482933 RK |
1424 | Post_Call := New_List; |
1425 | ||
2f1b20a9 ES |
1426 | Formal := First_Formal (Subp); |
1427 | Actual := First_Actual (N); | |
70482933 RK |
1428 | while Present (Formal) loop |
1429 | E_Formal := Etype (Formal); | |
1430 | ||
1431 | if Is_Scalar_Type (E_Formal) | |
1432 | or else Nkind (Actual) = N_Slice | |
1433 | then | |
1434 | Check_Fortran_Logical; | |
1435 | ||
1436 | -- RM 6.4.1 (11) | |
1437 | ||
1438 | elsif Ekind (Formal) /= E_Out_Parameter then | |
1439 | ||
1440 | -- The unusual case of the current instance of a protected type | |
1441 | -- requires special handling. This can only occur in the context | |
1442 | -- of a call within the body of a protected operation. | |
1443 | ||
1444 | if Is_Entity_Name (Actual) | |
1445 | and then Ekind (Entity (Actual)) = E_Protected_Type | |
1446 | and then In_Open_Scopes (Entity (Actual)) | |
1447 | then | |
1448 | if Scope (Subp) /= Entity (Actual) then | |
1449 | Error_Msg_N ("operation outside protected type may not " | |
1450 | & "call back its protected operations?", Actual); | |
1451 | end if; | |
1452 | ||
1453 | Rewrite (Actual, | |
1454 | Expand_Protected_Object_Reference (N, Entity (Actual))); | |
1455 | end if; | |
1456 | ||
02822a92 RD |
1457 | -- Ada 2005 (AI-318-02): If the actual parameter is a call to a |
1458 | -- build-in-place function, then a temporary return object needs | |
1459 | -- to be created and access to it must be passed to the function. | |
f937473f RD |
1460 | -- Currently we limit such functions to those with inherently |
1461 | -- limited result subtypes, but eventually we plan to expand the | |
1462 | -- functions that are treated as build-in-place to include other | |
1463 | -- composite result types. | |
02822a92 RD |
1464 | |
1465 | if Ada_Version >= Ada_05 | |
1466 | and then Is_Build_In_Place_Function_Call (Actual) | |
1467 | then | |
1468 | Make_Build_In_Place_Call_In_Anonymous_Context (Actual); | |
1469 | end if; | |
1470 | ||
70482933 RK |
1471 | Apply_Constraint_Check (Actual, E_Formal); |
1472 | ||
1473 | -- Out parameter case. No constraint checks on access type | |
1474 | -- RM 6.4.1 (13) | |
1475 | ||
1476 | elsif Is_Access_Type (E_Formal) then | |
1477 | null; | |
1478 | ||
1479 | -- RM 6.4.1 (14) | |
1480 | ||
1481 | elsif Has_Discriminants (Base_Type (E_Formal)) | |
1482 | or else Has_Non_Null_Base_Init_Proc (E_Formal) | |
1483 | then | |
1484 | Apply_Constraint_Check (Actual, E_Formal); | |
1485 | ||
1486 | -- RM 6.4.1 (15) | |
1487 | ||
1488 | else | |
1489 | Apply_Constraint_Check (Actual, Base_Type (E_Formal)); | |
1490 | end if; | |
1491 | ||
1492 | -- Processing for IN-OUT and OUT parameters | |
1493 | ||
1494 | if Ekind (Formal) /= E_In_Parameter then | |
1495 | ||
1496 | -- For type conversions of arrays, apply length/range checks | |
1497 | ||
1498 | if Is_Array_Type (E_Formal) | |
1499 | and then Nkind (Actual) = N_Type_Conversion | |
1500 | then | |
1501 | if Is_Constrained (E_Formal) then | |
1502 | Apply_Length_Check (Expression (Actual), E_Formal); | |
1503 | else | |
1504 | Apply_Range_Check (Expression (Actual), E_Formal); | |
1505 | end if; | |
1506 | end if; | |
1507 | ||
1508 | -- If argument is a type conversion for a type that is passed | |
1509 | -- by copy, then we must pass the parameter by copy. | |
1510 | ||
1511 | if Nkind (Actual) = N_Type_Conversion | |
1512 | and then | |
1513 | (Is_Numeric_Type (E_Formal) | |
1514 | or else Is_Access_Type (E_Formal) | |
1515 | or else Is_Enumeration_Type (E_Formal) | |
1516 | or else Is_Bit_Packed_Array (Etype (Formal)) | |
1517 | or else Is_Bit_Packed_Array (Etype (Expression (Actual))) | |
1518 | ||
1519 | -- Also pass by copy if change of representation | |
1520 | ||
1521 | or else not Same_Representation | |
1522 | (Etype (Formal), | |
1523 | Etype (Expression (Actual)))) | |
1524 | then | |
1525 | Add_Call_By_Copy_Code; | |
1526 | ||
1527 | -- References to components of bit packed arrays are expanded | |
1528 | -- at this point, rather than at the point of analysis of the | |
1529 | -- actuals, to handle the expansion of the assignment to | |
1530 | -- [in] out parameters. | |
1531 | ||
1532 | elsif Is_Ref_To_Bit_Packed_Array (Actual) then | |
f44fe430 RD |
1533 | Add_Simple_Call_By_Copy_Code; |
1534 | ||
02822a92 RD |
1535 | -- If a non-scalar actual is possibly bit-aligned, we need a copy |
1536 | -- because the back-end cannot cope with such objects. In other | |
1537 | -- cases where alignment forces a copy, the back-end generates | |
1538 | -- it properly. It should not be generated unconditionally in the | |
1539 | -- front-end because it does not know precisely the alignment | |
1540 | -- requirements of the target, and makes too conservative an | |
1541 | -- estimate, leading to superfluous copies or spurious errors | |
1542 | -- on by-reference parameters. | |
f44fe430 | 1543 | |
02822a92 RD |
1544 | elsif Nkind (Actual) = N_Selected_Component |
1545 | and then | |
1546 | Component_May_Be_Bit_Aligned (Entity (Selector_Name (Actual))) | |
f44fe430 RD |
1547 | and then not Represented_As_Scalar (Etype (Formal)) |
1548 | then | |
1549 | Add_Simple_Call_By_Copy_Code; | |
70482933 RK |
1550 | |
1551 | -- References to slices of bit packed arrays are expanded | |
1552 | ||
1553 | elsif Is_Ref_To_Bit_Packed_Slice (Actual) then | |
1554 | Add_Call_By_Copy_Code; | |
1555 | ||
fbf5a39b AC |
1556 | -- References to possibly unaligned slices of arrays are expanded |
1557 | ||
1558 | elsif Is_Possibly_Unaligned_Slice (Actual) then | |
1559 | Add_Call_By_Copy_Code; | |
1560 | ||
7888a6ae | 1561 | -- Deal with access types where the actual subtype and the |
70482933 RK |
1562 | -- formal subtype are not the same, requiring a check. |
1563 | ||
638e383e | 1564 | -- It is necessary to exclude tagged types because of "downward |
70f91180 | 1565 | -- conversion" errors. |
70482933 RK |
1566 | |
1567 | elsif Is_Access_Type (E_Formal) | |
1568 | and then not Same_Type (E_Formal, Etype (Actual)) | |
1569 | and then not Is_Tagged_Type (Designated_Type (E_Formal)) | |
1570 | then | |
1571 | Add_Call_By_Copy_Code; | |
1572 | ||
faf3cf91 ES |
1573 | -- If the actual is not a scalar and is marked for volatile |
1574 | -- treatment, whereas the formal is not volatile, then pass | |
1575 | -- by copy unless it is a by-reference type. | |
1576 | ||
0386aad1 AC |
1577 | -- Note: we use Is_Volatile here rather than Treat_As_Volatile, |
1578 | -- because this is the enforcement of a language rule that applies | |
1579 | -- only to "real" volatile variables, not e.g. to the address | |
1580 | -- clause overlay case. | |
1581 | ||
70482933 | 1582 | elsif Is_Entity_Name (Actual) |
0386aad1 | 1583 | and then Is_Volatile (Entity (Actual)) |
faf3cf91 | 1584 | and then not Is_By_Reference_Type (Etype (Actual)) |
70482933 | 1585 | and then not Is_Scalar_Type (Etype (Entity (Actual))) |
0386aad1 | 1586 | and then not Is_Volatile (E_Formal) |
70482933 RK |
1587 | then |
1588 | Add_Call_By_Copy_Code; | |
1589 | ||
1590 | elsif Nkind (Actual) = N_Indexed_Component | |
1591 | and then Is_Entity_Name (Prefix (Actual)) | |
1592 | and then Has_Volatile_Components (Entity (Prefix (Actual))) | |
1593 | then | |
1594 | Add_Call_By_Copy_Code; | |
d79e621a GD |
1595 | |
1596 | -- Add call-by-copy code for the case of scalar out parameters | |
1597 | -- when it is not known at compile time that the subtype of the | |
c2369146 AC |
1598 | -- formal is a subrange of the subtype of the actual (or vice |
1599 | -- versa for in out parameters), in order to get range checks | |
1600 | -- on such actuals. (Maybe this case should be handled earlier | |
1601 | -- in the if statement???) | |
d79e621a GD |
1602 | |
1603 | elsif Is_Scalar_Type (E_Formal) | |
c2369146 AC |
1604 | and then |
1605 | (not In_Subrange_Of (E_Formal, Etype (Actual)) | |
1606 | or else | |
1607 | (Ekind (Formal) = E_In_Out_Parameter | |
1608 | and then not In_Subrange_Of (Etype (Actual), E_Formal))) | |
d79e621a GD |
1609 | then |
1610 | -- Perhaps the setting back to False should be done within | |
1611 | -- Add_Call_By_Copy_Code, since it could get set on other | |
1612 | -- cases occurring above??? | |
1613 | ||
1614 | if Do_Range_Check (Actual) then | |
1615 | Set_Do_Range_Check (Actual, False); | |
1616 | end if; | |
1617 | ||
1618 | Add_Call_By_Copy_Code; | |
70482933 RK |
1619 | end if; |
1620 | ||
fbf5a39b | 1621 | -- Processing for IN parameters |
70482933 RK |
1622 | |
1623 | else | |
fbf5a39b AC |
1624 | -- For IN parameters is in the packed array case, we expand an |
1625 | -- indexed component (the circuit in Exp_Ch4 deliberately left | |
1626 | -- indexed components appearing as actuals untouched, so that | |
1627 | -- the special processing above for the OUT and IN OUT cases | |
1628 | -- could be performed. We could make the test in Exp_Ch4 more | |
1629 | -- complex and have it detect the parameter mode, but it is | |
f44fe430 | 1630 | -- easier simply to handle all cases here.) |
fbf5a39b | 1631 | |
70482933 RK |
1632 | if Nkind (Actual) = N_Indexed_Component |
1633 | and then Is_Packed (Etype (Prefix (Actual))) | |
1634 | then | |
1635 | Reset_Packed_Prefix; | |
1636 | Expand_Packed_Element_Reference (Actual); | |
1637 | ||
0386aad1 AC |
1638 | -- If we have a reference to a bit packed array, we copy it, since |
1639 | -- the actual must be byte aligned. | |
70482933 | 1640 | |
fbf5a39b | 1641 | -- Is this really necessary in all cases??? |
70482933 | 1642 | |
fbf5a39b | 1643 | elsif Is_Ref_To_Bit_Packed_Array (Actual) then |
f44fe430 RD |
1644 | Add_Simple_Call_By_Copy_Code; |
1645 | ||
1646 | -- If a non-scalar actual is possibly unaligned, we need a copy | |
1647 | ||
1648 | elsif Is_Possibly_Unaligned_Object (Actual) | |
1649 | and then not Represented_As_Scalar (Etype (Formal)) | |
1650 | then | |
1651 | Add_Simple_Call_By_Copy_Code; | |
70482933 | 1652 | |
fbf5a39b AC |
1653 | -- Similarly, we have to expand slices of packed arrays here |
1654 | -- because the result must be byte aligned. | |
70482933 | 1655 | |
fbf5a39b AC |
1656 | elsif Is_Ref_To_Bit_Packed_Slice (Actual) then |
1657 | Add_Call_By_Copy_Code; | |
70482933 | 1658 | |
fbf5a39b AC |
1659 | -- Only processing remaining is to pass by copy if this is a |
1660 | -- reference to a possibly unaligned slice, since the caller | |
1661 | -- expects an appropriately aligned argument. | |
70482933 | 1662 | |
fbf5a39b AC |
1663 | elsif Is_Possibly_Unaligned_Slice (Actual) then |
1664 | Add_Call_By_Copy_Code; | |
70482933 RK |
1665 | end if; |
1666 | end if; | |
1667 | ||
1668 | Next_Formal (Formal); | |
1669 | Next_Actual (Actual); | |
1670 | end loop; | |
1671 | ||
1672 | -- Find right place to put post call stuff if it is present | |
1673 | ||
1674 | if not Is_Empty_List (Post_Call) then | |
1675 | ||
2f1b20a9 ES |
1676 | -- If call is not a list member, it must be the triggering statement |
1677 | -- of a triggering alternative or an entry call alternative, and we | |
1678 | -- can add the post call stuff to the corresponding statement list. | |
70482933 RK |
1679 | |
1680 | if not Is_List_Member (N) then | |
1681 | declare | |
1682 | P : constant Node_Id := Parent (N); | |
1683 | ||
1684 | begin | |
ac4d6407 RD |
1685 | pragma Assert (Nkind_In (P, N_Triggering_Alternative, |
1686 | N_Entry_Call_Alternative)); | |
70482933 RK |
1687 | |
1688 | if Is_Non_Empty_List (Statements (P)) then | |
1689 | Insert_List_Before_And_Analyze | |
1690 | (First (Statements (P)), Post_Call); | |
1691 | else | |
1692 | Set_Statements (P, Post_Call); | |
1693 | end if; | |
1694 | end; | |
1695 | ||
1696 | -- Otherwise, normal case where N is in a statement sequence, | |
1697 | -- just put the post-call stuff after the call statement. | |
1698 | ||
1699 | else | |
1700 | Insert_Actions_After (N, Post_Call); | |
1701 | end if; | |
1702 | end if; | |
1703 | ||
98f01d53 | 1704 | -- The call node itself is re-analyzed in Expand_Call |
70482933 RK |
1705 | |
1706 | end Expand_Actuals; | |
1707 | ||
1708 | ----------------- | |
1709 | -- Expand_Call -- | |
1710 | ----------------- | |
1711 | ||
1712 | -- This procedure handles expansion of function calls and procedure call | |
1713 | -- statements (i.e. it serves as the body for Expand_N_Function_Call and | |
70f91180 | 1714 | -- Expand_N_Procedure_Call_Statement). Processing for calls includes: |
70482933 | 1715 | |
70f91180 | 1716 | -- Replace call to Raise_Exception by Raise_Exception_Always if possible |
70482933 RK |
1717 | -- Provide values of actuals for all formals in Extra_Formals list |
1718 | -- Replace "call" to enumeration literal function by literal itself | |
1719 | -- Rewrite call to predefined operator as operator | |
1720 | -- Replace actuals to in-out parameters that are numeric conversions, | |
1721 | -- with explicit assignment to temporaries before and after the call. | |
1722 | -- Remove optional actuals if First_Optional_Parameter specified. | |
1723 | ||
1724 | -- Note that the list of actuals has been filled with default expressions | |
1725 | -- during semantic analysis of the call. Only the extra actuals required | |
1726 | -- for the 'Constrained attribute and for accessibility checks are added | |
1727 | -- at this point. | |
1728 | ||
1729 | procedure Expand_Call (N : Node_Id) is | |
1730 | Loc : constant Source_Ptr := Sloc (N); | |
70482933 | 1731 | Extra_Actuals : List_Id := No_List; |
fdce4bb7 | 1732 | Prev : Node_Id := Empty; |
758c442c | 1733 | |
70482933 RK |
1734 | procedure Add_Actual_Parameter (Insert_Param : Node_Id); |
1735 | -- Adds one entry to the end of the actual parameter list. Used for | |
2f1b20a9 ES |
1736 | -- default parameters and for extra actuals (for Extra_Formals). The |
1737 | -- argument is an N_Parameter_Association node. | |
70482933 RK |
1738 | |
1739 | procedure Add_Extra_Actual (Expr : Node_Id; EF : Entity_Id); | |
2f1b20a9 ES |
1740 | -- Adds an extra actual to the list of extra actuals. Expr is the |
1741 | -- expression for the value of the actual, EF is the entity for the | |
1742 | -- extra formal. | |
70482933 RK |
1743 | |
1744 | function Inherited_From_Formal (S : Entity_Id) return Entity_Id; | |
1745 | -- Within an instance, a type derived from a non-tagged formal derived | |
70f91180 RD |
1746 | -- type inherits from the original parent, not from the actual. The |
1747 | -- current derivation mechanism has the derived type inherit from the | |
1748 | -- actual, which is only correct outside of the instance. If the | |
1749 | -- subprogram is inherited, we test for this particular case through a | |
1750 | -- convoluted tree traversal before setting the proper subprogram to be | |
1751 | -- called. | |
70482933 RK |
1752 | |
1753 | -------------------------- | |
1754 | -- Add_Actual_Parameter -- | |
1755 | -------------------------- | |
1756 | ||
1757 | procedure Add_Actual_Parameter (Insert_Param : Node_Id) is | |
1758 | Actual_Expr : constant Node_Id := | |
1759 | Explicit_Actual_Parameter (Insert_Param); | |
1760 | ||
1761 | begin | |
1762 | -- Case of insertion is first named actual | |
1763 | ||
1764 | if No (Prev) or else | |
1765 | Nkind (Parent (Prev)) /= N_Parameter_Association | |
1766 | then | |
1767 | Set_Next_Named_Actual (Insert_Param, First_Named_Actual (N)); | |
1768 | Set_First_Named_Actual (N, Actual_Expr); | |
1769 | ||
1770 | if No (Prev) then | |
c8ef728f | 1771 | if No (Parameter_Associations (N)) then |
70482933 RK |
1772 | Set_Parameter_Associations (N, New_List); |
1773 | Append (Insert_Param, Parameter_Associations (N)); | |
1774 | end if; | |
1775 | else | |
1776 | Insert_After (Prev, Insert_Param); | |
1777 | end if; | |
1778 | ||
1779 | -- Case of insertion is not first named actual | |
1780 | ||
1781 | else | |
1782 | Set_Next_Named_Actual | |
1783 | (Insert_Param, Next_Named_Actual (Parent (Prev))); | |
1784 | Set_Next_Named_Actual (Parent (Prev), Actual_Expr); | |
1785 | Append (Insert_Param, Parameter_Associations (N)); | |
1786 | end if; | |
1787 | ||
1788 | Prev := Actual_Expr; | |
1789 | end Add_Actual_Parameter; | |
1790 | ||
1791 | ---------------------- | |
1792 | -- Add_Extra_Actual -- | |
1793 | ---------------------- | |
1794 | ||
1795 | procedure Add_Extra_Actual (Expr : Node_Id; EF : Entity_Id) is | |
1796 | Loc : constant Source_Ptr := Sloc (Expr); | |
1797 | ||
1798 | begin | |
1799 | if Extra_Actuals = No_List then | |
1800 | Extra_Actuals := New_List; | |
1801 | Set_Parent (Extra_Actuals, N); | |
1802 | end if; | |
1803 | ||
1804 | Append_To (Extra_Actuals, | |
1805 | Make_Parameter_Association (Loc, | |
1806 | Explicit_Actual_Parameter => Expr, | |
1807 | Selector_Name => | |
1808 | Make_Identifier (Loc, Chars (EF)))); | |
1809 | ||
1810 | Analyze_And_Resolve (Expr, Etype (EF)); | |
75a64833 AC |
1811 | |
1812 | if Nkind (N) = N_Function_Call then | |
1813 | Set_Is_Accessibility_Actual (Parent (Expr)); | |
1814 | end if; | |
70482933 RK |
1815 | end Add_Extra_Actual; |
1816 | ||
1817 | --------------------------- | |
1818 | -- Inherited_From_Formal -- | |
1819 | --------------------------- | |
1820 | ||
1821 | function Inherited_From_Formal (S : Entity_Id) return Entity_Id is | |
1822 | Par : Entity_Id; | |
1823 | Gen_Par : Entity_Id; | |
1824 | Gen_Prim : Elist_Id; | |
1825 | Elmt : Elmt_Id; | |
1826 | Indic : Node_Id; | |
1827 | ||
1828 | begin | |
1829 | -- If the operation is inherited, it is attached to the corresponding | |
1830 | -- type derivation. If the parent in the derivation is a generic | |
1831 | -- actual, it is a subtype of the actual, and we have to recover the | |
1832 | -- original derived type declaration to find the proper parent. | |
1833 | ||
1834 | if Nkind (Parent (S)) /= N_Full_Type_Declaration | |
fbf5a39b | 1835 | or else not Is_Derived_Type (Defining_Identifier (Parent (S))) |
2f1b20a9 ES |
1836 | or else Nkind (Type_Definition (Original_Node (Parent (S)))) /= |
1837 | N_Derived_Type_Definition | |
fbf5a39b | 1838 | or else not In_Instance |
70482933 RK |
1839 | then |
1840 | return Empty; | |
1841 | ||
1842 | else | |
1843 | Indic := | |
e27b834b AC |
1844 | Subtype_Indication |
1845 | (Type_Definition (Original_Node (Parent (S)))); | |
70482933 RK |
1846 | |
1847 | if Nkind (Indic) = N_Subtype_Indication then | |
1848 | Par := Entity (Subtype_Mark (Indic)); | |
1849 | else | |
1850 | Par := Entity (Indic); | |
1851 | end if; | |
1852 | end if; | |
1853 | ||
1854 | if not Is_Generic_Actual_Type (Par) | |
1855 | or else Is_Tagged_Type (Par) | |
1856 | or else Nkind (Parent (Par)) /= N_Subtype_Declaration | |
1857 | or else not In_Open_Scopes (Scope (Par)) | |
70482933 RK |
1858 | then |
1859 | return Empty; | |
70482933 RK |
1860 | else |
1861 | Gen_Par := Generic_Parent_Type (Parent (Par)); | |
1862 | end if; | |
1863 | ||
7888a6ae GD |
1864 | -- If the actual has no generic parent type, the formal is not |
1865 | -- a formal derived type, so nothing to inherit. | |
1866 | ||
1867 | if No (Gen_Par) then | |
1868 | return Empty; | |
1869 | end if; | |
1870 | ||
2f1b20a9 ES |
1871 | -- If the generic parent type is still the generic type, this is a |
1872 | -- private formal, not a derived formal, and there are no operations | |
1873 | -- inherited from the formal. | |
fbf5a39b AC |
1874 | |
1875 | if Nkind (Parent (Gen_Par)) = N_Formal_Type_Declaration then | |
1876 | return Empty; | |
1877 | end if; | |
1878 | ||
70482933 | 1879 | Gen_Prim := Collect_Primitive_Operations (Gen_Par); |
70482933 | 1880 | |
2f1b20a9 | 1881 | Elmt := First_Elmt (Gen_Prim); |
70482933 RK |
1882 | while Present (Elmt) loop |
1883 | if Chars (Node (Elmt)) = Chars (S) then | |
1884 | declare | |
1885 | F1 : Entity_Id; | |
1886 | F2 : Entity_Id; | |
70482933 | 1887 | |
2f1b20a9 | 1888 | begin |
70482933 RK |
1889 | F1 := First_Formal (S); |
1890 | F2 := First_Formal (Node (Elmt)); | |
70482933 RK |
1891 | while Present (F1) |
1892 | and then Present (F2) | |
1893 | loop | |
70482933 RK |
1894 | if Etype (F1) = Etype (F2) |
1895 | or else Etype (F2) = Gen_Par | |
1896 | then | |
1897 | Next_Formal (F1); | |
1898 | Next_Formal (F2); | |
1899 | else | |
1900 | Next_Elmt (Elmt); | |
1901 | exit; -- not the right subprogram | |
1902 | end if; | |
1903 | ||
1904 | return Node (Elmt); | |
1905 | end loop; | |
1906 | end; | |
1907 | ||
1908 | else | |
1909 | Next_Elmt (Elmt); | |
1910 | end if; | |
1911 | end loop; | |
1912 | ||
1913 | raise Program_Error; | |
1914 | end Inherited_From_Formal; | |
1915 | ||
fdce4bb7 JM |
1916 | -- Local variables |
1917 | ||
1918 | Remote : constant Boolean := Is_Remote_Call (N); | |
1919 | Actual : Node_Id; | |
1920 | Formal : Entity_Id; | |
1921 | Orig_Subp : Entity_Id := Empty; | |
1922 | Param_Count : Natural := 0; | |
1923 | Parent_Formal : Entity_Id; | |
1924 | Parent_Subp : Entity_Id; | |
1925 | Scop : Entity_Id; | |
1926 | Subp : Entity_Id; | |
1927 | ||
e27b834b | 1928 | Prev_Orig : Node_Id; |
fdce4bb7 JM |
1929 | -- Original node for an actual, which may have been rewritten. If the |
1930 | -- actual is a function call that has been transformed from a selected | |
1931 | -- component, the original node is unanalyzed. Otherwise, it carries | |
1932 | -- semantic information used to generate additional actuals. | |
1933 | ||
1934 | CW_Interface_Formals_Present : Boolean := False; | |
1935 | ||
70482933 RK |
1936 | -- Start of processing for Expand_Call |
1937 | ||
1938 | begin | |
07fc65c4 GB |
1939 | -- Ignore if previous error |
1940 | ||
1941 | if Nkind (N) in N_Has_Etype and then Etype (N) = Any_Type then | |
1942 | return; | |
1943 | end if; | |
1944 | ||
70482933 RK |
1945 | -- Call using access to subprogram with explicit dereference |
1946 | ||
1947 | if Nkind (Name (N)) = N_Explicit_Dereference then | |
1948 | Subp := Etype (Name (N)); | |
1949 | Parent_Subp := Empty; | |
1950 | ||
1951 | -- Case of call to simple entry, where the Name is a selected component | |
1952 | -- whose prefix is the task, and whose selector name is the entry name | |
1953 | ||
1954 | elsif Nkind (Name (N)) = N_Selected_Component then | |
1955 | Subp := Entity (Selector_Name (Name (N))); | |
1956 | Parent_Subp := Empty; | |
1957 | ||
1958 | -- Case of call to member of entry family, where Name is an indexed | |
1959 | -- component, with the prefix being a selected component giving the | |
1960 | -- task and entry family name, and the index being the entry index. | |
1961 | ||
1962 | elsif Nkind (Name (N)) = N_Indexed_Component then | |
1963 | Subp := Entity (Selector_Name (Prefix (Name (N)))); | |
1964 | Parent_Subp := Empty; | |
1965 | ||
1966 | -- Normal case | |
1967 | ||
1968 | else | |
1969 | Subp := Entity (Name (N)); | |
1970 | Parent_Subp := Alias (Subp); | |
1971 | ||
1972 | -- Replace call to Raise_Exception by call to Raise_Exception_Always | |
1973 | -- if we can tell that the first parameter cannot possibly be null. | |
70f91180 | 1974 | -- This improves efficiency by avoiding a run-time test. |
70482933 | 1975 | |
7888a6ae GD |
1976 | -- We do not do this if Raise_Exception_Always does not exist, which |
1977 | -- can happen in configurable run time profiles which provide only a | |
70f91180 | 1978 | -- Raise_Exception. |
7888a6ae GD |
1979 | |
1980 | if Is_RTE (Subp, RE_Raise_Exception) | |
1981 | and then RTE_Available (RE_Raise_Exception_Always) | |
70482933 RK |
1982 | then |
1983 | declare | |
1984 | FA : constant Node_Id := Original_Node (First_Actual (N)); | |
1985 | ||
1986 | begin | |
1987 | -- The case we catch is where the first argument is obtained | |
2f1b20a9 ES |
1988 | -- using the Identity attribute (which must always be |
1989 | -- non-null). | |
70482933 RK |
1990 | |
1991 | if Nkind (FA) = N_Attribute_Reference | |
1992 | and then Attribute_Name (FA) = Name_Identity | |
1993 | then | |
1994 | Subp := RTE (RE_Raise_Exception_Always); | |
7888a6ae | 1995 | Set_Name (N, New_Occurrence_Of (Subp, Loc)); |
70482933 RK |
1996 | end if; |
1997 | end; | |
1998 | end if; | |
1999 | ||
2000 | if Ekind (Subp) = E_Entry then | |
2001 | Parent_Subp := Empty; | |
2002 | end if; | |
2003 | end if; | |
2004 | ||
f4d379b8 HK |
2005 | -- Ada 2005 (AI-345): We have a procedure call as a triggering |
2006 | -- alternative in an asynchronous select or as an entry call in | |
2007 | -- a conditional or timed select. Check whether the procedure call | |
2008 | -- is a renaming of an entry and rewrite it as an entry call. | |
2009 | ||
2010 | if Ada_Version >= Ada_05 | |
2011 | and then Nkind (N) = N_Procedure_Call_Statement | |
2012 | and then | |
2013 | ((Nkind (Parent (N)) = N_Triggering_Alternative | |
2014 | and then Triggering_Statement (Parent (N)) = N) | |
2015 | or else | |
2016 | (Nkind (Parent (N)) = N_Entry_Call_Alternative | |
2017 | and then Entry_Call_Statement (Parent (N)) = N)) | |
2018 | then | |
2019 | declare | |
2020 | Ren_Decl : Node_Id; | |
2021 | Ren_Root : Entity_Id := Subp; | |
2022 | ||
2023 | begin | |
2024 | -- This may be a chain of renamings, find the root | |
2025 | ||
2026 | if Present (Alias (Ren_Root)) then | |
2027 | Ren_Root := Alias (Ren_Root); | |
2028 | end if; | |
2029 | ||
2030 | if Present (Original_Node (Parent (Parent (Ren_Root)))) then | |
2031 | Ren_Decl := Original_Node (Parent (Parent (Ren_Root))); | |
2032 | ||
2033 | if Nkind (Ren_Decl) = N_Subprogram_Renaming_Declaration then | |
2034 | Rewrite (N, | |
2035 | Make_Entry_Call_Statement (Loc, | |
2036 | Name => | |
2037 | New_Copy_Tree (Name (Ren_Decl)), | |
2038 | Parameter_Associations => | |
2039 | New_Copy_List_Tree (Parameter_Associations (N)))); | |
2040 | ||
2041 | return; | |
2042 | end if; | |
2043 | end if; | |
2044 | end; | |
2045 | end if; | |
2046 | ||
e27b834b AC |
2047 | -- First step, compute extra actuals, corresponding to any Extra_Formals |
2048 | -- present. Note that we do not access Extra_Formals directly, instead | |
2049 | -- we simply note the presence of the extra formals as we process the | |
2050 | -- regular formals collecting corresponding actuals in Extra_Actuals. | |
70482933 | 2051 | |
c2369146 AC |
2052 | -- We also generate any required range checks for actuals for in formals |
2053 | -- as we go through the loop, since this is a convenient place to do it. | |
2054 | -- (Though it seems that this would be better done in Expand_Actuals???) | |
fbf5a39b | 2055 | |
fdce4bb7 JM |
2056 | Formal := First_Formal (Subp); |
2057 | Actual := First_Actual (N); | |
2058 | Param_Count := 1; | |
70482933 | 2059 | while Present (Formal) loop |
fbf5a39b | 2060 | |
d79e621a | 2061 | -- Generate range check if required |
fbf5a39b | 2062 | |
d79e621a | 2063 | if Do_Range_Check (Actual) |
c2369146 | 2064 | and then Ekind (Formal) = E_In_Parameter |
d79e621a GD |
2065 | then |
2066 | Set_Do_Range_Check (Actual, False); | |
2067 | Generate_Range_Check | |
2068 | (Actual, Etype (Formal), CE_Range_Check_Failed); | |
2069 | end if; | |
fbf5a39b AC |
2070 | |
2071 | -- Prepare to examine current entry | |
2072 | ||
70482933 RK |
2073 | Prev := Actual; |
2074 | Prev_Orig := Original_Node (Prev); | |
2075 | ||
758c442c | 2076 | -- Ada 2005 (AI-251): Check if any formal is a class-wide interface |
2f1b20a9 | 2077 | -- to expand it in a further round. |
758c442c GD |
2078 | |
2079 | CW_Interface_Formals_Present := | |
2080 | CW_Interface_Formals_Present | |
2081 | or else | |
2082 | (Ekind (Etype (Formal)) = E_Class_Wide_Type | |
2083 | and then Is_Interface (Etype (Etype (Formal)))) | |
2084 | or else | |
2085 | (Ekind (Etype (Formal)) = E_Anonymous_Access_Type | |
2086 | and then Is_Interface (Directly_Designated_Type | |
2087 | (Etype (Etype (Formal))))); | |
2088 | ||
2089 | -- Create possible extra actual for constrained case. Usually, the | |
2090 | -- extra actual is of the form actual'constrained, but since this | |
2091 | -- attribute is only available for unconstrained records, TRUE is | |
2092 | -- expanded if the type of the formal happens to be constrained (for | |
2093 | -- instance when this procedure is inherited from an unconstrained | |
2094 | -- record to a constrained one) or if the actual has no discriminant | |
2095 | -- (its type is constrained). An exception to this is the case of a | |
2096 | -- private type without discriminants. In this case we pass FALSE | |
2097 | -- because the object has underlying discriminants with defaults. | |
70482933 RK |
2098 | |
2099 | if Present (Extra_Constrained (Formal)) then | |
2100 | if Ekind (Etype (Prev)) in Private_Kind | |
2101 | and then not Has_Discriminants (Base_Type (Etype (Prev))) | |
2102 | then | |
01aef5ad GD |
2103 | Add_Extra_Actual |
2104 | (New_Occurrence_Of (Standard_False, Loc), | |
2105 | Extra_Constrained (Formal)); | |
70482933 RK |
2106 | |
2107 | elsif Is_Constrained (Etype (Formal)) | |
2108 | or else not Has_Discriminants (Etype (Prev)) | |
2109 | then | |
01aef5ad GD |
2110 | Add_Extra_Actual |
2111 | (New_Occurrence_Of (Standard_True, Loc), | |
2112 | Extra_Constrained (Formal)); | |
70482933 | 2113 | |
5d09245e AC |
2114 | -- Do not produce extra actuals for Unchecked_Union parameters. |
2115 | -- Jump directly to the end of the loop. | |
2116 | ||
2117 | elsif Is_Unchecked_Union (Base_Type (Etype (Actual))) then | |
2118 | goto Skip_Extra_Actual_Generation; | |
2119 | ||
70482933 RK |
2120 | else |
2121 | -- If the actual is a type conversion, then the constrained | |
2122 | -- test applies to the actual, not the target type. | |
2123 | ||
2124 | declare | |
2f1b20a9 | 2125 | Act_Prev : Node_Id; |
70482933 RK |
2126 | |
2127 | begin | |
2f1b20a9 ES |
2128 | -- Test for unchecked conversions as well, which can occur |
2129 | -- as out parameter actuals on calls to stream procedures. | |
70482933 | 2130 | |
2f1b20a9 | 2131 | Act_Prev := Prev; |
ac4d6407 RD |
2132 | while Nkind_In (Act_Prev, N_Type_Conversion, |
2133 | N_Unchecked_Type_Conversion) | |
fbf5a39b | 2134 | loop |
70482933 | 2135 | Act_Prev := Expression (Act_Prev); |
fbf5a39b | 2136 | end loop; |
70482933 | 2137 | |
3563739b AC |
2138 | -- If the expression is a conversion of a dereference, this |
2139 | -- is internally generated code that manipulates addresses, | |
2140 | -- e.g. when building interface tables. No check should | |
2141 | -- occur in this case, and the discriminated object is not | |
2142 | -- directly a hand. | |
f4d379b8 HK |
2143 | |
2144 | if not Comes_From_Source (Actual) | |
2145 | and then Nkind (Actual) = N_Unchecked_Type_Conversion | |
2146 | and then Nkind (Act_Prev) = N_Explicit_Dereference | |
2147 | then | |
2148 | Add_Extra_Actual | |
2149 | (New_Occurrence_Of (Standard_False, Loc), | |
2150 | Extra_Constrained (Formal)); | |
2151 | ||
2152 | else | |
2153 | Add_Extra_Actual | |
2154 | (Make_Attribute_Reference (Sloc (Prev), | |
2155 | Prefix => | |
2156 | Duplicate_Subexpr_No_Checks | |
2157 | (Act_Prev, Name_Req => True), | |
2158 | Attribute_Name => Name_Constrained), | |
2159 | Extra_Constrained (Formal)); | |
2160 | end if; | |
70482933 RK |
2161 | end; |
2162 | end if; | |
2163 | end if; | |
2164 | ||
2165 | -- Create possible extra actual for accessibility level | |
2166 | ||
2167 | if Present (Extra_Accessibility (Formal)) then | |
7888a6ae GD |
2168 | |
2169 | -- Ada 2005 (AI-252): If the actual was rewritten as an Access | |
2170 | -- attribute, then the original actual may be an aliased object | |
2171 | -- occurring as the prefix in a call using "Object.Operation" | |
2172 | -- notation. In that case we must pass the level of the object, | |
2173 | -- so Prev_Orig is reset to Prev and the attribute will be | |
2174 | -- processed by the code for Access attributes further below. | |
2175 | ||
2176 | if Prev_Orig /= Prev | |
2177 | and then Nkind (Prev) = N_Attribute_Reference | |
2178 | and then | |
2179 | Get_Attribute_Id (Attribute_Name (Prev)) = Attribute_Access | |
2180 | and then Is_Aliased_View (Prev_Orig) | |
2181 | then | |
2182 | Prev_Orig := Prev; | |
2183 | end if; | |
2184 | ||
fdce4bb7 JM |
2185 | -- Ada 2005 (AI-251): Thunks must propagate the extra actuals |
2186 | -- of accessibility levels. | |
2187 | ||
2188 | if Ekind (Current_Scope) in Subprogram_Kind | |
2189 | and then Is_Thunk (Current_Scope) | |
2190 | then | |
2191 | declare | |
2192 | Parm_Ent : Entity_Id; | |
2193 | ||
2194 | begin | |
2195 | if Is_Controlling_Actual (Actual) then | |
2196 | ||
2197 | -- Find the corresponding actual of the thunk | |
2198 | ||
2199 | Parm_Ent := First_Entity (Current_Scope); | |
2200 | for J in 2 .. Param_Count loop | |
2201 | Next_Entity (Parm_Ent); | |
2202 | end loop; | |
2203 | ||
2204 | else pragma Assert (Is_Entity_Name (Actual)); | |
2205 | Parm_Ent := Entity (Actual); | |
2206 | end if; | |
2207 | ||
2208 | Add_Extra_Actual | |
2209 | (New_Occurrence_Of (Extra_Accessibility (Parm_Ent), Loc), | |
2210 | Extra_Accessibility (Formal)); | |
2211 | end; | |
2212 | ||
2213 | elsif Is_Entity_Name (Prev_Orig) then | |
70482933 | 2214 | |
d766cee3 RD |
2215 | -- When passing an access parameter, or a renaming of an access |
2216 | -- parameter, as the actual to another access parameter we need | |
2217 | -- to pass along the actual's own access level parameter. This | |
2218 | -- is done if we are within the scope of the formal access | |
2219 | -- parameter (if this is an inlined body the extra formal is | |
2220 | -- irrelevant). | |
2221 | ||
2222 | if (Is_Formal (Entity (Prev_Orig)) | |
2223 | or else | |
2224 | (Present (Renamed_Object (Entity (Prev_Orig))) | |
2225 | and then | |
2226 | Is_Entity_Name (Renamed_Object (Entity (Prev_Orig))) | |
2227 | and then | |
2228 | Is_Formal | |
2229 | (Entity (Renamed_Object (Entity (Prev_Orig)))))) | |
70482933 RK |
2230 | and then Ekind (Etype (Prev_Orig)) = E_Anonymous_Access_Type |
2231 | and then In_Open_Scopes (Scope (Entity (Prev_Orig))) | |
2232 | then | |
2233 | declare | |
2234 | Parm_Ent : constant Entity_Id := Param_Entity (Prev_Orig); | |
2235 | ||
2236 | begin | |
2237 | pragma Assert (Present (Parm_Ent)); | |
2238 | ||
2239 | if Present (Extra_Accessibility (Parm_Ent)) then | |
f4d379b8 HK |
2240 | Add_Extra_Actual |
2241 | (New_Occurrence_Of | |
2242 | (Extra_Accessibility (Parm_Ent), Loc), | |
2243 | Extra_Accessibility (Formal)); | |
70482933 RK |
2244 | |
2245 | -- If the actual access parameter does not have an | |
2246 | -- associated extra formal providing its scope level, | |
2247 | -- then treat the actual as having library-level | |
2248 | -- accessibility. | |
2249 | ||
2250 | else | |
f4d379b8 HK |
2251 | Add_Extra_Actual |
2252 | (Make_Integer_Literal (Loc, | |
01aef5ad | 2253 | Intval => Scope_Depth (Standard_Standard)), |
f4d379b8 | 2254 | Extra_Accessibility (Formal)); |
70482933 RK |
2255 | end if; |
2256 | end; | |
2257 | ||
7888a6ae GD |
2258 | -- The actual is a normal access value, so just pass the level |
2259 | -- of the actual's access type. | |
70482933 RK |
2260 | |
2261 | else | |
f4d379b8 HK |
2262 | Add_Extra_Actual |
2263 | (Make_Integer_Literal (Loc, | |
01aef5ad | 2264 | Intval => Type_Access_Level (Etype (Prev_Orig))), |
f4d379b8 | 2265 | Extra_Accessibility (Formal)); |
70482933 RK |
2266 | end if; |
2267 | ||
01aef5ad GD |
2268 | -- If the actual is an access discriminant, then pass the level |
2269 | -- of the enclosing object (RM05-3.10.2(12.4/2)). | |
2270 | ||
2271 | elsif Nkind (Prev_Orig) = N_Selected_Component | |
2272 | and then Ekind (Entity (Selector_Name (Prev_Orig))) = | |
2273 | E_Discriminant | |
2274 | and then Ekind (Etype (Entity (Selector_Name (Prev_Orig)))) = | |
2275 | E_Anonymous_Access_Type | |
2276 | then | |
2277 | Add_Extra_Actual | |
2278 | (Make_Integer_Literal (Loc, | |
2279 | Intval => Object_Access_Level (Prefix (Prev_Orig))), | |
2280 | Extra_Accessibility (Formal)); | |
2281 | ||
2282 | -- All other cases | |
fdce4bb7 | 2283 | |
70482933 RK |
2284 | else |
2285 | case Nkind (Prev_Orig) is | |
2286 | ||
2287 | when N_Attribute_Reference => | |
70482933 RK |
2288 | case Get_Attribute_Id (Attribute_Name (Prev_Orig)) is |
2289 | ||
75a64833 | 2290 | -- For X'Access, pass on the level of the prefix X |
70482933 RK |
2291 | |
2292 | when Attribute_Access => | |
75a64833 AC |
2293 | Add_Extra_Actual |
2294 | (Make_Integer_Literal (Loc, | |
2295 | Intval => | |
2296 | Object_Access_Level | |
2297 | (Prefix (Prev_Orig))), | |
bac7206d | 2298 | Extra_Accessibility (Formal)); |
70482933 RK |
2299 | |
2300 | -- Treat the unchecked attributes as library-level | |
2301 | ||
2302 | when Attribute_Unchecked_Access | | |
2303 | Attribute_Unrestricted_Access => | |
01aef5ad GD |
2304 | Add_Extra_Actual |
2305 | (Make_Integer_Literal (Loc, | |
2306 | Intval => Scope_Depth (Standard_Standard)), | |
2307 | Extra_Accessibility (Formal)); | |
70482933 RK |
2308 | |
2309 | -- No other cases of attributes returning access | |
2310 | -- values that can be passed to access parameters | |
2311 | ||
2312 | when others => | |
2313 | raise Program_Error; | |
2314 | ||
2315 | end case; | |
2316 | ||
2317 | -- For allocators we pass the level of the execution of | |
2318 | -- the called subprogram, which is one greater than the | |
2319 | -- current scope level. | |
2320 | ||
2321 | when N_Allocator => | |
01aef5ad GD |
2322 | Add_Extra_Actual |
2323 | (Make_Integer_Literal (Loc, | |
2324 | Intval => Scope_Depth (Current_Scope) + 1), | |
2325 | Extra_Accessibility (Formal)); | |
70482933 | 2326 | |
8ca3bf91 GD |
2327 | -- For other cases we simply pass the level of the actual's |
2328 | -- access type. The type is retrieved from Prev rather than | |
61549759 | 2329 | -- Prev_Orig, because in some cases Prev_Orig denotes an |
8ca3bf91 | 2330 | -- original expression that has not been analyzed. |
70482933 RK |
2331 | |
2332 | when others => | |
01aef5ad GD |
2333 | Add_Extra_Actual |
2334 | (Make_Integer_Literal (Loc, | |
8ca3bf91 | 2335 | Intval => Type_Access_Level (Etype (Prev))), |
01aef5ad | 2336 | Extra_Accessibility (Formal)); |
70482933 RK |
2337 | end case; |
2338 | end if; | |
2339 | end if; | |
2340 | ||
2f1b20a9 ES |
2341 | -- Perform the check of 4.6(49) that prevents a null value from being |
2342 | -- passed as an actual to an access parameter. Note that the check is | |
2343 | -- elided in the common cases of passing an access attribute or | |
2344 | -- access parameter as an actual. Also, we currently don't enforce | |
2345 | -- this check for expander-generated actuals and when -gnatdj is set. | |
70482933 | 2346 | |
2f1b20a9 | 2347 | if Ada_Version >= Ada_05 then |
70482933 | 2348 | |
2f1b20a9 | 2349 | -- Ada 2005 (AI-231): Check null-excluding access types |
70482933 | 2350 | |
2f1b20a9 ES |
2351 | if Is_Access_Type (Etype (Formal)) |
2352 | and then Can_Never_Be_Null (Etype (Formal)) | |
2353 | and then Nkind (Prev) /= N_Raise_Constraint_Error | |
d766cee3 | 2354 | and then (Known_Null (Prev) |
2f1b20a9 ES |
2355 | or else not Can_Never_Be_Null (Etype (Prev))) |
2356 | then | |
2357 | Install_Null_Excluding_Check (Prev); | |
2358 | end if; | |
70482933 | 2359 | |
2f1b20a9 | 2360 | -- Ada_Version < Ada_05 |
70482933 | 2361 | |
2f1b20a9 ES |
2362 | else |
2363 | if Ekind (Etype (Formal)) /= E_Anonymous_Access_Type | |
2364 | or else Access_Checks_Suppressed (Subp) | |
2365 | then | |
2366 | null; | |
70482933 | 2367 | |
2f1b20a9 ES |
2368 | elsif Debug_Flag_J then |
2369 | null; | |
70482933 | 2370 | |
2f1b20a9 ES |
2371 | elsif not Comes_From_Source (Prev) then |
2372 | null; | |
70482933 | 2373 | |
2f1b20a9 ES |
2374 | elsif Is_Entity_Name (Prev) |
2375 | and then Ekind (Etype (Prev)) = E_Anonymous_Access_Type | |
2376 | then | |
2377 | null; | |
2820d220 | 2378 | |
ac4d6407 | 2379 | elsif Nkind_In (Prev, N_Allocator, N_Attribute_Reference) then |
2f1b20a9 ES |
2380 | null; |
2381 | ||
2382 | -- Suppress null checks when passing to access parameters of Java | |
7888a6ae GD |
2383 | -- and CIL subprograms. (Should this be done for other foreign |
2384 | -- conventions as well ???) | |
2f1b20a9 | 2385 | |
7888a6ae GD |
2386 | elsif Convention (Subp) = Convention_Java |
2387 | or else Convention (Subp) = Convention_CIL | |
2388 | then | |
2f1b20a9 ES |
2389 | null; |
2390 | ||
2391 | else | |
2392 | Install_Null_Excluding_Check (Prev); | |
2393 | end if; | |
70482933 RK |
2394 | end if; |
2395 | ||
fbf5a39b AC |
2396 | -- Perform appropriate validity checks on parameters that |
2397 | -- are entities. | |
70482933 RK |
2398 | |
2399 | if Validity_Checks_On then | |
6cdb2c6e AC |
2400 | if (Ekind (Formal) = E_In_Parameter |
2401 | and then Validity_Check_In_Params) | |
2402 | or else | |
2403 | (Ekind (Formal) = E_In_Out_Parameter | |
2404 | and then Validity_Check_In_Out_Params) | |
70482933 | 2405 | then |
7888a6ae GD |
2406 | -- If the actual is an indexed component of a packed type (or |
2407 | -- is an indexed or selected component whose prefix recursively | |
2408 | -- meets this condition), it has not been expanded yet. It will | |
2409 | -- be copied in the validity code that follows, and has to be | |
2410 | -- expanded appropriately, so reanalyze it. | |
08aa9a4a | 2411 | |
7888a6ae GD |
2412 | -- What we do is just to unset analyzed bits on prefixes till |
2413 | -- we reach something that does not have a prefix. | |
2414 | ||
2415 | declare | |
2416 | Nod : Node_Id; | |
2417 | ||
2418 | begin | |
2419 | Nod := Actual; | |
ac4d6407 RD |
2420 | while Nkind_In (Nod, N_Indexed_Component, |
2421 | N_Selected_Component) | |
7888a6ae GD |
2422 | loop |
2423 | Set_Analyzed (Nod, False); | |
2424 | Nod := Prefix (Nod); | |
2425 | end loop; | |
2426 | end; | |
08aa9a4a | 2427 | |
70482933 | 2428 | Ensure_Valid (Actual); |
70482933 RK |
2429 | end if; |
2430 | end if; | |
2431 | ||
2432 | -- For IN OUT and OUT parameters, ensure that subscripts are valid | |
2433 | -- since this is a left side reference. We only do this for calls | |
2434 | -- from the source program since we assume that compiler generated | |
2435 | -- calls explicitly generate any required checks. We also need it | |
2436 | -- only if we are doing standard validity checks, since clearly it | |
2437 | -- is not needed if validity checks are off, and in subscript | |
2438 | -- validity checking mode, all indexed components are checked with | |
2439 | -- a call directly from Expand_N_Indexed_Component. | |
2440 | ||
2441 | if Comes_From_Source (N) | |
2442 | and then Ekind (Formal) /= E_In_Parameter | |
2443 | and then Validity_Checks_On | |
2444 | and then Validity_Check_Default | |
2445 | and then not Validity_Check_Subscripts | |
2446 | then | |
2447 | Check_Valid_Lvalue_Subscripts (Actual); | |
2448 | end if; | |
2449 | ||
c8ef728f ES |
2450 | -- Mark any scalar OUT parameter that is a simple variable as no |
2451 | -- longer known to be valid (unless the type is always valid). This | |
2452 | -- reflects the fact that if an OUT parameter is never set in a | |
2453 | -- procedure, then it can become invalid on the procedure return. | |
fbf5a39b AC |
2454 | |
2455 | if Ekind (Formal) = E_Out_Parameter | |
2456 | and then Is_Entity_Name (Actual) | |
2457 | and then Ekind (Entity (Actual)) = E_Variable | |
2458 | and then not Is_Known_Valid (Etype (Actual)) | |
2459 | then | |
2460 | Set_Is_Known_Valid (Entity (Actual), False); | |
2461 | end if; | |
2462 | ||
c8ef728f ES |
2463 | -- For an OUT or IN OUT parameter, if the actual is an entity, then |
2464 | -- clear current values, since they can be clobbered. We are probably | |
2465 | -- doing this in more places than we need to, but better safe than | |
2466 | -- sorry when it comes to retaining bad current values! | |
fbf5a39b AC |
2467 | |
2468 | if Ekind (Formal) /= E_In_Parameter | |
2469 | and then Is_Entity_Name (Actual) | |
67ce0d7e | 2470 | and then Present (Entity (Actual)) |
fbf5a39b | 2471 | then |
67ce0d7e RD |
2472 | declare |
2473 | Ent : constant Entity_Id := Entity (Actual); | |
2474 | Sav : Node_Id; | |
2475 | ||
2476 | begin | |
ac4d6407 RD |
2477 | -- For an OUT or IN OUT parameter that is an assignable entity, |
2478 | -- we do not want to clobber the Last_Assignment field, since | |
2479 | -- if it is set, it was precisely because it is indeed an OUT | |
75ba322d AC |
2480 | -- or IN OUT parameter! We do reset the Is_Known_Valid flag |
2481 | -- since the subprogram could have returned in invalid value. | |
ac4d6407 RD |
2482 | |
2483 | if (Ekind (Formal) = E_Out_Parameter | |
2484 | or else | |
2485 | Ekind (Formal) = E_In_Out_Parameter) | |
67ce0d7e RD |
2486 | and then Is_Assignable (Ent) |
2487 | then | |
2488 | Sav := Last_Assignment (Ent); | |
2489 | Kill_Current_Values (Ent); | |
2490 | Set_Last_Assignment (Ent, Sav); | |
75ba322d | 2491 | Set_Is_Known_Valid (Ent, False); |
67ce0d7e RD |
2492 | |
2493 | -- For all other cases, just kill the current values | |
2494 | ||
2495 | else | |
2496 | Kill_Current_Values (Ent); | |
2497 | end if; | |
2498 | end; | |
fbf5a39b AC |
2499 | end if; |
2500 | ||
70482933 RK |
2501 | -- If the formal is class wide and the actual is an aggregate, force |
2502 | -- evaluation so that the back end who does not know about class-wide | |
2503 | -- type, does not generate a temporary of the wrong size. | |
2504 | ||
2505 | if not Is_Class_Wide_Type (Etype (Formal)) then | |
2506 | null; | |
2507 | ||
2508 | elsif Nkind (Actual) = N_Aggregate | |
2509 | or else (Nkind (Actual) = N_Qualified_Expression | |
2510 | and then Nkind (Expression (Actual)) = N_Aggregate) | |
2511 | then | |
2512 | Force_Evaluation (Actual); | |
2513 | end if; | |
2514 | ||
2515 | -- In a remote call, if the formal is of a class-wide type, check | |
2516 | -- that the actual meets the requirements described in E.4(18). | |
2517 | ||
7888a6ae | 2518 | if Remote and then Is_Class_Wide_Type (Etype (Formal)) then |
70482933 | 2519 | Insert_Action (Actual, |
7888a6ae GD |
2520 | Make_Transportable_Check (Loc, |
2521 | Duplicate_Subexpr_Move_Checks (Actual))); | |
70482933 RK |
2522 | end if; |
2523 | ||
5d09245e AC |
2524 | -- This label is required when skipping extra actual generation for |
2525 | -- Unchecked_Union parameters. | |
2526 | ||
2527 | <<Skip_Extra_Actual_Generation>> | |
2528 | ||
fdce4bb7 | 2529 | Param_Count := Param_Count + 1; |
70482933 RK |
2530 | Next_Actual (Actual); |
2531 | Next_Formal (Formal); | |
2532 | end loop; | |
2533 | ||
c8ef728f ES |
2534 | -- If we are expanding a rhs of an assignment we need to check if tag |
2535 | -- propagation is needed. You might expect this processing to be in | |
2536 | -- Analyze_Assignment but has to be done earlier (bottom-up) because the | |
2537 | -- assignment might be transformed to a declaration for an unconstrained | |
2538 | -- value if the expression is classwide. | |
70482933 RK |
2539 | |
2540 | if Nkind (N) = N_Function_Call | |
2541 | and then Is_Tag_Indeterminate (N) | |
2542 | and then Is_Entity_Name (Name (N)) | |
2543 | then | |
2544 | declare | |
2545 | Ass : Node_Id := Empty; | |
2546 | ||
2547 | begin | |
2548 | if Nkind (Parent (N)) = N_Assignment_Statement then | |
2549 | Ass := Parent (N); | |
2550 | ||
2551 | elsif Nkind (Parent (N)) = N_Qualified_Expression | |
2552 | and then Nkind (Parent (Parent (N))) = N_Assignment_Statement | |
2553 | then | |
2554 | Ass := Parent (Parent (N)); | |
02822a92 RD |
2555 | |
2556 | elsif Nkind (Parent (N)) = N_Explicit_Dereference | |
2557 | and then Nkind (Parent (Parent (N))) = N_Assignment_Statement | |
2558 | then | |
2559 | Ass := Parent (Parent (N)); | |
70482933 RK |
2560 | end if; |
2561 | ||
2562 | if Present (Ass) | |
2563 | and then Is_Class_Wide_Type (Etype (Name (Ass))) | |
2564 | then | |
02822a92 RD |
2565 | if Is_Access_Type (Etype (N)) then |
2566 | if Designated_Type (Etype (N)) /= | |
2567 | Root_Type (Etype (Name (Ass))) | |
2568 | then | |
2569 | Error_Msg_NE | |
2570 | ("tag-indeterminate expression " | |
d766cee3 | 2571 | & " must have designated type& (RM 5.2 (6))", |
02822a92 RD |
2572 | N, Root_Type (Etype (Name (Ass)))); |
2573 | else | |
2574 | Propagate_Tag (Name (Ass), N); | |
2575 | end if; | |
2576 | ||
2577 | elsif Etype (N) /= Root_Type (Etype (Name (Ass))) then | |
fbf5a39b AC |
2578 | Error_Msg_NE |
2579 | ("tag-indeterminate expression must have type&" | |
d766cee3 | 2580 | & "(RM 5.2 (6))", N, Root_Type (Etype (Name (Ass)))); |
02822a92 | 2581 | |
fbf5a39b AC |
2582 | else |
2583 | Propagate_Tag (Name (Ass), N); | |
2584 | end if; | |
2585 | ||
2586 | -- The call will be rewritten as a dispatching call, and | |
2587 | -- expanded as such. | |
2588 | ||
70482933 RK |
2589 | return; |
2590 | end if; | |
2591 | end; | |
2592 | end if; | |
2593 | ||
758c442c GD |
2594 | -- Ada 2005 (AI-251): If some formal is a class-wide interface, expand |
2595 | -- it to point to the correct secondary virtual table | |
2596 | ||
ac4d6407 | 2597 | if Nkind_In (N, N_Function_Call, N_Procedure_Call_Statement) |
758c442c GD |
2598 | and then CW_Interface_Formals_Present |
2599 | then | |
2600 | Expand_Interface_Actuals (N); | |
2601 | end if; | |
2602 | ||
70482933 RK |
2603 | -- Deals with Dispatch_Call if we still have a call, before expanding |
2604 | -- extra actuals since this will be done on the re-analysis of the | |
2605 | -- dispatching call. Note that we do not try to shorten the actual | |
2606 | -- list for a dispatching call, it would not make sense to do so. | |
7888a6ae GD |
2607 | -- Expansion of dispatching calls is suppressed when VM_Target, because |
2608 | -- the VM back-ends directly handle the generation of dispatching | |
70482933 RK |
2609 | -- calls and would have to undo any expansion to an indirect call. |
2610 | ||
ac4d6407 | 2611 | if Nkind_In (N, N_Function_Call, N_Procedure_Call_Statement) |
70482933 | 2612 | and then Present (Controlling_Argument (N)) |
70482933 | 2613 | then |
1f110335 | 2614 | if Tagged_Type_Expansion then |
70f91180 | 2615 | Expand_Dispatching_Call (N); |
fbf5a39b | 2616 | |
70f91180 RD |
2617 | -- The following return is worrisome. Is it really OK to |
2618 | -- skip all remaining processing in this procedure ??? | |
fbf5a39b | 2619 | |
70f91180 RD |
2620 | return; |
2621 | ||
70f91180 | 2622 | else |
5a1ccfb1 AC |
2623 | Apply_Tag_Checks (N); |
2624 | ||
2625 | -- Expansion of a dispatching call results in an indirect call, | |
2626 | -- which in turn causes current values to be killed (see | |
2627 | -- Resolve_Call), so on VM targets we do the call here to ensure | |
2628 | -- consistent warnings between VM and non-VM targets. | |
2629 | ||
70f91180 RD |
2630 | Kill_Current_Values; |
2631 | end if; | |
2632 | end if; | |
70482933 RK |
2633 | |
2634 | -- Similarly, expand calls to RCI subprograms on which pragma | |
2635 | -- All_Calls_Remote applies. The rewriting will be reanalyzed | |
2636 | -- later. Do this only when the call comes from source since we do | |
8fc789c8 | 2637 | -- not want such a rewriting to occur in expanded code. |
70482933 | 2638 | |
70f91180 | 2639 | if Is_All_Remote_Call (N) then |
70482933 RK |
2640 | Expand_All_Calls_Remote_Subprogram_Call (N); |
2641 | ||
2642 | -- Similarly, do not add extra actuals for an entry call whose entity | |
2643 | -- is a protected procedure, or for an internal protected subprogram | |
2644 | -- call, because it will be rewritten as a protected subprogram call | |
2645 | -- and reanalyzed (see Expand_Protected_Subprogram_Call). | |
2646 | ||
2647 | elsif Is_Protected_Type (Scope (Subp)) | |
2648 | and then (Ekind (Subp) = E_Procedure | |
2649 | or else Ekind (Subp) = E_Function) | |
2650 | then | |
2651 | null; | |
2652 | ||
2653 | -- During that loop we gathered the extra actuals (the ones that | |
2654 | -- correspond to Extra_Formals), so now they can be appended. | |
2655 | ||
2656 | else | |
2657 | while Is_Non_Empty_List (Extra_Actuals) loop | |
2658 | Add_Actual_Parameter (Remove_Head (Extra_Actuals)); | |
2659 | end loop; | |
2660 | end if; | |
2661 | ||
f44fe430 RD |
2662 | -- At this point we have all the actuals, so this is the point at |
2663 | -- which the various expansion activities for actuals is carried out. | |
2664 | ||
2665 | Expand_Actuals (N, Subp); | |
70482933 RK |
2666 | |
2667 | -- If the subprogram is a renaming, or if it is inherited, replace it | |
2668 | -- in the call with the name of the actual subprogram being called. | |
2669 | -- If this is a dispatching call, the run-time decides what to call. | |
2670 | -- The Alias attribute does not apply to entries. | |
2671 | ||
2672 | if Nkind (N) /= N_Entry_Call_Statement | |
2673 | and then No (Controlling_Argument (N)) | |
2674 | and then Present (Parent_Subp) | |
2675 | then | |
2676 | if Present (Inherited_From_Formal (Subp)) then | |
2677 | Parent_Subp := Inherited_From_Formal (Subp); | |
2678 | else | |
2679 | while Present (Alias (Parent_Subp)) loop | |
2680 | Parent_Subp := Alias (Parent_Subp); | |
2681 | end loop; | |
2682 | end if; | |
2683 | ||
c8ef728f ES |
2684 | -- The below setting of Entity is suspect, see F109-018 discussion??? |
2685 | ||
70482933 RK |
2686 | Set_Entity (Name (N), Parent_Subp); |
2687 | ||
f937473f | 2688 | if Is_Abstract_Subprogram (Parent_Subp) |
70482933 RK |
2689 | and then not In_Instance |
2690 | then | |
2691 | Error_Msg_NE | |
2692 | ("cannot call abstract subprogram &!", Name (N), Parent_Subp); | |
2693 | end if; | |
2694 | ||
d4817e3f HK |
2695 | -- Inspect all formals of derived subprogram Subp. Compare parameter |
2696 | -- types with the parent subprogram and check whether an actual may | |
2697 | -- need a type conversion to the corresponding formal of the parent | |
2698 | -- subprogram. | |
70482933 | 2699 | |
d4817e3f | 2700 | -- Not clear whether intrinsic subprograms need such conversions. ??? |
70482933 RK |
2701 | |
2702 | if not Is_Intrinsic_Subprogram (Parent_Subp) | |
2703 | or else Is_Generic_Instance (Parent_Subp) | |
2704 | then | |
d4817e3f HK |
2705 | declare |
2706 | procedure Convert (Act : Node_Id; Typ : Entity_Id); | |
2707 | -- Rewrite node Act as a type conversion of Act to Typ. Analyze | |
2708 | -- and resolve the newly generated construct. | |
70482933 | 2709 | |
d4817e3f HK |
2710 | ------------- |
2711 | -- Convert -- | |
2712 | ------------- | |
70482933 | 2713 | |
d4817e3f HK |
2714 | procedure Convert (Act : Node_Id; Typ : Entity_Id) is |
2715 | begin | |
2716 | Rewrite (Act, OK_Convert_To (Typ, Relocate_Node (Act))); | |
2717 | Analyze (Act); | |
2718 | Resolve (Act, Typ); | |
2719 | end Convert; | |
2720 | ||
2721 | -- Local variables | |
2722 | ||
2723 | Actual_Typ : Entity_Id; | |
2724 | Formal_Typ : Entity_Id; | |
2725 | Parent_Typ : Entity_Id; | |
2726 | ||
2727 | begin | |
2728 | Actual := First_Actual (N); | |
2729 | Formal := First_Formal (Subp); | |
2730 | Parent_Formal := First_Formal (Parent_Subp); | |
2731 | while Present (Formal) loop | |
2732 | Actual_Typ := Etype (Actual); | |
2733 | Formal_Typ := Etype (Formal); | |
2734 | Parent_Typ := Etype (Parent_Formal); | |
2735 | ||
2736 | -- For an IN parameter of a scalar type, the parent formal | |
2737 | -- type and derived formal type differ or the parent formal | |
2738 | -- type and actual type do not match statically. | |
2739 | ||
2740 | if Is_Scalar_Type (Formal_Typ) | |
2741 | and then Ekind (Formal) = E_In_Parameter | |
2742 | and then Formal_Typ /= Parent_Typ | |
2743 | and then | |
2744 | not Subtypes_Statically_Match (Parent_Typ, Actual_Typ) | |
2745 | and then not Raises_Constraint_Error (Actual) | |
2746 | then | |
2747 | Convert (Actual, Parent_Typ); | |
2748 | Enable_Range_Check (Actual); | |
2749 | ||
d79e621a GD |
2750 | -- If the actual has been marked as requiring a range |
2751 | -- check, then generate it here. | |
2752 | ||
2753 | if Do_Range_Check (Actual) then | |
2754 | Set_Do_Range_Check (Actual, False); | |
2755 | Generate_Range_Check | |
2756 | (Actual, Etype (Formal), CE_Range_Check_Failed); | |
2757 | end if; | |
2758 | ||
d4817e3f HK |
2759 | -- For access types, the parent formal type and actual type |
2760 | -- differ. | |
2761 | ||
2762 | elsif Is_Access_Type (Formal_Typ) | |
2763 | and then Base_Type (Parent_Typ) /= Base_Type (Actual_Typ) | |
70482933 | 2764 | then |
d4817e3f HK |
2765 | if Ekind (Formal) /= E_In_Parameter then |
2766 | Convert (Actual, Parent_Typ); | |
2767 | ||
2768 | elsif Ekind (Parent_Typ) = E_Anonymous_Access_Type | |
2769 | and then Designated_Type (Parent_Typ) /= | |
2770 | Designated_Type (Actual_Typ) | |
2771 | and then not Is_Controlling_Formal (Formal) | |
2772 | then | |
2773 | -- This unchecked conversion is not necessary unless | |
2774 | -- inlining is enabled, because in that case the type | |
2775 | -- mismatch may become visible in the body about to be | |
2776 | -- inlined. | |
2777 | ||
2778 | Rewrite (Actual, | |
2779 | Unchecked_Convert_To (Parent_Typ, | |
2780 | Relocate_Node (Actual))); | |
2781 | ||
2782 | Analyze (Actual); | |
2783 | Resolve (Actual, Parent_Typ); | |
2784 | end if; | |
70482933 | 2785 | |
d4817e3f HK |
2786 | -- For array and record types, the parent formal type and |
2787 | -- derived formal type have different sizes or pragma Pack | |
2788 | -- status. | |
70482933 | 2789 | |
d4817e3f HK |
2790 | elsif ((Is_Array_Type (Formal_Typ) |
2791 | and then Is_Array_Type (Parent_Typ)) | |
2792 | or else | |
2793 | (Is_Record_Type (Formal_Typ) | |
2794 | and then Is_Record_Type (Parent_Typ))) | |
2795 | and then | |
2796 | (Esize (Formal_Typ) /= Esize (Parent_Typ) | |
2797 | or else Has_Pragma_Pack (Formal_Typ) /= | |
2798 | Has_Pragma_Pack (Parent_Typ)) | |
2799 | then | |
2800 | Convert (Actual, Parent_Typ); | |
70482933 | 2801 | end if; |
70482933 | 2802 | |
d4817e3f HK |
2803 | Next_Actual (Actual); |
2804 | Next_Formal (Formal); | |
2805 | Next_Formal (Parent_Formal); | |
2806 | end loop; | |
2807 | end; | |
70482933 RK |
2808 | end if; |
2809 | ||
2810 | Orig_Subp := Subp; | |
2811 | Subp := Parent_Subp; | |
2812 | end if; | |
2813 | ||
8a36a0cc AC |
2814 | -- Check for violation of No_Abort_Statements |
2815 | ||
fbf5a39b AC |
2816 | if Is_RTE (Subp, RE_Abort_Task) then |
2817 | Check_Restriction (No_Abort_Statements, N); | |
8a36a0cc AC |
2818 | |
2819 | -- Check for violation of No_Dynamic_Attachment | |
2820 | ||
2821 | elsif RTU_Loaded (Ada_Interrupts) | |
2822 | and then (Is_RTE (Subp, RE_Is_Reserved) or else | |
2823 | Is_RTE (Subp, RE_Is_Attached) or else | |
2824 | Is_RTE (Subp, RE_Current_Handler) or else | |
2825 | Is_RTE (Subp, RE_Attach_Handler) or else | |
2826 | Is_RTE (Subp, RE_Exchange_Handler) or else | |
2827 | Is_RTE (Subp, RE_Detach_Handler) or else | |
2828 | Is_RTE (Subp, RE_Reference)) | |
2829 | then | |
2830 | Check_Restriction (No_Dynamic_Attachment, N); | |
fbf5a39b AC |
2831 | end if; |
2832 | ||
8a36a0cc AC |
2833 | -- Deal with case where call is an explicit dereference |
2834 | ||
c01a9391 | 2835 | if Nkind (Name (N)) = N_Explicit_Dereference then |
70482933 RK |
2836 | |
2837 | -- Handle case of access to protected subprogram type | |
2838 | ||
f937473f | 2839 | if Is_Access_Protected_Subprogram_Type |
d4817e3f | 2840 | (Base_Type (Etype (Prefix (Name (N))))) |
70482933 RK |
2841 | then |
2842 | -- If this is a call through an access to protected operation, | |
2843 | -- the prefix has the form (object'address, operation'access). | |
2844 | -- Rewrite as a for other protected calls: the object is the | |
2845 | -- first parameter of the list of actuals. | |
2846 | ||
2847 | declare | |
2848 | Call : Node_Id; | |
2849 | Parm : List_Id; | |
2850 | Nam : Node_Id; | |
2851 | Obj : Node_Id; | |
fbf5a39b AC |
2852 | Ptr : constant Node_Id := Prefix (Name (N)); |
2853 | ||
2854 | T : constant Entity_Id := | |
2855 | Equivalent_Type (Base_Type (Etype (Ptr))); | |
2856 | ||
2857 | D_T : constant Entity_Id := | |
2858 | Designated_Type (Base_Type (Etype (Ptr))); | |
70482933 RK |
2859 | |
2860 | begin | |
f44fe430 RD |
2861 | Obj := |
2862 | Make_Selected_Component (Loc, | |
2863 | Prefix => Unchecked_Convert_To (T, Ptr), | |
2864 | Selector_Name => | |
2865 | New_Occurrence_Of (First_Entity (T), Loc)); | |
2866 | ||
2867 | Nam := | |
2868 | Make_Selected_Component (Loc, | |
2869 | Prefix => Unchecked_Convert_To (T, Ptr), | |
2870 | Selector_Name => | |
2871 | New_Occurrence_Of (Next_Entity (First_Entity (T)), Loc)); | |
70482933 | 2872 | |
02822a92 RD |
2873 | Nam := |
2874 | Make_Explicit_Dereference (Loc, | |
2875 | Prefix => Nam); | |
70482933 RK |
2876 | |
2877 | if Present (Parameter_Associations (N)) then | |
2878 | Parm := Parameter_Associations (N); | |
2879 | else | |
2880 | Parm := New_List; | |
2881 | end if; | |
2882 | ||
2883 | Prepend (Obj, Parm); | |
2884 | ||
2885 | if Etype (D_T) = Standard_Void_Type then | |
02822a92 RD |
2886 | Call := |
2887 | Make_Procedure_Call_Statement (Loc, | |
2888 | Name => Nam, | |
2889 | Parameter_Associations => Parm); | |
70482933 | 2890 | else |
02822a92 RD |
2891 | Call := |
2892 | Make_Function_Call (Loc, | |
2893 | Name => Nam, | |
2894 | Parameter_Associations => Parm); | |
70482933 RK |
2895 | end if; |
2896 | ||
2897 | Set_First_Named_Actual (Call, First_Named_Actual (N)); | |
70482933 RK |
2898 | Set_Etype (Call, Etype (D_T)); |
2899 | ||
2900 | -- We do not re-analyze the call to avoid infinite recursion. | |
2901 | -- We analyze separately the prefix and the object, and set | |
2902 | -- the checks on the prefix that would otherwise be emitted | |
2903 | -- when resolving a call. | |
2904 | ||
2905 | Rewrite (N, Call); | |
2906 | Analyze (Nam); | |
2907 | Apply_Access_Check (Nam); | |
2908 | Analyze (Obj); | |
2909 | return; | |
2910 | end; | |
2911 | end if; | |
2912 | end if; | |
2913 | ||
2914 | -- If this is a call to an intrinsic subprogram, then perform the | |
2915 | -- appropriate expansion to the corresponding tree node and we | |
2916 | -- are all done (since after that the call is gone!) | |
2917 | ||
98f01d53 AC |
2918 | -- In the case where the intrinsic is to be processed by the back end, |
2919 | -- the call to Expand_Intrinsic_Call will do nothing, which is fine, | |
2920 | -- since the idea in this case is to pass the call unchanged. | |
d766cee3 RD |
2921 | -- If the intrinsic is an inherited unchecked conversion, and the |
2922 | -- derived type is the target type of the conversion, we must retain | |
2923 | -- it as the return type of the expression. Otherwise the expansion | |
2924 | -- below, which uses the parent operation, will yield the wrong type. | |
98f01d53 | 2925 | |
70482933 RK |
2926 | if Is_Intrinsic_Subprogram (Subp) then |
2927 | Expand_Intrinsic_Call (N, Subp); | |
d766cee3 RD |
2928 | |
2929 | if Nkind (N) = N_Unchecked_Type_Conversion | |
2930 | and then Parent_Subp /= Orig_Subp | |
2931 | and then Etype (Parent_Subp) /= Etype (Orig_Subp) | |
2932 | then | |
2933 | Set_Etype (N, Etype (Orig_Subp)); | |
2934 | end if; | |
2935 | ||
70482933 RK |
2936 | return; |
2937 | end if; | |
2938 | ||
2939 | if Ekind (Subp) = E_Function | |
2940 | or else Ekind (Subp) = E_Procedure | |
2941 | then | |
26a43556 | 2942 | -- We perform two simple optimization on calls: |
8dbf3473 | 2943 | |
3563739b | 2944 | -- a) replace calls to null procedures unconditionally; |
26a43556 | 2945 | |
3563739b | 2946 | -- b) for To_Address, just do an unchecked conversion. Not only is |
26a43556 AC |
2947 | -- this efficient, but it also avoids order of elaboration problems |
2948 | -- when address clauses are inlined (address expression elaborated | |
2949 | -- at the wrong point). | |
2950 | ||
2951 | -- We perform these optimization regardless of whether we are in the | |
2952 | -- main unit or in a unit in the context of the main unit, to ensure | |
2953 | -- that tree generated is the same in both cases, for Inspector use. | |
2954 | ||
2955 | if Is_RTE (Subp, RE_To_Address) then | |
2956 | Rewrite (N, | |
2957 | Unchecked_Convert_To | |
2958 | (RTE (RE_Address), Relocate_Node (First_Actual (N)))); | |
2959 | return; | |
2960 | ||
2961 | elsif Is_Null_Procedure (Subp) then | |
8dbf3473 AC |
2962 | Rewrite (N, Make_Null_Statement (Loc)); |
2963 | return; | |
2964 | end if; | |
2965 | ||
70482933 RK |
2966 | if Is_Inlined (Subp) then |
2967 | ||
a41ea816 | 2968 | Inlined_Subprogram : declare |
fbf5a39b AC |
2969 | Bod : Node_Id; |
2970 | Must_Inline : Boolean := False; | |
2971 | Spec : constant Node_Id := Unit_Declaration_Node (Subp); | |
5b4994bc | 2972 | Scop : constant Entity_Id := Scope (Subp); |
70482933 | 2973 | |
a41ea816 | 2974 | function In_Unfrozen_Instance return Boolean; |
26a43556 AC |
2975 | -- If the subprogram comes from an instance in the same unit, |
2976 | -- and the instance is not yet frozen, inlining might trigger | |
2977 | -- order-of-elaboration problems in gigi. | |
a41ea816 AC |
2978 | |
2979 | -------------------------- | |
2980 | -- In_Unfrozen_Instance -- | |
2981 | -------------------------- | |
2982 | ||
2983 | function In_Unfrozen_Instance return Boolean is | |
2f1b20a9 | 2984 | S : Entity_Id; |
a41ea816 AC |
2985 | |
2986 | begin | |
2f1b20a9 | 2987 | S := Scop; |
a41ea816 AC |
2988 | while Present (S) |
2989 | and then S /= Standard_Standard | |
2990 | loop | |
2991 | if Is_Generic_Instance (S) | |
2992 | and then Present (Freeze_Node (S)) | |
2993 | and then not Analyzed (Freeze_Node (S)) | |
2994 | then | |
2995 | return True; | |
2996 | end if; | |
2997 | ||
2998 | S := Scope (S); | |
2999 | end loop; | |
3000 | ||
3001 | return False; | |
3002 | end In_Unfrozen_Instance; | |
3003 | ||
3004 | -- Start of processing for Inlined_Subprogram | |
3005 | ||
70482933 | 3006 | begin |
2f1b20a9 ES |
3007 | -- Verify that the body to inline has already been seen, and |
3008 | -- that if the body is in the current unit the inlining does | |
3009 | -- not occur earlier. This avoids order-of-elaboration problems | |
3010 | -- in the back end. | |
3011 | ||
3012 | -- This should be documented in sinfo/einfo ??? | |
70482933 | 3013 | |
fbf5a39b AC |
3014 | if No (Spec) |
3015 | or else Nkind (Spec) /= N_Subprogram_Declaration | |
3016 | or else No (Body_To_Inline (Spec)) | |
70482933 | 3017 | then |
fbf5a39b AC |
3018 | Must_Inline := False; |
3019 | ||
26a43556 AC |
3020 | -- If this an inherited function that returns a private type, |
3021 | -- do not inline if the full view is an unconstrained array, | |
3022 | -- because such calls cannot be inlined. | |
5b4994bc AC |
3023 | |
3024 | elsif Present (Orig_Subp) | |
3025 | and then Is_Array_Type (Etype (Orig_Subp)) | |
3026 | and then not Is_Constrained (Etype (Orig_Subp)) | |
3027 | then | |
3028 | Must_Inline := False; | |
3029 | ||
a41ea816 | 3030 | elsif In_Unfrozen_Instance then |
5b4994bc AC |
3031 | Must_Inline := False; |
3032 | ||
fbf5a39b AC |
3033 | else |
3034 | Bod := Body_To_Inline (Spec); | |
3035 | ||
3036 | if (In_Extended_Main_Code_Unit (N) | |
3037 | or else In_Extended_Main_Code_Unit (Parent (N)) | |
ac4d6407 | 3038 | or else Has_Pragma_Inline_Always (Subp)) |
fbf5a39b AC |
3039 | and then (not In_Same_Extended_Unit (Sloc (Bod), Loc) |
3040 | or else | |
3041 | Earlier_In_Extended_Unit (Sloc (Bod), Loc)) | |
3042 | then | |
3043 | Must_Inline := True; | |
3044 | ||
3045 | -- If we are compiling a package body that is not the main | |
3046 | -- unit, it must be for inlining/instantiation purposes, | |
3047 | -- in which case we inline the call to insure that the same | |
3048 | -- temporaries are generated when compiling the body by | |
3049 | -- itself. Otherwise link errors can occur. | |
3050 | ||
2820d220 AC |
3051 | -- If the function being called is itself in the main unit, |
3052 | -- we cannot inline, because there is a risk of double | |
3053 | -- elaboration and/or circularity: the inlining can make | |
3054 | -- visible a private entity in the body of the main unit, | |
3055 | -- that gigi will see before its sees its proper definition. | |
3056 | ||
fbf5a39b AC |
3057 | elsif not (In_Extended_Main_Code_Unit (N)) |
3058 | and then In_Package_Body | |
3059 | then | |
2820d220 | 3060 | Must_Inline := not In_Extended_Main_Source_Unit (Subp); |
fbf5a39b AC |
3061 | end if; |
3062 | end if; | |
3063 | ||
3064 | if Must_Inline then | |
70482933 RK |
3065 | Expand_Inlined_Call (N, Subp, Orig_Subp); |
3066 | ||
3067 | else | |
fbf5a39b | 3068 | -- Let the back end handle it |
70482933 RK |
3069 | |
3070 | Add_Inlined_Body (Subp); | |
3071 | ||
3072 | if Front_End_Inlining | |
3073 | and then Nkind (Spec) = N_Subprogram_Declaration | |
3074 | and then (In_Extended_Main_Code_Unit (N)) | |
3075 | and then No (Body_To_Inline (Spec)) | |
3076 | and then not Has_Completion (Subp) | |
3077 | and then In_Same_Extended_Unit (Sloc (Spec), Loc) | |
70482933 | 3078 | then |
fbf5a39b | 3079 | Cannot_Inline |
26a43556 | 3080 | ("cannot inline& (body not seen yet)?", N, Subp); |
70482933 RK |
3081 | end if; |
3082 | end if; | |
a41ea816 | 3083 | end Inlined_Subprogram; |
70482933 RK |
3084 | end if; |
3085 | end if; | |
3086 | ||
26a43556 AC |
3087 | -- Check for protected subprogram. This is either an intra-object call, |
3088 | -- or a protected function call. Protected procedure calls are rewritten | |
3089 | -- as entry calls and handled accordingly. | |
70482933 | 3090 | |
26a43556 AC |
3091 | -- In Ada 2005, this may be an indirect call to an access parameter that |
3092 | -- is an access_to_subprogram. In that case the anonymous type has a | |
3093 | -- scope that is a protected operation, but the call is a regular one. | |
c8ef728f | 3094 | |
70482933 RK |
3095 | Scop := Scope (Subp); |
3096 | ||
3097 | if Nkind (N) /= N_Entry_Call_Statement | |
3098 | and then Is_Protected_Type (Scop) | |
c8ef728f | 3099 | and then Ekind (Subp) /= E_Subprogram_Type |
70482933 | 3100 | then |
26a43556 AC |
3101 | -- If the call is an internal one, it is rewritten as a call to the |
3102 | -- corresponding unprotected subprogram. | |
70482933 RK |
3103 | |
3104 | Expand_Protected_Subprogram_Call (N, Subp, Scop); | |
3105 | end if; | |
3106 | ||
26a43556 AC |
3107 | -- Functions returning controlled objects need special attention: |
3108 | -- if the return type is limited, the context is an initialization | |
6eab5a95 AC |
3109 | -- and different processing applies. If the call is to a protected |
3110 | -- function, the expansion above will call Expand_Call recusively. | |
3111 | -- To prevent a double attachment, check that the current call is | |
3112 | -- not a rewriting of a protected function call. | |
70482933 | 3113 | |
048e5cef | 3114 | if Needs_Finalization (Etype (Subp)) |
02822a92 | 3115 | and then not Is_Inherently_Limited_Type (Etype (Subp)) |
6eab5a95 AC |
3116 | and then |
3117 | (No (First_Formal (Subp)) | |
3118 | or else | |
3119 | not Is_Concurrent_Record_Type (Etype (First_Formal (Subp)))) | |
70482933 RK |
3120 | then |
3121 | Expand_Ctrl_Function_Call (N); | |
3122 | end if; | |
3123 | ||
26a43556 AC |
3124 | -- Test for First_Optional_Parameter, and if so, truncate parameter list |
3125 | -- if there are optional parameters at the trailing end. | |
3126 | -- Note: we never delete procedures for call via a pointer. | |
70482933 RK |
3127 | |
3128 | if (Ekind (Subp) = E_Procedure or else Ekind (Subp) = E_Function) | |
3129 | and then Present (First_Optional_Parameter (Subp)) | |
3130 | then | |
3131 | declare | |
3132 | Last_Keep_Arg : Node_Id; | |
3133 | ||
3134 | begin | |
26a43556 AC |
3135 | -- Last_Keep_Arg will hold the last actual that should be kept. |
3136 | -- If it remains empty at the end, it means that all parameters | |
3137 | -- are optional. | |
70482933 RK |
3138 | |
3139 | Last_Keep_Arg := Empty; | |
3140 | ||
26a43556 AC |
3141 | -- Find first optional parameter, must be present since we checked |
3142 | -- the validity of the parameter before setting it. | |
70482933 RK |
3143 | |
3144 | Formal := First_Formal (Subp); | |
3145 | Actual := First_Actual (N); | |
3146 | while Formal /= First_Optional_Parameter (Subp) loop | |
3147 | Last_Keep_Arg := Actual; | |
3148 | Next_Formal (Formal); | |
3149 | Next_Actual (Actual); | |
3150 | end loop; | |
3151 | ||
fbf5a39b AC |
3152 | -- We have Formal and Actual pointing to the first potentially |
3153 | -- droppable argument. We can drop all the trailing arguments | |
3154 | -- whose actual matches the default. Note that we know that all | |
3155 | -- remaining formals have defaults, because we checked that this | |
3156 | -- requirement was met before setting First_Optional_Parameter. | |
70482933 RK |
3157 | |
3158 | -- We use Fully_Conformant_Expressions to check for identity | |
3159 | -- between formals and actuals, which may miss some cases, but | |
3160 | -- on the other hand, this is only an optimization (if we fail | |
3161 | -- to truncate a parameter it does not affect functionality). | |
3162 | -- So if the default is 3 and the actual is 1+2, we consider | |
3163 | -- them unequal, which hardly seems worrisome. | |
3164 | ||
3165 | while Present (Formal) loop | |
3166 | if not Fully_Conformant_Expressions | |
3167 | (Actual, Default_Value (Formal)) | |
3168 | then | |
3169 | Last_Keep_Arg := Actual; | |
3170 | end if; | |
3171 | ||
3172 | Next_Formal (Formal); | |
3173 | Next_Actual (Actual); | |
3174 | end loop; | |
3175 | ||
3176 | -- If no arguments, delete entire list, this is the easy case | |
3177 | ||
3178 | if No (Last_Keep_Arg) then | |
70482933 RK |
3179 | Set_Parameter_Associations (N, No_List); |
3180 | Set_First_Named_Actual (N, Empty); | |
3181 | ||
3182 | -- Case where at the last retained argument is positional. This | |
3183 | -- is also an easy case, since the retained arguments are already | |
3184 | -- in the right form, and we don't need to worry about the order | |
3185 | -- of arguments that get eliminated. | |
3186 | ||
3187 | elsif Is_List_Member (Last_Keep_Arg) then | |
3188 | while Present (Next (Last_Keep_Arg)) loop | |
ac4d6407 | 3189 | Discard_Node (Remove_Next (Last_Keep_Arg)); |
70482933 RK |
3190 | end loop; |
3191 | ||
3192 | Set_First_Named_Actual (N, Empty); | |
3193 | ||
3194 | -- This is the annoying case where the last retained argument | |
3195 | -- is a named parameter. Since the original arguments are not | |
3196 | -- in declaration order, we may have to delete some fairly | |
3197 | -- random collection of arguments. | |
3198 | ||
3199 | else | |
3200 | declare | |
3201 | Temp : Node_Id; | |
3202 | Passoc : Node_Id; | |
fbf5a39b | 3203 | |
70482933 RK |
3204 | begin |
3205 | -- First step, remove all the named parameters from the | |
3206 | -- list (they are still chained using First_Named_Actual | |
3207 | -- and Next_Named_Actual, so we have not lost them!) | |
3208 | ||
3209 | Temp := First (Parameter_Associations (N)); | |
3210 | ||
3211 | -- Case of all parameters named, remove them all | |
3212 | ||
3213 | if Nkind (Temp) = N_Parameter_Association then | |
3214 | while Is_Non_Empty_List (Parameter_Associations (N)) loop | |
3215 | Temp := Remove_Head (Parameter_Associations (N)); | |
3216 | end loop; | |
3217 | ||
3218 | -- Case of mixed positional/named, remove named parameters | |
3219 | ||
3220 | else | |
3221 | while Nkind (Next (Temp)) /= N_Parameter_Association loop | |
3222 | Next (Temp); | |
3223 | end loop; | |
3224 | ||
3225 | while Present (Next (Temp)) loop | |
7888a6ae | 3226 | Remove (Next (Temp)); |
70482933 RK |
3227 | end loop; |
3228 | end if; | |
3229 | ||
3230 | -- Now we loop through the named parameters, till we get | |
3231 | -- to the last one to be retained, adding them to the list. | |
3232 | -- Note that the Next_Named_Actual list does not need to be | |
3233 | -- touched since we are only reordering them on the actual | |
3234 | -- parameter association list. | |
3235 | ||
3236 | Passoc := Parent (First_Named_Actual (N)); | |
3237 | loop | |
3238 | Temp := Relocate_Node (Passoc); | |
3239 | Append_To | |
3240 | (Parameter_Associations (N), Temp); | |
3241 | exit when | |
3242 | Last_Keep_Arg = Explicit_Actual_Parameter (Passoc); | |
3243 | Passoc := Parent (Next_Named_Actual (Passoc)); | |
3244 | end loop; | |
3245 | ||
3246 | Set_Next_Named_Actual (Temp, Empty); | |
3247 | ||
3248 | loop | |
3249 | Temp := Next_Named_Actual (Passoc); | |
3250 | exit when No (Temp); | |
3251 | Set_Next_Named_Actual | |
3252 | (Passoc, Next_Named_Actual (Parent (Temp))); | |
70482933 RK |
3253 | end loop; |
3254 | end; | |
811c6a85 | 3255 | |
70482933 RK |
3256 | end if; |
3257 | end; | |
3258 | end if; | |
70482933 RK |
3259 | end Expand_Call; |
3260 | ||
3261 | -------------------------- | |
3262 | -- Expand_Inlined_Call -- | |
3263 | -------------------------- | |
3264 | ||
3265 | procedure Expand_Inlined_Call | |
3266 | (N : Node_Id; | |
3267 | Subp : Entity_Id; | |
3268 | Orig_Subp : Entity_Id) | |
3269 | is | |
fbf5a39b AC |
3270 | Loc : constant Source_Ptr := Sloc (N); |
3271 | Is_Predef : constant Boolean := | |
3272 | Is_Predefined_File_Name | |
3273 | (Unit_File_Name (Get_Source_Unit (Subp))); | |
3274 | Orig_Bod : constant Node_Id := | |
3275 | Body_To_Inline (Unit_Declaration_Node (Subp)); | |
3276 | ||
70482933 RK |
3277 | Blk : Node_Id; |
3278 | Bod : Node_Id; | |
3279 | Decl : Node_Id; | |
c8ef728f | 3280 | Decls : constant List_Id := New_List; |
70482933 RK |
3281 | Exit_Lab : Entity_Id := Empty; |
3282 | F : Entity_Id; | |
3283 | A : Node_Id; | |
3284 | Lab_Decl : Node_Id; | |
3285 | Lab_Id : Node_Id; | |
3286 | New_A : Node_Id; | |
3287 | Num_Ret : Int := 0; | |
70482933 RK |
3288 | Ret_Type : Entity_Id; |
3289 | Targ : Node_Id; | |
c8ef728f | 3290 | Targ1 : Node_Id; |
70482933 RK |
3291 | Temp : Entity_Id; |
3292 | Temp_Typ : Entity_Id; | |
3293 | ||
c8ef728f ES |
3294 | Is_Unc : constant Boolean := |
3295 | Is_Array_Type (Etype (Subp)) | |
3296 | and then not Is_Constrained (Etype (Subp)); | |
26a43556 AC |
3297 | -- If the type returned by the function is unconstrained and the call |
3298 | -- can be inlined, special processing is required. | |
c8ef728f | 3299 | |
70482933 | 3300 | procedure Make_Exit_Label; |
26a43556 AC |
3301 | -- Build declaration for exit label to be used in Return statements, |
3302 | -- sets Exit_Lab (the label node) and Lab_Decl (corresponding implcit | |
3303 | -- declaration). | |
70482933 RK |
3304 | |
3305 | function Process_Formals (N : Node_Id) return Traverse_Result; | |
26a43556 AC |
3306 | -- Replace occurrence of a formal with the corresponding actual, or the |
3307 | -- thunk generated for it. | |
70482933 | 3308 | |
fbf5a39b | 3309 | function Process_Sloc (Nod : Node_Id) return Traverse_Result; |
26a43556 AC |
3310 | -- If the call being expanded is that of an internal subprogram, set the |
3311 | -- sloc of the generated block to that of the call itself, so that the | |
3312 | -- expansion is skipped by the "next" command in gdb. | |
fbf5a39b | 3313 | -- Same processing for a subprogram in a predefined file, e.g. |
26a43556 AC |
3314 | -- Ada.Tags. If Debug_Generated_Code is true, suppress this change to |
3315 | -- simplify our own development. | |
fbf5a39b | 3316 | |
70482933 RK |
3317 | procedure Rewrite_Function_Call (N : Node_Id; Blk : Node_Id); |
3318 | -- If the function body is a single expression, replace call with | |
3319 | -- expression, else insert block appropriately. | |
3320 | ||
3321 | procedure Rewrite_Procedure_Call (N : Node_Id; Blk : Node_Id); | |
3322 | -- If procedure body has no local variables, inline body without | |
02822a92 | 3323 | -- creating block, otherwise rewrite call with block. |
70482933 | 3324 | |
5453d5bd AC |
3325 | function Formal_Is_Used_Once (Formal : Entity_Id) return Boolean; |
3326 | -- Determine whether a formal parameter is used only once in Orig_Bod | |
3327 | ||
70482933 RK |
3328 | --------------------- |
3329 | -- Make_Exit_Label -- | |
3330 | --------------------- | |
3331 | ||
3332 | procedure Make_Exit_Label is | |
3333 | begin | |
98f01d53 | 3334 | -- Create exit label for subprogram if one does not exist yet |
70482933 RK |
3335 | |
3336 | if No (Exit_Lab) then | |
02822a92 RD |
3337 | Lab_Id := |
3338 | Make_Identifier (Loc, | |
3339 | Chars => New_Internal_Name ('L')); | |
70482933 RK |
3340 | Set_Entity (Lab_Id, |
3341 | Make_Defining_Identifier (Loc, Chars (Lab_Id))); | |
3342 | Exit_Lab := Make_Label (Loc, Lab_Id); | |
3343 | ||
3344 | Lab_Decl := | |
3345 | Make_Implicit_Label_Declaration (Loc, | |
3346 | Defining_Identifier => Entity (Lab_Id), | |
3347 | Label_Construct => Exit_Lab); | |
3348 | end if; | |
3349 | end Make_Exit_Label; | |
3350 | ||
3351 | --------------------- | |
3352 | -- Process_Formals -- | |
3353 | --------------------- | |
3354 | ||
3355 | function Process_Formals (N : Node_Id) return Traverse_Result is | |
3356 | A : Entity_Id; | |
3357 | E : Entity_Id; | |
3358 | Ret : Node_Id; | |
3359 | ||
3360 | begin | |
3361 | if Is_Entity_Name (N) | |
3362 | and then Present (Entity (N)) | |
3363 | then | |
3364 | E := Entity (N); | |
3365 | ||
3366 | if Is_Formal (E) | |
3367 | and then Scope (E) = Subp | |
3368 | then | |
3369 | A := Renamed_Object (E); | |
3370 | ||
02822a92 RD |
3371 | -- Rewrite the occurrence of the formal into an occurrence of |
3372 | -- the actual. Also establish visibility on the proper view of | |
3373 | -- the actual's subtype for the body's context (if the actual's | |
3374 | -- subtype is private at the call point but its full view is | |
3375 | -- visible to the body, then the inlined tree here must be | |
3376 | -- analyzed with the full view). | |
3377 | ||
70482933 RK |
3378 | if Is_Entity_Name (A) then |
3379 | Rewrite (N, New_Occurrence_Of (Entity (A), Loc)); | |
02822a92 | 3380 | Check_Private_View (N); |
70482933 RK |
3381 | |
3382 | elsif Nkind (A) = N_Defining_Identifier then | |
3383 | Rewrite (N, New_Occurrence_Of (A, Loc)); | |
02822a92 | 3384 | Check_Private_View (N); |
70482933 | 3385 | |
d766cee3 RD |
3386 | -- Numeric literal |
3387 | ||
3388 | else | |
70482933 RK |
3389 | Rewrite (N, New_Copy (A)); |
3390 | end if; | |
3391 | end if; | |
3392 | ||
3393 | return Skip; | |
3394 | ||
d766cee3 | 3395 | elsif Nkind (N) = N_Simple_Return_Statement then |
70482933 RK |
3396 | if No (Expression (N)) then |
3397 | Make_Exit_Label; | |
d766cee3 RD |
3398 | Rewrite (N, |
3399 | Make_Goto_Statement (Loc, | |
3400 | Name => New_Copy (Lab_Id))); | |
70482933 RK |
3401 | |
3402 | else | |
3403 | if Nkind (Parent (N)) = N_Handled_Sequence_Of_Statements | |
3404 | and then Nkind (Parent (Parent (N))) = N_Subprogram_Body | |
3405 | then | |
fbf5a39b | 3406 | -- Function body is a single expression. No need for |
70482933 | 3407 | -- exit label. |
fbf5a39b | 3408 | |
70482933 RK |
3409 | null; |
3410 | ||
3411 | else | |
3412 | Num_Ret := Num_Ret + 1; | |
3413 | Make_Exit_Label; | |
3414 | end if; | |
3415 | ||
3416 | -- Because of the presence of private types, the views of the | |
3417 | -- expression and the context may be different, so place an | |
3418 | -- unchecked conversion to the context type to avoid spurious | |
8fc789c8 | 3419 | -- errors, e.g. when the expression is a numeric literal and |
70482933 RK |
3420 | -- the context is private. If the expression is an aggregate, |
3421 | -- use a qualified expression, because an aggregate is not a | |
3422 | -- legal argument of a conversion. | |
3423 | ||
ac4d6407 | 3424 | if Nkind_In (Expression (N), N_Aggregate, N_Null) then |
70482933 RK |
3425 | Ret := |
3426 | Make_Qualified_Expression (Sloc (N), | |
3427 | Subtype_Mark => New_Occurrence_Of (Ret_Type, Sloc (N)), | |
3428 | Expression => Relocate_Node (Expression (N))); | |
3429 | else | |
3430 | Ret := | |
3431 | Unchecked_Convert_To | |
3432 | (Ret_Type, Relocate_Node (Expression (N))); | |
3433 | end if; | |
3434 | ||
3435 | if Nkind (Targ) = N_Defining_Identifier then | |
3436 | Rewrite (N, | |
3437 | Make_Assignment_Statement (Loc, | |
3438 | Name => New_Occurrence_Of (Targ, Loc), | |
3439 | Expression => Ret)); | |
3440 | else | |
3441 | Rewrite (N, | |
3442 | Make_Assignment_Statement (Loc, | |
3443 | Name => New_Copy (Targ), | |
3444 | Expression => Ret)); | |
3445 | end if; | |
3446 | ||
3447 | Set_Assignment_OK (Name (N)); | |
3448 | ||
3449 | if Present (Exit_Lab) then | |
3450 | Insert_After (N, | |
3451 | Make_Goto_Statement (Loc, | |
3452 | Name => New_Copy (Lab_Id))); | |
3453 | end if; | |
3454 | end if; | |
3455 | ||
3456 | return OK; | |
3457 | ||
fbf5a39b AC |
3458 | -- Remove pragma Unreferenced since it may refer to formals that |
3459 | -- are not visible in the inlined body, and in any case we will | |
3460 | -- not be posting warnings on the inlined body so it is unneeded. | |
3461 | ||
3462 | elsif Nkind (N) = N_Pragma | |
1923d2d6 | 3463 | and then Pragma_Name (N) = Name_Unreferenced |
fbf5a39b AC |
3464 | then |
3465 | Rewrite (N, Make_Null_Statement (Sloc (N))); | |
3466 | return OK; | |
3467 | ||
70482933 RK |
3468 | else |
3469 | return OK; | |
3470 | end if; | |
3471 | end Process_Formals; | |
3472 | ||
3473 | procedure Replace_Formals is new Traverse_Proc (Process_Formals); | |
3474 | ||
fbf5a39b AC |
3475 | ------------------ |
3476 | -- Process_Sloc -- | |
3477 | ------------------ | |
3478 | ||
3479 | function Process_Sloc (Nod : Node_Id) return Traverse_Result is | |
3480 | begin | |
3481 | if not Debug_Generated_Code then | |
3482 | Set_Sloc (Nod, Sloc (N)); | |
3483 | Set_Comes_From_Source (Nod, False); | |
3484 | end if; | |
3485 | ||
3486 | return OK; | |
3487 | end Process_Sloc; | |
3488 | ||
3489 | procedure Reset_Slocs is new Traverse_Proc (Process_Sloc); | |
3490 | ||
70482933 RK |
3491 | --------------------------- |
3492 | -- Rewrite_Function_Call -- | |
3493 | --------------------------- | |
3494 | ||
3495 | procedure Rewrite_Function_Call (N : Node_Id; Blk : Node_Id) is | |
fbf5a39b AC |
3496 | HSS : constant Node_Id := Handled_Statement_Sequence (Blk); |
3497 | Fst : constant Node_Id := First (Statements (HSS)); | |
70482933 RK |
3498 | |
3499 | begin | |
70482933 RK |
3500 | -- Optimize simple case: function body is a single return statement, |
3501 | -- which has been expanded into an assignment. | |
3502 | ||
3503 | if Is_Empty_List (Declarations (Blk)) | |
3504 | and then Nkind (Fst) = N_Assignment_Statement | |
3505 | and then No (Next (Fst)) | |
3506 | then | |
3507 | ||
3508 | -- The function call may have been rewritten as the temporary | |
3509 | -- that holds the result of the call, in which case remove the | |
3510 | -- now useless declaration. | |
3511 | ||
3512 | if Nkind (N) = N_Identifier | |
3513 | and then Nkind (Parent (Entity (N))) = N_Object_Declaration | |
3514 | then | |
3515 | Rewrite (Parent (Entity (N)), Make_Null_Statement (Loc)); | |
3516 | end if; | |
3517 | ||
3518 | Rewrite (N, Expression (Fst)); | |
3519 | ||
3520 | elsif Nkind (N) = N_Identifier | |
3521 | and then Nkind (Parent (Entity (N))) = N_Object_Declaration | |
3522 | then | |
98f01d53 | 3523 | -- The block assigns the result of the call to the temporary |
70482933 RK |
3524 | |
3525 | Insert_After (Parent (Entity (N)), Blk); | |
3526 | ||
3527 | elsif Nkind (Parent (N)) = N_Assignment_Statement | |
c8ef728f ES |
3528 | and then |
3529 | (Is_Entity_Name (Name (Parent (N))) | |
3530 | or else | |
3531 | (Nkind (Name (Parent (N))) = N_Explicit_Dereference | |
3532 | and then Is_Entity_Name (Prefix (Name (Parent (N)))))) | |
70482933 | 3533 | then |
fbf5a39b | 3534 | -- Replace assignment with the block |
70482933 | 3535 | |
30c20106 AC |
3536 | declare |
3537 | Original_Assignment : constant Node_Id := Parent (N); | |
7324bf49 AC |
3538 | |
3539 | begin | |
2f1b20a9 ES |
3540 | -- Preserve the original assignment node to keep the complete |
3541 | -- assignment subtree consistent enough for Analyze_Assignment | |
3542 | -- to proceed (specifically, the original Lhs node must still | |
3543 | -- have an assignment statement as its parent). | |
7324bf49 | 3544 | |
2f1b20a9 ES |
3545 | -- We cannot rely on Original_Node to go back from the block |
3546 | -- node to the assignment node, because the assignment might | |
3547 | -- already be a rewrite substitution. | |
30c20106 | 3548 | |
7324bf49 | 3549 | Discard_Node (Relocate_Node (Original_Assignment)); |
30c20106 AC |
3550 | Rewrite (Original_Assignment, Blk); |
3551 | end; | |
70482933 RK |
3552 | |
3553 | elsif Nkind (Parent (N)) = N_Object_Declaration then | |
3554 | Set_Expression (Parent (N), Empty); | |
3555 | Insert_After (Parent (N), Blk); | |
c8ef728f ES |
3556 | |
3557 | elsif Is_Unc then | |
3558 | Insert_Before (Parent (N), Blk); | |
70482933 RK |
3559 | end if; |
3560 | end Rewrite_Function_Call; | |
3561 | ||
3562 | ---------------------------- | |
3563 | -- Rewrite_Procedure_Call -- | |
3564 | ---------------------------- | |
3565 | ||
3566 | procedure Rewrite_Procedure_Call (N : Node_Id; Blk : Node_Id) is | |
fbf5a39b | 3567 | HSS : constant Node_Id := Handled_Statement_Sequence (Blk); |
70482933 | 3568 | begin |
02822a92 RD |
3569 | -- If there is a transient scope for N, this will be the scope of the |
3570 | -- actions for N, and the statements in Blk need to be within this | |
3571 | -- scope. For example, they need to have visibility on the constant | |
3572 | -- declarations created for the formals. | |
3573 | ||
3574 | -- If N needs no transient scope, and if there are no declarations in | |
3575 | -- the inlined body, we can do a little optimization and insert the | |
3576 | -- statements for the body directly after N, and rewrite N to a | |
3577 | -- null statement, instead of rewriting N into a full-blown block | |
3578 | -- statement. | |
3579 | ||
3580 | if not Scope_Is_Transient | |
3581 | and then Is_Empty_List (Declarations (Blk)) | |
3582 | then | |
70482933 RK |
3583 | Insert_List_After (N, Statements (HSS)); |
3584 | Rewrite (N, Make_Null_Statement (Loc)); | |
3585 | else | |
3586 | Rewrite (N, Blk); | |
3587 | end if; | |
3588 | end Rewrite_Procedure_Call; | |
3589 | ||
5453d5bd AC |
3590 | ------------------------- |
3591 | -- Formal_Is_Used_Once -- | |
02822a92 | 3592 | ------------------------- |
5453d5bd AC |
3593 | |
3594 | function Formal_Is_Used_Once (Formal : Entity_Id) return Boolean is | |
3595 | Use_Counter : Int := 0; | |
3596 | ||
3597 | function Count_Uses (N : Node_Id) return Traverse_Result; | |
3598 | -- Traverse the tree and count the uses of the formal parameter. | |
3599 | -- In this case, for optimization purposes, we do not need to | |
3600 | -- continue the traversal once more than one use is encountered. | |
3601 | ||
cc335f43 AC |
3602 | ---------------- |
3603 | -- Count_Uses -- | |
3604 | ---------------- | |
3605 | ||
5453d5bd AC |
3606 | function Count_Uses (N : Node_Id) return Traverse_Result is |
3607 | begin | |
5453d5bd AC |
3608 | -- The original node is an identifier |
3609 | ||
3610 | if Nkind (N) = N_Identifier | |
3611 | and then Present (Entity (N)) | |
3612 | ||
2f1b20a9 | 3613 | -- Original node's entity points to the one in the copied body |
5453d5bd AC |
3614 | |
3615 | and then Nkind (Entity (N)) = N_Identifier | |
3616 | and then Present (Entity (Entity (N))) | |
3617 | ||
3618 | -- The entity of the copied node is the formal parameter | |
3619 | ||
3620 | and then Entity (Entity (N)) = Formal | |
3621 | then | |
3622 | Use_Counter := Use_Counter + 1; | |
3623 | ||
3624 | if Use_Counter > 1 then | |
3625 | ||
3626 | -- Denote more than one use and abandon the traversal | |
3627 | ||
3628 | Use_Counter := 2; | |
3629 | return Abandon; | |
3630 | ||
3631 | end if; | |
3632 | end if; | |
3633 | ||
3634 | return OK; | |
3635 | end Count_Uses; | |
3636 | ||
3637 | procedure Count_Formal_Uses is new Traverse_Proc (Count_Uses); | |
3638 | ||
3639 | -- Start of processing for Formal_Is_Used_Once | |
3640 | ||
3641 | begin | |
5453d5bd AC |
3642 | Count_Formal_Uses (Orig_Bod); |
3643 | return Use_Counter = 1; | |
5453d5bd AC |
3644 | end Formal_Is_Used_Once; |
3645 | ||
70482933 RK |
3646 | -- Start of processing for Expand_Inlined_Call |
3647 | ||
3648 | begin | |
8dbf3473 | 3649 | |
f44fe430 RD |
3650 | -- Check for an illegal attempt to inline a recursive procedure. If the |
3651 | -- subprogram has parameters this is detected when trying to supply a | |
3652 | -- binding for parameters that already have one. For parameterless | |
3653 | -- subprograms this must be done explicitly. | |
3654 | ||
3655 | if In_Open_Scopes (Subp) then | |
3656 | Error_Msg_N ("call to recursive subprogram cannot be inlined?", N); | |
3657 | Set_Is_Inlined (Subp, False); | |
3658 | return; | |
3659 | end if; | |
3660 | ||
2ccf2fb3 ES |
3661 | if Nkind (Orig_Bod) = N_Defining_Identifier |
3662 | or else Nkind (Orig_Bod) = N_Defining_Operator_Symbol | |
3663 | then | |
70482933 RK |
3664 | -- Subprogram is a renaming_as_body. Calls appearing after the |
3665 | -- renaming can be replaced with calls to the renamed entity | |
f44fe430 RD |
3666 | -- directly, because the subprograms are subtype conformant. If |
3667 | -- the renamed subprogram is an inherited operation, we must redo | |
3668 | -- the expansion because implicit conversions may be needed. | |
70482933 RK |
3669 | |
3670 | Set_Name (N, New_Occurrence_Of (Orig_Bod, Loc)); | |
f44fe430 RD |
3671 | |
3672 | if Present (Alias (Orig_Bod)) then | |
3673 | Expand_Call (N); | |
3674 | end if; | |
3675 | ||
70482933 RK |
3676 | return; |
3677 | end if; | |
3678 | ||
3679 | -- Use generic machinery to copy body of inlined subprogram, as if it | |
3680 | -- were an instantiation, resetting source locations appropriately, so | |
3681 | -- that nested inlined calls appear in the main unit. | |
3682 | ||
3683 | Save_Env (Subp, Empty); | |
fbf5a39b | 3684 | Set_Copied_Sloc_For_Inlined_Body (N, Defining_Entity (Orig_Bod)); |
70482933 | 3685 | |
fbf5a39b | 3686 | Bod := Copy_Generic_Node (Orig_Bod, Empty, Instantiating => True); |
70482933 RK |
3687 | Blk := |
3688 | Make_Block_Statement (Loc, | |
3689 | Declarations => Declarations (Bod), | |
3690 | Handled_Statement_Sequence => Handled_Statement_Sequence (Bod)); | |
3691 | ||
3692 | if No (Declarations (Bod)) then | |
3693 | Set_Declarations (Blk, New_List); | |
3694 | end if; | |
3695 | ||
c8ef728f | 3696 | -- For the unconstrained case, capture the name of the local |
02822a92 RD |
3697 | -- variable that holds the result. This must be the first declaration |
3698 | -- in the block, because its bounds cannot depend on local variables. | |
3699 | -- Otherwise there is no way to declare the result outside of the | |
3700 | -- block. Needless to say, in general the bounds will depend on the | |
3701 | -- actuals in the call. | |
c8ef728f ES |
3702 | |
3703 | if Is_Unc then | |
02822a92 | 3704 | Targ1 := Defining_Identifier (First (Declarations (Blk))); |
c8ef728f ES |
3705 | end if; |
3706 | ||
98f01d53 | 3707 | -- If this is a derived function, establish the proper return type |
70482933 RK |
3708 | |
3709 | if Present (Orig_Subp) | |
3710 | and then Orig_Subp /= Subp | |
3711 | then | |
3712 | Ret_Type := Etype (Orig_Subp); | |
3713 | else | |
3714 | Ret_Type := Etype (Subp); | |
3715 | end if; | |
3716 | ||
70482933 RK |
3717 | -- Create temporaries for the actuals that are expressions, or that |
3718 | -- are scalars and require copying to preserve semantics. | |
3719 | ||
2f1b20a9 ES |
3720 | F := First_Formal (Subp); |
3721 | A := First_Actual (N); | |
70482933 | 3722 | while Present (F) loop |
70482933 | 3723 | if Present (Renamed_Object (F)) then |
2f1b20a9 | 3724 | Error_Msg_N ("cannot inline call to recursive subprogram", N); |
70482933 RK |
3725 | return; |
3726 | end if; | |
3727 | ||
3728 | -- If the argument may be a controlling argument in a call within | |
f44fe430 RD |
3729 | -- the inlined body, we must preserve its classwide nature to insure |
3730 | -- that dynamic dispatching take place subsequently. If the formal | |
3731 | -- has a constraint it must be preserved to retain the semantics of | |
3732 | -- the body. | |
70482933 RK |
3733 | |
3734 | if Is_Class_Wide_Type (Etype (F)) | |
3735 | or else (Is_Access_Type (Etype (F)) | |
3736 | and then | |
3737 | Is_Class_Wide_Type (Designated_Type (Etype (F)))) | |
3738 | then | |
3739 | Temp_Typ := Etype (F); | |
3740 | ||
3741 | elsif Base_Type (Etype (F)) = Base_Type (Etype (A)) | |
3742 | and then Etype (F) /= Base_Type (Etype (F)) | |
3743 | then | |
3744 | Temp_Typ := Etype (F); | |
3745 | ||
3746 | else | |
3747 | Temp_Typ := Etype (A); | |
3748 | end if; | |
3749 | ||
5b4994bc AC |
3750 | -- If the actual is a simple name or a literal, no need to |
3751 | -- create a temporary, object can be used directly. | |
70482933 | 3752 | |
7888a6ae GD |
3753 | -- If the actual is a literal and the formal has its address taken, |
3754 | -- we cannot pass the literal itself as an argument, so its value | |
3755 | -- must be captured in a temporary. | |
3756 | ||
fbf5a39b AC |
3757 | if (Is_Entity_Name (A) |
3758 | and then | |
3759 | (not Is_Scalar_Type (Etype (A)) | |
3760 | or else Ekind (Entity (A)) = E_Enumeration_Literal)) | |
3761 | ||
5453d5bd AC |
3762 | -- When the actual is an identifier and the corresponding formal |
3763 | -- is used only once in the original body, the formal can be | |
3764 | -- substituted directly with the actual parameter. | |
3765 | ||
3766 | or else (Nkind (A) = N_Identifier | |
3767 | and then Formal_Is_Used_Once (F)) | |
3768 | ||
7888a6ae | 3769 | or else |
ac4d6407 RD |
3770 | (Nkind_In (A, N_Real_Literal, |
3771 | N_Integer_Literal, | |
3772 | N_Character_Literal) | |
3773 | and then not Address_Taken (F)) | |
70482933 | 3774 | then |
fbf5a39b AC |
3775 | if Etype (F) /= Etype (A) then |
3776 | Set_Renamed_Object | |
3777 | (F, Unchecked_Convert_To (Etype (F), Relocate_Node (A))); | |
3778 | else | |
3779 | Set_Renamed_Object (F, A); | |
3780 | end if; | |
3781 | ||
3782 | else | |
70482933 RK |
3783 | Temp := |
3784 | Make_Defining_Identifier (Loc, | |
3785 | Chars => New_Internal_Name ('C')); | |
3786 | ||
3787 | -- If the actual for an in/in-out parameter is a view conversion, | |
3788 | -- make it into an unchecked conversion, given that an untagged | |
3789 | -- type conversion is not a proper object for a renaming. | |
fbf5a39b | 3790 | |
70482933 RK |
3791 | -- In-out conversions that involve real conversions have already |
3792 | -- been transformed in Expand_Actuals. | |
3793 | ||
3794 | if Nkind (A) = N_Type_Conversion | |
fbf5a39b | 3795 | and then Ekind (F) /= E_In_Parameter |
70482933 | 3796 | then |
02822a92 RD |
3797 | New_A := |
3798 | Make_Unchecked_Type_Conversion (Loc, | |
3799 | Subtype_Mark => New_Occurrence_Of (Etype (F), Loc), | |
3800 | Expression => Relocate_Node (Expression (A))); | |
70482933 RK |
3801 | |
3802 | elsif Etype (F) /= Etype (A) then | |
3803 | New_A := Unchecked_Convert_To (Etype (F), Relocate_Node (A)); | |
3804 | Temp_Typ := Etype (F); | |
3805 | ||
3806 | else | |
3807 | New_A := Relocate_Node (A); | |
3808 | end if; | |
3809 | ||
3810 | Set_Sloc (New_A, Sloc (N)); | |
3811 | ||
02822a92 RD |
3812 | -- If the actual has a by-reference type, it cannot be copied, so |
3813 | -- its value is captured in a renaming declaration. Otherwise | |
7888a6ae | 3814 | -- declare a local constant initialized with the actual. |
02822a92 | 3815 | |
4a3b249c RD |
3816 | -- We also use a renaming declaration for expressions of an array |
3817 | -- type that is not bit-packed, both for efficiency reasons and to | |
3818 | -- respect the semantics of the call: in most cases the original | |
3819 | -- call will pass the parameter by reference, and thus the inlined | |
3820 | -- code will have the same semantics. | |
bafc9e1d | 3821 | |
70482933 RK |
3822 | if Ekind (F) = E_In_Parameter |
3823 | and then not Is_Limited_Type (Etype (A)) | |
02822a92 | 3824 | and then not Is_Tagged_Type (Etype (A)) |
bafc9e1d AC |
3825 | and then |
3826 | (not Is_Array_Type (Etype (A)) | |
f66d46ec | 3827 | or else not Is_Object_Reference (A) |
bafc9e1d | 3828 | or else Is_Bit_Packed_Array (Etype (A))) |
70482933 RK |
3829 | then |
3830 | Decl := | |
3831 | Make_Object_Declaration (Loc, | |
3832 | Defining_Identifier => Temp, | |
3833 | Constant_Present => True, | |
3834 | Object_Definition => New_Occurrence_Of (Temp_Typ, Loc), | |
3835 | Expression => New_A); | |
3836 | else | |
3837 | Decl := | |
3838 | Make_Object_Renaming_Declaration (Loc, | |
3839 | Defining_Identifier => Temp, | |
3840 | Subtype_Mark => New_Occurrence_Of (Temp_Typ, Loc), | |
3841 | Name => New_A); | |
3842 | end if; | |
3843 | ||
c8ef728f | 3844 | Append (Decl, Decls); |
70482933 | 3845 | Set_Renamed_Object (F, Temp); |
70482933 RK |
3846 | end if; |
3847 | ||
3848 | Next_Formal (F); | |
3849 | Next_Actual (A); | |
3850 | end loop; | |
3851 | ||
3852 | -- Establish target of function call. If context is not assignment or | |
3853 | -- declaration, create a temporary as a target. The declaration for | |
3854 | -- the temporary may be subsequently optimized away if the body is a | |
3855 | -- single expression, or if the left-hand side of the assignment is | |
c8ef728f | 3856 | -- simple enough, i.e. an entity or an explicit dereference of one. |
70482933 RK |
3857 | |
3858 | if Ekind (Subp) = E_Function then | |
3859 | if Nkind (Parent (N)) = N_Assignment_Statement | |
3860 | and then Is_Entity_Name (Name (Parent (N))) | |
3861 | then | |
3862 | Targ := Name (Parent (N)); | |
3863 | ||
c8ef728f ES |
3864 | elsif Nkind (Parent (N)) = N_Assignment_Statement |
3865 | and then Nkind (Name (Parent (N))) = N_Explicit_Dereference | |
3866 | and then Is_Entity_Name (Prefix (Name (Parent (N)))) | |
3867 | then | |
3868 | Targ := Name (Parent (N)); | |
3869 | ||
70482933 | 3870 | else |
98f01d53 | 3871 | -- Replace call with temporary and create its declaration |
70482933 RK |
3872 | |
3873 | Temp := | |
3874 | Make_Defining_Identifier (Loc, New_Internal_Name ('C')); | |
758c442c | 3875 | Set_Is_Internal (Temp); |
70482933 | 3876 | |
30783513 | 3877 | -- For the unconstrained case, the generated temporary has the |
4a3b249c RD |
3878 | -- same constrained declaration as the result variable. It may |
3879 | -- eventually be possible to remove that temporary and use the | |
3880 | -- result variable directly. | |
c8ef728f ES |
3881 | |
3882 | if Is_Unc then | |
3883 | Decl := | |
3884 | Make_Object_Declaration (Loc, | |
3885 | Defining_Identifier => Temp, | |
3886 | Object_Definition => | |
3887 | New_Copy_Tree (Object_Definition (Parent (Targ1)))); | |
3888 | ||
3889 | Replace_Formals (Decl); | |
3890 | ||
3891 | else | |
3892 | Decl := | |
3893 | Make_Object_Declaration (Loc, | |
3894 | Defining_Identifier => Temp, | |
3895 | Object_Definition => | |
3896 | New_Occurrence_Of (Ret_Type, Loc)); | |
3897 | ||
3898 | Set_Etype (Temp, Ret_Type); | |
3899 | end if; | |
70482933 RK |
3900 | |
3901 | Set_No_Initialization (Decl); | |
c8ef728f | 3902 | Append (Decl, Decls); |
70482933 RK |
3903 | Rewrite (N, New_Occurrence_Of (Temp, Loc)); |
3904 | Targ := Temp; | |
3905 | end if; | |
3906 | end if; | |
3907 | ||
c8ef728f ES |
3908 | Insert_Actions (N, Decls); |
3909 | ||
98f01d53 | 3910 | -- Traverse the tree and replace formals with actuals or their thunks. |
70482933 RK |
3911 | -- Attach block to tree before analysis and rewriting. |
3912 | ||
3913 | Replace_Formals (Blk); | |
3914 | Set_Parent (Blk, N); | |
3915 | ||
fbf5a39b AC |
3916 | if not Comes_From_Source (Subp) |
3917 | or else Is_Predef | |
3918 | then | |
3919 | Reset_Slocs (Blk); | |
3920 | end if; | |
3921 | ||
70482933 RK |
3922 | if Present (Exit_Lab) then |
3923 | ||
3924 | -- If the body was a single expression, the single return statement | |
3925 | -- and the corresponding label are useless. | |
3926 | ||
3927 | if Num_Ret = 1 | |
3928 | and then | |
3929 | Nkind (Last (Statements (Handled_Statement_Sequence (Blk)))) = | |
3930 | N_Goto_Statement | |
3931 | then | |
3932 | Remove (Last (Statements (Handled_Statement_Sequence (Blk)))); | |
3933 | else | |
3934 | Append (Lab_Decl, (Declarations (Blk))); | |
3935 | Append (Exit_Lab, Statements (Handled_Statement_Sequence (Blk))); | |
3936 | end if; | |
3937 | end if; | |
3938 | ||
3939 | -- Analyze Blk with In_Inlined_Body set, to avoid spurious errors on | |
4a3b249c | 3940 | -- conflicting private views that Gigi would ignore. If this is a |
fbf5a39b AC |
3941 | -- predefined unit, analyze with checks off, as is done in the non- |
3942 | -- inlined run-time units. | |
70482933 RK |
3943 | |
3944 | declare | |
3945 | I_Flag : constant Boolean := In_Inlined_Body; | |
3946 | ||
3947 | begin | |
3948 | In_Inlined_Body := True; | |
fbf5a39b AC |
3949 | |
3950 | if Is_Predef then | |
3951 | declare | |
3952 | Style : constant Boolean := Style_Check; | |
3953 | begin | |
3954 | Style_Check := False; | |
3955 | Analyze (Blk, Suppress => All_Checks); | |
3956 | Style_Check := Style; | |
3957 | end; | |
3958 | ||
3959 | else | |
3960 | Analyze (Blk); | |
3961 | end if; | |
3962 | ||
70482933 RK |
3963 | In_Inlined_Body := I_Flag; |
3964 | end; | |
3965 | ||
3966 | if Ekind (Subp) = E_Procedure then | |
3967 | Rewrite_Procedure_Call (N, Blk); | |
3968 | else | |
3969 | Rewrite_Function_Call (N, Blk); | |
c8ef728f ES |
3970 | |
3971 | -- For the unconstrained case, the replacement of the call has been | |
3972 | -- made prior to the complete analysis of the generated declarations. | |
3973 | -- Propagate the proper type now. | |
3974 | ||
3975 | if Is_Unc then | |
3976 | if Nkind (N) = N_Identifier then | |
3977 | Set_Etype (N, Etype (Entity (N))); | |
3978 | else | |
3979 | Set_Etype (N, Etype (Targ1)); | |
3980 | end if; | |
3981 | end if; | |
70482933 RK |
3982 | end if; |
3983 | ||
3984 | Restore_Env; | |
3985 | ||
98f01d53 | 3986 | -- Cleanup mapping between formals and actuals for other expansions |
70482933 RK |
3987 | |
3988 | F := First_Formal (Subp); | |
70482933 RK |
3989 | while Present (F) loop |
3990 | Set_Renamed_Object (F, Empty); | |
3991 | Next_Formal (F); | |
3992 | end loop; | |
3993 | end Expand_Inlined_Call; | |
3994 | ||
3995 | ---------------------------- | |
3996 | -- Expand_N_Function_Call -- | |
3997 | ---------------------------- | |
3998 | ||
3999 | procedure Expand_N_Function_Call (N : Node_Id) is | |
70482933 | 4000 | begin |
ac4d6407 | 4001 | Expand_Call (N); |
c986420e | 4002 | |
4a3b249c RD |
4003 | -- If the return value of a foreign compiled function is VAX Float, then |
4004 | -- expand the return (adjusts the location of the return value on | |
4005 | -- Alpha/VMS, no-op everywhere else). | |
612c5336 | 4006 | -- Comes_From_Source intercepts recursive expansion. |
2acde248 | 4007 | |
c986420e DR |
4008 | if Vax_Float (Etype (N)) |
4009 | and then Nkind (N) = N_Function_Call | |
c986420e DR |
4010 | and then Present (Name (N)) |
4011 | and then Present (Entity (Name (N))) | |
4012 | and then Has_Foreign_Convention (Entity (Name (N))) | |
612c5336 | 4013 | and then Comes_From_Source (Parent (N)) |
c986420e DR |
4014 | then |
4015 | Expand_Vax_Foreign_Return (N); | |
4016 | end if; | |
70482933 RK |
4017 | end Expand_N_Function_Call; |
4018 | ||
4019 | --------------------------------------- | |
4020 | -- Expand_N_Procedure_Call_Statement -- | |
4021 | --------------------------------------- | |
4022 | ||
4023 | procedure Expand_N_Procedure_Call_Statement (N : Node_Id) is | |
4024 | begin | |
4025 | Expand_Call (N); | |
4026 | end Expand_N_Procedure_Call_Statement; | |
4027 | ||
4028 | ------------------------------ | |
4029 | -- Expand_N_Subprogram_Body -- | |
4030 | ------------------------------ | |
4031 | ||
4a3b249c RD |
4032 | -- Add poll call if ATC polling is enabled, unless the body will be inlined |
4033 | -- by the back-end. | |
70482933 | 4034 | |
7888a6ae | 4035 | -- Add dummy push/pop label nodes at start and end to clear any local |
4a3b249c | 4036 | -- exception indications if local-exception-to-goto optimization is active. |
7888a6ae | 4037 | |
f44fe430 RD |
4038 | -- Add return statement if last statement in body is not a return statement |
4039 | -- (this makes things easier on Gigi which does not want to have to handle | |
4040 | -- a missing return). | |
70482933 RK |
4041 | |
4042 | -- Add call to Activate_Tasks if body is a task activator | |
4043 | ||
4044 | -- Deal with possible detection of infinite recursion | |
4045 | ||
4046 | -- Eliminate body completely if convention stubbed | |
4047 | ||
4048 | -- Encode entity names within body, since we will not need to reference | |
4049 | -- these entities any longer in the front end. | |
4050 | ||
4051 | -- Initialize scalar out parameters if Initialize/Normalize_Scalars | |
4052 | ||
c9a4817d RD |
4053 | -- Reset Pure indication if any parameter has root type System.Address |
4054 | ||
12e0c41c AC |
4055 | -- Wrap thread body |
4056 | ||
70482933 RK |
4057 | procedure Expand_N_Subprogram_Body (N : Node_Id) is |
4058 | Loc : constant Source_Ptr := Sloc (N); | |
4059 | H : constant Node_Id := Handled_Statement_Sequence (N); | |
c9a4817d | 4060 | Body_Id : Entity_Id; |
70482933 | 4061 | Except_H : Node_Id; |
70482933 | 4062 | L : List_Id; |
70f91180 | 4063 | Spec_Id : Entity_Id; |
70482933 RK |
4064 | |
4065 | procedure Add_Return (S : List_Id); | |
4066 | -- Append a return statement to the statement sequence S if the last | |
4067 | -- statement is not already a return or a goto statement. Note that | |
4a3b249c RD |
4068 | -- the latter test is not critical, it does not matter if we add a few |
4069 | -- extra returns, since they get eliminated anyway later on. | |
70482933 RK |
4070 | |
4071 | ---------------- | |
4072 | -- Add_Return -- | |
4073 | ---------------- | |
4074 | ||
4075 | procedure Add_Return (S : List_Id) is | |
7888a6ae GD |
4076 | Last_Stm : Node_Id; |
4077 | Loc : Source_Ptr; | |
12e0c41c AC |
4078 | |
4079 | begin | |
7888a6ae GD |
4080 | -- Get last statement, ignoring any Pop_xxx_Label nodes, which are |
4081 | -- not relevant in this context since they are not executable. | |
12e0c41c | 4082 | |
7888a6ae GD |
4083 | Last_Stm := Last (S); |
4084 | while Nkind (Last_Stm) in N_Pop_xxx_Label loop | |
4085 | Prev (Last_Stm); | |
4086 | end loop; | |
12e0c41c | 4087 | |
7888a6ae | 4088 | -- Now insert return unless last statement is a transfer |
12e0c41c | 4089 | |
7888a6ae | 4090 | if not Is_Transfer (Last_Stm) then |
12e0c41c | 4091 | |
7888a6ae GD |
4092 | -- The source location for the return is the end label of the |
4093 | -- procedure if present. Otherwise use the sloc of the last | |
4094 | -- statement in the list. If the list comes from a generated | |
4095 | -- exception handler and we are not debugging generated code, | |
4096 | -- all the statements within the handler are made invisible | |
4097 | -- to the debugger. | |
12e0c41c | 4098 | |
7888a6ae GD |
4099 | if Nkind (Parent (S)) = N_Exception_Handler |
4100 | and then not Comes_From_Source (Parent (S)) | |
4101 | then | |
4102 | Loc := Sloc (Last_Stm); | |
12e0c41c | 4103 | |
7888a6ae GD |
4104 | elsif Present (End_Label (H)) then |
4105 | Loc := Sloc (End_Label (H)); | |
12e0c41c | 4106 | |
7888a6ae GD |
4107 | else |
4108 | Loc := Sloc (Last_Stm); | |
4109 | end if; | |
12e0c41c | 4110 | |
5334d18f BD |
4111 | declare |
4112 | Rtn : constant Node_Id := Make_Simple_Return_Statement (Loc); | |
4113 | ||
4114 | begin | |
4a3b249c RD |
4115 | -- Append return statement, and set analyzed manually. We can't |
4116 | -- call Analyze on this return since the scope is wrong. | |
5334d18f BD |
4117 | |
4118 | -- Note: it almost works to push the scope and then do the | |
4a3b249c | 4119 | -- Analyze call, but something goes wrong in some weird cases |
5334d18f BD |
4120 | -- and it is not worth worrying about ??? |
4121 | ||
4122 | Append_To (S, Rtn); | |
4123 | Set_Analyzed (Rtn); | |
4124 | ||
4125 | -- Call _Postconditions procedure if appropriate. We need to | |
4126 | -- do this explicitly because we did not analyze the generated | |
4127 | -- return statement above, so the call did not get inserted. | |
4128 | ||
4129 | if Ekind (Spec_Id) = E_Procedure | |
4130 | and then Has_Postconditions (Spec_Id) | |
4131 | then | |
4132 | pragma Assert (Present (Postcondition_Proc (Spec_Id))); | |
4133 | Insert_Action (Rtn, | |
4134 | Make_Procedure_Call_Statement (Loc, | |
4135 | Name => | |
4136 | New_Reference_To (Postcondition_Proc (Spec_Id), Loc))); | |
4137 | end if; | |
4138 | end; | |
12e0c41c | 4139 | end if; |
7888a6ae | 4140 | end Add_Return; |
12e0c41c | 4141 | |
70482933 RK |
4142 | -- Start of processing for Expand_N_Subprogram_Body |
4143 | ||
4144 | begin | |
4a3b249c RD |
4145 | -- Set L to either the list of declarations if present, or to the list |
4146 | -- of statements if no declarations are present. This is used to insert | |
4147 | -- new stuff at the start. | |
70482933 RK |
4148 | |
4149 | if Is_Non_Empty_List (Declarations (N)) then | |
4150 | L := Declarations (N); | |
4151 | else | |
7888a6ae GD |
4152 | L := Statements (H); |
4153 | end if; | |
4154 | ||
4155 | -- If local-exception-to-goto optimization active, insert dummy push | |
4156 | -- statements at start, and dummy pop statements at end. | |
4157 | ||
4158 | if (Debug_Flag_Dot_G | |
4159 | or else Restriction_Active (No_Exception_Propagation)) | |
4160 | and then Is_Non_Empty_List (L) | |
4161 | then | |
4162 | declare | |
4163 | FS : constant Node_Id := First (L); | |
4164 | FL : constant Source_Ptr := Sloc (FS); | |
4165 | LS : Node_Id; | |
4166 | LL : Source_Ptr; | |
4167 | ||
4168 | begin | |
4169 | -- LS points to either last statement, if statements are present | |
4170 | -- or to the last declaration if there are no statements present. | |
4171 | -- It is the node after which the pop's are generated. | |
4172 | ||
4173 | if Is_Non_Empty_List (Statements (H)) then | |
4174 | LS := Last (Statements (H)); | |
4175 | else | |
4176 | LS := Last (L); | |
4177 | end if; | |
4178 | ||
4179 | LL := Sloc (LS); | |
4180 | ||
4181 | Insert_List_Before_And_Analyze (FS, New_List ( | |
4182 | Make_Push_Constraint_Error_Label (FL), | |
4183 | Make_Push_Program_Error_Label (FL), | |
4184 | Make_Push_Storage_Error_Label (FL))); | |
4185 | ||
4186 | Insert_List_After_And_Analyze (LS, New_List ( | |
4187 | Make_Pop_Constraint_Error_Label (LL), | |
4188 | Make_Pop_Program_Error_Label (LL), | |
4189 | Make_Pop_Storage_Error_Label (LL))); | |
4190 | end; | |
70482933 RK |
4191 | end if; |
4192 | ||
70482933 RK |
4193 | -- Find entity for subprogram |
4194 | ||
c9a4817d RD |
4195 | Body_Id := Defining_Entity (N); |
4196 | ||
70482933 RK |
4197 | if Present (Corresponding_Spec (N)) then |
4198 | Spec_Id := Corresponding_Spec (N); | |
4199 | else | |
c9a4817d RD |
4200 | Spec_Id := Body_Id; |
4201 | end if; | |
4202 | ||
7888a6ae GD |
4203 | -- Need poll on entry to subprogram if polling enabled. We only do this |
4204 | -- for non-empty subprograms, since it does not seem necessary to poll | |
4a3b249c | 4205 | -- for a dummy null subprogram. |
c885d7a1 AC |
4206 | |
4207 | if Is_Non_Empty_List (L) then | |
4a3b249c RD |
4208 | |
4209 | -- Do not add a polling call if the subprogram is to be inlined by | |
4210 | -- the back-end, to avoid repeated calls with multiple inlinings. | |
4211 | ||
c885d7a1 AC |
4212 | if Is_Inlined (Spec_Id) |
4213 | and then Front_End_Inlining | |
4214 | and then Optimization_Level > 1 | |
4215 | then | |
4216 | null; | |
4217 | else | |
4218 | Generate_Poll_Call (First (L)); | |
4219 | end if; | |
4220 | end if; | |
4221 | ||
4a3b249c RD |
4222 | -- If this is a Pure function which has any parameters whose root type |
4223 | -- is System.Address, reset the Pure indication, since it will likely | |
4224 | -- cause incorrect code to be generated as the parameter is probably | |
4225 | -- a pointer, and the fact that the same pointer is passed does not mean | |
4226 | -- that the same value is being referenced. | |
91b1417d AC |
4227 | |
4228 | -- Note that if the programmer gave an explicit Pure_Function pragma, | |
4229 | -- then we believe the programmer, and leave the subprogram Pure. | |
4230 | ||
4a3b249c RD |
4231 | -- This code should probably be at the freeze point, so that it happens |
4232 | -- even on a -gnatc (or more importantly -gnatt) compile, so that the | |
4233 | -- semantic tree has Is_Pure set properly ??? | |
c9a4817d RD |
4234 | |
4235 | if Is_Pure (Spec_Id) | |
4236 | and then Is_Subprogram (Spec_Id) | |
4237 | and then not Has_Pragma_Pure_Function (Spec_Id) | |
4238 | then | |
4239 | declare | |
2f1b20a9 | 4240 | F : Entity_Id; |
c9a4817d RD |
4241 | |
4242 | begin | |
2f1b20a9 | 4243 | F := First_Formal (Spec_Id); |
c9a4817d | 4244 | while Present (F) loop |
8a36a0cc | 4245 | if Is_Descendent_Of_Address (Etype (F)) then |
c9a4817d RD |
4246 | Set_Is_Pure (Spec_Id, False); |
4247 | ||
4248 | if Spec_Id /= Body_Id then | |
4249 | Set_Is_Pure (Body_Id, False); | |
4250 | end if; | |
4251 | ||
4252 | exit; | |
4253 | end if; | |
4254 | ||
4255 | Next_Formal (F); | |
4256 | end loop; | |
4257 | end; | |
70482933 RK |
4258 | end if; |
4259 | ||
4260 | -- Initialize any scalar OUT args if Initialize/Normalize_Scalars | |
4261 | ||
4262 | if Init_Or_Norm_Scalars and then Is_Subprogram (Spec_Id) then | |
4263 | declare | |
2f1b20a9 | 4264 | F : Entity_Id; |
70482933 RK |
4265 | |
4266 | begin | |
70482933 RK |
4267 | -- Loop through formals |
4268 | ||
2f1b20a9 | 4269 | F := First_Formal (Spec_Id); |
70482933 RK |
4270 | while Present (F) loop |
4271 | if Is_Scalar_Type (Etype (F)) | |
4272 | and then Ekind (F) = E_Out_Parameter | |
4273 | then | |
70f91180 RD |
4274 | Check_Restriction (No_Default_Initialization, F); |
4275 | ||
02822a92 RD |
4276 | -- Insert the initialization. We turn off validity checks |
4277 | -- for this assignment, since we do not want any check on | |
4278 | -- the initial value itself (which may well be invalid). | |
4279 | ||
70482933 RK |
4280 | Insert_Before_And_Analyze (First (L), |
4281 | Make_Assignment_Statement (Loc, | |
02822a92 | 4282 | Name => New_Occurrence_Of (F, Loc), |
70f91180 | 4283 | Expression => Get_Simple_Init_Val (Etype (F), N)), |
02822a92 | 4284 | Suppress => Validity_Check); |
70482933 RK |
4285 | end if; |
4286 | ||
4287 | Next_Formal (F); | |
4288 | end loop; | |
70482933 RK |
4289 | end; |
4290 | end if; | |
4291 | ||
4292 | -- Clear out statement list for stubbed procedure | |
4293 | ||
4294 | if Present (Corresponding_Spec (N)) then | |
4295 | Set_Elaboration_Flag (N, Spec_Id); | |
4296 | ||
4297 | if Convention (Spec_Id) = Convention_Stubbed | |
4298 | or else Is_Eliminated (Spec_Id) | |
4299 | then | |
4300 | Set_Declarations (N, Empty_List); | |
4301 | Set_Handled_Statement_Sequence (N, | |
4302 | Make_Handled_Sequence_Of_Statements (Loc, | |
4303 | Statements => New_List ( | |
4304 | Make_Null_Statement (Loc)))); | |
4305 | return; | |
4306 | end if; | |
4307 | end if; | |
4308 | ||
70f91180 RD |
4309 | -- Create a set of discriminals for the next protected subprogram body |
4310 | ||
4311 | if Is_List_Member (N) | |
4312 | and then Present (Parent (List_Containing (N))) | |
4313 | and then Nkind (Parent (List_Containing (N))) = N_Protected_Body | |
4314 | and then Present (Next_Protected_Operation (N)) | |
4315 | then | |
4316 | Set_Discriminals (Parent (Base_Type (Scope (Spec_Id)))); | |
4317 | end if; | |
4318 | ||
4a3b249c RD |
4319 | -- Returns_By_Ref flag is normally set when the subprogram is frozen but |
4320 | -- subprograms with no specs are not frozen. | |
70482933 RK |
4321 | |
4322 | declare | |
4323 | Typ : constant Entity_Id := Etype (Spec_Id); | |
4324 | Utyp : constant Entity_Id := Underlying_Type (Typ); | |
4325 | ||
4326 | begin | |
4327 | if not Acts_As_Spec (N) | |
4328 | and then Nkind (Parent (Parent (Spec_Id))) /= | |
4329 | N_Subprogram_Body_Stub | |
4330 | then | |
4331 | null; | |
4332 | ||
02822a92 | 4333 | elsif Is_Inherently_Limited_Type (Typ) then |
70482933 RK |
4334 | Set_Returns_By_Ref (Spec_Id); |
4335 | ||
048e5cef | 4336 | elsif Present (Utyp) and then CW_Or_Has_Controlled_Part (Utyp) then |
70482933 RK |
4337 | Set_Returns_By_Ref (Spec_Id); |
4338 | end if; | |
4339 | end; | |
4340 | ||
4a3b249c RD |
4341 | -- For a procedure, we add a return for all possible syntactic ends of |
4342 | -- the subprogram. | |
70482933 RK |
4343 | |
4344 | if Ekind (Spec_Id) = E_Procedure | |
4345 | or else Ekind (Spec_Id) = E_Generic_Procedure | |
4346 | then | |
4347 | Add_Return (Statements (H)); | |
4348 | ||
4349 | if Present (Exception_Handlers (H)) then | |
4350 | Except_H := First_Non_Pragma (Exception_Handlers (H)); | |
70482933 RK |
4351 | while Present (Except_H) loop |
4352 | Add_Return (Statements (Except_H)); | |
4353 | Next_Non_Pragma (Except_H); | |
4354 | end loop; | |
4355 | end if; | |
4356 | ||
98f01d53 AC |
4357 | -- For a function, we must deal with the case where there is at least |
4358 | -- one missing return. What we do is to wrap the entire body of the | |
4359 | -- function in a block: | |
70482933 RK |
4360 | |
4361 | -- begin | |
4362 | -- ... | |
4363 | -- end; | |
4364 | ||
4365 | -- becomes | |
4366 | ||
4367 | -- begin | |
4368 | -- begin | |
4369 | -- ... | |
4370 | -- end; | |
4371 | ||
4372 | -- raise Program_Error; | |
4373 | -- end; | |
4374 | ||
4a3b249c RD |
4375 | -- This approach is necessary because the raise must be signalled to the |
4376 | -- caller, not handled by any local handler (RM 6.4(11)). | |
70482933 | 4377 | |
4a3b249c RD |
4378 | -- Note: we do not need to analyze the constructed sequence here, since |
4379 | -- it has no handler, and an attempt to analyze the handled statement | |
4380 | -- sequence twice is risky in various ways (e.g. the issue of expanding | |
4381 | -- cleanup actions twice). | |
70482933 RK |
4382 | |
4383 | elsif Has_Missing_Return (Spec_Id) then | |
4384 | declare | |
4385 | Hloc : constant Source_Ptr := Sloc (H); | |
4386 | Blok : constant Node_Id := | |
4387 | Make_Block_Statement (Hloc, | |
4388 | Handled_Statement_Sequence => H); | |
4389 | Rais : constant Node_Id := | |
07fc65c4 GB |
4390 | Make_Raise_Program_Error (Hloc, |
4391 | Reason => PE_Missing_Return); | |
70482933 RK |
4392 | |
4393 | begin | |
4394 | Set_Handled_Statement_Sequence (N, | |
4395 | Make_Handled_Sequence_Of_Statements (Hloc, | |
4396 | Statements => New_List (Blok, Rais))); | |
4397 | ||
7888a6ae | 4398 | Push_Scope (Spec_Id); |
70482933 RK |
4399 | Analyze (Blok); |
4400 | Analyze (Rais); | |
4401 | Pop_Scope; | |
4402 | end; | |
4403 | end if; | |
4404 | ||
70482933 RK |
4405 | -- If subprogram contains a parameterless recursive call, then we may |
4406 | -- have an infinite recursion, so see if we can generate code to check | |
4407 | -- for this possibility if storage checks are not suppressed. | |
4408 | ||
4409 | if Ekind (Spec_Id) = E_Procedure | |
4410 | and then Has_Recursive_Call (Spec_Id) | |
4411 | and then not Storage_Checks_Suppressed (Spec_Id) | |
4412 | then | |
4413 | Detect_Infinite_Recursion (N, Spec_Id); | |
4414 | end if; | |
4415 | ||
70482933 RK |
4416 | -- Set to encode entity names in package body before gigi is called |
4417 | ||
4418 | Qualify_Entity_Names (N); | |
4419 | end Expand_N_Subprogram_Body; | |
4420 | ||
4421 | ----------------------------------- | |
4422 | -- Expand_N_Subprogram_Body_Stub -- | |
4423 | ----------------------------------- | |
4424 | ||
4425 | procedure Expand_N_Subprogram_Body_Stub (N : Node_Id) is | |
4426 | begin | |
4427 | if Present (Corresponding_Body (N)) then | |
4428 | Expand_N_Subprogram_Body ( | |
4429 | Unit_Declaration_Node (Corresponding_Body (N))); | |
4430 | end if; | |
70482933 RK |
4431 | end Expand_N_Subprogram_Body_Stub; |
4432 | ||
4433 | ------------------------------------- | |
4434 | -- Expand_N_Subprogram_Declaration -- | |
4435 | ------------------------------------- | |
4436 | ||
70482933 RK |
4437 | -- If the declaration appears within a protected body, it is a private |
4438 | -- operation of the protected type. We must create the corresponding | |
4439 | -- protected subprogram an associated formals. For a normal protected | |
4440 | -- operation, this is done when expanding the protected type declaration. | |
4441 | ||
758c442c GD |
4442 | -- If the declaration is for a null procedure, emit null body |
4443 | ||
70482933 | 4444 | procedure Expand_N_Subprogram_Declaration (N : Node_Id) is |
fbf5a39b AC |
4445 | Loc : constant Source_Ptr := Sloc (N); |
4446 | Subp : constant Entity_Id := Defining_Entity (N); | |
4447 | Scop : constant Entity_Id := Scope (Subp); | |
4448 | Prot_Decl : Node_Id; | |
4449 | Prot_Bod : Node_Id; | |
4450 | Prot_Id : Entity_Id; | |
70482933 RK |
4451 | |
4452 | begin | |
2f1b20a9 ES |
4453 | -- Deal with case of protected subprogram. Do not generate protected |
4454 | -- operation if operation is flagged as eliminated. | |
70482933 RK |
4455 | |
4456 | if Is_List_Member (N) | |
4457 | and then Present (Parent (List_Containing (N))) | |
4458 | and then Nkind (Parent (List_Containing (N))) = N_Protected_Body | |
4459 | and then Is_Protected_Type (Scop) | |
4460 | then | |
6871ba5f AC |
4461 | if No (Protected_Body_Subprogram (Subp)) |
4462 | and then not Is_Eliminated (Subp) | |
4463 | then | |
fbf5a39b | 4464 | Prot_Decl := |
70482933 RK |
4465 | Make_Subprogram_Declaration (Loc, |
4466 | Specification => | |
4467 | Build_Protected_Sub_Specification | |
2f1b20a9 | 4468 | (N, Scop, Unprotected_Mode)); |
70482933 RK |
4469 | |
4470 | -- The protected subprogram is declared outside of the protected | |
4471 | -- body. Given that the body has frozen all entities so far, we | |
fbf5a39b | 4472 | -- analyze the subprogram and perform freezing actions explicitly. |
19590d70 GD |
4473 | -- including the generation of an explicit freeze node, to ensure |
4474 | -- that gigi has the proper order of elaboration. | |
fbf5a39b AC |
4475 | -- If the body is a subunit, the insertion point is before the |
4476 | -- stub in the parent. | |
70482933 RK |
4477 | |
4478 | Prot_Bod := Parent (List_Containing (N)); | |
4479 | ||
4480 | if Nkind (Parent (Prot_Bod)) = N_Subunit then | |
4481 | Prot_Bod := Corresponding_Stub (Parent (Prot_Bod)); | |
4482 | end if; | |
4483 | ||
fbf5a39b AC |
4484 | Insert_Before (Prot_Bod, Prot_Decl); |
4485 | Prot_Id := Defining_Unit_Name (Specification (Prot_Decl)); | |
19590d70 | 4486 | Set_Has_Delayed_Freeze (Prot_Id); |
70482933 | 4487 | |
7888a6ae | 4488 | Push_Scope (Scope (Scop)); |
fbf5a39b | 4489 | Analyze (Prot_Decl); |
19590d70 | 4490 | Insert_Actions (N, Freeze_Entity (Prot_Id, Loc)); |
fbf5a39b | 4491 | Set_Protected_Body_Subprogram (Subp, Prot_Id); |
70482933 RK |
4492 | Pop_Scope; |
4493 | end if; | |
758c442c | 4494 | |
e1f3cb58 AC |
4495 | -- Ada 2005 (AI-348): Generate body for a null procedure. |
4496 | -- In most cases this is superfluous because calls to it | |
4497 | -- will be automatically inlined, but we definitely need | |
4498 | -- the body if preconditions for the procedure are present. | |
02822a92 | 4499 | |
758c442c GD |
4500 | elsif Nkind (Specification (N)) = N_Procedure_Specification |
4501 | and then Null_Present (Specification (N)) | |
4502 | then | |
4503 | declare | |
e1f3cb58 | 4504 | Bod : constant Node_Id := Body_To_Inline (N); |
d6533e74 | 4505 | |
758c442c | 4506 | begin |
e1f3cb58 AC |
4507 | Set_Has_Completion (Subp, False); |
4508 | Append_Freeze_Action (Subp, Bod); | |
c73ae90f | 4509 | |
e1f3cb58 AC |
4510 | -- The body now contains raise statements, so calls to it will |
4511 | -- not be inlined. | |
c73ae90f | 4512 | |
e1f3cb58 | 4513 | Set_Is_Inlined (Subp, False); |
758c442c | 4514 | end; |
70482933 RK |
4515 | end if; |
4516 | end Expand_N_Subprogram_Declaration; | |
4517 | ||
4518 | --------------------------------------- | |
4519 | -- Expand_Protected_Object_Reference -- | |
4520 | --------------------------------------- | |
4521 | ||
4522 | function Expand_Protected_Object_Reference | |
4523 | (N : Node_Id; | |
02822a92 | 4524 | Scop : Entity_Id) return Node_Id |
70482933 RK |
4525 | is |
4526 | Loc : constant Source_Ptr := Sloc (N); | |
4527 | Corr : Entity_Id; | |
4528 | Rec : Node_Id; | |
4529 | Param : Entity_Id; | |
4530 | Proc : Entity_Id; | |
4531 | ||
4532 | begin | |
02822a92 RD |
4533 | Rec := |
4534 | Make_Identifier (Loc, | |
4535 | Chars => Name_uObject); | |
70482933 RK |
4536 | Set_Etype (Rec, Corresponding_Record_Type (Scop)); |
4537 | ||
2f1b20a9 ES |
4538 | -- Find enclosing protected operation, and retrieve its first parameter, |
4539 | -- which denotes the enclosing protected object. If the enclosing | |
4540 | -- operation is an entry, we are immediately within the protected body, | |
4541 | -- and we can retrieve the object from the service entries procedure. A | |
16b05213 | 4542 | -- barrier function has the same signature as an entry. A barrier |
2f1b20a9 ES |
4543 | -- function is compiled within the protected object, but unlike |
4544 | -- protected operations its never needs locks, so that its protected | |
4545 | -- body subprogram points to itself. | |
70482933 RK |
4546 | |
4547 | Proc := Current_Scope; | |
70482933 RK |
4548 | while Present (Proc) |
4549 | and then Scope (Proc) /= Scop | |
4550 | loop | |
4551 | Proc := Scope (Proc); | |
4552 | end loop; | |
4553 | ||
4554 | Corr := Protected_Body_Subprogram (Proc); | |
4555 | ||
4556 | if No (Corr) then | |
4557 | ||
4558 | -- Previous error left expansion incomplete. | |
4559 | -- Nothing to do on this call. | |
4560 | ||
4561 | return Empty; | |
4562 | end if; | |
4563 | ||
4564 | Param := | |
4565 | Defining_Identifier | |
4566 | (First (Parameter_Specifications (Parent (Corr)))); | |
4567 | ||
4568 | if Is_Subprogram (Proc) | |
4569 | and then Proc /= Corr | |
4570 | then | |
98f01d53 | 4571 | -- Protected function or procedure |
70482933 RK |
4572 | |
4573 | Set_Entity (Rec, Param); | |
4574 | ||
2f1b20a9 ES |
4575 | -- Rec is a reference to an entity which will not be in scope when |
4576 | -- the call is reanalyzed, and needs no further analysis. | |
70482933 RK |
4577 | |
4578 | Set_Analyzed (Rec); | |
4579 | ||
4580 | else | |
2f1b20a9 ES |
4581 | -- Entry or barrier function for entry body. The first parameter of |
4582 | -- the entry body procedure is pointer to the object. We create a | |
4583 | -- local variable of the proper type, duplicating what is done to | |
4584 | -- define _object later on. | |
70482933 RK |
4585 | |
4586 | declare | |
4587 | Decls : List_Id; | |
fbf5a39b AC |
4588 | Obj_Ptr : constant Entity_Id := Make_Defining_Identifier (Loc, |
4589 | Chars => | |
4590 | New_Internal_Name ('T')); | |
4591 | ||
70482933 RK |
4592 | begin |
4593 | Decls := New_List ( | |
4594 | Make_Full_Type_Declaration (Loc, | |
4595 | Defining_Identifier => Obj_Ptr, | |
4596 | Type_Definition => | |
4597 | Make_Access_To_Object_Definition (Loc, | |
4598 | Subtype_Indication => | |
4599 | New_Reference_To | |
4600 | (Corresponding_Record_Type (Scop), Loc)))); | |
4601 | ||
4602 | Insert_Actions (N, Decls); | |
4603 | Insert_Actions (N, Freeze_Entity (Obj_Ptr, Sloc (N))); | |
4604 | ||
4605 | Rec := | |
4606 | Make_Explicit_Dereference (Loc, | |
4607 | Unchecked_Convert_To (Obj_Ptr, | |
4608 | New_Occurrence_Of (Param, Loc))); | |
4609 | ||
2f1b20a9 | 4610 | -- Analyze new actual. Other actuals in calls are already analyzed |
7888a6ae | 4611 | -- and the list of actuals is not reanalyzed after rewriting. |
70482933 RK |
4612 | |
4613 | Set_Parent (Rec, N); | |
4614 | Analyze (Rec); | |
4615 | end; | |
4616 | end if; | |
4617 | ||
4618 | return Rec; | |
4619 | end Expand_Protected_Object_Reference; | |
4620 | ||
4621 | -------------------------------------- | |
4622 | -- Expand_Protected_Subprogram_Call -- | |
4623 | -------------------------------------- | |
4624 | ||
4625 | procedure Expand_Protected_Subprogram_Call | |
4626 | (N : Node_Id; | |
4627 | Subp : Entity_Id; | |
4628 | Scop : Entity_Id) | |
4629 | is | |
4630 | Rec : Node_Id; | |
4631 | ||
4632 | begin | |
4633 | -- If the protected object is not an enclosing scope, this is | |
4634 | -- an inter-object function call. Inter-object procedure | |
4635 | -- calls are expanded by Exp_Ch9.Build_Simple_Entry_Call. | |
4636 | -- The call is intra-object only if the subprogram being | |
4637 | -- called is in the protected body being compiled, and if the | |
4638 | -- protected object in the call is statically the enclosing type. | |
4639 | -- The object may be an component of some other data structure, | |
4640 | -- in which case this must be handled as an inter-object call. | |
4641 | ||
4642 | if not In_Open_Scopes (Scop) | |
4643 | or else not Is_Entity_Name (Name (N)) | |
4644 | then | |
4645 | if Nkind (Name (N)) = N_Selected_Component then | |
4646 | Rec := Prefix (Name (N)); | |
4647 | ||
4648 | else | |
4649 | pragma Assert (Nkind (Name (N)) = N_Indexed_Component); | |
4650 | Rec := Prefix (Prefix (Name (N))); | |
4651 | end if; | |
4652 | ||
4653 | Build_Protected_Subprogram_Call (N, | |
4654 | Name => New_Occurrence_Of (Subp, Sloc (N)), | |
4655 | Rec => Convert_Concurrent (Rec, Etype (Rec)), | |
4656 | External => True); | |
4657 | ||
4658 | else | |
4659 | Rec := Expand_Protected_Object_Reference (N, Scop); | |
4660 | ||
4661 | if No (Rec) then | |
4662 | return; | |
4663 | end if; | |
4664 | ||
4665 | Build_Protected_Subprogram_Call (N, | |
4666 | Name => Name (N), | |
4667 | Rec => Rec, | |
4668 | External => False); | |
4669 | ||
4670 | end if; | |
4671 | ||
70482933 RK |
4672 | -- If it is a function call it can appear in elaboration code and |
4673 | -- the called entity must be frozen here. | |
4674 | ||
4675 | if Ekind (Subp) = E_Function then | |
4676 | Freeze_Expression (Name (N)); | |
4677 | end if; | |
811c6a85 AC |
4678 | |
4679 | -- Analyze and resolve the new call. The actuals have already been | |
b0159fbe | 4680 | -- resolved, but expansion of a function call will add extra actuals |
811c6a85 AC |
4681 | -- if needed. Analysis of a procedure call already includes resolution. |
4682 | ||
4683 | Analyze (N); | |
4684 | ||
4685 | if Ekind (Subp) = E_Function then | |
4686 | Resolve (N, Etype (Subp)); | |
4687 | end if; | |
70482933 RK |
4688 | end Expand_Protected_Subprogram_Call; |
4689 | ||
02822a92 RD |
4690 | -------------------------------- |
4691 | -- Is_Build_In_Place_Function -- | |
4692 | -------------------------------- | |
70482933 | 4693 | |
02822a92 RD |
4694 | function Is_Build_In_Place_Function (E : Entity_Id) return Boolean is |
4695 | begin | |
4696 | -- For now we test whether E denotes a function or access-to-function | |
f937473f RD |
4697 | -- type whose result subtype is inherently limited. Later this test may |
4698 | -- be revised to allow composite nonlimited types. Functions with a | |
4699 | -- foreign convention or whose result type has a foreign convention | |
02822a92 RD |
4700 | -- never qualify. |
4701 | ||
4702 | if Ekind (E) = E_Function | |
f937473f | 4703 | or else Ekind (E) = E_Generic_Function |
02822a92 RD |
4704 | or else (Ekind (E) = E_Subprogram_Type |
4705 | and then Etype (E) /= Standard_Void_Type) | |
4706 | then | |
f937473f RD |
4707 | -- Note: If you have Convention (C) on an inherently limited type, |
4708 | -- you're on your own. That is, the C code will have to be carefully | |
4709 | -- written to know about the Ada conventions. | |
4710 | ||
02822a92 RD |
4711 | if Has_Foreign_Convention (E) |
4712 | or else Has_Foreign_Convention (Etype (E)) | |
3ca505dc | 4713 | then |
02822a92 | 4714 | return False; |
c8ef728f | 4715 | |
2a31c32b AC |
4716 | -- In Ada 2005 all functions with an inherently limited return type |
4717 | -- must be handled using a build-in-place profile, including the case | |
4718 | -- of a function with a limited interface result, where the function | |
4719 | -- may return objects of nonlimited descendants. | |
7888a6ae | 4720 | |
02822a92 RD |
4721 | else |
4722 | return Is_Inherently_Limited_Type (Etype (E)) | |
f937473f RD |
4723 | and then Ada_Version >= Ada_05 |
4724 | and then not Debug_Flag_Dot_L; | |
c8ef728f ES |
4725 | end if; |
4726 | ||
02822a92 RD |
4727 | else |
4728 | return False; | |
4729 | end if; | |
4730 | end Is_Build_In_Place_Function; | |
f4d379b8 | 4731 | |
02822a92 RD |
4732 | ------------------------------------- |
4733 | -- Is_Build_In_Place_Function_Call -- | |
4734 | ------------------------------------- | |
f4d379b8 | 4735 | |
02822a92 RD |
4736 | function Is_Build_In_Place_Function_Call (N : Node_Id) return Boolean is |
4737 | Exp_Node : Node_Id := N; | |
4738 | Function_Id : Entity_Id; | |
f4d379b8 | 4739 | |
02822a92 | 4740 | begin |
19590d70 GD |
4741 | -- Step past qualification or unchecked conversion (the latter can occur |
4742 | -- in cases of calls to 'Input). | |
4743 | ||
ac4d6407 RD |
4744 | if Nkind_In |
4745 | (Exp_Node, N_Qualified_Expression, N_Unchecked_Type_Conversion) | |
19590d70 | 4746 | then |
02822a92 RD |
4747 | Exp_Node := Expression (N); |
4748 | end if; | |
758c442c | 4749 | |
02822a92 RD |
4750 | if Nkind (Exp_Node) /= N_Function_Call then |
4751 | return False; | |
3ca505dc | 4752 | |
02822a92 RD |
4753 | else |
4754 | if Is_Entity_Name (Name (Exp_Node)) then | |
4755 | Function_Id := Entity (Name (Exp_Node)); | |
758c442c | 4756 | |
02822a92 RD |
4757 | elsif Nkind (Name (Exp_Node)) = N_Explicit_Dereference then |
4758 | Function_Id := Etype (Name (Exp_Node)); | |
4759 | end if; | |
758c442c | 4760 | |
02822a92 RD |
4761 | return Is_Build_In_Place_Function (Function_Id); |
4762 | end if; | |
4763 | end Is_Build_In_Place_Function_Call; | |
758c442c | 4764 | |
02822a92 RD |
4765 | ----------------------- |
4766 | -- Freeze_Subprogram -- | |
4767 | ----------------------- | |
758c442c | 4768 | |
02822a92 RD |
4769 | procedure Freeze_Subprogram (N : Node_Id) is |
4770 | Loc : constant Source_Ptr := Sloc (N); | |
3ca505dc | 4771 | |
02822a92 RD |
4772 | procedure Register_Predefined_DT_Entry (Prim : Entity_Id); |
4773 | -- (Ada 2005): Register a predefined primitive in all the secondary | |
4774 | -- dispatch tables of its primitive type. | |
3ca505dc | 4775 | |
f4d379b8 HK |
4776 | ---------------------------------- |
4777 | -- Register_Predefined_DT_Entry -- | |
4778 | ---------------------------------- | |
4779 | ||
4780 | procedure Register_Predefined_DT_Entry (Prim : Entity_Id) is | |
4781 | Iface_DT_Ptr : Elmt_Id; | |
02822a92 | 4782 | Tagged_Typ : Entity_Id; |
f4d379b8 | 4783 | Thunk_Id : Entity_Id; |
7888a6ae | 4784 | Thunk_Code : Node_Id; |
f4d379b8 HK |
4785 | |
4786 | begin | |
02822a92 | 4787 | Tagged_Typ := Find_Dispatching_Type (Prim); |
f4d379b8 | 4788 | |
02822a92 | 4789 | if No (Access_Disp_Table (Tagged_Typ)) |
ce2b6ba5 | 4790 | or else not Has_Interfaces (Tagged_Typ) |
c8ef728f | 4791 | or else not RTE_Available (RE_Interface_Tag) |
f937473f | 4792 | or else Restriction_Active (No_Dispatching_Calls) |
f4d379b8 HK |
4793 | then |
4794 | return; | |
4795 | end if; | |
4796 | ||
1923d2d6 JM |
4797 | -- Skip the first two access-to-dispatch-table pointers since they |
4798 | -- leads to the primary dispatch table (predefined DT and user | |
4799 | -- defined DT). We are only concerned with the secondary dispatch | |
4800 | -- table pointers. Note that the access-to- dispatch-table pointer | |
4801 | -- corresponds to the first implemented interface retrieved below. | |
f4d379b8 | 4802 | |
02822a92 | 4803 | Iface_DT_Ptr := |
1923d2d6 | 4804 | Next_Elmt (Next_Elmt (First_Elmt (Access_Disp_Table (Tagged_Typ)))); |
f937473f | 4805 | |
7888a6ae GD |
4806 | while Present (Iface_DT_Ptr) |
4807 | and then Ekind (Node (Iface_DT_Ptr)) = E_Constant | |
4808 | loop | |
ac4d6407 | 4809 | pragma Assert (Has_Thunks (Node (Iface_DT_Ptr))); |
d766cee3 | 4810 | Expand_Interface_Thunk (Prim, Thunk_Id, Thunk_Code); |
7888a6ae GD |
4811 | |
4812 | if Present (Thunk_Code) then | |
ac4d6407 | 4813 | Insert_Actions_After (N, New_List ( |
7888a6ae GD |
4814 | Thunk_Code, |
4815 | ||
4816 | Build_Set_Predefined_Prim_Op_Address (Loc, | |
1923d2d6 JM |
4817 | Tag_Node => |
4818 | New_Reference_To (Node (Next_Elmt (Iface_DT_Ptr)), Loc), | |
7888a6ae GD |
4819 | Position => DT_Position (Prim), |
4820 | Address_Node => | |
70f91180 | 4821 | Unchecked_Convert_To (RTE (RE_Prim_Ptr), |
1923d2d6 JM |
4822 | Make_Attribute_Reference (Loc, |
4823 | Prefix => New_Reference_To (Thunk_Id, Loc), | |
4824 | Attribute_Name => Name_Unrestricted_Access))), | |
ac4d6407 RD |
4825 | |
4826 | Build_Set_Predefined_Prim_Op_Address (Loc, | |
1923d2d6 JM |
4827 | Tag_Node => |
4828 | New_Reference_To | |
4829 | (Node (Next_Elmt (Next_Elmt (Next_Elmt (Iface_DT_Ptr)))), | |
4830 | Loc), | |
ac4d6407 RD |
4831 | Position => DT_Position (Prim), |
4832 | Address_Node => | |
70f91180 | 4833 | Unchecked_Convert_To (RTE (RE_Prim_Ptr), |
1923d2d6 JM |
4834 | Make_Attribute_Reference (Loc, |
4835 | Prefix => New_Reference_To (Prim, Loc), | |
4836 | Attribute_Name => Name_Unrestricted_Access))))); | |
7888a6ae | 4837 | end if; |
f4d379b8 | 4838 | |
1923d2d6 JM |
4839 | -- Skip the tag of the predefined primitives dispatch table |
4840 | ||
4841 | Next_Elmt (Iface_DT_Ptr); | |
4842 | pragma Assert (Has_Thunks (Node (Iface_DT_Ptr))); | |
4843 | ||
4844 | -- Skip the tag of the no-thunks dispatch table | |
4845 | ||
4846 | Next_Elmt (Iface_DT_Ptr); | |
4847 | pragma Assert (not Has_Thunks (Node (Iface_DT_Ptr))); | |
4848 | ||
4849 | -- Skip the tag of the predefined primitives no-thunks dispatch | |
4850 | -- table | |
4851 | ||
ac4d6407 RD |
4852 | Next_Elmt (Iface_DT_Ptr); |
4853 | pragma Assert (not Has_Thunks (Node (Iface_DT_Ptr))); | |
4854 | ||
f4d379b8 | 4855 | Next_Elmt (Iface_DT_Ptr); |
f4d379b8 HK |
4856 | end loop; |
4857 | end Register_Predefined_DT_Entry; | |
4858 | ||
7888a6ae | 4859 | -- Local variables |
3ca505dc | 4860 | |
7888a6ae | 4861 | Subp : constant Entity_Id := Entity (N); |
3ca505dc | 4862 | |
ac4d6407 RD |
4863 | -- Start of processing for Freeze_Subprogram |
4864 | ||
7888a6ae | 4865 | begin |
d766cee3 RD |
4866 | -- We suppress the initialization of the dispatch table entry when |
4867 | -- VM_Target because the dispatching mechanism is handled internally | |
4868 | -- by the VM. | |
4869 | ||
4870 | if Is_Dispatching_Operation (Subp) | |
4871 | and then not Is_Abstract_Subprogram (Subp) | |
4872 | and then Present (DTC_Entity (Subp)) | |
4873 | and then Present (Scope (DTC_Entity (Subp))) | |
1f110335 | 4874 | and then Tagged_Type_Expansion |
d766cee3 RD |
4875 | and then not Restriction_Active (No_Dispatching_Calls) |
4876 | and then RTE_Available (RE_Tag) | |
4877 | then | |
7888a6ae | 4878 | declare |
d766cee3 | 4879 | Typ : constant Entity_Id := Scope (DTC_Entity (Subp)); |
c8ef728f | 4880 | |
7888a6ae | 4881 | begin |
8fc789c8 | 4882 | -- Handle private overridden primitives |
c8ef728f | 4883 | |
d766cee3 RD |
4884 | if not Is_CPP_Class (Typ) then |
4885 | Check_Overriding_Operation (Subp); | |
7888a6ae | 4886 | end if; |
c8ef728f | 4887 | |
d766cee3 RD |
4888 | -- We assume that imported CPP primitives correspond with objects |
4889 | -- whose constructor is in the CPP side; therefore we don't need | |
4890 | -- to generate code to register them in the dispatch table. | |
c8ef728f | 4891 | |
d766cee3 RD |
4892 | if Is_CPP_Class (Typ) then |
4893 | null; | |
3ca505dc | 4894 | |
d766cee3 RD |
4895 | -- Handle CPP primitives found in derivations of CPP_Class types. |
4896 | -- These primitives must have been inherited from some parent, and | |
4897 | -- there is no need to register them in the dispatch table because | |
4898 | -- Build_Inherit_Prims takes care of the initialization of these | |
4899 | -- slots. | |
3ca505dc | 4900 | |
d766cee3 RD |
4901 | elsif Is_Imported (Subp) |
4902 | and then (Convention (Subp) = Convention_CPP | |
4903 | or else Convention (Subp) = Convention_C) | |
4904 | then | |
4905 | null; | |
4906 | ||
4907 | -- Generate code to register the primitive in non statically | |
4908 | -- allocated dispatch tables | |
4909 | ||
4910 | elsif not Static_Dispatch_Tables | |
4911 | or else not | |
4912 | Is_Library_Level_Tagged_Type (Scope (DTC_Entity (Subp))) | |
4913 | then | |
4914 | -- When a primitive is frozen, enter its name in its dispatch | |
4915 | -- table slot. | |
f4d379b8 | 4916 | |
d766cee3 | 4917 | if not Is_Interface (Typ) |
ce2b6ba5 | 4918 | or else Present (Interface_Alias (Subp)) |
d766cee3 RD |
4919 | then |
4920 | if Is_Predefined_Dispatching_Operation (Subp) then | |
4921 | Register_Predefined_DT_Entry (Subp); | |
7888a6ae | 4922 | end if; |
d766cee3 | 4923 | |
991395ab AC |
4924 | Insert_Actions_After (N, |
4925 | Register_Primitive (Loc, Prim => Subp)); | |
7888a6ae GD |
4926 | end if; |
4927 | end if; | |
4928 | end; | |
70482933 RK |
4929 | end if; |
4930 | ||
7888a6ae GD |
4931 | -- Mark functions that return by reference. Note that it cannot be part |
4932 | -- of the normal semantic analysis of the spec since the underlying | |
4933 | -- returned type may not be known yet (for private types). | |
70482933 | 4934 | |
d766cee3 RD |
4935 | declare |
4936 | Typ : constant Entity_Id := Etype (Subp); | |
4937 | Utyp : constant Entity_Id := Underlying_Type (Typ); | |
4938 | begin | |
4939 | if Is_Inherently_Limited_Type (Typ) then | |
4940 | Set_Returns_By_Ref (Subp); | |
048e5cef | 4941 | elsif Present (Utyp) and then CW_Or_Has_Controlled_Part (Utyp) then |
d766cee3 RD |
4942 | Set_Returns_By_Ref (Subp); |
4943 | end if; | |
4944 | end; | |
70482933 RK |
4945 | end Freeze_Subprogram; |
4946 | ||
8dbf3473 AC |
4947 | ----------------------- |
4948 | -- Is_Null_Procedure -- | |
4949 | ----------------------- | |
4950 | ||
4951 | function Is_Null_Procedure (Subp : Entity_Id) return Boolean is | |
4952 | Decl : constant Node_Id := Unit_Declaration_Node (Subp); | |
4953 | ||
4954 | begin | |
4955 | if Ekind (Subp) /= E_Procedure then | |
4956 | return False; | |
4957 | ||
4958 | -- Check if this is a declared null procedure | |
4959 | ||
4960 | elsif Nkind (Decl) = N_Subprogram_Declaration then | |
e1f3cb58 AC |
4961 | if not Null_Present (Specification (Decl)) then |
4962 | return False; | |
8dbf3473 AC |
4963 | |
4964 | elsif No (Body_To_Inline (Decl)) then | |
4965 | return False; | |
4966 | ||
4967 | -- Check if the body contains only a null statement, followed by | |
4968 | -- the return statement added during expansion. | |
4969 | ||
4970 | else | |
4971 | declare | |
4972 | Orig_Bod : constant Node_Id := Body_To_Inline (Decl); | |
4973 | ||
4974 | Stat : Node_Id; | |
4975 | Stat2 : Node_Id; | |
4976 | ||
4977 | begin | |
4978 | if Nkind (Orig_Bod) /= N_Subprogram_Body then | |
4979 | return False; | |
4980 | else | |
327503f1 JM |
4981 | -- We must skip SCIL nodes because they are currently |
4982 | -- implemented as special N_Null_Statement nodes. | |
4983 | ||
8dbf3473 | 4984 | Stat := |
327503f1 | 4985 | First_Non_SCIL_Node |
8dbf3473 | 4986 | (Statements (Handled_Statement_Sequence (Orig_Bod))); |
327503f1 | 4987 | Stat2 := Next_Non_SCIL_Node (Stat); |
8dbf3473 AC |
4988 | |
4989 | return | |
e1f3cb58 AC |
4990 | Is_Empty_List (Declarations (Orig_Bod)) |
4991 | and then Nkind (Stat) = N_Null_Statement | |
4992 | and then | |
8dbf3473 AC |
4993 | (No (Stat2) |
4994 | or else | |
4995 | (Nkind (Stat2) = N_Simple_Return_Statement | |
4996 | and then No (Next (Stat2)))); | |
4997 | end if; | |
4998 | end; | |
4999 | end if; | |
5000 | ||
5001 | else | |
5002 | return False; | |
5003 | end if; | |
5004 | end Is_Null_Procedure; | |
5005 | ||
02822a92 RD |
5006 | ------------------------------------------- |
5007 | -- Make_Build_In_Place_Call_In_Allocator -- | |
5008 | ------------------------------------------- | |
5009 | ||
5010 | procedure Make_Build_In_Place_Call_In_Allocator | |
5011 | (Allocator : Node_Id; | |
5012 | Function_Call : Node_Id) | |
5013 | is | |
5014 | Loc : Source_Ptr; | |
5015 | Func_Call : Node_Id := Function_Call; | |
5016 | Function_Id : Entity_Id; | |
5017 | Result_Subt : Entity_Id; | |
5018 | Acc_Type : constant Entity_Id := Etype (Allocator); | |
5019 | New_Allocator : Node_Id; | |
5020 | Return_Obj_Access : Entity_Id; | |
5021 | ||
5022 | begin | |
19590d70 GD |
5023 | -- Step past qualification or unchecked conversion (the latter can occur |
5024 | -- in cases of calls to 'Input). | |
5025 | ||
ac4d6407 RD |
5026 | if Nkind_In (Func_Call, |
5027 | N_Qualified_Expression, | |
5028 | N_Unchecked_Type_Conversion) | |
19590d70 | 5029 | then |
02822a92 RD |
5030 | Func_Call := Expression (Func_Call); |
5031 | end if; | |
5032 | ||
fdce4bb7 JM |
5033 | -- If the call has already been processed to add build-in-place actuals |
5034 | -- then return. This should not normally occur in an allocator context, | |
5035 | -- but we add the protection as a defensive measure. | |
5036 | ||
5037 | if Is_Expanded_Build_In_Place_Call (Func_Call) then | |
5038 | return; | |
5039 | end if; | |
5040 | ||
5041 | -- Mark the call as processed as a build-in-place call | |
5042 | ||
5043 | Set_Is_Expanded_Build_In_Place_Call (Func_Call); | |
5044 | ||
02822a92 RD |
5045 | Loc := Sloc (Function_Call); |
5046 | ||
5047 | if Is_Entity_Name (Name (Func_Call)) then | |
5048 | Function_Id := Entity (Name (Func_Call)); | |
5049 | ||
5050 | elsif Nkind (Name (Func_Call)) = N_Explicit_Dereference then | |
5051 | Function_Id := Etype (Name (Func_Call)); | |
5052 | ||
5053 | else | |
5054 | raise Program_Error; | |
5055 | end if; | |
5056 | ||
5057 | Result_Subt := Etype (Function_Id); | |
5058 | ||
f937473f RD |
5059 | -- When the result subtype is constrained, the return object must be |
5060 | -- allocated on the caller side, and access to it is passed to the | |
5061 | -- function. | |
02822a92 | 5062 | |
7888a6ae GD |
5063 | -- Here and in related routines, we must examine the full view of the |
5064 | -- type, because the view at the point of call may differ from that | |
5065 | -- that in the function body, and the expansion mechanism depends on | |
5066 | -- the characteristics of the full view. | |
5067 | ||
5068 | if Is_Constrained (Underlying_Type (Result_Subt)) then | |
02822a92 | 5069 | |
f937473f RD |
5070 | -- Replace the initialized allocator of form "new T'(Func (...))" |
5071 | -- with an uninitialized allocator of form "new T", where T is the | |
5072 | -- result subtype of the called function. The call to the function | |
5073 | -- is handled separately further below. | |
02822a92 | 5074 | |
f937473f | 5075 | New_Allocator := |
fad0600d AC |
5076 | Make_Allocator (Loc, |
5077 | Expression => New_Reference_To (Result_Subt, Loc)); | |
5078 | Set_No_Initialization (New_Allocator); | |
5079 | ||
5080 | -- Copy attributes to new allocator. Note that the new allocator | |
5081 | -- logically comes from source if the original one did, so copy the | |
5082 | -- relevant flag. This ensures proper treatment of the restriction | |
5083 | -- No_Implicit_Heap_Allocations in this case. | |
02822a92 | 5084 | |
fad0600d | 5085 | Set_Storage_Pool (New_Allocator, Storage_Pool (Allocator)); |
f937473f | 5086 | Set_Procedure_To_Call (New_Allocator, Procedure_To_Call (Allocator)); |
fad0600d | 5087 | Set_Comes_From_Source (New_Allocator, Comes_From_Source (Allocator)); |
02822a92 | 5088 | |
f937473f | 5089 | Rewrite (Allocator, New_Allocator); |
02822a92 | 5090 | |
f937473f RD |
5091 | -- Create a new access object and initialize it to the result of the |
5092 | -- new uninitialized allocator. | |
02822a92 | 5093 | |
f937473f RD |
5094 | Return_Obj_Access := |
5095 | Make_Defining_Identifier (Loc, New_Internal_Name ('R')); | |
5096 | Set_Etype (Return_Obj_Access, Acc_Type); | |
5097 | ||
5098 | Insert_Action (Allocator, | |
5099 | Make_Object_Declaration (Loc, | |
5100 | Defining_Identifier => Return_Obj_Access, | |
5101 | Object_Definition => New_Reference_To (Acc_Type, Loc), | |
5102 | Expression => Relocate_Node (Allocator))); | |
5103 | ||
7888a6ae GD |
5104 | -- When the function has a controlling result, an allocation-form |
5105 | -- parameter must be passed indicating that the caller is allocating | |
5106 | -- the result object. This is needed because such a function can be | |
5107 | -- called as a dispatching operation and must be treated similarly | |
5108 | -- to functions with unconstrained result subtypes. | |
5109 | ||
5110 | Add_Alloc_Form_Actual_To_Build_In_Place_Call | |
5111 | (Func_Call, Function_Id, Alloc_Form => Caller_Allocation); | |
5112 | ||
5113 | Add_Final_List_Actual_To_Build_In_Place_Call | |
5114 | (Func_Call, Function_Id, Acc_Type); | |
5115 | ||
5116 | Add_Task_Actuals_To_Build_In_Place_Call | |
5117 | (Func_Call, Function_Id, Master_Actual => Master_Id (Acc_Type)); | |
5118 | ||
f937473f RD |
5119 | -- Add an implicit actual to the function call that provides access |
5120 | -- to the allocated object. An unchecked conversion to the (specific) | |
5121 | -- result subtype of the function is inserted to handle cases where | |
5122 | -- the access type of the allocator has a class-wide designated type. | |
5123 | ||
f937473f RD |
5124 | Add_Access_Actual_To_Build_In_Place_Call |
5125 | (Func_Call, | |
5126 | Function_Id, | |
5127 | Make_Unchecked_Type_Conversion (Loc, | |
5128 | Subtype_Mark => New_Reference_To (Result_Subt, Loc), | |
5129 | Expression => | |
5130 | Make_Explicit_Dereference (Loc, | |
5131 | Prefix => New_Reference_To (Return_Obj_Access, Loc)))); | |
5132 | ||
5133 | -- When the result subtype is unconstrained, the function itself must | |
5134 | -- perform the allocation of the return object, so we pass parameters | |
5135 | -- indicating that. We don't yet handle the case where the allocation | |
5136 | -- must be done in a user-defined storage pool, which will require | |
5137 | -- passing another actual or two to provide allocation/deallocation | |
5138 | -- operations. ??? | |
5139 | ||
5140 | else | |
7888a6ae | 5141 | |
f937473f RD |
5142 | -- Pass an allocation parameter indicating that the function should |
5143 | -- allocate its result on the heap. | |
5144 | ||
5145 | Add_Alloc_Form_Actual_To_Build_In_Place_Call | |
5146 | (Func_Call, Function_Id, Alloc_Form => Global_Heap); | |
5147 | ||
7888a6ae GD |
5148 | Add_Final_List_Actual_To_Build_In_Place_Call |
5149 | (Func_Call, Function_Id, Acc_Type); | |
f937473f | 5150 | |
f937473f RD |
5151 | Add_Task_Actuals_To_Build_In_Place_Call |
5152 | (Func_Call, Function_Id, Master_Actual => Master_Id (Acc_Type)); | |
7888a6ae GD |
5153 | |
5154 | -- The caller does not provide the return object in this case, so we | |
5155 | -- have to pass null for the object access actual. | |
5156 | ||
f937473f RD |
5157 | Add_Access_Actual_To_Build_In_Place_Call |
5158 | (Func_Call, Function_Id, Return_Object => Empty); | |
5159 | end if; | |
02822a92 RD |
5160 | |
5161 | -- Finally, replace the allocator node with a reference to the result | |
5162 | -- of the function call itself (which will effectively be an access | |
5163 | -- to the object created by the allocator). | |
5164 | ||
5165 | Rewrite (Allocator, Make_Reference (Loc, Relocate_Node (Function_Call))); | |
5166 | Analyze_And_Resolve (Allocator, Acc_Type); | |
5167 | end Make_Build_In_Place_Call_In_Allocator; | |
5168 | ||
5169 | --------------------------------------------------- | |
5170 | -- Make_Build_In_Place_Call_In_Anonymous_Context -- | |
5171 | --------------------------------------------------- | |
5172 | ||
5173 | procedure Make_Build_In_Place_Call_In_Anonymous_Context | |
5174 | (Function_Call : Node_Id) | |
5175 | is | |
5176 | Loc : Source_Ptr; | |
5177 | Func_Call : Node_Id := Function_Call; | |
5178 | Function_Id : Entity_Id; | |
5179 | Result_Subt : Entity_Id; | |
5180 | Return_Obj_Id : Entity_Id; | |
5181 | Return_Obj_Decl : Entity_Id; | |
5182 | ||
5183 | begin | |
19590d70 GD |
5184 | -- Step past qualification or unchecked conversion (the latter can occur |
5185 | -- in cases of calls to 'Input). | |
5186 | ||
ac4d6407 RD |
5187 | if Nkind_In (Func_Call, N_Qualified_Expression, |
5188 | N_Unchecked_Type_Conversion) | |
19590d70 | 5189 | then |
02822a92 RD |
5190 | Func_Call := Expression (Func_Call); |
5191 | end if; | |
5192 | ||
fdce4bb7 JM |
5193 | -- If the call has already been processed to add build-in-place actuals |
5194 | -- then return. One place this can occur is for calls to build-in-place | |
5195 | -- functions that occur within a call to a protected operation, where | |
5196 | -- due to rewriting and expansion of the protected call there can be | |
5197 | -- more than one call to Expand_Actuals for the same set of actuals. | |
5198 | ||
5199 | if Is_Expanded_Build_In_Place_Call (Func_Call) then | |
5200 | return; | |
5201 | end if; | |
5202 | ||
5203 | -- Mark the call as processed as a build-in-place call | |
5204 | ||
5205 | Set_Is_Expanded_Build_In_Place_Call (Func_Call); | |
5206 | ||
02822a92 RD |
5207 | Loc := Sloc (Function_Call); |
5208 | ||
5209 | if Is_Entity_Name (Name (Func_Call)) then | |
5210 | Function_Id := Entity (Name (Func_Call)); | |
5211 | ||
5212 | elsif Nkind (Name (Func_Call)) = N_Explicit_Dereference then | |
5213 | Function_Id := Etype (Name (Func_Call)); | |
5214 | ||
5215 | else | |
5216 | raise Program_Error; | |
5217 | end if; | |
5218 | ||
5219 | Result_Subt := Etype (Function_Id); | |
5220 | ||
f937473f RD |
5221 | -- When the result subtype is constrained, an object of the subtype is |
5222 | -- declared and an access value designating it is passed as an actual. | |
02822a92 | 5223 | |
7888a6ae | 5224 | if Is_Constrained (Underlying_Type (Result_Subt)) then |
02822a92 | 5225 | |
f937473f RD |
5226 | -- Create a temporary object to hold the function result |
5227 | ||
5228 | Return_Obj_Id := | |
5229 | Make_Defining_Identifier (Loc, | |
5230 | Chars => New_Internal_Name ('R')); | |
5231 | Set_Etype (Return_Obj_Id, Result_Subt); | |
02822a92 | 5232 | |
f937473f RD |
5233 | Return_Obj_Decl := |
5234 | Make_Object_Declaration (Loc, | |
5235 | Defining_Identifier => Return_Obj_Id, | |
5236 | Aliased_Present => True, | |
5237 | Object_Definition => New_Reference_To (Result_Subt, Loc)); | |
02822a92 | 5238 | |
f937473f | 5239 | Set_No_Initialization (Return_Obj_Decl); |
02822a92 | 5240 | |
f937473f | 5241 | Insert_Action (Func_Call, Return_Obj_Decl); |
02822a92 | 5242 | |
7888a6ae GD |
5243 | -- When the function has a controlling result, an allocation-form |
5244 | -- parameter must be passed indicating that the caller is allocating | |
5245 | -- the result object. This is needed because such a function can be | |
5246 | -- called as a dispatching operation and must be treated similarly | |
5247 | -- to functions with unconstrained result subtypes. | |
5248 | ||
5249 | Add_Alloc_Form_Actual_To_Build_In_Place_Call | |
5250 | (Func_Call, Function_Id, Alloc_Form => Caller_Allocation); | |
5251 | ||
5252 | Add_Final_List_Actual_To_Build_In_Place_Call | |
5253 | (Func_Call, Function_Id, Acc_Type => Empty); | |
f937473f | 5254 | |
f937473f RD |
5255 | Add_Task_Actuals_To_Build_In_Place_Call |
5256 | (Func_Call, Function_Id, Make_Identifier (Loc, Name_uMaster)); | |
7888a6ae GD |
5257 | |
5258 | -- Add an implicit actual to the function call that provides access | |
5259 | -- to the caller's return object. | |
5260 | ||
f937473f RD |
5261 | Add_Access_Actual_To_Build_In_Place_Call |
5262 | (Func_Call, Function_Id, New_Reference_To (Return_Obj_Id, Loc)); | |
5263 | ||
5264 | -- When the result subtype is unconstrained, the function must allocate | |
5265 | -- the return object in the secondary stack, so appropriate implicit | |
5266 | -- parameters are added to the call to indicate that. A transient | |
5267 | -- scope is established to ensure eventual cleanup of the result. | |
5268 | ||
5269 | else | |
7888a6ae | 5270 | |
f937473f RD |
5271 | -- Pass an allocation parameter indicating that the function should |
5272 | -- allocate its result on the secondary stack. | |
5273 | ||
5274 | Add_Alloc_Form_Actual_To_Build_In_Place_Call | |
5275 | (Func_Call, Function_Id, Alloc_Form => Secondary_Stack); | |
5276 | ||
7888a6ae GD |
5277 | Add_Final_List_Actual_To_Build_In_Place_Call |
5278 | (Func_Call, Function_Id, Acc_Type => Empty); | |
f937473f | 5279 | |
f937473f RD |
5280 | Add_Task_Actuals_To_Build_In_Place_Call |
5281 | (Func_Call, Function_Id, Make_Identifier (Loc, Name_uMaster)); | |
7888a6ae GD |
5282 | |
5283 | -- Pass a null value to the function since no return object is | |
5284 | -- available on the caller side. | |
5285 | ||
f937473f RD |
5286 | Add_Access_Actual_To_Build_In_Place_Call |
5287 | (Func_Call, Function_Id, Empty); | |
5288 | ||
5289 | Establish_Transient_Scope (Func_Call, Sec_Stack => True); | |
5290 | end if; | |
02822a92 RD |
5291 | end Make_Build_In_Place_Call_In_Anonymous_Context; |
5292 | ||
ce2798e8 | 5293 | -------------------------------------------- |
02822a92 | 5294 | -- Make_Build_In_Place_Call_In_Assignment -- |
ce2798e8 | 5295 | -------------------------------------------- |
02822a92 RD |
5296 | |
5297 | procedure Make_Build_In_Place_Call_In_Assignment | |
5298 | (Assign : Node_Id; | |
5299 | Function_Call : Node_Id) | |
5300 | is | |
3a69b5ff AC |
5301 | Lhs : constant Node_Id := Name (Assign); |
5302 | Func_Call : Node_Id := Function_Call; | |
5303 | Func_Id : Entity_Id; | |
5304 | Loc : Source_Ptr; | |
5305 | Obj_Decl : Node_Id; | |
5306 | Obj_Id : Entity_Id; | |
5307 | Ptr_Typ : Entity_Id; | |
5308 | Ptr_Typ_Decl : Node_Id; | |
5309 | Result_Subt : Entity_Id; | |
5310 | Target : Node_Id; | |
02822a92 RD |
5311 | |
5312 | begin | |
19590d70 GD |
5313 | -- Step past qualification or unchecked conversion (the latter can occur |
5314 | -- in cases of calls to 'Input). | |
5315 | ||
ac4d6407 RD |
5316 | if Nkind_In (Func_Call, N_Qualified_Expression, |
5317 | N_Unchecked_Type_Conversion) | |
19590d70 | 5318 | then |
02822a92 RD |
5319 | Func_Call := Expression (Func_Call); |
5320 | end if; | |
5321 | ||
fdce4bb7 JM |
5322 | -- If the call has already been processed to add build-in-place actuals |
5323 | -- then return. This should not normally occur in an assignment context, | |
5324 | -- but we add the protection as a defensive measure. | |
5325 | ||
5326 | if Is_Expanded_Build_In_Place_Call (Func_Call) then | |
5327 | return; | |
5328 | end if; | |
5329 | ||
5330 | -- Mark the call as processed as a build-in-place call | |
5331 | ||
5332 | Set_Is_Expanded_Build_In_Place_Call (Func_Call); | |
5333 | ||
02822a92 RD |
5334 | Loc := Sloc (Function_Call); |
5335 | ||
5336 | if Is_Entity_Name (Name (Func_Call)) then | |
3a69b5ff | 5337 | Func_Id := Entity (Name (Func_Call)); |
02822a92 RD |
5338 | |
5339 | elsif Nkind (Name (Func_Call)) = N_Explicit_Dereference then | |
3a69b5ff | 5340 | Func_Id := Etype (Name (Func_Call)); |
02822a92 RD |
5341 | |
5342 | else | |
5343 | raise Program_Error; | |
5344 | end if; | |
5345 | ||
3a69b5ff | 5346 | Result_Subt := Etype (Func_Id); |
02822a92 | 5347 | |
f937473f RD |
5348 | -- When the result subtype is unconstrained, an additional actual must |
5349 | -- be passed to indicate that the caller is providing the return object. | |
7888a6ae GD |
5350 | -- This parameter must also be passed when the called function has a |
5351 | -- controlling result, because dispatching calls to the function needs | |
5352 | -- to be treated effectively the same as calls to class-wide functions. | |
f937473f | 5353 | |
7888a6ae | 5354 | Add_Alloc_Form_Actual_To_Build_In_Place_Call |
3a69b5ff | 5355 | (Func_Call, Func_Id, Alloc_Form => Caller_Allocation); |
f937473f | 5356 | |
70f91180 RD |
5357 | -- If Lhs is a selected component, then pass it along so that its prefix |
5358 | -- object will be used as the source of the finalization list. | |
5359 | ||
5360 | if Nkind (Lhs) = N_Selected_Component then | |
5361 | Add_Final_List_Actual_To_Build_In_Place_Call | |
3a69b5ff | 5362 | (Func_Call, Func_Id, Acc_Type => Empty, Sel_Comp => Lhs); |
70f91180 RD |
5363 | else |
5364 | Add_Final_List_Actual_To_Build_In_Place_Call | |
3a69b5ff | 5365 | (Func_Call, Func_Id, Acc_Type => Empty); |
70f91180 | 5366 | end if; |
02822a92 | 5367 | |
f937473f | 5368 | Add_Task_Actuals_To_Build_In_Place_Call |
3a69b5ff | 5369 | (Func_Call, Func_Id, Make_Identifier (Loc, Name_uMaster)); |
7888a6ae GD |
5370 | |
5371 | -- Add an implicit actual to the function call that provides access to | |
5372 | -- the caller's return object. | |
5373 | ||
02822a92 RD |
5374 | Add_Access_Actual_To_Build_In_Place_Call |
5375 | (Func_Call, | |
3a69b5ff | 5376 | Func_Id, |
02822a92 RD |
5377 | Make_Unchecked_Type_Conversion (Loc, |
5378 | Subtype_Mark => New_Reference_To (Result_Subt, Loc), | |
5379 | Expression => Relocate_Node (Lhs))); | |
5380 | ||
5381 | -- Create an access type designating the function's result subtype | |
5382 | ||
3a69b5ff | 5383 | Ptr_Typ := |
02822a92 RD |
5384 | Make_Defining_Identifier (Loc, New_Internal_Name ('A')); |
5385 | ||
5386 | Ptr_Typ_Decl := | |
5387 | Make_Full_Type_Declaration (Loc, | |
3a69b5ff | 5388 | Defining_Identifier => Ptr_Typ, |
02822a92 RD |
5389 | Type_Definition => |
5390 | Make_Access_To_Object_Definition (Loc, | |
5391 | All_Present => True, | |
5392 | Subtype_Indication => | |
5393 | New_Reference_To (Result_Subt, Loc))); | |
02822a92 RD |
5394 | Insert_After_And_Analyze (Assign, Ptr_Typ_Decl); |
5395 | ||
5396 | -- Finally, create an access object initialized to a reference to the | |
5397 | -- function call. | |
5398 | ||
3a69b5ff AC |
5399 | Obj_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('R')); |
5400 | Set_Etype (Obj_Id, Ptr_Typ); | |
02822a92 | 5401 | |
3a69b5ff | 5402 | Obj_Decl := |
02822a92 | 5403 | Make_Object_Declaration (Loc, |
3a69b5ff AC |
5404 | Defining_Identifier => Obj_Id, |
5405 | Object_Definition => | |
5406 | New_Reference_To (Ptr_Typ, Loc), | |
5407 | Expression => | |
5408 | Make_Reference (Loc, | |
5409 | Prefix => Relocate_Node (Func_Call))); | |
5410 | Insert_After_And_Analyze (Ptr_Typ_Decl, Obj_Decl); | |
02822a92 RD |
5411 | |
5412 | Rewrite (Assign, Make_Null_Statement (Loc)); | |
3a69b5ff AC |
5413 | |
5414 | -- Retrieve the target of the assignment | |
5415 | ||
5416 | if Nkind (Lhs) = N_Selected_Component then | |
5417 | Target := Selector_Name (Lhs); | |
5418 | elsif Nkind (Lhs) = N_Type_Conversion then | |
5419 | Target := Expression (Lhs); | |
5420 | else | |
5421 | Target := Lhs; | |
5422 | end if; | |
5423 | ||
5424 | -- If we are assigning to a return object or this is an expression of | |
5425 | -- an extension aggregate, the target should either be an identifier | |
5426 | -- or a simple expression. All other cases imply a different scenario. | |
5427 | ||
5428 | if Nkind (Target) in N_Has_Entity then | |
5429 | Target := Entity (Target); | |
5430 | else | |
5431 | return; | |
5432 | end if; | |
5433 | ||
5434 | -- When the target of the assignment is a return object of an enclosing | |
5435 | -- build-in-place function and also requires finalization, the list | |
5436 | -- generated for the assignment must be moved to that of the enclosing | |
5437 | -- function. | |
5438 | ||
5439 | -- function Enclosing_BIP_Function return Ctrl_Typ is | |
5440 | -- begin | |
5441 | -- return (Ctrl_Parent_Part => BIP_Function with ...); | |
5442 | -- end Enclosing_BIP_Function; | |
5443 | ||
5444 | if Is_Return_Object (Target) | |
5445 | and then Needs_Finalization (Etype (Target)) | |
5446 | and then Needs_Finalization (Result_Subt) | |
5447 | then | |
5448 | declare | |
5449 | Obj_List : constant Node_Id := Find_Final_List (Obj_Id); | |
5450 | Encl_List : Node_Id; | |
5451 | Encl_Scop : Entity_Id; | |
5452 | ||
5453 | begin | |
5454 | Encl_Scop := Scope (Target); | |
5455 | ||
5456 | -- Locate the scope of the extended return statement | |
5457 | ||
5458 | while Present (Encl_Scop) | |
5459 | and then Ekind (Encl_Scop) /= E_Return_Statement | |
5460 | loop | |
5461 | Encl_Scop := Scope (Encl_Scop); | |
5462 | end loop; | |
5463 | ||
5464 | -- A return object should always be enclosed by a return statement | |
5465 | -- scope at some level. | |
5466 | ||
5467 | pragma Assert (Present (Encl_Scop)); | |
5468 | ||
5469 | Encl_List := | |
5470 | Make_Attribute_Reference (Loc, | |
5471 | Prefix => | |
5472 | New_Reference_To ( | |
5473 | Finalization_Chain_Entity (Encl_Scop), Loc), | |
5474 | Attribute_Name => Name_Unrestricted_Access); | |
5475 | ||
5476 | -- Generate a call to move final list | |
5477 | ||
5478 | Insert_After_And_Analyze (Obj_Decl, | |
5479 | Make_Procedure_Call_Statement (Loc, | |
5480 | Name => | |
5481 | New_Reference_To (RTE (RE_Move_Final_List), Loc), | |
5482 | Parameter_Associations => New_List (Obj_List, Encl_List))); | |
5483 | end; | |
5484 | end if; | |
02822a92 RD |
5485 | end Make_Build_In_Place_Call_In_Assignment; |
5486 | ||
5487 | ---------------------------------------------------- | |
5488 | -- Make_Build_In_Place_Call_In_Object_Declaration -- | |
5489 | ---------------------------------------------------- | |
5490 | ||
5491 | procedure Make_Build_In_Place_Call_In_Object_Declaration | |
5492 | (Object_Decl : Node_Id; | |
5493 | Function_Call : Node_Id) | |
5494 | is | |
f937473f RD |
5495 | Loc : Source_Ptr; |
5496 | Obj_Def_Id : constant Entity_Id := | |
5497 | Defining_Identifier (Object_Decl); | |
7888a6ae | 5498 | |
f937473f RD |
5499 | Func_Call : Node_Id := Function_Call; |
5500 | Function_Id : Entity_Id; | |
5501 | Result_Subt : Entity_Id; | |
5502 | Caller_Object : Node_Id; | |
5503 | Call_Deref : Node_Id; | |
5504 | Ref_Type : Entity_Id; | |
5505 | Ptr_Typ_Decl : Node_Id; | |
5506 | Def_Id : Entity_Id; | |
5507 | New_Expr : Node_Id; | |
5508 | Enclosing_Func : Entity_Id; | |
5509 | Pass_Caller_Acc : Boolean := False; | |
02822a92 RD |
5510 | |
5511 | begin | |
19590d70 GD |
5512 | -- Step past qualification or unchecked conversion (the latter can occur |
5513 | -- in cases of calls to 'Input). | |
5514 | ||
ac4d6407 RD |
5515 | if Nkind_In (Func_Call, N_Qualified_Expression, |
5516 | N_Unchecked_Type_Conversion) | |
19590d70 | 5517 | then |
02822a92 RD |
5518 | Func_Call := Expression (Func_Call); |
5519 | end if; | |
5520 | ||
fdce4bb7 JM |
5521 | -- If the call has already been processed to add build-in-place actuals |
5522 | -- then return. This should not normally occur in an object declaration, | |
5523 | -- but we add the protection as a defensive measure. | |
5524 | ||
5525 | if Is_Expanded_Build_In_Place_Call (Func_Call) then | |
5526 | return; | |
5527 | end if; | |
5528 | ||
5529 | -- Mark the call as processed as a build-in-place call | |
5530 | ||
5531 | Set_Is_Expanded_Build_In_Place_Call (Func_Call); | |
5532 | ||
02822a92 RD |
5533 | Loc := Sloc (Function_Call); |
5534 | ||
5535 | if Is_Entity_Name (Name (Func_Call)) then | |
5536 | Function_Id := Entity (Name (Func_Call)); | |
5537 | ||
5538 | elsif Nkind (Name (Func_Call)) = N_Explicit_Dereference then | |
5539 | Function_Id := Etype (Name (Func_Call)); | |
5540 | ||
5541 | else | |
5542 | raise Program_Error; | |
5543 | end if; | |
5544 | ||
5545 | Result_Subt := Etype (Function_Id); | |
5546 | ||
f937473f RD |
5547 | -- In the constrained case, add an implicit actual to the function call |
5548 | -- that provides access to the declared object. An unchecked conversion | |
5549 | -- to the (specific) result type of the function is inserted to handle | |
5550 | -- the case where the object is declared with a class-wide type. | |
5551 | ||
7888a6ae | 5552 | if Is_Constrained (Underlying_Type (Result_Subt)) then |
f937473f RD |
5553 | Caller_Object := |
5554 | Make_Unchecked_Type_Conversion (Loc, | |
5555 | Subtype_Mark => New_Reference_To (Result_Subt, Loc), | |
5556 | Expression => New_Reference_To (Obj_Def_Id, Loc)); | |
02822a92 | 5557 | |
7888a6ae GD |
5558 | -- When the function has a controlling result, an allocation-form |
5559 | -- parameter must be passed indicating that the caller is allocating | |
5560 | -- the result object. This is needed because such a function can be | |
5561 | -- called as a dispatching operation and must be treated similarly | |
5562 | -- to functions with unconstrained result subtypes. | |
5563 | ||
5564 | Add_Alloc_Form_Actual_To_Build_In_Place_Call | |
5565 | (Func_Call, Function_Id, Alloc_Form => Caller_Allocation); | |
5566 | ||
f937473f RD |
5567 | -- If the function's result subtype is unconstrained and the object is |
5568 | -- a return object of an enclosing build-in-place function, then the | |
5569 | -- implicit build-in-place parameters of the enclosing function must be | |
ce14c577 AC |
5570 | -- passed along to the called function. (Unfortunately, this won't cover |
5571 | -- the case of extension aggregates where the ancestor part is a build- | |
5572 | -- in-place unconstrained function call that should be passed along the | |
5573 | -- caller's parameters. Currently those get mishandled by reassigning | |
5574 | -- the result of the call to the aggregate return object, when the call | |
5575 | -- result should really be directly built in place in the aggregate and | |
5576 | -- not built in a temporary. ???) | |
5577 | ||
5578 | elsif Is_Return_Object (Defining_Identifier (Object_Decl)) then | |
f937473f RD |
5579 | Pass_Caller_Acc := True; |
5580 | ||
5581 | Enclosing_Func := Enclosing_Subprogram (Obj_Def_Id); | |
5582 | ||
5583 | -- If the enclosing function has a constrained result type, then | |
5584 | -- caller allocation will be used. | |
5585 | ||
5586 | if Is_Constrained (Etype (Enclosing_Func)) then | |
5587 | Add_Alloc_Form_Actual_To_Build_In_Place_Call | |
5588 | (Func_Call, Function_Id, Alloc_Form => Caller_Allocation); | |
5589 | ||
5590 | -- Otherwise, when the enclosing function has an unconstrained result | |
5591 | -- type, the BIP_Alloc_Form formal of the enclosing function must be | |
7888a6ae | 5592 | -- passed along to the callee. |
f937473f RD |
5593 | |
5594 | else | |
5595 | Add_Alloc_Form_Actual_To_Build_In_Place_Call | |
5596 | (Func_Call, | |
5597 | Function_Id, | |
5598 | Alloc_Form_Exp => | |
5599 | New_Reference_To | |
5600 | (Build_In_Place_Formal (Enclosing_Func, BIP_Alloc_Form), | |
5601 | Loc)); | |
5602 | end if; | |
5603 | ||
5604 | -- Retrieve the BIPacc formal from the enclosing function and convert | |
5605 | -- it to the access type of the callee's BIP_Object_Access formal. | |
5606 | ||
5607 | Caller_Object := | |
5608 | Make_Unchecked_Type_Conversion (Loc, | |
5609 | Subtype_Mark => | |
5610 | New_Reference_To | |
5611 | (Etype | |
5612 | (Build_In_Place_Formal (Function_Id, BIP_Object_Access)), | |
5613 | Loc), | |
5614 | Expression => | |
5615 | New_Reference_To | |
5616 | (Build_In_Place_Formal (Enclosing_Func, BIP_Object_Access), | |
5617 | Loc)); | |
5618 | ||
5619 | -- In other unconstrained cases, pass an indication to do the allocation | |
5620 | -- on the secondary stack and set Caller_Object to Empty so that a null | |
5621 | -- value will be passed for the caller's object address. A transient | |
5622 | -- scope is established to ensure eventual cleanup of the result. | |
5623 | ||
5624 | else | |
5625 | Add_Alloc_Form_Actual_To_Build_In_Place_Call | |
5626 | (Func_Call, | |
5627 | Function_Id, | |
5628 | Alloc_Form => Secondary_Stack); | |
5629 | Caller_Object := Empty; | |
5630 | ||
5631 | Establish_Transient_Scope (Object_Decl, Sec_Stack => True); | |
5632 | end if; | |
5633 | ||
7888a6ae GD |
5634 | Add_Final_List_Actual_To_Build_In_Place_Call |
5635 | (Func_Call, Function_Id, Acc_Type => Empty); | |
5636 | ||
f937473f RD |
5637 | if Nkind (Parent (Object_Decl)) = N_Extended_Return_Statement |
5638 | and then Has_Task (Result_Subt) | |
5639 | then | |
5640 | Enclosing_Func := Enclosing_Subprogram (Obj_Def_Id); | |
7888a6ae GD |
5641 | |
5642 | -- Here we're passing along the master that was passed in to this | |
5643 | -- function. | |
5644 | ||
f937473f RD |
5645 | Add_Task_Actuals_To_Build_In_Place_Call |
5646 | (Func_Call, Function_Id, | |
5647 | Master_Actual => | |
5648 | New_Reference_To | |
5649 | (Build_In_Place_Formal (Enclosing_Func, BIP_Master), Loc)); | |
7888a6ae | 5650 | |
f937473f RD |
5651 | else |
5652 | Add_Task_Actuals_To_Build_In_Place_Call | |
5653 | (Func_Call, Function_Id, Make_Identifier (Loc, Name_uMaster)); | |
5654 | end if; | |
7888a6ae | 5655 | |
02822a92 | 5656 | Add_Access_Actual_To_Build_In_Place_Call |
f937473f | 5657 | (Func_Call, Function_Id, Caller_Object, Is_Access => Pass_Caller_Acc); |
02822a92 RD |
5658 | |
5659 | -- Create an access type designating the function's result subtype | |
5660 | ||
5661 | Ref_Type := | |
5662 | Make_Defining_Identifier (Loc, New_Internal_Name ('A')); | |
5663 | ||
5664 | Ptr_Typ_Decl := | |
5665 | Make_Full_Type_Declaration (Loc, | |
5666 | Defining_Identifier => Ref_Type, | |
5667 | Type_Definition => | |
5668 | Make_Access_To_Object_Definition (Loc, | |
5669 | All_Present => True, | |
5670 | Subtype_Indication => | |
5671 | New_Reference_To (Result_Subt, Loc))); | |
5672 | ||
f937473f RD |
5673 | -- The access type and its accompanying object must be inserted after |
5674 | -- the object declaration in the constrained case, so that the function | |
5675 | -- call can be passed access to the object. In the unconstrained case, | |
5676 | -- the access type and object must be inserted before the object, since | |
5677 | -- the object declaration is rewritten to be a renaming of a dereference | |
5678 | -- of the access object. | |
5679 | ||
7888a6ae | 5680 | if Is_Constrained (Underlying_Type (Result_Subt)) then |
f937473f RD |
5681 | Insert_After_And_Analyze (Object_Decl, Ptr_Typ_Decl); |
5682 | else | |
4f6e2c24 | 5683 | Insert_Action (Object_Decl, Ptr_Typ_Decl); |
f937473f | 5684 | end if; |
02822a92 RD |
5685 | |
5686 | -- Finally, create an access object initialized to a reference to the | |
5687 | -- function call. | |
5688 | ||
5689 | Def_Id := | |
5690 | Make_Defining_Identifier (Loc, | |
5691 | Chars => New_Internal_Name ('R')); | |
5692 | Set_Etype (Def_Id, Ref_Type); | |
5693 | ||
5694 | New_Expr := | |
5695 | Make_Reference (Loc, | |
5696 | Prefix => Relocate_Node (Func_Call)); | |
5697 | ||
5698 | Insert_After_And_Analyze (Ptr_Typ_Decl, | |
5699 | Make_Object_Declaration (Loc, | |
5700 | Defining_Identifier => Def_Id, | |
5701 | Object_Definition => New_Reference_To (Ref_Type, Loc), | |
5702 | Expression => New_Expr)); | |
5703 | ||
7888a6ae | 5704 | if Is_Constrained (Underlying_Type (Result_Subt)) then |
f937473f RD |
5705 | Set_Expression (Object_Decl, Empty); |
5706 | Set_No_Initialization (Object_Decl); | |
5707 | ||
5708 | -- In case of an unconstrained result subtype, rewrite the object | |
5709 | -- declaration as an object renaming where the renamed object is a | |
5710 | -- dereference of <function_Call>'reference: | |
5711 | -- | |
5712 | -- Obj : Subt renames <function_call>'Ref.all; | |
5713 | ||
5714 | else | |
5715 | Call_Deref := | |
5716 | Make_Explicit_Dereference (Loc, | |
5717 | Prefix => New_Reference_To (Def_Id, Loc)); | |
5718 | ||
5719 | Rewrite (Object_Decl, | |
5720 | Make_Object_Renaming_Declaration (Loc, | |
5721 | Defining_Identifier => Make_Defining_Identifier (Loc, | |
5722 | New_Internal_Name ('D')), | |
5723 | Access_Definition => Empty, | |
5724 | Subtype_Mark => New_Occurrence_Of (Result_Subt, Loc), | |
5725 | Name => Call_Deref)); | |
5726 | ||
5727 | Set_Renamed_Object (Defining_Identifier (Object_Decl), Call_Deref); | |
5728 | ||
5729 | Analyze (Object_Decl); | |
5730 | ||
5731 | -- Replace the internal identifier of the renaming declaration's | |
5732 | -- entity with identifier of the original object entity. We also have | |
5733 | -- to exchange the entities containing their defining identifiers to | |
5734 | -- ensure the correct replacement of the object declaration by the | |
5735 | -- object renaming declaration to avoid homograph conflicts (since | |
5736 | -- the object declaration's defining identifier was already entered | |
67ce0d7e RD |
5737 | -- in current scope). The Next_Entity links of the two entities also |
5738 | -- have to be swapped since the entities are part of the return | |
5739 | -- scope's entity list and the list structure would otherwise be | |
7e8ed0a6 | 5740 | -- corrupted. Finally, the homonym chain must be preserved as well. |
67ce0d7e RD |
5741 | |
5742 | declare | |
5743 | Renaming_Def_Id : constant Entity_Id := | |
5744 | Defining_Identifier (Object_Decl); | |
5745 | Next_Entity_Temp : constant Entity_Id := | |
5746 | Next_Entity (Renaming_Def_Id); | |
5747 | begin | |
5748 | Set_Chars (Renaming_Def_Id, Chars (Obj_Def_Id)); | |
5749 | ||
5750 | -- Swap next entity links in preparation for exchanging entities | |
f937473f | 5751 | |
67ce0d7e RD |
5752 | Set_Next_Entity (Renaming_Def_Id, Next_Entity (Obj_Def_Id)); |
5753 | Set_Next_Entity (Obj_Def_Id, Next_Entity_Temp); | |
7e8ed0a6 | 5754 | Set_Homonym (Renaming_Def_Id, Homonym (Obj_Def_Id)); |
67ce0d7e RD |
5755 | |
5756 | Exchange_Entities (Renaming_Def_Id, Obj_Def_Id); | |
5757 | end; | |
f937473f | 5758 | end if; |
02822a92 RD |
5759 | |
5760 | -- If the object entity has a class-wide Etype, then we need to change | |
5761 | -- it to the result subtype of the function call, because otherwise the | |
53b308f6 AC |
5762 | -- object will be class-wide without an explicit initialization and |
5763 | -- won't be allocated properly by the back end. It seems unclean to make | |
5764 | -- such a revision to the type at this point, and we should try to | |
5765 | -- improve this treatment when build-in-place functions with class-wide | |
5766 | -- results are implemented. ??? | |
02822a92 RD |
5767 | |
5768 | if Is_Class_Wide_Type (Etype (Defining_Identifier (Object_Decl))) then | |
5769 | Set_Etype (Defining_Identifier (Object_Decl), Result_Subt); | |
5770 | end if; | |
5771 | end Make_Build_In_Place_Call_In_Object_Declaration; | |
5772 | ||
8fb68c56 RD |
5773 | -------------------------- |
5774 | -- Needs_BIP_Final_List -- | |
5775 | -------------------------- | |
5776 | ||
048e5cef BD |
5777 | function Needs_BIP_Final_List (E : Entity_Id) return Boolean is |
5778 | pragma Assert (Is_Build_In_Place_Function (E)); | |
5779 | Result_Subt : constant Entity_Id := Underlying_Type (Etype (E)); | |
8fb68c56 | 5780 | |
048e5cef BD |
5781 | begin |
5782 | -- We need the BIP_Final_List if the result type needs finalization. We | |
5783 | -- also need it for tagged types, even if not class-wide, because some | |
5784 | -- type extension might need finalization, and all overriding functions | |
5785 | -- must have the same calling conventions. However, if there is a | |
5786 | -- pragma Restrictions (No_Finalization), we never need this parameter. | |
5787 | ||
5788 | return (Needs_Finalization (Result_Subt) | |
8fb68c56 | 5789 | or else Is_Tagged_Type (Underlying_Type (Result_Subt))) |
048e5cef BD |
5790 | and then not Restriction_Active (No_Finalization); |
5791 | end Needs_BIP_Final_List; | |
5792 | ||
70482933 | 5793 | end Exp_Ch6; |