]>
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 | -- -- | |
1d005acc | 9 | -- Copyright (C) 1992-2019, 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 | ||
879ac954 | 26 | with Atree; use Atree; |
a2dbe7d5 | 27 | with Aspects; use Aspects; |
879ac954 AC |
28 | with Checks; use Checks; |
29 | with Contracts; use Contracts; | |
30 | with Debug; use Debug; | |
31 | with Einfo; use Einfo; | |
32 | with Errout; use Errout; | |
33 | with Elists; use Elists; | |
4ac62786 | 34 | with Expander; use Expander; |
879ac954 AC |
35 | with Exp_Aggr; use Exp_Aggr; |
36 | with Exp_Atag; use Exp_Atag; | |
37 | with Exp_Ch2; use Exp_Ch2; | |
38 | with Exp_Ch3; use Exp_Ch3; | |
39 | with Exp_Ch7; use Exp_Ch7; | |
40 | with Exp_Ch9; use Exp_Ch9; | |
41 | with Exp_Dbug; use Exp_Dbug; | |
42 | with Exp_Disp; use Exp_Disp; | |
43 | with Exp_Dist; use Exp_Dist; | |
44 | with Exp_Intr; use Exp_Intr; | |
45 | with Exp_Pakd; use Exp_Pakd; | |
46 | with Exp_Tss; use Exp_Tss; | |
879ac954 AC |
47 | with Exp_Util; use Exp_Util; |
48 | with Freeze; use Freeze; | |
879ac954 | 49 | with Inline; use Inline; |
4ac62786 | 50 | with Itypes; use Itypes; |
879ac954 AC |
51 | with Lib; use Lib; |
52 | with Namet; use Namet; | |
53 | with Nlists; use Nlists; | |
54 | with Nmake; use Nmake; | |
55 | with Opt; use Opt; | |
56 | with Restrict; use Restrict; | |
57 | with Rident; use Rident; | |
58 | with Rtsfind; use Rtsfind; | |
59 | with Sem; use Sem; | |
60 | with Sem_Aux; use Sem_Aux; | |
61 | with Sem_Ch6; use Sem_Ch6; | |
62 | with Sem_Ch8; use Sem_Ch8; | |
63 | with Sem_Ch13; use Sem_Ch13; | |
64 | with Sem_Dim; use Sem_Dim; | |
65 | with Sem_Disp; use Sem_Disp; | |
66 | with Sem_Dist; use Sem_Dist; | |
67 | with Sem_Eval; use Sem_Eval; | |
68 | with Sem_Mech; use Sem_Mech; | |
69 | with Sem_Res; use Sem_Res; | |
70 | with Sem_SCIL; use Sem_SCIL; | |
71 | with Sem_Util; use Sem_Util; | |
72 | with Sinfo; use Sinfo; | |
73 | with Snames; use Snames; | |
74 | with Stand; use Stand; | |
879ac954 AC |
75 | with Tbuild; use Tbuild; |
76 | with Uintp; use Uintp; | |
77 | with Validsw; use Validsw; | |
70482933 RK |
78 | |
79 | package body Exp_Ch6 is | |
80 | ||
81 | ----------------------- | |
82 | -- Local Subprograms -- | |
83 | ----------------------- | |
84 | ||
02822a92 RD |
85 | procedure Add_Access_Actual_To_Build_In_Place_Call |
86 | (Function_Call : Node_Id; | |
87 | Function_Id : Entity_Id; | |
f937473f RD |
88 | Return_Object : Node_Id; |
89 | Is_Access : Boolean := False); | |
02822a92 RD |
90 | -- Ada 2005 (AI-318-02): Apply the Unrestricted_Access attribute to the |
91 | -- object name given by Return_Object and add the attribute to the end of | |
92 | -- the actual parameter list associated with the build-in-place function | |
f937473f RD |
93 | -- call denoted by Function_Call. However, if Is_Access is True, then |
94 | -- Return_Object is already an access expression, in which case it's passed | |
95 | -- along directly to the build-in-place function. Finally, if Return_Object | |
96 | -- is empty, then pass a null literal as the actual. | |
97 | ||
200b7162 | 98 | procedure Add_Unconstrained_Actuals_To_Build_In_Place_Call |
f937473f RD |
99 | (Function_Call : Node_Id; |
100 | Function_Id : Entity_Id; | |
101 | Alloc_Form : BIP_Allocation_Form := Unspecified; | |
200b7162 BD |
102 | Alloc_Form_Exp : Node_Id := Empty; |
103 | Pool_Actual : Node_Id := Make_Null (No_Location)); | |
104 | -- Ada 2005 (AI-318-02): Add the actuals needed for a build-in-place | |
105 | -- function call that returns a caller-unknown-size result (BIP_Alloc_Form | |
106 | -- and BIP_Storage_Pool). If Alloc_Form_Exp is present, then use it, | |
107 | -- otherwise pass a literal corresponding to the Alloc_Form parameter | |
108 | -- (which must not be Unspecified in that case). Pool_Actual is the | |
109 | -- parameter to pass to BIP_Storage_Pool. | |
f937473f | 110 | |
d3f70b35 | 111 | procedure Add_Finalization_Master_Actual_To_Build_In_Place_Call |
2c17ca0a AC |
112 | (Func_Call : Node_Id; |
113 | Func_Id : Entity_Id; | |
114 | Ptr_Typ : Entity_Id := Empty; | |
115 | Master_Exp : Node_Id := Empty); | |
df3e68b1 HK |
116 | -- Ada 2005 (AI-318-02): If the result type of a build-in-place call needs |
117 | -- finalization actions, add an actual parameter which is a pointer to the | |
2c17ca0a AC |
118 | -- finalization master of the caller. If Master_Exp is not Empty, then that |
119 | -- will be passed as the actual. Otherwise, if Ptr_Typ is left Empty, this | |
120 | -- will result in an automatic "null" value for the actual. | |
f937473f RD |
121 | |
122 | procedure Add_Task_Actuals_To_Build_In_Place_Call | |
123 | (Function_Call : Node_Id; | |
124 | Function_Id : Entity_Id; | |
1399d355 AC |
125 | Master_Actual : Node_Id; |
126 | Chain : Node_Id := Empty); | |
f937473f RD |
127 | -- Ada 2005 (AI-318-02): For a build-in-place call, if the result type |
128 | -- contains tasks, add two actual parameters: the master, and a pointer to | |
129 | -- the caller's activation chain. Master_Actual is the actual parameter | |
130 | -- expression to pass for the master. In most cases, this is the current | |
131 | -- master (_master). The two exceptions are: If the function call is the | |
132 | -- initialization expression for an allocator, we pass the master of the | |
6dfc5592 | 133 | -- access type. If the function call is the initialization expression for a |
1399d355 AC |
134 | -- return object, we pass along the master passed in by the caller. In most |
135 | -- contexts, the activation chain to pass is the local one, which is | |
136 | -- indicated by No (Chain). However, in an allocator, the caller passes in | |
137 | -- the activation Chain. Note: Master_Actual can be Empty, but only if | |
138 | -- there are no tasks. | |
02822a92 | 139 | |
0691ed6b | 140 | function Caller_Known_Size |
1155ae01 AC |
141 | (Func_Call : Node_Id; |
142 | Result_Subt : Entity_Id) return Boolean; | |
0691ed6b AC |
143 | -- True if result subtype is definite, or has a size that does not require |
144 | -- secondary stack usage (i.e. no variant part or components whose type | |
145 | -- depends on discriminants). In particular, untagged types with only | |
146 | -- access discriminants do not require secondary stack use. Note we must | |
147 | -- always use the secondary stack for dispatching-on-result calls. | |
148 | ||
1ed19d98 JM |
149 | function Check_Number_Of_Actuals |
150 | (Subp_Call : Node_Id; | |
151 | Subp_Id : Entity_Id) return Boolean; | |
152 | -- Given a subprogram call to the given subprogram return True if the | |
153 | -- number of actual parameters (including extra actuals) is correct. | |
154 | ||
70482933 RK |
155 | procedure Check_Overriding_Operation (Subp : Entity_Id); |
156 | -- Subp is a dispatching operation. Check whether it may override an | |
157 | -- inherited private operation, in which case its DT entry is that of | |
158 | -- the hidden operation, not the one it may have received earlier. | |
159 | -- This must be done before emitting the code to set the corresponding | |
160 | -- DT to the address of the subprogram. The actual placement of Subp in | |
161 | -- the proper place in the list of primitive operations is done in | |
162 | -- Declare_Inherited_Private_Subprograms, which also has to deal with | |
163 | -- implicit operations. This duplication is unavoidable for now??? | |
164 | ||
165 | procedure Detect_Infinite_Recursion (N : Node_Id; Spec : Entity_Id); | |
166 | -- This procedure is called only if the subprogram body N, whose spec | |
167 | -- has the given entity Spec, contains a parameterless recursive call. | |
168 | -- It attempts to generate runtime code to detect if this a case of | |
169 | -- infinite recursion. | |
170 | -- | |
171 | -- The body is scanned to determine dependencies. If the only external | |
172 | -- dependencies are on a small set of scalar variables, then the values | |
173 | -- of these variables are captured on entry to the subprogram, and if | |
174 | -- the values are not changed for the call, we know immediately that | |
175 | -- we have an infinite recursion. | |
176 | ||
ca1f6b29 | 177 | procedure Expand_Actuals |
ec40b86c HK |
178 | (N : Node_Id; |
179 | Subp : Entity_Id; | |
180 | Post_Call : out List_Id); | |
181 | -- Return a list of actions to take place after the call in Post_Call. The | |
182 | -- call will later be rewritten as an Expression_With_Actions, with the | |
183 | -- Post_Call actions inserted, and the call inside. | |
ca1f6b29 | 184 | -- |
ec40b86c HK |
185 | -- For each actual of an in-out or out parameter which is a numeric (view) |
186 | -- conversion of the form T (A), where A denotes a variable, we insert the | |
187 | -- declaration: | |
da574a86 AC |
188 | -- |
189 | -- Temp : T[ := T (A)]; | |
190 | -- | |
191 | -- prior to the call. Then we replace the actual with a reference to Temp, | |
192 | -- and append the assignment: | |
193 | -- | |
194 | -- A := TypeA (Temp); | |
195 | -- | |
196 | -- after the call. Here TypeA is the actual type of variable A. For out | |
197 | -- parameters, the initial declaration has no expression. If A is not an | |
198 | -- entity name, we generate instead: | |
199 | -- | |
200 | -- Var : TypeA renames A; | |
201 | -- Temp : T := Var; -- omitting expression for out parameter. | |
202 | -- ... | |
203 | -- Var := TypeA (Temp); | |
204 | -- | |
205 | -- For other in-out parameters, we emit the required constraint checks | |
206 | -- before and/or after the call. | |
207 | -- | |
208 | -- For all parameter modes, actuals that denote components and slices of | |
209 | -- packed arrays are expanded into suitable temporaries. | |
210 | -- | |
00907026 EB |
211 | -- For nonscalar objects that are possibly unaligned, add call by copy code |
212 | -- (copy in for IN and IN OUT, copy out for OUT and IN OUT). | |
da574a86 | 213 | -- |
5f6fb720 AC |
214 | -- For OUT and IN OUT parameters, add predicate checks after the call |
215 | -- based on the predicates of the actual type. | |
ca1f6b29 BD |
216 | |
217 | procedure Expand_Call_Helper (N : Node_Id; Post_Call : out List_Id); | |
ec40b86c | 218 | -- Does the main work of Expand_Call. Post_Call is as for Expand_Actuals. |
da574a86 | 219 | |
df3e68b1 HK |
220 | procedure Expand_Ctrl_Function_Call (N : Node_Id); |
221 | -- N is a function call which returns a controlled object. Transform the | |
222 | -- call into a temporary which retrieves the returned object from the | |
223 | -- secondary stack using 'reference. | |
224 | ||
2b3d67a5 | 225 | procedure Expand_Non_Function_Return (N : Node_Id); |
c9d70ab1 AC |
226 | -- Expand a simple return statement found in a procedure body, entry body, |
227 | -- accept statement, or an extended return statement. Note that all non- | |
228 | -- function returns are simple return statements. | |
2b3d67a5 | 229 | |
70482933 RK |
230 | function Expand_Protected_Object_Reference |
231 | (N : Node_Id; | |
02822a92 | 232 | Scop : Entity_Id) return Node_Id; |
70482933 RK |
233 | |
234 | procedure Expand_Protected_Subprogram_Call | |
235 | (N : Node_Id; | |
236 | Subp : Entity_Id; | |
237 | Scop : Entity_Id); | |
238 | -- A call to a protected subprogram within the protected object may appear | |
239 | -- as a regular call. The list of actuals must be expanded to contain a | |
240 | -- reference to the object itself, and the call becomes a call to the | |
241 | -- corresponding protected subprogram. | |
242 | ||
de01377c AC |
243 | procedure Expand_Simple_Function_Return (N : Node_Id); |
244 | -- Expand simple return from function. In the case where we are returning | |
245 | -- from a function body this is called by Expand_N_Simple_Return_Statement. | |
246 | ||
63585f75 SB |
247 | function Has_Unconstrained_Access_Discriminants |
248 | (Subtyp : Entity_Id) return Boolean; | |
de01377c AC |
249 | -- Returns True if the given subtype is unconstrained and has one or more |
250 | -- access discriminants. | |
2b3d67a5 | 251 | |
ec40b86c HK |
252 | procedure Insert_Post_Call_Actions (N : Node_Id; Post_Call : List_Id); |
253 | -- Insert the Post_Call list previously produced by routine Expand_Actuals | |
254 | -- or Expand_Call_Helper into the tree. | |
255 | ||
4ac62786 AC |
256 | procedure Replace_Renaming_Declaration_Id |
257 | (New_Decl : Node_Id; | |
258 | Orig_Decl : Node_Id); | |
259 | -- Replace the internal identifier of the new renaming declaration New_Decl | |
260 | -- with the identifier of its original declaration Orig_Decl exchanging the | |
261 | -- entities containing their defining identifiers to ensure the correct | |
262 | -- replacement of the object declaration by the object renaming declaration | |
263 | -- to avoid homograph conflicts (since the object declaration's defining | |
264 | -- identifier was already entered in the current scope). The Next_Entity | |
265 | -- links of the two entities are also swapped since the entities are part | |
266 | -- of the return scope's entity list and the list structure would otherwise | |
267 | -- be corrupted. The homonym chain is preserved as well. | |
268 | ||
2700b9c1 AC |
269 | procedure Rewrite_Function_Call_For_C (N : Node_Id); |
270 | -- When generating C code, replace a call to a function that returns an | |
271 | -- array into the generated procedure with an additional out parameter. | |
272 | ||
c79f6efd BD |
273 | procedure Set_Enclosing_Sec_Stack_Return (N : Node_Id); |
274 | -- N is a return statement for a function that returns its result on the | |
275 | -- secondary stack. This sets the Sec_Stack_Needed_For_Return flag on the | |
276 | -- function and all blocks and loops that the return statement is jumping | |
277 | -- out of. This ensures that the secondary stack is not released; otherwise | |
278 | -- the function result would be reclaimed before returning to the caller. | |
279 | ||
02822a92 RD |
280 | ---------------------------------------------- |
281 | -- Add_Access_Actual_To_Build_In_Place_Call -- | |
282 | ---------------------------------------------- | |
283 | ||
284 | procedure Add_Access_Actual_To_Build_In_Place_Call | |
285 | (Function_Call : Node_Id; | |
286 | Function_Id : Entity_Id; | |
f937473f RD |
287 | Return_Object : Node_Id; |
288 | Is_Access : Boolean := False) | |
02822a92 RD |
289 | is |
290 | Loc : constant Source_Ptr := Sloc (Function_Call); | |
291 | Obj_Address : Node_Id; | |
f937473f | 292 | Obj_Acc_Formal : Entity_Id; |
02822a92 RD |
293 | |
294 | begin | |
f937473f | 295 | -- Locate the implicit access parameter in the called function |
02822a92 | 296 | |
f937473f | 297 | Obj_Acc_Formal := Build_In_Place_Formal (Function_Id, BIP_Object_Access); |
02822a92 | 298 | |
f937473f RD |
299 | -- If no return object is provided, then pass null |
300 | ||
301 | if not Present (Return_Object) then | |
302 | Obj_Address := Make_Null (Loc); | |
7888a6ae | 303 | Set_Parent (Obj_Address, Function_Call); |
02822a92 | 304 | |
f937473f RD |
305 | -- If Return_Object is already an expression of an access type, then use |
306 | -- it directly, since it must be an access value denoting the return | |
307 | -- object, and couldn't possibly be the return object itself. | |
308 | ||
309 | elsif Is_Access then | |
310 | Obj_Address := Return_Object; | |
7888a6ae | 311 | Set_Parent (Obj_Address, Function_Call); |
02822a92 RD |
312 | |
313 | -- Apply Unrestricted_Access to caller's return object | |
314 | ||
f937473f RD |
315 | else |
316 | Obj_Address := | |
317 | Make_Attribute_Reference (Loc, | |
318 | Prefix => Return_Object, | |
319 | Attribute_Name => Name_Unrestricted_Access); | |
7888a6ae GD |
320 | |
321 | Set_Parent (Return_Object, Obj_Address); | |
322 | Set_Parent (Obj_Address, Function_Call); | |
f937473f | 323 | end if; |
02822a92 RD |
324 | |
325 | Analyze_And_Resolve (Obj_Address, Etype (Obj_Acc_Formal)); | |
326 | ||
327 | -- Build the parameter association for the new actual and add it to the | |
328 | -- end of the function's actuals. | |
329 | ||
f937473f RD |
330 | Add_Extra_Actual_To_Call (Function_Call, Obj_Acc_Formal, Obj_Address); |
331 | end Add_Access_Actual_To_Build_In_Place_Call; | |
332 | ||
3e7302c3 | 333 | ------------------------------------------------------ |
200b7162 | 334 | -- Add_Unconstrained_Actuals_To_Build_In_Place_Call -- |
3e7302c3 | 335 | ------------------------------------------------------ |
f937473f | 336 | |
200b7162 | 337 | procedure Add_Unconstrained_Actuals_To_Build_In_Place_Call |
f937473f RD |
338 | (Function_Call : Node_Id; |
339 | Function_Id : Entity_Id; | |
340 | Alloc_Form : BIP_Allocation_Form := Unspecified; | |
200b7162 BD |
341 | Alloc_Form_Exp : Node_Id := Empty; |
342 | Pool_Actual : Node_Id := Make_Null (No_Location)) | |
f937473f | 343 | is |
7d1d3a54 HK |
344 | Loc : constant Source_Ptr := Sloc (Function_Call); |
345 | ||
f937473f RD |
346 | Alloc_Form_Actual : Node_Id; |
347 | Alloc_Form_Formal : Node_Id; | |
200b7162 | 348 | Pool_Formal : Node_Id; |
f937473f RD |
349 | |
350 | begin | |
7d1d3a54 HK |
351 | -- Nothing to do when the size of the object is known, and the caller is |
352 | -- in charge of allocating it, and the callee doesn't unconditionally | |
353 | -- require an allocation form (such as due to having a tagged result). | |
354 | ||
355 | if not Needs_BIP_Alloc_Form (Function_Id) then | |
7888a6ae GD |
356 | return; |
357 | end if; | |
358 | ||
f937473f RD |
359 | -- Locate the implicit allocation form parameter in the called function. |
360 | -- Maybe it would be better for each implicit formal of a build-in-place | |
361 | -- function to have a flag or a Uint attribute to identify it. ??? | |
362 | ||
363 | Alloc_Form_Formal := Build_In_Place_Formal (Function_Id, BIP_Alloc_Form); | |
364 | ||
365 | if Present (Alloc_Form_Exp) then | |
366 | pragma Assert (Alloc_Form = Unspecified); | |
367 | ||
368 | Alloc_Form_Actual := Alloc_Form_Exp; | |
369 | ||
370 | else | |
371 | pragma Assert (Alloc_Form /= Unspecified); | |
372 | ||
373 | Alloc_Form_Actual := | |
374 | Make_Integer_Literal (Loc, | |
375 | Intval => UI_From_Int (BIP_Allocation_Form'Pos (Alloc_Form))); | |
376 | end if; | |
377 | ||
378 | Analyze_And_Resolve (Alloc_Form_Actual, Etype (Alloc_Form_Formal)); | |
379 | ||
380 | -- Build the parameter association for the new actual and add it to the | |
381 | -- end of the function's actuals. | |
382 | ||
383 | Add_Extra_Actual_To_Call | |
384 | (Function_Call, Alloc_Form_Formal, Alloc_Form_Actual); | |
200b7162 | 385 | |
7d1d3a54 HK |
386 | -- Pass the Storage_Pool parameter. This parameter is omitted on ZFP as |
387 | -- those targets do not support pools. | |
200b7162 | 388 | |
535a8637 | 389 | if RTE_Available (RE_Root_Storage_Pool_Ptr) then |
8417f4b2 AC |
390 | Pool_Formal := Build_In_Place_Formal (Function_Id, BIP_Storage_Pool); |
391 | Analyze_And_Resolve (Pool_Actual, Etype (Pool_Formal)); | |
392 | Add_Extra_Actual_To_Call | |
393 | (Function_Call, Pool_Formal, Pool_Actual); | |
394 | end if; | |
200b7162 | 395 | end Add_Unconstrained_Actuals_To_Build_In_Place_Call; |
f937473f | 396 | |
d3f70b35 AC |
397 | ----------------------------------------------------------- |
398 | -- Add_Finalization_Master_Actual_To_Build_In_Place_Call -- | |
399 | ----------------------------------------------------------- | |
df3e68b1 | 400 | |
d3f70b35 | 401 | procedure Add_Finalization_Master_Actual_To_Build_In_Place_Call |
2c17ca0a AC |
402 | (Func_Call : Node_Id; |
403 | Func_Id : Entity_Id; | |
404 | Ptr_Typ : Entity_Id := Empty; | |
405 | Master_Exp : Node_Id := Empty) | |
df3e68b1 HK |
406 | is |
407 | begin | |
d3f70b35 | 408 | if not Needs_BIP_Finalization_Master (Func_Id) then |
df3e68b1 HK |
409 | return; |
410 | end if; | |
411 | ||
412 | declare | |
413 | Formal : constant Entity_Id := | |
d3f70b35 | 414 | Build_In_Place_Formal (Func_Id, BIP_Finalization_Master); |
df3e68b1 HK |
415 | Loc : constant Source_Ptr := Sloc (Func_Call); |
416 | ||
417 | Actual : Node_Id; | |
418 | Desig_Typ : Entity_Id; | |
419 | ||
420 | begin | |
2c17ca0a AC |
421 | -- If there is a finalization master actual, such as the implicit |
422 | -- finalization master of an enclosing build-in-place function, | |
423 | -- then this must be added as an extra actual of the call. | |
424 | ||
425 | if Present (Master_Exp) then | |
426 | Actual := Master_Exp; | |
427 | ||
d3f70b35 | 428 | -- Case where the context does not require an actual master |
df3e68b1 | 429 | |
2c17ca0a | 430 | elsif No (Ptr_Typ) then |
df3e68b1 HK |
431 | Actual := Make_Null (Loc); |
432 | ||
433 | else | |
434 | Desig_Typ := Directly_Designated_Type (Ptr_Typ); | |
435 | ||
436 | -- Check for a library-level access type whose designated type has | |
a267d8cc AC |
437 | -- suppressed finalization or the access type is subject to pragma |
438 | -- No_Heap_Finalization. Such an access type lacks a master. Pass | |
439 | -- a null actual to callee in order to signal a missing master. | |
df3e68b1 HK |
440 | |
441 | if Is_Library_Level_Entity (Ptr_Typ) | |
cccb761b | 442 | and then (Finalize_Storage_Only (Desig_Typ) |
a267d8cc | 443 | or else No_Heap_Finalization (Ptr_Typ)) |
df3e68b1 HK |
444 | then |
445 | Actual := Make_Null (Loc); | |
446 | ||
447 | -- Types in need of finalization actions | |
448 | ||
449 | elsif Needs_Finalization (Desig_Typ) then | |
450 | ||
d3f70b35 AC |
451 | -- The general mechanism of creating finalization masters for |
452 | -- anonymous access types is disabled by default, otherwise | |
453 | -- finalization masters will pop all over the place. Such types | |
454 | -- use context-specific masters. | |
df3e68b1 HK |
455 | |
456 | if Ekind (Ptr_Typ) = E_Anonymous_Access_Type | |
d3f70b35 | 457 | and then No (Finalization_Master (Ptr_Typ)) |
df3e68b1 | 458 | then |
32b794c8 | 459 | Build_Anonymous_Master (Ptr_Typ); |
df3e68b1 HK |
460 | end if; |
461 | ||
d3f70b35 | 462 | -- Access-to-controlled types should always have a master |
df3e68b1 | 463 | |
d3f70b35 | 464 | pragma Assert (Present (Finalization_Master (Ptr_Typ))); |
df3e68b1 HK |
465 | |
466 | Actual := | |
467 | Make_Attribute_Reference (Loc, | |
468 | Prefix => | |
e4494292 | 469 | New_Occurrence_Of (Finalization_Master (Ptr_Typ), Loc), |
df3e68b1 HK |
470 | Attribute_Name => Name_Unrestricted_Access); |
471 | ||
472 | -- Tagged types | |
473 | ||
474 | else | |
475 | Actual := Make_Null (Loc); | |
476 | end if; | |
477 | end if; | |
478 | ||
479 | Analyze_And_Resolve (Actual, Etype (Formal)); | |
480 | ||
481 | -- Build the parameter association for the new actual and add it to | |
482 | -- the end of the function's actuals. | |
483 | ||
484 | Add_Extra_Actual_To_Call (Func_Call, Formal, Actual); | |
485 | end; | |
d3f70b35 | 486 | end Add_Finalization_Master_Actual_To_Build_In_Place_Call; |
df3e68b1 | 487 | |
f937473f RD |
488 | ------------------------------ |
489 | -- Add_Extra_Actual_To_Call -- | |
490 | ------------------------------ | |
491 | ||
492 | procedure Add_Extra_Actual_To_Call | |
493 | (Subprogram_Call : Node_Id; | |
494 | Extra_Formal : Entity_Id; | |
495 | Extra_Actual : Node_Id) | |
496 | is | |
497 | Loc : constant Source_Ptr := Sloc (Subprogram_Call); | |
498 | Param_Assoc : Node_Id; | |
499 | ||
500 | begin | |
02822a92 RD |
501 | Param_Assoc := |
502 | Make_Parameter_Association (Loc, | |
f937473f RD |
503 | Selector_Name => New_Occurrence_Of (Extra_Formal, Loc), |
504 | Explicit_Actual_Parameter => Extra_Actual); | |
02822a92 | 505 | |
f937473f RD |
506 | Set_Parent (Param_Assoc, Subprogram_Call); |
507 | Set_Parent (Extra_Actual, Param_Assoc); | |
02822a92 | 508 | |
f937473f RD |
509 | if Present (Parameter_Associations (Subprogram_Call)) then |
510 | if Nkind (Last (Parameter_Associations (Subprogram_Call))) = | |
02822a92 RD |
511 | N_Parameter_Association |
512 | then | |
f937473f RD |
513 | |
514 | -- Find last named actual, and append | |
515 | ||
516 | declare | |
517 | L : Node_Id; | |
518 | begin | |
519 | L := First_Actual (Subprogram_Call); | |
520 | while Present (L) loop | |
521 | if No (Next_Actual (L)) then | |
522 | Set_Next_Named_Actual (Parent (L), Extra_Actual); | |
523 | exit; | |
524 | end if; | |
525 | Next_Actual (L); | |
526 | end loop; | |
527 | end; | |
528 | ||
02822a92 | 529 | else |
f937473f | 530 | Set_First_Named_Actual (Subprogram_Call, Extra_Actual); |
02822a92 RD |
531 | end if; |
532 | ||
f937473f | 533 | Append (Param_Assoc, To => Parameter_Associations (Subprogram_Call)); |
02822a92 RD |
534 | |
535 | else | |
f937473f RD |
536 | Set_Parameter_Associations (Subprogram_Call, New_List (Param_Assoc)); |
537 | Set_First_Named_Actual (Subprogram_Call, Extra_Actual); | |
02822a92 | 538 | end if; |
f937473f RD |
539 | end Add_Extra_Actual_To_Call; |
540 | ||
f937473f RD |
541 | --------------------------------------------- |
542 | -- Add_Task_Actuals_To_Build_In_Place_Call -- | |
543 | --------------------------------------------- | |
544 | ||
545 | procedure Add_Task_Actuals_To_Build_In_Place_Call | |
546 | (Function_Call : Node_Id; | |
547 | Function_Id : Entity_Id; | |
1399d355 AC |
548 | Master_Actual : Node_Id; |
549 | Chain : Node_Id := Empty) | |
f937473f | 550 | is |
af89615f | 551 | Loc : constant Source_Ptr := Sloc (Function_Call); |
af89615f AC |
552 | Actual : Node_Id; |
553 | Chain_Actual : Node_Id; | |
554 | Chain_Formal : Node_Id; | |
555 | Master_Formal : Node_Id; | |
6dfc5592 | 556 | |
f937473f RD |
557 | begin |
558 | -- No such extra parameters are needed if there are no tasks | |
559 | ||
1ed19d98 | 560 | if not Needs_BIP_Task_Actuals (Function_Id) then |
f937473f RD |
561 | return; |
562 | end if; | |
563 | ||
af89615f AC |
564 | Actual := Master_Actual; |
565 | ||
44bf8eb0 AC |
566 | -- Use a dummy _master actual in case of No_Task_Hierarchy |
567 | ||
568 | if Restriction_Active (No_Task_Hierarchy) then | |
569 | Actual := New_Occurrence_Of (RTE (RE_Library_Task_Level), Loc); | |
94bbf008 AC |
570 | |
571 | -- In the case where we use the master associated with an access type, | |
572 | -- the actual is an entity and requires an explicit reference. | |
573 | ||
574 | elsif Nkind (Actual) = N_Defining_Identifier then | |
e4494292 | 575 | Actual := New_Occurrence_Of (Actual, Loc); |
44bf8eb0 AC |
576 | end if; |
577 | ||
af89615f | 578 | -- Locate the implicit master parameter in the called function |
f937473f | 579 | |
af89615f AC |
580 | Master_Formal := Build_In_Place_Formal (Function_Id, BIP_Task_Master); |
581 | Analyze_And_Resolve (Actual, Etype (Master_Formal)); | |
f937473f | 582 | |
af89615f AC |
583 | -- Build the parameter association for the new actual and add it to the |
584 | -- end of the function's actuals. | |
f937473f | 585 | |
af89615f | 586 | Add_Extra_Actual_To_Call (Function_Call, Master_Formal, Actual); |
75a64833 | 587 | |
af89615f | 588 | -- Locate the implicit activation chain parameter in the called function |
f937473f | 589 | |
af89615f AC |
590 | Chain_Formal := |
591 | Build_In_Place_Formal (Function_Id, BIP_Activation_Chain); | |
f937473f | 592 | |
af89615f | 593 | -- Create the actual which is a pointer to the current activation chain |
f937473f | 594 | |
1399d355 AC |
595 | if No (Chain) then |
596 | Chain_Actual := | |
597 | Make_Attribute_Reference (Loc, | |
598 | Prefix => Make_Identifier (Loc, Name_uChain), | |
599 | Attribute_Name => Name_Unrestricted_Access); | |
600 | ||
601 | -- Allocator case; make a reference to the Chain passed in by the caller | |
602 | ||
603 | else | |
604 | Chain_Actual := | |
605 | Make_Attribute_Reference (Loc, | |
606 | Prefix => New_Occurrence_Of (Chain, Loc), | |
607 | Attribute_Name => Name_Unrestricted_Access); | |
608 | end if; | |
f937473f | 609 | |
af89615f | 610 | Analyze_And_Resolve (Chain_Actual, Etype (Chain_Formal)); |
f937473f | 611 | |
af89615f AC |
612 | -- Build the parameter association for the new actual and add it to the |
613 | -- end of the function's actuals. | |
f937473f | 614 | |
af89615f | 615 | Add_Extra_Actual_To_Call (Function_Call, Chain_Formal, Chain_Actual); |
f937473f RD |
616 | end Add_Task_Actuals_To_Build_In_Place_Call; |
617 | ||
618 | ----------------------- | |
619 | -- BIP_Formal_Suffix -- | |
620 | ----------------------- | |
621 | ||
622 | function BIP_Formal_Suffix (Kind : BIP_Formal_Kind) return String is | |
623 | begin | |
624 | case Kind is | |
d8f43ee6 | 625 | when BIP_Alloc_Form => |
f937473f | 626 | return "BIPalloc"; |
d8f43ee6 HK |
627 | |
628 | when BIP_Storage_Pool => | |
200b7162 | 629 | return "BIPstoragepool"; |
d8f43ee6 | 630 | |
d3f70b35 AC |
631 | when BIP_Finalization_Master => |
632 | return "BIPfinalizationmaster"; | |
d8f43ee6 HK |
633 | |
634 | when BIP_Task_Master => | |
af89615f | 635 | return "BIPtaskmaster"; |
d8f43ee6 HK |
636 | |
637 | when BIP_Activation_Chain => | |
f937473f | 638 | return "BIPactivationchain"; |
d8f43ee6 HK |
639 | |
640 | when BIP_Object_Access => | |
f937473f RD |
641 | return "BIPaccess"; |
642 | end case; | |
643 | end BIP_Formal_Suffix; | |
644 | ||
645 | --------------------------- | |
646 | -- Build_In_Place_Formal -- | |
647 | --------------------------- | |
648 | ||
649 | function Build_In_Place_Formal | |
650 | (Func : Entity_Id; | |
651 | Kind : BIP_Formal_Kind) return Entity_Id | |
652 | is | |
16d92641 | 653 | Formal_Suffix : constant String := BIP_Formal_Suffix (Kind); |
f937473f RD |
654 | Extra_Formal : Entity_Id := Extra_Formals (Func); |
655 | ||
656 | begin | |
657 | -- Maybe it would be better for each implicit formal of a build-in-place | |
658 | -- function to have a flag or a Uint attribute to identify it. ??? | |
659 | ||
0d566e01 ES |
660 | -- The return type in the function declaration may have been a limited |
661 | -- view, and the extra formals for the function were not generated at | |
aeae67ed | 662 | -- that point. At the point of call the full view must be available and |
0d566e01 ES |
663 | -- the extra formals can be created. |
664 | ||
665 | if No (Extra_Formal) then | |
666 | Create_Extra_Formals (Func); | |
667 | Extra_Formal := Extra_Formals (Func); | |
668 | end if; | |
669 | ||
16d92641 PMR |
670 | -- We search for a formal with a matching suffix. We can't search |
671 | -- for the full name, because of the code at the end of Sem_Ch6.- | |
672 | -- Create_Extra_Formals, which copies the Extra_Formals over to | |
673 | -- the Alias of an instance, which will cause the formals to have | |
674 | -- "incorrect" names. | |
675 | ||
f937473f | 676 | loop |
19590d70 | 677 | pragma Assert (Present (Extra_Formal)); |
16d92641 PMR |
678 | declare |
679 | Name : constant String := Get_Name_String (Chars (Extra_Formal)); | |
680 | begin | |
681 | exit when Name'Length >= Formal_Suffix'Length | |
682 | and then Formal_Suffix = | |
683 | Name (Name'Last - Formal_Suffix'Length + 1 .. Name'Last); | |
684 | end; | |
af89615f | 685 | |
f937473f RD |
686 | Next_Formal_With_Extras (Extra_Formal); |
687 | end loop; | |
688 | ||
f937473f RD |
689 | return Extra_Formal; |
690 | end Build_In_Place_Formal; | |
02822a92 | 691 | |
4039e173 AC |
692 | ------------------------------- |
693 | -- Build_Procedure_Body_Form -- | |
694 | ------------------------------- | |
695 | ||
696 | function Build_Procedure_Body_Form | |
697 | (Func_Id : Entity_Id; | |
698 | Func_Body : Node_Id) return Node_Id | |
699 | is | |
700 | Loc : constant Source_Ptr := Sloc (Func_Body); | |
701 | ||
702 | Proc_Decl : constant Node_Id := | |
703 | Next (Unit_Declaration_Node (Func_Id)); | |
704 | -- It is assumed that the next node following the declaration of the | |
705 | -- corresponding subprogram spec is the declaration of the procedure | |
706 | -- form. | |
707 | ||
708 | Proc_Id : constant Entity_Id := Defining_Entity (Proc_Decl); | |
709 | ||
710 | procedure Replace_Returns (Param_Id : Entity_Id; Stmts : List_Id); | |
711 | -- Replace each return statement found in the list Stmts with an | |
712 | -- assignment of the return expression to parameter Param_Id. | |
713 | ||
714 | --------------------- | |
715 | -- Replace_Returns -- | |
716 | --------------------- | |
717 | ||
718 | procedure Replace_Returns (Param_Id : Entity_Id; Stmts : List_Id) is | |
719 | Stmt : Node_Id; | |
720 | ||
721 | begin | |
722 | Stmt := First (Stmts); | |
723 | while Present (Stmt) loop | |
724 | if Nkind (Stmt) = N_Block_Statement then | |
8f8f531f PMR |
725 | Replace_Returns (Param_Id, |
726 | Statements (Handled_Statement_Sequence (Stmt))); | |
4039e173 AC |
727 | |
728 | elsif Nkind (Stmt) = N_Case_Statement then | |
729 | declare | |
730 | Alt : Node_Id; | |
731 | begin | |
732 | Alt := First (Alternatives (Stmt)); | |
733 | while Present (Alt) loop | |
734 | Replace_Returns (Param_Id, Statements (Alt)); | |
735 | Next (Alt); | |
736 | end loop; | |
737 | end; | |
738 | ||
17fd72ce ES |
739 | elsif Nkind (Stmt) = N_Extended_Return_Statement then |
740 | declare | |
741 | Ret_Obj : constant Entity_Id := | |
742 | Defining_Entity | |
743 | (First (Return_Object_Declarations (Stmt))); | |
744 | Assign : constant Node_Id := | |
745 | Make_Assignment_Statement (Sloc (Stmt), | |
746 | Name => | |
747 | New_Occurrence_Of (Param_Id, Loc), | |
748 | Expression => | |
749 | New_Occurrence_Of (Ret_Obj, Sloc (Stmt))); | |
a14bbbb4 | 750 | Stmts : List_Id; |
17fd72ce ES |
751 | |
752 | begin | |
6dc87f5f | 753 | -- The extended return may just contain the declaration |
a14bbbb4 AC |
754 | |
755 | if Present (Handled_Statement_Sequence (Stmt)) then | |
6dc87f5f | 756 | Stmts := Statements (Handled_Statement_Sequence (Stmt)); |
a14bbbb4 AC |
757 | else |
758 | Stmts := New_List; | |
759 | end if; | |
760 | ||
17fd72ce ES |
761 | Set_Assignment_OK (Name (Assign)); |
762 | ||
763 | Rewrite (Stmt, | |
764 | Make_Block_Statement (Sloc (Stmt), | |
765 | Declarations => | |
766 | Return_Object_Declarations (Stmt), | |
767 | Handled_Statement_Sequence => | |
768 | Make_Handled_Sequence_Of_Statements (Loc, | |
a14bbbb4 | 769 | Statements => Stmts))); |
17fd72ce ES |
770 | |
771 | Replace_Returns (Param_Id, Stmts); | |
772 | ||
773 | Append_To (Stmts, Assign); | |
774 | Append_To (Stmts, Make_Simple_Return_Statement (Loc)); | |
775 | end; | |
776 | ||
4039e173 AC |
777 | elsif Nkind (Stmt) = N_If_Statement then |
778 | Replace_Returns (Param_Id, Then_Statements (Stmt)); | |
779 | Replace_Returns (Param_Id, Else_Statements (Stmt)); | |
780 | ||
781 | declare | |
782 | Part : Node_Id; | |
783 | begin | |
784 | Part := First (Elsif_Parts (Stmt)); | |
785 | while Present (Part) loop | |
0ef5cd0a | 786 | Replace_Returns (Param_Id, Then_Statements (Part)); |
4039e173 AC |
787 | Next (Part); |
788 | end loop; | |
789 | end; | |
790 | ||
791 | elsif Nkind (Stmt) = N_Loop_Statement then | |
792 | Replace_Returns (Param_Id, Statements (Stmt)); | |
793 | ||
794 | elsif Nkind (Stmt) = N_Simple_Return_Statement then | |
795 | ||
796 | -- Generate: | |
797 | -- Param := Expr; | |
798 | -- return; | |
799 | ||
800 | Rewrite (Stmt, | |
801 | Make_Assignment_Statement (Sloc (Stmt), | |
802 | Name => New_Occurrence_Of (Param_Id, Loc), | |
803 | Expression => Relocate_Node (Expression (Stmt)))); | |
804 | ||
805 | Insert_After (Stmt, Make_Simple_Return_Statement (Loc)); | |
806 | ||
807 | -- Skip the added return | |
808 | ||
809 | Next (Stmt); | |
810 | end if; | |
811 | ||
812 | Next (Stmt); | |
813 | end loop; | |
814 | end Replace_Returns; | |
815 | ||
816 | -- Local variables | |
817 | ||
818 | Stmts : List_Id; | |
819 | New_Body : Node_Id; | |
820 | ||
821 | -- Start of processing for Build_Procedure_Body_Form | |
822 | ||
823 | begin | |
824 | -- This routine replaces the original function body: | |
825 | ||
826 | -- function F (...) return Array_Typ is | |
827 | -- begin | |
828 | -- ... | |
829 | -- return Something; | |
830 | -- end F; | |
831 | ||
832 | -- with the following: | |
833 | ||
834 | -- procedure P (..., Result : out Array_Typ) is | |
835 | -- begin | |
836 | -- ... | |
837 | -- Result := Something; | |
838 | -- end P; | |
839 | ||
840 | Stmts := | |
841 | Statements (Handled_Statement_Sequence (Func_Body)); | |
842 | Replace_Returns (Last_Entity (Proc_Id), Stmts); | |
843 | ||
844 | New_Body := | |
845 | Make_Subprogram_Body (Loc, | |
846 | Specification => | |
847 | Copy_Subprogram_Spec (Specification (Proc_Decl)), | |
848 | Declarations => Declarations (Func_Body), | |
849 | Handled_Statement_Sequence => | |
850 | Make_Handled_Sequence_Of_Statements (Loc, | |
851 | Statements => Stmts)); | |
852 | ||
0ef5cd0a AC |
853 | -- If the function is a generic instance, so is the new procedure. |
854 | -- Set flag accordingly so that the proper renaming declarations are | |
855 | -- generated. | |
856 | ||
857 | Set_Is_Generic_Instance (Proc_Id, Is_Generic_Instance (Func_Id)); | |
4039e173 AC |
858 | return New_Body; |
859 | end Build_Procedure_Body_Form; | |
860 | ||
0691ed6b AC |
861 | ----------------------- |
862 | -- Caller_Known_Size -- | |
863 | ----------------------- | |
864 | ||
865 | function Caller_Known_Size | |
1155ae01 AC |
866 | (Func_Call : Node_Id; |
867 | Result_Subt : Entity_Id) return Boolean | |
868 | is | |
0691ed6b | 869 | begin |
1155ae01 AC |
870 | return |
871 | (Is_Definite_Subtype (Underlying_Type (Result_Subt)) | |
872 | and then No (Controlling_Argument (Func_Call))) | |
873 | or else not Requires_Transient_Scope (Underlying_Type (Result_Subt)); | |
0691ed6b AC |
874 | end Caller_Known_Size; |
875 | ||
1ed19d98 JM |
876 | ----------------------------- |
877 | -- Check_Number_Of_Actuals -- | |
878 | ----------------------------- | |
879 | ||
880 | function Check_Number_Of_Actuals | |
881 | (Subp_Call : Node_Id; | |
882 | Subp_Id : Entity_Id) return Boolean | |
883 | is | |
884 | Formal : Entity_Id; | |
885 | Actual : Node_Id; | |
886 | ||
887 | begin | |
888 | pragma Assert (Nkind_In (Subp_Call, N_Entry_Call_Statement, | |
889 | N_Function_Call, | |
890 | N_Procedure_Call_Statement)); | |
891 | ||
892 | Formal := First_Formal_With_Extras (Subp_Id); | |
893 | Actual := First_Actual (Subp_Call); | |
894 | ||
895 | while Present (Formal) and then Present (Actual) loop | |
896 | Next_Formal_With_Extras (Formal); | |
897 | Next_Actual (Actual); | |
898 | end loop; | |
899 | ||
900 | return No (Formal) and then No (Actual); | |
901 | end Check_Number_Of_Actuals; | |
902 | ||
c9a4817d RD |
903 | -------------------------------- |
904 | -- Check_Overriding_Operation -- | |
905 | -------------------------------- | |
70482933 RK |
906 | |
907 | procedure Check_Overriding_Operation (Subp : Entity_Id) is | |
908 | Typ : constant Entity_Id := Find_Dispatching_Type (Subp); | |
909 | Op_List : constant Elist_Id := Primitive_Operations (Typ); | |
910 | Op_Elmt : Elmt_Id; | |
911 | Prim_Op : Entity_Id; | |
912 | Par_Op : Entity_Id; | |
913 | ||
914 | begin | |
915 | if Is_Derived_Type (Typ) | |
916 | and then not Is_Private_Type (Typ) | |
917 | and then In_Open_Scopes (Scope (Etype (Typ))) | |
d347f572 | 918 | and then Is_Base_Type (Typ) |
70482933 | 919 | then |
2f1b20a9 ES |
920 | -- Subp overrides an inherited private operation if there is an |
921 | -- inherited operation with a different name than Subp (see | |
922 | -- Derive_Subprogram) whose Alias is a hidden subprogram with the | |
923 | -- same name as Subp. | |
70482933 RK |
924 | |
925 | Op_Elmt := First_Elmt (Op_List); | |
926 | while Present (Op_Elmt) loop | |
927 | Prim_Op := Node (Op_Elmt); | |
928 | Par_Op := Alias (Prim_Op); | |
929 | ||
930 | if Present (Par_Op) | |
931 | and then not Comes_From_Source (Prim_Op) | |
932 | and then Chars (Prim_Op) /= Chars (Par_Op) | |
933 | and then Chars (Par_Op) = Chars (Subp) | |
934 | and then Is_Hidden (Par_Op) | |
935 | and then Type_Conformant (Prim_Op, Subp) | |
936 | then | |
024d33d8 | 937 | Set_DT_Position_Value (Subp, DT_Position (Prim_Op)); |
70482933 RK |
938 | end if; |
939 | ||
940 | Next_Elmt (Op_Elmt); | |
941 | end loop; | |
942 | end if; | |
943 | end Check_Overriding_Operation; | |
944 | ||
945 | ------------------------------- | |
946 | -- Detect_Infinite_Recursion -- | |
947 | ------------------------------- | |
948 | ||
949 | procedure Detect_Infinite_Recursion (N : Node_Id; Spec : Entity_Id) is | |
950 | Loc : constant Source_Ptr := Sloc (N); | |
951 | ||
fbf5a39b | 952 | Var_List : constant Elist_Id := New_Elmt_List; |
70482933 RK |
953 | -- List of globals referenced by body of procedure |
954 | ||
fbf5a39b | 955 | Call_List : constant Elist_Id := New_Elmt_List; |
70482933 RK |
956 | -- List of recursive calls in body of procedure |
957 | ||
fbf5a39b | 958 | Shad_List : constant Elist_Id := New_Elmt_List; |
2f1b20a9 ES |
959 | -- List of entity id's for entities created to capture the value of |
960 | -- referenced globals on entry to the procedure. | |
70482933 RK |
961 | |
962 | Scop : constant Uint := Scope_Depth (Spec); | |
2f1b20a9 ES |
963 | -- This is used to record the scope depth of the current procedure, so |
964 | -- that we can identify global references. | |
70482933 RK |
965 | |
966 | Max_Vars : constant := 4; | |
967 | -- Do not test more than four global variables | |
968 | ||
969 | Count_Vars : Natural := 0; | |
970 | -- Count variables found so far | |
971 | ||
972 | Var : Entity_Id; | |
973 | Elm : Elmt_Id; | |
974 | Ent : Entity_Id; | |
975 | Call : Elmt_Id; | |
976 | Decl : Node_Id; | |
977 | Test : Node_Id; | |
978 | Elm1 : Elmt_Id; | |
979 | Elm2 : Elmt_Id; | |
980 | Last : Node_Id; | |
981 | ||
982 | function Process (Nod : Node_Id) return Traverse_Result; | |
983 | -- Function to traverse the subprogram body (using Traverse_Func) | |
984 | ||
985 | ------------- | |
986 | -- Process -- | |
987 | ------------- | |
988 | ||
989 | function Process (Nod : Node_Id) return Traverse_Result is | |
990 | begin | |
991 | -- Procedure call | |
992 | ||
993 | if Nkind (Nod) = N_Procedure_Call_Statement then | |
994 | ||
995 | -- Case of one of the detected recursive calls | |
996 | ||
997 | if Is_Entity_Name (Name (Nod)) | |
998 | and then Has_Recursive_Call (Entity (Name (Nod))) | |
999 | and then Entity (Name (Nod)) = Spec | |
1000 | then | |
1001 | Append_Elmt (Nod, Call_List); | |
1002 | return Skip; | |
1003 | ||
1004 | -- Any other procedure call may have side effects | |
1005 | ||
1006 | else | |
1007 | return Abandon; | |
1008 | end if; | |
1009 | ||
1010 | -- A call to a pure function can always be ignored | |
1011 | ||
1012 | elsif Nkind (Nod) = N_Function_Call | |
1013 | and then Is_Entity_Name (Name (Nod)) | |
1014 | and then Is_Pure (Entity (Name (Nod))) | |
1015 | then | |
1016 | return Skip; | |
1017 | ||
1018 | -- Case of an identifier reference | |
1019 | ||
1020 | elsif Nkind (Nod) = N_Identifier then | |
1021 | Ent := Entity (Nod); | |
1022 | ||
1023 | -- If no entity, then ignore the reference | |
1024 | ||
1025 | -- Not clear why this can happen. To investigate, remove this | |
1026 | -- test and look at the crash that occurs here in 3401-004 ??? | |
1027 | ||
1028 | if No (Ent) then | |
1029 | return Skip; | |
1030 | ||
1031 | -- Ignore entities with no Scope, again not clear how this | |
1032 | -- can happen, to investigate, look at 4108-008 ??? | |
1033 | ||
1034 | elsif No (Scope (Ent)) then | |
1035 | return Skip; | |
1036 | ||
1037 | -- Ignore the reference if not to a more global object | |
1038 | ||
1039 | elsif Scope_Depth (Scope (Ent)) >= Scop then | |
1040 | return Skip; | |
1041 | ||
1042 | -- References to types, exceptions and constants are always OK | |
1043 | ||
1044 | elsif Is_Type (Ent) | |
1045 | or else Ekind (Ent) = E_Exception | |
1046 | or else Ekind (Ent) = E_Constant | |
1047 | then | |
1048 | return Skip; | |
1049 | ||
1050 | -- If other than a non-volatile scalar variable, we have some | |
1051 | -- kind of global reference (e.g. to a function) that we cannot | |
1052 | -- deal with so we forget the attempt. | |
1053 | ||
1054 | elsif Ekind (Ent) /= E_Variable | |
1055 | or else not Is_Scalar_Type (Etype (Ent)) | |
fbf5a39b | 1056 | or else Treat_As_Volatile (Ent) |
70482933 RK |
1057 | then |
1058 | return Abandon; | |
1059 | ||
1060 | -- Otherwise we have a reference to a global scalar | |
1061 | ||
1062 | else | |
1063 | -- Loop through global entities already detected | |
1064 | ||
1065 | Elm := First_Elmt (Var_List); | |
1066 | loop | |
1067 | -- If not detected before, record this new global reference | |
1068 | ||
1069 | if No (Elm) then | |
1070 | Count_Vars := Count_Vars + 1; | |
1071 | ||
1072 | if Count_Vars <= Max_Vars then | |
1073 | Append_Elmt (Entity (Nod), Var_List); | |
1074 | else | |
1075 | return Abandon; | |
1076 | end if; | |
1077 | ||
1078 | exit; | |
1079 | ||
1080 | -- If recorded before, ignore | |
1081 | ||
1082 | elsif Node (Elm) = Entity (Nod) then | |
1083 | return Skip; | |
1084 | ||
1085 | -- Otherwise keep looking | |
1086 | ||
1087 | else | |
1088 | Next_Elmt (Elm); | |
1089 | end if; | |
1090 | end loop; | |
1091 | ||
1092 | return Skip; | |
1093 | end if; | |
1094 | ||
1095 | -- For all other node kinds, recursively visit syntactic children | |
1096 | ||
1097 | else | |
1098 | return OK; | |
1099 | end if; | |
1100 | end Process; | |
1101 | ||
02822a92 | 1102 | function Traverse_Body is new Traverse_Func (Process); |
70482933 RK |
1103 | |
1104 | -- Start of processing for Detect_Infinite_Recursion | |
1105 | ||
1106 | begin | |
2f1b20a9 ES |
1107 | -- Do not attempt detection in No_Implicit_Conditional mode, since we |
1108 | -- won't be able to generate the code to handle the recursion in any | |
1109 | -- case. | |
70482933 | 1110 | |
6e937c1c | 1111 | if Restriction_Active (No_Implicit_Conditionals) then |
70482933 RK |
1112 | return; |
1113 | end if; | |
1114 | ||
1115 | -- Otherwise do traversal and quit if we get abandon signal | |
1116 | ||
1117 | if Traverse_Body (N) = Abandon then | |
1118 | return; | |
1119 | ||
2f1b20a9 ES |
1120 | -- We must have a call, since Has_Recursive_Call was set. If not just |
1121 | -- ignore (this is only an error check, so if we have a funny situation, | |
a90bd866 | 1122 | -- due to bugs or errors, we do not want to bomb). |
70482933 RK |
1123 | |
1124 | elsif Is_Empty_Elmt_List (Call_List) then | |
1125 | return; | |
1126 | end if; | |
1127 | ||
1128 | -- Here is the case where we detect recursion at compile time | |
1129 | ||
2f1b20a9 ES |
1130 | -- Push our current scope for analyzing the declarations and code that |
1131 | -- we will insert for the checking. | |
70482933 | 1132 | |
7888a6ae | 1133 | Push_Scope (Spec); |
70482933 | 1134 | |
2f1b20a9 ES |
1135 | -- This loop builds temporary variables for each of the referenced |
1136 | -- globals, so that at the end of the loop the list Shad_List contains | |
1137 | -- these temporaries in one-to-one correspondence with the elements in | |
1138 | -- Var_List. | |
70482933 RK |
1139 | |
1140 | Last := Empty; | |
1141 | Elm := First_Elmt (Var_List); | |
1142 | while Present (Elm) loop | |
1143 | Var := Node (Elm); | |
c12beea0 | 1144 | Ent := Make_Temporary (Loc, 'S'); |
70482933 RK |
1145 | Append_Elmt (Ent, Shad_List); |
1146 | ||
2f1b20a9 ES |
1147 | -- Insert a declaration for this temporary at the start of the |
1148 | -- declarations for the procedure. The temporaries are declared as | |
1149 | -- constant objects initialized to the current values of the | |
1150 | -- corresponding temporaries. | |
70482933 RK |
1151 | |
1152 | Decl := | |
1153 | Make_Object_Declaration (Loc, | |
1154 | Defining_Identifier => Ent, | |
1155 | Object_Definition => New_Occurrence_Of (Etype (Var), Loc), | |
1156 | Constant_Present => True, | |
1157 | Expression => New_Occurrence_Of (Var, Loc)); | |
1158 | ||
1159 | if No (Last) then | |
1160 | Prepend (Decl, Declarations (N)); | |
1161 | else | |
1162 | Insert_After (Last, Decl); | |
1163 | end if; | |
1164 | ||
1165 | Last := Decl; | |
1166 | Analyze (Decl); | |
1167 | Next_Elmt (Elm); | |
1168 | end loop; | |
1169 | ||
1170 | -- Loop through calls | |
1171 | ||
1172 | Call := First_Elmt (Call_List); | |
1173 | while Present (Call) loop | |
1174 | ||
1175 | -- Build a predicate expression of the form | |
1176 | ||
1177 | -- True | |
1178 | -- and then global1 = temp1 | |
1179 | -- and then global2 = temp2 | |
1180 | -- ... | |
1181 | ||
1182 | -- This predicate determines if any of the global values | |
1183 | -- referenced by the procedure have changed since the | |
1184 | -- current call, if not an infinite recursion is assured. | |
1185 | ||
1186 | Test := New_Occurrence_Of (Standard_True, Loc); | |
1187 | ||
1188 | Elm1 := First_Elmt (Var_List); | |
1189 | Elm2 := First_Elmt (Shad_List); | |
1190 | while Present (Elm1) loop | |
1191 | Test := | |
1192 | Make_And_Then (Loc, | |
1193 | Left_Opnd => Test, | |
1194 | Right_Opnd => | |
1195 | Make_Op_Eq (Loc, | |
1196 | Left_Opnd => New_Occurrence_Of (Node (Elm1), Loc), | |
1197 | Right_Opnd => New_Occurrence_Of (Node (Elm2), Loc))); | |
1198 | ||
1199 | Next_Elmt (Elm1); | |
1200 | Next_Elmt (Elm2); | |
1201 | end loop; | |
1202 | ||
1203 | -- Now we replace the call with the sequence | |
1204 | ||
1205 | -- if no-changes (see above) then | |
1206 | -- raise Storage_Error; | |
1207 | -- else | |
1208 | -- original-call | |
1209 | -- end if; | |
1210 | ||
1211 | Rewrite (Node (Call), | |
1212 | Make_If_Statement (Loc, | |
1213 | Condition => Test, | |
1214 | Then_Statements => New_List ( | |
07fc65c4 GB |
1215 | Make_Raise_Storage_Error (Loc, |
1216 | Reason => SE_Infinite_Recursion)), | |
70482933 RK |
1217 | |
1218 | Else_Statements => New_List ( | |
1219 | Relocate_Node (Node (Call))))); | |
1220 | ||
1221 | Analyze (Node (Call)); | |
1222 | ||
1223 | Next_Elmt (Call); | |
1224 | end loop; | |
1225 | ||
1226 | -- Remove temporary scope stack entry used for analysis | |
1227 | ||
1228 | Pop_Scope; | |
1229 | end Detect_Infinite_Recursion; | |
1230 | ||
1231 | -------------------- | |
1232 | -- Expand_Actuals -- | |
1233 | -------------------- | |
1234 | ||
ca1f6b29 | 1235 | procedure Expand_Actuals |
ec40b86c HK |
1236 | (N : Node_Id; |
1237 | Subp : Entity_Id; | |
1238 | Post_Call : out List_Id) | |
ca1f6b29 | 1239 | is |
70482933 RK |
1240 | Loc : constant Source_Ptr := Sloc (N); |
1241 | Actual : Node_Id; | |
1242 | Formal : Entity_Id; | |
1243 | N_Node : Node_Id; | |
f6820c2d | 1244 | E_Actual : Entity_Id; |
70482933 RK |
1245 | E_Formal : Entity_Id; |
1246 | ||
1247 | procedure Add_Call_By_Copy_Code; | |
fbf5a39b AC |
1248 | -- For cases where the parameter must be passed by copy, this routine |
1249 | -- generates a temporary variable into which the actual is copied and | |
1250 | -- then passes this as the parameter. For an OUT or IN OUT parameter, | |
1251 | -- an assignment is also generated to copy the result back. The call | |
1252 | -- also takes care of any constraint checks required for the type | |
1253 | -- conversion case (on both the way in and the way out). | |
70482933 | 1254 | |
348c3ae6 | 1255 | procedure Add_Simple_Call_By_Copy_Code (Bit_Packed_Array : Boolean); |
f44fe430 RD |
1256 | -- This is similar to the above, but is used in cases where we know |
1257 | -- that all that is needed is to simply create a temporary and copy | |
348c3ae6 EB |
1258 | -- the value in and out of the temporary. If Bit_Packed_Array is True, |
1259 | -- the procedure is called for a bit-packed array actual. | |
70482933 | 1260 | |
62e45e3e HK |
1261 | procedure Add_Validation_Call_By_Copy_Code (Act : Node_Id); |
1262 | -- Perform copy-back for actual parameter Act which denotes a validation | |
1263 | -- variable. | |
1264 | ||
70482933 RK |
1265 | procedure Check_Fortran_Logical; |
1266 | -- A value of type Logical that is passed through a formal parameter | |
1267 | -- must be normalized because .TRUE. usually does not have the same | |
1268 | -- representation as True. We assume that .FALSE. = False = 0. | |
1269 | -- What about functions that return a logical type ??? | |
1270 | ||
758c442c GD |
1271 | function Is_Legal_Copy return Boolean; |
1272 | -- Check that an actual can be copied before generating the temporary | |
348c3ae6 EB |
1273 | -- to be used in the call. If the formal is of a by_reference type or |
1274 | -- is aliased, then the program is illegal (this can only happen in | |
1275 | -- the presence of representation clauses that force a misalignment) | |
1276 | -- If the formal is a by_reference parameter imposed by a DEC pragma, | |
1277 | -- emit a warning that this might lead to unaligned arguments. | |
758c442c | 1278 | |
70482933 | 1279 | function Make_Var (Actual : Node_Id) return Entity_Id; |
da574a86 AC |
1280 | -- Returns an entity that refers to the given actual parameter, Actual |
1281 | -- (not including any type conversion). If Actual is an entity name, | |
1282 | -- then this entity is returned unchanged, otherwise a renaming is | |
1283 | -- created to provide an entity for the actual. | |
70482933 RK |
1284 | |
1285 | procedure Reset_Packed_Prefix; | |
1286 | -- The expansion of a packed array component reference is delayed in | |
1287 | -- the context of a call. Now we need to complete the expansion, so we | |
1288 | -- unmark the analyzed bits in all prefixes. | |
1289 | ||
1290 | --------------------------- | |
1291 | -- Add_Call_By_Copy_Code -- | |
1292 | --------------------------- | |
1293 | ||
1294 | procedure Add_Call_By_Copy_Code is | |
db99c46e | 1295 | Crep : Boolean; |
cc335f43 | 1296 | Expr : Node_Id; |
db99c46e AC |
1297 | F_Typ : Entity_Id := Etype (Formal); |
1298 | Indic : Node_Id; | |
cc335f43 AC |
1299 | Init : Node_Id; |
1300 | Temp : Entity_Id; | |
cc335f43 | 1301 | V_Typ : Entity_Id; |
db99c46e | 1302 | Var : Entity_Id; |
70482933 RK |
1303 | |
1304 | begin | |
758c442c GD |
1305 | if not Is_Legal_Copy then |
1306 | return; | |
1307 | end if; | |
1308 | ||
b086849e | 1309 | Temp := Make_Temporary (Loc, 'T', Actual); |
70482933 | 1310 | |
db99c46e AC |
1311 | -- Handle formals whose type comes from the limited view |
1312 | ||
1313 | if From_Limited_With (F_Typ) | |
1314 | and then Has_Non_Limited_View (F_Typ) | |
1315 | then | |
1316 | F_Typ := Non_Limited_View (F_Typ); | |
1317 | end if; | |
1318 | ||
f44fe430 RD |
1319 | -- Use formal type for temp, unless formal type is an unconstrained |
1320 | -- array, in which case we don't have to worry about bounds checks, | |
758c442c | 1321 | -- and we use the actual type, since that has appropriate bounds. |
f44fe430 RD |
1322 | |
1323 | if Is_Array_Type (F_Typ) and then not Is_Constrained (F_Typ) then | |
1324 | Indic := New_Occurrence_Of (Etype (Actual), Loc); | |
1325 | else | |
db99c46e | 1326 | Indic := New_Occurrence_Of (F_Typ, Loc); |
f44fe430 RD |
1327 | end if; |
1328 | ||
13931a38 EB |
1329 | -- The new code will be properly analyzed below and the setting of |
1330 | -- the Do_Range_Check flag recomputed so remove the obsolete one. | |
1331 | ||
1332 | Set_Do_Range_Check (Actual, False); | |
1333 | ||
70482933 | 1334 | if Nkind (Actual) = N_Type_Conversion then |
13931a38 EB |
1335 | Set_Do_Range_Check (Expression (Actual), False); |
1336 | ||
70482933 | 1337 | V_Typ := Etype (Expression (Actual)); |
19f0526a AC |
1338 | |
1339 | -- If the formal is an (in-)out parameter, capture the name | |
1340 | -- of the variable in order to build the post-call assignment. | |
81a5b587 AC |
1341 | |
1342 | Var := Make_Var (Expression (Actual)); | |
19f0526a | 1343 | |
08aa9a4a | 1344 | Crep := not Same_Representation |
0da2c8ac | 1345 | (F_Typ, Etype (Expression (Actual))); |
08aa9a4a | 1346 | |
70482933 RK |
1347 | else |
1348 | V_Typ := Etype (Actual); | |
1349 | Var := Make_Var (Actual); | |
1350 | Crep := False; | |
1351 | end if; | |
1352 | ||
1353 | -- Setup initialization for case of in out parameter, or an out | |
1354 | -- parameter where the formal is an unconstrained array (in the | |
1355 | -- latter case, we have to pass in an object with bounds). | |
1356 | ||
cc335f43 AC |
1357 | -- If this is an out parameter, the initial copy is wasteful, so as |
1358 | -- an optimization for the one-dimensional case we extract the | |
1359 | -- bounds of the actual and build an uninitialized temporary of the | |
1360 | -- right size. | |
1361 | ||
e693ddbe EB |
1362 | -- If the formal is an out parameter with discriminants, the |
1363 | -- discriminants must be captured even if the rest of the object | |
1364 | -- is in principle uninitialized, because the discriminants may | |
1365 | -- be read by the called subprogram. | |
1366 | ||
70482933 | 1367 | if Ekind (Formal) = E_In_Out_Parameter |
0da2c8ac | 1368 | or else (Is_Array_Type (F_Typ) and then not Is_Constrained (F_Typ)) |
e693ddbe | 1369 | or else Has_Discriminants (F_Typ) |
70482933 RK |
1370 | then |
1371 | if Nkind (Actual) = N_Type_Conversion then | |
1372 | if Conversion_OK (Actual) then | |
0da2c8ac | 1373 | Init := OK_Convert_To (F_Typ, New_Occurrence_Of (Var, Loc)); |
70482933 | 1374 | else |
0da2c8ac | 1375 | Init := Convert_To (F_Typ, New_Occurrence_Of (Var, Loc)); |
70482933 | 1376 | end if; |
cc335f43 AC |
1377 | |
1378 | elsif Ekind (Formal) = E_Out_Parameter | |
0da2c8ac AC |
1379 | and then Is_Array_Type (F_Typ) |
1380 | and then Number_Dimensions (F_Typ) = 1 | |
1381 | and then not Has_Non_Null_Base_Init_Proc (F_Typ) | |
cc335f43 AC |
1382 | then |
1383 | -- Actual is a one-dimensional array or slice, and the type | |
1384 | -- requires no initialization. Create a temporary of the | |
f44fe430 | 1385 | -- right size, but do not copy actual into it (optimization). |
cc335f43 AC |
1386 | |
1387 | Init := Empty; | |
1388 | Indic := | |
1389 | Make_Subtype_Indication (Loc, | |
5f6fb720 | 1390 | Subtype_Mark => New_Occurrence_Of (F_Typ, Loc), |
cc335f43 AC |
1391 | Constraint => |
1392 | Make_Index_Or_Discriminant_Constraint (Loc, | |
1393 | Constraints => New_List ( | |
1394 | Make_Range (Loc, | |
1395 | Low_Bound => | |
1396 | Make_Attribute_Reference (Loc, | |
5f6fb720 | 1397 | Prefix => New_Occurrence_Of (Var, Loc), |
70f91180 | 1398 | Attribute_Name => Name_First), |
cc335f43 AC |
1399 | High_Bound => |
1400 | Make_Attribute_Reference (Loc, | |
5f6fb720 | 1401 | Prefix => New_Occurrence_Of (Var, Loc), |
cc335f43 AC |
1402 | Attribute_Name => Name_Last))))); |
1403 | ||
70482933 RK |
1404 | else |
1405 | Init := New_Occurrence_Of (Var, Loc); | |
1406 | end if; | |
1407 | ||
1408 | -- An initialization is created for packed conversions as | |
1409 | -- actuals for out parameters to enable Make_Object_Declaration | |
1410 | -- to determine the proper subtype for N_Node. Note that this | |
1411 | -- is wasteful because the extra copying on the call side is | |
1412 | -- not required for such out parameters. ??? | |
1413 | ||
1414 | elsif Ekind (Formal) = E_Out_Parameter | |
1415 | and then Nkind (Actual) = N_Type_Conversion | |
0da2c8ac | 1416 | and then (Is_Bit_Packed_Array (F_Typ) |
70482933 RK |
1417 | or else |
1418 | Is_Bit_Packed_Array (Etype (Expression (Actual)))) | |
1419 | then | |
1420 | if Conversion_OK (Actual) then | |
f44fe430 | 1421 | Init := OK_Convert_To (F_Typ, New_Occurrence_Of (Var, Loc)); |
70482933 | 1422 | else |
f44fe430 | 1423 | Init := Convert_To (F_Typ, New_Occurrence_Of (Var, Loc)); |
70482933 | 1424 | end if; |
2e071734 AC |
1425 | |
1426 | elsif Ekind (Formal) = E_In_Parameter then | |
02822a92 RD |
1427 | |
1428 | -- Handle the case in which the actual is a type conversion | |
1429 | ||
1430 | if Nkind (Actual) = N_Type_Conversion then | |
1431 | if Conversion_OK (Actual) then | |
1432 | Init := OK_Convert_To (F_Typ, New_Occurrence_Of (Var, Loc)); | |
1433 | else | |
1434 | Init := Convert_To (F_Typ, New_Occurrence_Of (Var, Loc)); | |
1435 | end if; | |
1436 | else | |
1437 | Init := New_Occurrence_Of (Var, Loc); | |
1438 | end if; | |
2e071734 | 1439 | |
68e4cc98 ES |
1440 | -- Access types are passed in without checks, but if a copy-back is |
1441 | -- required for a null-excluding check on an in-out or out parameter, | |
1442 | -- then the initial value is that of the actual. | |
1443 | ||
1444 | elsif Is_Access_Type (E_Formal) | |
1445 | and then Can_Never_Be_Null (Etype (Actual)) | |
1446 | and then not Can_Never_Be_Null (E_Formal) | |
1447 | then | |
1448 | Init := New_Occurrence_Of (Var, Loc); | |
1449 | ||
70482933 RK |
1450 | else |
1451 | Init := Empty; | |
1452 | end if; | |
1453 | ||
1454 | N_Node := | |
1455 | Make_Object_Declaration (Loc, | |
1456 | Defining_Identifier => Temp, | |
cc335f43 | 1457 | Object_Definition => Indic, |
f44fe430 | 1458 | Expression => Init); |
70482933 RK |
1459 | Set_Assignment_OK (N_Node); |
1460 | Insert_Action (N, N_Node); | |
1461 | ||
1462 | -- Now, normally the deal here is that we use the defining | |
1463 | -- identifier created by that object declaration. There is | |
1464 | -- one exception to this. In the change of representation case | |
1465 | -- the above declaration will end up looking like: | |
1466 | ||
1467 | -- temp : type := identifier; | |
1468 | ||
1469 | -- And in this case we might as well use the identifier directly | |
1470 | -- and eliminate the temporary. Note that the analysis of the | |
1471 | -- declaration was not a waste of time in that case, since it is | |
1472 | -- what generated the necessary change of representation code. If | |
1473 | -- the change of representation introduced additional code, as in | |
1474 | -- a fixed-integer conversion, the expression is not an identifier | |
1475 | -- and must be kept. | |
1476 | ||
1477 | if Crep | |
1478 | and then Present (Expression (N_Node)) | |
1479 | and then Is_Entity_Name (Expression (N_Node)) | |
1480 | then | |
1481 | Temp := Entity (Expression (N_Node)); | |
1482 | Rewrite (N_Node, Make_Null_Statement (Loc)); | |
1483 | end if; | |
1484 | ||
fbf5a39b | 1485 | -- For IN parameter, all we do is to replace the actual |
70482933 | 1486 | |
fbf5a39b | 1487 | if Ekind (Formal) = E_In_Parameter then |
e4494292 | 1488 | Rewrite (Actual, New_Occurrence_Of (Temp, Loc)); |
fbf5a39b AC |
1489 | Analyze (Actual); |
1490 | ||
1491 | -- Processing for OUT or IN OUT parameter | |
1492 | ||
1493 | else | |
c8ef728f ES |
1494 | -- Kill current value indications for the temporary variable we |
1495 | -- created, since we just passed it as an OUT parameter. | |
1496 | ||
1497 | Kill_Current_Values (Temp); | |
75ba322d | 1498 | Set_Is_Known_Valid (Temp, False); |
8f0303e7 | 1499 | Set_Is_True_Constant (Temp, False); |
c8ef728f | 1500 | |
fbf5a39b AC |
1501 | -- If type conversion, use reverse conversion on exit |
1502 | ||
1503 | if Nkind (Actual) = N_Type_Conversion then | |
1504 | if Conversion_OK (Actual) then | |
1505 | Expr := OK_Convert_To (V_Typ, New_Occurrence_Of (Temp, Loc)); | |
1506 | else | |
1507 | Expr := Convert_To (V_Typ, New_Occurrence_Of (Temp, Loc)); | |
1508 | end if; | |
70482933 | 1509 | else |
fbf5a39b | 1510 | Expr := New_Occurrence_Of (Temp, Loc); |
70482933 | 1511 | end if; |
70482933 | 1512 | |
e4494292 | 1513 | Rewrite (Actual, New_Occurrence_Of (Temp, Loc)); |
fbf5a39b | 1514 | Analyze (Actual); |
70482933 | 1515 | |
d766cee3 RD |
1516 | -- If the actual is a conversion of a packed reference, it may |
1517 | -- already have been expanded by Remove_Side_Effects, and the | |
1518 | -- resulting variable is a temporary which does not designate | |
1519 | -- the proper out-parameter, which may not be addressable. In | |
1520 | -- that case, generate an assignment to the original expression | |
b0159fbe | 1521 | -- (before expansion of the packed reference) so that the proper |
d766cee3 | 1522 | -- expansion of assignment to a packed component can take place. |
70482933 | 1523 | |
d766cee3 RD |
1524 | declare |
1525 | Obj : Node_Id; | |
1526 | Lhs : Node_Id; | |
1527 | ||
1528 | begin | |
1529 | if Is_Renaming_Of_Object (Var) | |
1530 | and then Nkind (Renamed_Object (Var)) = N_Selected_Component | |
d766cee3 RD |
1531 | and then Nkind (Original_Node (Prefix (Renamed_Object (Var)))) |
1532 | = N_Indexed_Component | |
1533 | and then | |
1534 | Has_Non_Standard_Rep (Etype (Prefix (Renamed_Object (Var)))) | |
1535 | then | |
1536 | Obj := Renamed_Object (Var); | |
1537 | Lhs := | |
1538 | Make_Selected_Component (Loc, | |
1539 | Prefix => | |
1540 | New_Copy_Tree (Original_Node (Prefix (Obj))), | |
1541 | Selector_Name => New_Copy (Selector_Name (Obj))); | |
1542 | Reset_Analyzed_Flags (Lhs); | |
1543 | ||
1544 | else | |
c8307596 | 1545 | Lhs := New_Occurrence_Of (Var, Loc); |
d766cee3 RD |
1546 | end if; |
1547 | ||
1548 | Set_Assignment_OK (Lhs); | |
1549 | ||
d15f9422 AC |
1550 | if Is_Access_Type (E_Formal) |
1551 | and then Is_Entity_Name (Lhs) | |
996c8821 RD |
1552 | and then |
1553 | Present (Effective_Extra_Accessibility (Entity (Lhs))) | |
d15f9422 | 1554 | then |
4bb43ffb AC |
1555 | -- Copyback target is an Ada 2012 stand-alone object of an |
1556 | -- anonymous access type. | |
d15f9422 AC |
1557 | |
1558 | pragma Assert (Ada_Version >= Ada_2012); | |
1559 | ||
1560 | if Type_Access_Level (E_Formal) > | |
996c8821 RD |
1561 | Object_Access_Level (Lhs) |
1562 | then | |
1563 | Append_To (Post_Call, | |
1564 | Make_Raise_Program_Error (Loc, | |
1565 | Reason => PE_Accessibility_Check_Failed)); | |
d15f9422 AC |
1566 | end if; |
1567 | ||
1568 | Append_To (Post_Call, | |
1569 | Make_Assignment_Statement (Loc, | |
1570 | Name => Lhs, | |
1571 | Expression => Expr)); | |
1572 | ||
996c8821 RD |
1573 | -- We would like to somehow suppress generation of the |
1574 | -- extra_accessibility assignment generated by the expansion | |
1575 | -- of the above assignment statement. It's not a correctness | |
1576 | -- issue because the following assignment renders it dead, | |
1577 | -- but generating back-to-back assignments to the same | |
1578 | -- target is undesirable. ??? | |
d15f9422 AC |
1579 | |
1580 | Append_To (Post_Call, | |
1581 | Make_Assignment_Statement (Loc, | |
1582 | Name => New_Occurrence_Of ( | |
1583 | Effective_Extra_Accessibility (Entity (Lhs)), Loc), | |
1584 | Expression => Make_Integer_Literal (Loc, | |
1585 | Type_Access_Level (E_Formal)))); | |
996c8821 | 1586 | |
d15f9422 | 1587 | else |
68e4cc98 ES |
1588 | if Is_Access_Type (E_Formal) |
1589 | and then Can_Never_Be_Null (Etype (Actual)) | |
1590 | and then not Can_Never_Be_Null (E_Formal) | |
1591 | then | |
1592 | Append_To (Post_Call, | |
1593 | Make_Raise_Constraint_Error (Loc, | |
1594 | Condition => | |
1595 | Make_Op_Eq (Loc, | |
1596 | Left_Opnd => New_Occurrence_Of (Temp, Loc), | |
1597 | Right_Opnd => Make_Null (Loc)), | |
1598 | Reason => CE_Access_Check_Failed)); | |
1599 | end if; | |
1600 | ||
d15f9422 AC |
1601 | Append_To (Post_Call, |
1602 | Make_Assignment_Statement (Loc, | |
1603 | Name => Lhs, | |
1604 | Expression => Expr)); | |
1605 | end if; | |
d766cee3 | 1606 | end; |
fbf5a39b | 1607 | end if; |
70482933 RK |
1608 | end Add_Call_By_Copy_Code; |
1609 | ||
1610 | ---------------------------------- | |
f44fe430 | 1611 | -- Add_Simple_Call_By_Copy_Code -- |
70482933 RK |
1612 | ---------------------------------- |
1613 | ||
348c3ae6 | 1614 | procedure Add_Simple_Call_By_Copy_Code (Bit_Packed_Array : Boolean) is |
758c442c | 1615 | Decl : Node_Id; |
db99c46e | 1616 | F_Typ : Entity_Id := Etype (Formal); |
70482933 | 1617 | Incod : Node_Id; |
db99c46e | 1618 | Indic : Node_Id; |
70482933 | 1619 | Lhs : Node_Id; |
db99c46e | 1620 | Outcod : Node_Id; |
70482933 | 1621 | Rhs : Node_Id; |
db99c46e | 1622 | Temp : Entity_Id; |
70482933 RK |
1623 | |
1624 | begin | |
348c3ae6 EB |
1625 | -- ??? We need to do the copy for a bit-packed array because this is |
1626 | -- where the rewriting into a mask-and-shift sequence is done. But of | |
1627 | -- course this may break the program if it expects bits to be really | |
1628 | -- passed by reference. That's what we have done historically though. | |
1629 | ||
1630 | if not Bit_Packed_Array and then not Is_Legal_Copy then | |
758c442c GD |
1631 | return; |
1632 | end if; | |
1633 | ||
db99c46e AC |
1634 | -- Handle formals whose type comes from the limited view |
1635 | ||
1636 | if From_Limited_With (F_Typ) | |
1637 | and then Has_Non_Limited_View (F_Typ) | |
1638 | then | |
1639 | F_Typ := Non_Limited_View (F_Typ); | |
1640 | end if; | |
1641 | ||
f44fe430 RD |
1642 | -- Use formal type for temp, unless formal type is an unconstrained |
1643 | -- array, in which case we don't have to worry about bounds checks, | |
758c442c | 1644 | -- and we use the actual type, since that has appropriate bounds. |
f44fe430 RD |
1645 | |
1646 | if Is_Array_Type (F_Typ) and then not Is_Constrained (F_Typ) then | |
1647 | Indic := New_Occurrence_Of (Etype (Actual), Loc); | |
1648 | else | |
db99c46e | 1649 | Indic := New_Occurrence_Of (F_Typ, Loc); |
f44fe430 | 1650 | end if; |
70482933 RK |
1651 | |
1652 | -- Prepare to generate code | |
1653 | ||
f44fe430 RD |
1654 | Reset_Packed_Prefix; |
1655 | ||
b086849e | 1656 | Temp := Make_Temporary (Loc, 'T', Actual); |
70482933 RK |
1657 | Incod := Relocate_Node (Actual); |
1658 | Outcod := New_Copy_Tree (Incod); | |
1659 | ||
1660 | -- Generate declaration of temporary variable, initializing it | |
c73ae90f | 1661 | -- with the input parameter unless we have an OUT formal or |
758c442c | 1662 | -- this is an initialization call. |
70482933 | 1663 | |
c73ae90f GD |
1664 | -- If the formal is an out parameter with discriminants, the |
1665 | -- discriminants must be captured even if the rest of the object | |
1666 | -- is in principle uninitialized, because the discriminants may | |
1667 | -- be read by the called subprogram. | |
1668 | ||
70482933 RK |
1669 | if Ekind (Formal) = E_Out_Parameter then |
1670 | Incod := Empty; | |
758c442c | 1671 | |
db99c46e | 1672 | if Has_Discriminants (F_Typ) then |
c73ae90f GD |
1673 | Indic := New_Occurrence_Of (Etype (Actual), Loc); |
1674 | end if; | |
1675 | ||
758c442c | 1676 | elsif Inside_Init_Proc then |
c73ae90f GD |
1677 | |
1678 | -- Could use a comment here to match comment below ??? | |
1679 | ||
758c442c GD |
1680 | if Nkind (Actual) /= N_Selected_Component |
1681 | or else | |
1682 | not Has_Discriminant_Dependent_Constraint | |
1683 | (Entity (Selector_Name (Actual))) | |
1684 | then | |
1685 | Incod := Empty; | |
1686 | ||
c73ae90f GD |
1687 | -- Otherwise, keep the component in order to generate the proper |
1688 | -- actual subtype, that depends on enclosing discriminants. | |
758c442c | 1689 | |
c73ae90f | 1690 | else |
758c442c GD |
1691 | null; |
1692 | end if; | |
70482933 RK |
1693 | end if; |
1694 | ||
758c442c | 1695 | Decl := |
70482933 RK |
1696 | Make_Object_Declaration (Loc, |
1697 | Defining_Identifier => Temp, | |
f44fe430 | 1698 | Object_Definition => Indic, |
758c442c GD |
1699 | Expression => Incod); |
1700 | ||
1701 | if Inside_Init_Proc | |
1702 | and then No (Incod) | |
1703 | then | |
1704 | -- If the call is to initialize a component of a composite type, | |
1705 | -- and the component does not depend on discriminants, use the | |
1706 | -- actual type of the component. This is required in case the | |
1707 | -- component is constrained, because in general the formal of the | |
1708 | -- initialization procedure will be unconstrained. Note that if | |
1709 | -- the component being initialized is constrained by an enclosing | |
1710 | -- discriminant, the presence of the initialization in the | |
1711 | -- declaration will generate an expression for the actual subtype. | |
1712 | ||
1713 | Set_No_Initialization (Decl); | |
1714 | Set_Object_Definition (Decl, | |
1715 | New_Occurrence_Of (Etype (Actual), Loc)); | |
1716 | end if; | |
1717 | ||
1718 | Insert_Action (N, Decl); | |
70482933 RK |
1719 | |
1720 | -- The actual is simply a reference to the temporary | |
1721 | ||
1722 | Rewrite (Actual, New_Occurrence_Of (Temp, Loc)); | |
1723 | ||
1724 | -- Generate copy out if OUT or IN OUT parameter | |
1725 | ||
1726 | if Ekind (Formal) /= E_In_Parameter then | |
1727 | Lhs := Outcod; | |
1728 | Rhs := New_Occurrence_Of (Temp, Loc); | |
8f0303e7 | 1729 | Set_Is_True_Constant (Temp, False); |
70482933 RK |
1730 | |
1731 | -- Deal with conversion | |
1732 | ||
1733 | if Nkind (Lhs) = N_Type_Conversion then | |
1734 | Lhs := Expression (Lhs); | |
1735 | Rhs := Convert_To (Etype (Actual), Rhs); | |
1736 | end if; | |
1737 | ||
1738 | Append_To (Post_Call, | |
1739 | Make_Assignment_Statement (Loc, | |
1740 | Name => Lhs, | |
1741 | Expression => Rhs)); | |
f44fe430 | 1742 | Set_Assignment_OK (Name (Last (Post_Call))); |
70482933 | 1743 | end if; |
f44fe430 | 1744 | end Add_Simple_Call_By_Copy_Code; |
70482933 | 1745 | |
62e45e3e HK |
1746 | -------------------------------------- |
1747 | -- Add_Validation_Call_By_Copy_Code -- | |
1748 | -------------------------------------- | |
1749 | ||
1750 | procedure Add_Validation_Call_By_Copy_Code (Act : Node_Id) is | |
1751 | Expr : Node_Id; | |
1752 | Obj : Node_Id; | |
1753 | Obj_Typ : Entity_Id; | |
0691ed6b | 1754 | Var : constant Node_Id := Unqual_Conv (Act); |
62e45e3e HK |
1755 | Var_Id : Entity_Id; |
1756 | ||
1757 | begin | |
13931a38 EB |
1758 | -- Generate range check if required |
1759 | ||
1760 | if Do_Range_Check (Actual) then | |
1761 | Generate_Range_Check (Actual, E_Formal, CE_Range_Check_Failed); | |
1762 | end if; | |
1763 | ||
1764 | -- If there is a type conversion in the actual, it will be reinstated | |
1765 | -- below, the new instance will be properly analyzed and the setting | |
1766 | -- of the Do_Range_Check flag recomputed so remove the obsolete one. | |
1767 | ||
1768 | if Nkind (Actual) = N_Type_Conversion then | |
1769 | Set_Do_Range_Check (Expression (Actual), False); | |
1770 | end if; | |
1771 | ||
62e45e3e HK |
1772 | -- Copy the value of the validation variable back into the object |
1773 | -- being validated. | |
1774 | ||
1775 | if Is_Entity_Name (Var) then | |
1776 | Var_Id := Entity (Var); | |
1777 | Obj := Validated_Object (Var_Id); | |
1778 | Obj_Typ := Etype (Obj); | |
1779 | ||
1780 | Expr := New_Occurrence_Of (Var_Id, Loc); | |
1781 | ||
1782 | -- A type conversion is needed when the validation variable and | |
1783 | -- the validated object carry different types. This case occurs | |
1784 | -- when the actual is qualified in some fashion. | |
1785 | ||
1786 | -- Common: | |
1787 | -- subtype Int is Integer range ...; | |
1788 | -- procedure Call (Val : in out Integer); | |
1789 | ||
1790 | -- Original: | |
1791 | -- Object : Int; | |
1792 | -- Call (Integer (Object)); | |
1793 | ||
1794 | -- Expanded: | |
1795 | -- Object : Int; | |
1796 | -- Var : Integer := Object; -- conversion to base type | |
1797 | -- if not Var'Valid then -- validity check | |
1798 | -- Call (Var); -- modify Var | |
1799 | -- Object := Int (Var); -- conversion to subtype | |
1800 | ||
1801 | if Etype (Var_Id) /= Obj_Typ then | |
1802 | Expr := | |
1803 | Make_Type_Conversion (Loc, | |
1804 | Subtype_Mark => New_Occurrence_Of (Obj_Typ, Loc), | |
1805 | Expression => Expr); | |
1806 | end if; | |
1807 | ||
1808 | -- Generate: | |
1809 | -- Object := Var; | |
1810 | -- <or> | |
1811 | -- Object := Object_Type (Var); | |
1812 | ||
1813 | Append_To (Post_Call, | |
1814 | Make_Assignment_Statement (Loc, | |
1815 | Name => Obj, | |
1816 | Expression => Expr)); | |
1817 | ||
1818 | -- If the flow reaches this point, then this routine was invoked with | |
1819 | -- an actual which does not denote a validation variable. | |
1820 | ||
1821 | else | |
1822 | pragma Assert (False); | |
1823 | null; | |
1824 | end if; | |
1825 | end Add_Validation_Call_By_Copy_Code; | |
1826 | ||
70482933 RK |
1827 | --------------------------- |
1828 | -- Check_Fortran_Logical -- | |
1829 | --------------------------- | |
1830 | ||
1831 | procedure Check_Fortran_Logical is | |
fbf5a39b | 1832 | Logical : constant Entity_Id := Etype (Formal); |
70482933 RK |
1833 | Var : Entity_Id; |
1834 | ||
1835 | -- Note: this is very incomplete, e.g. it does not handle arrays | |
1836 | -- of logical values. This is really not the right approach at all???) | |
1837 | ||
1838 | begin | |
1839 | if Convention (Subp) = Convention_Fortran | |
1840 | and then Root_Type (Etype (Formal)) = Standard_Boolean | |
1841 | and then Ekind (Formal) /= E_In_Parameter | |
1842 | then | |
1843 | Var := Make_Var (Actual); | |
1844 | Append_To (Post_Call, | |
1845 | Make_Assignment_Statement (Loc, | |
1846 | Name => New_Occurrence_Of (Var, Loc), | |
1847 | Expression => | |
1848 | Unchecked_Convert_To ( | |
1849 | Logical, | |
1850 | Make_Op_Ne (Loc, | |
1851 | Left_Opnd => New_Occurrence_Of (Var, Loc), | |
1852 | Right_Opnd => | |
1853 | Unchecked_Convert_To ( | |
1854 | Logical, | |
1855 | New_Occurrence_Of (Standard_False, Loc)))))); | |
1856 | end if; | |
1857 | end Check_Fortran_Logical; | |
1858 | ||
758c442c GD |
1859 | ------------------- |
1860 | -- Is_Legal_Copy -- | |
1861 | ------------------- | |
1862 | ||
1863 | function Is_Legal_Copy return Boolean is | |
1864 | begin | |
1865 | -- An attempt to copy a value of such a type can only occur if | |
1866 | -- representation clauses give the actual a misaligned address. | |
1867 | ||
5d66b937 EB |
1868 | if Is_By_Reference_Type (Etype (Formal)) |
1869 | or else Is_Aliased (Formal) | |
1870 | or else (Mechanism (Formal) = By_Reference | |
1871 | and then not Has_Foreign_Convention (Subp)) | |
1872 | then | |
f45ccc7c | 1873 | |
f8f50235 AC |
1874 | -- The actual may in fact be properly aligned but there is not |
1875 | -- enough front-end information to determine this. In that case | |
5d66b937 EB |
1876 | -- gigi will emit an error or a warning if a copy is not legal, |
1877 | -- or generate the proper code. | |
f45ccc7c | 1878 | |
758c442c GD |
1879 | return False; |
1880 | ||
1881 | -- For users of Starlet, we assume that the specification of by- | |
7888a6ae | 1882 | -- reference mechanism is mandatory. This may lead to unaligned |
758c442c GD |
1883 | -- objects but at least for DEC legacy code it is known to work. |
1884 | -- The warning will alert users of this code that a problem may | |
1885 | -- be lurking. | |
1886 | ||
1887 | elsif Mechanism (Formal) = By_Reference | |
5d66b937 | 1888 | and then Ekind (Scope (Formal)) = E_Procedure |
758c442c GD |
1889 | and then Is_Valued_Procedure (Scope (Formal)) |
1890 | then | |
1891 | Error_Msg_N | |
685bc70f | 1892 | ("by_reference actual may be misaligned??", Actual); |
758c442c GD |
1893 | return False; |
1894 | ||
1895 | else | |
1896 | return True; | |
1897 | end if; | |
1898 | end Is_Legal_Copy; | |
1899 | ||
70482933 RK |
1900 | -------------- |
1901 | -- Make_Var -- | |
1902 | -------------- | |
1903 | ||
1904 | function Make_Var (Actual : Node_Id) return Entity_Id is | |
1905 | Var : Entity_Id; | |
1906 | ||
1907 | begin | |
1908 | if Is_Entity_Name (Actual) then | |
1909 | return Entity (Actual); | |
1910 | ||
1911 | else | |
b086849e | 1912 | Var := Make_Temporary (Loc, 'T', Actual); |
70482933 RK |
1913 | |
1914 | N_Node := | |
1915 | Make_Object_Renaming_Declaration (Loc, | |
1916 | Defining_Identifier => Var, | |
1917 | Subtype_Mark => | |
1918 | New_Occurrence_Of (Etype (Actual), Loc), | |
1919 | Name => Relocate_Node (Actual)); | |
1920 | ||
1921 | Insert_Action (N, N_Node); | |
1922 | return Var; | |
1923 | end if; | |
1924 | end Make_Var; | |
1925 | ||
1926 | ------------------------- | |
1927 | -- Reset_Packed_Prefix -- | |
1928 | ------------------------- | |
1929 | ||
1930 | procedure Reset_Packed_Prefix is | |
1931 | Pfx : Node_Id := Actual; | |
70482933 RK |
1932 | begin |
1933 | loop | |
1934 | Set_Analyzed (Pfx, False); | |
ac4d6407 RD |
1935 | exit when |
1936 | not Nkind_In (Pfx, N_Selected_Component, N_Indexed_Component); | |
70482933 RK |
1937 | Pfx := Prefix (Pfx); |
1938 | end loop; | |
1939 | end Reset_Packed_Prefix; | |
1940 | ||
1941 | -- Start of processing for Expand_Actuals | |
1942 | ||
1943 | begin | |
70482933 RK |
1944 | Post_Call := New_List; |
1945 | ||
2f1b20a9 ES |
1946 | Formal := First_Formal (Subp); |
1947 | Actual := First_Actual (N); | |
70482933 RK |
1948 | while Present (Formal) loop |
1949 | E_Formal := Etype (Formal); | |
f6820c2d | 1950 | E_Actual := Etype (Actual); |
70482933 | 1951 | |
db99c46e AC |
1952 | -- Handle formals whose type comes from the limited view |
1953 | ||
1954 | if From_Limited_With (E_Formal) | |
1955 | and then Has_Non_Limited_View (E_Formal) | |
1956 | then | |
1957 | E_Formal := Non_Limited_View (E_Formal); | |
1958 | end if; | |
1959 | ||
70482933 RK |
1960 | if Is_Scalar_Type (E_Formal) |
1961 | or else Nkind (Actual) = N_Slice | |
1962 | then | |
1963 | Check_Fortran_Logical; | |
1964 | ||
1965 | -- RM 6.4.1 (11) | |
1966 | ||
1967 | elsif Ekind (Formal) /= E_Out_Parameter then | |
1968 | ||
1969 | -- The unusual case of the current instance of a protected type | |
1970 | -- requires special handling. This can only occur in the context | |
1971 | -- of a call within the body of a protected operation. | |
1972 | ||
1973 | if Is_Entity_Name (Actual) | |
1974 | and then Ekind (Entity (Actual)) = E_Protected_Type | |
1975 | and then In_Open_Scopes (Entity (Actual)) | |
1976 | then | |
1977 | if Scope (Subp) /= Entity (Actual) then | |
685bc70f AC |
1978 | Error_Msg_N |
1979 | ("operation outside protected type may not " | |
1980 | & "call back its protected operations??", Actual); | |
70482933 RK |
1981 | end if; |
1982 | ||
1983 | Rewrite (Actual, | |
1984 | Expand_Protected_Object_Reference (N, Entity (Actual))); | |
1985 | end if; | |
1986 | ||
02822a92 RD |
1987 | -- Ada 2005 (AI-318-02): If the actual parameter is a call to a |
1988 | -- build-in-place function, then a temporary return object needs | |
1989 | -- to be created and access to it must be passed to the function. | |
f937473f RD |
1990 | -- Currently we limit such functions to those with inherently |
1991 | -- limited result subtypes, but eventually we plan to expand the | |
1992 | -- functions that are treated as build-in-place to include other | |
1993 | -- composite result types. | |
02822a92 | 1994 | |
95eb8b69 | 1995 | if Is_Build_In_Place_Function_Call (Actual) then |
02822a92 | 1996 | Make_Build_In_Place_Call_In_Anonymous_Context (Actual); |
4ac62786 AC |
1997 | |
1998 | -- Ada 2005 (AI-318-02): Specialization of the previous case for | |
1999 | -- actuals containing build-in-place function calls whose returned | |
2000 | -- object covers interface types. | |
2001 | ||
2002 | elsif Present (Unqual_BIP_Iface_Function_Call (Actual)) then | |
2003 | Make_Build_In_Place_Iface_Call_In_Anonymous_Context (Actual); | |
02822a92 RD |
2004 | end if; |
2005 | ||
70482933 RK |
2006 | Apply_Constraint_Check (Actual, E_Formal); |
2007 | ||
2008 | -- Out parameter case. No constraint checks on access type | |
68e4cc98 ES |
2009 | -- RM 6.4.1 (13), but on return a null-excluding check may be |
2010 | -- required (see below). | |
70482933 RK |
2011 | |
2012 | elsif Is_Access_Type (E_Formal) then | |
2013 | null; | |
2014 | ||
2015 | -- RM 6.4.1 (14) | |
2016 | ||
2017 | elsif Has_Discriminants (Base_Type (E_Formal)) | |
2018 | or else Has_Non_Null_Base_Init_Proc (E_Formal) | |
2019 | then | |
2020 | Apply_Constraint_Check (Actual, E_Formal); | |
2021 | ||
2022 | -- RM 6.4.1 (15) | |
2023 | ||
2024 | else | |
2025 | Apply_Constraint_Check (Actual, Base_Type (E_Formal)); | |
2026 | end if; | |
2027 | ||
2028 | -- Processing for IN-OUT and OUT parameters | |
2029 | ||
2030 | if Ekind (Formal) /= E_In_Parameter then | |
2031 | ||
2032 | -- For type conversions of arrays, apply length/range checks | |
2033 | ||
2034 | if Is_Array_Type (E_Formal) | |
2035 | and then Nkind (Actual) = N_Type_Conversion | |
2036 | then | |
2037 | if Is_Constrained (E_Formal) then | |
2038 | Apply_Length_Check (Expression (Actual), E_Formal); | |
2039 | else | |
2040 | Apply_Range_Check (Expression (Actual), E_Formal); | |
2041 | end if; | |
2042 | end if; | |
2043 | ||
62e45e3e HK |
2044 | -- The actual denotes a variable which captures the value of an |
2045 | -- object for validation purposes. Add a copy-back to reflect any | |
2046 | -- potential changes in value back into the original object. | |
2047 | ||
2048 | -- Var : ... := Object; | |
2049 | -- if not Var'Valid then -- validity check | |
2050 | -- Call (Var); -- modify var | |
2051 | -- Object := Var; -- update Object | |
2052 | ||
2053 | -- This case is given higher priority because the subsequent check | |
2054 | -- for type conversion may add an extra copy of the variable and | |
2055 | -- prevent proper value propagation back in the original object. | |
2056 | ||
2057 | if Is_Validation_Variable_Reference (Actual) then | |
2058 | Add_Validation_Call_By_Copy_Code (Actual); | |
70482933 | 2059 | |
62e45e3e HK |
2060 | -- If argument is a type conversion for a type that is passed by |
2061 | -- copy, then we must pass the parameter by copy. | |
2062 | ||
2063 | elsif Nkind (Actual) = N_Type_Conversion | |
70482933 RK |
2064 | and then |
2065 | (Is_Numeric_Type (E_Formal) | |
2066 | or else Is_Access_Type (E_Formal) | |
2067 | or else Is_Enumeration_Type (E_Formal) | |
2068 | or else Is_Bit_Packed_Array (Etype (Formal)) | |
2069 | or else Is_Bit_Packed_Array (Etype (Expression (Actual))) | |
2070 | ||
2071 | -- Also pass by copy if change of representation | |
2072 | ||
2073 | or else not Same_Representation | |
da574a86 AC |
2074 | (Etype (Formal), |
2075 | Etype (Expression (Actual)))) | |
70482933 RK |
2076 | then |
2077 | Add_Call_By_Copy_Code; | |
2078 | ||
607114db | 2079 | -- References to components of bit-packed arrays are expanded |
70482933 RK |
2080 | -- at this point, rather than at the point of analysis of the |
2081 | -- actuals, to handle the expansion of the assignment to | |
2082 | -- [in] out parameters. | |
2083 | ||
2084 | elsif Is_Ref_To_Bit_Packed_Array (Actual) then | |
348c3ae6 | 2085 | Add_Simple_Call_By_Copy_Code (Bit_Packed_Array => True); |
f44fe430 | 2086 | |
00907026 | 2087 | -- If a nonscalar actual is possibly bit-aligned, we need a copy |
02822a92 RD |
2088 | -- because the back-end cannot cope with such objects. In other |
2089 | -- cases where alignment forces a copy, the back-end generates | |
2090 | -- it properly. It should not be generated unconditionally in the | |
2091 | -- front-end because it does not know precisely the alignment | |
2092 | -- requirements of the target, and makes too conservative an | |
2093 | -- estimate, leading to superfluous copies or spurious errors | |
2094 | -- on by-reference parameters. | |
f44fe430 | 2095 | |
02822a92 RD |
2096 | elsif Nkind (Actual) = N_Selected_Component |
2097 | and then | |
2098 | Component_May_Be_Bit_Aligned (Entity (Selector_Name (Actual))) | |
f44fe430 RD |
2099 | and then not Represented_As_Scalar (Etype (Formal)) |
2100 | then | |
348c3ae6 | 2101 | Add_Simple_Call_By_Copy_Code (Bit_Packed_Array => False); |
70482933 | 2102 | |
607114db | 2103 | -- References to slices of bit-packed arrays are expanded |
70482933 RK |
2104 | |
2105 | elsif Is_Ref_To_Bit_Packed_Slice (Actual) then | |
2106 | Add_Call_By_Copy_Code; | |
2107 | ||
fbf5a39b AC |
2108 | -- References to possibly unaligned slices of arrays are expanded |
2109 | ||
2110 | elsif Is_Possibly_Unaligned_Slice (Actual) then | |
2111 | Add_Call_By_Copy_Code; | |
2112 | ||
7888a6ae | 2113 | -- Deal with access types where the actual subtype and the |
70482933 RK |
2114 | -- formal subtype are not the same, requiring a check. |
2115 | ||
638e383e | 2116 | -- It is necessary to exclude tagged types because of "downward |
68e4cc98 ES |
2117 | -- conversion" errors, but null-excluding checks on return may be |
2118 | -- required. | |
70482933 RK |
2119 | |
2120 | elsif Is_Access_Type (E_Formal) | |
70482933 | 2121 | and then not Is_Tagged_Type (Designated_Type (E_Formal)) |
68e4cc98 ES |
2122 | and then (not Same_Type (E_Formal, E_Actual) |
2123 | or else (Can_Never_Be_Null (E_Actual) | |
2124 | and then not Can_Never_Be_Null (E_Formal))) | |
70482933 RK |
2125 | then |
2126 | Add_Call_By_Copy_Code; | |
2127 | ||
faf3cf91 ES |
2128 | -- If the actual is not a scalar and is marked for volatile |
2129 | -- treatment, whereas the formal is not volatile, then pass | |
2130 | -- by copy unless it is a by-reference type. | |
2131 | ||
0386aad1 AC |
2132 | -- Note: we use Is_Volatile here rather than Treat_As_Volatile, |
2133 | -- because this is the enforcement of a language rule that applies | |
2134 | -- only to "real" volatile variables, not e.g. to the address | |
2135 | -- clause overlay case. | |
2136 | ||
70482933 | 2137 | elsif Is_Entity_Name (Actual) |
0386aad1 | 2138 | and then Is_Volatile (Entity (Actual)) |
f6820c2d | 2139 | and then not Is_By_Reference_Type (E_Actual) |
70482933 | 2140 | and then not Is_Scalar_Type (Etype (Entity (Actual))) |
0386aad1 | 2141 | and then not Is_Volatile (E_Formal) |
70482933 RK |
2142 | then |
2143 | Add_Call_By_Copy_Code; | |
2144 | ||
2145 | elsif Nkind (Actual) = N_Indexed_Component | |
2146 | and then Is_Entity_Name (Prefix (Actual)) | |
2147 | and then Has_Volatile_Components (Entity (Prefix (Actual))) | |
2148 | then | |
2149 | Add_Call_By_Copy_Code; | |
d79e621a GD |
2150 | |
2151 | -- Add call-by-copy code for the case of scalar out parameters | |
2152 | -- when it is not known at compile time that the subtype of the | |
c2369146 AC |
2153 | -- formal is a subrange of the subtype of the actual (or vice |
2154 | -- versa for in out parameters), in order to get range checks | |
2155 | -- on such actuals. (Maybe this case should be handled earlier | |
2156 | -- in the if statement???) | |
d79e621a GD |
2157 | |
2158 | elsif Is_Scalar_Type (E_Formal) | |
c2369146 | 2159 | and then |
f6820c2d | 2160 | (not In_Subrange_Of (E_Formal, E_Actual) |
c2369146 AC |
2161 | or else |
2162 | (Ekind (Formal) = E_In_Out_Parameter | |
f6820c2d | 2163 | and then not In_Subrange_Of (E_Actual, E_Formal))) |
d79e621a | 2164 | then |
d79e621a | 2165 | Add_Call_By_Copy_Code; |
70482933 RK |
2166 | end if; |
2167 | ||
5f6fb720 | 2168 | -- RM 3.2.4 (23/3): A predicate is checked on in-out and out |
f6820c2d AC |
2169 | -- by-reference parameters on exit from the call. If the actual |
2170 | -- is a derived type and the operation is inherited, the body | |
2171 | -- of the operation will not contain a call to the predicate | |
2172 | -- function, so it must be done explicitly after the call. Ditto | |
2173 | -- if the actual is an entity of a predicated subtype. | |
2174 | ||
cae64f11 AC |
2175 | -- The rule refers to by-reference types, but a check is needed |
2176 | -- for by-copy types as well. That check is subsumed by the rule | |
2177 | -- for subtype conversion on assignment, but we can generate the | |
2178 | -- required check now. | |
2179 | ||
dd4e47ab | 2180 | -- Note also that Subp may be either a subprogram entity for |
e93f4e12 AC |
2181 | -- direct calls, or a type entity for indirect calls, which must |
2182 | -- be handled separately because the name does not denote an | |
2183 | -- overloadable entity. | |
dd4e47ab | 2184 | |
2ac4a591 | 2185 | By_Ref_Predicate_Check : declare |
5f6fb720 AC |
2186 | Aund : constant Entity_Id := Underlying_Type (E_Actual); |
2187 | Atyp : Entity_Id; | |
2188 | ||
2ac4a591 AC |
2189 | function Is_Public_Subp return Boolean; |
2190 | -- Check whether the subprogram being called is a visible | |
2191 | -- operation of the type of the actual. Used to determine | |
2192 | -- whether an invariant check must be generated on the | |
2193 | -- caller side. | |
2194 | ||
2195 | --------------------- | |
2196 | -- Is_Public_Subp -- | |
2197 | --------------------- | |
2198 | ||
2199 | function Is_Public_Subp return Boolean is | |
2200 | Pack : constant Entity_Id := Scope (Subp); | |
2201 | Subp_Decl : Node_Id; | |
2202 | ||
2203 | begin | |
2204 | if not Is_Subprogram (Subp) then | |
2205 | return False; | |
2206 | ||
2207 | -- The operation may be inherited, or a primitive of the | |
2208 | -- root type. | |
2209 | ||
2210 | elsif | |
2211 | Nkind_In (Parent (Subp), N_Private_Extension_Declaration, | |
2212 | N_Full_Type_Declaration) | |
2213 | then | |
2214 | Subp_Decl := Parent (Subp); | |
2215 | ||
2216 | else | |
2217 | Subp_Decl := Unit_Declaration_Node (Subp); | |
2218 | end if; | |
2219 | ||
2220 | return Ekind (Pack) = E_Package | |
2221 | and then | |
2222 | List_Containing (Subp_Decl) = | |
2223 | Visible_Declarations | |
2224 | (Specification (Unit_Declaration_Node (Pack))); | |
2225 | end Is_Public_Subp; | |
2226 | ||
2227 | -- Start of processing for By_Ref_Predicate_Check | |
2228 | ||
5f6fb720 AC |
2229 | begin |
2230 | if No (Aund) then | |
2231 | Atyp := E_Actual; | |
2232 | else | |
2233 | Atyp := Aund; | |
2234 | end if; | |
2235 | ||
2236 | if Has_Predicates (Atyp) | |
2237 | and then Present (Predicate_Function (Atyp)) | |
2238 | ||
2239 | -- Skip predicate checks for special cases | |
2240 | ||
b8e6830b | 2241 | and then Predicate_Tests_On_Arguments (Subp) |
5f6fb720 AC |
2242 | then |
2243 | Append_To (Post_Call, | |
2244 | Make_Predicate_Check (Atyp, Actual)); | |
2245 | end if; | |
2ac4a591 AC |
2246 | |
2247 | -- We generated caller-side invariant checks in two cases: | |
2248 | ||
2249 | -- a) when calling an inherited operation, where there is an | |
2250 | -- implicit view conversion of the actual to the parent type. | |
2251 | ||
2252 | -- b) When the conversion is explicit | |
2253 | ||
2254 | -- We treat these cases separately because the required | |
2255 | -- conversion for a) is added later when expanding the call. | |
2256 | ||
2257 | if Has_Invariants (Etype (Actual)) | |
2258 | and then | |
2259 | Nkind (Parent (Subp)) = N_Private_Extension_Declaration | |
2260 | then | |
b9eb3aa8 | 2261 | if Comes_From_Source (N) and then Is_Public_Subp then |
2ac4a591 AC |
2262 | Append_To (Post_Call, Make_Invariant_Call (Actual)); |
2263 | end if; | |
2264 | ||
2265 | elsif Nkind (Actual) = N_Type_Conversion | |
2266 | and then Has_Invariants (Etype (Expression (Actual))) | |
2267 | then | |
2268 | if Comes_From_Source (N) and then Is_Public_Subp then | |
2269 | Append_To (Post_Call, | |
2270 | Make_Invariant_Call (Expression (Actual))); | |
2271 | end if; | |
2272 | end if; | |
2273 | end By_Ref_Predicate_Check; | |
f6820c2d | 2274 | |
fbf5a39b | 2275 | -- Processing for IN parameters |
70482933 RK |
2276 | |
2277 | else | |
13931a38 EB |
2278 | -- Generate range check if required |
2279 | ||
2280 | if Do_Range_Check (Actual) then | |
2281 | Generate_Range_Check (Actual, E_Formal, CE_Range_Check_Failed); | |
2282 | end if; | |
2283 | ||
607114db | 2284 | -- For IN parameters in the bit-packed array case, we expand an |
fbf5a39b AC |
2285 | -- indexed component (the circuit in Exp_Ch4 deliberately left |
2286 | -- indexed components appearing as actuals untouched, so that | |
2287 | -- the special processing above for the OUT and IN OUT cases | |
2288 | -- could be performed. We could make the test in Exp_Ch4 more | |
2289 | -- complex and have it detect the parameter mode, but it is | |
f44fe430 | 2290 | -- easier simply to handle all cases here.) |
fbf5a39b | 2291 | |
70482933 | 2292 | if Nkind (Actual) = N_Indexed_Component |
b3f75672 | 2293 | and then Is_Bit_Packed_Array (Etype (Prefix (Actual))) |
70482933 RK |
2294 | then |
2295 | Reset_Packed_Prefix; | |
2296 | Expand_Packed_Element_Reference (Actual); | |
2297 | ||
607114db | 2298 | -- If we have a reference to a bit-packed array, we copy it, since |
0386aad1 | 2299 | -- the actual must be byte aligned. |
70482933 | 2300 | |
fbf5a39b | 2301 | -- Is this really necessary in all cases??? |
70482933 | 2302 | |
fbf5a39b | 2303 | elsif Is_Ref_To_Bit_Packed_Array (Actual) then |
348c3ae6 | 2304 | Add_Simple_Call_By_Copy_Code (Bit_Packed_Array => True); |
f44fe430 | 2305 | |
00907026 | 2306 | -- If a nonscalar actual is possibly unaligned, we need a copy |
f44fe430 RD |
2307 | |
2308 | elsif Is_Possibly_Unaligned_Object (Actual) | |
2309 | and then not Represented_As_Scalar (Etype (Formal)) | |
2310 | then | |
348c3ae6 | 2311 | Add_Simple_Call_By_Copy_Code (Bit_Packed_Array => False); |
70482933 | 2312 | |
fbf5a39b AC |
2313 | -- Similarly, we have to expand slices of packed arrays here |
2314 | -- because the result must be byte aligned. | |
70482933 | 2315 | |
fbf5a39b AC |
2316 | elsif Is_Ref_To_Bit_Packed_Slice (Actual) then |
2317 | Add_Call_By_Copy_Code; | |
70482933 | 2318 | |
fbf5a39b AC |
2319 | -- Only processing remaining is to pass by copy if this is a |
2320 | -- reference to a possibly unaligned slice, since the caller | |
2321 | -- expects an appropriately aligned argument. | |
70482933 | 2322 | |
fbf5a39b AC |
2323 | elsif Is_Possibly_Unaligned_Slice (Actual) then |
2324 | Add_Call_By_Copy_Code; | |
fb468a94 AC |
2325 | |
2326 | -- An unusual case: a current instance of an enclosing task can be | |
2327 | -- an actual, and must be replaced by a reference to self. | |
2328 | ||
2329 | elsif Is_Entity_Name (Actual) | |
2330 | and then Is_Task_Type (Entity (Actual)) | |
2331 | then | |
2332 | if In_Open_Scopes (Entity (Actual)) then | |
2333 | Rewrite (Actual, | |
2334 | (Make_Function_Call (Loc, | |
da574a86 | 2335 | Name => New_Occurrence_Of (RTE (RE_Self), Loc)))); |
fb468a94 AC |
2336 | Analyze (Actual); |
2337 | ||
2338 | -- A task type cannot otherwise appear as an actual | |
2339 | ||
2340 | else | |
2341 | raise Program_Error; | |
2342 | end if; | |
70482933 RK |
2343 | end if; |
2344 | end if; | |
2345 | ||
2346 | Next_Formal (Formal); | |
2347 | Next_Actual (Actual); | |
2348 | end loop; | |
70482933 RK |
2349 | end Expand_Actuals; |
2350 | ||
2351 | ----------------- | |
2352 | -- Expand_Call -- | |
2353 | ----------------- | |
2354 | ||
ca1f6b29 BD |
2355 | procedure Expand_Call (N : Node_Id) is |
2356 | Post_Call : List_Id; | |
3fc40cd7 | 2357 | |
ca1f6b29 | 2358 | begin |
3fc40cd7 PMR |
2359 | pragma Assert (Nkind_In (N, N_Entry_Call_Statement, |
2360 | N_Function_Call, | |
2361 | N_Procedure_Call_Statement)); | |
2362 | ||
ca1f6b29 BD |
2363 | Expand_Call_Helper (N, Post_Call); |
2364 | Insert_Post_Call_Actions (N, Post_Call); | |
2365 | end Expand_Call; | |
2366 | ||
2367 | ------------------------ | |
2368 | -- Expand_Call_Helper -- | |
2369 | ------------------------ | |
2370 | ||
70482933 RK |
2371 | -- This procedure handles expansion of function calls and procedure call |
2372 | -- statements (i.e. it serves as the body for Expand_N_Function_Call and | |
70f91180 | 2373 | -- Expand_N_Procedure_Call_Statement). Processing for calls includes: |
70482933 | 2374 | |
70f91180 | 2375 | -- Replace call to Raise_Exception by Raise_Exception_Always if possible |
70482933 RK |
2376 | -- Provide values of actuals for all formals in Extra_Formals list |
2377 | -- Replace "call" to enumeration literal function by literal itself | |
2378 | -- Rewrite call to predefined operator as operator | |
2379 | -- Replace actuals to in-out parameters that are numeric conversions, | |
2380 | -- with explicit assignment to temporaries before and after the call. | |
70482933 RK |
2381 | |
2382 | -- Note that the list of actuals has been filled with default expressions | |
2383 | -- during semantic analysis of the call. Only the extra actuals required | |
2384 | -- for the 'Constrained attribute and for accessibility checks are added | |
2385 | -- at this point. | |
2386 | ||
ca1f6b29 | 2387 | procedure Expand_Call_Helper (N : Node_Id; Post_Call : out List_Id) is |
70482933 | 2388 | Loc : constant Source_Ptr := Sloc (N); |
6dfc5592 | 2389 | Call_Node : Node_Id := N; |
70482933 | 2390 | Extra_Actuals : List_Id := No_List; |
fdce4bb7 | 2391 | Prev : Node_Id := Empty; |
758c442c | 2392 | |
70482933 RK |
2393 | procedure Add_Actual_Parameter (Insert_Param : Node_Id); |
2394 | -- Adds one entry to the end of the actual parameter list. Used for | |
2f1b20a9 ES |
2395 | -- default parameters and for extra actuals (for Extra_Formals). The |
2396 | -- argument is an N_Parameter_Association node. | |
70482933 RK |
2397 | |
2398 | procedure Add_Extra_Actual (Expr : Node_Id; EF : Entity_Id); | |
2f1b20a9 ES |
2399 | -- Adds an extra actual to the list of extra actuals. Expr is the |
2400 | -- expression for the value of the actual, EF is the entity for the | |
2401 | -- extra formal. | |
70482933 | 2402 | |
5f325af2 AC |
2403 | procedure Add_View_Conversion_Invariants |
2404 | (Formal : Entity_Id; | |
2405 | Actual : Node_Id); | |
10c2c151 AC |
2406 | -- Adds invariant checks for every intermediate type between the range |
2407 | -- of a view converted argument to its ancestor (from parent to child). | |
84e13614 | 2408 | |
a081ded4 ES |
2409 | function Can_Fold_Predicate_Call (P : Entity_Id) return Boolean; |
2410 | -- Try to constant-fold a predicate check, which often enough is a | |
2411 | -- simple arithmetic expression that can be computed statically if | |
2412 | -- its argument is static. This cleans up the output of CCG, even | |
2413 | -- though useless predicate checks will be generally removed by | |
2414 | -- back-end optimizations. | |
2415 | ||
70482933 | 2416 | function Inherited_From_Formal (S : Entity_Id) return Entity_Id; |
1fb63e89 | 2417 | -- Within an instance, a type derived from an untagged formal derived |
70f91180 RD |
2418 | -- type inherits from the original parent, not from the actual. The |
2419 | -- current derivation mechanism has the derived type inherit from the | |
2420 | -- actual, which is only correct outside of the instance. If the | |
2421 | -- subprogram is inherited, we test for this particular case through a | |
2422 | -- convoluted tree traversal before setting the proper subprogram to be | |
2423 | -- called. | |
70482933 | 2424 | |
84f4072a JM |
2425 | function In_Unfrozen_Instance (E : Entity_Id) return Boolean; |
2426 | -- Return true if E comes from an instance that is not yet frozen | |
2427 | ||
5a644684 JM |
2428 | function Is_Class_Wide_Interface_Type (E : Entity_Id) return Boolean; |
2429 | -- Return True when E is a class-wide interface type or an access to | |
2430 | -- a class-wide interface type. | |
2431 | ||
df3e68b1 | 2432 | function Is_Direct_Deep_Call (Subp : Entity_Id) return Boolean; |
2c1b72d7 | 2433 | -- Determine if Subp denotes a non-dispatching call to a Deep routine |
df3e68b1 | 2434 | |
dd386db0 AC |
2435 | function New_Value (From : Node_Id) return Node_Id; |
2436 | -- From is the original Expression. New_Value is equivalent to a call | |
2437 | -- to Duplicate_Subexpr with an explicit dereference when From is an | |
2438 | -- access parameter. | |
2439 | ||
70482933 RK |
2440 | -------------------------- |
2441 | -- Add_Actual_Parameter -- | |
2442 | -------------------------- | |
2443 | ||
2444 | procedure Add_Actual_Parameter (Insert_Param : Node_Id) is | |
2445 | Actual_Expr : constant Node_Id := | |
2446 | Explicit_Actual_Parameter (Insert_Param); | |
2447 | ||
2448 | begin | |
2449 | -- Case of insertion is first named actual | |
2450 | ||
2451 | if No (Prev) or else | |
2452 | Nkind (Parent (Prev)) /= N_Parameter_Association | |
2453 | then | |
6dfc5592 RD |
2454 | Set_Next_Named_Actual |
2455 | (Insert_Param, First_Named_Actual (Call_Node)); | |
2456 | Set_First_Named_Actual (Call_Node, Actual_Expr); | |
70482933 RK |
2457 | |
2458 | if No (Prev) then | |
6dfc5592 RD |
2459 | if No (Parameter_Associations (Call_Node)) then |
2460 | Set_Parameter_Associations (Call_Node, New_List); | |
70482933 | 2461 | end if; |
57a3fca9 AC |
2462 | |
2463 | Append (Insert_Param, Parameter_Associations (Call_Node)); | |
2464 | ||
70482933 RK |
2465 | else |
2466 | Insert_After (Prev, Insert_Param); | |
2467 | end if; | |
2468 | ||
2469 | -- Case of insertion is not first named actual | |
2470 | ||
2471 | else | |
2472 | Set_Next_Named_Actual | |
2473 | (Insert_Param, Next_Named_Actual (Parent (Prev))); | |
2474 | Set_Next_Named_Actual (Parent (Prev), Actual_Expr); | |
6dfc5592 | 2475 | Append (Insert_Param, Parameter_Associations (Call_Node)); |
70482933 RK |
2476 | end if; |
2477 | ||
2478 | Prev := Actual_Expr; | |
2479 | end Add_Actual_Parameter; | |
2480 | ||
2481 | ---------------------- | |
2482 | -- Add_Extra_Actual -- | |
2483 | ---------------------- | |
2484 | ||
2485 | procedure Add_Extra_Actual (Expr : Node_Id; EF : Entity_Id) is | |
2486 | Loc : constant Source_Ptr := Sloc (Expr); | |
2487 | ||
2488 | begin | |
2489 | if Extra_Actuals = No_List then | |
2490 | Extra_Actuals := New_List; | |
6dfc5592 | 2491 | Set_Parent (Extra_Actuals, Call_Node); |
70482933 RK |
2492 | end if; |
2493 | ||
2494 | Append_To (Extra_Actuals, | |
2495 | Make_Parameter_Association (Loc, | |
7a2c2277 | 2496 | Selector_Name => New_Occurrence_Of (EF, Loc), |
9d983bbf | 2497 | Explicit_Actual_Parameter => Expr)); |
70482933 RK |
2498 | |
2499 | Analyze_And_Resolve (Expr, Etype (EF)); | |
75a64833 | 2500 | |
6dfc5592 | 2501 | if Nkind (Call_Node) = N_Function_Call then |
75a64833 AC |
2502 | Set_Is_Accessibility_Actual (Parent (Expr)); |
2503 | end if; | |
70482933 RK |
2504 | end Add_Extra_Actual; |
2505 | ||
5f325af2 AC |
2506 | ------------------------------------ |
2507 | -- Add_View_Conversion_Invariants -- | |
2508 | ------------------------------------ | |
84e13614 | 2509 | |
5f325af2 AC |
2510 | procedure Add_View_Conversion_Invariants |
2511 | (Formal : Entity_Id; | |
2512 | Actual : Node_Id) | |
2513 | is | |
84e13614 | 2514 | Arg : Entity_Id; |
10c2c151 | 2515 | Curr_Typ : Entity_Id; |
84e13614 JS |
2516 | Inv_Checks : List_Id; |
2517 | Par_Typ : Entity_Id; | |
2518 | ||
2519 | begin | |
2520 | Inv_Checks := No_List; | |
2521 | ||
10c2c151 AC |
2522 | -- Extract the argument from a potentially nested set of view |
2523 | -- conversions. | |
84e13614 JS |
2524 | |
2525 | Arg := Actual; | |
2526 | while Nkind (Arg) = N_Type_Conversion loop | |
2527 | Arg := Expression (Arg); | |
2528 | end loop; | |
2529 | ||
10c2c151 AC |
2530 | -- Move up the derivation chain starting with the type of the formal |
2531 | -- parameter down to the type of the actual object. | |
84e13614 | 2532 | |
10c2c151 AC |
2533 | Curr_Typ := Empty; |
2534 | Par_Typ := Etype (Arg); | |
84e13614 JS |
2535 | while Par_Typ /= Etype (Formal) and Par_Typ /= Curr_Typ loop |
2536 | Curr_Typ := Par_Typ; | |
10c2c151 | 2537 | |
84e13614 JS |
2538 | if Has_Invariants (Curr_Typ) |
2539 | and then Present (Invariant_Procedure (Curr_Typ)) | |
2540 | then | |
2541 | -- Verify the invariate of the current type. Generate: | |
10c2c151 AC |
2542 | |
2543 | -- <Curr_Typ>Invariant (Curr_Typ (Arg)); | |
84e13614 JS |
2544 | |
2545 | Prepend_New_To (Inv_Checks, | |
2546 | Make_Procedure_Call_Statement (Loc, | |
2547 | Name => | |
2548 | New_Occurrence_Of | |
2549 | (Invariant_Procedure (Curr_Typ), Loc), | |
2550 | Parameter_Associations => New_List ( | |
2551 | Make_Type_Conversion (Loc, | |
2552 | Subtype_Mark => New_Occurrence_Of (Curr_Typ, Loc), | |
2553 | Expression => New_Copy_Tree (Arg))))); | |
2554 | end if; | |
2555 | ||
2556 | Par_Typ := Base_Type (Etype (Curr_Typ)); | |
2557 | end loop; | |
2558 | ||
2559 | if not Is_Empty_List (Inv_Checks) then | |
2560 | Insert_Actions_After (N, Inv_Checks); | |
2561 | end if; | |
5f325af2 | 2562 | end Add_View_Conversion_Invariants; |
84e13614 | 2563 | |
a081ded4 ES |
2564 | ----------------------------- |
2565 | -- Can_Fold_Predicate_Call -- | |
2566 | ----------------------------- | |
2567 | ||
2568 | function Can_Fold_Predicate_Call (P : Entity_Id) return Boolean is | |
6ef13c4f | 2569 | Actual : Node_Id; |
a081ded4 ES |
2570 | |
2571 | function May_Fold (N : Node_Id) return Traverse_Result; | |
2572 | -- The predicate expression is foldable if it only contains operators | |
2573 | -- and literals. During this check, we also replace occurrences of | |
2574 | -- the formal of the constructed predicate function with the static | |
2575 | -- value of the actual. This is done on a copy of the analyzed | |
2576 | -- expression for the predicate. | |
2577 | ||
29c64a0f HK |
2578 | -------------- |
2579 | -- May_Fold -- | |
2580 | -------------- | |
2581 | ||
a081ded4 ES |
2582 | function May_Fold (N : Node_Id) return Traverse_Result is |
2583 | begin | |
2584 | case Nkind (N) is | |
29c64a0f HK |
2585 | when N_Binary_Op |
2586 | | N_Unary_Op | |
2587 | => | |
a081ded4 ES |
2588 | return OK; |
2589 | ||
29c64a0f HK |
2590 | when N_Expanded_Name |
2591 | | N_Identifier | |
2592 | => | |
a081ded4 ES |
2593 | if Ekind (Entity (N)) = E_In_Parameter |
2594 | and then Entity (N) = First_Entity (P) | |
2595 | then | |
2596 | Rewrite (N, New_Copy (Actual)); | |
2597 | Set_Is_Static_Expression (N); | |
2598 | return OK; | |
2599 | ||
2600 | elsif Ekind (Entity (N)) = E_Enumeration_Literal then | |
2601 | return OK; | |
2602 | ||
2603 | else | |
2604 | return Abandon; | |
2605 | end if; | |
2606 | ||
29c64a0f HK |
2607 | when N_Case_Expression |
2608 | | N_If_Expression | |
2609 | => | |
a081ded4 ES |
2610 | return OK; |
2611 | ||
2612 | when N_Integer_Literal => | |
2613 | return OK; | |
2614 | ||
2615 | when others => | |
2616 | return Abandon; | |
2617 | end case; | |
2618 | end May_Fold; | |
2619 | ||
2620 | function Try_Fold is new Traverse_Func (May_Fold); | |
2621 | ||
6ef13c4f | 2622 | -- Other lLocal variables |
29c64a0f | 2623 | |
6ef13c4f ES |
2624 | Subt : constant Entity_Id := Etype (First_Entity (P)); |
2625 | Aspect : Node_Id; | |
2626 | Pred : Node_Id; | |
29c64a0f | 2627 | |
a081ded4 ES |
2628 | -- Start of processing for Can_Fold_Predicate_Call |
2629 | ||
2630 | begin | |
2631 | -- Folding is only interesting if the actual is static and its type | |
2632 | -- has a Dynamic_Predicate aspect. For CodePeer we preserve the | |
2633 | -- function call. | |
2634 | ||
6ef13c4f ES |
2635 | Actual := First (Parameter_Associations (Call_Node)); |
2636 | Aspect := Find_Aspect (Subt, Aspect_Dynamic_Predicate); | |
2637 | ||
2638 | -- If actual is a declared constant, retrieve its value | |
2639 | ||
2640 | if Is_Entity_Name (Actual) | |
2641 | and then Ekind (Entity (Actual)) = E_Constant | |
2642 | then | |
2643 | Actual := Constant_Value (Entity (Actual)); | |
2644 | end if; | |
2645 | ||
2646 | if No (Actual) | |
2647 | or else Nkind (Actual) /= N_Integer_Literal | |
a081ded4 | 2648 | or else not Has_Dynamic_Predicate_Aspect (Subt) |
6ef13c4f | 2649 | or else No (Aspect) |
a081ded4 ES |
2650 | or else CodePeer_Mode |
2651 | then | |
2652 | return False; | |
2653 | end if; | |
2654 | ||
2655 | -- Retrieve the analyzed expression for the predicate | |
2656 | ||
6ef13c4f | 2657 | Pred := New_Copy_Tree (Expression (Aspect)); |
a081ded4 ES |
2658 | |
2659 | if Try_Fold (Pred) = OK then | |
2660 | Rewrite (Call_Node, Pred); | |
2661 | Analyze_And_Resolve (Call_Node, Standard_Boolean); | |
2662 | return True; | |
2663 | ||
29c64a0f | 2664 | -- Otherwise continue the expansion of the function call |
a081ded4 | 2665 | |
29c64a0f | 2666 | else |
a081ded4 ES |
2667 | return False; |
2668 | end if; | |
2669 | end Can_Fold_Predicate_Call; | |
2670 | ||
70482933 RK |
2671 | --------------------------- |
2672 | -- Inherited_From_Formal -- | |
2673 | --------------------------- | |
2674 | ||
2675 | function Inherited_From_Formal (S : Entity_Id) return Entity_Id is | |
2676 | Par : Entity_Id; | |
2677 | Gen_Par : Entity_Id; | |
2678 | Gen_Prim : Elist_Id; | |
2679 | Elmt : Elmt_Id; | |
2680 | Indic : Node_Id; | |
2681 | ||
2682 | begin | |
2683 | -- If the operation is inherited, it is attached to the corresponding | |
2684 | -- type derivation. If the parent in the derivation is a generic | |
2685 | -- actual, it is a subtype of the actual, and we have to recover the | |
2686 | -- original derived type declaration to find the proper parent. | |
2687 | ||
2688 | if Nkind (Parent (S)) /= N_Full_Type_Declaration | |
fbf5a39b | 2689 | or else not Is_Derived_Type (Defining_Identifier (Parent (S))) |
2f1b20a9 ES |
2690 | or else Nkind (Type_Definition (Original_Node (Parent (S)))) /= |
2691 | N_Derived_Type_Definition | |
fbf5a39b | 2692 | or else not In_Instance |
70482933 RK |
2693 | then |
2694 | return Empty; | |
2695 | ||
2696 | else | |
2697 | Indic := | |
e27b834b AC |
2698 | Subtype_Indication |
2699 | (Type_Definition (Original_Node (Parent (S)))); | |
70482933 RK |
2700 | |
2701 | if Nkind (Indic) = N_Subtype_Indication then | |
2702 | Par := Entity (Subtype_Mark (Indic)); | |
2703 | else | |
2704 | Par := Entity (Indic); | |
2705 | end if; | |
2706 | end if; | |
2707 | ||
2708 | if not Is_Generic_Actual_Type (Par) | |
2709 | or else Is_Tagged_Type (Par) | |
2710 | or else Nkind (Parent (Par)) /= N_Subtype_Declaration | |
2711 | or else not In_Open_Scopes (Scope (Par)) | |
70482933 RK |
2712 | then |
2713 | return Empty; | |
70482933 RK |
2714 | else |
2715 | Gen_Par := Generic_Parent_Type (Parent (Par)); | |
2716 | end if; | |
2717 | ||
7888a6ae GD |
2718 | -- If the actual has no generic parent type, the formal is not |
2719 | -- a formal derived type, so nothing to inherit. | |
2720 | ||
2721 | if No (Gen_Par) then | |
2722 | return Empty; | |
2723 | end if; | |
2724 | ||
2f1b20a9 ES |
2725 | -- If the generic parent type is still the generic type, this is a |
2726 | -- private formal, not a derived formal, and there are no operations | |
2727 | -- inherited from the formal. | |
fbf5a39b AC |
2728 | |
2729 | if Nkind (Parent (Gen_Par)) = N_Formal_Type_Declaration then | |
2730 | return Empty; | |
2731 | end if; | |
2732 | ||
70482933 | 2733 | Gen_Prim := Collect_Primitive_Operations (Gen_Par); |
70482933 | 2734 | |
2f1b20a9 | 2735 | Elmt := First_Elmt (Gen_Prim); |
70482933 RK |
2736 | while Present (Elmt) loop |
2737 | if Chars (Node (Elmt)) = Chars (S) then | |
2738 | declare | |
2739 | F1 : Entity_Id; | |
2740 | F2 : Entity_Id; | |
70482933 | 2741 | |
2f1b20a9 | 2742 | begin |
70482933 RK |
2743 | F1 := First_Formal (S); |
2744 | F2 := First_Formal (Node (Elmt)); | |
70482933 RK |
2745 | while Present (F1) |
2746 | and then Present (F2) | |
2747 | loop | |
70482933 RK |
2748 | if Etype (F1) = Etype (F2) |
2749 | or else Etype (F2) = Gen_Par | |
2750 | then | |
2751 | Next_Formal (F1); | |
2752 | Next_Formal (F2); | |
2753 | else | |
2754 | Next_Elmt (Elmt); | |
2755 | exit; -- not the right subprogram | |
2756 | end if; | |
2757 | ||
2758 | return Node (Elmt); | |
2759 | end loop; | |
2760 | end; | |
2761 | ||
2762 | else | |
2763 | Next_Elmt (Elmt); | |
2764 | end if; | |
2765 | end loop; | |
2766 | ||
2767 | raise Program_Error; | |
2768 | end Inherited_From_Formal; | |
2769 | ||
84f4072a JM |
2770 | -------------------------- |
2771 | -- In_Unfrozen_Instance -- | |
2772 | -------------------------- | |
2773 | ||
2774 | function In_Unfrozen_Instance (E : Entity_Id) return Boolean is | |
bde73c6b | 2775 | S : Entity_Id; |
84f4072a JM |
2776 | |
2777 | begin | |
bde73c6b AC |
2778 | S := E; |
2779 | while Present (S) and then S /= Standard_Standard loop | |
84f4072a JM |
2780 | if Is_Generic_Instance (S) |
2781 | and then Present (Freeze_Node (S)) | |
2782 | and then not Analyzed (Freeze_Node (S)) | |
2783 | then | |
2784 | return True; | |
2785 | end if; | |
2786 | ||
2787 | S := Scope (S); | |
2788 | end loop; | |
2789 | ||
2790 | return False; | |
2791 | end In_Unfrozen_Instance; | |
2792 | ||
5a644684 JM |
2793 | ---------------------------------- |
2794 | -- Is_Class_Wide_Interface_Type -- | |
2795 | ---------------------------------- | |
2796 | ||
2797 | function Is_Class_Wide_Interface_Type (E : Entity_Id) return Boolean is | |
5a644684 | 2798 | DDT : Entity_Id; |
7f8c1cd3 | 2799 | Typ : Entity_Id := E; |
5a644684 JM |
2800 | |
2801 | begin | |
2802 | if Has_Non_Limited_View (Typ) then | |
2803 | Typ := Non_Limited_View (Typ); | |
2804 | end if; | |
2805 | ||
2806 | if Ekind (Typ) = E_Anonymous_Access_Type then | |
2807 | DDT := Directly_Designated_Type (Typ); | |
2808 | ||
2809 | if Has_Non_Limited_View (DDT) then | |
2810 | DDT := Non_Limited_View (DDT); | |
2811 | end if; | |
2812 | ||
2813 | return Is_Class_Wide_Type (DDT) and then Is_Interface (DDT); | |
2814 | else | |
2815 | return Is_Class_Wide_Type (Typ) and then Is_Interface (Typ); | |
2816 | end if; | |
2817 | end Is_Class_Wide_Interface_Type; | |
2818 | ||
df3e68b1 HK |
2819 | ------------------------- |
2820 | -- Is_Direct_Deep_Call -- | |
2821 | ------------------------- | |
2822 | ||
2823 | function Is_Direct_Deep_Call (Subp : Entity_Id) return Boolean is | |
2824 | begin | |
2825 | if Is_TSS (Subp, TSS_Deep_Adjust) | |
2826 | or else Is_TSS (Subp, TSS_Deep_Finalize) | |
2827 | or else Is_TSS (Subp, TSS_Deep_Initialize) | |
2828 | then | |
2829 | declare | |
2830 | Actual : Node_Id; | |
2831 | Formal : Node_Id; | |
2832 | ||
2833 | begin | |
2834 | Actual := First (Parameter_Associations (N)); | |
2835 | Formal := First_Formal (Subp); | |
2836 | while Present (Actual) | |
2837 | and then Present (Formal) | |
2838 | loop | |
2839 | if Nkind (Actual) = N_Identifier | |
2840 | and then Is_Controlling_Actual (Actual) | |
2841 | and then Etype (Actual) = Etype (Formal) | |
2842 | then | |
2843 | return True; | |
2844 | end if; | |
2845 | ||
2846 | Next (Actual); | |
2847 | Next_Formal (Formal); | |
2848 | end loop; | |
2849 | end; | |
2850 | end if; | |
2851 | ||
2852 | return False; | |
2853 | end Is_Direct_Deep_Call; | |
2854 | ||
dd386db0 AC |
2855 | --------------- |
2856 | -- New_Value -- | |
2857 | --------------- | |
2858 | ||
2859 | function New_Value (From : Node_Id) return Node_Id is | |
2860 | Res : constant Node_Id := Duplicate_Subexpr (From); | |
2861 | begin | |
2862 | if Is_Access_Type (Etype (From)) then | |
bde73c6b | 2863 | return Make_Explicit_Dereference (Sloc (From), Prefix => Res); |
dd386db0 AC |
2864 | else |
2865 | return Res; | |
2866 | end if; | |
2867 | end New_Value; | |
2868 | ||
fdce4bb7 JM |
2869 | -- Local variables |
2870 | ||
888be6b1 | 2871 | Remote : constant Boolean := Is_Remote_Call (Call_Node); |
fdce4bb7 JM |
2872 | Actual : Node_Id; |
2873 | Formal : Entity_Id; | |
2874 | Orig_Subp : Entity_Id := Empty; | |
2875 | Param_Count : Natural := 0; | |
2876 | Parent_Formal : Entity_Id; | |
2877 | Parent_Subp : Entity_Id; | |
6a237c45 | 2878 | Pref_Entity : Entity_Id; |
fdce4bb7 JM |
2879 | Scop : Entity_Id; |
2880 | Subp : Entity_Id; | |
2881 | ||
e27b834b | 2882 | Prev_Orig : Node_Id; |
fdce4bb7 JM |
2883 | -- Original node for an actual, which may have been rewritten. If the |
2884 | -- actual is a function call that has been transformed from a selected | |
2885 | -- component, the original node is unanalyzed. Otherwise, it carries | |
2886 | -- semantic information used to generate additional actuals. | |
2887 | ||
2888 | CW_Interface_Formals_Present : Boolean := False; | |
2889 | ||
ca1f6b29 | 2890 | -- Start of processing for Expand_Call_Helper |
70482933 RK |
2891 | |
2892 | begin | |
ca1f6b29 BD |
2893 | Post_Call := New_List; |
2894 | ||
fc90cc62 AC |
2895 | -- Expand the function or procedure call if the first actual has a |
2896 | -- declared dimension aspect, and the subprogram is declared in one | |
2897 | -- of the dimension I/O packages. | |
dec6faf1 AC |
2898 | |
2899 | if Ada_Version >= Ada_2012 | |
fc90cc62 AC |
2900 | and then |
2901 | Nkind_In (Call_Node, N_Procedure_Call_Statement, N_Function_Call) | |
dec6faf1 AC |
2902 | and then Present (Parameter_Associations (Call_Node)) |
2903 | then | |
df378148 | 2904 | Expand_Put_Call_With_Symbol (Call_Node); |
dec6faf1 AC |
2905 | end if; |
2906 | ||
07fc65c4 GB |
2907 | -- Ignore if previous error |
2908 | ||
6dfc5592 RD |
2909 | if Nkind (Call_Node) in N_Has_Etype |
2910 | and then Etype (Call_Node) = Any_Type | |
2911 | then | |
07fc65c4 GB |
2912 | return; |
2913 | end if; | |
2914 | ||
70482933 RK |
2915 | -- Call using access to subprogram with explicit dereference |
2916 | ||
6dfc5592 RD |
2917 | if Nkind (Name (Call_Node)) = N_Explicit_Dereference then |
2918 | Subp := Etype (Name (Call_Node)); | |
70482933 RK |
2919 | Parent_Subp := Empty; |
2920 | ||
2921 | -- Case of call to simple entry, where the Name is a selected component | |
2922 | -- whose prefix is the task, and whose selector name is the entry name | |
2923 | ||
6dfc5592 RD |
2924 | elsif Nkind (Name (Call_Node)) = N_Selected_Component then |
2925 | Subp := Entity (Selector_Name (Name (Call_Node))); | |
70482933 RK |
2926 | Parent_Subp := Empty; |
2927 | ||
2928 | -- Case of call to member of entry family, where Name is an indexed | |
2929 | -- component, with the prefix being a selected component giving the | |
2930 | -- task and entry family name, and the index being the entry index. | |
2931 | ||
6dfc5592 RD |
2932 | elsif Nkind (Name (Call_Node)) = N_Indexed_Component then |
2933 | Subp := Entity (Selector_Name (Prefix (Name (Call_Node)))); | |
70482933 RK |
2934 | Parent_Subp := Empty; |
2935 | ||
2936 | -- Normal case | |
2937 | ||
2938 | else | |
6dfc5592 | 2939 | Subp := Entity (Name (Call_Node)); |
70482933 RK |
2940 | Parent_Subp := Alias (Subp); |
2941 | ||
2942 | -- Replace call to Raise_Exception by call to Raise_Exception_Always | |
2943 | -- if we can tell that the first parameter cannot possibly be null. | |
70f91180 | 2944 | -- This improves efficiency by avoiding a run-time test. |
70482933 | 2945 | |
7888a6ae GD |
2946 | -- We do not do this if Raise_Exception_Always does not exist, which |
2947 | -- can happen in configurable run time profiles which provide only a | |
70f91180 | 2948 | -- Raise_Exception. |
7888a6ae GD |
2949 | |
2950 | if Is_RTE (Subp, RE_Raise_Exception) | |
2951 | and then RTE_Available (RE_Raise_Exception_Always) | |
70482933 RK |
2952 | then |
2953 | declare | |
3cae7f14 RD |
2954 | FA : constant Node_Id := |
2955 | Original_Node (First_Actual (Call_Node)); | |
2956 | ||
70482933 RK |
2957 | begin |
2958 | -- The case we catch is where the first argument is obtained | |
2f1b20a9 ES |
2959 | -- using the Identity attribute (which must always be |
2960 | -- non-null). | |
70482933 RK |
2961 | |
2962 | if Nkind (FA) = N_Attribute_Reference | |
2963 | and then Attribute_Name (FA) = Name_Identity | |
2964 | then | |
2965 | Subp := RTE (RE_Raise_Exception_Always); | |
6dfc5592 | 2966 | Set_Name (Call_Node, New_Occurrence_Of (Subp, Loc)); |
70482933 RK |
2967 | end if; |
2968 | end; | |
2969 | end if; | |
2970 | ||
2971 | if Ekind (Subp) = E_Entry then | |
2972 | Parent_Subp := Empty; | |
2973 | end if; | |
2974 | end if; | |
2975 | ||
f4d379b8 HK |
2976 | -- Ada 2005 (AI-345): We have a procedure call as a triggering |
2977 | -- alternative in an asynchronous select or as an entry call in | |
2978 | -- a conditional or timed select. Check whether the procedure call | |
2979 | -- is a renaming of an entry and rewrite it as an entry call. | |
2980 | ||
0791fbe9 | 2981 | if Ada_Version >= Ada_2005 |
6dfc5592 | 2982 | and then Nkind (Call_Node) = N_Procedure_Call_Statement |
f4d379b8 | 2983 | and then |
6dfc5592 | 2984 | ((Nkind (Parent (Call_Node)) = N_Triggering_Alternative |
3cae7f14 | 2985 | and then Triggering_Statement (Parent (Call_Node)) = Call_Node) |
f4d379b8 | 2986 | or else |
6dfc5592 | 2987 | (Nkind (Parent (Call_Node)) = N_Entry_Call_Alternative |
3cae7f14 | 2988 | and then Entry_Call_Statement (Parent (Call_Node)) = Call_Node)) |
f4d379b8 HK |
2989 | then |
2990 | declare | |
2991 | Ren_Decl : Node_Id; | |
2992 | Ren_Root : Entity_Id := Subp; | |
2993 | ||
2994 | begin | |
2995 | -- This may be a chain of renamings, find the root | |
2996 | ||
2997 | if Present (Alias (Ren_Root)) then | |
2998 | Ren_Root := Alias (Ren_Root); | |
2999 | end if; | |
3000 | ||
3001 | if Present (Original_Node (Parent (Parent (Ren_Root)))) then | |
3002 | Ren_Decl := Original_Node (Parent (Parent (Ren_Root))); | |
3003 | ||
3004 | if Nkind (Ren_Decl) = N_Subprogram_Renaming_Declaration then | |
6dfc5592 | 3005 | Rewrite (Call_Node, |
f4d379b8 HK |
3006 | Make_Entry_Call_Statement (Loc, |
3007 | Name => | |
3008 | New_Copy_Tree (Name (Ren_Decl)), | |
3009 | Parameter_Associations => | |
6dfc5592 RD |
3010 | New_Copy_List_Tree |
3011 | (Parameter_Associations (Call_Node)))); | |
f4d379b8 HK |
3012 | |
3013 | return; | |
3014 | end if; | |
3015 | end if; | |
3016 | end; | |
3017 | end if; | |
3018 | ||
a081ded4 ES |
3019 | -- if this is a call to a predicate function, try to constant |
3020 | -- fold it. | |
3021 | ||
3022 | if Nkind (Call_Node) = N_Function_Call | |
3023 | and then Is_Entity_Name (Name (Call_Node)) | |
3024 | and then Is_Predicate_Function (Subp) | |
3025 | and then Can_Fold_Predicate_Call (Subp) | |
3026 | then | |
3027 | return; | |
3028 | end if; | |
3029 | ||
2700b9c1 AC |
3030 | if Modify_Tree_For_C |
3031 | and then Nkind (Call_Node) = N_Function_Call | |
3032 | and then Is_Entity_Name (Name (Call_Node)) | |
2700b9c1 | 3033 | then |
780d73d7 AC |
3034 | declare |
3035 | Func_Id : constant Entity_Id := | |
3036 | Ultimate_Alias (Entity (Name (Call_Node))); | |
3037 | begin | |
3038 | -- When generating C code, transform a function call that returns | |
3039 | -- a constrained array type into procedure form. | |
aeb98f1d | 3040 | |
780d73d7 AC |
3041 | if Rewritten_For_C (Func_Id) then |
3042 | ||
3043 | -- For internally generated calls ensure that they reference | |
3044 | -- the entity of the spec of the called function (needed since | |
3045 | -- the expander may generate calls using the entity of their | |
3046 | -- body). See for example Expand_Boolean_Operator(). | |
3047 | ||
3048 | if not (Comes_From_Source (Call_Node)) | |
3049 | and then Nkind (Unit_Declaration_Node (Func_Id)) = | |
3050 | N_Subprogram_Body | |
3051 | then | |
3052 | Set_Entity (Name (Call_Node), | |
3053 | Corresponding_Function | |
3054 | (Corresponding_Procedure (Func_Id))); | |
3055 | end if; | |
3056 | ||
3057 | Rewrite_Function_Call_For_C (Call_Node); | |
3058 | return; | |
3059 | ||
3060 | -- Also introduce a temporary for functions that return a record | |
3061 | -- called within another procedure or function call, since records | |
3062 | -- are passed by pointer in the generated C code, and we cannot | |
3063 | -- take a pointer from a subprogram call. | |
3064 | ||
3065 | elsif Nkind (Parent (Call_Node)) in N_Subprogram_Call | |
3066 | and then Is_Record_Type (Etype (Func_Id)) | |
3067 | then | |
3068 | declare | |
3069 | Temp_Id : constant Entity_Id := Make_Temporary (Loc, 'T'); | |
3070 | Decl : Node_Id; | |
3071 | ||
3072 | begin | |
3073 | -- Generate: | |
3074 | -- Temp : ... := Func_Call (...); | |
3075 | ||
3076 | Decl := | |
3077 | Make_Object_Declaration (Loc, | |
3078 | Defining_Identifier => Temp_Id, | |
3079 | Object_Definition => | |
3080 | New_Occurrence_Of (Etype (Func_Id), Loc), | |
3081 | Expression => | |
3082 | Make_Function_Call (Loc, | |
3083 | Name => | |
3084 | New_Occurrence_Of (Func_Id, Loc), | |
3085 | Parameter_Associations => | |
3086 | Parameter_Associations (Call_Node))); | |
3087 | ||
3088 | Insert_Action (Parent (Call_Node), Decl); | |
3089 | Rewrite (Call_Node, New_Occurrence_Of (Temp_Id, Loc)); | |
3090 | return; | |
3091 | end; | |
3092 | end if; | |
3093 | end; | |
2700b9c1 AC |
3094 | end if; |
3095 | ||
e27b834b AC |
3096 | -- First step, compute extra actuals, corresponding to any Extra_Formals |
3097 | -- present. Note that we do not access Extra_Formals directly, instead | |
3098 | -- we simply note the presence of the extra formals as we process the | |
3099 | -- regular formals collecting corresponding actuals in Extra_Actuals. | |
70482933 | 3100 | |
c2369146 AC |
3101 | -- We also generate any required range checks for actuals for in formals |
3102 | -- as we go through the loop, since this is a convenient place to do it. | |
3103 | -- (Though it seems that this would be better done in Expand_Actuals???) | |
fbf5a39b | 3104 | |
e2441021 AC |
3105 | -- Special case: Thunks must not compute the extra actuals; they must |
3106 | -- just propagate to the target primitive their extra actuals. | |
3107 | ||
3108 | if Is_Thunk (Current_Scope) | |
3109 | and then Thunk_Entity (Current_Scope) = Subp | |
3110 | and then Present (Extra_Formals (Subp)) | |
3111 | then | |
3112 | pragma Assert (Present (Extra_Formals (Current_Scope))); | |
3113 | ||
3114 | declare | |
3115 | Target_Formal : Entity_Id; | |
3116 | Thunk_Formal : Entity_Id; | |
3117 | ||
3118 | begin | |
3119 | Target_Formal := Extra_Formals (Subp); | |
3120 | Thunk_Formal := Extra_Formals (Current_Scope); | |
3121 | while Present (Target_Formal) loop | |
3122 | Add_Extra_Actual | |
683af98c AC |
3123 | (Expr => New_Occurrence_Of (Thunk_Formal, Loc), |
3124 | EF => Thunk_Formal); | |
e2441021 AC |
3125 | |
3126 | Target_Formal := Extra_Formal (Target_Formal); | |
3127 | Thunk_Formal := Extra_Formal (Thunk_Formal); | |
3128 | end loop; | |
3129 | ||
3130 | while Is_Non_Empty_List (Extra_Actuals) loop | |
3131 | Add_Actual_Parameter (Remove_Head (Extra_Actuals)); | |
3132 | end loop; | |
3133 | ||
ca1f6b29 BD |
3134 | Expand_Actuals (Call_Node, Subp, Post_Call); |
3135 | pragma Assert (Is_Empty_List (Post_Call)); | |
e2441021 AC |
3136 | return; |
3137 | end; | |
3138 | end if; | |
3139 | ||
8c5b03a0 AC |
3140 | Formal := First_Formal (Subp); |
3141 | Actual := First_Actual (Call_Node); | |
fdce4bb7 | 3142 | Param_Count := 1; |
70482933 | 3143 | while Present (Formal) loop |
fbf5a39b AC |
3144 | -- Prepare to examine current entry |
3145 | ||
70482933 RK |
3146 | Prev := Actual; |
3147 | Prev_Orig := Original_Node (Prev); | |
3148 | ||
758c442c | 3149 | -- Ada 2005 (AI-251): Check if any formal is a class-wide interface |
2f1b20a9 | 3150 | -- to expand it in a further round. |
758c442c GD |
3151 | |
3152 | CW_Interface_Formals_Present := | |
3153 | CW_Interface_Formals_Present | |
5a644684 | 3154 | or else Is_Class_Wide_Interface_Type (Etype (Formal)); |
758c442c GD |
3155 | |
3156 | -- Create possible extra actual for constrained case. Usually, the | |
3157 | -- extra actual is of the form actual'constrained, but since this | |
3158 | -- attribute is only available for unconstrained records, TRUE is | |
3159 | -- expanded if the type of the formal happens to be constrained (for | |
3160 | -- instance when this procedure is inherited from an unconstrained | |
3161 | -- record to a constrained one) or if the actual has no discriminant | |
3162 | -- (its type is constrained). An exception to this is the case of a | |
3163 | -- private type without discriminants. In this case we pass FALSE | |
3164 | -- because the object has underlying discriminants with defaults. | |
70482933 RK |
3165 | |
3166 | if Present (Extra_Constrained (Formal)) then | |
3167 | if Ekind (Etype (Prev)) in Private_Kind | |
3168 | and then not Has_Discriminants (Base_Type (Etype (Prev))) | |
3169 | then | |
01aef5ad | 3170 | Add_Extra_Actual |
683af98c AC |
3171 | (Expr => New_Occurrence_Of (Standard_False, Loc), |
3172 | EF => Extra_Constrained (Formal)); | |
70482933 RK |
3173 | |
3174 | elsif Is_Constrained (Etype (Formal)) | |
3175 | or else not Has_Discriminants (Etype (Prev)) | |
3176 | then | |
01aef5ad | 3177 | Add_Extra_Actual |
683af98c AC |
3178 | (Expr => New_Occurrence_Of (Standard_True, Loc), |
3179 | EF => Extra_Constrained (Formal)); | |
70482933 | 3180 | |
5d09245e AC |
3181 | -- Do not produce extra actuals for Unchecked_Union parameters. |
3182 | -- Jump directly to the end of the loop. | |
3183 | ||
3184 | elsif Is_Unchecked_Union (Base_Type (Etype (Actual))) then | |
3185 | goto Skip_Extra_Actual_Generation; | |
3186 | ||
70482933 RK |
3187 | else |
3188 | -- If the actual is a type conversion, then the constrained | |
3189 | -- test applies to the actual, not the target type. | |
3190 | ||
3191 | declare | |
2f1b20a9 | 3192 | Act_Prev : Node_Id; |
70482933 RK |
3193 | |
3194 | begin | |
2f1b20a9 ES |
3195 | -- Test for unchecked conversions as well, which can occur |
3196 | -- as out parameter actuals on calls to stream procedures. | |
70482933 | 3197 | |
2f1b20a9 | 3198 | Act_Prev := Prev; |
ac4d6407 RD |
3199 | while Nkind_In (Act_Prev, N_Type_Conversion, |
3200 | N_Unchecked_Type_Conversion) | |
fbf5a39b | 3201 | loop |
70482933 | 3202 | Act_Prev := Expression (Act_Prev); |
fbf5a39b | 3203 | end loop; |
70482933 | 3204 | |
3563739b AC |
3205 | -- If the expression is a conversion of a dereference, this |
3206 | -- is internally generated code that manipulates addresses, | |
3207 | -- e.g. when building interface tables. No check should | |
3208 | -- occur in this case, and the discriminated object is not | |
3209 | -- directly a hand. | |
f4d379b8 HK |
3210 | |
3211 | if not Comes_From_Source (Actual) | |
3212 | and then Nkind (Actual) = N_Unchecked_Type_Conversion | |
3213 | and then Nkind (Act_Prev) = N_Explicit_Dereference | |
3214 | then | |
3215 | Add_Extra_Actual | |
683af98c AC |
3216 | (Expr => New_Occurrence_Of (Standard_False, Loc), |
3217 | EF => Extra_Constrained (Formal)); | |
f4d379b8 HK |
3218 | |
3219 | else | |
3220 | Add_Extra_Actual | |
683af98c AC |
3221 | (Expr => |
3222 | Make_Attribute_Reference (Sloc (Prev), | |
3223 | Prefix => | |
3224 | Duplicate_Subexpr_No_Checks | |
3225 | (Act_Prev, Name_Req => True), | |
3226 | Attribute_Name => Name_Constrained), | |
3227 | EF => Extra_Constrained (Formal)); | |
f4d379b8 | 3228 | end if; |
70482933 RK |
3229 | end; |
3230 | end if; | |
3231 | end if; | |
3232 | ||
3233 | -- Create possible extra actual for accessibility level | |
3234 | ||
43b26411 | 3235 | if Present (Get_Accessibility (Formal)) then |
7888a6ae GD |
3236 | |
3237 | -- Ada 2005 (AI-252): If the actual was rewritten as an Access | |
3238 | -- attribute, then the original actual may be an aliased object | |
3239 | -- occurring as the prefix in a call using "Object.Operation" | |
3240 | -- notation. In that case we must pass the level of the object, | |
3241 | -- so Prev_Orig is reset to Prev and the attribute will be | |
3242 | -- processed by the code for Access attributes further below. | |
3243 | ||
3244 | if Prev_Orig /= Prev | |
3245 | and then Nkind (Prev) = N_Attribute_Reference | |
7f5e671b PMR |
3246 | and then Get_Attribute_Id (Attribute_Name (Prev)) = |
3247 | Attribute_Access | |
7888a6ae GD |
3248 | and then Is_Aliased_View (Prev_Orig) |
3249 | then | |
3250 | Prev_Orig := Prev; | |
05dbb83f | 3251 | |
d449ed75 PMR |
3252 | -- A class-wide precondition generates a test in which formals of |
3253 | -- the subprogram are replaced by actuals that came from source. | |
3254 | -- In that case as well, the accessiblity comes from the actual. | |
3255 | -- This is the one case in which there are references to formals | |
3256 | -- outside of their subprogram. | |
3257 | ||
3258 | elsif Prev_Orig /= Prev | |
3259 | and then Is_Entity_Name (Prev_Orig) | |
3260 | and then Present (Entity (Prev_Orig)) | |
3261 | and then Is_Formal (Entity (Prev_Orig)) | |
3262 | and then not In_Open_Scopes (Scope (Entity (Prev_Orig))) | |
3263 | then | |
3264 | Prev_Orig := Prev; | |
3265 | ||
05dbb83f AC |
3266 | -- If the actual is a formal of an enclosing subprogram it is |
3267 | -- the right entity, even if it is a rewriting. This happens | |
3268 | -- when the call is within an inherited condition or predicate. | |
3269 | ||
3270 | elsif Is_Entity_Name (Actual) | |
3271 | and then Is_Formal (Entity (Actual)) | |
3272 | and then In_Open_Scopes (Scope (Entity (Actual))) | |
3273 | then | |
3274 | Prev_Orig := Prev; | |
6a237c45 AC |
3275 | |
3276 | elsif Nkind (Prev_Orig) = N_Type_Conversion then | |
3277 | Prev_Orig := Expression (Prev_Orig); | |
7888a6ae GD |
3278 | end if; |
3279 | ||
9d983bbf AC |
3280 | -- Ada 2005 (AI-251): Thunks must propagate the extra actuals of |
3281 | -- accessibility levels. | |
fdce4bb7 | 3282 | |
da1c23dd | 3283 | if Is_Thunk (Current_Scope) then |
fdce4bb7 JM |
3284 | declare |
3285 | Parm_Ent : Entity_Id; | |
3286 | ||
3287 | begin | |
3288 | if Is_Controlling_Actual (Actual) then | |
3289 | ||
3290 | -- Find the corresponding actual of the thunk | |
3291 | ||
3292 | Parm_Ent := First_Entity (Current_Scope); | |
3293 | for J in 2 .. Param_Count loop | |
3294 | Next_Entity (Parm_Ent); | |
3295 | end loop; | |
3296 | ||
8a49a499 | 3297 | -- Handle unchecked conversion of access types generated |
5b5b27ad | 3298 | -- in thunks (cf. Expand_Interface_Thunk). |
8a49a499 AC |
3299 | |
3300 | elsif Is_Access_Type (Etype (Actual)) | |
3301 | and then Nkind (Actual) = N_Unchecked_Type_Conversion | |
3302 | then | |
3303 | Parm_Ent := Entity (Expression (Actual)); | |
3304 | ||
fdce4bb7 JM |
3305 | else pragma Assert (Is_Entity_Name (Actual)); |
3306 | Parm_Ent := Entity (Actual); | |
3307 | end if; | |
3308 | ||
3309 | Add_Extra_Actual | |
683af98c | 3310 | (Expr => |
43b26411 JS |
3311 | New_Occurrence_Of (Get_Accessibility (Parm_Ent), Loc), |
3312 | EF => Get_Accessibility (Formal)); | |
fdce4bb7 JM |
3313 | end; |
3314 | ||
3315 | elsif Is_Entity_Name (Prev_Orig) then | |
70482933 | 3316 | |
d766cee3 RD |
3317 | -- When passing an access parameter, or a renaming of an access |
3318 | -- parameter, as the actual to another access parameter we need | |
3319 | -- to pass along the actual's own access level parameter. This | |
3320 | -- is done if we are within the scope of the formal access | |
3321 | -- parameter (if this is an inlined body the extra formal is | |
3322 | -- irrelevant). | |
3323 | ||
3324 | if (Is_Formal (Entity (Prev_Orig)) | |
3325 | or else | |
3326 | (Present (Renamed_Object (Entity (Prev_Orig))) | |
3327 | and then | |
3328 | Is_Entity_Name (Renamed_Object (Entity (Prev_Orig))) | |
3329 | and then | |
3330 | Is_Formal | |
3331 | (Entity (Renamed_Object (Entity (Prev_Orig)))))) | |
70482933 RK |
3332 | and then Ekind (Etype (Prev_Orig)) = E_Anonymous_Access_Type |
3333 | and then In_Open_Scopes (Scope (Entity (Prev_Orig))) | |
3334 | then | |
3335 | declare | |
3336 | Parm_Ent : constant Entity_Id := Param_Entity (Prev_Orig); | |
3337 | ||
3338 | begin | |
3339 | pragma Assert (Present (Parm_Ent)); | |
3340 | ||
43b26411 | 3341 | if Present (Get_Accessibility (Parm_Ent)) then |
f4d379b8 | 3342 | Add_Extra_Actual |
683af98c AC |
3343 | (Expr => |
3344 | New_Occurrence_Of | |
43b26411 JS |
3345 | (Get_Accessibility (Parm_Ent), Loc), |
3346 | EF => Get_Accessibility (Formal)); | |
70482933 RK |
3347 | |
3348 | -- If the actual access parameter does not have an | |
3349 | -- associated extra formal providing its scope level, | |
3350 | -- then treat the actual as having library-level | |
3351 | -- accessibility. | |
3352 | ||
3353 | else | |
f4d379b8 | 3354 | Add_Extra_Actual |
683af98c AC |
3355 | (Expr => |
3356 | Make_Integer_Literal (Loc, | |
3357 | Intval => Scope_Depth (Standard_Standard)), | |
43b26411 | 3358 | EF => Get_Accessibility (Formal)); |
70482933 RK |
3359 | end if; |
3360 | end; | |
3361 | ||
7888a6ae GD |
3362 | -- The actual is a normal access value, so just pass the level |
3363 | -- of the actual's access type. | |
70482933 RK |
3364 | |
3365 | else | |
f4d379b8 | 3366 | Add_Extra_Actual |
683af98c | 3367 | (Expr => Dynamic_Accessibility_Level (Prev_Orig), |
43b26411 | 3368 | EF => Get_Accessibility (Formal)); |
70482933 RK |
3369 | end if; |
3370 | ||
01aef5ad GD |
3371 | -- If the actual is an access discriminant, then pass the level |
3372 | -- of the enclosing object (RM05-3.10.2(12.4/2)). | |
3373 | ||
3374 | elsif Nkind (Prev_Orig) = N_Selected_Component | |
3375 | and then Ekind (Entity (Selector_Name (Prev_Orig))) = | |
3376 | E_Discriminant | |
3377 | and then Ekind (Etype (Entity (Selector_Name (Prev_Orig)))) = | |
3378 | E_Anonymous_Access_Type | |
3379 | then | |
3380 | Add_Extra_Actual | |
683af98c AC |
3381 | (Expr => |
3382 | Make_Integer_Literal (Loc, | |
3383 | Intval => Object_Access_Level (Prefix (Prev_Orig))), | |
43b26411 | 3384 | EF => Get_Accessibility (Formal)); |
01aef5ad GD |
3385 | |
3386 | -- All other cases | |
fdce4bb7 | 3387 | |
70482933 RK |
3388 | else |
3389 | case Nkind (Prev_Orig) is | |
70482933 | 3390 | when N_Attribute_Reference => |
70482933 | 3391 | case Get_Attribute_Id (Attribute_Name (Prev_Orig)) is |
87b66149 JS |
3392 | -- Ignore 'Result, 'Loop_Entry, and 'Old as they can |
3393 | -- be used to identify access objects and do not have | |
3394 | -- an effect on accessibility level. | |
3395 | ||
3396 | when Attribute_Loop_Entry | |
3397 | | Attribute_Old | |
3398 | | Attribute_Result | |
3399 | => | |
3400 | null; | |
70482933 | 3401 | |
75a64833 | 3402 | -- For X'Access, pass on the level of the prefix X |
70482933 RK |
3403 | |
3404 | when Attribute_Access => | |
996c8821 | 3405 | |
683af98c | 3406 | -- Accessibility level of S'Access is that of A |
6a237c45 AC |
3407 | |
3408 | Prev_Orig := Prefix (Prev_Orig); | |
3409 | ||
683af98c AC |
3410 | -- If the expression is a view conversion, the |
3411 | -- accessibility level is that of the expression. | |
6a237c45 | 3412 | |
683af98c AC |
3413 | if Nkind (Original_Node (Prev_Orig)) = |
3414 | N_Type_Conversion | |
6a237c45 | 3415 | and then |
683af98c AC |
3416 | Nkind (Expression (Original_Node (Prev_Orig))) = |
3417 | N_Explicit_Dereference | |
6a237c45 AC |
3418 | then |
3419 | Prev_Orig := | |
3420 | Expression (Original_Node (Prev_Orig)); | |
3421 | end if; | |
3422 | ||
6cce2156 GD |
3423 | -- If this is an Access attribute applied to the |
3424 | -- the current instance object passed to a type | |
3425 | -- initialization procedure, then use the level | |
3426 | -- of the type itself. This is not really correct, | |
3427 | -- as there should be an extra level parameter | |
3428 | -- passed in with _init formals (only in the case | |
3429 | -- where the type is immutably limited), but we | |
3430 | -- don't have an easy way currently to create such | |
3431 | -- an extra formal (init procs aren't ever frozen). | |
3432 | -- For now we just use the level of the type, | |
3433 | -- which may be too shallow, but that works better | |
3434 | -- than passing Object_Access_Level of the type, | |
3435 | -- which can be one level too deep in some cases. | |
3436 | -- ??? | |
3437 | ||
6a237c45 | 3438 | -- A further case that requires special handling |
64ac53f4 | 3439 | -- is the common idiom E.all'access. If E is a |
6a237c45 AC |
3440 | -- formal of the enclosing subprogram, the |
3441 | -- accessibility of the expression is that of E. | |
3442 | ||
3443 | if Is_Entity_Name (Prev_Orig) then | |
3444 | Pref_Entity := Entity (Prev_Orig); | |
3445 | ||
3446 | elsif Nkind (Prev_Orig) = N_Explicit_Dereference | |
683af98c | 3447 | and then Is_Entity_Name (Prefix (Prev_Orig)) |
6a237c45 AC |
3448 | then |
3449 | Pref_Entity := Entity (Prefix ((Prev_Orig))); | |
3450 | ||
3451 | else | |
3452 | Pref_Entity := Empty; | |
3453 | end if; | |
3454 | ||
3455 | if Is_Entity_Name (Prev_Orig) | |
3456 | and then Is_Type (Entity (Prev_Orig)) | |
6cce2156 GD |
3457 | then |
3458 | Add_Extra_Actual | |
683af98c AC |
3459 | (Expr => |
3460 | Make_Integer_Literal (Loc, | |
3461 | Intval => | |
3462 | Type_Access_Level (Pref_Entity)), | |
43b26411 | 3463 | EF => Get_Accessibility (Formal)); |
6a237c45 AC |
3464 | |
3465 | elsif Nkind (Prev_Orig) = N_Explicit_Dereference | |
3466 | and then Present (Pref_Entity) | |
3467 | and then Is_Formal (Pref_Entity) | |
3468 | and then Present | |
43b26411 | 3469 | (Get_Accessibility (Pref_Entity)) |
6a237c45 | 3470 | then |
683af98c AC |
3471 | Add_Extra_Actual |
3472 | (Expr => | |
3473 | New_Occurrence_Of | |
43b26411 JS |
3474 | (Get_Accessibility (Pref_Entity), Loc), |
3475 | EF => Get_Accessibility (Formal)); | |
6cce2156 GD |
3476 | |
3477 | else | |
3478 | Add_Extra_Actual | |
683af98c AC |
3479 | (Expr => |
3480 | Make_Integer_Literal (Loc, | |
3481 | Intval => | |
3482 | Object_Access_Level (Prev_Orig)), | |
43b26411 | 3483 | EF => Get_Accessibility (Formal)); |
6cce2156 | 3484 | end if; |
70482933 RK |
3485 | |
3486 | -- Treat the unchecked attributes as library-level | |
3487 | ||
d8f43ee6 HK |
3488 | when Attribute_Unchecked_Access |
3489 | | Attribute_Unrestricted_Access | |
3490 | => | |
01aef5ad | 3491 | Add_Extra_Actual |
683af98c AC |
3492 | (Expr => |
3493 | Make_Integer_Literal (Loc, | |
3494 | Intval => Scope_Depth (Standard_Standard)), | |
43b26411 | 3495 | EF => Get_Accessibility (Formal)); |
70482933 RK |
3496 | |
3497 | -- No other cases of attributes returning access | |
9d983bbf | 3498 | -- values that can be passed to access parameters. |
70482933 RK |
3499 | |
3500 | when others => | |
3501 | raise Program_Error; | |
3502 | ||
3503 | end case; | |
3504 | ||
92a745f3 TQ |
3505 | -- For allocators we pass the level of the execution of the |
3506 | -- called subprogram, which is one greater than the current | |
43fa58c2 JM |
3507 | -- scope level. However, according to RM 3.10.2(14/3) this |
3508 | -- is wrong since for an anonymous allocator defining the | |
3509 | -- value of an access parameter, the accessibility level is | |
3510 | -- that of the innermost master of the call??? | |
70482933 RK |
3511 | |
3512 | when N_Allocator => | |
01aef5ad | 3513 | Add_Extra_Actual |
683af98c AC |
3514 | (Expr => |
3515 | Make_Integer_Literal (Loc, | |
3516 | Intval => Scope_Depth (Current_Scope) + 1), | |
43b26411 | 3517 | EF => Get_Accessibility (Formal)); |
70482933 | 3518 | |
d15f9422 AC |
3519 | -- For most other cases we simply pass the level of the |
3520 | -- actual's access type. The type is retrieved from | |
3521 | -- Prev rather than Prev_Orig, because in some cases | |
3522 | -- Prev_Orig denotes an original expression that has | |
3523 | -- not been analyzed. | |
70482933 RK |
3524 | |
3525 | when others => | |
01aef5ad | 3526 | Add_Extra_Actual |
683af98c | 3527 | (Expr => Dynamic_Accessibility_Level (Prev), |
43b26411 | 3528 | EF => Get_Accessibility (Formal)); |
70482933 RK |
3529 | end case; |
3530 | end if; | |
3531 | end if; | |
3532 | ||
2f1b20a9 | 3533 | -- Perform the check of 4.6(49) that prevents a null value from being |
b3f48fd4 AC |
3534 | -- passed as an actual to an access parameter. Note that the check |
3535 | -- is elided in the common cases of passing an access attribute or | |
2f1b20a9 ES |
3536 | -- access parameter as an actual. Also, we currently don't enforce |
3537 | -- this check for expander-generated actuals and when -gnatdj is set. | |
70482933 | 3538 | |
0791fbe9 | 3539 | if Ada_Version >= Ada_2005 then |
70482933 | 3540 | |
b3f48fd4 AC |
3541 | -- Ada 2005 (AI-231): Check null-excluding access types. Note that |
3542 | -- the intent of 6.4.1(13) is that null-exclusion checks should | |
3543 | -- not be done for 'out' parameters, even though it refers only | |
308e6f3a | 3544 | -- to constraint checks, and a null_exclusion is not a constraint. |
b3f48fd4 | 3545 | -- Note that AI05-0196-1 corrects this mistake in the RM. |
70482933 | 3546 | |
2f1b20a9 ES |
3547 | if Is_Access_Type (Etype (Formal)) |
3548 | and then Can_Never_Be_Null (Etype (Formal)) | |
b3f48fd4 | 3549 | and then Ekind (Formal) /= E_Out_Parameter |
2f1b20a9 | 3550 | and then Nkind (Prev) /= N_Raise_Constraint_Error |
d766cee3 | 3551 | and then (Known_Null (Prev) |
996c8821 | 3552 | or else not Can_Never_Be_Null (Etype (Prev))) |
2f1b20a9 ES |
3553 | then |
3554 | Install_Null_Excluding_Check (Prev); | |
3555 | end if; | |
70482933 | 3556 | |
0791fbe9 | 3557 | -- Ada_Version < Ada_2005 |
70482933 | 3558 | |
2f1b20a9 ES |
3559 | else |
3560 | if Ekind (Etype (Formal)) /= E_Anonymous_Access_Type | |
3561 | or else Access_Checks_Suppressed (Subp) | |
3562 | then | |
3563 | null; | |
70482933 | 3564 | |
2f1b20a9 ES |
3565 | elsif Debug_Flag_J then |
3566 | null; | |
70482933 | 3567 | |
2f1b20a9 ES |
3568 | elsif not Comes_From_Source (Prev) then |
3569 | null; | |
70482933 | 3570 | |
2f1b20a9 ES |
3571 | elsif Is_Entity_Name (Prev) |
3572 | and then Ekind (Etype (Prev)) = E_Anonymous_Access_Type | |
3573 | then | |
3574 | null; | |
2820d220 | 3575 | |
ac4d6407 | 3576 | elsif Nkind_In (Prev, N_Allocator, N_Attribute_Reference) then |
2f1b20a9 ES |
3577 | null; |
3578 | ||
2f1b20a9 ES |
3579 | else |
3580 | Install_Null_Excluding_Check (Prev); | |
3581 | end if; | |
70482933 RK |
3582 | end if; |
3583 | ||
fbf5a39b AC |
3584 | -- Perform appropriate validity checks on parameters that |
3585 | -- are entities. | |
70482933 RK |
3586 | |
3587 | if Validity_Checks_On then | |
6cdb2c6e | 3588 | if (Ekind (Formal) = E_In_Parameter |
996c8821 | 3589 | and then Validity_Check_In_Params) |
6cdb2c6e AC |
3590 | or else |
3591 | (Ekind (Formal) = E_In_Out_Parameter | |
996c8821 | 3592 | and then Validity_Check_In_Out_Params) |
70482933 | 3593 | then |
7888a6ae GD |
3594 | -- If the actual is an indexed component of a packed type (or |
3595 | -- is an indexed or selected component whose prefix recursively | |
3596 | -- meets this condition), it has not been expanded yet. It will | |
3597 | -- be copied in the validity code that follows, and has to be | |
3598 | -- expanded appropriately, so reanalyze it. | |
08aa9a4a | 3599 | |
7888a6ae GD |
3600 | -- What we do is just to unset analyzed bits on prefixes till |
3601 | -- we reach something that does not have a prefix. | |
3602 | ||
3603 | declare | |
3604 | Nod : Node_Id; | |
3605 | ||
3606 | begin | |
3607 | Nod := Actual; | |
ac4d6407 RD |
3608 | while Nkind_In (Nod, N_Indexed_Component, |
3609 | N_Selected_Component) | |
7888a6ae GD |
3610 | loop |
3611 | Set_Analyzed (Nod, False); | |
3612 | Nod := Prefix (Nod); | |
3613 | end loop; | |
3614 | end; | |
08aa9a4a | 3615 | |
70482933 | 3616 | Ensure_Valid (Actual); |
70482933 RK |
3617 | end if; |
3618 | end if; | |
3619 | ||
3620 | -- For IN OUT and OUT parameters, ensure that subscripts are valid | |
3621 | -- since this is a left side reference. We only do this for calls | |
3622 | -- from the source program since we assume that compiler generated | |
3623 | -- calls explicitly generate any required checks. We also need it | |
b3f48fd4 AC |
3624 | -- only if we are doing standard validity checks, since clearly it is |
3625 | -- not needed if validity checks are off, and in subscript validity | |
3626 | -- checking mode, all indexed components are checked with a call | |
3627 | -- directly from Expand_N_Indexed_Component. | |
70482933 | 3628 | |
6dfc5592 | 3629 | if Comes_From_Source (Call_Node) |
70482933 RK |
3630 | and then Ekind (Formal) /= E_In_Parameter |
3631 | and then Validity_Checks_On | |
3632 | and then Validity_Check_Default | |
3633 | and then not Validity_Check_Subscripts | |
3634 | then | |
3635 | Check_Valid_Lvalue_Subscripts (Actual); | |
3636 | end if; | |
3637 | ||
c8ef728f ES |
3638 | -- Mark any scalar OUT parameter that is a simple variable as no |
3639 | -- longer known to be valid (unless the type is always valid). This | |
3640 | -- reflects the fact that if an OUT parameter is never set in a | |
3641 | -- procedure, then it can become invalid on the procedure return. | |
fbf5a39b AC |
3642 | |
3643 | if Ekind (Formal) = E_Out_Parameter | |
3644 | and then Is_Entity_Name (Actual) | |
3645 | and then Ekind (Entity (Actual)) = E_Variable | |
3646 | and then not Is_Known_Valid (Etype (Actual)) | |
3647 | then | |
3648 | Set_Is_Known_Valid (Entity (Actual), False); | |
3649 | end if; | |
3650 | ||
c8ef728f ES |
3651 | -- For an OUT or IN OUT parameter, if the actual is an entity, then |
3652 | -- clear current values, since they can be clobbered. We are probably | |
3653 | -- doing this in more places than we need to, but better safe than | |
a90bd866 | 3654 | -- sorry when it comes to retaining bad current values. |
fbf5a39b AC |
3655 | |
3656 | if Ekind (Formal) /= E_In_Parameter | |
3657 | and then Is_Entity_Name (Actual) | |
67ce0d7e | 3658 | and then Present (Entity (Actual)) |
fbf5a39b | 3659 | then |
67ce0d7e RD |
3660 | declare |
3661 | Ent : constant Entity_Id := Entity (Actual); | |
3662 | Sav : Node_Id; | |
3663 | ||
3664 | begin | |
ac4d6407 RD |
3665 | -- For an OUT or IN OUT parameter that is an assignable entity, |
3666 | -- we do not want to clobber the Last_Assignment field, since | |
3667 | -- if it is set, it was precisely because it is indeed an OUT | |
a90bd866 | 3668 | -- or IN OUT parameter. We do reset the Is_Known_Valid flag |
75ba322d | 3669 | -- since the subprogram could have returned in invalid value. |
ac4d6407 | 3670 | |
13931a38 | 3671 | if Is_Assignable (Ent) then |
67ce0d7e RD |
3672 | Sav := Last_Assignment (Ent); |
3673 | Kill_Current_Values (Ent); | |
3674 | Set_Last_Assignment (Ent, Sav); | |
75ba322d | 3675 | Set_Is_Known_Valid (Ent, False); |
8f0303e7 | 3676 | Set_Is_True_Constant (Ent, False); |
67ce0d7e | 3677 | |
4bb43ffb | 3678 | -- For all other cases, just kill the current values |
67ce0d7e RD |
3679 | |
3680 | else | |
3681 | Kill_Current_Values (Ent); | |
3682 | end if; | |
3683 | end; | |
fbf5a39b AC |
3684 | end if; |
3685 | ||
70482933 RK |
3686 | -- If the formal is class wide and the actual is an aggregate, force |
3687 | -- evaluation so that the back end who does not know about class-wide | |
3688 | -- type, does not generate a temporary of the wrong size. | |
3689 | ||
3690 | if not Is_Class_Wide_Type (Etype (Formal)) then | |
3691 | null; | |
3692 | ||
3693 | elsif Nkind (Actual) = N_Aggregate | |
3694 | or else (Nkind (Actual) = N_Qualified_Expression | |
3695 | and then Nkind (Expression (Actual)) = N_Aggregate) | |
3696 | then | |
3697 | Force_Evaluation (Actual); | |
3698 | end if; | |
3699 | ||
3700 | -- In a remote call, if the formal is of a class-wide type, check | |
3701 | -- that the actual meets the requirements described in E.4(18). | |
3702 | ||
7888a6ae | 3703 | if Remote and then Is_Class_Wide_Type (Etype (Formal)) then |
70482933 | 3704 | Insert_Action (Actual, |
7888a6ae GD |
3705 | Make_Transportable_Check (Loc, |
3706 | Duplicate_Subexpr_Move_Checks (Actual))); | |
70482933 RK |
3707 | end if; |
3708 | ||
5f325af2 AC |
3709 | -- Perform invariant checks for all intermediate types in a view |
3710 | -- conversion after successful return from a call that passes the | |
3711 | -- view conversion as an IN OUT or OUT parameter (RM 7.3.2 (12/3, | |
3712 | -- 13/3, 14/3)). Consider only source conversion in order to avoid | |
3713 | -- generating spurious checks on complex expansion such as object | |
3714 | -- initialization through an extension aggregate. | |
84e13614 | 3715 | |
5f325af2 AC |
3716 | if Comes_From_Source (N) |
3717 | and then Ekind (Formal) /= E_In_Parameter | |
84e13614 JS |
3718 | and then Nkind (Actual) = N_Type_Conversion |
3719 | then | |
5f325af2 | 3720 | Add_View_Conversion_Invariants (Formal, Actual); |
84e13614 JS |
3721 | end if; |
3722 | ||
4f94fa11 AC |
3723 | -- Generating C the initialization of an allocator is performed by |
3724 | -- means of individual statements, and hence it must be done before | |
3725 | -- the call. | |
3726 | ||
3727 | if Modify_Tree_For_C | |
3728 | and then Nkind (Actual) = N_Allocator | |
3729 | and then Nkind (Expression (Actual)) = N_Qualified_Expression | |
3730 | then | |
3731 | Remove_Side_Effects (Actual); | |
3732 | end if; | |
3733 | ||
5d09245e AC |
3734 | -- This label is required when skipping extra actual generation for |
3735 | -- Unchecked_Union parameters. | |
3736 | ||
3737 | <<Skip_Extra_Actual_Generation>> | |
3738 | ||
fdce4bb7 | 3739 | Param_Count := Param_Count + 1; |
70482933 RK |
3740 | Next_Actual (Actual); |
3741 | Next_Formal (Formal); | |
3742 | end loop; | |
3743 | ||
bdf69d33 | 3744 | -- If we are calling an Ada 2012 function which needs to have the |
63585f75 SB |
3745 | -- "accessibility level determined by the point of call" (AI05-0234) |
3746 | -- passed in to it, then pass it in. | |
3747 | ||
b8a93198 | 3748 | if Ekind_In (Subp, E_Function, E_Operator, E_Subprogram_Type) |
57a3fca9 AC |
3749 | and then |
3750 | Present (Extra_Accessibility_Of_Result (Ultimate_Alias (Subp))) | |
63585f75 SB |
3751 | then |
3752 | declare | |
3753 | Ancestor : Node_Id := Parent (Call_Node); | |
3754 | Level : Node_Id := Empty; | |
3755 | Defer : Boolean := False; | |
3756 | ||
3757 | begin | |
3758 | -- Unimplemented: if Subp returns an anonymous access type, then | |
57a3fca9 | 3759 | |
63585f75 SB |
3760 | -- a) if the call is the operand of an explict conversion, then |
3761 | -- the target type of the conversion (a named access type) | |
3762 | -- determines the accessibility level pass in; | |
57a3fca9 | 3763 | |
63585f75 SB |
3764 | -- b) if the call defines an access discriminant of an object |
3765 | -- (e.g., the discriminant of an object being created by an | |
3766 | -- allocator, or the discriminant of a function result), | |
3767 | -- then the accessibility level to pass in is that of the | |
3768 | -- discriminated object being initialized). | |
3769 | ||
57a3fca9 AC |
3770 | -- ??? |
3771 | ||
63585f75 SB |
3772 | while Nkind (Ancestor) = N_Qualified_Expression |
3773 | loop | |
3774 | Ancestor := Parent (Ancestor); | |
3775 | end loop; | |
3776 | ||
3777 | case Nkind (Ancestor) is | |
3778 | when N_Allocator => | |
ebf494ec | 3779 | |
63585f75 | 3780 | -- At this point, we'd like to assign |
ebf494ec | 3781 | |
63585f75 | 3782 | -- Level := Dynamic_Accessibility_Level (Ancestor); |
ebf494ec | 3783 | |
63585f75 SB |
3784 | -- but Etype of Ancestor may not have been set yet, |
3785 | -- so that doesn't work. | |
ebf494ec | 3786 | |
63585f75 SB |
3787 | -- Handle this later in Expand_Allocator_Expression. |
3788 | ||
3789 | Defer := True; | |
3790 | ||
d8f43ee6 HK |
3791 | when N_Object_Declaration |
3792 | | N_Object_Renaming_Declaration | |
3793 | => | |
63585f75 SB |
3794 | declare |
3795 | Def_Id : constant Entity_Id := | |
3796 | Defining_Identifier (Ancestor); | |
ebf494ec | 3797 | |
63585f75 SB |
3798 | begin |
3799 | if Is_Return_Object (Def_Id) then | |
3800 | if Present (Extra_Accessibility_Of_Result | |
3801 | (Return_Applies_To (Scope (Def_Id)))) | |
3802 | then | |
3803 | -- Pass along value that was passed in if the | |
3804 | -- routine we are returning from also has an | |
3805 | -- Accessibility_Of_Result formal. | |
3806 | ||
3807 | Level := | |
3808 | New_Occurrence_Of | |
3809 | (Extra_Accessibility_Of_Result | |
ebf494ec | 3810 | (Return_Applies_To (Scope (Def_Id))), Loc); |
63585f75 SB |
3811 | end if; |
3812 | else | |
ebf494ec RD |
3813 | Level := |
3814 | Make_Integer_Literal (Loc, | |
3815 | Intval => Object_Access_Level (Def_Id)); | |
63585f75 SB |
3816 | end if; |
3817 | end; | |
3818 | ||
3819 | when N_Simple_Return_Statement => | |
3820 | if Present (Extra_Accessibility_Of_Result | |
ebf494ec RD |
3821 | (Return_Applies_To |
3822 | (Return_Statement_Entity (Ancestor)))) | |
63585f75 | 3823 | then |
fb12497d AC |
3824 | -- Pass along value that was passed in if the returned |
3825 | -- routine also has an Accessibility_Of_Result formal. | |
63585f75 SB |
3826 | |
3827 | Level := | |
3828 | New_Occurrence_Of | |
3829 | (Extra_Accessibility_Of_Result | |
d8f43ee6 HK |
3830 | (Return_Applies_To |
3831 | (Return_Statement_Entity (Ancestor))), Loc); | |
63585f75 SB |
3832 | end if; |
3833 | ||
3834 | when others => | |
3835 | null; | |
3836 | end case; | |
3837 | ||
3838 | if not Defer then | |
3839 | if not Present (Level) then | |
ebf494ec | 3840 | |
63585f75 | 3841 | -- The "innermost master that evaluates the function call". |
ebf494ec | 3842 | |
886b5a18 AC |
3843 | -- ??? - Should we use Integer'Last here instead in order |
3844 | -- to deal with (some of) the problems associated with | |
3845 | -- calls to subps whose enclosing scope is unknown (e.g., | |
3846 | -- Anon_Access_To_Subp_Param.all)? | |
63585f75 | 3847 | |
d8f43ee6 HK |
3848 | Level := |
3849 | Make_Integer_Literal (Loc, | |
3850 | Intval => Scope_Depth (Current_Scope) + 1); | |
63585f75 SB |
3851 | end if; |
3852 | ||
57a3fca9 | 3853 | Add_Extra_Actual |
683af98c AC |
3854 | (Expr => Level, |
3855 | EF => | |
3856 | Extra_Accessibility_Of_Result (Ultimate_Alias (Subp))); | |
63585f75 SB |
3857 | end if; |
3858 | end; | |
3859 | end if; | |
3860 | ||
4bb43ffb | 3861 | -- If we are expanding the RHS of an assignment we need to check if tag |
c8ef728f ES |
3862 | -- propagation is needed. You might expect this processing to be in |
3863 | -- Analyze_Assignment but has to be done earlier (bottom-up) because the | |
3864 | -- assignment might be transformed to a declaration for an unconstrained | |
3865 | -- value if the expression is classwide. | |
70482933 | 3866 | |
6dfc5592 RD |
3867 | if Nkind (Call_Node) = N_Function_Call |
3868 | and then Is_Tag_Indeterminate (Call_Node) | |
3869 | and then Is_Entity_Name (Name (Call_Node)) | |
70482933 RK |
3870 | then |
3871 | declare | |
3872 | Ass : Node_Id := Empty; | |
3873 | ||
3874 | begin | |
6dfc5592 RD |
3875 | if Nkind (Parent (Call_Node)) = N_Assignment_Statement then |
3876 | Ass := Parent (Call_Node); | |
70482933 | 3877 | |
6dfc5592 | 3878 | elsif Nkind (Parent (Call_Node)) = N_Qualified_Expression |
3cae7f14 RD |
3879 | and then Nkind (Parent (Parent (Call_Node))) = |
3880 | N_Assignment_Statement | |
70482933 | 3881 | then |
6dfc5592 | 3882 | Ass := Parent (Parent (Call_Node)); |
02822a92 | 3883 | |
6dfc5592 | 3884 | elsif Nkind (Parent (Call_Node)) = N_Explicit_Dereference |
3cae7f14 RD |
3885 | and then Nkind (Parent (Parent (Call_Node))) = |
3886 | N_Assignment_Statement | |
02822a92 | 3887 | then |
6dfc5592 | 3888 | Ass := Parent (Parent (Call_Node)); |
70482933 RK |
3889 | end if; |
3890 | ||
3891 | if Present (Ass) | |
3892 | and then Is_Class_Wide_Type (Etype (Name (Ass))) | |
3893 | then | |
6dfc5592 RD |
3894 | if Is_Access_Type (Etype (Call_Node)) then |
3895 | if Designated_Type (Etype (Call_Node)) /= | |
02822a92 RD |
3896 | Root_Type (Etype (Name (Ass))) |
3897 | then | |
3898 | Error_Msg_NE | |
a4f4dbdb AC |
3899 | ("tag-indeterminate expression must have designated " |
3900 | & "type& (RM 5.2 (6))", | |
3cae7f14 | 3901 | Call_Node, Root_Type (Etype (Name (Ass)))); |
02822a92 | 3902 | else |
6dfc5592 | 3903 | Propagate_Tag (Name (Ass), Call_Node); |
02822a92 RD |
3904 | end if; |
3905 | ||
6dfc5592 | 3906 | elsif Etype (Call_Node) /= Root_Type (Etype (Name (Ass))) then |
fbf5a39b | 3907 | Error_Msg_NE |
a4f4dbdb AC |
3908 | ("tag-indeterminate expression must have type & " |
3909 | & "(RM 5.2 (6))", | |
6dfc5592 | 3910 | Call_Node, Root_Type (Etype (Name (Ass)))); |
02822a92 | 3911 | |
fbf5a39b | 3912 | else |
6dfc5592 | 3913 | Propagate_Tag (Name (Ass), Call_Node); |
fbf5a39b AC |
3914 | end if; |
3915 | ||
3916 | -- The call will be rewritten as a dispatching call, and | |
3917 | -- expanded as such. | |
3918 | ||
70482933 RK |
3919 | return; |
3920 | end if; | |
3921 | end; | |
3922 | end if; | |
3923 | ||
758c442c GD |
3924 | -- Ada 2005 (AI-251): If some formal is a class-wide interface, expand |
3925 | -- it to point to the correct secondary virtual table | |
3926 | ||
d3b00ce3 | 3927 | if Nkind (Call_Node) in N_Subprogram_Call |
758c442c GD |
3928 | and then CW_Interface_Formals_Present |
3929 | then | |
6dfc5592 | 3930 | Expand_Interface_Actuals (Call_Node); |
758c442c GD |
3931 | end if; |
3932 | ||
70482933 RK |
3933 | -- Deals with Dispatch_Call if we still have a call, before expanding |
3934 | -- extra actuals since this will be done on the re-analysis of the | |
b3f48fd4 AC |
3935 | -- dispatching call. Note that we do not try to shorten the actual list |
3936 | -- for a dispatching call, it would not make sense to do so. Expansion | |
535a8637 | 3937 | -- of dispatching calls is suppressed for VM targets, because the VM |
b3f48fd4 AC |
3938 | -- back-ends directly handle the generation of dispatching calls and |
3939 | -- would have to undo any expansion to an indirect call. | |
70482933 | 3940 | |
d3b00ce3 | 3941 | if Nkind (Call_Node) in N_Subprogram_Call |
6dfc5592 | 3942 | and then Present (Controlling_Argument (Call_Node)) |
70482933 | 3943 | then |
6dfc5592 | 3944 | declare |
dd386db0 | 3945 | Call_Typ : constant Entity_Id := Etype (Call_Node); |
6dfc5592 RD |
3946 | Typ : constant Entity_Id := Find_Dispatching_Type (Subp); |
3947 | Eq_Prim_Op : Entity_Id := Empty; | |
dd386db0 AC |
3948 | New_Call : Node_Id; |
3949 | Param : Node_Id; | |
3950 | Prev_Call : Node_Id; | |
fbf5a39b | 3951 | |
6dfc5592 RD |
3952 | begin |
3953 | if not Is_Limited_Type (Typ) then | |
3954 | Eq_Prim_Op := Find_Prim_Op (Typ, Name_Op_Eq); | |
3955 | end if; | |
fbf5a39b | 3956 | |
6dfc5592 RD |
3957 | if Tagged_Type_Expansion then |
3958 | Expand_Dispatching_Call (Call_Node); | |
70f91180 | 3959 | |
6dfc5592 RD |
3960 | -- The following return is worrisome. Is it really OK to skip |
3961 | -- all remaining processing in this procedure ??? | |
5a1ccfb1 | 3962 | |
6dfc5592 | 3963 | return; |
5a1ccfb1 | 3964 | |
6dfc5592 RD |
3965 | -- VM targets |
3966 | ||
3967 | else | |
3968 | Apply_Tag_Checks (Call_Node); | |
3969 | ||
dd386db0 AC |
3970 | -- If this is a dispatching "=", we must first compare the |
3971 | -- tags so we generate: x.tag = y.tag and then x = y | |
3972 | ||
3973 | if Subp = Eq_Prim_Op then | |
3974 | ||
75b87c16 | 3975 | -- Mark the node as analyzed to avoid reanalyzing this |
dd386db0 AC |
3976 | -- dispatching call (which would cause a never-ending loop) |
3977 | ||
3978 | Prev_Call := Relocate_Node (Call_Node); | |
3979 | Set_Analyzed (Prev_Call); | |
3980 | ||
3981 | Param := First_Actual (Call_Node); | |
3982 | New_Call := | |
3983 | Make_And_Then (Loc, | |
3984 | Left_Opnd => | |
3985 | Make_Op_Eq (Loc, | |
3986 | Left_Opnd => | |
3987 | Make_Selected_Component (Loc, | |
3988 | Prefix => New_Value (Param), | |
3989 | Selector_Name => | |
e4494292 RD |
3990 | New_Occurrence_Of |
3991 | (First_Tag_Component (Typ), Loc)), | |
dd386db0 AC |
3992 | |
3993 | Right_Opnd => | |
3994 | Make_Selected_Component (Loc, | |
3995 | Prefix => | |
3996 | Unchecked_Convert_To (Typ, | |
3997 | New_Value (Next_Actual (Param))), | |
3998 | Selector_Name => | |
e4494292 | 3999 | New_Occurrence_Of |
dd386db0 AC |
4000 | (First_Tag_Component (Typ), Loc))), |
4001 | Right_Opnd => Prev_Call); | |
4002 | ||
4003 | Rewrite (Call_Node, New_Call); | |
4004 | ||
4005 | Analyze_And_Resolve | |
4006 | (Call_Node, Call_Typ, Suppress => All_Checks); | |
4007 | end if; | |
4008 | ||
6dfc5592 RD |
4009 | -- Expansion of a dispatching call results in an indirect call, |
4010 | -- which in turn causes current values to be killed (see | |
4011 | -- Resolve_Call), so on VM targets we do the call here to | |
4012 | -- ensure consistent warnings between VM and non-VM targets. | |
4013 | ||
4014 | Kill_Current_Values; | |
4015 | end if; | |
4016 | ||
4017 | -- If this is a dispatching "=" then we must update the reference | |
4018 | -- to the call node because we generated: | |
4019 | -- x.tag = y.tag and then x = y | |
4020 | ||
dd386db0 | 4021 | if Subp = Eq_Prim_Op then |
6dfc5592 RD |
4022 | Call_Node := Right_Opnd (Call_Node); |
4023 | end if; | |
4024 | end; | |
70f91180 | 4025 | end if; |
70482933 RK |
4026 | |
4027 | -- Similarly, expand calls to RCI subprograms on which pragma | |
4028 | -- All_Calls_Remote applies. The rewriting will be reanalyzed | |
b3f48fd4 AC |
4029 | -- later. Do this only when the call comes from source since we |
4030 | -- do not want such a rewriting to occur in expanded code. | |
70482933 | 4031 | |
6dfc5592 RD |
4032 | if Is_All_Remote_Call (Call_Node) then |
4033 | Expand_All_Calls_Remote_Subprogram_Call (Call_Node); | |
70482933 RK |
4034 | |
4035 | -- Similarly, do not add extra actuals for an entry call whose entity | |
4036 | -- is a protected procedure, or for an internal protected subprogram | |
4037 | -- call, because it will be rewritten as a protected subprogram call | |
4038 | -- and reanalyzed (see Expand_Protected_Subprogram_Call). | |
4039 | ||
4040 | elsif Is_Protected_Type (Scope (Subp)) | |
4041 | and then (Ekind (Subp) = E_Procedure | |
4042 | or else Ekind (Subp) = E_Function) | |
4043 | then | |
4044 | null; | |
4045 | ||
4046 | -- During that loop we gathered the extra actuals (the ones that | |
4047 | -- correspond to Extra_Formals), so now they can be appended. | |
4048 | ||
4049 | else | |
4050 | while Is_Non_Empty_List (Extra_Actuals) loop | |
4051 | Add_Actual_Parameter (Remove_Head (Extra_Actuals)); | |
4052 | end loop; | |
4053 | end if; | |
4054 | ||
b3f48fd4 AC |
4055 | -- At this point we have all the actuals, so this is the point at which |
4056 | -- the various expansion activities for actuals is carried out. | |
f44fe430 | 4057 | |
ca1f6b29 | 4058 | Expand_Actuals (Call_Node, Subp, Post_Call); |
70482933 | 4059 | |
5f49133f AC |
4060 | -- Verify that the actuals do not share storage. This check must be done |
4061 | -- on the caller side rather that inside the subprogram to avoid issues | |
4062 | -- of parameter passing. | |
4063 | ||
4064 | if Check_Aliasing_Of_Parameters then | |
4065 | Apply_Parameter_Aliasing_Checks (Call_Node, Subp); | |
4066 | end if; | |
4067 | ||
b3f48fd4 AC |
4068 | -- If the subprogram is a renaming, or if it is inherited, replace it in |
4069 | -- the call with the name of the actual subprogram being called. If this | |
4070 | -- is a dispatching call, the run-time decides what to call. The Alias | |
4071 | -- attribute does not apply to entries. | |
70482933 | 4072 | |
6dfc5592 RD |
4073 | if Nkind (Call_Node) /= N_Entry_Call_Statement |
4074 | and then No (Controlling_Argument (Call_Node)) | |
70482933 | 4075 | and then Present (Parent_Subp) |
df3e68b1 | 4076 | and then not Is_Direct_Deep_Call (Subp) |
70482933 RK |
4077 | then |
4078 | if Present (Inherited_From_Formal (Subp)) then | |
4079 | Parent_Subp := Inherited_From_Formal (Subp); | |
4080 | else | |
b81a5940 | 4081 | Parent_Subp := Ultimate_Alias (Parent_Subp); |
70482933 RK |
4082 | end if; |
4083 | ||
c8ef728f ES |
4084 | -- The below setting of Entity is suspect, see F109-018 discussion??? |
4085 | ||
6dfc5592 | 4086 | Set_Entity (Name (Call_Node), Parent_Subp); |
70482933 | 4087 | |
f937473f | 4088 | if Is_Abstract_Subprogram (Parent_Subp) |
70482933 RK |
4089 | and then not In_Instance |
4090 | then | |
4091 | Error_Msg_NE | |
6dfc5592 RD |
4092 | ("cannot call abstract subprogram &!", |
4093 | Name (Call_Node), Parent_Subp); | |
70482933 RK |
4094 | end if; |
4095 | ||
d4817e3f HK |
4096 | -- Inspect all formals of derived subprogram Subp. Compare parameter |
4097 | -- types with the parent subprogram and check whether an actual may | |
4098 | -- need a type conversion to the corresponding formal of the parent | |
4099 | -- subprogram. | |
70482933 | 4100 | |
d4817e3f | 4101 | -- Not clear whether intrinsic subprograms need such conversions. ??? |
70482933 RK |
4102 | |
4103 | if not Is_Intrinsic_Subprogram (Parent_Subp) | |
4104 | or else Is_Generic_Instance (Parent_Subp) | |
4105 | then | |
d4817e3f HK |
4106 | declare |
4107 | procedure Convert (Act : Node_Id; Typ : Entity_Id); | |
4108 | -- Rewrite node Act as a type conversion of Act to Typ. Analyze | |
4109 | -- and resolve the newly generated construct. | |
70482933 | 4110 | |
d4817e3f HK |
4111 | ------------- |
4112 | -- Convert -- | |
4113 | ------------- | |
70482933 | 4114 | |
d4817e3f HK |
4115 | procedure Convert (Act : Node_Id; Typ : Entity_Id) is |
4116 | begin | |
4117 | Rewrite (Act, OK_Convert_To (Typ, Relocate_Node (Act))); | |
4118 | Analyze (Act); | |
4119 | Resolve (Act, Typ); | |
4120 | end Convert; | |
4121 | ||
4122 | -- Local variables | |
4123 | ||
4124 | Actual_Typ : Entity_Id; | |
4125 | Formal_Typ : Entity_Id; | |
4126 | Parent_Typ : Entity_Id; | |
4127 | ||
4128 | begin | |
6dfc5592 | 4129 | Actual := First_Actual (Call_Node); |
d4817e3f HK |
4130 | Formal := First_Formal (Subp); |
4131 | Parent_Formal := First_Formal (Parent_Subp); | |
4132 | while Present (Formal) loop | |
4133 | Actual_Typ := Etype (Actual); | |
4134 | Formal_Typ := Etype (Formal); | |
4135 | Parent_Typ := Etype (Parent_Formal); | |
4136 | ||
4137 | -- For an IN parameter of a scalar type, the parent formal | |
4138 | -- type and derived formal type differ or the parent formal | |
4139 | -- type and actual type do not match statically. | |
4140 | ||
4141 | if Is_Scalar_Type (Formal_Typ) | |
4142 | and then Ekind (Formal) = E_In_Parameter | |
4143 | and then Formal_Typ /= Parent_Typ | |
4144 | and then | |
4145 | not Subtypes_Statically_Match (Parent_Typ, Actual_Typ) | |
4146 | and then not Raises_Constraint_Error (Actual) | |
4147 | then | |
4148 | Convert (Actual, Parent_Typ); | |
4149 | Enable_Range_Check (Actual); | |
4150 | ||
d79e621a GD |
4151 | -- If the actual has been marked as requiring a range |
4152 | -- check, then generate it here. | |
4153 | ||
4154 | if Do_Range_Check (Actual) then | |
d79e621a GD |
4155 | Generate_Range_Check |
4156 | (Actual, Etype (Formal), CE_Range_Check_Failed); | |
4157 | end if; | |
4158 | ||
d4817e3f HK |
4159 | -- For access types, the parent formal type and actual type |
4160 | -- differ. | |
4161 | ||
4162 | elsif Is_Access_Type (Formal_Typ) | |
4163 | and then Base_Type (Parent_Typ) /= Base_Type (Actual_Typ) | |
70482933 | 4164 | then |
d4817e3f HK |
4165 | if Ekind (Formal) /= E_In_Parameter then |
4166 | Convert (Actual, Parent_Typ); | |
4167 | ||
4168 | elsif Ekind (Parent_Typ) = E_Anonymous_Access_Type | |
4169 | and then Designated_Type (Parent_Typ) /= | |
4170 | Designated_Type (Actual_Typ) | |
4171 | and then not Is_Controlling_Formal (Formal) | |
4172 | then | |
4173 | -- This unchecked conversion is not necessary unless | |
4174 | -- inlining is enabled, because in that case the type | |
4175 | -- mismatch may become visible in the body about to be | |
4176 | -- inlined. | |
4177 | ||
4178 | Rewrite (Actual, | |
4179 | Unchecked_Convert_To (Parent_Typ, | |
4180 | Relocate_Node (Actual))); | |
d4817e3f HK |
4181 | Analyze (Actual); |
4182 | Resolve (Actual, Parent_Typ); | |
4183 | end if; | |
70482933 | 4184 | |
ab01e614 AC |
4185 | -- If there is a change of representation, then generate a |
4186 | -- warning, and do the change of representation. | |
4187 | ||
4188 | elsif not Same_Representation (Formal_Typ, Parent_Typ) then | |
4189 | Error_Msg_N | |
4190 | ("??change of representation required", Actual); | |
4191 | Convert (Actual, Parent_Typ); | |
4192 | ||
d4817e3f HK |
4193 | -- For array and record types, the parent formal type and |
4194 | -- derived formal type have different sizes or pragma Pack | |
4195 | -- status. | |
70482933 | 4196 | |
d4817e3f | 4197 | elsif ((Is_Array_Type (Formal_Typ) |
ab01e614 | 4198 | and then Is_Array_Type (Parent_Typ)) |
d4817e3f HK |
4199 | or else |
4200 | (Is_Record_Type (Formal_Typ) | |
ab01e614 | 4201 | and then Is_Record_Type (Parent_Typ))) |
d4817e3f HK |
4202 | and then |
4203 | (Esize (Formal_Typ) /= Esize (Parent_Typ) | |
ab01e614 AC |
4204 | or else Has_Pragma_Pack (Formal_Typ) /= |
4205 | Has_Pragma_Pack (Parent_Typ)) | |
d4817e3f HK |
4206 | then |
4207 | Convert (Actual, Parent_Typ); | |
70482933 | 4208 | end if; |
70482933 | 4209 | |
d4817e3f HK |
4210 | Next_Actual (Actual); |
4211 | Next_Formal (Formal); | |
4212 | Next_Formal (Parent_Formal); | |
4213 | end loop; | |
4214 | end; | |
70482933 RK |
4215 | end if; |
4216 | ||
4217 | Orig_Subp := Subp; | |
4218 | Subp := Parent_Subp; | |
4219 | end if; | |
4220 | ||
8a36a0cc AC |
4221 | -- Deal with case where call is an explicit dereference |
4222 | ||
6dfc5592 | 4223 | if Nkind (Name (Call_Node)) = N_Explicit_Dereference then |
70482933 RK |
4224 | |
4225 | -- Handle case of access to protected subprogram type | |
4226 | ||
f937473f | 4227 | if Is_Access_Protected_Subprogram_Type |
6dfc5592 | 4228 | (Base_Type (Etype (Prefix (Name (Call_Node))))) |
70482933 | 4229 | then |
b3f48fd4 AC |
4230 | -- If this is a call through an access to protected operation, the |
4231 | -- prefix has the form (object'address, operation'access). Rewrite | |
4232 | -- as a for other protected calls: the object is the 1st parameter | |
4233 | -- of the list of actuals. | |
70482933 RK |
4234 | |
4235 | declare | |
4236 | Call : Node_Id; | |
4237 | Parm : List_Id; | |
4238 | Nam : Node_Id; | |
4239 | Obj : Node_Id; | |
6dfc5592 | 4240 | Ptr : constant Node_Id := Prefix (Name (Call_Node)); |
fbf5a39b AC |
4241 | |
4242 | T : constant Entity_Id := | |
4243 | Equivalent_Type (Base_Type (Etype (Ptr))); | |
4244 | ||
4245 | D_T : constant Entity_Id := | |
4246 | Designated_Type (Base_Type (Etype (Ptr))); | |
70482933 RK |
4247 | |
4248 | begin | |
f44fe430 RD |
4249 | Obj := |
4250 | Make_Selected_Component (Loc, | |
4251 | Prefix => Unchecked_Convert_To (T, Ptr), | |
4252 | Selector_Name => | |
4253 | New_Occurrence_Of (First_Entity (T), Loc)); | |
4254 | ||
4255 | Nam := | |
4256 | Make_Selected_Component (Loc, | |
4257 | Prefix => Unchecked_Convert_To (T, Ptr), | |
4258 | Selector_Name => | |
4259 | New_Occurrence_Of (Next_Entity (First_Entity (T)), Loc)); | |
70482933 | 4260 | |
02822a92 RD |
4261 | Nam := |
4262 | Make_Explicit_Dereference (Loc, | |
4263 | Prefix => Nam); | |
70482933 | 4264 | |
be035558 | 4265 | if Present (Parameter_Associations (Call_Node)) then |
6dfc5592 | 4266 | Parm := Parameter_Associations (Call_Node); |
70482933 RK |
4267 | else |
4268 | Parm := New_List; | |
4269 | end if; | |
4270 | ||
4271 | Prepend (Obj, Parm); | |
4272 | ||
4273 | if Etype (D_T) = Standard_Void_Type then | |
02822a92 RD |
4274 | Call := |
4275 | Make_Procedure_Call_Statement (Loc, | |
4276 | Name => Nam, | |
4277 | Parameter_Associations => Parm); | |
70482933 | 4278 | else |
02822a92 RD |
4279 | Call := |
4280 | Make_Function_Call (Loc, | |
4281 | Name => Nam, | |
4282 | Parameter_Associations => Parm); | |
70482933 RK |
4283 | end if; |
4284 | ||
6dfc5592 | 4285 | Set_First_Named_Actual (Call, First_Named_Actual (Call_Node)); |
70482933 RK |
4286 | Set_Etype (Call, Etype (D_T)); |
4287 | ||
4288 | -- We do not re-analyze the call to avoid infinite recursion. | |
4289 | -- We analyze separately the prefix and the object, and set | |
4290 | -- the checks on the prefix that would otherwise be emitted | |
4291 | -- when resolving a call. | |
4292 | ||
6dfc5592 | 4293 | Rewrite (Call_Node, Call); |
70482933 RK |
4294 | Analyze (Nam); |
4295 | Apply_Access_Check (Nam); | |
4296 | Analyze (Obj); | |
4297 | return; | |
4298 | end; | |
4299 | end if; | |
4300 | end if; | |
4301 | ||
4302 | -- If this is a call to an intrinsic subprogram, then perform the | |
4303 | -- appropriate expansion to the corresponding tree node and we | |
a90bd866 | 4304 | -- are all done (since after that the call is gone). |
70482933 | 4305 | |
98f01d53 AC |
4306 | -- In the case where the intrinsic is to be processed by the back end, |
4307 | -- the call to Expand_Intrinsic_Call will do nothing, which is fine, | |
b3f48fd4 AC |
4308 | -- since the idea in this case is to pass the call unchanged. If the |
4309 | -- intrinsic is an inherited unchecked conversion, and the derived type | |
4310 | -- is the target type of the conversion, we must retain it as the return | |
4311 | -- type of the expression. Otherwise the expansion below, which uses the | |
4312 | -- parent operation, will yield the wrong type. | |
98f01d53 | 4313 | |
70482933 | 4314 | if Is_Intrinsic_Subprogram (Subp) then |
6dfc5592 | 4315 | Expand_Intrinsic_Call (Call_Node, Subp); |
d766cee3 | 4316 | |
6dfc5592 | 4317 | if Nkind (Call_Node) = N_Unchecked_Type_Conversion |
d766cee3 RD |
4318 | and then Parent_Subp /= Orig_Subp |
4319 | and then Etype (Parent_Subp) /= Etype (Orig_Subp) | |
4320 | then | |
6dfc5592 | 4321 | Set_Etype (Call_Node, Etype (Orig_Subp)); |
d766cee3 RD |
4322 | end if; |
4323 | ||
70482933 RK |
4324 | return; |
4325 | end if; | |
4326 | ||
b29def53 AC |
4327 | if Ekind_In (Subp, E_Function, E_Procedure) then |
4328 | ||
f68fc405 AC |
4329 | -- We perform a simple optimization on calls for To_Address by |
4330 | -- replacing them with an unchecked conversion. Not only is this | |
4331 | -- efficient, but it also avoids order of elaboration problems when | |
4332 | -- address clauses are inlined (address expression elaborated at the | |
ca1f6b29 | 4333 | -- wrong point). |
26a43556 | 4334 | |
f68fc405 | 4335 | -- We perform this optimization regardless of whether we are in the |
26a43556 | 4336 | -- main unit or in a unit in the context of the main unit, to ensure |
ca1f6b29 BD |
4337 | -- that the generated tree is the same in both cases, for CodePeer |
4338 | -- use. | |
26a43556 AC |
4339 | |
4340 | if Is_RTE (Subp, RE_To_Address) then | |
6dfc5592 | 4341 | Rewrite (Call_Node, |
26a43556 | 4342 | Unchecked_Convert_To |
6dfc5592 | 4343 | (RTE (RE_Address), Relocate_Node (First_Actual (Call_Node)))); |
26a43556 | 4344 | return; |
7d827255 | 4345 | |
7ec25b2b AC |
4346 | -- A call to a null procedure is replaced by a null statement, but we |
4347 | -- are not allowed to ignore possible side effects of the call, so we | |
4348 | -- make sure that actuals are evaluated. | |
66f95f60 | 4349 | -- We also suppress this optimization for GNATCoverage. |
7d827255 | 4350 | |
66f95f60 AC |
4351 | elsif Is_Null_Procedure (Subp) |
4352 | and then not Opt.Suppress_Control_Flow_Optimizations | |
4353 | then | |
7d827255 AC |
4354 | Actual := First_Actual (Call_Node); |
4355 | while Present (Actual) loop | |
4356 | Remove_Side_Effects (Actual); | |
4357 | Next_Actual (Actual); | |
4358 | end loop; | |
4359 | ||
4360 | Rewrite (Call_Node, Make_Null_Statement (Loc)); | |
4361 | return; | |
8dbf3473 AC |
4362 | end if; |
4363 | ||
6c26bac2 | 4364 | -- Handle inlining. No action needed if the subprogram is not inlined |
f087ea44 | 4365 | |
6c26bac2 AC |
4366 | if not Is_Inlined (Subp) then |
4367 | null; | |
f087ea44 | 4368 | |
49209838 EB |
4369 | -- Front-end inlining of expression functions (performed also when |
4370 | -- back-end inlining is enabled). | |
b5f3c913 AC |
4371 | |
4372 | elsif Is_Inlinable_Expression_Function (Subp) then | |
4373 | Rewrite (N, New_Copy (Expression_Of_Expression_Function (Subp))); | |
4374 | Analyze (N); | |
4375 | return; | |
4376 | ||
49209838 | 4377 | -- Handle front-end inlining |
84f4072a | 4378 | |
6c26bac2 | 4379 | elsif not Back_End_Inlining then |
a41ea816 | 4380 | Inlined_Subprogram : declare |
fbf5a39b AC |
4381 | Bod : Node_Id; |
4382 | Must_Inline : Boolean := False; | |
4383 | Spec : constant Node_Id := Unit_Declaration_Node (Subp); | |
a41ea816 | 4384 | |
70482933 | 4385 | begin |
2f1b20a9 ES |
4386 | -- Verify that the body to inline has already been seen, and |
4387 | -- that if the body is in the current unit the inlining does | |
4388 | -- not occur earlier. This avoids order-of-elaboration problems | |
4389 | -- in the back end. | |
4390 | ||
4391 | -- This should be documented in sinfo/einfo ??? | |
70482933 | 4392 | |
fbf5a39b AC |
4393 | if No (Spec) |
4394 | or else Nkind (Spec) /= N_Subprogram_Declaration | |
4395 | or else No (Body_To_Inline (Spec)) | |
70482933 | 4396 | then |
fbf5a39b AC |
4397 | Must_Inline := False; |
4398 | ||
26a43556 AC |
4399 | -- If this an inherited function that returns a private type, |
4400 | -- do not inline if the full view is an unconstrained array, | |
4401 | -- because such calls cannot be inlined. | |
5b4994bc AC |
4402 | |
4403 | elsif Present (Orig_Subp) | |
4404 | and then Is_Array_Type (Etype (Orig_Subp)) | |
4405 | and then not Is_Constrained (Etype (Orig_Subp)) | |
4406 | then | |
4407 | Must_Inline := False; | |
4408 | ||
84f4072a | 4409 | elsif In_Unfrozen_Instance (Scope (Subp)) then |
5b4994bc AC |
4410 | Must_Inline := False; |
4411 | ||
fbf5a39b AC |
4412 | else |
4413 | Bod := Body_To_Inline (Spec); | |
4414 | ||
6dfc5592 RD |
4415 | if (In_Extended_Main_Code_Unit (Call_Node) |
4416 | or else In_Extended_Main_Code_Unit (Parent (Call_Node)) | |
ac4d6407 | 4417 | or else Has_Pragma_Inline_Always (Subp)) |
fbf5a39b AC |
4418 | and then (not In_Same_Extended_Unit (Sloc (Bod), Loc) |
4419 | or else | |
4420 | Earlier_In_Extended_Unit (Sloc (Bod), Loc)) | |
4421 | then | |
4422 | Must_Inline := True; | |
4423 | ||
4424 | -- If we are compiling a package body that is not the main | |
4425 | -- unit, it must be for inlining/instantiation purposes, | |
4426 | -- in which case we inline the call to insure that the same | |
4427 | -- temporaries are generated when compiling the body by | |
4428 | -- itself. Otherwise link errors can occur. | |
4429 | ||
2820d220 AC |
4430 | -- If the function being called is itself in the main unit, |
4431 | -- we cannot inline, because there is a risk of double | |
4432 | -- elaboration and/or circularity: the inlining can make | |
4433 | -- visible a private entity in the body of the main unit, | |
4434 | -- that gigi will see before its sees its proper definition. | |
4435 | ||
6dfc5592 | 4436 | elsif not (In_Extended_Main_Code_Unit (Call_Node)) |
fbf5a39b AC |
4437 | and then In_Package_Body |
4438 | then | |
2820d220 | 4439 | Must_Inline := not In_Extended_Main_Source_Unit (Subp); |
1ba563f5 AC |
4440 | |
4441 | -- Inline calls to _postconditions when generating C code | |
4442 | ||
64f5d139 | 4443 | elsif Modify_Tree_For_C |
1ba563f5 AC |
4444 | and then In_Same_Extended_Unit (Sloc (Bod), Loc) |
4445 | and then Chars (Name (N)) = Name_uPostconditions | |
4446 | then | |
4447 | Must_Inline := True; | |
fbf5a39b AC |
4448 | end if; |
4449 | end if; | |
4450 | ||
4451 | if Must_Inline then | |
6dfc5592 | 4452 | Expand_Inlined_Call (Call_Node, Subp, Orig_Subp); |
70482933 RK |
4453 | |
4454 | else | |
fbf5a39b | 4455 | -- Let the back end handle it |
70482933 | 4456 | |
cf27c5a2 | 4457 | Add_Inlined_Body (Subp, Call_Node); |
70482933 RK |
4458 | |
4459 | if Front_End_Inlining | |
4460 | and then Nkind (Spec) = N_Subprogram_Declaration | |
6dfc5592 | 4461 | and then (In_Extended_Main_Code_Unit (Call_Node)) |
70482933 RK |
4462 | and then No (Body_To_Inline (Spec)) |
4463 | and then not Has_Completion (Subp) | |
4464 | and then In_Same_Extended_Unit (Sloc (Spec), Loc) | |
70482933 | 4465 | then |
fbf5a39b | 4466 | Cannot_Inline |
685bc70f AC |
4467 | ("cannot inline& (body not seen yet)?", |
4468 | Call_Node, Subp); | |
70482933 RK |
4469 | end if; |
4470 | end if; | |
a41ea816 | 4471 | end Inlined_Subprogram; |
84f4072a | 4472 | |
49209838 EB |
4473 | -- Front-end expansion of simple functions returning unconstrained |
4474 | -- types (see Check_And_Split_Unconstrained_Function). Note that the | |
4475 | -- case of a simple renaming (Body_To_Inline in N_Entity below, see | |
4476 | -- also Build_Renamed_Body) cannot be expanded here because this may | |
4477 | -- give rise to order-of-elaboration issues for the types of the | |
4478 | -- parameters of the subprogram, if any. | |
6c26bac2 | 4479 | |
49209838 EB |
4480 | elsif Present (Unit_Declaration_Node (Subp)) |
4481 | and then Nkind (Unit_Declaration_Node (Subp)) = | |
4482 | N_Subprogram_Declaration | |
4483 | and then Present (Body_To_Inline (Unit_Declaration_Node (Subp))) | |
4484 | and then | |
4485 | Nkind (Body_To_Inline (Unit_Declaration_Node (Subp))) not in | |
4486 | N_Entity | |
4487 | then | |
4488 | Expand_Inlined_Call (Call_Node, Subp, Orig_Subp); | |
4489 | ||
4490 | -- Back-end inlining either if optimization is enabled or the call is | |
4491 | -- required to be inlined. | |
4492 | ||
4493 | elsif Optimization_Level > 0 | |
4494 | or else Has_Pragma_Inline_Always (Subp) | |
6c26bac2 | 4495 | then |
cf27c5a2 | 4496 | Add_Inlined_Body (Subp, Call_Node); |
70482933 RK |
4497 | end if; |
4498 | end if; | |
4499 | ||
26a43556 AC |
4500 | -- Check for protected subprogram. This is either an intra-object call, |
4501 | -- or a protected function call. Protected procedure calls are rewritten | |
4502 | -- as entry calls and handled accordingly. | |
70482933 | 4503 | |
26a43556 AC |
4504 | -- In Ada 2005, this may be an indirect call to an access parameter that |
4505 | -- is an access_to_subprogram. In that case the anonymous type has a | |
4506 | -- scope that is a protected operation, but the call is a regular one. | |
6f76a257 | 4507 | -- In either case do not expand call if subprogram is eliminated. |
c8ef728f | 4508 | |
70482933 RK |
4509 | Scop := Scope (Subp); |
4510 | ||
6dfc5592 | 4511 | if Nkind (Call_Node) /= N_Entry_Call_Statement |
70482933 | 4512 | and then Is_Protected_Type (Scop) |
c8ef728f | 4513 | and then Ekind (Subp) /= E_Subprogram_Type |
6f76a257 | 4514 | and then not Is_Eliminated (Subp) |
70482933 | 4515 | then |
26a43556 AC |
4516 | -- If the call is an internal one, it is rewritten as a call to the |
4517 | -- corresponding unprotected subprogram. | |
70482933 | 4518 | |
6dfc5592 | 4519 | Expand_Protected_Subprogram_Call (Call_Node, Subp, Scop); |
70482933 RK |
4520 | end if; |
4521 | ||
df3e68b1 HK |
4522 | -- Functions returning controlled objects need special attention. If |
4523 | -- the return type is limited, then the context is initialization and | |
4524 | -- different processing applies. If the call is to a protected function, | |
4525 | -- the expansion above will call Expand_Call recursively. Otherwise the | |
4526 | -- function call is transformed into a temporary which obtains the | |
4527 | -- result from the secondary stack. | |
70482933 | 4528 | |
c768e988 | 4529 | if Needs_Finalization (Etype (Subp)) then |
cd644ae2 PMR |
4530 | if not Is_Build_In_Place_Function_Call (Call_Node) |
4531 | and then | |
4532 | (No (First_Formal (Subp)) | |
3fc40cd7 PMR |
4533 | or else |
4534 | not Is_Concurrent_Record_Type (Etype (First_Formal (Subp)))) | |
cd644ae2 PMR |
4535 | then |
4536 | Expand_Ctrl_Function_Call (Call_Node); | |
4537 | ||
c768e988 AC |
4538 | -- Build-in-place function calls which appear in anonymous contexts |
4539 | -- need a transient scope to ensure the proper finalization of the | |
4540 | -- intermediate result after its use. | |
4541 | ||
cd644ae2 | 4542 | elsif Is_Build_In_Place_Function_Call (Call_Node) |
3fc40cd7 PMR |
4543 | and then Nkind_In (Parent (Unqual_Conv (Call_Node)), |
4544 | N_Attribute_Reference, | |
4545 | N_Function_Call, | |
4546 | N_Indexed_Component, | |
4547 | N_Object_Renaming_Declaration, | |
4548 | N_Procedure_Call_Statement, | |
4549 | N_Selected_Component, | |
4550 | N_Slice) | |
d2ca5779 PMR |
4551 | and then |
4552 | (Ekind (Current_Scope) /= E_Loop | |
4553 | or else Nkind (Parent (N)) /= N_Function_Call | |
4554 | or else not Is_Build_In_Place_Function_Call (Parent (N))) | |
c768e988 | 4555 | then |
6560f851 | 4556 | Establish_Transient_Scope (Call_Node, Manage_Sec_Stack => True); |
c768e988 | 4557 | end if; |
70482933 | 4558 | end if; |
ca1f6b29 | 4559 | end Expand_Call_Helper; |
70482933 | 4560 | |
df3e68b1 HK |
4561 | ------------------------------- |
4562 | -- Expand_Ctrl_Function_Call -- | |
4563 | ------------------------------- | |
4564 | ||
4565 | procedure Expand_Ctrl_Function_Call (N : Node_Id) is | |
bf561f2b AC |
4566 | function Is_Element_Reference (N : Node_Id) return Boolean; |
4567 | -- Determine whether node N denotes a reference to an Ada 2012 container | |
4568 | -- element. | |
4569 | ||
4570 | -------------------------- | |
4571 | -- Is_Element_Reference -- | |
4572 | -------------------------- | |
4573 | ||
4574 | function Is_Element_Reference (N : Node_Id) return Boolean is | |
4575 | Ref : constant Node_Id := Original_Node (N); | |
4576 | ||
4577 | begin | |
4578 | -- Analysis marks an element reference by setting the generalized | |
4579 | -- indexing attribute of an indexed component before the component | |
4580 | -- is rewritten into a function call. | |
4581 | ||
4582 | return | |
4583 | Nkind (Ref) = N_Indexed_Component | |
4584 | and then Present (Generalized_Indexing (Ref)); | |
4585 | end Is_Element_Reference; | |
4586 | ||
bf561f2b AC |
4587 | -- Start of processing for Expand_Ctrl_Function_Call |
4588 | ||
df3e68b1 HK |
4589 | begin |
4590 | -- Optimization, if the returned value (which is on the sec-stack) is | |
4591 | -- returned again, no need to copy/readjust/finalize, we can just pass | |
4592 | -- the value thru (see Expand_N_Simple_Return_Statement), and thus no | |
4593 | -- attachment is needed | |
4594 | ||
4595 | if Nkind (Parent (N)) = N_Simple_Return_Statement then | |
4596 | return; | |
4597 | end if; | |
4598 | ||
4599 | -- Resolution is now finished, make sure we don't start analysis again | |
4600 | -- because of the duplication. | |
4601 | ||
4602 | Set_Analyzed (N); | |
4603 | ||
4604 | -- A function which returns a controlled object uses the secondary | |
4605 | -- stack. Rewrite the call into a temporary which obtains the result of | |
4606 | -- the function using 'reference. | |
4607 | ||
4608 | Remove_Side_Effects (N); | |
3cebd1c0 | 4609 | |
937e9676 AC |
4610 | -- The side effect removal of the function call produced a temporary. |
4611 | -- When the context is a case expression, if expression, or expression | |
4612 | -- with actions, the lifetime of the temporary must be extended to match | |
4613 | -- that of the context. Otherwise the function result will be finalized | |
4614 | -- too early and affect the result of the expression. To prevent this | |
4615 | -- unwanted effect, the temporary should not be considered for clean up | |
4616 | -- actions by the general finalization machinery. | |
4617 | ||
4618 | -- Exception to this rule are references to Ada 2012 container elements. | |
bf561f2b AC |
4619 | -- Such references must be finalized at the end of each iteration of the |
4620 | -- related quantified expression, otherwise the container will remain | |
4621 | -- busy. | |
4622 | ||
937e9676 | 4623 | if Nkind (N) = N_Explicit_Dereference |
bf561f2b | 4624 | and then Within_Case_Or_If_Expression (N) |
937e9676 | 4625 | and then not Is_Element_Reference (N) |
3cebd1c0 | 4626 | then |
937e9676 | 4627 | Set_Is_Ignored_Transient (Entity (Prefix (N))); |
3cebd1c0 | 4628 | end if; |
df3e68b1 HK |
4629 | end Expand_Ctrl_Function_Call; |
4630 | ||
2b3d67a5 AC |
4631 | ---------------------------------------- |
4632 | -- Expand_N_Extended_Return_Statement -- | |
4633 | ---------------------------------------- | |
4634 | ||
4635 | -- If there is a Handled_Statement_Sequence, we rewrite this: | |
4636 | ||
4637 | -- return Result : T := <expression> do | |
4638 | -- <handled_seq_of_stms> | |
4639 | -- end return; | |
4640 | ||
4641 | -- to be: | |
4642 | ||
4643 | -- declare | |
4644 | -- Result : T := <expression>; | |
4645 | -- begin | |
4646 | -- <handled_seq_of_stms> | |
4647 | -- return Result; | |
4648 | -- end; | |
4649 | ||
4650 | -- Otherwise (no Handled_Statement_Sequence), we rewrite this: | |
4651 | ||
4652 | -- return Result : T := <expression>; | |
4653 | ||
4654 | -- to be: | |
4655 | ||
4656 | -- return <expression>; | |
4657 | ||
4658 | -- unless it's build-in-place or there's no <expression>, in which case | |
4659 | -- we generate: | |
4660 | ||
4661 | -- declare | |
4662 | -- Result : T := <expression>; | |
4663 | -- begin | |
4664 | -- return Result; | |
4665 | -- end; | |
4666 | ||
4667 | -- Note that this case could have been written by the user as an extended | |
4668 | -- return statement, or could have been transformed to this from a simple | |
4669 | -- return statement. | |
4670 | ||
4671 | -- That is, we need to have a reified return object if there are statements | |
4672 | -- (which might refer to it) or if we're doing build-in-place (so we can | |
4673 | -- set its address to the final resting place or if there is no expression | |
7d1d3a54 | 4674 | -- (in which case default initial values might need to be set)). |
2b3d67a5 AC |
4675 | |
4676 | procedure Expand_N_Extended_Return_Statement (N : Node_Id) is | |
4677 | Loc : constant Source_Ptr := Sloc (N); | |
4678 | ||
7d1d3a54 | 4679 | function Build_Heap_Or_Pool_Allocator |
df3e68b1 HK |
4680 | (Temp_Id : Entity_Id; |
4681 | Temp_Typ : Entity_Id; | |
4682 | Func_Id : Entity_Id; | |
4683 | Ret_Typ : Entity_Id; | |
4684 | Alloc_Expr : Node_Id) return Node_Id; | |
4685 | -- Create the statements necessary to allocate a return object on the | |
7d1d3a54 HK |
4686 | -- heap or user-defined storage pool. The object may need finalization |
4687 | -- actions depending on the return type. | |
df3e68b1 | 4688 | -- |
7d1d3a54 HK |
4689 | -- * Controlled case |
4690 | -- | |
4691 | -- if BIPfinalizationmaster = null then | |
4692 | -- Temp_Id := <Alloc_Expr>; | |
4693 | -- else | |
4694 | -- declare | |
4695 | -- type Ptr_Typ is access Ret_Typ; | |
4696 | -- for Ptr_Typ'Storage_Pool use | |
4697 | -- Base_Pool (BIPfinalizationmaster.all).all; | |
4698 | -- Local : Ptr_Typ; | |
df3e68b1 | 4699 | -- |
df3e68b1 | 4700 | -- begin |
7d1d3a54 HK |
4701 | -- procedure Allocate (...) is |
4702 | -- begin | |
4703 | -- System.Storage_Pools.Subpools.Allocate_Any (...); | |
4704 | -- end Allocate; | |
df3e68b1 | 4705 | -- |
7d1d3a54 HK |
4706 | -- Local := <Alloc_Expr>; |
4707 | -- Temp_Id := Temp_Typ (Local); | |
4708 | -- end; | |
4709 | -- end if; | |
4710 | -- | |
4711 | -- * Non-controlled case | |
4712 | -- | |
4713 | -- Temp_Id := <Alloc_Expr>; | |
df3e68b1 HK |
4714 | -- |
4715 | -- Temp_Id is the temporary which is used to reference the internally | |
4716 | -- created object in all allocation forms. Temp_Typ is the type of the | |
4717 | -- temporary. Func_Id is the enclosing function. Ret_Typ is the return | |
4718 | -- type of Func_Id. Alloc_Expr is the actual allocator. | |
2b3d67a5 | 4719 | |
e5f2c03c | 4720 | function Move_Activation_Chain (Func_Id : Entity_Id) return Node_Id; |
2b3d67a5 AC |
4721 | -- Construct a call to System.Tasking.Stages.Move_Activation_Chain |
4722 | -- with parameters: | |
4723 | -- From current activation chain | |
4724 | -- To activation chain passed in by the caller | |
4725 | -- New_Master master passed in by the caller | |
e5f2c03c AC |
4726 | -- |
4727 | -- Func_Id is the entity of the function where the extended return | |
4728 | -- statement appears. | |
2b3d67a5 | 4729 | |
7d1d3a54 HK |
4730 | ---------------------------------- |
4731 | -- Build_Heap_Or_Pool_Allocator -- | |
4732 | ---------------------------------- | |
df3e68b1 | 4733 | |
7d1d3a54 | 4734 | function Build_Heap_Or_Pool_Allocator |
df3e68b1 HK |
4735 | (Temp_Id : Entity_Id; |
4736 | Temp_Typ : Entity_Id; | |
4737 | Func_Id : Entity_Id; | |
4738 | Ret_Typ : Entity_Id; | |
4739 | Alloc_Expr : Node_Id) return Node_Id | |
4740 | is | |
4741 | begin | |
200b7162 BD |
4742 | pragma Assert (Is_Build_In_Place_Function (Func_Id)); |
4743 | ||
7d1d3a54 | 4744 | -- Processing for objects that require finalization actions |
df3e68b1 | 4745 | |
535a8637 | 4746 | if Needs_Finalization (Ret_Typ) then |
df3e68b1 | 4747 | declare |
d3f70b35 AC |
4748 | Decls : constant List_Id := New_List; |
4749 | Fin_Mas_Id : constant Entity_Id := | |
4750 | Build_In_Place_Formal | |
4751 | (Func_Id, BIP_Finalization_Master); | |
6a4f3b31 HK |
4752 | Orig_Expr : constant Node_Id := |
4753 | New_Copy_Tree | |
4754 | (Source => Alloc_Expr, | |
4755 | Scopes_In_EWA_OK => True); | |
d3f70b35 | 4756 | Stmts : constant List_Id := New_List; |
ba759acd AC |
4757 | Desig_Typ : Entity_Id; |
4758 | Local_Id : Entity_Id; | |
4759 | Pool_Id : Entity_Id; | |
4760 | Ptr_Typ : Entity_Id; | |
df3e68b1 HK |
4761 | |
4762 | begin | |
4763 | -- Generate: | |
d3f70b35 | 4764 | -- Pool_Id renames Base_Pool (BIPfinalizationmaster.all).all; |
df3e68b1 HK |
4765 | |
4766 | Pool_Id := Make_Temporary (Loc, 'P'); | |
4767 | ||
4768 | Append_To (Decls, | |
4769 | Make_Object_Renaming_Declaration (Loc, | |
4770 | Defining_Identifier => Pool_Id, | |
2c1b72d7 | 4771 | Subtype_Mark => |
e4494292 | 4772 | New_Occurrence_Of (RTE (RE_Root_Storage_Pool), Loc), |
2c1b72d7 | 4773 | Name => |
df3e68b1 HK |
4774 | Make_Explicit_Dereference (Loc, |
4775 | Prefix => | |
4776 | Make_Function_Call (Loc, | |
2c1b72d7 | 4777 | Name => |
e4494292 | 4778 | New_Occurrence_Of (RTE (RE_Base_Pool), Loc), |
df3e68b1 HK |
4779 | Parameter_Associations => New_List ( |
4780 | Make_Explicit_Dereference (Loc, | |
d3f70b35 | 4781 | Prefix => |
e4494292 | 4782 | New_Occurrence_Of (Fin_Mas_Id, Loc))))))); |
df3e68b1 HK |
4783 | |
4784 | -- Create an access type which uses the storage pool of the | |
d3f70b35 AC |
4785 | -- caller's master. This additional type is necessary because |
4786 | -- the finalization master cannot be associated with the type | |
df3e68b1 HK |
4787 | -- of the temporary. Otherwise the secondary stack allocation |
4788 | -- will fail. | |
4789 | ||
ba759acd AC |
4790 | Desig_Typ := Ret_Typ; |
4791 | ||
4792 | -- Ensure that the build-in-place machinery uses a fat pointer | |
4793 | -- when allocating an unconstrained array on the heap. In this | |
4794 | -- case the result object type is a constrained array type even | |
4795 | -- though the function type is unconstrained. | |
4796 | ||
4797 | if Ekind (Desig_Typ) = E_Array_Subtype then | |
4798 | Desig_Typ := Base_Type (Desig_Typ); | |
4799 | end if; | |
4800 | ||
df3e68b1 | 4801 | -- Generate: |
ba759acd | 4802 | -- type Ptr_Typ is access Desig_Typ; |
df3e68b1 HK |
4803 | |
4804 | Ptr_Typ := Make_Temporary (Loc, 'P'); | |
4805 | ||
4806 | Append_To (Decls, | |
4807 | Make_Full_Type_Declaration (Loc, | |
4808 | Defining_Identifier => Ptr_Typ, | |
2c1b72d7 | 4809 | Type_Definition => |
df3e68b1 HK |
4810 | Make_Access_To_Object_Definition (Loc, |
4811 | Subtype_Indication => | |
e4494292 | 4812 | New_Occurrence_Of (Desig_Typ, Loc)))); |
df3e68b1 | 4813 | |
d3f70b35 AC |
4814 | -- Perform minor decoration in order to set the master and the |
4815 | -- storage pool attributes. | |
df3e68b1 | 4816 | |
7d1d3a54 | 4817 | Set_Ekind (Ptr_Typ, E_Access_Type); |
d3f70b35 | 4818 | Set_Finalization_Master (Ptr_Typ, Fin_Mas_Id); |
df3e68b1 HK |
4819 | Set_Associated_Storage_Pool (Ptr_Typ, Pool_Id); |
4820 | ||
4821 | -- Create the temporary, generate: | |
df3e68b1 HK |
4822 | -- Local_Id : Ptr_Typ; |
4823 | ||
4824 | Local_Id := Make_Temporary (Loc, 'T'); | |
4825 | ||
4826 | Append_To (Decls, | |
4827 | Make_Object_Declaration (Loc, | |
4828 | Defining_Identifier => Local_Id, | |
2c1b72d7 | 4829 | Object_Definition => |
e4494292 | 4830 | New_Occurrence_Of (Ptr_Typ, Loc))); |
df3e68b1 HK |
4831 | |
4832 | -- Allocate the object, generate: | |
df3e68b1 HK |
4833 | -- Local_Id := <Alloc_Expr>; |
4834 | ||
4835 | Append_To (Stmts, | |
4836 | Make_Assignment_Statement (Loc, | |
e4494292 | 4837 | Name => New_Occurrence_Of (Local_Id, Loc), |
df3e68b1 HK |
4838 | Expression => Alloc_Expr)); |
4839 | ||
4840 | -- Generate: | |
4841 | -- Temp_Id := Temp_Typ (Local_Id); | |
4842 | ||
4843 | Append_To (Stmts, | |
4844 | Make_Assignment_Statement (Loc, | |
e4494292 | 4845 | Name => New_Occurrence_Of (Temp_Id, Loc), |
df3e68b1 HK |
4846 | Expression => |
4847 | Unchecked_Convert_To (Temp_Typ, | |
e4494292 | 4848 | New_Occurrence_Of (Local_Id, Loc)))); |
df3e68b1 HK |
4849 | |
4850 | -- Wrap the allocation in a block. This is further conditioned | |
d3f70b35 AC |
4851 | -- by checking the caller finalization master at runtime. A |
4852 | -- null value indicates a non-existent master, most likely due | |
4853 | -- to a Finalize_Storage_Only allocation. | |
df3e68b1 HK |
4854 | |
4855 | -- Generate: | |
7d1d3a54 HK |
4856 | -- if BIPfinalizationmaster = null then |
4857 | -- Temp_Id := <Orig_Expr>; | |
4858 | -- else | |
df3e68b1 HK |
4859 | -- declare |
4860 | -- <Decls> | |
4861 | -- begin | |
4862 | -- <Stmts> | |
4863 | -- end; | |
4864 | -- end if; | |
4865 | ||
4866 | return | |
4867 | Make_If_Statement (Loc, | |
2c1b72d7 | 4868 | Condition => |
7d1d3a54 | 4869 | Make_Op_Eq (Loc, |
e4494292 | 4870 | Left_Opnd => New_Occurrence_Of (Fin_Mas_Id, Loc), |
2c1b72d7 | 4871 | Right_Opnd => Make_Null (Loc)), |
df3e68b1 HK |
4872 | |
4873 | Then_Statements => New_List ( | |
7d1d3a54 HK |
4874 | Make_Assignment_Statement (Loc, |
4875 | Name => New_Occurrence_Of (Temp_Id, Loc), | |
4876 | Expression => Orig_Expr)), | |
4877 | ||
4878 | Else_Statements => New_List ( | |
df3e68b1 | 4879 | Make_Block_Statement (Loc, |
2c1b72d7 | 4880 | Declarations => Decls, |
df3e68b1 HK |
4881 | Handled_Statement_Sequence => |
4882 | Make_Handled_Sequence_Of_Statements (Loc, | |
4883 | Statements => Stmts)))); | |
4884 | end; | |
4885 | ||
4886 | -- For all other cases, generate: | |
df3e68b1 HK |
4887 | -- Temp_Id := <Alloc_Expr>; |
4888 | ||
4889 | else | |
4890 | return | |
4891 | Make_Assignment_Statement (Loc, | |
e4494292 | 4892 | Name => New_Occurrence_Of (Temp_Id, Loc), |
df3e68b1 HK |
4893 | Expression => Alloc_Expr); |
4894 | end if; | |
7d1d3a54 | 4895 | end Build_Heap_Or_Pool_Allocator; |
2b3d67a5 | 4896 | |
2b3d67a5 AC |
4897 | --------------------------- |
4898 | -- Move_Activation_Chain -- | |
4899 | --------------------------- | |
4900 | ||
e5f2c03c | 4901 | function Move_Activation_Chain (Func_Id : Entity_Id) return Node_Id is |
2b3d67a5 | 4902 | begin |
2b3d67a5 AC |
4903 | return |
4904 | Make_Procedure_Call_Statement (Loc, | |
2c1b72d7 | 4905 | Name => |
e4494292 | 4906 | New_Occurrence_Of (RTE (RE_Move_Activation_Chain), Loc), |
0613fb33 AC |
4907 | |
4908 | Parameter_Associations => New_List ( | |
4909 | ||
4910 | -- Source chain | |
4911 | ||
4912 | Make_Attribute_Reference (Loc, | |
4913 | Prefix => Make_Identifier (Loc, Name_uChain), | |
4914 | Attribute_Name => Name_Unrestricted_Access), | |
4915 | ||
4916 | -- Destination chain | |
4917 | ||
e4494292 | 4918 | New_Occurrence_Of |
e5f2c03c | 4919 | (Build_In_Place_Formal (Func_Id, BIP_Activation_Chain), Loc), |
0613fb33 AC |
4920 | |
4921 | -- New master | |
4922 | ||
e4494292 | 4923 | New_Occurrence_Of |
e5f2c03c | 4924 | (Build_In_Place_Formal (Func_Id, BIP_Task_Master), Loc))); |
2b3d67a5 AC |
4925 | end Move_Activation_Chain; |
4926 | ||
e5f2c03c AC |
4927 | -- Local variables |
4928 | ||
4929 | Func_Id : constant Entity_Id := | |
4930 | Return_Applies_To (Return_Statement_Entity (N)); | |
4931 | Is_BIP_Func : constant Boolean := | |
4932 | Is_Build_In_Place_Function (Func_Id); | |
4933 | Ret_Obj_Id : constant Entity_Id := | |
4934 | First_Entity (Return_Statement_Entity (N)); | |
4935 | Ret_Obj_Decl : constant Node_Id := Parent (Ret_Obj_Id); | |
4936 | Ret_Typ : constant Entity_Id := Etype (Func_Id); | |
4937 | ||
4938 | Exp : Node_Id; | |
4939 | HSS : Node_Id; | |
4940 | Result : Node_Id; | |
e5f2c03c AC |
4941 | Stmts : List_Id; |
4942 | ||
dcd5fd67 PMR |
4943 | Return_Stmt : Node_Id := Empty; |
4944 | -- Force initialization to facilitate static analysis | |
4945 | ||
df3e68b1 | 4946 | -- Start of processing for Expand_N_Extended_Return_Statement |
2b3d67a5 | 4947 | |
df3e68b1 | 4948 | begin |
f6f4d8d4 JM |
4949 | -- Given that functionality of interface thunks is simple (just displace |
4950 | -- the pointer to the object) they are always handled by means of | |
4951 | -- simple return statements. | |
4952 | ||
76ed5f08 | 4953 | pragma Assert (not Is_Thunk (Current_Subprogram)); |
f6f4d8d4 | 4954 | |
df3e68b1 HK |
4955 | if Nkind (Ret_Obj_Decl) = N_Object_Declaration then |
4956 | Exp := Expression (Ret_Obj_Decl); | |
b3801819 PMR |
4957 | |
4958 | -- Assert that if F says "return R : T := G(...) do..." | |
4959 | -- then F and G are both b-i-p, or neither b-i-p. | |
4960 | ||
4961 | if Nkind (Exp) = N_Function_Call then | |
76ed5f08 | 4962 | pragma Assert (Ekind (Current_Subprogram) = E_Function); |
b3801819 | 4963 | pragma Assert |
76ed5f08 | 4964 | (Is_Build_In_Place_Function (Current_Subprogram) = |
b3801819 PMR |
4965 | Is_Build_In_Place_Function_Call (Exp)); |
4966 | null; | |
4967 | end if; | |
df3e68b1 HK |
4968 | else |
4969 | Exp := Empty; | |
4970 | end if; | |
2b3d67a5 | 4971 | |
df3e68b1 | 4972 | HSS := Handled_Statement_Sequence (N); |
2b3d67a5 | 4973 | |
df3e68b1 HK |
4974 | -- If the returned object needs finalization actions, the function must |
4975 | -- perform the appropriate cleanup should it fail to return. The state | |
4976 | -- of the function itself is tracked through a flag which is coupled | |
4977 | -- with the scope finalizer. There is one flag per each return object | |
4978 | -- in case of multiple returns. | |
2b3d67a5 | 4979 | |
e5f2c03c | 4980 | if Is_BIP_Func and then Needs_Finalization (Etype (Ret_Obj_Id)) then |
df3e68b1 HK |
4981 | declare |
4982 | Flag_Decl : Node_Id; | |
4983 | Flag_Id : Entity_Id; | |
4984 | Func_Bod : Node_Id; | |
2b3d67a5 | 4985 | |
df3e68b1 HK |
4986 | begin |
4987 | -- Recover the function body | |
2b3d67a5 | 4988 | |
e5f2c03c | 4989 | Func_Bod := Unit_Declaration_Node (Func_Id); |
0613fb33 | 4990 | |
df3e68b1 HK |
4991 | if Nkind (Func_Bod) = N_Subprogram_Declaration then |
4992 | Func_Bod := Parent (Parent (Corresponding_Body (Func_Bod))); | |
4993 | end if; | |
2b3d67a5 | 4994 | |
d4dfb005 BD |
4995 | if Nkind (Func_Bod) = N_Function_Specification then |
4996 | Func_Bod := Parent (Func_Bod); -- one more level for child units | |
4997 | end if; | |
4998 | ||
4999 | pragma Assert (Nkind (Func_Bod) = N_Subprogram_Body); | |
5000 | ||
df3e68b1 | 5001 | -- Create a flag to track the function state |
2b3d67a5 | 5002 | |
df3e68b1 | 5003 | Flag_Id := Make_Temporary (Loc, 'F'); |
3cebd1c0 | 5004 | Set_Status_Flag_Or_Transient_Decl (Ret_Obj_Id, Flag_Id); |
2b3d67a5 | 5005 | |
df3e68b1 HK |
5006 | -- Insert the flag at the beginning of the function declarations, |
5007 | -- generate: | |
5008 | -- Fnn : Boolean := False; | |
2b3d67a5 | 5009 | |
df3e68b1 HK |
5010 | Flag_Decl := |
5011 | Make_Object_Declaration (Loc, | |
5012 | Defining_Identifier => Flag_Id, | |
2c1b72d7 | 5013 | Object_Definition => |
e4494292 RD |
5014 | New_Occurrence_Of (Standard_Boolean, Loc), |
5015 | Expression => | |
5016 | New_Occurrence_Of (Standard_False, Loc)); | |
2b3d67a5 | 5017 | |
df3e68b1 HK |
5018 | Prepend_To (Declarations (Func_Bod), Flag_Decl); |
5019 | Analyze (Flag_Decl); | |
5020 | end; | |
5021 | end if; | |
2b3d67a5 AC |
5022 | |
5023 | -- Build a simple_return_statement that returns the return object when | |
5024 | -- there is a statement sequence, or no expression, or the result will | |
5025 | -- be built in place. Note however that we currently do this for all | |
d4dfb005 | 5026 | -- composite cases, even though not all are built in place. |
2b3d67a5 | 5027 | |
df3e68b1 | 5028 | if Present (HSS) |
e5f2c03c | 5029 | or else Is_Composite_Type (Ret_Typ) |
2b3d67a5 AC |
5030 | or else No (Exp) |
5031 | then | |
df3e68b1 HK |
5032 | if No (HSS) then |
5033 | Stmts := New_List; | |
2b3d67a5 AC |
5034 | |
5035 | -- If the extended return has a handled statement sequence, then wrap | |
5036 | -- it in a block and use the block as the first statement. | |
5037 | ||
5038 | else | |
df3e68b1 HK |
5039 | Stmts := New_List ( |
5040 | Make_Block_Statement (Loc, | |
2c1b72d7 | 5041 | Declarations => New_List, |
df3e68b1 | 5042 | Handled_Statement_Sequence => HSS)); |
2b3d67a5 AC |
5043 | end if; |
5044 | ||
df3e68b1 HK |
5045 | -- If the result type contains tasks, we call Move_Activation_Chain. |
5046 | -- Later, the cleanup code will call Complete_Master, which will | |
5047 | -- terminate any unactivated tasks belonging to the return statement | |
5048 | -- master. But Move_Activation_Chain updates their master to be that | |
5049 | -- of the caller, so they will not be terminated unless the return | |
5050 | -- statement completes unsuccessfully due to exception, abort, goto, | |
5051 | -- or exit. As a formality, we test whether the function requires the | |
5052 | -- result to be built in place, though that's necessarily true for | |
5053 | -- the case of result types with task parts. | |
2b3d67a5 | 5054 | |
e5f2c03c AC |
5055 | if Is_BIP_Func and then Has_Task (Ret_Typ) then |
5056 | ||
4a1bfefb AC |
5057 | -- The return expression is an aggregate for a complex type which |
5058 | -- contains tasks. This particular case is left unexpanded since | |
5059 | -- the regular expansion would insert all temporaries and | |
5060 | -- initialization code in the wrong block. | |
5061 | ||
5062 | if Nkind (Exp) = N_Aggregate then | |
5063 | Expand_N_Aggregate (Exp); | |
5064 | end if; | |
5065 | ||
1a36a0cd AC |
5066 | -- Do not move the activation chain if the return object does not |
5067 | -- contain tasks. | |
5068 | ||
5069 | if Has_Task (Etype (Ret_Obj_Id)) then | |
e5f2c03c | 5070 | Append_To (Stmts, Move_Activation_Chain (Func_Id)); |
1a36a0cd | 5071 | end if; |
2b3d67a5 AC |
5072 | end if; |
5073 | ||
df3e68b1 HK |
5074 | -- Update the state of the function right before the object is |
5075 | -- returned. | |
5076 | ||
e5f2c03c | 5077 | if Is_BIP_Func and then Needs_Finalization (Etype (Ret_Obj_Id)) then |
df3e68b1 | 5078 | declare |
35a1c212 | 5079 | Flag_Id : constant Entity_Id := |
3cebd1c0 | 5080 | Status_Flag_Or_Transient_Decl (Ret_Obj_Id); |
4fdebd93 | 5081 | |
df3e68b1 HK |
5082 | begin |
5083 | -- Generate: | |
5084 | -- Fnn := True; | |
5085 | ||
5086 | Append_To (Stmts, | |
5087 | Make_Assignment_Statement (Loc, | |
e4494292 RD |
5088 | Name => New_Occurrence_Of (Flag_Id, Loc), |
5089 | Expression => New_Occurrence_Of (Standard_True, Loc))); | |
df3e68b1 | 5090 | end; |
2b3d67a5 AC |
5091 | end if; |
5092 | ||
5093 | -- Build a simple_return_statement that returns the return object | |
5094 | ||
df3e68b1 | 5095 | Return_Stmt := |
2b3d67a5 | 5096 | Make_Simple_Return_Statement (Loc, |
2c1b72d7 | 5097 | Expression => New_Occurrence_Of (Ret_Obj_Id, Loc)); |
df3e68b1 | 5098 | Append_To (Stmts, Return_Stmt); |
2b3d67a5 | 5099 | |
df3e68b1 | 5100 | HSS := Make_Handled_Sequence_Of_Statements (Loc, Stmts); |
2b3d67a5 AC |
5101 | end if; |
5102 | ||
df3e68b1 | 5103 | -- Case where we build a return statement block |
2b3d67a5 | 5104 | |
df3e68b1 | 5105 | if Present (HSS) then |
2b3d67a5 AC |
5106 | Result := |
5107 | Make_Block_Statement (Loc, | |
2c1b72d7 | 5108 | Declarations => Return_Object_Declarations (N), |
df3e68b1 | 5109 | Handled_Statement_Sequence => HSS); |
2b3d67a5 AC |
5110 | |
5111 | -- We set the entity of the new block statement to be that of the | |
5112 | -- return statement. This is necessary so that various fields, such | |
5113 | -- as Finalization_Chain_Entity carry over from the return statement | |
5114 | -- to the block. Note that this block is unusual, in that its entity | |
5115 | -- is an E_Return_Statement rather than an E_Block. | |
5116 | ||
5117 | Set_Identifier | |
5118 | (Result, New_Occurrence_Of (Return_Statement_Entity (N), Loc)); | |
5119 | ||
54bf19e4 | 5120 | -- If the object decl was already rewritten as a renaming, then we |
47a6f660 | 5121 | -- don't want to do the object allocation and transformation of |
54bf19e4 | 5122 | -- the return object declaration to a renaming. This case occurs |
2b3d67a5 | 5123 | -- when the return object is initialized by a call to another |
54bf19e4 AC |
5124 | -- build-in-place function, and that function is responsible for |
5125 | -- the allocation of the return object. | |
2b3d67a5 | 5126 | |
e5f2c03c | 5127 | if Is_BIP_Func |
df3e68b1 | 5128 | and then Nkind (Ret_Obj_Decl) = N_Object_Renaming_Declaration |
2b3d67a5 | 5129 | then |
df3e68b1 HK |
5130 | pragma Assert |
5131 | (Nkind (Original_Node (Ret_Obj_Decl)) = N_Object_Declaration | |
4ac62786 AC |
5132 | and then |
5133 | ||
5134 | -- It is a regular BIP object declaration | |
5135 | ||
5136 | (Is_Build_In_Place_Function_Call | |
5137 | (Expression (Original_Node (Ret_Obj_Decl))) | |
5138 | ||
5139 | -- It is a BIP object declaration that displaces the pointer | |
5140 | -- to the object to reference a convered interface type. | |
5141 | ||
5142 | or else | |
5143 | Present (Unqual_BIP_Iface_Function_Call | |
5144 | (Expression (Original_Node (Ret_Obj_Decl)))))); | |
df3e68b1 HK |
5145 | |
5146 | -- Return the build-in-place result by reference | |
2b3d67a5 | 5147 | |
df3e68b1 | 5148 | Set_By_Ref (Return_Stmt); |
2b3d67a5 | 5149 | |
e5f2c03c | 5150 | elsif Is_BIP_Func then |
2b3d67a5 AC |
5151 | |
5152 | -- Locate the implicit access parameter associated with the | |
5153 | -- caller-supplied return object and convert the return | |
5154 | -- statement's return object declaration to a renaming of a | |
5155 | -- dereference of the access parameter. If the return object's | |
5156 | -- declaration includes an expression that has not already been | |
5157 | -- expanded as separate assignments, then add an assignment | |
5158 | -- statement to ensure the return object gets initialized. | |
5159 | ||
df3e68b1 HK |
5160 | -- declare |
5161 | -- Result : T [:= <expression>]; | |
5162 | -- begin | |
5163 | -- ... | |
2b3d67a5 AC |
5164 | |
5165 | -- is converted to | |
5166 | ||
df3e68b1 HK |
5167 | -- declare |
5168 | -- Result : T renames FuncRA.all; | |
5169 | -- [Result := <expression;] | |
5170 | -- begin | |
5171 | -- ... | |
2b3d67a5 AC |
5172 | |
5173 | declare | |
e5f2c03c AC |
5174 | Ret_Obj_Expr : constant Node_Id := Expression (Ret_Obj_Decl); |
5175 | Ret_Obj_Typ : constant Entity_Id := Etype (Ret_Obj_Id); | |
5176 | ||
2b3d67a5 | 5177 | Init_Assignment : Node_Id := Empty; |
e5f2c03c AC |
5178 | Obj_Acc_Formal : Entity_Id; |
5179 | Obj_Acc_Deref : Node_Id; | |
5180 | Obj_Alloc_Formal : Entity_Id; | |
2b3d67a5 AC |
5181 | |
5182 | begin | |
5183 | -- Build-in-place results must be returned by reference | |
5184 | ||
df3e68b1 | 5185 | Set_By_Ref (Return_Stmt); |
2b3d67a5 AC |
5186 | |
5187 | -- Retrieve the implicit access parameter passed by the caller | |
5188 | ||
e5f2c03c AC |
5189 | Obj_Acc_Formal := |
5190 | Build_In_Place_Formal (Func_Id, BIP_Object_Access); | |
2b3d67a5 AC |
5191 | |
5192 | -- If the return object's declaration includes an expression | |
5193 | -- and the declaration isn't marked as No_Initialization, then | |
5194 | -- we need to generate an assignment to the object and insert | |
5195 | -- it after the declaration before rewriting it as a renaming | |
5196 | -- (otherwise we'll lose the initialization). The case where | |
5197 | -- the result type is an interface (or class-wide interface) | |
5198 | -- is also excluded because the context of the function call | |
5199 | -- must be unconstrained, so the initialization will always | |
5200 | -- be done as part of an allocator evaluation (storage pool | |
5201 | -- or secondary stack), never to a constrained target object | |
5202 | -- passed in by the caller. Besides the assignment being | |
5203 | -- unneeded in this case, it avoids problems with trying to | |
5204 | -- generate a dispatching assignment when the return expression | |
5205 | -- is a nonlimited descendant of a limited interface (the | |
5206 | -- interface has no assignment operation). | |
5207 | ||
e5f2c03c | 5208 | if Present (Ret_Obj_Expr) |
df3e68b1 | 5209 | and then not No_Initialization (Ret_Obj_Decl) |
e5f2c03c | 5210 | and then not Is_Interface (Ret_Obj_Typ) |
2b3d67a5 AC |
5211 | then |
5212 | Init_Assignment := | |
5213 | Make_Assignment_Statement (Loc, | |
e5f2c03c | 5214 | Name => New_Occurrence_Of (Ret_Obj_Id, Loc), |
6a4f3b31 HK |
5215 | Expression => |
5216 | New_Copy_Tree | |
5217 | (Source => Ret_Obj_Expr, | |
5218 | Scopes_In_EWA_OK => True)); | |
df3e68b1 | 5219 | |
e5f2c03c | 5220 | Set_Etype (Name (Init_Assignment), Etype (Ret_Obj_Id)); |
2b3d67a5 AC |
5221 | Set_Assignment_OK (Name (Init_Assignment)); |
5222 | Set_No_Ctrl_Actions (Init_Assignment); | |
5223 | ||
5224 | Set_Parent (Name (Init_Assignment), Init_Assignment); | |
5225 | Set_Parent (Expression (Init_Assignment), Init_Assignment); | |
5226 | ||
df3e68b1 | 5227 | Set_Expression (Ret_Obj_Decl, Empty); |
2b3d67a5 | 5228 | |
e5f2c03c | 5229 | if Is_Class_Wide_Type (Etype (Ret_Obj_Id)) |
2b3d67a5 AC |
5230 | and then not Is_Class_Wide_Type |
5231 | (Etype (Expression (Init_Assignment))) | |
5232 | then | |
5233 | Rewrite (Expression (Init_Assignment), | |
5234 | Make_Type_Conversion (Loc, | |
5235 | Subtype_Mark => | |
e5f2c03c | 5236 | New_Occurrence_Of (Etype (Ret_Obj_Id), Loc), |
2c1b72d7 | 5237 | Expression => |
2b3d67a5 AC |
5238 | Relocate_Node (Expression (Init_Assignment)))); |
5239 | end if; | |
5240 | ||
5241 | -- In the case of functions where the calling context can | |
5242 | -- determine the form of allocation needed, initialization | |
5243 | -- is done with each part of the if statement that handles | |
5244 | -- the different forms of allocation (this is true for | |
7d1d3a54 | 5245 | -- unconstrained, tagged, and controlled result subtypes). |
2b3d67a5 | 5246 | |
7d1d3a54 | 5247 | if not Needs_BIP_Alloc_Form (Func_Id) then |
df3e68b1 | 5248 | Insert_After (Ret_Obj_Decl, Init_Assignment); |
2b3d67a5 AC |
5249 | end if; |
5250 | end if; | |
5251 | ||
5252 | -- When the function's subtype is unconstrained, a run-time | |
bde9a2c2 | 5253 | -- test may be needed to decide the form of allocation to use |
2b3d67a5 AC |
5254 | -- for the return object. The function has an implicit formal |
5255 | -- parameter indicating this. If the BIP_Alloc_Form formal has | |
5256 | -- the value one, then the caller has passed access to an | |
5257 | -- existing object for use as the return object. If the value | |
5258 | -- is two, then the return object must be allocated on the | |
5259 | -- secondary stack. Otherwise, the object must be allocated in | |
15529d0a PMR |
5260 | -- a storage pool. We generate an if statement to test the |
5261 | -- implicit allocation formal and initialize a local access | |
5262 | -- value appropriately, creating allocators in the secondary | |
7d1d3a54 | 5263 | -- stack and global heap cases. The special formal also exists |
15529d0a PMR |
5264 | -- and must be tested when the function has a tagged result, |
5265 | -- even when the result subtype is constrained, because in | |
5266 | -- general such functions can be called in dispatching contexts | |
5267 | -- and must be handled similarly to functions with a class-wide | |
5268 | -- result. | |
2b3d67a5 | 5269 | |
7d1d3a54 | 5270 | if Needs_BIP_Alloc_Form (Func_Id) then |
2b3d67a5 | 5271 | Obj_Alloc_Formal := |
e5f2c03c | 5272 | Build_In_Place_Formal (Func_Id, BIP_Alloc_Form); |
2b3d67a5 AC |
5273 | |
5274 | declare | |
8417f4b2 AC |
5275 | Pool_Id : constant Entity_Id := |
5276 | Make_Temporary (Loc, 'P'); | |
2b3d67a5 AC |
5277 | Alloc_Obj_Id : Entity_Id; |
5278 | Alloc_Obj_Decl : Node_Id; | |
5279 | Alloc_If_Stmt : Node_Id; | |
640ad9c2 | 5280 | Guard_Except : Node_Id; |
200b7162 | 5281 | Heap_Allocator : Node_Id; |
200b7162 BD |
5282 | Pool_Decl : Node_Id; |
5283 | Pool_Allocator : Node_Id; | |
8417f4b2 AC |
5284 | Ptr_Type_Decl : Node_Id; |
5285 | Ref_Type : Entity_Id; | |
5286 | SS_Allocator : Node_Id; | |
2b3d67a5 AC |
5287 | |
5288 | begin | |
2b3d67a5 AC |
5289 | -- Create an access type designating the function's |
5290 | -- result subtype. | |
5291 | ||
5292 | Ref_Type := Make_Temporary (Loc, 'A'); | |
5293 | ||
5294 | Ptr_Type_Decl := | |
5295 | Make_Full_Type_Declaration (Loc, | |
5296 | Defining_Identifier => Ref_Type, | |
2c1b72d7 | 5297 | Type_Definition => |
2b3d67a5 | 5298 | Make_Access_To_Object_Definition (Loc, |
2c1b72d7 | 5299 | All_Present => True, |
2b3d67a5 | 5300 | Subtype_Indication => |
e5f2c03c | 5301 | New_Occurrence_Of (Ret_Obj_Typ, Loc))); |
2b3d67a5 | 5302 | |
df3e68b1 | 5303 | Insert_Before (Ret_Obj_Decl, Ptr_Type_Decl); |
2b3d67a5 AC |
5304 | |
5305 | -- Create an access object that will be initialized to an | |
5306 | -- access value denoting the return object, either coming | |
5307 | -- from an implicit access value passed in by the caller | |
5308 | -- or from the result of an allocator. | |
5309 | ||
5310 | Alloc_Obj_Id := Make_Temporary (Loc, 'R'); | |
5311 | Set_Etype (Alloc_Obj_Id, Ref_Type); | |
5312 | ||
5313 | Alloc_Obj_Decl := | |
5314 | Make_Object_Declaration (Loc, | |
5315 | Defining_Identifier => Alloc_Obj_Id, | |
2c1b72d7 | 5316 | Object_Definition => |
e4494292 | 5317 | New_Occurrence_Of (Ref_Type, Loc)); |
2b3d67a5 | 5318 | |
df3e68b1 | 5319 | Insert_Before (Ret_Obj_Decl, Alloc_Obj_Decl); |
2b3d67a5 AC |
5320 | |
5321 | -- Create allocators for both the secondary stack and | |
5322 | -- global heap. If there's an initialization expression, | |
5323 | -- then create these as initialized allocators. | |
5324 | ||
e5f2c03c | 5325 | if Present (Ret_Obj_Expr) |
df3e68b1 | 5326 | and then not No_Initialization (Ret_Obj_Decl) |
2b3d67a5 AC |
5327 | then |
5328 | -- Always use the type of the expression for the | |
5329 | -- qualified expression, rather than the result type. | |
5330 | -- In general we cannot always use the result type | |
5331 | -- for the allocator, because the expression might be | |
5332 | -- of a specific type, such as in the case of an | |
5333 | -- aggregate or even a nonlimited object when the | |
5334 | -- result type is a limited class-wide interface type. | |
5335 | ||
5336 | Heap_Allocator := | |
5337 | Make_Allocator (Loc, | |
5338 | Expression => | |
5339 | Make_Qualified_Expression (Loc, | |
5340 | Subtype_Mark => | |
e4494292 | 5341 | New_Occurrence_Of |
e5f2c03c | 5342 | (Etype (Ret_Obj_Expr), Loc), |
6a4f3b31 HK |
5343 | Expression => |
5344 | New_Copy_Tree | |
5345 | (Source => Ret_Obj_Expr, | |
5346 | Scopes_In_EWA_OK => True))); | |
2b3d67a5 AC |
5347 | |
5348 | else | |
5349 | -- If the function returns a class-wide type we cannot | |
5350 | -- use the return type for the allocator. Instead we | |
5351 | -- use the type of the expression, which must be an | |
5352 | -- aggregate of a definite type. | |
5353 | ||
e5f2c03c | 5354 | if Is_Class_Wide_Type (Ret_Obj_Typ) then |
2b3d67a5 AC |
5355 | Heap_Allocator := |
5356 | Make_Allocator (Loc, | |
5357 | Expression => | |
e4494292 | 5358 | New_Occurrence_Of |
e5f2c03c | 5359 | (Etype (Ret_Obj_Expr), Loc)); |
2b3d67a5 AC |
5360 | else |
5361 | Heap_Allocator := | |
5362 | Make_Allocator (Loc, | |
5363 | Expression => | |
e5f2c03c | 5364 | New_Occurrence_Of (Ret_Obj_Typ, Loc)); |
2b3d67a5 AC |
5365 | end if; |
5366 | ||
5367 | -- If the object requires default initialization then | |
5368 | -- that will happen later following the elaboration of | |
5369 | -- the object renaming. If we don't turn it off here | |
5370 | -- then the object will be default initialized twice. | |
5371 | ||
5372 | Set_No_Initialization (Heap_Allocator); | |
5373 | end if; | |
5374 | ||
3a248f7c BD |
5375 | -- Set the flag indicating that the allocator came from |
5376 | -- a build-in-place return statement, so we can avoid | |
5377 | -- adjusting the allocated object. Note that this flag | |
5378 | -- will be inherited by the copies made below. | |
5379 | ||
5380 | Set_Alloc_For_BIP_Return (Heap_Allocator); | |
5381 | ||
200b7162 | 5382 | -- The Pool_Allocator is just like the Heap_Allocator, |
8417f4b2 AC |
5383 | -- except we set Storage_Pool and Procedure_To_Call so |
5384 | -- it will use the user-defined storage pool. | |
200b7162 | 5385 | |
6a4f3b31 HK |
5386 | Pool_Allocator := |
5387 | New_Copy_Tree | |
5388 | (Source => Heap_Allocator, | |
5389 | Scopes_In_EWA_OK => True); | |
5390 | ||
3a248f7c | 5391 | pragma Assert (Alloc_For_BIP_Return (Pool_Allocator)); |
8417f4b2 AC |
5392 | |
5393 | -- Do not generate the renaming of the build-in-place | |
535a8637 AC |
5394 | -- pool parameter on ZFP because the parameter is not |
5395 | -- created in the first place. | |
8417f4b2 | 5396 | |
535a8637 | 5397 | if RTE_Available (RE_Root_Storage_Pool_Ptr) then |
8417f4b2 AC |
5398 | Pool_Decl := |
5399 | Make_Object_Renaming_Declaration (Loc, | |
5400 | Defining_Identifier => Pool_Id, | |
5401 | Subtype_Mark => | |
e4494292 | 5402 | New_Occurrence_Of |
8417f4b2 AC |
5403 | (RTE (RE_Root_Storage_Pool), Loc), |
5404 | Name => | |
5405 | Make_Explicit_Dereference (Loc, | |
e4494292 | 5406 | New_Occurrence_Of |
8417f4b2 | 5407 | (Build_In_Place_Formal |
e5f2c03c | 5408 | (Func_Id, BIP_Storage_Pool), Loc))); |
8417f4b2 AC |
5409 | Set_Storage_Pool (Pool_Allocator, Pool_Id); |
5410 | Set_Procedure_To_Call | |
5411 | (Pool_Allocator, RTE (RE_Allocate_Any)); | |
5412 | else | |
5413 | Pool_Decl := Make_Null_Statement (Loc); | |
5414 | end if; | |
200b7162 | 5415 | |
2b3d67a5 AC |
5416 | -- If the No_Allocators restriction is active, then only |
5417 | -- an allocator for secondary stack allocation is needed. | |
5418 | -- It's OK for such allocators to have Comes_From_Source | |
5419 | -- set to False, because gigi knows not to flag them as | |
5420 | -- being a violation of No_Implicit_Heap_Allocations. | |
5421 | ||
5422 | if Restriction_Active (No_Allocators) then | |
5423 | SS_Allocator := Heap_Allocator; | |
5424 | Heap_Allocator := Make_Null (Loc); | |
200b7162 | 5425 | Pool_Allocator := Make_Null (Loc); |
2b3d67a5 | 5426 | |
200b7162 BD |
5427 | -- Otherwise the heap and pool allocators may be needed, |
5428 | -- so we make another allocator for secondary stack | |
5429 | -- allocation. | |
2b3d67a5 AC |
5430 | |
5431 | else | |
6a4f3b31 HK |
5432 | SS_Allocator := |
5433 | New_Copy_Tree | |
5434 | (Source => Heap_Allocator, | |
5435 | Scopes_In_EWA_OK => True); | |
5436 | ||
3a248f7c | 5437 | pragma Assert (Alloc_For_BIP_Return (SS_Allocator)); |
2b3d67a5 | 5438 | |
3e7302c3 | 5439 | -- The heap and pool allocators are marked as |
200b7162 BD |
5440 | -- Comes_From_Source since they correspond to an |
5441 | -- explicit user-written allocator (that is, it will | |
5442 | -- only be executed on behalf of callers that call the | |
3e7302c3 AC |
5443 | -- function as initialization for such an allocator). |
5444 | -- Prevents errors when No_Implicit_Heap_Allocations | |
5445 | -- is in force. | |
2b3d67a5 AC |
5446 | |
5447 | Set_Comes_From_Source (Heap_Allocator, True); | |
200b7162 | 5448 | Set_Comes_From_Source (Pool_Allocator, True); |
2b3d67a5 AC |
5449 | end if; |
5450 | ||
abbfd698 | 5451 | -- The allocator is returned on the secondary stack |
2b3d67a5 | 5452 | |
abbfd698 | 5453 | Check_Restriction (No_Secondary_Stack, N); |
535a8637 AC |
5454 | Set_Storage_Pool (SS_Allocator, RTE (RE_SS_Pool)); |
5455 | Set_Procedure_To_Call | |
5456 | (SS_Allocator, RTE (RE_SS_Allocate)); | |
5457 | ||
5458 | -- The allocator is returned on the secondary stack, | |
5459 | -- so indicate that the function return, as well as | |
c79f6efd | 5460 | -- all blocks that encloses the allocator, must not |
535a8637 AC |
5461 | -- release it. The flags must be set now because |
5462 | -- the decision to use the secondary stack is done | |
5463 | -- very late in the course of expanding the return | |
5464 | -- statement, past the point where these flags are | |
5465 | -- normally set. | |
5466 | ||
e5f2c03c | 5467 | Set_Uses_Sec_Stack (Func_Id); |
535a8637 | 5468 | Set_Uses_Sec_Stack (Return_Statement_Entity (N)); |
c79f6efd BD |
5469 | Set_Sec_Stack_Needed_For_Return |
5470 | (Return_Statement_Entity (N)); | |
5471 | Set_Enclosing_Sec_Stack_Return (N); | |
2b3d67a5 | 5472 | |
640ad9c2 HK |
5473 | -- Guard against poor expansion on the caller side by |
5474 | -- using a raise statement to catch out-of-range values | |
5475 | -- of formal parameter BIP_Alloc_Form. | |
5476 | ||
5477 | if Exceptions_OK then | |
5478 | Guard_Except := | |
5479 | Make_Raise_Program_Error (Loc, | |
5480 | Reason => PE_Build_In_Place_Mismatch); | |
5481 | else | |
5482 | Guard_Except := Make_Null_Statement (Loc); | |
5483 | end if; | |
5484 | ||
2b3d67a5 AC |
5485 | -- Create an if statement to test the BIP_Alloc_Form |
5486 | -- formal and initialize the access object to either the | |
200b7162 BD |
5487 | -- BIP_Object_Access formal (BIP_Alloc_Form = |
5488 | -- Caller_Allocation), the result of allocating the | |
5489 | -- object in the secondary stack (BIP_Alloc_Form = | |
5490 | -- Secondary_Stack), or else an allocator to create the | |
5491 | -- return object in the heap or user-defined pool | |
5492 | -- (BIP_Alloc_Form = Global_Heap or User_Storage_Pool). | |
2b3d67a5 AC |
5493 | |
5494 | -- ??? An unchecked type conversion must be made in the | |
5495 | -- case of assigning the access object formal to the | |
5496 | -- local access object, because a normal conversion would | |
5497 | -- be illegal in some cases (such as converting access- | |
5498 | -- to-unconstrained to access-to-constrained), but the | |
5499 | -- the unchecked conversion will presumably fail to work | |
5500 | -- right in just such cases. It's not clear at all how to | |
5501 | -- handle this. ??? | |
5502 | ||
5503 | Alloc_If_Stmt := | |
5504 | Make_If_Statement (Loc, | |
df3e68b1 | 5505 | Condition => |
2b3d67a5 | 5506 | Make_Op_Eq (Loc, |
2c1b72d7 | 5507 | Left_Opnd => |
e4494292 | 5508 | New_Occurrence_Of (Obj_Alloc_Formal, Loc), |
2b3d67a5 AC |
5509 | Right_Opnd => |
5510 | Make_Integer_Literal (Loc, | |
5511 | UI_From_Int (BIP_Allocation_Form'Pos | |
5512 | (Caller_Allocation)))), | |
df3e68b1 HK |
5513 | |
5514 | Then_Statements => New_List ( | |
5515 | Make_Assignment_Statement (Loc, | |
2c1b72d7 | 5516 | Name => |
e4494292 | 5517 | New_Occurrence_Of (Alloc_Obj_Id, Loc), |
df3e68b1 HK |
5518 | Expression => |
5519 | Make_Unchecked_Type_Conversion (Loc, | |
5520 | Subtype_Mark => | |
e4494292 | 5521 | New_Occurrence_Of (Ref_Type, Loc), |
2c1b72d7 | 5522 | Expression => |
e5f2c03c | 5523 | New_Occurrence_Of (Obj_Acc_Formal, Loc)))), |
df3e68b1 HK |
5524 | |
5525 | Elsif_Parts => New_List ( | |
5526 | Make_Elsif_Part (Loc, | |
5527 | Condition => | |
5528 | Make_Op_Eq (Loc, | |
2c1b72d7 | 5529 | Left_Opnd => |
e4494292 | 5530 | New_Occurrence_Of (Obj_Alloc_Formal, Loc), |
df3e68b1 HK |
5531 | Right_Opnd => |
5532 | Make_Integer_Literal (Loc, | |
5533 | UI_From_Int (BIP_Allocation_Form'Pos | |
2b3d67a5 | 5534 | (Secondary_Stack)))), |
df3e68b1 HK |
5535 | |
5536 | Then_Statements => New_List ( | |
5537 | Make_Assignment_Statement (Loc, | |
2c1b72d7 | 5538 | Name => |
e4494292 | 5539 | New_Occurrence_Of (Alloc_Obj_Id, Loc), |
200b7162 BD |
5540 | Expression => SS_Allocator))), |
5541 | ||
5542 | Make_Elsif_Part (Loc, | |
5543 | Condition => | |
5544 | Make_Op_Eq (Loc, | |
5545 | Left_Opnd => | |
e4494292 | 5546 | New_Occurrence_Of (Obj_Alloc_Formal, Loc), |
200b7162 BD |
5547 | Right_Opnd => |
5548 | Make_Integer_Literal (Loc, | |
5549 | UI_From_Int (BIP_Allocation_Form'Pos | |
5550 | (Global_Heap)))), | |
5551 | ||
5552 | Then_Statements => New_List ( | |
7d1d3a54 | 5553 | Build_Heap_Or_Pool_Allocator |
200b7162 BD |
5554 | (Temp_Id => Alloc_Obj_Id, |
5555 | Temp_Typ => Ref_Type, | |
e5f2c03c AC |
5556 | Func_Id => Func_Id, |
5557 | Ret_Typ => Ret_Obj_Typ, | |
5168a9b3 PMR |
5558 | Alloc_Expr => Heap_Allocator))), |
5559 | ||
5560 | -- ???If all is well, we can put the following | |
5561 | -- 'elsif' in the 'else', but this is a useful | |
5562 | -- self-check in case caller and callee don't agree | |
5563 | -- on whether BIPAlloc and so on should be passed. | |
5564 | ||
5565 | Make_Elsif_Part (Loc, | |
5566 | Condition => | |
5567 | Make_Op_Eq (Loc, | |
5568 | Left_Opnd => | |
5569 | New_Occurrence_Of (Obj_Alloc_Formal, Loc), | |
5570 | Right_Opnd => | |
5571 | Make_Integer_Literal (Loc, | |
5572 | UI_From_Int (BIP_Allocation_Form'Pos | |
5573 | (User_Storage_Pool)))), | |
5574 | ||
5575 | Then_Statements => New_List ( | |
5576 | Pool_Decl, | |
7d1d3a54 | 5577 | Build_Heap_Or_Pool_Allocator |
5168a9b3 PMR |
5578 | (Temp_Id => Alloc_Obj_Id, |
5579 | Temp_Typ => Ref_Type, | |
5580 | Func_Id => Func_Id, | |
5581 | Ret_Typ => Ret_Obj_Typ, | |
5582 | Alloc_Expr => Pool_Allocator)))), | |
5583 | ||
5584 | -- Raise Program_Error if it's none of the above; | |
fc47ef60 | 5585 | -- this is a compiler bug. |
df3e68b1 | 5586 | |
640ad9c2 | 5587 | Else_Statements => New_List (Guard_Except)); |
2b3d67a5 AC |
5588 | |
5589 | -- If a separate initialization assignment was created | |
5590 | -- earlier, append that following the assignment of the | |
5591 | -- implicit access formal to the access object, to ensure | |
54bf19e4 AC |
5592 | -- that the return object is initialized in that case. In |
5593 | -- this situation, the target of the assignment must be | |
5594 | -- rewritten to denote a dereference of the access to the | |
5595 | -- return object passed in by the caller. | |
2b3d67a5 AC |
5596 | |
5597 | if Present (Init_Assignment) then | |
5598 | Rewrite (Name (Init_Assignment), | |
5599 | Make_Explicit_Dereference (Loc, | |
e4494292 | 5600 | Prefix => New_Occurrence_Of (Alloc_Obj_Id, Loc))); |
56af8688 PMR |
5601 | pragma Assert |
5602 | (Assignment_OK | |
5603 | (Original_Node (Name (Init_Assignment)))); | |
5604 | Set_Assignment_OK (Name (Init_Assignment)); | |
df3e68b1 | 5605 | |
e5f2c03c | 5606 | Set_Etype (Name (Init_Assignment), Etype (Ret_Obj_Id)); |
2b3d67a5 AC |
5607 | |
5608 | Append_To | |
2c1b72d7 | 5609 | (Then_Statements (Alloc_If_Stmt), Init_Assignment); |
2b3d67a5 AC |
5610 | end if; |
5611 | ||
df3e68b1 | 5612 | Insert_Before (Ret_Obj_Decl, Alloc_If_Stmt); |
2b3d67a5 AC |
5613 | |
5614 | -- Remember the local access object for use in the | |
5615 | -- dereference of the renaming created below. | |
5616 | ||
bde9a2c2 EB |
5617 | Obj_Acc_Formal := Alloc_Obj_Id; |
5618 | end; | |
5619 | ||
5620 | -- When the function's subtype is unconstrained and a run-time | |
5621 | -- test is not needed, we nevertheless need to build the return | |
5622 | -- using the function's result subtype. | |
5623 | ||
5624 | elsif not Is_Constrained (Underlying_Type (Etype (Func_Id))) | |
5625 | then | |
5626 | declare | |
5627 | Alloc_Obj_Id : Entity_Id; | |
5628 | Alloc_Obj_Decl : Node_Id; | |
5629 | Ptr_Type_Decl : Node_Id; | |
5630 | Ref_Type : Entity_Id; | |
5631 | ||
5632 | begin | |
5633 | -- Create an access type designating the function's | |
5634 | -- result subtype. | |
5635 | ||
5636 | Ref_Type := Make_Temporary (Loc, 'A'); | |
5637 | ||
5638 | Ptr_Type_Decl := | |
5639 | Make_Full_Type_Declaration (Loc, | |
5640 | Defining_Identifier => Ref_Type, | |
5641 | Type_Definition => | |
5642 | Make_Access_To_Object_Definition (Loc, | |
5643 | All_Present => True, | |
5644 | Subtype_Indication => | |
5645 | New_Occurrence_Of (Ret_Obj_Typ, Loc))); | |
5646 | ||
5647 | Insert_Before (Ret_Obj_Decl, Ptr_Type_Decl); | |
5648 | ||
5649 | -- Create an access object initialized to the conversion | |
5650 | -- of the implicit access value passed in by the caller. | |
5651 | ||
5652 | Alloc_Obj_Id := Make_Temporary (Loc, 'R'); | |
5653 | Set_Etype (Alloc_Obj_Id, Ref_Type); | |
5654 | ||
5655 | -- See the ??? comment a few lines above about the use of | |
5656 | -- an unchecked conversion here. | |
5657 | ||
5658 | Alloc_Obj_Decl := | |
5659 | Make_Object_Declaration (Loc, | |
5660 | Defining_Identifier => Alloc_Obj_Id, | |
5661 | Object_Definition => | |
5662 | New_Occurrence_Of (Ref_Type, Loc), | |
5663 | Expression => | |
5664 | Make_Unchecked_Type_Conversion (Loc, | |
5665 | Subtype_Mark => | |
5666 | New_Occurrence_Of (Ref_Type, Loc), | |
5667 | Expression => | |
5668 | New_Occurrence_Of (Obj_Acc_Formal, Loc))); | |
5669 | ||
5670 | Insert_Before (Ret_Obj_Decl, Alloc_Obj_Decl); | |
5671 | ||
5672 | -- Remember the local access object for use in the | |
5673 | -- dereference of the renaming created below. | |
5674 | ||
e5f2c03c | 5675 | Obj_Acc_Formal := Alloc_Obj_Id; |
2b3d67a5 AC |
5676 | end; |
5677 | end if; | |
5678 | ||
5679 | -- Replace the return object declaration with a renaming of a | |
5680 | -- dereference of the access value designating the return | |
5681 | -- object. | |
5682 | ||
5683 | Obj_Acc_Deref := | |
5684 | Make_Explicit_Dereference (Loc, | |
e5f2c03c | 5685 | Prefix => New_Occurrence_Of (Obj_Acc_Formal, Loc)); |
2b3d67a5 | 5686 | |
df3e68b1 | 5687 | Rewrite (Ret_Obj_Decl, |
2b3d67a5 | 5688 | Make_Object_Renaming_Declaration (Loc, |
e5f2c03c | 5689 | Defining_Identifier => Ret_Obj_Id, |
2c1b72d7 | 5690 | Access_Definition => Empty, |
e5f2c03c | 5691 | Subtype_Mark => New_Occurrence_Of (Ret_Obj_Typ, Loc), |
2c1b72d7 | 5692 | Name => Obj_Acc_Deref)); |
2b3d67a5 | 5693 | |
e5f2c03c | 5694 | Set_Renamed_Object (Ret_Obj_Id, Obj_Acc_Deref); |
2b3d67a5 AC |
5695 | end; |
5696 | end if; | |
5697 | ||
5698 | -- Case where we do not build a block | |
5699 | ||
5700 | else | |
df3e68b1 HK |
5701 | -- We're about to drop Return_Object_Declarations on the floor, so |
5702 | -- we need to insert it, in case it got expanded into useful code. | |
2b3d67a5 AC |
5703 | -- Remove side effects from expression, which may be duplicated in |
5704 | -- subsequent checks (see Expand_Simple_Function_Return). | |
5705 | ||
df3e68b1 | 5706 | Insert_List_Before (N, Return_Object_Declarations (N)); |
2b3d67a5 AC |
5707 | Remove_Side_Effects (Exp); |
5708 | ||
5709 | -- Build simple_return_statement that returns the expression directly | |
5710 | ||
df3e68b1 HK |
5711 | Return_Stmt := Make_Simple_Return_Statement (Loc, Expression => Exp); |
5712 | Result := Return_Stmt; | |
2b3d67a5 AC |
5713 | end if; |
5714 | ||
5715 | -- Set the flag to prevent infinite recursion | |
5716 | ||
df3e68b1 | 5717 | Set_Comes_From_Extended_Return_Statement (Return_Stmt); |
2b3d67a5 AC |
5718 | |
5719 | Rewrite (N, Result); | |
bde9a2c2 | 5720 | Analyze (N, Suppress => All_Checks); |
2b3d67a5 AC |
5721 | end Expand_N_Extended_Return_Statement; |
5722 | ||
70482933 RK |
5723 | ---------------------------- |
5724 | -- Expand_N_Function_Call -- | |
5725 | ---------------------------- | |
5726 | ||
5727 | procedure Expand_N_Function_Call (N : Node_Id) is | |
70482933 | 5728 | begin |
ac4d6407 | 5729 | Expand_Call (N); |
70482933 RK |
5730 | end Expand_N_Function_Call; |
5731 | ||
5732 | --------------------------------------- | |
5733 | -- Expand_N_Procedure_Call_Statement -- | |
5734 | --------------------------------------- | |
5735 | ||
5736 | procedure Expand_N_Procedure_Call_Statement (N : Node_Id) is | |
5737 | begin | |
1af4455a | 5738 | Expand_Call (N); |
70482933 RK |
5739 | end Expand_N_Procedure_Call_Statement; |
5740 | ||
2b3d67a5 AC |
5741 | -------------------------------------- |
5742 | -- Expand_N_Simple_Return_Statement -- | |
5743 | -------------------------------------- | |
5744 | ||
5745 | procedure Expand_N_Simple_Return_Statement (N : Node_Id) is | |
5746 | begin | |
5747 | -- Defend against previous errors (i.e. the return statement calls a | |
5748 | -- function that is not available in configurable runtime). | |
5749 | ||
5750 | if Present (Expression (N)) | |
5751 | and then Nkind (Expression (N)) = N_Empty | |
5752 | then | |
ee2ba856 | 5753 | Check_Error_Detected; |
2b3d67a5 AC |
5754 | return; |
5755 | end if; | |
5756 | ||
5757 | -- Distinguish the function and non-function cases: | |
5758 | ||
5759 | case Ekind (Return_Applies_To (Return_Statement_Entity (N))) is | |
d8f43ee6 HK |
5760 | when E_Function |
5761 | | E_Generic_Function | |
5762 | => | |
2b3d67a5 AC |
5763 | Expand_Simple_Function_Return (N); |
5764 | ||
d8f43ee6 HK |
5765 | when E_Entry |
5766 | | E_Entry_Family | |
5767 | | E_Generic_Procedure | |
5768 | | E_Procedure | |
5769 | | E_Return_Statement | |
5770 | => | |
2b3d67a5 AC |
5771 | Expand_Non_Function_Return (N); |
5772 | ||
5773 | when others => | |
5774 | raise Program_Error; | |
5775 | end case; | |
5776 | ||
5777 | exception | |
5778 | when RE_Not_Available => | |
5779 | return; | |
5780 | end Expand_N_Simple_Return_Statement; | |
5781 | ||
70482933 RK |
5782 | ------------------------------ |
5783 | -- Expand_N_Subprogram_Body -- | |
5784 | ------------------------------ | |
5785 | ||
4a3b249c RD |
5786 | -- Add poll call if ATC polling is enabled, unless the body will be inlined |
5787 | -- by the back-end. | |
70482933 | 5788 | |
7888a6ae | 5789 | -- Add dummy push/pop label nodes at start and end to clear any local |
4a3b249c | 5790 | -- exception indications if local-exception-to-goto optimization is active. |
7888a6ae | 5791 | |
f44fe430 RD |
5792 | -- Add return statement if last statement in body is not a return statement |
5793 | -- (this makes things easier on Gigi which does not want to have to handle | |
5794 | -- a missing return). | |
70482933 RK |
5795 | |
5796 | -- Add call to Activate_Tasks if body is a task activator | |
5797 | ||
5798 | -- Deal with possible detection of infinite recursion | |
5799 | ||
5800 | -- Eliminate body completely if convention stubbed | |
5801 | ||
5802 | -- Encode entity names within body, since we will not need to reference | |
5803 | -- these entities any longer in the front end. | |
5804 | ||
5805 | -- Initialize scalar out parameters if Initialize/Normalize_Scalars | |
5806 | ||
c9a4817d | 5807 | -- Reset Pure indication if any parameter has root type System.Address |
199c6a10 AC |
5808 | -- or has any parameters of limited types, where limited means that the |
5809 | -- run-time view is limited (i.e. the full type is limited). | |
c9a4817d | 5810 | |
12e0c41c AC |
5811 | -- Wrap thread body |
5812 | ||
70482933 | 5813 | procedure Expand_N_Subprogram_Body (N : Node_Id) is |
1af4455a HK |
5814 | Body_Id : constant Entity_Id := Defining_Entity (N); |
5815 | HSS : constant Node_Id := Handled_Statement_Sequence (N); | |
5816 | Loc : constant Source_Ptr := Sloc (N); | |
70482933 | 5817 | |
2700b9c1 AC |
5818 | procedure Add_Return (Spec_Id : Entity_Id; Stmts : List_Id); |
5819 | -- Append a return statement to the statement sequence Stmts if the last | |
5820 | -- statement is not already a return or a goto statement. Note that the | |
5821 | -- latter test is not critical, it does not matter if we add a few extra | |
5822 | -- returns, since they get eliminated anyway later on. Spec_Id denotes | |
5823 | -- the corresponding spec of the subprogram body. | |
5824 | ||
70482933 RK |
5825 | ---------------- |
5826 | -- Add_Return -- | |
5827 | ---------------- | |
5828 | ||
2700b9c1 | 5829 | procedure Add_Return (Spec_Id : Entity_Id; Stmts : List_Id) is |
c9d70ab1 AC |
5830 | Last_Stmt : Node_Id; |
5831 | Loc : Source_Ptr; | |
5832 | Stmt : Node_Id; | |
12e0c41c AC |
5833 | |
5834 | begin | |
7888a6ae GD |
5835 | -- Get last statement, ignoring any Pop_xxx_Label nodes, which are |
5836 | -- not relevant in this context since they are not executable. | |
12e0c41c | 5837 | |
2700b9c1 | 5838 | Last_Stmt := Last (Stmts); |
c9d70ab1 AC |
5839 | while Nkind (Last_Stmt) in N_Pop_xxx_Label loop |
5840 | Prev (Last_Stmt); | |
7888a6ae | 5841 | end loop; |
12e0c41c | 5842 | |
7888a6ae | 5843 | -- Now insert return unless last statement is a transfer |
12e0c41c | 5844 | |
c9d70ab1 | 5845 | if not Is_Transfer (Last_Stmt) then |
12e0c41c | 5846 | |
7888a6ae GD |
5847 | -- The source location for the return is the end label of the |
5848 | -- procedure if present. Otherwise use the sloc of the last | |
5849 | -- statement in the list. If the list comes from a generated | |
5850 | -- exception handler and we are not debugging generated code, | |
5851 | -- all the statements within the handler are made invisible | |
5852 | -- to the debugger. | |
12e0c41c | 5853 | |
2700b9c1 AC |
5854 | if Nkind (Parent (Stmts)) = N_Exception_Handler |
5855 | and then not Comes_From_Source (Parent (Stmts)) | |
7888a6ae | 5856 | then |
c9d70ab1 | 5857 | Loc := Sloc (Last_Stmt); |
241ebe89 HK |
5858 | elsif Present (End_Label (HSS)) then |
5859 | Loc := Sloc (End_Label (HSS)); | |
7888a6ae | 5860 | else |
c9d70ab1 | 5861 | Loc := Sloc (Last_Stmt); |
7888a6ae | 5862 | end if; |
12e0c41c | 5863 | |
c9d70ab1 AC |
5864 | -- Append return statement, and set analyzed manually. We can't |
5865 | -- call Analyze on this return since the scope is wrong. | |
5334d18f | 5866 | |
c9d70ab1 AC |
5867 | -- Note: it almost works to push the scope and then do the Analyze |
5868 | -- call, but something goes wrong in some weird cases and it is | |
5869 | -- not worth worrying about ??? | |
5334d18f | 5870 | |
c9d70ab1 | 5871 | Stmt := Make_Simple_Return_Statement (Loc); |
5334d18f | 5872 | |
c9d70ab1 AC |
5873 | -- The return statement is handled properly, and the call to the |
5874 | -- postcondition, inserted below, does not require information | |
5875 | -- from the body either. However, that call is analyzed in the | |
5876 | -- enclosing scope, and an elaboration check might improperly be | |
5877 | -- added to it. A guard in Sem_Elab is needed to prevent that | |
5878 | -- spurious check, see Check_Elab_Call. | |
6a74a7b0 | 5879 | |
2700b9c1 | 5880 | Append_To (Stmts, Stmt); |
c9d70ab1 | 5881 | Set_Analyzed (Stmt); |
5334d18f | 5882 | |
c9d70ab1 AC |
5883 | -- Call the _Postconditions procedure if the related subprogram |
5884 | -- has contract assertions that need to be verified on exit. | |
5334d18f | 5885 | |
c9d70ab1 AC |
5886 | if Ekind (Spec_Id) = E_Procedure |
5887 | and then Present (Postconditions_Proc (Spec_Id)) | |
5888 | then | |
5889 | Insert_Action (Stmt, | |
5890 | Make_Procedure_Call_Statement (Loc, | |
5891 | Name => | |
5892 | New_Occurrence_Of (Postconditions_Proc (Spec_Id), Loc))); | |
5893 | end if; | |
12e0c41c | 5894 | end if; |
7888a6ae | 5895 | end Add_Return; |
12e0c41c | 5896 | |
4039e173 | 5897 | -- Local variables |
241ebe89 | 5898 | |
2700b9c1 AC |
5899 | Except_H : Node_Id; |
5900 | L : List_Id; | |
5901 | Spec_Id : Entity_Id; | |
5902 | ||
70482933 RK |
5903 | -- Start of processing for Expand_N_Subprogram_Body |
5904 | ||
5905 | begin | |
1af4455a HK |
5906 | if Present (Corresponding_Spec (N)) then |
5907 | Spec_Id := Corresponding_Spec (N); | |
5908 | else | |
5909 | Spec_Id := Body_Id; | |
5910 | end if; | |
241ebe89 | 5911 | |
90e7b558 AC |
5912 | -- If this is a Pure function which has any parameters whose root type |
5913 | -- is System.Address, reset the Pure indication. | |
5914 | -- This check is also performed when the subprogram is frozen, but we | |
5915 | -- repeat it on the body so that the indication is consistent, and so | |
5916 | -- it applies as well to bodies without separate specifications. | |
5917 | ||
5918 | if Is_Pure (Spec_Id) | |
5919 | and then Is_Subprogram (Spec_Id) | |
5920 | and then not Has_Pragma_Pure_Function (Spec_Id) | |
5921 | then | |
5922 | Check_Function_With_Address_Parameter (Spec_Id); | |
5923 | ||
5924 | if Spec_Id /= Body_Id then | |
5925 | Set_Is_Pure (Body_Id, Is_Pure (Spec_Id)); | |
5926 | end if; | |
5927 | end if; | |
5928 | ||
4a3b249c RD |
5929 | -- Set L to either the list of declarations if present, or to the list |
5930 | -- of statements if no declarations are present. This is used to insert | |
5931 | -- new stuff at the start. | |
70482933 RK |
5932 | |
5933 | if Is_Non_Empty_List (Declarations (N)) then | |
5934 | L := Declarations (N); | |
5935 | else | |
241ebe89 | 5936 | L := Statements (HSS); |
7888a6ae GD |
5937 | end if; |
5938 | ||
5939 | -- If local-exception-to-goto optimization active, insert dummy push | |
1adaea16 AC |
5940 | -- statements at start, and dummy pop statements at end, but inhibit |
5941 | -- this if we have No_Exception_Handlers, since they are useless and | |
3747db82 ES |
5942 | -- interfere with analysis, e.g. by CodePeer. We also don't need these |
5943 | -- if we're unnesting subprograms because the only purpose of these | |
5944 | -- nodes is to ensure we don't set a label in one subprogram and branch | |
5945 | -- to it in another. | |
7888a6ae GD |
5946 | |
5947 | if (Debug_Flag_Dot_G | |
5948 | or else Restriction_Active (No_Exception_Propagation)) | |
1adaea16 AC |
5949 | and then not Restriction_Active (No_Exception_Handlers) |
5950 | and then not CodePeer_Mode | |
3747db82 | 5951 | and then not Unnest_Subprogram_Mode |
7888a6ae GD |
5952 | and then Is_Non_Empty_List (L) |
5953 | then | |
5954 | declare | |
5955 | FS : constant Node_Id := First (L); | |
5956 | FL : constant Source_Ptr := Sloc (FS); | |
5957 | LS : Node_Id; | |
5958 | LL : Source_Ptr; | |
5959 | ||
5960 | begin | |
5961 | -- LS points to either last statement, if statements are present | |
5962 | -- or to the last declaration if there are no statements present. | |
5963 | -- It is the node after which the pop's are generated. | |
5964 | ||
241ebe89 HK |
5965 | if Is_Non_Empty_List (Statements (HSS)) then |
5966 | LS := Last (Statements (HSS)); | |
7888a6ae GD |
5967 | else |
5968 | LS := Last (L); | |
5969 | end if; | |
5970 | ||
5971 | LL := Sloc (LS); | |
5972 | ||
5973 | Insert_List_Before_And_Analyze (FS, New_List ( | |
5974 | Make_Push_Constraint_Error_Label (FL), | |
5975 | Make_Push_Program_Error_Label (FL), | |
5976 | Make_Push_Storage_Error_Label (FL))); | |
5977 | ||
5978 | Insert_List_After_And_Analyze (LS, New_List ( | |
5979 | Make_Pop_Constraint_Error_Label (LL), | |
5980 | Make_Pop_Program_Error_Label (LL), | |
5981 | Make_Pop_Storage_Error_Label (LL))); | |
5982 | end; | |
70482933 RK |
5983 | end if; |
5984 | ||
7888a6ae GD |
5985 | -- Need poll on entry to subprogram if polling enabled. We only do this |
5986 | -- for non-empty subprograms, since it does not seem necessary to poll | |
4a3b249c | 5987 | -- for a dummy null subprogram. |
c885d7a1 AC |
5988 | |
5989 | if Is_Non_Empty_List (L) then | |
4a3b249c RD |
5990 | |
5991 | -- Do not add a polling call if the subprogram is to be inlined by | |
5992 | -- the back-end, to avoid repeated calls with multiple inlinings. | |
5993 | ||
c885d7a1 AC |
5994 | if Is_Inlined (Spec_Id) |
5995 | and then Front_End_Inlining | |
5996 | and then Optimization_Level > 1 | |
5997 | then | |
5998 | null; | |
5999 | else | |
6000 | Generate_Poll_Call (First (L)); | |
6001 | end if; | |
6002 | end if; | |
6003 | ||
70482933 RK |
6004 | -- Initialize any scalar OUT args if Initialize/Normalize_Scalars |
6005 | ||
6006 | if Init_Or_Norm_Scalars and then Is_Subprogram (Spec_Id) then | |
6007 | declare | |
2f1b20a9 | 6008 | F : Entity_Id; |
05c064c1 | 6009 | A : Node_Id; |
70482933 RK |
6010 | |
6011 | begin | |
70482933 RK |
6012 | -- Loop through formals |
6013 | ||
2f1b20a9 | 6014 | F := First_Formal (Spec_Id); |
70482933 RK |
6015 | while Present (F) loop |
6016 | if Is_Scalar_Type (Etype (F)) | |
6017 | and then Ekind (F) = E_Out_Parameter | |
6018 | then | |
70f91180 RD |
6019 | Check_Restriction (No_Default_Initialization, F); |
6020 | ||
02822a92 RD |
6021 | -- Insert the initialization. We turn off validity checks |
6022 | -- for this assignment, since we do not want any check on | |
6023 | -- the initial value itself (which may well be invalid). | |
05c064c1 | 6024 | -- Predicate checks are disabled as well (RM 6.4.1 (13/3)) |
02822a92 | 6025 | |
c9d70ab1 AC |
6026 | A := |
6027 | Make_Assignment_Statement (Loc, | |
02822a92 | 6028 | Name => New_Occurrence_Of (F, Loc), |
05c064c1 AC |
6029 | Expression => Get_Simple_Init_Val (Etype (F), N)); |
6030 | Set_Suppress_Assignment_Checks (A); | |
6031 | ||
6032 | Insert_Before_And_Analyze (First (L), | |
6033 | A, Suppress => Validity_Check); | |
70482933 RK |
6034 | end if; |
6035 | ||
6036 | Next_Formal (F); | |
6037 | end loop; | |
70482933 RK |
6038 | end; |
6039 | end if; | |
6040 | ||
6041 | -- Clear out statement list for stubbed procedure | |
6042 | ||
6043 | if Present (Corresponding_Spec (N)) then | |
6044 | Set_Elaboration_Flag (N, Spec_Id); | |
6045 | ||
6046 | if Convention (Spec_Id) = Convention_Stubbed | |
6047 | or else Is_Eliminated (Spec_Id) | |
6048 | then | |
6049 | Set_Declarations (N, Empty_List); | |
6050 | Set_Handled_Statement_Sequence (N, | |
6051 | Make_Handled_Sequence_Of_Statements (Loc, | |
2c1b72d7 | 6052 | Statements => New_List (Make_Null_Statement (Loc)))); |
241ebe89 | 6053 | |
70482933 RK |
6054 | return; |
6055 | end if; | |
6056 | end if; | |
6057 | ||
70f91180 RD |
6058 | -- Create a set of discriminals for the next protected subprogram body |
6059 | ||
6060 | if Is_List_Member (N) | |
6061 | and then Present (Parent (List_Containing (N))) | |
6062 | and then Nkind (Parent (List_Containing (N))) = N_Protected_Body | |
6063 | and then Present (Next_Protected_Operation (N)) | |
6064 | then | |
6065 | Set_Discriminals (Parent (Base_Type (Scope (Spec_Id)))); | |
6066 | end if; | |
6067 | ||
4a3b249c RD |
6068 | -- Returns_By_Ref flag is normally set when the subprogram is frozen but |
6069 | -- subprograms with no specs are not frozen. | |
70482933 RK |
6070 | |
6071 | declare | |
6072 | Typ : constant Entity_Id := Etype (Spec_Id); | |
6073 | Utyp : constant Entity_Id := Underlying_Type (Typ); | |
6074 | ||
6075 | begin | |
d6e1090a | 6076 | if Is_Limited_View (Typ) then |
70482933 RK |
6077 | Set_Returns_By_Ref (Spec_Id); |
6078 | ||
048e5cef | 6079 | elsif Present (Utyp) and then CW_Or_Has_Controlled_Part (Utyp) then |
70482933 RK |
6080 | Set_Returns_By_Ref (Spec_Id); |
6081 | end if; | |
6082 | end; | |
6083 | ||
4a3b249c RD |
6084 | -- For a procedure, we add a return for all possible syntactic ends of |
6085 | -- the subprogram. | |
70482933 | 6086 | |
b29def53 | 6087 | if Ekind_In (Spec_Id, E_Procedure, E_Generic_Procedure) then |
2700b9c1 | 6088 | Add_Return (Spec_Id, Statements (HSS)); |
70482933 | 6089 | |
241ebe89 HK |
6090 | if Present (Exception_Handlers (HSS)) then |
6091 | Except_H := First_Non_Pragma (Exception_Handlers (HSS)); | |
70482933 | 6092 | while Present (Except_H) loop |
2700b9c1 | 6093 | Add_Return (Spec_Id, Statements (Except_H)); |
70482933 RK |
6094 | Next_Non_Pragma (Except_H); |
6095 | end loop; | |
6096 | end if; | |
6097 | ||
98f01d53 AC |
6098 | -- For a function, we must deal with the case where there is at least |
6099 | -- one missing return. What we do is to wrap the entire body of the | |
6100 | -- function in a block: | |
70482933 RK |
6101 | |
6102 | -- begin | |
6103 | -- ... | |
6104 | -- end; | |
6105 | ||
6106 | -- becomes | |
6107 | ||
6108 | -- begin | |
6109 | -- begin | |
6110 | -- ... | |
6111 | -- end; | |
6112 | ||
6113 | -- raise Program_Error; | |
6114 | -- end; | |
6115 | ||
4a3b249c RD |
6116 | -- This approach is necessary because the raise must be signalled to the |
6117 | -- caller, not handled by any local handler (RM 6.4(11)). | |
70482933 | 6118 | |
4a3b249c RD |
6119 | -- Note: we do not need to analyze the constructed sequence here, since |
6120 | -- it has no handler, and an attempt to analyze the handled statement | |
6121 | -- sequence twice is risky in various ways (e.g. the issue of expanding | |
6122 | -- cleanup actions twice). | |
70482933 RK |
6123 | |
6124 | elsif Has_Missing_Return (Spec_Id) then | |
6125 | declare | |
241ebe89 | 6126 | Hloc : constant Source_Ptr := Sloc (HSS); |
70482933 RK |
6127 | Blok : constant Node_Id := |
6128 | Make_Block_Statement (Hloc, | |
241ebe89 | 6129 | Handled_Statement_Sequence => HSS); |
70482933 | 6130 | Rais : constant Node_Id := |
07fc65c4 GB |
6131 | Make_Raise_Program_Error (Hloc, |
6132 | Reason => PE_Missing_Return); | |
70482933 RK |
6133 | |
6134 | begin | |
6135 | Set_Handled_Statement_Sequence (N, | |
6136 | Make_Handled_Sequence_Of_Statements (Hloc, | |
6137 | Statements => New_List (Blok, Rais))); | |
6138 | ||
7888a6ae | 6139 | Push_Scope (Spec_Id); |
70482933 RK |
6140 | Analyze (Blok); |
6141 | Analyze (Rais); | |
6142 | Pop_Scope; | |
6143 | end; | |
6144 | end if; | |
6145 | ||
70482933 RK |
6146 | -- If subprogram contains a parameterless recursive call, then we may |
6147 | -- have an infinite recursion, so see if we can generate code to check | |
6148 | -- for this possibility if storage checks are not suppressed. | |
6149 | ||
6150 | if Ekind (Spec_Id) = E_Procedure | |
6151 | and then Has_Recursive_Call (Spec_Id) | |
6152 | and then not Storage_Checks_Suppressed (Spec_Id) | |
6153 | then | |
6154 | Detect_Infinite_Recursion (N, Spec_Id); | |
6155 | end if; | |
6156 | ||
70482933 RK |
6157 | -- Set to encode entity names in package body before gigi is called |
6158 | ||
6159 | Qualify_Entity_Names (N); | |
7327f5c2 AC |
6160 | |
6161 | -- If the body belongs to a nonabstract library-level source primitive | |
6162 | -- of a tagged type, install an elaboration check which ensures that a | |
6163 | -- dispatching call targeting the primitive will not execute the body | |
6164 | -- without it being previously elaborated. | |
6165 | ||
6166 | Install_Primitive_Elaboration_Check (N); | |
70482933 RK |
6167 | end Expand_N_Subprogram_Body; |
6168 | ||
6169 | ----------------------------------- | |
6170 | -- Expand_N_Subprogram_Body_Stub -- | |
6171 | ----------------------------------- | |
6172 | ||
6173 | procedure Expand_N_Subprogram_Body_Stub (N : Node_Id) is | |
31ae1b46 | 6174 | Bod : Node_Id; |
c37e6613 | 6175 | |
70482933 RK |
6176 | begin |
6177 | if Present (Corresponding_Body (N)) then | |
31ae1b46 AC |
6178 | Bod := Unit_Declaration_Node (Corresponding_Body (N)); |
6179 | ||
6180 | -- The body may have been expanded already when it is analyzed | |
6181 | -- through the subunit node. Do no expand again: it interferes | |
6182 | -- with the construction of unnesting tables when generating C. | |
6183 | ||
6184 | if not Analyzed (Bod) then | |
6185 | Expand_N_Subprogram_Body (Bod); | |
6186 | end if; | |
6187 | ||
6188 | -- Add full qualification to entities that may be created late | |
6189 | -- during unnesting. | |
6190 | ||
6191 | Qualify_Entity_Names (N); | |
70482933 | 6192 | end if; |
70482933 RK |
6193 | end Expand_N_Subprogram_Body_Stub; |
6194 | ||
6195 | ------------------------------------- | |
6196 | -- Expand_N_Subprogram_Declaration -- | |
6197 | ------------------------------------- | |
6198 | ||
70482933 RK |
6199 | -- If the declaration appears within a protected body, it is a private |
6200 | -- operation of the protected type. We must create the corresponding | |
6201 | -- protected subprogram an associated formals. For a normal protected | |
6202 | -- operation, this is done when expanding the protected type declaration. | |
6203 | ||
758c442c GD |
6204 | -- If the declaration is for a null procedure, emit null body |
6205 | ||
70482933 | 6206 | procedure Expand_N_Subprogram_Declaration (N : Node_Id) is |
2700b9c1 AC |
6207 | Loc : constant Source_Ptr := Sloc (N); |
6208 | Subp : constant Entity_Id := Defining_Entity (N); | |
6209 | ||
2700b9c1 AC |
6210 | -- Local variables |
6211 | ||
1af4455a | 6212 | Scop : constant Entity_Id := Scope (Subp); |
fbf5a39b | 6213 | Prot_Bod : Node_Id; |
241ebe89 | 6214 | Prot_Decl : Node_Id; |
fbf5a39b | 6215 | Prot_Id : Entity_Id; |
70482933 | 6216 | |
2700b9c1 AC |
6217 | -- Start of processing for Expand_N_Subprogram_Declaration |
6218 | ||
70482933 | 6219 | begin |
2ba431e5 YM |
6220 | -- In SPARK, subprogram declarations are only allowed in package |
6221 | -- specifications. | |
7ff2d234 | 6222 | |
fe5d3068 YM |
6223 | if Nkind (Parent (N)) /= N_Package_Specification then |
6224 | if Nkind (Parent (N)) = N_Compilation_Unit then | |
ce5ba43a | 6225 | Check_SPARK_05_Restriction |
fe5d3068 YM |
6226 | ("subprogram declaration is not a library item", N); |
6227 | ||
6228 | elsif Present (Next (N)) | |
7ff2d234 | 6229 | and then Nkind (Next (N)) = N_Pragma |
533e3abc | 6230 | and then Get_Pragma_Id (Next (N)) = Pragma_Import |
7ff2d234 | 6231 | then |
2ba431e5 | 6232 | -- In SPARK, subprogram declarations are also permitted in |
7ff2d234 AC |
6233 | -- declarative parts when immediately followed by a corresponding |
6234 | -- pragma Import. We only check here that there is some pragma | |
6235 | -- Import. | |
6236 | ||
6237 | null; | |
6238 | else | |
ce5ba43a | 6239 | Check_SPARK_05_Restriction |
fe5d3068 | 6240 | ("subprogram declaration is not allowed here", N); |
7ff2d234 AC |
6241 | end if; |
6242 | end if; | |
6243 | ||
2f1b20a9 ES |
6244 | -- Deal with case of protected subprogram. Do not generate protected |
6245 | -- operation if operation is flagged as eliminated. | |
70482933 RK |
6246 | |
6247 | if Is_List_Member (N) | |
6248 | and then Present (Parent (List_Containing (N))) | |
6249 | and then Nkind (Parent (List_Containing (N))) = N_Protected_Body | |
6250 | and then Is_Protected_Type (Scop) | |
6251 | then | |
6871ba5f AC |
6252 | if No (Protected_Body_Subprogram (Subp)) |
6253 | and then not Is_Eliminated (Subp) | |
6254 | then | |
fbf5a39b | 6255 | Prot_Decl := |
70482933 RK |
6256 | Make_Subprogram_Declaration (Loc, |
6257 | Specification => | |
6258 | Build_Protected_Sub_Specification | |
2f1b20a9 | 6259 | (N, Scop, Unprotected_Mode)); |
70482933 RK |
6260 | |
6261 | -- The protected subprogram is declared outside of the protected | |
6262 | -- body. Given that the body has frozen all entities so far, we | |
fbf5a39b | 6263 | -- analyze the subprogram and perform freezing actions explicitly. |
19590d70 GD |
6264 | -- including the generation of an explicit freeze node, to ensure |
6265 | -- that gigi has the proper order of elaboration. | |
fbf5a39b AC |
6266 | -- If the body is a subunit, the insertion point is before the |
6267 | -- stub in the parent. | |
70482933 RK |
6268 | |
6269 | Prot_Bod := Parent (List_Containing (N)); | |
6270 | ||
6271 | if Nkind (Parent (Prot_Bod)) = N_Subunit then | |
6272 | Prot_Bod := Corresponding_Stub (Parent (Prot_Bod)); | |
6273 | end if; | |
6274 | ||
fbf5a39b AC |
6275 | Insert_Before (Prot_Bod, Prot_Decl); |
6276 | Prot_Id := Defining_Unit_Name (Specification (Prot_Decl)); | |
19590d70 | 6277 | Set_Has_Delayed_Freeze (Prot_Id); |
70482933 | 6278 | |
7888a6ae | 6279 | Push_Scope (Scope (Scop)); |
fbf5a39b | 6280 | Analyze (Prot_Decl); |
6b958cec | 6281 | Freeze_Before (N, Prot_Id); |
fbf5a39b | 6282 | Set_Protected_Body_Subprogram (Subp, Prot_Id); |
47bfea3a AC |
6283 | |
6284 | -- Create protected operation as well. Even though the operation | |
6285 | -- is only accessible within the body, it is possible to make it | |
6286 | -- available outside of the protected object by using 'Access to | |
3d923671 | 6287 | -- provide a callback, so build protected version in all cases. |
47bfea3a AC |
6288 | |
6289 | Prot_Decl := | |
3d923671 AC |
6290 | Make_Subprogram_Declaration (Loc, |
6291 | Specification => | |
6292 | Build_Protected_Sub_Specification (N, Scop, Protected_Mode)); | |
47bfea3a AC |
6293 | Insert_Before (Prot_Bod, Prot_Decl); |
6294 | Analyze (Prot_Decl); | |
6295 | ||
70482933 RK |
6296 | Pop_Scope; |
6297 | end if; | |
758c442c | 6298 | |
54bf19e4 AC |
6299 | -- Ada 2005 (AI-348): Generate body for a null procedure. In most |
6300 | -- cases this is superfluous because calls to it will be automatically | |
6301 | -- inlined, but we definitely need the body if preconditions for the | |
b912db16 | 6302 | -- procedure are present, or if performing coverage analysis. |
02822a92 | 6303 | |
758c442c GD |
6304 | elsif Nkind (Specification (N)) = N_Procedure_Specification |
6305 | and then Null_Present (Specification (N)) | |
6306 | then | |
6307 | declare | |
e1f3cb58 | 6308 | Bod : constant Node_Id := Body_To_Inline (N); |
d6533e74 | 6309 | |
758c442c | 6310 | begin |
e1f3cb58 AC |
6311 | Set_Has_Completion (Subp, False); |
6312 | Append_Freeze_Action (Subp, Bod); | |
c73ae90f | 6313 | |
e1f3cb58 AC |
6314 | -- The body now contains raise statements, so calls to it will |
6315 | -- not be inlined. | |
c73ae90f | 6316 | |
e1f3cb58 | 6317 | Set_Is_Inlined (Subp, False); |
758c442c | 6318 | end; |
70482933 | 6319 | end if; |
2700b9c1 AC |
6320 | |
6321 | -- When generating C code, transform a function that returns a | |
6322 | -- constrained array type into a procedure with an out parameter | |
6323 | -- that carries the return value. | |
6324 | ||
638f5054 AC |
6325 | -- We skip this transformation for unchecked conversions, since they |
6326 | -- are not needed by the C generator (and this also produces cleaner | |
6327 | -- output). | |
6328 | ||
2700b9c1 AC |
6329 | if Modify_Tree_For_C |
6330 | and then Nkind (Specification (N)) = N_Function_Specification | |
6331 | and then Is_Array_Type (Etype (Subp)) | |
6332 | and then Is_Constrained (Etype (Subp)) | |
638f5054 | 6333 | and then not Is_Unchecked_Conversion_Instance (Subp) |
2700b9c1 | 6334 | then |
51b42ffa | 6335 | Build_Procedure_Form (N); |
2700b9c1 | 6336 | end if; |
70482933 RK |
6337 | end Expand_N_Subprogram_Declaration; |
6338 | ||
2b3d67a5 AC |
6339 | -------------------------------- |
6340 | -- Expand_Non_Function_Return -- | |
6341 | -------------------------------- | |
6342 | ||
6343 | procedure Expand_Non_Function_Return (N : Node_Id) is | |
6344 | pragma Assert (No (Expression (N))); | |
6345 | ||
c9d70ab1 AC |
6346 | Loc : constant Source_Ptr := Sloc (N); |
6347 | Scope_Id : Entity_Id := Return_Applies_To (Return_Statement_Entity (N)); | |
6348 | Kind : constant Entity_Kind := Ekind (Scope_Id); | |
6349 | Call : Node_Id; | |
6350 | Acc_Stat : Node_Id; | |
6351 | Goto_Stat : Node_Id; | |
6352 | Lab_Node : Node_Id; | |
2b3d67a5 AC |
6353 | |
6354 | begin | |
c9d70ab1 AC |
6355 | -- Call the _Postconditions procedure if the related subprogram has |
6356 | -- contract assertions that need to be verified on exit. | |
6357 | ||
6358 | if Ekind_In (Scope_Id, E_Entry, E_Entry_Family, E_Procedure) | |
6359 | and then Present (Postconditions_Proc (Scope_Id)) | |
2b3d67a5 | 6360 | then |
2b3d67a5 AC |
6361 | Insert_Action (N, |
6362 | Make_Procedure_Call_Statement (Loc, | |
c9d70ab1 | 6363 | Name => New_Occurrence_Of (Postconditions_Proc (Scope_Id), Loc))); |
2b3d67a5 AC |
6364 | end if; |
6365 | ||
6366 | -- If it is a return from a procedure do no extra steps | |
6367 | ||
6368 | if Kind = E_Procedure or else Kind = E_Generic_Procedure then | |
6369 | return; | |
6370 | ||
6371 | -- If it is a nested return within an extended one, replace it with a | |
6372 | -- return of the previously declared return object. | |
6373 | ||
6374 | elsif Kind = E_Return_Statement then | |
6375 | Rewrite (N, | |
6376 | Make_Simple_Return_Statement (Loc, | |
6377 | Expression => | |
6378 | New_Occurrence_Of (First_Entity (Scope_Id), Loc))); | |
6379 | Set_Comes_From_Extended_Return_Statement (N); | |
6380 | Set_Return_Statement_Entity (N, Scope_Id); | |
6381 | Expand_Simple_Function_Return (N); | |
6382 | return; | |
6383 | end if; | |
6384 | ||
6385 | pragma Assert (Is_Entry (Scope_Id)); | |
6386 | ||
6387 | -- Look at the enclosing block to see whether the return is from an | |
6388 | -- accept statement or an entry body. | |
6389 | ||
6390 | for J in reverse 0 .. Scope_Stack.Last loop | |
6391 | Scope_Id := Scope_Stack.Table (J).Entity; | |
6392 | exit when Is_Concurrent_Type (Scope_Id); | |
6393 | end loop; | |
6394 | ||
6395 | -- If it is a return from accept statement it is expanded as call to | |
6396 | -- RTS Complete_Rendezvous and a goto to the end of the accept body. | |
6397 | ||
6398 | -- (cf : Expand_N_Accept_Statement, Expand_N_Selective_Accept, | |
6399 | -- Expand_N_Accept_Alternative in exp_ch9.adb) | |
6400 | ||
6401 | if Is_Task_Type (Scope_Id) then | |
6402 | ||
6403 | Call := | |
6404 | Make_Procedure_Call_Statement (Loc, | |
e4494292 | 6405 | Name => New_Occurrence_Of (RTE (RE_Complete_Rendezvous), Loc)); |
2b3d67a5 AC |
6406 | Insert_Before (N, Call); |
6407 | -- why not insert actions here??? | |
6408 | Analyze (Call); | |
6409 | ||
6410 | Acc_Stat := Parent (N); | |
6411 | while Nkind (Acc_Stat) /= N_Accept_Statement loop | |
6412 | Acc_Stat := Parent (Acc_Stat); | |
6413 | end loop; | |
6414 | ||
6415 | Lab_Node := Last (Statements | |
6416 | (Handled_Statement_Sequence (Acc_Stat))); | |
6417 | ||
6418 | Goto_Stat := Make_Goto_Statement (Loc, | |
6419 | Name => New_Occurrence_Of | |
6420 | (Entity (Identifier (Lab_Node)), Loc)); | |
6421 | ||
6422 | Set_Analyzed (Goto_Stat); | |
6423 | ||
6424 | Rewrite (N, Goto_Stat); | |
6425 | Analyze (N); | |
6426 | ||
6427 | -- If it is a return from an entry body, put a Complete_Entry_Body call | |
6428 | -- in front of the return. | |
6429 | ||
6430 | elsif Is_Protected_Type (Scope_Id) then | |
6431 | Call := | |
6432 | Make_Procedure_Call_Statement (Loc, | |
6433 | Name => | |
e4494292 | 6434 | New_Occurrence_Of (RTE (RE_Complete_Entry_Body), Loc), |
2b3d67a5 AC |
6435 | Parameter_Associations => New_List ( |
6436 | Make_Attribute_Reference (Loc, | |
2c1b72d7 | 6437 | Prefix => |
e4494292 | 6438 | New_Occurrence_Of |
2b3d67a5 | 6439 | (Find_Protection_Object (Current_Scope), Loc), |
2c1b72d7 | 6440 | Attribute_Name => Name_Unchecked_Access))); |
2b3d67a5 AC |
6441 | |
6442 | Insert_Before (N, Call); | |
6443 | Analyze (Call); | |
6444 | end if; | |
6445 | end Expand_Non_Function_Return; | |
6446 | ||
70482933 RK |
6447 | --------------------------------------- |
6448 | -- Expand_Protected_Object_Reference -- | |
6449 | --------------------------------------- | |
6450 | ||
6451 | function Expand_Protected_Object_Reference | |
6452 | (N : Node_Id; | |
02822a92 | 6453 | Scop : Entity_Id) return Node_Id |
70482933 RK |
6454 | is |
6455 | Loc : constant Source_Ptr := Sloc (N); | |
6456 | Corr : Entity_Id; | |
6457 | Rec : Node_Id; | |
6458 | Param : Entity_Id; | |
6459 | Proc : Entity_Id; | |
6460 | ||
6461 | begin | |
7675ad4f | 6462 | Rec := Make_Identifier (Loc, Name_uObject); |
70482933 RK |
6463 | Set_Etype (Rec, Corresponding_Record_Type (Scop)); |
6464 | ||
2f1b20a9 ES |
6465 | -- Find enclosing protected operation, and retrieve its first parameter, |
6466 | -- which denotes the enclosing protected object. If the enclosing | |
6467 | -- operation is an entry, we are immediately within the protected body, | |
6468 | -- and we can retrieve the object from the service entries procedure. A | |
16b05213 | 6469 | -- barrier function has the same signature as an entry. A barrier |
2f1b20a9 ES |
6470 | -- function is compiled within the protected object, but unlike |
6471 | -- protected operations its never needs locks, so that its protected | |
6472 | -- body subprogram points to itself. | |
70482933 RK |
6473 | |
6474 | Proc := Current_Scope; | |
70482933 RK |
6475 | while Present (Proc) |
6476 | and then Scope (Proc) /= Scop | |
6477 | loop | |
6478 | Proc := Scope (Proc); | |
6479 | end loop; | |
6480 | ||
6481 | Corr := Protected_Body_Subprogram (Proc); | |
6482 | ||
6483 | if No (Corr) then | |
6484 | ||
6485 | -- Previous error left expansion incomplete. | |
6486 | -- Nothing to do on this call. | |
6487 | ||
6488 | return Empty; | |
6489 | end if; | |
6490 | ||
6491 | Param := | |
6492 | Defining_Identifier | |
6493 | (First (Parameter_Specifications (Parent (Corr)))); | |
6494 | ||
b9696ffb AC |
6495 | if Is_Subprogram (Proc) and then Proc /= Corr then |
6496 | ||
98f01d53 | 6497 | -- Protected function or procedure |
70482933 RK |
6498 | |
6499 | Set_Entity (Rec, Param); | |
6500 | ||
2f1b20a9 ES |
6501 | -- Rec is a reference to an entity which will not be in scope when |
6502 | -- the call is reanalyzed, and needs no further analysis. | |
70482933 RK |
6503 | |
6504 | Set_Analyzed (Rec); | |
6505 | ||
6506 | else | |
2f1b20a9 ES |
6507 | -- Entry or barrier function for entry body. The first parameter of |
6508 | -- the entry body procedure is pointer to the object. We create a | |
6509 | -- local variable of the proper type, duplicating what is done to | |
6510 | -- define _object later on. | |
70482933 RK |
6511 | |
6512 | declare | |
c12beea0 | 6513 | Decls : List_Id; |
c8307596 | 6514 | Obj_Ptr : constant Entity_Id := Make_Temporary (Loc, 'T'); |
fbf5a39b | 6515 | |
70482933 RK |
6516 | begin |
6517 | Decls := New_List ( | |
6518 | Make_Full_Type_Declaration (Loc, | |
6519 | Defining_Identifier => Obj_Ptr, | |
2c1b72d7 | 6520 | Type_Definition => |
70482933 RK |
6521 | Make_Access_To_Object_Definition (Loc, |
6522 | Subtype_Indication => | |
e4494292 | 6523 | New_Occurrence_Of |
c12beea0 | 6524 | (Corresponding_Record_Type (Scop), Loc)))); |
70482933 RK |
6525 | |
6526 | Insert_Actions (N, Decls); | |
6b958cec | 6527 | Freeze_Before (N, Obj_Ptr); |
70482933 RK |
6528 | |
6529 | Rec := | |
6530 | Make_Explicit_Dereference (Loc, | |
2c1b72d7 AC |
6531 | Prefix => |
6532 | Unchecked_Convert_To (Obj_Ptr, | |
6533 | New_Occurrence_Of (Param, Loc))); | |
70482933 | 6534 | |
2f1b20a9 | 6535 | -- Analyze new actual. Other actuals in calls are already analyzed |
7888a6ae | 6536 | -- and the list of actuals is not reanalyzed after rewriting. |
70482933 RK |
6537 | |
6538 | Set_Parent (Rec, N); | |
6539 | Analyze (Rec); | |
6540 | end; | |
6541 | end if; | |
6542 | ||
6543 | return Rec; | |
6544 | end Expand_Protected_Object_Reference; | |
6545 | ||
6546 | -------------------------------------- | |
6547 | -- Expand_Protected_Subprogram_Call -- | |
6548 | -------------------------------------- | |
6549 | ||
6550 | procedure Expand_Protected_Subprogram_Call | |
6551 | (N : Node_Id; | |
6552 | Subp : Entity_Id; | |
6553 | Scop : Entity_Id) | |
6554 | is | |
f31dcd99 | 6555 | Rec : Node_Id; |
70482933 | 6556 | |
86ec3bfb AC |
6557 | procedure Expand_Internal_Init_Call; |
6558 | -- A call to an operation of the type may occur in the initialization | |
6559 | -- of a private component. In that case the prefix of the call is an | |
6560 | -- entity name and the call is treated as internal even though it | |
6561 | -- appears in code outside of the protected type. | |
6562 | ||
36295779 AC |
6563 | procedure Freeze_Called_Function; |
6564 | -- If it is a function call it can appear in elaboration code and | |
6565 | -- the called entity must be frozen before the call. This must be | |
6566 | -- done before the call is expanded, as the expansion may rewrite it | |
6567 | -- to something other than a call (e.g. a temporary initialized in a | |
6568 | -- transient block). | |
6569 | ||
86ec3bfb AC |
6570 | ------------------------------- |
6571 | -- Expand_Internal_Init_Call -- | |
6572 | ------------------------------- | |
6573 | ||
6574 | procedure Expand_Internal_Init_Call is | |
6575 | begin | |
6576 | -- If the context is a protected object (rather than a protected | |
6577 | -- type) the call itself is bound to raise program_error because | |
6578 | -- the protected body will not have been elaborated yet. This is | |
6579 | -- diagnosed subsequently in Sem_Elab. | |
6580 | ||
6581 | Freeze_Called_Function; | |
6582 | ||
6583 | -- The target of the internal call is the first formal of the | |
6584 | -- enclosing initialization procedure. | |
6585 | ||
6586 | Rec := New_Occurrence_Of (First_Formal (Current_Scope), Sloc (N)); | |
6587 | Build_Protected_Subprogram_Call (N, | |
6588 | Name => Name (N), | |
6589 | Rec => Rec, | |
6590 | External => False); | |
6591 | Analyze (N); | |
6592 | Resolve (N, Etype (Subp)); | |
6593 | end Expand_Internal_Init_Call; | |
6594 | ||
36295779 AC |
6595 | ---------------------------- |
6596 | -- Freeze_Called_Function -- | |
6597 | ---------------------------- | |
6598 | ||
6599 | procedure Freeze_Called_Function is | |
6600 | begin | |
6601 | if Ekind (Subp) = E_Function then | |
6602 | Freeze_Expression (Name (N)); | |
6603 | end if; | |
6604 | end Freeze_Called_Function; | |
6605 | ||
6606 | -- Start of processing for Expand_Protected_Subprogram_Call | |
6607 | ||
70482933 | 6608 | begin |
54bf19e4 AC |
6609 | -- If the protected object is not an enclosing scope, this is an inter- |
6610 | -- object function call. Inter-object procedure calls are expanded by | |
6611 | -- Exp_Ch9.Build_Simple_Entry_Call. The call is intra-object only if the | |
6612 | -- subprogram being called is in the protected body being compiled, and | |
6613 | -- if the protected object in the call is statically the enclosing type. | |
a77152ca | 6614 | -- The object may be a component of some other data structure, in which |
54bf19e4 | 6615 | -- case this must be handled as an inter-object call. |
70482933 RK |
6616 | |
6617 | if not In_Open_Scopes (Scop) | |
9ca67d3f | 6618 | or else Is_Entry_Wrapper (Current_Scope) |
f31dcd99 | 6619 | or else not Is_Entity_Name (Name (N)) |
70482933 RK |
6620 | then |
6621 | if Nkind (Name (N)) = N_Selected_Component then | |
6622 | Rec := Prefix (Name (N)); | |
6623 | ||
86ec3bfb | 6624 | elsif Nkind (Name (N)) = N_Indexed_Component then |
70482933 | 6625 | Rec := Prefix (Prefix (Name (N))); |
86ec3bfb | 6626 | |
5e127570 AC |
6627 | -- If this is a call within an entry wrapper, it appears within a |
6628 | -- precondition that calls another primitive of the synchronized | |
6629 | -- type. The target object of the call is the first actual on the | |
6630 | -- wrapper. Note that this is an external call, because the wrapper | |
6631 | -- is called outside of the synchronized object. This means that | |
6632 | -- an entry call to an entry with preconditions involves two | |
6633 | -- synchronized operations. | |
6634 | ||
6635 | elsif Ekind (Current_Scope) = E_Procedure | |
6636 | and then Is_Entry_Wrapper (Current_Scope) | |
6637 | then | |
6638 | Rec := New_Occurrence_Of (First_Entity (Current_Scope), Sloc (N)); | |
6639 | ||
6cdce506 ES |
6640 | -- A default parameter of a protected operation may be a call to |
6641 | -- a protected function of the type. This appears as an internal | |
6642 | -- call in the profile of the operation, but if the context is an | |
6643 | -- external call we must convert the call into an external one, | |
6644 | -- using the protected object that is the target, so that: | |
6645 | ||
6646 | -- Prot.P (F) | |
6647 | -- is transformed into | |
6648 | -- Prot.P (Prot.F) | |
6649 | ||
6650 | elsif Nkind (Parent (N)) = N_Procedure_Call_Statement | |
6651 | and then Nkind (Name (Parent (N))) = N_Selected_Component | |
6652 | and then Is_Protected_Type (Etype (Prefix (Name (Parent (N))))) | |
6653 | and then Is_Entity_Name (Name (N)) | |
6654 | and then Scope (Entity (Name (N))) = | |
92a68a04 | 6655 | Etype (Prefix (Name (Parent (N)))) |
6cdce506 ES |
6656 | then |
6657 | Rewrite (Name (N), | |
6658 | Make_Selected_Component (Sloc (N), | |
92a68a04 | 6659 | Prefix => New_Copy_Tree (Prefix (Name (Parent (N)))), |
6cdce506 | 6660 | Selector_Name => Relocate_Node (Name (N)))); |
92a68a04 | 6661 | |
6cdce506 ES |
6662 | Analyze_And_Resolve (N); |
6663 | return; | |
6664 | ||
86ec3bfb AC |
6665 | else |
6666 | -- If the context is the initialization procedure for a protected | |
6667 | -- type, the call is legal because the called entity must be a | |
6668 | -- function of that enclosing type, and this is treated as an | |
6669 | -- internal call. | |
6670 | ||
f31dcd99 HK |
6671 | pragma Assert |
6672 | (Is_Entity_Name (Name (N)) and then Inside_Init_Proc); | |
6673 | ||
86ec3bfb AC |
6674 | Expand_Internal_Init_Call; |
6675 | return; | |
70482933 RK |
6676 | end if; |
6677 | ||
36295779 | 6678 | Freeze_Called_Function; |
70482933 | 6679 | Build_Protected_Subprogram_Call (N, |
2c1b72d7 | 6680 | Name => New_Occurrence_Of (Subp, Sloc (N)), |
2ba1a7c7 | 6681 | Rec => Convert_Concurrent (Rec, Etype (Rec)), |
70482933 RK |
6682 | External => True); |
6683 | ||
6684 | else | |
6685 | Rec := Expand_Protected_Object_Reference (N, Scop); | |
6686 | ||
6687 | if No (Rec) then | |
6688 | return; | |
6689 | end if; | |
6690 | ||
36295779 | 6691 | Freeze_Called_Function; |
70482933 RK |
6692 | Build_Protected_Subprogram_Call (N, |
6693 | Name => Name (N), | |
6694 | Rec => Rec, | |
6695 | External => False); | |
70482933 RK |
6696 | end if; |
6697 | ||
811c6a85 | 6698 | -- Analyze and resolve the new call. The actuals have already been |
b0159fbe | 6699 | -- resolved, but expansion of a function call will add extra actuals |
811c6a85 AC |
6700 | -- if needed. Analysis of a procedure call already includes resolution. |
6701 | ||
6702 | Analyze (N); | |
6703 | ||
6704 | if Ekind (Subp) = E_Function then | |
6705 | Resolve (N, Etype (Subp)); | |
6706 | end if; | |
70482933 RK |
6707 | end Expand_Protected_Subprogram_Call; |
6708 | ||
2b3d67a5 AC |
6709 | ----------------------------------- |
6710 | -- Expand_Simple_Function_Return -- | |
6711 | ----------------------------------- | |
6712 | ||
54bf19e4 | 6713 | -- The "simple" comes from the syntax rule simple_return_statement. The |
a90bd866 | 6714 | -- semantics are not at all simple. |
2b3d67a5 AC |
6715 | |
6716 | procedure Expand_Simple_Function_Return (N : Node_Id) is | |
6717 | Loc : constant Source_Ptr := Sloc (N); | |
6718 | ||
6719 | Scope_Id : constant Entity_Id := | |
6720 | Return_Applies_To (Return_Statement_Entity (N)); | |
6721 | -- The function we are returning from | |
6722 | ||
6723 | R_Type : constant Entity_Id := Etype (Scope_Id); | |
6724 | -- The result type of the function | |
6725 | ||
6726 | Utyp : constant Entity_Id := Underlying_Type (R_Type); | |
6727 | ||
81501d2b | 6728 | Exp : Node_Id := Expression (N); |
2b3d67a5 AC |
6729 | pragma Assert (Present (Exp)); |
6730 | ||
6731 | Exptyp : constant Entity_Id := Etype (Exp); | |
6732 | -- The type of the expression (not necessarily the same as R_Type) | |
6733 | ||
6734 | Subtype_Ind : Node_Id; | |
54bf19e4 AC |
6735 | -- If the result type of the function is class-wide and the expression |
6736 | -- has a specific type, then we use the expression's type as the type of | |
6737 | -- the return object. In cases where the expression is an aggregate that | |
6738 | -- is built in place, this avoids the need for an expensive conversion | |
6739 | -- of the return object to the specific type on assignments to the | |
6740 | -- individual components. | |
2b3d67a5 AC |
6741 | |
6742 | begin | |
6743 | if Is_Class_Wide_Type (R_Type) | |
81501d2b AC |
6744 | and then not Is_Class_Wide_Type (Exptyp) |
6745 | and then Nkind (Exp) /= N_Type_Conversion | |
2b3d67a5 | 6746 | then |
81501d2b | 6747 | Subtype_Ind := New_Occurrence_Of (Exptyp, Loc); |
2b3d67a5 AC |
6748 | else |
6749 | Subtype_Ind := New_Occurrence_Of (R_Type, Loc); | |
81501d2b AC |
6750 | |
6751 | -- If the result type is class-wide and the expression is a view | |
6752 | -- conversion, the conversion plays no role in the expansion because | |
6753 | -- it does not modify the tag of the object. Remove the conversion | |
6754 | -- altogether to prevent tag overwriting. | |
6755 | ||
6756 | if Is_Class_Wide_Type (R_Type) | |
6757 | and then not Is_Class_Wide_Type (Exptyp) | |
6758 | and then Nkind (Exp) = N_Type_Conversion | |
6759 | then | |
6760 | Exp := Expression (Exp); | |
6761 | end if; | |
2b3d67a5 AC |
6762 | end if; |
6763 | ||
b3801819 PMR |
6764 | -- Assert that if F says "return G(...);" |
6765 | -- then F and G are both b-i-p, or neither b-i-p. | |
6766 | ||
6767 | if Nkind (Exp) = N_Function_Call then | |
6768 | pragma Assert (Ekind (Scope_Id) = E_Function); | |
6769 | pragma Assert | |
6770 | (Is_Build_In_Place_Function (Scope_Id) = | |
6771 | Is_Build_In_Place_Function_Call (Exp)); | |
6772 | null; | |
6773 | end if; | |
6774 | ||
cd644ae2 PMR |
6775 | -- For the case of a simple return that does not come from an |
6776 | -- extended return, in the case of build-in-place, we rewrite | |
6777 | -- "return <expression>;" to be: | |
2b3d67a5 AC |
6778 | |
6779 | -- return _anon_ : <return_subtype> := <expression> | |
6780 | ||
6781 | -- The expansion produced by Expand_N_Extended_Return_Statement will | |
6782 | -- contain simple return statements (for example, a block containing | |
6783 | -- simple return of the return object), which brings us back here with | |
6784 | -- Comes_From_Extended_Return_Statement set. The reason for the barrier | |
6785 | -- checking for a simple return that does not come from an extended | |
6786 | -- return is to avoid this infinite recursion. | |
6787 | ||
6788 | -- The reason for this design is that for Ada 2005 limited returns, we | |
6789 | -- need to reify the return object, so we can build it "in place", and | |
6790 | -- we need a block statement to hang finalization and tasking stuff. | |
6791 | ||
6792 | -- ??? In order to avoid disruption, we avoid translating to extended | |
6793 | -- return except in the cases where we really need to (Ada 2005 for | |
6794 | -- inherently limited). We might prefer to do this translation in all | |
6795 | -- cases (except perhaps for the case of Ada 95 inherently limited), | |
6796 | -- in order to fully exercise the Expand_N_Extended_Return_Statement | |
6797 | -- code. This would also allow us to do the build-in-place optimization | |
6798 | -- for efficiency even in cases where it is semantically not required. | |
6799 | ||
6800 | -- As before, we check the type of the return expression rather than the | |
6801 | -- return type of the function, because the latter may be a limited | |
6802 | -- class-wide interface type, which is not a limited type, even though | |
6803 | -- the type of the expression may be. | |
6804 | ||
d4dfb005 BD |
6805 | pragma Assert |
6806 | (Comes_From_Extended_Return_Statement (N) | |
3fc40cd7 PMR |
6807 | or else not Is_Build_In_Place_Function_Call (Exp) |
6808 | or else Is_Build_In_Place_Function (Scope_Id)); | |
d4dfb005 | 6809 | |
2b3d67a5 | 6810 | if not Comes_From_Extended_Return_Statement (N) |
d4dfb005 | 6811 | and then Is_Build_In_Place_Function (Scope_Id) |
2b3d67a5 | 6812 | and then not Debug_Flag_Dot_L |
f6f4d8d4 JM |
6813 | |
6814 | -- The functionality of interface thunks is simple and it is always | |
6815 | -- handled by means of simple return statements. This leaves their | |
6816 | -- expansion simple and clean. | |
6817 | ||
da1c23dd | 6818 | and then not Is_Thunk (Current_Scope) |
2b3d67a5 AC |
6819 | then |
6820 | declare | |
6821 | Return_Object_Entity : constant Entity_Id := | |
6822 | Make_Temporary (Loc, 'R', Exp); | |
f6f4d8d4 | 6823 | |
2b3d67a5 AC |
6824 | Obj_Decl : constant Node_Id := |
6825 | Make_Object_Declaration (Loc, | |
6826 | Defining_Identifier => Return_Object_Entity, | |
6827 | Object_Definition => Subtype_Ind, | |
6828 | Expression => Exp); | |
6829 | ||
f6f4d8d4 JM |
6830 | Ext : constant Node_Id := |
6831 | Make_Extended_Return_Statement (Loc, | |
6832 | Return_Object_Declarations => New_List (Obj_Decl)); | |
2b3d67a5 AC |
6833 | -- Do not perform this high-level optimization if the result type |
6834 | -- is an interface because the "this" pointer must be displaced. | |
6835 | ||
6836 | begin | |
6837 | Rewrite (N, Ext); | |
6838 | Analyze (N); | |
6839 | return; | |
6840 | end; | |
6841 | end if; | |
6842 | ||
6843 | -- Here we have a simple return statement that is part of the expansion | |
6844 | -- of an extended return statement (either written by the user, or | |
6845 | -- generated by the above code). | |
6846 | ||
6847 | -- Always normalize C/Fortran boolean result. This is not always needed, | |
6848 | -- but it seems a good idea to minimize the passing around of non- | |
6849 | -- normalized values, and in any case this handles the processing of | |
6850 | -- barrier functions for protected types, which turn the condition into | |
6851 | -- a return statement. | |
6852 | ||
6853 | if Is_Boolean_Type (Exptyp) | |
6854 | and then Nonzero_Is_True (Exptyp) | |
6855 | then | |
6856 | Adjust_Condition (Exp); | |
6857 | Adjust_Result_Type (Exp, Exptyp); | |
6858 | end if; | |
6859 | ||
6860 | -- Do validity check if enabled for returns | |
6861 | ||
6862 | if Validity_Checks_On | |
6863 | and then Validity_Check_Returns | |
6864 | then | |
6865 | Ensure_Valid (Exp); | |
6866 | end if; | |
6867 | ||
6868 | -- Check the result expression of a scalar function against the subtype | |
6869 | -- of the function by inserting a conversion. This conversion must | |
6870 | -- eventually be performed for other classes of types, but for now it's | |
6871 | -- only done for scalars. | |
6872 | -- ??? | |
6873 | ||
6874 | if Is_Scalar_Type (Exptyp) then | |
6875 | Rewrite (Exp, Convert_To (R_Type, Exp)); | |
6876 | ||
6877 | -- The expression is resolved to ensure that the conversion gets | |
6878 | -- expanded to generate a possible constraint check. | |
6879 | ||
6880 | Analyze_And_Resolve (Exp, R_Type); | |
6881 | end if; | |
6882 | ||
6883 | -- Deal with returning variable length objects and controlled types | |
6884 | ||
6885 | -- Nothing to do if we are returning by reference, or this is not a | |
6886 | -- type that requires special processing (indicated by the fact that | |
6887 | -- it requires a cleanup scope for the secondary stack case). | |
6888 | ||
d4dfb005 | 6889 | if Is_Build_In_Place_Function (Scope_Id) |
2b3d67a5 AC |
6890 | or else Is_Limited_Interface (Exptyp) |
6891 | then | |
6892 | null; | |
6893 | ||
f6f4d8d4 JM |
6894 | -- No copy needed for thunks returning interface type objects since |
6895 | -- the object is returned by reference and the maximum functionality | |
6896 | -- required is just to displace the pointer. | |
6897 | ||
4b342b91 | 6898 | elsif Is_Thunk (Current_Scope) and then Is_Interface (Exptyp) then |
f6f4d8d4 JM |
6899 | null; |
6900 | ||
ed09416f AC |
6901 | -- If the call is within a thunk and the type is a limited view, the |
6902 | -- backend will eventually see the non-limited view of the type. | |
6903 | ||
bdeea27b | 6904 | elsif Is_Thunk (Current_Scope) and then Is_Incomplete_Type (Exptyp) then |
ed09416f AC |
6905 | return; |
6906 | ||
95a79822 ES |
6907 | -- A return statement from a Ghost function does not use the secondary |
6908 | -- stack (or any other one). | |
6909 | ||
6910 | elsif not Requires_Transient_Scope (R_Type) | |
6911 | or else Is_Ignored_Ghost_Entity (Scope_Id) | |
6912 | then | |
2b3d67a5 | 6913 | |
d29f68cf AC |
6914 | -- Mutable records with variable-length components are not returned |
6915 | -- on the sec-stack, so we need to make sure that the back end will | |
6916 | -- only copy back the size of the actual value, and not the maximum | |
6917 | -- size. We create an actual subtype for this purpose. However we | |
6918 | -- need not do it if the expression is a function call since this | |
6919 | -- will be done in the called function and doing it here too would | |
6920 | -- cause a temporary with maximum size to be created. | |
2b3d67a5 AC |
6921 | |
6922 | declare | |
6923 | Ubt : constant Entity_Id := Underlying_Type (Base_Type (Exptyp)); | |
6924 | Decl : Node_Id; | |
6925 | Ent : Entity_Id; | |
6926 | begin | |
d29f68cf AC |
6927 | if Nkind (Exp) /= N_Function_Call |
6928 | and then Has_Discriminants (Ubt) | |
2b3d67a5 AC |
6929 | and then not Is_Constrained (Ubt) |
6930 | and then not Has_Unchecked_Union (Ubt) | |
6931 | then | |
6932 | Decl := Build_Actual_Subtype (Ubt, Exp); | |
6933 | Ent := Defining_Identifier (Decl); | |
6934 | Insert_Action (Exp, Decl); | |
6935 | Rewrite (Exp, Unchecked_Convert_To (Ent, Exp)); | |
6936 | Analyze_And_Resolve (Exp); | |
6937 | end if; | |
6938 | end; | |
6939 | ||
6940 | -- Here if secondary stack is used | |
6941 | ||
6942 | else | |
c624298a | 6943 | -- Prevent the reclamation of the secondary stack by all enclosing |
c79f6efd BD |
6944 | -- blocks and loops as well as the related function; otherwise the |
6945 | -- result would be reclaimed too early. | |
adb252d8 | 6946 | |
c79f6efd | 6947 | Set_Enclosing_Sec_Stack_Return (N); |
2b3d67a5 AC |
6948 | |
6949 | -- Optimize the case where the result is a function call. In this | |
6950 | -- case either the result is already on the secondary stack, or is | |
6951 | -- already being returned with the stack pointer depressed and no | |
54bf19e4 AC |
6952 | -- further processing is required except to set the By_Ref flag |
6953 | -- to ensure that gigi does not attempt an extra unnecessary copy. | |
2b3d67a5 AC |
6954 | -- (actually not just unnecessary but harmfully wrong in the case |
6955 | -- of a controlled type, where gigi does not know how to do a copy). | |
54bf19e4 AC |
6956 | -- To make up for a gcc 2.8.1 deficiency (???), we perform the copy |
6957 | -- for array types if the constrained status of the target type is | |
6958 | -- different from that of the expression. | |
2b3d67a5 AC |
6959 | |
6960 | if Requires_Transient_Scope (Exptyp) | |
6961 | and then | |
6962 | (not Is_Array_Type (Exptyp) | |
6963 | or else Is_Constrained (Exptyp) = Is_Constrained (R_Type) | |
6964 | or else CW_Or_Has_Controlled_Part (Utyp)) | |
6965 | and then Nkind (Exp) = N_Function_Call | |
6966 | then | |
6967 | Set_By_Ref (N); | |
6968 | ||
6969 | -- Remove side effects from the expression now so that other parts | |
6970 | -- of the expander do not have to reanalyze this node without this | |
6971 | -- optimization | |
6972 | ||
6973 | Rewrite (Exp, Duplicate_Subexpr_No_Checks (Exp)); | |
6974 | ||
ec7f007c AC |
6975 | -- Ada 2005 (AI-251): If the type of the returned object is |
6976 | -- an interface then add an implicit type conversion to force | |
6977 | -- displacement of the "this" pointer. | |
6978 | ||
6979 | if Is_Interface (R_Type) then | |
6980 | Rewrite (Exp, Convert_To (R_Type, Relocate_Node (Exp))); | |
6981 | end if; | |
6982 | ||
6983 | Analyze_And_Resolve (Exp, R_Type); | |
6984 | ||
2b3d67a5 AC |
6985 | -- For controlled types, do the allocation on the secondary stack |
6986 | -- manually in order to call adjust at the right time: | |
6987 | ||
6988 | -- type Anon1 is access R_Type; | |
6989 | -- for Anon1'Storage_pool use ss_pool; | |
6990 | -- Anon2 : anon1 := new R_Type'(expr); | |
6991 | -- return Anon2.all; | |
6992 | ||
6993 | -- We do the same for classwide types that are not potentially | |
6994 | -- controlled (by the virtue of restriction No_Finalization) because | |
6995 | -- gigi is not able to properly allocate class-wide types. | |
6996 | ||
6997 | elsif CW_Or_Has_Controlled_Part (Utyp) then | |
6998 | declare | |
6999 | Loc : constant Source_Ptr := Sloc (N); | |
7000 | Acc_Typ : constant Entity_Id := Make_Temporary (Loc, 'A'); | |
7001 | Alloc_Node : Node_Id; | |
7002 | Temp : Entity_Id; | |
7003 | ||
7004 | begin | |
7005 | Set_Ekind (Acc_Typ, E_Access_Type); | |
7006 | ||
7007 | Set_Associated_Storage_Pool (Acc_Typ, RTE (RE_SS_Pool)); | |
7008 | ||
7009 | -- This is an allocator for the secondary stack, and it's fine | |
7010 | -- to have Comes_From_Source set False on it, as gigi knows not | |
7011 | -- to flag it as a violation of No_Implicit_Heap_Allocations. | |
7012 | ||
7013 | Alloc_Node := | |
7014 | Make_Allocator (Loc, | |
7015 | Expression => | |
7016 | Make_Qualified_Expression (Loc, | |
e4494292 | 7017 | Subtype_Mark => New_Occurrence_Of (Etype (Exp), Loc), |
2b3d67a5 AC |
7018 | Expression => Relocate_Node (Exp))); |
7019 | ||
7020 | -- We do not want discriminant checks on the declaration, | |
7021 | -- given that it gets its value from the allocator. | |
7022 | ||
7023 | Set_No_Initialization (Alloc_Node); | |
7024 | ||
7025 | Temp := Make_Temporary (Loc, 'R', Alloc_Node); | |
7026 | ||
7027 | Insert_List_Before_And_Analyze (N, New_List ( | |
7028 | Make_Full_Type_Declaration (Loc, | |
7029 | Defining_Identifier => Acc_Typ, | |
7030 | Type_Definition => | |
7031 | Make_Access_To_Object_Definition (Loc, | |
7032 | Subtype_Indication => Subtype_Ind)), | |
7033 | ||
7034 | Make_Object_Declaration (Loc, | |
7035 | Defining_Identifier => Temp, | |
e4494292 | 7036 | Object_Definition => New_Occurrence_Of (Acc_Typ, Loc), |
2b3d67a5 AC |
7037 | Expression => Alloc_Node))); |
7038 | ||
7039 | Rewrite (Exp, | |
7040 | Make_Explicit_Dereference (Loc, | |
e4494292 | 7041 | Prefix => New_Occurrence_Of (Temp, Loc))); |
2b3d67a5 | 7042 | |
a1092b48 AC |
7043 | -- Ada 2005 (AI-251): If the type of the returned object is |
7044 | -- an interface then add an implicit type conversion to force | |
7045 | -- displacement of the "this" pointer. | |
7046 | ||
7047 | if Is_Interface (R_Type) then | |
7048 | Rewrite (Exp, Convert_To (R_Type, Relocate_Node (Exp))); | |
7049 | end if; | |
7050 | ||
2b3d67a5 AC |
7051 | Analyze_And_Resolve (Exp, R_Type); |
7052 | end; | |
7053 | ||
7054 | -- Otherwise use the gigi mechanism to allocate result on the | |
7055 | -- secondary stack. | |
7056 | ||
7057 | else | |
7058 | Check_Restriction (No_Secondary_Stack, N); | |
7059 | Set_Storage_Pool (N, RTE (RE_SS_Pool)); | |
535a8637 | 7060 | Set_Procedure_To_Call (N, RTE (RE_SS_Allocate)); |
2b3d67a5 AC |
7061 | end if; |
7062 | end if; | |
7063 | ||
54bf19e4 AC |
7064 | -- Implement the rules of 6.5(8-10), which require a tag check in |
7065 | -- the case of a limited tagged return type, and tag reassignment for | |
2b3d67a5 AC |
7066 | -- nonlimited tagged results. These actions are needed when the return |
7067 | -- type is a specific tagged type and the result expression is a | |
54bf19e4 AC |
7068 | -- conversion or a formal parameter, because in that case the tag of |
7069 | -- the expression might differ from the tag of the specific result type. | |
2b3d67a5 | 7070 | |
320fbd1e JS |
7071 | -- We must also verify an underlying type exists for the return type in |
7072 | -- case it is incomplete - in which case is not necessary to generate a | |
7073 | -- check anyway since an incomplete limited tagged return type would | |
7074 | -- qualify as a premature usage. | |
7075 | ||
7076 | if Present (Utyp) | |
7077 | and then Is_Tagged_Type (Utyp) | |
2b3d67a5 AC |
7078 | and then not Is_Class_Wide_Type (Utyp) |
7079 | and then (Nkind_In (Exp, N_Type_Conversion, | |
7080 | N_Unchecked_Type_Conversion) | |
7081 | or else (Is_Entity_Name (Exp) | |
bb6a856b | 7082 | and then Is_Formal (Entity (Exp)))) |
2b3d67a5 | 7083 | then |
54bf19e4 AC |
7084 | -- When the return type is limited, perform a check that the tag of |
7085 | -- the result is the same as the tag of the return type. | |
2b3d67a5 AC |
7086 | |
7087 | if Is_Limited_Type (R_Type) then | |
7088 | Insert_Action (Exp, | |
7089 | Make_Raise_Constraint_Error (Loc, | |
7090 | Condition => | |
7091 | Make_Op_Ne (Loc, | |
2c1b72d7 | 7092 | Left_Opnd => |
2b3d67a5 | 7093 | Make_Selected_Component (Loc, |
7675ad4f AC |
7094 | Prefix => Duplicate_Subexpr (Exp), |
7095 | Selector_Name => Make_Identifier (Loc, Name_uTag)), | |
2b3d67a5 AC |
7096 | Right_Opnd => |
7097 | Make_Attribute_Reference (Loc, | |
2c1b72d7 AC |
7098 | Prefix => |
7099 | New_Occurrence_Of (Base_Type (Utyp), Loc), | |
2b3d67a5 | 7100 | Attribute_Name => Name_Tag)), |
2c1b72d7 | 7101 | Reason => CE_Tag_Check_Failed)); |
2b3d67a5 AC |
7102 | |
7103 | -- If the result type is a specific nonlimited tagged type, then we | |
7104 | -- have to ensure that the tag of the result is that of the result | |
54bf19e4 AC |
7105 | -- type. This is handled by making a copy of the expression in |
7106 | -- the case where it might have a different tag, namely when the | |
2b3d67a5 AC |
7107 | -- expression is a conversion or a formal parameter. We create a new |
7108 | -- object of the result type and initialize it from the expression, | |
7109 | -- which will implicitly force the tag to be set appropriately. | |
7110 | ||
7111 | else | |
7112 | declare | |
7113 | ExpR : constant Node_Id := Relocate_Node (Exp); | |
7114 | Result_Id : constant Entity_Id := | |
7115 | Make_Temporary (Loc, 'R', ExpR); | |
7116 | Result_Exp : constant Node_Id := | |
e4494292 | 7117 | New_Occurrence_Of (Result_Id, Loc); |
2b3d67a5 AC |
7118 | Result_Obj : constant Node_Id := |
7119 | Make_Object_Declaration (Loc, | |
7120 | Defining_Identifier => Result_Id, | |
7121 | Object_Definition => | |
e4494292 | 7122 | New_Occurrence_Of (R_Type, Loc), |
2b3d67a5 AC |
7123 | Constant_Present => True, |
7124 | Expression => ExpR); | |
7125 | ||
7126 | begin | |
7127 | Set_Assignment_OK (Result_Obj); | |
7128 | Insert_Action (Exp, Result_Obj); | |
7129 | ||
7130 | Rewrite (Exp, Result_Exp); | |
7131 | Analyze_And_Resolve (Exp, R_Type); | |
7132 | end; | |
7133 | end if; | |
7134 | ||
7135 | -- Ada 2005 (AI-344): If the result type is class-wide, then insert | |
7136 | -- a check that the level of the return expression's underlying type | |
7137 | -- is not deeper than the level of the master enclosing the function. | |
7138 | -- Always generate the check when the type of the return expression | |
7139 | -- is class-wide, when it's a type conversion, or when it's a formal | |
7140 | -- parameter. Otherwise, suppress the check in the case where the | |
7141 | -- return expression has a specific type whose level is known not to | |
7142 | -- be statically deeper than the function's result type. | |
7143 | ||
0a376301 JM |
7144 | -- No runtime check needed in interface thunks since it is performed |
7145 | -- by the target primitive associated with the thunk. | |
7146 | ||
2b3d67a5 AC |
7147 | -- Note: accessibility check is skipped in the VM case, since there |
7148 | -- does not seem to be any practical way to implement this check. | |
7149 | ||
0791fbe9 | 7150 | elsif Ada_Version >= Ada_2005 |
2b3d67a5 AC |
7151 | and then Tagged_Type_Expansion |
7152 | and then Is_Class_Wide_Type (R_Type) | |
0a376301 | 7153 | and then not Is_Thunk (Current_Scope) |
3217f71e | 7154 | and then not Scope_Suppress.Suppress (Accessibility_Check) |
2b3d67a5 AC |
7155 | and then |
7156 | (Is_Class_Wide_Type (Etype (Exp)) | |
7157 | or else Nkind_In (Exp, N_Type_Conversion, | |
7158 | N_Unchecked_Type_Conversion) | |
7159 | or else (Is_Entity_Name (Exp) | |
bb6a856b | 7160 | and then Is_Formal (Entity (Exp))) |
2b3d67a5 AC |
7161 | or else Scope_Depth (Enclosing_Dynamic_Scope (Etype (Exp))) > |
7162 | Scope_Depth (Enclosing_Dynamic_Scope (Scope_Id))) | |
7163 | then | |
7164 | declare | |
7165 | Tag_Node : Node_Id; | |
7166 | ||
7167 | begin | |
7168 | -- Ada 2005 (AI-251): In class-wide interface objects we displace | |
c5f5123f AC |
7169 | -- "this" to reference the base of the object. This is required to |
7170 | -- get access to the TSD of the object. | |
2b3d67a5 AC |
7171 | |
7172 | if Is_Class_Wide_Type (Etype (Exp)) | |
7173 | and then Is_Interface (Etype (Exp)) | |
2b3d67a5 | 7174 | then |
47a6f660 AC |
7175 | -- If the expression is an explicit dereference then we can |
7176 | -- directly displace the pointer to reference the base of | |
7177 | -- the object. | |
7178 | ||
7179 | if Nkind (Exp) = N_Explicit_Dereference then | |
7180 | Tag_Node := | |
7181 | Make_Explicit_Dereference (Loc, | |
7182 | Prefix => | |
7183 | Unchecked_Convert_To (RTE (RE_Tag_Ptr), | |
7184 | Make_Function_Call (Loc, | |
7185 | Name => | |
7186 | New_Occurrence_Of (RTE (RE_Base_Address), Loc), | |
7187 | Parameter_Associations => New_List ( | |
7188 | Unchecked_Convert_To (RTE (RE_Address), | |
7189 | Duplicate_Subexpr (Prefix (Exp))))))); | |
7190 | ||
7191 | -- Similar case to the previous one but the expression is a | |
7192 | -- renaming of an explicit dereference. | |
7193 | ||
7194 | elsif Nkind (Exp) = N_Identifier | |
7195 | and then Present (Renamed_Object (Entity (Exp))) | |
7196 | and then Nkind (Renamed_Object (Entity (Exp))) | |
7197 | = N_Explicit_Dereference | |
7198 | then | |
7199 | Tag_Node := | |
7200 | Make_Explicit_Dereference (Loc, | |
7201 | Prefix => | |
7202 | Unchecked_Convert_To (RTE (RE_Tag_Ptr), | |
7203 | Make_Function_Call (Loc, | |
7204 | Name => | |
7205 | New_Occurrence_Of (RTE (RE_Base_Address), Loc), | |
7206 | Parameter_Associations => New_List ( | |
7207 | Unchecked_Convert_To (RTE (RE_Address), | |
7208 | Duplicate_Subexpr | |
7209 | (Prefix | |
7210 | (Renamed_Object (Entity (Exp))))))))); | |
7211 | ||
7212 | -- Common case: obtain the address of the actual object and | |
7213 | -- displace the pointer to reference the base of the object. | |
7214 | ||
7215 | else | |
7216 | Tag_Node := | |
7217 | Make_Explicit_Dereference (Loc, | |
7218 | Prefix => | |
7219 | Unchecked_Convert_To (RTE (RE_Tag_Ptr), | |
7220 | Make_Function_Call (Loc, | |
7221 | Name => | |
7222 | New_Occurrence_Of (RTE (RE_Base_Address), Loc), | |
7223 | Parameter_Associations => New_List ( | |
7224 | Make_Attribute_Reference (Loc, | |
7225 | Prefix => Duplicate_Subexpr (Exp), | |
7226 | Attribute_Name => Name_Address))))); | |
7227 | end if; | |
2b3d67a5 AC |
7228 | else |
7229 | Tag_Node := | |
7230 | Make_Attribute_Reference (Loc, | |
2c1b72d7 | 7231 | Prefix => Duplicate_Subexpr (Exp), |
2b3d67a5 AC |
7232 | Attribute_Name => Name_Tag); |
7233 | end if; | |
7234 | ||
c6840e83 AC |
7235 | -- CodePeer does not do anything useful with |
7236 | -- Ada.Tags.Type_Specific_Data components. | |
f2a54683 | 7237 | |
c6840e83 | 7238 | if not CodePeer_Mode then |
f2a54683 AC |
7239 | Insert_Action (Exp, |
7240 | Make_Raise_Program_Error (Loc, | |
7241 | Condition => | |
7242 | Make_Op_Gt (Loc, | |
7243 | Left_Opnd => Build_Get_Access_Level (Loc, Tag_Node), | |
7244 | Right_Opnd => | |
7245 | Make_Integer_Literal (Loc, | |
7246 | Scope_Depth (Enclosing_Dynamic_Scope (Scope_Id)))), | |
c6840e83 | 7247 | Reason => PE_Accessibility_Check_Failed)); |
f2a54683 | 7248 | end if; |
2b3d67a5 AC |
7249 | end; |
7250 | ||
7251 | -- AI05-0073: If function has a controlling access result, check that | |
7252 | -- the tag of the return value, if it is not null, matches designated | |
7253 | -- type of return type. | |
f7ea2603 RD |
7254 | |
7255 | -- The return expression is referenced twice in the code below, so it | |
7256 | -- must be made free of side effects. Given that different compilers | |
2b3d67a5 AC |
7257 | -- may evaluate these parameters in different order, both occurrences |
7258 | -- perform a copy. | |
7259 | ||
7260 | elsif Ekind (R_Type) = E_Anonymous_Access_Type | |
7261 | and then Has_Controlling_Result (Scope_Id) | |
7262 | then | |
7263 | Insert_Action (N, | |
7264 | Make_Raise_Constraint_Error (Loc, | |
7265 | Condition => | |
7266 | Make_And_Then (Loc, | |
7267 | Left_Opnd => | |
7268 | Make_Op_Ne (Loc, | |
7269 | Left_Opnd => Duplicate_Subexpr (Exp), | |
7270 | Right_Opnd => Make_Null (Loc)), | |
ebf494ec | 7271 | |
2b3d67a5 AC |
7272 | Right_Opnd => Make_Op_Ne (Loc, |
7273 | Left_Opnd => | |
7274 | Make_Selected_Component (Loc, | |
7275 | Prefix => Duplicate_Subexpr (Exp), | |
7675ad4f | 7276 | Selector_Name => Make_Identifier (Loc, Name_uTag)), |
ebf494ec | 7277 | |
2b3d67a5 AC |
7278 | Right_Opnd => |
7279 | Make_Attribute_Reference (Loc, | |
7280 | Prefix => | |
7281 | New_Occurrence_Of (Designated_Type (R_Type), Loc), | |
7282 | Attribute_Name => Name_Tag))), | |
ebf494ec | 7283 | |
2b3d67a5 AC |
7284 | Reason => CE_Tag_Check_Failed), |
7285 | Suppress => All_Checks); | |
7286 | end if; | |
7287 | ||
63585f75 SB |
7288 | -- AI05-0234: RM 6.5(21/3). Check access discriminants to |
7289 | -- ensure that the function result does not outlive an | |
7290 | -- object designated by one of it discriminants. | |
7291 | ||
57a3fca9 | 7292 | if Present (Extra_Accessibility_Of_Result (Scope_Id)) |
63585f75 SB |
7293 | and then Has_Unconstrained_Access_Discriminants (R_Type) |
7294 | then | |
7295 | declare | |
ebf494ec | 7296 | Discrim_Source : Node_Id; |
63585f75 SB |
7297 | |
7298 | procedure Check_Against_Result_Level (Level : Node_Id); | |
ebf494ec RD |
7299 | -- Check the given accessibility level against the level |
7300 | -- determined by the point of call. (AI05-0234). | |
63585f75 SB |
7301 | |
7302 | -------------------------------- | |
7303 | -- Check_Against_Result_Level -- | |
7304 | -------------------------------- | |
7305 | ||
7306 | procedure Check_Against_Result_Level (Level : Node_Id) is | |
7307 | begin | |
7308 | Insert_Action (N, | |
7309 | Make_Raise_Program_Error (Loc, | |
7310 | Condition => | |
7311 | Make_Op_Gt (Loc, | |
7312 | Left_Opnd => Level, | |
7313 | Right_Opnd => | |
7314 | New_Occurrence_Of | |
7315 | (Extra_Accessibility_Of_Result (Scope_Id), Loc)), | |
7316 | Reason => PE_Accessibility_Check_Failed)); | |
7317 | end Check_Against_Result_Level; | |
ebf494ec | 7318 | |
63585f75 | 7319 | begin |
ebf494ec | 7320 | Discrim_Source := Exp; |
63585f75 SB |
7321 | while Nkind (Discrim_Source) = N_Qualified_Expression loop |
7322 | Discrim_Source := Expression (Discrim_Source); | |
7323 | end loop; | |
7324 | ||
7325 | if Nkind (Discrim_Source) = N_Identifier | |
7326 | and then Is_Return_Object (Entity (Discrim_Source)) | |
7327 | then | |
63585f75 SB |
7328 | Discrim_Source := Entity (Discrim_Source); |
7329 | ||
7330 | if Is_Constrained (Etype (Discrim_Source)) then | |
7331 | Discrim_Source := Etype (Discrim_Source); | |
7332 | else | |
7333 | Discrim_Source := Expression (Parent (Discrim_Source)); | |
7334 | end if; | |
7335 | ||
7336 | elsif Nkind (Discrim_Source) = N_Identifier | |
7337 | and then Nkind_In (Original_Node (Discrim_Source), | |
7338 | N_Aggregate, N_Extension_Aggregate) | |
7339 | then | |
63585f75 SB |
7340 | Discrim_Source := Original_Node (Discrim_Source); |
7341 | ||
7342 | elsif Nkind (Discrim_Source) = N_Explicit_Dereference and then | |
7343 | Nkind (Original_Node (Discrim_Source)) = N_Function_Call | |
7344 | then | |
63585f75 | 7345 | Discrim_Source := Original_Node (Discrim_Source); |
63585f75 SB |
7346 | end if; |
7347 | ||
0691ed6b | 7348 | Discrim_Source := Unqual_Conv (Discrim_Source); |
63585f75 SB |
7349 | |
7350 | case Nkind (Discrim_Source) is | |
7351 | when N_Defining_Identifier => | |
54bf19e4 AC |
7352 | pragma Assert (Is_Composite_Type (Discrim_Source) |
7353 | and then Has_Discriminants (Discrim_Source) | |
7354 | and then Is_Constrained (Discrim_Source)); | |
63585f75 SB |
7355 | |
7356 | declare | |
7357 | Discrim : Entity_Id := | |
7358 | First_Discriminant (Base_Type (R_Type)); | |
7359 | Disc_Elmt : Elmt_Id := | |
7360 | First_Elmt (Discriminant_Constraint | |
7361 | (Discrim_Source)); | |
7362 | begin | |
7363 | loop | |
7364 | if Ekind (Etype (Discrim)) = | |
54bf19e4 AC |
7365 | E_Anonymous_Access_Type |
7366 | then | |
63585f75 SB |
7367 | Check_Against_Result_Level |
7368 | (Dynamic_Accessibility_Level (Node (Disc_Elmt))); | |
7369 | end if; | |
7370 | ||
7371 | Next_Elmt (Disc_Elmt); | |
7372 | Next_Discriminant (Discrim); | |
7373 | exit when not Present (Discrim); | |
7374 | end loop; | |
7375 | end; | |
7376 | ||
d8f43ee6 HK |
7377 | when N_Aggregate |
7378 | | N_Extension_Aggregate | |
7379 | => | |
54bf19e4 AC |
7380 | -- Unimplemented: extension aggregate case where discrims |
7381 | -- come from ancestor part, not extension part. | |
63585f75 SB |
7382 | |
7383 | declare | |
7384 | Discrim : Entity_Id := | |
7385 | First_Discriminant (Base_Type (R_Type)); | |
7386 | ||
7387 | Disc_Exp : Node_Id := Empty; | |
7388 | ||
7389 | Positionals_Exhausted | |
7390 | : Boolean := not Present (Expressions | |
7391 | (Discrim_Source)); | |
7392 | ||
7393 | function Associated_Expr | |
7394 | (Comp_Id : Entity_Id; | |
7395 | Associations : List_Id) return Node_Id; | |
7396 | ||
7397 | -- Given a component and a component associations list, | |
7398 | -- locate the expression for that component; returns | |
7399 | -- Empty if no such expression is found. | |
7400 | ||
7401 | --------------------- | |
7402 | -- Associated_Expr -- | |
7403 | --------------------- | |
7404 | ||
7405 | function Associated_Expr | |
7406 | (Comp_Id : Entity_Id; | |
7407 | Associations : List_Id) return Node_Id | |
7408 | is | |
54bf19e4 | 7409 | Assoc : Node_Id; |
63585f75 | 7410 | Choice : Node_Id; |
54bf19e4 | 7411 | |
63585f75 SB |
7412 | begin |
7413 | -- Simple linear search seems ok here | |
7414 | ||
54bf19e4 | 7415 | Assoc := First (Associations); |
63585f75 SB |
7416 | while Present (Assoc) loop |
7417 | Choice := First (Choices (Assoc)); | |
63585f75 SB |
7418 | while Present (Choice) loop |
7419 | if (Nkind (Choice) = N_Identifier | |
54bf19e4 AC |
7420 | and then Chars (Choice) = Chars (Comp_Id)) |
7421 | or else (Nkind (Choice) = N_Others_Choice) | |
63585f75 SB |
7422 | then |
7423 | return Expression (Assoc); | |
7424 | end if; | |
7425 | ||
7426 | Next (Choice); | |
7427 | end loop; | |
7428 | ||
7429 | Next (Assoc); | |
7430 | end loop; | |
7431 | ||
7432 | return Empty; | |
7433 | end Associated_Expr; | |
7434 | ||
63585f75 SB |
7435 | begin |
7436 | if not Positionals_Exhausted then | |
7437 | Disc_Exp := First (Expressions (Discrim_Source)); | |
7438 | end if; | |
7439 | ||
7440 | loop | |
7441 | if Positionals_Exhausted then | |
54bf19e4 AC |
7442 | Disc_Exp := |
7443 | Associated_Expr | |
7444 | (Discrim, | |
7445 | Component_Associations (Discrim_Source)); | |
63585f75 SB |
7446 | end if; |
7447 | ||
7448 | if Ekind (Etype (Discrim)) = | |
54bf19e4 AC |
7449 | E_Anonymous_Access_Type |
7450 | then | |
63585f75 SB |
7451 | Check_Against_Result_Level |
7452 | (Dynamic_Accessibility_Level (Disc_Exp)); | |
7453 | end if; | |
7454 | ||
7455 | Next_Discriminant (Discrim); | |
7456 | exit when not Present (Discrim); | |
7457 | ||
7458 | if not Positionals_Exhausted then | |
7459 | Next (Disc_Exp); | |
7460 | Positionals_Exhausted := not Present (Disc_Exp); | |
7461 | end if; | |
7462 | end loop; | |
7463 | end; | |
7464 | ||
7465 | when N_Function_Call => | |
54bf19e4 AC |
7466 | |
7467 | -- No check needed (check performed by callee) | |
7468 | ||
63585f75 SB |
7469 | null; |
7470 | ||
7471 | when others => | |
63585f75 SB |
7472 | declare |
7473 | Level : constant Node_Id := | |
54bf19e4 AC |
7474 | Make_Integer_Literal (Loc, |
7475 | Object_Access_Level (Discrim_Source)); | |
7476 | ||
63585f75 SB |
7477 | begin |
7478 | -- Unimplemented: check for name prefix that includes | |
7479 | -- a dereference of an access value with a dynamic | |
7480 | -- accessibility level (e.g., an access param or a | |
7481 | -- saooaaat) and use dynamic level in that case. For | |
7482 | -- example: | |
7483 | -- return Access_Param.all(Some_Index).Some_Component; | |
54bf19e4 | 7484 | -- ??? |
63585f75 SB |
7485 | |
7486 | Set_Etype (Level, Standard_Natural); | |
7487 | Check_Against_Result_Level (Level); | |
7488 | end; | |
63585f75 SB |
7489 | end case; |
7490 | end; | |
7491 | end if; | |
7492 | ||
00907026 EB |
7493 | -- If we are returning a nonscalar object that is possibly unaligned, |
7494 | -- then copy the value into a temporary first. This copy may need to | |
7495 | -- expand to a loop of component operations. | |
2b3d67a5 AC |
7496 | |
7497 | if Is_Possibly_Unaligned_Slice (Exp) | |
00907026 EB |
7498 | or else (Is_Possibly_Unaligned_Object (Exp) |
7499 | and then not Represented_As_Scalar (Etype (Exp))) | |
2b3d67a5 AC |
7500 | then |
7501 | declare | |
7502 | ExpR : constant Node_Id := Relocate_Node (Exp); | |
7503 | Tnn : constant Entity_Id := Make_Temporary (Loc, 'T', ExpR); | |
7504 | begin | |
7505 | Insert_Action (Exp, | |
7506 | Make_Object_Declaration (Loc, | |
7507 | Defining_Identifier => Tnn, | |
7508 | Constant_Present => True, | |
7509 | Object_Definition => New_Occurrence_Of (R_Type, Loc), | |
7510 | Expression => ExpR), | |
2c1b72d7 | 7511 | Suppress => All_Checks); |
2b3d67a5 AC |
7512 | Rewrite (Exp, New_Occurrence_Of (Tnn, Loc)); |
7513 | end; | |
7514 | end if; | |
7515 | ||
c9d70ab1 AC |
7516 | -- Call the _Postconditions procedure if the related function has |
7517 | -- contract assertions that need to be verified on exit. | |
2b3d67a5 AC |
7518 | |
7519 | if Ekind (Scope_Id) = E_Function | |
c9d70ab1 | 7520 | and then Present (Postconditions_Proc (Scope_Id)) |
2b3d67a5 | 7521 | then |
c8593453 AC |
7522 | -- In the case of discriminated objects, we have created a |
7523 | -- constrained subtype above, and used the underlying type. This | |
7524 | -- transformation is post-analysis and harmless, except that now the | |
7525 | -- call to the post-condition will be analyzed and the type kinds | |
7526 | -- have to match. | |
7527 | ||
7528 | if Nkind (Exp) = N_Unchecked_Type_Conversion | |
7529 | and then Is_Private_Type (R_Type) /= Is_Private_Type (Etype (Exp)) | |
2b3d67a5 | 7530 | then |
c8593453 AC |
7531 | Rewrite (Exp, Expression (Relocate_Node (Exp))); |
7532 | end if; | |
2b3d67a5 | 7533 | |
c8593453 AC |
7534 | -- We are going to reference the returned value twice in this case, |
7535 | -- once in the call to _Postconditions, and once in the actual return | |
7536 | -- statement, but we can't have side effects happening twice. | |
2b3d67a5 | 7537 | |
89d3b1a1 | 7538 | Force_Evaluation (Exp, Mode => Strict); |
2b3d67a5 | 7539 | |
c9d70ab1 | 7540 | -- Generate call to _Postconditions |
2b3d67a5 AC |
7541 | |
7542 | Insert_Action (Exp, | |
7543 | Make_Procedure_Call_Statement (Loc, | |
c9d70ab1 AC |
7544 | Name => |
7545 | New_Occurrence_Of (Postconditions_Proc (Scope_Id), Loc), | |
c8593453 | 7546 | Parameter_Associations => New_List (New_Copy_Tree (Exp)))); |
2b3d67a5 AC |
7547 | end if; |
7548 | ||
7549 | -- Ada 2005 (AI-251): If this return statement corresponds with an | |
7550 | -- simple return statement associated with an extended return statement | |
7551 | -- and the type of the returned object is an interface then generate an | |
7552 | -- implicit conversion to force displacement of the "this" pointer. | |
7553 | ||
0791fbe9 | 7554 | if Ada_Version >= Ada_2005 |
2b3d67a5 AC |
7555 | and then Comes_From_Extended_Return_Statement (N) |
7556 | and then Nkind (Expression (N)) = N_Identifier | |
7557 | and then Is_Interface (Utyp) | |
7558 | and then Utyp /= Underlying_Type (Exptyp) | |
7559 | then | |
7560 | Rewrite (Exp, Convert_To (Utyp, Relocate_Node (Exp))); | |
7561 | Analyze_And_Resolve (Exp); | |
7562 | end if; | |
7563 | end Expand_Simple_Function_Return; | |
7564 | ||
02822a92 RD |
7565 | ----------------------- |
7566 | -- Freeze_Subprogram -- | |
7567 | ----------------------- | |
758c442c | 7568 | |
02822a92 RD |
7569 | procedure Freeze_Subprogram (N : Node_Id) is |
7570 | Loc : constant Source_Ptr := Sloc (N); | |
3ca505dc | 7571 | |
02822a92 RD |
7572 | procedure Register_Predefined_DT_Entry (Prim : Entity_Id); |
7573 | -- (Ada 2005): Register a predefined primitive in all the secondary | |
7574 | -- dispatch tables of its primitive type. | |
3ca505dc | 7575 | |
f4d379b8 HK |
7576 | ---------------------------------- |
7577 | -- Register_Predefined_DT_Entry -- | |
7578 | ---------------------------------- | |
7579 | ||
7580 | procedure Register_Predefined_DT_Entry (Prim : Entity_Id) is | |
7581 | Iface_DT_Ptr : Elmt_Id; | |
02822a92 | 7582 | Tagged_Typ : Entity_Id; |
f4d379b8 | 7583 | Thunk_Id : Entity_Id; |
7888a6ae | 7584 | Thunk_Code : Node_Id; |
f4d379b8 HK |
7585 | |
7586 | begin | |
02822a92 | 7587 | Tagged_Typ := Find_Dispatching_Type (Prim); |
f4d379b8 | 7588 | |
02822a92 | 7589 | if No (Access_Disp_Table (Tagged_Typ)) |
ce2b6ba5 | 7590 | or else not Has_Interfaces (Tagged_Typ) |
c8ef728f | 7591 | or else not RTE_Available (RE_Interface_Tag) |
f937473f | 7592 | or else Restriction_Active (No_Dispatching_Calls) |
f4d379b8 HK |
7593 | then |
7594 | return; | |
7595 | end if; | |
7596 | ||
1923d2d6 JM |
7597 | -- Skip the first two access-to-dispatch-table pointers since they |
7598 | -- leads to the primary dispatch table (predefined DT and user | |
7599 | -- defined DT). We are only concerned with the secondary dispatch | |
7600 | -- table pointers. Note that the access-to- dispatch-table pointer | |
7601 | -- corresponds to the first implemented interface retrieved below. | |
f4d379b8 | 7602 | |
02822a92 | 7603 | Iface_DT_Ptr := |
1923d2d6 | 7604 | Next_Elmt (Next_Elmt (First_Elmt (Access_Disp_Table (Tagged_Typ)))); |
f937473f | 7605 | |
7888a6ae | 7606 | while Present (Iface_DT_Ptr) |
df3e68b1 | 7607 | and then Ekind (Node (Iface_DT_Ptr)) = E_Constant |
7888a6ae | 7608 | loop |
ac4d6407 | 7609 | pragma Assert (Has_Thunks (Node (Iface_DT_Ptr))); |
20dc266e JM |
7610 | Expand_Interface_Thunk (Prim, Thunk_Id, Thunk_Code, |
7611 | Iface => Related_Type (Node (Iface_DT_Ptr))); | |
7888a6ae GD |
7612 | |
7613 | if Present (Thunk_Code) then | |
ac4d6407 | 7614 | Insert_Actions_After (N, New_List ( |
7888a6ae GD |
7615 | Thunk_Code, |
7616 | ||
7617 | Build_Set_Predefined_Prim_Op_Address (Loc, | |
54bf19e4 | 7618 | Tag_Node => |
e4494292 | 7619 | New_Occurrence_Of (Node (Next_Elmt (Iface_DT_Ptr)), Loc), |
54bf19e4 | 7620 | Position => DT_Position (Prim), |
7888a6ae | 7621 | Address_Node => |
70f91180 | 7622 | Unchecked_Convert_To (RTE (RE_Prim_Ptr), |
1923d2d6 | 7623 | Make_Attribute_Reference (Loc, |
e4494292 | 7624 | Prefix => New_Occurrence_Of (Thunk_Id, Loc), |
1923d2d6 | 7625 | Attribute_Name => Name_Unrestricted_Access))), |
ac4d6407 RD |
7626 | |
7627 | Build_Set_Predefined_Prim_Op_Address (Loc, | |
54bf19e4 | 7628 | Tag_Node => |
e4494292 | 7629 | New_Occurrence_Of |
1923d2d6 JM |
7630 | (Node (Next_Elmt (Next_Elmt (Next_Elmt (Iface_DT_Ptr)))), |
7631 | Loc), | |
54bf19e4 | 7632 | Position => DT_Position (Prim), |
ac4d6407 | 7633 | Address_Node => |
70f91180 | 7634 | Unchecked_Convert_To (RTE (RE_Prim_Ptr), |
1923d2d6 | 7635 | Make_Attribute_Reference (Loc, |
e4494292 | 7636 | Prefix => New_Occurrence_Of (Prim, Loc), |
1923d2d6 | 7637 | Attribute_Name => Name_Unrestricted_Access))))); |
7888a6ae | 7638 | end if; |
f4d379b8 | 7639 | |
1923d2d6 JM |
7640 | -- Skip the tag of the predefined primitives dispatch table |
7641 | ||
7642 | Next_Elmt (Iface_DT_Ptr); | |
7643 | pragma Assert (Has_Thunks (Node (Iface_DT_Ptr))); | |
7644 | ||
54bf19e4 | 7645 | -- Skip tag of the no-thunks dispatch table |
1923d2d6 JM |
7646 | |
7647 | Next_Elmt (Iface_DT_Ptr); | |
7648 | pragma Assert (not Has_Thunks (Node (Iface_DT_Ptr))); | |
7649 | ||
54bf19e4 | 7650 | -- Skip tag of predefined primitives no-thunks dispatch table |
1923d2d6 | 7651 | |
ac4d6407 RD |
7652 | Next_Elmt (Iface_DT_Ptr); |
7653 | pragma Assert (not Has_Thunks (Node (Iface_DT_Ptr))); | |
7654 | ||
f4d379b8 | 7655 | Next_Elmt (Iface_DT_Ptr); |
f4d379b8 HK |
7656 | end loop; |
7657 | end Register_Predefined_DT_Entry; | |
7658 | ||
7888a6ae | 7659 | -- Local variables |
3ca505dc | 7660 | |
df3e68b1 | 7661 | Subp : constant Entity_Id := Entity (N); |
3ca505dc | 7662 | |
ac4d6407 RD |
7663 | -- Start of processing for Freeze_Subprogram |
7664 | ||
7888a6ae | 7665 | begin |
d766cee3 | 7666 | -- We suppress the initialization of the dispatch table entry when |
535a8637 AC |
7667 | -- not Tagged_Type_Expansion because the dispatching mechanism is |
7668 | -- handled internally by the target. | |
d766cee3 RD |
7669 | |
7670 | if Is_Dispatching_Operation (Subp) | |
7671 | and then not Is_Abstract_Subprogram (Subp) | |
7672 | and then Present (DTC_Entity (Subp)) | |
7673 | and then Present (Scope (DTC_Entity (Subp))) | |
1f110335 | 7674 | and then Tagged_Type_Expansion |
d766cee3 RD |
7675 | and then not Restriction_Active (No_Dispatching_Calls) |
7676 | and then RTE_Available (RE_Tag) | |
7677 | then | |
7888a6ae | 7678 | declare |
d766cee3 | 7679 | Typ : constant Entity_Id := Scope (DTC_Entity (Subp)); |
c8ef728f | 7680 | |
7888a6ae | 7681 | begin |
8fc789c8 | 7682 | -- Handle private overridden primitives |
c8ef728f | 7683 | |
d766cee3 RD |
7684 | if not Is_CPP_Class (Typ) then |
7685 | Check_Overriding_Operation (Subp); | |
7888a6ae | 7686 | end if; |
c8ef728f | 7687 | |
d766cee3 RD |
7688 | -- We assume that imported CPP primitives correspond with objects |
7689 | -- whose constructor is in the CPP side; therefore we don't need | |
7690 | -- to generate code to register them in the dispatch table. | |
c8ef728f | 7691 | |
d766cee3 RD |
7692 | if Is_CPP_Class (Typ) then |
7693 | null; | |
3ca505dc | 7694 | |
d766cee3 RD |
7695 | -- Handle CPP primitives found in derivations of CPP_Class types. |
7696 | -- These primitives must have been inherited from some parent, and | |
7697 | -- there is no need to register them in the dispatch table because | |
5b6f12c7 | 7698 | -- Build_Inherit_Prims takes care of initializing these slots. |
3ca505dc | 7699 | |
d766cee3 | 7700 | elsif Is_Imported (Subp) |
54bf19e4 AC |
7701 | and then (Convention (Subp) = Convention_CPP |
7702 | or else Convention (Subp) = Convention_C) | |
d766cee3 RD |
7703 | then |
7704 | null; | |
7705 | ||
7706 | -- Generate code to register the primitive in non statically | |
7707 | -- allocated dispatch tables | |
7708 | ||
bfae1846 AC |
7709 | elsif not Building_Static_DT (Scope (DTC_Entity (Subp))) then |
7710 | ||
d766cee3 RD |
7711 | -- When a primitive is frozen, enter its name in its dispatch |
7712 | -- table slot. | |
f4d379b8 | 7713 | |
d766cee3 | 7714 | if not Is_Interface (Typ) |
ce2b6ba5 | 7715 | or else Present (Interface_Alias (Subp)) |
d766cee3 RD |
7716 | then |
7717 | if Is_Predefined_Dispatching_Operation (Subp) then | |
7718 | Register_Predefined_DT_Entry (Subp); | |
7888a6ae | 7719 | end if; |
d766cee3 | 7720 | |
991395ab AC |
7721 | Insert_Actions_After (N, |
7722 | Register_Primitive (Loc, Prim => Subp)); | |
7888a6ae GD |
7723 | end if; |
7724 | end if; | |
7725 | end; | |
70482933 RK |
7726 | end if; |
7727 | ||
7888a6ae GD |
7728 | -- Mark functions that return by reference. Note that it cannot be part |
7729 | -- of the normal semantic analysis of the spec since the underlying | |
7730 | -- returned type may not be known yet (for private types). | |
70482933 | 7731 | |
d766cee3 RD |
7732 | declare |
7733 | Typ : constant Entity_Id := Etype (Subp); | |
7734 | Utyp : constant Entity_Id := Underlying_Type (Typ); | |
d6e1090a | 7735 | |
d766cee3 | 7736 | begin |
51245e2d | 7737 | if Is_Limited_View (Typ) then |
d766cee3 | 7738 | Set_Returns_By_Ref (Subp); |
d6e1090a | 7739 | |
048e5cef | 7740 | elsif Present (Utyp) and then CW_Or_Has_Controlled_Part (Utyp) then |
d766cee3 RD |
7741 | Set_Returns_By_Ref (Subp); |
7742 | end if; | |
7743 | end; | |
b546e2a7 AC |
7744 | |
7745 | -- Wnen freezing a null procedure, analyze its delayed aspects now | |
7746 | -- because we may not have reached the end of the declarative list when | |
7747 | -- delayed aspects are normally analyzed. This ensures that dispatching | |
7748 | -- calls are properly rewritten when the generated _Postcondition | |
7749 | -- procedure is analyzed in the null procedure body. | |
7750 | ||
7751 | if Nkind (Parent (Subp)) = N_Procedure_Specification | |
7752 | and then Null_Present (Parent (Subp)) | |
7753 | then | |
f99ff327 | 7754 | Analyze_Entry_Or_Subprogram_Contract (Subp); |
b546e2a7 | 7755 | end if; |
70482933 RK |
7756 | end Freeze_Subprogram; |
7757 | ||
7d1d3a54 HK |
7758 | -------------------------------------------- |
7759 | -- Has_Unconstrained_Access_Discriminants -- | |
7760 | -------------------------------------------- | |
7761 | ||
7762 | function Has_Unconstrained_Access_Discriminants | |
7763 | (Subtyp : Entity_Id) return Boolean | |
7764 | is | |
7765 | Discr : Entity_Id; | |
7766 | ||
7767 | begin | |
7768 | if Has_Discriminants (Subtyp) | |
7769 | and then not Is_Constrained (Subtyp) | |
7770 | then | |
7771 | Discr := First_Discriminant (Subtyp); | |
7772 | while Present (Discr) loop | |
7773 | if Ekind (Etype (Discr)) = E_Anonymous_Access_Type then | |
7774 | return True; | |
7775 | end if; | |
7776 | ||
7777 | Next_Discriminant (Discr); | |
7778 | end loop; | |
7779 | end if; | |
7780 | ||
7781 | return False; | |
7782 | end Has_Unconstrained_Access_Discriminants; | |
7783 | ||
ca1f6b29 BD |
7784 | ------------------------------ |
7785 | -- Insert_Post_Call_Actions -- | |
7786 | ------------------------------ | |
7787 | ||
ec40b86c | 7788 | procedure Insert_Post_Call_Actions (N : Node_Id; Post_Call : List_Id) is |
40b4bc2d AC |
7789 | Context : constant Node_Id := Parent (N); |
7790 | ||
ca1f6b29 BD |
7791 | begin |
7792 | if Is_Empty_List (Post_Call) then | |
7793 | return; | |
7794 | end if; | |
7795 | ||
ec40b86c HK |
7796 | -- Cases where the call is not a member of a statement list. This |
7797 | -- includes the case where the call is an actual in another function | |
7798 | -- call or indexing, i.e. an expression context as well. | |
ca1f6b29 BD |
7799 | |
7800 | if not Is_List_Member (N) | |
40b4bc2d | 7801 | or else Nkind_In (Context, N_Function_Call, N_Indexed_Component) |
ca1f6b29 BD |
7802 | then |
7803 | -- In Ada 2012 the call may be a function call in an expression | |
ec40b86c HK |
7804 | -- (since OUT and IN OUT parameters are now allowed for such calls). |
7805 | -- The write-back of (in)-out parameters is handled by the back-end, | |
7806 | -- but the constraint checks generated when subtypes of formal and | |
7807 | -- actual don't match must be inserted in the form of assignments. | |
ca1f6b29 BD |
7808 | |
7809 | if Nkind (Original_Node (N)) = N_Function_Call then | |
7810 | pragma Assert (Ada_Version >= Ada_2012); | |
7811 | -- Functions with '[in] out' parameters are only allowed in Ada | |
7812 | -- 2012. | |
7813 | ||
7814 | -- We used to handle this by climbing up parents to a | |
7815 | -- non-statement/declaration and then simply making a call to | |
7816 | -- Insert_Actions_After (P, Post_Call), but that doesn't work | |
7817 | -- for Ada 2012. If we are in the middle of an expression, e.g. | |
7818 | -- the condition of an IF, this call would insert after the IF | |
ec40b86c HK |
7819 | -- statement, which is much too late to be doing the write back. |
7820 | -- For example: | |
ca1f6b29 BD |
7821 | |
7822 | -- if Clobber (X) then | |
7823 | -- Put_Line (X'Img); | |
7824 | -- else | |
7825 | -- goto Junk | |
7826 | -- end if; | |
7827 | ||
ec40b86c HK |
7828 | -- Now assume Clobber changes X, if we put the write back after |
7829 | -- the IF, the Put_Line gets the wrong value and the goto causes | |
7830 | -- the write back to be skipped completely. | |
ca1f6b29 BD |
7831 | |
7832 | -- To deal with this, we replace the call by | |
7833 | ||
7834 | -- do | |
7835 | -- Tnnn : constant function-result-type := function-call; | |
7836 | -- Post_Call actions | |
7837 | -- in | |
7838 | -- Tnnn; | |
7839 | -- end; | |
7840 | ||
7841 | declare | |
7842 | Loc : constant Source_Ptr := Sloc (N); | |
7843 | Tnnn : constant Entity_Id := Make_Temporary (Loc, 'T'); | |
7844 | FRTyp : constant Entity_Id := Etype (N); | |
7845 | Name : constant Node_Id := Relocate_Node (N); | |
7846 | ||
7847 | begin | |
7848 | Prepend_To (Post_Call, | |
7849 | Make_Object_Declaration (Loc, | |
7850 | Defining_Identifier => Tnnn, | |
7851 | Object_Definition => New_Occurrence_Of (FRTyp, Loc), | |
7852 | Constant_Present => True, | |
7853 | Expression => Name)); | |
7854 | ||
7855 | Rewrite (N, | |
7856 | Make_Expression_With_Actions (Loc, | |
7857 | Actions => Post_Call, | |
7858 | Expression => New_Occurrence_Of (Tnnn, Loc))); | |
7859 | ||
7860 | -- We don't want to just blindly call Analyze_And_Resolve | |
7861 | -- because that would cause unwanted recursion on the call. | |
7862 | -- So for a moment set the call as analyzed to prevent that | |
7863 | -- recursion, and get the rest analyzed properly, then reset | |
7864 | -- the analyzed flag, so our caller can continue. | |
7865 | ||
7866 | Set_Analyzed (Name, True); | |
7867 | Analyze_And_Resolve (N, FRTyp); | |
7868 | Set_Analyzed (Name, False); | |
7869 | end; | |
7870 | ||
ec40b86c HK |
7871 | -- If not the special Ada 2012 case of a function call, then we must |
7872 | -- have the triggering statement of a triggering alternative or an | |
7873 | -- entry call alternative, and we can add the post call stuff to the | |
7874 | -- corresponding statement list. | |
ca1f6b29 BD |
7875 | |
7876 | else | |
40b4bc2d AC |
7877 | pragma Assert (Nkind_In (Context, N_Entry_Call_Alternative, |
7878 | N_Triggering_Alternative)); | |
ca1f6b29 | 7879 | |
40b4bc2d AC |
7880 | if Is_Non_Empty_List (Statements (Context)) then |
7881 | Insert_List_Before_And_Analyze | |
7882 | (First (Statements (Context)), Post_Call); | |
7883 | else | |
7884 | Set_Statements (Context, Post_Call); | |
7885 | end if; | |
ca1f6b29 BD |
7886 | end if; |
7887 | ||
40b4bc2d AC |
7888 | -- A procedure call is always part of a declarative or statement list, |
7889 | -- however a function call may appear nested within a construct. Most | |
7890 | -- cases of function call nesting are handled in the special case above. | |
7891 | -- The only exception is when the function call acts as an actual in a | |
7892 | -- procedure call. In this case the function call is in a list, but the | |
7893 | -- post-call actions must be inserted after the procedure call. | |
7894 | ||
7895 | elsif Nkind (Context) = N_Procedure_Call_Statement then | |
7896 | Insert_Actions_After (Context, Post_Call); | |
7897 | ||
ec40b86c HK |
7898 | -- Otherwise, normal case where N is in a statement sequence, just put |
7899 | -- the post-call stuff after the call statement. | |
ca1f6b29 BD |
7900 | |
7901 | else | |
7902 | Insert_Actions_After (N, Post_Call); | |
7903 | end if; | |
7904 | end Insert_Post_Call_Actions; | |
7905 | ||
7d1d3a54 HK |
7906 | ----------------------------------- |
7907 | -- Is_Build_In_Place_Result_Type -- | |
7908 | ----------------------------------- | |
7909 | ||
7910 | function Is_Build_In_Place_Result_Type (Typ : Entity_Id) return Boolean is | |
7911 | begin | |
7912 | if not Expander_Active then | |
7913 | return False; | |
7914 | end if; | |
7915 | ||
7916 | -- In Ada 2005 all functions with an inherently limited return type | |
7917 | -- must be handled using a build-in-place profile, including the case | |
7918 | -- of a function with a limited interface result, where the function | |
7919 | -- may return objects of nonlimited descendants. | |
7920 | ||
7921 | if Is_Limited_View (Typ) then | |
7922 | return Ada_Version >= Ada_2005 and then not Debug_Flag_Dot_L; | |
7923 | ||
7924 | else | |
7925 | if Debug_Flag_Dot_9 then | |
7926 | return False; | |
7927 | end if; | |
7928 | ||
7929 | if Has_Interfaces (Typ) then | |
7930 | return False; | |
7931 | end if; | |
7932 | ||
7933 | declare | |
7934 | T : Entity_Id := Typ; | |
7935 | begin | |
7936 | -- For T'Class, return True if it's True for T. This is necessary | |
7937 | -- because a class-wide function might say "return F (...)", where | |
7938 | -- F returns the corresponding specific type. We need a loop in | |
7939 | -- case T is a subtype of a class-wide type. | |
7940 | ||
7941 | while Is_Class_Wide_Type (T) loop | |
7942 | T := Etype (T); | |
7943 | end loop; | |
7944 | ||
7945 | -- If this is a generic formal type in an instance, return True if | |
7946 | -- it's True for the generic actual type. | |
7947 | ||
7948 | if Nkind (Parent (T)) = N_Subtype_Declaration | |
7949 | and then Present (Generic_Parent_Type (Parent (T))) | |
7950 | then | |
7951 | T := Entity (Subtype_Indication (Parent (T))); | |
7952 | ||
7953 | if Present (Full_View (T)) then | |
7954 | T := Full_View (T); | |
7955 | end if; | |
7956 | end if; | |
7957 | ||
7958 | if Present (Underlying_Type (T)) then | |
7959 | T := Underlying_Type (T); | |
7960 | end if; | |
7961 | ||
7962 | declare | |
7963 | Result : Boolean; | |
7964 | -- So we can stop here in the debugger | |
7965 | begin | |
7966 | -- ???For now, enable build-in-place for a very narrow set of | |
7967 | -- controlled types. Change "if True" to "if False" to | |
7968 | -- experiment with more controlled types. Eventually, we might | |
7969 | -- like to enable build-in-place for all tagged types, all | |
7970 | -- types that need finalization, and all caller-unknown-size | |
7971 | -- types. | |
7972 | ||
7973 | if True then | |
7974 | Result := Is_Controlled (T) | |
7975 | and then Present (Enclosing_Subprogram (T)) | |
7976 | and then not Is_Compilation_Unit (Enclosing_Subprogram (T)) | |
7977 | and then Ekind (Enclosing_Subprogram (T)) = E_Procedure; | |
7978 | else | |
7979 | Result := Is_Controlled (T); | |
7980 | end if; | |
7981 | ||
7982 | return Result; | |
7983 | end; | |
7984 | end; | |
7985 | end if; | |
7986 | end Is_Build_In_Place_Result_Type; | |
7987 | ||
7988 | -------------------------------- | |
7989 | -- Is_Build_In_Place_Function -- | |
7990 | -------------------------------- | |
7991 | ||
7992 | function Is_Build_In_Place_Function (E : Entity_Id) return Boolean is | |
7993 | begin | |
7994 | -- This function is called from Expand_Subtype_From_Expr during | |
7995 | -- semantic analysis, even when expansion is off. In those cases | |
7996 | -- the build_in_place expansion will not take place. | |
7997 | ||
7998 | if not Expander_Active then | |
7999 | return False; | |
8000 | end if; | |
8001 | ||
8002 | -- For now we test whether E denotes a function or access-to-function | |
8003 | -- type whose result subtype is inherently limited. Later this test | |
adc81ec8 | 8004 | -- may be revised to allow composite nonlimited types. |
7d1d3a54 HK |
8005 | |
8006 | if Ekind_In (E, E_Function, E_Generic_Function) | |
8007 | or else (Ekind (E) = E_Subprogram_Type | |
8008 | and then Etype (E) /= Standard_Void_Type) | |
8009 | then | |
adc81ec8 BD |
8010 | -- If the function is imported from a foreign language, we don't do |
8011 | -- build-in-place. Note that Import (Ada) functions can do | |
8012 | -- build-in-place. Note that it is OK for a build-in-place function | |
8013 | -- to return a type with a foreign convention; the build-in-place | |
8014 | -- machinery will ensure there is no copying. | |
7d1d3a54 HK |
8015 | |
8016 | return Is_Build_In_Place_Result_Type (Etype (E)) | |
adc81ec8 | 8017 | and then not (Has_Foreign_Convention (E) and then Is_Imported (E)) |
7d1d3a54 HK |
8018 | and then not Debug_Flag_Dot_L; |
8019 | else | |
8020 | return False; | |
8021 | end if; | |
8022 | end Is_Build_In_Place_Function; | |
8023 | ||
8024 | ------------------------------------- | |
8025 | -- Is_Build_In_Place_Function_Call -- | |
8026 | ------------------------------------- | |
8027 | ||
8028 | function Is_Build_In_Place_Function_Call (N : Node_Id) return Boolean is | |
8029 | Exp_Node : constant Node_Id := Unqual_Conv (N); | |
8030 | Function_Id : Entity_Id; | |
8031 | ||
8032 | begin | |
8033 | -- Return False if the expander is currently inactive, since awareness | |
8034 | -- of build-in-place treatment is only relevant during expansion. Note | |
8035 | -- that Is_Build_In_Place_Function, which is called as part of this | |
8036 | -- function, is also conditioned this way, but we need to check here as | |
8037 | -- well to avoid blowing up on processing protected calls when expansion | |
8038 | -- is disabled (such as with -gnatc) since those would trip over the | |
8039 | -- raise of Program_Error below. | |
8040 | ||
8041 | -- In SPARK mode, build-in-place calls are not expanded, so that we | |
8042 | -- may end up with a call that is neither resolved to an entity, nor | |
8043 | -- an indirect call. | |
8044 | ||
8045 | if not Expander_Active or else Nkind (Exp_Node) /= N_Function_Call then | |
8046 | return False; | |
8047 | end if; | |
8048 | ||
8049 | if Is_Entity_Name (Name (Exp_Node)) then | |
8050 | Function_Id := Entity (Name (Exp_Node)); | |
8051 | ||
8052 | -- In the case of an explicitly dereferenced call, use the subprogram | |
8053 | -- type generated for the dereference. | |
8054 | ||
8055 | elsif Nkind (Name (Exp_Node)) = N_Explicit_Dereference then | |
8056 | Function_Id := Etype (Name (Exp_Node)); | |
8057 | ||
8058 | -- This may be a call to a protected function. | |
8059 | ||
8060 | elsif Nkind (Name (Exp_Node)) = N_Selected_Component then | |
8061 | Function_Id := Etype (Entity (Selector_Name (Name (Exp_Node)))); | |
8062 | ||
8063 | else | |
8064 | raise Program_Error; | |
8065 | end if; | |
8066 | ||
8067 | declare | |
8068 | Result : constant Boolean := Is_Build_In_Place_Function (Function_Id); | |
8069 | -- So we can stop here in the debugger | |
8070 | begin | |
8071 | return Result; | |
8072 | end; | |
8073 | end Is_Build_In_Place_Function_Call; | |
8074 | ||
8dbf3473 AC |
8075 | ----------------------- |
8076 | -- Is_Null_Procedure -- | |
8077 | ----------------------- | |
8078 | ||
8079 | function Is_Null_Procedure (Subp : Entity_Id) return Boolean is | |
8080 | Decl : constant Node_Id := Unit_Declaration_Node (Subp); | |
8081 | ||
8082 | begin | |
8083 | if Ekind (Subp) /= E_Procedure then | |
8084 | return False; | |
8085 | ||
8086 | -- Check if this is a declared null procedure | |
8087 | ||
8088 | elsif Nkind (Decl) = N_Subprogram_Declaration then | |
e1f3cb58 AC |
8089 | if not Null_Present (Specification (Decl)) then |
8090 | return False; | |
8dbf3473 AC |
8091 | |
8092 | elsif No (Body_To_Inline (Decl)) then | |
8093 | return False; | |
8094 | ||
8095 | -- Check if the body contains only a null statement, followed by | |
8096 | -- the return statement added during expansion. | |
8097 | ||
8098 | else | |
8099 | declare | |
8100 | Orig_Bod : constant Node_Id := Body_To_Inline (Decl); | |
8101 | ||
8102 | Stat : Node_Id; | |
8103 | Stat2 : Node_Id; | |
8104 | ||
8105 | begin | |
8106 | if Nkind (Orig_Bod) /= N_Subprogram_Body then | |
8107 | return False; | |
8108 | else | |
327503f1 JM |
8109 | -- We must skip SCIL nodes because they are currently |
8110 | -- implemented as special N_Null_Statement nodes. | |
8111 | ||
8dbf3473 | 8112 | Stat := |
327503f1 | 8113 | First_Non_SCIL_Node |
8dbf3473 | 8114 | (Statements (Handled_Statement_Sequence (Orig_Bod))); |
327503f1 | 8115 | Stat2 := Next_Non_SCIL_Node (Stat); |
8dbf3473 AC |
8116 | |
8117 | return | |
e1f3cb58 AC |
8118 | Is_Empty_List (Declarations (Orig_Bod)) |
8119 | and then Nkind (Stat) = N_Null_Statement | |
8120 | and then | |
8dbf3473 AC |
8121 | (No (Stat2) |
8122 | or else | |
8123 | (Nkind (Stat2) = N_Simple_Return_Statement | |
8124 | and then No (Next (Stat2)))); | |
8125 | end if; | |
8126 | end; | |
8127 | end if; | |
8128 | ||
8129 | else | |
8130 | return False; | |
8131 | end if; | |
8132 | end Is_Null_Procedure; | |
8133 | ||
02822a92 RD |
8134 | ------------------------------------------- |
8135 | -- Make_Build_In_Place_Call_In_Allocator -- | |
8136 | ------------------------------------------- | |
8137 | ||
8138 | procedure Make_Build_In_Place_Call_In_Allocator | |
8139 | (Allocator : Node_Id; | |
8140 | Function_Call : Node_Id) | |
8141 | is | |
94bbf008 | 8142 | Acc_Type : constant Entity_Id := Etype (Allocator); |
90e491a7 | 8143 | Loc : constant Source_Ptr := Sloc (Function_Call); |
02822a92 | 8144 | Func_Call : Node_Id := Function_Call; |
1399d355 | 8145 | Ref_Func_Call : Node_Id; |
02822a92 RD |
8146 | Function_Id : Entity_Id; |
8147 | Result_Subt : Entity_Id; | |
02822a92 | 8148 | New_Allocator : Node_Id; |
1399d355 AC |
8149 | Return_Obj_Access : Entity_Id; -- temp for function result |
8150 | Temp_Init : Node_Id; -- initial value of Return_Obj_Access | |
8151 | Alloc_Form : BIP_Allocation_Form; | |
8152 | Pool : Node_Id; -- nonnull if Alloc_Form = User_Storage_Pool | |
8153 | Return_Obj_Actual : Node_Id; -- the temp.all, in caller-allocates case | |
8154 | Chain : Entity_Id; -- activation chain, in case of tasks | |
02822a92 RD |
8155 | |
8156 | begin | |
19590d70 GD |
8157 | -- Step past qualification or unchecked conversion (the latter can occur |
8158 | -- in cases of calls to 'Input). | |
8159 | ||
7d1d3a54 HK |
8160 | if Nkind_In (Func_Call, N_Qualified_Expression, |
8161 | N_Type_Conversion, | |
8162 | N_Unchecked_Type_Conversion) | |
19590d70 | 8163 | then |
02822a92 RD |
8164 | Func_Call := Expression (Func_Call); |
8165 | end if; | |
8166 | ||
fdce4bb7 JM |
8167 | -- Mark the call as processed as a build-in-place call |
8168 | ||
d4dfb005 | 8169 | pragma Assert (not Is_Expanded_Build_In_Place_Call (Func_Call)); |
fdce4bb7 JM |
8170 | Set_Is_Expanded_Build_In_Place_Call (Func_Call); |
8171 | ||
02822a92 RD |
8172 | if Is_Entity_Name (Name (Func_Call)) then |
8173 | Function_Id := Entity (Name (Func_Call)); | |
8174 | ||
8175 | elsif Nkind (Name (Func_Call)) = N_Explicit_Dereference then | |
8176 | Function_Id := Etype (Name (Func_Call)); | |
8177 | ||
8178 | else | |
8179 | raise Program_Error; | |
8180 | end if; | |
8181 | ||
94bbf008 | 8182 | Result_Subt := Available_View (Etype (Function_Id)); |
02822a92 | 8183 | |
1399d355 AC |
8184 | -- Create a temp for the function result. In the caller-allocates case, |
8185 | -- this will be initialized to the result of a new uninitialized | |
8186 | -- allocator. Note: we do not use Allocator as the Related_Node of | |
8187 | -- Return_Obj_Access in call to Make_Temporary below as this would | |
8188 | -- create a sort of infinite "recursion". | |
0d566e01 | 8189 | |
1399d355 AC |
8190 | Return_Obj_Access := Make_Temporary (Loc, 'R'); |
8191 | Set_Etype (Return_Obj_Access, Acc_Type); | |
d4dfb005 | 8192 | Set_Can_Never_Be_Null (Acc_Type, False); |
3fc40cd7 | 8193 | -- It gets initialized to null, so we can't have that |
0d566e01 | 8194 | |
7d1d3a54 HK |
8195 | -- When the result subtype is constrained, the return object is created |
8196 | -- on the caller side, and access to it is passed to the function. This | |
8197 | -- optimization is disabled when the result subtype needs finalization | |
8198 | -- actions because the caller side allocation may result in undesirable | |
8199 | -- finalization. Consider the following example: | |
8200 | -- | |
8201 | -- function Make_Lim_Ctrl return Lim_Ctrl is | |
8202 | -- begin | |
8203 | -- return Result : Lim_Ctrl := raise Program_Error do | |
8204 | -- null; | |
8205 | -- end return; | |
8206 | -- end Make_Lim_Ctrl; | |
8207 | -- | |
8208 | -- Obj : Lim_Ctrl_Ptr := new Lim_Ctrl'(Make_Lim_Ctrl); | |
8209 | -- | |
8210 | -- Even though the size of limited controlled type Lim_Ctrl is known, | |
8211 | -- allocating Obj at the caller side will chain Obj on Lim_Ctrl_Ptr's | |
8212 | -- finalization master. The subsequent call to Make_Lim_Ctrl will fail | |
8213 | -- during the initialization actions for Result, which implies that | |
8214 | -- Result (and Obj by extension) should not be finalized. However Obj | |
8215 | -- will be finalized when access type Lim_Ctrl_Ptr goes out of scope | |
8216 | -- since it is already attached on the related finalization master. | |
02822a92 | 8217 | |
7888a6ae | 8218 | -- Here and in related routines, we must examine the full view of the |
cf0e5ca7 BD |
8219 | -- type, because the view at the point of call may differ from the |
8220 | -- one in the function body, and the expansion mechanism depends on | |
7888a6ae GD |
8221 | -- the characteristics of the full view. |
8222 | ||
cf0e5ca7 BD |
8223 | if Needs_BIP_Alloc_Form (Function_Id) then |
8224 | Temp_Init := Empty; | |
8225 | ||
8226 | -- Case of a user-defined storage pool. Pass an allocation parameter | |
8227 | -- indicating that the function should allocate its result in the | |
8228 | -- pool, and pass the pool. Use 'Unrestricted_Access because the | |
8229 | -- pool may not be aliased. | |
8230 | ||
8231 | if Present (Associated_Storage_Pool (Acc_Type)) then | |
8232 | Alloc_Form := User_Storage_Pool; | |
8233 | Pool := | |
8234 | Make_Attribute_Reference (Loc, | |
8235 | Prefix => | |
8236 | New_Occurrence_Of | |
8237 | (Associated_Storage_Pool (Acc_Type), Loc), | |
8238 | Attribute_Name => Name_Unrestricted_Access); | |
8239 | ||
8240 | -- No user-defined pool; pass an allocation parameter indicating that | |
8241 | -- the function should allocate its result on the heap. | |
8242 | ||
8243 | else | |
8244 | Alloc_Form := Global_Heap; | |
8245 | Pool := Make_Null (No_Location); | |
8246 | end if; | |
8247 | ||
8248 | -- The caller does not provide the return object in this case, so we | |
8249 | -- have to pass null for the object access actual. | |
8250 | ||
8251 | Return_Obj_Actual := Empty; | |
8252 | ||
8253 | else | |
f937473f RD |
8254 | -- Replace the initialized allocator of form "new T'(Func (...))" |
8255 | -- with an uninitialized allocator of form "new T", where T is the | |
8256 | -- result subtype of the called function. The call to the function | |
8257 | -- is handled separately further below. | |
02822a92 | 8258 | |
f937473f | 8259 | New_Allocator := |
fad0600d | 8260 | Make_Allocator (Loc, |
e4494292 | 8261 | Expression => New_Occurrence_Of (Result_Subt, Loc)); |
fad0600d AC |
8262 | Set_No_Initialization (New_Allocator); |
8263 | ||
8264 | -- Copy attributes to new allocator. Note that the new allocator | |
8265 | -- logically comes from source if the original one did, so copy the | |
8266 | -- relevant flag. This ensures proper treatment of the restriction | |
8267 | -- No_Implicit_Heap_Allocations in this case. | |
02822a92 | 8268 | |
fad0600d | 8269 | Set_Storage_Pool (New_Allocator, Storage_Pool (Allocator)); |
f937473f | 8270 | Set_Procedure_To_Call (New_Allocator, Procedure_To_Call (Allocator)); |
fad0600d | 8271 | Set_Comes_From_Source (New_Allocator, Comes_From_Source (Allocator)); |
02822a92 | 8272 | |
f937473f | 8273 | Rewrite (Allocator, New_Allocator); |
02822a92 | 8274 | |
1399d355 | 8275 | -- Initial value of the temp is the result of the uninitialized |
90e491a7 PMR |
8276 | -- allocator. Unchecked_Convert is needed for T'Input where T is |
8277 | -- derived from a controlled type. | |
02822a92 | 8278 | |
1399d355 | 8279 | Temp_Init := Relocate_Node (Allocator); |
f937473f | 8280 | |
7d1d3a54 HK |
8281 | if Nkind_In (Function_Call, N_Type_Conversion, |
8282 | N_Unchecked_Type_Conversion) | |
90e491a7 PMR |
8283 | then |
8284 | Temp_Init := Unchecked_Convert_To (Acc_Type, Temp_Init); | |
8285 | end if; | |
8286 | ||
1399d355 AC |
8287 | -- Indicate that caller allocates, and pass in the return object |
8288 | ||
8289 | Alloc_Form := Caller_Allocation; | |
8290 | Pool := Make_Null (No_Location); | |
8291 | Return_Obj_Actual := | |
8292 | Make_Unchecked_Type_Conversion (Loc, | |
8293 | Subtype_Mark => New_Occurrence_Of (Result_Subt, Loc), | |
8294 | Expression => | |
8295 | Make_Explicit_Dereference (Loc, | |
8296 | Prefix => New_Occurrence_Of (Return_Obj_Access, Loc))); | |
f937473f RD |
8297 | |
8298 | -- When the result subtype is unconstrained, the function itself must | |
8299 | -- perform the allocation of the return object, so we pass parameters | |
1399d355 | 8300 | -- indicating that. |
f937473f | 8301 | |
1399d355 AC |
8302 | end if; |
8303 | ||
8304 | -- Declare the temp object | |
8305 | ||
8306 | Insert_Action (Allocator, | |
8307 | Make_Object_Declaration (Loc, | |
8308 | Defining_Identifier => Return_Obj_Access, | |
8309 | Object_Definition => New_Occurrence_Of (Acc_Type, Loc), | |
8310 | Expression => Temp_Init)); | |
8311 | ||
8312 | Ref_Func_Call := Make_Reference (Loc, Func_Call); | |
8313 | ||
8314 | -- Ada 2005 (AI-251): If the type of the allocator is an interface | |
8315 | -- then generate an implicit conversion to force displacement of the | |
8316 | -- "this" pointer. | |
8317 | ||
8318 | if Is_Interface (Designated_Type (Acc_Type)) then | |
8319 | Rewrite | |
8320 | (Ref_Func_Call, | |
8321 | OK_Convert_To (Acc_Type, Ref_Func_Call)); | |
90e491a7 PMR |
8322 | |
8323 | -- If the types are incompatible, we need an unchecked conversion. Note | |
8324 | -- that the full types will be compatible, but the types not visibly | |
8325 | -- compatible. | |
8326 | ||
7d1d3a54 HK |
8327 | elsif Nkind_In (Function_Call, N_Type_Conversion, |
8328 | N_Unchecked_Type_Conversion) | |
90e491a7 PMR |
8329 | then |
8330 | Ref_Func_Call := Unchecked_Convert_To (Acc_Type, Ref_Func_Call); | |
f937473f | 8331 | end if; |
02822a92 | 8332 | |
1399d355 AC |
8333 | declare |
8334 | Assign : constant Node_Id := | |
7d1d3a54 HK |
8335 | Make_Assignment_Statement (Loc, |
8336 | Name => New_Occurrence_Of (Return_Obj_Access, Loc), | |
8337 | Expression => Ref_Func_Call); | |
1399d355 AC |
8338 | -- Assign the result of the function call into the temp. In the |
8339 | -- caller-allocates case, this is overwriting the temp with its | |
8340 | -- initial value, which has no effect. In the callee-allocates case, | |
8341 | -- this is setting the temp to point to the object allocated by the | |
90e491a7 PMR |
8342 | -- callee. Unchecked_Convert is needed for T'Input where T is derived |
8343 | -- from a controlled type. | |
1399d355 AC |
8344 | |
8345 | Actions : List_Id; | |
8346 | -- Actions to be inserted. If there are no tasks, this is just the | |
8347 | -- assignment statement. If the allocated object has tasks, we need | |
8348 | -- to wrap the assignment in a block that activates them. The | |
8349 | -- activation chain of that block must be passed to the function, | |
8350 | -- rather than some outer chain. | |
7d1d3a54 | 8351 | |
1399d355 AC |
8352 | begin |
8353 | if Has_Task (Result_Subt) then | |
8354 | Actions := New_List; | |
8355 | Build_Task_Allocate_Block_With_Init_Stmts | |
8356 | (Actions, Allocator, Init_Stmts => New_List (Assign)); | |
8357 | Chain := Activation_Chain_Entity (Last (Actions)); | |
8358 | else | |
8359 | Actions := New_List (Assign); | |
8360 | Chain := Empty; | |
8361 | end if; | |
8362 | ||
8363 | Insert_Actions (Allocator, Actions); | |
8364 | end; | |
8365 | ||
8366 | -- When the function has a controlling result, an allocation-form | |
8367 | -- parameter must be passed indicating that the caller is allocating | |
8368 | -- the result object. This is needed because such a function can be | |
8369 | -- called as a dispatching operation and must be treated similarly | |
8370 | -- to functions with unconstrained result subtypes. | |
8371 | ||
8372 | Add_Unconstrained_Actuals_To_Build_In_Place_Call | |
8373 | (Func_Call, Function_Id, Alloc_Form, Pool_Actual => Pool); | |
8374 | ||
8375 | Add_Finalization_Master_Actual_To_Build_In_Place_Call | |
8376 | (Func_Call, Function_Id, Acc_Type); | |
8377 | ||
8378 | Add_Task_Actuals_To_Build_In_Place_Call | |
8379 | (Func_Call, Function_Id, Master_Actual => Master_Id (Acc_Type), | |
8380 | Chain => Chain); | |
8381 | ||
8382 | -- Add an implicit actual to the function call that provides access | |
8383 | -- to the allocated object. An unchecked conversion to the (specific) | |
8384 | -- result subtype of the function is inserted to handle cases where | |
8385 | -- the access type of the allocator has a class-wide designated type. | |
8386 | ||
8387 | Add_Access_Actual_To_Build_In_Place_Call | |
8388 | (Func_Call, Function_Id, Return_Obj_Actual); | |
8389 | ||
1399d355 | 8390 | -- Finally, replace the allocator node with a reference to the temp |
02822a92 | 8391 | |
1399d355 | 8392 | Rewrite (Allocator, New_Occurrence_Of (Return_Obj_Access, Loc)); |
d2d4b355 | 8393 | |
02822a92 | 8394 | Analyze_And_Resolve (Allocator, Acc_Type); |
1ed19d98 | 8395 | pragma Assert (Check_Number_Of_Actuals (Func_Call, Function_Id)); |
02822a92 RD |
8396 | end Make_Build_In_Place_Call_In_Allocator; |
8397 | ||
8398 | --------------------------------------------------- | |
8399 | -- Make_Build_In_Place_Call_In_Anonymous_Context -- | |
8400 | --------------------------------------------------- | |
8401 | ||
8402 | procedure Make_Build_In_Place_Call_In_Anonymous_Context | |
8403 | (Function_Call : Node_Id) | |
8404 | is | |
90e491a7 | 8405 | Loc : constant Source_Ptr := Sloc (Function_Call); |
0691ed6b | 8406 | Func_Call : constant Node_Id := Unqual_Conv (Function_Call); |
02822a92 RD |
8407 | Function_Id : Entity_Id; |
8408 | Result_Subt : Entity_Id; | |
8409 | Return_Obj_Id : Entity_Id; | |
8410 | Return_Obj_Decl : Entity_Id; | |
8411 | ||
8412 | begin | |
fdce4bb7 JM |
8413 | -- If the call has already been processed to add build-in-place actuals |
8414 | -- then return. One place this can occur is for calls to build-in-place | |
8415 | -- functions that occur within a call to a protected operation, where | |
8416 | -- due to rewriting and expansion of the protected call there can be | |
8417 | -- more than one call to Expand_Actuals for the same set of actuals. | |
8418 | ||
8419 | if Is_Expanded_Build_In_Place_Call (Func_Call) then | |
8420 | return; | |
8421 | end if; | |
8422 | ||
8423 | -- Mark the call as processed as a build-in-place call | |
8424 | ||
8425 | Set_Is_Expanded_Build_In_Place_Call (Func_Call); | |
8426 | ||
02822a92 RD |
8427 | if Is_Entity_Name (Name (Func_Call)) then |
8428 | Function_Id := Entity (Name (Func_Call)); | |
8429 | ||
8430 | elsif Nkind (Name (Func_Call)) = N_Explicit_Dereference then | |
8431 | Function_Id := Etype (Name (Func_Call)); | |
8432 | ||
8433 | else | |
8434 | raise Program_Error; | |
8435 | end if; | |
8436 | ||
8437 | Result_Subt := Etype (Function_Id); | |
8438 | ||
df3e68b1 HK |
8439 | -- If the build-in-place function returns a controlled object, then the |
8440 | -- object needs to be finalized immediately after the context. Since | |
8441 | -- this case produces a transient scope, the servicing finalizer needs | |
8442 | -- to name the returned object. Create a temporary which is initialized | |
8443 | -- with the function call: | |
8444 | -- | |
8445 | -- Temp_Id : Func_Type := BIP_Func_Call; | |
8446 | -- | |
8447 | -- The initialization expression of the temporary will be rewritten by | |
8448 | -- the expander using the appropriate mechanism in Make_Build_In_Place_ | |
8449 | -- Call_In_Object_Declaration. | |
8450 | ||
8451 | if Needs_Finalization (Result_Subt) then | |
8452 | declare | |
8453 | Temp_Id : constant Entity_Id := Make_Temporary (Loc, 'R'); | |
8454 | Temp_Decl : Node_Id; | |
8455 | ||
8456 | begin | |
8457 | -- Reset the guard on the function call since the following does | |
8458 | -- not perform actual call expansion. | |
8459 | ||
8460 | Set_Is_Expanded_Build_In_Place_Call (Func_Call, False); | |
8461 | ||
8462 | Temp_Decl := | |
8463 | Make_Object_Declaration (Loc, | |
8464 | Defining_Identifier => Temp_Id, | |
8465 | Object_Definition => | |
e4494292 | 8466 | New_Occurrence_Of (Result_Subt, Loc), |
df3e68b1 HK |
8467 | Expression => |
8468 | New_Copy_Tree (Function_Call)); | |
8469 | ||
8470 | Insert_Action (Function_Call, Temp_Decl); | |
8471 | ||
e4494292 | 8472 | Rewrite (Function_Call, New_Occurrence_Of (Temp_Id, Loc)); |
df3e68b1 HK |
8473 | Analyze (Function_Call); |
8474 | end; | |
8475 | ||
e51102b2 | 8476 | -- When the result subtype is definite, an object of the subtype is |
f937473f | 8477 | -- declared and an access value designating it is passed as an actual. |
02822a92 | 8478 | |
0691ed6b | 8479 | elsif Caller_Known_Size (Func_Call, Result_Subt) then |
02822a92 | 8480 | |
f937473f RD |
8481 | -- Create a temporary object to hold the function result |
8482 | ||
c12beea0 | 8483 | Return_Obj_Id := Make_Temporary (Loc, 'R'); |
f937473f | 8484 | Set_Etype (Return_Obj_Id, Result_Subt); |
02822a92 | 8485 | |
f937473f RD |
8486 | Return_Obj_Decl := |
8487 | Make_Object_Declaration (Loc, | |
8488 | Defining_Identifier => Return_Obj_Id, | |
8489 | Aliased_Present => True, | |
e4494292 | 8490 | Object_Definition => New_Occurrence_Of (Result_Subt, Loc)); |
02822a92 | 8491 | |
f937473f | 8492 | Set_No_Initialization (Return_Obj_Decl); |
02822a92 | 8493 | |
f937473f | 8494 | Insert_Action (Func_Call, Return_Obj_Decl); |
02822a92 | 8495 | |
7888a6ae GD |
8496 | -- When the function has a controlling result, an allocation-form |
8497 | -- parameter must be passed indicating that the caller is allocating | |
8498 | -- the result object. This is needed because such a function can be | |
8499 | -- called as a dispatching operation and must be treated similarly | |
8500 | -- to functions with unconstrained result subtypes. | |
8501 | ||
200b7162 | 8502 | Add_Unconstrained_Actuals_To_Build_In_Place_Call |
7888a6ae GD |
8503 | (Func_Call, Function_Id, Alloc_Form => Caller_Allocation); |
8504 | ||
d3f70b35 | 8505 | Add_Finalization_Master_Actual_To_Build_In_Place_Call |
df3e68b1 | 8506 | (Func_Call, Function_Id); |
f937473f | 8507 | |
f937473f RD |
8508 | Add_Task_Actuals_To_Build_In_Place_Call |
8509 | (Func_Call, Function_Id, Make_Identifier (Loc, Name_uMaster)); | |
7888a6ae GD |
8510 | |
8511 | -- Add an implicit actual to the function call that provides access | |
8512 | -- to the caller's return object. | |
8513 | ||
f937473f | 8514 | Add_Access_Actual_To_Build_In_Place_Call |
e4494292 | 8515 | (Func_Call, Function_Id, New_Occurrence_Of (Return_Obj_Id, Loc)); |
f937473f | 8516 | |
1ed19d98 JM |
8517 | pragma Assert (Check_Number_Of_Actuals (Func_Call, Function_Id)); |
8518 | ||
f937473f RD |
8519 | -- When the result subtype is unconstrained, the function must allocate |
8520 | -- the return object in the secondary stack, so appropriate implicit | |
8521 | -- parameters are added to the call to indicate that. A transient | |
8522 | -- scope is established to ensure eventual cleanup of the result. | |
8523 | ||
8524 | else | |
8525 | -- Pass an allocation parameter indicating that the function should | |
8526 | -- allocate its result on the secondary stack. | |
8527 | ||
200b7162 | 8528 | Add_Unconstrained_Actuals_To_Build_In_Place_Call |
f937473f RD |
8529 | (Func_Call, Function_Id, Alloc_Form => Secondary_Stack); |
8530 | ||
d3f70b35 | 8531 | Add_Finalization_Master_Actual_To_Build_In_Place_Call |
df3e68b1 | 8532 | (Func_Call, Function_Id); |
f937473f | 8533 | |
f937473f RD |
8534 | Add_Task_Actuals_To_Build_In_Place_Call |
8535 | (Func_Call, Function_Id, Make_Identifier (Loc, Name_uMaster)); | |
7888a6ae GD |
8536 | |
8537 | -- Pass a null value to the function since no return object is | |
8538 | -- available on the caller side. | |
8539 | ||
f937473f RD |
8540 | Add_Access_Actual_To_Build_In_Place_Call |
8541 | (Func_Call, Function_Id, Empty); | |
1ed19d98 JM |
8542 | |
8543 | pragma Assert (Check_Number_Of_Actuals (Func_Call, Function_Id)); | |
f937473f | 8544 | end if; |
02822a92 RD |
8545 | end Make_Build_In_Place_Call_In_Anonymous_Context; |
8546 | ||
ce2798e8 | 8547 | -------------------------------------------- |
02822a92 | 8548 | -- Make_Build_In_Place_Call_In_Assignment -- |
ce2798e8 | 8549 | -------------------------------------------- |
02822a92 RD |
8550 | |
8551 | procedure Make_Build_In_Place_Call_In_Assignment | |
8552 | (Assign : Node_Id; | |
8553 | Function_Call : Node_Id) | |
8554 | is | |
3fc40cd7 PMR |
8555 | Func_Call : constant Node_Id := Unqual_Conv (Function_Call); |
8556 | Lhs : constant Node_Id := Name (Assign); | |
d4dfb005 | 8557 | Loc : constant Source_Ptr := Sloc (Function_Call); |
3fc40cd7 | 8558 | Func_Id : Entity_Id; |
3a69b5ff AC |
8559 | Obj_Decl : Node_Id; |
8560 | Obj_Id : Entity_Id; | |
8561 | Ptr_Typ : Entity_Id; | |
8562 | Ptr_Typ_Decl : Node_Id; | |
74cab21a | 8563 | New_Expr : Node_Id; |
3a69b5ff | 8564 | Result_Subt : Entity_Id; |
02822a92 RD |
8565 | |
8566 | begin | |
fdce4bb7 JM |
8567 | -- Mark the call as processed as a build-in-place call |
8568 | ||
d4dfb005 | 8569 | pragma Assert (not Is_Expanded_Build_In_Place_Call (Func_Call)); |
fdce4bb7 JM |
8570 | Set_Is_Expanded_Build_In_Place_Call (Func_Call); |
8571 | ||
02822a92 | 8572 | if Is_Entity_Name (Name (Func_Call)) then |
3a69b5ff | 8573 | Func_Id := Entity (Name (Func_Call)); |
02822a92 RD |
8574 | |
8575 | elsif Nkind (Name (Func_Call)) = N_Explicit_Dereference then | |
3a69b5ff | 8576 | Func_Id := Etype (Name (Func_Call)); |
02822a92 RD |
8577 | |
8578 | else | |
8579 | raise Program_Error; | |
8580 | end if; | |
8581 | ||
3a69b5ff | 8582 | Result_Subt := Etype (Func_Id); |
02822a92 | 8583 | |
f937473f RD |
8584 | -- When the result subtype is unconstrained, an additional actual must |
8585 | -- be passed to indicate that the caller is providing the return object. | |
7888a6ae GD |
8586 | -- This parameter must also be passed when the called function has a |
8587 | -- controlling result, because dispatching calls to the function needs | |
8588 | -- to be treated effectively the same as calls to class-wide functions. | |
f937473f | 8589 | |
200b7162 | 8590 | Add_Unconstrained_Actuals_To_Build_In_Place_Call |
3a69b5ff | 8591 | (Func_Call, Func_Id, Alloc_Form => Caller_Allocation); |
f937473f | 8592 | |
d3f70b35 | 8593 | Add_Finalization_Master_Actual_To_Build_In_Place_Call |
df3e68b1 | 8594 | (Func_Call, Func_Id); |
02822a92 | 8595 | |
f937473f | 8596 | Add_Task_Actuals_To_Build_In_Place_Call |
3a69b5ff | 8597 | (Func_Call, Func_Id, Make_Identifier (Loc, Name_uMaster)); |
7888a6ae GD |
8598 | |
8599 | -- Add an implicit actual to the function call that provides access to | |
8600 | -- the caller's return object. | |
8601 | ||
02822a92 RD |
8602 | Add_Access_Actual_To_Build_In_Place_Call |
8603 | (Func_Call, | |
3a69b5ff | 8604 | Func_Id, |
02822a92 | 8605 | Make_Unchecked_Type_Conversion (Loc, |
e4494292 | 8606 | Subtype_Mark => New_Occurrence_Of (Result_Subt, Loc), |
02822a92 RD |
8607 | Expression => Relocate_Node (Lhs))); |
8608 | ||
8609 | -- Create an access type designating the function's result subtype | |
8610 | ||
c12beea0 | 8611 | Ptr_Typ := Make_Temporary (Loc, 'A'); |
02822a92 RD |
8612 | |
8613 | Ptr_Typ_Decl := | |
8614 | Make_Full_Type_Declaration (Loc, | |
3a69b5ff | 8615 | Defining_Identifier => Ptr_Typ, |
2c1b72d7 | 8616 | Type_Definition => |
02822a92 | 8617 | Make_Access_To_Object_Definition (Loc, |
2c1b72d7 | 8618 | All_Present => True, |
02822a92 | 8619 | Subtype_Indication => |
e4494292 | 8620 | New_Occurrence_Of (Result_Subt, Loc))); |
02822a92 RD |
8621 | Insert_After_And_Analyze (Assign, Ptr_Typ_Decl); |
8622 | ||
8623 | -- Finally, create an access object initialized to a reference to the | |
03e1048e AC |
8624 | -- function call. We know this access value is non-null, so mark the |
8625 | -- entity accordingly to suppress junk access checks. | |
02822a92 | 8626 | |
74cab21a EB |
8627 | New_Expr := Make_Reference (Loc, Relocate_Node (Func_Call)); |
8628 | ||
d4dfb005 BD |
8629 | -- Add a conversion if it's the wrong type |
8630 | ||
8631 | if Etype (New_Expr) /= Ptr_Typ then | |
3fc40cd7 PMR |
8632 | New_Expr := |
8633 | Make_Unchecked_Type_Conversion (Loc, | |
8634 | New_Occurrence_Of (Ptr_Typ, Loc), New_Expr); | |
d4dfb005 BD |
8635 | end if; |
8636 | ||
74cab21a | 8637 | Obj_Id := Make_Temporary (Loc, 'R', New_Expr); |
3a69b5ff | 8638 | Set_Etype (Obj_Id, Ptr_Typ); |
74cab21a | 8639 | Set_Is_Known_Non_Null (Obj_Id); |
02822a92 | 8640 | |
3a69b5ff | 8641 | Obj_Decl := |
02822a92 | 8642 | Make_Object_Declaration (Loc, |
3a69b5ff | 8643 | Defining_Identifier => Obj_Id, |
e4494292 | 8644 | Object_Definition => New_Occurrence_Of (Ptr_Typ, Loc), |
74cab21a | 8645 | Expression => New_Expr); |
3a69b5ff | 8646 | Insert_After_And_Analyze (Ptr_Typ_Decl, Obj_Decl); |
02822a92 RD |
8647 | |
8648 | Rewrite (Assign, Make_Null_Statement (Loc)); | |
1ed19d98 | 8649 | pragma Assert (Check_Number_Of_Actuals (Func_Call, Func_Id)); |
02822a92 RD |
8650 | end Make_Build_In_Place_Call_In_Assignment; |
8651 | ||
8652 | ---------------------------------------------------- | |
8653 | -- Make_Build_In_Place_Call_In_Object_Declaration -- | |
8654 | ---------------------------------------------------- | |
8655 | ||
8656 | procedure Make_Build_In_Place_Call_In_Object_Declaration | |
e5f2c03c | 8657 | (Obj_Decl : Node_Id; |
02822a92 RD |
8658 | Function_Call : Node_Id) |
8659 | is | |
15529d0a PMR |
8660 | function Get_Function_Id (Func_Call : Node_Id) return Entity_Id; |
8661 | -- Get the value of Function_Id, below | |
8662 | ||
3fc40cd7 PMR |
8663 | --------------------- |
8664 | -- Get_Function_Id -- | |
8665 | --------------------- | |
8666 | ||
15529d0a PMR |
8667 | function Get_Function_Id (Func_Call : Node_Id) return Entity_Id is |
8668 | begin | |
8669 | if Is_Entity_Name (Name (Func_Call)) then | |
8670 | return Entity (Name (Func_Call)); | |
8671 | ||
8672 | elsif Nkind (Name (Func_Call)) = N_Explicit_Dereference then | |
8673 | return Etype (Name (Func_Call)); | |
8674 | ||
8675 | else | |
8676 | raise Program_Error; | |
8677 | end if; | |
8678 | end Get_Function_Id; | |
8679 | ||
3fc40cd7 | 8680 | -- Local variables |
15529d0a | 8681 | |
3fc40cd7 PMR |
8682 | Func_Call : constant Node_Id := Unqual_Conv (Function_Call); |
8683 | Function_Id : constant Entity_Id := Get_Function_Id (Func_Call); | |
8684 | Loc : constant Source_Ptr := Sloc (Function_Call); | |
8685 | Obj_Loc : constant Source_Ptr := Sloc (Obj_Decl); | |
8686 | Obj_Def_Id : constant Entity_Id := Defining_Identifier (Obj_Decl); | |
8687 | Obj_Typ : constant Entity_Id := Etype (Obj_Def_Id); | |
8688 | Encl_Func : constant Entity_Id := Enclosing_Subprogram (Obj_Def_Id); | |
8689 | Result_Subt : constant Entity_Id := Etype (Function_Id); | |
e5f2c03c | 8690 | |
8417f4b2 AC |
8691 | Call_Deref : Node_Id; |
8692 | Caller_Object : Node_Id; | |
8693 | Def_Id : Entity_Id; | |
3fc40cd7 | 8694 | Designated_Type : Entity_Id; |
2c17ca0a | 8695 | Fmaster_Actual : Node_Id := Empty; |
8417f4b2 | 8696 | Pool_Actual : Node_Id; |
f65c67d3 | 8697 | Ptr_Typ : Entity_Id; |
8417f4b2 | 8698 | Ptr_Typ_Decl : Node_Id; |
f937473f | 8699 | Pass_Caller_Acc : Boolean := False; |
8c7ff9a0 | 8700 | Res_Decl : Node_Id; |
15529d0a PMR |
8701 | |
8702 | Definite : constant Boolean := | |
8703 | Caller_Known_Size (Func_Call, Result_Subt) | |
3fc40cd7 | 8704 | and then not Is_Class_Wide_Type (Obj_Typ); |
15529d0a PMR |
8705 | -- In the case of "X : T'Class := F(...);", where F returns a |
8706 | -- Caller_Known_Size (specific) tagged type, we treat it as | |
8707 | -- indefinite, because the code for the Definite case below sets the | |
8708 | -- initialization expression of the object to Empty, which would be | |
98b779ae PMR |
8709 | -- illegal Ada, and would cause gigi to misallocate X. |
8710 | ||
8711 | -- Start of processing for Make_Build_In_Place_Call_In_Object_Declaration | |
b68cf874 | 8712 | |
02822a92 | 8713 | begin |
98b779ae PMR |
8714 | -- If the call has already been processed to add build-in-place actuals |
8715 | -- then return. | |
8716 | ||
8717 | if Is_Expanded_Build_In_Place_Call (Func_Call) then | |
8718 | return; | |
8719 | end if; | |
8720 | ||
fdce4bb7 JM |
8721 | -- Mark the call as processed as a build-in-place call |
8722 | ||
8723 | Set_Is_Expanded_Build_In_Place_Call (Func_Call); | |
8724 | ||
15529d0a PMR |
8725 | -- Create an access type designating the function's result subtype. |
8726 | -- We use the type of the original call because it may be a call to an | |
8727 | -- inherited operation, which the expansion has replaced with the parent | |
8728 | -- operation that yields the parent type. Note that this access type | |
8729 | -- must be declared before we establish a transient scope, so that it | |
8730 | -- receives the proper accessibility level. | |
02822a92 | 8731 | |
15529d0a PMR |
8732 | if Is_Class_Wide_Type (Obj_Typ) |
8733 | and then not Is_Interface (Obj_Typ) | |
8734 | and then not Is_Class_Wide_Type (Etype (Function_Call)) | |
8735 | then | |
8736 | Designated_Type := Obj_Typ; | |
8737 | else | |
8738 | Designated_Type := Etype (Function_Call); | |
8739 | end if; | |
02822a92 | 8740 | |
15529d0a PMR |
8741 | Ptr_Typ := Make_Temporary (Loc, 'A'); |
8742 | Ptr_Typ_Decl := | |
8743 | Make_Full_Type_Declaration (Loc, | |
8744 | Defining_Identifier => Ptr_Typ, | |
8745 | Type_Definition => | |
8746 | Make_Access_To_Object_Definition (Loc, | |
8747 | All_Present => True, | |
8748 | Subtype_Indication => | |
8749 | New_Occurrence_Of (Designated_Type, Loc))); | |
8750 | ||
8751 | -- The access type and its accompanying object must be inserted after | |
8752 | -- the object declaration in the constrained case, so that the function | |
8753 | -- call can be passed access to the object. In the indefinite case, or | |
8754 | -- if the object declaration is for a return object, the access type and | |
8755 | -- object must be inserted before the object, since the object | |
8756 | -- declaration is rewritten to be a renaming of a dereference of the | |
8757 | -- access object. Note: we need to freeze Ptr_Typ explicitly, because | |
8758 | -- the result object is in a different (transient) scope, so won't cause | |
8759 | -- freezing. | |
8760 | ||
3fc40cd7 | 8761 | if Definite and then not Is_Return_Object (Obj_Def_Id) then |
a2dbe7d5 ES |
8762 | |
8763 | -- The presence of an address clause complicates the build-in-place | |
8764 | -- expansion because the indicated address must be processed before | |
8765 | -- the indirect call is generated (including the definition of a | |
64ac53f4 | 8766 | -- local pointer to the object). The address clause may come from |
a2dbe7d5 ES |
8767 | -- an aspect specification or from an explicit attribute |
8768 | -- specification appearing after the object declaration. These two | |
8769 | -- cases require different processing. | |
8770 | ||
8771 | if Has_Aspect (Obj_Def_Id, Aspect_Address) then | |
8772 | ||
8773 | -- Skip non-delayed pragmas that correspond to other aspects, if | |
8774 | -- any, to find proper insertion point for freeze node of object. | |
8775 | ||
8776 | declare | |
8777 | D : Node_Id := Obj_Decl; | |
8778 | N : Node_Id := Next (D); | |
8779 | ||
8780 | begin | |
8781 | while Present (N) | |
663afa9f | 8782 | and then Nkind_In (N, N_Attribute_Reference, N_Pragma) |
a2dbe7d5 ES |
8783 | loop |
8784 | Analyze (N); | |
8785 | D := N; | |
8786 | Next (N); | |
8787 | end loop; | |
8788 | ||
8789 | Insert_After (D, Ptr_Typ_Decl); | |
8790 | ||
8791 | -- Freeze object before pointer declaration, to ensure that | |
8792 | -- generated attribute for address is inserted at the proper | |
8793 | -- place. | |
8794 | ||
8795 | Freeze_Before (Ptr_Typ_Decl, Obj_Def_Id); | |
8796 | end; | |
8797 | ||
8798 | Analyze (Ptr_Typ_Decl); | |
8799 | ||
8800 | elsif Present (Following_Address_Clause (Obj_Decl)) then | |
8801 | ||
8802 | -- Locate explicit address clause, which may also follow pragmas | |
8803 | -- generated by other aspect specifications. | |
8804 | ||
8805 | declare | |
8806 | Addr : constant Node_Id := Following_Address_Clause (Obj_Decl); | |
8807 | D : Node_Id := Next (Obj_Decl); | |
8808 | ||
8809 | begin | |
8810 | while Present (D) loop | |
8811 | Analyze (D); | |
8812 | exit when D = Addr; | |
8813 | Next (D); | |
8814 | end loop; | |
8815 | ||
8816 | Insert_After_And_Analyze (Addr, Ptr_Typ_Decl); | |
8817 | end; | |
8818 | ||
8819 | else | |
8820 | Insert_After_And_Analyze (Obj_Decl, Ptr_Typ_Decl); | |
8821 | end if; | |
02822a92 | 8822 | else |
15529d0a | 8823 | Insert_Action (Obj_Decl, Ptr_Typ_Decl); |
02822a92 RD |
8824 | end if; |
8825 | ||
15529d0a PMR |
8826 | -- Force immediate freezing of Ptr_Typ because Res_Decl will be |
8827 | -- elaborated in an inner (transient) scope and thus won't cause | |
8828 | -- freezing by itself. It's not an itype, but it needs to be frozen | |
8829 | -- inside the current subprogram (see Freeze_Outside in freeze.adb). | |
8830 | ||
8831 | Freeze_Itype (Ptr_Typ, Ptr_Typ_Decl); | |
8832 | ||
8833 | -- If the object is a return object of an enclosing build-in-place | |
8834 | -- function, then the implicit build-in-place parameters of the | |
8835 | -- enclosing function are simply passed along to the called function. | |
8836 | -- (Unfortunately, this won't cover the case of extension aggregates | |
8837 | -- where the ancestor part is a build-in-place indefinite function | |
8838 | -- call that should be passed along the caller's parameters. | |
8839 | -- Currently those get mishandled by reassigning the result of the | |
8840 | -- call to the aggregate return object, when the call result should | |
8841 | -- really be directly built in place in the aggregate and not in a | |
8842 | -- temporary. ???) | |
8843 | ||
8844 | if Is_Return_Object (Obj_Def_Id) then | |
8845 | Pass_Caller_Acc := True; | |
8846 | ||
8847 | -- When the enclosing function has a BIP_Alloc_Form formal then we | |
3fc40cd7 PMR |
8848 | -- pass it along to the callee (such as when the enclosing function |
8849 | -- has an unconstrained or tagged result type). | |
15529d0a PMR |
8850 | |
8851 | if Needs_BIP_Alloc_Form (Encl_Func) then | |
8852 | if RTE_Available (RE_Root_Storage_Pool_Ptr) then | |
8853 | Pool_Actual := | |
8854 | New_Occurrence_Of | |
8855 | (Build_In_Place_Formal | |
8856 | (Encl_Func, BIP_Storage_Pool), Loc); | |
02822a92 | 8857 | |
15529d0a | 8858 | -- The build-in-place pool formal is not built on e.g. ZFP |
1155ae01 | 8859 | |
15529d0a PMR |
8860 | else |
8861 | Pool_Actual := Empty; | |
8862 | end if; | |
8863 | ||
8864 | Add_Unconstrained_Actuals_To_Build_In_Place_Call | |
8865 | (Function_Call => Func_Call, | |
8866 | Function_Id => Function_Id, | |
8867 | Alloc_Form_Exp => | |
8868 | New_Occurrence_Of | |
8869 | (Build_In_Place_Formal (Encl_Func, BIP_Alloc_Form), Loc), | |
8870 | Pool_Actual => Pool_Actual); | |
8871 | ||
8872 | -- Otherwise, if enclosing function has a definite result subtype, | |
8873 | -- then caller allocation will be used. | |
d4dfb005 | 8874 | |
0691ed6b | 8875 | else |
15529d0a PMR |
8876 | Add_Unconstrained_Actuals_To_Build_In_Place_Call |
8877 | (Func_Call, Function_Id, Alloc_Form => Caller_Allocation); | |
0691ed6b | 8878 | end if; |
f65c67d3 | 8879 | |
15529d0a PMR |
8880 | if Needs_BIP_Finalization_Master (Encl_Func) then |
8881 | Fmaster_Actual := | |
8882 | New_Occurrence_Of | |
8883 | (Build_In_Place_Formal | |
8884 | (Encl_Func, BIP_Finalization_Master), Loc); | |
8885 | end if; | |
f65c67d3 | 8886 | |
15529d0a PMR |
8887 | -- Retrieve the BIPacc formal from the enclosing function and convert |
8888 | -- it to the access type of the callee's BIP_Object_Access formal. | |
0691ed6b | 8889 | |
15529d0a PMR |
8890 | Caller_Object := |
8891 | Make_Unchecked_Type_Conversion (Loc, | |
8892 | Subtype_Mark => | |
8893 | New_Occurrence_Of | |
3fc40cd7 PMR |
8894 | (Etype (Build_In_Place_Formal |
8895 | (Function_Id, BIP_Object_Access)), | |
15529d0a PMR |
8896 | Loc), |
8897 | Expression => | |
8898 | New_Occurrence_Of | |
8899 | (Build_In_Place_Formal (Encl_Func, BIP_Object_Access), | |
8900 | Loc)); | |
0691ed6b | 8901 | |
15529d0a PMR |
8902 | -- In the definite case, add an implicit actual to the function call |
8903 | -- that provides access to the declared object. An unchecked conversion | |
8904 | -- to the (specific) result type of the function is inserted to handle | |
8905 | -- the case where the object is declared with a class-wide type. | |
0691ed6b | 8906 | |
15529d0a PMR |
8907 | elsif Definite then |
8908 | Caller_Object := | |
8909 | Make_Unchecked_Type_Conversion (Loc, | |
8910 | Subtype_Mark => New_Occurrence_Of (Result_Subt, Loc), | |
8911 | Expression => New_Occurrence_Of (Obj_Def_Id, Loc)); | |
0691ed6b | 8912 | |
15529d0a PMR |
8913 | -- When the function has a controlling result, an allocation-form |
8914 | -- parameter must be passed indicating that the caller is allocating | |
8915 | -- the result object. This is needed because such a function can be | |
8916 | -- called as a dispatching operation and must be treated similarly to | |
8917 | -- functions with indefinite result subtypes. | |
f65c67d3 | 8918 | |
15529d0a PMR |
8919 | Add_Unconstrained_Actuals_To_Build_In_Place_Call |
8920 | (Func_Call, Function_Id, Alloc_Form => Caller_Allocation); | |
0691ed6b | 8921 | |
15529d0a PMR |
8922 | -- The allocation for indefinite library-level objects occurs on the |
8923 | -- heap as opposed to the secondary stack. This accommodates DLLs where | |
8924 | -- the secondary stack is destroyed after each library unload. This is a | |
8925 | -- hybrid mechanism where a stack-allocated object lives on the heap. | |
8417f4b2 | 8926 | |
15529d0a PMR |
8927 | elsif Is_Library_Level_Entity (Obj_Def_Id) |
8928 | and then not Restriction_Active (No_Implicit_Heap_Allocations) | |
8929 | then | |
8930 | Add_Unconstrained_Actuals_To_Build_In_Place_Call | |
8931 | (Func_Call, Function_Id, Alloc_Form => Global_Heap); | |
8932 | Caller_Object := Empty; | |
8417f4b2 | 8933 | |
15529d0a PMR |
8934 | -- Create a finalization master for the access result type to ensure |
8935 | -- that the heap allocation can properly chain the object and later | |
8936 | -- finalize it when the library unit goes out of scope. | |
8417f4b2 | 8937 | |
15529d0a PMR |
8938 | if Needs_Finalization (Etype (Func_Call)) then |
8939 | Build_Finalization_Master | |
8940 | (Typ => Ptr_Typ, | |
8941 | For_Lib_Level => True, | |
8942 | Insertion_Node => Ptr_Typ_Decl); | |
1bb6e262 | 8943 | |
15529d0a PMR |
8944 | Fmaster_Actual := |
8945 | Make_Attribute_Reference (Loc, | |
8946 | Prefix => | |
8947 | New_Occurrence_Of (Finalization_Master (Ptr_Typ), Loc), | |
8948 | Attribute_Name => Name_Unrestricted_Access); | |
8949 | end if; | |
1bb6e262 | 8950 | |
6560f851 HK |
8951 | -- In other indefinite cases, pass an indication to do the allocation |
8952 | -- on the secondary stack and set Caller_Object to Empty so that a null | |
15529d0a PMR |
8953 | -- value will be passed for the caller's object address. A transient |
8954 | -- scope is established to ensure eventual cleanup of the result. | |
1bb6e262 | 8955 | |
15529d0a PMR |
8956 | else |
8957 | Add_Unconstrained_Actuals_To_Build_In_Place_Call | |
8958 | (Func_Call, Function_Id, Alloc_Form => Secondary_Stack); | |
8959 | Caller_Object := Empty; | |
1bb6e262 | 8960 | |
6560f851 | 8961 | Establish_Transient_Scope (Obj_Decl, Manage_Sec_Stack => True); |
15529d0a | 8962 | end if; |
1bb6e262 | 8963 | |
15529d0a PMR |
8964 | -- Pass along any finalization master actual, which is needed in the |
8965 | -- case where the called function initializes a return object of an | |
8966 | -- enclosing build-in-place function. | |
1bb6e262 | 8967 | |
15529d0a PMR |
8968 | Add_Finalization_Master_Actual_To_Build_In_Place_Call |
8969 | (Func_Call => Func_Call, | |
8970 | Func_Id => Function_Id, | |
8971 | Master_Exp => Fmaster_Actual); | |
8434cfc7 | 8972 | |
15529d0a | 8973 | if Nkind (Parent (Obj_Decl)) = N_Extended_Return_Statement |
1ed19d98 | 8974 | and then Needs_BIP_Task_Actuals (Function_Id) |
15529d0a PMR |
8975 | then |
8976 | -- Here we're passing along the master that was passed in to this | |
8977 | -- function. | |
8434cfc7 | 8978 | |
15529d0a PMR |
8979 | Add_Task_Actuals_To_Build_In_Place_Call |
8980 | (Func_Call, Function_Id, | |
8981 | Master_Actual => | |
8982 | New_Occurrence_Of | |
8983 | (Build_In_Place_Formal (Encl_Func, BIP_Task_Master), Loc)); | |
8434cfc7 | 8984 | |
15529d0a PMR |
8985 | else |
8986 | Add_Task_Actuals_To_Build_In_Place_Call | |
8987 | (Func_Call, Function_Id, Make_Identifier (Loc, Name_uMaster)); | |
8988 | end if; | |
8434cfc7 | 8989 | |
15529d0a PMR |
8990 | Add_Access_Actual_To_Build_In_Place_Call |
8991 | (Func_Call, | |
8992 | Function_Id, | |
8993 | Caller_Object, | |
8994 | Is_Access => Pass_Caller_Acc); | |
8434cfc7 | 8995 | |
15529d0a PMR |
8996 | -- Finally, create an access object initialized to a reference to the |
8997 | -- function call. We know this access value cannot be null, so mark the | |
8998 | -- entity accordingly to suppress the access check. | |
2c17ca0a | 8999 | |
15529d0a PMR |
9000 | Def_Id := Make_Temporary (Loc, 'R', Func_Call); |
9001 | Set_Etype (Def_Id, Ptr_Typ); | |
9002 | Set_Is_Known_Non_Null (Def_Id); | |
7888a6ae | 9003 | |
3fc40cd7 PMR |
9004 | if Nkind_In (Function_Call, N_Type_Conversion, |
9005 | N_Unchecked_Type_Conversion) | |
5d57846b | 9006 | then |
15529d0a PMR |
9007 | Res_Decl := |
9008 | Make_Object_Declaration (Loc, | |
9009 | Defining_Identifier => Def_Id, | |
9010 | Constant_Present => True, | |
9011 | Object_Definition => New_Occurrence_Of (Ptr_Typ, Loc), | |
9012 | Expression => | |
3fc40cd7 PMR |
9013 | Make_Unchecked_Type_Conversion (Loc, |
9014 | New_Occurrence_Of (Ptr_Typ, Loc), | |
9015 | Make_Reference (Loc, Relocate_Node (Func_Call)))); | |
15529d0a PMR |
9016 | else |
9017 | Res_Decl := | |
9018 | Make_Object_Declaration (Loc, | |
9019 | Defining_Identifier => Def_Id, | |
9020 | Constant_Present => True, | |
9021 | Object_Definition => New_Occurrence_Of (Ptr_Typ, Loc), | |
9022 | Expression => | |
9023 | Make_Reference (Loc, Relocate_Node (Func_Call))); | |
9024 | end if; | |
7888a6ae | 9025 | |
15529d0a | 9026 | Insert_After_And_Analyze (Ptr_Typ_Decl, Res_Decl); |
7888a6ae | 9027 | |
15529d0a PMR |
9028 | -- If the result subtype of the called function is definite and is not |
9029 | -- itself the return expression of an enclosing BIP function, then mark | |
9030 | -- the object as having no initialization. | |
7888a6ae | 9031 | |
3fc40cd7 PMR |
9032 | if Definite and then not Is_Return_Object (Obj_Def_Id) then |
9033 | ||
15529d0a PMR |
9034 | -- The related object declaration is encased in a transient block |
9035 | -- because the build-in-place function call contains at least one | |
9036 | -- nested function call that produces a controlled transient | |
9037 | -- temporary: | |
02822a92 | 9038 | |
15529d0a | 9039 | -- Obj : ... := BIP_Func_Call (Ctrl_Func_Call); |
02822a92 | 9040 | |
15529d0a PMR |
9041 | -- Since the build-in-place expansion decouples the call from the |
9042 | -- object declaration, the finalization machinery lacks the context | |
9043 | -- which prompted the generation of the transient block. To resolve | |
9044 | -- this scenario, store the build-in-place call. | |
c12beea0 | 9045 | |
15529d0a PMR |
9046 | if Scope_Is_Transient and then Node_To_Be_Wrapped = Obj_Decl then |
9047 | Set_BIP_Initialization_Call (Obj_Def_Id, Res_Decl); | |
d4dfb005 | 9048 | end if; |
f65c67d3 | 9049 | |
15529d0a PMR |
9050 | Set_Expression (Obj_Decl, Empty); |
9051 | Set_No_Initialization (Obj_Decl); | |
f937473f | 9052 | |
15529d0a PMR |
9053 | -- In case of an indefinite result subtype, or if the call is the |
9054 | -- return expression of an enclosing BIP function, rewrite the object | |
9055 | -- declaration as an object renaming where the renamed object is a | |
9056 | -- dereference of <function_Call>'reference: | |
9057 | -- | |
9058 | -- Obj : Subt renames <function_call>'Ref.all; | |
f937473f | 9059 | |
15529d0a PMR |
9060 | else |
9061 | Call_Deref := | |
9062 | Make_Explicit_Dereference (Obj_Loc, | |
9063 | Prefix => New_Occurrence_Of (Def_Id, Obj_Loc)); | |
9064 | ||
9065 | Rewrite (Obj_Decl, | |
9066 | Make_Object_Renaming_Declaration (Obj_Loc, | |
9067 | Defining_Identifier => Make_Temporary (Obj_Loc, 'D'), | |
3fc40cd7 | 9068 | Subtype_Mark => |
15529d0a | 9069 | New_Occurrence_Of (Designated_Type, Obj_Loc), |
3fc40cd7 | 9070 | Name => Call_Deref)); |
15529d0a | 9071 | |
90e491a7 PMR |
9072 | -- At this point, Defining_Identifier (Obj_Decl) is no longer equal |
9073 | -- to Obj_Def_Id. | |
9074 | ||
9075 | Set_Renamed_Object (Defining_Identifier (Obj_Decl), Call_Deref); | |
15529d0a PMR |
9076 | |
9077 | -- If the original entity comes from source, then mark the new | |
9078 | -- entity as needing debug information, even though it's defined | |
9079 | -- by a generated renaming that does not come from source, so that | |
9080 | -- the Materialize_Entity flag will be set on the entity when | |
9081 | -- Debug_Renaming_Declaration is called during analysis. | |
9082 | ||
9083 | if Comes_From_Source (Obj_Def_Id) then | |
90e491a7 | 9084 | Set_Debug_Info_Needed (Defining_Identifier (Obj_Decl)); |
0691ed6b | 9085 | end if; |
cd644ae2 | 9086 | |
15529d0a PMR |
9087 | Analyze (Obj_Decl); |
9088 | Replace_Renaming_Declaration_Id | |
9089 | (Obj_Decl, Original_Node (Obj_Decl)); | |
cd644ae2 | 9090 | end if; |
1ed19d98 JM |
9091 | |
9092 | pragma Assert (Check_Number_Of_Actuals (Func_Call, Function_Id)); | |
02822a92 RD |
9093 | end Make_Build_In_Place_Call_In_Object_Declaration; |
9094 | ||
4ac62786 AC |
9095 | ------------------------------------------------- |
9096 | -- Make_Build_In_Place_Iface_Call_In_Allocator -- | |
9097 | ------------------------------------------------- | |
9098 | ||
9099 | procedure Make_Build_In_Place_Iface_Call_In_Allocator | |
9100 | (Allocator : Node_Id; | |
9101 | Function_Call : Node_Id) | |
9102 | is | |
9103 | BIP_Func_Call : constant Node_Id := | |
9104 | Unqual_BIP_Iface_Function_Call (Function_Call); | |
9105 | Loc : constant Source_Ptr := Sloc (Function_Call); | |
9106 | ||
9107 | Anon_Type : Entity_Id; | |
9108 | Tmp_Decl : Node_Id; | |
9109 | Tmp_Id : Entity_Id; | |
9110 | ||
9111 | begin | |
9112 | -- No action of the call has already been processed | |
9113 | ||
9114 | if Is_Expanded_Build_In_Place_Call (BIP_Func_Call) then | |
9115 | return; | |
9116 | end if; | |
9117 | ||
9118 | Tmp_Id := Make_Temporary (Loc, 'D'); | |
9119 | ||
9120 | -- Insert a temporary before N initialized with the BIP function call | |
9121 | -- without its enclosing type conversions and analyze it without its | |
9122 | -- expansion. This temporary facilitates us reusing the BIP machinery, | |
9123 | -- which takes care of adding the extra build-in-place actuals and | |
9124 | -- transforms this object declaration into an object renaming | |
9125 | -- declaration. | |
9126 | ||
9127 | Anon_Type := Create_Itype (E_Anonymous_Access_Type, Function_Call); | |
9128 | Set_Directly_Designated_Type (Anon_Type, Etype (BIP_Func_Call)); | |
9129 | Set_Etype (Anon_Type, Anon_Type); | |
9130 | ||
9131 | Tmp_Decl := | |
9132 | Make_Object_Declaration (Loc, | |
9133 | Defining_Identifier => Tmp_Id, | |
9134 | Object_Definition => New_Occurrence_Of (Anon_Type, Loc), | |
9135 | Expression => | |
9136 | Make_Allocator (Loc, | |
9137 | Expression => | |
9138 | Make_Qualified_Expression (Loc, | |
9139 | Subtype_Mark => | |
9140 | New_Occurrence_Of (Etype (BIP_Func_Call), Loc), | |
9141 | Expression => New_Copy_Tree (BIP_Func_Call)))); | |
9142 | ||
9143 | Expander_Mode_Save_And_Set (False); | |
9144 | Insert_Action (Allocator, Tmp_Decl); | |
9145 | Expander_Mode_Restore; | |
9146 | ||
9147 | Make_Build_In_Place_Call_In_Allocator | |
9148 | (Allocator => Expression (Tmp_Decl), | |
9149 | Function_Call => Expression (Expression (Tmp_Decl))); | |
9150 | ||
9151 | Rewrite (Allocator, New_Occurrence_Of (Tmp_Id, Loc)); | |
9152 | end Make_Build_In_Place_Iface_Call_In_Allocator; | |
9153 | ||
9154 | --------------------------------------------------------- | |
9155 | -- Make_Build_In_Place_Iface_Call_In_Anonymous_Context -- | |
9156 | --------------------------------------------------------- | |
9157 | ||
9158 | procedure Make_Build_In_Place_Iface_Call_In_Anonymous_Context | |
9159 | (Function_Call : Node_Id) | |
9160 | is | |
9161 | BIP_Func_Call : constant Node_Id := | |
9162 | Unqual_BIP_Iface_Function_Call (Function_Call); | |
9163 | Loc : constant Source_Ptr := Sloc (Function_Call); | |
9164 | ||
9165 | Tmp_Decl : Node_Id; | |
9166 | Tmp_Id : Entity_Id; | |
9167 | ||
9168 | begin | |
9169 | -- No action of the call has already been processed | |
9170 | ||
9171 | if Is_Expanded_Build_In_Place_Call (BIP_Func_Call) then | |
9172 | return; | |
9173 | end if; | |
9174 | ||
9175 | pragma Assert (Needs_Finalization (Etype (BIP_Func_Call))); | |
9176 | ||
9177 | -- Insert a temporary before the call initialized with function call to | |
9178 | -- reuse the BIP machinery which takes care of adding the extra build-in | |
9179 | -- place actuals and transforms this object declaration into an object | |
9180 | -- renaming declaration. | |
9181 | ||
9182 | Tmp_Id := Make_Temporary (Loc, 'D'); | |
9183 | ||
9184 | Tmp_Decl := | |
9185 | Make_Object_Declaration (Loc, | |
9186 | Defining_Identifier => Tmp_Id, | |
9187 | Object_Definition => | |
9188 | New_Occurrence_Of (Etype (Function_Call), Loc), | |
9189 | Expression => Relocate_Node (Function_Call)); | |
9190 | ||
9191 | Expander_Mode_Save_And_Set (False); | |
9192 | Insert_Action (Function_Call, Tmp_Decl); | |
9193 | Expander_Mode_Restore; | |
9194 | ||
9195 | Make_Build_In_Place_Iface_Call_In_Object_Declaration | |
9196 | (Obj_Decl => Tmp_Decl, | |
9197 | Function_Call => Expression (Tmp_Decl)); | |
9198 | end Make_Build_In_Place_Iface_Call_In_Anonymous_Context; | |
9199 | ||
9200 | ---------------------------------------------------------- | |
9201 | -- Make_Build_In_Place_Iface_Call_In_Object_Declaration -- | |
9202 | ---------------------------------------------------------- | |
9203 | ||
9204 | procedure Make_Build_In_Place_Iface_Call_In_Object_Declaration | |
9205 | (Obj_Decl : Node_Id; | |
9206 | Function_Call : Node_Id) | |
9207 | is | |
9208 | BIP_Func_Call : constant Node_Id := | |
9209 | Unqual_BIP_Iface_Function_Call (Function_Call); | |
9210 | Loc : constant Source_Ptr := Sloc (Function_Call); | |
9211 | Obj_Id : constant Entity_Id := Defining_Entity (Obj_Decl); | |
9212 | ||
9213 | Tmp_Decl : Node_Id; | |
9214 | Tmp_Id : Entity_Id; | |
9215 | ||
9216 | begin | |
9217 | -- No action of the call has already been processed | |
9218 | ||
9219 | if Is_Expanded_Build_In_Place_Call (BIP_Func_Call) then | |
9220 | return; | |
9221 | end if; | |
9222 | ||
9223 | Tmp_Id := Make_Temporary (Loc, 'D'); | |
9224 | ||
9225 | -- Insert a temporary before N initialized with the BIP function call | |
9226 | -- without its enclosing type conversions and analyze it without its | |
9227 | -- expansion. This temporary facilitates us reusing the BIP machinery, | |
9228 | -- which takes care of adding the extra build-in-place actuals and | |
9229 | -- transforms this object declaration into an object renaming | |
9230 | -- declaration. | |
9231 | ||
9232 | Tmp_Decl := | |
9233 | Make_Object_Declaration (Loc, | |
9234 | Defining_Identifier => Tmp_Id, | |
9235 | Object_Definition => | |
9236 | New_Occurrence_Of (Etype (BIP_Func_Call), Loc), | |
9237 | Expression => New_Copy_Tree (BIP_Func_Call)); | |
9238 | ||
9239 | Expander_Mode_Save_And_Set (False); | |
9240 | Insert_Action (Obj_Decl, Tmp_Decl); | |
9241 | Expander_Mode_Restore; | |
9242 | ||
9243 | Make_Build_In_Place_Call_In_Object_Declaration | |
9244 | (Obj_Decl => Tmp_Decl, | |
9245 | Function_Call => Expression (Tmp_Decl)); | |
9246 | ||
9247 | pragma Assert (Nkind (Tmp_Decl) = N_Object_Renaming_Declaration); | |
9248 | ||
9249 | -- Replace the original build-in-place function call by a reference to | |
9250 | -- the resulting temporary object renaming declaration. In this way, | |
9251 | -- all the interface conversions performed in the original Function_Call | |
9252 | -- on the build-in-place object are preserved. | |
9253 | ||
9254 | Rewrite (BIP_Func_Call, New_Occurrence_Of (Tmp_Id, Loc)); | |
9255 | ||
9256 | -- Replace the original object declaration by an internal object | |
9257 | -- renaming declaration. This leaves the generated code more clean (the | |
9258 | -- build-in-place function call in an object renaming declaration and | |
9259 | -- displacements of the pointer to the build-in-place object in another | |
9260 | -- renaming declaration) and allows us to invoke the routine that takes | |
9261 | -- care of replacing the identifier of the renaming declaration (routine | |
9262 | -- originally developed for the regular build-in-place management). | |
9263 | ||
9264 | Rewrite (Obj_Decl, | |
9265 | Make_Object_Renaming_Declaration (Loc, | |
9266 | Defining_Identifier => Make_Temporary (Loc, 'D'), | |
9267 | Subtype_Mark => New_Occurrence_Of (Etype (Obj_Id), Loc), | |
9268 | Name => Function_Call)); | |
9269 | Analyze (Obj_Decl); | |
9270 | ||
9271 | Replace_Renaming_Declaration_Id (Obj_Decl, Original_Node (Obj_Decl)); | |
9272 | end Make_Build_In_Place_Iface_Call_In_Object_Declaration; | |
9273 | ||
3bfb3c03 JM |
9274 | -------------------------------------------- |
9275 | -- Make_CPP_Constructor_Call_In_Allocator -- | |
9276 | -------------------------------------------- | |
9277 | ||
9278 | procedure Make_CPP_Constructor_Call_In_Allocator | |
9279 | (Allocator : Node_Id; | |
9280 | Function_Call : Node_Id) | |
9281 | is | |
9282 | Loc : constant Source_Ptr := Sloc (Function_Call); | |
9283 | Acc_Type : constant Entity_Id := Etype (Allocator); | |
9284 | Function_Id : constant Entity_Id := Entity (Name (Function_Call)); | |
9285 | Result_Subt : constant Entity_Id := Available_View (Etype (Function_Id)); | |
9286 | ||
9287 | New_Allocator : Node_Id; | |
9288 | Return_Obj_Access : Entity_Id; | |
9289 | Tmp_Obj : Node_Id; | |
9290 | ||
9291 | begin | |
9292 | pragma Assert (Nkind (Allocator) = N_Allocator | |
8c7ff9a0 | 9293 | and then Nkind (Function_Call) = N_Function_Call); |
3bfb3c03 | 9294 | pragma Assert (Convention (Function_Id) = Convention_CPP |
8c7ff9a0 | 9295 | and then Is_Constructor (Function_Id)); |
3bfb3c03 JM |
9296 | pragma Assert (Is_Constrained (Underlying_Type (Result_Subt))); |
9297 | ||
9298 | -- Replace the initialized allocator of form "new T'(Func (...))" with | |
9299 | -- an uninitialized allocator of form "new T", where T is the result | |
9300 | -- subtype of the called function. The call to the function is handled | |
9301 | -- separately further below. | |
9302 | ||
9303 | New_Allocator := | |
9304 | Make_Allocator (Loc, | |
e4494292 | 9305 | Expression => New_Occurrence_Of (Result_Subt, Loc)); |
3bfb3c03 JM |
9306 | Set_No_Initialization (New_Allocator); |
9307 | ||
9308 | -- Copy attributes to new allocator. Note that the new allocator | |
9309 | -- logically comes from source if the original one did, so copy the | |
9310 | -- relevant flag. This ensures proper treatment of the restriction | |
9311 | -- No_Implicit_Heap_Allocations in this case. | |
9312 | ||
9313 | Set_Storage_Pool (New_Allocator, Storage_Pool (Allocator)); | |
9314 | Set_Procedure_To_Call (New_Allocator, Procedure_To_Call (Allocator)); | |
9315 | Set_Comes_From_Source (New_Allocator, Comes_From_Source (Allocator)); | |
9316 | ||
9317 | Rewrite (Allocator, New_Allocator); | |
9318 | ||
9319 | -- Create a new access object and initialize it to the result of the | |
9320 | -- new uninitialized allocator. Note: we do not use Allocator as the | |
9321 | -- Related_Node of Return_Obj_Access in call to Make_Temporary below | |
9322 | -- as this would create a sort of infinite "recursion". | |
9323 | ||
9324 | Return_Obj_Access := Make_Temporary (Loc, 'R'); | |
9325 | Set_Etype (Return_Obj_Access, Acc_Type); | |
9326 | ||
9327 | -- Generate: | |
9328 | -- Rnnn : constant ptr_T := new (T); | |
9329 | -- Init (Rnn.all,...); | |
9330 | ||
9331 | Tmp_Obj := | |
9332 | Make_Object_Declaration (Loc, | |
9333 | Defining_Identifier => Return_Obj_Access, | |
9334 | Constant_Present => True, | |
e4494292 | 9335 | Object_Definition => New_Occurrence_Of (Acc_Type, Loc), |
3bfb3c03 JM |
9336 | Expression => Relocate_Node (Allocator)); |
9337 | Insert_Action (Allocator, Tmp_Obj); | |
9338 | ||
9339 | Insert_List_After_And_Analyze (Tmp_Obj, | |
9340 | Build_Initialization_Call (Loc, | |
9341 | Id_Ref => | |
9342 | Make_Explicit_Dereference (Loc, | |
e4494292 | 9343 | Prefix => New_Occurrence_Of (Return_Obj_Access, Loc)), |
3bfb3c03 JM |
9344 | Typ => Etype (Function_Id), |
9345 | Constructor_Ref => Function_Call)); | |
9346 | ||
9347 | -- Finally, replace the allocator node with a reference to the result of | |
9348 | -- the function call itself (which will effectively be an access to the | |
9349 | -- object created by the allocator). | |
9350 | ||
e4494292 | 9351 | Rewrite (Allocator, New_Occurrence_Of (Return_Obj_Access, Loc)); |
3bfb3c03 JM |
9352 | |
9353 | -- Ada 2005 (AI-251): If the type of the allocator is an interface then | |
9354 | -- generate an implicit conversion to force displacement of the "this" | |
9355 | -- pointer. | |
9356 | ||
9357 | if Is_Interface (Designated_Type (Acc_Type)) then | |
9358 | Rewrite (Allocator, Convert_To (Acc_Type, Relocate_Node (Allocator))); | |
9359 | end if; | |
9360 | ||
9361 | Analyze_And_Resolve (Allocator, Acc_Type); | |
9362 | end Make_CPP_Constructor_Call_In_Allocator; | |
9363 | ||
1ed19d98 JM |
9364 | ---------------------------- |
9365 | -- Needs_BIP_Task_Actuals -- | |
9366 | ---------------------------- | |
9367 | ||
9368 | function Needs_BIP_Task_Actuals (Func_Id : Entity_Id) return Boolean is | |
9369 | pragma Assert (Is_Build_In_Place_Function (Func_Id)); | |
9370 | Func_Typ : constant Entity_Id := Underlying_Type (Etype (Func_Id)); | |
9371 | begin | |
9372 | return Has_Task (Func_Typ); | |
9373 | end Needs_BIP_Task_Actuals; | |
9374 | ||
d3f70b35 AC |
9375 | ----------------------------------- |
9376 | -- Needs_BIP_Finalization_Master -- | |
9377 | ----------------------------------- | |
8fb68c56 | 9378 | |
d3f70b35 AC |
9379 | function Needs_BIP_Finalization_Master |
9380 | (Func_Id : Entity_Id) return Boolean | |
9381 | is | |
df3e68b1 HK |
9382 | pragma Assert (Is_Build_In_Place_Function (Func_Id)); |
9383 | Func_Typ : constant Entity_Id := Underlying_Type (Etype (Func_Id)); | |
048e5cef | 9384 | begin |
66340e0e AC |
9385 | -- A formal giving the finalization master is needed for build-in-place |
9386 | -- functions whose result type needs finalization or is a tagged type. | |
9387 | -- Tagged primitive build-in-place functions need such a formal because | |
9388 | -- they can be called by a dispatching call, and extensions may require | |
9389 | -- finalization even if the root type doesn't. This means they're also | |
9390 | -- needed for tagged nonprimitive build-in-place functions with tagged | |
9391 | -- results, since such functions can be called via access-to-function | |
9392 | -- types, and those can be used to call primitives, so masters have to | |
9393 | -- be passed to all such build-in-place functions, primitive or not. | |
9394 | ||
df3e68b1 HK |
9395 | return |
9396 | not Restriction_Active (No_Finalization) | |
66340e0e AC |
9397 | and then (Needs_Finalization (Func_Typ) |
9398 | or else Is_Tagged_Type (Func_Typ)); | |
d3f70b35 | 9399 | end Needs_BIP_Finalization_Master; |
048e5cef | 9400 | |
1bb6e262 AC |
9401 | -------------------------- |
9402 | -- Needs_BIP_Alloc_Form -- | |
9403 | -------------------------- | |
9404 | ||
9405 | function Needs_BIP_Alloc_Form (Func_Id : Entity_Id) return Boolean is | |
9406 | pragma Assert (Is_Build_In_Place_Function (Func_Id)); | |
9407 | Func_Typ : constant Entity_Id := Underlying_Type (Etype (Func_Id)); | |
1bb6e262 | 9408 | begin |
cf0e5ca7 | 9409 | return Requires_Transient_Scope (Func_Typ); |
1bb6e262 AC |
9410 | end Needs_BIP_Alloc_Form; |
9411 | ||
63585f75 SB |
9412 | -------------------------------------- |
9413 | -- Needs_Result_Accessibility_Level -- | |
9414 | -------------------------------------- | |
9415 | ||
9416 | function Needs_Result_Accessibility_Level | |
9417 | (Func_Id : Entity_Id) return Boolean | |
9418 | is | |
9419 | Func_Typ : constant Entity_Id := Underlying_Type (Etype (Func_Id)); | |
9420 | ||
9421 | function Has_Unconstrained_Access_Discriminant_Component | |
ebf494ec RD |
9422 | (Comp_Typ : Entity_Id) return Boolean; |
9423 | -- Returns True if any component of the type has an unconstrained access | |
9424 | -- discriminant. | |
63585f75 SB |
9425 | |
9426 | ----------------------------------------------------- | |
9427 | -- Has_Unconstrained_Access_Discriminant_Component -- | |
9428 | ----------------------------------------------------- | |
9429 | ||
9430 | function Has_Unconstrained_Access_Discriminant_Component | |
9431 | (Comp_Typ : Entity_Id) return Boolean | |
9432 | is | |
9433 | begin | |
9434 | if not Is_Limited_Type (Comp_Typ) then | |
9435 | return False; | |
ebf494ec | 9436 | |
63585f75 SB |
9437 | -- Only limited types can have access discriminants with |
9438 | -- defaults. | |
9439 | ||
9440 | elsif Has_Unconstrained_Access_Discriminants (Comp_Typ) then | |
9441 | return True; | |
9442 | ||
9443 | elsif Is_Array_Type (Comp_Typ) then | |
9444 | return Has_Unconstrained_Access_Discriminant_Component | |
9445 | (Underlying_Type (Component_Type (Comp_Typ))); | |
9446 | ||
9447 | elsif Is_Record_Type (Comp_Typ) then | |
9448 | declare | |
ebf494ec RD |
9449 | Comp : Entity_Id; |
9450 | ||
63585f75 | 9451 | begin |
ebf494ec | 9452 | Comp := First_Component (Comp_Typ); |
63585f75 SB |
9453 | while Present (Comp) loop |
9454 | if Has_Unconstrained_Access_Discriminant_Component | |
9455 | (Underlying_Type (Etype (Comp))) | |
9456 | then | |
9457 | return True; | |
9458 | end if; | |
9459 | ||
9460 | Next_Component (Comp); | |
9461 | end loop; | |
9462 | end; | |
9463 | end if; | |
9464 | ||
9465 | return False; | |
9466 | end Has_Unconstrained_Access_Discriminant_Component; | |
9467 | ||
8d21ff60 JS |
9468 | Disable_Coextension_Cases : constant Boolean := True; |
9469 | -- Flag used to temporarily disable a "True" result for types with | |
9470 | -- access discriminants and related coextension cases. | |
57a3fca9 | 9471 | |
63585f75 SB |
9472 | -- Start of processing for Needs_Result_Accessibility_Level |
9473 | ||
9474 | begin | |
ebf494ec RD |
9475 | -- False if completion unavailable (how does this happen???) |
9476 | ||
9477 | if not Present (Func_Typ) then | |
9478 | return False; | |
63585f75 | 9479 | |
ebf494ec | 9480 | -- False if not a function, also handle enum-lit renames case |
63585f75 | 9481 | |
ebf494ec RD |
9482 | elsif Func_Typ = Standard_Void_Type |
9483 | or else Is_Scalar_Type (Func_Typ) | |
63585f75 SB |
9484 | then |
9485 | return False; | |
63585f75 | 9486 | |
ebf494ec | 9487 | -- Handle a corner case, a cross-dialect subp renaming. For example, |
30168043 AC |
9488 | -- an Ada 2012 renaming of an Ada 2005 subprogram. This can occur when |
9489 | -- an Ada 2005 (or earlier) unit references predefined run-time units. | |
ebf494ec RD |
9490 | |
9491 | elsif Present (Alias (Func_Id)) then | |
9492 | ||
63585f75 SB |
9493 | -- Unimplemented: a cross-dialect subp renaming which does not set |
9494 | -- the Alias attribute (e.g., a rename of a dereference of an access | |
54bf19e4 | 9495 | -- to subprogram value). ??? |
63585f75 SB |
9496 | |
9497 | return Present (Extra_Accessibility_Of_Result (Alias (Func_Id))); | |
63585f75 | 9498 | |
ebf494ec RD |
9499 | -- Remaining cases require Ada 2012 mode |
9500 | ||
9501 | elsif Ada_Version < Ada_2012 then | |
63585f75 | 9502 | return False; |
63585f75 | 9503 | |
8d21ff60 JS |
9504 | -- Handle the situation where a result is an anonymous access type |
9505 | -- RM 3.10.2 (10.3/3). | |
9506 | ||
9507 | elsif Ekind (Func_Typ) = E_Anonymous_Access_Type then | |
9508 | return True; | |
9509 | ||
9510 | -- The following cases are related to coextensions and do not fully | |
9511 | -- cover everything mentioned in RM 3.10.2 (12) ??? | |
9512 | ||
9513 | -- Temporarily disabled ??? | |
9514 | ||
9515 | elsif Disable_Coextension_Cases then | |
9516 | return False; | |
9517 | ||
9518 | -- In the case of, say, a null tagged record result type, the need for | |
9519 | -- this extra parameter might not be obvious so this function returns | |
9520 | -- True for all tagged types for compatibility reasons. | |
9521 | ||
9522 | -- A function with, say, a tagged null controlling result type might | |
9523 | -- be overridden by a primitive of an extension having an access | |
9524 | -- discriminant and the overrider and overridden must have compatible | |
9525 | -- calling conventions (including implicitly declared parameters). | |
9526 | ||
9527 | -- Similarly, values of one access-to-subprogram type might designate | |
9528 | -- both a primitive subprogram of a given type and a function which is, | |
9529 | -- for example, not a primitive subprogram of any type. Again, this | |
9530 | -- requires calling convention compatibility. It might be possible to | |
9531 | -- solve these issues by introducing wrappers, but that is not the | |
9532 | -- approach that was chosen. | |
63585f75 | 9533 | |
8d21ff60 | 9534 | elsif Is_Tagged_Type (Func_Typ) then |
63585f75 | 9535 | return True; |
63585f75 | 9536 | |
ebf494ec | 9537 | elsif Has_Unconstrained_Access_Discriminants (Func_Typ) then |
63585f75 | 9538 | return True; |
63585f75 | 9539 | |
ebf494ec | 9540 | elsif Has_Unconstrained_Access_Discriminant_Component (Func_Typ) then |
63585f75 | 9541 | return True; |
63585f75 | 9542 | |
ebf494ec RD |
9543 | -- False for all other cases |
9544 | ||
9545 | else | |
9546 | return False; | |
9547 | end if; | |
63585f75 SB |
9548 | end Needs_Result_Accessibility_Level; |
9549 | ||
4ac62786 AC |
9550 | ------------------------------------- |
9551 | -- Replace_Renaming_Declaration_Id -- | |
9552 | ------------------------------------- | |
9553 | ||
9554 | procedure Replace_Renaming_Declaration_Id | |
9555 | (New_Decl : Node_Id; | |
9556 | Orig_Decl : Node_Id) | |
9557 | is | |
9558 | New_Id : constant Entity_Id := Defining_Entity (New_Decl); | |
9559 | Orig_Id : constant Entity_Id := Defining_Entity (Orig_Decl); | |
9560 | ||
9561 | begin | |
9562 | Set_Chars (New_Id, Chars (Orig_Id)); | |
9563 | ||
9564 | -- Swap next entity links in preparation for exchanging entities | |
9565 | ||
9566 | declare | |
9567 | Next_Id : constant Entity_Id := Next_Entity (New_Id); | |
9568 | begin | |
3f6d1daa JS |
9569 | Link_Entities (New_Id, Next_Entity (Orig_Id)); |
9570 | Link_Entities (Orig_Id, Next_Id); | |
4ac62786 AC |
9571 | end; |
9572 | ||
9573 | Set_Homonym (New_Id, Homonym (Orig_Id)); | |
9574 | Exchange_Entities (New_Id, Orig_Id); | |
9575 | ||
9576 | -- Preserve source indication of original declaration, so that xref | |
9577 | -- information is properly generated for the right entity. | |
9578 | ||
9579 | Preserve_Comes_From_Source (New_Decl, Orig_Decl); | |
9580 | Preserve_Comes_From_Source (Orig_Id, Orig_Decl); | |
9581 | ||
9582 | Set_Comes_From_Source (New_Id, False); | |
9583 | end Replace_Renaming_Declaration_Id; | |
9584 | ||
2700b9c1 AC |
9585 | --------------------------------- |
9586 | -- Rewrite_Function_Call_For_C -- | |
9587 | --------------------------------- | |
9588 | ||
9589 | procedure Rewrite_Function_Call_For_C (N : Node_Id) is | |
9b7924dd AC |
9590 | Orig_Func : constant Entity_Id := Entity (Name (N)); |
9591 | Func_Id : constant Entity_Id := Ultimate_Alias (Orig_Func); | |
5c12e9fb | 9592 | Par : constant Node_Id := Parent (N); |
888be6b1 | 9593 | Proc_Id : constant Entity_Id := Corresponding_Procedure (Func_Id); |
cdabbb52 | 9594 | Loc : constant Source_Ptr := Sloc (Par); |
5c12e9fb | 9595 | Actuals : List_Id; |
9b7924dd | 9596 | Last_Actual : Node_Id; |
5c12e9fb | 9597 | Last_Formal : Entity_Id; |
2700b9c1 | 9598 | |
aeb98f1d JM |
9599 | -- Start of processing for Rewrite_Function_Call_For_C |
9600 | ||
2700b9c1 | 9601 | begin |
cdabbb52 HK |
9602 | -- The actuals may be given by named associations, so the added actual |
9603 | -- that is the target of the return value of the call must be a named | |
9604 | -- association as well, so we retrieve the name of the generated | |
9605 | -- out_formal. | |
5c12e9fb AC |
9606 | |
9607 | Last_Formal := First_Formal (Proc_Id); | |
9608 | while Present (Next_Formal (Last_Formal)) loop | |
9609 | Last_Formal := Next_Formal (Last_Formal); | |
9610 | end loop; | |
9611 | ||
2700b9c1 AC |
9612 | Actuals := Parameter_Associations (N); |
9613 | ||
6f99dcec | 9614 | -- The original function may lack parameters |
241fac51 ES |
9615 | |
9616 | if No (Actuals) then | |
9617 | Actuals := New_List; | |
9618 | end if; | |
9619 | ||
2700b9c1 AC |
9620 | -- If the function call is the expression of an assignment statement, |
9621 | -- transform the assignment into a procedure call. Generate: | |
9622 | ||
9623 | -- LHS := Func_Call (...); | |
9624 | ||
9625 | -- Proc_Call (..., LHS); | |
9626 | ||
9b7924dd AC |
9627 | -- If function is inherited, a conversion may be necessary. |
9628 | ||
2700b9c1 | 9629 | if Nkind (Par) = N_Assignment_Statement then |
9b7924dd AC |
9630 | Last_Actual := Name (Par); |
9631 | ||
9632 | if not Comes_From_Source (Orig_Func) | |
9633 | and then Etype (Orig_Func) /= Etype (Func_Id) | |
9634 | then | |
2a253c5b AC |
9635 | Last_Actual := |
9636 | Make_Type_Conversion (Loc, | |
9637 | New_Occurrence_Of (Etype (Func_Id), Loc), | |
9638 | Last_Actual); | |
9b7924dd AC |
9639 | end if; |
9640 | ||
5c12e9fb AC |
9641 | Append_To (Actuals, |
9642 | Make_Parameter_Association (Loc, | |
cdabbb52 HK |
9643 | Selector_Name => |
9644 | Make_Identifier (Loc, Chars (Last_Formal)), | |
9b7924dd | 9645 | Explicit_Actual_Parameter => Last_Actual)); |
cdabbb52 | 9646 | |
2700b9c1 AC |
9647 | Rewrite (Par, |
9648 | Make_Procedure_Call_Statement (Loc, | |
9649 | Name => New_Occurrence_Of (Proc_Id, Loc), | |
9650 | Parameter_Associations => Actuals)); | |
9651 | Analyze (Par); | |
9652 | ||
9653 | -- Otherwise the context is an expression. Generate a temporary and a | |
9654 | -- procedure call to obtain the function result. Generate: | |
9655 | ||
9656 | -- ... Func_Call (...) ... | |
9657 | ||
9658 | -- Temp : ...; | |
9659 | -- Proc_Call (..., Temp); | |
9660 | -- ... Temp ... | |
9661 | ||
9662 | else | |
9663 | declare | |
9664 | Temp_Id : constant Entity_Id := Make_Temporary (Loc, 'T'); | |
9665 | Call : Node_Id; | |
9666 | Decl : Node_Id; | |
9667 | ||
9668 | begin | |
9669 | -- Generate: | |
9670 | -- Temp : ...; | |
9671 | ||
9672 | Decl := | |
9673 | Make_Object_Declaration (Loc, | |
9674 | Defining_Identifier => Temp_Id, | |
9675 | Object_Definition => | |
9676 | New_Occurrence_Of (Etype (Func_Id), Loc)); | |
9677 | ||
9678 | -- Generate: | |
9679 | -- Proc_Call (..., Temp); | |
9680 | ||
5c12e9fb AC |
9681 | Append_To (Actuals, |
9682 | Make_Parameter_Association (Loc, | |
cdabbb52 HK |
9683 | Selector_Name => |
9684 | Make_Identifier (Loc, Chars (Last_Formal)), | |
9685 | Explicit_Actual_Parameter => | |
9686 | New_Occurrence_Of (Temp_Id, Loc))); | |
9687 | ||
2700b9c1 AC |
9688 | Call := |
9689 | Make_Procedure_Call_Statement (Loc, | |
9690 | Name => New_Occurrence_Of (Proc_Id, Loc), | |
9691 | Parameter_Associations => Actuals); | |
9692 | ||
9693 | Insert_Actions (Par, New_List (Decl, Call)); | |
9694 | Rewrite (N, New_Occurrence_Of (Temp_Id, Loc)); | |
9695 | end; | |
9696 | end if; | |
9697 | end Rewrite_Function_Call_For_C; | |
9698 | ||
c79f6efd BD |
9699 | ------------------------------------ |
9700 | -- Set_Enclosing_Sec_Stack_Return -- | |
9701 | ------------------------------------ | |
9702 | ||
9703 | procedure Set_Enclosing_Sec_Stack_Return (N : Node_Id) is | |
9704 | P : Node_Id := N; | |
9705 | ||
9706 | begin | |
9707 | -- Due to a possible mix of internally generated blocks, source blocks | |
9708 | -- and loops, the scope stack may not be contiguous as all labels are | |
9709 | -- inserted at the top level within the related function. Instead, | |
9710 | -- perform a parent-based traversal and mark all appropriate constructs. | |
9711 | ||
9712 | while Present (P) loop | |
9713 | ||
9714 | -- Mark the label of a source or internally generated block or | |
9715 | -- loop. | |
9716 | ||
9717 | if Nkind_In (P, N_Block_Statement, N_Loop_Statement) then | |
9718 | Set_Sec_Stack_Needed_For_Return (Entity (Identifier (P))); | |
9719 | ||
9720 | -- Mark the enclosing function | |
9721 | ||
9722 | elsif Nkind (P) = N_Subprogram_Body then | |
9723 | if Present (Corresponding_Spec (P)) then | |
9724 | Set_Sec_Stack_Needed_For_Return (Corresponding_Spec (P)); | |
9725 | else | |
9726 | Set_Sec_Stack_Needed_For_Return (Defining_Entity (P)); | |
9727 | end if; | |
9728 | ||
9729 | -- Do not go beyond the enclosing function | |
9730 | ||
9731 | exit; | |
9732 | end if; | |
9733 | ||
9734 | P := Parent (P); | |
9735 | end loop; | |
9736 | end Set_Enclosing_Sec_Stack_Return; | |
9737 | ||
4ac62786 AC |
9738 | ------------------------------------ |
9739 | -- Unqual_BIP_Iface_Function_Call -- | |
9740 | ------------------------------------ | |
9741 | ||
9742 | function Unqual_BIP_Iface_Function_Call (Expr : Node_Id) return Node_Id is | |
9743 | Has_Pointer_Displacement : Boolean := False; | |
9744 | On_Object_Declaration : Boolean := False; | |
9745 | -- Remember if processing the renaming expressions on recursion we have | |
9746 | -- traversed an object declaration, since we can traverse many object | |
9747 | -- declaration renamings but just one regular object declaration. | |
9748 | ||
9749 | function Unqual_BIP_Function_Call (Expr : Node_Id) return Node_Id; | |
9750 | -- Search for a build-in-place function call skipping any qualification | |
9751 | -- including qualified expressions, type conversions, references, calls | |
9752 | -- to displace the pointer to the object, and renamings. Return Empty if | |
9753 | -- no build-in-place function call is found. | |
9754 | ||
9755 | ------------------------------ | |
9756 | -- Unqual_BIP_Function_Call -- | |
9757 | ------------------------------ | |
9758 | ||
9759 | function Unqual_BIP_Function_Call (Expr : Node_Id) return Node_Id is | |
9760 | begin | |
9761 | -- Recurse to handle case of multiple levels of qualification and/or | |
9762 | -- conversion. | |
9763 | ||
9764 | if Nkind_In (Expr, N_Qualified_Expression, | |
9765 | N_Type_Conversion, | |
9766 | N_Unchecked_Type_Conversion) | |
9767 | then | |
9768 | return Unqual_BIP_Function_Call (Expression (Expr)); | |
9769 | ||
9770 | -- Recurse to handle case of multiple levels of references and | |
9771 | -- explicit dereferences. | |
9772 | ||
9773 | elsif Nkind_In (Expr, N_Attribute_Reference, | |
9774 | N_Explicit_Dereference, | |
9775 | N_Reference) | |
9776 | then | |
9777 | return Unqual_BIP_Function_Call (Prefix (Expr)); | |
9778 | ||
9779 | -- Recurse on object renamings | |
9780 | ||
9781 | elsif Nkind (Expr) = N_Identifier | |
f63adaa7 | 9782 | and then Present (Entity (Expr)) |
4ac62786 AC |
9783 | and then Ekind_In (Entity (Expr), E_Constant, E_Variable) |
9784 | and then Nkind (Parent (Entity (Expr))) = | |
9785 | N_Object_Renaming_Declaration | |
9786 | and then Present (Renamed_Object (Entity (Expr))) | |
9787 | then | |
9788 | return Unqual_BIP_Function_Call (Renamed_Object (Entity (Expr))); | |
9789 | ||
9790 | -- Recurse on the initializing expression of the first reference of | |
9791 | -- an object declaration. | |
9792 | ||
9793 | elsif not On_Object_Declaration | |
9794 | and then Nkind (Expr) = N_Identifier | |
f63adaa7 | 9795 | and then Present (Entity (Expr)) |
4ac62786 AC |
9796 | and then Ekind_In (Entity (Expr), E_Constant, E_Variable) |
9797 | and then Nkind (Parent (Entity (Expr))) = N_Object_Declaration | |
9798 | and then Present (Expression (Parent (Entity (Expr)))) | |
9799 | then | |
9800 | On_Object_Declaration := True; | |
9801 | return | |
3fc40cd7 | 9802 | Unqual_BIP_Function_Call (Expression (Parent (Entity (Expr)))); |
4ac62786 AC |
9803 | |
9804 | -- Recurse to handle calls to displace the pointer to the object to | |
9805 | -- reference a secondary dispatch table. | |
9806 | ||
9807 | elsif Nkind (Expr) = N_Function_Call | |
9808 | and then Nkind (Name (Expr)) in N_Has_Entity | |
f63adaa7 | 9809 | and then Present (Entity (Name (Expr))) |
4ac62786 AC |
9810 | and then RTU_Loaded (Ada_Tags) |
9811 | and then RTE_Available (RE_Displace) | |
9812 | and then Is_RTE (Entity (Name (Expr)), RE_Displace) | |
9813 | then | |
9814 | Has_Pointer_Displacement := True; | |
9815 | return | |
9816 | Unqual_BIP_Function_Call (First (Parameter_Associations (Expr))); | |
9817 | ||
9818 | -- Normal case: check if the inner expression is a BIP function call | |
9819 | -- and the pointer to the object is displaced. | |
9820 | ||
9821 | elsif Has_Pointer_Displacement | |
9822 | and then Is_Build_In_Place_Function_Call (Expr) | |
9823 | then | |
9824 | return Expr; | |
9825 | ||
9826 | else | |
9827 | return Empty; | |
9828 | end if; | |
9829 | end Unqual_BIP_Function_Call; | |
9830 | ||
9831 | -- Start of processing for Unqual_BIP_Iface_Function_Call | |
9832 | ||
9833 | begin | |
d4dfb005 | 9834 | if Nkind (Expr) = N_Identifier and then No (Entity (Expr)) then |
3fc40cd7 PMR |
9835 | |
9836 | -- Can happen for X'Elab_Spec in the binder-generated file | |
9837 | ||
d4dfb005 BD |
9838 | return Empty; |
9839 | end if; | |
9840 | ||
4ac62786 AC |
9841 | return Unqual_BIP_Function_Call (Expr); |
9842 | end Unqual_BIP_Iface_Function_Call; | |
9843 | ||
70482933 | 9844 | end Exp_Ch6; |