]>
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 | -- -- | |
4c7e0990 | 9 | -- Copyright (C) 1992-2013, 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 | ||
cae64f11 | 26 | with Aspects; use Aspects; |
70482933 RK |
27 | with Atree; use Atree; |
28 | with Checks; use Checks; | |
29 | with Debug; use Debug; | |
30 | with Einfo; use Einfo; | |
31 | with Errout; use Errout; | |
32 | with Elists; use Elists; | |
4a1bfefb | 33 | with Exp_Aggr; use Exp_Aggr; |
f937473f | 34 | with Exp_Atag; use Exp_Atag; |
70482933 RK |
35 | with Exp_Ch2; use Exp_Ch2; |
36 | with Exp_Ch3; use Exp_Ch3; | |
37 | with Exp_Ch7; use Exp_Ch7; | |
38 | with Exp_Ch9; use Exp_Ch9; | |
70482933 RK |
39 | with Exp_Dbug; use Exp_Dbug; |
40 | with Exp_Disp; use Exp_Disp; | |
41 | with Exp_Dist; use Exp_Dist; | |
42 | with Exp_Intr; use Exp_Intr; | |
43 | with Exp_Pakd; use Exp_Pakd; | |
44 | with Exp_Tss; use Exp_Tss; | |
45 | with Exp_Util; use Exp_Util; | |
c986420e | 46 | with Exp_VFpt; use Exp_VFpt; |
fbf5a39b | 47 | with Fname; use Fname; |
70482933 | 48 | with Freeze; use Freeze; |
70482933 RK |
49 | with Inline; use Inline; |
50 | with Lib; use Lib; | |
7888a6ae | 51 | with Namet; use Namet; |
70482933 RK |
52 | with Nlists; use Nlists; |
53 | with Nmake; use Nmake; | |
54 | with Opt; use Opt; | |
84f4072a | 55 | with Output; use Output; |
70482933 | 56 | with Restrict; use Restrict; |
6e937c1c | 57 | with Rident; use Rident; |
70482933 RK |
58 | with Rtsfind; use Rtsfind; |
59 | with Sem; use Sem; | |
a4100e55 | 60 | with Sem_Aux; use Sem_Aux; |
70482933 RK |
61 | with Sem_Ch6; use Sem_Ch6; |
62 | with Sem_Ch8; use Sem_Ch8; | |
63 | with Sem_Ch12; use Sem_Ch12; | |
64 | with Sem_Ch13; use Sem_Ch13; | |
dec6faf1 | 65 | with Sem_Dim; use Sem_Dim; |
70482933 RK |
66 | with Sem_Disp; use Sem_Disp; |
67 | with Sem_Dist; use Sem_Dist; | |
dec6faf1 | 68 | with Sem_Eval; use Sem_Eval; |
758c442c | 69 | with Sem_Mech; use Sem_Mech; |
70482933 | 70 | with Sem_Res; use Sem_Res; |
d06b3b1d | 71 | with Sem_SCIL; use Sem_SCIL; |
70482933 RK |
72 | with Sem_Util; use Sem_Util; |
73 | with Sinfo; use Sinfo; | |
84f4072a | 74 | with Sinput; use Sinput; |
70482933 RK |
75 | with Snames; use Snames; |
76 | with Stand; use Stand; | |
8b404dac | 77 | with Stringt; use Stringt; |
2b3d67a5 | 78 | with Targparm; use Targparm; |
70482933 RK |
79 | with Tbuild; use Tbuild; |
80 | with Uintp; use Uintp; | |
81 | with Validsw; use Validsw; | |
82 | ||
83 | package body Exp_Ch6 is | |
84 | ||
84f4072a JM |
85 | Inlined_Calls : Elist_Id := No_Elist; |
86 | Backend_Calls : Elist_Id := No_Elist; | |
87 | -- List of frontend inlined calls and inline calls passed to the backend | |
88 | ||
70482933 RK |
89 | ----------------------- |
90 | -- Local Subprograms -- | |
91 | ----------------------- | |
92 | ||
02822a92 RD |
93 | procedure Add_Access_Actual_To_Build_In_Place_Call |
94 | (Function_Call : Node_Id; | |
95 | Function_Id : Entity_Id; | |
f937473f RD |
96 | Return_Object : Node_Id; |
97 | Is_Access : Boolean := False); | |
02822a92 RD |
98 | -- Ada 2005 (AI-318-02): Apply the Unrestricted_Access attribute to the |
99 | -- object name given by Return_Object and add the attribute to the end of | |
100 | -- the actual parameter list associated with the build-in-place function | |
f937473f RD |
101 | -- call denoted by Function_Call. However, if Is_Access is True, then |
102 | -- Return_Object is already an access expression, in which case it's passed | |
103 | -- along directly to the build-in-place function. Finally, if Return_Object | |
104 | -- is empty, then pass a null literal as the actual. | |
105 | ||
200b7162 | 106 | procedure Add_Unconstrained_Actuals_To_Build_In_Place_Call |
f937473f RD |
107 | (Function_Call : Node_Id; |
108 | Function_Id : Entity_Id; | |
109 | Alloc_Form : BIP_Allocation_Form := Unspecified; | |
200b7162 BD |
110 | Alloc_Form_Exp : Node_Id := Empty; |
111 | Pool_Actual : Node_Id := Make_Null (No_Location)); | |
112 | -- Ada 2005 (AI-318-02): Add the actuals needed for a build-in-place | |
113 | -- function call that returns a caller-unknown-size result (BIP_Alloc_Form | |
114 | -- and BIP_Storage_Pool). If Alloc_Form_Exp is present, then use it, | |
115 | -- otherwise pass a literal corresponding to the Alloc_Form parameter | |
116 | -- (which must not be Unspecified in that case). Pool_Actual is the | |
117 | -- parameter to pass to BIP_Storage_Pool. | |
f937473f | 118 | |
d3f70b35 | 119 | procedure Add_Finalization_Master_Actual_To_Build_In_Place_Call |
2c17ca0a AC |
120 | (Func_Call : Node_Id; |
121 | Func_Id : Entity_Id; | |
122 | Ptr_Typ : Entity_Id := Empty; | |
123 | Master_Exp : Node_Id := Empty); | |
df3e68b1 HK |
124 | -- Ada 2005 (AI-318-02): If the result type of a build-in-place call needs |
125 | -- finalization actions, add an actual parameter which is a pointer to the | |
2c17ca0a AC |
126 | -- finalization master of the caller. If Master_Exp is not Empty, then that |
127 | -- will be passed as the actual. Otherwise, if Ptr_Typ is left Empty, this | |
128 | -- will result in an automatic "null" value for the actual. | |
f937473f RD |
129 | |
130 | procedure Add_Task_Actuals_To_Build_In_Place_Call | |
131 | (Function_Call : Node_Id; | |
132 | Function_Id : Entity_Id; | |
133 | Master_Actual : Node_Id); | |
134 | -- Ada 2005 (AI-318-02): For a build-in-place call, if the result type | |
135 | -- contains tasks, add two actual parameters: the master, and a pointer to | |
136 | -- the caller's activation chain. Master_Actual is the actual parameter | |
137 | -- expression to pass for the master. In most cases, this is the current | |
138 | -- master (_master). The two exceptions are: If the function call is the | |
139 | -- initialization expression for an allocator, we pass the master of the | |
6dfc5592 RD |
140 | -- access type. If the function call is the initialization expression for a |
141 | -- return object, we pass along the master passed in by the caller. The | |
142 | -- activation chain to pass is always the local one. Note: Master_Actual | |
dd386db0 | 143 | -- can be Empty, but only if there are no tasks. |
02822a92 | 144 | |
70482933 RK |
145 | procedure Check_Overriding_Operation (Subp : Entity_Id); |
146 | -- Subp is a dispatching operation. Check whether it may override an | |
147 | -- inherited private operation, in which case its DT entry is that of | |
148 | -- the hidden operation, not the one it may have received earlier. | |
149 | -- This must be done before emitting the code to set the corresponding | |
150 | -- DT to the address of the subprogram. The actual placement of Subp in | |
151 | -- the proper place in the list of primitive operations is done in | |
152 | -- Declare_Inherited_Private_Subprograms, which also has to deal with | |
153 | -- implicit operations. This duplication is unavoidable for now??? | |
154 | ||
155 | procedure Detect_Infinite_Recursion (N : Node_Id; Spec : Entity_Id); | |
156 | -- This procedure is called only if the subprogram body N, whose spec | |
157 | -- has the given entity Spec, contains a parameterless recursive call. | |
158 | -- It attempts to generate runtime code to detect if this a case of | |
159 | -- infinite recursion. | |
160 | -- | |
161 | -- The body is scanned to determine dependencies. If the only external | |
162 | -- dependencies are on a small set of scalar variables, then the values | |
163 | -- of these variables are captured on entry to the subprogram, and if | |
164 | -- the values are not changed for the call, we know immediately that | |
165 | -- we have an infinite recursion. | |
166 | ||
df3e68b1 HK |
167 | procedure Expand_Ctrl_Function_Call (N : Node_Id); |
168 | -- N is a function call which returns a controlled object. Transform the | |
169 | -- call into a temporary which retrieves the returned object from the | |
170 | -- secondary stack using 'reference. | |
171 | ||
70482933 RK |
172 | procedure Expand_Inlined_Call |
173 | (N : Node_Id; | |
174 | Subp : Entity_Id; | |
175 | Orig_Subp : Entity_Id); | |
176 | -- If called subprogram can be inlined by the front-end, retrieve the | |
177 | -- analyzed body, replace formals with actuals and expand call in place. | |
178 | -- Generate thunks for actuals that are expressions, and insert the | |
179 | -- corresponding constant declarations before the call. If the original | |
180 | -- call is to a derived operation, the return type is the one of the | |
181 | -- derived operation, but the body is that of the original, so return | |
182 | -- expressions in the body must be converted to the desired type (which | |
183 | -- is simply not noted in the tree without inline expansion). | |
184 | ||
2b3d67a5 AC |
185 | procedure Expand_Non_Function_Return (N : Node_Id); |
186 | -- Called by Expand_N_Simple_Return_Statement in case we're returning from | |
187 | -- a procedure body, entry body, accept statement, or extended return | |
aeae67ed | 188 | -- statement. Note that all non-function returns are simple return |
2b3d67a5 AC |
189 | -- statements. |
190 | ||
70482933 RK |
191 | function Expand_Protected_Object_Reference |
192 | (N : Node_Id; | |
02822a92 | 193 | Scop : Entity_Id) return Node_Id; |
70482933 RK |
194 | |
195 | procedure Expand_Protected_Subprogram_Call | |
196 | (N : Node_Id; | |
197 | Subp : Entity_Id; | |
198 | Scop : Entity_Id); | |
199 | -- A call to a protected subprogram within the protected object may appear | |
200 | -- as a regular call. The list of actuals must be expanded to contain a | |
201 | -- reference to the object itself, and the call becomes a call to the | |
202 | -- corresponding protected subprogram. | |
203 | ||
63585f75 SB |
204 | function Has_Unconstrained_Access_Discriminants |
205 | (Subtyp : Entity_Id) return Boolean; | |
206 | -- Returns True if the given subtype is unconstrained and has one | |
207 | -- or more access discriminants. | |
208 | ||
2b3d67a5 AC |
209 | procedure Expand_Simple_Function_Return (N : Node_Id); |
210 | -- Expand simple return from function. In the case where we are returning | |
211 | -- from a function body this is called by Expand_N_Simple_Return_Statement. | |
212 | ||
02822a92 RD |
213 | ---------------------------------------------- |
214 | -- Add_Access_Actual_To_Build_In_Place_Call -- | |
215 | ---------------------------------------------- | |
216 | ||
217 | procedure Add_Access_Actual_To_Build_In_Place_Call | |
218 | (Function_Call : Node_Id; | |
219 | Function_Id : Entity_Id; | |
f937473f RD |
220 | Return_Object : Node_Id; |
221 | Is_Access : Boolean := False) | |
02822a92 RD |
222 | is |
223 | Loc : constant Source_Ptr := Sloc (Function_Call); | |
224 | Obj_Address : Node_Id; | |
f937473f | 225 | Obj_Acc_Formal : Entity_Id; |
02822a92 RD |
226 | |
227 | begin | |
f937473f | 228 | -- Locate the implicit access parameter in the called function |
02822a92 | 229 | |
f937473f | 230 | Obj_Acc_Formal := Build_In_Place_Formal (Function_Id, BIP_Object_Access); |
02822a92 | 231 | |
f937473f RD |
232 | -- If no return object is provided, then pass null |
233 | ||
234 | if not Present (Return_Object) then | |
235 | Obj_Address := Make_Null (Loc); | |
7888a6ae | 236 | Set_Parent (Obj_Address, Function_Call); |
02822a92 | 237 | |
f937473f RD |
238 | -- If Return_Object is already an expression of an access type, then use |
239 | -- it directly, since it must be an access value denoting the return | |
240 | -- object, and couldn't possibly be the return object itself. | |
241 | ||
242 | elsif Is_Access then | |
243 | Obj_Address := Return_Object; | |
7888a6ae | 244 | Set_Parent (Obj_Address, Function_Call); |
02822a92 RD |
245 | |
246 | -- Apply Unrestricted_Access to caller's return object | |
247 | ||
f937473f RD |
248 | else |
249 | Obj_Address := | |
250 | Make_Attribute_Reference (Loc, | |
251 | Prefix => Return_Object, | |
252 | Attribute_Name => Name_Unrestricted_Access); | |
7888a6ae GD |
253 | |
254 | Set_Parent (Return_Object, Obj_Address); | |
255 | Set_Parent (Obj_Address, Function_Call); | |
f937473f | 256 | end if; |
02822a92 RD |
257 | |
258 | Analyze_And_Resolve (Obj_Address, Etype (Obj_Acc_Formal)); | |
259 | ||
260 | -- Build the parameter association for the new actual and add it to the | |
261 | -- end of the function's actuals. | |
262 | ||
f937473f RD |
263 | Add_Extra_Actual_To_Call (Function_Call, Obj_Acc_Formal, Obj_Address); |
264 | end Add_Access_Actual_To_Build_In_Place_Call; | |
265 | ||
3e7302c3 | 266 | ------------------------------------------------------ |
200b7162 | 267 | -- Add_Unconstrained_Actuals_To_Build_In_Place_Call -- |
3e7302c3 | 268 | ------------------------------------------------------ |
f937473f | 269 | |
200b7162 | 270 | procedure Add_Unconstrained_Actuals_To_Build_In_Place_Call |
f937473f RD |
271 | (Function_Call : Node_Id; |
272 | Function_Id : Entity_Id; | |
273 | Alloc_Form : BIP_Allocation_Form := Unspecified; | |
200b7162 BD |
274 | Alloc_Form_Exp : Node_Id := Empty; |
275 | Pool_Actual : Node_Id := Make_Null (No_Location)) | |
f937473f RD |
276 | is |
277 | Loc : constant Source_Ptr := Sloc (Function_Call); | |
278 | Alloc_Form_Actual : Node_Id; | |
279 | Alloc_Form_Formal : Node_Id; | |
200b7162 | 280 | Pool_Formal : Node_Id; |
f937473f RD |
281 | |
282 | begin | |
7888a6ae GD |
283 | -- The allocation form generally doesn't need to be passed in the case |
284 | -- of a constrained result subtype, since normally the caller performs | |
285 | -- the allocation in that case. However this formal is still needed in | |
286 | -- the case where the function has a tagged result, because generally | |
287 | -- such functions can be called in a dispatching context and such calls | |
288 | -- must be handled like calls to class-wide functions. | |
289 | ||
290 | if Is_Constrained (Underlying_Type (Etype (Function_Id))) | |
291 | and then not Is_Tagged_Type (Underlying_Type (Etype (Function_Id))) | |
292 | then | |
293 | return; | |
294 | end if; | |
295 | ||
f937473f RD |
296 | -- Locate the implicit allocation form parameter in the called function. |
297 | -- Maybe it would be better for each implicit formal of a build-in-place | |
298 | -- function to have a flag or a Uint attribute to identify it. ??? | |
299 | ||
300 | Alloc_Form_Formal := Build_In_Place_Formal (Function_Id, BIP_Alloc_Form); | |
301 | ||
302 | if Present (Alloc_Form_Exp) then | |
303 | pragma Assert (Alloc_Form = Unspecified); | |
304 | ||
305 | Alloc_Form_Actual := Alloc_Form_Exp; | |
306 | ||
307 | else | |
308 | pragma Assert (Alloc_Form /= Unspecified); | |
309 | ||
310 | Alloc_Form_Actual := | |
311 | Make_Integer_Literal (Loc, | |
312 | Intval => UI_From_Int (BIP_Allocation_Form'Pos (Alloc_Form))); | |
313 | end if; | |
314 | ||
315 | Analyze_And_Resolve (Alloc_Form_Actual, Etype (Alloc_Form_Formal)); | |
316 | ||
317 | -- Build the parameter association for the new actual and add it to the | |
318 | -- end of the function's actuals. | |
319 | ||
320 | Add_Extra_Actual_To_Call | |
321 | (Function_Call, Alloc_Form_Formal, Alloc_Form_Actual); | |
200b7162 | 322 | |
ea10ca9c | 323 | -- Pass the Storage_Pool parameter. This parameter is omitted on |
3e452820 | 324 | -- .NET/JVM/ZFP as those targets do not support pools. |
200b7162 | 325 | |
ea10ca9c AC |
326 | if VM_Target = No_VM |
327 | and then RTE_Available (RE_Root_Storage_Pool_Ptr) | |
3e452820 | 328 | then |
8417f4b2 AC |
329 | Pool_Formal := Build_In_Place_Formal (Function_Id, BIP_Storage_Pool); |
330 | Analyze_And_Resolve (Pool_Actual, Etype (Pool_Formal)); | |
331 | Add_Extra_Actual_To_Call | |
332 | (Function_Call, Pool_Formal, Pool_Actual); | |
333 | end if; | |
200b7162 | 334 | end Add_Unconstrained_Actuals_To_Build_In_Place_Call; |
f937473f | 335 | |
d3f70b35 AC |
336 | ----------------------------------------------------------- |
337 | -- Add_Finalization_Master_Actual_To_Build_In_Place_Call -- | |
338 | ----------------------------------------------------------- | |
df3e68b1 | 339 | |
d3f70b35 | 340 | procedure Add_Finalization_Master_Actual_To_Build_In_Place_Call |
2c17ca0a AC |
341 | (Func_Call : Node_Id; |
342 | Func_Id : Entity_Id; | |
343 | Ptr_Typ : Entity_Id := Empty; | |
344 | Master_Exp : Node_Id := Empty) | |
df3e68b1 HK |
345 | is |
346 | begin | |
d3f70b35 | 347 | if not Needs_BIP_Finalization_Master (Func_Id) then |
df3e68b1 HK |
348 | return; |
349 | end if; | |
350 | ||
351 | declare | |
352 | Formal : constant Entity_Id := | |
d3f70b35 | 353 | Build_In_Place_Formal (Func_Id, BIP_Finalization_Master); |
df3e68b1 HK |
354 | Loc : constant Source_Ptr := Sloc (Func_Call); |
355 | ||
356 | Actual : Node_Id; | |
357 | Desig_Typ : Entity_Id; | |
358 | ||
359 | begin | |
2c17ca0a AC |
360 | -- If there is a finalization master actual, such as the implicit |
361 | -- finalization master of an enclosing build-in-place function, | |
362 | -- then this must be added as an extra actual of the call. | |
363 | ||
364 | if Present (Master_Exp) then | |
365 | Actual := Master_Exp; | |
366 | ||
d3f70b35 | 367 | -- Case where the context does not require an actual master |
df3e68b1 | 368 | |
2c17ca0a | 369 | elsif No (Ptr_Typ) then |
df3e68b1 HK |
370 | Actual := Make_Null (Loc); |
371 | ||
372 | else | |
373 | Desig_Typ := Directly_Designated_Type (Ptr_Typ); | |
374 | ||
375 | -- Check for a library-level access type whose designated type has | |
d3f70b35 | 376 | -- supressed finalization. Such an access types lack a master. |
df3e68b1 | 377 | -- Pass a null actual to the callee in order to signal a missing |
d3f70b35 | 378 | -- master. |
df3e68b1 HK |
379 | |
380 | if Is_Library_Level_Entity (Ptr_Typ) | |
381 | and then Finalize_Storage_Only (Desig_Typ) | |
382 | then | |
383 | Actual := Make_Null (Loc); | |
384 | ||
385 | -- Types in need of finalization actions | |
386 | ||
387 | elsif Needs_Finalization (Desig_Typ) then | |
388 | ||
d3f70b35 AC |
389 | -- The general mechanism of creating finalization masters for |
390 | -- anonymous access types is disabled by default, otherwise | |
391 | -- finalization masters will pop all over the place. Such types | |
392 | -- use context-specific masters. | |
df3e68b1 HK |
393 | |
394 | if Ekind (Ptr_Typ) = E_Anonymous_Access_Type | |
d3f70b35 | 395 | and then No (Finalization_Master (Ptr_Typ)) |
df3e68b1 | 396 | then |
d3f70b35 | 397 | Build_Finalization_Master |
df3e68b1 HK |
398 | (Typ => Ptr_Typ, |
399 | Ins_Node => Associated_Node_For_Itype (Ptr_Typ), | |
400 | Encl_Scope => Scope (Ptr_Typ)); | |
401 | end if; | |
402 | ||
d3f70b35 | 403 | -- Access-to-controlled types should always have a master |
df3e68b1 | 404 | |
d3f70b35 | 405 | pragma Assert (Present (Finalization_Master (Ptr_Typ))); |
df3e68b1 HK |
406 | |
407 | Actual := | |
408 | Make_Attribute_Reference (Loc, | |
409 | Prefix => | |
d3f70b35 | 410 | New_Reference_To (Finalization_Master (Ptr_Typ), Loc), |
df3e68b1 HK |
411 | Attribute_Name => Name_Unrestricted_Access); |
412 | ||
413 | -- Tagged types | |
414 | ||
415 | else | |
416 | Actual := Make_Null (Loc); | |
417 | end if; | |
418 | end if; | |
419 | ||
420 | Analyze_And_Resolve (Actual, Etype (Formal)); | |
421 | ||
422 | -- Build the parameter association for the new actual and add it to | |
423 | -- the end of the function's actuals. | |
424 | ||
425 | Add_Extra_Actual_To_Call (Func_Call, Formal, Actual); | |
426 | end; | |
d3f70b35 | 427 | end Add_Finalization_Master_Actual_To_Build_In_Place_Call; |
df3e68b1 | 428 | |
f937473f RD |
429 | ------------------------------ |
430 | -- Add_Extra_Actual_To_Call -- | |
431 | ------------------------------ | |
432 | ||
433 | procedure Add_Extra_Actual_To_Call | |
434 | (Subprogram_Call : Node_Id; | |
435 | Extra_Formal : Entity_Id; | |
436 | Extra_Actual : Node_Id) | |
437 | is | |
438 | Loc : constant Source_Ptr := Sloc (Subprogram_Call); | |
439 | Param_Assoc : Node_Id; | |
440 | ||
441 | begin | |
02822a92 RD |
442 | Param_Assoc := |
443 | Make_Parameter_Association (Loc, | |
f937473f RD |
444 | Selector_Name => New_Occurrence_Of (Extra_Formal, Loc), |
445 | Explicit_Actual_Parameter => Extra_Actual); | |
02822a92 | 446 | |
f937473f RD |
447 | Set_Parent (Param_Assoc, Subprogram_Call); |
448 | Set_Parent (Extra_Actual, Param_Assoc); | |
02822a92 | 449 | |
f937473f RD |
450 | if Present (Parameter_Associations (Subprogram_Call)) then |
451 | if Nkind (Last (Parameter_Associations (Subprogram_Call))) = | |
02822a92 RD |
452 | N_Parameter_Association |
453 | then | |
f937473f RD |
454 | |
455 | -- Find last named actual, and append | |
456 | ||
457 | declare | |
458 | L : Node_Id; | |
459 | begin | |
460 | L := First_Actual (Subprogram_Call); | |
461 | while Present (L) loop | |
462 | if No (Next_Actual (L)) then | |
463 | Set_Next_Named_Actual (Parent (L), Extra_Actual); | |
464 | exit; | |
465 | end if; | |
466 | Next_Actual (L); | |
467 | end loop; | |
468 | end; | |
469 | ||
02822a92 | 470 | else |
f937473f | 471 | Set_First_Named_Actual (Subprogram_Call, Extra_Actual); |
02822a92 RD |
472 | end if; |
473 | ||
f937473f | 474 | Append (Param_Assoc, To => Parameter_Associations (Subprogram_Call)); |
02822a92 RD |
475 | |
476 | else | |
f937473f RD |
477 | Set_Parameter_Associations (Subprogram_Call, New_List (Param_Assoc)); |
478 | Set_First_Named_Actual (Subprogram_Call, Extra_Actual); | |
02822a92 | 479 | end if; |
f937473f RD |
480 | end Add_Extra_Actual_To_Call; |
481 | ||
f937473f RD |
482 | --------------------------------------------- |
483 | -- Add_Task_Actuals_To_Build_In_Place_Call -- | |
484 | --------------------------------------------- | |
485 | ||
486 | procedure Add_Task_Actuals_To_Build_In_Place_Call | |
487 | (Function_Call : Node_Id; | |
488 | Function_Id : Entity_Id; | |
489 | Master_Actual : Node_Id) | |
f937473f | 490 | is |
af89615f AC |
491 | Loc : constant Source_Ptr := Sloc (Function_Call); |
492 | Result_Subt : constant Entity_Id := | |
493 | Available_View (Etype (Function_Id)); | |
494 | Actual : Node_Id; | |
495 | Chain_Actual : Node_Id; | |
496 | Chain_Formal : Node_Id; | |
497 | Master_Formal : Node_Id; | |
6dfc5592 | 498 | |
f937473f RD |
499 | begin |
500 | -- No such extra parameters are needed if there are no tasks | |
501 | ||
1a36a0cd | 502 | if not Has_Task (Result_Subt) then |
f937473f RD |
503 | return; |
504 | end if; | |
505 | ||
af89615f AC |
506 | Actual := Master_Actual; |
507 | ||
44bf8eb0 AC |
508 | -- Use a dummy _master actual in case of No_Task_Hierarchy |
509 | ||
510 | if Restriction_Active (No_Task_Hierarchy) then | |
511 | Actual := New_Occurrence_Of (RTE (RE_Library_Task_Level), Loc); | |
94bbf008 AC |
512 | |
513 | -- In the case where we use the master associated with an access type, | |
514 | -- the actual is an entity and requires an explicit reference. | |
515 | ||
516 | elsif Nkind (Actual) = N_Defining_Identifier then | |
517 | Actual := New_Reference_To (Actual, Loc); | |
44bf8eb0 AC |
518 | end if; |
519 | ||
af89615f | 520 | -- Locate the implicit master parameter in the called function |
f937473f | 521 | |
af89615f AC |
522 | Master_Formal := Build_In_Place_Formal (Function_Id, BIP_Task_Master); |
523 | Analyze_And_Resolve (Actual, Etype (Master_Formal)); | |
f937473f | 524 | |
af89615f AC |
525 | -- Build the parameter association for the new actual and add it to the |
526 | -- end of the function's actuals. | |
f937473f | 527 | |
af89615f | 528 | Add_Extra_Actual_To_Call (Function_Call, Master_Formal, Actual); |
75a64833 | 529 | |
af89615f | 530 | -- Locate the implicit activation chain parameter in the called function |
f937473f | 531 | |
af89615f AC |
532 | Chain_Formal := |
533 | Build_In_Place_Formal (Function_Id, BIP_Activation_Chain); | |
f937473f | 534 | |
af89615f | 535 | -- Create the actual which is a pointer to the current activation chain |
f937473f | 536 | |
af89615f AC |
537 | Chain_Actual := |
538 | Make_Attribute_Reference (Loc, | |
539 | Prefix => Make_Identifier (Loc, Name_uChain), | |
540 | Attribute_Name => Name_Unrestricted_Access); | |
f937473f | 541 | |
af89615f | 542 | Analyze_And_Resolve (Chain_Actual, Etype (Chain_Formal)); |
f937473f | 543 | |
af89615f AC |
544 | -- Build the parameter association for the new actual and add it to the |
545 | -- end of the function's actuals. | |
f937473f | 546 | |
af89615f | 547 | Add_Extra_Actual_To_Call (Function_Call, Chain_Formal, Chain_Actual); |
f937473f RD |
548 | end Add_Task_Actuals_To_Build_In_Place_Call; |
549 | ||
550 | ----------------------- | |
551 | -- BIP_Formal_Suffix -- | |
552 | ----------------------- | |
553 | ||
554 | function BIP_Formal_Suffix (Kind : BIP_Formal_Kind) return String is | |
555 | begin | |
556 | case Kind is | |
d3f70b35 | 557 | when BIP_Alloc_Form => |
f937473f | 558 | return "BIPalloc"; |
af89615f | 559 | when BIP_Storage_Pool => |
200b7162 | 560 | return "BIPstoragepool"; |
d3f70b35 AC |
561 | when BIP_Finalization_Master => |
562 | return "BIPfinalizationmaster"; | |
af89615f AC |
563 | when BIP_Task_Master => |
564 | return "BIPtaskmaster"; | |
d3f70b35 | 565 | when BIP_Activation_Chain => |
f937473f | 566 | return "BIPactivationchain"; |
d3f70b35 | 567 | when BIP_Object_Access => |
f937473f RD |
568 | return "BIPaccess"; |
569 | end case; | |
570 | end BIP_Formal_Suffix; | |
571 | ||
572 | --------------------------- | |
573 | -- Build_In_Place_Formal -- | |
574 | --------------------------- | |
575 | ||
576 | function Build_In_Place_Formal | |
577 | (Func : Entity_Id; | |
578 | Kind : BIP_Formal_Kind) return Entity_Id | |
579 | is | |
af89615f AC |
580 | Formal_Name : constant Name_Id := |
581 | New_External_Name | |
582 | (Chars (Func), BIP_Formal_Suffix (Kind)); | |
f937473f RD |
583 | Extra_Formal : Entity_Id := Extra_Formals (Func); |
584 | ||
585 | begin | |
586 | -- Maybe it would be better for each implicit formal of a build-in-place | |
587 | -- function to have a flag or a Uint attribute to identify it. ??? | |
588 | ||
0d566e01 ES |
589 | -- The return type in the function declaration may have been a limited |
590 | -- view, and the extra formals for the function were not generated at | |
aeae67ed | 591 | -- that point. At the point of call the full view must be available and |
0d566e01 ES |
592 | -- the extra formals can be created. |
593 | ||
594 | if No (Extra_Formal) then | |
595 | Create_Extra_Formals (Func); | |
596 | Extra_Formal := Extra_Formals (Func); | |
597 | end if; | |
598 | ||
f937473f | 599 | loop |
19590d70 | 600 | pragma Assert (Present (Extra_Formal)); |
af89615f AC |
601 | exit when Chars (Extra_Formal) = Formal_Name; |
602 | ||
f937473f RD |
603 | Next_Formal_With_Extras (Extra_Formal); |
604 | end loop; | |
605 | ||
f937473f RD |
606 | return Extra_Formal; |
607 | end Build_In_Place_Formal; | |
02822a92 | 608 | |
c9a4817d RD |
609 | -------------------------------- |
610 | -- Check_Overriding_Operation -- | |
611 | -------------------------------- | |
70482933 RK |
612 | |
613 | procedure Check_Overriding_Operation (Subp : Entity_Id) is | |
614 | Typ : constant Entity_Id := Find_Dispatching_Type (Subp); | |
615 | Op_List : constant Elist_Id := Primitive_Operations (Typ); | |
616 | Op_Elmt : Elmt_Id; | |
617 | Prim_Op : Entity_Id; | |
618 | Par_Op : Entity_Id; | |
619 | ||
620 | begin | |
621 | if Is_Derived_Type (Typ) | |
622 | and then not Is_Private_Type (Typ) | |
623 | and then In_Open_Scopes (Scope (Etype (Typ))) | |
d347f572 | 624 | and then Is_Base_Type (Typ) |
70482933 | 625 | then |
2f1b20a9 ES |
626 | -- Subp overrides an inherited private operation if there is an |
627 | -- inherited operation with a different name than Subp (see | |
628 | -- Derive_Subprogram) whose Alias is a hidden subprogram with the | |
629 | -- same name as Subp. | |
70482933 RK |
630 | |
631 | Op_Elmt := First_Elmt (Op_List); | |
632 | while Present (Op_Elmt) loop | |
633 | Prim_Op := Node (Op_Elmt); | |
634 | Par_Op := Alias (Prim_Op); | |
635 | ||
636 | if Present (Par_Op) | |
637 | and then not Comes_From_Source (Prim_Op) | |
638 | and then Chars (Prim_Op) /= Chars (Par_Op) | |
639 | and then Chars (Par_Op) = Chars (Subp) | |
640 | and then Is_Hidden (Par_Op) | |
641 | and then Type_Conformant (Prim_Op, Subp) | |
642 | then | |
643 | Set_DT_Position (Subp, DT_Position (Prim_Op)); | |
644 | end if; | |
645 | ||
646 | Next_Elmt (Op_Elmt); | |
647 | end loop; | |
648 | end if; | |
649 | end Check_Overriding_Operation; | |
650 | ||
651 | ------------------------------- | |
652 | -- Detect_Infinite_Recursion -- | |
653 | ------------------------------- | |
654 | ||
655 | procedure Detect_Infinite_Recursion (N : Node_Id; Spec : Entity_Id) is | |
656 | Loc : constant Source_Ptr := Sloc (N); | |
657 | ||
fbf5a39b | 658 | Var_List : constant Elist_Id := New_Elmt_List; |
70482933 RK |
659 | -- List of globals referenced by body of procedure |
660 | ||
fbf5a39b | 661 | Call_List : constant Elist_Id := New_Elmt_List; |
70482933 RK |
662 | -- List of recursive calls in body of procedure |
663 | ||
fbf5a39b | 664 | Shad_List : constant Elist_Id := New_Elmt_List; |
2f1b20a9 ES |
665 | -- List of entity id's for entities created to capture the value of |
666 | -- referenced globals on entry to the procedure. | |
70482933 RK |
667 | |
668 | Scop : constant Uint := Scope_Depth (Spec); | |
2f1b20a9 ES |
669 | -- This is used to record the scope depth of the current procedure, so |
670 | -- that we can identify global references. | |
70482933 RK |
671 | |
672 | Max_Vars : constant := 4; | |
673 | -- Do not test more than four global variables | |
674 | ||
675 | Count_Vars : Natural := 0; | |
676 | -- Count variables found so far | |
677 | ||
678 | Var : Entity_Id; | |
679 | Elm : Elmt_Id; | |
680 | Ent : Entity_Id; | |
681 | Call : Elmt_Id; | |
682 | Decl : Node_Id; | |
683 | Test : Node_Id; | |
684 | Elm1 : Elmt_Id; | |
685 | Elm2 : Elmt_Id; | |
686 | Last : Node_Id; | |
687 | ||
688 | function Process (Nod : Node_Id) return Traverse_Result; | |
689 | -- Function to traverse the subprogram body (using Traverse_Func) | |
690 | ||
691 | ------------- | |
692 | -- Process -- | |
693 | ------------- | |
694 | ||
695 | function Process (Nod : Node_Id) return Traverse_Result is | |
696 | begin | |
697 | -- Procedure call | |
698 | ||
699 | if Nkind (Nod) = N_Procedure_Call_Statement then | |
700 | ||
701 | -- Case of one of the detected recursive calls | |
702 | ||
703 | if Is_Entity_Name (Name (Nod)) | |
704 | and then Has_Recursive_Call (Entity (Name (Nod))) | |
705 | and then Entity (Name (Nod)) = Spec | |
706 | then | |
707 | Append_Elmt (Nod, Call_List); | |
708 | return Skip; | |
709 | ||
710 | -- Any other procedure call may have side effects | |
711 | ||
712 | else | |
713 | return Abandon; | |
714 | end if; | |
715 | ||
716 | -- A call to a pure function can always be ignored | |
717 | ||
718 | elsif Nkind (Nod) = N_Function_Call | |
719 | and then Is_Entity_Name (Name (Nod)) | |
720 | and then Is_Pure (Entity (Name (Nod))) | |
721 | then | |
722 | return Skip; | |
723 | ||
724 | -- Case of an identifier reference | |
725 | ||
726 | elsif Nkind (Nod) = N_Identifier then | |
727 | Ent := Entity (Nod); | |
728 | ||
729 | -- If no entity, then ignore the reference | |
730 | ||
731 | -- Not clear why this can happen. To investigate, remove this | |
732 | -- test and look at the crash that occurs here in 3401-004 ??? | |
733 | ||
734 | if No (Ent) then | |
735 | return Skip; | |
736 | ||
737 | -- Ignore entities with no Scope, again not clear how this | |
738 | -- can happen, to investigate, look at 4108-008 ??? | |
739 | ||
740 | elsif No (Scope (Ent)) then | |
741 | return Skip; | |
742 | ||
743 | -- Ignore the reference if not to a more global object | |
744 | ||
745 | elsif Scope_Depth (Scope (Ent)) >= Scop then | |
746 | return Skip; | |
747 | ||
748 | -- References to types, exceptions and constants are always OK | |
749 | ||
750 | elsif Is_Type (Ent) | |
751 | or else Ekind (Ent) = E_Exception | |
752 | or else Ekind (Ent) = E_Constant | |
753 | then | |
754 | return Skip; | |
755 | ||
756 | -- If other than a non-volatile scalar variable, we have some | |
757 | -- kind of global reference (e.g. to a function) that we cannot | |
758 | -- deal with so we forget the attempt. | |
759 | ||
760 | elsif Ekind (Ent) /= E_Variable | |
761 | or else not Is_Scalar_Type (Etype (Ent)) | |
fbf5a39b | 762 | or else Treat_As_Volatile (Ent) |
70482933 RK |
763 | then |
764 | return Abandon; | |
765 | ||
766 | -- Otherwise we have a reference to a global scalar | |
767 | ||
768 | else | |
769 | -- Loop through global entities already detected | |
770 | ||
771 | Elm := First_Elmt (Var_List); | |
772 | loop | |
773 | -- If not detected before, record this new global reference | |
774 | ||
775 | if No (Elm) then | |
776 | Count_Vars := Count_Vars + 1; | |
777 | ||
778 | if Count_Vars <= Max_Vars then | |
779 | Append_Elmt (Entity (Nod), Var_List); | |
780 | else | |
781 | return Abandon; | |
782 | end if; | |
783 | ||
784 | exit; | |
785 | ||
786 | -- If recorded before, ignore | |
787 | ||
788 | elsif Node (Elm) = Entity (Nod) then | |
789 | return Skip; | |
790 | ||
791 | -- Otherwise keep looking | |
792 | ||
793 | else | |
794 | Next_Elmt (Elm); | |
795 | end if; | |
796 | end loop; | |
797 | ||
798 | return Skip; | |
799 | end if; | |
800 | ||
801 | -- For all other node kinds, recursively visit syntactic children | |
802 | ||
803 | else | |
804 | return OK; | |
805 | end if; | |
806 | end Process; | |
807 | ||
02822a92 | 808 | function Traverse_Body is new Traverse_Func (Process); |
70482933 RK |
809 | |
810 | -- Start of processing for Detect_Infinite_Recursion | |
811 | ||
812 | begin | |
2f1b20a9 ES |
813 | -- Do not attempt detection in No_Implicit_Conditional mode, since we |
814 | -- won't be able to generate the code to handle the recursion in any | |
815 | -- case. | |
70482933 | 816 | |
6e937c1c | 817 | if Restriction_Active (No_Implicit_Conditionals) then |
70482933 RK |
818 | return; |
819 | end if; | |
820 | ||
821 | -- Otherwise do traversal and quit if we get abandon signal | |
822 | ||
823 | if Traverse_Body (N) = Abandon then | |
824 | return; | |
825 | ||
2f1b20a9 ES |
826 | -- We must have a call, since Has_Recursive_Call was set. If not just |
827 | -- ignore (this is only an error check, so if we have a funny situation, | |
a90bd866 | 828 | -- due to bugs or errors, we do not want to bomb). |
70482933 RK |
829 | |
830 | elsif Is_Empty_Elmt_List (Call_List) then | |
831 | return; | |
832 | end if; | |
833 | ||
834 | -- Here is the case where we detect recursion at compile time | |
835 | ||
2f1b20a9 ES |
836 | -- Push our current scope for analyzing the declarations and code that |
837 | -- we will insert for the checking. | |
70482933 | 838 | |
7888a6ae | 839 | Push_Scope (Spec); |
70482933 | 840 | |
2f1b20a9 ES |
841 | -- This loop builds temporary variables for each of the referenced |
842 | -- globals, so that at the end of the loop the list Shad_List contains | |
843 | -- these temporaries in one-to-one correspondence with the elements in | |
844 | -- Var_List. | |
70482933 RK |
845 | |
846 | Last := Empty; | |
847 | Elm := First_Elmt (Var_List); | |
848 | while Present (Elm) loop | |
849 | Var := Node (Elm); | |
c12beea0 | 850 | Ent := Make_Temporary (Loc, 'S'); |
70482933 RK |
851 | Append_Elmt (Ent, Shad_List); |
852 | ||
2f1b20a9 ES |
853 | -- Insert a declaration for this temporary at the start of the |
854 | -- declarations for the procedure. The temporaries are declared as | |
855 | -- constant objects initialized to the current values of the | |
856 | -- corresponding temporaries. | |
70482933 RK |
857 | |
858 | Decl := | |
859 | Make_Object_Declaration (Loc, | |
860 | Defining_Identifier => Ent, | |
861 | Object_Definition => New_Occurrence_Of (Etype (Var), Loc), | |
862 | Constant_Present => True, | |
863 | Expression => New_Occurrence_Of (Var, Loc)); | |
864 | ||
865 | if No (Last) then | |
866 | Prepend (Decl, Declarations (N)); | |
867 | else | |
868 | Insert_After (Last, Decl); | |
869 | end if; | |
870 | ||
871 | Last := Decl; | |
872 | Analyze (Decl); | |
873 | Next_Elmt (Elm); | |
874 | end loop; | |
875 | ||
876 | -- Loop through calls | |
877 | ||
878 | Call := First_Elmt (Call_List); | |
879 | while Present (Call) loop | |
880 | ||
881 | -- Build a predicate expression of the form | |
882 | ||
883 | -- True | |
884 | -- and then global1 = temp1 | |
885 | -- and then global2 = temp2 | |
886 | -- ... | |
887 | ||
888 | -- This predicate determines if any of the global values | |
889 | -- referenced by the procedure have changed since the | |
890 | -- current call, if not an infinite recursion is assured. | |
891 | ||
892 | Test := New_Occurrence_Of (Standard_True, Loc); | |
893 | ||
894 | Elm1 := First_Elmt (Var_List); | |
895 | Elm2 := First_Elmt (Shad_List); | |
896 | while Present (Elm1) loop | |
897 | Test := | |
898 | Make_And_Then (Loc, | |
899 | Left_Opnd => Test, | |
900 | Right_Opnd => | |
901 | Make_Op_Eq (Loc, | |
902 | Left_Opnd => New_Occurrence_Of (Node (Elm1), Loc), | |
903 | Right_Opnd => New_Occurrence_Of (Node (Elm2), Loc))); | |
904 | ||
905 | Next_Elmt (Elm1); | |
906 | Next_Elmt (Elm2); | |
907 | end loop; | |
908 | ||
909 | -- Now we replace the call with the sequence | |
910 | ||
911 | -- if no-changes (see above) then | |
912 | -- raise Storage_Error; | |
913 | -- else | |
914 | -- original-call | |
915 | -- end if; | |
916 | ||
917 | Rewrite (Node (Call), | |
918 | Make_If_Statement (Loc, | |
919 | Condition => Test, | |
920 | Then_Statements => New_List ( | |
07fc65c4 GB |
921 | Make_Raise_Storage_Error (Loc, |
922 | Reason => SE_Infinite_Recursion)), | |
70482933 RK |
923 | |
924 | Else_Statements => New_List ( | |
925 | Relocate_Node (Node (Call))))); | |
926 | ||
927 | Analyze (Node (Call)); | |
928 | ||
929 | Next_Elmt (Call); | |
930 | end loop; | |
931 | ||
932 | -- Remove temporary scope stack entry used for analysis | |
933 | ||
934 | Pop_Scope; | |
935 | end Detect_Infinite_Recursion; | |
936 | ||
937 | -------------------- | |
938 | -- Expand_Actuals -- | |
939 | -------------------- | |
940 | ||
941 | procedure Expand_Actuals (N : Node_Id; Subp : Entity_Id) is | |
942 | Loc : constant Source_Ptr := Sloc (N); | |
943 | Actual : Node_Id; | |
944 | Formal : Entity_Id; | |
945 | N_Node : Node_Id; | |
946 | Post_Call : List_Id; | |
f6820c2d | 947 | E_Actual : Entity_Id; |
70482933 RK |
948 | E_Formal : Entity_Id; |
949 | ||
950 | procedure Add_Call_By_Copy_Code; | |
fbf5a39b AC |
951 | -- For cases where the parameter must be passed by copy, this routine |
952 | -- generates a temporary variable into which the actual is copied and | |
953 | -- then passes this as the parameter. For an OUT or IN OUT parameter, | |
954 | -- an assignment is also generated to copy the result back. The call | |
955 | -- also takes care of any constraint checks required for the type | |
956 | -- conversion case (on both the way in and the way out). | |
70482933 | 957 | |
f44fe430 RD |
958 | procedure Add_Simple_Call_By_Copy_Code; |
959 | -- This is similar to the above, but is used in cases where we know | |
960 | -- that all that is needed is to simply create a temporary and copy | |
961 | -- the value in and out of the temporary. | |
70482933 RK |
962 | |
963 | procedure Check_Fortran_Logical; | |
964 | -- A value of type Logical that is passed through a formal parameter | |
965 | -- must be normalized because .TRUE. usually does not have the same | |
966 | -- representation as True. We assume that .FALSE. = False = 0. | |
967 | -- What about functions that return a logical type ??? | |
968 | ||
758c442c GD |
969 | function Is_Legal_Copy return Boolean; |
970 | -- Check that an actual can be copied before generating the temporary | |
971 | -- to be used in the call. If the actual is of a by_reference type then | |
972 | -- the program is illegal (this can only happen in the presence of | |
973 | -- rep. clauses that force an incorrect alignment). If the formal is | |
974 | -- a by_reference parameter imposed by a DEC pragma, emit a warning to | |
975 | -- the effect that this might lead to unaligned arguments. | |
976 | ||
70482933 RK |
977 | function Make_Var (Actual : Node_Id) return Entity_Id; |
978 | -- Returns an entity that refers to the given actual parameter, | |
979 | -- Actual (not including any type conversion). If Actual is an | |
980 | -- entity name, then this entity is returned unchanged, otherwise | |
981 | -- a renaming is created to provide an entity for the actual. | |
982 | ||
983 | procedure Reset_Packed_Prefix; | |
984 | -- The expansion of a packed array component reference is delayed in | |
985 | -- the context of a call. Now we need to complete the expansion, so we | |
986 | -- unmark the analyzed bits in all prefixes. | |
987 | ||
988 | --------------------------- | |
989 | -- Add_Call_By_Copy_Code -- | |
990 | --------------------------- | |
991 | ||
992 | procedure Add_Call_By_Copy_Code is | |
cc335f43 AC |
993 | Expr : Node_Id; |
994 | Init : Node_Id; | |
995 | Temp : Entity_Id; | |
f44fe430 | 996 | Indic : Node_Id; |
cc335f43 | 997 | Var : Entity_Id; |
0da2c8ac | 998 | F_Typ : constant Entity_Id := Etype (Formal); |
cc335f43 AC |
999 | V_Typ : Entity_Id; |
1000 | Crep : Boolean; | |
70482933 RK |
1001 | |
1002 | begin | |
758c442c GD |
1003 | if not Is_Legal_Copy then |
1004 | return; | |
1005 | end if; | |
1006 | ||
b086849e | 1007 | Temp := Make_Temporary (Loc, 'T', Actual); |
70482933 | 1008 | |
f44fe430 RD |
1009 | -- Use formal type for temp, unless formal type is an unconstrained |
1010 | -- array, in which case we don't have to worry about bounds checks, | |
758c442c | 1011 | -- and we use the actual type, since that has appropriate bounds. |
f44fe430 RD |
1012 | |
1013 | if Is_Array_Type (F_Typ) and then not Is_Constrained (F_Typ) then | |
1014 | Indic := New_Occurrence_Of (Etype (Actual), Loc); | |
1015 | else | |
1016 | Indic := New_Occurrence_Of (Etype (Formal), Loc); | |
1017 | end if; | |
1018 | ||
70482933 RK |
1019 | if Nkind (Actual) = N_Type_Conversion then |
1020 | V_Typ := Etype (Expression (Actual)); | |
19f0526a AC |
1021 | |
1022 | -- If the formal is an (in-)out parameter, capture the name | |
1023 | -- of the variable in order to build the post-call assignment. | |
81a5b587 AC |
1024 | |
1025 | Var := Make_Var (Expression (Actual)); | |
19f0526a | 1026 | |
08aa9a4a | 1027 | Crep := not Same_Representation |
0da2c8ac | 1028 | (F_Typ, Etype (Expression (Actual))); |
08aa9a4a | 1029 | |
70482933 RK |
1030 | else |
1031 | V_Typ := Etype (Actual); | |
1032 | Var := Make_Var (Actual); | |
1033 | Crep := False; | |
1034 | end if; | |
1035 | ||
1036 | -- Setup initialization for case of in out parameter, or an out | |
1037 | -- parameter where the formal is an unconstrained array (in the | |
1038 | -- latter case, we have to pass in an object with bounds). | |
1039 | ||
cc335f43 AC |
1040 | -- If this is an out parameter, the initial copy is wasteful, so as |
1041 | -- an optimization for the one-dimensional case we extract the | |
1042 | -- bounds of the actual and build an uninitialized temporary of the | |
1043 | -- right size. | |
1044 | ||
70482933 | 1045 | if Ekind (Formal) = E_In_Out_Parameter |
0da2c8ac | 1046 | or else (Is_Array_Type (F_Typ) and then not Is_Constrained (F_Typ)) |
70482933 RK |
1047 | then |
1048 | if Nkind (Actual) = N_Type_Conversion then | |
1049 | if Conversion_OK (Actual) then | |
0da2c8ac | 1050 | Init := OK_Convert_To (F_Typ, New_Occurrence_Of (Var, Loc)); |
70482933 | 1051 | else |
0da2c8ac | 1052 | Init := Convert_To (F_Typ, New_Occurrence_Of (Var, Loc)); |
70482933 | 1053 | end if; |
cc335f43 AC |
1054 | |
1055 | elsif Ekind (Formal) = E_Out_Parameter | |
0da2c8ac AC |
1056 | and then Is_Array_Type (F_Typ) |
1057 | and then Number_Dimensions (F_Typ) = 1 | |
1058 | and then not Has_Non_Null_Base_Init_Proc (F_Typ) | |
cc335f43 AC |
1059 | then |
1060 | -- Actual is a one-dimensional array or slice, and the type | |
1061 | -- requires no initialization. Create a temporary of the | |
f44fe430 | 1062 | -- right size, but do not copy actual into it (optimization). |
cc335f43 AC |
1063 | |
1064 | Init := Empty; | |
1065 | Indic := | |
1066 | Make_Subtype_Indication (Loc, | |
1067 | Subtype_Mark => | |
0da2c8ac | 1068 | New_Occurrence_Of (F_Typ, Loc), |
cc335f43 AC |
1069 | Constraint => |
1070 | Make_Index_Or_Discriminant_Constraint (Loc, | |
1071 | Constraints => New_List ( | |
1072 | Make_Range (Loc, | |
1073 | Low_Bound => | |
1074 | Make_Attribute_Reference (Loc, | |
1075 | Prefix => New_Occurrence_Of (Var, Loc), | |
70f91180 | 1076 | Attribute_Name => Name_First), |
cc335f43 AC |
1077 | High_Bound => |
1078 | Make_Attribute_Reference (Loc, | |
1079 | Prefix => New_Occurrence_Of (Var, Loc), | |
1080 | Attribute_Name => Name_Last))))); | |
1081 | ||
70482933 RK |
1082 | else |
1083 | Init := New_Occurrence_Of (Var, Loc); | |
1084 | end if; | |
1085 | ||
1086 | -- An initialization is created for packed conversions as | |
1087 | -- actuals for out parameters to enable Make_Object_Declaration | |
1088 | -- to determine the proper subtype for N_Node. Note that this | |
1089 | -- is wasteful because the extra copying on the call side is | |
1090 | -- not required for such out parameters. ??? | |
1091 | ||
1092 | elsif Ekind (Formal) = E_Out_Parameter | |
1093 | and then Nkind (Actual) = N_Type_Conversion | |
0da2c8ac | 1094 | and then (Is_Bit_Packed_Array (F_Typ) |
70482933 RK |
1095 | or else |
1096 | Is_Bit_Packed_Array (Etype (Expression (Actual)))) | |
1097 | then | |
1098 | if Conversion_OK (Actual) then | |
f44fe430 | 1099 | Init := OK_Convert_To (F_Typ, New_Occurrence_Of (Var, Loc)); |
70482933 | 1100 | else |
f44fe430 | 1101 | Init := Convert_To (F_Typ, New_Occurrence_Of (Var, Loc)); |
70482933 | 1102 | end if; |
2e071734 AC |
1103 | |
1104 | elsif Ekind (Formal) = E_In_Parameter then | |
02822a92 RD |
1105 | |
1106 | -- Handle the case in which the actual is a type conversion | |
1107 | ||
1108 | if Nkind (Actual) = N_Type_Conversion then | |
1109 | if Conversion_OK (Actual) then | |
1110 | Init := OK_Convert_To (F_Typ, New_Occurrence_Of (Var, Loc)); | |
1111 | else | |
1112 | Init := Convert_To (F_Typ, New_Occurrence_Of (Var, Loc)); | |
1113 | end if; | |
1114 | else | |
1115 | Init := New_Occurrence_Of (Var, Loc); | |
1116 | end if; | |
2e071734 | 1117 | |
70482933 RK |
1118 | else |
1119 | Init := Empty; | |
1120 | end if; | |
1121 | ||
1122 | N_Node := | |
1123 | Make_Object_Declaration (Loc, | |
1124 | Defining_Identifier => Temp, | |
cc335f43 | 1125 | Object_Definition => Indic, |
f44fe430 | 1126 | Expression => Init); |
70482933 RK |
1127 | Set_Assignment_OK (N_Node); |
1128 | Insert_Action (N, N_Node); | |
1129 | ||
1130 | -- Now, normally the deal here is that we use the defining | |
1131 | -- identifier created by that object declaration. There is | |
1132 | -- one exception to this. In the change of representation case | |
1133 | -- the above declaration will end up looking like: | |
1134 | ||
1135 | -- temp : type := identifier; | |
1136 | ||
1137 | -- And in this case we might as well use the identifier directly | |
1138 | -- and eliminate the temporary. Note that the analysis of the | |
1139 | -- declaration was not a waste of time in that case, since it is | |
1140 | -- what generated the necessary change of representation code. If | |
1141 | -- the change of representation introduced additional code, as in | |
1142 | -- a fixed-integer conversion, the expression is not an identifier | |
1143 | -- and must be kept. | |
1144 | ||
1145 | if Crep | |
1146 | and then Present (Expression (N_Node)) | |
1147 | and then Is_Entity_Name (Expression (N_Node)) | |
1148 | then | |
1149 | Temp := Entity (Expression (N_Node)); | |
1150 | Rewrite (N_Node, Make_Null_Statement (Loc)); | |
1151 | end if; | |
1152 | ||
fbf5a39b | 1153 | -- For IN parameter, all we do is to replace the actual |
70482933 | 1154 | |
fbf5a39b AC |
1155 | if Ekind (Formal) = E_In_Parameter then |
1156 | Rewrite (Actual, New_Reference_To (Temp, Loc)); | |
1157 | Analyze (Actual); | |
1158 | ||
1159 | -- Processing for OUT or IN OUT parameter | |
1160 | ||
1161 | else | |
c8ef728f ES |
1162 | -- Kill current value indications for the temporary variable we |
1163 | -- created, since we just passed it as an OUT parameter. | |
1164 | ||
1165 | Kill_Current_Values (Temp); | |
75ba322d | 1166 | Set_Is_Known_Valid (Temp, False); |
c8ef728f | 1167 | |
fbf5a39b AC |
1168 | -- If type conversion, use reverse conversion on exit |
1169 | ||
1170 | if Nkind (Actual) = N_Type_Conversion then | |
1171 | if Conversion_OK (Actual) then | |
1172 | Expr := OK_Convert_To (V_Typ, New_Occurrence_Of (Temp, Loc)); | |
1173 | else | |
1174 | Expr := Convert_To (V_Typ, New_Occurrence_Of (Temp, Loc)); | |
1175 | end if; | |
70482933 | 1176 | else |
fbf5a39b | 1177 | Expr := New_Occurrence_Of (Temp, Loc); |
70482933 | 1178 | end if; |
70482933 | 1179 | |
fbf5a39b AC |
1180 | Rewrite (Actual, New_Reference_To (Temp, Loc)); |
1181 | Analyze (Actual); | |
70482933 | 1182 | |
d766cee3 RD |
1183 | -- If the actual is a conversion of a packed reference, it may |
1184 | -- already have been expanded by Remove_Side_Effects, and the | |
1185 | -- resulting variable is a temporary which does not designate | |
1186 | -- the proper out-parameter, which may not be addressable. In | |
1187 | -- that case, generate an assignment to the original expression | |
b0159fbe | 1188 | -- (before expansion of the packed reference) so that the proper |
d766cee3 | 1189 | -- expansion of assignment to a packed component can take place. |
70482933 | 1190 | |
d766cee3 RD |
1191 | declare |
1192 | Obj : Node_Id; | |
1193 | Lhs : Node_Id; | |
1194 | ||
1195 | begin | |
1196 | if Is_Renaming_Of_Object (Var) | |
1197 | and then Nkind (Renamed_Object (Var)) = N_Selected_Component | |
1198 | and then Is_Entity_Name (Prefix (Renamed_Object (Var))) | |
1199 | and then Nkind (Original_Node (Prefix (Renamed_Object (Var)))) | |
1200 | = N_Indexed_Component | |
1201 | and then | |
1202 | Has_Non_Standard_Rep (Etype (Prefix (Renamed_Object (Var)))) | |
1203 | then | |
1204 | Obj := Renamed_Object (Var); | |
1205 | Lhs := | |
1206 | Make_Selected_Component (Loc, | |
1207 | Prefix => | |
1208 | New_Copy_Tree (Original_Node (Prefix (Obj))), | |
1209 | Selector_Name => New_Copy (Selector_Name (Obj))); | |
1210 | Reset_Analyzed_Flags (Lhs); | |
1211 | ||
1212 | else | |
1213 | Lhs := New_Occurrence_Of (Var, Loc); | |
1214 | end if; | |
1215 | ||
1216 | Set_Assignment_OK (Lhs); | |
1217 | ||
d15f9422 AC |
1218 | if Is_Access_Type (E_Formal) |
1219 | and then Is_Entity_Name (Lhs) | |
996c8821 RD |
1220 | and then |
1221 | Present (Effective_Extra_Accessibility (Entity (Lhs))) | |
d15f9422 | 1222 | then |
4bb43ffb AC |
1223 | -- Copyback target is an Ada 2012 stand-alone object of an |
1224 | -- anonymous access type. | |
d15f9422 AC |
1225 | |
1226 | pragma Assert (Ada_Version >= Ada_2012); | |
1227 | ||
1228 | if Type_Access_Level (E_Formal) > | |
996c8821 RD |
1229 | Object_Access_Level (Lhs) |
1230 | then | |
1231 | Append_To (Post_Call, | |
1232 | Make_Raise_Program_Error (Loc, | |
1233 | Reason => PE_Accessibility_Check_Failed)); | |
d15f9422 AC |
1234 | end if; |
1235 | ||
1236 | Append_To (Post_Call, | |
1237 | Make_Assignment_Statement (Loc, | |
1238 | Name => Lhs, | |
1239 | Expression => Expr)); | |
1240 | ||
996c8821 RD |
1241 | -- We would like to somehow suppress generation of the |
1242 | -- extra_accessibility assignment generated by the expansion | |
1243 | -- of the above assignment statement. It's not a correctness | |
1244 | -- issue because the following assignment renders it dead, | |
1245 | -- but generating back-to-back assignments to the same | |
1246 | -- target is undesirable. ??? | |
d15f9422 AC |
1247 | |
1248 | Append_To (Post_Call, | |
1249 | Make_Assignment_Statement (Loc, | |
1250 | Name => New_Occurrence_Of ( | |
1251 | Effective_Extra_Accessibility (Entity (Lhs)), Loc), | |
1252 | Expression => Make_Integer_Literal (Loc, | |
1253 | Type_Access_Level (E_Formal)))); | |
996c8821 | 1254 | |
d15f9422 AC |
1255 | else |
1256 | Append_To (Post_Call, | |
1257 | Make_Assignment_Statement (Loc, | |
1258 | Name => Lhs, | |
1259 | Expression => Expr)); | |
1260 | end if; | |
d766cee3 | 1261 | end; |
fbf5a39b | 1262 | end if; |
70482933 RK |
1263 | end Add_Call_By_Copy_Code; |
1264 | ||
1265 | ---------------------------------- | |
f44fe430 | 1266 | -- Add_Simple_Call_By_Copy_Code -- |
70482933 RK |
1267 | ---------------------------------- |
1268 | ||
f44fe430 | 1269 | procedure Add_Simple_Call_By_Copy_Code is |
70482933 | 1270 | Temp : Entity_Id; |
758c442c | 1271 | Decl : Node_Id; |
70482933 RK |
1272 | Incod : Node_Id; |
1273 | Outcod : Node_Id; | |
1274 | Lhs : Node_Id; | |
1275 | Rhs : Node_Id; | |
f44fe430 RD |
1276 | Indic : Node_Id; |
1277 | F_Typ : constant Entity_Id := Etype (Formal); | |
70482933 RK |
1278 | |
1279 | begin | |
758c442c GD |
1280 | if not Is_Legal_Copy then |
1281 | return; | |
1282 | end if; | |
1283 | ||
f44fe430 RD |
1284 | -- Use formal type for temp, unless formal type is an unconstrained |
1285 | -- array, in which case we don't have to worry about bounds checks, | |
758c442c | 1286 | -- and we use the actual type, since that has appropriate bounds. |
f44fe430 RD |
1287 | |
1288 | if Is_Array_Type (F_Typ) and then not Is_Constrained (F_Typ) then | |
1289 | Indic := New_Occurrence_Of (Etype (Actual), Loc); | |
1290 | else | |
1291 | Indic := New_Occurrence_Of (Etype (Formal), Loc); | |
1292 | end if; | |
70482933 RK |
1293 | |
1294 | -- Prepare to generate code | |
1295 | ||
f44fe430 RD |
1296 | Reset_Packed_Prefix; |
1297 | ||
b086849e | 1298 | Temp := Make_Temporary (Loc, 'T', Actual); |
70482933 RK |
1299 | Incod := Relocate_Node (Actual); |
1300 | Outcod := New_Copy_Tree (Incod); | |
1301 | ||
1302 | -- Generate declaration of temporary variable, initializing it | |
c73ae90f | 1303 | -- with the input parameter unless we have an OUT formal or |
758c442c | 1304 | -- this is an initialization call. |
70482933 | 1305 | |
c73ae90f GD |
1306 | -- If the formal is an out parameter with discriminants, the |
1307 | -- discriminants must be captured even if the rest of the object | |
1308 | -- is in principle uninitialized, because the discriminants may | |
1309 | -- be read by the called subprogram. | |
1310 | ||
70482933 RK |
1311 | if Ekind (Formal) = E_Out_Parameter then |
1312 | Incod := Empty; | |
758c442c | 1313 | |
c73ae90f GD |
1314 | if Has_Discriminants (Etype (Formal)) then |
1315 | Indic := New_Occurrence_Of (Etype (Actual), Loc); | |
1316 | end if; | |
1317 | ||
758c442c | 1318 | elsif Inside_Init_Proc then |
c73ae90f GD |
1319 | |
1320 | -- Could use a comment here to match comment below ??? | |
1321 | ||
758c442c GD |
1322 | if Nkind (Actual) /= N_Selected_Component |
1323 | or else | |
1324 | not Has_Discriminant_Dependent_Constraint | |
1325 | (Entity (Selector_Name (Actual))) | |
1326 | then | |
1327 | Incod := Empty; | |
1328 | ||
c73ae90f GD |
1329 | -- Otherwise, keep the component in order to generate the proper |
1330 | -- actual subtype, that depends on enclosing discriminants. | |
758c442c | 1331 | |
c73ae90f | 1332 | else |
758c442c GD |
1333 | null; |
1334 | end if; | |
70482933 RK |
1335 | end if; |
1336 | ||
758c442c | 1337 | Decl := |
70482933 RK |
1338 | Make_Object_Declaration (Loc, |
1339 | Defining_Identifier => Temp, | |
f44fe430 | 1340 | Object_Definition => Indic, |
758c442c GD |
1341 | Expression => Incod); |
1342 | ||
1343 | if Inside_Init_Proc | |
1344 | and then No (Incod) | |
1345 | then | |
1346 | -- If the call is to initialize a component of a composite type, | |
1347 | -- and the component does not depend on discriminants, use the | |
1348 | -- actual type of the component. This is required in case the | |
1349 | -- component is constrained, because in general the formal of the | |
1350 | -- initialization procedure will be unconstrained. Note that if | |
1351 | -- the component being initialized is constrained by an enclosing | |
1352 | -- discriminant, the presence of the initialization in the | |
1353 | -- declaration will generate an expression for the actual subtype. | |
1354 | ||
1355 | Set_No_Initialization (Decl); | |
1356 | Set_Object_Definition (Decl, | |
1357 | New_Occurrence_Of (Etype (Actual), Loc)); | |
1358 | end if; | |
1359 | ||
1360 | Insert_Action (N, Decl); | |
70482933 RK |
1361 | |
1362 | -- The actual is simply a reference to the temporary | |
1363 | ||
1364 | Rewrite (Actual, New_Occurrence_Of (Temp, Loc)); | |
1365 | ||
1366 | -- Generate copy out if OUT or IN OUT parameter | |
1367 | ||
1368 | if Ekind (Formal) /= E_In_Parameter then | |
1369 | Lhs := Outcod; | |
1370 | Rhs := New_Occurrence_Of (Temp, Loc); | |
1371 | ||
1372 | -- Deal with conversion | |
1373 | ||
1374 | if Nkind (Lhs) = N_Type_Conversion then | |
1375 | Lhs := Expression (Lhs); | |
1376 | Rhs := Convert_To (Etype (Actual), Rhs); | |
1377 | end if; | |
1378 | ||
1379 | Append_To (Post_Call, | |
1380 | Make_Assignment_Statement (Loc, | |
1381 | Name => Lhs, | |
1382 | Expression => Rhs)); | |
f44fe430 | 1383 | Set_Assignment_OK (Name (Last (Post_Call))); |
70482933 | 1384 | end if; |
f44fe430 | 1385 | end Add_Simple_Call_By_Copy_Code; |
70482933 RK |
1386 | |
1387 | --------------------------- | |
1388 | -- Check_Fortran_Logical -- | |
1389 | --------------------------- | |
1390 | ||
1391 | procedure Check_Fortran_Logical is | |
fbf5a39b | 1392 | Logical : constant Entity_Id := Etype (Formal); |
70482933 RK |
1393 | Var : Entity_Id; |
1394 | ||
1395 | -- Note: this is very incomplete, e.g. it does not handle arrays | |
1396 | -- of logical values. This is really not the right approach at all???) | |
1397 | ||
1398 | begin | |
1399 | if Convention (Subp) = Convention_Fortran | |
1400 | and then Root_Type (Etype (Formal)) = Standard_Boolean | |
1401 | and then Ekind (Formal) /= E_In_Parameter | |
1402 | then | |
1403 | Var := Make_Var (Actual); | |
1404 | Append_To (Post_Call, | |
1405 | Make_Assignment_Statement (Loc, | |
1406 | Name => New_Occurrence_Of (Var, Loc), | |
1407 | Expression => | |
1408 | Unchecked_Convert_To ( | |
1409 | Logical, | |
1410 | Make_Op_Ne (Loc, | |
1411 | Left_Opnd => New_Occurrence_Of (Var, Loc), | |
1412 | Right_Opnd => | |
1413 | Unchecked_Convert_To ( | |
1414 | Logical, | |
1415 | New_Occurrence_Of (Standard_False, Loc)))))); | |
1416 | end if; | |
1417 | end Check_Fortran_Logical; | |
1418 | ||
758c442c GD |
1419 | ------------------- |
1420 | -- Is_Legal_Copy -- | |
1421 | ------------------- | |
1422 | ||
1423 | function Is_Legal_Copy return Boolean is | |
1424 | begin | |
1425 | -- An attempt to copy a value of such a type can only occur if | |
1426 | -- representation clauses give the actual a misaligned address. | |
1427 | ||
1428 | if Is_By_Reference_Type (Etype (Formal)) then | |
f45ccc7c | 1429 | |
aaf1cd90 RD |
1430 | -- If the front-end does not perform full type layout, the actual |
1431 | -- may in fact be properly aligned but there is not enough front- | |
1432 | -- end information to determine this. In that case gigi will emit | |
1433 | -- an error if a copy is not legal, or generate the proper code. | |
1434 | -- For other backends we report the error now. | |
1435 | ||
1436 | -- Seems wrong to be issuing an error in the expander, since it | |
1437 | -- will be missed in -gnatc mode ??? | |
f45ccc7c AC |
1438 | |
1439 | if Frontend_Layout_On_Target then | |
1440 | Error_Msg_N | |
1441 | ("misaligned actual cannot be passed by reference", Actual); | |
1442 | end if; | |
1443 | ||
758c442c GD |
1444 | return False; |
1445 | ||
1446 | -- For users of Starlet, we assume that the specification of by- | |
7888a6ae | 1447 | -- reference mechanism is mandatory. This may lead to unaligned |
758c442c GD |
1448 | -- objects but at least for DEC legacy code it is known to work. |
1449 | -- The warning will alert users of this code that a problem may | |
1450 | -- be lurking. | |
1451 | ||
1452 | elsif Mechanism (Formal) = By_Reference | |
1453 | and then Is_Valued_Procedure (Scope (Formal)) | |
1454 | then | |
1455 | Error_Msg_N | |
685bc70f | 1456 | ("by_reference actual may be misaligned??", Actual); |
758c442c GD |
1457 | return False; |
1458 | ||
1459 | else | |
1460 | return True; | |
1461 | end if; | |
1462 | end Is_Legal_Copy; | |
1463 | ||
70482933 RK |
1464 | -------------- |
1465 | -- Make_Var -- | |
1466 | -------------- | |
1467 | ||
1468 | function Make_Var (Actual : Node_Id) return Entity_Id is | |
1469 | Var : Entity_Id; | |
1470 | ||
1471 | begin | |
1472 | if Is_Entity_Name (Actual) then | |
1473 | return Entity (Actual); | |
1474 | ||
1475 | else | |
b086849e | 1476 | Var := Make_Temporary (Loc, 'T', Actual); |
70482933 RK |
1477 | |
1478 | N_Node := | |
1479 | Make_Object_Renaming_Declaration (Loc, | |
1480 | Defining_Identifier => Var, | |
1481 | Subtype_Mark => | |
1482 | New_Occurrence_Of (Etype (Actual), Loc), | |
1483 | Name => Relocate_Node (Actual)); | |
1484 | ||
1485 | Insert_Action (N, N_Node); | |
1486 | return Var; | |
1487 | end if; | |
1488 | end Make_Var; | |
1489 | ||
1490 | ------------------------- | |
1491 | -- Reset_Packed_Prefix -- | |
1492 | ------------------------- | |
1493 | ||
1494 | procedure Reset_Packed_Prefix is | |
1495 | Pfx : Node_Id := Actual; | |
70482933 RK |
1496 | begin |
1497 | loop | |
1498 | Set_Analyzed (Pfx, False); | |
ac4d6407 RD |
1499 | exit when |
1500 | not Nkind_In (Pfx, N_Selected_Component, N_Indexed_Component); | |
70482933 RK |
1501 | Pfx := Prefix (Pfx); |
1502 | end loop; | |
1503 | end Reset_Packed_Prefix; | |
1504 | ||
1505 | -- Start of processing for Expand_Actuals | |
1506 | ||
1507 | begin | |
70482933 RK |
1508 | Post_Call := New_List; |
1509 | ||
2f1b20a9 ES |
1510 | Formal := First_Formal (Subp); |
1511 | Actual := First_Actual (N); | |
70482933 RK |
1512 | while Present (Formal) loop |
1513 | E_Formal := Etype (Formal); | |
f6820c2d | 1514 | E_Actual := Etype (Actual); |
70482933 RK |
1515 | |
1516 | if Is_Scalar_Type (E_Formal) | |
1517 | or else Nkind (Actual) = N_Slice | |
1518 | then | |
1519 | Check_Fortran_Logical; | |
1520 | ||
1521 | -- RM 6.4.1 (11) | |
1522 | ||
1523 | elsif Ekind (Formal) /= E_Out_Parameter then | |
1524 | ||
1525 | -- The unusual case of the current instance of a protected type | |
1526 | -- requires special handling. This can only occur in the context | |
1527 | -- of a call within the body of a protected operation. | |
1528 | ||
1529 | if Is_Entity_Name (Actual) | |
1530 | and then Ekind (Entity (Actual)) = E_Protected_Type | |
1531 | and then In_Open_Scopes (Entity (Actual)) | |
1532 | then | |
1533 | if Scope (Subp) /= Entity (Actual) then | |
685bc70f AC |
1534 | Error_Msg_N |
1535 | ("operation outside protected type may not " | |
1536 | & "call back its protected operations??", Actual); | |
70482933 RK |
1537 | end if; |
1538 | ||
1539 | Rewrite (Actual, | |
1540 | Expand_Protected_Object_Reference (N, Entity (Actual))); | |
1541 | end if; | |
1542 | ||
02822a92 RD |
1543 | -- Ada 2005 (AI-318-02): If the actual parameter is a call to a |
1544 | -- build-in-place function, then a temporary return object needs | |
1545 | -- to be created and access to it must be passed to the function. | |
f937473f RD |
1546 | -- Currently we limit such functions to those with inherently |
1547 | -- limited result subtypes, but eventually we plan to expand the | |
1548 | -- functions that are treated as build-in-place to include other | |
1549 | -- composite result types. | |
02822a92 | 1550 | |
95eb8b69 | 1551 | if Is_Build_In_Place_Function_Call (Actual) then |
02822a92 RD |
1552 | Make_Build_In_Place_Call_In_Anonymous_Context (Actual); |
1553 | end if; | |
1554 | ||
70482933 RK |
1555 | Apply_Constraint_Check (Actual, E_Formal); |
1556 | ||
1557 | -- Out parameter case. No constraint checks on access type | |
1558 | -- RM 6.4.1 (13) | |
1559 | ||
1560 | elsif Is_Access_Type (E_Formal) then | |
1561 | null; | |
1562 | ||
1563 | -- RM 6.4.1 (14) | |
1564 | ||
1565 | elsif Has_Discriminants (Base_Type (E_Formal)) | |
1566 | or else Has_Non_Null_Base_Init_Proc (E_Formal) | |
1567 | then | |
1568 | Apply_Constraint_Check (Actual, E_Formal); | |
1569 | ||
1570 | -- RM 6.4.1 (15) | |
1571 | ||
1572 | else | |
1573 | Apply_Constraint_Check (Actual, Base_Type (E_Formal)); | |
1574 | end if; | |
1575 | ||
1576 | -- Processing for IN-OUT and OUT parameters | |
1577 | ||
1578 | if Ekind (Formal) /= E_In_Parameter then | |
1579 | ||
1580 | -- For type conversions of arrays, apply length/range checks | |
1581 | ||
1582 | if Is_Array_Type (E_Formal) | |
1583 | and then Nkind (Actual) = N_Type_Conversion | |
1584 | then | |
1585 | if Is_Constrained (E_Formal) then | |
1586 | Apply_Length_Check (Expression (Actual), E_Formal); | |
1587 | else | |
1588 | Apply_Range_Check (Expression (Actual), E_Formal); | |
1589 | end if; | |
1590 | end if; | |
1591 | ||
1592 | -- If argument is a type conversion for a type that is passed | |
1593 | -- by copy, then we must pass the parameter by copy. | |
1594 | ||
1595 | if Nkind (Actual) = N_Type_Conversion | |
1596 | and then | |
1597 | (Is_Numeric_Type (E_Formal) | |
1598 | or else Is_Access_Type (E_Formal) | |
1599 | or else Is_Enumeration_Type (E_Formal) | |
1600 | or else Is_Bit_Packed_Array (Etype (Formal)) | |
1601 | or else Is_Bit_Packed_Array (Etype (Expression (Actual))) | |
1602 | ||
1603 | -- Also pass by copy if change of representation | |
1604 | ||
1605 | or else not Same_Representation | |
1606 | (Etype (Formal), | |
1607 | Etype (Expression (Actual)))) | |
1608 | then | |
1609 | Add_Call_By_Copy_Code; | |
1610 | ||
1611 | -- References to components of bit packed arrays are expanded | |
1612 | -- at this point, rather than at the point of analysis of the | |
1613 | -- actuals, to handle the expansion of the assignment to | |
1614 | -- [in] out parameters. | |
1615 | ||
1616 | elsif Is_Ref_To_Bit_Packed_Array (Actual) then | |
f44fe430 RD |
1617 | Add_Simple_Call_By_Copy_Code; |
1618 | ||
02822a92 RD |
1619 | -- If a non-scalar actual is possibly bit-aligned, we need a copy |
1620 | -- because the back-end cannot cope with such objects. In other | |
1621 | -- cases where alignment forces a copy, the back-end generates | |
1622 | -- it properly. It should not be generated unconditionally in the | |
1623 | -- front-end because it does not know precisely the alignment | |
1624 | -- requirements of the target, and makes too conservative an | |
1625 | -- estimate, leading to superfluous copies or spurious errors | |
1626 | -- on by-reference parameters. | |
f44fe430 | 1627 | |
02822a92 RD |
1628 | elsif Nkind (Actual) = N_Selected_Component |
1629 | and then | |
1630 | Component_May_Be_Bit_Aligned (Entity (Selector_Name (Actual))) | |
f44fe430 RD |
1631 | and then not Represented_As_Scalar (Etype (Formal)) |
1632 | then | |
1633 | Add_Simple_Call_By_Copy_Code; | |
70482933 RK |
1634 | |
1635 | -- References to slices of bit packed arrays are expanded | |
1636 | ||
1637 | elsif Is_Ref_To_Bit_Packed_Slice (Actual) then | |
1638 | Add_Call_By_Copy_Code; | |
1639 | ||
fbf5a39b AC |
1640 | -- References to possibly unaligned slices of arrays are expanded |
1641 | ||
1642 | elsif Is_Possibly_Unaligned_Slice (Actual) then | |
1643 | Add_Call_By_Copy_Code; | |
1644 | ||
7888a6ae | 1645 | -- Deal with access types where the actual subtype and the |
70482933 RK |
1646 | -- formal subtype are not the same, requiring a check. |
1647 | ||
638e383e | 1648 | -- It is necessary to exclude tagged types because of "downward |
70f91180 | 1649 | -- conversion" errors. |
70482933 RK |
1650 | |
1651 | elsif Is_Access_Type (E_Formal) | |
f6820c2d | 1652 | and then not Same_Type (E_Formal, E_Actual) |
70482933 RK |
1653 | and then not Is_Tagged_Type (Designated_Type (E_Formal)) |
1654 | then | |
1655 | Add_Call_By_Copy_Code; | |
1656 | ||
faf3cf91 ES |
1657 | -- If the actual is not a scalar and is marked for volatile |
1658 | -- treatment, whereas the formal is not volatile, then pass | |
1659 | -- by copy unless it is a by-reference type. | |
1660 | ||
0386aad1 AC |
1661 | -- Note: we use Is_Volatile here rather than Treat_As_Volatile, |
1662 | -- because this is the enforcement of a language rule that applies | |
1663 | -- only to "real" volatile variables, not e.g. to the address | |
1664 | -- clause overlay case. | |
1665 | ||
70482933 | 1666 | elsif Is_Entity_Name (Actual) |
0386aad1 | 1667 | and then Is_Volatile (Entity (Actual)) |
f6820c2d | 1668 | and then not Is_By_Reference_Type (E_Actual) |
70482933 | 1669 | and then not Is_Scalar_Type (Etype (Entity (Actual))) |
0386aad1 | 1670 | and then not Is_Volatile (E_Formal) |
70482933 RK |
1671 | then |
1672 | Add_Call_By_Copy_Code; | |
1673 | ||
1674 | elsif Nkind (Actual) = N_Indexed_Component | |
1675 | and then Is_Entity_Name (Prefix (Actual)) | |
1676 | and then Has_Volatile_Components (Entity (Prefix (Actual))) | |
1677 | then | |
1678 | Add_Call_By_Copy_Code; | |
d79e621a GD |
1679 | |
1680 | -- Add call-by-copy code for the case of scalar out parameters | |
1681 | -- when it is not known at compile time that the subtype of the | |
c2369146 AC |
1682 | -- formal is a subrange of the subtype of the actual (or vice |
1683 | -- versa for in out parameters), in order to get range checks | |
1684 | -- on such actuals. (Maybe this case should be handled earlier | |
1685 | -- in the if statement???) | |
d79e621a GD |
1686 | |
1687 | elsif Is_Scalar_Type (E_Formal) | |
c2369146 | 1688 | and then |
f6820c2d | 1689 | (not In_Subrange_Of (E_Formal, E_Actual) |
c2369146 AC |
1690 | or else |
1691 | (Ekind (Formal) = E_In_Out_Parameter | |
f6820c2d | 1692 | and then not In_Subrange_Of (E_Actual, E_Formal))) |
d79e621a GD |
1693 | then |
1694 | -- Perhaps the setting back to False should be done within | |
1695 | -- Add_Call_By_Copy_Code, since it could get set on other | |
1696 | -- cases occurring above??? | |
1697 | ||
1698 | if Do_Range_Check (Actual) then | |
1699 | Set_Do_Range_Check (Actual, False); | |
1700 | end if; | |
1701 | ||
1702 | Add_Call_By_Copy_Code; | |
70482933 RK |
1703 | end if; |
1704 | ||
f6820c2d AC |
1705 | -- RM 3.2.4 (23/3) : A predicate is checked on in-out and out |
1706 | -- by-reference parameters on exit from the call. If the actual | |
1707 | -- is a derived type and the operation is inherited, the body | |
1708 | -- of the operation will not contain a call to the predicate | |
1709 | -- function, so it must be done explicitly after the call. Ditto | |
1710 | -- if the actual is an entity of a predicated subtype. | |
1711 | ||
cae64f11 AC |
1712 | -- The rule refers to by-reference types, but a check is needed |
1713 | -- for by-copy types as well. That check is subsumed by the rule | |
1714 | -- for subtype conversion on assignment, but we can generate the | |
1715 | -- required check now. | |
1716 | ||
1717 | -- Note that this is needed only if the subtype of the actual has | |
1718 | -- an explicit predicate aspect, not if it inherits them from a | |
1719 | -- base type or ancestor. The check is also superfluous if the | |
1720 | -- subtype is elaborated before the body of the subprogram, but | |
1721 | -- this is harder to verify, and there may be a redundant check. | |
1722 | ||
dd4e47ab | 1723 | -- Note also that Subp may be either a subprogram entity for |
e93f4e12 AC |
1724 | -- direct calls, or a type entity for indirect calls, which must |
1725 | -- be handled separately because the name does not denote an | |
1726 | -- overloadable entity. | |
dd4e47ab | 1727 | |
e93f4e12 AC |
1728 | -- If the formal is class-wide the corresponding postcondition |
1729 | -- procedure does not include a predicate call, so it has to be | |
1730 | -- generated explicitly. | |
1731 | ||
51597c23 AC |
1732 | if not Is_Init_Proc (Subp) |
1733 | and then (Has_Aspect (E_Actual, Aspect_Predicate) | |
1734 | or else | |
1735 | Has_Aspect (E_Actual, Aspect_Dynamic_Predicate) | |
1736 | or else | |
1737 | Has_Aspect (E_Actual, Aspect_Static_Predicate)) | |
1738 | and then Present (Predicate_Function (E_Actual)) | |
f6820c2d | 1739 | then |
51597c23 AC |
1740 | if Is_Entity_Name (Actual) |
1741 | or else | |
1742 | (Is_Derived_Type (E_Actual) | |
1743 | and then Is_Overloadable (Subp) | |
1744 | and then Is_Inherited_Operation_For_Type (Subp, E_Actual)) | |
f6820c2d | 1745 | then |
2e86f679 RD |
1746 | Append_To (Post_Call, |
1747 | Make_Predicate_Check (E_Actual, Actual)); | |
e93f4e12 AC |
1748 | |
1749 | elsif Is_Class_Wide_Type (E_Formal) | |
1750 | and then not Is_Class_Wide_Type (E_Actual) | |
1751 | then | |
2e86f679 RD |
1752 | Append_To (Post_Call, |
1753 | Make_Predicate_Check (E_Actual, Actual)); | |
f6820c2d AC |
1754 | end if; |
1755 | end if; | |
1756 | ||
fbf5a39b | 1757 | -- Processing for IN parameters |
70482933 RK |
1758 | |
1759 | else | |
fbf5a39b AC |
1760 | -- For IN parameters is in the packed array case, we expand an |
1761 | -- indexed component (the circuit in Exp_Ch4 deliberately left | |
1762 | -- indexed components appearing as actuals untouched, so that | |
1763 | -- the special processing above for the OUT and IN OUT cases | |
1764 | -- could be performed. We could make the test in Exp_Ch4 more | |
1765 | -- complex and have it detect the parameter mode, but it is | |
f44fe430 | 1766 | -- easier simply to handle all cases here.) |
fbf5a39b | 1767 | |
70482933 RK |
1768 | if Nkind (Actual) = N_Indexed_Component |
1769 | and then Is_Packed (Etype (Prefix (Actual))) | |
1770 | then | |
1771 | Reset_Packed_Prefix; | |
1772 | Expand_Packed_Element_Reference (Actual); | |
1773 | ||
0386aad1 AC |
1774 | -- If we have a reference to a bit packed array, we copy it, since |
1775 | -- the actual must be byte aligned. | |
70482933 | 1776 | |
fbf5a39b | 1777 | -- Is this really necessary in all cases??? |
70482933 | 1778 | |
fbf5a39b | 1779 | elsif Is_Ref_To_Bit_Packed_Array (Actual) then |
f44fe430 RD |
1780 | Add_Simple_Call_By_Copy_Code; |
1781 | ||
1782 | -- If a non-scalar actual is possibly unaligned, we need a copy | |
1783 | ||
1784 | elsif Is_Possibly_Unaligned_Object (Actual) | |
1785 | and then not Represented_As_Scalar (Etype (Formal)) | |
1786 | then | |
1787 | Add_Simple_Call_By_Copy_Code; | |
70482933 | 1788 | |
fbf5a39b AC |
1789 | -- Similarly, we have to expand slices of packed arrays here |
1790 | -- because the result must be byte aligned. | |
70482933 | 1791 | |
fbf5a39b AC |
1792 | elsif Is_Ref_To_Bit_Packed_Slice (Actual) then |
1793 | Add_Call_By_Copy_Code; | |
70482933 | 1794 | |
fbf5a39b AC |
1795 | -- Only processing remaining is to pass by copy if this is a |
1796 | -- reference to a possibly unaligned slice, since the caller | |
1797 | -- expects an appropriately aligned argument. | |
70482933 | 1798 | |
fbf5a39b AC |
1799 | elsif Is_Possibly_Unaligned_Slice (Actual) then |
1800 | Add_Call_By_Copy_Code; | |
fb468a94 AC |
1801 | |
1802 | -- An unusual case: a current instance of an enclosing task can be | |
1803 | -- an actual, and must be replaced by a reference to self. | |
1804 | ||
1805 | elsif Is_Entity_Name (Actual) | |
1806 | and then Is_Task_Type (Entity (Actual)) | |
1807 | then | |
1808 | if In_Open_Scopes (Entity (Actual)) then | |
1809 | Rewrite (Actual, | |
1810 | (Make_Function_Call (Loc, | |
1811 | Name => New_Reference_To (RTE (RE_Self), Loc)))); | |
1812 | Analyze (Actual); | |
1813 | ||
1814 | -- A task type cannot otherwise appear as an actual | |
1815 | ||
1816 | else | |
1817 | raise Program_Error; | |
1818 | end if; | |
70482933 RK |
1819 | end if; |
1820 | end if; | |
1821 | ||
1822 | Next_Formal (Formal); | |
1823 | Next_Actual (Actual); | |
1824 | end loop; | |
1825 | ||
1826 | -- Find right place to put post call stuff if it is present | |
1827 | ||
1828 | if not Is_Empty_List (Post_Call) then | |
1829 | ||
bdf69d33 | 1830 | -- Cases where the call is not a member of a statement list |
70482933 RK |
1831 | |
1832 | if not Is_List_Member (N) then | |
1833 | declare | |
bdf69d33 | 1834 | P : Node_Id := Parent (N); |
70482933 RK |
1835 | |
1836 | begin | |
bdf69d33 AC |
1837 | -- In Ada 2012 the call may be a function call in an expression |
1838 | -- (since OUT and IN OUT parameters are now allowed for such | |
1839 | -- calls. The write-back of (in)-out parameters is handled | |
1840 | -- by the back-end, but the constraint checks generated when | |
1841 | -- subtypes of formal and actual don't match must be inserted | |
1842 | -- in the form of assignments, at the nearest point after the | |
1843 | -- declaration or statement that contains the call. | |
1844 | ||
1845 | if Ada_Version >= Ada_2012 | |
1846 | and then Nkind (N) = N_Function_Call | |
1847 | then | |
1848 | while Nkind (P) not in N_Declaration | |
1849 | and then | |
1850 | Nkind (P) not in N_Statement_Other_Than_Procedure_Call | |
1851 | loop | |
1852 | P := Parent (P); | |
1853 | end loop; | |
1854 | ||
1855 | Insert_Actions_After (P, Post_Call); | |
1856 | ||
1857 | -- If not the special Ada 2012 case of a function call, then | |
1858 | -- we must have the triggering statement of a triggering | |
1859 | -- alternative or an entry call alternative, and we can add | |
1860 | -- the post call stuff to the corresponding statement list. | |
70482933 | 1861 | |
70482933 | 1862 | else |
bdf69d33 AC |
1863 | pragma Assert (Nkind_In (P, N_Triggering_Alternative, |
1864 | N_Entry_Call_Alternative)); | |
1865 | ||
1866 | if Is_Non_Empty_List (Statements (P)) then | |
1867 | Insert_List_Before_And_Analyze | |
1868 | (First (Statements (P)), Post_Call); | |
1869 | else | |
1870 | Set_Statements (P, Post_Call); | |
1871 | end if; | |
70482933 | 1872 | end if; |
bdf69d33 | 1873 | |
70482933 RK |
1874 | end; |
1875 | ||
1876 | -- Otherwise, normal case where N is in a statement sequence, | |
1877 | -- just put the post-call stuff after the call statement. | |
1878 | ||
1879 | else | |
1880 | Insert_Actions_After (N, Post_Call); | |
1881 | end if; | |
1882 | end if; | |
1883 | ||
98f01d53 | 1884 | -- The call node itself is re-analyzed in Expand_Call |
70482933 RK |
1885 | |
1886 | end Expand_Actuals; | |
1887 | ||
1888 | ----------------- | |
1889 | -- Expand_Call -- | |
1890 | ----------------- | |
1891 | ||
1892 | -- This procedure handles expansion of function calls and procedure call | |
1893 | -- statements (i.e. it serves as the body for Expand_N_Function_Call and | |
70f91180 | 1894 | -- Expand_N_Procedure_Call_Statement). Processing for calls includes: |
70482933 | 1895 | |
70f91180 | 1896 | -- Replace call to Raise_Exception by Raise_Exception_Always if possible |
70482933 RK |
1897 | -- Provide values of actuals for all formals in Extra_Formals list |
1898 | -- Replace "call" to enumeration literal function by literal itself | |
1899 | -- Rewrite call to predefined operator as operator | |
1900 | -- Replace actuals to in-out parameters that are numeric conversions, | |
1901 | -- with explicit assignment to temporaries before and after the call. | |
1902 | -- Remove optional actuals if First_Optional_Parameter specified. | |
1903 | ||
1904 | -- Note that the list of actuals has been filled with default expressions | |
1905 | -- during semantic analysis of the call. Only the extra actuals required | |
1906 | -- for the 'Constrained attribute and for accessibility checks are added | |
1907 | -- at this point. | |
1908 | ||
1909 | procedure Expand_Call (N : Node_Id) is | |
1910 | Loc : constant Source_Ptr := Sloc (N); | |
6dfc5592 | 1911 | Call_Node : Node_Id := N; |
70482933 | 1912 | Extra_Actuals : List_Id := No_List; |
fdce4bb7 | 1913 | Prev : Node_Id := Empty; |
758c442c | 1914 | |
70482933 RK |
1915 | procedure Add_Actual_Parameter (Insert_Param : Node_Id); |
1916 | -- Adds one entry to the end of the actual parameter list. Used for | |
2f1b20a9 ES |
1917 | -- default parameters and for extra actuals (for Extra_Formals). The |
1918 | -- argument is an N_Parameter_Association node. | |
70482933 RK |
1919 | |
1920 | procedure Add_Extra_Actual (Expr : Node_Id; EF : Entity_Id); | |
2f1b20a9 ES |
1921 | -- Adds an extra actual to the list of extra actuals. Expr is the |
1922 | -- expression for the value of the actual, EF is the entity for the | |
1923 | -- extra formal. | |
70482933 | 1924 | |
84f4072a JM |
1925 | procedure Do_Inline (Subp : Entity_Id; Orig_Subp : Entity_Id); |
1926 | -- Check and inline the body of Subp. Invoked when compiling with | |
1927 | -- optimizations enabled and Subp has pragma inline or inline always. | |
1928 | -- If the subprogram is a renaming, or if it is inherited, then Subp | |
1929 | -- references the renamed entity and Orig_Subp is the entity of the | |
1930 | -- call node N. | |
1931 | ||
1932 | procedure Do_Inline_Always (Subp : Entity_Id; Orig_Subp : Entity_Id); | |
1933 | -- Check and inline the body of Subp. Invoked when compiling without | |
1934 | -- optimizations and Subp has pragma inline always. If the subprogram is | |
1935 | -- a renaming, or if it is inherited, then Subp references the renamed | |
1936 | -- entity and Orig_Subp is the entity of the call node N. | |
1937 | ||
70482933 RK |
1938 | function Inherited_From_Formal (S : Entity_Id) return Entity_Id; |
1939 | -- Within an instance, a type derived from a non-tagged formal derived | |
70f91180 RD |
1940 | -- type inherits from the original parent, not from the actual. The |
1941 | -- current derivation mechanism has the derived type inherit from the | |
1942 | -- actual, which is only correct outside of the instance. If the | |
1943 | -- subprogram is inherited, we test for this particular case through a | |
1944 | -- convoluted tree traversal before setting the proper subprogram to be | |
1945 | -- called. | |
70482933 | 1946 | |
84f4072a JM |
1947 | function In_Unfrozen_Instance (E : Entity_Id) return Boolean; |
1948 | -- Return true if E comes from an instance that is not yet frozen | |
1949 | ||
df3e68b1 | 1950 | function Is_Direct_Deep_Call (Subp : Entity_Id) return Boolean; |
2c1b72d7 | 1951 | -- Determine if Subp denotes a non-dispatching call to a Deep routine |
df3e68b1 | 1952 | |
dd386db0 AC |
1953 | function New_Value (From : Node_Id) return Node_Id; |
1954 | -- From is the original Expression. New_Value is equivalent to a call | |
1955 | -- to Duplicate_Subexpr with an explicit dereference when From is an | |
1956 | -- access parameter. | |
1957 | ||
70482933 RK |
1958 | -------------------------- |
1959 | -- Add_Actual_Parameter -- | |
1960 | -------------------------- | |
1961 | ||
1962 | procedure Add_Actual_Parameter (Insert_Param : Node_Id) is | |
1963 | Actual_Expr : constant Node_Id := | |
1964 | Explicit_Actual_Parameter (Insert_Param); | |
1965 | ||
1966 | begin | |
1967 | -- Case of insertion is first named actual | |
1968 | ||
1969 | if No (Prev) or else | |
1970 | Nkind (Parent (Prev)) /= N_Parameter_Association | |
1971 | then | |
6dfc5592 RD |
1972 | Set_Next_Named_Actual |
1973 | (Insert_Param, First_Named_Actual (Call_Node)); | |
1974 | Set_First_Named_Actual (Call_Node, Actual_Expr); | |
70482933 RK |
1975 | |
1976 | if No (Prev) then | |
6dfc5592 RD |
1977 | if No (Parameter_Associations (Call_Node)) then |
1978 | Set_Parameter_Associations (Call_Node, New_List); | |
70482933 | 1979 | end if; |
57a3fca9 AC |
1980 | |
1981 | Append (Insert_Param, Parameter_Associations (Call_Node)); | |
1982 | ||
70482933 RK |
1983 | else |
1984 | Insert_After (Prev, Insert_Param); | |
1985 | end if; | |
1986 | ||
1987 | -- Case of insertion is not first named actual | |
1988 | ||
1989 | else | |
1990 | Set_Next_Named_Actual | |
1991 | (Insert_Param, Next_Named_Actual (Parent (Prev))); | |
1992 | Set_Next_Named_Actual (Parent (Prev), Actual_Expr); | |
6dfc5592 | 1993 | Append (Insert_Param, Parameter_Associations (Call_Node)); |
70482933 RK |
1994 | end if; |
1995 | ||
1996 | Prev := Actual_Expr; | |
1997 | end Add_Actual_Parameter; | |
1998 | ||
1999 | ---------------------- | |
2000 | -- Add_Extra_Actual -- | |
2001 | ---------------------- | |
2002 | ||
2003 | procedure Add_Extra_Actual (Expr : Node_Id; EF : Entity_Id) is | |
2004 | Loc : constant Source_Ptr := Sloc (Expr); | |
2005 | ||
2006 | begin | |
2007 | if Extra_Actuals = No_List then | |
2008 | Extra_Actuals := New_List; | |
6dfc5592 | 2009 | Set_Parent (Extra_Actuals, Call_Node); |
70482933 RK |
2010 | end if; |
2011 | ||
2012 | Append_To (Extra_Actuals, | |
2013 | Make_Parameter_Association (Loc, | |
9d983bbf AC |
2014 | Selector_Name => Make_Identifier (Loc, Chars (EF)), |
2015 | Explicit_Actual_Parameter => Expr)); | |
70482933 RK |
2016 | |
2017 | Analyze_And_Resolve (Expr, Etype (EF)); | |
75a64833 | 2018 | |
6dfc5592 | 2019 | if Nkind (Call_Node) = N_Function_Call then |
75a64833 AC |
2020 | Set_Is_Accessibility_Actual (Parent (Expr)); |
2021 | end if; | |
70482933 RK |
2022 | end Add_Extra_Actual; |
2023 | ||
84f4072a JM |
2024 | ---------------- |
2025 | -- Do_Inline -- | |
2026 | ---------------- | |
2027 | ||
2028 | procedure Do_Inline (Subp : Entity_Id; Orig_Subp : Entity_Id) is | |
2029 | Spec : constant Node_Id := Unit_Declaration_Node (Subp); | |
2030 | ||
2031 | procedure Do_Backend_Inline; | |
2032 | -- Check that the call can be safely passed to the backend. If true | |
2033 | -- then register the enclosing unit of Subp to Inlined_Bodies so that | |
2034 | -- the body of Subp can be retrieved and analyzed by the backend. | |
2035 | ||
2036 | procedure Register_Backend_Call (N : Node_Id); | |
2037 | -- Append N to the list Backend_Calls | |
2038 | ||
2039 | ----------------------- | |
2040 | -- Do_Backend_Inline -- | |
2041 | ----------------------- | |
2042 | ||
2043 | procedure Do_Backend_Inline is | |
2044 | begin | |
2045 | -- No extra test needed for init subprograms since we know they | |
a90bd866 | 2046 | -- are available to the backend. |
84f4072a JM |
2047 | |
2048 | if Is_Init_Proc (Subp) then | |
2049 | Add_Inlined_Body (Subp); | |
2050 | Register_Backend_Call (Call_Node); | |
2051 | ||
2052 | -- Verify that if the body to inline is located in the current | |
2053 | -- unit the inlining does not occur earlier. This avoids | |
2054 | -- order-of-elaboration problems in the back end. | |
2055 | ||
2056 | elsif In_Same_Extended_Unit (Call_Node, Subp) | |
2057 | and then Nkind (Spec) = N_Subprogram_Declaration | |
2058 | and then Earlier_In_Extended_Unit | |
2059 | (Loc, Sloc (Body_To_Inline (Spec))) | |
2060 | then | |
2061 | Error_Msg_NE | |
685bc70f | 2062 | ("cannot inline& (body not seen yet)??", Call_Node, Subp); |
84f4072a JM |
2063 | |
2064 | else | |
2065 | declare | |
2066 | Backend_Inline : Boolean := True; | |
2067 | ||
2068 | begin | |
2069 | -- If we are compiling a package body that is not the | |
2070 | -- main unit, it must be for inlining/instantiation | |
2071 | -- purposes, in which case we inline the call to insure | |
2072 | -- that the same temporaries are generated when compiling | |
2073 | -- the body by itself. Otherwise link errors can occur. | |
2074 | ||
2075 | -- If the function being called is itself in the main | |
2076 | -- unit, we cannot inline, because there is a risk of | |
2077 | -- double elaboration and/or circularity: the inlining | |
2078 | -- can make visible a private entity in the body of the | |
2079 | -- main unit, that gigi will see before its sees its | |
2080 | -- proper definition. | |
2081 | ||
2082 | if not (In_Extended_Main_Code_Unit (Call_Node)) | |
2083 | and then In_Package_Body | |
2084 | then | |
2085 | Backend_Inline := | |
2086 | not In_Extended_Main_Source_Unit (Subp); | |
2087 | end if; | |
2088 | ||
2089 | if Backend_Inline then | |
2090 | Add_Inlined_Body (Subp); | |
2091 | Register_Backend_Call (Call_Node); | |
2092 | end if; | |
2093 | end; | |
2094 | end if; | |
2095 | end Do_Backend_Inline; | |
2096 | ||
2097 | --------------------------- | |
2098 | -- Register_Backend_Call -- | |
2099 | --------------------------- | |
2100 | ||
2101 | procedure Register_Backend_Call (N : Node_Id) is | |
2102 | begin | |
2103 | if Backend_Calls = No_Elist then | |
2104 | Backend_Calls := New_Elmt_List; | |
2105 | end if; | |
2106 | ||
2107 | Append_Elmt (N, To => Backend_Calls); | |
2108 | end Register_Backend_Call; | |
2109 | ||
2110 | -- Start of processing for Do_Inline | |
2111 | ||
2112 | begin | |
2113 | -- Verify that the body to inline has already been seen | |
2114 | ||
2115 | if No (Spec) | |
2116 | or else Nkind (Spec) /= N_Subprogram_Declaration | |
2117 | or else No (Body_To_Inline (Spec)) | |
2118 | then | |
2119 | if Comes_From_Source (Subp) | |
2120 | and then Must_Inline (Subp) | |
2121 | then | |
2122 | Cannot_Inline | |
2123 | ("cannot inline& (body not seen yet)?", Call_Node, Subp); | |
2124 | ||
2125 | -- Let the back end handle it | |
2126 | ||
2127 | else | |
2128 | Do_Backend_Inline; | |
2129 | return; | |
2130 | end if; | |
2131 | ||
2132 | -- If this an inherited function that returns a private type, do not | |
2133 | -- inline if the full view is an unconstrained array, because such | |
2134 | -- calls cannot be inlined. | |
2135 | ||
2136 | elsif Present (Orig_Subp) | |
2137 | and then Is_Array_Type (Etype (Orig_Subp)) | |
2138 | and then not Is_Constrained (Etype (Orig_Subp)) | |
2139 | then | |
2140 | Cannot_Inline | |
2141 | ("cannot inline& (unconstrained array)?", Call_Node, Subp); | |
2142 | ||
2143 | else | |
2144 | Expand_Inlined_Call (Call_Node, Subp, Orig_Subp); | |
2145 | end if; | |
2146 | end Do_Inline; | |
2147 | ||
2148 | ---------------------- | |
2149 | -- Do_Inline_Always -- | |
2150 | ---------------------- | |
2151 | ||
2152 | procedure Do_Inline_Always (Subp : Entity_Id; Orig_Subp : Entity_Id) is | |
2153 | Spec : constant Node_Id := Unit_Declaration_Node (Subp); | |
2154 | Body_Id : Entity_Id; | |
2155 | ||
2156 | begin | |
2157 | if No (Spec) | |
2158 | or else Nkind (Spec) /= N_Subprogram_Declaration | |
2159 | or else No (Body_To_Inline (Spec)) | |
2160 | or else Serious_Errors_Detected /= 0 | |
2161 | then | |
2162 | return; | |
2163 | end if; | |
2164 | ||
2165 | Body_Id := Corresponding_Body (Spec); | |
2166 | ||
2167 | -- Verify that the body to inline has already been seen | |
2168 | ||
2169 | if No (Body_Id) | |
2170 | or else not Analyzed (Body_Id) | |
2171 | then | |
2172 | Set_Is_Inlined (Subp, False); | |
2173 | ||
2174 | if Comes_From_Source (Subp) then | |
2175 | ||
2176 | -- Report a warning only if the call is located in the unit of | |
2177 | -- the called subprogram; otherwise it is an error. | |
2178 | ||
2179 | if not In_Same_Extended_Unit (Call_Node, Subp) then | |
2180 | Cannot_Inline | |
685bc70f | 2181 | ("cannot inline& (body not seen yet)?", Call_Node, Subp, |
84f4072a JM |
2182 | Is_Serious => True); |
2183 | ||
2184 | elsif In_Open_Scopes (Subp) then | |
2185 | ||
2186 | -- For backward compatibility we generate the same error | |
2187 | -- or warning of the previous implementation. This will | |
2188 | -- be changed when we definitely incorporate the new | |
2189 | -- support ??? | |
2190 | ||
2191 | if Front_End_Inlining | |
2192 | and then Optimization_Level = 0 | |
2193 | then | |
2194 | Error_Msg_N | |
685bc70f | 2195 | ("call to recursive subprogram cannot be inlined?p?", |
84f4072a JM |
2196 | N); |
2197 | ||
2198 | -- Do not emit error compiling runtime packages | |
2199 | ||
2200 | elsif Is_Predefined_File_Name | |
2201 | (Unit_File_Name (Get_Source_Unit (Subp))) | |
2202 | then | |
2203 | Error_Msg_N | |
685bc70f | 2204 | ("call to recursive subprogram cannot be inlined??", |
84f4072a JM |
2205 | N); |
2206 | ||
2207 | else | |
2208 | Error_Msg_N | |
2209 | ("call to recursive subprogram cannot be inlined", | |
2210 | N); | |
2211 | end if; | |
2212 | ||
2213 | else | |
2214 | Cannot_Inline | |
2215 | ("cannot inline& (body not seen yet)?", Call_Node, Subp); | |
2216 | end if; | |
2217 | end if; | |
2218 | ||
2219 | return; | |
2220 | ||
2221 | -- If this an inherited function that returns a private type, do not | |
2222 | -- inline if the full view is an unconstrained array, because such | |
2223 | -- calls cannot be inlined. | |
2224 | ||
2225 | elsif Present (Orig_Subp) | |
2226 | and then Is_Array_Type (Etype (Orig_Subp)) | |
2227 | and then not Is_Constrained (Etype (Orig_Subp)) | |
2228 | then | |
2229 | Cannot_Inline | |
2230 | ("cannot inline& (unconstrained array)?", Call_Node, Subp); | |
2231 | ||
2232 | -- If the called subprogram comes from an instance in the same | |
2233 | -- unit, and the instance is not yet frozen, inlining might | |
2234 | -- trigger order-of-elaboration problems. | |
2235 | ||
2236 | elsif In_Unfrozen_Instance (Scope (Subp)) then | |
2237 | Cannot_Inline | |
2238 | ("cannot inline& (unfrozen instance)?", Call_Node, Subp); | |
2239 | ||
2240 | else | |
2241 | Expand_Inlined_Call (Call_Node, Subp, Orig_Subp); | |
2242 | end if; | |
2243 | end Do_Inline_Always; | |
2244 | ||
70482933 RK |
2245 | --------------------------- |
2246 | -- Inherited_From_Formal -- | |
2247 | --------------------------- | |
2248 | ||
2249 | function Inherited_From_Formal (S : Entity_Id) return Entity_Id is | |
2250 | Par : Entity_Id; | |
2251 | Gen_Par : Entity_Id; | |
2252 | Gen_Prim : Elist_Id; | |
2253 | Elmt : Elmt_Id; | |
2254 | Indic : Node_Id; | |
2255 | ||
2256 | begin | |
2257 | -- If the operation is inherited, it is attached to the corresponding | |
2258 | -- type derivation. If the parent in the derivation is a generic | |
2259 | -- actual, it is a subtype of the actual, and we have to recover the | |
2260 | -- original derived type declaration to find the proper parent. | |
2261 | ||
2262 | if Nkind (Parent (S)) /= N_Full_Type_Declaration | |
fbf5a39b | 2263 | or else not Is_Derived_Type (Defining_Identifier (Parent (S))) |
2f1b20a9 ES |
2264 | or else Nkind (Type_Definition (Original_Node (Parent (S)))) /= |
2265 | N_Derived_Type_Definition | |
fbf5a39b | 2266 | or else not In_Instance |
70482933 RK |
2267 | then |
2268 | return Empty; | |
2269 | ||
2270 | else | |
2271 | Indic := | |
e27b834b AC |
2272 | Subtype_Indication |
2273 | (Type_Definition (Original_Node (Parent (S)))); | |
70482933 RK |
2274 | |
2275 | if Nkind (Indic) = N_Subtype_Indication then | |
2276 | Par := Entity (Subtype_Mark (Indic)); | |
2277 | else | |
2278 | Par := Entity (Indic); | |
2279 | end if; | |
2280 | end if; | |
2281 | ||
2282 | if not Is_Generic_Actual_Type (Par) | |
2283 | or else Is_Tagged_Type (Par) | |
2284 | or else Nkind (Parent (Par)) /= N_Subtype_Declaration | |
2285 | or else not In_Open_Scopes (Scope (Par)) | |
70482933 RK |
2286 | then |
2287 | return Empty; | |
70482933 RK |
2288 | else |
2289 | Gen_Par := Generic_Parent_Type (Parent (Par)); | |
2290 | end if; | |
2291 | ||
7888a6ae GD |
2292 | -- If the actual has no generic parent type, the formal is not |
2293 | -- a formal derived type, so nothing to inherit. | |
2294 | ||
2295 | if No (Gen_Par) then | |
2296 | return Empty; | |
2297 | end if; | |
2298 | ||
2f1b20a9 ES |
2299 | -- If the generic parent type is still the generic type, this is a |
2300 | -- private formal, not a derived formal, and there are no operations | |
2301 | -- inherited from the formal. | |
fbf5a39b AC |
2302 | |
2303 | if Nkind (Parent (Gen_Par)) = N_Formal_Type_Declaration then | |
2304 | return Empty; | |
2305 | end if; | |
2306 | ||
70482933 | 2307 | Gen_Prim := Collect_Primitive_Operations (Gen_Par); |
70482933 | 2308 | |
2f1b20a9 | 2309 | Elmt := First_Elmt (Gen_Prim); |
70482933 RK |
2310 | while Present (Elmt) loop |
2311 | if Chars (Node (Elmt)) = Chars (S) then | |
2312 | declare | |
2313 | F1 : Entity_Id; | |
2314 | F2 : Entity_Id; | |
70482933 | 2315 | |
2f1b20a9 | 2316 | begin |
70482933 RK |
2317 | F1 := First_Formal (S); |
2318 | F2 := First_Formal (Node (Elmt)); | |
70482933 RK |
2319 | while Present (F1) |
2320 | and then Present (F2) | |
2321 | loop | |
70482933 RK |
2322 | if Etype (F1) = Etype (F2) |
2323 | or else Etype (F2) = Gen_Par | |
2324 | then | |
2325 | Next_Formal (F1); | |
2326 | Next_Formal (F2); | |
2327 | else | |
2328 | Next_Elmt (Elmt); | |
2329 | exit; -- not the right subprogram | |
2330 | end if; | |
2331 | ||
2332 | return Node (Elmt); | |
2333 | end loop; | |
2334 | end; | |
2335 | ||
2336 | else | |
2337 | Next_Elmt (Elmt); | |
2338 | end if; | |
2339 | end loop; | |
2340 | ||
2341 | raise Program_Error; | |
2342 | end Inherited_From_Formal; | |
2343 | ||
84f4072a JM |
2344 | -------------------------- |
2345 | -- In_Unfrozen_Instance -- | |
2346 | -------------------------- | |
2347 | ||
2348 | function In_Unfrozen_Instance (E : Entity_Id) return Boolean is | |
bde73c6b | 2349 | S : Entity_Id; |
84f4072a JM |
2350 | |
2351 | begin | |
bde73c6b AC |
2352 | S := E; |
2353 | while Present (S) and then S /= Standard_Standard loop | |
84f4072a JM |
2354 | if Is_Generic_Instance (S) |
2355 | and then Present (Freeze_Node (S)) | |
2356 | and then not Analyzed (Freeze_Node (S)) | |
2357 | then | |
2358 | return True; | |
2359 | end if; | |
2360 | ||
2361 | S := Scope (S); | |
2362 | end loop; | |
2363 | ||
2364 | return False; | |
2365 | end In_Unfrozen_Instance; | |
2366 | ||
df3e68b1 HK |
2367 | ------------------------- |
2368 | -- Is_Direct_Deep_Call -- | |
2369 | ------------------------- | |
2370 | ||
2371 | function Is_Direct_Deep_Call (Subp : Entity_Id) return Boolean is | |
2372 | begin | |
2373 | if Is_TSS (Subp, TSS_Deep_Adjust) | |
2374 | or else Is_TSS (Subp, TSS_Deep_Finalize) | |
2375 | or else Is_TSS (Subp, TSS_Deep_Initialize) | |
2376 | then | |
2377 | declare | |
2378 | Actual : Node_Id; | |
2379 | Formal : Node_Id; | |
2380 | ||
2381 | begin | |
2382 | Actual := First (Parameter_Associations (N)); | |
2383 | Formal := First_Formal (Subp); | |
2384 | while Present (Actual) | |
2385 | and then Present (Formal) | |
2386 | loop | |
2387 | if Nkind (Actual) = N_Identifier | |
2388 | and then Is_Controlling_Actual (Actual) | |
2389 | and then Etype (Actual) = Etype (Formal) | |
2390 | then | |
2391 | return True; | |
2392 | end if; | |
2393 | ||
2394 | Next (Actual); | |
2395 | Next_Formal (Formal); | |
2396 | end loop; | |
2397 | end; | |
2398 | end if; | |
2399 | ||
2400 | return False; | |
2401 | end Is_Direct_Deep_Call; | |
2402 | ||
dd386db0 AC |
2403 | --------------- |
2404 | -- New_Value -- | |
2405 | --------------- | |
2406 | ||
2407 | function New_Value (From : Node_Id) return Node_Id is | |
2408 | Res : constant Node_Id := Duplicate_Subexpr (From); | |
2409 | begin | |
2410 | if Is_Access_Type (Etype (From)) then | |
bde73c6b | 2411 | return Make_Explicit_Dereference (Sloc (From), Prefix => Res); |
dd386db0 AC |
2412 | else |
2413 | return Res; | |
2414 | end if; | |
2415 | end New_Value; | |
2416 | ||
fdce4bb7 JM |
2417 | -- Local variables |
2418 | ||
deb8dacc HK |
2419 | Curr_S : constant Entity_Id := Current_Scope; |
2420 | Remote : constant Boolean := Is_Remote_Call (Call_Node); | |
fdce4bb7 JM |
2421 | Actual : Node_Id; |
2422 | Formal : Entity_Id; | |
2423 | Orig_Subp : Entity_Id := Empty; | |
2424 | Param_Count : Natural := 0; | |
2425 | Parent_Formal : Entity_Id; | |
2426 | Parent_Subp : Entity_Id; | |
2427 | Scop : Entity_Id; | |
2428 | Subp : Entity_Id; | |
2429 | ||
e27b834b | 2430 | Prev_Orig : Node_Id; |
fdce4bb7 JM |
2431 | -- Original node for an actual, which may have been rewritten. If the |
2432 | -- actual is a function call that has been transformed from a selected | |
2433 | -- component, the original node is unanalyzed. Otherwise, it carries | |
2434 | -- semantic information used to generate additional actuals. | |
2435 | ||
2436 | CW_Interface_Formals_Present : Boolean := False; | |
2437 | ||
70482933 RK |
2438 | -- Start of processing for Expand_Call |
2439 | ||
2440 | begin | |
dec6faf1 AC |
2441 | -- Expand the procedure call if the first actual has a dimension and if |
2442 | -- the procedure is Put (Ada 2012). | |
2443 | ||
2444 | if Ada_Version >= Ada_2012 | |
2445 | and then Nkind (Call_Node) = N_Procedure_Call_Statement | |
2446 | and then Present (Parameter_Associations (Call_Node)) | |
2447 | then | |
df378148 | 2448 | Expand_Put_Call_With_Symbol (Call_Node); |
dec6faf1 AC |
2449 | end if; |
2450 | ||
07fc65c4 GB |
2451 | -- Ignore if previous error |
2452 | ||
6dfc5592 RD |
2453 | if Nkind (Call_Node) in N_Has_Etype |
2454 | and then Etype (Call_Node) = Any_Type | |
2455 | then | |
07fc65c4 GB |
2456 | return; |
2457 | end if; | |
2458 | ||
70482933 RK |
2459 | -- Call using access to subprogram with explicit dereference |
2460 | ||
6dfc5592 RD |
2461 | if Nkind (Name (Call_Node)) = N_Explicit_Dereference then |
2462 | Subp := Etype (Name (Call_Node)); | |
70482933 RK |
2463 | Parent_Subp := Empty; |
2464 | ||
2465 | -- Case of call to simple entry, where the Name is a selected component | |
2466 | -- whose prefix is the task, and whose selector name is the entry name | |
2467 | ||
6dfc5592 RD |
2468 | elsif Nkind (Name (Call_Node)) = N_Selected_Component then |
2469 | Subp := Entity (Selector_Name (Name (Call_Node))); | |
70482933 RK |
2470 | Parent_Subp := Empty; |
2471 | ||
2472 | -- Case of call to member of entry family, where Name is an indexed | |
2473 | -- component, with the prefix being a selected component giving the | |
2474 | -- task and entry family name, and the index being the entry index. | |
2475 | ||
6dfc5592 RD |
2476 | elsif Nkind (Name (Call_Node)) = N_Indexed_Component then |
2477 | Subp := Entity (Selector_Name (Prefix (Name (Call_Node)))); | |
70482933 RK |
2478 | Parent_Subp := Empty; |
2479 | ||
2480 | -- Normal case | |
2481 | ||
2482 | else | |
6dfc5592 | 2483 | Subp := Entity (Name (Call_Node)); |
70482933 RK |
2484 | Parent_Subp := Alias (Subp); |
2485 | ||
2486 | -- Replace call to Raise_Exception by call to Raise_Exception_Always | |
2487 | -- if we can tell that the first parameter cannot possibly be null. | |
70f91180 | 2488 | -- This improves efficiency by avoiding a run-time test. |
70482933 | 2489 | |
7888a6ae GD |
2490 | -- We do not do this if Raise_Exception_Always does not exist, which |
2491 | -- can happen in configurable run time profiles which provide only a | |
70f91180 | 2492 | -- Raise_Exception. |
7888a6ae GD |
2493 | |
2494 | if Is_RTE (Subp, RE_Raise_Exception) | |
2495 | and then RTE_Available (RE_Raise_Exception_Always) | |
70482933 RK |
2496 | then |
2497 | declare | |
3cae7f14 RD |
2498 | FA : constant Node_Id := |
2499 | Original_Node (First_Actual (Call_Node)); | |
2500 | ||
70482933 RK |
2501 | begin |
2502 | -- The case we catch is where the first argument is obtained | |
2f1b20a9 ES |
2503 | -- using the Identity attribute (which must always be |
2504 | -- non-null). | |
70482933 RK |
2505 | |
2506 | if Nkind (FA) = N_Attribute_Reference | |
2507 | and then Attribute_Name (FA) = Name_Identity | |
2508 | then | |
2509 | Subp := RTE (RE_Raise_Exception_Always); | |
6dfc5592 | 2510 | Set_Name (Call_Node, New_Occurrence_Of (Subp, Loc)); |
70482933 RK |
2511 | end if; |
2512 | end; | |
2513 | end if; | |
2514 | ||
2515 | if Ekind (Subp) = E_Entry then | |
2516 | Parent_Subp := Empty; | |
2517 | end if; | |
2518 | end if; | |
2519 | ||
d3f70b35 AC |
2520 | -- Detect the following code in System.Finalization_Masters only on |
2521 | -- .NET/JVM targets: | |
deb8dacc | 2522 | -- |
d3f70b35 | 2523 | -- procedure Finalize (Master : in out Finalization_Master) is |
deb8dacc HK |
2524 | -- begin |
2525 | -- . . . | |
2526 | -- begin | |
2527 | -- Finalize (Curr_Ptr.all); | |
2528 | -- | |
2529 | -- Since .NET/JVM compilers lack address arithmetic and Deep_Finalize | |
2530 | -- cannot be named in library or user code, the compiler has to install | |
2531 | -- a kludge and transform the call to Finalize into Deep_Finalize. | |
2532 | ||
2533 | if VM_Target /= No_VM | |
2534 | and then Chars (Subp) = Name_Finalize | |
2535 | and then Ekind (Curr_S) = E_Block | |
2536 | and then Ekind (Scope (Curr_S)) = E_Procedure | |
2537 | and then Chars (Scope (Curr_S)) = Name_Finalize | |
2538 | and then Etype (First_Formal (Scope (Curr_S))) = | |
d3f70b35 | 2539 | RTE (RE_Finalization_Master) |
deb8dacc HK |
2540 | then |
2541 | declare | |
2542 | Deep_Fin : constant Entity_Id := | |
2543 | Find_Prim_Op (RTE (RE_Root_Controlled), | |
2544 | TSS_Deep_Finalize); | |
2545 | begin | |
2546 | -- Since Root_Controlled is a tagged type, the compiler should | |
2547 | -- always generate Deep_Finalize for it. | |
2548 | ||
2549 | pragma Assert (Present (Deep_Fin)); | |
2550 | ||
2551 | -- Generate: | |
2552 | -- Deep_Finalize (Curr_Ptr.all); | |
2553 | ||
2554 | Rewrite (N, | |
2555 | Make_Procedure_Call_Statement (Loc, | |
2556 | Name => | |
2557 | New_Reference_To (Deep_Fin, Loc), | |
2558 | Parameter_Associations => | |
2559 | New_Copy_List_Tree (Parameter_Associations (N)))); | |
2560 | ||
2561 | Analyze (N); | |
2562 | return; | |
2563 | end; | |
2564 | end if; | |
2565 | ||
f4d379b8 HK |
2566 | -- Ada 2005 (AI-345): We have a procedure call as a triggering |
2567 | -- alternative in an asynchronous select or as an entry call in | |
2568 | -- a conditional or timed select. Check whether the procedure call | |
2569 | -- is a renaming of an entry and rewrite it as an entry call. | |
2570 | ||
0791fbe9 | 2571 | if Ada_Version >= Ada_2005 |
6dfc5592 | 2572 | and then Nkind (Call_Node) = N_Procedure_Call_Statement |
f4d379b8 | 2573 | and then |
6dfc5592 | 2574 | ((Nkind (Parent (Call_Node)) = N_Triggering_Alternative |
3cae7f14 | 2575 | and then Triggering_Statement (Parent (Call_Node)) = Call_Node) |
f4d379b8 | 2576 | or else |
6dfc5592 | 2577 | (Nkind (Parent (Call_Node)) = N_Entry_Call_Alternative |
3cae7f14 | 2578 | and then Entry_Call_Statement (Parent (Call_Node)) = Call_Node)) |
f4d379b8 HK |
2579 | then |
2580 | declare | |
2581 | Ren_Decl : Node_Id; | |
2582 | Ren_Root : Entity_Id := Subp; | |
2583 | ||
2584 | begin | |
2585 | -- This may be a chain of renamings, find the root | |
2586 | ||
2587 | if Present (Alias (Ren_Root)) then | |
2588 | Ren_Root := Alias (Ren_Root); | |
2589 | end if; | |
2590 | ||
2591 | if Present (Original_Node (Parent (Parent (Ren_Root)))) then | |
2592 | Ren_Decl := Original_Node (Parent (Parent (Ren_Root))); | |
2593 | ||
2594 | if Nkind (Ren_Decl) = N_Subprogram_Renaming_Declaration then | |
6dfc5592 | 2595 | Rewrite (Call_Node, |
f4d379b8 HK |
2596 | Make_Entry_Call_Statement (Loc, |
2597 | Name => | |
2598 | New_Copy_Tree (Name (Ren_Decl)), | |
2599 | Parameter_Associations => | |
6dfc5592 RD |
2600 | New_Copy_List_Tree |
2601 | (Parameter_Associations (Call_Node)))); | |
f4d379b8 HK |
2602 | |
2603 | return; | |
2604 | end if; | |
2605 | end if; | |
2606 | end; | |
2607 | end if; | |
2608 | ||
e27b834b AC |
2609 | -- First step, compute extra actuals, corresponding to any Extra_Formals |
2610 | -- present. Note that we do not access Extra_Formals directly, instead | |
2611 | -- we simply note the presence of the extra formals as we process the | |
2612 | -- regular formals collecting corresponding actuals in Extra_Actuals. | |
70482933 | 2613 | |
c2369146 AC |
2614 | -- We also generate any required range checks for actuals for in formals |
2615 | -- as we go through the loop, since this is a convenient place to do it. | |
2616 | -- (Though it seems that this would be better done in Expand_Actuals???) | |
fbf5a39b | 2617 | |
e2441021 AC |
2618 | -- Special case: Thunks must not compute the extra actuals; they must |
2619 | -- just propagate to the target primitive their extra actuals. | |
2620 | ||
2621 | if Is_Thunk (Current_Scope) | |
2622 | and then Thunk_Entity (Current_Scope) = Subp | |
2623 | and then Present (Extra_Formals (Subp)) | |
2624 | then | |
2625 | pragma Assert (Present (Extra_Formals (Current_Scope))); | |
2626 | ||
2627 | declare | |
2628 | Target_Formal : Entity_Id; | |
2629 | Thunk_Formal : Entity_Id; | |
2630 | ||
2631 | begin | |
2632 | Target_Formal := Extra_Formals (Subp); | |
2633 | Thunk_Formal := Extra_Formals (Current_Scope); | |
2634 | while Present (Target_Formal) loop | |
2635 | Add_Extra_Actual | |
2636 | (New_Occurrence_Of (Thunk_Formal, Loc), Thunk_Formal); | |
2637 | ||
2638 | Target_Formal := Extra_Formal (Target_Formal); | |
2639 | Thunk_Formal := Extra_Formal (Thunk_Formal); | |
2640 | end loop; | |
2641 | ||
2642 | while Is_Non_Empty_List (Extra_Actuals) loop | |
2643 | Add_Actual_Parameter (Remove_Head (Extra_Actuals)); | |
2644 | end loop; | |
2645 | ||
2646 | Expand_Actuals (Call_Node, Subp); | |
2647 | return; | |
2648 | end; | |
2649 | end if; | |
2650 | ||
8c5b03a0 AC |
2651 | Formal := First_Formal (Subp); |
2652 | Actual := First_Actual (Call_Node); | |
fdce4bb7 | 2653 | Param_Count := 1; |
70482933 | 2654 | while Present (Formal) loop |
fbf5a39b | 2655 | |
d79e621a | 2656 | -- Generate range check if required |
fbf5a39b | 2657 | |
d79e621a | 2658 | if Do_Range_Check (Actual) |
c2369146 | 2659 | and then Ekind (Formal) = E_In_Parameter |
d79e621a GD |
2660 | then |
2661 | Set_Do_Range_Check (Actual, False); | |
2662 | Generate_Range_Check | |
2663 | (Actual, Etype (Formal), CE_Range_Check_Failed); | |
2664 | end if; | |
fbf5a39b AC |
2665 | |
2666 | -- Prepare to examine current entry | |
2667 | ||
70482933 RK |
2668 | Prev := Actual; |
2669 | Prev_Orig := Original_Node (Prev); | |
2670 | ||
758c442c | 2671 | -- Ada 2005 (AI-251): Check if any formal is a class-wide interface |
2f1b20a9 | 2672 | -- to expand it in a further round. |
758c442c GD |
2673 | |
2674 | CW_Interface_Formals_Present := | |
2675 | CW_Interface_Formals_Present | |
2676 | or else | |
2677 | (Ekind (Etype (Formal)) = E_Class_Wide_Type | |
8c5b03a0 | 2678 | and then Is_Interface (Etype (Etype (Formal)))) |
758c442c GD |
2679 | or else |
2680 | (Ekind (Etype (Formal)) = E_Anonymous_Access_Type | |
2681 | and then Is_Interface (Directly_Designated_Type | |
2682 | (Etype (Etype (Formal))))); | |
2683 | ||
2684 | -- Create possible extra actual for constrained case. Usually, the | |
2685 | -- extra actual is of the form actual'constrained, but since this | |
2686 | -- attribute is only available for unconstrained records, TRUE is | |
2687 | -- expanded if the type of the formal happens to be constrained (for | |
2688 | -- instance when this procedure is inherited from an unconstrained | |
2689 | -- record to a constrained one) or if the actual has no discriminant | |
2690 | -- (its type is constrained). An exception to this is the case of a | |
2691 | -- private type without discriminants. In this case we pass FALSE | |
2692 | -- because the object has underlying discriminants with defaults. | |
70482933 RK |
2693 | |
2694 | if Present (Extra_Constrained (Formal)) then | |
2695 | if Ekind (Etype (Prev)) in Private_Kind | |
2696 | and then not Has_Discriminants (Base_Type (Etype (Prev))) | |
2697 | then | |
01aef5ad GD |
2698 | Add_Extra_Actual |
2699 | (New_Occurrence_Of (Standard_False, Loc), | |
2700 | Extra_Constrained (Formal)); | |
70482933 RK |
2701 | |
2702 | elsif Is_Constrained (Etype (Formal)) | |
2703 | or else not Has_Discriminants (Etype (Prev)) | |
2704 | then | |
01aef5ad GD |
2705 | Add_Extra_Actual |
2706 | (New_Occurrence_Of (Standard_True, Loc), | |
2707 | Extra_Constrained (Formal)); | |
70482933 | 2708 | |
5d09245e AC |
2709 | -- Do not produce extra actuals for Unchecked_Union parameters. |
2710 | -- Jump directly to the end of the loop. | |
2711 | ||
2712 | elsif Is_Unchecked_Union (Base_Type (Etype (Actual))) then | |
2713 | goto Skip_Extra_Actual_Generation; | |
2714 | ||
70482933 RK |
2715 | else |
2716 | -- If the actual is a type conversion, then the constrained | |
2717 | -- test applies to the actual, not the target type. | |
2718 | ||
2719 | declare | |
2f1b20a9 | 2720 | Act_Prev : Node_Id; |
70482933 RK |
2721 | |
2722 | begin | |
2f1b20a9 ES |
2723 | -- Test for unchecked conversions as well, which can occur |
2724 | -- as out parameter actuals on calls to stream procedures. | |
70482933 | 2725 | |
2f1b20a9 | 2726 | Act_Prev := Prev; |
ac4d6407 RD |
2727 | while Nkind_In (Act_Prev, N_Type_Conversion, |
2728 | N_Unchecked_Type_Conversion) | |
fbf5a39b | 2729 | loop |
70482933 | 2730 | Act_Prev := Expression (Act_Prev); |
fbf5a39b | 2731 | end loop; |
70482933 | 2732 | |
3563739b AC |
2733 | -- If the expression is a conversion of a dereference, this |
2734 | -- is internally generated code that manipulates addresses, | |
2735 | -- e.g. when building interface tables. No check should | |
2736 | -- occur in this case, and the discriminated object is not | |
2737 | -- directly a hand. | |
f4d379b8 HK |
2738 | |
2739 | if not Comes_From_Source (Actual) | |
2740 | and then Nkind (Actual) = N_Unchecked_Type_Conversion | |
2741 | and then Nkind (Act_Prev) = N_Explicit_Dereference | |
2742 | then | |
2743 | Add_Extra_Actual | |
2744 | (New_Occurrence_Of (Standard_False, Loc), | |
2745 | Extra_Constrained (Formal)); | |
2746 | ||
2747 | else | |
2748 | Add_Extra_Actual | |
2749 | (Make_Attribute_Reference (Sloc (Prev), | |
2750 | Prefix => | |
2751 | Duplicate_Subexpr_No_Checks | |
2752 | (Act_Prev, Name_Req => True), | |
2753 | Attribute_Name => Name_Constrained), | |
2754 | Extra_Constrained (Formal)); | |
2755 | end if; | |
70482933 RK |
2756 | end; |
2757 | end if; | |
2758 | end if; | |
2759 | ||
2760 | -- Create possible extra actual for accessibility level | |
2761 | ||
2762 | if Present (Extra_Accessibility (Formal)) then | |
7888a6ae GD |
2763 | |
2764 | -- Ada 2005 (AI-252): If the actual was rewritten as an Access | |
2765 | -- attribute, then the original actual may be an aliased object | |
2766 | -- occurring as the prefix in a call using "Object.Operation" | |
2767 | -- notation. In that case we must pass the level of the object, | |
2768 | -- so Prev_Orig is reset to Prev and the attribute will be | |
2769 | -- processed by the code for Access attributes further below. | |
2770 | ||
2771 | if Prev_Orig /= Prev | |
2772 | and then Nkind (Prev) = N_Attribute_Reference | |
2773 | and then | |
2774 | Get_Attribute_Id (Attribute_Name (Prev)) = Attribute_Access | |
2775 | and then Is_Aliased_View (Prev_Orig) | |
2776 | then | |
2777 | Prev_Orig := Prev; | |
2778 | end if; | |
2779 | ||
9d983bbf AC |
2780 | -- Ada 2005 (AI-251): Thunks must propagate the extra actuals of |
2781 | -- accessibility levels. | |
fdce4bb7 | 2782 | |
da1c23dd | 2783 | if Is_Thunk (Current_Scope) then |
fdce4bb7 JM |
2784 | declare |
2785 | Parm_Ent : Entity_Id; | |
2786 | ||
2787 | begin | |
2788 | if Is_Controlling_Actual (Actual) then | |
2789 | ||
2790 | -- Find the corresponding actual of the thunk | |
2791 | ||
2792 | Parm_Ent := First_Entity (Current_Scope); | |
2793 | for J in 2 .. Param_Count loop | |
2794 | Next_Entity (Parm_Ent); | |
2795 | end loop; | |
2796 | ||
8a49a499 | 2797 | -- Handle unchecked conversion of access types generated |
5b5b27ad | 2798 | -- in thunks (cf. Expand_Interface_Thunk). |
8a49a499 AC |
2799 | |
2800 | elsif Is_Access_Type (Etype (Actual)) | |
2801 | and then Nkind (Actual) = N_Unchecked_Type_Conversion | |
2802 | then | |
2803 | Parm_Ent := Entity (Expression (Actual)); | |
2804 | ||
fdce4bb7 JM |
2805 | else pragma Assert (Is_Entity_Name (Actual)); |
2806 | Parm_Ent := Entity (Actual); | |
2807 | end if; | |
2808 | ||
2809 | Add_Extra_Actual | |
2810 | (New_Occurrence_Of (Extra_Accessibility (Parm_Ent), Loc), | |
2811 | Extra_Accessibility (Formal)); | |
2812 | end; | |
2813 | ||
2814 | elsif Is_Entity_Name (Prev_Orig) then | |
70482933 | 2815 | |
d766cee3 RD |
2816 | -- When passing an access parameter, or a renaming of an access |
2817 | -- parameter, as the actual to another access parameter we need | |
2818 | -- to pass along the actual's own access level parameter. This | |
2819 | -- is done if we are within the scope of the formal access | |
2820 | -- parameter (if this is an inlined body the extra formal is | |
2821 | -- irrelevant). | |
2822 | ||
2823 | if (Is_Formal (Entity (Prev_Orig)) | |
2824 | or else | |
2825 | (Present (Renamed_Object (Entity (Prev_Orig))) | |
2826 | and then | |
2827 | Is_Entity_Name (Renamed_Object (Entity (Prev_Orig))) | |
2828 | and then | |
2829 | Is_Formal | |
2830 | (Entity (Renamed_Object (Entity (Prev_Orig)))))) | |
70482933 RK |
2831 | and then Ekind (Etype (Prev_Orig)) = E_Anonymous_Access_Type |
2832 | and then In_Open_Scopes (Scope (Entity (Prev_Orig))) | |
2833 | then | |
2834 | declare | |
2835 | Parm_Ent : constant Entity_Id := Param_Entity (Prev_Orig); | |
2836 | ||
2837 | begin | |
2838 | pragma Assert (Present (Parm_Ent)); | |
2839 | ||
2840 | if Present (Extra_Accessibility (Parm_Ent)) then | |
f4d379b8 HK |
2841 | Add_Extra_Actual |
2842 | (New_Occurrence_Of | |
2843 | (Extra_Accessibility (Parm_Ent), Loc), | |
2844 | Extra_Accessibility (Formal)); | |
70482933 RK |
2845 | |
2846 | -- If the actual access parameter does not have an | |
2847 | -- associated extra formal providing its scope level, | |
2848 | -- then treat the actual as having library-level | |
2849 | -- accessibility. | |
2850 | ||
2851 | else | |
f4d379b8 HK |
2852 | Add_Extra_Actual |
2853 | (Make_Integer_Literal (Loc, | |
01aef5ad | 2854 | Intval => Scope_Depth (Standard_Standard)), |
f4d379b8 | 2855 | Extra_Accessibility (Formal)); |
70482933 RK |
2856 | end if; |
2857 | end; | |
2858 | ||
7888a6ae GD |
2859 | -- The actual is a normal access value, so just pass the level |
2860 | -- of the actual's access type. | |
70482933 RK |
2861 | |
2862 | else | |
f4d379b8 | 2863 | Add_Extra_Actual |
d15f9422 | 2864 | (Dynamic_Accessibility_Level (Prev_Orig), |
f4d379b8 | 2865 | Extra_Accessibility (Formal)); |
70482933 RK |
2866 | end if; |
2867 | ||
01aef5ad GD |
2868 | -- If the actual is an access discriminant, then pass the level |
2869 | -- of the enclosing object (RM05-3.10.2(12.4/2)). | |
2870 | ||
2871 | elsif Nkind (Prev_Orig) = N_Selected_Component | |
2872 | and then Ekind (Entity (Selector_Name (Prev_Orig))) = | |
2873 | E_Discriminant | |
2874 | and then Ekind (Etype (Entity (Selector_Name (Prev_Orig)))) = | |
2875 | E_Anonymous_Access_Type | |
2876 | then | |
2877 | Add_Extra_Actual | |
2878 | (Make_Integer_Literal (Loc, | |
2879 | Intval => Object_Access_Level (Prefix (Prev_Orig))), | |
2880 | Extra_Accessibility (Formal)); | |
2881 | ||
2882 | -- All other cases | |
fdce4bb7 | 2883 | |
70482933 RK |
2884 | else |
2885 | case Nkind (Prev_Orig) is | |
2886 | ||
2887 | when N_Attribute_Reference => | |
70482933 RK |
2888 | case Get_Attribute_Id (Attribute_Name (Prev_Orig)) is |
2889 | ||
75a64833 | 2890 | -- For X'Access, pass on the level of the prefix X |
70482933 RK |
2891 | |
2892 | when Attribute_Access => | |
996c8821 | 2893 | |
6cce2156 GD |
2894 | -- If this is an Access attribute applied to the |
2895 | -- the current instance object passed to a type | |
2896 | -- initialization procedure, then use the level | |
2897 | -- of the type itself. This is not really correct, | |
2898 | -- as there should be an extra level parameter | |
2899 | -- passed in with _init formals (only in the case | |
2900 | -- where the type is immutably limited), but we | |
2901 | -- don't have an easy way currently to create such | |
2902 | -- an extra formal (init procs aren't ever frozen). | |
2903 | -- For now we just use the level of the type, | |
2904 | -- which may be too shallow, but that works better | |
2905 | -- than passing Object_Access_Level of the type, | |
2906 | -- which can be one level too deep in some cases. | |
2907 | -- ??? | |
2908 | ||
2909 | if Is_Entity_Name (Prefix (Prev_Orig)) | |
2910 | and then Is_Type (Entity (Prefix (Prev_Orig))) | |
2911 | then | |
2912 | Add_Extra_Actual | |
2913 | (Make_Integer_Literal (Loc, | |
2914 | Intval => | |
2915 | Type_Access_Level | |
2916 | (Entity (Prefix (Prev_Orig)))), | |
2917 | Extra_Accessibility (Formal)); | |
2918 | ||
2919 | else | |
2920 | Add_Extra_Actual | |
2921 | (Make_Integer_Literal (Loc, | |
2922 | Intval => | |
2923 | Object_Access_Level | |
2924 | (Prefix (Prev_Orig))), | |
2925 | Extra_Accessibility (Formal)); | |
2926 | end if; | |
70482933 RK |
2927 | |
2928 | -- Treat the unchecked attributes as library-level | |
2929 | ||
2930 | when Attribute_Unchecked_Access | | |
2931 | Attribute_Unrestricted_Access => | |
01aef5ad GD |
2932 | Add_Extra_Actual |
2933 | (Make_Integer_Literal (Loc, | |
2934 | Intval => Scope_Depth (Standard_Standard)), | |
2935 | Extra_Accessibility (Formal)); | |
70482933 RK |
2936 | |
2937 | -- No other cases of attributes returning access | |
9d983bbf | 2938 | -- values that can be passed to access parameters. |
70482933 RK |
2939 | |
2940 | when others => | |
2941 | raise Program_Error; | |
2942 | ||
2943 | end case; | |
2944 | ||
92a745f3 TQ |
2945 | -- For allocators we pass the level of the execution of the |
2946 | -- called subprogram, which is one greater than the current | |
2947 | -- scope level. | |
70482933 RK |
2948 | |
2949 | when N_Allocator => | |
01aef5ad GD |
2950 | Add_Extra_Actual |
2951 | (Make_Integer_Literal (Loc, | |
2952 | Intval => Scope_Depth (Current_Scope) + 1), | |
2953 | Extra_Accessibility (Formal)); | |
70482933 | 2954 | |
d15f9422 AC |
2955 | -- For most other cases we simply pass the level of the |
2956 | -- actual's access type. The type is retrieved from | |
2957 | -- Prev rather than Prev_Orig, because in some cases | |
2958 | -- Prev_Orig denotes an original expression that has | |
2959 | -- not been analyzed. | |
70482933 RK |
2960 | |
2961 | when others => | |
01aef5ad | 2962 | Add_Extra_Actual |
d15f9422 | 2963 | (Dynamic_Accessibility_Level (Prev), |
01aef5ad | 2964 | Extra_Accessibility (Formal)); |
70482933 RK |
2965 | end case; |
2966 | end if; | |
2967 | end if; | |
2968 | ||
2f1b20a9 | 2969 | -- Perform the check of 4.6(49) that prevents a null value from being |
b3f48fd4 AC |
2970 | -- passed as an actual to an access parameter. Note that the check |
2971 | -- is elided in the common cases of passing an access attribute or | |
2f1b20a9 ES |
2972 | -- access parameter as an actual. Also, we currently don't enforce |
2973 | -- this check for expander-generated actuals and when -gnatdj is set. | |
70482933 | 2974 | |
0791fbe9 | 2975 | if Ada_Version >= Ada_2005 then |
70482933 | 2976 | |
b3f48fd4 AC |
2977 | -- Ada 2005 (AI-231): Check null-excluding access types. Note that |
2978 | -- the intent of 6.4.1(13) is that null-exclusion checks should | |
2979 | -- not be done for 'out' parameters, even though it refers only | |
308e6f3a | 2980 | -- to constraint checks, and a null_exclusion is not a constraint. |
b3f48fd4 | 2981 | -- Note that AI05-0196-1 corrects this mistake in the RM. |
70482933 | 2982 | |
2f1b20a9 ES |
2983 | if Is_Access_Type (Etype (Formal)) |
2984 | and then Can_Never_Be_Null (Etype (Formal)) | |
b3f48fd4 | 2985 | and then Ekind (Formal) /= E_Out_Parameter |
2f1b20a9 | 2986 | and then Nkind (Prev) /= N_Raise_Constraint_Error |
d766cee3 | 2987 | and then (Known_Null (Prev) |
996c8821 | 2988 | or else not Can_Never_Be_Null (Etype (Prev))) |
2f1b20a9 ES |
2989 | then |
2990 | Install_Null_Excluding_Check (Prev); | |
2991 | end if; | |
70482933 | 2992 | |
0791fbe9 | 2993 | -- Ada_Version < Ada_2005 |
70482933 | 2994 | |
2f1b20a9 ES |
2995 | else |
2996 | if Ekind (Etype (Formal)) /= E_Anonymous_Access_Type | |
2997 | or else Access_Checks_Suppressed (Subp) | |
2998 | then | |
2999 | null; | |
70482933 | 3000 | |
2f1b20a9 ES |
3001 | elsif Debug_Flag_J then |
3002 | null; | |
70482933 | 3003 | |
2f1b20a9 ES |
3004 | elsif not Comes_From_Source (Prev) then |
3005 | null; | |
70482933 | 3006 | |
2f1b20a9 ES |
3007 | elsif Is_Entity_Name (Prev) |
3008 | and then Ekind (Etype (Prev)) = E_Anonymous_Access_Type | |
3009 | then | |
3010 | null; | |
2820d220 | 3011 | |
ac4d6407 | 3012 | elsif Nkind_In (Prev, N_Allocator, N_Attribute_Reference) then |
2f1b20a9 ES |
3013 | null; |
3014 | ||
3015 | -- Suppress null checks when passing to access parameters of Java | |
7888a6ae GD |
3016 | -- and CIL subprograms. (Should this be done for other foreign |
3017 | -- conventions as well ???) | |
2f1b20a9 | 3018 | |
7888a6ae GD |
3019 | elsif Convention (Subp) = Convention_Java |
3020 | or else Convention (Subp) = Convention_CIL | |
3021 | then | |
2f1b20a9 ES |
3022 | null; |
3023 | ||
3024 | else | |
3025 | Install_Null_Excluding_Check (Prev); | |
3026 | end if; | |
70482933 RK |
3027 | end if; |
3028 | ||
fbf5a39b AC |
3029 | -- Perform appropriate validity checks on parameters that |
3030 | -- are entities. | |
70482933 RK |
3031 | |
3032 | if Validity_Checks_On then | |
6cdb2c6e | 3033 | if (Ekind (Formal) = E_In_Parameter |
996c8821 | 3034 | and then Validity_Check_In_Params) |
6cdb2c6e AC |
3035 | or else |
3036 | (Ekind (Formal) = E_In_Out_Parameter | |
996c8821 | 3037 | and then Validity_Check_In_Out_Params) |
70482933 | 3038 | then |
7888a6ae GD |
3039 | -- If the actual is an indexed component of a packed type (or |
3040 | -- is an indexed or selected component whose prefix recursively | |
3041 | -- meets this condition), it has not been expanded yet. It will | |
3042 | -- be copied in the validity code that follows, and has to be | |
3043 | -- expanded appropriately, so reanalyze it. | |
08aa9a4a | 3044 | |
7888a6ae GD |
3045 | -- What we do is just to unset analyzed bits on prefixes till |
3046 | -- we reach something that does not have a prefix. | |
3047 | ||
3048 | declare | |
3049 | Nod : Node_Id; | |
3050 | ||
3051 | begin | |
3052 | Nod := Actual; | |
ac4d6407 RD |
3053 | while Nkind_In (Nod, N_Indexed_Component, |
3054 | N_Selected_Component) | |
7888a6ae GD |
3055 | loop |
3056 | Set_Analyzed (Nod, False); | |
3057 | Nod := Prefix (Nod); | |
3058 | end loop; | |
3059 | end; | |
08aa9a4a | 3060 | |
70482933 | 3061 | Ensure_Valid (Actual); |
70482933 RK |
3062 | end if; |
3063 | end if; | |
3064 | ||
b5bf3335 AC |
3065 | -- For Ada 2012, if a parameter is aliased, the actual must be a |
3066 | -- tagged type or an aliased view of an object. | |
8c5b03a0 | 3067 | |
b5bf3335 AC |
3068 | if Is_Aliased (Formal) |
3069 | and then not Is_Aliased_View (Actual) | |
3070 | and then not Is_Tagged_Type (Etype (Formal)) | |
3071 | then | |
8c5b03a0 AC |
3072 | Error_Msg_NE |
3073 | ("actual for aliased formal& must be aliased object", | |
3074 | Actual, Formal); | |
3075 | end if; | |
3076 | ||
70482933 RK |
3077 | -- For IN OUT and OUT parameters, ensure that subscripts are valid |
3078 | -- since this is a left side reference. We only do this for calls | |
3079 | -- from the source program since we assume that compiler generated | |
3080 | -- calls explicitly generate any required checks. We also need it | |
b3f48fd4 AC |
3081 | -- only if we are doing standard validity checks, since clearly it is |
3082 | -- not needed if validity checks are off, and in subscript validity | |
3083 | -- checking mode, all indexed components are checked with a call | |
3084 | -- directly from Expand_N_Indexed_Component. | |
70482933 | 3085 | |
6dfc5592 | 3086 | if Comes_From_Source (Call_Node) |
70482933 RK |
3087 | and then Ekind (Formal) /= E_In_Parameter |
3088 | and then Validity_Checks_On | |
3089 | and then Validity_Check_Default | |
3090 | and then not Validity_Check_Subscripts | |
3091 | then | |
3092 | Check_Valid_Lvalue_Subscripts (Actual); | |
3093 | end if; | |
3094 | ||
c8ef728f ES |
3095 | -- Mark any scalar OUT parameter that is a simple variable as no |
3096 | -- longer known to be valid (unless the type is always valid). This | |
3097 | -- reflects the fact that if an OUT parameter is never set in a | |
3098 | -- procedure, then it can become invalid on the procedure return. | |
fbf5a39b AC |
3099 | |
3100 | if Ekind (Formal) = E_Out_Parameter | |
3101 | and then Is_Entity_Name (Actual) | |
3102 | and then Ekind (Entity (Actual)) = E_Variable | |
3103 | and then not Is_Known_Valid (Etype (Actual)) | |
3104 | then | |
3105 | Set_Is_Known_Valid (Entity (Actual), False); | |
3106 | end if; | |
3107 | ||
c8ef728f ES |
3108 | -- For an OUT or IN OUT parameter, if the actual is an entity, then |
3109 | -- clear current values, since they can be clobbered. We are probably | |
3110 | -- doing this in more places than we need to, but better safe than | |
a90bd866 | 3111 | -- sorry when it comes to retaining bad current values. |
fbf5a39b AC |
3112 | |
3113 | if Ekind (Formal) /= E_In_Parameter | |
3114 | and then Is_Entity_Name (Actual) | |
67ce0d7e | 3115 | and then Present (Entity (Actual)) |
fbf5a39b | 3116 | then |
67ce0d7e RD |
3117 | declare |
3118 | Ent : constant Entity_Id := Entity (Actual); | |
3119 | Sav : Node_Id; | |
3120 | ||
3121 | begin | |
ac4d6407 RD |
3122 | -- For an OUT or IN OUT parameter that is an assignable entity, |
3123 | -- we do not want to clobber the Last_Assignment field, since | |
3124 | -- if it is set, it was precisely because it is indeed an OUT | |
a90bd866 | 3125 | -- or IN OUT parameter. We do reset the Is_Known_Valid flag |
75ba322d | 3126 | -- since the subprogram could have returned in invalid value. |
ac4d6407 | 3127 | |
8c5b03a0 | 3128 | if Ekind_In (Formal, E_Out_Parameter, E_In_Out_Parameter) |
67ce0d7e RD |
3129 | and then Is_Assignable (Ent) |
3130 | then | |
3131 | Sav := Last_Assignment (Ent); | |
3132 | Kill_Current_Values (Ent); | |
3133 | Set_Last_Assignment (Ent, Sav); | |
75ba322d | 3134 | Set_Is_Known_Valid (Ent, False); |
67ce0d7e | 3135 | |
4bb43ffb | 3136 | -- For all other cases, just kill the current values |
67ce0d7e RD |
3137 | |
3138 | else | |
3139 | Kill_Current_Values (Ent); | |
3140 | end if; | |
3141 | end; | |
fbf5a39b AC |
3142 | end if; |
3143 | ||
70482933 RK |
3144 | -- If the formal is class wide and the actual is an aggregate, force |
3145 | -- evaluation so that the back end who does not know about class-wide | |
3146 | -- type, does not generate a temporary of the wrong size. | |
3147 | ||
3148 | if not Is_Class_Wide_Type (Etype (Formal)) then | |
3149 | null; | |
3150 | ||
3151 | elsif Nkind (Actual) = N_Aggregate | |
3152 | or else (Nkind (Actual) = N_Qualified_Expression | |
3153 | and then Nkind (Expression (Actual)) = N_Aggregate) | |
3154 | then | |
3155 | Force_Evaluation (Actual); | |
3156 | end if; | |
3157 | ||
3158 | -- In a remote call, if the formal is of a class-wide type, check | |
3159 | -- that the actual meets the requirements described in E.4(18). | |
3160 | ||
7888a6ae | 3161 | if Remote and then Is_Class_Wide_Type (Etype (Formal)) then |
70482933 | 3162 | Insert_Action (Actual, |
7888a6ae GD |
3163 | Make_Transportable_Check (Loc, |
3164 | Duplicate_Subexpr_Move_Checks (Actual))); | |
70482933 RK |
3165 | end if; |
3166 | ||
5d09245e AC |
3167 | -- This label is required when skipping extra actual generation for |
3168 | -- Unchecked_Union parameters. | |
3169 | ||
3170 | <<Skip_Extra_Actual_Generation>> | |
3171 | ||
fdce4bb7 | 3172 | Param_Count := Param_Count + 1; |
70482933 RK |
3173 | Next_Actual (Actual); |
3174 | Next_Formal (Formal); | |
3175 | end loop; | |
3176 | ||
bdf69d33 | 3177 | -- If we are calling an Ada 2012 function which needs to have the |
63585f75 SB |
3178 | -- "accessibility level determined by the point of call" (AI05-0234) |
3179 | -- passed in to it, then pass it in. | |
3180 | ||
b8a93198 | 3181 | if Ekind_In (Subp, E_Function, E_Operator, E_Subprogram_Type) |
57a3fca9 AC |
3182 | and then |
3183 | Present (Extra_Accessibility_Of_Result (Ultimate_Alias (Subp))) | |
63585f75 SB |
3184 | then |
3185 | declare | |
3186 | Ancestor : Node_Id := Parent (Call_Node); | |
3187 | Level : Node_Id := Empty; | |
3188 | Defer : Boolean := False; | |
3189 | ||
3190 | begin | |
3191 | -- Unimplemented: if Subp returns an anonymous access type, then | |
57a3fca9 | 3192 | |
63585f75 SB |
3193 | -- a) if the call is the operand of an explict conversion, then |
3194 | -- the target type of the conversion (a named access type) | |
3195 | -- determines the accessibility level pass in; | |
57a3fca9 | 3196 | |
63585f75 SB |
3197 | -- b) if the call defines an access discriminant of an object |
3198 | -- (e.g., the discriminant of an object being created by an | |
3199 | -- allocator, or the discriminant of a function result), | |
3200 | -- then the accessibility level to pass in is that of the | |
3201 | -- discriminated object being initialized). | |
3202 | ||
57a3fca9 AC |
3203 | -- ??? |
3204 | ||
63585f75 SB |
3205 | while Nkind (Ancestor) = N_Qualified_Expression |
3206 | loop | |
3207 | Ancestor := Parent (Ancestor); | |
3208 | end loop; | |
3209 | ||
3210 | case Nkind (Ancestor) is | |
3211 | when N_Allocator => | |
ebf494ec | 3212 | |
63585f75 | 3213 | -- At this point, we'd like to assign |
ebf494ec | 3214 | |
63585f75 | 3215 | -- Level := Dynamic_Accessibility_Level (Ancestor); |
ebf494ec | 3216 | |
63585f75 SB |
3217 | -- but Etype of Ancestor may not have been set yet, |
3218 | -- so that doesn't work. | |
ebf494ec | 3219 | |
63585f75 SB |
3220 | -- Handle this later in Expand_Allocator_Expression. |
3221 | ||
3222 | Defer := True; | |
3223 | ||
3224 | when N_Object_Declaration | N_Object_Renaming_Declaration => | |
3225 | declare | |
3226 | Def_Id : constant Entity_Id := | |
3227 | Defining_Identifier (Ancestor); | |
ebf494ec | 3228 | |
63585f75 SB |
3229 | begin |
3230 | if Is_Return_Object (Def_Id) then | |
3231 | if Present (Extra_Accessibility_Of_Result | |
3232 | (Return_Applies_To (Scope (Def_Id)))) | |
3233 | then | |
3234 | -- Pass along value that was passed in if the | |
3235 | -- routine we are returning from also has an | |
3236 | -- Accessibility_Of_Result formal. | |
3237 | ||
3238 | Level := | |
3239 | New_Occurrence_Of | |
3240 | (Extra_Accessibility_Of_Result | |
ebf494ec | 3241 | (Return_Applies_To (Scope (Def_Id))), Loc); |
63585f75 SB |
3242 | end if; |
3243 | else | |
ebf494ec RD |
3244 | Level := |
3245 | Make_Integer_Literal (Loc, | |
3246 | Intval => Object_Access_Level (Def_Id)); | |
63585f75 SB |
3247 | end if; |
3248 | end; | |
3249 | ||
3250 | when N_Simple_Return_Statement => | |
3251 | if Present (Extra_Accessibility_Of_Result | |
ebf494ec RD |
3252 | (Return_Applies_To |
3253 | (Return_Statement_Entity (Ancestor)))) | |
63585f75 SB |
3254 | then |
3255 | -- Pass along value that was passed in if the routine | |
3256 | -- we are returning from also has an | |
3257 | -- Accessibility_Of_Result formal. | |
3258 | ||
3259 | Level := | |
3260 | New_Occurrence_Of | |
3261 | (Extra_Accessibility_Of_Result | |
3262 | (Return_Applies_To | |
3263 | (Return_Statement_Entity (Ancestor))), Loc); | |
3264 | end if; | |
3265 | ||
3266 | when others => | |
3267 | null; | |
3268 | end case; | |
3269 | ||
3270 | if not Defer then | |
3271 | if not Present (Level) then | |
ebf494ec | 3272 | |
63585f75 | 3273 | -- The "innermost master that evaluates the function call". |
ebf494ec | 3274 | |
886b5a18 AC |
3275 | -- ??? - Should we use Integer'Last here instead in order |
3276 | -- to deal with (some of) the problems associated with | |
3277 | -- calls to subps whose enclosing scope is unknown (e.g., | |
3278 | -- Anon_Access_To_Subp_Param.all)? | |
63585f75 SB |
3279 | |
3280 | Level := Make_Integer_Literal (Loc, | |
3281 | Scope_Depth (Current_Scope) + 1); | |
3282 | end if; | |
3283 | ||
57a3fca9 AC |
3284 | Add_Extra_Actual |
3285 | (Level, | |
3286 | Extra_Accessibility_Of_Result (Ultimate_Alias (Subp))); | |
63585f75 SB |
3287 | end if; |
3288 | end; | |
3289 | end if; | |
3290 | ||
4bb43ffb | 3291 | -- If we are expanding the RHS of an assignment we need to check if tag |
c8ef728f ES |
3292 | -- propagation is needed. You might expect this processing to be in |
3293 | -- Analyze_Assignment but has to be done earlier (bottom-up) because the | |
3294 | -- assignment might be transformed to a declaration for an unconstrained | |
3295 | -- value if the expression is classwide. | |
70482933 | 3296 | |
6dfc5592 RD |
3297 | if Nkind (Call_Node) = N_Function_Call |
3298 | and then Is_Tag_Indeterminate (Call_Node) | |
3299 | and then Is_Entity_Name (Name (Call_Node)) | |
70482933 RK |
3300 | then |
3301 | declare | |
3302 | Ass : Node_Id := Empty; | |
3303 | ||
3304 | begin | |
6dfc5592 RD |
3305 | if Nkind (Parent (Call_Node)) = N_Assignment_Statement then |
3306 | Ass := Parent (Call_Node); | |
70482933 | 3307 | |
6dfc5592 | 3308 | elsif Nkind (Parent (Call_Node)) = N_Qualified_Expression |
3cae7f14 RD |
3309 | and then Nkind (Parent (Parent (Call_Node))) = |
3310 | N_Assignment_Statement | |
70482933 | 3311 | then |
6dfc5592 | 3312 | Ass := Parent (Parent (Call_Node)); |
02822a92 | 3313 | |
6dfc5592 | 3314 | elsif Nkind (Parent (Call_Node)) = N_Explicit_Dereference |
3cae7f14 RD |
3315 | and then Nkind (Parent (Parent (Call_Node))) = |
3316 | N_Assignment_Statement | |
02822a92 | 3317 | then |
6dfc5592 | 3318 | Ass := Parent (Parent (Call_Node)); |
70482933 RK |
3319 | end if; |
3320 | ||
3321 | if Present (Ass) | |
3322 | and then Is_Class_Wide_Type (Etype (Name (Ass))) | |
3323 | then | |
6dfc5592 RD |
3324 | if Is_Access_Type (Etype (Call_Node)) then |
3325 | if Designated_Type (Etype (Call_Node)) /= | |
02822a92 RD |
3326 | Root_Type (Etype (Name (Ass))) |
3327 | then | |
3328 | Error_Msg_NE | |
3329 | ("tag-indeterminate expression " | |
d766cee3 | 3330 | & " must have designated type& (RM 5.2 (6))", |
3cae7f14 | 3331 | Call_Node, Root_Type (Etype (Name (Ass)))); |
02822a92 | 3332 | else |
6dfc5592 | 3333 | Propagate_Tag (Name (Ass), Call_Node); |
02822a92 RD |
3334 | end if; |
3335 | ||
6dfc5592 | 3336 | elsif Etype (Call_Node) /= Root_Type (Etype (Name (Ass))) then |
fbf5a39b AC |
3337 | Error_Msg_NE |
3338 | ("tag-indeterminate expression must have type&" | |
6dfc5592 RD |
3339 | & "(RM 5.2 (6))", |
3340 | Call_Node, Root_Type (Etype (Name (Ass)))); | |
02822a92 | 3341 | |
fbf5a39b | 3342 | else |
6dfc5592 | 3343 | Propagate_Tag (Name (Ass), Call_Node); |
fbf5a39b AC |
3344 | end if; |
3345 | ||
3346 | -- The call will be rewritten as a dispatching call, and | |
3347 | -- expanded as such. | |
3348 | ||
70482933 RK |
3349 | return; |
3350 | end if; | |
3351 | end; | |
3352 | end if; | |
3353 | ||
758c442c GD |
3354 | -- Ada 2005 (AI-251): If some formal is a class-wide interface, expand |
3355 | -- it to point to the correct secondary virtual table | |
3356 | ||
d3b00ce3 | 3357 | if Nkind (Call_Node) in N_Subprogram_Call |
758c442c GD |
3358 | and then CW_Interface_Formals_Present |
3359 | then | |
6dfc5592 | 3360 | Expand_Interface_Actuals (Call_Node); |
758c442c GD |
3361 | end if; |
3362 | ||
70482933 RK |
3363 | -- Deals with Dispatch_Call if we still have a call, before expanding |
3364 | -- extra actuals since this will be done on the re-analysis of the | |
b3f48fd4 AC |
3365 | -- dispatching call. Note that we do not try to shorten the actual list |
3366 | -- for a dispatching call, it would not make sense to do so. Expansion | |
3367 | -- of dispatching calls is suppressed when VM_Target, because the VM | |
3368 | -- back-ends directly handle the generation of dispatching calls and | |
3369 | -- would have to undo any expansion to an indirect call. | |
70482933 | 3370 | |
d3b00ce3 | 3371 | if Nkind (Call_Node) in N_Subprogram_Call |
6dfc5592 | 3372 | and then Present (Controlling_Argument (Call_Node)) |
70482933 | 3373 | then |
6dfc5592 | 3374 | declare |
dd386db0 | 3375 | Call_Typ : constant Entity_Id := Etype (Call_Node); |
6dfc5592 RD |
3376 | Typ : constant Entity_Id := Find_Dispatching_Type (Subp); |
3377 | Eq_Prim_Op : Entity_Id := Empty; | |
dd386db0 AC |
3378 | New_Call : Node_Id; |
3379 | Param : Node_Id; | |
3380 | Prev_Call : Node_Id; | |
fbf5a39b | 3381 | |
6dfc5592 RD |
3382 | begin |
3383 | if not Is_Limited_Type (Typ) then | |
3384 | Eq_Prim_Op := Find_Prim_Op (Typ, Name_Op_Eq); | |
3385 | end if; | |
fbf5a39b | 3386 | |
6dfc5592 RD |
3387 | if Tagged_Type_Expansion then |
3388 | Expand_Dispatching_Call (Call_Node); | |
70f91180 | 3389 | |
6dfc5592 RD |
3390 | -- The following return is worrisome. Is it really OK to skip |
3391 | -- all remaining processing in this procedure ??? | |
5a1ccfb1 | 3392 | |
6dfc5592 | 3393 | return; |
5a1ccfb1 | 3394 | |
6dfc5592 RD |
3395 | -- VM targets |
3396 | ||
3397 | else | |
3398 | Apply_Tag_Checks (Call_Node); | |
3399 | ||
dd386db0 AC |
3400 | -- If this is a dispatching "=", we must first compare the |
3401 | -- tags so we generate: x.tag = y.tag and then x = y | |
3402 | ||
3403 | if Subp = Eq_Prim_Op then | |
3404 | ||
3405 | -- Mark the node as analyzed to avoid reanalizing this | |
3406 | -- dispatching call (which would cause a never-ending loop) | |
3407 | ||
3408 | Prev_Call := Relocate_Node (Call_Node); | |
3409 | Set_Analyzed (Prev_Call); | |
3410 | ||
3411 | Param := First_Actual (Call_Node); | |
3412 | New_Call := | |
3413 | Make_And_Then (Loc, | |
3414 | Left_Opnd => | |
3415 | Make_Op_Eq (Loc, | |
3416 | Left_Opnd => | |
3417 | Make_Selected_Component (Loc, | |
3418 | Prefix => New_Value (Param), | |
3419 | Selector_Name => | |
3420 | New_Reference_To (First_Tag_Component (Typ), | |
3421 | Loc)), | |
3422 | ||
3423 | Right_Opnd => | |
3424 | Make_Selected_Component (Loc, | |
3425 | Prefix => | |
3426 | Unchecked_Convert_To (Typ, | |
3427 | New_Value (Next_Actual (Param))), | |
3428 | Selector_Name => | |
3429 | New_Reference_To | |
3430 | (First_Tag_Component (Typ), Loc))), | |
3431 | Right_Opnd => Prev_Call); | |
3432 | ||
3433 | Rewrite (Call_Node, New_Call); | |
3434 | ||
3435 | Analyze_And_Resolve | |
3436 | (Call_Node, Call_Typ, Suppress => All_Checks); | |
3437 | end if; | |
3438 | ||
6dfc5592 RD |
3439 | -- Expansion of a dispatching call results in an indirect call, |
3440 | -- which in turn causes current values to be killed (see | |
3441 | -- Resolve_Call), so on VM targets we do the call here to | |
3442 | -- ensure consistent warnings between VM and non-VM targets. | |
3443 | ||
3444 | Kill_Current_Values; | |
3445 | end if; | |
3446 | ||
3447 | -- If this is a dispatching "=" then we must update the reference | |
3448 | -- to the call node because we generated: | |
3449 | -- x.tag = y.tag and then x = y | |
3450 | ||
dd386db0 | 3451 | if Subp = Eq_Prim_Op then |
6dfc5592 RD |
3452 | Call_Node := Right_Opnd (Call_Node); |
3453 | end if; | |
3454 | end; | |
70f91180 | 3455 | end if; |
70482933 RK |
3456 | |
3457 | -- Similarly, expand calls to RCI subprograms on which pragma | |
3458 | -- All_Calls_Remote applies. The rewriting will be reanalyzed | |
b3f48fd4 AC |
3459 | -- later. Do this only when the call comes from source since we |
3460 | -- do not want such a rewriting to occur in expanded code. | |
70482933 | 3461 | |
6dfc5592 RD |
3462 | if Is_All_Remote_Call (Call_Node) then |
3463 | Expand_All_Calls_Remote_Subprogram_Call (Call_Node); | |
70482933 RK |
3464 | |
3465 | -- Similarly, do not add extra actuals for an entry call whose entity | |
3466 | -- is a protected procedure, or for an internal protected subprogram | |
3467 | -- call, because it will be rewritten as a protected subprogram call | |
3468 | -- and reanalyzed (see Expand_Protected_Subprogram_Call). | |
3469 | ||
3470 | elsif Is_Protected_Type (Scope (Subp)) | |
3471 | and then (Ekind (Subp) = E_Procedure | |
3472 | or else Ekind (Subp) = E_Function) | |
3473 | then | |
3474 | null; | |
3475 | ||
3476 | -- During that loop we gathered the extra actuals (the ones that | |
3477 | -- correspond to Extra_Formals), so now they can be appended. | |
3478 | ||
3479 | else | |
3480 | while Is_Non_Empty_List (Extra_Actuals) loop | |
3481 | Add_Actual_Parameter (Remove_Head (Extra_Actuals)); | |
3482 | end loop; | |
3483 | end if; | |
3484 | ||
b3f48fd4 AC |
3485 | -- At this point we have all the actuals, so this is the point at which |
3486 | -- the various expansion activities for actuals is carried out. | |
f44fe430 | 3487 | |
6dfc5592 | 3488 | Expand_Actuals (Call_Node, Subp); |
70482933 | 3489 | |
5f49133f AC |
3490 | -- Verify that the actuals do not share storage. This check must be done |
3491 | -- on the caller side rather that inside the subprogram to avoid issues | |
3492 | -- of parameter passing. | |
3493 | ||
3494 | if Check_Aliasing_Of_Parameters then | |
3495 | Apply_Parameter_Aliasing_Checks (Call_Node, Subp); | |
3496 | end if; | |
3497 | ||
b3f48fd4 AC |
3498 | -- If the subprogram is a renaming, or if it is inherited, replace it in |
3499 | -- the call with the name of the actual subprogram being called. If this | |
3500 | -- is a dispatching call, the run-time decides what to call. The Alias | |
3501 | -- attribute does not apply to entries. | |
70482933 | 3502 | |
6dfc5592 RD |
3503 | if Nkind (Call_Node) /= N_Entry_Call_Statement |
3504 | and then No (Controlling_Argument (Call_Node)) | |
70482933 | 3505 | and then Present (Parent_Subp) |
df3e68b1 | 3506 | and then not Is_Direct_Deep_Call (Subp) |
70482933 RK |
3507 | then |
3508 | if Present (Inherited_From_Formal (Subp)) then | |
3509 | Parent_Subp := Inherited_From_Formal (Subp); | |
3510 | else | |
b81a5940 | 3511 | Parent_Subp := Ultimate_Alias (Parent_Subp); |
70482933 RK |
3512 | end if; |
3513 | ||
c8ef728f ES |
3514 | -- The below setting of Entity is suspect, see F109-018 discussion??? |
3515 | ||
6dfc5592 | 3516 | Set_Entity (Name (Call_Node), Parent_Subp); |
70482933 | 3517 | |
f937473f | 3518 | if Is_Abstract_Subprogram (Parent_Subp) |
70482933 RK |
3519 | and then not In_Instance |
3520 | then | |
3521 | Error_Msg_NE | |
6dfc5592 RD |
3522 | ("cannot call abstract subprogram &!", |
3523 | Name (Call_Node), Parent_Subp); | |
70482933 RK |
3524 | end if; |
3525 | ||
d4817e3f HK |
3526 | -- Inspect all formals of derived subprogram Subp. Compare parameter |
3527 | -- types with the parent subprogram and check whether an actual may | |
3528 | -- need a type conversion to the corresponding formal of the parent | |
3529 | -- subprogram. | |
70482933 | 3530 | |
d4817e3f | 3531 | -- Not clear whether intrinsic subprograms need such conversions. ??? |
70482933 RK |
3532 | |
3533 | if not Is_Intrinsic_Subprogram (Parent_Subp) | |
3534 | or else Is_Generic_Instance (Parent_Subp) | |
3535 | then | |
d4817e3f HK |
3536 | declare |
3537 | procedure Convert (Act : Node_Id; Typ : Entity_Id); | |
3538 | -- Rewrite node Act as a type conversion of Act to Typ. Analyze | |
3539 | -- and resolve the newly generated construct. | |
70482933 | 3540 | |
d4817e3f HK |
3541 | ------------- |
3542 | -- Convert -- | |
3543 | ------------- | |
70482933 | 3544 | |
d4817e3f HK |
3545 | procedure Convert (Act : Node_Id; Typ : Entity_Id) is |
3546 | begin | |
3547 | Rewrite (Act, OK_Convert_To (Typ, Relocate_Node (Act))); | |
3548 | Analyze (Act); | |
3549 | Resolve (Act, Typ); | |
3550 | end Convert; | |
3551 | ||
3552 | -- Local variables | |
3553 | ||
3554 | Actual_Typ : Entity_Id; | |
3555 | Formal_Typ : Entity_Id; | |
3556 | Parent_Typ : Entity_Id; | |
3557 | ||
3558 | begin | |
6dfc5592 | 3559 | Actual := First_Actual (Call_Node); |
d4817e3f HK |
3560 | Formal := First_Formal (Subp); |
3561 | Parent_Formal := First_Formal (Parent_Subp); | |
3562 | while Present (Formal) loop | |
3563 | Actual_Typ := Etype (Actual); | |
3564 | Formal_Typ := Etype (Formal); | |
3565 | Parent_Typ := Etype (Parent_Formal); | |
3566 | ||
3567 | -- For an IN parameter of a scalar type, the parent formal | |
3568 | -- type and derived formal type differ or the parent formal | |
3569 | -- type and actual type do not match statically. | |
3570 | ||
3571 | if Is_Scalar_Type (Formal_Typ) | |
3572 | and then Ekind (Formal) = E_In_Parameter | |
3573 | and then Formal_Typ /= Parent_Typ | |
3574 | and then | |
3575 | not Subtypes_Statically_Match (Parent_Typ, Actual_Typ) | |
3576 | and then not Raises_Constraint_Error (Actual) | |
3577 | then | |
3578 | Convert (Actual, Parent_Typ); | |
3579 | Enable_Range_Check (Actual); | |
3580 | ||
d79e621a GD |
3581 | -- If the actual has been marked as requiring a range |
3582 | -- check, then generate it here. | |
3583 | ||
3584 | if Do_Range_Check (Actual) then | |
3585 | Set_Do_Range_Check (Actual, False); | |
3586 | Generate_Range_Check | |
3587 | (Actual, Etype (Formal), CE_Range_Check_Failed); | |
3588 | end if; | |
3589 | ||
d4817e3f HK |
3590 | -- For access types, the parent formal type and actual type |
3591 | -- differ. | |
3592 | ||
3593 | elsif Is_Access_Type (Formal_Typ) | |
3594 | and then Base_Type (Parent_Typ) /= Base_Type (Actual_Typ) | |
70482933 | 3595 | then |
d4817e3f HK |
3596 | if Ekind (Formal) /= E_In_Parameter then |
3597 | Convert (Actual, Parent_Typ); | |
3598 | ||
3599 | elsif Ekind (Parent_Typ) = E_Anonymous_Access_Type | |
3600 | and then Designated_Type (Parent_Typ) /= | |
3601 | Designated_Type (Actual_Typ) | |
3602 | and then not Is_Controlling_Formal (Formal) | |
3603 | then | |
3604 | -- This unchecked conversion is not necessary unless | |
3605 | -- inlining is enabled, because in that case the type | |
3606 | -- mismatch may become visible in the body about to be | |
3607 | -- inlined. | |
3608 | ||
3609 | Rewrite (Actual, | |
3610 | Unchecked_Convert_To (Parent_Typ, | |
3611 | Relocate_Node (Actual))); | |
d4817e3f HK |
3612 | Analyze (Actual); |
3613 | Resolve (Actual, Parent_Typ); | |
3614 | end if; | |
70482933 | 3615 | |
d4817e3f HK |
3616 | -- For array and record types, the parent formal type and |
3617 | -- derived formal type have different sizes or pragma Pack | |
3618 | -- status. | |
70482933 | 3619 | |
d4817e3f HK |
3620 | elsif ((Is_Array_Type (Formal_Typ) |
3621 | and then Is_Array_Type (Parent_Typ)) | |
3622 | or else | |
3623 | (Is_Record_Type (Formal_Typ) | |
3624 | and then Is_Record_Type (Parent_Typ))) | |
3625 | and then | |
3626 | (Esize (Formal_Typ) /= Esize (Parent_Typ) | |
3627 | or else Has_Pragma_Pack (Formal_Typ) /= | |
3628 | Has_Pragma_Pack (Parent_Typ)) | |
3629 | then | |
3630 | Convert (Actual, Parent_Typ); | |
70482933 | 3631 | end if; |
70482933 | 3632 | |
d4817e3f HK |
3633 | Next_Actual (Actual); |
3634 | Next_Formal (Formal); | |
3635 | Next_Formal (Parent_Formal); | |
3636 | end loop; | |
3637 | end; | |
70482933 RK |
3638 | end if; |
3639 | ||
3640 | Orig_Subp := Subp; | |
3641 | Subp := Parent_Subp; | |
3642 | end if; | |
3643 | ||
8a36a0cc AC |
3644 | -- Check for violation of No_Abort_Statements |
3645 | ||
273adcdf AC |
3646 | if Restriction_Check_Required (No_Abort_Statements) |
3647 | and then Is_RTE (Subp, RE_Abort_Task) | |
3648 | then | |
6dfc5592 | 3649 | Check_Restriction (No_Abort_Statements, Call_Node); |
8a36a0cc AC |
3650 | |
3651 | -- Check for violation of No_Dynamic_Attachment | |
3652 | ||
273adcdf AC |
3653 | elsif Restriction_Check_Required (No_Dynamic_Attachment) |
3654 | and then RTU_Loaded (Ada_Interrupts) | |
8a36a0cc AC |
3655 | and then (Is_RTE (Subp, RE_Is_Reserved) or else |
3656 | Is_RTE (Subp, RE_Is_Attached) or else | |
3657 | Is_RTE (Subp, RE_Current_Handler) or else | |
3658 | Is_RTE (Subp, RE_Attach_Handler) or else | |
3659 | Is_RTE (Subp, RE_Exchange_Handler) or else | |
3660 | Is_RTE (Subp, RE_Detach_Handler) or else | |
3661 | Is_RTE (Subp, RE_Reference)) | |
3662 | then | |
6dfc5592 | 3663 | Check_Restriction (No_Dynamic_Attachment, Call_Node); |
fbf5a39b AC |
3664 | end if; |
3665 | ||
8a36a0cc AC |
3666 | -- Deal with case where call is an explicit dereference |
3667 | ||
6dfc5592 | 3668 | if Nkind (Name (Call_Node)) = N_Explicit_Dereference then |
70482933 RK |
3669 | |
3670 | -- Handle case of access to protected subprogram type | |
3671 | ||
f937473f | 3672 | if Is_Access_Protected_Subprogram_Type |
6dfc5592 | 3673 | (Base_Type (Etype (Prefix (Name (Call_Node))))) |
70482933 | 3674 | then |
b3f48fd4 AC |
3675 | -- If this is a call through an access to protected operation, the |
3676 | -- prefix has the form (object'address, operation'access). Rewrite | |
3677 | -- as a for other protected calls: the object is the 1st parameter | |
3678 | -- of the list of actuals. | |
70482933 RK |
3679 | |
3680 | declare | |
3681 | Call : Node_Id; | |
3682 | Parm : List_Id; | |
3683 | Nam : Node_Id; | |
3684 | Obj : Node_Id; | |
6dfc5592 | 3685 | Ptr : constant Node_Id := Prefix (Name (Call_Node)); |
fbf5a39b AC |
3686 | |
3687 | T : constant Entity_Id := | |
3688 | Equivalent_Type (Base_Type (Etype (Ptr))); | |
3689 | ||
3690 | D_T : constant Entity_Id := | |
3691 | Designated_Type (Base_Type (Etype (Ptr))); | |
70482933 RK |
3692 | |
3693 | begin | |
f44fe430 RD |
3694 | Obj := |
3695 | Make_Selected_Component (Loc, | |
3696 | Prefix => Unchecked_Convert_To (T, Ptr), | |
3697 | Selector_Name => | |
3698 | New_Occurrence_Of (First_Entity (T), Loc)); | |
3699 | ||
3700 | Nam := | |
3701 | Make_Selected_Component (Loc, | |
3702 | Prefix => Unchecked_Convert_To (T, Ptr), | |
3703 | Selector_Name => | |
3704 | New_Occurrence_Of (Next_Entity (First_Entity (T)), Loc)); | |
70482933 | 3705 | |
02822a92 RD |
3706 | Nam := |
3707 | Make_Explicit_Dereference (Loc, | |
3708 | Prefix => Nam); | |
70482933 | 3709 | |
6dfc5592 RD |
3710 | if Present (Parameter_Associations (Call_Node)) then |
3711 | Parm := Parameter_Associations (Call_Node); | |
70482933 RK |
3712 | else |
3713 | Parm := New_List; | |
3714 | end if; | |
3715 | ||
3716 | Prepend (Obj, Parm); | |
3717 | ||
3718 | if Etype (D_T) = Standard_Void_Type then | |
02822a92 RD |
3719 | Call := |
3720 | Make_Procedure_Call_Statement (Loc, | |
3721 | Name => Nam, | |
3722 | Parameter_Associations => Parm); | |
70482933 | 3723 | else |
02822a92 RD |
3724 | Call := |
3725 | Make_Function_Call (Loc, | |
3726 | Name => Nam, | |
3727 | Parameter_Associations => Parm); | |
70482933 RK |
3728 | end if; |
3729 | ||
6dfc5592 | 3730 | Set_First_Named_Actual (Call, First_Named_Actual (Call_Node)); |
70482933 RK |
3731 | Set_Etype (Call, Etype (D_T)); |
3732 | ||
3733 | -- We do not re-analyze the call to avoid infinite recursion. | |
3734 | -- We analyze separately the prefix and the object, and set | |
3735 | -- the checks on the prefix that would otherwise be emitted | |
3736 | -- when resolving a call. | |
3737 | ||
6dfc5592 | 3738 | Rewrite (Call_Node, Call); |
70482933 RK |
3739 | Analyze (Nam); |
3740 | Apply_Access_Check (Nam); | |
3741 | Analyze (Obj); | |
3742 | return; | |
3743 | end; | |
3744 | end if; | |
3745 | end if; | |
3746 | ||
3747 | -- If this is a call to an intrinsic subprogram, then perform the | |
3748 | -- appropriate expansion to the corresponding tree node and we | |
a90bd866 | 3749 | -- are all done (since after that the call is gone). |
70482933 | 3750 | |
98f01d53 AC |
3751 | -- In the case where the intrinsic is to be processed by the back end, |
3752 | -- the call to Expand_Intrinsic_Call will do nothing, which is fine, | |
b3f48fd4 AC |
3753 | -- since the idea in this case is to pass the call unchanged. If the |
3754 | -- intrinsic is an inherited unchecked conversion, and the derived type | |
3755 | -- is the target type of the conversion, we must retain it as the return | |
3756 | -- type of the expression. Otherwise the expansion below, which uses the | |
3757 | -- parent operation, will yield the wrong type. | |
98f01d53 | 3758 | |
70482933 | 3759 | if Is_Intrinsic_Subprogram (Subp) then |
6dfc5592 | 3760 | Expand_Intrinsic_Call (Call_Node, Subp); |
d766cee3 | 3761 | |
6dfc5592 | 3762 | if Nkind (Call_Node) = N_Unchecked_Type_Conversion |
d766cee3 RD |
3763 | and then Parent_Subp /= Orig_Subp |
3764 | and then Etype (Parent_Subp) /= Etype (Orig_Subp) | |
3765 | then | |
6dfc5592 | 3766 | Set_Etype (Call_Node, Etype (Orig_Subp)); |
d766cee3 RD |
3767 | end if; |
3768 | ||
70482933 RK |
3769 | return; |
3770 | end if; | |
3771 | ||
b29def53 AC |
3772 | if Ekind_In (Subp, E_Function, E_Procedure) then |
3773 | ||
26a43556 | 3774 | -- We perform two simple optimization on calls: |
8dbf3473 | 3775 | |
3563739b | 3776 | -- a) replace calls to null procedures unconditionally; |
26a43556 | 3777 | |
3563739b | 3778 | -- b) for To_Address, just do an unchecked conversion. Not only is |
26a43556 AC |
3779 | -- this efficient, but it also avoids order of elaboration problems |
3780 | -- when address clauses are inlined (address expression elaborated | |
3781 | -- at the wrong point). | |
3782 | ||
3783 | -- We perform these optimization regardless of whether we are in the | |
3784 | -- main unit or in a unit in the context of the main unit, to ensure | |
2cbac6c6 | 3785 | -- that tree generated is the same in both cases, for CodePeer use. |
26a43556 AC |
3786 | |
3787 | if Is_RTE (Subp, RE_To_Address) then | |
6dfc5592 | 3788 | Rewrite (Call_Node, |
26a43556 | 3789 | Unchecked_Convert_To |
6dfc5592 | 3790 | (RTE (RE_Address), Relocate_Node (First_Actual (Call_Node)))); |
26a43556 AC |
3791 | return; |
3792 | ||
3793 | elsif Is_Null_Procedure (Subp) then | |
6dfc5592 | 3794 | Rewrite (Call_Node, Make_Null_Statement (Loc)); |
8dbf3473 AC |
3795 | return; |
3796 | end if; | |
3797 | ||
84f4072a JM |
3798 | -- Handle inlining (old semantics) |
3799 | ||
3800 | if Is_Inlined (Subp) and then not Debug_Flag_Dot_K then | |
a41ea816 | 3801 | Inlined_Subprogram : declare |
fbf5a39b AC |
3802 | Bod : Node_Id; |
3803 | Must_Inline : Boolean := False; | |
3804 | Spec : constant Node_Id := Unit_Declaration_Node (Subp); | |
a41ea816 | 3805 | |
70482933 | 3806 | begin |
2f1b20a9 ES |
3807 | -- Verify that the body to inline has already been seen, and |
3808 | -- that if the body is in the current unit the inlining does | |
3809 | -- not occur earlier. This avoids order-of-elaboration problems | |
3810 | -- in the back end. | |
3811 | ||
3812 | -- This should be documented in sinfo/einfo ??? | |
70482933 | 3813 | |
fbf5a39b AC |
3814 | if No (Spec) |
3815 | or else Nkind (Spec) /= N_Subprogram_Declaration | |
3816 | or else No (Body_To_Inline (Spec)) | |
70482933 | 3817 | then |
fbf5a39b AC |
3818 | Must_Inline := False; |
3819 | ||
26a43556 AC |
3820 | -- If this an inherited function that returns a private type, |
3821 | -- do not inline if the full view is an unconstrained array, | |
3822 | -- because such calls cannot be inlined. | |
5b4994bc AC |
3823 | |
3824 | elsif Present (Orig_Subp) | |
3825 | and then Is_Array_Type (Etype (Orig_Subp)) | |
3826 | and then not Is_Constrained (Etype (Orig_Subp)) | |
3827 | then | |
3828 | Must_Inline := False; | |
3829 | ||
84f4072a | 3830 | elsif In_Unfrozen_Instance (Scope (Subp)) then |
5b4994bc AC |
3831 | Must_Inline := False; |
3832 | ||
fbf5a39b AC |
3833 | else |
3834 | Bod := Body_To_Inline (Spec); | |
3835 | ||
6dfc5592 RD |
3836 | if (In_Extended_Main_Code_Unit (Call_Node) |
3837 | or else In_Extended_Main_Code_Unit (Parent (Call_Node)) | |
ac4d6407 | 3838 | or else Has_Pragma_Inline_Always (Subp)) |
fbf5a39b AC |
3839 | and then (not In_Same_Extended_Unit (Sloc (Bod), Loc) |
3840 | or else | |
3841 | Earlier_In_Extended_Unit (Sloc (Bod), Loc)) | |
3842 | then | |
3843 | Must_Inline := True; | |
3844 | ||
3845 | -- If we are compiling a package body that is not the main | |
3846 | -- unit, it must be for inlining/instantiation purposes, | |
3847 | -- in which case we inline the call to insure that the same | |
3848 | -- temporaries are generated when compiling the body by | |
3849 | -- itself. Otherwise link errors can occur. | |
3850 | ||
2820d220 AC |
3851 | -- If the function being called is itself in the main unit, |
3852 | -- we cannot inline, because there is a risk of double | |
3853 | -- elaboration and/or circularity: the inlining can make | |
3854 | -- visible a private entity in the body of the main unit, | |
3855 | -- that gigi will see before its sees its proper definition. | |
3856 | ||
6dfc5592 | 3857 | elsif not (In_Extended_Main_Code_Unit (Call_Node)) |
fbf5a39b AC |
3858 | and then In_Package_Body |
3859 | then | |
2820d220 | 3860 | Must_Inline := not In_Extended_Main_Source_Unit (Subp); |
fbf5a39b AC |
3861 | end if; |
3862 | end if; | |
3863 | ||
3864 | if Must_Inline then | |
6dfc5592 | 3865 | Expand_Inlined_Call (Call_Node, Subp, Orig_Subp); |
70482933 RK |
3866 | |
3867 | else | |
fbf5a39b | 3868 | -- Let the back end handle it |
70482933 RK |
3869 | |
3870 | Add_Inlined_Body (Subp); | |
3871 | ||
3872 | if Front_End_Inlining | |
3873 | and then Nkind (Spec) = N_Subprogram_Declaration | |
6dfc5592 | 3874 | and then (In_Extended_Main_Code_Unit (Call_Node)) |
70482933 RK |
3875 | and then No (Body_To_Inline (Spec)) |
3876 | and then not Has_Completion (Subp) | |
3877 | and then In_Same_Extended_Unit (Sloc (Spec), Loc) | |
70482933 | 3878 | then |
fbf5a39b | 3879 | Cannot_Inline |
685bc70f AC |
3880 | ("cannot inline& (body not seen yet)?", |
3881 | Call_Node, Subp); | |
70482933 RK |
3882 | end if; |
3883 | end if; | |
a41ea816 | 3884 | end Inlined_Subprogram; |
84f4072a JM |
3885 | |
3886 | -- Handle inlining (new semantics) | |
3887 | ||
3888 | elsif Is_Inlined (Subp) then | |
3889 | declare | |
3890 | Spec : constant Node_Id := Unit_Declaration_Node (Subp); | |
3891 | ||
3892 | begin | |
ea3a4ad0 | 3893 | if Must_Inline (Subp) then |
84f4072a JM |
3894 | if In_Extended_Main_Code_Unit (Call_Node) |
3895 | and then In_Same_Extended_Unit (Sloc (Spec), Loc) | |
3896 | and then not Has_Completion (Subp) | |
3897 | then | |
3898 | Cannot_Inline | |
3899 | ("cannot inline& (body not seen yet)?", | |
3900 | Call_Node, Subp); | |
3901 | ||
3902 | else | |
3903 | Do_Inline_Always (Subp, Orig_Subp); | |
3904 | end if; | |
ea3a4ad0 JM |
3905 | |
3906 | elsif Optimization_Level > 0 then | |
3907 | Do_Inline (Subp, Orig_Subp); | |
84f4072a JM |
3908 | end if; |
3909 | ||
3910 | -- The call may have been inlined or may have been passed to | |
3911 | -- the backend. No further action needed if it was inlined. | |
3912 | ||
3913 | if Nkind (N) /= N_Function_Call then | |
3914 | return; | |
3915 | end if; | |
3916 | end; | |
70482933 RK |
3917 | end if; |
3918 | end if; | |
3919 | ||
26a43556 AC |
3920 | -- Check for protected subprogram. This is either an intra-object call, |
3921 | -- or a protected function call. Protected procedure calls are rewritten | |
3922 | -- as entry calls and handled accordingly. | |
70482933 | 3923 | |
26a43556 AC |
3924 | -- In Ada 2005, this may be an indirect call to an access parameter that |
3925 | -- is an access_to_subprogram. In that case the anonymous type has a | |
3926 | -- scope that is a protected operation, but the call is a regular one. | |
6f76a257 | 3927 | -- In either case do not expand call if subprogram is eliminated. |
c8ef728f | 3928 | |
70482933 RK |
3929 | Scop := Scope (Subp); |
3930 | ||
6dfc5592 | 3931 | if Nkind (Call_Node) /= N_Entry_Call_Statement |
70482933 | 3932 | and then Is_Protected_Type (Scop) |
c8ef728f | 3933 | and then Ekind (Subp) /= E_Subprogram_Type |
6f76a257 | 3934 | and then not Is_Eliminated (Subp) |
70482933 | 3935 | then |
26a43556 AC |
3936 | -- If the call is an internal one, it is rewritten as a call to the |
3937 | -- corresponding unprotected subprogram. | |
70482933 | 3938 | |
6dfc5592 | 3939 | Expand_Protected_Subprogram_Call (Call_Node, Subp, Scop); |
70482933 RK |
3940 | end if; |
3941 | ||
df3e68b1 HK |
3942 | -- Functions returning controlled objects need special attention. If |
3943 | -- the return type is limited, then the context is initialization and | |
3944 | -- different processing applies. If the call is to a protected function, | |
3945 | -- the expansion above will call Expand_Call recursively. Otherwise the | |
3946 | -- function call is transformed into a temporary which obtains the | |
3947 | -- result from the secondary stack. | |
70482933 | 3948 | |
c768e988 | 3949 | if Needs_Finalization (Etype (Subp)) then |
51245e2d | 3950 | if not Is_Limited_View (Etype (Subp)) |
c768e988 AC |
3951 | and then |
3952 | (No (First_Formal (Subp)) | |
3953 | or else | |
3954 | not Is_Concurrent_Record_Type (Etype (First_Formal (Subp)))) | |
3955 | then | |
6dfc5592 | 3956 | Expand_Ctrl_Function_Call (Call_Node); |
c768e988 AC |
3957 | |
3958 | -- Build-in-place function calls which appear in anonymous contexts | |
3959 | -- need a transient scope to ensure the proper finalization of the | |
3960 | -- intermediate result after its use. | |
3961 | ||
6dfc5592 | 3962 | elsif Is_Build_In_Place_Function_Call (Call_Node) |
d3b00ce3 AC |
3963 | and then |
3964 | Nkind_In (Parent (Call_Node), N_Attribute_Reference, | |
3965 | N_Function_Call, | |
3966 | N_Indexed_Component, | |
3967 | N_Object_Renaming_Declaration, | |
3968 | N_Procedure_Call_Statement, | |
3969 | N_Selected_Component, | |
3970 | N_Slice) | |
c768e988 | 3971 | then |
6dfc5592 | 3972 | Establish_Transient_Scope (Call_Node, Sec_Stack => True); |
c768e988 | 3973 | end if; |
70482933 RK |
3974 | end if; |
3975 | ||
26a43556 AC |
3976 | -- Test for First_Optional_Parameter, and if so, truncate parameter list |
3977 | -- if there are optional parameters at the trailing end. | |
3978 | -- Note: we never delete procedures for call via a pointer. | |
70482933 RK |
3979 | |
3980 | if (Ekind (Subp) = E_Procedure or else Ekind (Subp) = E_Function) | |
3981 | and then Present (First_Optional_Parameter (Subp)) | |
3982 | then | |
3983 | declare | |
3984 | Last_Keep_Arg : Node_Id; | |
3985 | ||
3986 | begin | |
26a43556 AC |
3987 | -- Last_Keep_Arg will hold the last actual that should be kept. |
3988 | -- If it remains empty at the end, it means that all parameters | |
3989 | -- are optional. | |
70482933 RK |
3990 | |
3991 | Last_Keep_Arg := Empty; | |
3992 | ||
26a43556 AC |
3993 | -- Find first optional parameter, must be present since we checked |
3994 | -- the validity of the parameter before setting it. | |
70482933 RK |
3995 | |
3996 | Formal := First_Formal (Subp); | |
6dfc5592 | 3997 | Actual := First_Actual (Call_Node); |
70482933 RK |
3998 | while Formal /= First_Optional_Parameter (Subp) loop |
3999 | Last_Keep_Arg := Actual; | |
4000 | Next_Formal (Formal); | |
4001 | Next_Actual (Actual); | |
4002 | end loop; | |
4003 | ||
fbf5a39b AC |
4004 | -- We have Formal and Actual pointing to the first potentially |
4005 | -- droppable argument. We can drop all the trailing arguments | |
4006 | -- whose actual matches the default. Note that we know that all | |
4007 | -- remaining formals have defaults, because we checked that this | |
4008 | -- requirement was met before setting First_Optional_Parameter. | |
70482933 RK |
4009 | |
4010 | -- We use Fully_Conformant_Expressions to check for identity | |
4011 | -- between formals and actuals, which may miss some cases, but | |
4012 | -- on the other hand, this is only an optimization (if we fail | |
4013 | -- to truncate a parameter it does not affect functionality). | |
4014 | -- So if the default is 3 and the actual is 1+2, we consider | |
4015 | -- them unequal, which hardly seems worrisome. | |
4016 | ||
4017 | while Present (Formal) loop | |
4018 | if not Fully_Conformant_Expressions | |
4019 | (Actual, Default_Value (Formal)) | |
4020 | then | |
4021 | Last_Keep_Arg := Actual; | |
4022 | end if; | |
4023 | ||
4024 | Next_Formal (Formal); | |
4025 | Next_Actual (Actual); | |
4026 | end loop; | |
4027 | ||
4028 | -- If no arguments, delete entire list, this is the easy case | |
4029 | ||
4030 | if No (Last_Keep_Arg) then | |
6dfc5592 RD |
4031 | Set_Parameter_Associations (Call_Node, No_List); |
4032 | Set_First_Named_Actual (Call_Node, Empty); | |
70482933 RK |
4033 | |
4034 | -- Case where at the last retained argument is positional. This | |
4035 | -- is also an easy case, since the retained arguments are already | |
4036 | -- in the right form, and we don't need to worry about the order | |
4037 | -- of arguments that get eliminated. | |
4038 | ||
4039 | elsif Is_List_Member (Last_Keep_Arg) then | |
4040 | while Present (Next (Last_Keep_Arg)) loop | |
ac4d6407 | 4041 | Discard_Node (Remove_Next (Last_Keep_Arg)); |
70482933 RK |
4042 | end loop; |
4043 | ||
6dfc5592 | 4044 | Set_First_Named_Actual (Call_Node, Empty); |
70482933 RK |
4045 | |
4046 | -- This is the annoying case where the last retained argument | |
4047 | -- is a named parameter. Since the original arguments are not | |
4048 | -- in declaration order, we may have to delete some fairly | |
4049 | -- random collection of arguments. | |
4050 | ||
4051 | else | |
4052 | declare | |
4053 | Temp : Node_Id; | |
4054 | Passoc : Node_Id; | |
fbf5a39b | 4055 | |
70482933 RK |
4056 | begin |
4057 | -- First step, remove all the named parameters from the | |
4058 | -- list (they are still chained using First_Named_Actual | |
a90bd866 | 4059 | -- and Next_Named_Actual, so we have not lost them). |
70482933 | 4060 | |
6dfc5592 | 4061 | Temp := First (Parameter_Associations (Call_Node)); |
70482933 RK |
4062 | |
4063 | -- Case of all parameters named, remove them all | |
4064 | ||
4065 | if Nkind (Temp) = N_Parameter_Association then | |
6dfc5592 RD |
4066 | -- Suppress warnings to avoid warning on possible |
4067 | -- infinite loop (because Call_Node is not modified). | |
4068 | ||
4069 | pragma Warnings (Off); | |
4070 | while Is_Non_Empty_List | |
4071 | (Parameter_Associations (Call_Node)) | |
4072 | loop | |
4073 | Temp := | |
4074 | Remove_Head (Parameter_Associations (Call_Node)); | |
70482933 | 4075 | end loop; |
6dfc5592 | 4076 | pragma Warnings (On); |
70482933 RK |
4077 | |
4078 | -- Case of mixed positional/named, remove named parameters | |
4079 | ||
4080 | else | |
4081 | while Nkind (Next (Temp)) /= N_Parameter_Association loop | |
4082 | Next (Temp); | |
4083 | end loop; | |
4084 | ||
4085 | while Present (Next (Temp)) loop | |
7888a6ae | 4086 | Remove (Next (Temp)); |
70482933 RK |
4087 | end loop; |
4088 | end if; | |
4089 | ||
4090 | -- Now we loop through the named parameters, till we get | |
4091 | -- to the last one to be retained, adding them to the list. | |
4092 | -- Note that the Next_Named_Actual list does not need to be | |
4093 | -- touched since we are only reordering them on the actual | |
4094 | -- parameter association list. | |
4095 | ||
6dfc5592 | 4096 | Passoc := Parent (First_Named_Actual (Call_Node)); |
70482933 RK |
4097 | loop |
4098 | Temp := Relocate_Node (Passoc); | |
4099 | Append_To | |
6dfc5592 | 4100 | (Parameter_Associations (Call_Node), Temp); |
70482933 RK |
4101 | exit when |
4102 | Last_Keep_Arg = Explicit_Actual_Parameter (Passoc); | |
4103 | Passoc := Parent (Next_Named_Actual (Passoc)); | |
4104 | end loop; | |
4105 | ||
4106 | Set_Next_Named_Actual (Temp, Empty); | |
4107 | ||
4108 | loop | |
4109 | Temp := Next_Named_Actual (Passoc); | |
4110 | exit when No (Temp); | |
4111 | Set_Next_Named_Actual | |
4112 | (Passoc, Next_Named_Actual (Parent (Temp))); | |
70482933 RK |
4113 | end loop; |
4114 | end; | |
811c6a85 | 4115 | |
70482933 RK |
4116 | end if; |
4117 | end; | |
4118 | end if; | |
70482933 RK |
4119 | end Expand_Call; |
4120 | ||
8b404dac AC |
4121 | --------------------------- |
4122 | -- Expand_Contract_Cases -- | |
4123 | --------------------------- | |
4124 | ||
4125 | -- Pragma Contract_Cases is expanded in the following manner: | |
4126 | ||
4127 | -- subprogram S is | |
4128 | -- Flag_1 : Boolean := False; | |
4129 | -- . . . | |
4130 | -- Flag_N : Boolean := False; | |
4131 | -- Flag_N+1 : Boolean := False; -- when "others" present | |
4132 | -- Count : Natural := 0; | |
4133 | ||
4134 | -- <preconditions (if any)> | |
4135 | ||
4136 | -- if Case_Guard_1 then | |
4137 | -- Flag_1 := True; | |
4138 | -- Count := Count + 1; | |
4139 | -- end if; | |
4140 | -- . . . | |
4141 | -- if Case_Guard_N then | |
4142 | -- Flag_N := True; | |
4143 | -- Count := Count + 1; | |
4144 | -- end if; | |
4145 | ||
4146 | -- if Count = 0 then | |
4147 | -- raise Assertion_Error with "xxx contract cases incomplete"; | |
4148 | -- <or> | |
4149 | -- Flag_N+1 := True; -- when "others" present | |
4150 | ||
4151 | -- elsif Count > 1 then | |
4152 | -- declare | |
4153 | -- Str0 : constant String := | |
4154 | -- "contract cases overlap for subprogram ABC"; | |
4155 | -- Str1 : constant String := | |
4156 | -- (if Flag_1 then | |
4157 | -- Str0 & "case guard at xxx evaluates to True" | |
4158 | -- else Str0); | |
4159 | -- StrN : constant String := | |
4160 | -- (if Flag_N then | |
4161 | -- StrN-1 & "case guard at xxx evaluates to True" | |
4162 | -- else StrN-1); | |
4163 | -- begin | |
4164 | -- raise Assertion_Error with StrN; | |
4165 | -- end; | |
4166 | -- end if; | |
4167 | ||
4168 | -- procedure _Postconditions is | |
4169 | -- begin | |
4170 | -- <postconditions (if any)> | |
4171 | ||
4172 | -- if Flag_1 and then not Consequence_1 then | |
4173 | -- raise Assertion_Error with "failed contract case at xxx"; | |
4174 | -- end if; | |
4175 | -- . . . | |
4176 | -- if Flag_N[+1] and then not Consequence_N[+1] then | |
4177 | -- raise Assertion_Error with "failed contract case at xxx"; | |
4178 | -- end if; | |
4179 | -- end _Postconditions; | |
4180 | -- begin | |
4181 | -- . . . | |
4182 | -- end S; | |
4183 | ||
4184 | procedure Expand_Contract_Cases | |
4185 | (CCs : Node_Id; | |
4186 | Subp_Id : Entity_Id; | |
4187 | Decls : List_Id; | |
4188 | Stmts : in out List_Id) | |
4189 | is | |
4190 | Loc : constant Source_Ptr := Sloc (CCs); | |
4191 | ||
4192 | procedure Case_Guard_Error | |
4193 | (Decls : List_Id; | |
4194 | Flag : Entity_Id; | |
4195 | Error_Loc : Source_Ptr; | |
4196 | Msg : in out Entity_Id); | |
4197 | -- Given a declarative list Decls, status flag Flag, the location of the | |
4198 | -- error and a string Msg, construct the following check: | |
4199 | -- Msg : constant String := | |
4200 | -- (if Flag then | |
4201 | -- Msg & "case guard at Error_Loc evaluates to True" | |
4202 | -- else Msg); | |
4203 | -- The resulting code is added to Decls | |
4204 | ||
4205 | procedure Consequence_Error | |
4206 | (Checks : in out Node_Id; | |
4207 | Flag : Entity_Id; | |
4208 | Conseq : Node_Id); | |
4209 | -- Given an if statement Checks, status flag Flag and a consequence | |
4210 | -- Conseq, construct the following check: | |
4211 | -- [els]if Flag and then not Conseq then | |
4212 | -- raise Assertion_Error | |
4213 | -- with "failed contract case at Sloc (Conseq)"; | |
4214 | -- [end if;] | |
4215 | -- The resulting code is added to Checks | |
4216 | ||
4217 | function Declaration_Of (Id : Entity_Id) return Node_Id; | |
4218 | -- Given the entity Id of a boolean flag, generate: | |
4219 | -- Id : Boolean := False; | |
4220 | ||
4221 | function Increment (Id : Entity_Id) return Node_Id; | |
4222 | -- Given the entity Id of a numerical variable, generate: | |
4223 | -- Id := Id + 1; | |
4224 | ||
4225 | function Set (Id : Entity_Id) return Node_Id; | |
4226 | -- Given the entity Id of a boolean variable, generate: | |
4227 | -- Id := True; | |
4228 | ||
4229 | ---------------------- | |
4230 | -- Case_Guard_Error -- | |
4231 | ---------------------- | |
4232 | ||
4233 | procedure Case_Guard_Error | |
4234 | (Decls : List_Id; | |
4235 | Flag : Entity_Id; | |
4236 | Error_Loc : Source_Ptr; | |
4237 | Msg : in out Entity_Id) | |
4238 | is | |
4239 | New_Line : constant Character := Character'Val (10); | |
4240 | New_Msg : constant Entity_Id := Make_Temporary (Loc, 'S'); | |
4241 | ||
4242 | begin | |
4243 | Start_String; | |
4244 | Store_String_Char (New_Line); | |
4245 | Store_String_Chars (" case guard at "); | |
4246 | Store_String_Chars (Build_Location_String (Error_Loc)); | |
4247 | Store_String_Chars (" evaluates to True"); | |
4248 | ||
4249 | -- Generate: | |
4250 | -- New_Msg : constant String := | |
4251 | -- (if Flag then | |
4252 | -- Msg & "case guard at Error_Loc evaluates to True" | |
4253 | -- else Msg); | |
4254 | ||
4255 | Append_To (Decls, | |
4256 | Make_Object_Declaration (Loc, | |
4257 | Defining_Identifier => New_Msg, | |
4258 | Constant_Present => True, | |
4259 | Object_Definition => New_Reference_To (Standard_String, Loc), | |
4260 | Expression => | |
4261 | Make_If_Expression (Loc, | |
4262 | Expressions => New_List ( | |
4263 | New_Reference_To (Flag, Loc), | |
4264 | ||
4265 | Make_Op_Concat (Loc, | |
4266 | Left_Opnd => New_Reference_To (Msg, Loc), | |
4267 | Right_Opnd => Make_String_Literal (Loc, End_String)), | |
4268 | ||
4269 | New_Reference_To (Msg, Loc))))); | |
4270 | ||
4271 | Msg := New_Msg; | |
4272 | end Case_Guard_Error; | |
4273 | ||
4274 | ----------------------- | |
4275 | -- Consequence_Error -- | |
4276 | ----------------------- | |
4277 | ||
4278 | procedure Consequence_Error | |
4279 | (Checks : in out Node_Id; | |
4280 | Flag : Entity_Id; | |
4281 | Conseq : Node_Id) | |
4282 | is | |
4283 | Cond : Node_Id; | |
4284 | Error : Node_Id; | |
4285 | ||
4286 | begin | |
4287 | -- Generate: | |
4288 | -- Flag and then not Conseq | |
4289 | ||
4290 | Cond := | |
4291 | Make_And_Then (Loc, | |
4292 | Left_Opnd => New_Reference_To (Flag, Loc), | |
4293 | Right_Opnd => | |
4294 | Make_Op_Not (Loc, | |
4295 | Right_Opnd => Relocate_Node (Conseq))); | |
4296 | ||
4297 | -- Generate: | |
4298 | -- raise Assertion_Error | |
4299 | -- with "failed contract case at Sloc (Conseq)"; | |
4300 | ||
4301 | Start_String; | |
4302 | Store_String_Chars ("failed contract case at "); | |
4303 | Store_String_Chars (Build_Location_String (Sloc (Conseq))); | |
4304 | ||
4305 | Error := | |
4306 | Make_Procedure_Call_Statement (Loc, | |
4307 | Name => | |
4308 | New_Reference_To (RTE (RE_Raise_Assert_Failure), Loc), | |
4309 | Parameter_Associations => New_List ( | |
4310 | Make_String_Literal (Loc, End_String))); | |
4311 | ||
4312 | if No (Checks) then | |
4313 | Checks := | |
3cd4a210 | 4314 | Make_Implicit_If_Statement (CCs, |
8b404dac AC |
4315 | Condition => Cond, |
4316 | Then_Statements => New_List (Error)); | |
4317 | ||
4318 | else | |
4319 | if No (Elsif_Parts (Checks)) then | |
4320 | Set_Elsif_Parts (Checks, New_List); | |
4321 | end if; | |
4322 | ||
4323 | Append_To (Elsif_Parts (Checks), | |
4324 | Make_Elsif_Part (Loc, | |
4325 | Condition => Cond, | |
4326 | Then_Statements => New_List (Error))); | |
4327 | end if; | |
4328 | end Consequence_Error; | |
4329 | ||
4330 | -------------------- | |
4331 | -- Declaration_Of -- | |
4332 | -------------------- | |
4333 | ||
4334 | function Declaration_Of (Id : Entity_Id) return Node_Id is | |
4335 | begin | |
4336 | return | |
4337 | Make_Object_Declaration (Loc, | |
4338 | Defining_Identifier => Id, | |
4339 | Object_Definition => New_Reference_To (Standard_Boolean, Loc), | |
4340 | Expression => New_Reference_To (Standard_False, Loc)); | |
4341 | end Declaration_Of; | |
4342 | ||
4343 | --------------- | |
4344 | -- Increment -- | |
4345 | --------------- | |
4346 | ||
4347 | function Increment (Id : Entity_Id) return Node_Id is | |
4348 | begin | |
4349 | return | |
4350 | Make_Assignment_Statement (Loc, | |
4351 | Name => New_Reference_To (Id, Loc), | |
4352 | Expression => | |
4353 | Make_Op_Add (Loc, | |
4354 | Left_Opnd => New_Reference_To (Id, Loc), | |
4355 | Right_Opnd => Make_Integer_Literal (Loc, 1))); | |
4356 | end Increment; | |
4357 | ||
4358 | --------- | |
4359 | -- Set -- | |
4360 | --------- | |
4361 | ||
4362 | function Set (Id : Entity_Id) return Node_Id is | |
4363 | begin | |
4364 | return | |
4365 | Make_Assignment_Statement (Loc, | |
4366 | Name => New_Reference_To (Id, Loc), | |
4367 | Expression => New_Reference_To (Standard_True, Loc)); | |
4368 | end Set; | |
4369 | ||
4370 | -- Local variables | |
4371 | ||
4372 | Aggr : constant Node_Id := | |
4373 | Expression (First | |
4374 | (Pragma_Argument_Associations (CCs))); | |
4375 | Case_Guard : Node_Id; | |
4376 | CG_Checks : Node_Id; | |
4377 | CG_Stmts : List_Id; | |
4378 | Conseq : Node_Id; | |
4379 | Conseq_Checks : Node_Id := Empty; | |
4380 | Count : Entity_Id; | |
4381 | Error_Decls : List_Id; | |
4382 | Flag : Entity_Id; | |
4383 | Msg_Str : Entity_Id; | |
4384 | Multiple_PCs : Boolean; | |
4385 | Others_Flag : Entity_Id := Empty; | |
4386 | Post_Case : Node_Id; | |
4387 | ||
4388 | -- Start of processing for Expand_Contract_Cases | |
4389 | ||
4390 | begin | |
4391 | -- Do nothing if pragma is not enabled. If pragma is disabled, it has | |
4392 | -- already been rewritten as a Null statement. | |
4393 | ||
4394 | if Is_Ignored (CCs) then | |
4395 | return; | |
4396 | ||
4397 | -- Guard against malformed contract cases | |
4398 | ||
4399 | elsif Nkind (Aggr) /= N_Aggregate then | |
4400 | return; | |
4401 | end if; | |
4402 | ||
4403 | Multiple_PCs := List_Length (Component_Associations (Aggr)) > 1; | |
4404 | ||
4405 | -- Create the counter which tracks the number of case guards that | |
4406 | -- evaluate to True. | |
4407 | ||
4408 | -- Count : Natural := 0; | |
4409 | ||
4410 | Count := Make_Temporary (Loc, 'C'); | |
4411 | ||
4412 | Prepend_To (Decls, | |
4413 | Make_Object_Declaration (Loc, | |
4414 | Defining_Identifier => Count, | |
4415 | Object_Definition => New_Reference_To (Standard_Natural, Loc), | |
4416 | Expression => Make_Integer_Literal (Loc, 0))); | |
4417 | ||
4418 | -- Create the base error message for multiple overlapping case guards | |
4419 | ||
4420 | -- Msg_Str : constant String := | |
4421 | -- "contract cases overlap for subprogram Subp_Id"; | |
4422 | ||
4423 | if Multiple_PCs then | |
4424 | Msg_Str := Make_Temporary (Loc, 'S'); | |
4425 | ||
4426 | Start_String; | |
4427 | Store_String_Chars ("contract cases overlap for subprogram "); | |
4428 | Store_String_Chars (Get_Name_String (Chars (Subp_Id))); | |
4429 | ||
4430 | Error_Decls := New_List ( | |
4431 | Make_Object_Declaration (Loc, | |
4432 | Defining_Identifier => Msg_Str, | |
4433 | Constant_Present => True, | |
4434 | Object_Definition => New_Reference_To (Standard_String, Loc), | |
4435 | Expression => Make_String_Literal (Loc, End_String))); | |
4436 | end if; | |
4437 | ||
4438 | -- Process individual post cases | |
4439 | ||
4440 | Post_Case := First (Component_Associations (Aggr)); | |
4441 | while Present (Post_Case) loop | |
4442 | Case_Guard := First (Choices (Post_Case)); | |
4443 | Conseq := Expression (Post_Case); | |
4444 | ||
4445 | -- The "others" choice requires special processing | |
4446 | ||
4447 | if Nkind (Case_Guard) = N_Others_Choice then | |
4448 | Others_Flag := Make_Temporary (Loc, 'F'); | |
4449 | Prepend_To (Decls, Declaration_Of (Others_Flag)); | |
4450 | ||
4451 | -- Check possible overlap between a case guard and "others" | |
4452 | ||
4453 | if Multiple_PCs and Exception_Extra_Info then | |
4454 | Case_Guard_Error | |
4455 | (Decls => Error_Decls, | |
4456 | Flag => Others_Flag, | |
4457 | Error_Loc => Sloc (Case_Guard), | |
4458 | Msg => Msg_Str); | |
4459 | end if; | |
4460 | ||
4461 | -- Check the corresponding consequence of "others" | |
4462 | ||
4463 | Consequence_Error | |
4464 | (Checks => Conseq_Checks, | |
4465 | Flag => Others_Flag, | |
4466 | Conseq => Conseq); | |
4467 | ||
4468 | -- Regular post case | |
4469 | ||
4470 | else | |
4471 | -- Create the flag which tracks the state of its associated case | |
4472 | -- guard. | |
4473 | ||
4474 | Flag := Make_Temporary (Loc, 'F'); | |
4475 | Prepend_To (Decls, Declaration_Of (Flag)); | |
4476 | ||
4477 | -- The flag is set when the case guard is evaluated to True | |
4478 | -- if Case_Guard then | |
4479 | -- Flag := True; | |
4480 | -- Count := Count + 1; | |
4481 | -- end if; | |
4482 | ||
4483 | Append_To (Decls, | |
3cd4a210 | 4484 | Make_Implicit_If_Statement (CCs, |
8b404dac AC |
4485 | Condition => Relocate_Node (Case_Guard), |
4486 | Then_Statements => New_List ( | |
4487 | Set (Flag), | |
4488 | Increment (Count)))); | |
4489 | ||
4490 | -- Check whether this case guard overlaps with another one | |
4491 | ||
4492 | if Multiple_PCs and Exception_Extra_Info then | |
4493 | Case_Guard_Error | |
4494 | (Decls => Error_Decls, | |
4495 | Flag => Flag, | |
4496 | Error_Loc => Sloc (Case_Guard), | |
4497 | Msg => Msg_Str); | |
4498 | end if; | |
4499 | ||
4500 | -- The corresponding consequence of the case guard which evaluated | |
4501 | -- to True must hold on exit from the subprogram. | |
4502 | ||
4503 | Consequence_Error | |
4504 | (Checks => Conseq_Checks, | |
4505 | Flag => Flag, | |
4506 | Conseq => Conseq); | |
4507 | end if; | |
4508 | ||
4509 | Next (Post_Case); | |
4510 | end loop; | |
4511 | ||
4512 | -- Raise Assertion_Error when none of the case guards evaluate to True. | |
4513 | -- The only exception is when we have "others", in which case there is | |
4514 | -- no error because "others" acts as a default True. | |
4515 | ||
4516 | -- Generate: | |
4517 | -- Flag := True; | |
4518 | ||
4519 | if Present (Others_Flag) then | |
4520 | CG_Stmts := New_List (Set (Others_Flag)); | |
4521 | ||
4522 | -- Generate: | |
4523 | -- raise Assertion_Error with "xxx contract cases incomplete"; | |
4524 | ||
4525 | else | |
4526 | Start_String; | |
4527 | Store_String_Chars (Build_Location_String (Loc)); | |
4528 | Store_String_Chars (" contract cases incomplete"); | |
4529 | ||
4530 | CG_Stmts := New_List ( | |
4531 | Make_Procedure_Call_Statement (Loc, | |
4532 | Name => | |
4533 | New_Reference_To (RTE (RE_Raise_Assert_Failure), Loc), | |
4534 | Parameter_Associations => New_List ( | |
4535 | Make_String_Literal (Loc, End_String)))); | |
4536 | end if; | |
4537 | ||
4538 | CG_Checks := | |
3cd4a210 | 4539 | Make_Implicit_If_Statement (CCs, |
8b404dac AC |
4540 | Condition => |
4541 | Make_Op_Eq (Loc, | |
4542 | Left_Opnd => New_Reference_To (Count, Loc), | |
4543 | Right_Opnd => Make_Integer_Literal (Loc, 0)), | |
4544 | Then_Statements => CG_Stmts); | |
4545 | ||
4546 | -- Detect a possible failure due to several case guards evaluating to | |
4547 | -- True. | |
4548 | ||
4549 | -- Generate: | |
4550 | -- elsif Count > 0 then | |
4551 | -- declare | |
4552 | -- <Error_Decls> | |
4553 | -- begin | |
4554 | -- raise Assertion_Error with <Msg_Str>; | |
4555 | -- end if; | |
4556 | ||
4557 | if Multiple_PCs then | |
4558 | Set_Elsif_Parts (CG_Checks, New_List ( | |
4559 | Make_Elsif_Part (Loc, | |
4560 | Condition => | |
4561 | Make_Op_Gt (Loc, | |
4562 | Left_Opnd => New_Reference_To (Count, Loc), | |
4563 | Right_Opnd => Make_Integer_Literal (Loc, 1)), | |
4564 | ||
4565 | Then_Statements => New_List ( | |
4566 | Make_Block_Statement (Loc, | |
4567 | Declarations => Error_Decls, | |
4568 | Handled_Statement_Sequence => | |
4569 | Make_Handled_Sequence_Of_Statements (Loc, | |
4570 | Statements => New_List ( | |
4571 | Make_Procedure_Call_Statement (Loc, | |
4572 | Name => | |
4573 | New_Reference_To | |
4574 | (RTE (RE_Raise_Assert_Failure), Loc), | |
4575 | Parameter_Associations => New_List ( | |
4576 | New_Reference_To (Msg_Str, Loc)))))))))); | |
4577 | end if; | |
4578 | ||
4579 | Append_To (Decls, CG_Checks); | |
4580 | ||
4581 | -- Raise Assertion_Error when the corresponding consequence of a case | |
4582 | -- guard that evaluated to True fails. | |
4583 | ||
4584 | if No (Stmts) then | |
4585 | Stmts := New_List; | |
4586 | end if; | |
4587 | ||
4588 | Append_To (Stmts, Conseq_Checks); | |
4589 | end Expand_Contract_Cases; | |
4590 | ||
df3e68b1 HK |
4591 | ------------------------------- |
4592 | -- Expand_Ctrl_Function_Call -- | |
4593 | ------------------------------- | |
4594 | ||
4595 | procedure Expand_Ctrl_Function_Call (N : Node_Id) is | |
4596 | begin | |
4597 | -- Optimization, if the returned value (which is on the sec-stack) is | |
4598 | -- returned again, no need to copy/readjust/finalize, we can just pass | |
4599 | -- the value thru (see Expand_N_Simple_Return_Statement), and thus no | |
4600 | -- attachment is needed | |
4601 | ||
4602 | if Nkind (Parent (N)) = N_Simple_Return_Statement then | |
4603 | return; | |
4604 | end if; | |
4605 | ||
4606 | -- Resolution is now finished, make sure we don't start analysis again | |
4607 | -- because of the duplication. | |
4608 | ||
4609 | Set_Analyzed (N); | |
4610 | ||
4611 | -- A function which returns a controlled object uses the secondary | |
4612 | -- stack. Rewrite the call into a temporary which obtains the result of | |
4613 | -- the function using 'reference. | |
4614 | ||
4615 | Remove_Side_Effects (N); | |
3cebd1c0 | 4616 | |
4c7e0990 AC |
4617 | -- When the temporary function result appears inside a case or an if |
4618 | -- expression, its lifetime must be extended to match that of the | |
4619 | -- context. If not, the function result would be finalized prematurely | |
4620 | -- and the evaluation of the expression could yield the wrong result. | |
3cebd1c0 | 4621 | |
4c7e0990 | 4622 | if Within_Case_Or_If_Expression (N) |
3cebd1c0 AC |
4623 | and then Nkind (N) = N_Explicit_Dereference |
4624 | then | |
4625 | Set_Is_Processed_Transient (Entity (Prefix (N))); | |
4626 | end if; | |
df3e68b1 HK |
4627 | end Expand_Ctrl_Function_Call; |
4628 | ||
84f4072a | 4629 | ------------------------- |
70482933 | 4630 | -- Expand_Inlined_Call -- |
84f4072a | 4631 | ------------------------- |
70482933 RK |
4632 | |
4633 | procedure Expand_Inlined_Call | |
4634 | (N : Node_Id; | |
4635 | Subp : Entity_Id; | |
4636 | Orig_Subp : Entity_Id) | |
4637 | is | |
fbf5a39b AC |
4638 | Loc : constant Source_Ptr := Sloc (N); |
4639 | Is_Predef : constant Boolean := | |
4640 | Is_Predefined_File_Name | |
4641 | (Unit_File_Name (Get_Source_Unit (Subp))); | |
4642 | Orig_Bod : constant Node_Id := | |
4643 | Body_To_Inline (Unit_Declaration_Node (Subp)); | |
4644 | ||
70482933 | 4645 | Blk : Node_Id; |
70482933 | 4646 | Decl : Node_Id; |
c8ef728f | 4647 | Decls : constant List_Id := New_List; |
70482933 RK |
4648 | Exit_Lab : Entity_Id := Empty; |
4649 | F : Entity_Id; | |
4650 | A : Node_Id; | |
4651 | Lab_Decl : Node_Id; | |
4652 | Lab_Id : Node_Id; | |
4653 | New_A : Node_Id; | |
4654 | Num_Ret : Int := 0; | |
70482933 | 4655 | Ret_Type : Entity_Id; |
f4f92d9d AC |
4656 | |
4657 | Targ : Node_Id; | |
4658 | -- The target of the call. If context is an assignment statement then | |
bde73c6b | 4659 | -- this is the left-hand side of the assignment, else it is a temporary |
f4f92d9d AC |
4660 | -- to which the return value is assigned prior to rewriting the call. |
4661 | ||
4662 | Targ1 : Node_Id; | |
4663 | -- A separate target used when the return type is unconstrained | |
4664 | ||
70482933 RK |
4665 | Temp : Entity_Id; |
4666 | Temp_Typ : Entity_Id; | |
4667 | ||
3e2399ba AC |
4668 | Return_Object : Entity_Id := Empty; |
4669 | -- Entity in declaration in an extended_return_statement | |
4670 | ||
84f4072a JM |
4671 | Is_Unc : Boolean; |
4672 | Is_Unc_Decl : Boolean; | |
26a43556 AC |
4673 | -- If the type returned by the function is unconstrained and the call |
4674 | -- can be inlined, special processing is required. | |
c8ef728f | 4675 | |
70482933 | 4676 | procedure Make_Exit_Label; |
26a43556 | 4677 | -- Build declaration for exit label to be used in Return statements, |
c12beea0 RD |
4678 | -- sets Exit_Lab (the label node) and Lab_Decl (corresponding implicit |
4679 | -- declaration). Does nothing if Exit_Lab already set. | |
70482933 RK |
4680 | |
4681 | function Process_Formals (N : Node_Id) return Traverse_Result; | |
26a43556 | 4682 | -- Replace occurrence of a formal with the corresponding actual, or the |
5884c232 AC |
4683 | -- thunk generated for it. Replace a return statement with an assignment |
4684 | -- to the target of the call, with appropriate conversions if needed. | |
70482933 | 4685 | |
fbf5a39b | 4686 | function Process_Sloc (Nod : Node_Id) return Traverse_Result; |
26a43556 AC |
4687 | -- If the call being expanded is that of an internal subprogram, set the |
4688 | -- sloc of the generated block to that of the call itself, so that the | |
4689 | -- expansion is skipped by the "next" command in gdb. | |
fbf5a39b | 4690 | -- Same processing for a subprogram in a predefined file, e.g. |
26a43556 AC |
4691 | -- Ada.Tags. If Debug_Generated_Code is true, suppress this change to |
4692 | -- simplify our own development. | |
fbf5a39b | 4693 | |
84f4072a JM |
4694 | procedure Reset_Dispatching_Calls (N : Node_Id); |
4695 | -- In subtree N search for occurrences of dispatching calls that use the | |
4696 | -- Ada 2005 Object.Operation notation and the object is a formal of the | |
bde73c6b AC |
4697 | -- inlined subprogram. Reset the entity associated with Operation in all |
4698 | -- the found occurrences. | |
84f4072a | 4699 | |
70482933 RK |
4700 | procedure Rewrite_Function_Call (N : Node_Id; Blk : Node_Id); |
4701 | -- If the function body is a single expression, replace call with | |
4702 | -- expression, else insert block appropriately. | |
4703 | ||
4704 | procedure Rewrite_Procedure_Call (N : Node_Id; Blk : Node_Id); | |
4705 | -- If procedure body has no local variables, inline body without | |
02822a92 | 4706 | -- creating block, otherwise rewrite call with block. |
70482933 | 4707 | |
5453d5bd AC |
4708 | function Formal_Is_Used_Once (Formal : Entity_Id) return Boolean; |
4709 | -- Determine whether a formal parameter is used only once in Orig_Bod | |
4710 | ||
70482933 RK |
4711 | --------------------- |
4712 | -- Make_Exit_Label -- | |
4713 | --------------------- | |
4714 | ||
4715 | procedure Make_Exit_Label is | |
c12beea0 | 4716 | Lab_Ent : Entity_Id; |
70482933 | 4717 | begin |
70482933 | 4718 | if No (Exit_Lab) then |
c12beea0 RD |
4719 | Lab_Ent := Make_Temporary (Loc, 'L'); |
4720 | Lab_Id := New_Reference_To (Lab_Ent, Loc); | |
70482933 | 4721 | Exit_Lab := Make_Label (Loc, Lab_Id); |
70482933 RK |
4722 | Lab_Decl := |
4723 | Make_Implicit_Label_Declaration (Loc, | |
c12beea0 | 4724 | Defining_Identifier => Lab_Ent, |
70482933 RK |
4725 | Label_Construct => Exit_Lab); |
4726 | end if; | |
4727 | end Make_Exit_Label; | |
4728 | ||
4729 | --------------------- | |
4730 | -- Process_Formals -- | |
4731 | --------------------- | |
4732 | ||
4733 | function Process_Formals (N : Node_Id) return Traverse_Result is | |
4734 | A : Entity_Id; | |
4735 | E : Entity_Id; | |
4736 | Ret : Node_Id; | |
4737 | ||
4738 | begin | |
4bb43ffb | 4739 | if Is_Entity_Name (N) and then Present (Entity (N)) then |
70482933 RK |
4740 | E := Entity (N); |
4741 | ||
d7761b2d | 4742 | if Is_Formal (E) and then Scope (E) = Subp then |
70482933 RK |
4743 | A := Renamed_Object (E); |
4744 | ||
02822a92 RD |
4745 | -- Rewrite the occurrence of the formal into an occurrence of |
4746 | -- the actual. Also establish visibility on the proper view of | |
4747 | -- the actual's subtype for the body's context (if the actual's | |
4748 | -- subtype is private at the call point but its full view is | |
4749 | -- visible to the body, then the inlined tree here must be | |
4750 | -- analyzed with the full view). | |
4751 | ||
70482933 RK |
4752 | if Is_Entity_Name (A) then |
4753 | Rewrite (N, New_Occurrence_Of (Entity (A), Loc)); | |
02822a92 | 4754 | Check_Private_View (N); |
70482933 RK |
4755 | |
4756 | elsif Nkind (A) = N_Defining_Identifier then | |
4757 | Rewrite (N, New_Occurrence_Of (A, Loc)); | |
02822a92 | 4758 | Check_Private_View (N); |
70482933 | 4759 | |
d766cee3 RD |
4760 | -- Numeric literal |
4761 | ||
4762 | else | |
70482933 RK |
4763 | Rewrite (N, New_Copy (A)); |
4764 | end if; | |
4765 | end if; | |
f4f92d9d | 4766 | |
3e2399ba AC |
4767 | return Skip; |
4768 | ||
4769 | elsif Is_Entity_Name (N) | |
9f5b6c7f | 4770 | and then Present (Return_Object) |
3e2399ba AC |
4771 | and then Chars (N) = Chars (Return_Object) |
4772 | then | |
4773 | -- Occurrence within an extended return statement. The return | |
4774 | -- object is local to the body been inlined, and thus the generic | |
4775 | -- copy is not analyzed yet, so we match by name, and replace it | |
4776 | -- with target of call. | |
4777 | ||
4778 | if Nkind (Targ) = N_Defining_Identifier then | |
4779 | Rewrite (N, New_Occurrence_Of (Targ, Loc)); | |
4780 | else | |
4781 | Rewrite (N, New_Copy_Tree (Targ)); | |
4782 | end if; | |
70482933 RK |
4783 | |
4784 | return Skip; | |
4785 | ||
d766cee3 | 4786 | elsif Nkind (N) = N_Simple_Return_Statement then |
70482933 RK |
4787 | if No (Expression (N)) then |
4788 | Make_Exit_Label; | |
d766cee3 | 4789 | Rewrite (N, |
3e2399ba | 4790 | Make_Goto_Statement (Loc, Name => New_Copy (Lab_Id))); |
70482933 RK |
4791 | |
4792 | else | |
4793 | if Nkind (Parent (N)) = N_Handled_Sequence_Of_Statements | |
4794 | and then Nkind (Parent (Parent (N))) = N_Subprogram_Body | |
4795 | then | |
fbf5a39b | 4796 | -- Function body is a single expression. No need for |
70482933 | 4797 | -- exit label. |
fbf5a39b | 4798 | |
70482933 RK |
4799 | null; |
4800 | ||
4801 | else | |
4802 | Num_Ret := Num_Ret + 1; | |
4803 | Make_Exit_Label; | |
4804 | end if; | |
4805 | ||
4806 | -- Because of the presence of private types, the views of the | |
4807 | -- expression and the context may be different, so place an | |
4808 | -- unchecked conversion to the context type to avoid spurious | |
8fc789c8 | 4809 | -- errors, e.g. when the expression is a numeric literal and |
70482933 RK |
4810 | -- the context is private. If the expression is an aggregate, |
4811 | -- use a qualified expression, because an aggregate is not a | |
5884c232 AC |
4812 | -- legal argument of a conversion. Ditto for numeric literals, |
4813 | -- which must be resolved to a specific type. | |
70482933 | 4814 | |
5884c232 AC |
4815 | if Nkind_In (Expression (N), N_Aggregate, |
4816 | N_Null, | |
4817 | N_Real_Literal, | |
4818 | N_Integer_Literal) | |
4819 | then | |
70482933 RK |
4820 | Ret := |
4821 | Make_Qualified_Expression (Sloc (N), | |
f4f92d9d AC |
4822 | Subtype_Mark => New_Occurrence_Of (Ret_Type, Sloc (N)), |
4823 | Expression => Relocate_Node (Expression (N))); | |
70482933 RK |
4824 | else |
4825 | Ret := | |
4826 | Unchecked_Convert_To | |
4827 | (Ret_Type, Relocate_Node (Expression (N))); | |
4828 | end if; | |
4829 | ||
4830 | if Nkind (Targ) = N_Defining_Identifier then | |
4831 | Rewrite (N, | |
4832 | Make_Assignment_Statement (Loc, | |
f4f92d9d | 4833 | Name => New_Occurrence_Of (Targ, Loc), |
70482933 RK |
4834 | Expression => Ret)); |
4835 | else | |
4836 | Rewrite (N, | |
4837 | Make_Assignment_Statement (Loc, | |
f4f92d9d | 4838 | Name => New_Copy (Targ), |
70482933 RK |
4839 | Expression => Ret)); |
4840 | end if; | |
4841 | ||
4842 | Set_Assignment_OK (Name (N)); | |
4843 | ||
4844 | if Present (Exit_Lab) then | |
4845 | Insert_After (N, | |
f4f92d9d | 4846 | Make_Goto_Statement (Loc, Name => New_Copy (Lab_Id))); |
70482933 RK |
4847 | end if; |
4848 | end if; | |
4849 | ||
4850 | return OK; | |
4851 | ||
f4f92d9d AC |
4852 | -- An extended return becomes a block whose first statement is the |
4853 | -- assignment of the initial expression of the return object to the | |
4854 | -- target of the call itself. | |
3e2399ba | 4855 | |
f4f92d9d | 4856 | elsif Nkind (N) = N_Extended_Return_Statement then |
3e2399ba AC |
4857 | declare |
4858 | Return_Decl : constant Entity_Id := | |
4859 | First (Return_Object_Declarations (N)); | |
4860 | Assign : Node_Id; | |
4861 | ||
4862 | begin | |
4863 | Return_Object := Defining_Identifier (Return_Decl); | |
4864 | ||
4865 | if Present (Expression (Return_Decl)) then | |
4866 | if Nkind (Targ) = N_Defining_Identifier then | |
4867 | Assign := | |
4868 | Make_Assignment_Statement (Loc, | |
f4f92d9d | 4869 | Name => New_Occurrence_Of (Targ, Loc), |
3e2399ba AC |
4870 | Expression => Expression (Return_Decl)); |
4871 | else | |
4872 | Assign := | |
4873 | Make_Assignment_Statement (Loc, | |
f4f92d9d | 4874 | Name => New_Copy (Targ), |
3e2399ba AC |
4875 | Expression => Expression (Return_Decl)); |
4876 | end if; | |
4877 | ||
4878 | Set_Assignment_OK (Name (Assign)); | |
84f4072a JM |
4879 | |
4880 | if No (Handled_Statement_Sequence (N)) then | |
4881 | Set_Handled_Statement_Sequence (N, | |
4882 | Make_Handled_Sequence_Of_Statements (Loc, | |
4883 | Statements => New_List)); | |
4884 | end if; | |
4885 | ||
3e2399ba AC |
4886 | Prepend (Assign, |
4887 | Statements (Handled_Statement_Sequence (N))); | |
4888 | end if; | |
4889 | ||
4890 | Rewrite (N, | |
4891 | Make_Block_Statement (Loc, | |
4892 | Handled_Statement_Sequence => | |
4893 | Handled_Statement_Sequence (N))); | |
4894 | ||
4895 | return OK; | |
4896 | end; | |
4897 | ||
fbf5a39b AC |
4898 | -- Remove pragma Unreferenced since it may refer to formals that |
4899 | -- are not visible in the inlined body, and in any case we will | |
4900 | -- not be posting warnings on the inlined body so it is unneeded. | |
4901 | ||
4902 | elsif Nkind (N) = N_Pragma | |
1923d2d6 | 4903 | and then Pragma_Name (N) = Name_Unreferenced |
fbf5a39b AC |
4904 | then |
4905 | Rewrite (N, Make_Null_Statement (Sloc (N))); | |
4906 | return OK; | |
4907 | ||
70482933 RK |
4908 | else |
4909 | return OK; | |
4910 | end if; | |
4911 | end Process_Formals; | |
4912 | ||
4913 | procedure Replace_Formals is new Traverse_Proc (Process_Formals); | |
4914 | ||
fbf5a39b AC |
4915 | ------------------ |
4916 | -- Process_Sloc -- | |
4917 | ------------------ | |
4918 | ||
4919 | function Process_Sloc (Nod : Node_Id) return Traverse_Result is | |
4920 | begin | |
4921 | if not Debug_Generated_Code then | |
4922 | Set_Sloc (Nod, Sloc (N)); | |
4923 | Set_Comes_From_Source (Nod, False); | |
4924 | end if; | |
4925 | ||
4926 | return OK; | |
4927 | end Process_Sloc; | |
4928 | ||
4929 | procedure Reset_Slocs is new Traverse_Proc (Process_Sloc); | |
4930 | ||
84f4072a JM |
4931 | ------------------------------ |
4932 | -- Reset_Dispatching_Calls -- | |
4933 | ------------------------------ | |
4934 | ||
4935 | procedure Reset_Dispatching_Calls (N : Node_Id) is | |
4936 | ||
4937 | function Do_Reset (N : Node_Id) return Traverse_Result; | |
bde73c6b | 4938 | -- Comment required ??? |
84f4072a JM |
4939 | |
4940 | -------------- | |
bde73c6b | 4941 | -- Do_Reset -- |
84f4072a JM |
4942 | -------------- |
4943 | ||
4944 | function Do_Reset (N : Node_Id) return Traverse_Result is | |
4945 | begin | |
4946 | if Nkind (N) = N_Procedure_Call_Statement | |
4947 | and then Nkind (Name (N)) = N_Selected_Component | |
4948 | and then Nkind (Prefix (Name (N))) = N_Identifier | |
4949 | and then Is_Formal (Entity (Prefix (Name (N)))) | |
4950 | and then Is_Dispatching_Operation | |
4951 | (Entity (Selector_Name (Name (N)))) | |
4952 | then | |
4953 | Set_Entity (Selector_Name (Name (N)), Empty); | |
4954 | end if; | |
4955 | ||
4956 | return OK; | |
4957 | end Do_Reset; | |
4958 | ||
4959 | function Do_Reset_Calls is new Traverse_Func (Do_Reset); | |
4960 | ||
bde73c6b | 4961 | -- Local variables |
84f4072a JM |
4962 | |
4963 | Dummy : constant Traverse_Result := Do_Reset_Calls (N); | |
4964 | pragma Unreferenced (Dummy); | |
bde73c6b AC |
4965 | |
4966 | -- Start of processing for Reset_Dispatching_Calls | |
4967 | ||
84f4072a JM |
4968 | begin |
4969 | null; | |
4970 | end Reset_Dispatching_Calls; | |
4971 | ||
70482933 RK |
4972 | --------------------------- |
4973 | -- Rewrite_Function_Call -- | |
4974 | --------------------------- | |
4975 | ||
4976 | procedure Rewrite_Function_Call (N : Node_Id; Blk : Node_Id) is | |
fbf5a39b AC |
4977 | HSS : constant Node_Id := Handled_Statement_Sequence (Blk); |
4978 | Fst : constant Node_Id := First (Statements (HSS)); | |
70482933 RK |
4979 | |
4980 | begin | |
70482933 RK |
4981 | -- Optimize simple case: function body is a single return statement, |
4982 | -- which has been expanded into an assignment. | |
4983 | ||
4984 | if Is_Empty_List (Declarations (Blk)) | |
4985 | and then Nkind (Fst) = N_Assignment_Statement | |
4986 | and then No (Next (Fst)) | |
4987 | then | |
70482933 RK |
4988 | -- The function call may have been rewritten as the temporary |
4989 | -- that holds the result of the call, in which case remove the | |
4990 | -- now useless declaration. | |
4991 | ||
4992 | if Nkind (N) = N_Identifier | |
4993 | and then Nkind (Parent (Entity (N))) = N_Object_Declaration | |
4994 | then | |
4995 | Rewrite (Parent (Entity (N)), Make_Null_Statement (Loc)); | |
4996 | end if; | |
4997 | ||
4998 | Rewrite (N, Expression (Fst)); | |
4999 | ||
5000 | elsif Nkind (N) = N_Identifier | |
5001 | and then Nkind (Parent (Entity (N))) = N_Object_Declaration | |
5002 | then | |
98f01d53 | 5003 | -- The block assigns the result of the call to the temporary |
70482933 RK |
5004 | |
5005 | Insert_After (Parent (Entity (N)), Blk); | |
5006 | ||
54bf19e4 AC |
5007 | -- If the context is an assignment, and the left-hand side is free of |
5008 | -- side-effects, the replacement is also safe. | |
77aa62e7 AC |
5009 | -- Can this be generalized further??? |
5010 | ||
70482933 | 5011 | elsif Nkind (Parent (N)) = N_Assignment_Statement |
c8ef728f ES |
5012 | and then |
5013 | (Is_Entity_Name (Name (Parent (N))) | |
54bf19e4 AC |
5014 | or else |
5015 | (Nkind (Name (Parent (N))) = N_Explicit_Dereference | |
5016 | and then Is_Entity_Name (Prefix (Name (Parent (N))))) | |
77aa62e7 | 5017 | |
54bf19e4 AC |
5018 | or else |
5019 | (Nkind (Name (Parent (N))) = N_Selected_Component | |
5020 | and then Is_Entity_Name (Prefix (Name (Parent (N)))))) | |
70482933 | 5021 | then |
fbf5a39b | 5022 | -- Replace assignment with the block |
70482933 | 5023 | |
30c20106 AC |
5024 | declare |
5025 | Original_Assignment : constant Node_Id := Parent (N); | |
7324bf49 AC |
5026 | |
5027 | begin | |
2f1b20a9 ES |
5028 | -- Preserve the original assignment node to keep the complete |
5029 | -- assignment subtree consistent enough for Analyze_Assignment | |
5030 | -- to proceed (specifically, the original Lhs node must still | |
5031 | -- have an assignment statement as its parent). | |
7324bf49 | 5032 | |
2f1b20a9 ES |
5033 | -- We cannot rely on Original_Node to go back from the block |
5034 | -- node to the assignment node, because the assignment might | |
5035 | -- already be a rewrite substitution. | |
30c20106 | 5036 | |
7324bf49 | 5037 | Discard_Node (Relocate_Node (Original_Assignment)); |
30c20106 AC |
5038 | Rewrite (Original_Assignment, Blk); |
5039 | end; | |
70482933 RK |
5040 | |
5041 | elsif Nkind (Parent (N)) = N_Object_Declaration then | |
c8ef728f | 5042 | |
84f4072a JM |
5043 | -- A call to a function which returns an unconstrained type |
5044 | -- found in the expression initializing an object-declaration is | |
5045 | -- expanded into a procedure call which must be added after the | |
5046 | -- object declaration. | |
5047 | ||
5048 | if Is_Unc_Decl and then Debug_Flag_Dot_K then | |
5049 | Insert_Action_After (Parent (N), Blk); | |
5050 | else | |
5051 | Set_Expression (Parent (N), Empty); | |
5052 | Insert_After (Parent (N), Blk); | |
5053 | end if; | |
5054 | ||
5055 | elsif Is_Unc and then not Debug_Flag_Dot_K then | |
c8ef728f | 5056 | Insert_Before (Parent (N), Blk); |
70482933 RK |
5057 | end if; |
5058 | end Rewrite_Function_Call; | |
5059 | ||
5060 | ---------------------------- | |
5061 | -- Rewrite_Procedure_Call -- | |
5062 | ---------------------------- | |
5063 | ||
5064 | procedure Rewrite_Procedure_Call (N : Node_Id; Blk : Node_Id) is | |
fbf5a39b | 5065 | HSS : constant Node_Id := Handled_Statement_Sequence (Blk); |
f4f92d9d | 5066 | |
70482933 | 5067 | begin |
02822a92 RD |
5068 | -- If there is a transient scope for N, this will be the scope of the |
5069 | -- actions for N, and the statements in Blk need to be within this | |
5070 | -- scope. For example, they need to have visibility on the constant | |
5071 | -- declarations created for the formals. | |
5072 | ||
5073 | -- If N needs no transient scope, and if there are no declarations in | |
5074 | -- the inlined body, we can do a little optimization and insert the | |
5075 | -- statements for the body directly after N, and rewrite N to a | |
5076 | -- null statement, instead of rewriting N into a full-blown block | |
5077 | -- statement. | |
5078 | ||
5079 | if not Scope_Is_Transient | |
5080 | and then Is_Empty_List (Declarations (Blk)) | |
5081 | then | |
70482933 RK |
5082 | Insert_List_After (N, Statements (HSS)); |
5083 | Rewrite (N, Make_Null_Statement (Loc)); | |
5084 | else | |
5085 | Rewrite (N, Blk); | |
5086 | end if; | |
5087 | end Rewrite_Procedure_Call; | |
5088 | ||
5453d5bd AC |
5089 | ------------------------- |
5090 | -- Formal_Is_Used_Once -- | |
02822a92 | 5091 | ------------------------- |
5453d5bd AC |
5092 | |
5093 | function Formal_Is_Used_Once (Formal : Entity_Id) return Boolean is | |
5094 | Use_Counter : Int := 0; | |
5095 | ||
5096 | function Count_Uses (N : Node_Id) return Traverse_Result; | |
5097 | -- Traverse the tree and count the uses of the formal parameter. | |
5098 | -- In this case, for optimization purposes, we do not need to | |
5099 | -- continue the traversal once more than one use is encountered. | |
5100 | ||
cc335f43 AC |
5101 | ---------------- |
5102 | -- Count_Uses -- | |
5103 | ---------------- | |
5104 | ||
5453d5bd AC |
5105 | function Count_Uses (N : Node_Id) return Traverse_Result is |
5106 | begin | |
5453d5bd AC |
5107 | -- The original node is an identifier |
5108 | ||
5109 | if Nkind (N) = N_Identifier | |
5110 | and then Present (Entity (N)) | |
5111 | ||
2f1b20a9 | 5112 | -- Original node's entity points to the one in the copied body |
5453d5bd AC |
5113 | |
5114 | and then Nkind (Entity (N)) = N_Identifier | |
5115 | and then Present (Entity (Entity (N))) | |
5116 | ||
5117 | -- The entity of the copied node is the formal parameter | |
5118 | ||
5119 | and then Entity (Entity (N)) = Formal | |
5120 | then | |
5121 | Use_Counter := Use_Counter + 1; | |
5122 | ||
5123 | if Use_Counter > 1 then | |
5124 | ||
5125 | -- Denote more than one use and abandon the traversal | |
5126 | ||
5127 | Use_Counter := 2; | |
5128 | return Abandon; | |
5129 | ||
5130 | end if; | |
5131 | end if; | |
5132 | ||
5133 | return OK; | |
5134 | end Count_Uses; | |
5135 | ||
5136 | procedure Count_Formal_Uses is new Traverse_Proc (Count_Uses); | |
5137 | ||
5138 | -- Start of processing for Formal_Is_Used_Once | |
5139 | ||
5140 | begin | |
5453d5bd AC |
5141 | Count_Formal_Uses (Orig_Bod); |
5142 | return Use_Counter = 1; | |
5453d5bd AC |
5143 | end Formal_Is_Used_Once; |
5144 | ||
70482933 RK |
5145 | -- Start of processing for Expand_Inlined_Call |
5146 | ||
5147 | begin | |
84f4072a JM |
5148 | -- Initializations for old/new semantics |
5149 | ||
5150 | if not Debug_Flag_Dot_K then | |
5151 | Is_Unc := Is_Array_Type (Etype (Subp)) | |
5152 | and then not Is_Constrained (Etype (Subp)); | |
5153 | Is_Unc_Decl := False; | |
5154 | else | |
5155 | Is_Unc := Returns_Unconstrained_Type (Subp) | |
5156 | and then Optimization_Level > 0; | |
5157 | Is_Unc_Decl := Nkind (Parent (N)) = N_Object_Declaration | |
5158 | and then Is_Unc; | |
5159 | end if; | |
5160 | ||
f44fe430 RD |
5161 | -- Check for an illegal attempt to inline a recursive procedure. If the |
5162 | -- subprogram has parameters this is detected when trying to supply a | |
5163 | -- binding for parameters that already have one. For parameterless | |
5164 | -- subprograms this must be done explicitly. | |
5165 | ||
5166 | if In_Open_Scopes (Subp) then | |
685bc70f | 5167 | Error_Msg_N ("call to recursive subprogram cannot be inlined??", N); |
f44fe430 RD |
5168 | Set_Is_Inlined (Subp, False); |
5169 | return; | |
e761d11c AC |
5170 | |
5171 | -- Skip inlining if this is not a true inlining since the attribute | |
5172 | -- Body_To_Inline is also set for renamings (see sinfo.ads) | |
5173 | ||
5174 | elsif Nkind (Orig_Bod) in N_Entity then | |
5175 | return; | |
5176 | ||
5177 | -- Skip inlining if the function returns an unconstrained type using | |
844ec038 AC |
5178 | -- an extended return statement since this part of the new inlining |
5179 | -- model which is not yet supported by the current implementation. ??? | |
e761d11c AC |
5180 | |
5181 | elsif Is_Unc | |
5182 | and then | |
5183 | Nkind (First (Statements (Handled_Statement_Sequence (Orig_Bod)))) | |
5184 | = N_Extended_Return_Statement | |
84f4072a | 5185 | and then not Debug_Flag_Dot_K |
e761d11c AC |
5186 | then |
5187 | return; | |
f44fe430 RD |
5188 | end if; |
5189 | ||
2ccf2fb3 ES |
5190 | if Nkind (Orig_Bod) = N_Defining_Identifier |
5191 | or else Nkind (Orig_Bod) = N_Defining_Operator_Symbol | |
5192 | then | |
8a45b58c RD |
5193 | -- Subprogram is renaming_as_body. Calls occurring after the renaming |
5194 | -- can be replaced with calls to the renamed entity directly, because | |
5195 | -- the subprograms are subtype conformant. If the renamed subprogram | |
5196 | -- is an inherited operation, we must redo the expansion because | |
5197 | -- implicit conversions may be needed. Similarly, if the renamed | |
5198 | -- entity is inlined, expand the call for further optimizations. | |
70482933 RK |
5199 | |
5200 | Set_Name (N, New_Occurrence_Of (Orig_Bod, Loc)); | |
f44fe430 | 5201 | |
676e8420 | 5202 | if Present (Alias (Orig_Bod)) or else Is_Inlined (Orig_Bod) then |
f44fe430 RD |
5203 | Expand_Call (N); |
5204 | end if; | |
5205 | ||
70482933 RK |
5206 | return; |
5207 | end if; | |
5208 | ||
84f4072a JM |
5209 | -- Register the call in the list of inlined calls |
5210 | ||
5211 | if Inlined_Calls = No_Elist then | |
5212 | Inlined_Calls := New_Elmt_List; | |
5213 | end if; | |
5214 | ||
5215 | Append_Elmt (N, To => Inlined_Calls); | |
5216 | ||
70482933 RK |
5217 | -- Use generic machinery to copy body of inlined subprogram, as if it |
5218 | -- were an instantiation, resetting source locations appropriately, so | |
5219 | -- that nested inlined calls appear in the main unit. | |
5220 | ||
5221 | Save_Env (Subp, Empty); | |
fbf5a39b | 5222 | Set_Copied_Sloc_For_Inlined_Body (N, Defining_Entity (Orig_Bod)); |
70482933 | 5223 | |
84f4072a | 5224 | -- Old semantics |
70482933 | 5225 | |
84f4072a JM |
5226 | if not Debug_Flag_Dot_K then |
5227 | declare | |
5228 | Bod : Node_Id; | |
5229 | ||
5230 | begin | |
5231 | Bod := Copy_Generic_Node (Orig_Bod, Empty, Instantiating => True); | |
5232 | Blk := | |
5233 | Make_Block_Statement (Loc, | |
5234 | Declarations => Declarations (Bod), | |
5235 | Handled_Statement_Sequence => | |
5236 | Handled_Statement_Sequence (Bod)); | |
70482933 | 5237 | |
84f4072a JM |
5238 | if No (Declarations (Bod)) then |
5239 | Set_Declarations (Blk, New_List); | |
5240 | end if; | |
54bf19e4 | 5241 | |
84f4072a JM |
5242 | -- For the unconstrained case, capture the name of the local |
5243 | -- variable that holds the result. This must be the first | |
5244 | -- declaration in the block, because its bounds cannot depend | |
5245 | -- on local variables. Otherwise there is no way to declare the | |
5246 | -- result outside of the block. Needless to say, in general the | |
5247 | -- bounds will depend on the actuals in the call. | |
c8ef728f | 5248 | |
84f4072a JM |
5249 | -- If the context is an assignment statement, as is the case |
5250 | -- for the expansion of an extended return, the left-hand side | |
5251 | -- provides bounds even if the return type is unconstrained. | |
5252 | ||
5253 | if Is_Unc then | |
5254 | declare | |
5255 | First_Decl : Node_Id; | |
5256 | ||
5257 | begin | |
5258 | First_Decl := First (Declarations (Blk)); | |
5259 | ||
5260 | if Nkind (First_Decl) /= N_Object_Declaration then | |
5261 | return; | |
5262 | end if; | |
5263 | ||
5264 | if Nkind (Parent (N)) /= N_Assignment_Statement then | |
5265 | Targ1 := Defining_Identifier (First_Decl); | |
5266 | else | |
5267 | Targ1 := Name (Parent (N)); | |
5268 | end if; | |
5269 | end; | |
5270 | end if; | |
5271 | end; | |
5272 | ||
5273 | -- New semantics | |
5274 | ||
5275 | else | |
5276 | declare | |
5277 | Bod : Node_Id; | |
5278 | ||
5279 | begin | |
5280 | -- General case | |
5281 | ||
5282 | if not Is_Unc then | |
5283 | Bod := | |
5284 | Copy_Generic_Node (Orig_Bod, Empty, Instantiating => True); | |
5285 | Blk := | |
5286 | Make_Block_Statement (Loc, | |
5287 | Declarations => Declarations (Bod), | |
5288 | Handled_Statement_Sequence => | |
5289 | Handled_Statement_Sequence (Bod)); | |
5290 | ||
5291 | -- Inline a call to a function that returns an unconstrained type. | |
5292 | -- The semantic analyzer checked that frontend-inlined functions | |
5293 | -- returning unconstrained types have no declarations and have | |
5294 | -- a single extended return statement. As part of its processing | |
5295 | -- the function was split in two subprograms: a procedure P and | |
5296 | -- a function F that has a block with a call to procedure P (see | |
5297 | -- Split_Unconstrained_Function). | |
5298 | ||
5299 | else | |
5300 | pragma Assert | |
5301 | (Nkind | |
92a7cd46 RD |
5302 | (First |
5303 | (Statements (Handled_Statement_Sequence (Orig_Bod)))) | |
84f4072a JM |
5304 | = N_Block_Statement); |
5305 | ||
5306 | declare | |
5307 | Blk_Stmt : constant Node_Id := | |
5308 | First | |
5309 | (Statements | |
92a7cd46 | 5310 | (Handled_Statement_Sequence (Orig_Bod))); |
84f4072a JM |
5311 | First_Stmt : constant Node_Id := |
5312 | First | |
5313 | (Statements | |
92a7cd46 | 5314 | (Handled_Statement_Sequence (Blk_Stmt))); |
84f4072a JM |
5315 | Second_Stmt : constant Node_Id := Next (First_Stmt); |
5316 | ||
5317 | begin | |
5318 | pragma Assert | |
5319 | (Nkind (First_Stmt) = N_Procedure_Call_Statement | |
92a7cd46 RD |
5320 | and then Nkind (Second_Stmt) = N_Simple_Return_Statement |
5321 | and then No (Next (Second_Stmt))); | |
84f4072a JM |
5322 | |
5323 | Bod := | |
5324 | Copy_Generic_Node | |
5325 | (First | |
92a7cd46 | 5326 | (Statements (Handled_Statement_Sequence (Orig_Bod))), |
84f4072a JM |
5327 | Empty, Instantiating => True); |
5328 | Blk := Bod; | |
5329 | ||
5330 | -- Capture the name of the local variable that holds the | |
5331 | -- result. This must be the first declaration in the block, | |
5332 | -- because its bounds cannot depend on local variables. | |
5333 | -- Otherwise there is no way to declare the result outside | |
5334 | -- of the block. Needless to say, in general the bounds will | |
5335 | -- depend on the actuals in the call. | |
5336 | ||
5337 | if Nkind (Parent (N)) /= N_Assignment_Statement then | |
5338 | Targ1 := Defining_Identifier (First (Declarations (Blk))); | |
5339 | ||
5340 | -- If the context is an assignment statement, as is the case | |
5341 | -- for the expansion of an extended return, the left-hand | |
5342 | -- side provides bounds even if the return type is | |
5343 | -- unconstrained. | |
5344 | ||
5345 | else | |
5346 | Targ1 := Name (Parent (N)); | |
5347 | end if; | |
5348 | end; | |
5349 | end if; | |
5350 | ||
5351 | if No (Declarations (Bod)) then | |
5352 | Set_Declarations (Blk, New_List); | |
5353 | end if; | |
5354 | end; | |
c8ef728f ES |
5355 | end if; |
5356 | ||
98f01d53 | 5357 | -- If this is a derived function, establish the proper return type |
70482933 | 5358 | |
54bf19e4 | 5359 | if Present (Orig_Subp) and then Orig_Subp /= Subp then |
70482933 RK |
5360 | Ret_Type := Etype (Orig_Subp); |
5361 | else | |
5362 | Ret_Type := Etype (Subp); | |
5363 | end if; | |
5364 | ||
2557e054 RD |
5365 | -- Create temporaries for the actuals that are expressions, or that are |
5366 | -- scalars and require copying to preserve semantics. | |
70482933 | 5367 | |
2f1b20a9 ES |
5368 | F := First_Formal (Subp); |
5369 | A := First_Actual (N); | |
70482933 | 5370 | while Present (F) loop |
70482933 | 5371 | if Present (Renamed_Object (F)) then |
2f1b20a9 | 5372 | Error_Msg_N ("cannot inline call to recursive subprogram", N); |
70482933 RK |
5373 | return; |
5374 | end if; | |
5375 | ||
24cb156d AC |
5376 | -- Reset Last_Assignment for any parameters of mode out or in out, to |
5377 | -- prevent spurious warnings about overwriting for assignments to the | |
5378 | -- formal in the inlined code. | |
5379 | ||
2557e054 | 5380 | if Is_Entity_Name (A) and then Ekind (F) /= E_In_Parameter then |
24cb156d AC |
5381 | Set_Last_Assignment (Entity (A), Empty); |
5382 | end if; | |
5383 | ||
70482933 | 5384 | -- If the argument may be a controlling argument in a call within |
f44fe430 RD |
5385 | -- the inlined body, we must preserve its classwide nature to insure |
5386 | -- that dynamic dispatching take place subsequently. If the formal | |
5387 | -- has a constraint it must be preserved to retain the semantics of | |
5388 | -- the body. | |
70482933 RK |
5389 | |
5390 | if Is_Class_Wide_Type (Etype (F)) | |
5391 | or else (Is_Access_Type (Etype (F)) | |
f4f92d9d | 5392 | and then Is_Class_Wide_Type (Designated_Type (Etype (F)))) |
70482933 RK |
5393 | then |
5394 | Temp_Typ := Etype (F); | |
5395 | ||
5396 | elsif Base_Type (Etype (F)) = Base_Type (Etype (A)) | |
5397 | and then Etype (F) /= Base_Type (Etype (F)) | |
5398 | then | |
5399 | Temp_Typ := Etype (F); | |
70482933 RK |
5400 | else |
5401 | Temp_Typ := Etype (A); | |
5402 | end if; | |
5403 | ||
5b4994bc AC |
5404 | -- If the actual is a simple name or a literal, no need to |
5405 | -- create a temporary, object can be used directly. | |
70482933 | 5406 | |
7888a6ae GD |
5407 | -- If the actual is a literal and the formal has its address taken, |
5408 | -- we cannot pass the literal itself as an argument, so its value | |
5409 | -- must be captured in a temporary. | |
5410 | ||
fbf5a39b AC |
5411 | if (Is_Entity_Name (A) |
5412 | and then | |
5413 | (not Is_Scalar_Type (Etype (A)) | |
5414 | or else Ekind (Entity (A)) = E_Enumeration_Literal)) | |
5415 | ||
2557e054 RD |
5416 | -- When the actual is an identifier and the corresponding formal is |
5417 | -- used only once in the original body, the formal can be substituted | |
5418 | -- directly with the actual parameter. | |
5453d5bd AC |
5419 | |
5420 | or else (Nkind (A) = N_Identifier | |
5421 | and then Formal_Is_Used_Once (F)) | |
5422 | ||
7888a6ae | 5423 | or else |
ac4d6407 | 5424 | (Nkind_In (A, N_Real_Literal, |
f4f92d9d AC |
5425 | N_Integer_Literal, |
5426 | N_Character_Literal) | |
5427 | and then not Address_Taken (F)) | |
70482933 | 5428 | then |
fbf5a39b AC |
5429 | if Etype (F) /= Etype (A) then |
5430 | Set_Renamed_Object | |
f4f92d9d | 5431 | (F, Unchecked_Convert_To (Etype (F), Relocate_Node (A))); |
fbf5a39b AC |
5432 | else |
5433 | Set_Renamed_Object (F, A); | |
5434 | end if; | |
5435 | ||
5436 | else | |
c12beea0 | 5437 | Temp := Make_Temporary (Loc, 'C'); |
70482933 RK |
5438 | |
5439 | -- If the actual for an in/in-out parameter is a view conversion, | |
5440 | -- make it into an unchecked conversion, given that an untagged | |
5441 | -- type conversion is not a proper object for a renaming. | |
fbf5a39b | 5442 | |
70482933 RK |
5443 | -- In-out conversions that involve real conversions have already |
5444 | -- been transformed in Expand_Actuals. | |
5445 | ||
5446 | if Nkind (A) = N_Type_Conversion | |
fbf5a39b | 5447 | and then Ekind (F) /= E_In_Parameter |
70482933 | 5448 | then |
02822a92 RD |
5449 | New_A := |
5450 | Make_Unchecked_Type_Conversion (Loc, | |
5451 | Subtype_Mark => New_Occurrence_Of (Etype (F), Loc), | |
5452 | Expression => Relocate_Node (Expression (A))); | |
70482933 RK |
5453 | |
5454 | elsif Etype (F) /= Etype (A) then | |
5455 | New_A := Unchecked_Convert_To (Etype (F), Relocate_Node (A)); | |
5456 | Temp_Typ := Etype (F); | |
5457 | ||
5458 | else | |
5459 | New_A := Relocate_Node (A); | |
5460 | end if; | |
5461 | ||
5462 | Set_Sloc (New_A, Sloc (N)); | |
5463 | ||
2557e054 RD |
5464 | -- If the actual has a by-reference type, it cannot be copied, |
5465 | -- so its value is captured in a renaming declaration. Otherwise | |
7888a6ae | 5466 | -- declare a local constant initialized with the actual. |
02822a92 | 5467 | |
4a3b249c RD |
5468 | -- We also use a renaming declaration for expressions of an array |
5469 | -- type that is not bit-packed, both for efficiency reasons and to | |
5470 | -- respect the semantics of the call: in most cases the original | |
5471 | -- call will pass the parameter by reference, and thus the inlined | |
5472 | -- code will have the same semantics. | |
bafc9e1d | 5473 | |
70482933 | 5474 | if Ekind (F) = E_In_Parameter |
dbe36d67 | 5475 | and then not Is_By_Reference_Type (Etype (A)) |
bafc9e1d | 5476 | and then |
f4f92d9d AC |
5477 | (not Is_Array_Type (Etype (A)) |
5478 | or else not Is_Object_Reference (A) | |
5479 | or else Is_Bit_Packed_Array (Etype (A))) | |
70482933 RK |
5480 | then |
5481 | Decl := | |
5482 | Make_Object_Declaration (Loc, | |
5483 | Defining_Identifier => Temp, | |
db15225a AC |
5484 | Constant_Present => True, |
5485 | Object_Definition => New_Occurrence_Of (Temp_Typ, Loc), | |
5486 | Expression => New_A); | |
70482933 RK |
5487 | else |
5488 | Decl := | |
5489 | Make_Object_Renaming_Declaration (Loc, | |
5490 | Defining_Identifier => Temp, | |
5491 | Subtype_Mark => New_Occurrence_Of (Temp_Typ, Loc), | |
5492 | Name => New_A); | |
5493 | end if; | |
5494 | ||
c8ef728f | 5495 | Append (Decl, Decls); |
70482933 | 5496 | Set_Renamed_Object (F, Temp); |
70482933 RK |
5497 | end if; |
5498 | ||
5499 | Next_Formal (F); | |
5500 | Next_Actual (A); | |
5501 | end loop; | |
5502 | ||
5503 | -- Establish target of function call. If context is not assignment or | |
db15225a AC |
5504 | -- declaration, create a temporary as a target. The declaration for the |
5505 | -- temporary may be subsequently optimized away if the body is a single | |
5506 | -- expression, or if the left-hand side of the assignment is simple | |
5507 | -- enough, i.e. an entity or an explicit dereference of one. | |
70482933 RK |
5508 | |
5509 | if Ekind (Subp) = E_Function then | |
5510 | if Nkind (Parent (N)) = N_Assignment_Statement | |
5511 | and then Is_Entity_Name (Name (Parent (N))) | |
5512 | then | |
5513 | Targ := Name (Parent (N)); | |
5514 | ||
c8ef728f ES |
5515 | elsif Nkind (Parent (N)) = N_Assignment_Statement |
5516 | and then Nkind (Name (Parent (N))) = N_Explicit_Dereference | |
5517 | and then Is_Entity_Name (Prefix (Name (Parent (N)))) | |
5518 | then | |
5519 | Targ := Name (Parent (N)); | |
5520 | ||
77aa62e7 AC |
5521 | elsif Nkind (Parent (N)) = N_Assignment_Statement |
5522 | and then Nkind (Name (Parent (N))) = N_Selected_Component | |
5523 | and then Is_Entity_Name (Prefix (Name (Parent (N)))) | |
5524 | then | |
5525 | Targ := New_Copy_Tree (Name (Parent (N))); | |
5526 | ||
3e2399ba AC |
5527 | elsif Nkind (Parent (N)) = N_Object_Declaration |
5528 | and then Is_Limited_Type (Etype (Subp)) | |
5529 | then | |
5530 | Targ := Defining_Identifier (Parent (N)); | |
5531 | ||
84f4072a JM |
5532 | -- New semantics: In an object declaration avoid an extra copy |
5533 | -- of the result of a call to an inlined function that returns | |
5534 | -- an unconstrained type | |
5535 | ||
5536 | elsif Debug_Flag_Dot_K | |
5537 | and then Nkind (Parent (N)) = N_Object_Declaration | |
5538 | and then Is_Unc | |
5539 | then | |
5540 | Targ := Defining_Identifier (Parent (N)); | |
5541 | ||
70482933 | 5542 | else |
98f01d53 | 5543 | -- Replace call with temporary and create its declaration |
70482933 | 5544 | |
c12beea0 | 5545 | Temp := Make_Temporary (Loc, 'C'); |
758c442c | 5546 | Set_Is_Internal (Temp); |
70482933 | 5547 | |
30783513 | 5548 | -- For the unconstrained case, the generated temporary has the |
4a3b249c RD |
5549 | -- same constrained declaration as the result variable. It may |
5550 | -- eventually be possible to remove that temporary and use the | |
5551 | -- result variable directly. | |
c8ef728f | 5552 | |
77aa62e7 AC |
5553 | if Is_Unc |
5554 | and then Nkind (Parent (N)) /= N_Assignment_Statement | |
5555 | then | |
c8ef728f ES |
5556 | Decl := |
5557 | Make_Object_Declaration (Loc, | |
5558 | Defining_Identifier => Temp, | |
54bf19e4 | 5559 | Object_Definition => |
c8ef728f ES |
5560 | New_Copy_Tree (Object_Definition (Parent (Targ1)))); |
5561 | ||
5562 | Replace_Formals (Decl); | |
5563 | ||
5564 | else | |
5565 | Decl := | |
5566 | Make_Object_Declaration (Loc, | |
5567 | Defining_Identifier => Temp, | |
54bf19e4 | 5568 | Object_Definition => New_Occurrence_Of (Ret_Type, Loc)); |
c8ef728f ES |
5569 | |
5570 | Set_Etype (Temp, Ret_Type); | |
5571 | end if; | |
70482933 RK |
5572 | |
5573 | Set_No_Initialization (Decl); | |
c8ef728f | 5574 | Append (Decl, Decls); |
70482933 RK |
5575 | Rewrite (N, New_Occurrence_Of (Temp, Loc)); |
5576 | Targ := Temp; | |
5577 | end if; | |
5578 | end if; | |
5579 | ||
c8ef728f ES |
5580 | Insert_Actions (N, Decls); |
5581 | ||
84f4072a JM |
5582 | if Is_Unc_Decl then |
5583 | ||
5584 | -- Special management for inlining a call to a function that returns | |
5585 | -- an unconstrained type and initializes an object declaration: we | |
5586 | -- avoid generating undesired extra calls and goto statements. | |
5587 | ||
5588 | -- Given: | |
5589 | -- function Func (...) return ... | |
5590 | -- begin | |
5591 | -- declare | |
5592 | -- Result : String (1 .. 4); | |
5593 | -- begin | |
5594 | -- Proc (Result, ...); | |
5595 | -- return Result; | |
5596 | -- end; | |
5597 | -- end F; | |
5598 | ||
5599 | -- Result : String := Func (...); | |
5600 | ||
5601 | -- Replace this object declaration by: | |
5602 | ||
5603 | -- Result : String (1 .. 4); | |
5604 | -- Proc (Result, ...); | |
5605 | ||
5606 | Remove_Homonym (Targ); | |
5607 | ||
5608 | Decl := | |
5609 | Make_Object_Declaration | |
5610 | (Loc, | |
5611 | Defining_Identifier => Targ, | |
5612 | Object_Definition => | |
5613 | New_Copy_Tree (Object_Definition (Parent (Targ1)))); | |
5614 | Replace_Formals (Decl); | |
5615 | Rewrite (Parent (N), Decl); | |
5616 | Analyze (Parent (N)); | |
5617 | ||
5618 | -- Avoid spurious warnings since we know that this declaration is | |
5619 | -- referenced by the procedure call. | |
5620 | ||
5621 | Set_Never_Set_In_Source (Targ, False); | |
5622 | ||
5623 | -- Remove the local declaration of the extended return stmt from the | |
5624 | -- inlined code | |
5625 | ||
5626 | Remove (Parent (Targ1)); | |
5627 | ||
5628 | -- Update the reference to the result (since we have rewriten the | |
5629 | -- object declaration) | |
5630 | ||
5631 | declare | |
5632 | Blk_Call_Stmt : Node_Id; | |
5633 | ||
5634 | begin | |
5635 | -- Capture the call to the procedure | |
5636 | ||
5637 | Blk_Call_Stmt := | |
5638 | First (Statements (Handled_Statement_Sequence (Blk))); | |
5639 | pragma Assert | |
5640 | (Nkind (Blk_Call_Stmt) = N_Procedure_Call_Statement); | |
5641 | ||
5642 | Remove (First (Parameter_Associations (Blk_Call_Stmt))); | |
5643 | Prepend_To (Parameter_Associations (Blk_Call_Stmt), | |
5644 | New_Reference_To (Targ, Loc)); | |
5645 | end; | |
5646 | ||
5647 | -- Remove the return statement | |
5648 | ||
5649 | pragma Assert | |
92a7cd46 RD |
5650 | (Nkind (Last (Statements (Handled_Statement_Sequence (Blk)))) = |
5651 | N_Simple_Return_Statement); | |
84f4072a JM |
5652 | |
5653 | Remove (Last (Statements (Handled_Statement_Sequence (Blk)))); | |
5654 | end if; | |
5655 | ||
98f01d53 | 5656 | -- Traverse the tree and replace formals with actuals or their thunks. |
70482933 RK |
5657 | -- Attach block to tree before analysis and rewriting. |
5658 | ||
5659 | Replace_Formals (Blk); | |
5660 | Set_Parent (Blk, N); | |
5661 | ||
54bf19e4 | 5662 | if not Comes_From_Source (Subp) or else Is_Predef then |
fbf5a39b AC |
5663 | Reset_Slocs (Blk); |
5664 | end if; | |
5665 | ||
84f4072a JM |
5666 | if Is_Unc_Decl then |
5667 | ||
a90bd866 | 5668 | -- No action needed since return statement has been already removed |
84f4072a JM |
5669 | |
5670 | null; | |
5671 | ||
5672 | elsif Present (Exit_Lab) then | |
70482933 RK |
5673 | |
5674 | -- If the body was a single expression, the single return statement | |
5675 | -- and the corresponding label are useless. | |
5676 | ||
5677 | if Num_Ret = 1 | |
5678 | and then | |
5679 | Nkind (Last (Statements (Handled_Statement_Sequence (Blk)))) = | |
54bf19e4 | 5680 | N_Goto_Statement |
70482933 RK |
5681 | then |
5682 | Remove (Last (Statements (Handled_Statement_Sequence (Blk)))); | |
5683 | else | |
5684 | Append (Lab_Decl, (Declarations (Blk))); | |
5685 | Append (Exit_Lab, Statements (Handled_Statement_Sequence (Blk))); | |
5686 | end if; | |
5687 | end if; | |
5688 | ||
2557e054 RD |
5689 | -- Analyze Blk with In_Inlined_Body set, to avoid spurious errors |
5690 | -- on conflicting private views that Gigi would ignore. If this is a | |
fbf5a39b AC |
5691 | -- predefined unit, analyze with checks off, as is done in the non- |
5692 | -- inlined run-time units. | |
70482933 RK |
5693 | |
5694 | declare | |
5695 | I_Flag : constant Boolean := In_Inlined_Body; | |
5696 | ||
5697 | begin | |
5698 | In_Inlined_Body := True; | |
fbf5a39b AC |
5699 | |
5700 | if Is_Predef then | |
5701 | declare | |
5702 | Style : constant Boolean := Style_Check; | |
84f4072a | 5703 | |
fbf5a39b AC |
5704 | begin |
5705 | Style_Check := False; | |
84f4072a JM |
5706 | |
5707 | -- Search for dispatching calls that use the Object.Operation | |
5708 | -- notation using an Object that is a parameter of the inlined | |
5709 | -- function. We reset the decoration of Operation to force | |
5710 | -- the reanalysis of the inlined dispatching call because | |
5711 | -- the actual object has been inlined. | |
5712 | ||
5713 | Reset_Dispatching_Calls (Blk); | |
5714 | ||
fbf5a39b AC |
5715 | Analyze (Blk, Suppress => All_Checks); |
5716 | Style_Check := Style; | |
5717 | end; | |
5718 | ||
5719 | else | |
5720 | Analyze (Blk); | |
5721 | end if; | |
5722 | ||
70482933 RK |
5723 | In_Inlined_Body := I_Flag; |
5724 | end; | |
5725 | ||
5726 | if Ekind (Subp) = E_Procedure then | |
5727 | Rewrite_Procedure_Call (N, Blk); | |
54bf19e4 | 5728 | |
70482933 RK |
5729 | else |
5730 | Rewrite_Function_Call (N, Blk); | |
c8ef728f | 5731 | |
84f4072a JM |
5732 | if Is_Unc_Decl then |
5733 | null; | |
5734 | ||
c8ef728f ES |
5735 | -- For the unconstrained case, the replacement of the call has been |
5736 | -- made prior to the complete analysis of the generated declarations. | |
5737 | -- Propagate the proper type now. | |
5738 | ||
84f4072a | 5739 | elsif Is_Unc then |
c8ef728f ES |
5740 | if Nkind (N) = N_Identifier then |
5741 | Set_Etype (N, Etype (Entity (N))); | |
5742 | else | |
5743 | Set_Etype (N, Etype (Targ1)); | |
5744 | end if; | |
5745 | end if; | |
70482933 RK |
5746 | end if; |
5747 | ||
5748 | Restore_Env; | |
5749 | ||
98f01d53 | 5750 | -- Cleanup mapping between formals and actuals for other expansions |
70482933 RK |
5751 | |
5752 | F := First_Formal (Subp); | |
70482933 RK |
5753 | while Present (F) loop |
5754 | Set_Renamed_Object (F, Empty); | |
5755 | Next_Formal (F); | |
5756 | end loop; | |
5757 | end Expand_Inlined_Call; | |
5758 | ||
2b3d67a5 AC |
5759 | ---------------------------------------- |
5760 | -- Expand_N_Extended_Return_Statement -- | |
5761 | ---------------------------------------- | |
5762 | ||
5763 | -- If there is a Handled_Statement_Sequence, we rewrite this: | |
5764 | ||
5765 | -- return Result : T := <expression> do | |
5766 | -- <handled_seq_of_stms> | |
5767 | -- end return; | |
5768 | ||
5769 | -- to be: | |
5770 | ||
5771 | -- declare | |
5772 | -- Result : T := <expression>; | |
5773 | -- begin | |
5774 | -- <handled_seq_of_stms> | |
5775 | -- return Result; | |
5776 | -- end; | |
5777 | ||
5778 | -- Otherwise (no Handled_Statement_Sequence), we rewrite this: | |
5779 | ||
5780 | -- return Result : T := <expression>; | |
5781 | ||
5782 | -- to be: | |
5783 | ||
5784 | -- return <expression>; | |
5785 | ||
5786 | -- unless it's build-in-place or there's no <expression>, in which case | |
5787 | -- we generate: | |
5788 | ||
5789 | -- declare | |
5790 | -- Result : T := <expression>; | |
5791 | -- begin | |
5792 | -- return Result; | |
5793 | -- end; | |
5794 | ||
5795 | -- Note that this case could have been written by the user as an extended | |
5796 | -- return statement, or could have been transformed to this from a simple | |
5797 | -- return statement. | |
5798 | ||
5799 | -- That is, we need to have a reified return object if there are statements | |
5800 | -- (which might refer to it) or if we're doing build-in-place (so we can | |
5801 | -- set its address to the final resting place or if there is no expression | |
5802 | -- (in which case default initial values might need to be set). | |
5803 | ||
5804 | procedure Expand_N_Extended_Return_Statement (N : Node_Id) is | |
5805 | Loc : constant Source_Ptr := Sloc (N); | |
5806 | ||
df3e68b1 HK |
5807 | Par_Func : constant Entity_Id := |
5808 | Return_Applies_To (Return_Statement_Entity (N)); | |
1a36a0cd | 5809 | Result_Subt : constant Entity_Id := Etype (Par_Func); |
df3e68b1 HK |
5810 | Ret_Obj_Id : constant Entity_Id := |
5811 | First_Entity (Return_Statement_Entity (N)); | |
5812 | Ret_Obj_Decl : constant Node_Id := Parent (Ret_Obj_Id); | |
5813 | ||
5814 | Is_Build_In_Place : constant Boolean := | |
5815 | Is_Build_In_Place_Function (Par_Func); | |
5816 | ||
5817 | Exp : Node_Id; | |
5818 | HSS : Node_Id; | |
5819 | Result : Node_Id; | |
5820 | Return_Stmt : Node_Id; | |
5821 | Stmts : List_Id; | |
5822 | ||
5823 | function Build_Heap_Allocator | |
5824 | (Temp_Id : Entity_Id; | |
5825 | Temp_Typ : Entity_Id; | |
5826 | Func_Id : Entity_Id; | |
5827 | Ret_Typ : Entity_Id; | |
5828 | Alloc_Expr : Node_Id) return Node_Id; | |
5829 | -- Create the statements necessary to allocate a return object on the | |
d3f70b35 AC |
5830 | -- caller's master. The master is available through implicit parameter |
5831 | -- BIPfinalizationmaster. | |
df3e68b1 | 5832 | -- |
d3f70b35 | 5833 | -- if BIPfinalizationmaster /= null then |
df3e68b1 HK |
5834 | -- declare |
5835 | -- type Ptr_Typ is access Ret_Typ; | |
5836 | -- for Ptr_Typ'Storage_Pool use | |
d3f70b35 | 5837 | -- Base_Pool (BIPfinalizationmaster.all).all; |
df3e68b1 HK |
5838 | -- Local : Ptr_Typ; |
5839 | -- | |
5840 | -- begin | |
5841 | -- procedure Allocate (...) is | |
5842 | -- begin | |
d3f70b35 | 5843 | -- System.Storage_Pools.Subpools.Allocate_Any (...); |
df3e68b1 HK |
5844 | -- end Allocate; |
5845 | -- | |
5846 | -- Local := <Alloc_Expr>; | |
5847 | -- Temp_Id := Temp_Typ (Local); | |
5848 | -- end; | |
5849 | -- end if; | |
5850 | -- | |
5851 | -- Temp_Id is the temporary which is used to reference the internally | |
5852 | -- created object in all allocation forms. Temp_Typ is the type of the | |
5853 | -- temporary. Func_Id is the enclosing function. Ret_Typ is the return | |
5854 | -- type of Func_Id. Alloc_Expr is the actual allocator. | |
2b3d67a5 | 5855 | |
2b3d67a5 AC |
5856 | function Move_Activation_Chain return Node_Id; |
5857 | -- Construct a call to System.Tasking.Stages.Move_Activation_Chain | |
5858 | -- with parameters: | |
5859 | -- From current activation chain | |
5860 | -- To activation chain passed in by the caller | |
5861 | -- New_Master master passed in by the caller | |
5862 | ||
df3e68b1 HK |
5863 | -------------------------- |
5864 | -- Build_Heap_Allocator -- | |
5865 | -------------------------- | |
5866 | ||
5867 | function Build_Heap_Allocator | |
5868 | (Temp_Id : Entity_Id; | |
5869 | Temp_Typ : Entity_Id; | |
5870 | Func_Id : Entity_Id; | |
5871 | Ret_Typ : Entity_Id; | |
5872 | Alloc_Expr : Node_Id) return Node_Id | |
5873 | is | |
5874 | begin | |
200b7162 BD |
5875 | pragma Assert (Is_Build_In_Place_Function (Func_Id)); |
5876 | ||
df3e68b1 | 5877 | -- Processing for build-in-place object allocation. This is disabled |
d3f70b35 | 5878 | -- on .NET/JVM because the targets do not support pools. |
df3e68b1 HK |
5879 | |
5880 | if VM_Target = No_VM | |
df3e68b1 HK |
5881 | and then Needs_Finalization (Ret_Typ) |
5882 | then | |
5883 | declare | |
d3f70b35 AC |
5884 | Decls : constant List_Id := New_List; |
5885 | Fin_Mas_Id : constant Entity_Id := | |
5886 | Build_In_Place_Formal | |
5887 | (Func_Id, BIP_Finalization_Master); | |
5888 | Stmts : constant List_Id := New_List; | |
ba759acd AC |
5889 | Desig_Typ : Entity_Id; |
5890 | Local_Id : Entity_Id; | |
5891 | Pool_Id : Entity_Id; | |
5892 | Ptr_Typ : Entity_Id; | |
df3e68b1 HK |
5893 | |
5894 | begin | |
5895 | -- Generate: | |
d3f70b35 | 5896 | -- Pool_Id renames Base_Pool (BIPfinalizationmaster.all).all; |
df3e68b1 HK |
5897 | |
5898 | Pool_Id := Make_Temporary (Loc, 'P'); | |
5899 | ||
5900 | Append_To (Decls, | |
5901 | Make_Object_Renaming_Declaration (Loc, | |
5902 | Defining_Identifier => Pool_Id, | |
2c1b72d7 | 5903 | Subtype_Mark => |
df3e68b1 | 5904 | New_Reference_To (RTE (RE_Root_Storage_Pool), Loc), |
2c1b72d7 | 5905 | Name => |
df3e68b1 HK |
5906 | Make_Explicit_Dereference (Loc, |
5907 | Prefix => | |
5908 | Make_Function_Call (Loc, | |
2c1b72d7 | 5909 | Name => |
df3e68b1 | 5910 | New_Reference_To (RTE (RE_Base_Pool), Loc), |
df3e68b1 HK |
5911 | Parameter_Associations => New_List ( |
5912 | Make_Explicit_Dereference (Loc, | |
d3f70b35 AC |
5913 | Prefix => |
5914 | New_Reference_To (Fin_Mas_Id, Loc))))))); | |
df3e68b1 HK |
5915 | |
5916 | -- Create an access type which uses the storage pool of the | |
d3f70b35 AC |
5917 | -- caller's master. This additional type is necessary because |
5918 | -- the finalization master cannot be associated with the type | |
df3e68b1 HK |
5919 | -- of the temporary. Otherwise the secondary stack allocation |
5920 | -- will fail. | |
5921 | ||
ba759acd AC |
5922 | Desig_Typ := Ret_Typ; |
5923 | ||
5924 | -- Ensure that the build-in-place machinery uses a fat pointer | |
5925 | -- when allocating an unconstrained array on the heap. In this | |
5926 | -- case the result object type is a constrained array type even | |
5927 | -- though the function type is unconstrained. | |
5928 | ||
5929 | if Ekind (Desig_Typ) = E_Array_Subtype then | |
5930 | Desig_Typ := Base_Type (Desig_Typ); | |
5931 | end if; | |
5932 | ||
df3e68b1 | 5933 | -- Generate: |
ba759acd | 5934 | -- type Ptr_Typ is access Desig_Typ; |
df3e68b1 HK |
5935 | |
5936 | Ptr_Typ := Make_Temporary (Loc, 'P'); | |
5937 | ||
5938 | Append_To (Decls, | |
5939 | Make_Full_Type_Declaration (Loc, | |
5940 | Defining_Identifier => Ptr_Typ, | |
2c1b72d7 | 5941 | Type_Definition => |
df3e68b1 HK |
5942 | Make_Access_To_Object_Definition (Loc, |
5943 | Subtype_Indication => | |
ba759acd | 5944 | New_Reference_To (Desig_Typ, Loc)))); |
df3e68b1 | 5945 | |
d3f70b35 AC |
5946 | -- Perform minor decoration in order to set the master and the |
5947 | -- storage pool attributes. | |
df3e68b1 HK |
5948 | |
5949 | Set_Ekind (Ptr_Typ, E_Access_Type); | |
d3f70b35 | 5950 | Set_Finalization_Master (Ptr_Typ, Fin_Mas_Id); |
df3e68b1 HK |
5951 | Set_Associated_Storage_Pool (Ptr_Typ, Pool_Id); |
5952 | ||
5953 | -- Create the temporary, generate: | |
df3e68b1 HK |
5954 | -- Local_Id : Ptr_Typ; |
5955 | ||
5956 | Local_Id := Make_Temporary (Loc, 'T'); | |
5957 | ||
5958 | Append_To (Decls, | |
5959 | Make_Object_Declaration (Loc, | |
5960 | Defining_Identifier => Local_Id, | |
2c1b72d7 | 5961 | Object_Definition => |
df3e68b1 HK |
5962 | New_Reference_To (Ptr_Typ, Loc))); |
5963 | ||
5964 | -- Allocate the object, generate: | |
df3e68b1 HK |
5965 | -- Local_Id := <Alloc_Expr>; |
5966 | ||
5967 | Append_To (Stmts, | |
5968 | Make_Assignment_Statement (Loc, | |
2c1b72d7 | 5969 | Name => New_Reference_To (Local_Id, Loc), |
df3e68b1 HK |
5970 | Expression => Alloc_Expr)); |
5971 | ||
5972 | -- Generate: | |
5973 | -- Temp_Id := Temp_Typ (Local_Id); | |
5974 | ||
5975 | Append_To (Stmts, | |
5976 | Make_Assignment_Statement (Loc, | |
2c1b72d7 | 5977 | Name => New_Reference_To (Temp_Id, Loc), |
df3e68b1 HK |
5978 | Expression => |
5979 | Unchecked_Convert_To (Temp_Typ, | |
5980 | New_Reference_To (Local_Id, Loc)))); | |
5981 | ||
5982 | -- Wrap the allocation in a block. This is further conditioned | |
d3f70b35 AC |
5983 | -- by checking the caller finalization master at runtime. A |
5984 | -- null value indicates a non-existent master, most likely due | |
5985 | -- to a Finalize_Storage_Only allocation. | |
df3e68b1 HK |
5986 | |
5987 | -- Generate: | |
d3f70b35 | 5988 | -- if BIPfinalizationmaster /= null then |
df3e68b1 HK |
5989 | -- declare |
5990 | -- <Decls> | |
5991 | -- begin | |
5992 | -- <Stmts> | |
5993 | -- end; | |
5994 | -- end if; | |
5995 | ||
5996 | return | |
5997 | Make_If_Statement (Loc, | |
2c1b72d7 | 5998 | Condition => |
df3e68b1 | 5999 | Make_Op_Ne (Loc, |
d3f70b35 | 6000 | Left_Opnd => New_Reference_To (Fin_Mas_Id, Loc), |
2c1b72d7 | 6001 | Right_Opnd => Make_Null (Loc)), |
df3e68b1 HK |
6002 | |
6003 | Then_Statements => New_List ( | |
6004 | Make_Block_Statement (Loc, | |
2c1b72d7 | 6005 | Declarations => Decls, |
df3e68b1 HK |
6006 | Handled_Statement_Sequence => |
6007 | Make_Handled_Sequence_Of_Statements (Loc, | |
6008 | Statements => Stmts)))); | |
6009 | end; | |
6010 | ||
6011 | -- For all other cases, generate: | |
df3e68b1 HK |
6012 | -- Temp_Id := <Alloc_Expr>; |
6013 | ||
6014 | else | |
6015 | return | |
6016 | Make_Assignment_Statement (Loc, | |
2c1b72d7 | 6017 | Name => New_Reference_To (Temp_Id, Loc), |
df3e68b1 HK |
6018 | Expression => Alloc_Expr); |
6019 | end if; | |
6020 | end Build_Heap_Allocator; | |
2b3d67a5 | 6021 | |
2b3d67a5 AC |
6022 | --------------------------- |
6023 | -- Move_Activation_Chain -- | |
6024 | --------------------------- | |
6025 | ||
6026 | function Move_Activation_Chain return Node_Id is | |
2b3d67a5 | 6027 | begin |
2b3d67a5 AC |
6028 | return |
6029 | Make_Procedure_Call_Statement (Loc, | |
2c1b72d7 | 6030 | Name => |
df3e68b1 | 6031 | New_Reference_To (RTE (RE_Move_Activation_Chain), Loc), |
0613fb33 AC |
6032 | |
6033 | Parameter_Associations => New_List ( | |
6034 | ||
6035 | -- Source chain | |
6036 | ||
6037 | Make_Attribute_Reference (Loc, | |
6038 | Prefix => Make_Identifier (Loc, Name_uChain), | |
6039 | Attribute_Name => Name_Unrestricted_Access), | |
6040 | ||
6041 | -- Destination chain | |
6042 | ||
6043 | New_Reference_To | |
6044 | (Build_In_Place_Formal (Par_Func, BIP_Activation_Chain), Loc), | |
6045 | ||
6046 | -- New master | |
6047 | ||
6048 | New_Reference_To | |
af89615f | 6049 | (Build_In_Place_Formal (Par_Func, BIP_Task_Master), Loc))); |
2b3d67a5 AC |
6050 | end Move_Activation_Chain; |
6051 | ||
df3e68b1 | 6052 | -- Start of processing for Expand_N_Extended_Return_Statement |
2b3d67a5 | 6053 | |
df3e68b1 | 6054 | begin |
f6f4d8d4 JM |
6055 | -- Given that functionality of interface thunks is simple (just displace |
6056 | -- the pointer to the object) they are always handled by means of | |
6057 | -- simple return statements. | |
6058 | ||
da1c23dd | 6059 | pragma Assert (not Is_Thunk (Current_Scope)); |
f6f4d8d4 | 6060 | |
df3e68b1 HK |
6061 | if Nkind (Ret_Obj_Decl) = N_Object_Declaration then |
6062 | Exp := Expression (Ret_Obj_Decl); | |
6063 | else | |
6064 | Exp := Empty; | |
6065 | end if; | |
2b3d67a5 | 6066 | |
df3e68b1 | 6067 | HSS := Handled_Statement_Sequence (N); |
2b3d67a5 | 6068 | |
df3e68b1 HK |
6069 | -- If the returned object needs finalization actions, the function must |
6070 | -- perform the appropriate cleanup should it fail to return. The state | |
6071 | -- of the function itself is tracked through a flag which is coupled | |
6072 | -- with the scope finalizer. There is one flag per each return object | |
6073 | -- in case of multiple returns. | |
2b3d67a5 | 6074 | |
df3e68b1 HK |
6075 | if Is_Build_In_Place |
6076 | and then Needs_Finalization (Etype (Ret_Obj_Id)) | |
6077 | then | |
6078 | declare | |
6079 | Flag_Decl : Node_Id; | |
6080 | Flag_Id : Entity_Id; | |
6081 | Func_Bod : Node_Id; | |
2b3d67a5 | 6082 | |
df3e68b1 HK |
6083 | begin |
6084 | -- Recover the function body | |
2b3d67a5 | 6085 | |
df3e68b1 | 6086 | Func_Bod := Unit_Declaration_Node (Par_Func); |
0613fb33 | 6087 | |
df3e68b1 HK |
6088 | if Nkind (Func_Bod) = N_Subprogram_Declaration then |
6089 | Func_Bod := Parent (Parent (Corresponding_Body (Func_Bod))); | |
6090 | end if; | |
2b3d67a5 | 6091 | |
df3e68b1 | 6092 | -- Create a flag to track the function state |
2b3d67a5 | 6093 | |
df3e68b1 | 6094 | Flag_Id := Make_Temporary (Loc, 'F'); |
3cebd1c0 | 6095 | Set_Status_Flag_Or_Transient_Decl (Ret_Obj_Id, Flag_Id); |
2b3d67a5 | 6096 | |
df3e68b1 HK |
6097 | -- Insert the flag at the beginning of the function declarations, |
6098 | -- generate: | |
6099 | -- Fnn : Boolean := False; | |
2b3d67a5 | 6100 | |
df3e68b1 HK |
6101 | Flag_Decl := |
6102 | Make_Object_Declaration (Loc, | |
6103 | Defining_Identifier => Flag_Id, | |
2c1b72d7 AC |
6104 | Object_Definition => |
6105 | New_Reference_To (Standard_Boolean, Loc), | |
6106 | Expression => New_Reference_To (Standard_False, Loc)); | |
2b3d67a5 | 6107 | |
df3e68b1 HK |
6108 | Prepend_To (Declarations (Func_Bod), Flag_Decl); |
6109 | Analyze (Flag_Decl); | |
6110 | end; | |
6111 | end if; | |
2b3d67a5 AC |
6112 | |
6113 | -- Build a simple_return_statement that returns the return object when | |
6114 | -- there is a statement sequence, or no expression, or the result will | |
6115 | -- be built in place. Note however that we currently do this for all | |
6116 | -- composite cases, even though nonlimited composite results are not yet | |
6117 | -- built in place (though we plan to do so eventually). | |
6118 | ||
df3e68b1 | 6119 | if Present (HSS) |
1a36a0cd | 6120 | or else Is_Composite_Type (Result_Subt) |
2b3d67a5 AC |
6121 | or else No (Exp) |
6122 | then | |
df3e68b1 HK |
6123 | if No (HSS) then |
6124 | Stmts := New_List; | |
2b3d67a5 AC |
6125 | |
6126 | -- If the extended return has a handled statement sequence, then wrap | |
6127 | -- it in a block and use the block as the first statement. | |
6128 | ||
6129 | else | |
df3e68b1 HK |
6130 | Stmts := New_List ( |
6131 | Make_Block_Statement (Loc, | |
2c1b72d7 | 6132 | Declarations => New_List, |
df3e68b1 | 6133 | Handled_Statement_Sequence => HSS)); |
2b3d67a5 AC |
6134 | end if; |
6135 | ||
df3e68b1 HK |
6136 | -- If the result type contains tasks, we call Move_Activation_Chain. |
6137 | -- Later, the cleanup code will call Complete_Master, which will | |
6138 | -- terminate any unactivated tasks belonging to the return statement | |
6139 | -- master. But Move_Activation_Chain updates their master to be that | |
6140 | -- of the caller, so they will not be terminated unless the return | |
6141 | -- statement completes unsuccessfully due to exception, abort, goto, | |
6142 | -- or exit. As a formality, we test whether the function requires the | |
6143 | -- result to be built in place, though that's necessarily true for | |
6144 | -- the case of result types with task parts. | |
2b3d67a5 AC |
6145 | |
6146 | if Is_Build_In_Place | |
1a36a0cd | 6147 | and then Has_Task (Result_Subt) |
2b3d67a5 | 6148 | then |
4a1bfefb AC |
6149 | -- The return expression is an aggregate for a complex type which |
6150 | -- contains tasks. This particular case is left unexpanded since | |
6151 | -- the regular expansion would insert all temporaries and | |
6152 | -- initialization code in the wrong block. | |
6153 | ||
6154 | if Nkind (Exp) = N_Aggregate then | |
6155 | Expand_N_Aggregate (Exp); | |
6156 | end if; | |
6157 | ||
1a36a0cd AC |
6158 | -- Do not move the activation chain if the return object does not |
6159 | -- contain tasks. | |
6160 | ||
6161 | if Has_Task (Etype (Ret_Obj_Id)) then | |
6162 | Append_To (Stmts, Move_Activation_Chain); | |
6163 | end if; | |
2b3d67a5 AC |
6164 | end if; |
6165 | ||
df3e68b1 HK |
6166 | -- Update the state of the function right before the object is |
6167 | -- returned. | |
6168 | ||
6169 | if Is_Build_In_Place | |
6170 | and then Needs_Finalization (Etype (Ret_Obj_Id)) | |
6171 | then | |
6172 | declare | |
35a1c212 | 6173 | Flag_Id : constant Entity_Id := |
3cebd1c0 | 6174 | Status_Flag_Or_Transient_Decl (Ret_Obj_Id); |
4fdebd93 | 6175 | |
df3e68b1 HK |
6176 | begin |
6177 | -- Generate: | |
6178 | -- Fnn := True; | |
6179 | ||
6180 | Append_To (Stmts, | |
6181 | Make_Assignment_Statement (Loc, | |
2c1b72d7 AC |
6182 | Name => New_Reference_To (Flag_Id, Loc), |
6183 | Expression => New_Reference_To (Standard_True, Loc))); | |
df3e68b1 | 6184 | end; |
2b3d67a5 AC |
6185 | end if; |
6186 | ||
6187 | -- Build a simple_return_statement that returns the return object | |
6188 | ||
df3e68b1 | 6189 | Return_Stmt := |
2b3d67a5 | 6190 | Make_Simple_Return_Statement (Loc, |
2c1b72d7 | 6191 | Expression => New_Occurrence_Of (Ret_Obj_Id, Loc)); |
df3e68b1 | 6192 | Append_To (Stmts, Return_Stmt); |
2b3d67a5 | 6193 | |
df3e68b1 | 6194 | HSS := Make_Handled_Sequence_Of_Statements (Loc, Stmts); |
2b3d67a5 AC |
6195 | end if; |
6196 | ||
df3e68b1 | 6197 | -- Case where we build a return statement block |
2b3d67a5 | 6198 | |
df3e68b1 | 6199 | if Present (HSS) then |
2b3d67a5 AC |
6200 | Result := |
6201 | Make_Block_Statement (Loc, | |
2c1b72d7 | 6202 | Declarations => Return_Object_Declarations (N), |
df3e68b1 | 6203 | Handled_Statement_Sequence => HSS); |
2b3d67a5 AC |
6204 | |
6205 | -- We set the entity of the new block statement to be that of the | |
6206 | -- return statement. This is necessary so that various fields, such | |
6207 | -- as Finalization_Chain_Entity carry over from the return statement | |
6208 | -- to the block. Note that this block is unusual, in that its entity | |
6209 | -- is an E_Return_Statement rather than an E_Block. | |
6210 | ||
6211 | Set_Identifier | |
6212 | (Result, New_Occurrence_Of (Return_Statement_Entity (N), Loc)); | |
6213 | ||
54bf19e4 AC |
6214 | -- If the object decl was already rewritten as a renaming, then we |
6215 | -- don't want to do the object allocation and transformation of of | |
6216 | -- the return object declaration to a renaming. This case occurs | |
2b3d67a5 | 6217 | -- when the return object is initialized by a call to another |
54bf19e4 AC |
6218 | -- build-in-place function, and that function is responsible for |
6219 | -- the allocation of the return object. | |
2b3d67a5 AC |
6220 | |
6221 | if Is_Build_In_Place | |
df3e68b1 | 6222 | and then Nkind (Ret_Obj_Decl) = N_Object_Renaming_Declaration |
2b3d67a5 | 6223 | then |
df3e68b1 HK |
6224 | pragma Assert |
6225 | (Nkind (Original_Node (Ret_Obj_Decl)) = N_Object_Declaration | |
2c1b72d7 AC |
6226 | and then Is_Build_In_Place_Function_Call |
6227 | (Expression (Original_Node (Ret_Obj_Decl)))); | |
df3e68b1 HK |
6228 | |
6229 | -- Return the build-in-place result by reference | |
2b3d67a5 | 6230 | |
df3e68b1 | 6231 | Set_By_Ref (Return_Stmt); |
2b3d67a5 AC |
6232 | |
6233 | elsif Is_Build_In_Place then | |
6234 | ||
6235 | -- Locate the implicit access parameter associated with the | |
6236 | -- caller-supplied return object and convert the return | |
6237 | -- statement's return object declaration to a renaming of a | |
6238 | -- dereference of the access parameter. If the return object's | |
6239 | -- declaration includes an expression that has not already been | |
6240 | -- expanded as separate assignments, then add an assignment | |
6241 | -- statement to ensure the return object gets initialized. | |
6242 | ||
df3e68b1 HK |
6243 | -- declare |
6244 | -- Result : T [:= <expression>]; | |
6245 | -- begin | |
6246 | -- ... | |
2b3d67a5 AC |
6247 | |
6248 | -- is converted to | |
6249 | ||
df3e68b1 HK |
6250 | -- declare |
6251 | -- Result : T renames FuncRA.all; | |
6252 | -- [Result := <expression;] | |
6253 | -- begin | |
6254 | -- ... | |
2b3d67a5 AC |
6255 | |
6256 | declare | |
6257 | Return_Obj_Id : constant Entity_Id := | |
df3e68b1 | 6258 | Defining_Identifier (Ret_Obj_Decl); |
2b3d67a5 AC |
6259 | Return_Obj_Typ : constant Entity_Id := Etype (Return_Obj_Id); |
6260 | Return_Obj_Expr : constant Node_Id := | |
df3e68b1 | 6261 | Expression (Ret_Obj_Decl); |
2b3d67a5 AC |
6262 | Constr_Result : constant Boolean := |
6263 | Is_Constrained (Result_Subt); | |
6264 | Obj_Alloc_Formal : Entity_Id; | |
6265 | Object_Access : Entity_Id; | |
6266 | Obj_Acc_Deref : Node_Id; | |
6267 | Init_Assignment : Node_Id := Empty; | |
6268 | ||
6269 | begin | |
6270 | -- Build-in-place results must be returned by reference | |
6271 | ||
df3e68b1 | 6272 | Set_By_Ref (Return_Stmt); |
2b3d67a5 AC |
6273 | |
6274 | -- Retrieve the implicit access parameter passed by the caller | |
6275 | ||
6276 | Object_Access := | |
df3e68b1 | 6277 | Build_In_Place_Formal (Par_Func, BIP_Object_Access); |
2b3d67a5 AC |
6278 | |
6279 | -- If the return object's declaration includes an expression | |
6280 | -- and the declaration isn't marked as No_Initialization, then | |
6281 | -- we need to generate an assignment to the object and insert | |
6282 | -- it after the declaration before rewriting it as a renaming | |
6283 | -- (otherwise we'll lose the initialization). The case where | |
6284 | -- the result type is an interface (or class-wide interface) | |
6285 | -- is also excluded because the context of the function call | |
6286 | -- must be unconstrained, so the initialization will always | |
6287 | -- be done as part of an allocator evaluation (storage pool | |
6288 | -- or secondary stack), never to a constrained target object | |
6289 | -- passed in by the caller. Besides the assignment being | |
6290 | -- unneeded in this case, it avoids problems with trying to | |
6291 | -- generate a dispatching assignment when the return expression | |
6292 | -- is a nonlimited descendant of a limited interface (the | |
6293 | -- interface has no assignment operation). | |
6294 | ||
6295 | if Present (Return_Obj_Expr) | |
df3e68b1 | 6296 | and then not No_Initialization (Ret_Obj_Decl) |
2b3d67a5 AC |
6297 | and then not Is_Interface (Return_Obj_Typ) |
6298 | then | |
6299 | Init_Assignment := | |
6300 | Make_Assignment_Statement (Loc, | |
2c1b72d7 AC |
6301 | Name => New_Reference_To (Return_Obj_Id, Loc), |
6302 | Expression => Relocate_Node (Return_Obj_Expr)); | |
df3e68b1 | 6303 | |
2b3d67a5 AC |
6304 | Set_Etype (Name (Init_Assignment), Etype (Return_Obj_Id)); |
6305 | Set_Assignment_OK (Name (Init_Assignment)); | |
6306 | Set_No_Ctrl_Actions (Init_Assignment); | |
6307 | ||
6308 | Set_Parent (Name (Init_Assignment), Init_Assignment); | |
6309 | Set_Parent (Expression (Init_Assignment), Init_Assignment); | |
6310 | ||
df3e68b1 | 6311 | Set_Expression (Ret_Obj_Decl, Empty); |
2b3d67a5 AC |
6312 | |
6313 | if Is_Class_Wide_Type (Etype (Return_Obj_Id)) | |
6314 | and then not Is_Class_Wide_Type | |
6315 | (Etype (Expression (Init_Assignment))) | |
6316 | then | |
6317 | Rewrite (Expression (Init_Assignment), | |
6318 | Make_Type_Conversion (Loc, | |
6319 | Subtype_Mark => | |
df3e68b1 | 6320 | New_Occurrence_Of (Etype (Return_Obj_Id), Loc), |
2c1b72d7 | 6321 | Expression => |
2b3d67a5 AC |
6322 | Relocate_Node (Expression (Init_Assignment)))); |
6323 | end if; | |
6324 | ||
6325 | -- In the case of functions where the calling context can | |
6326 | -- determine the form of allocation needed, initialization | |
6327 | -- is done with each part of the if statement that handles | |
6328 | -- the different forms of allocation (this is true for | |
6329 | -- unconstrained and tagged result subtypes). | |
6330 | ||
6331 | if Constr_Result | |
6332 | and then not Is_Tagged_Type (Underlying_Type (Result_Subt)) | |
6333 | then | |
df3e68b1 | 6334 | Insert_After (Ret_Obj_Decl, Init_Assignment); |
2b3d67a5 AC |
6335 | end if; |
6336 | end if; | |
6337 | ||
6338 | -- When the function's subtype is unconstrained, a run-time | |
6339 | -- test is needed to determine the form of allocation to use | |
6340 | -- for the return object. The function has an implicit formal | |
6341 | -- parameter indicating this. If the BIP_Alloc_Form formal has | |
6342 | -- the value one, then the caller has passed access to an | |
6343 | -- existing object for use as the return object. If the value | |
6344 | -- is two, then the return object must be allocated on the | |
6345 | -- secondary stack. Otherwise, the object must be allocated in | |
6346 | -- a storage pool (currently only supported for the global | |
6347 | -- heap, user-defined storage pools TBD ???). We generate an | |
6348 | -- if statement to test the implicit allocation formal and | |
6349 | -- initialize a local access value appropriately, creating | |
6350 | -- allocators in the secondary stack and global heap cases. | |
6351 | -- The special formal also exists and must be tested when the | |
6352 | -- function has a tagged result, even when the result subtype | |
6353 | -- is constrained, because in general such functions can be | |
6354 | -- called in dispatching contexts and must be handled similarly | |
6355 | -- to functions with a class-wide result. | |
6356 | ||
6357 | if not Constr_Result | |
6358 | or else Is_Tagged_Type (Underlying_Type (Result_Subt)) | |
6359 | then | |
6360 | Obj_Alloc_Formal := | |
df3e68b1 | 6361 | Build_In_Place_Formal (Par_Func, BIP_Alloc_Form); |
2b3d67a5 AC |
6362 | |
6363 | declare | |
8417f4b2 AC |
6364 | Pool_Id : constant Entity_Id := |
6365 | Make_Temporary (Loc, 'P'); | |
2b3d67a5 AC |
6366 | Alloc_Obj_Id : Entity_Id; |
6367 | Alloc_Obj_Decl : Node_Id; | |
6368 | Alloc_If_Stmt : Node_Id; | |
200b7162 | 6369 | Heap_Allocator : Node_Id; |
200b7162 BD |
6370 | Pool_Decl : Node_Id; |
6371 | Pool_Allocator : Node_Id; | |
8417f4b2 AC |
6372 | Ptr_Type_Decl : Node_Id; |
6373 | Ref_Type : Entity_Id; | |
6374 | SS_Allocator : Node_Id; | |
2b3d67a5 AC |
6375 | |
6376 | begin | |
6377 | -- Reuse the itype created for the function's implicit | |
6378 | -- access formal. This avoids the need to create a new | |
6379 | -- access type here, plus it allows assigning the access | |
6380 | -- formal directly without applying a conversion. | |
6381 | ||
df3e68b1 | 6382 | -- Ref_Type := Etype (Object_Access); |
2b3d67a5 AC |
6383 | |
6384 | -- Create an access type designating the function's | |
6385 | -- result subtype. | |
6386 | ||
6387 | Ref_Type := Make_Temporary (Loc, 'A'); | |
6388 | ||
6389 | Ptr_Type_Decl := | |
6390 | Make_Full_Type_Declaration (Loc, | |
6391 | Defining_Identifier => Ref_Type, | |
2c1b72d7 | 6392 | Type_Definition => |
2b3d67a5 | 6393 | Make_Access_To_Object_Definition (Loc, |
2c1b72d7 | 6394 | All_Present => True, |
2b3d67a5 AC |
6395 | Subtype_Indication => |
6396 | New_Reference_To (Return_Obj_Typ, Loc))); | |
6397 | ||
df3e68b1 | 6398 | Insert_Before (Ret_Obj_Decl, Ptr_Type_Decl); |
2b3d67a5 AC |
6399 | |
6400 | -- Create an access object that will be initialized to an | |
6401 | -- access value denoting the return object, either coming | |
6402 | -- from an implicit access value passed in by the caller | |
6403 | -- or from the result of an allocator. | |
6404 | ||
6405 | Alloc_Obj_Id := Make_Temporary (Loc, 'R'); | |
6406 | Set_Etype (Alloc_Obj_Id, Ref_Type); | |
6407 | ||
6408 | Alloc_Obj_Decl := | |
6409 | Make_Object_Declaration (Loc, | |
6410 | Defining_Identifier => Alloc_Obj_Id, | |
2c1b72d7 | 6411 | Object_Definition => |
df3e68b1 | 6412 | New_Reference_To (Ref_Type, Loc)); |
2b3d67a5 | 6413 | |
df3e68b1 | 6414 | Insert_Before (Ret_Obj_Decl, Alloc_Obj_Decl); |
2b3d67a5 AC |
6415 | |
6416 | -- Create allocators for both the secondary stack and | |
6417 | -- global heap. If there's an initialization expression, | |
6418 | -- then create these as initialized allocators. | |
6419 | ||
6420 | if Present (Return_Obj_Expr) | |
df3e68b1 | 6421 | and then not No_Initialization (Ret_Obj_Decl) |
2b3d67a5 AC |
6422 | then |
6423 | -- Always use the type of the expression for the | |
6424 | -- qualified expression, rather than the result type. | |
6425 | -- In general we cannot always use the result type | |
6426 | -- for the allocator, because the expression might be | |
6427 | -- of a specific type, such as in the case of an | |
6428 | -- aggregate or even a nonlimited object when the | |
6429 | -- result type is a limited class-wide interface type. | |
6430 | ||
6431 | Heap_Allocator := | |
6432 | Make_Allocator (Loc, | |
6433 | Expression => | |
6434 | Make_Qualified_Expression (Loc, | |
6435 | Subtype_Mark => | |
6436 | New_Reference_To | |
6437 | (Etype (Return_Obj_Expr), Loc), | |
2c1b72d7 | 6438 | Expression => |
2b3d67a5 AC |
6439 | New_Copy_Tree (Return_Obj_Expr))); |
6440 | ||
6441 | else | |
6442 | -- If the function returns a class-wide type we cannot | |
6443 | -- use the return type for the allocator. Instead we | |
6444 | -- use the type of the expression, which must be an | |
6445 | -- aggregate of a definite type. | |
6446 | ||
6447 | if Is_Class_Wide_Type (Return_Obj_Typ) then | |
6448 | Heap_Allocator := | |
6449 | Make_Allocator (Loc, | |
6450 | Expression => | |
6451 | New_Reference_To | |
6452 | (Etype (Return_Obj_Expr), Loc)); | |
6453 | else | |
6454 | Heap_Allocator := | |
6455 | Make_Allocator (Loc, | |
6456 | Expression => | |
6457 | New_Reference_To (Return_Obj_Typ, Loc)); | |
6458 | end if; | |
6459 | ||
6460 | -- If the object requires default initialization then | |
6461 | -- that will happen later following the elaboration of | |
6462 | -- the object renaming. If we don't turn it off here | |
6463 | -- then the object will be default initialized twice. | |
6464 | ||
6465 | Set_No_Initialization (Heap_Allocator); | |
6466 | end if; | |
6467 | ||
200b7162 | 6468 | -- The Pool_Allocator is just like the Heap_Allocator, |
8417f4b2 AC |
6469 | -- except we set Storage_Pool and Procedure_To_Call so |
6470 | -- it will use the user-defined storage pool. | |
200b7162 BD |
6471 | |
6472 | Pool_Allocator := New_Copy_Tree (Heap_Allocator); | |
8417f4b2 AC |
6473 | |
6474 | -- Do not generate the renaming of the build-in-place | |
3e452820 AC |
6475 | -- pool parameter on .NET/JVM/ZFP because the parameter |
6476 | -- is not created in the first place. | |
8417f4b2 | 6477 | |
ea10ca9c AC |
6478 | if VM_Target = No_VM |
6479 | and then RTE_Available (RE_Root_Storage_Pool_Ptr) | |
3e452820 | 6480 | then |
8417f4b2 AC |
6481 | Pool_Decl := |
6482 | Make_Object_Renaming_Declaration (Loc, | |
6483 | Defining_Identifier => Pool_Id, | |
6484 | Subtype_Mark => | |
6485 | New_Reference_To | |
6486 | (RTE (RE_Root_Storage_Pool), Loc), | |
6487 | Name => | |
6488 | Make_Explicit_Dereference (Loc, | |
6489 | New_Reference_To | |
6490 | (Build_In_Place_Formal | |
6491 | (Par_Func, BIP_Storage_Pool), Loc))); | |
6492 | Set_Storage_Pool (Pool_Allocator, Pool_Id); | |
6493 | Set_Procedure_To_Call | |
6494 | (Pool_Allocator, RTE (RE_Allocate_Any)); | |
6495 | else | |
6496 | Pool_Decl := Make_Null_Statement (Loc); | |
6497 | end if; | |
200b7162 | 6498 | |
2b3d67a5 AC |
6499 | -- If the No_Allocators restriction is active, then only |
6500 | -- an allocator for secondary stack allocation is needed. | |
6501 | -- It's OK for such allocators to have Comes_From_Source | |
6502 | -- set to False, because gigi knows not to flag them as | |
6503 | -- being a violation of No_Implicit_Heap_Allocations. | |
6504 | ||
6505 | if Restriction_Active (No_Allocators) then | |
6506 | SS_Allocator := Heap_Allocator; | |
6507 | Heap_Allocator := Make_Null (Loc); | |
200b7162 | 6508 | Pool_Allocator := Make_Null (Loc); |
2b3d67a5 | 6509 | |
200b7162 BD |
6510 | -- Otherwise the heap and pool allocators may be needed, |
6511 | -- so we make another allocator for secondary stack | |
6512 | -- allocation. | |
2b3d67a5 AC |
6513 | |
6514 | else | |
6515 | SS_Allocator := New_Copy_Tree (Heap_Allocator); | |
6516 | ||
3e7302c3 | 6517 | -- The heap and pool allocators are marked as |
200b7162 BD |
6518 | -- Comes_From_Source since they correspond to an |
6519 | -- explicit user-written allocator (that is, it will | |
6520 | -- only be executed on behalf of callers that call the | |
3e7302c3 AC |
6521 | -- function as initialization for such an allocator). |
6522 | -- Prevents errors when No_Implicit_Heap_Allocations | |
6523 | -- is in force. | |
2b3d67a5 AC |
6524 | |
6525 | Set_Comes_From_Source (Heap_Allocator, True); | |
200b7162 | 6526 | Set_Comes_From_Source (Pool_Allocator, True); |
2b3d67a5 AC |
6527 | end if; |
6528 | ||
6529 | -- The allocator is returned on the secondary stack. We | |
6530 | -- don't do this on VM targets, since the SS is not used. | |
6531 | ||
6532 | if VM_Target = No_VM then | |
6533 | Set_Storage_Pool (SS_Allocator, RTE (RE_SS_Pool)); | |
6534 | Set_Procedure_To_Call | |
6535 | (SS_Allocator, RTE (RE_SS_Allocate)); | |
6536 | ||
6537 | -- The allocator is returned on the secondary stack, | |
6538 | -- so indicate that the function return, as well as | |
6539 | -- the block that encloses the allocator, must not | |
54bf19e4 AC |
6540 | -- release it. The flags must be set now because |
6541 | -- the decision to use the secondary stack is done | |
6542 | -- very late in the course of expanding the return | |
2b3d67a5 AC |
6543 | -- statement, past the point where these flags are |
6544 | -- normally set. | |
6545 | ||
df3e68b1 | 6546 | Set_Sec_Stack_Needed_For_Return (Par_Func); |
2b3d67a5 AC |
6547 | Set_Sec_Stack_Needed_For_Return |
6548 | (Return_Statement_Entity (N)); | |
df3e68b1 | 6549 | Set_Uses_Sec_Stack (Par_Func); |
2b3d67a5 AC |
6550 | Set_Uses_Sec_Stack (Return_Statement_Entity (N)); |
6551 | end if; | |
6552 | ||
6553 | -- Create an if statement to test the BIP_Alloc_Form | |
6554 | -- formal and initialize the access object to either the | |
200b7162 BD |
6555 | -- BIP_Object_Access formal (BIP_Alloc_Form = |
6556 | -- Caller_Allocation), the result of allocating the | |
6557 | -- object in the secondary stack (BIP_Alloc_Form = | |
6558 | -- Secondary_Stack), or else an allocator to create the | |
6559 | -- return object in the heap or user-defined pool | |
6560 | -- (BIP_Alloc_Form = Global_Heap or User_Storage_Pool). | |
2b3d67a5 AC |
6561 | |
6562 | -- ??? An unchecked type conversion must be made in the | |
6563 | -- case of assigning the access object formal to the | |
6564 | -- local access object, because a normal conversion would | |
6565 | -- be illegal in some cases (such as converting access- | |
6566 | -- to-unconstrained to access-to-constrained), but the | |
6567 | -- the unchecked conversion will presumably fail to work | |
6568 | -- right in just such cases. It's not clear at all how to | |
6569 | -- handle this. ??? | |
6570 | ||
6571 | Alloc_If_Stmt := | |
6572 | Make_If_Statement (Loc, | |
df3e68b1 | 6573 | Condition => |
2b3d67a5 | 6574 | Make_Op_Eq (Loc, |
2c1b72d7 | 6575 | Left_Opnd => |
2b3d67a5 AC |
6576 | New_Reference_To (Obj_Alloc_Formal, Loc), |
6577 | Right_Opnd => | |
6578 | Make_Integer_Literal (Loc, | |
6579 | UI_From_Int (BIP_Allocation_Form'Pos | |
6580 | (Caller_Allocation)))), | |
df3e68b1 HK |
6581 | |
6582 | Then_Statements => New_List ( | |
6583 | Make_Assignment_Statement (Loc, | |
2c1b72d7 | 6584 | Name => |
df3e68b1 HK |
6585 | New_Reference_To (Alloc_Obj_Id, Loc), |
6586 | Expression => | |
6587 | Make_Unchecked_Type_Conversion (Loc, | |
6588 | Subtype_Mark => | |
6589 | New_Reference_To (Ref_Type, Loc), | |
2c1b72d7 | 6590 | Expression => |
df3e68b1 HK |
6591 | New_Reference_To (Object_Access, Loc)))), |
6592 | ||
6593 | Elsif_Parts => New_List ( | |
6594 | Make_Elsif_Part (Loc, | |
6595 | Condition => | |
6596 | Make_Op_Eq (Loc, | |
2c1b72d7 | 6597 | Left_Opnd => |
df3e68b1 HK |
6598 | New_Reference_To (Obj_Alloc_Formal, Loc), |
6599 | Right_Opnd => | |
6600 | Make_Integer_Literal (Loc, | |
6601 | UI_From_Int (BIP_Allocation_Form'Pos | |
2b3d67a5 | 6602 | (Secondary_Stack)))), |
df3e68b1 HK |
6603 | |
6604 | Then_Statements => New_List ( | |
6605 | Make_Assignment_Statement (Loc, | |
2c1b72d7 | 6606 | Name => |
df3e68b1 | 6607 | New_Reference_To (Alloc_Obj_Id, Loc), |
200b7162 BD |
6608 | Expression => SS_Allocator))), |
6609 | ||
6610 | Make_Elsif_Part (Loc, | |
6611 | Condition => | |
6612 | Make_Op_Eq (Loc, | |
6613 | Left_Opnd => | |
6614 | New_Reference_To (Obj_Alloc_Formal, Loc), | |
6615 | Right_Opnd => | |
6616 | Make_Integer_Literal (Loc, | |
6617 | UI_From_Int (BIP_Allocation_Form'Pos | |
6618 | (Global_Heap)))), | |
6619 | ||
6620 | Then_Statements => New_List ( | |
6621 | Build_Heap_Allocator | |
6622 | (Temp_Id => Alloc_Obj_Id, | |
6623 | Temp_Typ => Ref_Type, | |
6624 | Func_Id => Par_Func, | |
6625 | Ret_Typ => Return_Obj_Typ, | |
6626 | Alloc_Expr => Heap_Allocator)))), | |
df3e68b1 HK |
6627 | |
6628 | Else_Statements => New_List ( | |
200b7162 | 6629 | Pool_Decl, |
df3e68b1 HK |
6630 | Build_Heap_Allocator |
6631 | (Temp_Id => Alloc_Obj_Id, | |
6632 | Temp_Typ => Ref_Type, | |
6633 | Func_Id => Par_Func, | |
6634 | Ret_Typ => Return_Obj_Typ, | |
200b7162 | 6635 | Alloc_Expr => Pool_Allocator))); |
2b3d67a5 AC |
6636 | |
6637 | -- If a separate initialization assignment was created | |
6638 | -- earlier, append that following the assignment of the | |
6639 | -- implicit access formal to the access object, to ensure | |
54bf19e4 AC |
6640 | -- that the return object is initialized in that case. In |
6641 | -- this situation, the target of the assignment must be | |
6642 | -- rewritten to denote a dereference of the access to the | |
6643 | -- return object passed in by the caller. | |
2b3d67a5 AC |
6644 | |
6645 | if Present (Init_Assignment) then | |
6646 | Rewrite (Name (Init_Assignment), | |
6647 | Make_Explicit_Dereference (Loc, | |
2c1b72d7 | 6648 | Prefix => New_Reference_To (Alloc_Obj_Id, Loc))); |
df3e68b1 | 6649 | |
2b3d67a5 AC |
6650 | Set_Etype |
6651 | (Name (Init_Assignment), Etype (Return_Obj_Id)); | |
6652 | ||
6653 | Append_To | |
2c1b72d7 | 6654 | (Then_Statements (Alloc_If_Stmt), Init_Assignment); |
2b3d67a5 AC |
6655 | end if; |
6656 | ||
df3e68b1 | 6657 | Insert_Before (Ret_Obj_Decl, Alloc_If_Stmt); |
2b3d67a5 AC |
6658 | |
6659 | -- Remember the local access object for use in the | |
6660 | -- dereference of the renaming created below. | |
6661 | ||
6662 | Object_Access := Alloc_Obj_Id; | |
6663 | end; | |
6664 | end if; | |
6665 | ||
6666 | -- Replace the return object declaration with a renaming of a | |
6667 | -- dereference of the access value designating the return | |
6668 | -- object. | |
6669 | ||
6670 | Obj_Acc_Deref := | |
6671 | Make_Explicit_Dereference (Loc, | |
2c1b72d7 | 6672 | Prefix => New_Reference_To (Object_Access, Loc)); |
2b3d67a5 | 6673 | |
df3e68b1 | 6674 | Rewrite (Ret_Obj_Decl, |
2b3d67a5 AC |
6675 | Make_Object_Renaming_Declaration (Loc, |
6676 | Defining_Identifier => Return_Obj_Id, | |
2c1b72d7 AC |
6677 | Access_Definition => Empty, |
6678 | Subtype_Mark => | |
df3e68b1 | 6679 | New_Occurrence_Of (Return_Obj_Typ, Loc), |
2c1b72d7 | 6680 | Name => Obj_Acc_Deref)); |
2b3d67a5 AC |
6681 | |
6682 | Set_Renamed_Object (Return_Obj_Id, Obj_Acc_Deref); | |
6683 | end; | |
6684 | end if; | |
6685 | ||
6686 | -- Case where we do not build a block | |
6687 | ||
6688 | else | |
df3e68b1 HK |
6689 | -- We're about to drop Return_Object_Declarations on the floor, so |
6690 | -- we need to insert it, in case it got expanded into useful code. | |
2b3d67a5 AC |
6691 | -- Remove side effects from expression, which may be duplicated in |
6692 | -- subsequent checks (see Expand_Simple_Function_Return). | |
6693 | ||
df3e68b1 | 6694 | Insert_List_Before (N, Return_Object_Declarations (N)); |
2b3d67a5 AC |
6695 | Remove_Side_Effects (Exp); |
6696 | ||
6697 | -- Build simple_return_statement that returns the expression directly | |
6698 | ||
df3e68b1 HK |
6699 | Return_Stmt := Make_Simple_Return_Statement (Loc, Expression => Exp); |
6700 | Result := Return_Stmt; | |
2b3d67a5 AC |
6701 | end if; |
6702 | ||
6703 | -- Set the flag to prevent infinite recursion | |
6704 | ||
df3e68b1 | 6705 | Set_Comes_From_Extended_Return_Statement (Return_Stmt); |
2b3d67a5 AC |
6706 | |
6707 | Rewrite (N, Result); | |
6708 | Analyze (N); | |
6709 | end Expand_N_Extended_Return_Statement; | |
6710 | ||
70482933 RK |
6711 | ---------------------------- |
6712 | -- Expand_N_Function_Call -- | |
6713 | ---------------------------- | |
6714 | ||
6715 | procedure Expand_N_Function_Call (N : Node_Id) is | |
70482933 | 6716 | begin |
ac4d6407 | 6717 | Expand_Call (N); |
c986420e | 6718 | |
4a3b249c RD |
6719 | -- If the return value of a foreign compiled function is VAX Float, then |
6720 | -- expand the return (adjusts the location of the return value on | |
6721 | -- Alpha/VMS, no-op everywhere else). | |
612c5336 | 6722 | -- Comes_From_Source intercepts recursive expansion. |
2acde248 | 6723 | |
84f4072a JM |
6724 | if Nkind (N) = N_Function_Call |
6725 | and then Vax_Float (Etype (N)) | |
c986420e DR |
6726 | and then Present (Name (N)) |
6727 | and then Present (Entity (Name (N))) | |
6728 | and then Has_Foreign_Convention (Entity (Name (N))) | |
612c5336 | 6729 | and then Comes_From_Source (Parent (N)) |
c986420e DR |
6730 | then |
6731 | Expand_Vax_Foreign_Return (N); | |
6732 | end if; | |
70482933 RK |
6733 | end Expand_N_Function_Call; |
6734 | ||
6735 | --------------------------------------- | |
6736 | -- Expand_N_Procedure_Call_Statement -- | |
6737 | --------------------------------------- | |
6738 | ||
6739 | procedure Expand_N_Procedure_Call_Statement (N : Node_Id) is | |
6740 | begin | |
6741 | Expand_Call (N); | |
6742 | end Expand_N_Procedure_Call_Statement; | |
6743 | ||
2b3d67a5 AC |
6744 | -------------------------------------- |
6745 | -- Expand_N_Simple_Return_Statement -- | |
6746 | -------------------------------------- | |
6747 | ||
6748 | procedure Expand_N_Simple_Return_Statement (N : Node_Id) is | |
6749 | begin | |
6750 | -- Defend against previous errors (i.e. the return statement calls a | |
6751 | -- function that is not available in configurable runtime). | |
6752 | ||
6753 | if Present (Expression (N)) | |
6754 | and then Nkind (Expression (N)) = N_Empty | |
6755 | then | |
ee2ba856 | 6756 | Check_Error_Detected; |
2b3d67a5 AC |
6757 | return; |
6758 | end if; | |
6759 | ||
6760 | -- Distinguish the function and non-function cases: | |
6761 | ||
6762 | case Ekind (Return_Applies_To (Return_Statement_Entity (N))) is | |
6763 | ||
6764 | when E_Function | | |
6765 | E_Generic_Function => | |
6766 | Expand_Simple_Function_Return (N); | |
6767 | ||
6768 | when E_Procedure | | |
6769 | E_Generic_Procedure | | |
6770 | E_Entry | | |
6771 | E_Entry_Family | | |
6772 | E_Return_Statement => | |
6773 | Expand_Non_Function_Return (N); | |
6774 | ||
6775 | when others => | |
6776 | raise Program_Error; | |
6777 | end case; | |
6778 | ||
6779 | exception | |
6780 | when RE_Not_Available => | |
6781 | return; | |
6782 | end Expand_N_Simple_Return_Statement; | |
6783 | ||
70482933 RK |
6784 | ------------------------------ |
6785 | -- Expand_N_Subprogram_Body -- | |
6786 | ------------------------------ | |
6787 | ||
4a3b249c RD |
6788 | -- Add poll call if ATC polling is enabled, unless the body will be inlined |
6789 | -- by the back-end. | |
70482933 | 6790 | |
7888a6ae | 6791 | -- Add dummy push/pop label nodes at start and end to clear any local |
4a3b249c | 6792 | -- exception indications if local-exception-to-goto optimization is active. |
7888a6ae | 6793 | |
f44fe430 RD |
6794 | -- Add return statement if last statement in body is not a return statement |
6795 | -- (this makes things easier on Gigi which does not want to have to handle | |
6796 | -- a missing return). | |
70482933 RK |
6797 | |
6798 | -- Add call to Activate_Tasks if body is a task activator | |
6799 | ||
6800 | -- Deal with possible detection of infinite recursion | |
6801 | ||
6802 | -- Eliminate body completely if convention stubbed | |
6803 | ||
6804 | -- Encode entity names within body, since we will not need to reference | |
6805 | -- these entities any longer in the front end. | |
6806 | ||
6807 | -- Initialize scalar out parameters if Initialize/Normalize_Scalars | |
6808 | ||
c9a4817d | 6809 | -- Reset Pure indication if any parameter has root type System.Address |
199c6a10 AC |
6810 | -- or has any parameters of limited types, where limited means that the |
6811 | -- run-time view is limited (i.e. the full type is limited). | |
c9a4817d | 6812 | |
12e0c41c AC |
6813 | -- Wrap thread body |
6814 | ||
70482933 RK |
6815 | procedure Expand_N_Subprogram_Body (N : Node_Id) is |
6816 | Loc : constant Source_Ptr := Sloc (N); | |
6817 | H : constant Node_Id := Handled_Statement_Sequence (N); | |
c9a4817d | 6818 | Body_Id : Entity_Id; |
70482933 | 6819 | Except_H : Node_Id; |
70482933 | 6820 | L : List_Id; |
70f91180 | 6821 | Spec_Id : Entity_Id; |
70482933 RK |
6822 | |
6823 | procedure Add_Return (S : List_Id); | |
6824 | -- Append a return statement to the statement sequence S if the last | |
6825 | -- statement is not already a return or a goto statement. Note that | |
4a3b249c RD |
6826 | -- the latter test is not critical, it does not matter if we add a few |
6827 | -- extra returns, since they get eliminated anyway later on. | |
70482933 RK |
6828 | |
6829 | ---------------- | |
6830 | -- Add_Return -- | |
6831 | ---------------- | |
6832 | ||
6833 | procedure Add_Return (S : List_Id) is | |
7888a6ae GD |
6834 | Last_Stm : Node_Id; |
6835 | Loc : Source_Ptr; | |
12e0c41c AC |
6836 | |
6837 | begin | |
7888a6ae GD |
6838 | -- Get last statement, ignoring any Pop_xxx_Label nodes, which are |
6839 | -- not relevant in this context since they are not executable. | |
12e0c41c | 6840 | |
7888a6ae GD |
6841 | Last_Stm := Last (S); |
6842 | while Nkind (Last_Stm) in N_Pop_xxx_Label loop | |
6843 | Prev (Last_Stm); | |
6844 | end loop; | |
12e0c41c | 6845 | |
7888a6ae | 6846 | -- Now insert return unless last statement is a transfer |
12e0c41c | 6847 | |
7888a6ae | 6848 | if not Is_Transfer (Last_Stm) then |
12e0c41c | 6849 | |
7888a6ae GD |
6850 | -- The source location for the return is the end label of the |
6851 | -- procedure if present. Otherwise use the sloc of the last | |
6852 | -- statement in the list. If the list comes from a generated | |
6853 | -- exception handler and we are not debugging generated code, | |
6854 | -- all the statements within the handler are made invisible | |
6855 | -- to the debugger. | |
12e0c41c | 6856 | |
7888a6ae GD |
6857 | if Nkind (Parent (S)) = N_Exception_Handler |
6858 | and then not Comes_From_Source (Parent (S)) | |
6859 | then | |
6860 | Loc := Sloc (Last_Stm); | |
7888a6ae GD |
6861 | elsif Present (End_Label (H)) then |
6862 | Loc := Sloc (End_Label (H)); | |
7888a6ae GD |
6863 | else |
6864 | Loc := Sloc (Last_Stm); | |
6865 | end if; | |
12e0c41c | 6866 | |
5334d18f BD |
6867 | declare |
6868 | Rtn : constant Node_Id := Make_Simple_Return_Statement (Loc); | |
6869 | ||
6870 | begin | |
4a3b249c RD |
6871 | -- Append return statement, and set analyzed manually. We can't |
6872 | -- call Analyze on this return since the scope is wrong. | |
5334d18f BD |
6873 | |
6874 | -- Note: it almost works to push the scope and then do the | |
4a3b249c | 6875 | -- Analyze call, but something goes wrong in some weird cases |
5334d18f BD |
6876 | -- and it is not worth worrying about ??? |
6877 | ||
6878 | Append_To (S, Rtn); | |
6879 | Set_Analyzed (Rtn); | |
6880 | ||
6881 | -- Call _Postconditions procedure if appropriate. We need to | |
6882 | -- do this explicitly because we did not analyze the generated | |
6883 | -- return statement above, so the call did not get inserted. | |
6884 | ||
6885 | if Ekind (Spec_Id) = E_Procedure | |
6886 | and then Has_Postconditions (Spec_Id) | |
6887 | then | |
6888 | pragma Assert (Present (Postcondition_Proc (Spec_Id))); | |
6889 | Insert_Action (Rtn, | |
6890 | Make_Procedure_Call_Statement (Loc, | |
6891 | Name => | |
6892 | New_Reference_To (Postcondition_Proc (Spec_Id), Loc))); | |
6893 | end if; | |
6894 | end; | |
12e0c41c | 6895 | end if; |
7888a6ae | 6896 | end Add_Return; |
12e0c41c | 6897 | |
70482933 RK |
6898 | -- Start of processing for Expand_N_Subprogram_Body |
6899 | ||
6900 | begin | |
4a3b249c RD |
6901 | -- Set L to either the list of declarations if present, or to the list |
6902 | -- of statements if no declarations are present. This is used to insert | |
6903 | -- new stuff at the start. | |
70482933 RK |
6904 | |
6905 | if Is_Non_Empty_List (Declarations (N)) then | |
6906 | L := Declarations (N); | |
6907 | else | |
7888a6ae GD |
6908 | L := Statements (H); |
6909 | end if; | |
6910 | ||
6911 | -- If local-exception-to-goto optimization active, insert dummy push | |
1adaea16 AC |
6912 | -- statements at start, and dummy pop statements at end, but inhibit |
6913 | -- this if we have No_Exception_Handlers, since they are useless and | |
6914 | -- intefere with analysis, e.g. by codepeer. | |
7888a6ae GD |
6915 | |
6916 | if (Debug_Flag_Dot_G | |
6917 | or else Restriction_Active (No_Exception_Propagation)) | |
1adaea16 AC |
6918 | and then not Restriction_Active (No_Exception_Handlers) |
6919 | and then not CodePeer_Mode | |
7888a6ae GD |
6920 | and then Is_Non_Empty_List (L) |
6921 | then | |
6922 | declare | |
6923 | FS : constant Node_Id := First (L); | |
6924 | FL : constant Source_Ptr := Sloc (FS); | |
6925 | LS : Node_Id; | |
6926 | LL : Source_Ptr; | |
6927 | ||
6928 | begin | |
6929 | -- LS points to either last statement, if statements are present | |
6930 | -- or to the last declaration if there are no statements present. | |
6931 | -- It is the node after which the pop's are generated. | |
6932 | ||
6933 | if Is_Non_Empty_List (Statements (H)) then | |
6934 | LS := Last (Statements (H)); | |
6935 | else | |
6936 | LS := Last (L); | |
6937 | end if; | |
6938 | ||
6939 | LL := Sloc (LS); | |
6940 | ||
6941 | Insert_List_Before_And_Analyze (FS, New_List ( | |
6942 | Make_Push_Constraint_Error_Label (FL), | |
6943 | Make_Push_Program_Error_Label (FL), | |
6944 | Make_Push_Storage_Error_Label (FL))); | |
6945 | ||
6946 | Insert_List_After_And_Analyze (LS, New_List ( | |
6947 | Make_Pop_Constraint_Error_Label (LL), | |
6948 | Make_Pop_Program_Error_Label (LL), | |
6949 | Make_Pop_Storage_Error_Label (LL))); | |
6950 | end; | |
70482933 RK |
6951 | end if; |
6952 | ||
70482933 RK |
6953 | -- Find entity for subprogram |
6954 | ||
c9a4817d RD |
6955 | Body_Id := Defining_Entity (N); |
6956 | ||
70482933 RK |
6957 | if Present (Corresponding_Spec (N)) then |
6958 | Spec_Id := Corresponding_Spec (N); | |
6959 | else | |
c9a4817d RD |
6960 | Spec_Id := Body_Id; |
6961 | end if; | |
6962 | ||
7888a6ae GD |
6963 | -- Need poll on entry to subprogram if polling enabled. We only do this |
6964 | -- for non-empty subprograms, since it does not seem necessary to poll | |
4a3b249c | 6965 | -- for a dummy null subprogram. |
c885d7a1 AC |
6966 | |
6967 | if Is_Non_Empty_List (L) then | |
4a3b249c RD |
6968 | |
6969 | -- Do not add a polling call if the subprogram is to be inlined by | |
6970 | -- the back-end, to avoid repeated calls with multiple inlinings. | |
6971 | ||
c885d7a1 AC |
6972 | if Is_Inlined (Spec_Id) |
6973 | and then Front_End_Inlining | |
6974 | and then Optimization_Level > 1 | |
6975 | then | |
6976 | null; | |
6977 | else | |
6978 | Generate_Poll_Call (First (L)); | |
6979 | end if; | |
6980 | end if; | |
6981 | ||
4a3b249c RD |
6982 | -- If this is a Pure function which has any parameters whose root type |
6983 | -- is System.Address, reset the Pure indication, since it will likely | |
6984 | -- cause incorrect code to be generated as the parameter is probably | |
6985 | -- a pointer, and the fact that the same pointer is passed does not mean | |
6986 | -- that the same value is being referenced. | |
91b1417d AC |
6987 | |
6988 | -- Note that if the programmer gave an explicit Pure_Function pragma, | |
6989 | -- then we believe the programmer, and leave the subprogram Pure. | |
6990 | ||
4a3b249c RD |
6991 | -- This code should probably be at the freeze point, so that it happens |
6992 | -- even on a -gnatc (or more importantly -gnatt) compile, so that the | |
6993 | -- semantic tree has Is_Pure set properly ??? | |
c9a4817d RD |
6994 | |
6995 | if Is_Pure (Spec_Id) | |
6996 | and then Is_Subprogram (Spec_Id) | |
6997 | and then not Has_Pragma_Pure_Function (Spec_Id) | |
6998 | then | |
6999 | declare | |
2f1b20a9 | 7000 | F : Entity_Id; |
c9a4817d RD |
7001 | |
7002 | begin | |
2f1b20a9 | 7003 | F := First_Formal (Spec_Id); |
c9a4817d | 7004 | while Present (F) loop |
e5dc610e | 7005 | if Is_Descendent_Of_Address (Etype (F)) |
199c6a10 AC |
7006 | |
7007 | -- Note that this test is being made in the body of the | |
7008 | -- subprogram, not the spec, so we are testing the full | |
7009 | -- type for being limited here, as required. | |
7010 | ||
e5dc610e AC |
7011 | or else Is_Limited_Type (Etype (F)) |
7012 | then | |
c9a4817d RD |
7013 | Set_Is_Pure (Spec_Id, False); |
7014 | ||
7015 | if Spec_Id /= Body_Id then | |
7016 | Set_Is_Pure (Body_Id, False); | |
7017 | end if; | |
7018 | ||
7019 | exit; | |
7020 | end if; | |
7021 | ||
7022 | Next_Formal (F); | |
7023 | end loop; | |
7024 | end; | |
70482933 RK |
7025 | end if; |
7026 | ||
7027 | -- Initialize any scalar OUT args if Initialize/Normalize_Scalars | |
7028 | ||
7029 | if Init_Or_Norm_Scalars and then Is_Subprogram (Spec_Id) then | |
7030 | declare | |
2f1b20a9 | 7031 | F : Entity_Id; |
05c064c1 | 7032 | A : Node_Id; |
70482933 RK |
7033 | |
7034 | begin | |
70482933 RK |
7035 | -- Loop through formals |
7036 | ||
2f1b20a9 | 7037 | F := First_Formal (Spec_Id); |
70482933 RK |
7038 | while Present (F) loop |
7039 | if Is_Scalar_Type (Etype (F)) | |
7040 | and then Ekind (F) = E_Out_Parameter | |
7041 | then | |
70f91180 RD |
7042 | Check_Restriction (No_Default_Initialization, F); |
7043 | ||
02822a92 RD |
7044 | -- Insert the initialization. We turn off validity checks |
7045 | -- for this assignment, since we do not want any check on | |
7046 | -- the initial value itself (which may well be invalid). | |
05c064c1 | 7047 | -- Predicate checks are disabled as well (RM 6.4.1 (13/3)) |
02822a92 | 7048 | |
05c064c1 | 7049 | A := Make_Assignment_Statement (Loc, |
02822a92 | 7050 | Name => New_Occurrence_Of (F, Loc), |
05c064c1 AC |
7051 | Expression => Get_Simple_Init_Val (Etype (F), N)); |
7052 | Set_Suppress_Assignment_Checks (A); | |
7053 | ||
7054 | Insert_Before_And_Analyze (First (L), | |
7055 | A, Suppress => Validity_Check); | |
70482933 RK |
7056 | end if; |
7057 | ||
7058 | Next_Formal (F); | |
7059 | end loop; | |
70482933 RK |
7060 | end; |
7061 | end if; | |
7062 | ||
7063 | -- Clear out statement list for stubbed procedure | |
7064 | ||
7065 | if Present (Corresponding_Spec (N)) then | |
7066 | Set_Elaboration_Flag (N, Spec_Id); | |
7067 | ||
7068 | if Convention (Spec_Id) = Convention_Stubbed | |
7069 | or else Is_Eliminated (Spec_Id) | |
7070 | then | |
7071 | Set_Declarations (N, Empty_List); | |
7072 | Set_Handled_Statement_Sequence (N, | |
7073 | Make_Handled_Sequence_Of_Statements (Loc, | |
2c1b72d7 | 7074 | Statements => New_List (Make_Null_Statement (Loc)))); |
70482933 RK |
7075 | return; |
7076 | end if; | |
7077 | end if; | |
7078 | ||
70f91180 RD |
7079 | -- Create a set of discriminals for the next protected subprogram body |
7080 | ||
7081 | if Is_List_Member (N) | |
7082 | and then Present (Parent (List_Containing (N))) | |
7083 | and then Nkind (Parent (List_Containing (N))) = N_Protected_Body | |
7084 | and then Present (Next_Protected_Operation (N)) | |
7085 | then | |
7086 | Set_Discriminals (Parent (Base_Type (Scope (Spec_Id)))); | |
7087 | end if; | |
7088 | ||
4a3b249c RD |
7089 | -- Returns_By_Ref flag is normally set when the subprogram is frozen but |
7090 | -- subprograms with no specs are not frozen. | |
70482933 RK |
7091 | |
7092 | declare | |
7093 | Typ : constant Entity_Id := Etype (Spec_Id); | |
7094 | Utyp : constant Entity_Id := Underlying_Type (Typ); | |
7095 | ||
7096 | begin | |
7097 | if not Acts_As_Spec (N) | |
7098 | and then Nkind (Parent (Parent (Spec_Id))) /= | |
7099 | N_Subprogram_Body_Stub | |
7100 | then | |
7101 | null; | |
7102 | ||
51245e2d | 7103 | elsif Is_Limited_View (Typ) then |
70482933 RK |
7104 | Set_Returns_By_Ref (Spec_Id); |
7105 | ||
048e5cef | 7106 | elsif Present (Utyp) and then CW_Or_Has_Controlled_Part (Utyp) then |
70482933 RK |
7107 | Set_Returns_By_Ref (Spec_Id); |
7108 | end if; | |
7109 | end; | |
7110 | ||
4a3b249c RD |
7111 | -- For a procedure, we add a return for all possible syntactic ends of |
7112 | -- the subprogram. | |
70482933 | 7113 | |
b29def53 | 7114 | if Ekind_In (Spec_Id, E_Procedure, E_Generic_Procedure) then |
70482933 RK |
7115 | Add_Return (Statements (H)); |
7116 | ||
7117 | if Present (Exception_Handlers (H)) then | |
7118 | Except_H := First_Non_Pragma (Exception_Handlers (H)); | |
70482933 RK |
7119 | while Present (Except_H) loop |
7120 | Add_Return (Statements (Except_H)); | |
7121 | Next_Non_Pragma (Except_H); | |
7122 | end loop; | |
7123 | end if; | |
7124 | ||
98f01d53 AC |
7125 | -- For a function, we must deal with the case where there is at least |
7126 | -- one missing return. What we do is to wrap the entire body of the | |
7127 | -- function in a block: | |
70482933 RK |
7128 | |
7129 | -- begin | |
7130 | -- ... | |
7131 | -- end; | |
7132 | ||
7133 | -- becomes | |
7134 | ||
7135 | -- begin | |
7136 | -- begin | |
7137 | -- ... | |
7138 | -- end; | |
7139 | ||
7140 | -- raise Program_Error; | |
7141 | -- end; | |
7142 | ||
4a3b249c RD |
7143 | -- This approach is necessary because the raise must be signalled to the |
7144 | -- caller, not handled by any local handler (RM 6.4(11)). | |
70482933 | 7145 | |
4a3b249c RD |
7146 | -- Note: we do not need to analyze the constructed sequence here, since |
7147 | -- it has no handler, and an attempt to analyze the handled statement | |
7148 | -- sequence twice is risky in various ways (e.g. the issue of expanding | |
7149 | -- cleanup actions twice). | |
70482933 RK |
7150 | |
7151 | elsif Has_Missing_Return (Spec_Id) then | |
7152 | declare | |
7153 | Hloc : constant Source_Ptr := Sloc (H); | |
7154 | Blok : constant Node_Id := | |
7155 | Make_Block_Statement (Hloc, | |
7156 | Handled_Statement_Sequence => H); | |
7157 | Rais : constant Node_Id := | |
07fc65c4 GB |
7158 | Make_Raise_Program_Error (Hloc, |
7159 | Reason => PE_Missing_Return); | |
70482933 RK |
7160 | |
7161 | begin | |
7162 | Set_Handled_Statement_Sequence (N, | |
7163 | Make_Handled_Sequence_Of_Statements (Hloc, | |
7164 | Statements => New_List (Blok, Rais))); | |
7165 | ||
7888a6ae | 7166 | Push_Scope (Spec_Id); |
70482933 RK |
7167 | Analyze (Blok); |
7168 | Analyze (Rais); | |
7169 | Pop_Scope; | |
7170 | end; | |
7171 | end if; | |
7172 | ||
70482933 RK |
7173 | -- If subprogram contains a parameterless recursive call, then we may |
7174 | -- have an infinite recursion, so see if we can generate code to check | |
7175 | -- for this possibility if storage checks are not suppressed. | |
7176 | ||
7177 | if Ekind (Spec_Id) = E_Procedure | |
7178 | and then Has_Recursive_Call (Spec_Id) | |
7179 | and then not Storage_Checks_Suppressed (Spec_Id) | |
7180 | then | |
7181 | Detect_Infinite_Recursion (N, Spec_Id); | |
7182 | end if; | |
7183 | ||
70482933 RK |
7184 | -- Set to encode entity names in package body before gigi is called |
7185 | ||
7186 | Qualify_Entity_Names (N); | |
7187 | end Expand_N_Subprogram_Body; | |
7188 | ||
7189 | ----------------------------------- | |
7190 | -- Expand_N_Subprogram_Body_Stub -- | |
7191 | ----------------------------------- | |
7192 | ||
7193 | procedure Expand_N_Subprogram_Body_Stub (N : Node_Id) is | |
7194 | begin | |
7195 | if Present (Corresponding_Body (N)) then | |
7196 | Expand_N_Subprogram_Body ( | |
7197 | Unit_Declaration_Node (Corresponding_Body (N))); | |
7198 | end if; | |
70482933 RK |
7199 | end Expand_N_Subprogram_Body_Stub; |
7200 | ||
7201 | ------------------------------------- | |
7202 | -- Expand_N_Subprogram_Declaration -- | |
7203 | ------------------------------------- | |
7204 | ||
70482933 RK |
7205 | -- If the declaration appears within a protected body, it is a private |
7206 | -- operation of the protected type. We must create the corresponding | |
7207 | -- protected subprogram an associated formals. For a normal protected | |
7208 | -- operation, this is done when expanding the protected type declaration. | |
7209 | ||
758c442c GD |
7210 | -- If the declaration is for a null procedure, emit null body |
7211 | ||
70482933 | 7212 | procedure Expand_N_Subprogram_Declaration (N : Node_Id) is |
fbf5a39b AC |
7213 | Loc : constant Source_Ptr := Sloc (N); |
7214 | Subp : constant Entity_Id := Defining_Entity (N); | |
7215 | Scop : constant Entity_Id := Scope (Subp); | |
7216 | Prot_Decl : Node_Id; | |
7217 | Prot_Bod : Node_Id; | |
7218 | Prot_Id : Entity_Id; | |
70482933 RK |
7219 | |
7220 | begin | |
2ba431e5 YM |
7221 | -- In SPARK, subprogram declarations are only allowed in package |
7222 | -- specifications. | |
7ff2d234 | 7223 | |
fe5d3068 YM |
7224 | if Nkind (Parent (N)) /= N_Package_Specification then |
7225 | if Nkind (Parent (N)) = N_Compilation_Unit then | |
2ba431e5 | 7226 | Check_SPARK_Restriction |
fe5d3068 YM |
7227 | ("subprogram declaration is not a library item", N); |
7228 | ||
7229 | elsif Present (Next (N)) | |
7ff2d234 AC |
7230 | and then Nkind (Next (N)) = N_Pragma |
7231 | and then Get_Pragma_Id (Pragma_Name (Next (N))) = Pragma_Import | |
7232 | then | |
2ba431e5 | 7233 | -- In SPARK, subprogram declarations are also permitted in |
7ff2d234 AC |
7234 | -- declarative parts when immediately followed by a corresponding |
7235 | -- pragma Import. We only check here that there is some pragma | |
7236 | -- Import. | |
7237 | ||
7238 | null; | |
7239 | else | |
2ba431e5 | 7240 | Check_SPARK_Restriction |
fe5d3068 | 7241 | ("subprogram declaration is not allowed here", N); |
7ff2d234 AC |
7242 | end if; |
7243 | end if; | |
7244 | ||
2f1b20a9 ES |
7245 | -- Deal with case of protected subprogram. Do not generate protected |
7246 | -- operation if operation is flagged as eliminated. | |
70482933 RK |
7247 | |
7248 | if Is_List_Member (N) | |
7249 | and then Present (Parent (List_Containing (N))) | |
7250 | and then Nkind (Parent (List_Containing (N))) = N_Protected_Body | |
7251 | and then Is_Protected_Type (Scop) | |
7252 | then | |
6871ba5f AC |
7253 | if No (Protected_Body_Subprogram (Subp)) |
7254 | and then not Is_Eliminated (Subp) | |
7255 | then | |
fbf5a39b | 7256 | Prot_Decl := |
70482933 RK |
7257 | Make_Subprogram_Declaration (Loc, |
7258 | Specification => | |
7259 | Build_Protected_Sub_Specification | |
2f1b20a9 | 7260 | (N, Scop, Unprotected_Mode)); |
70482933 RK |
7261 | |
7262 | -- The protected subprogram is declared outside of the protected | |
7263 | -- body. Given that the body has frozen all entities so far, we | |
fbf5a39b | 7264 | -- analyze the subprogram and perform freezing actions explicitly. |
19590d70 GD |
7265 | -- including the generation of an explicit freeze node, to ensure |
7266 | -- that gigi has the proper order of elaboration. | |
fbf5a39b AC |
7267 | -- If the body is a subunit, the insertion point is before the |
7268 | -- stub in the parent. | |
70482933 RK |
7269 | |
7270 | Prot_Bod := Parent (List_Containing (N)); | |
7271 | ||
7272 | if Nkind (Parent (Prot_Bod)) = N_Subunit then | |
7273 | Prot_Bod := Corresponding_Stub (Parent (Prot_Bod)); | |
7274 | end if; | |
7275 | ||
fbf5a39b AC |
7276 | Insert_Before (Prot_Bod, Prot_Decl); |
7277 | Prot_Id := Defining_Unit_Name (Specification (Prot_Decl)); | |
19590d70 | 7278 | Set_Has_Delayed_Freeze (Prot_Id); |
70482933 | 7279 | |
7888a6ae | 7280 | Push_Scope (Scope (Scop)); |
fbf5a39b | 7281 | Analyze (Prot_Decl); |
6b958cec | 7282 | Freeze_Before (N, Prot_Id); |
fbf5a39b | 7283 | Set_Protected_Body_Subprogram (Subp, Prot_Id); |
47bfea3a AC |
7284 | |
7285 | -- Create protected operation as well. Even though the operation | |
7286 | -- is only accessible within the body, it is possible to make it | |
7287 | -- available outside of the protected object by using 'Access to | |
3d923671 | 7288 | -- provide a callback, so build protected version in all cases. |
47bfea3a AC |
7289 | |
7290 | Prot_Decl := | |
3d923671 AC |
7291 | Make_Subprogram_Declaration (Loc, |
7292 | Specification => | |
7293 | Build_Protected_Sub_Specification (N, Scop, Protected_Mode)); | |
47bfea3a AC |
7294 | Insert_Before (Prot_Bod, Prot_Decl); |
7295 | Analyze (Prot_Decl); | |
7296 | ||
70482933 RK |
7297 | Pop_Scope; |
7298 | end if; | |
758c442c | 7299 | |
54bf19e4 AC |
7300 | -- Ada 2005 (AI-348): Generate body for a null procedure. In most |
7301 | -- cases this is superfluous because calls to it will be automatically | |
7302 | -- inlined, but we definitely need the body if preconditions for the | |
7303 | -- procedure are present. | |
02822a92 | 7304 | |
758c442c GD |
7305 | elsif Nkind (Specification (N)) = N_Procedure_Specification |
7306 | and then Null_Present (Specification (N)) | |
7307 | then | |
7308 | declare | |
e1f3cb58 | 7309 | Bod : constant Node_Id := Body_To_Inline (N); |
d6533e74 | 7310 | |
758c442c | 7311 | begin |
e1f3cb58 AC |
7312 | Set_Has_Completion (Subp, False); |
7313 | Append_Freeze_Action (Subp, Bod); | |
c73ae90f | 7314 | |
e1f3cb58 AC |
7315 | -- The body now contains raise statements, so calls to it will |
7316 | -- not be inlined. | |
c73ae90f | 7317 | |
e1f3cb58 | 7318 | Set_Is_Inlined (Subp, False); |
758c442c | 7319 | end; |
70482933 RK |
7320 | end if; |
7321 | end Expand_N_Subprogram_Declaration; | |
7322 | ||
2b3d67a5 AC |
7323 | -------------------------------- |
7324 | -- Expand_Non_Function_Return -- | |
7325 | -------------------------------- | |
7326 | ||
7327 | procedure Expand_Non_Function_Return (N : Node_Id) is | |
7328 | pragma Assert (No (Expression (N))); | |
7329 | ||
7330 | Loc : constant Source_Ptr := Sloc (N); | |
7331 | Scope_Id : Entity_Id := | |
7332 | Return_Applies_To (Return_Statement_Entity (N)); | |
7333 | Kind : constant Entity_Kind := Ekind (Scope_Id); | |
7334 | Call : Node_Id; | |
7335 | Acc_Stat : Node_Id; | |
7336 | Goto_Stat : Node_Id; | |
7337 | Lab_Node : Node_Id; | |
7338 | ||
7339 | begin | |
7340 | -- Call _Postconditions procedure if procedure with active | |
54bf19e4 AC |
7341 | -- postconditions. Here, we use the Postcondition_Proc attribute, |
7342 | -- which is needed for implicitly-generated returns. Functions | |
7343 | -- never have implicitly-generated returns, and there's no | |
7344 | -- room for Postcondition_Proc in E_Function, so we look up the | |
7345 | -- identifier Name_uPostconditions for function returns (see | |
2b3d67a5 AC |
7346 | -- Expand_Simple_Function_Return). |
7347 | ||
7348 | if Ekind (Scope_Id) = E_Procedure | |
7349 | and then Has_Postconditions (Scope_Id) | |
7350 | then | |
7351 | pragma Assert (Present (Postcondition_Proc (Scope_Id))); | |
7352 | Insert_Action (N, | |
7353 | Make_Procedure_Call_Statement (Loc, | |
7354 | Name => New_Reference_To (Postcondition_Proc (Scope_Id), Loc))); | |
7355 | end if; | |
7356 | ||
7357 | -- If it is a return from a procedure do no extra steps | |
7358 | ||
7359 | if Kind = E_Procedure or else Kind = E_Generic_Procedure then | |
7360 | return; | |
7361 | ||
7362 | -- If it is a nested return within an extended one, replace it with a | |
7363 | -- return of the previously declared return object. | |
7364 | ||
7365 | elsif Kind = E_Return_Statement then | |
7366 | Rewrite (N, | |
7367 | Make_Simple_Return_Statement (Loc, | |
7368 | Expression => | |
7369 | New_Occurrence_Of (First_Entity (Scope_Id), Loc))); | |
7370 | Set_Comes_From_Extended_Return_Statement (N); | |
7371 | Set_Return_Statement_Entity (N, Scope_Id); | |
7372 | Expand_Simple_Function_Return (N); | |
7373 | return; | |
7374 | end if; | |
7375 | ||
7376 | pragma Assert (Is_Entry (Scope_Id)); | |
7377 | ||
7378 | -- Look at the enclosing block to see whether the return is from an | |
7379 | -- accept statement or an entry body. | |
7380 | ||
7381 | for J in reverse 0 .. Scope_Stack.Last loop | |
7382 | Scope_Id := Scope_Stack.Table (J).Entity; | |
7383 | exit when Is_Concurrent_Type (Scope_Id); | |
7384 | end loop; | |
7385 | ||
7386 | -- If it is a return from accept statement it is expanded as call to | |
7387 | -- RTS Complete_Rendezvous and a goto to the end of the accept body. | |
7388 | ||
7389 | -- (cf : Expand_N_Accept_Statement, Expand_N_Selective_Accept, | |
7390 | -- Expand_N_Accept_Alternative in exp_ch9.adb) | |
7391 | ||
7392 | if Is_Task_Type (Scope_Id) then | |
7393 | ||
7394 | Call := | |
7395 | Make_Procedure_Call_Statement (Loc, | |
7396 | Name => New_Reference_To (RTE (RE_Complete_Rendezvous), Loc)); | |
7397 | Insert_Before (N, Call); | |
7398 | -- why not insert actions here??? | |
7399 | Analyze (Call); | |
7400 | ||
7401 | Acc_Stat := Parent (N); | |
7402 | while Nkind (Acc_Stat) /= N_Accept_Statement loop | |
7403 | Acc_Stat := Parent (Acc_Stat); | |
7404 | end loop; | |
7405 | ||
7406 | Lab_Node := Last (Statements | |
7407 | (Handled_Statement_Sequence (Acc_Stat))); | |
7408 | ||
7409 | Goto_Stat := Make_Goto_Statement (Loc, | |
7410 | Name => New_Occurrence_Of | |
7411 | (Entity (Identifier (Lab_Node)), Loc)); | |
7412 | ||
7413 | Set_Analyzed (Goto_Stat); | |
7414 | ||
7415 | Rewrite (N, Goto_Stat); | |
7416 | Analyze (N); | |
7417 | ||
7418 | -- If it is a return from an entry body, put a Complete_Entry_Body call | |
7419 | -- in front of the return. | |
7420 | ||
7421 | elsif Is_Protected_Type (Scope_Id) then | |
7422 | Call := | |
7423 | Make_Procedure_Call_Statement (Loc, | |
7424 | Name => | |
7425 | New_Reference_To (RTE (RE_Complete_Entry_Body), Loc), | |
7426 | Parameter_Associations => New_List ( | |
7427 | Make_Attribute_Reference (Loc, | |
2c1b72d7 | 7428 | Prefix => |
2b3d67a5 AC |
7429 | New_Reference_To |
7430 | (Find_Protection_Object (Current_Scope), Loc), | |
2c1b72d7 | 7431 | Attribute_Name => Name_Unchecked_Access))); |
2b3d67a5 AC |
7432 | |
7433 | Insert_Before (N, Call); | |
7434 | Analyze (Call); | |
7435 | end if; | |
7436 | end Expand_Non_Function_Return; | |
7437 | ||
70482933 RK |
7438 | --------------------------------------- |
7439 | -- Expand_Protected_Object_Reference -- | |
7440 | --------------------------------------- | |
7441 | ||
7442 | function Expand_Protected_Object_Reference | |
7443 | (N : Node_Id; | |
02822a92 | 7444 | Scop : Entity_Id) return Node_Id |
70482933 RK |
7445 | is |
7446 | Loc : constant Source_Ptr := Sloc (N); | |
7447 | Corr : Entity_Id; | |
7448 | Rec : Node_Id; | |
7449 | Param : Entity_Id; | |
7450 | Proc : Entity_Id; | |
7451 | ||
7452 | begin | |
7675ad4f | 7453 | Rec := Make_Identifier (Loc, Name_uObject); |
70482933 RK |
7454 | Set_Etype (Rec, Corresponding_Record_Type (Scop)); |
7455 | ||
2f1b20a9 ES |
7456 | -- Find enclosing protected operation, and retrieve its first parameter, |
7457 | -- which denotes the enclosing protected object. If the enclosing | |
7458 | -- operation is an entry, we are immediately within the protected body, | |
7459 | -- and we can retrieve the object from the service entries procedure. A | |
16b05213 | 7460 | -- barrier function has the same signature as an entry. A barrier |
2f1b20a9 ES |
7461 | -- function is compiled within the protected object, but unlike |
7462 | -- protected operations its never needs locks, so that its protected | |
7463 | -- body subprogram points to itself. | |
70482933 RK |
7464 | |
7465 | Proc := Current_Scope; | |
70482933 RK |
7466 | while Present (Proc) |
7467 | and then Scope (Proc) /= Scop | |
7468 | loop | |
7469 | Proc := Scope (Proc); | |
7470 | end loop; | |
7471 | ||
7472 | Corr := Protected_Body_Subprogram (Proc); | |
7473 | ||
7474 | if No (Corr) then | |
7475 | ||
7476 | -- Previous error left expansion incomplete. | |
7477 | -- Nothing to do on this call. | |
7478 | ||
7479 | return Empty; | |
7480 | end if; | |
7481 | ||
7482 | Param := | |
7483 | Defining_Identifier | |
7484 | (First (Parameter_Specifications (Parent (Corr)))); | |
7485 | ||
7486 | if Is_Subprogram (Proc) | |
7487 | and then Proc /= Corr | |
7488 | then | |
98f01d53 | 7489 | -- Protected function or procedure |
70482933 RK |
7490 | |
7491 | Set_Entity (Rec, Param); | |
7492 | ||
2f1b20a9 ES |
7493 | -- Rec is a reference to an entity which will not be in scope when |
7494 | -- the call is reanalyzed, and needs no further analysis. | |
70482933 RK |
7495 | |
7496 | Set_Analyzed (Rec); | |
7497 | ||
7498 | else | |
2f1b20a9 ES |
7499 | -- Entry or barrier function for entry body. The first parameter of |
7500 | -- the entry body procedure is pointer to the object. We create a | |
7501 | -- local variable of the proper type, duplicating what is done to | |
7502 | -- define _object later on. | |
70482933 RK |
7503 | |
7504 | declare | |
c12beea0 RD |
7505 | Decls : List_Id; |
7506 | Obj_Ptr : constant Entity_Id := Make_Temporary (Loc, 'T'); | |
fbf5a39b | 7507 | |
70482933 RK |
7508 | begin |
7509 | Decls := New_List ( | |
7510 | Make_Full_Type_Declaration (Loc, | |
7511 | Defining_Identifier => Obj_Ptr, | |
2c1b72d7 | 7512 | Type_Definition => |
70482933 RK |
7513 | Make_Access_To_Object_Definition (Loc, |
7514 | Subtype_Indication => | |
7515 | New_Reference_To | |
c12beea0 | 7516 | (Corresponding_Record_Type (Scop), Loc)))); |
70482933 RK |
7517 | |
7518 | Insert_Actions (N, Decls); | |
6b958cec | 7519 | Freeze_Before (N, Obj_Ptr); |
70482933 RK |
7520 | |
7521 | Rec := | |
7522 | Make_Explicit_Dereference (Loc, | |
2c1b72d7 AC |
7523 | Prefix => |
7524 | Unchecked_Convert_To (Obj_Ptr, | |
7525 | New_Occurrence_Of (Param, Loc))); | |
70482933 | 7526 | |
2f1b20a9 | 7527 | -- Analyze new actual. Other actuals in calls are already analyzed |
7888a6ae | 7528 | -- and the list of actuals is not reanalyzed after rewriting. |
70482933 RK |
7529 | |
7530 | Set_Parent (Rec, N); | |
7531 | Analyze (Rec); | |
7532 | end; | |
7533 | end if; | |
7534 | ||
7535 | return Rec; | |
7536 | end Expand_Protected_Object_Reference; | |
7537 | ||
7538 | -------------------------------------- | |
7539 | -- Expand_Protected_Subprogram_Call -- | |
7540 | -------------------------------------- | |
7541 | ||
7542 | procedure Expand_Protected_Subprogram_Call | |
7543 | (N : Node_Id; | |
7544 | Subp : Entity_Id; | |
7545 | Scop : Entity_Id) | |
7546 | is | |
7547 | Rec : Node_Id; | |
7548 | ||
7549 | begin | |
54bf19e4 AC |
7550 | -- If the protected object is not an enclosing scope, this is an inter- |
7551 | -- object function call. Inter-object procedure calls are expanded by | |
7552 | -- Exp_Ch9.Build_Simple_Entry_Call. The call is intra-object only if the | |
7553 | -- subprogram being called is in the protected body being compiled, and | |
7554 | -- if the protected object in the call is statically the enclosing type. | |
7555 | -- The object may be an component of some other data structure, in which | |
7556 | -- case this must be handled as an inter-object call. | |
70482933 RK |
7557 | |
7558 | if not In_Open_Scopes (Scop) | |
7559 | or else not Is_Entity_Name (Name (N)) | |
7560 | then | |
7561 | if Nkind (Name (N)) = N_Selected_Component then | |
7562 | Rec := Prefix (Name (N)); | |
7563 | ||
7564 | else | |
7565 | pragma Assert (Nkind (Name (N)) = N_Indexed_Component); | |
7566 | Rec := Prefix (Prefix (Name (N))); | |
7567 | end if; | |
7568 | ||
7569 | Build_Protected_Subprogram_Call (N, | |
2c1b72d7 | 7570 | Name => New_Occurrence_Of (Subp, Sloc (N)), |
2ba1a7c7 | 7571 | Rec => Convert_Concurrent (Rec, Etype (Rec)), |
70482933 RK |
7572 | External => True); |
7573 | ||
7574 | else | |
7575 | Rec := Expand_Protected_Object_Reference (N, Scop); | |
7576 | ||
7577 | if No (Rec) then | |
7578 | return; | |
7579 | end if; | |
7580 | ||
7581 | Build_Protected_Subprogram_Call (N, | |
7582 | Name => Name (N), | |
7583 | Rec => Rec, | |
7584 | External => False); | |
7585 | ||
7586 | end if; | |
7587 | ||
70482933 RK |
7588 | -- If it is a function call it can appear in elaboration code and |
7589 | -- the called entity must be frozen here. | |
7590 | ||
7591 | if Ekind (Subp) = E_Function then | |
7592 | Freeze_Expression (Name (N)); | |
7593 | end if; | |
811c6a85 AC |
7594 | |
7595 | -- Analyze and resolve the new call. The actuals have already been | |
b0159fbe | 7596 | -- resolved, but expansion of a function call will add extra actuals |
811c6a85 AC |
7597 | -- if needed. Analysis of a procedure call already includes resolution. |
7598 | ||
7599 | Analyze (N); | |
7600 | ||
7601 | if Ekind (Subp) = E_Function then | |
7602 | Resolve (N, Etype (Subp)); | |
7603 | end if; | |
70482933 RK |
7604 | end Expand_Protected_Subprogram_Call; |
7605 | ||
63585f75 SB |
7606 | -------------------------------------------- |
7607 | -- Has_Unconstrained_Access_Discriminants -- | |
7608 | -------------------------------------------- | |
7609 | ||
7610 | function Has_Unconstrained_Access_Discriminants | |
7611 | (Subtyp : Entity_Id) return Boolean | |
7612 | is | |
7613 | Discr : Entity_Id; | |
7614 | ||
7615 | begin | |
7616 | if Has_Discriminants (Subtyp) | |
7617 | and then not Is_Constrained (Subtyp) | |
7618 | then | |
7619 | Discr := First_Discriminant (Subtyp); | |
7620 | while Present (Discr) loop | |
7621 | if Ekind (Etype (Discr)) = E_Anonymous_Access_Type then | |
7622 | return True; | |
7623 | end if; | |
7624 | ||
7625 | Next_Discriminant (Discr); | |
7626 | end loop; | |
7627 | end if; | |
ebf494ec | 7628 | |
63585f75 SB |
7629 | return False; |
7630 | end Has_Unconstrained_Access_Discriminants; | |
7631 | ||
2b3d67a5 AC |
7632 | ----------------------------------- |
7633 | -- Expand_Simple_Function_Return -- | |
7634 | ----------------------------------- | |
7635 | ||
54bf19e4 | 7636 | -- The "simple" comes from the syntax rule simple_return_statement. The |
a90bd866 | 7637 | -- semantics are not at all simple. |
2b3d67a5 AC |
7638 | |
7639 | procedure Expand_Simple_Function_Return (N : Node_Id) is | |
7640 | Loc : constant Source_Ptr := Sloc (N); | |
7641 | ||
7642 | Scope_Id : constant Entity_Id := | |
7643 | Return_Applies_To (Return_Statement_Entity (N)); | |
7644 | -- The function we are returning from | |
7645 | ||
7646 | R_Type : constant Entity_Id := Etype (Scope_Id); | |
7647 | -- The result type of the function | |
7648 | ||
7649 | Utyp : constant Entity_Id := Underlying_Type (R_Type); | |
7650 | ||
7651 | Exp : constant Node_Id := Expression (N); | |
7652 | pragma Assert (Present (Exp)); | |
7653 | ||
7654 | Exptyp : constant Entity_Id := Etype (Exp); | |
7655 | -- The type of the expression (not necessarily the same as R_Type) | |
7656 | ||
7657 | Subtype_Ind : Node_Id; | |
54bf19e4 AC |
7658 | -- If the result type of the function is class-wide and the expression |
7659 | -- has a specific type, then we use the expression's type as the type of | |
7660 | -- the return object. In cases where the expression is an aggregate that | |
7661 | -- is built in place, this avoids the need for an expensive conversion | |
7662 | -- of the return object to the specific type on assignments to the | |
7663 | -- individual components. | |
2b3d67a5 AC |
7664 | |
7665 | begin | |
7666 | if Is_Class_Wide_Type (R_Type) | |
7667 | and then not Is_Class_Wide_Type (Etype (Exp)) | |
7668 | then | |
7669 | Subtype_Ind := New_Occurrence_Of (Etype (Exp), Loc); | |
7670 | else | |
7671 | Subtype_Ind := New_Occurrence_Of (R_Type, Loc); | |
7672 | end if; | |
7673 | ||
7674 | -- For the case of a simple return that does not come from an extended | |
7675 | -- return, in the case of Ada 2005 where we are returning a limited | |
7676 | -- type, we rewrite "return <expression>;" to be: | |
7677 | ||
7678 | -- return _anon_ : <return_subtype> := <expression> | |
7679 | ||
7680 | -- The expansion produced by Expand_N_Extended_Return_Statement will | |
7681 | -- contain simple return statements (for example, a block containing | |
7682 | -- simple return of the return object), which brings us back here with | |
7683 | -- Comes_From_Extended_Return_Statement set. The reason for the barrier | |
7684 | -- checking for a simple return that does not come from an extended | |
7685 | -- return is to avoid this infinite recursion. | |
7686 | ||
7687 | -- The reason for this design is that for Ada 2005 limited returns, we | |
7688 | -- need to reify the return object, so we can build it "in place", and | |
7689 | -- we need a block statement to hang finalization and tasking stuff. | |
7690 | ||
7691 | -- ??? In order to avoid disruption, we avoid translating to extended | |
7692 | -- return except in the cases where we really need to (Ada 2005 for | |
7693 | -- inherently limited). We might prefer to do this translation in all | |
7694 | -- cases (except perhaps for the case of Ada 95 inherently limited), | |
7695 | -- in order to fully exercise the Expand_N_Extended_Return_Statement | |
7696 | -- code. This would also allow us to do the build-in-place optimization | |
7697 | -- for efficiency even in cases where it is semantically not required. | |
7698 | ||
7699 | -- As before, we check the type of the return expression rather than the | |
7700 | -- return type of the function, because the latter may be a limited | |
7701 | -- class-wide interface type, which is not a limited type, even though | |
7702 | -- the type of the expression may be. | |
7703 | ||
7704 | if not Comes_From_Extended_Return_Statement (N) | |
51245e2d | 7705 | and then Is_Limited_View (Etype (Expression (N))) |
0791fbe9 | 7706 | and then Ada_Version >= Ada_2005 |
2b3d67a5 | 7707 | and then not Debug_Flag_Dot_L |
f6f4d8d4 JM |
7708 | |
7709 | -- The functionality of interface thunks is simple and it is always | |
7710 | -- handled by means of simple return statements. This leaves their | |
7711 | -- expansion simple and clean. | |
7712 | ||
da1c23dd | 7713 | and then not Is_Thunk (Current_Scope) |
2b3d67a5 AC |
7714 | then |
7715 | declare | |
7716 | Return_Object_Entity : constant Entity_Id := | |
7717 | Make_Temporary (Loc, 'R', Exp); | |
f6f4d8d4 | 7718 | |
2b3d67a5 AC |
7719 | Obj_Decl : constant Node_Id := |
7720 | Make_Object_Declaration (Loc, | |
7721 | Defining_Identifier => Return_Object_Entity, | |
7722 | Object_Definition => Subtype_Ind, | |
7723 | Expression => Exp); | |
7724 | ||
f6f4d8d4 JM |
7725 | Ext : constant Node_Id := |
7726 | Make_Extended_Return_Statement (Loc, | |
7727 | Return_Object_Declarations => New_List (Obj_Decl)); | |
2b3d67a5 AC |
7728 | -- Do not perform this high-level optimization if the result type |
7729 | -- is an interface because the "this" pointer must be displaced. | |
7730 | ||
7731 | begin | |
7732 | Rewrite (N, Ext); | |
7733 | Analyze (N); | |
7734 | return; | |
7735 | end; | |
7736 | end if; | |
7737 | ||
7738 | -- Here we have a simple return statement that is part of the expansion | |
7739 | -- of an extended return statement (either written by the user, or | |
7740 | -- generated by the above code). | |
7741 | ||
7742 | -- Always normalize C/Fortran boolean result. This is not always needed, | |
7743 | -- but it seems a good idea to minimize the passing around of non- | |
7744 | -- normalized values, and in any case this handles the processing of | |
7745 | -- barrier functions for protected types, which turn the condition into | |
7746 | -- a return statement. | |
7747 | ||
7748 | if Is_Boolean_Type (Exptyp) | |
7749 | and then Nonzero_Is_True (Exptyp) | |
7750 | then | |
7751 | Adjust_Condition (Exp); | |
7752 | Adjust_Result_Type (Exp, Exptyp); | |
7753 | end if; | |
7754 | ||
7755 | -- Do validity check if enabled for returns | |
7756 | ||
7757 | if Validity_Checks_On | |
7758 | and then Validity_Check_Returns | |
7759 | then | |
7760 | Ensure_Valid (Exp); | |
7761 | end if; | |
7762 | ||
7763 | -- Check the result expression of a scalar function against the subtype | |
7764 | -- of the function by inserting a conversion. This conversion must | |
7765 | -- eventually be performed for other classes of types, but for now it's | |
7766 | -- only done for scalars. | |
7767 | -- ??? | |
7768 | ||
7769 | if Is_Scalar_Type (Exptyp) then | |
7770 | Rewrite (Exp, Convert_To (R_Type, Exp)); | |
7771 | ||
7772 | -- The expression is resolved to ensure that the conversion gets | |
7773 | -- expanded to generate a possible constraint check. | |
7774 | ||
7775 | Analyze_And_Resolve (Exp, R_Type); | |
7776 | end if; | |
7777 | ||
7778 | -- Deal with returning variable length objects and controlled types | |
7779 | ||
7780 | -- Nothing to do if we are returning by reference, or this is not a | |
7781 | -- type that requires special processing (indicated by the fact that | |
7782 | -- it requires a cleanup scope for the secondary stack case). | |
7783 | ||
51245e2d | 7784 | if Is_Limited_View (Exptyp) |
2b3d67a5 AC |
7785 | or else Is_Limited_Interface (Exptyp) |
7786 | then | |
7787 | null; | |
7788 | ||
f6f4d8d4 JM |
7789 | -- No copy needed for thunks returning interface type objects since |
7790 | -- the object is returned by reference and the maximum functionality | |
7791 | -- required is just to displace the pointer. | |
7792 | ||
4b342b91 | 7793 | elsif Is_Thunk (Current_Scope) and then Is_Interface (Exptyp) then |
f6f4d8d4 JM |
7794 | null; |
7795 | ||
2b3d67a5 AC |
7796 | elsif not Requires_Transient_Scope (R_Type) then |
7797 | ||
7798 | -- Mutable records with no variable length components are not | |
7799 | -- returned on the sec-stack, so we need to make sure that the | |
7800 | -- backend will only copy back the size of the actual value, and not | |
7801 | -- the maximum size. We create an actual subtype for this purpose. | |
7802 | ||
7803 | declare | |
7804 | Ubt : constant Entity_Id := Underlying_Type (Base_Type (Exptyp)); | |
7805 | Decl : Node_Id; | |
7806 | Ent : Entity_Id; | |
7807 | begin | |
7808 | if Has_Discriminants (Ubt) | |
7809 | and then not Is_Constrained (Ubt) | |
7810 | and then not Has_Unchecked_Union (Ubt) | |
7811 | then | |
7812 | Decl := Build_Actual_Subtype (Ubt, Exp); | |
7813 | Ent := Defining_Identifier (Decl); | |
7814 | Insert_Action (Exp, Decl); | |
7815 | Rewrite (Exp, Unchecked_Convert_To (Ent, Exp)); | |
7816 | Analyze_And_Resolve (Exp); | |
7817 | end if; | |
7818 | end; | |
7819 | ||
7820 | -- Here if secondary stack is used | |
7821 | ||
7822 | else | |
7823 | -- Make sure that no surrounding block will reclaim the secondary | |
7824 | -- stack on which we are going to put the result. Not only may this | |
7825 | -- introduce secondary stack leaks but worse, if the reclamation is | |
7826 | -- done too early, then the result we are returning may get | |
7827 | -- clobbered. | |
7828 | ||
7829 | declare | |
7830 | S : Entity_Id; | |
7831 | begin | |
7832 | S := Current_Scope; | |
7833 | while Ekind (S) = E_Block or else Ekind (S) = E_Loop loop | |
7834 | Set_Sec_Stack_Needed_For_Return (S, True); | |
7835 | S := Enclosing_Dynamic_Scope (S); | |
7836 | end loop; | |
7837 | end; | |
7838 | ||
7839 | -- Optimize the case where the result is a function call. In this | |
7840 | -- case either the result is already on the secondary stack, or is | |
7841 | -- already being returned with the stack pointer depressed and no | |
54bf19e4 AC |
7842 | -- further processing is required except to set the By_Ref flag |
7843 | -- to ensure that gigi does not attempt an extra unnecessary copy. | |
2b3d67a5 AC |
7844 | -- (actually not just unnecessary but harmfully wrong in the case |
7845 | -- of a controlled type, where gigi does not know how to do a copy). | |
54bf19e4 AC |
7846 | -- To make up for a gcc 2.8.1 deficiency (???), we perform the copy |
7847 | -- for array types if the constrained status of the target type is | |
7848 | -- different from that of the expression. | |
2b3d67a5 AC |
7849 | |
7850 | if Requires_Transient_Scope (Exptyp) | |
7851 | and then | |
7852 | (not Is_Array_Type (Exptyp) | |
7853 | or else Is_Constrained (Exptyp) = Is_Constrained (R_Type) | |
7854 | or else CW_Or_Has_Controlled_Part (Utyp)) | |
7855 | and then Nkind (Exp) = N_Function_Call | |
7856 | then | |
7857 | Set_By_Ref (N); | |
7858 | ||
7859 | -- Remove side effects from the expression now so that other parts | |
7860 | -- of the expander do not have to reanalyze this node without this | |
7861 | -- optimization | |
7862 | ||
7863 | Rewrite (Exp, Duplicate_Subexpr_No_Checks (Exp)); | |
7864 | ||
7865 | -- For controlled types, do the allocation on the secondary stack | |
7866 | -- manually in order to call adjust at the right time: | |
7867 | ||
7868 | -- type Anon1 is access R_Type; | |
7869 | -- for Anon1'Storage_pool use ss_pool; | |
7870 | -- Anon2 : anon1 := new R_Type'(expr); | |
7871 | -- return Anon2.all; | |
7872 | ||
7873 | -- We do the same for classwide types that are not potentially | |
7874 | -- controlled (by the virtue of restriction No_Finalization) because | |
7875 | -- gigi is not able to properly allocate class-wide types. | |
7876 | ||
7877 | elsif CW_Or_Has_Controlled_Part (Utyp) then | |
7878 | declare | |
7879 | Loc : constant Source_Ptr := Sloc (N); | |
7880 | Acc_Typ : constant Entity_Id := Make_Temporary (Loc, 'A'); | |
7881 | Alloc_Node : Node_Id; | |
7882 | Temp : Entity_Id; | |
7883 | ||
7884 | begin | |
7885 | Set_Ekind (Acc_Typ, E_Access_Type); | |
7886 | ||
7887 | Set_Associated_Storage_Pool (Acc_Typ, RTE (RE_SS_Pool)); | |
7888 | ||
7889 | -- This is an allocator for the secondary stack, and it's fine | |
7890 | -- to have Comes_From_Source set False on it, as gigi knows not | |
7891 | -- to flag it as a violation of No_Implicit_Heap_Allocations. | |
7892 | ||
7893 | Alloc_Node := | |
7894 | Make_Allocator (Loc, | |
7895 | Expression => | |
7896 | Make_Qualified_Expression (Loc, | |
7897 | Subtype_Mark => New_Reference_To (Etype (Exp), Loc), | |
7898 | Expression => Relocate_Node (Exp))); | |
7899 | ||
7900 | -- We do not want discriminant checks on the declaration, | |
7901 | -- given that it gets its value from the allocator. | |
7902 | ||
7903 | Set_No_Initialization (Alloc_Node); | |
7904 | ||
7905 | Temp := Make_Temporary (Loc, 'R', Alloc_Node); | |
7906 | ||
7907 | Insert_List_Before_And_Analyze (N, New_List ( | |
7908 | Make_Full_Type_Declaration (Loc, | |
7909 | Defining_Identifier => Acc_Typ, | |
7910 | Type_Definition => | |
7911 | Make_Access_To_Object_Definition (Loc, | |
7912 | Subtype_Indication => Subtype_Ind)), | |
7913 | ||
7914 | Make_Object_Declaration (Loc, | |
7915 | Defining_Identifier => Temp, | |
7916 | Object_Definition => New_Reference_To (Acc_Typ, Loc), | |
7917 | Expression => Alloc_Node))); | |
7918 | ||
7919 | Rewrite (Exp, | |
7920 | Make_Explicit_Dereference (Loc, | |
7921 | Prefix => New_Reference_To (Temp, Loc))); | |
7922 | ||
a1092b48 AC |
7923 | -- Ada 2005 (AI-251): If the type of the returned object is |
7924 | -- an interface then add an implicit type conversion to force | |
7925 | -- displacement of the "this" pointer. | |
7926 | ||
7927 | if Is_Interface (R_Type) then | |
7928 | Rewrite (Exp, Convert_To (R_Type, Relocate_Node (Exp))); | |
7929 | end if; | |
7930 | ||
2b3d67a5 AC |
7931 | Analyze_And_Resolve (Exp, R_Type); |
7932 | end; | |
7933 | ||
7934 | -- Otherwise use the gigi mechanism to allocate result on the | |
7935 | -- secondary stack. | |
7936 | ||
7937 | else | |
7938 | Check_Restriction (No_Secondary_Stack, N); | |
7939 | Set_Storage_Pool (N, RTE (RE_SS_Pool)); | |
7940 | ||
7941 | -- If we are generating code for the VM do not use | |
7942 | -- SS_Allocate since everything is heap-allocated anyway. | |
7943 | ||
7944 | if VM_Target = No_VM then | |
7945 | Set_Procedure_To_Call (N, RTE (RE_SS_Allocate)); | |
7946 | end if; | |
7947 | end if; | |
7948 | end if; | |
7949 | ||
54bf19e4 AC |
7950 | -- Implement the rules of 6.5(8-10), which require a tag check in |
7951 | -- the case of a limited tagged return type, and tag reassignment for | |
2b3d67a5 AC |
7952 | -- nonlimited tagged results. These actions are needed when the return |
7953 | -- type is a specific tagged type and the result expression is a | |
54bf19e4 AC |
7954 | -- conversion or a formal parameter, because in that case the tag of |
7955 | -- the expression might differ from the tag of the specific result type. | |
2b3d67a5 AC |
7956 | |
7957 | if Is_Tagged_Type (Utyp) | |
7958 | and then not Is_Class_Wide_Type (Utyp) | |
7959 | and then (Nkind_In (Exp, N_Type_Conversion, | |
7960 | N_Unchecked_Type_Conversion) | |
7961 | or else (Is_Entity_Name (Exp) | |
7962 | and then Ekind (Entity (Exp)) in Formal_Kind)) | |
7963 | then | |
54bf19e4 AC |
7964 | -- When the return type is limited, perform a check that the tag of |
7965 | -- the result is the same as the tag of the return type. | |
2b3d67a5 AC |
7966 | |
7967 | if Is_Limited_Type (R_Type) then | |
7968 | Insert_Action (Exp, | |
7969 | Make_Raise_Constraint_Error (Loc, | |
7970 | Condition => | |
7971 | Make_Op_Ne (Loc, | |
2c1b72d7 | 7972 | Left_Opnd => |
2b3d67a5 | 7973 | Make_Selected_Component (Loc, |
7675ad4f AC |
7974 | Prefix => Duplicate_Subexpr (Exp), |
7975 | Selector_Name => Make_Identifier (Loc, Name_uTag)), | |
2b3d67a5 AC |
7976 | Right_Opnd => |
7977 | Make_Attribute_Reference (Loc, | |
2c1b72d7 AC |
7978 | Prefix => |
7979 | New_Occurrence_Of (Base_Type (Utyp), Loc), | |
2b3d67a5 | 7980 | Attribute_Name => Name_Tag)), |
2c1b72d7 | 7981 | Reason => CE_Tag_Check_Failed)); |
2b3d67a5 AC |
7982 | |
7983 | -- If the result type is a specific nonlimited tagged type, then we | |
7984 | -- have to ensure that the tag of the result is that of the result | |
54bf19e4 AC |
7985 | -- type. This is handled by making a copy of the expression in |
7986 | -- the case where it might have a different tag, namely when the | |
2b3d67a5 AC |
7987 | -- expression is a conversion or a formal parameter. We create a new |
7988 | -- object of the result type and initialize it from the expression, | |
7989 | -- which will implicitly force the tag to be set appropriately. | |
7990 | ||
7991 | else | |
7992 | declare | |
7993 | ExpR : constant Node_Id := Relocate_Node (Exp); | |
7994 | Result_Id : constant Entity_Id := | |
7995 | Make_Temporary (Loc, 'R', ExpR); | |
7996 | Result_Exp : constant Node_Id := | |
7997 | New_Reference_To (Result_Id, Loc); | |
7998 | Result_Obj : constant Node_Id := | |
7999 | Make_Object_Declaration (Loc, | |
8000 | Defining_Identifier => Result_Id, | |
8001 | Object_Definition => | |
8002 | New_Reference_To (R_Type, Loc), | |
8003 | Constant_Present => True, | |
8004 | Expression => ExpR); | |
8005 | ||
8006 | begin | |
8007 | Set_Assignment_OK (Result_Obj); | |
8008 | Insert_Action (Exp, Result_Obj); | |
8009 | ||
8010 | Rewrite (Exp, Result_Exp); | |
8011 | Analyze_And_Resolve (Exp, R_Type); | |
8012 | end; | |
8013 | end if; | |
8014 | ||
8015 | -- Ada 2005 (AI-344): If the result type is class-wide, then insert | |
8016 | -- a check that the level of the return expression's underlying type | |
8017 | -- is not deeper than the level of the master enclosing the function. | |
8018 | -- Always generate the check when the type of the return expression | |
8019 | -- is class-wide, when it's a type conversion, or when it's a formal | |
8020 | -- parameter. Otherwise, suppress the check in the case where the | |
8021 | -- return expression has a specific type whose level is known not to | |
8022 | -- be statically deeper than the function's result type. | |
8023 | ||
0a376301 JM |
8024 | -- No runtime check needed in interface thunks since it is performed |
8025 | -- by the target primitive associated with the thunk. | |
8026 | ||
2b3d67a5 AC |
8027 | -- Note: accessibility check is skipped in the VM case, since there |
8028 | -- does not seem to be any practical way to implement this check. | |
8029 | ||
0791fbe9 | 8030 | elsif Ada_Version >= Ada_2005 |
2b3d67a5 AC |
8031 | and then Tagged_Type_Expansion |
8032 | and then Is_Class_Wide_Type (R_Type) | |
0a376301 | 8033 | and then not Is_Thunk (Current_Scope) |
3217f71e | 8034 | and then not Scope_Suppress.Suppress (Accessibility_Check) |
2b3d67a5 AC |
8035 | and then |
8036 | (Is_Class_Wide_Type (Etype (Exp)) | |
8037 | or else Nkind_In (Exp, N_Type_Conversion, | |
8038 | N_Unchecked_Type_Conversion) | |
8039 | or else (Is_Entity_Name (Exp) | |
2c1b72d7 | 8040 | and then Ekind (Entity (Exp)) in Formal_Kind) |
2b3d67a5 AC |
8041 | or else Scope_Depth (Enclosing_Dynamic_Scope (Etype (Exp))) > |
8042 | Scope_Depth (Enclosing_Dynamic_Scope (Scope_Id))) | |
8043 | then | |
8044 | declare | |
8045 | Tag_Node : Node_Id; | |
8046 | ||
8047 | begin | |
8048 | -- Ada 2005 (AI-251): In class-wide interface objects we displace | |
c5f5123f AC |
8049 | -- "this" to reference the base of the object. This is required to |
8050 | -- get access to the TSD of the object. | |
2b3d67a5 AC |
8051 | |
8052 | if Is_Class_Wide_Type (Etype (Exp)) | |
8053 | and then Is_Interface (Etype (Exp)) | |
8054 | and then Nkind (Exp) = N_Explicit_Dereference | |
8055 | then | |
8056 | Tag_Node := | |
8057 | Make_Explicit_Dereference (Loc, | |
2c1b72d7 AC |
8058 | Prefix => |
8059 | Unchecked_Convert_To (RTE (RE_Tag_Ptr), | |
8060 | Make_Function_Call (Loc, | |
8061 | Name => | |
8062 | New_Reference_To (RTE (RE_Base_Address), Loc), | |
8063 | Parameter_Associations => New_List ( | |
8064 | Unchecked_Convert_To (RTE (RE_Address), | |
8065 | Duplicate_Subexpr (Prefix (Exp))))))); | |
2b3d67a5 AC |
8066 | else |
8067 | Tag_Node := | |
8068 | Make_Attribute_Reference (Loc, | |
2c1b72d7 | 8069 | Prefix => Duplicate_Subexpr (Exp), |
2b3d67a5 AC |
8070 | Attribute_Name => Name_Tag); |
8071 | end if; | |
8072 | ||
8073 | Insert_Action (Exp, | |
8074 | Make_Raise_Program_Error (Loc, | |
8075 | Condition => | |
8076 | Make_Op_Gt (Loc, | |
2c1b72d7 | 8077 | Left_Opnd => Build_Get_Access_Level (Loc, Tag_Node), |
2b3d67a5 AC |
8078 | Right_Opnd => |
8079 | Make_Integer_Literal (Loc, | |
8080 | Scope_Depth (Enclosing_Dynamic_Scope (Scope_Id)))), | |
8081 | Reason => PE_Accessibility_Check_Failed)); | |
8082 | end; | |
8083 | ||
8084 | -- AI05-0073: If function has a controlling access result, check that | |
8085 | -- the tag of the return value, if it is not null, matches designated | |
8086 | -- type of return type. | |
f7ea2603 RD |
8087 | |
8088 | -- The return expression is referenced twice in the code below, so it | |
8089 | -- must be made free of side effects. Given that different compilers | |
2b3d67a5 AC |
8090 | -- may evaluate these parameters in different order, both occurrences |
8091 | -- perform a copy. | |
8092 | ||
8093 | elsif Ekind (R_Type) = E_Anonymous_Access_Type | |
8094 | and then Has_Controlling_Result (Scope_Id) | |
8095 | then | |
8096 | Insert_Action (N, | |
8097 | Make_Raise_Constraint_Error (Loc, | |
8098 | Condition => | |
8099 | Make_And_Then (Loc, | |
8100 | Left_Opnd => | |
8101 | Make_Op_Ne (Loc, | |
8102 | Left_Opnd => Duplicate_Subexpr (Exp), | |
8103 | Right_Opnd => Make_Null (Loc)), | |
ebf494ec | 8104 | |
2b3d67a5 AC |
8105 | Right_Opnd => Make_Op_Ne (Loc, |
8106 | Left_Opnd => | |
8107 | Make_Selected_Component (Loc, | |
8108 | Prefix => Duplicate_Subexpr (Exp), | |
7675ad4f | 8109 | Selector_Name => Make_Identifier (Loc, Name_uTag)), |
ebf494ec | 8110 | |
2b3d67a5 AC |
8111 | Right_Opnd => |
8112 | Make_Attribute_Reference (Loc, | |
8113 | Prefix => | |
8114 | New_Occurrence_Of (Designated_Type (R_Type), Loc), | |
8115 | Attribute_Name => Name_Tag))), | |
ebf494ec | 8116 | |
2b3d67a5 AC |
8117 | Reason => CE_Tag_Check_Failed), |
8118 | Suppress => All_Checks); | |
8119 | end if; | |
8120 | ||
63585f75 SB |
8121 | -- AI05-0234: RM 6.5(21/3). Check access discriminants to |
8122 | -- ensure that the function result does not outlive an | |
8123 | -- object designated by one of it discriminants. | |
8124 | ||
57a3fca9 | 8125 | if Present (Extra_Accessibility_Of_Result (Scope_Id)) |
63585f75 SB |
8126 | and then Has_Unconstrained_Access_Discriminants (R_Type) |
8127 | then | |
8128 | declare | |
ebf494ec | 8129 | Discrim_Source : Node_Id; |
63585f75 SB |
8130 | |
8131 | procedure Check_Against_Result_Level (Level : Node_Id); | |
ebf494ec RD |
8132 | -- Check the given accessibility level against the level |
8133 | -- determined by the point of call. (AI05-0234). | |
63585f75 SB |
8134 | |
8135 | -------------------------------- | |
8136 | -- Check_Against_Result_Level -- | |
8137 | -------------------------------- | |
8138 | ||
8139 | procedure Check_Against_Result_Level (Level : Node_Id) is | |
8140 | begin | |
8141 | Insert_Action (N, | |
8142 | Make_Raise_Program_Error (Loc, | |
8143 | Condition => | |
8144 | Make_Op_Gt (Loc, | |
8145 | Left_Opnd => Level, | |
8146 | Right_Opnd => | |
8147 | New_Occurrence_Of | |
8148 | (Extra_Accessibility_Of_Result (Scope_Id), Loc)), | |
8149 | Reason => PE_Accessibility_Check_Failed)); | |
8150 | end Check_Against_Result_Level; | |
ebf494ec | 8151 | |
63585f75 | 8152 | begin |
ebf494ec | 8153 | Discrim_Source := Exp; |
63585f75 SB |
8154 | while Nkind (Discrim_Source) = N_Qualified_Expression loop |
8155 | Discrim_Source := Expression (Discrim_Source); | |
8156 | end loop; | |
8157 | ||
8158 | if Nkind (Discrim_Source) = N_Identifier | |
8159 | and then Is_Return_Object (Entity (Discrim_Source)) | |
8160 | then | |
63585f75 SB |
8161 | Discrim_Source := Entity (Discrim_Source); |
8162 | ||
8163 | if Is_Constrained (Etype (Discrim_Source)) then | |
8164 | Discrim_Source := Etype (Discrim_Source); | |
8165 | else | |
8166 | Discrim_Source := Expression (Parent (Discrim_Source)); | |
8167 | end if; | |
8168 | ||
8169 | elsif Nkind (Discrim_Source) = N_Identifier | |
8170 | and then Nkind_In (Original_Node (Discrim_Source), | |
8171 | N_Aggregate, N_Extension_Aggregate) | |
8172 | then | |
63585f75 SB |
8173 | Discrim_Source := Original_Node (Discrim_Source); |
8174 | ||
8175 | elsif Nkind (Discrim_Source) = N_Explicit_Dereference and then | |
8176 | Nkind (Original_Node (Discrim_Source)) = N_Function_Call | |
8177 | then | |
63585f75 | 8178 | Discrim_Source := Original_Node (Discrim_Source); |
63585f75 SB |
8179 | end if; |
8180 | ||
8181 | while Nkind_In (Discrim_Source, N_Qualified_Expression, | |
8182 | N_Type_Conversion, | |
8183 | N_Unchecked_Type_Conversion) | |
8184 | loop | |
63585f75 SB |
8185 | Discrim_Source := Expression (Discrim_Source); |
8186 | end loop; | |
8187 | ||
8188 | case Nkind (Discrim_Source) is | |
8189 | when N_Defining_Identifier => | |
8190 | ||
54bf19e4 AC |
8191 | pragma Assert (Is_Composite_Type (Discrim_Source) |
8192 | and then Has_Discriminants (Discrim_Source) | |
8193 | and then Is_Constrained (Discrim_Source)); | |
63585f75 SB |
8194 | |
8195 | declare | |
8196 | Discrim : Entity_Id := | |
8197 | First_Discriminant (Base_Type (R_Type)); | |
8198 | Disc_Elmt : Elmt_Id := | |
8199 | First_Elmt (Discriminant_Constraint | |
8200 | (Discrim_Source)); | |
8201 | begin | |
8202 | loop | |
8203 | if Ekind (Etype (Discrim)) = | |
54bf19e4 AC |
8204 | E_Anonymous_Access_Type |
8205 | then | |
63585f75 SB |
8206 | Check_Against_Result_Level |
8207 | (Dynamic_Accessibility_Level (Node (Disc_Elmt))); | |
8208 | end if; | |
8209 | ||
8210 | Next_Elmt (Disc_Elmt); | |
8211 | Next_Discriminant (Discrim); | |
8212 | exit when not Present (Discrim); | |
8213 | end loop; | |
8214 | end; | |
8215 | ||
8216 | when N_Aggregate | N_Extension_Aggregate => | |
8217 | ||
54bf19e4 AC |
8218 | -- Unimplemented: extension aggregate case where discrims |
8219 | -- come from ancestor part, not extension part. | |
63585f75 SB |
8220 | |
8221 | declare | |
8222 | Discrim : Entity_Id := | |
8223 | First_Discriminant (Base_Type (R_Type)); | |
8224 | ||
8225 | Disc_Exp : Node_Id := Empty; | |
8226 | ||
8227 | Positionals_Exhausted | |
8228 | : Boolean := not Present (Expressions | |
8229 | (Discrim_Source)); | |
8230 | ||
8231 | function Associated_Expr | |
8232 | (Comp_Id : Entity_Id; | |
8233 | Associations : List_Id) return Node_Id; | |
8234 | ||
8235 | -- Given a component and a component associations list, | |
8236 | -- locate the expression for that component; returns | |
8237 | -- Empty if no such expression is found. | |
8238 | ||
8239 | --------------------- | |
8240 | -- Associated_Expr -- | |
8241 | --------------------- | |
8242 | ||
8243 | function Associated_Expr | |
8244 | (Comp_Id : Entity_Id; | |
8245 | Associations : List_Id) return Node_Id | |
8246 | is | |
54bf19e4 | 8247 | Assoc : Node_Id; |
63585f75 | 8248 | Choice : Node_Id; |
54bf19e4 | 8249 | |
63585f75 SB |
8250 | begin |
8251 | -- Simple linear search seems ok here | |
8252 | ||
54bf19e4 | 8253 | Assoc := First (Associations); |
63585f75 SB |
8254 | while Present (Assoc) loop |
8255 | Choice := First (Choices (Assoc)); | |
63585f75 SB |
8256 | while Present (Choice) loop |
8257 | if (Nkind (Choice) = N_Identifier | |
54bf19e4 AC |
8258 | and then Chars (Choice) = Chars (Comp_Id)) |
8259 | or else (Nkind (Choice) = N_Others_Choice) | |
63585f75 SB |
8260 | then |
8261 | return Expression (Assoc); | |
8262 | end if; | |
8263 | ||
8264 | Next (Choice); | |
8265 | end loop; | |
8266 | ||
8267 | Next (Assoc); | |
8268 | end loop; | |
8269 | ||
8270 | return Empty; | |
8271 | end Associated_Expr; | |
8272 | ||
8273 | -- Start of processing for Expand_Simple_Function_Return | |
8274 | ||
8275 | begin | |
8276 | if not Positionals_Exhausted then | |
8277 | Disc_Exp := First (Expressions (Discrim_Source)); | |
8278 | end if; | |
8279 | ||
8280 | loop | |
8281 | if Positionals_Exhausted then | |
54bf19e4 AC |
8282 | Disc_Exp := |
8283 | Associated_Expr | |
8284 | (Discrim, | |
8285 | Component_Associations (Discrim_Source)); | |
63585f75 SB |
8286 | end if; |
8287 | ||
8288 | if Ekind (Etype (Discrim)) = | |
54bf19e4 AC |
8289 | E_Anonymous_Access_Type |
8290 | then | |
63585f75 SB |
8291 | Check_Against_Result_Level |
8292 | (Dynamic_Accessibility_Level (Disc_Exp)); | |
8293 | end if; | |
8294 | ||
8295 | Next_Discriminant (Discrim); | |
8296 | exit when not Present (Discrim); | |
8297 | ||
8298 | if not Positionals_Exhausted then | |
8299 | Next (Disc_Exp); | |
8300 | Positionals_Exhausted := not Present (Disc_Exp); | |
8301 | end if; | |
8302 | end loop; | |
8303 | end; | |
8304 | ||
8305 | when N_Function_Call => | |
54bf19e4 AC |
8306 | |
8307 | -- No check needed (check performed by callee) | |
8308 | ||
63585f75 SB |
8309 | null; |
8310 | ||
8311 | when others => | |
8312 | ||
8313 | declare | |
8314 | Level : constant Node_Id := | |
54bf19e4 AC |
8315 | Make_Integer_Literal (Loc, |
8316 | Object_Access_Level (Discrim_Source)); | |
8317 | ||
63585f75 SB |
8318 | begin |
8319 | -- Unimplemented: check for name prefix that includes | |
8320 | -- a dereference of an access value with a dynamic | |
8321 | -- accessibility level (e.g., an access param or a | |
8322 | -- saooaaat) and use dynamic level in that case. For | |
8323 | -- example: | |
8324 | -- return Access_Param.all(Some_Index).Some_Component; | |
54bf19e4 | 8325 | -- ??? |
63585f75 SB |
8326 | |
8327 | Set_Etype (Level, Standard_Natural); | |
8328 | Check_Against_Result_Level (Level); | |
8329 | end; | |
8330 | ||
8331 | end case; | |
8332 | end; | |
8333 | end if; | |
8334 | ||
2b3d67a5 AC |
8335 | -- If we are returning an object that may not be bit-aligned, then copy |
8336 | -- the value into a temporary first. This copy may need to expand to a | |
8337 | -- loop of component operations. | |
8338 | ||
8339 | if Is_Possibly_Unaligned_Slice (Exp) | |
8340 | or else Is_Possibly_Unaligned_Object (Exp) | |
8341 | then | |
8342 | declare | |
8343 | ExpR : constant Node_Id := Relocate_Node (Exp); | |
8344 | Tnn : constant Entity_Id := Make_Temporary (Loc, 'T', ExpR); | |
8345 | begin | |
8346 | Insert_Action (Exp, | |
8347 | Make_Object_Declaration (Loc, | |
8348 | Defining_Identifier => Tnn, | |
8349 | Constant_Present => True, | |
8350 | Object_Definition => New_Occurrence_Of (R_Type, Loc), | |
8351 | Expression => ExpR), | |
2c1b72d7 | 8352 | Suppress => All_Checks); |
2b3d67a5 AC |
8353 | Rewrite (Exp, New_Occurrence_Of (Tnn, Loc)); |
8354 | end; | |
8355 | end if; | |
8356 | ||
8357 | -- Generate call to postcondition checks if they are present | |
8358 | ||
8359 | if Ekind (Scope_Id) = E_Function | |
8360 | and then Has_Postconditions (Scope_Id) | |
8361 | then | |
8362 | -- We are going to reference the returned value twice in this case, | |
8363 | -- once in the call to _Postconditions, and once in the actual return | |
8364 | -- statement, but we can't have side effects happening twice, and in | |
8365 | -- any case for efficiency we don't want to do the computation twice. | |
8366 | ||
8367 | -- If the returned expression is an entity name, we don't need to | |
8368 | -- worry since it is efficient and safe to reference it twice, that's | |
8369 | -- also true for literals other than string literals, and for the | |
8370 | -- case of X.all where X is an entity name. | |
8371 | ||
8372 | if Is_Entity_Name (Exp) | |
8373 | or else Nkind_In (Exp, N_Character_Literal, | |
8374 | N_Integer_Literal, | |
8375 | N_Real_Literal) | |
8376 | or else (Nkind (Exp) = N_Explicit_Dereference | |
2c1b72d7 | 8377 | and then Is_Entity_Name (Prefix (Exp))) |
2b3d67a5 AC |
8378 | then |
8379 | null; | |
8380 | ||
8381 | -- Otherwise we are going to need a temporary to capture the value | |
8382 | ||
8383 | else | |
8384 | declare | |
ca3e17b0 | 8385 | ExpR : Node_Id := Relocate_Node (Exp); |
2b3d67a5 AC |
8386 | Tnn : constant Entity_Id := Make_Temporary (Loc, 'T', ExpR); |
8387 | ||
8388 | begin | |
ca3e17b0 AC |
8389 | -- In the case of discriminated objects, we have created a |
8390 | -- constrained subtype above, and used the underlying type. | |
8391 | -- This transformation is post-analysis and harmless, except | |
8392 | -- that now the call to the post-condition will be analyzed and | |
8393 | -- type kinds have to match. | |
8394 | ||
8395 | if Nkind (ExpR) = N_Unchecked_Type_Conversion | |
8396 | and then | |
8397 | Is_Private_Type (R_Type) /= Is_Private_Type (Etype (ExpR)) | |
8398 | then | |
8399 | ExpR := Expression (ExpR); | |
8400 | end if; | |
8401 | ||
2b3d67a5 AC |
8402 | -- For a complex expression of an elementary type, capture |
8403 | -- value in the temporary and use it as the reference. | |
8404 | ||
8405 | if Is_Elementary_Type (R_Type) then | |
8406 | Insert_Action (Exp, | |
8407 | Make_Object_Declaration (Loc, | |
8408 | Defining_Identifier => Tnn, | |
8409 | Constant_Present => True, | |
8410 | Object_Definition => New_Occurrence_Of (R_Type, Loc), | |
8411 | Expression => ExpR), | |
8412 | Suppress => All_Checks); | |
8413 | ||
8414 | Rewrite (Exp, New_Occurrence_Of (Tnn, Loc)); | |
8415 | ||
8416 | -- If we have something we can rename, generate a renaming of | |
8417 | -- the object and replace the expression with a reference | |
8418 | ||
8419 | elsif Is_Object_Reference (Exp) then | |
8420 | Insert_Action (Exp, | |
8421 | Make_Object_Renaming_Declaration (Loc, | |
8422 | Defining_Identifier => Tnn, | |
8423 | Subtype_Mark => New_Occurrence_Of (R_Type, Loc), | |
8424 | Name => ExpR), | |
8425 | Suppress => All_Checks); | |
8426 | ||
8427 | Rewrite (Exp, New_Occurrence_Of (Tnn, Loc)); | |
8428 | ||
8429 | -- Otherwise we have something like a string literal or an | |
8430 | -- aggregate. We could copy the value, but that would be | |
8431 | -- inefficient. Instead we make a reference to the value and | |
8432 | -- capture this reference with a renaming, the expression is | |
8433 | -- then replaced by a dereference of this renaming. | |
8434 | ||
8435 | else | |
8436 | -- For now, copy the value, since the code below does not | |
8437 | -- seem to work correctly ??? | |
8438 | ||
8439 | Insert_Action (Exp, | |
8440 | Make_Object_Declaration (Loc, | |
8441 | Defining_Identifier => Tnn, | |
8442 | Constant_Present => True, | |
8443 | Object_Definition => New_Occurrence_Of (R_Type, Loc), | |
8444 | Expression => Relocate_Node (Exp)), | |
8445 | Suppress => All_Checks); | |
8446 | ||
8447 | Rewrite (Exp, New_Occurrence_Of (Tnn, Loc)); | |
8448 | ||
8449 | -- Insert_Action (Exp, | |
8450 | -- Make_Object_Renaming_Declaration (Loc, | |
8451 | -- Defining_Identifier => Tnn, | |
8452 | -- Access_Definition => | |
8453 | -- Make_Access_Definition (Loc, | |
8454 | -- All_Present => True, | |
8455 | -- Subtype_Mark => New_Occurrence_Of (R_Type, Loc)), | |
8456 | -- Name => | |
8457 | -- Make_Reference (Loc, | |
8458 | -- Prefix => Relocate_Node (Exp))), | |
8459 | -- Suppress => All_Checks); | |
8460 | ||
8461 | -- Rewrite (Exp, | |
8462 | -- Make_Explicit_Dereference (Loc, | |
8463 | -- Prefix => New_Occurrence_Of (Tnn, Loc))); | |
8464 | end if; | |
8465 | end; | |
8466 | end if; | |
8467 | ||
8468 | -- Generate call to _postconditions | |
8469 | ||
8470 | Insert_Action (Exp, | |
8471 | Make_Procedure_Call_Statement (Loc, | |
8472 | Name => Make_Identifier (Loc, Name_uPostconditions), | |
8473 | Parameter_Associations => New_List (Duplicate_Subexpr (Exp)))); | |
8474 | end if; | |
8475 | ||
8476 | -- Ada 2005 (AI-251): If this return statement corresponds with an | |
8477 | -- simple return statement associated with an extended return statement | |
8478 | -- and the type of the returned object is an interface then generate an | |
8479 | -- implicit conversion to force displacement of the "this" pointer. | |
8480 | ||
0791fbe9 | 8481 | if Ada_Version >= Ada_2005 |
2b3d67a5 AC |
8482 | and then Comes_From_Extended_Return_Statement (N) |
8483 | and then Nkind (Expression (N)) = N_Identifier | |
8484 | and then Is_Interface (Utyp) | |
8485 | and then Utyp /= Underlying_Type (Exptyp) | |
8486 | then | |
8487 | Rewrite (Exp, Convert_To (Utyp, Relocate_Node (Exp))); | |
8488 | Analyze_And_Resolve (Exp); | |
8489 | end if; | |
8490 | end Expand_Simple_Function_Return; | |
8491 | ||
ea3c0651 AC |
8492 | -------------------------------- |
8493 | -- Expand_Subprogram_Contract -- | |
8494 | -------------------------------- | |
8495 | ||
8496 | procedure Expand_Subprogram_Contract | |
8497 | (N : Node_Id; | |
8498 | Spec_Id : Entity_Id; | |
8499 | Body_Id : Entity_Id) | |
8500 | is | |
8501 | procedure Add_Invariant_And_Predicate_Checks | |
8502 | (Subp_Id : Entity_Id; | |
8503 | Stmts : in out List_Id; | |
8504 | Result : out Node_Id); | |
8505 | -- Process the result of function Subp_Id (if applicable) and all its | |
8506 | -- formals. Add invariant and predicate checks where applicable. The | |
8507 | -- routine appends all the checks to list Stmts. If Subp_Id denotes a | |
8508 | -- function, Result contains the entity of parameter _Result, to be | |
8509 | -- used in the creation of procedure _Postconditions. | |
8510 | ||
8511 | procedure Append_Enabled_Item (Item : Node_Id; List : in out List_Id); | |
8512 | -- Append a node to a list. If there is no list, create a new one. When | |
8513 | -- the item denotes a pragma, it is added to the list only when it is | |
8514 | -- enabled. | |
8515 | ||
8516 | procedure Build_Postconditions_Procedure | |
8517 | (Subp_Id : Entity_Id; | |
8518 | Stmts : List_Id; | |
8519 | Result : Entity_Id); | |
8520 | -- Create the body of procedure _Postconditions which handles various | |
8521 | -- assertion actions on exit from subprogram Subp_Id. Stmts is the list | |
8522 | -- of statements to be checked on exit. Parameter Result is the entity | |
8523 | -- of parameter _Result when Subp_Id denotes a function. | |
8524 | ||
8525 | function Build_Pragma_Check_Equivalent | |
8526 | (Prag : Node_Id; | |
8527 | Subp_Id : Entity_Id := Empty; | |
8528 | Inher_Id : Entity_Id := Empty) return Node_Id; | |
8529 | -- Transform a [refined] pre- or postcondition denoted by Prag into an | |
8530 | -- equivalent pragma Check. When the pre- or postcondition is inherited, | |
8531 | -- the routine corrects the references of all formals of Inher_Id to | |
8532 | -- point to the formals of Subp_Id. | |
8533 | ||
8534 | procedure Collect_Body_Postconditions (Stmts : in out List_Id); | |
8535 | -- Process all postconditions found in the declarations of the body. The | |
8536 | -- routine appends the pragma Check equivalents to list Stmts. | |
8537 | ||
8538 | procedure Collect_Spec_Postconditions | |
8539 | (Subp_Id : Entity_Id; | |
8540 | Stmts : in out List_Id); | |
8541 | -- Process all [inherited] postconditions of subprogram spec Subp_Id. | |
8542 | -- The routine appends the pragma Check equivalents to list Stmts. | |
8543 | ||
8544 | procedure Collect_Spec_Preconditions (Subp_Id : Entity_Id); | |
8545 | -- Process all [inherited] preconditions of subprogram spec Subp_Id. The | |
8546 | -- routine prepends the pragma Check equivalents to the declarations of | |
8547 | -- the body. | |
8548 | ||
8549 | procedure Prepend_To_Declarations (Item : Node_Id); | |
8550 | -- Prepend a single item to the declarations of the subprogram body | |
8551 | ||
8552 | procedure Process_Contract_Cases | |
8553 | (Subp_Id : Entity_Id; | |
8554 | Stmts : in out List_Id); | |
8555 | -- Process pragma Contract_Cases of subprogram spec Subp_Id. The routine | |
8556 | -- appends the expanded code to list Stmts. | |
8557 | ||
8558 | ---------------------------------------- | |
8559 | -- Add_Invariant_And_Predicate_Checks -- | |
8560 | ---------------------------------------- | |
8561 | ||
8562 | procedure Add_Invariant_And_Predicate_Checks | |
8563 | (Subp_Id : Entity_Id; | |
8564 | Stmts : in out List_Id; | |
8565 | Result : out Node_Id) | |
8566 | is | |
8567 | procedure Add_Invariant_Access_Checks (Id : Entity_Id); | |
8568 | -- Id denotes the return value of a function or a formal parameter. | |
8569 | -- Add an invariant check if the type of Id is access to a type with | |
8570 | -- invariants. The routine appends the generated code to Stmts. | |
8571 | ||
8572 | function Invariant_Checks_OK (Typ : Entity_Id) return Boolean; | |
8573 | -- Determine whether type Typ can benefit from invariant checks. To | |
8574 | -- qualify, the type must have a non-null invariant procedure and | |
8575 | -- subprogram Subp_Id must appear visible from the point of view of | |
8576 | -- the type. | |
8577 | ||
8578 | function Predicate_Checks_OK (Typ : Entity_Id) return Boolean; | |
8579 | -- Determine whether type Typ can benefit from predicate checks. To | |
8580 | -- qualify, the type must have at least one checked predicate. | |
8581 | ||
8582 | --------------------------------- | |
8583 | -- Add_Invariant_Access_Checks -- | |
8584 | --------------------------------- | |
8585 | ||
8586 | procedure Add_Invariant_Access_Checks (Id : Entity_Id) is | |
8587 | Loc : constant Source_Ptr := Sloc (N); | |
8588 | Ref : Node_Id; | |
8589 | Typ : Entity_Id; | |
8590 | ||
8591 | begin | |
8592 | Typ := Etype (Id); | |
8593 | ||
8594 | if Is_Access_Type (Typ) and then not Is_Access_Constant (Typ) then | |
8595 | Typ := Designated_Type (Typ); | |
8596 | ||
8597 | if Invariant_Checks_OK (Typ) then | |
8598 | Ref := | |
8599 | Make_Explicit_Dereference (Loc, | |
8600 | Prefix => New_Occurrence_Of (Id, Loc)); | |
8601 | Set_Etype (Ref, Typ); | |
8602 | ||
8603 | -- Generate: | |
8604 | -- if <Id> /= null then | |
8605 | -- <invariant_call (<Ref>)> | |
8606 | -- end if; | |
8607 | ||
8608 | Append_Enabled_Item | |
8609 | (Item => | |
8610 | Make_If_Statement (Loc, | |
8611 | Condition => | |
8612 | Make_Op_Ne (Loc, | |
8613 | Left_Opnd => New_Occurrence_Of (Id, Loc), | |
8614 | Right_Opnd => Make_Null (Loc)), | |
8615 | Then_Statements => New_List ( | |
8616 | Make_Invariant_Call (Ref))), | |
8617 | List => Stmts); | |
8618 | end if; | |
8619 | end if; | |
8620 | end Add_Invariant_Access_Checks; | |
8621 | ||
8622 | ------------------------- | |
8623 | -- Invariant_Checks_OK -- | |
8624 | ------------------------- | |
8625 | ||
8626 | function Invariant_Checks_OK (Typ : Entity_Id) return Boolean is | |
8627 | function Has_Null_Body (Proc_Id : Entity_Id) return Boolean; | |
8628 | -- Determine whether the body of procedure Proc_Id contains a sole | |
8629 | -- null statement, possibly followed by an optional return. | |
8630 | ||
8631 | function Has_Public_Visibility_Of_Subprogram return Boolean; | |
8632 | -- Determine whether type Typ has public visibility of subprogram | |
8633 | -- Subp_Id. | |
8634 | ||
8635 | ------------------- | |
8636 | -- Has_Null_Body -- | |
8637 | ------------------- | |
8638 | ||
8639 | function Has_Null_Body (Proc_Id : Entity_Id) return Boolean is | |
8640 | Body_Id : Entity_Id; | |
8641 | Decl : Node_Id; | |
8642 | Spec : Node_Id; | |
8643 | Stmt1 : Node_Id; | |
8644 | Stmt2 : Node_Id; | |
8645 | ||
8646 | begin | |
8647 | Spec := Parent (Proc_Id); | |
8648 | Decl := Parent (Spec); | |
8649 | ||
8650 | -- Retrieve the entity of the invariant procedure body | |
8651 | ||
8652 | if Nkind (Spec) = N_Procedure_Specification | |
8653 | and then Nkind (Decl) = N_Subprogram_Declaration | |
8654 | then | |
8655 | Body_Id := Corresponding_Body (Decl); | |
8656 | ||
8657 | -- The body acts as a spec | |
8658 | ||
8659 | else | |
8660 | Body_Id := Proc_Id; | |
8661 | end if; | |
8662 | ||
8663 | -- The body will be generated later | |
8664 | ||
8665 | if No (Body_Id) then | |
8666 | return False; | |
8667 | end if; | |
8668 | ||
8669 | Spec := Parent (Body_Id); | |
8670 | Decl := Parent (Spec); | |
8671 | ||
8672 | pragma Assert | |
8673 | (Nkind (Spec) = N_Procedure_Specification | |
8674 | and then Nkind (Decl) = N_Subprogram_Body); | |
8675 | ||
8676 | Stmt1 := First (Statements (Handled_Statement_Sequence (Decl))); | |
8677 | ||
8678 | -- Look for a null statement followed by an optional return | |
8679 | -- statement. | |
8680 | ||
8681 | if Nkind (Stmt1) = N_Null_Statement then | |
8682 | Stmt2 := Next (Stmt1); | |
8683 | ||
8684 | if Present (Stmt2) then | |
8685 | return Nkind (Stmt2) = N_Simple_Return_Statement; | |
8686 | else | |
8687 | return True; | |
8688 | end if; | |
8689 | end if; | |
8690 | ||
8691 | return False; | |
8692 | end Has_Null_Body; | |
8693 | ||
8694 | ----------------------------------------- | |
8695 | -- Has_Public_Visibility_Of_Subprogram -- | |
8696 | ----------------------------------------- | |
8697 | ||
8698 | function Has_Public_Visibility_Of_Subprogram return Boolean is | |
8699 | Subp_Decl : constant Node_Id := Unit_Declaration_Node (Subp_Id); | |
d950f051 | 8700 | |
ea3c0651 AC |
8701 | begin |
8702 | -- An Initialization procedure must be considered visible even | |
8703 | -- though it is internally generated. | |
8704 | ||
8705 | if Is_Init_Proc (Defining_Entity (Subp_Decl)) then | |
8706 | return True; | |
8707 | ||
d950f051 AC |
8708 | elsif Ekind (Scope (Typ)) /= E_Package then |
8709 | return False; | |
8710 | ||
ea3c0651 AC |
8711 | -- Internally generated code is never publicly visible except |
8712 | -- for a subprogram that is the implementation of an expression | |
8713 | -- function. In that case the visibility is determined by the | |
8714 | -- last check. | |
8715 | ||
8716 | elsif not Comes_From_Source (Subp_Decl) | |
8717 | and then | |
8718 | (Nkind (Original_Node (Subp_Decl)) /= N_Expression_Function | |
8719 | or else not | |
8720 | Comes_From_Source (Defining_Entity (Subp_Decl))) | |
8721 | then | |
8722 | return False; | |
8723 | ||
8724 | -- Determine whether the subprogram is declared in the visible | |
8725 | -- declarations of the package containing the type. | |
8726 | ||
8727 | else | |
d950f051 AC |
8728 | return List_Containing (Subp_Decl) = |
8729 | Visible_Declarations | |
8730 | (Specification (Unit_Declaration_Node (Scope (Typ)))); | |
ea3c0651 AC |
8731 | end if; |
8732 | end Has_Public_Visibility_Of_Subprogram; | |
8733 | ||
8734 | -- Start of processing for Invariant_Checks_OK | |
8735 | ||
8736 | begin | |
8737 | return | |
8738 | Has_Invariants (Typ) | |
8739 | and then Present (Invariant_Procedure (Typ)) | |
8740 | and then not Has_Null_Body (Invariant_Procedure (Typ)) | |
8741 | and then Has_Public_Visibility_Of_Subprogram; | |
8742 | end Invariant_Checks_OK; | |
8743 | ||
8744 | ------------------------- | |
8745 | -- Predicate_Checks_OK -- | |
8746 | ------------------------- | |
8747 | ||
8748 | function Predicate_Checks_OK (Typ : Entity_Id) return Boolean is | |
8749 | function Has_Checked_Predicate return Boolean; | |
8750 | -- Determine whether type Typ has or inherits at least one | |
8751 | -- predicate aspect or pragma, for which the applicable policy is | |
8752 | -- Checked. | |
8753 | ||
8754 | --------------------------- | |
8755 | -- Has_Checked_Predicate -- | |
8756 | --------------------------- | |
8757 | ||
8758 | function Has_Checked_Predicate return Boolean is | |
8759 | Anc : Entity_Id; | |
8760 | Pred : Node_Id; | |
8761 | ||
8762 | begin | |
8763 | -- Climb the ancestor type chain staring from the input. This | |
8764 | -- is done because the input type may lack aspect/pragma | |
8765 | -- predicate and simply inherit those from its ancestor. | |
8766 | ||
5b6f12c7 AC |
8767 | -- Note that predicate pragmas correspond to all three cases |
8768 | -- of predicate aspects (Predicate, Dynamic_Predicate, and | |
ea3c0651 AC |
8769 | -- Static_Predicate), so this routine checks for all three |
8770 | -- cases. | |
8771 | ||
8772 | Anc := Typ; | |
8773 | while Present (Anc) loop | |
8774 | Pred := Get_Pragma (Anc, Pragma_Predicate); | |
8775 | ||
8776 | if Present (Pred) and then not Is_Ignored (Pred) then | |
8777 | return True; | |
8778 | end if; | |
8779 | ||
8780 | Anc := Nearest_Ancestor (Anc); | |
8781 | end loop; | |
8782 | ||
8783 | return False; | |
8784 | end Has_Checked_Predicate; | |
8785 | ||
8786 | -- Start of processing for Predicate_Checks_OK | |
8787 | ||
8788 | begin | |
8789 | return | |
8790 | Has_Predicates (Typ) | |
8791 | and then Present (Predicate_Function (Typ)) | |
8792 | and then Has_Checked_Predicate; | |
8793 | end Predicate_Checks_OK; | |
8794 | ||
8795 | -- Local variables | |
8796 | ||
8797 | Loc : constant Source_Ptr := Sloc (N); | |
8798 | Formal : Entity_Id; | |
8799 | Typ : Entity_Id; | |
8800 | ||
8801 | -- Start of processing for Add_Invariant_And_Predicate_Checks | |
8802 | ||
8803 | begin | |
8804 | Result := Empty; | |
8805 | ||
8806 | -- Do not generate any checks if no code is being generated | |
8807 | ||
8808 | if not Expander_Active then | |
8809 | return; | |
8810 | end if; | |
8811 | ||
8812 | -- Process the result of a function | |
8813 | ||
8814 | if Ekind_In (Subp_Id, E_Function, E_Generic_Function) then | |
8815 | Typ := Etype (Subp_Id); | |
8816 | ||
8817 | -- Generate _Result which is used in procedure _Postconditions to | |
8818 | -- verify the return value. | |
8819 | ||
8820 | Result := Make_Defining_Identifier (Loc, Name_uResult); | |
8821 | Set_Etype (Result, Typ); | |
8822 | ||
8823 | -- Add an invariant check when the return type has invariants and | |
8824 | -- the related function is visible to the outside. | |
8825 | ||
8826 | if Invariant_Checks_OK (Typ) then | |
8827 | Append_Enabled_Item | |
8828 | (Item => | |
8829 | Make_Invariant_Call (New_Occurrence_Of (Result, Loc)), | |
8830 | List => Stmts); | |
8831 | end if; | |
8832 | ||
8833 | -- Add an invariant check when the return type is an access to a | |
8834 | -- type with invariants. | |
8835 | ||
8836 | Add_Invariant_Access_Checks (Result); | |
8837 | end if; | |
8838 | ||
8839 | -- Add invariant and predicates for all formals that qualify | |
8840 | ||
8841 | Formal := First_Formal (Subp_Id); | |
8842 | while Present (Formal) loop | |
8843 | Typ := Etype (Formal); | |
8844 | ||
8845 | if Ekind (Formal) /= E_In_Parameter | |
8846 | or else Is_Access_Type (Typ) | |
8847 | then | |
8848 | if Invariant_Checks_OK (Typ) then | |
8849 | Append_Enabled_Item | |
8850 | (Item => | |
8851 | Make_Invariant_Call (New_Occurrence_Of (Formal, Loc)), | |
8852 | List => Stmts); | |
8853 | end if; | |
8854 | ||
8855 | Add_Invariant_Access_Checks (Formal); | |
8856 | ||
8857 | if Predicate_Checks_OK (Typ) then | |
8858 | Append_Enabled_Item | |
8859 | (Item => | |
8860 | Make_Predicate_Check | |
8861 | (Typ, New_Reference_To (Formal, Loc)), | |
8862 | List => Stmts); | |
8863 | end if; | |
8864 | end if; | |
8865 | ||
8866 | Next_Formal (Formal); | |
8867 | end loop; | |
8868 | end Add_Invariant_And_Predicate_Checks; | |
8869 | ||
8870 | ------------------------- | |
8871 | -- Append_Enabled_Item -- | |
8872 | ------------------------- | |
8873 | ||
8874 | procedure Append_Enabled_Item (Item : Node_Id; List : in out List_Id) is | |
8875 | begin | |
8876 | -- Do not chain ignored or disabled pragmas | |
8877 | ||
8878 | if Nkind (Item) = N_Pragma | |
8879 | and then (Is_Ignored (Item) or else Is_Disabled (Item)) | |
8880 | then | |
8881 | null; | |
8882 | ||
5b6f12c7 | 8883 | -- Otherwise, add the item |
ea3c0651 AC |
8884 | |
8885 | else | |
8886 | if No (List) then | |
8887 | List := New_List; | |
8888 | end if; | |
8889 | ||
cbee4f74 AC |
8890 | -- If the pragma is a conjunct in a composite postcondition, it |
8891 | -- has been processed in reverse order. In the postcondition body | |
8892 | -- if must appear before the others. | |
8893 | ||
8894 | if Nkind (Item) = N_Pragma | |
8895 | and then From_Aspect_Specification (Item) | |
8896 | and then Split_PPC (Item) | |
8897 | then | |
8898 | Prepend (Item, List); | |
8899 | else | |
8900 | Append (Item, List); | |
8901 | end if; | |
ea3c0651 AC |
8902 | end if; |
8903 | end Append_Enabled_Item; | |
8904 | ||
8905 | ------------------------------------ | |
8906 | -- Build_Postconditions_Procedure -- | |
8907 | ------------------------------------ | |
8908 | ||
8909 | procedure Build_Postconditions_Procedure | |
8910 | (Subp_Id : Entity_Id; | |
8911 | Stmts : List_Id; | |
8912 | Result : Entity_Id) | |
8913 | is | |
8e1e62e3 AC |
8914 | procedure Insert_Before_First_Source_Declaration (Stmt : Node_Id); |
8915 | -- Insert node Stmt before the first source declaration of the | |
8916 | -- related subprogram's body. If no such declaration exists, Stmt | |
8917 | -- becomes the last declaration. | |
ea3c0651 | 8918 | |
8e1e62e3 AC |
8919 | -------------------------------------------- |
8920 | -- Insert_Before_First_Source_Declaration -- | |
8921 | -------------------------------------------- | |
ea3c0651 | 8922 | |
8e1e62e3 AC |
8923 | procedure Insert_Before_First_Source_Declaration (Stmt : Node_Id) is |
8924 | Decls : constant List_Id := Declarations (N); | |
8925 | Decl : Node_Id; | |
ea3c0651 AC |
8926 | |
8927 | begin | |
8e1e62e3 AC |
8928 | -- Inspect the declarations of the related subprogram body looking |
8929 | -- for the first source declaration. | |
8930 | ||
8931 | if Present (Decls) then | |
8932 | Decl := First (Decls); | |
8933 | while Present (Decl) loop | |
8934 | if Comes_From_Source (Decl) then | |
8935 | Insert_Before (Decl, Stmt); | |
8936 | return; | |
8937 | end if; | |
8938 | ||
8939 | Next (Decl); | |
8940 | end loop; | |
8941 | ||
8942 | -- If we get there, then the subprogram body lacks any source | |
8943 | -- declarations. The body of _Postconditions now acts as the | |
8944 | -- last declaration. | |
8945 | ||
8946 | Append (Stmt, Decls); | |
8947 | ||
ea3c0651 AC |
8948 | -- Ensure that the body has a declaration list |
8949 | ||
8e1e62e3 AC |
8950 | else |
8951 | Set_Declarations (N, New_List (Stmt)); | |
ea3c0651 | 8952 | end if; |
8e1e62e3 | 8953 | end Insert_Before_First_Source_Declaration; |
ea3c0651 AC |
8954 | |
8955 | -- Local variables | |
8956 | ||
8957 | Loc : constant Source_Ptr := Sloc (N); | |
8958 | Params : List_Id := No_List; | |
8959 | Proc_Id : Entity_Id; | |
8960 | ||
8961 | -- Start of processing for Build_Postconditions_Procedure | |
8962 | ||
8963 | begin | |
8964 | -- Do not create the routine if no code is being generated | |
8965 | ||
8966 | if not Expander_Active then | |
8967 | return; | |
8968 | ||
8969 | -- Nothing to do if there are no actions to check on exit | |
8970 | ||
8971 | elsif No (Stmts) then | |
8972 | return; | |
8973 | end if; | |
8974 | ||
8975 | Proc_Id := Make_Defining_Identifier (Loc, Name_uPostconditions); | |
8976 | ||
8977 | -- The related subprogram is a function, create the specification of | |
8978 | -- parameter _Result. | |
8979 | ||
8980 | if Present (Result) then | |
8981 | Params := New_List ( | |
8982 | Make_Parameter_Specification (Loc, | |
8983 | Defining_Identifier => Result, | |
8984 | Parameter_Type => | |
8985 | New_Reference_To (Etype (Result), Loc))); | |
8986 | end if; | |
8987 | ||
8e1e62e3 AC |
8988 | -- Insert _Postconditions before the first source declaration of the |
8989 | -- body. This ensures that the body will not cause any premature | |
8990 | -- freezing as it may mention types: | |
ea3c0651 AC |
8991 | |
8992 | -- procedure Proc (Obj : Array_Typ) is | |
8993 | -- procedure _postconditions is | |
8994 | -- begin | |
8995 | -- ... Obj ... | |
8996 | -- end _postconditions; | |
8997 | ||
8998 | -- subtype T is Array_Typ (Obj'First (1) .. Obj'Last (1)); | |
8999 | -- begin | |
9000 | ||
9001 | -- In the example above, Obj is of type T but the incorrect placement | |
9002 | -- of _Postconditions will cause a crash in gigi due to an out of | |
9003 | -- order reference. The body of _Postconditions must be placed after | |
9004 | -- the declaration of Temp to preserve correct visibility. | |
9005 | ||
8e1e62e3 | 9006 | Insert_Before_First_Source_Declaration ( |
ea3c0651 AC |
9007 | Make_Subprogram_Body (Loc, |
9008 | Specification => | |
9009 | Make_Procedure_Specification (Loc, | |
9010 | Defining_Unit_Name => Proc_Id, | |
9011 | Parameter_Specifications => Params), | |
9012 | ||
9013 | Declarations => Empty_List, | |
9014 | Handled_Statement_Sequence => | |
9015 | Make_Handled_Sequence_Of_Statements (Loc, Stmts))); | |
9016 | ||
9017 | -- Set the attributes of the related subprogram to capture the | |
9018 | -- generated procedure. | |
9019 | ||
9020 | if Ekind_In (Subp_Id, E_Generic_Procedure, E_Procedure) then | |
9021 | Set_Postcondition_Proc (Subp_Id, Proc_Id); | |
9022 | end if; | |
9023 | ||
9024 | Set_Has_Postconditions (Subp_Id); | |
9025 | end Build_Postconditions_Procedure; | |
9026 | ||
9027 | ----------------------------------- | |
9028 | -- Build_Pragma_Check_Equivalent -- | |
9029 | ----------------------------------- | |
9030 | ||
9031 | function Build_Pragma_Check_Equivalent | |
9032 | (Prag : Node_Id; | |
9033 | Subp_Id : Entity_Id := Empty; | |
9034 | Inher_Id : Entity_Id := Empty) return Node_Id | |
9035 | is | |
9036 | Loc : constant Source_Ptr := Sloc (Prag); | |
9037 | Prag_Nam : constant Name_Id := Pragma_Name (Prag); | |
9038 | Check_Prag : Node_Id; | |
9039 | Formals_Map : Elist_Id; | |
9040 | Inher_Formal : Entity_Id; | |
9041 | Msg_Arg : Node_Id; | |
9042 | Nam : Name_Id; | |
9043 | Subp_Formal : Entity_Id; | |
9044 | ||
9045 | begin | |
9046 | Formals_Map := No_Elist; | |
9047 | ||
9048 | -- When the pre- or postcondition is inherited, map the formals of | |
9049 | -- the inherited subprogram to those of the current subprogram. | |
9050 | ||
9051 | if Present (Inher_Id) then | |
9052 | pragma Assert (Present (Subp_Id)); | |
9053 | ||
9054 | Formals_Map := New_Elmt_List; | |
9055 | ||
9056 | -- Create a relation <inherited formal> => <subprogram formal> | |
9057 | ||
9058 | Inher_Formal := First_Formal (Inher_Id); | |
9059 | Subp_Formal := First_Formal (Subp_Id); | |
9060 | while Present (Inher_Formal) and then Present (Subp_Formal) loop | |
9061 | Append_Elmt (Inher_Formal, Formals_Map); | |
9062 | Append_Elmt (Subp_Formal, Formals_Map); | |
9063 | ||
9064 | Next_Formal (Inher_Formal); | |
9065 | Next_Formal (Subp_Formal); | |
9066 | end loop; | |
9067 | end if; | |
9068 | ||
9069 | -- Copy the original pragma while performing substitutions (if | |
9070 | -- applicable). | |
9071 | ||
9072 | Check_Prag := | |
9073 | New_Copy_Tree | |
9074 | (Source => Prag, | |
9075 | Map => Formals_Map, | |
9076 | New_Scope => Current_Scope); | |
9077 | ||
9078 | -- Mark the pragma as being internally generated and reset the | |
9079 | -- Analyzed flag. | |
9080 | ||
9081 | Set_Comes_From_Source (Check_Prag, False); | |
9082 | Set_Analyzed (Check_Prag, False); | |
9083 | ||
9084 | -- For a postcondition pragma within a generic, preserve the pragma | |
9085 | -- for later expansion. This is also used when an error was detected, | |
9086 | -- thus setting Expander_Active to False. | |
9087 | ||
9088 | if Prag_Nam = Name_Postcondition and then not Expander_Active then | |
9089 | return Check_Prag; | |
9090 | end if; | |
9091 | ||
9092 | if Present (Corresponding_Aspect (Prag)) then | |
9093 | Nam := Chars (Identifier (Corresponding_Aspect (Prag))); | |
9094 | else | |
9095 | Nam := Prag_Nam; | |
9096 | end if; | |
9097 | ||
9098 | -- Convert the copy into pragma Check by correcting the name and | |
9099 | -- adding a check_kind argument. | |
9100 | ||
9101 | Set_Pragma_Identifier | |
9102 | (Check_Prag, Make_Identifier (Loc, Name_Check)); | |
9103 | ||
9104 | Prepend_To (Pragma_Argument_Associations (Check_Prag), | |
9105 | Make_Pragma_Argument_Association (Loc, | |
9106 | Expression => Make_Identifier (Loc, Nam))); | |
9107 | ||
9108 | -- Update the error message when the pragma is inherited | |
9109 | ||
9110 | if Present (Inher_Id) then | |
9111 | Msg_Arg := Last (Pragma_Argument_Associations (Check_Prag)); | |
9112 | ||
9113 | if Chars (Msg_Arg) = Name_Message then | |
9114 | String_To_Name_Buffer (Strval (Expression (Msg_Arg))); | |
9115 | ||
9116 | -- Insert "inherited" to improve the error message | |
9117 | ||
9118 | if Name_Buffer (1 .. 8) = "failed p" then | |
9119 | Insert_Str_In_Name_Buffer ("inherited ", 8); | |
9120 | Set_Strval (Expression (Msg_Arg), String_From_Name_Buffer); | |
9121 | end if; | |
9122 | end if; | |
9123 | end if; | |
9124 | ||
9125 | return Check_Prag; | |
9126 | end Build_Pragma_Check_Equivalent; | |
9127 | ||
9128 | --------------------------------- | |
9129 | -- Collect_Body_Postconditions -- | |
9130 | --------------------------------- | |
9131 | ||
9132 | procedure Collect_Body_Postconditions (Stmts : in out List_Id) is | |
9133 | procedure Collect_Body_Postconditions_Of_Kind (Post_Nam : Name_Id); | |
9134 | -- Process postconditions of a particular kind denoted by Post_Nam | |
9135 | ||
9136 | ----------------------------------------- | |
9137 | -- Collect_Body_Postconditions_Of_Kind -- | |
9138 | ----------------------------------------- | |
9139 | ||
9140 | procedure Collect_Body_Postconditions_Of_Kind (Post_Nam : Name_Id) is | |
9141 | Check_Prag : Node_Id; | |
9142 | Decl : Node_Id; | |
9143 | ||
9144 | begin | |
9145 | pragma Assert (Nam_In (Post_Nam, Name_Postcondition, | |
9146 | Name_Refined_Post)); | |
9147 | ||
9148 | -- Inspect the declarations of the subprogram body looking for a | |
9149 | -- pragma that matches the desired name. | |
9150 | ||
9151 | Decl := First (Declarations (N)); | |
9152 | while Present (Decl) loop | |
9153 | if Nkind (Decl) = N_Pragma then | |
9154 | if Pragma_Name (Decl) = Post_Nam then | |
9155 | Analyze (Decl); | |
9156 | Check_Prag := Build_Pragma_Check_Equivalent (Decl); | |
9157 | ||
9158 | if Expander_Active then | |
9159 | Append_Enabled_Item | |
9160 | (Item => Check_Prag, | |
9161 | List => Stmts); | |
9162 | ||
9163 | -- When analyzing a generic unit, save the pragma for | |
9164 | -- later. | |
9165 | ||
9166 | else | |
9167 | Prepend_To_Declarations (Check_Prag); | |
9168 | end if; | |
9169 | end if; | |
9170 | ||
9171 | -- Skip internally generated code | |
9172 | ||
9173 | elsif not Comes_From_Source (Decl) then | |
9174 | null; | |
9175 | ||
9176 | -- Postconditions in bodies are usually grouped at the top of | |
9177 | -- the declarations. There is no point in inspecting the whole | |
9178 | -- source list. | |
9179 | ||
9180 | else | |
9181 | exit; | |
9182 | end if; | |
9183 | ||
9184 | Next (Decl); | |
9185 | end loop; | |
9186 | end Collect_Body_Postconditions_Of_Kind; | |
9187 | ||
9188 | -- Start of processing for Collect_Body_Postconditions | |
9189 | ||
9190 | begin | |
9191 | Collect_Body_Postconditions_Of_Kind (Name_Refined_Post); | |
9192 | Collect_Body_Postconditions_Of_Kind (Name_Postcondition); | |
9193 | end Collect_Body_Postconditions; | |
9194 | ||
9195 | --------------------------------- | |
9196 | -- Collect_Spec_Postconditions -- | |
9197 | --------------------------------- | |
9198 | ||
9199 | procedure Collect_Spec_Postconditions | |
9200 | (Subp_Id : Entity_Id; | |
9201 | Stmts : in out List_Id) | |
9202 | is | |
9203 | Inher_Subps : constant Subprogram_List := | |
9204 | Inherited_Subprograms (Subp_Id); | |
9205 | Check_Prag : Node_Id; | |
9206 | Prag : Node_Id; | |
9207 | Inher_Subp_Id : Entity_Id; | |
9208 | ||
9209 | begin | |
9210 | -- Process the contract of the spec | |
9211 | ||
9212 | Prag := Pre_Post_Conditions (Contract (Subp_Id)); | |
9213 | while Present (Prag) loop | |
9214 | if Pragma_Name (Prag) = Name_Postcondition then | |
9215 | Check_Prag := Build_Pragma_Check_Equivalent (Prag); | |
9216 | ||
9217 | if Expander_Active then | |
9218 | Append_Enabled_Item | |
9219 | (Item => Check_Prag, | |
9220 | List => Stmts); | |
9221 | ||
9222 | -- When analyzing a generic unit, save the pragma for later | |
9223 | ||
9224 | else | |
9225 | Prepend_To_Declarations (Check_Prag); | |
9226 | end if; | |
9227 | end if; | |
9228 | ||
9229 | Prag := Next_Pragma (Prag); | |
9230 | end loop; | |
9231 | ||
9232 | -- Process the contracts of all inherited subprograms, looking for | |
9233 | -- class-wide postconditions. | |
9234 | ||
9235 | for Index in Inher_Subps'Range loop | |
9236 | Inher_Subp_Id := Inher_Subps (Index); | |
9237 | ||
9238 | Prag := Pre_Post_Conditions (Contract (Inher_Subp_Id)); | |
9239 | while Present (Prag) loop | |
9240 | if Pragma_Name (Prag) = Name_Postcondition | |
9241 | and then Class_Present (Prag) | |
9242 | then | |
9243 | Check_Prag := | |
9244 | Build_Pragma_Check_Equivalent | |
9245 | (Prag => Prag, | |
9246 | Subp_Id => Subp_Id, | |
9247 | Inher_Id => Inher_Subp_Id); | |
9248 | ||
9249 | if Expander_Active then | |
9250 | Append_Enabled_Item | |
9251 | (Item => Check_Prag, | |
9252 | List => Stmts); | |
9253 | ||
9254 | -- When analyzing a generic unit, save the pragma for later | |
9255 | ||
9256 | else | |
9257 | Prepend_To_Declarations (Check_Prag); | |
9258 | end if; | |
9259 | end if; | |
9260 | ||
9261 | Prag := Next_Pragma (Prag); | |
9262 | end loop; | |
9263 | end loop; | |
9264 | end Collect_Spec_Postconditions; | |
9265 | ||
9266 | -------------------------------- | |
9267 | -- Collect_Spec_Preconditions -- | |
9268 | -------------------------------- | |
9269 | ||
9270 | procedure Collect_Spec_Preconditions (Subp_Id : Entity_Id) is | |
9271 | procedure Merge_Preconditions (From : Node_Id; Into : Node_Id); | |
9272 | -- Merge two class-wide preconditions by "or else"-ing them. The | |
9273 | -- changes are accumulated in parameter Into. Update the error | |
9274 | -- message of Into. | |
9275 | ||
9276 | ------------------------- | |
9277 | -- Merge_Preconditions -- | |
9278 | ------------------------- | |
9279 | ||
9280 | procedure Merge_Preconditions (From : Node_Id; Into : Node_Id) is | |
9281 | function Expression_Arg (Prag : Node_Id) return Node_Id; | |
9282 | -- Return the boolean expression argument of a precondition while | |
9283 | -- updating its parenteses count for the subsequent merge. | |
9284 | ||
9285 | function Message_Arg (Prag : Node_Id) return Node_Id; | |
9286 | -- Return the message argument of a precondition | |
9287 | ||
9288 | -------------------- | |
9289 | -- Expression_Arg -- | |
9290 | -------------------- | |
9291 | ||
9292 | function Expression_Arg (Prag : Node_Id) return Node_Id is | |
9293 | Args : constant List_Id := Pragma_Argument_Associations (Prag); | |
9294 | Arg : constant Node_Id := Get_Pragma_Arg (Next (First (Args))); | |
9295 | ||
9296 | begin | |
9297 | if Paren_Count (Arg) = 0 then | |
9298 | Set_Paren_Count (Arg, 1); | |
9299 | end if; | |
9300 | ||
9301 | return Arg; | |
9302 | end Expression_Arg; | |
9303 | ||
9304 | ----------------- | |
9305 | -- Message_Arg -- | |
9306 | ----------------- | |
9307 | ||
9308 | function Message_Arg (Prag : Node_Id) return Node_Id is | |
9309 | Args : constant List_Id := Pragma_Argument_Associations (Prag); | |
9310 | begin | |
9311 | return Get_Pragma_Arg (Last (Args)); | |
9312 | end Message_Arg; | |
9313 | ||
9314 | -- Local variables | |
9315 | ||
9316 | From_Expr : constant Node_Id := Expression_Arg (From); | |
9317 | From_Msg : constant Node_Id := Message_Arg (From); | |
9318 | Into_Expr : constant Node_Id := Expression_Arg (Into); | |
9319 | Into_Msg : constant Node_Id := Message_Arg (Into); | |
9320 | Loc : constant Source_Ptr := Sloc (Into); | |
9321 | ||
9322 | -- Start of processing for Merge_Preconditions | |
9323 | ||
9324 | begin | |
9325 | -- Merge the two preconditions by "or else"-ing them | |
9326 | ||
9327 | Rewrite (Into_Expr, | |
9328 | Make_Or_Else (Loc, | |
9329 | Right_Opnd => Relocate_Node (Into_Expr), | |
9330 | Left_Opnd => From_Expr)); | |
9331 | ||
9332 | -- Merge the two error messages to produce a single message of the | |
9333 | -- form: | |
9334 | ||
9335 | -- failed precondition from ... | |
9336 | -- also failed inherited precondition from ... | |
9337 | ||
9338 | if not Exception_Locations_Suppressed then | |
9339 | Start_String (Strval (Into_Msg)); | |
9340 | Store_String_Char (ASCII.LF); | |
9341 | Store_String_Chars (" also "); | |
9342 | Store_String_Chars (Strval (From_Msg)); | |
9343 | ||
9344 | Set_Strval (Into_Msg, End_String); | |
9345 | end if; | |
9346 | end Merge_Preconditions; | |
9347 | ||
9348 | -- Local variables | |
9349 | ||
9350 | Inher_Subps : constant Subprogram_List := | |
9351 | Inherited_Subprograms (Subp_Id); | |
9352 | Check_Prag : Node_Id; | |
9353 | Class_Pre : Node_Id := Empty; | |
9354 | Inher_Subp_Id : Entity_Id; | |
9355 | Prag : Node_Id; | |
9356 | ||
9357 | -- Start of processing for Collect_Spec_Preconditions | |
9358 | ||
9359 | begin | |
9360 | -- Process the contract of the spec | |
9361 | ||
9362 | Prag := Pre_Post_Conditions (Contract (Subp_Id)); | |
9363 | while Present (Prag) loop | |
9364 | if Pragma_Name (Prag) = Name_Precondition then | |
9365 | Check_Prag := Build_Pragma_Check_Equivalent (Prag); | |
9366 | ||
9367 | -- Save the sole class-wide precondition (if any) for the next | |
9368 | -- step where it will be merged with inherited preconditions. | |
9369 | ||
9370 | if Class_Present (Prag) then | |
9371 | Class_Pre := Check_Prag; | |
9372 | ||
9373 | -- Accumulate the corresponding Check pragmas to the top of the | |
9374 | -- declarations. Prepending the items ensures that they will | |
9375 | -- be evaluated in their original order. | |
9376 | ||
9377 | else | |
9378 | Prepend_To_Declarations (Check_Prag); | |
9379 | end if; | |
9380 | end if; | |
9381 | ||
9382 | Prag := Next_Pragma (Prag); | |
9383 | end loop; | |
9384 | ||
9385 | -- Process the contracts of all inherited subprograms, looking for | |
9386 | -- class-wide preconditions. | |
9387 | ||
9388 | for Index in Inher_Subps'Range loop | |
9389 | Inher_Subp_Id := Inher_Subps (Index); | |
9390 | ||
9391 | Prag := Pre_Post_Conditions (Contract (Inher_Subp_Id)); | |
9392 | while Present (Prag) loop | |
9393 | if Pragma_Name (Prag) = Name_Precondition | |
9394 | and then Class_Present (Prag) | |
9395 | then | |
9396 | Check_Prag := | |
9397 | Build_Pragma_Check_Equivalent | |
9398 | (Prag => Prag, | |
9399 | Subp_Id => Subp_Id, | |
9400 | Inher_Id => Inher_Subp_Id); | |
9401 | ||
9402 | -- The spec or an inherited subprogram already yielded a | |
9403 | -- class-wide precondition. Merge the existing precondition | |
9404 | -- with the current one using "or else". | |
9405 | ||
9406 | if Present (Class_Pre) then | |
9407 | Merge_Preconditions (Check_Prag, Class_Pre); | |
9408 | else | |
9409 | Class_Pre := Check_Prag; | |
9410 | end if; | |
9411 | end if; | |
9412 | ||
9413 | Prag := Next_Pragma (Prag); | |
9414 | end loop; | |
9415 | end loop; | |
9416 | ||
9417 | -- Add the merged class-wide preconditions (if any) | |
9418 | ||
9419 | if Present (Class_Pre) then | |
9420 | Prepend_To_Declarations (Class_Pre); | |
9421 | end if; | |
9422 | end Collect_Spec_Preconditions; | |
9423 | ||
9424 | ----------------------------- | |
9425 | -- Prepend_To_Declarations -- | |
9426 | ----------------------------- | |
9427 | ||
9428 | procedure Prepend_To_Declarations (Item : Node_Id) is | |
9429 | Decls : List_Id := Declarations (N); | |
9430 | ||
9431 | begin | |
9432 | -- Ensure that the body has a declarative list | |
9433 | ||
9434 | if No (Decls) then | |
9435 | Decls := New_List; | |
9436 | Set_Declarations (N, Decls); | |
9437 | end if; | |
9438 | ||
9439 | Prepend_To (Decls, Item); | |
9440 | end Prepend_To_Declarations; | |
9441 | ||
9442 | ---------------------------- | |
9443 | -- Process_Contract_Cases -- | |
9444 | ---------------------------- | |
9445 | ||
9446 | procedure Process_Contract_Cases | |
9447 | (Subp_Id : Entity_Id; | |
9448 | Stmts : in out List_Id) | |
9449 | is | |
9450 | Prag : Node_Id; | |
9451 | ||
9452 | begin | |
9453 | -- Do not build the Contract_Cases circuitry if no code is being | |
9454 | -- generated. | |
9455 | ||
9456 | if not Expander_Active then | |
3cd4a210 | 9457 | return; |
ea3c0651 AC |
9458 | end if; |
9459 | ||
9460 | Prag := Contract_Test_Cases (Contract (Subp_Id)); | |
9461 | while Present (Prag) loop | |
9462 | if Pragma_Name (Prag) = Name_Contract_Cases then | |
9463 | Expand_Contract_Cases | |
9464 | (CCs => Prag, | |
9465 | Subp_Id => Subp_Id, | |
9466 | Decls => Declarations (N), | |
9467 | Stmts => Stmts); | |
9468 | end if; | |
9469 | ||
9470 | Prag := Next_Pragma (Prag); | |
9471 | end loop; | |
9472 | end Process_Contract_Cases; | |
9473 | ||
9474 | -- Local variables | |
9475 | ||
9476 | Post_Stmts : List_Id := No_List; | |
9477 | Result : Entity_Id; | |
9478 | Subp_Id : Entity_Id; | |
9479 | ||
9480 | -- Start of processing for Expand_Subprogram_Contract | |
9481 | ||
9482 | begin | |
9483 | if Present (Spec_Id) then | |
9484 | Subp_Id := Spec_Id; | |
9485 | else | |
9486 | Subp_Id := Body_Id; | |
9487 | end if; | |
9488 | ||
9489 | -- Do not process a predicate function as its body will end up with a | |
9490 | -- recursive call to itself and blow up the stack. | |
9491 | ||
9492 | if Ekind (Subp_Id) = E_Function | |
9493 | and then Is_Predicate_Function (Subp_Id) | |
9494 | then | |
9495 | return; | |
9496 | ||
9497 | -- Do not process TSS subprograms | |
9498 | ||
9499 | elsif Get_TSS_Name (Subp_Id) /= TSS_Null then | |
9500 | return; | |
9501 | end if; | |
9502 | ||
9503 | -- The expansion of a subprogram contract involves the relocation of | |
9504 | -- various contract assertions to the declarations of the body in a | |
9505 | -- particular order. The order is as follows: | |
9506 | ||
9507 | -- function Example (...) return ... is | |
9508 | -- procedure _Postconditions (...) is | |
9509 | -- begin | |
9510 | -- <refined postconditions from body> | |
9511 | -- <postconditions from body> | |
9512 | -- <postconditions from spec> | |
9513 | -- <inherited postconditions> | |
f1bd0415 | 9514 | -- <contract case consequences> |
ea3c0651 AC |
9515 | -- <invariant check of function result (if applicable)> |
9516 | -- <invariant and predicate checks of parameters> | |
9517 | -- end _Postconditions; | |
9518 | ||
9519 | -- <inherited preconditions> | |
9520 | -- <preconditions from spec> | |
9521 | -- <preconditions from body> | |
9522 | -- <refined preconditions from body> | |
f1bd0415 | 9523 | -- <contract case conditions> |
ea3c0651 AC |
9524 | |
9525 | -- <source declarations> | |
9526 | -- begin | |
9527 | -- <source statements> | |
9528 | ||
9529 | -- _Preconditions (Result); | |
9530 | -- return Result; | |
9531 | -- end Example; | |
9532 | ||
9533 | -- Routine _Postconditions holds all contract assertions that must be | |
9534 | -- verified on exit from the related routine. | |
9535 | ||
9536 | -- Collect all [inherited] preconditions from the spec, transform them | |
9537 | -- into Check pragmas and add them to the declarations of the body in | |
9538 | -- the order outlined above. | |
9539 | ||
9540 | if Present (Spec_Id) then | |
9541 | Collect_Spec_Preconditions (Spec_Id); | |
9542 | end if; | |
9543 | ||
9544 | -- Transform all [refined] postconditions of the body into Check | |
9545 | -- pragmas. The resulting pragmas are accumulated in list Post_Stmts. | |
9546 | ||
9547 | Collect_Body_Postconditions (Post_Stmts); | |
9548 | ||
9549 | -- Transform all [inherited] postconditions from the spec into Check | |
9550 | -- pragmas. The resulting pragmas are accumulated in list Post_Stmts. | |
9551 | ||
9552 | if Present (Spec_Id) then | |
9553 | Collect_Spec_Postconditions (Spec_Id, Post_Stmts); | |
9554 | ||
9555 | -- Transform pragma Contract_Cases from the spec into its circuitry | |
9556 | ||
9557 | Process_Contract_Cases (Spec_Id, Post_Stmts); | |
9558 | end if; | |
9559 | ||
9560 | -- Apply invariant and predicate checks on the result of a function (if | |
9561 | -- applicable) and all formals. The resulting checks are accumulated in | |
9562 | -- list Post_Stmts. | |
9563 | ||
9564 | Add_Invariant_And_Predicate_Checks (Subp_Id, Post_Stmts, Result); | |
9565 | ||
9566 | -- Construct procedure _Postconditions | |
9567 | ||
9568 | Build_Postconditions_Procedure (Subp_Id, Post_Stmts, Result); | |
9569 | end Expand_Subprogram_Contract; | |
9570 | ||
02822a92 RD |
9571 | -------------------------------- |
9572 | -- Is_Build_In_Place_Function -- | |
9573 | -------------------------------- | |
70482933 | 9574 | |
02822a92 RD |
9575 | function Is_Build_In_Place_Function (E : Entity_Id) return Boolean is |
9576 | begin | |
5087048c AC |
9577 | -- This function is called from Expand_Subtype_From_Expr during |
9578 | -- semantic analysis, even when expansion is off. In those cases | |
9579 | -- the build_in_place expansion will not take place. | |
b0256cb6 AC |
9580 | |
9581 | if not Expander_Active then | |
9582 | return False; | |
9583 | end if; | |
9584 | ||
02822a92 | 9585 | -- For now we test whether E denotes a function or access-to-function |
5b6f12c7 AC |
9586 | -- type whose result subtype is inherently limited. Later this test |
9587 | -- may be revised to allow composite nonlimited types. Functions with | |
9588 | -- a foreign convention or whose result type has a foreign convention | |
02822a92 RD |
9589 | -- never qualify. |
9590 | ||
b29def53 | 9591 | if Ekind_In (E, E_Function, E_Generic_Function) |
02822a92 RD |
9592 | or else (Ekind (E) = E_Subprogram_Type |
9593 | and then Etype (E) /= Standard_Void_Type) | |
9594 | then | |
f937473f RD |
9595 | -- Note: If you have Convention (C) on an inherently limited type, |
9596 | -- you're on your own. That is, the C code will have to be carefully | |
9597 | -- written to know about the Ada conventions. | |
9598 | ||
02822a92 RD |
9599 | if Has_Foreign_Convention (E) |
9600 | or else Has_Foreign_Convention (Etype (E)) | |
3ca505dc | 9601 | then |
02822a92 | 9602 | return False; |
c8ef728f | 9603 | |
2a31c32b AC |
9604 | -- In Ada 2005 all functions with an inherently limited return type |
9605 | -- must be handled using a build-in-place profile, including the case | |
9606 | -- of a function with a limited interface result, where the function | |
9607 | -- may return objects of nonlimited descendants. | |
7888a6ae | 9608 | |
02822a92 | 9609 | else |
51245e2d | 9610 | return Is_Limited_View (Etype (E)) |
0791fbe9 | 9611 | and then Ada_Version >= Ada_2005 |
f937473f | 9612 | and then not Debug_Flag_Dot_L; |
c8ef728f ES |
9613 | end if; |
9614 | ||
02822a92 RD |
9615 | else |
9616 | return False; | |
9617 | end if; | |
9618 | end Is_Build_In_Place_Function; | |
f4d379b8 | 9619 | |
02822a92 RD |
9620 | ------------------------------------- |
9621 | -- Is_Build_In_Place_Function_Call -- | |
9622 | ------------------------------------- | |
f4d379b8 | 9623 | |
02822a92 RD |
9624 | function Is_Build_In_Place_Function_Call (N : Node_Id) return Boolean is |
9625 | Exp_Node : Node_Id := N; | |
9626 | Function_Id : Entity_Id; | |
f4d379b8 | 9627 | |
02822a92 | 9628 | begin |
5b6f12c7 AC |
9629 | -- Return False if the expander is currently inactive, since awareness |
9630 | -- of build-in-place treatment is only relevant during expansion. Note | |
9631 | -- that Is_Build_In_Place_Function, which is called as part of this | |
9632 | -- function, is also conditioned this way, but we need to check here as | |
9633 | -- well to avoid blowing up on processing protected calls when expansion | |
9634 | -- is disabled (such as with -gnatc) since those would trip over the | |
9635 | -- raise of Program_Error below. | |
c6d5d1ac | 9636 | |
5114f3ff AC |
9637 | -- In SPARK mode, build-in-place calls are not expanded, so that we |
9638 | -- may end up with a call that is neither resolved to an entity, nor | |
9639 | -- an indirect call. | |
9640 | ||
4460a9bc | 9641 | if not Expander_Active then |
c6d5d1ac AC |
9642 | return False; |
9643 | end if; | |
9644 | ||
19590d70 GD |
9645 | -- Step past qualification or unchecked conversion (the latter can occur |
9646 | -- in cases of calls to 'Input). | |
9647 | ||
94bbf008 AC |
9648 | if Nkind_In (Exp_Node, N_Qualified_Expression, |
9649 | N_Unchecked_Type_Conversion) | |
19590d70 | 9650 | then |
02822a92 RD |
9651 | Exp_Node := Expression (N); |
9652 | end if; | |
758c442c | 9653 | |
02822a92 RD |
9654 | if Nkind (Exp_Node) /= N_Function_Call then |
9655 | return False; | |
3ca505dc | 9656 | |
02822a92 | 9657 | else |
5114f3ff | 9658 | if Is_Entity_Name (Name (Exp_Node)) then |
02822a92 | 9659 | Function_Id := Entity (Name (Exp_Node)); |
758c442c | 9660 | |
94bbf008 AC |
9661 | -- In the case of an explicitly dereferenced call, use the subprogram |
9662 | -- type generated for the dereference. | |
9663 | ||
02822a92 RD |
9664 | elsif Nkind (Name (Exp_Node)) = N_Explicit_Dereference then |
9665 | Function_Id := Etype (Name (Exp_Node)); | |
2ba1a7c7 | 9666 | |
0812b84e AC |
9667 | -- This may be a call to a protected function. |
9668 | ||
9669 | elsif Nkind (Name (Exp_Node)) = N_Selected_Component then | |
9670 | Function_Id := Etype (Entity (Selector_Name (Name (Exp_Node)))); | |
9671 | ||
2ba1a7c7 AC |
9672 | else |
9673 | raise Program_Error; | |
02822a92 | 9674 | end if; |
758c442c | 9675 | |
02822a92 RD |
9676 | return Is_Build_In_Place_Function (Function_Id); |
9677 | end if; | |
9678 | end Is_Build_In_Place_Function_Call; | |
758c442c | 9679 | |
02822a92 RD |
9680 | ----------------------- |
9681 | -- Freeze_Subprogram -- | |
9682 | ----------------------- | |
758c442c | 9683 | |
02822a92 RD |
9684 | procedure Freeze_Subprogram (N : Node_Id) is |
9685 | Loc : constant Source_Ptr := Sloc (N); | |
3ca505dc | 9686 | |
02822a92 RD |
9687 | procedure Register_Predefined_DT_Entry (Prim : Entity_Id); |
9688 | -- (Ada 2005): Register a predefined primitive in all the secondary | |
9689 | -- dispatch tables of its primitive type. | |
3ca505dc | 9690 | |
f4d379b8 HK |
9691 | ---------------------------------- |
9692 | -- Register_Predefined_DT_Entry -- | |
9693 | ---------------------------------- | |
9694 | ||
9695 | procedure Register_Predefined_DT_Entry (Prim : Entity_Id) is | |
9696 | Iface_DT_Ptr : Elmt_Id; | |
02822a92 | 9697 | Tagged_Typ : Entity_Id; |
f4d379b8 | 9698 | Thunk_Id : Entity_Id; |
7888a6ae | 9699 | Thunk_Code : Node_Id; |
f4d379b8 HK |
9700 | |
9701 | begin | |
02822a92 | 9702 | Tagged_Typ := Find_Dispatching_Type (Prim); |
f4d379b8 | 9703 | |
02822a92 | 9704 | if No (Access_Disp_Table (Tagged_Typ)) |
ce2b6ba5 | 9705 | or else not Has_Interfaces (Tagged_Typ) |
c8ef728f | 9706 | or else not RTE_Available (RE_Interface_Tag) |
f937473f | 9707 | or else Restriction_Active (No_Dispatching_Calls) |
f4d379b8 HK |
9708 | then |
9709 | return; | |
9710 | end if; | |
9711 | ||
1923d2d6 JM |
9712 | -- Skip the first two access-to-dispatch-table pointers since they |
9713 | -- leads to the primary dispatch table (predefined DT and user | |
9714 | -- defined DT). We are only concerned with the secondary dispatch | |
9715 | -- table pointers. Note that the access-to- dispatch-table pointer | |
9716 | -- corresponds to the first implemented interface retrieved below. | |
f4d379b8 | 9717 | |
02822a92 | 9718 | Iface_DT_Ptr := |
1923d2d6 | 9719 | Next_Elmt (Next_Elmt (First_Elmt (Access_Disp_Table (Tagged_Typ)))); |
f937473f | 9720 | |
7888a6ae | 9721 | while Present (Iface_DT_Ptr) |
df3e68b1 | 9722 | and then Ekind (Node (Iface_DT_Ptr)) = E_Constant |
7888a6ae | 9723 | loop |
ac4d6407 | 9724 | pragma Assert (Has_Thunks (Node (Iface_DT_Ptr))); |
d766cee3 | 9725 | Expand_Interface_Thunk (Prim, Thunk_Id, Thunk_Code); |
7888a6ae GD |
9726 | |
9727 | if Present (Thunk_Code) then | |
ac4d6407 | 9728 | Insert_Actions_After (N, New_List ( |
7888a6ae GD |
9729 | Thunk_Code, |
9730 | ||
9731 | Build_Set_Predefined_Prim_Op_Address (Loc, | |
54bf19e4 | 9732 | Tag_Node => |
1923d2d6 | 9733 | New_Reference_To (Node (Next_Elmt (Iface_DT_Ptr)), Loc), |
54bf19e4 | 9734 | Position => DT_Position (Prim), |
7888a6ae | 9735 | Address_Node => |
70f91180 | 9736 | Unchecked_Convert_To (RTE (RE_Prim_Ptr), |
1923d2d6 JM |
9737 | Make_Attribute_Reference (Loc, |
9738 | Prefix => New_Reference_To (Thunk_Id, Loc), | |
9739 | Attribute_Name => Name_Unrestricted_Access))), | |
ac4d6407 RD |
9740 | |
9741 | Build_Set_Predefined_Prim_Op_Address (Loc, | |
54bf19e4 | 9742 | Tag_Node => |
1923d2d6 JM |
9743 | New_Reference_To |
9744 | (Node (Next_Elmt (Next_Elmt (Next_Elmt (Iface_DT_Ptr)))), | |
9745 | Loc), | |
54bf19e4 | 9746 | Position => DT_Position (Prim), |
ac4d6407 | 9747 | Address_Node => |
70f91180 | 9748 | Unchecked_Convert_To (RTE (RE_Prim_Ptr), |
1923d2d6 JM |
9749 | Make_Attribute_Reference (Loc, |
9750 | Prefix => New_Reference_To (Prim, Loc), | |
9751 | Attribute_Name => Name_Unrestricted_Access))))); | |
7888a6ae | 9752 | end if; |
f4d379b8 | 9753 | |
1923d2d6 JM |
9754 | -- Skip the tag of the predefined primitives dispatch table |
9755 | ||
9756 | Next_Elmt (Iface_DT_Ptr); | |
9757 | pragma Assert (Has_Thunks (Node (Iface_DT_Ptr))); | |
9758 | ||
54bf19e4 | 9759 | -- Skip tag of the no-thunks dispatch table |
1923d2d6 JM |
9760 | |
9761 | Next_Elmt (Iface_DT_Ptr); | |
9762 | pragma Assert (not Has_Thunks (Node (Iface_DT_Ptr))); | |
9763 | ||
54bf19e4 | 9764 | -- Skip tag of predefined primitives no-thunks dispatch table |
1923d2d6 | 9765 | |
ac4d6407 RD |
9766 | Next_Elmt (Iface_DT_Ptr); |
9767 | pragma Assert (not Has_Thunks (Node (Iface_DT_Ptr))); | |
9768 | ||
f4d379b8 | 9769 | Next_Elmt (Iface_DT_Ptr); |
f4d379b8 HK |
9770 | end loop; |
9771 | end Register_Predefined_DT_Entry; | |
9772 | ||
7888a6ae | 9773 | -- Local variables |
3ca505dc | 9774 | |
df3e68b1 | 9775 | Subp : constant Entity_Id := Entity (N); |
3ca505dc | 9776 | |
ac4d6407 RD |
9777 | -- Start of processing for Freeze_Subprogram |
9778 | ||
7888a6ae | 9779 | begin |
d766cee3 RD |
9780 | -- We suppress the initialization of the dispatch table entry when |
9781 | -- VM_Target because the dispatching mechanism is handled internally | |
9782 | -- by the VM. | |
9783 | ||
9784 | if Is_Dispatching_Operation (Subp) | |
9785 | and then not Is_Abstract_Subprogram (Subp) | |
9786 | and then Present (DTC_Entity (Subp)) | |
9787 | and then Present (Scope (DTC_Entity (Subp))) | |
1f110335 | 9788 | and then Tagged_Type_Expansion |
d766cee3 RD |
9789 | and then not Restriction_Active (No_Dispatching_Calls) |
9790 | and then RTE_Available (RE_Tag) | |
9791 | then | |
7888a6ae | 9792 | declare |
d766cee3 | 9793 | Typ : constant Entity_Id := Scope (DTC_Entity (Subp)); |
c8ef728f | 9794 | |
7888a6ae | 9795 | begin |
8fc789c8 | 9796 | -- Handle private overridden primitives |
c8ef728f | 9797 | |
d766cee3 RD |
9798 | if not Is_CPP_Class (Typ) then |
9799 | Check_Overriding_Operation (Subp); | |
7888a6ae | 9800 | end if; |
c8ef728f | 9801 | |
d766cee3 RD |
9802 | -- We assume that imported CPP primitives correspond with objects |
9803 | -- whose constructor is in the CPP side; therefore we don't need | |
9804 | -- to generate code to register them in the dispatch table. | |
c8ef728f | 9805 | |
d766cee3 RD |
9806 | if Is_CPP_Class (Typ) then |
9807 | null; | |
3ca505dc | 9808 | |
d766cee3 RD |
9809 | -- Handle CPP primitives found in derivations of CPP_Class types. |
9810 | -- These primitives must have been inherited from some parent, and | |
9811 | -- there is no need to register them in the dispatch table because | |
5b6f12c7 | 9812 | -- Build_Inherit_Prims takes care of initializing these slots. |
3ca505dc | 9813 | |
d766cee3 | 9814 | elsif Is_Imported (Subp) |
54bf19e4 AC |
9815 | and then (Convention (Subp) = Convention_CPP |
9816 | or else Convention (Subp) = Convention_C) | |
d766cee3 RD |
9817 | then |
9818 | null; | |
9819 | ||
9820 | -- Generate code to register the primitive in non statically | |
9821 | -- allocated dispatch tables | |
9822 | ||
bfae1846 AC |
9823 | elsif not Building_Static_DT (Scope (DTC_Entity (Subp))) then |
9824 | ||
d766cee3 RD |
9825 | -- When a primitive is frozen, enter its name in its dispatch |
9826 | -- table slot. | |
f4d379b8 | 9827 | |
d766cee3 | 9828 | if not Is_Interface (Typ) |
ce2b6ba5 | 9829 | or else Present (Interface_Alias (Subp)) |
d766cee3 RD |
9830 | then |
9831 | if Is_Predefined_Dispatching_Operation (Subp) then | |
9832 | Register_Predefined_DT_Entry (Subp); | |
7888a6ae | 9833 | end if; |
d766cee3 | 9834 | |
991395ab AC |
9835 | Insert_Actions_After (N, |
9836 | Register_Primitive (Loc, Prim => Subp)); | |
7888a6ae GD |
9837 | end if; |
9838 | end if; | |
9839 | end; | |
70482933 RK |
9840 | end if; |
9841 | ||
7888a6ae GD |
9842 | -- Mark functions that return by reference. Note that it cannot be part |
9843 | -- of the normal semantic analysis of the spec since the underlying | |
9844 | -- returned type may not be known yet (for private types). | |
70482933 | 9845 | |
d766cee3 RD |
9846 | declare |
9847 | Typ : constant Entity_Id := Etype (Subp); | |
9848 | Utyp : constant Entity_Id := Underlying_Type (Typ); | |
9849 | begin | |
51245e2d | 9850 | if Is_Limited_View (Typ) then |
d766cee3 | 9851 | Set_Returns_By_Ref (Subp); |
048e5cef | 9852 | elsif Present (Utyp) and then CW_Or_Has_Controlled_Part (Utyp) then |
d766cee3 RD |
9853 | Set_Returns_By_Ref (Subp); |
9854 | end if; | |
9855 | end; | |
b546e2a7 AC |
9856 | |
9857 | -- Wnen freezing a null procedure, analyze its delayed aspects now | |
9858 | -- because we may not have reached the end of the declarative list when | |
9859 | -- delayed aspects are normally analyzed. This ensures that dispatching | |
9860 | -- calls are properly rewritten when the generated _Postcondition | |
9861 | -- procedure is analyzed in the null procedure body. | |
9862 | ||
9863 | if Nkind (Parent (Subp)) = N_Procedure_Specification | |
9864 | and then Null_Present (Parent (Subp)) | |
9865 | then | |
5afe5d2d | 9866 | Analyze_Subprogram_Contract (Subp); |
b546e2a7 | 9867 | end if; |
70482933 RK |
9868 | end Freeze_Subprogram; |
9869 | ||
8dbf3473 AC |
9870 | ----------------------- |
9871 | -- Is_Null_Procedure -- | |
9872 | ----------------------- | |
9873 | ||
9874 | function Is_Null_Procedure (Subp : Entity_Id) return Boolean is | |
9875 | Decl : constant Node_Id := Unit_Declaration_Node (Subp); | |
9876 | ||
9877 | begin | |
9878 | if Ekind (Subp) /= E_Procedure then | |
9879 | return False; | |
9880 | ||
9881 | -- Check if this is a declared null procedure | |
9882 | ||
9883 | elsif Nkind (Decl) = N_Subprogram_Declaration then | |
e1f3cb58 AC |
9884 | if not Null_Present (Specification (Decl)) then |
9885 | return False; | |
8dbf3473 AC |
9886 | |
9887 | elsif No (Body_To_Inline (Decl)) then | |
9888 | return False; | |
9889 | ||
9890 | -- Check if the body contains only a null statement, followed by | |
9891 | -- the return statement added during expansion. | |
9892 | ||
9893 | else | |
9894 | declare | |
9895 | Orig_Bod : constant Node_Id := Body_To_Inline (Decl); | |
9896 | ||
9897 | Stat : Node_Id; | |
9898 | Stat2 : Node_Id; | |
9899 | ||
9900 | begin | |
9901 | if Nkind (Orig_Bod) /= N_Subprogram_Body then | |
9902 | return False; | |
9903 | else | |
327503f1 JM |
9904 | -- We must skip SCIL nodes because they are currently |
9905 | -- implemented as special N_Null_Statement nodes. | |
9906 | ||
8dbf3473 | 9907 | Stat := |
327503f1 | 9908 | First_Non_SCIL_Node |
8dbf3473 | 9909 | (Statements (Handled_Statement_Sequence (Orig_Bod))); |
327503f1 | 9910 | Stat2 := Next_Non_SCIL_Node (Stat); |
8dbf3473 AC |
9911 | |
9912 | return | |
e1f3cb58 AC |
9913 | Is_Empty_List (Declarations (Orig_Bod)) |
9914 | and then Nkind (Stat) = N_Null_Statement | |
9915 | and then | |
8dbf3473 AC |
9916 | (No (Stat2) |
9917 | or else | |
9918 | (Nkind (Stat2) = N_Simple_Return_Statement | |
9919 | and then No (Next (Stat2)))); | |
9920 | end if; | |
9921 | end; | |
9922 | end if; | |
9923 | ||
9924 | else | |
9925 | return False; | |
9926 | end if; | |
9927 | end Is_Null_Procedure; | |
9928 | ||
02822a92 RD |
9929 | ------------------------------------------- |
9930 | -- Make_Build_In_Place_Call_In_Allocator -- | |
9931 | ------------------------------------------- | |
9932 | ||
9933 | procedure Make_Build_In_Place_Call_In_Allocator | |
9934 | (Allocator : Node_Id; | |
9935 | Function_Call : Node_Id) | |
9936 | is | |
94bbf008 | 9937 | Acc_Type : constant Entity_Id := Etype (Allocator); |
02822a92 RD |
9938 | Loc : Source_Ptr; |
9939 | Func_Call : Node_Id := Function_Call; | |
9940 | Function_Id : Entity_Id; | |
9941 | Result_Subt : Entity_Id; | |
02822a92 RD |
9942 | New_Allocator : Node_Id; |
9943 | Return_Obj_Access : Entity_Id; | |
9944 | ||
9945 | begin | |
19590d70 GD |
9946 | -- Step past qualification or unchecked conversion (the latter can occur |
9947 | -- in cases of calls to 'Input). | |
9948 | ||
ac4d6407 RD |
9949 | if Nkind_In (Func_Call, |
9950 | N_Qualified_Expression, | |
9951 | N_Unchecked_Type_Conversion) | |
19590d70 | 9952 | then |
02822a92 RD |
9953 | Func_Call := Expression (Func_Call); |
9954 | end if; | |
9955 | ||
fdce4bb7 JM |
9956 | -- If the call has already been processed to add build-in-place actuals |
9957 | -- then return. This should not normally occur in an allocator context, | |
9958 | -- but we add the protection as a defensive measure. | |
9959 | ||
9960 | if Is_Expanded_Build_In_Place_Call (Func_Call) then | |
9961 | return; | |
9962 | end if; | |
9963 | ||
9964 | -- Mark the call as processed as a build-in-place call | |
9965 | ||
9966 | Set_Is_Expanded_Build_In_Place_Call (Func_Call); | |
9967 | ||
02822a92 RD |
9968 | Loc := Sloc (Function_Call); |
9969 | ||
9970 | if Is_Entity_Name (Name (Func_Call)) then | |
9971 | Function_Id := Entity (Name (Func_Call)); | |
9972 | ||
9973 | elsif Nkind (Name (Func_Call)) = N_Explicit_Dereference then | |
9974 | Function_Id := Etype (Name (Func_Call)); | |
9975 | ||
9976 | else | |
9977 | raise Program_Error; | |
9978 | end if; | |
9979 | ||
94bbf008 | 9980 | Result_Subt := Available_View (Etype (Function_Id)); |
02822a92 | 9981 | |
0d566e01 ES |
9982 | -- Check whether return type includes tasks. This may not have been done |
9983 | -- previously, if the type was a limited view. | |
9984 | ||
9985 | if Has_Task (Result_Subt) then | |
9986 | Build_Activation_Chain_Entity (Allocator); | |
9987 | end if; | |
9988 | ||
f937473f RD |
9989 | -- When the result subtype is constrained, the return object must be |
9990 | -- allocated on the caller side, and access to it is passed to the | |
9991 | -- function. | |
02822a92 | 9992 | |
7888a6ae GD |
9993 | -- Here and in related routines, we must examine the full view of the |
9994 | -- type, because the view at the point of call may differ from that | |
9995 | -- that in the function body, and the expansion mechanism depends on | |
9996 | -- the characteristics of the full view. | |
9997 | ||
9998 | if Is_Constrained (Underlying_Type (Result_Subt)) then | |
02822a92 | 9999 | |
f937473f RD |
10000 | -- Replace the initialized allocator of form "new T'(Func (...))" |
10001 | -- with an uninitialized allocator of form "new T", where T is the | |
10002 | -- result subtype of the called function. The call to the function | |
10003 | -- is handled separately further below. | |
02822a92 | 10004 | |
f937473f | 10005 | New_Allocator := |
fad0600d AC |
10006 | Make_Allocator (Loc, |
10007 | Expression => New_Reference_To (Result_Subt, Loc)); | |
10008 | Set_No_Initialization (New_Allocator); | |
10009 | ||
10010 | -- Copy attributes to new allocator. Note that the new allocator | |
10011 | -- logically comes from source if the original one did, so copy the | |
10012 | -- relevant flag. This ensures proper treatment of the restriction | |
10013 | -- No_Implicit_Heap_Allocations in this case. | |
02822a92 | 10014 | |
fad0600d | 10015 | Set_Storage_Pool (New_Allocator, Storage_Pool (Allocator)); |
f937473f | 10016 | Set_Procedure_To_Call (New_Allocator, Procedure_To_Call (Allocator)); |
fad0600d | 10017 | Set_Comes_From_Source (New_Allocator, Comes_From_Source (Allocator)); |
02822a92 | 10018 | |
f937473f | 10019 | Rewrite (Allocator, New_Allocator); |
02822a92 | 10020 | |
f937473f | 10021 | -- Create a new access object and initialize it to the result of the |
b0b7b57d | 10022 | -- new uninitialized allocator. Note: we do not use Allocator as the |
f104fca1 AC |
10023 | -- Related_Node of Return_Obj_Access in call to Make_Temporary below |
10024 | -- as this would create a sort of infinite "recursion". | |
02822a92 | 10025 | |
f104fca1 | 10026 | Return_Obj_Access := Make_Temporary (Loc, 'R'); |
f937473f RD |
10027 | Set_Etype (Return_Obj_Access, Acc_Type); |
10028 | ||
10029 | Insert_Action (Allocator, | |
10030 | Make_Object_Declaration (Loc, | |
10031 | Defining_Identifier => Return_Obj_Access, | |
10032 | Object_Definition => New_Reference_To (Acc_Type, Loc), | |
10033 | Expression => Relocate_Node (Allocator))); | |
10034 | ||
7888a6ae GD |
10035 | -- When the function has a controlling result, an allocation-form |
10036 | -- parameter must be passed indicating that the caller is allocating | |
10037 | -- the result object. This is needed because such a function can be | |
10038 | -- called as a dispatching operation and must be treated similarly | |
10039 | -- to functions with unconstrained result subtypes. | |
10040 | ||
200b7162 | 10041 | Add_Unconstrained_Actuals_To_Build_In_Place_Call |
7888a6ae GD |
10042 | (Func_Call, Function_Id, Alloc_Form => Caller_Allocation); |
10043 | ||
d3f70b35 | 10044 | Add_Finalization_Master_Actual_To_Build_In_Place_Call |
7888a6ae GD |
10045 | (Func_Call, Function_Id, Acc_Type); |
10046 | ||
10047 | Add_Task_Actuals_To_Build_In_Place_Call | |
10048 | (Func_Call, Function_Id, Master_Actual => Master_Id (Acc_Type)); | |
10049 | ||
f937473f RD |
10050 | -- Add an implicit actual to the function call that provides access |
10051 | -- to the allocated object. An unchecked conversion to the (specific) | |
10052 | -- result subtype of the function is inserted to handle cases where | |
10053 | -- the access type of the allocator has a class-wide designated type. | |
10054 | ||
f937473f RD |
10055 | Add_Access_Actual_To_Build_In_Place_Call |
10056 | (Func_Call, | |
10057 | Function_Id, | |
10058 | Make_Unchecked_Type_Conversion (Loc, | |
10059 | Subtype_Mark => New_Reference_To (Result_Subt, Loc), | |
10060 | Expression => | |
10061 | Make_Explicit_Dereference (Loc, | |
10062 | Prefix => New_Reference_To (Return_Obj_Access, Loc)))); | |
10063 | ||
10064 | -- When the result subtype is unconstrained, the function itself must | |
10065 | -- perform the allocation of the return object, so we pass parameters | |
10066 | -- indicating that. We don't yet handle the case where the allocation | |
10067 | -- must be done in a user-defined storage pool, which will require | |
10068 | -- passing another actual or two to provide allocation/deallocation | |
10069 | -- operations. ??? | |
10070 | ||
10071 | else | |
8417f4b2 AC |
10072 | -- Case of a user-defined storage pool. Pass an allocation parameter |
10073 | -- indicating that the function should allocate its result in the | |
10074 | -- pool, and pass the pool. Use 'Unrestricted_Access because the | |
10075 | -- pool may not be aliased. | |
200b7162 | 10076 | |
8417f4b2 AC |
10077 | if VM_Target = No_VM |
10078 | and then Present (Associated_Storage_Pool (Acc_Type)) | |
10079 | then | |
200b7162 BD |
10080 | Add_Unconstrained_Actuals_To_Build_In_Place_Call |
10081 | (Func_Call, Function_Id, Alloc_Form => User_Storage_Pool, | |
10082 | Pool_Actual => | |
10083 | Make_Attribute_Reference (Loc, | |
10084 | Prefix => | |
10085 | New_Reference_To | |
10086 | (Associated_Storage_Pool (Acc_Type), Loc), | |
10087 | Attribute_Name => Name_Unrestricted_Access)); | |
8417f4b2 AC |
10088 | |
10089 | -- No user-defined pool; pass an allocation parameter indicating that | |
10090 | -- the function should allocate its result on the heap. | |
10091 | ||
10092 | else | |
10093 | Add_Unconstrained_Actuals_To_Build_In_Place_Call | |
10094 | (Func_Call, Function_Id, Alloc_Form => Global_Heap); | |
200b7162 | 10095 | end if; |
f937473f | 10096 | |
d3f70b35 | 10097 | Add_Finalization_Master_Actual_To_Build_In_Place_Call |
7888a6ae | 10098 | (Func_Call, Function_Id, Acc_Type); |
f937473f | 10099 | |
94bbf008 AC |
10100 | Add_Task_Actuals_To_Build_In_Place_Call |
10101 | (Func_Call, Function_Id, Master_Actual => Master_Id (Acc_Type)); | |
7888a6ae GD |
10102 | |
10103 | -- The caller does not provide the return object in this case, so we | |
10104 | -- have to pass null for the object access actual. | |
10105 | ||
f937473f RD |
10106 | Add_Access_Actual_To_Build_In_Place_Call |
10107 | (Func_Call, Function_Id, Return_Object => Empty); | |
10108 | end if; | |
02822a92 | 10109 | |
b254da66 AC |
10110 | -- If the build-in-place function call returns a controlled object, |
10111 | -- the finalization master will require a reference to routine | |
10112 | -- Finalize_Address of the designated type. Setting this attribute | |
10113 | -- is done in the same manner to expansion of allocators. | |
10114 | ||
10115 | if Needs_Finalization (Result_Subt) then | |
10116 | ||
10117 | -- Controlled types with supressed finalization do not need to | |
10118 | -- associate the address of their Finalize_Address primitives with | |
10119 | -- a master since they do not need a master to begin with. | |
10120 | ||
10121 | if Is_Library_Level_Entity (Acc_Type) | |
10122 | and then Finalize_Storage_Only (Result_Subt) | |
10123 | then | |
10124 | null; | |
10125 | ||
5114f3ff AC |
10126 | -- Do not generate the call to Set_Finalize_Address in CodePeer mode |
10127 | -- because Finalize_Address is never built. | |
b254da66 | 10128 | |
5114f3ff | 10129 | elsif not CodePeer_Mode then |
b254da66 AC |
10130 | Insert_Action (Allocator, |
10131 | Make_Set_Finalize_Address_Call (Loc, | |
10132 | Typ => Etype (Function_Id), | |
10133 | Ptr_Typ => Acc_Type)); | |
10134 | end if; | |
10135 | end if; | |
10136 | ||
02822a92 RD |
10137 | -- Finally, replace the allocator node with a reference to the result |
10138 | -- of the function call itself (which will effectively be an access | |
10139 | -- to the object created by the allocator). | |
10140 | ||
10141 | Rewrite (Allocator, Make_Reference (Loc, Relocate_Node (Function_Call))); | |
d2d4b355 AC |
10142 | |
10143 | -- Ada 2005 (AI-251): If the type of the allocator is an interface then | |
10144 | -- generate an implicit conversion to force displacement of the "this" | |
10145 | -- pointer. | |
10146 | ||
10147 | if Is_Interface (Designated_Type (Acc_Type)) then | |
10148 | Rewrite (Allocator, Convert_To (Acc_Type, Relocate_Node (Allocator))); | |
10149 | end if; | |
10150 | ||
02822a92 RD |
10151 | Analyze_And_Resolve (Allocator, Acc_Type); |
10152 | end Make_Build_In_Place_Call_In_Allocator; | |
10153 | ||
10154 | --------------------------------------------------- | |
10155 | -- Make_Build_In_Place_Call_In_Anonymous_Context -- | |
10156 | --------------------------------------------------- | |
10157 | ||
10158 | procedure Make_Build_In_Place_Call_In_Anonymous_Context | |
10159 | (Function_Call : Node_Id) | |
10160 | is | |
10161 | Loc : Source_Ptr; | |
10162 | Func_Call : Node_Id := Function_Call; | |
10163 | Function_Id : Entity_Id; | |
10164 | Result_Subt : Entity_Id; | |
10165 | Return_Obj_Id : Entity_Id; | |
10166 | Return_Obj_Decl : Entity_Id; | |
10167 | ||
10168 | begin | |
19590d70 GD |
10169 | -- Step past qualification or unchecked conversion (the latter can occur |
10170 | -- in cases of calls to 'Input). | |
10171 | ||
ac4d6407 RD |
10172 | if Nkind_In (Func_Call, N_Qualified_Expression, |
10173 | N_Unchecked_Type_Conversion) | |
19590d70 | 10174 | then |
02822a92 RD |
10175 | Func_Call := Expression (Func_Call); |
10176 | end if; | |
10177 | ||
fdce4bb7 JM |
10178 | -- If the call has already been processed to add build-in-place actuals |
10179 | -- then return. One place this can occur is for calls to build-in-place | |
10180 | -- functions that occur within a call to a protected operation, where | |
10181 | -- due to rewriting and expansion of the protected call there can be | |
10182 | -- more than one call to Expand_Actuals for the same set of actuals. | |
10183 | ||
10184 | if Is_Expanded_Build_In_Place_Call (Func_Call) then | |
10185 | return; | |
10186 | end if; | |
10187 | ||
10188 | -- Mark the call as processed as a build-in-place call | |
10189 | ||
10190 | Set_Is_Expanded_Build_In_Place_Call (Func_Call); | |
10191 | ||
02822a92 RD |
10192 | Loc := Sloc (Function_Call); |
10193 | ||
10194 | if Is_Entity_Name (Name (Func_Call)) then | |
10195 | Function_Id := Entity (Name (Func_Call)); | |
10196 | ||
10197 | elsif Nkind (Name (Func_Call)) = N_Explicit_Dereference then | |
10198 | Function_Id := Etype (Name (Func_Call)); | |
10199 | ||
10200 | else | |
10201 | raise Program_Error; | |
10202 | end if; | |
10203 | ||
10204 | Result_Subt := Etype (Function_Id); | |
10205 | ||
df3e68b1 HK |
10206 | -- If the build-in-place function returns a controlled object, then the |
10207 | -- object needs to be finalized immediately after the context. Since | |
10208 | -- this case produces a transient scope, the servicing finalizer needs | |
10209 | -- to name the returned object. Create a temporary which is initialized | |
10210 | -- with the function call: | |
10211 | -- | |
10212 | -- Temp_Id : Func_Type := BIP_Func_Call; | |
10213 | -- | |
10214 | -- The initialization expression of the temporary will be rewritten by | |
10215 | -- the expander using the appropriate mechanism in Make_Build_In_Place_ | |
10216 | -- Call_In_Object_Declaration. | |
10217 | ||
10218 | if Needs_Finalization (Result_Subt) then | |
10219 | declare | |
10220 | Temp_Id : constant Entity_Id := Make_Temporary (Loc, 'R'); | |
10221 | Temp_Decl : Node_Id; | |
10222 | ||
10223 | begin | |
10224 | -- Reset the guard on the function call since the following does | |
10225 | -- not perform actual call expansion. | |
10226 | ||
10227 | Set_Is_Expanded_Build_In_Place_Call (Func_Call, False); | |
10228 | ||
10229 | Temp_Decl := | |
10230 | Make_Object_Declaration (Loc, | |
10231 | Defining_Identifier => Temp_Id, | |
10232 | Object_Definition => | |
10233 | New_Reference_To (Result_Subt, Loc), | |
10234 | Expression => | |
10235 | New_Copy_Tree (Function_Call)); | |
10236 | ||
10237 | Insert_Action (Function_Call, Temp_Decl); | |
10238 | ||
10239 | Rewrite (Function_Call, New_Reference_To (Temp_Id, Loc)); | |
10240 | Analyze (Function_Call); | |
10241 | end; | |
10242 | ||
f937473f RD |
10243 | -- When the result subtype is constrained, an object of the subtype is |
10244 | -- declared and an access value designating it is passed as an actual. | |
02822a92 | 10245 | |
df3e68b1 | 10246 | elsif Is_Constrained (Underlying_Type (Result_Subt)) then |
02822a92 | 10247 | |
f937473f RD |
10248 | -- Create a temporary object to hold the function result |
10249 | ||
c12beea0 | 10250 | Return_Obj_Id := Make_Temporary (Loc, 'R'); |
f937473f | 10251 | Set_Etype (Return_Obj_Id, Result_Subt); |
02822a92 | 10252 | |
f937473f RD |
10253 | Return_Obj_Decl := |
10254 | Make_Object_Declaration (Loc, | |
10255 | Defining_Identifier => Return_Obj_Id, | |
10256 | Aliased_Present => True, | |
10257 | Object_Definition => New_Reference_To (Result_Subt, Loc)); | |
02822a92 | 10258 | |
f937473f | 10259 | Set_No_Initialization (Return_Obj_Decl); |
02822a92 | 10260 | |
f937473f | 10261 | Insert_Action (Func_Call, Return_Obj_Decl); |
02822a92 | 10262 | |
7888a6ae GD |
10263 | -- When the function has a controlling result, an allocation-form |
10264 | -- parameter must be passed indicating that the caller is allocating | |
10265 | -- the result object. This is needed because such a function can be | |
10266 | -- called as a dispatching operation and must be treated similarly | |
10267 | -- to functions with unconstrained result subtypes. | |
10268 | ||
200b7162 | 10269 | Add_Unconstrained_Actuals_To_Build_In_Place_Call |
7888a6ae GD |
10270 | (Func_Call, Function_Id, Alloc_Form => Caller_Allocation); |
10271 | ||
d3f70b35 | 10272 | Add_Finalization_Master_Actual_To_Build_In_Place_Call |
df3e68b1 | 10273 | (Func_Call, Function_Id); |
f937473f | 10274 | |
f937473f RD |
10275 | Add_Task_Actuals_To_Build_In_Place_Call |
10276 | (Func_Call, Function_Id, Make_Identifier (Loc, Name_uMaster)); | |
7888a6ae GD |
10277 | |
10278 | -- Add an implicit actual to the function call that provides access | |
10279 | -- to the caller's return object. | |
10280 | ||
f937473f RD |
10281 | Add_Access_Actual_To_Build_In_Place_Call |
10282 | (Func_Call, Function_Id, New_Reference_To (Return_Obj_Id, Loc)); | |
10283 | ||
10284 | -- When the result subtype is unconstrained, the function must allocate | |
10285 | -- the return object in the secondary stack, so appropriate implicit | |
10286 | -- parameters are added to the call to indicate that. A transient | |
10287 | -- scope is established to ensure eventual cleanup of the result. | |
10288 | ||
10289 | else | |
10290 | -- Pass an allocation parameter indicating that the function should | |
10291 | -- allocate its result on the secondary stack. | |
10292 | ||
200b7162 | 10293 | Add_Unconstrained_Actuals_To_Build_In_Place_Call |
f937473f RD |
10294 | (Func_Call, Function_Id, Alloc_Form => Secondary_Stack); |
10295 | ||
d3f70b35 | 10296 | Add_Finalization_Master_Actual_To_Build_In_Place_Call |
df3e68b1 | 10297 | (Func_Call, Function_Id); |
f937473f | 10298 | |
f937473f RD |
10299 | Add_Task_Actuals_To_Build_In_Place_Call |
10300 | (Func_Call, Function_Id, Make_Identifier (Loc, Name_uMaster)); | |
7888a6ae GD |
10301 | |
10302 | -- Pass a null value to the function since no return object is | |
10303 | -- available on the caller side. | |
10304 | ||
f937473f RD |
10305 | Add_Access_Actual_To_Build_In_Place_Call |
10306 | (Func_Call, Function_Id, Empty); | |
f937473f | 10307 | end if; |
02822a92 RD |
10308 | end Make_Build_In_Place_Call_In_Anonymous_Context; |
10309 | ||
ce2798e8 | 10310 | -------------------------------------------- |
02822a92 | 10311 | -- Make_Build_In_Place_Call_In_Assignment -- |
ce2798e8 | 10312 | -------------------------------------------- |
02822a92 RD |
10313 | |
10314 | procedure Make_Build_In_Place_Call_In_Assignment | |
10315 | (Assign : Node_Id; | |
10316 | Function_Call : Node_Id) | |
10317 | is | |
3a69b5ff AC |
10318 | Lhs : constant Node_Id := Name (Assign); |
10319 | Func_Call : Node_Id := Function_Call; | |
10320 | Func_Id : Entity_Id; | |
10321 | Loc : Source_Ptr; | |
10322 | Obj_Decl : Node_Id; | |
10323 | Obj_Id : Entity_Id; | |
10324 | Ptr_Typ : Entity_Id; | |
10325 | Ptr_Typ_Decl : Node_Id; | |
74cab21a | 10326 | New_Expr : Node_Id; |
3a69b5ff AC |
10327 | Result_Subt : Entity_Id; |
10328 | Target : Node_Id; | |
02822a92 RD |
10329 | |
10330 | begin | |
19590d70 GD |
10331 | -- Step past qualification or unchecked conversion (the latter can occur |
10332 | -- in cases of calls to 'Input). | |
10333 | ||
ac4d6407 RD |
10334 | if Nkind_In (Func_Call, N_Qualified_Expression, |
10335 | N_Unchecked_Type_Conversion) | |
19590d70 | 10336 | then |
02822a92 RD |
10337 | Func_Call := Expression (Func_Call); |
10338 | end if; | |
10339 | ||
fdce4bb7 JM |
10340 | -- If the call has already been processed to add build-in-place actuals |
10341 | -- then return. This should not normally occur in an assignment context, | |
10342 | -- but we add the protection as a defensive measure. | |
10343 | ||
10344 | if Is_Expanded_Build_In_Place_Call (Func_Call) then | |
10345 | return; | |
10346 | end if; | |
10347 | ||
10348 | -- Mark the call as processed as a build-in-place call | |
10349 | ||
10350 | Set_Is_Expanded_Build_In_Place_Call (Func_Call); | |
10351 | ||
02822a92 RD |
10352 | Loc := Sloc (Function_Call); |
10353 | ||
10354 | if Is_Entity_Name (Name (Func_Call)) then | |
3a69b5ff | 10355 | Func_Id := Entity (Name (Func_Call)); |
02822a92 RD |
10356 | |
10357 | elsif Nkind (Name (Func_Call)) = N_Explicit_Dereference then | |
3a69b5ff | 10358 | Func_Id := Etype (Name (Func_Call)); |
02822a92 RD |
10359 | |
10360 | else | |
10361 | raise Program_Error; | |
10362 | end if; | |
10363 | ||
3a69b5ff | 10364 | Result_Subt := Etype (Func_Id); |
02822a92 | 10365 | |
f937473f RD |
10366 | -- When the result subtype is unconstrained, an additional actual must |
10367 | -- be passed to indicate that the caller is providing the return object. | |
7888a6ae GD |
10368 | -- This parameter must also be passed when the called function has a |
10369 | -- controlling result, because dispatching calls to the function needs | |
10370 | -- to be treated effectively the same as calls to class-wide functions. | |
f937473f | 10371 | |
200b7162 | 10372 | Add_Unconstrained_Actuals_To_Build_In_Place_Call |
3a69b5ff | 10373 | (Func_Call, Func_Id, Alloc_Form => Caller_Allocation); |
f937473f | 10374 | |
d3f70b35 | 10375 | Add_Finalization_Master_Actual_To_Build_In_Place_Call |
df3e68b1 | 10376 | (Func_Call, Func_Id); |
02822a92 | 10377 | |
f937473f | 10378 | Add_Task_Actuals_To_Build_In_Place_Call |
3a69b5ff | 10379 | (Func_Call, Func_Id, Make_Identifier (Loc, Name_uMaster)); |
7888a6ae GD |
10380 | |
10381 | -- Add an implicit actual to the function call that provides access to | |
10382 | -- the caller's return object. | |
10383 | ||
02822a92 RD |
10384 | Add_Access_Actual_To_Build_In_Place_Call |
10385 | (Func_Call, | |
3a69b5ff | 10386 | Func_Id, |
02822a92 RD |
10387 | Make_Unchecked_Type_Conversion (Loc, |
10388 | Subtype_Mark => New_Reference_To (Result_Subt, Loc), | |
10389 | Expression => Relocate_Node (Lhs))); | |
10390 | ||
10391 | -- Create an access type designating the function's result subtype | |
10392 | ||
c12beea0 | 10393 | Ptr_Typ := Make_Temporary (Loc, 'A'); |
02822a92 RD |
10394 | |
10395 | Ptr_Typ_Decl := | |
10396 | Make_Full_Type_Declaration (Loc, | |
3a69b5ff | 10397 | Defining_Identifier => Ptr_Typ, |
2c1b72d7 | 10398 | Type_Definition => |
02822a92 | 10399 | Make_Access_To_Object_Definition (Loc, |
2c1b72d7 | 10400 | All_Present => True, |
02822a92 RD |
10401 | Subtype_Indication => |
10402 | New_Reference_To (Result_Subt, Loc))); | |
02822a92 RD |
10403 | Insert_After_And_Analyze (Assign, Ptr_Typ_Decl); |
10404 | ||
10405 | -- Finally, create an access object initialized to a reference to the | |
03e1048e AC |
10406 | -- function call. We know this access value is non-null, so mark the |
10407 | -- entity accordingly to suppress junk access checks. | |
02822a92 | 10408 | |
74cab21a EB |
10409 | New_Expr := Make_Reference (Loc, Relocate_Node (Func_Call)); |
10410 | ||
10411 | Obj_Id := Make_Temporary (Loc, 'R', New_Expr); | |
3a69b5ff | 10412 | Set_Etype (Obj_Id, Ptr_Typ); |
74cab21a | 10413 | Set_Is_Known_Non_Null (Obj_Id); |
02822a92 | 10414 | |
3a69b5ff | 10415 | Obj_Decl := |
02822a92 | 10416 | Make_Object_Declaration (Loc, |
3a69b5ff | 10417 | Defining_Identifier => Obj_Id, |
2c1b72d7 | 10418 | Object_Definition => New_Reference_To (Ptr_Typ, Loc), |
74cab21a | 10419 | Expression => New_Expr); |
3a69b5ff | 10420 | Insert_After_And_Analyze (Ptr_Typ_Decl, Obj_Decl); |
02822a92 RD |
10421 | |
10422 | Rewrite (Assign, Make_Null_Statement (Loc)); | |
3a69b5ff AC |
10423 | |
10424 | -- Retrieve the target of the assignment | |
10425 | ||
10426 | if Nkind (Lhs) = N_Selected_Component then | |
10427 | Target := Selector_Name (Lhs); | |
10428 | elsif Nkind (Lhs) = N_Type_Conversion then | |
10429 | Target := Expression (Lhs); | |
10430 | else | |
10431 | Target := Lhs; | |
10432 | end if; | |
10433 | ||
10434 | -- If we are assigning to a return object or this is an expression of | |
10435 | -- an extension aggregate, the target should either be an identifier | |
10436 | -- or a simple expression. All other cases imply a different scenario. | |
10437 | ||
10438 | if Nkind (Target) in N_Has_Entity then | |
10439 | Target := Entity (Target); | |
10440 | else | |
10441 | return; | |
10442 | end if; | |
02822a92 RD |
10443 | end Make_Build_In_Place_Call_In_Assignment; |
10444 | ||
10445 | ---------------------------------------------------- | |
10446 | -- Make_Build_In_Place_Call_In_Object_Declaration -- | |
10447 | ---------------------------------------------------- | |
10448 | ||
10449 | procedure Make_Build_In_Place_Call_In_Object_Declaration | |
10450 | (Object_Decl : Node_Id; | |
10451 | Function_Call : Node_Id) | |
10452 | is | |
f937473f RD |
10453 | Loc : Source_Ptr; |
10454 | Obj_Def_Id : constant Entity_Id := | |
10455 | Defining_Identifier (Object_Decl); | |
2c17ca0a AC |
10456 | Enclosing_Func : constant Entity_Id := |
10457 | Enclosing_Subprogram (Obj_Def_Id); | |
8417f4b2 AC |
10458 | Call_Deref : Node_Id; |
10459 | Caller_Object : Node_Id; | |
10460 | Def_Id : Entity_Id; | |
2c17ca0a | 10461 | Fmaster_Actual : Node_Id := Empty; |
8417f4b2 AC |
10462 | Func_Call : Node_Id := Function_Call; |
10463 | Function_Id : Entity_Id; | |
10464 | Pool_Actual : Node_Id; | |
10465 | Ptr_Typ_Decl : Node_Id; | |
f937473f | 10466 | Pass_Caller_Acc : Boolean := False; |
8417f4b2 AC |
10467 | New_Expr : Node_Id; |
10468 | Ref_Type : Entity_Id; | |
8c7ff9a0 | 10469 | Res_Decl : Node_Id; |
8417f4b2 | 10470 | Result_Subt : Entity_Id; |
02822a92 RD |
10471 | |
10472 | begin | |
19590d70 GD |
10473 | -- Step past qualification or unchecked conversion (the latter can occur |
10474 | -- in cases of calls to 'Input). | |
10475 | ||
ac4d6407 RD |
10476 | if Nkind_In (Func_Call, N_Qualified_Expression, |
10477 | N_Unchecked_Type_Conversion) | |
19590d70 | 10478 | then |
02822a92 RD |
10479 | Func_Call := Expression (Func_Call); |
10480 | end if; | |
10481 | ||
fdce4bb7 JM |
10482 | -- If the call has already been processed to add build-in-place actuals |
10483 | -- then return. This should not normally occur in an object declaration, | |
10484 | -- but we add the protection as a defensive measure. | |
10485 | ||
10486 | if Is_Expanded_Build_In_Place_Call (Func_Call) then | |
10487 | return; | |
10488 | end if; | |
10489 | ||
10490 | -- Mark the call as processed as a build-in-place call | |
10491 | ||
10492 | Set_Is_Expanded_Build_In_Place_Call (Func_Call); | |
10493 | ||
02822a92 RD |
10494 | Loc := Sloc (Function_Call); |
10495 | ||
10496 | if Is_Entity_Name (Name (Func_Call)) then | |
10497 | Function_Id := Entity (Name (Func_Call)); | |
10498 | ||
10499 | elsif Nkind (Name (Func_Call)) = N_Explicit_Dereference then | |
10500 | Function_Id := Etype (Name (Func_Call)); | |
10501 | ||
10502 | else | |
10503 | raise Program_Error; | |
10504 | end if; | |
10505 | ||
10506 | Result_Subt := Etype (Function_Id); | |
10507 | ||
1bb6e262 AC |
10508 | -- If the the object is a return object of an enclosing build-in-place |
10509 | -- function, then the implicit build-in-place parameters of the | |
10510 | -- enclosing function are simply passed along to the called function. | |
10511 | -- (Unfortunately, this won't cover the case of extension aggregates | |
10512 | -- where the ancestor part is a build-in-place unconstrained function | |
10513 | -- call that should be passed along the caller's parameters. Currently | |
10514 | -- those get mishandled by reassigning the result of the call to the | |
10515 | -- aggregate return object, when the call result should really be | |
10516 | -- directly built in place in the aggregate and not in a temporary. ???) | |
10517 | ||
10518 | if Is_Return_Object (Defining_Identifier (Object_Decl)) then | |
f937473f RD |
10519 | Pass_Caller_Acc := True; |
10520 | ||
1bb6e262 AC |
10521 | -- When the enclosing function has a BIP_Alloc_Form formal then we |
10522 | -- pass it along to the callee (such as when the enclosing function | |
10523 | -- has an unconstrained or tagged result type). | |
f937473f | 10524 | |
1bb6e262 | 10525 | if Needs_BIP_Alloc_Form (Enclosing_Func) then |
3e452820 AC |
10526 | if VM_Target = No_VM and then |
10527 | RTE_Available (RE_Root_Storage_Pool_Ptr) | |
10528 | then | |
8417f4b2 AC |
10529 | Pool_Actual := |
10530 | New_Reference_To (Build_In_Place_Formal | |
10531 | (Enclosing_Func, BIP_Storage_Pool), Loc); | |
10532 | ||
10533 | -- The build-in-place pool formal is not built on .NET/JVM | |
10534 | ||
10535 | else | |
10536 | Pool_Actual := Empty; | |
10537 | end if; | |
10538 | ||
200b7162 | 10539 | Add_Unconstrained_Actuals_To_Build_In_Place_Call |
f937473f RD |
10540 | (Func_Call, |
10541 | Function_Id, | |
10542 | Alloc_Form_Exp => | |
10543 | New_Reference_To | |
10544 | (Build_In_Place_Formal (Enclosing_Func, BIP_Alloc_Form), | |
200b7162 | 10545 | Loc), |
8417f4b2 | 10546 | Pool_Actual => Pool_Actual); |
1bb6e262 AC |
10547 | |
10548 | -- Otherwise, if enclosing function has a constrained result subtype, | |
10549 | -- then caller allocation will be used. | |
10550 | ||
10551 | else | |
200b7162 | 10552 | Add_Unconstrained_Actuals_To_Build_In_Place_Call |
1bb6e262 | 10553 | (Func_Call, Function_Id, Alloc_Form => Caller_Allocation); |
f937473f RD |
10554 | end if; |
10555 | ||
2c17ca0a AC |
10556 | if Needs_BIP_Finalization_Master (Enclosing_Func) then |
10557 | Fmaster_Actual := | |
10558 | New_Reference_To | |
10559 | (Build_In_Place_Formal | |
10560 | (Enclosing_Func, BIP_Finalization_Master), Loc); | |
10561 | end if; | |
10562 | ||
f937473f RD |
10563 | -- Retrieve the BIPacc formal from the enclosing function and convert |
10564 | -- it to the access type of the callee's BIP_Object_Access formal. | |
10565 | ||
10566 | Caller_Object := | |
10567 | Make_Unchecked_Type_Conversion (Loc, | |
10568 | Subtype_Mark => | |
10569 | New_Reference_To | |
10570 | (Etype | |
10571 | (Build_In_Place_Formal (Function_Id, BIP_Object_Access)), | |
10572 | Loc), | |
10573 | Expression => | |
10574 | New_Reference_To | |
10575 | (Build_In_Place_Formal (Enclosing_Func, BIP_Object_Access), | |
10576 | Loc)); | |
10577 | ||
1bb6e262 AC |
10578 | -- In the constrained case, add an implicit actual to the function call |
10579 | -- that provides access to the declared object. An unchecked conversion | |
10580 | -- to the (specific) result type of the function is inserted to handle | |
10581 | -- the case where the object is declared with a class-wide type. | |
10582 | ||
10583 | elsif Is_Constrained (Underlying_Type (Result_Subt)) then | |
10584 | Caller_Object := | |
10585 | Make_Unchecked_Type_Conversion (Loc, | |
10586 | Subtype_Mark => New_Reference_To (Result_Subt, Loc), | |
10587 | Expression => New_Reference_To (Obj_Def_Id, Loc)); | |
10588 | ||
10589 | -- When the function has a controlling result, an allocation-form | |
10590 | -- parameter must be passed indicating that the caller is allocating | |
10591 | -- the result object. This is needed because such a function can be | |
10592 | -- called as a dispatching operation and must be treated similarly | |
10593 | -- to functions with unconstrained result subtypes. | |
10594 | ||
200b7162 | 10595 | Add_Unconstrained_Actuals_To_Build_In_Place_Call |
1bb6e262 AC |
10596 | (Func_Call, Function_Id, Alloc_Form => Caller_Allocation); |
10597 | ||
f937473f RD |
10598 | -- In other unconstrained cases, pass an indication to do the allocation |
10599 | -- on the secondary stack and set Caller_Object to Empty so that a null | |
10600 | -- value will be passed for the caller's object address. A transient | |
10601 | -- scope is established to ensure eventual cleanup of the result. | |
10602 | ||
10603 | else | |
200b7162 | 10604 | Add_Unconstrained_Actuals_To_Build_In_Place_Call |
3e7302c3 | 10605 | (Func_Call, Function_Id, Alloc_Form => Secondary_Stack); |
f937473f RD |
10606 | Caller_Object := Empty; |
10607 | ||
10608 | Establish_Transient_Scope (Object_Decl, Sec_Stack => True); | |
10609 | end if; | |
10610 | ||
2c17ca0a AC |
10611 | -- Pass along any finalization master actual, which is needed in the |
10612 | -- case where the called function initializes a return object of an | |
10613 | -- enclosing build-in-place function. | |
10614 | ||
d3f70b35 | 10615 | Add_Finalization_Master_Actual_To_Build_In_Place_Call |
2c17ca0a AC |
10616 | (Func_Call => Func_Call, |
10617 | Func_Id => Function_Id, | |
10618 | Master_Exp => Fmaster_Actual); | |
7888a6ae | 10619 | |
f937473f RD |
10620 | if Nkind (Parent (Object_Decl)) = N_Extended_Return_Statement |
10621 | and then Has_Task (Result_Subt) | |
10622 | then | |
7888a6ae GD |
10623 | -- Here we're passing along the master that was passed in to this |
10624 | -- function. | |
10625 | ||
f937473f RD |
10626 | Add_Task_Actuals_To_Build_In_Place_Call |
10627 | (Func_Call, Function_Id, | |
10628 | Master_Actual => | |
af89615f AC |
10629 | New_Reference_To (Build_In_Place_Formal |
10630 | (Enclosing_Func, BIP_Task_Master), Loc)); | |
7888a6ae | 10631 | |
f937473f RD |
10632 | else |
10633 | Add_Task_Actuals_To_Build_In_Place_Call | |
10634 | (Func_Call, Function_Id, Make_Identifier (Loc, Name_uMaster)); | |
10635 | end if; | |
7888a6ae | 10636 | |
02822a92 | 10637 | Add_Access_Actual_To_Build_In_Place_Call |
f937473f | 10638 | (Func_Call, Function_Id, Caller_Object, Is_Access => Pass_Caller_Acc); |
02822a92 | 10639 | |
b0b7b57d AC |
10640 | -- Create an access type designating the function's result subtype. We |
10641 | -- use the type of the original expression because it may be a call to | |
10642 | -- an inherited operation, which the expansion has replaced with the | |
10643 | -- parent operation that yields the parent type. | |
02822a92 | 10644 | |
c12beea0 | 10645 | Ref_Type := Make_Temporary (Loc, 'A'); |
02822a92 RD |
10646 | |
10647 | Ptr_Typ_Decl := | |
10648 | Make_Full_Type_Declaration (Loc, | |
10649 | Defining_Identifier => Ref_Type, | |
2c1b72d7 | 10650 | Type_Definition => |
02822a92 | 10651 | Make_Access_To_Object_Definition (Loc, |
2c1b72d7 | 10652 | All_Present => True, |
02822a92 | 10653 | Subtype_Indication => |
b0b7b57d | 10654 | New_Reference_To (Etype (Function_Call), Loc))); |
02822a92 | 10655 | |
f937473f RD |
10656 | -- The access type and its accompanying object must be inserted after |
10657 | -- the object declaration in the constrained case, so that the function | |
10658 | -- call can be passed access to the object. In the unconstrained case, | |
1bb6e262 AC |
10659 | -- or if the object declaration is for a return object, the access type |
10660 | -- and object must be inserted before the object, since the object | |
10661 | -- declaration is rewritten to be a renaming of a dereference of the | |
10662 | -- access object. | |
f937473f | 10663 | |
1bb6e262 AC |
10664 | if Is_Constrained (Underlying_Type (Result_Subt)) |
10665 | and then not Is_Return_Object (Defining_Identifier (Object_Decl)) | |
10666 | then | |
f937473f RD |
10667 | Insert_After_And_Analyze (Object_Decl, Ptr_Typ_Decl); |
10668 | else | |
4f6e2c24 | 10669 | Insert_Action (Object_Decl, Ptr_Typ_Decl); |
f937473f | 10670 | end if; |
02822a92 RD |
10671 | |
10672 | -- Finally, create an access object initialized to a reference to the | |
03e1048e AC |
10673 | -- function call. We know this access value cannot be null, so mark the |
10674 | -- entity accordingly to suppress the access check. | |
02822a92 | 10675 | |
2c1b72d7 | 10676 | New_Expr := Make_Reference (Loc, Relocate_Node (Func_Call)); |
02822a92 | 10677 | |
c12beea0 RD |
10678 | Def_Id := Make_Temporary (Loc, 'R', New_Expr); |
10679 | Set_Etype (Def_Id, Ref_Type); | |
74cab21a | 10680 | Set_Is_Known_Non_Null (Def_Id); |
c12beea0 | 10681 | |
8c7ff9a0 | 10682 | Res_Decl := |
02822a92 RD |
10683 | Make_Object_Declaration (Loc, |
10684 | Defining_Identifier => Def_Id, | |
10685 | Object_Definition => New_Reference_To (Ref_Type, Loc), | |
8c7ff9a0 AC |
10686 | Expression => New_Expr); |
10687 | Insert_After_And_Analyze (Ptr_Typ_Decl, Res_Decl); | |
02822a92 | 10688 | |
1bb6e262 AC |
10689 | -- If the result subtype of the called function is constrained and |
10690 | -- is not itself the return expression of an enclosing BIP function, | |
10691 | -- then mark the object as having no initialization. | |
10692 | ||
10693 | if Is_Constrained (Underlying_Type (Result_Subt)) | |
10694 | and then not Is_Return_Object (Defining_Identifier (Object_Decl)) | |
10695 | then | |
8c7ff9a0 AC |
10696 | -- The related object declaration is encased in a transient block |
10697 | -- because the build-in-place function call contains at least one | |
10698 | -- nested function call that produces a controlled transient | |
10699 | -- temporary: | |
10700 | ||
10701 | -- Obj : ... := BIP_Func_Call (Ctrl_Func_Call); | |
10702 | ||
10703 | -- Since the build-in-place expansion decouples the call from the | |
10704 | -- object declaration, the finalization machinery lacks the context | |
10705 | -- which prompted the generation of the transient block. To resolve | |
10706 | -- this scenario, store the build-in-place call. | |
10707 | ||
10708 | if Scope_Is_Transient | |
10709 | and then Node_To_Be_Wrapped = Object_Decl | |
10710 | then | |
10711 | Set_BIP_Initialization_Call (Obj_Def_Id, Res_Decl); | |
10712 | end if; | |
10713 | ||
f937473f RD |
10714 | Set_Expression (Object_Decl, Empty); |
10715 | Set_No_Initialization (Object_Decl); | |
10716 | ||
1bb6e262 AC |
10717 | -- In case of an unconstrained result subtype, or if the call is the |
10718 | -- return expression of an enclosing BIP function, rewrite the object | |
f937473f RD |
10719 | -- declaration as an object renaming where the renamed object is a |
10720 | -- dereference of <function_Call>'reference: | |
10721 | -- | |
10722 | -- Obj : Subt renames <function_call>'Ref.all; | |
10723 | ||
10724 | else | |
10725 | Call_Deref := | |
10726 | Make_Explicit_Dereference (Loc, | |
10727 | Prefix => New_Reference_To (Def_Id, Loc)); | |
10728 | ||
f00c5f52 | 10729 | Loc := Sloc (Object_Decl); |
f937473f RD |
10730 | Rewrite (Object_Decl, |
10731 | Make_Object_Renaming_Declaration (Loc, | |
c12beea0 | 10732 | Defining_Identifier => Make_Temporary (Loc, 'D'), |
f937473f RD |
10733 | Access_Definition => Empty, |
10734 | Subtype_Mark => New_Occurrence_Of (Result_Subt, Loc), | |
10735 | Name => Call_Deref)); | |
10736 | ||
10737 | Set_Renamed_Object (Defining_Identifier (Object_Decl), Call_Deref); | |
10738 | ||
10739 | Analyze (Object_Decl); | |
10740 | ||
10741 | -- Replace the internal identifier of the renaming declaration's | |
10742 | -- entity with identifier of the original object entity. We also have | |
10743 | -- to exchange the entities containing their defining identifiers to | |
10744 | -- ensure the correct replacement of the object declaration by the | |
10745 | -- object renaming declaration to avoid homograph conflicts (since | |
10746 | -- the object declaration's defining identifier was already entered | |
67ce0d7e RD |
10747 | -- in current scope). The Next_Entity links of the two entities also |
10748 | -- have to be swapped since the entities are part of the return | |
10749 | -- scope's entity list and the list structure would otherwise be | |
7e8ed0a6 | 10750 | -- corrupted. Finally, the homonym chain must be preserved as well. |
67ce0d7e RD |
10751 | |
10752 | declare | |
10753 | Renaming_Def_Id : constant Entity_Id := | |
10754 | Defining_Identifier (Object_Decl); | |
10755 | Next_Entity_Temp : constant Entity_Id := | |
10756 | Next_Entity (Renaming_Def_Id); | |
10757 | begin | |
10758 | Set_Chars (Renaming_Def_Id, Chars (Obj_Def_Id)); | |
10759 | ||
10760 | -- Swap next entity links in preparation for exchanging entities | |
f937473f | 10761 | |
67ce0d7e RD |
10762 | Set_Next_Entity (Renaming_Def_Id, Next_Entity (Obj_Def_Id)); |
10763 | Set_Next_Entity (Obj_Def_Id, Next_Entity_Temp); | |
7e8ed0a6 | 10764 | Set_Homonym (Renaming_Def_Id, Homonym (Obj_Def_Id)); |
67ce0d7e RD |
10765 | |
10766 | Exchange_Entities (Renaming_Def_Id, Obj_Def_Id); | |
f00c5f52 AC |
10767 | |
10768 | -- Preserve source indication of original declaration, so that | |
10769 | -- xref information is properly generated for the right entity. | |
10770 | ||
10771 | Preserve_Comes_From_Source | |
10772 | (Object_Decl, Original_Node (Object_Decl)); | |
e4982b64 AC |
10773 | |
10774 | Preserve_Comes_From_Source | |
10775 | (Obj_Def_Id, Original_Node (Object_Decl)); | |
10776 | ||
f00c5f52 | 10777 | Set_Comes_From_Source (Renaming_Def_Id, False); |
67ce0d7e | 10778 | end; |
f937473f | 10779 | end if; |
02822a92 RD |
10780 | |
10781 | -- If the object entity has a class-wide Etype, then we need to change | |
10782 | -- it to the result subtype of the function call, because otherwise the | |
53b308f6 AC |
10783 | -- object will be class-wide without an explicit initialization and |
10784 | -- won't be allocated properly by the back end. It seems unclean to make | |
10785 | -- such a revision to the type at this point, and we should try to | |
10786 | -- improve this treatment when build-in-place functions with class-wide | |
10787 | -- results are implemented. ??? | |
02822a92 RD |
10788 | |
10789 | if Is_Class_Wide_Type (Etype (Defining_Identifier (Object_Decl))) then | |
10790 | Set_Etype (Defining_Identifier (Object_Decl), Result_Subt); | |
10791 | end if; | |
10792 | end Make_Build_In_Place_Call_In_Object_Declaration; | |
10793 | ||
3bfb3c03 JM |
10794 | -------------------------------------------- |
10795 | -- Make_CPP_Constructor_Call_In_Allocator -- | |
10796 | -------------------------------------------- | |
10797 | ||
10798 | procedure Make_CPP_Constructor_Call_In_Allocator | |
10799 | (Allocator : Node_Id; | |
10800 | Function_Call : Node_Id) | |
10801 | is | |
10802 | Loc : constant Source_Ptr := Sloc (Function_Call); | |
10803 | Acc_Type : constant Entity_Id := Etype (Allocator); | |
10804 | Function_Id : constant Entity_Id := Entity (Name (Function_Call)); | |
10805 | Result_Subt : constant Entity_Id := Available_View (Etype (Function_Id)); | |
10806 | ||
10807 | New_Allocator : Node_Id; | |
10808 | Return_Obj_Access : Entity_Id; | |
10809 | Tmp_Obj : Node_Id; | |
10810 | ||
10811 | begin | |
10812 | pragma Assert (Nkind (Allocator) = N_Allocator | |
8c7ff9a0 | 10813 | and then Nkind (Function_Call) = N_Function_Call); |
3bfb3c03 | 10814 | pragma Assert (Convention (Function_Id) = Convention_CPP |
8c7ff9a0 | 10815 | and then Is_Constructor (Function_Id)); |
3bfb3c03 JM |
10816 | pragma Assert (Is_Constrained (Underlying_Type (Result_Subt))); |
10817 | ||
10818 | -- Replace the initialized allocator of form "new T'(Func (...))" with | |
10819 | -- an uninitialized allocator of form "new T", where T is the result | |
10820 | -- subtype of the called function. The call to the function is handled | |
10821 | -- separately further below. | |
10822 | ||
10823 | New_Allocator := | |
10824 | Make_Allocator (Loc, | |
10825 | Expression => New_Reference_To (Result_Subt, Loc)); | |
10826 | Set_No_Initialization (New_Allocator); | |
10827 | ||
10828 | -- Copy attributes to new allocator. Note that the new allocator | |
10829 | -- logically comes from source if the original one did, so copy the | |
10830 | -- relevant flag. This ensures proper treatment of the restriction | |
10831 | -- No_Implicit_Heap_Allocations in this case. | |
10832 | ||
10833 | Set_Storage_Pool (New_Allocator, Storage_Pool (Allocator)); | |
10834 | Set_Procedure_To_Call (New_Allocator, Procedure_To_Call (Allocator)); | |
10835 | Set_Comes_From_Source (New_Allocator, Comes_From_Source (Allocator)); | |
10836 | ||
10837 | Rewrite (Allocator, New_Allocator); | |
10838 | ||
10839 | -- Create a new access object and initialize it to the result of the | |
10840 | -- new uninitialized allocator. Note: we do not use Allocator as the | |
10841 | -- Related_Node of Return_Obj_Access in call to Make_Temporary below | |
10842 | -- as this would create a sort of infinite "recursion". | |
10843 | ||
10844 | Return_Obj_Access := Make_Temporary (Loc, 'R'); | |
10845 | Set_Etype (Return_Obj_Access, Acc_Type); | |
10846 | ||
10847 | -- Generate: | |
10848 | -- Rnnn : constant ptr_T := new (T); | |
10849 | -- Init (Rnn.all,...); | |
10850 | ||
10851 | Tmp_Obj := | |
10852 | Make_Object_Declaration (Loc, | |
10853 | Defining_Identifier => Return_Obj_Access, | |
10854 | Constant_Present => True, | |
10855 | Object_Definition => New_Reference_To (Acc_Type, Loc), | |
10856 | Expression => Relocate_Node (Allocator)); | |
10857 | Insert_Action (Allocator, Tmp_Obj); | |
10858 | ||
10859 | Insert_List_After_And_Analyze (Tmp_Obj, | |
10860 | Build_Initialization_Call (Loc, | |
10861 | Id_Ref => | |
10862 | Make_Explicit_Dereference (Loc, | |
10863 | Prefix => New_Reference_To (Return_Obj_Access, Loc)), | |
10864 | Typ => Etype (Function_Id), | |
10865 | Constructor_Ref => Function_Call)); | |
10866 | ||
10867 | -- Finally, replace the allocator node with a reference to the result of | |
10868 | -- the function call itself (which will effectively be an access to the | |
10869 | -- object created by the allocator). | |
10870 | ||
10871 | Rewrite (Allocator, New_Reference_To (Return_Obj_Access, Loc)); | |
10872 | ||
10873 | -- Ada 2005 (AI-251): If the type of the allocator is an interface then | |
10874 | -- generate an implicit conversion to force displacement of the "this" | |
10875 | -- pointer. | |
10876 | ||
10877 | if Is_Interface (Designated_Type (Acc_Type)) then | |
10878 | Rewrite (Allocator, Convert_To (Acc_Type, Relocate_Node (Allocator))); | |
10879 | end if; | |
10880 | ||
10881 | Analyze_And_Resolve (Allocator, Acc_Type); | |
10882 | end Make_CPP_Constructor_Call_In_Allocator; | |
10883 | ||
d3f70b35 AC |
10884 | ----------------------------------- |
10885 | -- Needs_BIP_Finalization_Master -- | |
10886 | ----------------------------------- | |
8fb68c56 | 10887 | |
d3f70b35 AC |
10888 | function Needs_BIP_Finalization_Master |
10889 | (Func_Id : Entity_Id) return Boolean | |
10890 | is | |
df3e68b1 HK |
10891 | pragma Assert (Is_Build_In_Place_Function (Func_Id)); |
10892 | Func_Typ : constant Entity_Id := Underlying_Type (Etype (Func_Id)); | |
048e5cef | 10893 | begin |
df3e68b1 HK |
10894 | return |
10895 | not Restriction_Active (No_Finalization) | |
10896 | and then Needs_Finalization (Func_Typ); | |
d3f70b35 | 10897 | end Needs_BIP_Finalization_Master; |
048e5cef | 10898 | |
1bb6e262 AC |
10899 | -------------------------- |
10900 | -- Needs_BIP_Alloc_Form -- | |
10901 | -------------------------- | |
10902 | ||
10903 | function Needs_BIP_Alloc_Form (Func_Id : Entity_Id) return Boolean is | |
10904 | pragma Assert (Is_Build_In_Place_Function (Func_Id)); | |
10905 | Func_Typ : constant Entity_Id := Underlying_Type (Etype (Func_Id)); | |
1bb6e262 AC |
10906 | begin |
10907 | return not Is_Constrained (Func_Typ) or else Is_Tagged_Type (Func_Typ); | |
10908 | end Needs_BIP_Alloc_Form; | |
10909 | ||
63585f75 SB |
10910 | -------------------------------------- |
10911 | -- Needs_Result_Accessibility_Level -- | |
10912 | -------------------------------------- | |
10913 | ||
10914 | function Needs_Result_Accessibility_Level | |
10915 | (Func_Id : Entity_Id) return Boolean | |
10916 | is | |
10917 | Func_Typ : constant Entity_Id := Underlying_Type (Etype (Func_Id)); | |
10918 | ||
10919 | function Has_Unconstrained_Access_Discriminant_Component | |
ebf494ec RD |
10920 | (Comp_Typ : Entity_Id) return Boolean; |
10921 | -- Returns True if any component of the type has an unconstrained access | |
10922 | -- discriminant. | |
63585f75 SB |
10923 | |
10924 | ----------------------------------------------------- | |
10925 | -- Has_Unconstrained_Access_Discriminant_Component -- | |
10926 | ----------------------------------------------------- | |
10927 | ||
10928 | function Has_Unconstrained_Access_Discriminant_Component | |
10929 | (Comp_Typ : Entity_Id) return Boolean | |
10930 | is | |
10931 | begin | |
10932 | if not Is_Limited_Type (Comp_Typ) then | |
10933 | return False; | |
ebf494ec | 10934 | |
63585f75 SB |
10935 | -- Only limited types can have access discriminants with |
10936 | -- defaults. | |
10937 | ||
10938 | elsif Has_Unconstrained_Access_Discriminants (Comp_Typ) then | |
10939 | return True; | |
10940 | ||
10941 | elsif Is_Array_Type (Comp_Typ) then | |
10942 | return Has_Unconstrained_Access_Discriminant_Component | |
10943 | (Underlying_Type (Component_Type (Comp_Typ))); | |
10944 | ||
10945 | elsif Is_Record_Type (Comp_Typ) then | |
10946 | declare | |
ebf494ec RD |
10947 | Comp : Entity_Id; |
10948 | ||
63585f75 | 10949 | begin |
ebf494ec | 10950 | Comp := First_Component (Comp_Typ); |
63585f75 SB |
10951 | while Present (Comp) loop |
10952 | if Has_Unconstrained_Access_Discriminant_Component | |
10953 | (Underlying_Type (Etype (Comp))) | |
10954 | then | |
10955 | return True; | |
10956 | end if; | |
10957 | ||
10958 | Next_Component (Comp); | |
10959 | end loop; | |
10960 | end; | |
10961 | end if; | |
10962 | ||
10963 | return False; | |
10964 | end Has_Unconstrained_Access_Discriminant_Component; | |
10965 | ||
57a3fca9 AC |
10966 | Feature_Disabled : constant Boolean := True; |
10967 | -- Temporary | |
10968 | ||
63585f75 SB |
10969 | -- Start of processing for Needs_Result_Accessibility_Level |
10970 | ||
10971 | begin | |
ebf494ec RD |
10972 | -- False if completion unavailable (how does this happen???) |
10973 | ||
10974 | if not Present (Func_Typ) then | |
10975 | return False; | |
63585f75 | 10976 | |
57a3fca9 AC |
10977 | elsif Feature_Disabled then |
10978 | return False; | |
10979 | ||
ebf494ec | 10980 | -- False if not a function, also handle enum-lit renames case |
63585f75 | 10981 | |
ebf494ec RD |
10982 | elsif Func_Typ = Standard_Void_Type |
10983 | or else Is_Scalar_Type (Func_Typ) | |
63585f75 SB |
10984 | then |
10985 | return False; | |
63585f75 | 10986 | |
ebf494ec | 10987 | -- Handle a corner case, a cross-dialect subp renaming. For example, |
30168043 AC |
10988 | -- an Ada 2012 renaming of an Ada 2005 subprogram. This can occur when |
10989 | -- an Ada 2005 (or earlier) unit references predefined run-time units. | |
ebf494ec RD |
10990 | |
10991 | elsif Present (Alias (Func_Id)) then | |
10992 | ||
63585f75 SB |
10993 | -- Unimplemented: a cross-dialect subp renaming which does not set |
10994 | -- the Alias attribute (e.g., a rename of a dereference of an access | |
54bf19e4 | 10995 | -- to subprogram value). ??? |
63585f75 SB |
10996 | |
10997 | return Present (Extra_Accessibility_Of_Result (Alias (Func_Id))); | |
63585f75 | 10998 | |
ebf494ec RD |
10999 | -- Remaining cases require Ada 2012 mode |
11000 | ||
11001 | elsif Ada_Version < Ada_2012 then | |
63585f75 | 11002 | return False; |
63585f75 | 11003 | |
ebf494ec | 11004 | elsif Ekind (Func_Typ) = E_Anonymous_Access_Type |
63585f75 SB |
11005 | or else Is_Tagged_Type (Func_Typ) |
11006 | then | |
11007 | -- In the case of, say, a null tagged record result type, the need | |
11008 | -- for this extra parameter might not be obvious. This function | |
11009 | -- returns True for all tagged types for compatibility reasons. | |
11010 | -- A function with, say, a tagged null controlling result type might | |
11011 | -- be overridden by a primitive of an extension having an access | |
11012 | -- discriminant and the overrider and overridden must have compatible | |
11013 | -- calling conventions (including implicitly declared parameters). | |
11014 | -- Similarly, values of one access-to-subprogram type might designate | |
11015 | -- both a primitive subprogram of a given type and a function | |
11016 | -- which is, for example, not a primitive subprogram of any type. | |
11017 | -- Again, this requires calling convention compatibility. | |
11018 | -- It might be possible to solve these issues by introducing | |
11019 | -- wrappers, but that is not the approach that was chosen. | |
11020 | ||
11021 | return True; | |
63585f75 | 11022 | |
ebf494ec | 11023 | elsif Has_Unconstrained_Access_Discriminants (Func_Typ) then |
63585f75 | 11024 | return True; |
63585f75 | 11025 | |
ebf494ec | 11026 | elsif Has_Unconstrained_Access_Discriminant_Component (Func_Typ) then |
63585f75 | 11027 | return True; |
63585f75 | 11028 | |
ebf494ec RD |
11029 | -- False for all other cases |
11030 | ||
11031 | else | |
11032 | return False; | |
11033 | end if; | |
63585f75 SB |
11034 | end Needs_Result_Accessibility_Level; |
11035 | ||
84f4072a JM |
11036 | ------------------------ |
11037 | -- List_Inlining_Info -- | |
11038 | ------------------------ | |
11039 | ||
11040 | procedure List_Inlining_Info is | |
11041 | Elmt : Elmt_Id; | |
11042 | Nod : Node_Id; | |
11043 | Count : Nat; | |
11044 | ||
11045 | begin | |
11046 | if not Debug_Flag_Dot_J then | |
11047 | return; | |
11048 | end if; | |
11049 | ||
11050 | -- Generate listing of calls inlined by the frontend | |
11051 | ||
11052 | if Present (Inlined_Calls) then | |
11053 | Count := 0; | |
11054 | Elmt := First_Elmt (Inlined_Calls); | |
11055 | while Present (Elmt) loop | |
11056 | Nod := Node (Elmt); | |
11057 | ||
11058 | if In_Extended_Main_Code_Unit (Nod) then | |
11059 | Count := Count + 1; | |
11060 | ||
11061 | if Count = 1 then | |
11062 | Write_Str ("Listing of frontend inlined calls"); | |
11063 | Write_Eol; | |
11064 | end if; | |
11065 | ||
11066 | Write_Str (" "); | |
11067 | Write_Int (Count); | |
11068 | Write_Str (":"); | |
11069 | Write_Location (Sloc (Nod)); | |
11070 | Write_Str (":"); | |
11071 | Output.Write_Eol; | |
11072 | end if; | |
11073 | ||
11074 | Next_Elmt (Elmt); | |
11075 | end loop; | |
11076 | end if; | |
11077 | ||
11078 | -- Generate listing of calls passed to the backend | |
11079 | ||
11080 | if Present (Backend_Calls) then | |
11081 | Count := 0; | |
11082 | ||
11083 | Elmt := First_Elmt (Backend_Calls); | |
11084 | while Present (Elmt) loop | |
11085 | Nod := Node (Elmt); | |
11086 | ||
11087 | if In_Extended_Main_Code_Unit (Nod) then | |
11088 | Count := Count + 1; | |
11089 | ||
11090 | if Count = 1 then | |
11091 | Write_Str ("Listing of inlined calls passed to the backend"); | |
11092 | Write_Eol; | |
11093 | end if; | |
11094 | ||
11095 | Write_Str (" "); | |
11096 | Write_Int (Count); | |
11097 | Write_Str (":"); | |
11098 | Write_Location (Sloc (Nod)); | |
11099 | Output.Write_Eol; | |
11100 | end if; | |
11101 | ||
11102 | Next_Elmt (Elmt); | |
11103 | end loop; | |
11104 | end if; | |
11105 | end List_Inlining_Info; | |
11106 | ||
70482933 | 11107 | end Exp_Ch6; |