]>
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 | -- -- | |
cccef051 | 9 | -- Copyright (C) 1992-2023, 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 | ||
f459afaa | 26 | with Accessibility; use Accessibility; |
104f58db BD |
27 | with Atree; use Atree; |
28 | with Aspects; use Aspects; | |
29 | with Checks; use Checks; | |
104f58db BD |
30 | with Debug; use Debug; |
31 | with Einfo; use Einfo; | |
76f9c7f4 | 32 | with Einfo.Entities; use Einfo.Entities; |
104f58db BD |
33 | with Einfo.Utils; use Einfo.Utils; |
34 | with Errout; use Errout; | |
35 | with Elists; use Elists; | |
36 | with Expander; use Expander; | |
37 | with Exp_Aggr; use Exp_Aggr; | |
38 | with Exp_Atag; use Exp_Atag; | |
39 | with Exp_Ch3; use Exp_Ch3; | |
37449332 | 40 | with Exp_Ch4; use Exp_Ch4; |
104f58db BD |
41 | with Exp_Ch7; use Exp_Ch7; |
42 | with Exp_Ch9; use Exp_Ch9; | |
43 | with Exp_Dbug; use Exp_Dbug; | |
44 | with Exp_Disp; use Exp_Disp; | |
45 | with Exp_Dist; use Exp_Dist; | |
46 | with Exp_Intr; use Exp_Intr; | |
47 | with Exp_Pakd; use Exp_Pakd; | |
48 | with Exp_Tss; use Exp_Tss; | |
49 | with Exp_Util; use Exp_Util; | |
50 | with Freeze; use Freeze; | |
51 | with Inline; use Inline; | |
52 | with Itypes; use Itypes; | |
53 | with Lib; use Lib; | |
54 | with Namet; use Namet; | |
55 | with Nlists; use Nlists; | |
56 | with Nmake; use Nmake; | |
57 | with Opt; use Opt; | |
58 | with Restrict; use Restrict; | |
59 | with Rident; use Rident; | |
60 | with Rtsfind; use Rtsfind; | |
61 | with Sem; use Sem; | |
62 | with Sem_Aux; use Sem_Aux; | |
63 | with Sem_Ch6; use Sem_Ch6; | |
64 | with Sem_Ch8; use Sem_Ch8; | |
65 | with Sem_Ch13; use Sem_Ch13; | |
66 | with Sem_Dim; use Sem_Dim; | |
67 | with Sem_Disp; use Sem_Disp; | |
68 | with Sem_Dist; use Sem_Dist; | |
69 | with Sem_Eval; use Sem_Eval; | |
70 | with Sem_Mech; use Sem_Mech; | |
71 | with Sem_Res; use Sem_Res; | |
72 | with Sem_SCIL; use Sem_SCIL; | |
73 | with Sem_Util; use Sem_Util; | |
ca4bff3a | 74 | use Sem_Util.Storage_Model_Support; |
104f58db BD |
75 | with Sinfo; use Sinfo; |
76 | with Sinfo.Nodes; use Sinfo.Nodes; | |
77 | with Sinfo.Utils; use Sinfo.Utils; | |
475e1d24 | 78 | with Sinput; use Sinput; |
104f58db BD |
79 | with Snames; use Snames; |
80 | with Stand; use Stand; | |
475e1d24 | 81 | with Stringt; use Stringt; |
104f58db BD |
82 | with Tbuild; use Tbuild; |
83 | with Uintp; use Uintp; | |
84 | with Validsw; use Validsw; | |
70482933 RK |
85 | |
86 | package body Exp_Ch6 is | |
87 | ||
cd7d1f44 EB |
88 | -------------------------------- |
89 | -- Function return mechanisms -- | |
90 | -------------------------------- | |
91 | ||
92 | -- This is a summary of the various function return mechanisms implemented | |
93 | -- in GNAT for Ada 2005 and later versions of the language. In the below | |
94 | -- table, the first column must be read as an if expression: if the result | |
95 | -- type of the function is limited, then the return mechanism is and ...; | |
96 | -- elsif the result type is indefinite or large definite, then ...; elsif | |
97 | -- ...; else ... The different mechanisms are implemented either in the | |
98 | -- front end, or in the back end, or partly in both ends, depending on the | |
99 | -- result type. | |
100 | ||
101 | -- Result type | Return mechanism | Front end | Back end | |
102 | -- -------------------------------------------------------------------- | |
103 | ||
104 | -- Limited Build In Place All | |
105 | ||
106 | -- Indefinite/ Secondary Stack Needs Fin. Others | |
107 | -- Large definite | |
108 | ||
109 | -- Needs Fin. Secondary Stack All | |
110 | -- (BERS False) | |
111 | ||
112 | -- Needs Fin. Invisible Parameter All All | |
113 | -- (BERS True) (return) (call) | |
114 | ||
115 | -- By Reference Invisible Parameter All | |
116 | ||
117 | -- Others Primary stack/ All | |
118 | -- Registers | |
119 | ||
120 | -- Needs Fin.: type needs finalization [RM 7.6(9.1/2-9.6/2)] | |
121 | -- BERS: Opt.Back_End_Return_Slot setting | |
122 | ||
123 | -- The table is valid for all calls except for those dispatching on result; | |
124 | -- the latter calls are considered as returning a class-wide type and thus | |
125 | -- always return on the secondary stack, with the help of a small wrapper | |
126 | -- function (thunk) if the original result type is not itself returned on | |
127 | -- the secondary stack as per the above table. | |
128 | ||
129 | -- Suffixes for Build-In-Place extra formals | |
82af7291 JM |
130 | |
131 | BIP_Alloc_Suffix : constant String := "BIPalloc"; | |
132 | BIP_Storage_Pool_Suffix : constant String := "BIPstoragepool"; | |
133 | BIP_Finalization_Master_Suffix : constant String := "BIPfinalizationmaster"; | |
134 | BIP_Task_Master_Suffix : constant String := "BIPtaskmaster"; | |
135 | BIP_Activation_Chain_Suffix : constant String := "BIPactivationchain"; | |
136 | BIP_Object_Access_Suffix : constant String := "BIPaccess"; | |
137 | ||
70482933 RK |
138 | ----------------------- |
139 | -- Local Subprograms -- | |
140 | ----------------------- | |
141 | ||
02822a92 RD |
142 | procedure Add_Access_Actual_To_Build_In_Place_Call |
143 | (Function_Call : Node_Id; | |
144 | Function_Id : Entity_Id; | |
f937473f RD |
145 | Return_Object : Node_Id; |
146 | Is_Access : Boolean := False); | |
02822a92 RD |
147 | -- Ada 2005 (AI-318-02): Apply the Unrestricted_Access attribute to the |
148 | -- object name given by Return_Object and add the attribute to the end of | |
149 | -- the actual parameter list associated with the build-in-place function | |
f937473f RD |
150 | -- call denoted by Function_Call. However, if Is_Access is True, then |
151 | -- Return_Object is already an access expression, in which case it's passed | |
152 | -- along directly to the build-in-place function. Finally, if Return_Object | |
153 | -- is empty, then pass a null literal as the actual. | |
154 | ||
200b7162 | 155 | procedure Add_Unconstrained_Actuals_To_Build_In_Place_Call |
f937473f RD |
156 | (Function_Call : Node_Id; |
157 | Function_Id : Entity_Id; | |
158 | Alloc_Form : BIP_Allocation_Form := Unspecified; | |
200b7162 BD |
159 | Alloc_Form_Exp : Node_Id := Empty; |
160 | Pool_Actual : Node_Id := Make_Null (No_Location)); | |
161 | -- Ada 2005 (AI-318-02): Add the actuals needed for a build-in-place | |
162 | -- function call that returns a caller-unknown-size result (BIP_Alloc_Form | |
163 | -- and BIP_Storage_Pool). If Alloc_Form_Exp is present, then use it, | |
164 | -- otherwise pass a literal corresponding to the Alloc_Form parameter | |
165 | -- (which must not be Unspecified in that case). Pool_Actual is the | |
166 | -- parameter to pass to BIP_Storage_Pool. | |
f937473f | 167 | |
d3f70b35 | 168 | procedure Add_Finalization_Master_Actual_To_Build_In_Place_Call |
2c17ca0a AC |
169 | (Func_Call : Node_Id; |
170 | Func_Id : Entity_Id; | |
171 | Ptr_Typ : Entity_Id := Empty; | |
172 | Master_Exp : Node_Id := Empty); | |
df3e68b1 HK |
173 | -- Ada 2005 (AI-318-02): If the result type of a build-in-place call needs |
174 | -- finalization actions, add an actual parameter which is a pointer to the | |
2c17ca0a AC |
175 | -- finalization master of the caller. If Master_Exp is not Empty, then that |
176 | -- will be passed as the actual. Otherwise, if Ptr_Typ is left Empty, this | |
177 | -- will result in an automatic "null" value for the actual. | |
f937473f RD |
178 | |
179 | procedure Add_Task_Actuals_To_Build_In_Place_Call | |
180 | (Function_Call : Node_Id; | |
181 | Function_Id : Entity_Id; | |
1399d355 AC |
182 | Master_Actual : Node_Id; |
183 | Chain : Node_Id := Empty); | |
f937473f RD |
184 | -- Ada 2005 (AI-318-02): For a build-in-place call, if the result type |
185 | -- contains tasks, add two actual parameters: the master, and a pointer to | |
186 | -- the caller's activation chain. Master_Actual is the actual parameter | |
187 | -- expression to pass for the master. In most cases, this is the current | |
188 | -- master (_master). The two exceptions are: If the function call is the | |
189 | -- initialization expression for an allocator, we pass the master of the | |
6dfc5592 | 190 | -- access type. If the function call is the initialization expression for a |
1399d355 AC |
191 | -- return object, we pass along the master passed in by the caller. In most |
192 | -- contexts, the activation chain to pass is the local one, which is | |
193 | -- indicated by No (Chain). However, in an allocator, the caller passes in | |
194 | -- the activation Chain. Note: Master_Actual can be Empty, but only if | |
195 | -- there are no tasks. | |
02822a92 | 196 | |
f6bbf84e EB |
197 | function Build_Flag_For_Function (Func_Id : Entity_Id) return Entity_Id; |
198 | -- Generate code to declare a boolean flag initialized to False in the | |
199 | -- function Func_Id and return the entity for the flag. | |
200 | ||
0691ed6b | 201 | function Caller_Known_Size |
1155ae01 AC |
202 | (Func_Call : Node_Id; |
203 | Result_Subt : Entity_Id) return Boolean; | |
89e037d0 | 204 | -- True if result subtype is definite or has a size that does not require |
0691ed6b AC |
205 | -- secondary stack usage (i.e. no variant part or components whose type |
206 | -- depends on discriminants). In particular, untagged types with only | |
207 | -- access discriminants do not require secondary stack use. Note we must | |
208 | -- always use the secondary stack for dispatching-on-result calls. | |
209 | ||
82af7291 JM |
210 | function Check_BIP_Actuals |
211 | (Subp_Call : Node_Id; | |
212 | Subp_Id : Entity_Id) return Boolean; | |
213 | -- Given a subprogram call to the given subprogram return True if the | |
f1668c3d JM |
214 | -- names of BIP extra actual and formal parameters match, and the number |
215 | -- of actuals (including extra actuals) matches the number of formals. | |
82af7291 | 216 | |
1ed19d98 JM |
217 | function Check_Number_Of_Actuals |
218 | (Subp_Call : Node_Id; | |
219 | Subp_Id : Entity_Id) return Boolean; | |
220 | -- Given a subprogram call to the given subprogram return True if the | |
221 | -- number of actual parameters (including extra actuals) is correct. | |
222 | ||
70482933 RK |
223 | procedure Check_Overriding_Operation (Subp : Entity_Id); |
224 | -- Subp is a dispatching operation. Check whether it may override an | |
225 | -- inherited private operation, in which case its DT entry is that of | |
226 | -- the hidden operation, not the one it may have received earlier. | |
227 | -- This must be done before emitting the code to set the corresponding | |
228 | -- DT to the address of the subprogram. The actual placement of Subp in | |
229 | -- the proper place in the list of primitive operations is done in | |
230 | -- Declare_Inherited_Private_Subprograms, which also has to deal with | |
231 | -- implicit operations. This duplication is unavoidable for now??? | |
232 | ||
233 | procedure Detect_Infinite_Recursion (N : Node_Id; Spec : Entity_Id); | |
234 | -- This procedure is called only if the subprogram body N, whose spec | |
235 | -- has the given entity Spec, contains a parameterless recursive call. | |
236 | -- It attempts to generate runtime code to detect if this a case of | |
237 | -- infinite recursion. | |
238 | -- | |
239 | -- The body is scanned to determine dependencies. If the only external | |
240 | -- dependencies are on a small set of scalar variables, then the values | |
241 | -- of these variables are captured on entry to the subprogram, and if | |
242 | -- the values are not changed for the call, we know immediately that | |
243 | -- we have an infinite recursion. | |
244 | ||
ca1f6b29 | 245 | procedure Expand_Actuals |
ec40b86c HK |
246 | (N : Node_Id; |
247 | Subp : Entity_Id; | |
248 | Post_Call : out List_Id); | |
249 | -- Return a list of actions to take place after the call in Post_Call. The | |
250 | -- call will later be rewritten as an Expression_With_Actions, with the | |
251 | -- Post_Call actions inserted, and the call inside. | |
ca1f6b29 | 252 | -- |
ec40b86c HK |
253 | -- For each actual of an in-out or out parameter which is a numeric (view) |
254 | -- conversion of the form T (A), where A denotes a variable, we insert the | |
255 | -- declaration: | |
da574a86 AC |
256 | -- |
257 | -- Temp : T[ := T (A)]; | |
258 | -- | |
259 | -- prior to the call. Then we replace the actual with a reference to Temp, | |
260 | -- and append the assignment: | |
261 | -- | |
262 | -- A := TypeA (Temp); | |
263 | -- | |
264 | -- after the call. Here TypeA is the actual type of variable A. For out | |
265 | -- parameters, the initial declaration has no expression. If A is not an | |
266 | -- entity name, we generate instead: | |
267 | -- | |
268 | -- Var : TypeA renames A; | |
269 | -- Temp : T := Var; -- omitting expression for out parameter. | |
270 | -- ... | |
271 | -- Var := TypeA (Temp); | |
272 | -- | |
273 | -- For other in-out parameters, we emit the required constraint checks | |
274 | -- before and/or after the call. | |
275 | -- | |
276 | -- For all parameter modes, actuals that denote components and slices of | |
277 | -- packed arrays are expanded into suitable temporaries. | |
278 | -- | |
00907026 EB |
279 | -- For nonscalar objects that are possibly unaligned, add call by copy code |
280 | -- (copy in for IN and IN OUT, copy out for OUT and IN OUT). | |
da574a86 | 281 | -- |
5f6fb720 AC |
282 | -- For OUT and IN OUT parameters, add predicate checks after the call |
283 | -- based on the predicates of the actual type. | |
ca1f6b29 BD |
284 | |
285 | procedure Expand_Call_Helper (N : Node_Id; Post_Call : out List_Id); | |
ec40b86c | 286 | -- Does the main work of Expand_Call. Post_Call is as for Expand_Actuals. |
da574a86 | 287 | |
c901877f | 288 | procedure Expand_Ctrl_Function_Call (N : Node_Id; Use_Sec_Stack : Boolean); |
df3e68b1 HK |
289 | -- N is a function call which returns a controlled object. Transform the |
290 | -- call into a temporary which retrieves the returned object from the | |
c901877f | 291 | -- primary or secondary stack (Use_Sec_Stack says which) using 'reference. |
df3e68b1 | 292 | |
2b3d67a5 | 293 | procedure Expand_Non_Function_Return (N : Node_Id); |
c9d70ab1 AC |
294 | -- Expand a simple return statement found in a procedure body, entry body, |
295 | -- accept statement, or an extended return statement. Note that all non- | |
296 | -- function returns are simple return statements. | |
2b3d67a5 | 297 | |
70482933 RK |
298 | function Expand_Protected_Object_Reference |
299 | (N : Node_Id; | |
02822a92 | 300 | Scop : Entity_Id) return Node_Id; |
70482933 RK |
301 | |
302 | procedure Expand_Protected_Subprogram_Call | |
303 | (N : Node_Id; | |
304 | Subp : Entity_Id; | |
305 | Scop : Entity_Id); | |
306 | -- A call to a protected subprogram within the protected object may appear | |
307 | -- as a regular call. The list of actuals must be expanded to contain a | |
308 | -- reference to the object itself, and the call becomes a call to the | |
309 | -- corresponding protected subprogram. | |
310 | ||
de01377c AC |
311 | procedure Expand_Simple_Function_Return (N : Node_Id); |
312 | -- Expand simple return from function. In the case where we are returning | |
313 | -- from a function body this is called by Expand_N_Simple_Return_Statement. | |
314 | ||
ec40b86c HK |
315 | procedure Insert_Post_Call_Actions (N : Node_Id; Post_Call : List_Id); |
316 | -- Insert the Post_Call list previously produced by routine Expand_Actuals | |
317 | -- or Expand_Call_Helper into the tree. | |
318 | ||
358e289d JM |
319 | function Is_True_Build_In_Place_Function_Call (N : Node_Id) return Boolean; |
320 | -- Ada 2005 (AI-318-02): Returns True if N denotes a call to a function | |
321 | -- that requires handling as a build-in-place call; returns False for | |
322 | -- non-BIP function calls and also for calls to functions with inherited | |
323 | -- BIP formals that do not require BIP formals. For example: | |
324 | -- | |
325 | -- type Iface is limited interface; | |
326 | -- function Get_Object return Iface; | |
327 | -- -- This function has BIP extra formals | |
328 | -- | |
329 | -- type Root1 is limited tagged record ... | |
330 | -- type T1 is new Root1 and Iface with ... | |
331 | -- function Get_Object return T1; | |
332 | -- -- This primitive requires the BIP formals, and the evaluation of | |
333 | -- -- Is_True_Build_In_Place_Function_Call returns True. | |
334 | -- | |
335 | -- type Root2 is tagged record ... | |
336 | -- type T2 is new Root2 and Iface with ... | |
337 | -- function Get_Object return T2; | |
338 | -- -- This primitive inherits the BIP formals of the interface primitive | |
339 | -- -- but, given that T2 is not a limited type, it does not require such | |
340 | -- -- formals; therefore Is_True_Build_In_Place_Function_Call returns | |
341 | -- -- False. | |
342 | ||
4ac62786 AC |
343 | procedure Replace_Renaming_Declaration_Id |
344 | (New_Decl : Node_Id; | |
345 | Orig_Decl : Node_Id); | |
346 | -- Replace the internal identifier of the new renaming declaration New_Decl | |
347 | -- with the identifier of its original declaration Orig_Decl exchanging the | |
348 | -- entities containing their defining identifiers to ensure the correct | |
349 | -- replacement of the object declaration by the object renaming declaration | |
350 | -- to avoid homograph conflicts (since the object declaration's defining | |
351 | -- identifier was already entered in the current scope). The Next_Entity | |
352 | -- links of the two entities are also swapped since the entities are part | |
353 | -- of the return scope's entity list and the list structure would otherwise | |
354 | -- be corrupted. The homonym chain is preserved as well. | |
355 | ||
2700b9c1 AC |
356 | procedure Rewrite_Function_Call_For_C (N : Node_Id); |
357 | -- When generating C code, replace a call to a function that returns an | |
358 | -- array into the generated procedure with an additional out parameter. | |
359 | ||
c79f6efd BD |
360 | procedure Set_Enclosing_Sec_Stack_Return (N : Node_Id); |
361 | -- N is a return statement for a function that returns its result on the | |
362 | -- secondary stack. This sets the Sec_Stack_Needed_For_Return flag on the | |
363 | -- function and all blocks and loops that the return statement is jumping | |
364 | -- out of. This ensures that the secondary stack is not released; otherwise | |
365 | -- the function result would be reclaimed before returning to the caller. | |
366 | ||
b19c922b VF |
367 | procedure Warn_BIP (Func_Call : Node_Id); |
368 | -- Give a warning on a build-in-place function call if the -gnatd_B switch | |
369 | -- was given. | |
370 | ||
02822a92 RD |
371 | ---------------------------------------------- |
372 | -- Add_Access_Actual_To_Build_In_Place_Call -- | |
373 | ---------------------------------------------- | |
374 | ||
375 | procedure Add_Access_Actual_To_Build_In_Place_Call | |
376 | (Function_Call : Node_Id; | |
377 | Function_Id : Entity_Id; | |
f937473f RD |
378 | Return_Object : Node_Id; |
379 | Is_Access : Boolean := False) | |
02822a92 RD |
380 | is |
381 | Loc : constant Source_Ptr := Sloc (Function_Call); | |
382 | Obj_Address : Node_Id; | |
f937473f | 383 | Obj_Acc_Formal : Entity_Id; |
02822a92 RD |
384 | |
385 | begin | |
f937473f | 386 | -- Locate the implicit access parameter in the called function |
02822a92 | 387 | |
f937473f | 388 | Obj_Acc_Formal := Build_In_Place_Formal (Function_Id, BIP_Object_Access); |
02822a92 | 389 | |
f937473f RD |
390 | -- If no return object is provided, then pass null |
391 | ||
7d0d27d9 | 392 | if No (Return_Object) then |
f937473f | 393 | Obj_Address := Make_Null (Loc); |
7888a6ae | 394 | Set_Parent (Obj_Address, Function_Call); |
02822a92 | 395 | |
f937473f RD |
396 | -- If Return_Object is already an expression of an access type, then use |
397 | -- it directly, since it must be an access value denoting the return | |
398 | -- object, and couldn't possibly be the return object itself. | |
399 | ||
400 | elsif Is_Access then | |
401 | Obj_Address := Return_Object; | |
7888a6ae | 402 | Set_Parent (Obj_Address, Function_Call); |
02822a92 RD |
403 | |
404 | -- Apply Unrestricted_Access to caller's return object | |
405 | ||
f937473f RD |
406 | else |
407 | Obj_Address := | |
408 | Make_Attribute_Reference (Loc, | |
409 | Prefix => Return_Object, | |
410 | Attribute_Name => Name_Unrestricted_Access); | |
7888a6ae GD |
411 | |
412 | Set_Parent (Return_Object, Obj_Address); | |
413 | Set_Parent (Obj_Address, Function_Call); | |
f937473f | 414 | end if; |
02822a92 RD |
415 | |
416 | Analyze_And_Resolve (Obj_Address, Etype (Obj_Acc_Formal)); | |
417 | ||
418 | -- Build the parameter association for the new actual and add it to the | |
419 | -- end of the function's actuals. | |
420 | ||
f937473f RD |
421 | Add_Extra_Actual_To_Call (Function_Call, Obj_Acc_Formal, Obj_Address); |
422 | end Add_Access_Actual_To_Build_In_Place_Call; | |
423 | ||
3e7302c3 | 424 | ------------------------------------------------------ |
200b7162 | 425 | -- Add_Unconstrained_Actuals_To_Build_In_Place_Call -- |
3e7302c3 | 426 | ------------------------------------------------------ |
f937473f | 427 | |
200b7162 | 428 | procedure Add_Unconstrained_Actuals_To_Build_In_Place_Call |
f937473f RD |
429 | (Function_Call : Node_Id; |
430 | Function_Id : Entity_Id; | |
431 | Alloc_Form : BIP_Allocation_Form := Unspecified; | |
200b7162 BD |
432 | Alloc_Form_Exp : Node_Id := Empty; |
433 | Pool_Actual : Node_Id := Make_Null (No_Location)) | |
f937473f | 434 | is |
7d1d3a54 HK |
435 | Loc : constant Source_Ptr := Sloc (Function_Call); |
436 | ||
f937473f RD |
437 | Alloc_Form_Actual : Node_Id; |
438 | Alloc_Form_Formal : Node_Id; | |
200b7162 | 439 | Pool_Formal : Node_Id; |
f937473f RD |
440 | |
441 | begin | |
7d1d3a54 HK |
442 | -- Nothing to do when the size of the object is known, and the caller is |
443 | -- in charge of allocating it, and the callee doesn't unconditionally | |
444 | -- require an allocation form (such as due to having a tagged result). | |
445 | ||
446 | if not Needs_BIP_Alloc_Form (Function_Id) then | |
7888a6ae GD |
447 | return; |
448 | end if; | |
449 | ||
f937473f RD |
450 | -- Locate the implicit allocation form parameter in the called function. |
451 | -- Maybe it would be better for each implicit formal of a build-in-place | |
452 | -- function to have a flag or a Uint attribute to identify it. ??? | |
453 | ||
454 | Alloc_Form_Formal := Build_In_Place_Formal (Function_Id, BIP_Alloc_Form); | |
455 | ||
456 | if Present (Alloc_Form_Exp) then | |
457 | pragma Assert (Alloc_Form = Unspecified); | |
458 | ||
459 | Alloc_Form_Actual := Alloc_Form_Exp; | |
460 | ||
461 | else | |
462 | pragma Assert (Alloc_Form /= Unspecified); | |
463 | ||
464 | Alloc_Form_Actual := | |
465 | Make_Integer_Literal (Loc, | |
466 | Intval => UI_From_Int (BIP_Allocation_Form'Pos (Alloc_Form))); | |
467 | end if; | |
468 | ||
469 | Analyze_And_Resolve (Alloc_Form_Actual, Etype (Alloc_Form_Formal)); | |
470 | ||
471 | -- Build the parameter association for the new actual and add it to the | |
472 | -- end of the function's actuals. | |
473 | ||
474 | Add_Extra_Actual_To_Call | |
475 | (Function_Call, Alloc_Form_Formal, Alloc_Form_Actual); | |
200b7162 | 476 | |
7d1d3a54 HK |
477 | -- Pass the Storage_Pool parameter. This parameter is omitted on ZFP as |
478 | -- those targets do not support pools. | |
200b7162 | 479 | |
535a8637 | 480 | if RTE_Available (RE_Root_Storage_Pool_Ptr) then |
8417f4b2 AC |
481 | Pool_Formal := Build_In_Place_Formal (Function_Id, BIP_Storage_Pool); |
482 | Analyze_And_Resolve (Pool_Actual, Etype (Pool_Formal)); | |
483 | Add_Extra_Actual_To_Call | |
484 | (Function_Call, Pool_Formal, Pool_Actual); | |
485 | end if; | |
200b7162 | 486 | end Add_Unconstrained_Actuals_To_Build_In_Place_Call; |
f937473f | 487 | |
d3f70b35 AC |
488 | ----------------------------------------------------------- |
489 | -- Add_Finalization_Master_Actual_To_Build_In_Place_Call -- | |
490 | ----------------------------------------------------------- | |
df3e68b1 | 491 | |
d3f70b35 | 492 | procedure Add_Finalization_Master_Actual_To_Build_In_Place_Call |
2c17ca0a AC |
493 | (Func_Call : Node_Id; |
494 | Func_Id : Entity_Id; | |
495 | Ptr_Typ : Entity_Id := Empty; | |
496 | Master_Exp : Node_Id := Empty) | |
df3e68b1 HK |
497 | is |
498 | begin | |
d3f70b35 | 499 | if not Needs_BIP_Finalization_Master (Func_Id) then |
df3e68b1 HK |
500 | return; |
501 | end if; | |
502 | ||
503 | declare | |
504 | Formal : constant Entity_Id := | |
d3f70b35 | 505 | Build_In_Place_Formal (Func_Id, BIP_Finalization_Master); |
df3e68b1 HK |
506 | Loc : constant Source_Ptr := Sloc (Func_Call); |
507 | ||
508 | Actual : Node_Id; | |
509 | Desig_Typ : Entity_Id; | |
510 | ||
511 | begin | |
358e289d JM |
512 | pragma Assert (Present (Formal)); |
513 | ||
2c17ca0a AC |
514 | -- If there is a finalization master actual, such as the implicit |
515 | -- finalization master of an enclosing build-in-place function, | |
516 | -- then this must be added as an extra actual of the call. | |
517 | ||
518 | if Present (Master_Exp) then | |
519 | Actual := Master_Exp; | |
520 | ||
d3f70b35 | 521 | -- Case where the context does not require an actual master |
df3e68b1 | 522 | |
2c17ca0a | 523 | elsif No (Ptr_Typ) then |
df3e68b1 HK |
524 | Actual := Make_Null (Loc); |
525 | ||
526 | else | |
527 | Desig_Typ := Directly_Designated_Type (Ptr_Typ); | |
528 | ||
529 | -- Check for a library-level access type whose designated type has | |
a267d8cc AC |
530 | -- suppressed finalization or the access type is subject to pragma |
531 | -- No_Heap_Finalization. Such an access type lacks a master. Pass | |
532 | -- a null actual to callee in order to signal a missing master. | |
df3e68b1 HK |
533 | |
534 | if Is_Library_Level_Entity (Ptr_Typ) | |
cccb761b | 535 | and then (Finalize_Storage_Only (Desig_Typ) |
a267d8cc | 536 | or else No_Heap_Finalization (Ptr_Typ)) |
df3e68b1 HK |
537 | then |
538 | Actual := Make_Null (Loc); | |
539 | ||
540 | -- Types in need of finalization actions | |
541 | ||
542 | elsif Needs_Finalization (Desig_Typ) then | |
543 | ||
d3f70b35 AC |
544 | -- The general mechanism of creating finalization masters for |
545 | -- anonymous access types is disabled by default, otherwise | |
546 | -- finalization masters will pop all over the place. Such types | |
547 | -- use context-specific masters. | |
df3e68b1 HK |
548 | |
549 | if Ekind (Ptr_Typ) = E_Anonymous_Access_Type | |
d3f70b35 | 550 | and then No (Finalization_Master (Ptr_Typ)) |
df3e68b1 | 551 | then |
32b794c8 | 552 | Build_Anonymous_Master (Ptr_Typ); |
df3e68b1 HK |
553 | end if; |
554 | ||
d3f70b35 | 555 | -- Access-to-controlled types should always have a master |
df3e68b1 | 556 | |
d3f70b35 | 557 | pragma Assert (Present (Finalization_Master (Ptr_Typ))); |
df3e68b1 HK |
558 | |
559 | Actual := | |
560 | Make_Attribute_Reference (Loc, | |
561 | Prefix => | |
e4494292 | 562 | New_Occurrence_Of (Finalization_Master (Ptr_Typ), Loc), |
df3e68b1 HK |
563 | Attribute_Name => Name_Unrestricted_Access); |
564 | ||
565 | -- Tagged types | |
566 | ||
567 | else | |
568 | Actual := Make_Null (Loc); | |
569 | end if; | |
570 | end if; | |
571 | ||
572 | Analyze_And_Resolve (Actual, Etype (Formal)); | |
573 | ||
574 | -- Build the parameter association for the new actual and add it to | |
575 | -- the end of the function's actuals. | |
576 | ||
577 | Add_Extra_Actual_To_Call (Func_Call, Formal, Actual); | |
578 | end; | |
d3f70b35 | 579 | end Add_Finalization_Master_Actual_To_Build_In_Place_Call; |
df3e68b1 | 580 | |
f937473f RD |
581 | ------------------------------ |
582 | -- Add_Extra_Actual_To_Call -- | |
583 | ------------------------------ | |
584 | ||
585 | procedure Add_Extra_Actual_To_Call | |
586 | (Subprogram_Call : Node_Id; | |
587 | Extra_Formal : Entity_Id; | |
588 | Extra_Actual : Node_Id) | |
589 | is | |
590 | Loc : constant Source_Ptr := Sloc (Subprogram_Call); | |
591 | Param_Assoc : Node_Id; | |
592 | ||
593 | begin | |
02822a92 RD |
594 | Param_Assoc := |
595 | Make_Parameter_Association (Loc, | |
f937473f RD |
596 | Selector_Name => New_Occurrence_Of (Extra_Formal, Loc), |
597 | Explicit_Actual_Parameter => Extra_Actual); | |
02822a92 | 598 | |
f937473f RD |
599 | Set_Parent (Param_Assoc, Subprogram_Call); |
600 | Set_Parent (Extra_Actual, Param_Assoc); | |
02822a92 | 601 | |
f937473f RD |
602 | if Present (Parameter_Associations (Subprogram_Call)) then |
603 | if Nkind (Last (Parameter_Associations (Subprogram_Call))) = | |
02822a92 RD |
604 | N_Parameter_Association |
605 | then | |
f937473f RD |
606 | |
607 | -- Find last named actual, and append | |
608 | ||
609 | declare | |
610 | L : Node_Id; | |
611 | begin | |
612 | L := First_Actual (Subprogram_Call); | |
613 | while Present (L) loop | |
614 | if No (Next_Actual (L)) then | |
615 | Set_Next_Named_Actual (Parent (L), Extra_Actual); | |
616 | exit; | |
617 | end if; | |
618 | Next_Actual (L); | |
619 | end loop; | |
620 | end; | |
621 | ||
02822a92 | 622 | else |
f937473f | 623 | Set_First_Named_Actual (Subprogram_Call, Extra_Actual); |
02822a92 RD |
624 | end if; |
625 | ||
f937473f | 626 | Append (Param_Assoc, To => Parameter_Associations (Subprogram_Call)); |
02822a92 RD |
627 | |
628 | else | |
f937473f RD |
629 | Set_Parameter_Associations (Subprogram_Call, New_List (Param_Assoc)); |
630 | Set_First_Named_Actual (Subprogram_Call, Extra_Actual); | |
02822a92 | 631 | end if; |
f937473f RD |
632 | end Add_Extra_Actual_To_Call; |
633 | ||
f937473f RD |
634 | --------------------------------------------- |
635 | -- Add_Task_Actuals_To_Build_In_Place_Call -- | |
636 | --------------------------------------------- | |
637 | ||
638 | procedure Add_Task_Actuals_To_Build_In_Place_Call | |
639 | (Function_Call : Node_Id; | |
640 | Function_Id : Entity_Id; | |
1399d355 AC |
641 | Master_Actual : Node_Id; |
642 | Chain : Node_Id := Empty) | |
f937473f | 643 | is |
af89615f | 644 | Loc : constant Source_Ptr := Sloc (Function_Call); |
af89615f AC |
645 | Actual : Node_Id; |
646 | Chain_Actual : Node_Id; | |
647 | Chain_Formal : Node_Id; | |
648 | Master_Formal : Node_Id; | |
6dfc5592 | 649 | |
f937473f RD |
650 | begin |
651 | -- No such extra parameters are needed if there are no tasks | |
652 | ||
1ed19d98 | 653 | if not Needs_BIP_Task_Actuals (Function_Id) then |
358e289d JM |
654 | |
655 | -- However we must add dummy extra actuals if the function is | |
656 | -- a dispatching operation that inherited these extra formals. | |
657 | ||
658 | if Is_Dispatching_Operation (Function_Id) | |
659 | and then Has_BIP_Extra_Formal (Function_Id, BIP_Task_Master) | |
660 | then | |
661 | Master_Formal := | |
662 | Build_In_Place_Formal (Function_Id, BIP_Task_Master); | |
663 | Actual := Make_Integer_Literal (Loc, Uint_0); | |
664 | Analyze_And_Resolve (Actual, Etype (Master_Formal)); | |
665 | Add_Extra_Actual_To_Call (Function_Call, Master_Formal, Actual); | |
666 | ||
667 | Chain_Formal := | |
668 | Build_In_Place_Formal (Function_Id, BIP_Activation_Chain); | |
669 | Chain_Actual := Make_Null (Loc); | |
670 | Analyze_And_Resolve (Chain_Actual, Etype (Chain_Formal)); | |
671 | Add_Extra_Actual_To_Call | |
672 | (Function_Call, Chain_Formal, Chain_Actual); | |
673 | end if; | |
674 | ||
f937473f RD |
675 | return; |
676 | end if; | |
677 | ||
af89615f AC |
678 | Actual := Master_Actual; |
679 | ||
44bf8eb0 AC |
680 | -- Use a dummy _master actual in case of No_Task_Hierarchy |
681 | ||
682 | if Restriction_Active (No_Task_Hierarchy) then | |
37cd8d97 | 683 | Actual := Make_Integer_Literal (Loc, Library_Task_Level); |
94bbf008 AC |
684 | |
685 | -- In the case where we use the master associated with an access type, | |
686 | -- the actual is an entity and requires an explicit reference. | |
687 | ||
688 | elsif Nkind (Actual) = N_Defining_Identifier then | |
e4494292 | 689 | Actual := New_Occurrence_Of (Actual, Loc); |
44bf8eb0 AC |
690 | end if; |
691 | ||
af89615f | 692 | -- Locate the implicit master parameter in the called function |
f937473f | 693 | |
af89615f AC |
694 | Master_Formal := Build_In_Place_Formal (Function_Id, BIP_Task_Master); |
695 | Analyze_And_Resolve (Actual, Etype (Master_Formal)); | |
f937473f | 696 | |
af89615f AC |
697 | -- Build the parameter association for the new actual and add it to the |
698 | -- end of the function's actuals. | |
f937473f | 699 | |
af89615f | 700 | Add_Extra_Actual_To_Call (Function_Call, Master_Formal, Actual); |
75a64833 | 701 | |
af89615f | 702 | -- Locate the implicit activation chain parameter in the called function |
f937473f | 703 | |
af89615f AC |
704 | Chain_Formal := |
705 | Build_In_Place_Formal (Function_Id, BIP_Activation_Chain); | |
f937473f | 706 | |
af89615f | 707 | -- Create the actual which is a pointer to the current activation chain |
f937473f | 708 | |
24dde337 SB |
709 | if Restriction_Active (No_Task_Hierarchy) then |
710 | Chain_Actual := Make_Null (Loc); | |
711 | ||
712 | elsif No (Chain) then | |
1399d355 AC |
713 | Chain_Actual := |
714 | Make_Attribute_Reference (Loc, | |
715 | Prefix => Make_Identifier (Loc, Name_uChain), | |
716 | Attribute_Name => Name_Unrestricted_Access); | |
717 | ||
718 | -- Allocator case; make a reference to the Chain passed in by the caller | |
719 | ||
720 | else | |
721 | Chain_Actual := | |
722 | Make_Attribute_Reference (Loc, | |
723 | Prefix => New_Occurrence_Of (Chain, Loc), | |
724 | Attribute_Name => Name_Unrestricted_Access); | |
725 | end if; | |
f937473f | 726 | |
af89615f | 727 | Analyze_And_Resolve (Chain_Actual, Etype (Chain_Formal)); |
f937473f | 728 | |
af89615f AC |
729 | -- Build the parameter association for the new actual and add it to the |
730 | -- end of the function's actuals. | |
f937473f | 731 | |
af89615f | 732 | Add_Extra_Actual_To_Call (Function_Call, Chain_Formal, Chain_Actual); |
f937473f RD |
733 | end Add_Task_Actuals_To_Build_In_Place_Call; |
734 | ||
c5a913d3 EB |
735 | ---------------------------------- |
736 | -- Apply_CW_Accessibility_Check -- | |
737 | ---------------------------------- | |
738 | ||
739 | procedure Apply_CW_Accessibility_Check (Exp : Node_Id; Func : Entity_Id) is | |
740 | Loc : constant Source_Ptr := Sloc (Exp); | |
741 | ||
742 | begin | |
8daf80ff EB |
743 | -- CodePeer does not do anything useful on Ada.Tags.Type_Specific_Data |
744 | -- components. | |
745 | ||
c5a913d3 | 746 | if Ada_Version >= Ada_2005 |
8daf80ff | 747 | and then not CodePeer_Mode |
c5a913d3 EB |
748 | and then Tagged_Type_Expansion |
749 | and then not Scope_Suppress.Suppress (Accessibility_Check) | |
750 | and then | |
751 | (Is_Class_Wide_Type (Etype (Exp)) | |
4a08c95c AC |
752 | or else Nkind (Exp) in |
753 | N_Type_Conversion | N_Unchecked_Type_Conversion | |
c5a913d3 EB |
754 | or else (Is_Entity_Name (Exp) |
755 | and then Is_Formal (Entity (Exp))) | |
756 | or else Scope_Depth (Enclosing_Dynamic_Scope (Etype (Exp))) > | |
757 | Scope_Depth (Enclosing_Dynamic_Scope (Func))) | |
758 | then | |
759 | declare | |
760 | Tag_Node : Node_Id; | |
761 | ||
762 | begin | |
763 | -- Ada 2005 (AI-251): In class-wide interface objects we displace | |
764 | -- "this" to reference the base of the object. This is required to | |
765 | -- get access to the TSD of the object. | |
766 | ||
767 | if Is_Class_Wide_Type (Etype (Exp)) | |
768 | and then Is_Interface (Etype (Exp)) | |
769 | then | |
770 | -- If the expression is an explicit dereference then we can | |
771 | -- directly displace the pointer to reference the base of | |
772 | -- the object. | |
773 | ||
774 | if Nkind (Exp) = N_Explicit_Dereference then | |
775 | Tag_Node := | |
776 | Make_Explicit_Dereference (Loc, | |
777 | Prefix => | |
778 | Unchecked_Convert_To (RTE (RE_Tag_Ptr), | |
779 | Make_Function_Call (Loc, | |
780 | Name => | |
781 | New_Occurrence_Of (RTE (RE_Base_Address), Loc), | |
782 | Parameter_Associations => New_List ( | |
783 | Unchecked_Convert_To (RTE (RE_Address), | |
784 | Duplicate_Subexpr (Prefix (Exp))))))); | |
785 | ||
786 | -- Similar case to the previous one but the expression is a | |
787 | -- renaming of an explicit dereference. | |
788 | ||
789 | elsif Nkind (Exp) = N_Identifier | |
790 | and then Present (Renamed_Object (Entity (Exp))) | |
791 | and then Nkind (Renamed_Object (Entity (Exp))) | |
792 | = N_Explicit_Dereference | |
793 | then | |
794 | Tag_Node := | |
795 | Make_Explicit_Dereference (Loc, | |
796 | Prefix => | |
797 | Unchecked_Convert_To (RTE (RE_Tag_Ptr), | |
798 | Make_Function_Call (Loc, | |
799 | Name => | |
800 | New_Occurrence_Of (RTE (RE_Base_Address), Loc), | |
801 | Parameter_Associations => New_List ( | |
802 | Unchecked_Convert_To (RTE (RE_Address), | |
803 | Duplicate_Subexpr | |
804 | (Prefix | |
805 | (Renamed_Object (Entity (Exp))))))))); | |
806 | ||
807 | -- Common case: obtain the address of the actual object and | |
808 | -- displace the pointer to reference the base of the object. | |
809 | ||
810 | else | |
811 | Tag_Node := | |
812 | Make_Explicit_Dereference (Loc, | |
813 | Prefix => | |
814 | Unchecked_Convert_To (RTE (RE_Tag_Ptr), | |
815 | Make_Function_Call (Loc, | |
816 | Name => | |
817 | New_Occurrence_Of (RTE (RE_Base_Address), Loc), | |
818 | Parameter_Associations => New_List ( | |
819 | Make_Attribute_Reference (Loc, | |
820 | Prefix => Duplicate_Subexpr (Exp), | |
821 | Attribute_Name => Name_Address))))); | |
822 | end if; | |
823 | else | |
824 | Tag_Node := | |
825 | Make_Attribute_Reference (Loc, | |
826 | Prefix => Duplicate_Subexpr (Exp), | |
827 | Attribute_Name => Name_Tag); | |
828 | end if; | |
829 | ||
8daf80ff EB |
830 | -- Suppress junk access chacks on RE_Tag_Ptr |
831 | ||
832 | Insert_Action (Exp, | |
833 | Make_Raise_Program_Error (Loc, | |
834 | Condition => | |
835 | Make_Op_Gt (Loc, | |
836 | Left_Opnd => Build_Get_Access_Level (Loc, Tag_Node), | |
837 | Right_Opnd => | |
838 | Make_Integer_Literal (Loc, | |
839 | Scope_Depth (Enclosing_Dynamic_Scope (Func)))), | |
840 | Reason => PE_Accessibility_Check_Failed), | |
841 | Suppress => Access_Check); | |
c5a913d3 EB |
842 | end; |
843 | end if; | |
844 | end Apply_CW_Accessibility_Check; | |
845 | ||
f937473f RD |
846 | ----------------------- |
847 | -- BIP_Formal_Suffix -- | |
848 | ----------------------- | |
849 | ||
850 | function BIP_Formal_Suffix (Kind : BIP_Formal_Kind) return String is | |
851 | begin | |
852 | case Kind is | |
d8f43ee6 | 853 | when BIP_Alloc_Form => |
82af7291 | 854 | return BIP_Alloc_Suffix; |
d8f43ee6 HK |
855 | |
856 | when BIP_Storage_Pool => | |
82af7291 | 857 | return BIP_Storage_Pool_Suffix; |
d8f43ee6 | 858 | |
d3f70b35 | 859 | when BIP_Finalization_Master => |
82af7291 | 860 | return BIP_Finalization_Master_Suffix; |
d8f43ee6 HK |
861 | |
862 | when BIP_Task_Master => | |
82af7291 | 863 | return BIP_Task_Master_Suffix; |
d8f43ee6 HK |
864 | |
865 | when BIP_Activation_Chain => | |
82af7291 | 866 | return BIP_Activation_Chain_Suffix; |
d8f43ee6 HK |
867 | |
868 | when BIP_Object_Access => | |
82af7291 | 869 | return BIP_Object_Access_Suffix; |
f937473f RD |
870 | end case; |
871 | end BIP_Formal_Suffix; | |
872 | ||
82af7291 JM |
873 | --------------------- |
874 | -- BIP_Suffix_Kind -- | |
875 | --------------------- | |
876 | ||
877 | function BIP_Suffix_Kind (E : Entity_Id) return BIP_Formal_Kind is | |
878 | Nam : constant String := Get_Name_String (Chars (E)); | |
879 | ||
880 | function Has_Suffix (Suffix : String) return Boolean; | |
881 | -- Return True if Nam has suffix Suffix | |
882 | ||
883 | function Has_Suffix (Suffix : String) return Boolean is | |
884 | Len : constant Natural := Suffix'Length; | |
885 | begin | |
886 | return Nam'Length > Len | |
887 | and then Nam (Nam'Last - Len + 1 .. Nam'Last) = Suffix; | |
888 | end Has_Suffix; | |
889 | ||
890 | -- Start of processing for BIP_Suffix_Kind | |
891 | ||
892 | begin | |
893 | if Has_Suffix (BIP_Alloc_Suffix) then | |
894 | return BIP_Alloc_Form; | |
895 | ||
896 | elsif Has_Suffix (BIP_Storage_Pool_Suffix) then | |
897 | return BIP_Storage_Pool; | |
898 | ||
899 | elsif Has_Suffix (BIP_Finalization_Master_Suffix) then | |
900 | return BIP_Finalization_Master; | |
901 | ||
902 | elsif Has_Suffix (BIP_Task_Master_Suffix) then | |
903 | return BIP_Task_Master; | |
904 | ||
905 | elsif Has_Suffix (BIP_Activation_Chain_Suffix) then | |
906 | return BIP_Activation_Chain; | |
907 | ||
908 | elsif Has_Suffix (BIP_Object_Access_Suffix) then | |
909 | return BIP_Object_Access; | |
910 | ||
911 | else | |
912 | raise Program_Error; | |
913 | end if; | |
914 | end BIP_Suffix_Kind; | |
915 | ||
f6bbf84e EB |
916 | ----------------------------- |
917 | -- Build_Flag_For_Function -- | |
918 | ----------------------------- | |
919 | ||
920 | function Build_Flag_For_Function (Func_Id : Entity_Id) return Entity_Id is | |
921 | Flag_Decl : Node_Id; | |
922 | Flag_Id : Entity_Id; | |
923 | Func_Bod : Node_Id; | |
924 | Loc : Source_Ptr; | |
925 | ||
926 | begin | |
927 | -- Recover the function body | |
928 | ||
929 | Func_Bod := Unit_Declaration_Node (Func_Id); | |
930 | ||
931 | if Nkind (Func_Bod) = N_Subprogram_Declaration then | |
932 | Func_Bod := Parent (Parent (Corresponding_Body (Func_Bod))); | |
933 | end if; | |
934 | ||
935 | if Nkind (Func_Bod) = N_Function_Specification then | |
936 | Func_Bod := Parent (Func_Bod); -- one more level for child units | |
937 | end if; | |
938 | ||
939 | pragma Assert (Nkind (Func_Bod) = N_Subprogram_Body); | |
940 | ||
941 | Loc := Sloc (Func_Bod); | |
942 | ||
943 | -- Create a flag to track the function state | |
944 | ||
945 | Flag_Id := Make_Temporary (Loc, 'F'); | |
946 | ||
947 | -- Insert the flag at the beginning of the function declarations, | |
948 | -- generate: | |
949 | -- Fnn : Boolean := False; | |
950 | ||
951 | Flag_Decl := | |
952 | Make_Object_Declaration (Loc, | |
953 | Defining_Identifier => Flag_Id, | |
954 | Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc), | |
955 | Expression => New_Occurrence_Of (Standard_False, Loc)); | |
956 | ||
957 | Prepend_To (Declarations (Func_Bod), Flag_Decl); | |
958 | Analyze (Flag_Decl); | |
959 | ||
960 | return Flag_Id; | |
961 | end Build_Flag_For_Function; | |
962 | ||
f937473f RD |
963 | --------------------------- |
964 | -- Build_In_Place_Formal -- | |
965 | --------------------------- | |
966 | ||
967 | function Build_In_Place_Formal | |
968 | (Func : Entity_Id; | |
969 | Kind : BIP_Formal_Kind) return Entity_Id | |
970 | is | |
765005dd | 971 | Extra_Formal : Entity_Id := Extra_Formals (Func); |
16d92641 | 972 | Formal_Suffix : constant String := BIP_Formal_Suffix (Kind); |
f937473f RD |
973 | |
974 | begin | |
975 | -- Maybe it would be better for each implicit formal of a build-in-place | |
976 | -- function to have a flag or a Uint attribute to identify it. ??? | |
977 | ||
0d566e01 ES |
978 | -- The return type in the function declaration may have been a limited |
979 | -- view, and the extra formals for the function were not generated at | |
aeae67ed | 980 | -- that point. At the point of call the full view must be available and |
bdd50567 | 981 | -- the extra formals can be created and Returns_By_Ref computed. |
0d566e01 ES |
982 | |
983 | if No (Extra_Formal) then | |
984 | Create_Extra_Formals (Func); | |
985 | Extra_Formal := Extra_Formals (Func); | |
bdd50567 | 986 | Compute_Returns_By_Ref (Func); |
0d566e01 ES |
987 | end if; |
988 | ||
16d92641 PMR |
989 | -- We search for a formal with a matching suffix. We can't search |
990 | -- for the full name, because of the code at the end of Sem_Ch6.- | |
991 | -- Create_Extra_Formals, which copies the Extra_Formals over to | |
992 | -- the Alias of an instance, which will cause the formals to have | |
993 | -- "incorrect" names. | |
994 | ||
358e289d | 995 | while Present (Extra_Formal) loop |
16d92641 PMR |
996 | declare |
997 | Name : constant String := Get_Name_String (Chars (Extra_Formal)); | |
998 | begin | |
999 | exit when Name'Length >= Formal_Suffix'Length | |
1000 | and then Formal_Suffix = | |
1001 | Name (Name'Last - Formal_Suffix'Length + 1 .. Name'Last); | |
1002 | end; | |
af89615f | 1003 | |
f937473f RD |
1004 | Next_Formal_With_Extras (Extra_Formal); |
1005 | end loop; | |
1006 | ||
358e289d JM |
1007 | if No (Extra_Formal) then |
1008 | raise Program_Error; | |
1009 | end if; | |
1010 | ||
f937473f RD |
1011 | return Extra_Formal; |
1012 | end Build_In_Place_Formal; | |
02822a92 | 1013 | |
4039e173 AC |
1014 | ------------------------------- |
1015 | -- Build_Procedure_Body_Form -- | |
1016 | ------------------------------- | |
1017 | ||
1018 | function Build_Procedure_Body_Form | |
1019 | (Func_Id : Entity_Id; | |
1020 | Func_Body : Node_Id) return Node_Id | |
1021 | is | |
1022 | Loc : constant Source_Ptr := Sloc (Func_Body); | |
1023 | ||
d79e7af5 AC |
1024 | Proc_Decl : constant Node_Id := Prev (Unit_Declaration_Node (Func_Id)); |
1025 | -- It is assumed that the node before the declaration of the | |
4039e173 AC |
1026 | -- corresponding subprogram spec is the declaration of the procedure |
1027 | -- form. | |
1028 | ||
1029 | Proc_Id : constant Entity_Id := Defining_Entity (Proc_Decl); | |
1030 | ||
1031 | procedure Replace_Returns (Param_Id : Entity_Id; Stmts : List_Id); | |
1032 | -- Replace each return statement found in the list Stmts with an | |
1033 | -- assignment of the return expression to parameter Param_Id. | |
1034 | ||
1035 | --------------------- | |
1036 | -- Replace_Returns -- | |
1037 | --------------------- | |
1038 | ||
1039 | procedure Replace_Returns (Param_Id : Entity_Id; Stmts : List_Id) is | |
1040 | Stmt : Node_Id; | |
1041 | ||
1042 | begin | |
1043 | Stmt := First (Stmts); | |
1044 | while Present (Stmt) loop | |
1045 | if Nkind (Stmt) = N_Block_Statement then | |
8f8f531f PMR |
1046 | Replace_Returns (Param_Id, |
1047 | Statements (Handled_Statement_Sequence (Stmt))); | |
4039e173 AC |
1048 | |
1049 | elsif Nkind (Stmt) = N_Case_Statement then | |
1050 | declare | |
1051 | Alt : Node_Id; | |
1052 | begin | |
1053 | Alt := First (Alternatives (Stmt)); | |
1054 | while Present (Alt) loop | |
1055 | Replace_Returns (Param_Id, Statements (Alt)); | |
1056 | Next (Alt); | |
1057 | end loop; | |
1058 | end; | |
1059 | ||
17fd72ce ES |
1060 | elsif Nkind (Stmt) = N_Extended_Return_Statement then |
1061 | declare | |
1062 | Ret_Obj : constant Entity_Id := | |
1063 | Defining_Entity | |
1064 | (First (Return_Object_Declarations (Stmt))); | |
1065 | Assign : constant Node_Id := | |
1066 | Make_Assignment_Statement (Sloc (Stmt), | |
1067 | Name => | |
1068 | New_Occurrence_Of (Param_Id, Loc), | |
1069 | Expression => | |
1070 | New_Occurrence_Of (Ret_Obj, Sloc (Stmt))); | |
a14bbbb4 | 1071 | Stmts : List_Id; |
17fd72ce ES |
1072 | |
1073 | begin | |
6dc87f5f | 1074 | -- The extended return may just contain the declaration |
a14bbbb4 AC |
1075 | |
1076 | if Present (Handled_Statement_Sequence (Stmt)) then | |
6dc87f5f | 1077 | Stmts := Statements (Handled_Statement_Sequence (Stmt)); |
a14bbbb4 AC |
1078 | else |
1079 | Stmts := New_List; | |
1080 | end if; | |
1081 | ||
17fd72ce ES |
1082 | Set_Assignment_OK (Name (Assign)); |
1083 | ||
1084 | Rewrite (Stmt, | |
1085 | Make_Block_Statement (Sloc (Stmt), | |
1086 | Declarations => | |
1087 | Return_Object_Declarations (Stmt), | |
1088 | Handled_Statement_Sequence => | |
1089 | Make_Handled_Sequence_Of_Statements (Loc, | |
a14bbbb4 | 1090 | Statements => Stmts))); |
17fd72ce ES |
1091 | |
1092 | Replace_Returns (Param_Id, Stmts); | |
1093 | ||
1094 | Append_To (Stmts, Assign); | |
1095 | Append_To (Stmts, Make_Simple_Return_Statement (Loc)); | |
1096 | end; | |
1097 | ||
4039e173 AC |
1098 | elsif Nkind (Stmt) = N_If_Statement then |
1099 | Replace_Returns (Param_Id, Then_Statements (Stmt)); | |
1100 | Replace_Returns (Param_Id, Else_Statements (Stmt)); | |
1101 | ||
1102 | declare | |
1103 | Part : Node_Id; | |
1104 | begin | |
1105 | Part := First (Elsif_Parts (Stmt)); | |
1106 | while Present (Part) loop | |
0ef5cd0a | 1107 | Replace_Returns (Param_Id, Then_Statements (Part)); |
4039e173 AC |
1108 | Next (Part); |
1109 | end loop; | |
1110 | end; | |
1111 | ||
1112 | elsif Nkind (Stmt) = N_Loop_Statement then | |
1113 | Replace_Returns (Param_Id, Statements (Stmt)); | |
1114 | ||
1115 | elsif Nkind (Stmt) = N_Simple_Return_Statement then | |
1116 | ||
1117 | -- Generate: | |
1118 | -- Param := Expr; | |
1119 | -- return; | |
1120 | ||
1121 | Rewrite (Stmt, | |
1122 | Make_Assignment_Statement (Sloc (Stmt), | |
1123 | Name => New_Occurrence_Of (Param_Id, Loc), | |
1124 | Expression => Relocate_Node (Expression (Stmt)))); | |
1125 | ||
1126 | Insert_After (Stmt, Make_Simple_Return_Statement (Loc)); | |
1127 | ||
1128 | -- Skip the added return | |
1129 | ||
1130 | Next (Stmt); | |
1131 | end if; | |
1132 | ||
1133 | Next (Stmt); | |
1134 | end loop; | |
1135 | end Replace_Returns; | |
1136 | ||
1137 | -- Local variables | |
1138 | ||
1139 | Stmts : List_Id; | |
1140 | New_Body : Node_Id; | |
1141 | ||
1142 | -- Start of processing for Build_Procedure_Body_Form | |
1143 | ||
1144 | begin | |
1145 | -- This routine replaces the original function body: | |
1146 | ||
1147 | -- function F (...) return Array_Typ is | |
1148 | -- begin | |
1149 | -- ... | |
1150 | -- return Something; | |
1151 | -- end F; | |
1152 | ||
1153 | -- with the following: | |
1154 | ||
1155 | -- procedure P (..., Result : out Array_Typ) is | |
1156 | -- begin | |
1157 | -- ... | |
1158 | -- Result := Something; | |
1159 | -- end P; | |
1160 | ||
1161 | Stmts := | |
1162 | Statements (Handled_Statement_Sequence (Func_Body)); | |
1163 | Replace_Returns (Last_Entity (Proc_Id), Stmts); | |
1164 | ||
1165 | New_Body := | |
1166 | Make_Subprogram_Body (Loc, | |
1167 | Specification => | |
1168 | Copy_Subprogram_Spec (Specification (Proc_Decl)), | |
1169 | Declarations => Declarations (Func_Body), | |
1170 | Handled_Statement_Sequence => | |
1171 | Make_Handled_Sequence_Of_Statements (Loc, | |
1172 | Statements => Stmts)); | |
1173 | ||
0ef5cd0a AC |
1174 | -- If the function is a generic instance, so is the new procedure. |
1175 | -- Set flag accordingly so that the proper renaming declarations are | |
1176 | -- generated. | |
1177 | ||
1178 | Set_Is_Generic_Instance (Proc_Id, Is_Generic_Instance (Func_Id)); | |
4039e173 AC |
1179 | return New_Body; |
1180 | end Build_Procedure_Body_Form; | |
1181 | ||
0691ed6b AC |
1182 | ----------------------- |
1183 | -- Caller_Known_Size -- | |
1184 | ----------------------- | |
1185 | ||
1186 | function Caller_Known_Size | |
1155ae01 AC |
1187 | (Func_Call : Node_Id; |
1188 | Result_Subt : Entity_Id) return Boolean | |
1189 | is | |
dbb0c80c EB |
1190 | Utyp : constant Entity_Id := Underlying_Type (Result_Subt); |
1191 | ||
0691ed6b | 1192 | begin |
89e037d0 EB |
1193 | return not Needs_Secondary_Stack (Utyp) |
1194 | and then not (Is_Tagged_Type (Utyp) | |
1195 | and then Present (Controlling_Argument (Func_Call))); | |
0691ed6b AC |
1196 | end Caller_Known_Size; |
1197 | ||
82af7291 JM |
1198 | ----------------------- |
1199 | -- Check_BIP_Actuals -- | |
1200 | ----------------------- | |
1201 | ||
1202 | function Check_BIP_Actuals | |
1203 | (Subp_Call : Node_Id; | |
1204 | Subp_Id : Entity_Id) return Boolean | |
1205 | is | |
1206 | Formal : Entity_Id; | |
1207 | Actual : Node_Id; | |
1208 | ||
1209 | begin | |
4a08c95c AC |
1210 | pragma Assert (Nkind (Subp_Call) in N_Entry_Call_Statement |
1211 | | N_Function_Call | |
1212 | | N_Procedure_Call_Statement); | |
82af7291 | 1213 | |
05894d1c GL |
1214 | -- In CodePeer_Mode, the tree for `'Elab_Spec` procedures will be |
1215 | -- malformed because GNAT does not perform the usual expansion that | |
1216 | -- results in the importation of external elaboration procedure symbols. | |
1217 | -- This is expected: the CodePeer backend has special handling for this | |
1218 | -- malformed tree. | |
1219 | -- Thus, we do not need to check the tree (and in fact can't, because | |
1220 | -- it's malformed). | |
1221 | ||
1222 | if CodePeer_Mode | |
1223 | and then Nkind (Name (Subp_Call)) = N_Attribute_Reference | |
1224 | and then Attribute_Name (Name (Subp_Call)) in Name_Elab_Spec | |
1225 | | Name_Elab_Body | |
1226 | | Name_Elab_Subp_Body | |
1227 | then | |
1228 | return True; | |
1229 | end if; | |
1230 | ||
82af7291 JM |
1231 | Formal := First_Formal_With_Extras (Subp_Id); |
1232 | Actual := First_Actual (Subp_Call); | |
1233 | ||
1234 | while Present (Formal) and then Present (Actual) loop | |
1235 | if Is_Build_In_Place_Entity (Formal) | |
1236 | and then Nkind (Actual) = N_Identifier | |
1237 | and then Is_Build_In_Place_Entity (Entity (Actual)) | |
1238 | and then BIP_Suffix_Kind (Formal) | |
1239 | /= BIP_Suffix_Kind (Entity (Actual)) | |
1240 | then | |
1241 | return False; | |
1242 | end if; | |
1243 | ||
1244 | Next_Formal_With_Extras (Formal); | |
1245 | Next_Actual (Actual); | |
1246 | end loop; | |
1247 | ||
1248 | return No (Formal) and then No (Actual); | |
1249 | end Check_BIP_Actuals; | |
1250 | ||
1ed19d98 JM |
1251 | ----------------------------- |
1252 | -- Check_Number_Of_Actuals -- | |
1253 | ----------------------------- | |
1254 | ||
1255 | function Check_Number_Of_Actuals | |
1256 | (Subp_Call : Node_Id; | |
1257 | Subp_Id : Entity_Id) return Boolean | |
1258 | is | |
1259 | Formal : Entity_Id; | |
1260 | Actual : Node_Id; | |
1261 | ||
1262 | begin | |
4a08c95c AC |
1263 | pragma Assert (Nkind (Subp_Call) in N_Entry_Call_Statement |
1264 | | N_Function_Call | |
1265 | | N_Procedure_Call_Statement); | |
1ed19d98 JM |
1266 | |
1267 | Formal := First_Formal_With_Extras (Subp_Id); | |
1268 | Actual := First_Actual (Subp_Call); | |
1269 | ||
1270 | while Present (Formal) and then Present (Actual) loop | |
1271 | Next_Formal_With_Extras (Formal); | |
1272 | Next_Actual (Actual); | |
1273 | end loop; | |
1274 | ||
1275 | return No (Formal) and then No (Actual); | |
1276 | end Check_Number_Of_Actuals; | |
1277 | ||
c9a4817d RD |
1278 | -------------------------------- |
1279 | -- Check_Overriding_Operation -- | |
1280 | -------------------------------- | |
70482933 RK |
1281 | |
1282 | procedure Check_Overriding_Operation (Subp : Entity_Id) is | |
1283 | Typ : constant Entity_Id := Find_Dispatching_Type (Subp); | |
1284 | Op_List : constant Elist_Id := Primitive_Operations (Typ); | |
1285 | Op_Elmt : Elmt_Id; | |
1286 | Prim_Op : Entity_Id; | |
1287 | Par_Op : Entity_Id; | |
1288 | ||
1289 | begin | |
1290 | if Is_Derived_Type (Typ) | |
1291 | and then not Is_Private_Type (Typ) | |
1292 | and then In_Open_Scopes (Scope (Etype (Typ))) | |
d347f572 | 1293 | and then Is_Base_Type (Typ) |
70482933 | 1294 | then |
2f1b20a9 ES |
1295 | -- Subp overrides an inherited private operation if there is an |
1296 | -- inherited operation with a different name than Subp (see | |
1297 | -- Derive_Subprogram) whose Alias is a hidden subprogram with the | |
1298 | -- same name as Subp. | |
70482933 RK |
1299 | |
1300 | Op_Elmt := First_Elmt (Op_List); | |
1301 | while Present (Op_Elmt) loop | |
1302 | Prim_Op := Node (Op_Elmt); | |
1303 | Par_Op := Alias (Prim_Op); | |
1304 | ||
1305 | if Present (Par_Op) | |
1306 | and then not Comes_From_Source (Prim_Op) | |
1307 | and then Chars (Prim_Op) /= Chars (Par_Op) | |
1308 | and then Chars (Par_Op) = Chars (Subp) | |
1309 | and then Is_Hidden (Par_Op) | |
1310 | and then Type_Conformant (Prim_Op, Subp) | |
1311 | then | |
024d33d8 | 1312 | Set_DT_Position_Value (Subp, DT_Position (Prim_Op)); |
70482933 RK |
1313 | end if; |
1314 | ||
1315 | Next_Elmt (Op_Elmt); | |
1316 | end loop; | |
1317 | end if; | |
1318 | end Check_Overriding_Operation; | |
1319 | ||
1320 | ------------------------------- | |
1321 | -- Detect_Infinite_Recursion -- | |
1322 | ------------------------------- | |
1323 | ||
1324 | procedure Detect_Infinite_Recursion (N : Node_Id; Spec : Entity_Id) is | |
1325 | Loc : constant Source_Ptr := Sloc (N); | |
1326 | ||
fbf5a39b | 1327 | Var_List : constant Elist_Id := New_Elmt_List; |
70482933 RK |
1328 | -- List of globals referenced by body of procedure |
1329 | ||
fbf5a39b | 1330 | Call_List : constant Elist_Id := New_Elmt_List; |
70482933 RK |
1331 | -- List of recursive calls in body of procedure |
1332 | ||
fbf5a39b | 1333 | Shad_List : constant Elist_Id := New_Elmt_List; |
2f1b20a9 ES |
1334 | -- List of entity id's for entities created to capture the value of |
1335 | -- referenced globals on entry to the procedure. | |
70482933 RK |
1336 | |
1337 | Scop : constant Uint := Scope_Depth (Spec); | |
2f1b20a9 ES |
1338 | -- This is used to record the scope depth of the current procedure, so |
1339 | -- that we can identify global references. | |
70482933 RK |
1340 | |
1341 | Max_Vars : constant := 4; | |
1342 | -- Do not test more than four global variables | |
1343 | ||
1344 | Count_Vars : Natural := 0; | |
1345 | -- Count variables found so far | |
1346 | ||
1347 | Var : Entity_Id; | |
1348 | Elm : Elmt_Id; | |
1349 | Ent : Entity_Id; | |
1350 | Call : Elmt_Id; | |
1351 | Decl : Node_Id; | |
1352 | Test : Node_Id; | |
1353 | Elm1 : Elmt_Id; | |
1354 | Elm2 : Elmt_Id; | |
1355 | Last : Node_Id; | |
1356 | ||
1357 | function Process (Nod : Node_Id) return Traverse_Result; | |
1358 | -- Function to traverse the subprogram body (using Traverse_Func) | |
1359 | ||
1360 | ------------- | |
1361 | -- Process -- | |
1362 | ------------- | |
1363 | ||
1364 | function Process (Nod : Node_Id) return Traverse_Result is | |
1365 | begin | |
1366 | -- Procedure call | |
1367 | ||
1368 | if Nkind (Nod) = N_Procedure_Call_Statement then | |
1369 | ||
1370 | -- Case of one of the detected recursive calls | |
1371 | ||
1372 | if Is_Entity_Name (Name (Nod)) | |
1373 | and then Has_Recursive_Call (Entity (Name (Nod))) | |
1374 | and then Entity (Name (Nod)) = Spec | |
1375 | then | |
1376 | Append_Elmt (Nod, Call_List); | |
1377 | return Skip; | |
1378 | ||
1379 | -- Any other procedure call may have side effects | |
1380 | ||
1381 | else | |
1382 | return Abandon; | |
1383 | end if; | |
1384 | ||
1385 | -- A call to a pure function can always be ignored | |
1386 | ||
1387 | elsif Nkind (Nod) = N_Function_Call | |
1388 | and then Is_Entity_Name (Name (Nod)) | |
1389 | and then Is_Pure (Entity (Name (Nod))) | |
1390 | then | |
1391 | return Skip; | |
1392 | ||
1393 | -- Case of an identifier reference | |
1394 | ||
1395 | elsif Nkind (Nod) = N_Identifier then | |
1396 | Ent := Entity (Nod); | |
1397 | ||
1398 | -- If no entity, then ignore the reference | |
1399 | ||
1400 | -- Not clear why this can happen. To investigate, remove this | |
1401 | -- test and look at the crash that occurs here in 3401-004 ??? | |
1402 | ||
1403 | if No (Ent) then | |
1404 | return Skip; | |
1405 | ||
1406 | -- Ignore entities with no Scope, again not clear how this | |
1407 | -- can happen, to investigate, look at 4108-008 ??? | |
1408 | ||
1409 | elsif No (Scope (Ent)) then | |
1410 | return Skip; | |
1411 | ||
1412 | -- Ignore the reference if not to a more global object | |
1413 | ||
1414 | elsif Scope_Depth (Scope (Ent)) >= Scop then | |
1415 | return Skip; | |
1416 | ||
1417 | -- References to types, exceptions and constants are always OK | |
1418 | ||
1419 | elsif Is_Type (Ent) | |
1420 | or else Ekind (Ent) = E_Exception | |
1421 | or else Ekind (Ent) = E_Constant | |
1422 | then | |
1423 | return Skip; | |
1424 | ||
1425 | -- If other than a non-volatile scalar variable, we have some | |
1426 | -- kind of global reference (e.g. to a function) that we cannot | |
1427 | -- deal with so we forget the attempt. | |
1428 | ||
1429 | elsif Ekind (Ent) /= E_Variable | |
1430 | or else not Is_Scalar_Type (Etype (Ent)) | |
fbf5a39b | 1431 | or else Treat_As_Volatile (Ent) |
70482933 RK |
1432 | then |
1433 | return Abandon; | |
1434 | ||
1435 | -- Otherwise we have a reference to a global scalar | |
1436 | ||
1437 | else | |
1438 | -- Loop through global entities already detected | |
1439 | ||
1440 | Elm := First_Elmt (Var_List); | |
1441 | loop | |
1442 | -- If not detected before, record this new global reference | |
1443 | ||
1444 | if No (Elm) then | |
1445 | Count_Vars := Count_Vars + 1; | |
1446 | ||
1447 | if Count_Vars <= Max_Vars then | |
1448 | Append_Elmt (Entity (Nod), Var_List); | |
1449 | else | |
1450 | return Abandon; | |
1451 | end if; | |
1452 | ||
1453 | exit; | |
1454 | ||
1455 | -- If recorded before, ignore | |
1456 | ||
1457 | elsif Node (Elm) = Entity (Nod) then | |
1458 | return Skip; | |
1459 | ||
1460 | -- Otherwise keep looking | |
1461 | ||
1462 | else | |
1463 | Next_Elmt (Elm); | |
1464 | end if; | |
1465 | end loop; | |
1466 | ||
1467 | return Skip; | |
1468 | end if; | |
1469 | ||
1470 | -- For all other node kinds, recursively visit syntactic children | |
1471 | ||
1472 | else | |
1473 | return OK; | |
1474 | end if; | |
1475 | end Process; | |
1476 | ||
02822a92 | 1477 | function Traverse_Body is new Traverse_Func (Process); |
70482933 RK |
1478 | |
1479 | -- Start of processing for Detect_Infinite_Recursion | |
1480 | ||
1481 | begin | |
2f1b20a9 ES |
1482 | -- Do not attempt detection in No_Implicit_Conditional mode, since we |
1483 | -- won't be able to generate the code to handle the recursion in any | |
1484 | -- case. | |
70482933 | 1485 | |
6e937c1c | 1486 | if Restriction_Active (No_Implicit_Conditionals) then |
70482933 RK |
1487 | return; |
1488 | end if; | |
1489 | ||
1490 | -- Otherwise do traversal and quit if we get abandon signal | |
1491 | ||
1492 | if Traverse_Body (N) = Abandon then | |
1493 | return; | |
1494 | ||
2f1b20a9 ES |
1495 | -- We must have a call, since Has_Recursive_Call was set. If not just |
1496 | -- ignore (this is only an error check, so if we have a funny situation, | |
a90bd866 | 1497 | -- due to bugs or errors, we do not want to bomb). |
70482933 RK |
1498 | |
1499 | elsif Is_Empty_Elmt_List (Call_List) then | |
1500 | return; | |
1501 | end if; | |
1502 | ||
1503 | -- Here is the case where we detect recursion at compile time | |
1504 | ||
2f1b20a9 ES |
1505 | -- Push our current scope for analyzing the declarations and code that |
1506 | -- we will insert for the checking. | |
70482933 | 1507 | |
7888a6ae | 1508 | Push_Scope (Spec); |
70482933 | 1509 | |
2f1b20a9 ES |
1510 | -- This loop builds temporary variables for each of the referenced |
1511 | -- globals, so that at the end of the loop the list Shad_List contains | |
1512 | -- these temporaries in one-to-one correspondence with the elements in | |
1513 | -- Var_List. | |
70482933 RK |
1514 | |
1515 | Last := Empty; | |
1516 | Elm := First_Elmt (Var_List); | |
1517 | while Present (Elm) loop | |
1518 | Var := Node (Elm); | |
c12beea0 | 1519 | Ent := Make_Temporary (Loc, 'S'); |
70482933 RK |
1520 | Append_Elmt (Ent, Shad_List); |
1521 | ||
2f1b20a9 ES |
1522 | -- Insert a declaration for this temporary at the start of the |
1523 | -- declarations for the procedure. The temporaries are declared as | |
1524 | -- constant objects initialized to the current values of the | |
1525 | -- corresponding temporaries. | |
70482933 RK |
1526 | |
1527 | Decl := | |
1528 | Make_Object_Declaration (Loc, | |
1529 | Defining_Identifier => Ent, | |
1530 | Object_Definition => New_Occurrence_Of (Etype (Var), Loc), | |
1531 | Constant_Present => True, | |
1532 | Expression => New_Occurrence_Of (Var, Loc)); | |
1533 | ||
1534 | if No (Last) then | |
1535 | Prepend (Decl, Declarations (N)); | |
1536 | else | |
1537 | Insert_After (Last, Decl); | |
1538 | end if; | |
1539 | ||
1540 | Last := Decl; | |
1541 | Analyze (Decl); | |
1542 | Next_Elmt (Elm); | |
1543 | end loop; | |
1544 | ||
1545 | -- Loop through calls | |
1546 | ||
1547 | Call := First_Elmt (Call_List); | |
1548 | while Present (Call) loop | |
1549 | ||
1550 | -- Build a predicate expression of the form | |
1551 | ||
1552 | -- True | |
1553 | -- and then global1 = temp1 | |
1554 | -- and then global2 = temp2 | |
1555 | -- ... | |
1556 | ||
1557 | -- This predicate determines if any of the global values | |
1558 | -- referenced by the procedure have changed since the | |
1559 | -- current call, if not an infinite recursion is assured. | |
1560 | ||
1561 | Test := New_Occurrence_Of (Standard_True, Loc); | |
1562 | ||
1563 | Elm1 := First_Elmt (Var_List); | |
1564 | Elm2 := First_Elmt (Shad_List); | |
1565 | while Present (Elm1) loop | |
1566 | Test := | |
1567 | Make_And_Then (Loc, | |
1568 | Left_Opnd => Test, | |
1569 | Right_Opnd => | |
1570 | Make_Op_Eq (Loc, | |
1571 | Left_Opnd => New_Occurrence_Of (Node (Elm1), Loc), | |
1572 | Right_Opnd => New_Occurrence_Of (Node (Elm2), Loc))); | |
1573 | ||
1574 | Next_Elmt (Elm1); | |
1575 | Next_Elmt (Elm2); | |
1576 | end loop; | |
1577 | ||
1578 | -- Now we replace the call with the sequence | |
1579 | ||
1580 | -- if no-changes (see above) then | |
1581 | -- raise Storage_Error; | |
1582 | -- else | |
1583 | -- original-call | |
1584 | -- end if; | |
1585 | ||
1586 | Rewrite (Node (Call), | |
1587 | Make_If_Statement (Loc, | |
1588 | Condition => Test, | |
1589 | Then_Statements => New_List ( | |
07fc65c4 GB |
1590 | Make_Raise_Storage_Error (Loc, |
1591 | Reason => SE_Infinite_Recursion)), | |
70482933 RK |
1592 | |
1593 | Else_Statements => New_List ( | |
1594 | Relocate_Node (Node (Call))))); | |
1595 | ||
1596 | Analyze (Node (Call)); | |
1597 | ||
1598 | Next_Elmt (Call); | |
1599 | end loop; | |
1600 | ||
1601 | -- Remove temporary scope stack entry used for analysis | |
1602 | ||
1603 | Pop_Scope; | |
1604 | end Detect_Infinite_Recursion; | |
1605 | ||
1606 | -------------------- | |
1607 | -- Expand_Actuals -- | |
1608 | -------------------- | |
1609 | ||
ca1f6b29 | 1610 | procedure Expand_Actuals |
ec40b86c HK |
1611 | (N : Node_Id; |
1612 | Subp : Entity_Id; | |
1613 | Post_Call : out List_Id) | |
ca1f6b29 | 1614 | is |
c43098ca PT |
1615 | Loc : constant Source_Ptr := Sloc (N); |
1616 | Actual : Node_Id; | |
1617 | Formal : Entity_Id; | |
1618 | N_Node : Node_Id; | |
1619 | E_Actual : Entity_Id; | |
1620 | E_Formal : Entity_Id; | |
70482933 RK |
1621 | |
1622 | procedure Add_Call_By_Copy_Code; | |
fbf5a39b AC |
1623 | -- For cases where the parameter must be passed by copy, this routine |
1624 | -- generates a temporary variable into which the actual is copied and | |
1625 | -- then passes this as the parameter. For an OUT or IN OUT parameter, | |
1626 | -- an assignment is also generated to copy the result back. The call | |
1627 | -- also takes care of any constraint checks required for the type | |
1628 | -- conversion case (on both the way in and the way out). | |
70482933 | 1629 | |
f5b65fab | 1630 | procedure Add_Simple_Call_By_Copy_Code (Force : Boolean); |
f44fe430 RD |
1631 | -- This is similar to the above, but is used in cases where we know |
1632 | -- that all that is needed is to simply create a temporary and copy | |
f5b65fab EB |
1633 | -- the value in and out of the temporary. If Force is True, then the |
1634 | -- procedure may disregard legality considerations. | |
1635 | ||
1636 | -- ??? We need to do the copy for a bit-packed array because this is | |
1637 | -- where the rewriting into a mask-and-shift sequence is done. But of | |
1638 | -- course this may break the program if it expects bits to be really | |
1639 | -- passed by reference. That's what we have done historically though. | |
70482933 | 1640 | |
62e45e3e HK |
1641 | procedure Add_Validation_Call_By_Copy_Code (Act : Node_Id); |
1642 | -- Perform copy-back for actual parameter Act which denotes a validation | |
1643 | -- variable. | |
1644 | ||
70482933 RK |
1645 | procedure Check_Fortran_Logical; |
1646 | -- A value of type Logical that is passed through a formal parameter | |
1647 | -- must be normalized because .TRUE. usually does not have the same | |
1648 | -- representation as True. We assume that .FALSE. = False = 0. | |
1649 | -- What about functions that return a logical type ??? | |
1650 | ||
758c442c GD |
1651 | function Is_Legal_Copy return Boolean; |
1652 | -- Check that an actual can be copied before generating the temporary | |
348c3ae6 EB |
1653 | -- to be used in the call. If the formal is of a by_reference type or |
1654 | -- is aliased, then the program is illegal (this can only happen in | |
1655 | -- the presence of representation clauses that force a misalignment) | |
1656 | -- If the formal is a by_reference parameter imposed by a DEC pragma, | |
1657 | -- emit a warning that this might lead to unaligned arguments. | |
758c442c | 1658 | |
70482933 | 1659 | function Make_Var (Actual : Node_Id) return Entity_Id; |
da574a86 AC |
1660 | -- Returns an entity that refers to the given actual parameter, Actual |
1661 | -- (not including any type conversion). If Actual is an entity name, | |
1662 | -- then this entity is returned unchanged, otherwise a renaming is | |
1663 | -- created to provide an entity for the actual. | |
70482933 RK |
1664 | |
1665 | procedure Reset_Packed_Prefix; | |
1666 | -- The expansion of a packed array component reference is delayed in | |
1667 | -- the context of a call. Now we need to complete the expansion, so we | |
1668 | -- unmark the analyzed bits in all prefixes. | |
1669 | ||
6a6ac079 EB |
1670 | function Requires_Atomic_Or_Volatile_Copy return Boolean; |
1671 | -- Returns whether a copy is required as per RM C.6(19) and gives a | |
1672 | -- warning in this case. | |
1673 | ||
70482933 RK |
1674 | --------------------------- |
1675 | -- Add_Call_By_Copy_Code -- | |
1676 | --------------------------- | |
1677 | ||
1678 | procedure Add_Call_By_Copy_Code is | |
db99c46e | 1679 | Crep : Boolean; |
cc335f43 | 1680 | Expr : Node_Id; |
db99c46e AC |
1681 | F_Typ : Entity_Id := Etype (Formal); |
1682 | Indic : Node_Id; | |
cc335f43 AC |
1683 | Init : Node_Id; |
1684 | Temp : Entity_Id; | |
cc335f43 | 1685 | V_Typ : Entity_Id; |
db99c46e | 1686 | Var : Entity_Id; |
70482933 RK |
1687 | |
1688 | begin | |
758c442c GD |
1689 | if not Is_Legal_Copy then |
1690 | return; | |
1691 | end if; | |
1692 | ||
b086849e | 1693 | Temp := Make_Temporary (Loc, 'T', Actual); |
70482933 | 1694 | |
db99c46e AC |
1695 | -- Handle formals whose type comes from the limited view |
1696 | ||
1697 | if From_Limited_With (F_Typ) | |
1698 | and then Has_Non_Limited_View (F_Typ) | |
1699 | then | |
1700 | F_Typ := Non_Limited_View (F_Typ); | |
1701 | end if; | |
1702 | ||
f44fe430 RD |
1703 | -- Use formal type for temp, unless formal type is an unconstrained |
1704 | -- array, in which case we don't have to worry about bounds checks, | |
758c442c | 1705 | -- and we use the actual type, since that has appropriate bounds. |
f44fe430 RD |
1706 | |
1707 | if Is_Array_Type (F_Typ) and then not Is_Constrained (F_Typ) then | |
1708 | Indic := New_Occurrence_Of (Etype (Actual), Loc); | |
1709 | else | |
db99c46e | 1710 | Indic := New_Occurrence_Of (F_Typ, Loc); |
f44fe430 RD |
1711 | end if; |
1712 | ||
13931a38 EB |
1713 | -- The new code will be properly analyzed below and the setting of |
1714 | -- the Do_Range_Check flag recomputed so remove the obsolete one. | |
1715 | ||
1716 | Set_Do_Range_Check (Actual, False); | |
1717 | ||
70482933 | 1718 | if Nkind (Actual) = N_Type_Conversion then |
13931a38 EB |
1719 | Set_Do_Range_Check (Expression (Actual), False); |
1720 | ||
70482933 | 1721 | V_Typ := Etype (Expression (Actual)); |
19f0526a AC |
1722 | |
1723 | -- If the formal is an (in-)out parameter, capture the name | |
1724 | -- of the variable in order to build the post-call assignment. | |
81a5b587 AC |
1725 | |
1726 | Var := Make_Var (Expression (Actual)); | |
19f0526a | 1727 | |
3968b02a | 1728 | Crep := not Has_Compatible_Representation |
e2f7d58c EB |
1729 | (Target_Typ => F_Typ, |
1730 | Operand_Typ => Etype (Expression (Actual))); | |
08aa9a4a | 1731 | |
70482933 RK |
1732 | else |
1733 | V_Typ := Etype (Actual); | |
1734 | Var := Make_Var (Actual); | |
1735 | Crep := False; | |
1736 | end if; | |
1737 | ||
e75d06f9 EB |
1738 | -- If the actual denotes a variable which captures the value of an |
1739 | -- object for validation purposes, we propagate the link with this | |
1740 | -- object to the new variable made from the actual just above. | |
1741 | ||
1742 | if Ekind (Formal) /= E_In_Parameter | |
1743 | and then Is_Validation_Variable_Reference (Actual) | |
1744 | then | |
1745 | declare | |
1746 | Ref : constant Node_Id := Unqual_Conv (Actual); | |
1747 | ||
1748 | begin | |
1749 | if Is_Entity_Name (Ref) then | |
1750 | Set_Validated_Object (Var, Validated_Object (Entity (Ref))); | |
1751 | ||
1752 | else | |
1753 | pragma Assert (False); | |
1754 | null; | |
1755 | end if; | |
1756 | end; | |
1757 | end if; | |
1758 | ||
70482933 RK |
1759 | -- Setup initialization for case of in out parameter, or an out |
1760 | -- parameter where the formal is an unconstrained array (in the | |
1761 | -- latter case, we have to pass in an object with bounds). | |
1762 | ||
cc335f43 AC |
1763 | -- If this is an out parameter, the initial copy is wasteful, so as |
1764 | -- an optimization for the one-dimensional case we extract the | |
1765 | -- bounds of the actual and build an uninitialized temporary of the | |
1766 | -- right size. | |
1767 | ||
e693ddbe EB |
1768 | -- If the formal is an out parameter with discriminants, the |
1769 | -- discriminants must be captured even if the rest of the object | |
1770 | -- is in principle uninitialized, because the discriminants may | |
1771 | -- be read by the called subprogram. | |
1772 | ||
70482933 | 1773 | if Ekind (Formal) = E_In_Out_Parameter |
0da2c8ac | 1774 | or else (Is_Array_Type (F_Typ) and then not Is_Constrained (F_Typ)) |
e693ddbe | 1775 | or else Has_Discriminants (F_Typ) |
70482933 RK |
1776 | then |
1777 | if Nkind (Actual) = N_Type_Conversion then | |
1778 | if Conversion_OK (Actual) then | |
0da2c8ac | 1779 | Init := OK_Convert_To (F_Typ, New_Occurrence_Of (Var, Loc)); |
70482933 | 1780 | else |
0da2c8ac | 1781 | Init := Convert_To (F_Typ, New_Occurrence_Of (Var, Loc)); |
70482933 | 1782 | end if; |
cc335f43 AC |
1783 | |
1784 | elsif Ekind (Formal) = E_Out_Parameter | |
0da2c8ac AC |
1785 | and then Is_Array_Type (F_Typ) |
1786 | and then Number_Dimensions (F_Typ) = 1 | |
1787 | and then not Has_Non_Null_Base_Init_Proc (F_Typ) | |
cc335f43 AC |
1788 | then |
1789 | -- Actual is a one-dimensional array or slice, and the type | |
1790 | -- requires no initialization. Create a temporary of the | |
f44fe430 | 1791 | -- right size, but do not copy actual into it (optimization). |
cc335f43 AC |
1792 | |
1793 | Init := Empty; | |
1794 | Indic := | |
1795 | Make_Subtype_Indication (Loc, | |
5f6fb720 | 1796 | Subtype_Mark => New_Occurrence_Of (F_Typ, Loc), |
cc335f43 AC |
1797 | Constraint => |
1798 | Make_Index_Or_Discriminant_Constraint (Loc, | |
1799 | Constraints => New_List ( | |
1800 | Make_Range (Loc, | |
1801 | Low_Bound => | |
1802 | Make_Attribute_Reference (Loc, | |
5f6fb720 | 1803 | Prefix => New_Occurrence_Of (Var, Loc), |
70f91180 | 1804 | Attribute_Name => Name_First), |
cc335f43 AC |
1805 | High_Bound => |
1806 | Make_Attribute_Reference (Loc, | |
5f6fb720 | 1807 | Prefix => New_Occurrence_Of (Var, Loc), |
cc335f43 AC |
1808 | Attribute_Name => Name_Last))))); |
1809 | ||
70482933 RK |
1810 | else |
1811 | Init := New_Occurrence_Of (Var, Loc); | |
1812 | end if; | |
1813 | ||
1814 | -- An initialization is created for packed conversions as | |
1815 | -- actuals for out parameters to enable Make_Object_Declaration | |
1816 | -- to determine the proper subtype for N_Node. Note that this | |
1817 | -- is wasteful because the extra copying on the call side is | |
1818 | -- not required for such out parameters. ??? | |
1819 | ||
1820 | elsif Ekind (Formal) = E_Out_Parameter | |
1821 | and then Nkind (Actual) = N_Type_Conversion | |
0da2c8ac | 1822 | and then (Is_Bit_Packed_Array (F_Typ) |
70482933 RK |
1823 | or else |
1824 | Is_Bit_Packed_Array (Etype (Expression (Actual)))) | |
1825 | then | |
1826 | if Conversion_OK (Actual) then | |
f44fe430 | 1827 | Init := OK_Convert_To (F_Typ, New_Occurrence_Of (Var, Loc)); |
70482933 | 1828 | else |
f44fe430 | 1829 | Init := Convert_To (F_Typ, New_Occurrence_Of (Var, Loc)); |
70482933 | 1830 | end if; |
2e071734 AC |
1831 | |
1832 | elsif Ekind (Formal) = E_In_Parameter then | |
02822a92 RD |
1833 | |
1834 | -- Handle the case in which the actual is a type conversion | |
1835 | ||
1836 | if Nkind (Actual) = N_Type_Conversion then | |
1837 | if Conversion_OK (Actual) then | |
1838 | Init := OK_Convert_To (F_Typ, New_Occurrence_Of (Var, Loc)); | |
1839 | else | |
1840 | Init := Convert_To (F_Typ, New_Occurrence_Of (Var, Loc)); | |
1841 | end if; | |
1842 | else | |
1843 | Init := New_Occurrence_Of (Var, Loc); | |
1844 | end if; | |
2e071734 | 1845 | |
68e4cc98 ES |
1846 | -- Access types are passed in without checks, but if a copy-back is |
1847 | -- required for a null-excluding check on an in-out or out parameter, | |
1848 | -- then the initial value is that of the actual. | |
1849 | ||
1850 | elsif Is_Access_Type (E_Formal) | |
1851 | and then Can_Never_Be_Null (Etype (Actual)) | |
1852 | and then not Can_Never_Be_Null (E_Formal) | |
1853 | then | |
1854 | Init := New_Occurrence_Of (Var, Loc); | |
1855 | ||
c873714f GD |
1856 | -- View conversions when the formal type has the Default_Value aspect |
1857 | -- require passing in the value of the conversion's operand. The type | |
1858 | -- of that operand also has Default_Value, as required by AI12-0074 | |
1859 | -- (RM 6.4.1(5.3/4)). The subtype denoted by the subtype_indication | |
1860 | -- is changed to the base type of the formal subtype, to ensure that | |
1861 | -- the actual's value can be assigned without a constraint check | |
1862 | -- (note that no check is done on passing to an out parameter). Also | |
1863 | -- note that the two types necessarily share the same ancestor type, | |
1864 | -- as required by 6.4.1(5.2/4), so underlying base types will match. | |
1865 | ||
1866 | elsif Ekind (Formal) = E_Out_Parameter | |
1867 | and then Is_Scalar_Type (Etype (F_Typ)) | |
1868 | and then Nkind (Actual) = N_Type_Conversion | |
1869 | and then Present (Default_Aspect_Value (Etype (F_Typ))) | |
1870 | then | |
1871 | Indic := New_Occurrence_Of (Base_Type (F_Typ), Loc); | |
1872 | Init := Convert_To | |
1873 | (Base_Type (F_Typ), New_Occurrence_Of (Var, Loc)); | |
1874 | ||
70482933 RK |
1875 | else |
1876 | Init := Empty; | |
1877 | end if; | |
1878 | ||
1879 | N_Node := | |
1880 | Make_Object_Declaration (Loc, | |
1881 | Defining_Identifier => Temp, | |
cc335f43 | 1882 | Object_Definition => Indic, |
f44fe430 | 1883 | Expression => Init); |
70482933 RK |
1884 | Set_Assignment_OK (N_Node); |
1885 | Insert_Action (N, N_Node); | |
1886 | ||
1887 | -- Now, normally the deal here is that we use the defining | |
1888 | -- identifier created by that object declaration. There is | |
1889 | -- one exception to this. In the change of representation case | |
1890 | -- the above declaration will end up looking like: | |
1891 | ||
1892 | -- temp : type := identifier; | |
1893 | ||
1894 | -- And in this case we might as well use the identifier directly | |
1895 | -- and eliminate the temporary. Note that the analysis of the | |
1896 | -- declaration was not a waste of time in that case, since it is | |
1897 | -- what generated the necessary change of representation code. If | |
1898 | -- the change of representation introduced additional code, as in | |
1899 | -- a fixed-integer conversion, the expression is not an identifier | |
1900 | -- and must be kept. | |
1901 | ||
1902 | if Crep | |
1903 | and then Present (Expression (N_Node)) | |
1904 | and then Is_Entity_Name (Expression (N_Node)) | |
1905 | then | |
1906 | Temp := Entity (Expression (N_Node)); | |
1907 | Rewrite (N_Node, Make_Null_Statement (Loc)); | |
1908 | end if; | |
1909 | ||
fbf5a39b | 1910 | -- For IN parameter, all we do is to replace the actual |
70482933 | 1911 | |
fbf5a39b | 1912 | if Ekind (Formal) = E_In_Parameter then |
e4494292 | 1913 | Rewrite (Actual, New_Occurrence_Of (Temp, Loc)); |
fbf5a39b AC |
1914 | Analyze (Actual); |
1915 | ||
1916 | -- Processing for OUT or IN OUT parameter | |
1917 | ||
1918 | else | |
c8ef728f ES |
1919 | -- Kill current value indications for the temporary variable we |
1920 | -- created, since we just passed it as an OUT parameter. | |
1921 | ||
1922 | Kill_Current_Values (Temp); | |
75ba322d | 1923 | Set_Is_Known_Valid (Temp, False); |
8f0303e7 | 1924 | Set_Is_True_Constant (Temp, False); |
c8ef728f | 1925 | |
fbf5a39b AC |
1926 | -- If type conversion, use reverse conversion on exit |
1927 | ||
1928 | if Nkind (Actual) = N_Type_Conversion then | |
1929 | if Conversion_OK (Actual) then | |
1930 | Expr := OK_Convert_To (V_Typ, New_Occurrence_Of (Temp, Loc)); | |
1931 | else | |
1932 | Expr := Convert_To (V_Typ, New_Occurrence_Of (Temp, Loc)); | |
1933 | end if; | |
70482933 | 1934 | else |
fbf5a39b | 1935 | Expr := New_Occurrence_Of (Temp, Loc); |
70482933 | 1936 | end if; |
70482933 | 1937 | |
03b4e4ae | 1938 | Rewrite (Actual, New_Occurrence_Of (Temp, Sloc (Actual))); |
fbf5a39b | 1939 | Analyze (Actual); |
70482933 | 1940 | |
d766cee3 RD |
1941 | -- If the actual is a conversion of a packed reference, it may |
1942 | -- already have been expanded by Remove_Side_Effects, and the | |
1943 | -- resulting variable is a temporary which does not designate | |
1944 | -- the proper out-parameter, which may not be addressable. In | |
1945 | -- that case, generate an assignment to the original expression | |
b0159fbe | 1946 | -- (before expansion of the packed reference) so that the proper |
d766cee3 | 1947 | -- expansion of assignment to a packed component can take place. |
70482933 | 1948 | |
d766cee3 RD |
1949 | declare |
1950 | Obj : Node_Id; | |
1951 | Lhs : Node_Id; | |
1952 | ||
1953 | begin | |
1954 | if Is_Renaming_Of_Object (Var) | |
1955 | and then Nkind (Renamed_Object (Var)) = N_Selected_Component | |
d766cee3 RD |
1956 | and then Nkind (Original_Node (Prefix (Renamed_Object (Var)))) |
1957 | = N_Indexed_Component | |
1958 | and then | |
1959 | Has_Non_Standard_Rep (Etype (Prefix (Renamed_Object (Var)))) | |
1960 | then | |
1961 | Obj := Renamed_Object (Var); | |
1962 | Lhs := | |
1963 | Make_Selected_Component (Loc, | |
1964 | Prefix => | |
1965 | New_Copy_Tree (Original_Node (Prefix (Obj))), | |
1966 | Selector_Name => New_Copy (Selector_Name (Obj))); | |
1967 | Reset_Analyzed_Flags (Lhs); | |
1968 | ||
1969 | else | |
c8307596 | 1970 | Lhs := New_Occurrence_Of (Var, Loc); |
d766cee3 RD |
1971 | end if; |
1972 | ||
1973 | Set_Assignment_OK (Lhs); | |
1974 | ||
d15f9422 AC |
1975 | if Is_Access_Type (E_Formal) |
1976 | and then Is_Entity_Name (Lhs) | |
996c8821 RD |
1977 | and then |
1978 | Present (Effective_Extra_Accessibility (Entity (Lhs))) | |
bcb8c3bb | 1979 | and then not No_Dynamic_Accessibility_Checks_Enabled (Lhs) |
d15f9422 | 1980 | then |
4bb43ffb AC |
1981 | -- Copyback target is an Ada 2012 stand-alone object of an |
1982 | -- anonymous access type. | |
d15f9422 AC |
1983 | |
1984 | pragma Assert (Ada_Version >= Ada_2012); | |
1985 | ||
d7e20130 | 1986 | Apply_Accessibility_Check (Lhs, E_Formal, N); |
d15f9422 AC |
1987 | |
1988 | Append_To (Post_Call, | |
1989 | Make_Assignment_Statement (Loc, | |
1990 | Name => Lhs, | |
1991 | Expression => Expr)); | |
1992 | ||
996c8821 RD |
1993 | -- We would like to somehow suppress generation of the |
1994 | -- extra_accessibility assignment generated by the expansion | |
1995 | -- of the above assignment statement. It's not a correctness | |
1996 | -- issue because the following assignment renders it dead, | |
1997 | -- but generating back-to-back assignments to the same | |
1998 | -- target is undesirable. ??? | |
d15f9422 AC |
1999 | |
2000 | Append_To (Post_Call, | |
2001 | Make_Assignment_Statement (Loc, | |
2002 | Name => New_Occurrence_Of ( | |
2003 | Effective_Extra_Accessibility (Entity (Lhs)), Loc), | |
2004 | Expression => Make_Integer_Literal (Loc, | |
2005 | Type_Access_Level (E_Formal)))); | |
996c8821 | 2006 | |
d15f9422 | 2007 | else |
68e4cc98 ES |
2008 | if Is_Access_Type (E_Formal) |
2009 | and then Can_Never_Be_Null (Etype (Actual)) | |
2010 | and then not Can_Never_Be_Null (E_Formal) | |
2011 | then | |
2012 | Append_To (Post_Call, | |
2013 | Make_Raise_Constraint_Error (Loc, | |
2014 | Condition => | |
2015 | Make_Op_Eq (Loc, | |
2016 | Left_Opnd => New_Occurrence_Of (Temp, Loc), | |
2017 | Right_Opnd => Make_Null (Loc)), | |
2018 | Reason => CE_Access_Check_Failed)); | |
2019 | end if; | |
2020 | ||
d15f9422 AC |
2021 | Append_To (Post_Call, |
2022 | Make_Assignment_Statement (Loc, | |
2023 | Name => Lhs, | |
2024 | Expression => Expr)); | |
2025 | end if; | |
e75d06f9 EB |
2026 | |
2027 | -- Add a copy-back to reflect any potential changes in value | |
2028 | -- back into the original object, if any. | |
2029 | ||
2030 | if Is_Validation_Variable_Reference (Lhs) then | |
2031 | Add_Validation_Call_By_Copy_Code (Lhs); | |
2032 | end if; | |
d766cee3 | 2033 | end; |
fbf5a39b | 2034 | end if; |
70482933 RK |
2035 | end Add_Call_By_Copy_Code; |
2036 | ||
2037 | ---------------------------------- | |
f44fe430 | 2038 | -- Add_Simple_Call_By_Copy_Code -- |
70482933 RK |
2039 | ---------------------------------- |
2040 | ||
f5b65fab | 2041 | procedure Add_Simple_Call_By_Copy_Code (Force : Boolean) is |
ca4bff3a EB |
2042 | With_Storage_Model : constant Boolean := |
2043 | Nkind (Actual) = N_Explicit_Dereference | |
2044 | and then | |
2045 | Has_Designated_Storage_Model_Aspect (Etype (Prefix (Actual))); | |
2046 | ||
2047 | Cpcod : List_Id; | |
758c442c | 2048 | Decl : Node_Id; |
ca4bff3a | 2049 | F_Typ : Entity_Id; |
70482933 | 2050 | Incod : Node_Id; |
db99c46e | 2051 | Indic : Node_Id; |
70482933 | 2052 | Lhs : Node_Id; |
db99c46e | 2053 | Outcod : Node_Id; |
70482933 | 2054 | Rhs : Node_Id; |
db99c46e | 2055 | Temp : Entity_Id; |
70482933 RK |
2056 | |
2057 | begin | |
f5b65fab | 2058 | -- Unless forced not to, check the legality of the copy operation |
348c3ae6 | 2059 | |
f5b65fab | 2060 | if not Force and then not Is_Legal_Copy then |
758c442c GD |
2061 | return; |
2062 | end if; | |
2063 | ||
ca4bff3a EB |
2064 | F_Typ := Etype (Formal); |
2065 | ||
db99c46e AC |
2066 | -- Handle formals whose type comes from the limited view |
2067 | ||
2068 | if From_Limited_With (F_Typ) | |
2069 | and then Has_Non_Limited_View (F_Typ) | |
2070 | then | |
2071 | F_Typ := Non_Limited_View (F_Typ); | |
2072 | end if; | |
2073 | ||
f44fe430 | 2074 | -- Use formal type for temp, unless formal type is an unconstrained |
c7b84ce6 EB |
2075 | -- composite, in which case we don't have to worry about checks and |
2076 | -- we can use the actual type, since that has appropriate bounds. | |
ca4bff3a | 2077 | |
c7b84ce6 EB |
2078 | if Is_Composite_Type (F_Typ) and then not Is_Constrained (F_Typ) then |
2079 | Indic := New_Occurrence_Of (Get_Actual_Subtype (Actual), Loc); | |
f44fe430 | 2080 | else |
db99c46e | 2081 | Indic := New_Occurrence_Of (F_Typ, Loc); |
f44fe430 | 2082 | end if; |
70482933 RK |
2083 | |
2084 | -- Prepare to generate code | |
2085 | ||
f44fe430 RD |
2086 | Reset_Packed_Prefix; |
2087 | ||
70482933 RK |
2088 | Incod := Relocate_Node (Actual); |
2089 | Outcod := New_Copy_Tree (Incod); | |
2090 | ||
2091 | -- Generate declaration of temporary variable, initializing it | |
c73ae90f | 2092 | -- with the input parameter unless we have an OUT formal or |
758c442c | 2093 | -- this is an initialization call. |
70482933 RK |
2094 | |
2095 | if Ekind (Formal) = E_Out_Parameter then | |
2096 | Incod := Empty; | |
758c442c GD |
2097 | |
2098 | elsif Inside_Init_Proc then | |
c73ae90f | 2099 | |
4458909a JS |
2100 | -- Skip using the actual as the expression in Decl if we are in |
2101 | -- an init proc and it is not a component which depends on a | |
2102 | -- discriminant, because, in this case, we need to use the actual | |
2103 | -- type of the component instead. | |
c73ae90f | 2104 | |
758c442c GD |
2105 | if Nkind (Actual) /= N_Selected_Component |
2106 | or else | |
2107 | not Has_Discriminant_Dependent_Constraint | |
2108 | (Entity (Selector_Name (Actual))) | |
2109 | then | |
2110 | Incod := Empty; | |
2111 | ||
4458909a JS |
2112 | -- Otherwise, keep the component so we can generate the proper |
2113 | -- actual subtype - since the subtype depends on enclosing | |
2114 | -- discriminants. | |
758c442c | 2115 | |
c73ae90f | 2116 | else |
758c442c GD |
2117 | null; |
2118 | end if; | |
70482933 RK |
2119 | end if; |
2120 | ||
ca4bff3a EB |
2121 | Cpcod := New_List; |
2122 | ||
2123 | if With_Storage_Model then | |
2124 | Temp := | |
2125 | Build_Temporary_On_Secondary_Stack (Loc, Entity (Indic), Cpcod); | |
2126 | ||
2127 | if Present (Incod) then | |
2128 | Append_To (Cpcod, | |
2129 | Make_Assignment_Statement (Loc, | |
2130 | Name => | |
2131 | Make_Explicit_Dereference (Loc, | |
2132 | Prefix => New_Occurrence_Of (Temp, Loc)), | |
2133 | Expression => Incod)); | |
2134 | Set_Suppress_Assignment_Checks (Last (Cpcod)); | |
2135 | end if; | |
2136 | ||
2137 | else | |
2138 | Temp := Make_Temporary (Loc, 'T', Actual); | |
2139 | ||
2140 | Decl := | |
2141 | Make_Object_Declaration (Loc, | |
2142 | Defining_Identifier => Temp, | |
2143 | Object_Definition => Indic, | |
2144 | Expression => Incod); | |
758c442c | 2145 | |
758c442c GD |
2146 | -- If the call is to initialize a component of a composite type, |
2147 | -- and the component does not depend on discriminants, use the | |
2148 | -- actual type of the component. This is required in case the | |
2149 | -- component is constrained, because in general the formal of the | |
2150 | -- initialization procedure will be unconstrained. Note that if | |
2151 | -- the component being initialized is constrained by an enclosing | |
2152 | -- discriminant, the presence of the initialization in the | |
2153 | -- declaration will generate an expression for the actual subtype. | |
2154 | ||
ca4bff3a EB |
2155 | if Inside_Init_Proc and then No (Incod) then |
2156 | Set_No_Initialization (Decl); | |
2157 | Set_Object_Definition (Decl, | |
2158 | New_Occurrence_Of (Etype (Actual), Loc)); | |
2159 | end if; | |
2160 | ||
2161 | Append_To (Cpcod, Decl); | |
758c442c GD |
2162 | end if; |
2163 | ||
ca4bff3a | 2164 | Insert_Actions (N, Cpcod); |
70482933 RK |
2165 | |
2166 | -- The actual is simply a reference to the temporary | |
2167 | ||
ca4bff3a EB |
2168 | if With_Storage_Model then |
2169 | Rewrite (Actual, | |
2170 | Make_Explicit_Dereference (Loc, | |
2171 | Prefix => New_Occurrence_Of (Temp, Loc))); | |
2172 | else | |
2173 | Rewrite (Actual, New_Occurrence_Of (Temp, Loc)); | |
2174 | end if; | |
2175 | ||
2176 | Analyze (Actual); | |
70482933 RK |
2177 | |
2178 | -- Generate copy out if OUT or IN OUT parameter | |
2179 | ||
2180 | if Ekind (Formal) /= E_In_Parameter then | |
2181 | Lhs := Outcod; | |
ca4bff3a EB |
2182 | |
2183 | if With_Storage_Model then | |
2184 | Rhs := | |
2185 | Make_Explicit_Dereference (Loc, | |
2186 | Prefix => New_Occurrence_Of (Temp, Loc)); | |
2187 | else | |
2188 | Rhs := New_Occurrence_Of (Temp, Loc); | |
2189 | Set_Is_True_Constant (Temp, False); | |
2190 | end if; | |
70482933 RK |
2191 | |
2192 | -- Deal with conversion | |
2193 | ||
2194 | if Nkind (Lhs) = N_Type_Conversion then | |
2195 | Lhs := Expression (Lhs); | |
2196 | Rhs := Convert_To (Etype (Actual), Rhs); | |
2197 | end if; | |
2198 | ||
2199 | Append_To (Post_Call, | |
2200 | Make_Assignment_Statement (Loc, | |
2201 | Name => Lhs, | |
2202 | Expression => Rhs)); | |
ca4bff3a | 2203 | Set_Suppress_Assignment_Checks (Last (Post_Call)); |
f44fe430 | 2204 | Set_Assignment_OK (Name (Last (Post_Call))); |
70482933 | 2205 | end if; |
f44fe430 | 2206 | end Add_Simple_Call_By_Copy_Code; |
70482933 | 2207 | |
62e45e3e HK |
2208 | -------------------------------------- |
2209 | -- Add_Validation_Call_By_Copy_Code -- | |
2210 | -------------------------------------- | |
2211 | ||
2212 | procedure Add_Validation_Call_By_Copy_Code (Act : Node_Id) is | |
e75d06f9 EB |
2213 | Var : constant Node_Id := Unqual_Conv (Act); |
2214 | ||
62e45e3e HK |
2215 | Expr : Node_Id; |
2216 | Obj : Node_Id; | |
2217 | Obj_Typ : Entity_Id; | |
62e45e3e HK |
2218 | Var_Id : Entity_Id; |
2219 | ||
2220 | begin | |
13931a38 EB |
2221 | -- Generate range check if required |
2222 | ||
2223 | if Do_Range_Check (Actual) then | |
2224 | Generate_Range_Check (Actual, E_Formal, CE_Range_Check_Failed); | |
2225 | end if; | |
2226 | ||
2227 | -- If there is a type conversion in the actual, it will be reinstated | |
2228 | -- below, the new instance will be properly analyzed and the setting | |
2229 | -- of the Do_Range_Check flag recomputed so remove the obsolete one. | |
2230 | ||
2231 | if Nkind (Actual) = N_Type_Conversion then | |
2232 | Set_Do_Range_Check (Expression (Actual), False); | |
2233 | end if; | |
2234 | ||
62e45e3e HK |
2235 | -- Copy the value of the validation variable back into the object |
2236 | -- being validated. | |
2237 | ||
2238 | if Is_Entity_Name (Var) then | |
2239 | Var_Id := Entity (Var); | |
2240 | Obj := Validated_Object (Var_Id); | |
2241 | Obj_Typ := Etype (Obj); | |
2242 | ||
2243 | Expr := New_Occurrence_Of (Var_Id, Loc); | |
2244 | ||
2245 | -- A type conversion is needed when the validation variable and | |
2246 | -- the validated object carry different types. This case occurs | |
2247 | -- when the actual is qualified in some fashion. | |
2248 | ||
2249 | -- Common: | |
2250 | -- subtype Int is Integer range ...; | |
2251 | -- procedure Call (Val : in out Integer); | |
2252 | ||
2253 | -- Original: | |
2254 | -- Object : Int; | |
2255 | -- Call (Integer (Object)); | |
2256 | ||
2257 | -- Expanded: | |
2258 | -- Object : Int; | |
2259 | -- Var : Integer := Object; -- conversion to base type | |
2260 | -- if not Var'Valid then -- validity check | |
2261 | -- Call (Var); -- modify Var | |
2262 | -- Object := Int (Var); -- conversion to subtype | |
2263 | ||
2264 | if Etype (Var_Id) /= Obj_Typ then | |
2265 | Expr := | |
2266 | Make_Type_Conversion (Loc, | |
2267 | Subtype_Mark => New_Occurrence_Of (Obj_Typ, Loc), | |
2268 | Expression => Expr); | |
2269 | end if; | |
2270 | ||
2271 | -- Generate: | |
2272 | -- Object := Var; | |
2273 | -- <or> | |
2274 | -- Object := Object_Type (Var); | |
2275 | ||
2276 | Append_To (Post_Call, | |
2277 | Make_Assignment_Statement (Loc, | |
2278 | Name => Obj, | |
2279 | Expression => Expr)); | |
2280 | ||
2281 | -- If the flow reaches this point, then this routine was invoked with | |
2282 | -- an actual which does not denote a validation variable. | |
2283 | ||
2284 | else | |
2285 | pragma Assert (False); | |
2286 | null; | |
2287 | end if; | |
2288 | end Add_Validation_Call_By_Copy_Code; | |
2289 | ||
70482933 RK |
2290 | --------------------------- |
2291 | -- Check_Fortran_Logical -- | |
2292 | --------------------------- | |
2293 | ||
2294 | procedure Check_Fortran_Logical is | |
fbf5a39b | 2295 | Logical : constant Entity_Id := Etype (Formal); |
70482933 RK |
2296 | Var : Entity_Id; |
2297 | ||
2298 | -- Note: this is very incomplete, e.g. it does not handle arrays | |
2299 | -- of logical values. This is really not the right approach at all???) | |
2300 | ||
2301 | begin | |
2302 | if Convention (Subp) = Convention_Fortran | |
2303 | and then Root_Type (Etype (Formal)) = Standard_Boolean | |
2304 | and then Ekind (Formal) /= E_In_Parameter | |
2305 | then | |
2306 | Var := Make_Var (Actual); | |
2307 | Append_To (Post_Call, | |
2308 | Make_Assignment_Statement (Loc, | |
2309 | Name => New_Occurrence_Of (Var, Loc), | |
2310 | Expression => | |
2311 | Unchecked_Convert_To ( | |
2312 | Logical, | |
2313 | Make_Op_Ne (Loc, | |
2314 | Left_Opnd => New_Occurrence_Of (Var, Loc), | |
2315 | Right_Opnd => | |
2316 | Unchecked_Convert_To ( | |
2317 | Logical, | |
2318 | New_Occurrence_Of (Standard_False, Loc)))))); | |
2319 | end if; | |
2320 | end Check_Fortran_Logical; | |
2321 | ||
758c442c GD |
2322 | ------------------- |
2323 | -- Is_Legal_Copy -- | |
2324 | ------------------- | |
2325 | ||
2326 | function Is_Legal_Copy return Boolean is | |
2327 | begin | |
2328 | -- An attempt to copy a value of such a type can only occur if | |
2329 | -- representation clauses give the actual a misaligned address. | |
2330 | ||
5d66b937 EB |
2331 | if Is_By_Reference_Type (Etype (Formal)) |
2332 | or else Is_Aliased (Formal) | |
2333 | or else (Mechanism (Formal) = By_Reference | |
2334 | and then not Has_Foreign_Convention (Subp)) | |
2335 | then | |
f45ccc7c | 2336 | |
f8f50235 AC |
2337 | -- The actual may in fact be properly aligned but there is not |
2338 | -- enough front-end information to determine this. In that case | |
5d66b937 EB |
2339 | -- gigi will emit an error or a warning if a copy is not legal, |
2340 | -- or generate the proper code. | |
f45ccc7c | 2341 | |
758c442c GD |
2342 | return False; |
2343 | ||
2344 | -- For users of Starlet, we assume that the specification of by- | |
7888a6ae | 2345 | -- reference mechanism is mandatory. This may lead to unaligned |
758c442c GD |
2346 | -- objects but at least for DEC legacy code it is known to work. |
2347 | -- The warning will alert users of this code that a problem may | |
2348 | -- be lurking. | |
2349 | ||
2350 | elsif Mechanism (Formal) = By_Reference | |
5d66b937 | 2351 | and then Ekind (Scope (Formal)) = E_Procedure |
758c442c GD |
2352 | and then Is_Valued_Procedure (Scope (Formal)) |
2353 | then | |
2354 | Error_Msg_N | |
685bc70f | 2355 | ("by_reference actual may be misaligned??", Actual); |
758c442c GD |
2356 | return False; |
2357 | ||
2358 | else | |
2359 | return True; | |
2360 | end if; | |
2361 | end Is_Legal_Copy; | |
2362 | ||
70482933 RK |
2363 | -------------- |
2364 | -- Make_Var -- | |
2365 | -------------- | |
2366 | ||
2367 | function Make_Var (Actual : Node_Id) return Entity_Id is | |
2368 | Var : Entity_Id; | |
2369 | ||
2370 | begin | |
2371 | if Is_Entity_Name (Actual) then | |
2372 | return Entity (Actual); | |
2373 | ||
2374 | else | |
b086849e | 2375 | Var := Make_Temporary (Loc, 'T', Actual); |
70482933 RK |
2376 | |
2377 | N_Node := | |
2378 | Make_Object_Renaming_Declaration (Loc, | |
2379 | Defining_Identifier => Var, | |
2380 | Subtype_Mark => | |
2381 | New_Occurrence_Of (Etype (Actual), Loc), | |
2382 | Name => Relocate_Node (Actual)); | |
2383 | ||
2384 | Insert_Action (N, N_Node); | |
2385 | return Var; | |
2386 | end if; | |
2387 | end Make_Var; | |
2388 | ||
2389 | ------------------------- | |
2390 | -- Reset_Packed_Prefix -- | |
2391 | ------------------------- | |
2392 | ||
2393 | procedure Reset_Packed_Prefix is | |
2394 | Pfx : Node_Id := Actual; | |
70482933 RK |
2395 | begin |
2396 | loop | |
2397 | Set_Analyzed (Pfx, False); | |
ac4d6407 | 2398 | exit when |
4a08c95c | 2399 | Nkind (Pfx) not in N_Selected_Component | N_Indexed_Component; |
70482933 RK |
2400 | Pfx := Prefix (Pfx); |
2401 | end loop; | |
2402 | end Reset_Packed_Prefix; | |
2403 | ||
6a6ac079 EB |
2404 | ---------------------------------------- |
2405 | -- Requires_Atomic_Or_Volatile_Copy -- | |
2406 | ---------------------------------------- | |
2407 | ||
2408 | function Requires_Atomic_Or_Volatile_Copy return Boolean is | |
2409 | begin | |
2410 | -- If the formal is already passed by copy, no need to do anything | |
2411 | ||
2412 | if Is_By_Copy_Type (E_Formal) then | |
2413 | return False; | |
2414 | end if; | |
2415 | ||
ae6fec84 EB |
2416 | -- There is no requirement inside initialization procedures and this |
2417 | -- would generate copies for atomic or volatile composite components. | |
2418 | ||
2419 | if Inside_Init_Proc then | |
2420 | return False; | |
2421 | end if; | |
2422 | ||
6a6ac079 EB |
2423 | -- Check for atomicity mismatch |
2424 | ||
2425 | if Is_Atomic_Object (Actual) and then not Is_Atomic (E_Formal) | |
2426 | then | |
2427 | if Comes_From_Source (N) then | |
2428 | Error_Msg_N | |
2d6f6e08 | 2429 | ("??atomic actual passed by copy (RM C.6(19))", Actual); |
6a6ac079 EB |
2430 | end if; |
2431 | return True; | |
2432 | end if; | |
2433 | ||
2434 | -- Check for volatility mismatch | |
2435 | ||
76f9c7f4 | 2436 | if Is_Volatile_Object_Ref (Actual) and then not Is_Volatile (E_Formal) |
6a6ac079 EB |
2437 | then |
2438 | if Comes_From_Source (N) then | |
2439 | Error_Msg_N | |
2d6f6e08 | 2440 | ("??volatile actual passed by copy (RM C.6(19))", Actual); |
6a6ac079 EB |
2441 | end if; |
2442 | return True; | |
2443 | end if; | |
2444 | ||
2445 | return False; | |
2446 | end Requires_Atomic_Or_Volatile_Copy; | |
2447 | ||
70482933 RK |
2448 | -- Start of processing for Expand_Actuals |
2449 | ||
2450 | begin | |
70482933 RK |
2451 | Post_Call := New_List; |
2452 | ||
2f1b20a9 ES |
2453 | Formal := First_Formal (Subp); |
2454 | Actual := First_Actual (N); | |
70482933 RK |
2455 | while Present (Formal) loop |
2456 | E_Formal := Etype (Formal); | |
f6820c2d | 2457 | E_Actual := Etype (Actual); |
70482933 | 2458 | |
db99c46e AC |
2459 | -- Handle formals whose type comes from the limited view |
2460 | ||
2461 | if From_Limited_With (E_Formal) | |
2462 | and then Has_Non_Limited_View (E_Formal) | |
2463 | then | |
2464 | E_Formal := Non_Limited_View (E_Formal); | |
2465 | end if; | |
2466 | ||
70482933 RK |
2467 | if Is_Scalar_Type (E_Formal) |
2468 | or else Nkind (Actual) = N_Slice | |
2469 | then | |
2470 | Check_Fortran_Logical; | |
2471 | ||
2472 | -- RM 6.4.1 (11) | |
2473 | ||
2474 | elsif Ekind (Formal) /= E_Out_Parameter then | |
2475 | ||
2476 | -- The unusual case of the current instance of a protected type | |
2477 | -- requires special handling. This can only occur in the context | |
2478 | -- of a call within the body of a protected operation. | |
2479 | ||
2480 | if Is_Entity_Name (Actual) | |
2481 | and then Ekind (Entity (Actual)) = E_Protected_Type | |
2482 | and then In_Open_Scopes (Entity (Actual)) | |
2483 | then | |
2484 | if Scope (Subp) /= Entity (Actual) then | |
685bc70f AC |
2485 | Error_Msg_N |
2486 | ("operation outside protected type may not " | |
2487 | & "call back its protected operations??", Actual); | |
70482933 RK |
2488 | end if; |
2489 | ||
2490 | Rewrite (Actual, | |
2491 | Expand_Protected_Object_Reference (N, Entity (Actual))); | |
2492 | end if; | |
2493 | ||
02822a92 RD |
2494 | -- Ada 2005 (AI-318-02): If the actual parameter is a call to a |
2495 | -- build-in-place function, then a temporary return object needs | |
82af7291 JM |
2496 | -- to be created and access to it must be passed to the function |
2497 | -- (and ensure that we have an activation chain defined for tasks | |
2498 | -- and a Master variable). | |
2499 | ||
f937473f RD |
2500 | -- Currently we limit such functions to those with inherently |
2501 | -- limited result subtypes, but eventually we plan to expand the | |
2502 | -- functions that are treated as build-in-place to include other | |
2503 | -- composite result types. | |
02822a92 | 2504 | |
f5b65fab EB |
2505 | -- But do not do it here for intrinsic subprograms since this will |
2506 | -- be done properly after the subprogram is expanded. | |
2507 | ||
2508 | if Is_Intrinsic_Subprogram (Subp) then | |
2509 | null; | |
2510 | ||
2511 | elsif Is_Build_In_Place_Function_Call (Actual) then | |
74e514af ES |
2512 | if Might_Have_Tasks (Etype (Actual)) then |
2513 | Build_Activation_Chain_Entity (N); | |
2514 | Build_Master_Entity (Etype (Actual)); | |
2515 | end if; | |
2516 | ||
02822a92 | 2517 | Make_Build_In_Place_Call_In_Anonymous_Context (Actual); |
4ac62786 AC |
2518 | |
2519 | -- Ada 2005 (AI-318-02): Specialization of the previous case for | |
2520 | -- actuals containing build-in-place function calls whose returned | |
2521 | -- object covers interface types. | |
2522 | ||
2523 | elsif Present (Unqual_BIP_Iface_Function_Call (Actual)) then | |
82af7291 JM |
2524 | Build_Activation_Chain_Entity (N); |
2525 | Build_Master_Entity (Etype (Actual)); | |
4ac62786 | 2526 | Make_Build_In_Place_Iface_Call_In_Anonymous_Context (Actual); |
02822a92 RD |
2527 | end if; |
2528 | ||
70482933 RK |
2529 | Apply_Constraint_Check (Actual, E_Formal); |
2530 | ||
2531 | -- Out parameter case. No constraint checks on access type | |
68e4cc98 ES |
2532 | -- RM 6.4.1 (13), but on return a null-excluding check may be |
2533 | -- required (see below). | |
70482933 RK |
2534 | |
2535 | elsif Is_Access_Type (E_Formal) then | |
2536 | null; | |
2537 | ||
2538 | -- RM 6.4.1 (14) | |
2539 | ||
2540 | elsif Has_Discriminants (Base_Type (E_Formal)) | |
2541 | or else Has_Non_Null_Base_Init_Proc (E_Formal) | |
2542 | then | |
2543 | Apply_Constraint_Check (Actual, E_Formal); | |
2544 | ||
2545 | -- RM 6.4.1 (15) | |
2546 | ||
2547 | else | |
2548 | Apply_Constraint_Check (Actual, Base_Type (E_Formal)); | |
2549 | end if; | |
2550 | ||
2551 | -- Processing for IN-OUT and OUT parameters | |
2552 | ||
2553 | if Ekind (Formal) /= E_In_Parameter then | |
2554 | ||
2555 | -- For type conversions of arrays, apply length/range checks | |
2556 | ||
2557 | if Is_Array_Type (E_Formal) | |
2558 | and then Nkind (Actual) = N_Type_Conversion | |
2559 | then | |
2560 | if Is_Constrained (E_Formal) then | |
2561 | Apply_Length_Check (Expression (Actual), E_Formal); | |
2562 | else | |
2563 | Apply_Range_Check (Expression (Actual), E_Formal); | |
2564 | end if; | |
2565 | end if; | |
2566 | ||
62e45e3e HK |
2567 | -- If argument is a type conversion for a type that is passed by |
2568 | -- copy, then we must pass the parameter by copy. | |
2569 | ||
e75d06f9 | 2570 | if Nkind (Actual) = N_Type_Conversion |
70482933 | 2571 | and then |
2e2e6cf1 | 2572 | (Is_Elementary_Type (E_Formal) |
70482933 RK |
2573 | or else Is_Bit_Packed_Array (Etype (Formal)) |
2574 | or else Is_Bit_Packed_Array (Etype (Expression (Actual))) | |
2575 | ||
2576 | -- Also pass by copy if change of representation | |
2577 | ||
3968b02a | 2578 | or else not Has_Compatible_Representation |
e2f7d58c EB |
2579 | (Target_Typ => Etype (Formal), |
2580 | Operand_Typ => Etype (Expression (Actual)))) | |
70482933 RK |
2581 | then |
2582 | Add_Call_By_Copy_Code; | |
2583 | ||
607114db | 2584 | -- References to components of bit-packed arrays are expanded |
70482933 RK |
2585 | -- at this point, rather than at the point of analysis of the |
2586 | -- actuals, to handle the expansion of the assignment to | |
2587 | -- [in] out parameters. | |
2588 | ||
2589 | elsif Is_Ref_To_Bit_Packed_Array (Actual) then | |
f5b65fab | 2590 | Add_Simple_Call_By_Copy_Code (Force => True); |
f44fe430 | 2591 | |
ca4bff3a EB |
2592 | -- If the actual has a nonnative storage model, we need a copy |
2593 | ||
2594 | elsif Nkind (Actual) = N_Explicit_Dereference | |
2595 | and then | |
2596 | Has_Designated_Storage_Model_Aspect (Etype (Prefix (Actual))) | |
2597 | and then | |
2598 | (Present (Storage_Model_Copy_To | |
2599 | (Storage_Model_Object (Etype (Prefix (Actual))))) | |
2600 | or else | |
2601 | (Ekind (Formal) = E_In_Out_Parameter | |
2602 | and then | |
8f563162 AC |
2603 | Present (Storage_Model_Copy_From |
2604 | (Storage_Model_Object (Etype (Prefix (Actual))))))) | |
ca4bff3a EB |
2605 | then |
2606 | Add_Simple_Call_By_Copy_Code (Force => True); | |
2607 | ||
00907026 | 2608 | -- If a nonscalar actual is possibly bit-aligned, we need a copy |
02822a92 RD |
2609 | -- because the back-end cannot cope with such objects. In other |
2610 | -- cases where alignment forces a copy, the back-end generates | |
2611 | -- it properly. It should not be generated unconditionally in the | |
2612 | -- front-end because it does not know precisely the alignment | |
2613 | -- requirements of the target, and makes too conservative an | |
2614 | -- estimate, leading to superfluous copies or spurious errors | |
2615 | -- on by-reference parameters. | |
f44fe430 | 2616 | |
02822a92 RD |
2617 | elsif Nkind (Actual) = N_Selected_Component |
2618 | and then | |
2619 | Component_May_Be_Bit_Aligned (Entity (Selector_Name (Actual))) | |
f44fe430 RD |
2620 | and then not Represented_As_Scalar (Etype (Formal)) |
2621 | then | |
f5b65fab | 2622 | Add_Simple_Call_By_Copy_Code (Force => False); |
70482933 | 2623 | |
607114db | 2624 | -- References to slices of bit-packed arrays are expanded |
70482933 RK |
2625 | |
2626 | elsif Is_Ref_To_Bit_Packed_Slice (Actual) then | |
2627 | Add_Call_By_Copy_Code; | |
2628 | ||
fbf5a39b AC |
2629 | -- References to possibly unaligned slices of arrays are expanded |
2630 | ||
2631 | elsif Is_Possibly_Unaligned_Slice (Actual) then | |
2632 | Add_Call_By_Copy_Code; | |
2633 | ||
7888a6ae | 2634 | -- Deal with access types where the actual subtype and the |
70482933 RK |
2635 | -- formal subtype are not the same, requiring a check. |
2636 | ||
638e383e | 2637 | -- It is necessary to exclude tagged types because of "downward |
68e4cc98 ES |
2638 | -- conversion" errors, but null-excluding checks on return may be |
2639 | -- required. | |
70482933 RK |
2640 | |
2641 | elsif Is_Access_Type (E_Formal) | |
70482933 | 2642 | and then not Is_Tagged_Type (Designated_Type (E_Formal)) |
68e4cc98 ES |
2643 | and then (not Same_Type (E_Formal, E_Actual) |
2644 | or else (Can_Never_Be_Null (E_Actual) | |
2645 | and then not Can_Never_Be_Null (E_Formal))) | |
70482933 RK |
2646 | then |
2647 | Add_Call_By_Copy_Code; | |
2648 | ||
6a6ac079 EB |
2649 | -- We may need to force a copy because of atomicity or volatility |
2650 | -- considerations. | |
70482933 | 2651 | |
6a6ac079 | 2652 | elsif Requires_Atomic_Or_Volatile_Copy then |
70482933 | 2653 | Add_Call_By_Copy_Code; |
d79e621a GD |
2654 | |
2655 | -- Add call-by-copy code for the case of scalar out parameters | |
2656 | -- when it is not known at compile time that the subtype of the | |
c2369146 AC |
2657 | -- formal is a subrange of the subtype of the actual (or vice |
2658 | -- versa for in out parameters), in order to get range checks | |
2659 | -- on such actuals. (Maybe this case should be handled earlier | |
2660 | -- in the if statement???) | |
d79e621a GD |
2661 | |
2662 | elsif Is_Scalar_Type (E_Formal) | |
c2369146 | 2663 | and then |
f6820c2d | 2664 | (not In_Subrange_Of (E_Formal, E_Actual) |
c2369146 AC |
2665 | or else |
2666 | (Ekind (Formal) = E_In_Out_Parameter | |
f6820c2d | 2667 | and then not In_Subrange_Of (E_Actual, E_Formal))) |
d79e621a | 2668 | then |
d79e621a | 2669 | Add_Call_By_Copy_Code; |
e75d06f9 EB |
2670 | |
2671 | -- The actual denotes a variable which captures the value of an | |
2672 | -- object for validation purposes. Add a copy-back to reflect any | |
2673 | -- potential changes in value back into the original object. | |
2674 | ||
2675 | -- Var : ... := Object; | |
2676 | -- if not Var'Valid then -- validity check | |
2677 | -- Call (Var); -- modify var | |
2678 | -- Object := Var; -- update Object | |
2679 | ||
2680 | elsif Is_Validation_Variable_Reference (Actual) then | |
2681 | Add_Validation_Call_By_Copy_Code (Actual); | |
70482933 RK |
2682 | end if; |
2683 | ||
5f6fb720 | 2684 | -- RM 3.2.4 (23/3): A predicate is checked on in-out and out |
f6820c2d AC |
2685 | -- by-reference parameters on exit from the call. If the actual |
2686 | -- is a derived type and the operation is inherited, the body | |
2687 | -- of the operation will not contain a call to the predicate | |
2688 | -- function, so it must be done explicitly after the call. Ditto | |
2689 | -- if the actual is an entity of a predicated subtype. | |
2690 | ||
cae64f11 AC |
2691 | -- The rule refers to by-reference types, but a check is needed |
2692 | -- for by-copy types as well. That check is subsumed by the rule | |
2693 | -- for subtype conversion on assignment, but we can generate the | |
2694 | -- required check now. | |
2695 | ||
dd4e47ab | 2696 | -- Note also that Subp may be either a subprogram entity for |
e93f4e12 AC |
2697 | -- direct calls, or a type entity for indirect calls, which must |
2698 | -- be handled separately because the name does not denote an | |
2699 | -- overloadable entity. | |
dd4e47ab | 2700 | |
2ac4a591 | 2701 | By_Ref_Predicate_Check : declare |
5f6fb720 AC |
2702 | Aund : constant Entity_Id := Underlying_Type (E_Actual); |
2703 | Atyp : Entity_Id; | |
2704 | ||
2705 | begin | |
2706 | if No (Aund) then | |
2707 | Atyp := E_Actual; | |
2708 | else | |
2709 | Atyp := Aund; | |
2710 | end if; | |
2711 | ||
152f64c2 | 2712 | if Predicate_Enabled (Atyp) |
5f6fb720 AC |
2713 | |
2714 | -- Skip predicate checks for special cases | |
2715 | ||
b8e6830b | 2716 | and then Predicate_Tests_On_Arguments (Subp) |
5f6fb720 AC |
2717 | then |
2718 | Append_To (Post_Call, | |
2719 | Make_Predicate_Check (Atyp, Actual)); | |
2720 | end if; | |
2ac4a591 | 2721 | end By_Ref_Predicate_Check; |
f6820c2d | 2722 | |
fbf5a39b | 2723 | -- Processing for IN parameters |
70482933 RK |
2724 | |
2725 | else | |
13931a38 EB |
2726 | -- Generate range check if required |
2727 | ||
2728 | if Do_Range_Check (Actual) then | |
2729 | Generate_Range_Check (Actual, E_Formal, CE_Range_Check_Failed); | |
2730 | end if; | |
2731 | ||
607114db | 2732 | -- For IN parameters in the bit-packed array case, we expand an |
fbf5a39b AC |
2733 | -- indexed component (the circuit in Exp_Ch4 deliberately left |
2734 | -- indexed components appearing as actuals untouched, so that | |
2735 | -- the special processing above for the OUT and IN OUT cases | |
2736 | -- could be performed. We could make the test in Exp_Ch4 more | |
2737 | -- complex and have it detect the parameter mode, but it is | |
f44fe430 | 2738 | -- easier simply to handle all cases here.) |
fbf5a39b | 2739 | |
70482933 | 2740 | if Nkind (Actual) = N_Indexed_Component |
b3f75672 | 2741 | and then Is_Bit_Packed_Array (Etype (Prefix (Actual))) |
70482933 RK |
2742 | then |
2743 | Reset_Packed_Prefix; | |
2744 | Expand_Packed_Element_Reference (Actual); | |
2745 | ||
607114db | 2746 | -- If we have a reference to a bit-packed array, we copy it, since |
0386aad1 | 2747 | -- the actual must be byte aligned. |
70482933 | 2748 | |
fbf5a39b | 2749 | -- Is this really necessary in all cases??? |
70482933 | 2750 | |
fbf5a39b | 2751 | elsif Is_Ref_To_Bit_Packed_Array (Actual) then |
f5b65fab EB |
2752 | Add_Simple_Call_By_Copy_Code (Force => True); |
2753 | ||
ca4bff3a EB |
2754 | -- If the actual has a nonnative storage model, we need a copy |
2755 | ||
2756 | elsif Nkind (Actual) = N_Explicit_Dereference | |
2757 | and then | |
2758 | Has_Designated_Storage_Model_Aspect (Etype (Prefix (Actual))) | |
2759 | and then | |
2760 | Present (Storage_Model_Copy_From | |
2761 | (Storage_Model_Object (Etype (Prefix (Actual))))) | |
2762 | then | |
2763 | Add_Simple_Call_By_Copy_Code (Force => True); | |
2764 | ||
f5b65fab EB |
2765 | -- If we have a C++ constructor call, we need to create the object |
2766 | ||
2767 | elsif Is_CPP_Constructor_Call (Actual) then | |
2768 | Add_Simple_Call_By_Copy_Code (Force => True); | |
f44fe430 | 2769 | |
00907026 | 2770 | -- If a nonscalar actual is possibly unaligned, we need a copy |
f44fe430 RD |
2771 | |
2772 | elsif Is_Possibly_Unaligned_Object (Actual) | |
2773 | and then not Represented_As_Scalar (Etype (Formal)) | |
2774 | then | |
f5b65fab | 2775 | Add_Simple_Call_By_Copy_Code (Force => False); |
70482933 | 2776 | |
fbf5a39b AC |
2777 | -- Similarly, we have to expand slices of packed arrays here |
2778 | -- because the result must be byte aligned. | |
70482933 | 2779 | |
fbf5a39b AC |
2780 | elsif Is_Ref_To_Bit_Packed_Slice (Actual) then |
2781 | Add_Call_By_Copy_Code; | |
70482933 | 2782 | |
fbf5a39b AC |
2783 | -- Only processing remaining is to pass by copy if this is a |
2784 | -- reference to a possibly unaligned slice, since the caller | |
2785 | -- expects an appropriately aligned argument. | |
70482933 | 2786 | |
fbf5a39b AC |
2787 | elsif Is_Possibly_Unaligned_Slice (Actual) then |
2788 | Add_Call_By_Copy_Code; | |
fb468a94 | 2789 | |
6a6ac079 EB |
2790 | -- We may need to force a copy because of atomicity or volatility |
2791 | -- considerations. | |
2792 | ||
2793 | elsif Requires_Atomic_Or_Volatile_Copy then | |
2794 | Add_Call_By_Copy_Code; | |
2795 | ||
fb468a94 AC |
2796 | -- An unusual case: a current instance of an enclosing task can be |
2797 | -- an actual, and must be replaced by a reference to self. | |
2798 | ||
2799 | elsif Is_Entity_Name (Actual) | |
2800 | and then Is_Task_Type (Entity (Actual)) | |
2801 | then | |
2802 | if In_Open_Scopes (Entity (Actual)) then | |
2803 | Rewrite (Actual, | |
2804 | (Make_Function_Call (Loc, | |
da574a86 | 2805 | Name => New_Occurrence_Of (RTE (RE_Self), Loc)))); |
fb468a94 AC |
2806 | Analyze (Actual); |
2807 | ||
2808 | -- A task type cannot otherwise appear as an actual | |
2809 | ||
2810 | else | |
2811 | raise Program_Error; | |
2812 | end if; | |
70482933 RK |
2813 | end if; |
2814 | end if; | |
2815 | ||
58e07eaa GD |
2816 | -- Type-invariant checks for in-out and out parameters, as well as |
2817 | -- for in parameters of procedures (AI05-0289 and AI12-0044). | |
2818 | ||
2819 | if Ekind (Formal) /= E_In_Parameter | |
2820 | or else Ekind (Subp) = E_Procedure | |
2821 | then | |
2822 | Caller_Side_Invariant_Checks : declare | |
2823 | ||
2824 | function Is_Public_Subp return Boolean; | |
2825 | -- Check whether the subprogram being called is a visible | |
2826 | -- operation of the type of the actual. Used to determine | |
2827 | -- whether an invariant check must be generated on the | |
2828 | -- caller side. | |
2829 | ||
2830 | --------------------- | |
2831 | -- Is_Public_Subp -- | |
2832 | --------------------- | |
2833 | ||
2834 | function Is_Public_Subp return Boolean is | |
2835 | Pack : constant Entity_Id := Scope (Subp); | |
2836 | Subp_Decl : Node_Id; | |
2837 | ||
2838 | begin | |
2839 | if not Is_Subprogram (Subp) then | |
2840 | return False; | |
2841 | ||
2842 | -- The operation may be inherited, or a primitive of the | |
2843 | -- root type. | |
2844 | ||
2845 | elsif | |
4a08c95c AC |
2846 | Nkind (Parent (Subp)) in N_Private_Extension_Declaration |
2847 | | N_Full_Type_Declaration | |
58e07eaa GD |
2848 | then |
2849 | Subp_Decl := Parent (Subp); | |
2850 | ||
2851 | else | |
2852 | Subp_Decl := Unit_Declaration_Node (Subp); | |
2853 | end if; | |
2854 | ||
2855 | return Ekind (Pack) = E_Package | |
2856 | and then | |
2857 | List_Containing (Subp_Decl) = | |
2858 | Visible_Declarations | |
2859 | (Specification (Unit_Declaration_Node (Pack))); | |
2860 | end Is_Public_Subp; | |
2861 | ||
2862 | -- Start of processing for Caller_Side_Invariant_Checks | |
2863 | ||
2864 | begin | |
2865 | -- We generate caller-side invariant checks in two cases: | |
2866 | ||
2867 | -- a) when calling an inherited operation, where there is an | |
2868 | -- implicit view conversion of the actual to the parent type. | |
2869 | ||
2870 | -- b) When the conversion is explicit | |
2871 | ||
2872 | -- We treat these cases separately because the required | |
2873 | -- conversion for a) is added later when expanding the call. | |
2874 | ||
2875 | if Has_Invariants (Etype (Actual)) | |
2876 | and then | |
2877 | Nkind (Parent (Etype (Actual))) | |
2878 | = N_Private_Extension_Declaration | |
2879 | then | |
2880 | if Comes_From_Source (N) and then Is_Public_Subp then | |
2881 | Append_To (Post_Call, Make_Invariant_Call (Actual)); | |
2882 | end if; | |
2883 | ||
2884 | elsif Nkind (Actual) = N_Type_Conversion | |
2885 | and then Has_Invariants (Etype (Expression (Actual))) | |
2886 | then | |
2887 | if Comes_From_Source (N) and then Is_Public_Subp then | |
2888 | Append_To | |
2889 | (Post_Call, Make_Invariant_Call (Expression (Actual))); | |
2890 | end if; | |
2891 | end if; | |
2892 | end Caller_Side_Invariant_Checks; | |
2893 | end if; | |
2894 | ||
70482933 RK |
2895 | Next_Formal (Formal); |
2896 | Next_Actual (Actual); | |
2897 | end loop; | |
70482933 RK |
2898 | end Expand_Actuals; |
2899 | ||
2900 | ----------------- | |
2901 | -- Expand_Call -- | |
2902 | ----------------- | |
2903 | ||
ca1f6b29 | 2904 | procedure Expand_Call (N : Node_Id) is |
37449332 EB |
2905 | function Is_Unchecked_Union_Equality (N : Node_Id) return Boolean; |
2906 | -- Return True if N is a call to the predefined equality operator of an | |
2907 | -- unchecked union type, or a renaming thereof. | |
2908 | ||
2909 | --------------------------------- | |
2910 | -- Is_Unchecked_Union_Equality -- | |
2911 | --------------------------------- | |
2912 | ||
2913 | function Is_Unchecked_Union_Equality (N : Node_Id) return Boolean is | |
2914 | begin | |
2915 | if Is_Entity_Name (Name (N)) | |
2916 | and then Ekind (Entity (Name (N))) = E_Function | |
2917 | and then Present (First_Formal (Entity (Name (N)))) | |
2918 | and then | |
2919 | Is_Unchecked_Union (Etype (First_Formal (Entity (Name (N))))) | |
2920 | then | |
2921 | declare | |
2922 | Func : constant Entity_Id := Entity (Name (N)); | |
2923 | Typ : constant Entity_Id := Etype (First_Formal (Func)); | |
2924 | Decl : constant Node_Id := | |
2925 | Original_Node (Parent (Declaration_Node (Func))); | |
2926 | ||
2927 | begin | |
2928 | return Func = TSS (Typ, TSS_Composite_Equality) | |
2929 | or else (Nkind (Decl) = N_Subprogram_Renaming_Declaration | |
2930 | and then Nkind (Name (Decl)) = N_Operator_Symbol | |
2931 | and then Chars (Name (Decl)) = Name_Op_Eq | |
2932 | and then Ekind (Entity (Name (Decl))) = E_Operator); | |
2933 | end; | |
2934 | ||
2935 | else | |
2936 | return False; | |
2937 | end if; | |
2938 | end Is_Unchecked_Union_Equality; | |
3fc40cd7 | 2939 | |
dc419b9f ES |
2940 | -- If this is an indirect call through an Access_To_Subprogram |
2941 | -- with contract specifications, it is rewritten as a call to | |
2942 | -- the corresponding Access_Subprogram_Wrapper with the same | |
2943 | -- actuals, whose body contains a naked indirect call (which | |
2944 | -- itself must not be rewritten, to prevent infinite recursion). | |
2945 | ||
2946 | Must_Rewrite_Indirect_Call : constant Boolean := | |
81e68a19 | 2947 | Ada_Version >= Ada_2022 |
dc419b9f ES |
2948 | and then Nkind (Name (N)) = N_Explicit_Dereference |
2949 | and then Ekind (Etype (Name (N))) = E_Subprogram_Type | |
2950 | and then Present | |
2951 | (Access_Subprogram_Wrapper (Etype (Name (N)))); | |
2952 | ||
37449332 EB |
2953 | Post_Call : List_Id; |
2954 | ||
2955 | -- Start of processing for Expand_Call | |
2956 | ||
ca1f6b29 | 2957 | begin |
4a08c95c AC |
2958 | pragma Assert (Nkind (N) in N_Entry_Call_Statement |
2959 | | N_Function_Call | |
2960 | | N_Procedure_Call_Statement); | |
3fc40cd7 | 2961 | |
a968d80d JS |
2962 | -- Check that this is not the call in the body of the access |
2963 | -- subprogram wrapper or the postconditions wrapper. | |
dc419b9f ES |
2964 | |
2965 | if Must_Rewrite_Indirect_Call | |
2966 | and then (not Is_Overloadable (Current_Scope) | |
a968d80d JS |
2967 | or else not (Is_Access_Subprogram_Wrapper (Current_Scope) |
2968 | or else | |
2969 | (Chars (Current_Scope) = Name_uWrapped_Statements | |
2970 | and then Is_Access_Subprogram_Wrapper | |
2971 | (Scope (Current_Scope))))) | |
dc419b9f ES |
2972 | then |
2973 | declare | |
23a9215f PT |
2974 | Loc : constant Source_Ptr := Sloc (N); |
2975 | Wrapper : constant Entity_Id := | |
dc419b9f ES |
2976 | Access_Subprogram_Wrapper (Etype (Name (N))); |
2977 | Ptr : constant Node_Id := Prefix (Name (N)); | |
2978 | Ptr_Type : constant Entity_Id := Etype (Ptr); | |
dc419b9f | 2979 | Typ : constant Entity_Id := Etype (N); |
7d3a9f39 | 2980 | |
dc419b9f | 2981 | New_N : Node_Id; |
23a9215f | 2982 | Parms : List_Id := Parameter_Associations (N); |
9b501e59 | 2983 | Ptr_Act : Node_Id; |
dc419b9f ES |
2984 | |
2985 | begin | |
2986 | -- The last actual in the call is the pointer itself. | |
2987 | -- If the aspect is inherited, convert the pointer to the | |
2988 | -- parent type that specifies the contract. | |
9b501e59 ES |
2989 | -- If the original access_to_subprogram has defaults for |
2990 | -- in_parameters, the call may include named associations, so | |
2991 | -- we create one for the pointer as well. | |
dc419b9f ES |
2992 | |
2993 | if Is_Derived_Type (Ptr_Type) | |
2994 | and then Ptr_Type /= Etype (Last_Formal (Wrapper)) | |
2995 | then | |
9b501e59 ES |
2996 | Ptr_Act := |
2997 | Make_Type_Conversion (Loc, | |
2998 | New_Occurrence_Of | |
2999 | (Etype (Last_Formal (Wrapper)), Loc), Ptr); | |
dc419b9f ES |
3000 | |
3001 | else | |
9b501e59 | 3002 | Ptr_Act := Ptr; |
dc419b9f ES |
3003 | end if; |
3004 | ||
7d3a9f39 ES |
3005 | -- Handle parameterless subprogram. |
3006 | ||
3007 | if No (Parms) then | |
3008 | Parms := New_List; | |
3009 | end if; | |
3010 | ||
9b501e59 ES |
3011 | Append |
3012 | (Make_Parameter_Association (Loc, | |
3013 | Selector_Name => Make_Identifier (Loc, | |
3014 | Chars (Last_Formal (Wrapper))), | |
3015 | Explicit_Actual_Parameter => Ptr_Act), | |
3016 | Parms); | |
3017 | ||
dc419b9f ES |
3018 | if Nkind (N) = N_Procedure_Call_Statement then |
3019 | New_N := Make_Procedure_Call_Statement (Loc, | |
23a9215f | 3020 | Name => New_Occurrence_Of (Wrapper, Loc), |
dc419b9f ES |
3021 | Parameter_Associations => Parms); |
3022 | else | |
3023 | New_N := Make_Function_Call (Loc, | |
3024 | Name => New_Occurrence_Of (Wrapper, Loc), | |
3025 | Parameter_Associations => Parms); | |
3026 | end if; | |
3027 | ||
3028 | Rewrite (N, New_N); | |
3029 | Analyze_And_Resolve (N, Typ); | |
3030 | end; | |
3031 | ||
37449332 EB |
3032 | -- Case of a call to the predefined equality operator of an unchecked |
3033 | -- union type, which requires specific processing. | |
3034 | ||
3035 | elsif Is_Unchecked_Union_Equality (N) then | |
3036 | declare | |
2e80be63 | 3037 | Eq : constant Entity_Id := Entity (Name (N)); |
37449332 EB |
3038 | |
3039 | begin | |
2e80be63 | 3040 | Expand_Unchecked_Union_Equality (N); |
37449332 EB |
3041 | |
3042 | -- If the call was not rewritten as a raise, expand the actuals | |
3043 | ||
3044 | if Nkind (N) = N_Function_Call then | |
3045 | pragma Assert (Check_Number_Of_Actuals (N, Eq)); | |
3046 | Expand_Actuals (N, Eq, Post_Call); | |
3047 | pragma Assert (Is_Empty_List (Post_Call)); | |
3048 | end if; | |
3049 | end; | |
3050 | ||
3051 | -- Normal case | |
3052 | ||
dc419b9f ES |
3053 | else |
3054 | Expand_Call_Helper (N, Post_Call); | |
3055 | Insert_Post_Call_Actions (N, Post_Call); | |
3056 | end if; | |
ca1f6b29 BD |
3057 | end Expand_Call; |
3058 | ||
3059 | ------------------------ | |
3060 | -- Expand_Call_Helper -- | |
3061 | ------------------------ | |
3062 | ||
70482933 RK |
3063 | -- This procedure handles expansion of function calls and procedure call |
3064 | -- statements (i.e. it serves as the body for Expand_N_Function_Call and | |
70f91180 | 3065 | -- Expand_N_Procedure_Call_Statement). Processing for calls includes: |
70482933 | 3066 | |
70f91180 | 3067 | -- Replace call to Raise_Exception by Raise_Exception_Always if possible |
70482933 RK |
3068 | -- Provide values of actuals for all formals in Extra_Formals list |
3069 | -- Replace "call" to enumeration literal function by literal itself | |
3070 | -- Rewrite call to predefined operator as operator | |
3071 | -- Replace actuals to in-out parameters that are numeric conversions, | |
3072 | -- with explicit assignment to temporaries before and after the call. | |
70482933 RK |
3073 | |
3074 | -- Note that the list of actuals has been filled with default expressions | |
3075 | -- during semantic analysis of the call. Only the extra actuals required | |
3076 | -- for the 'Constrained attribute and for accessibility checks are added | |
3077 | -- at this point. | |
3078 | ||
ca1f6b29 | 3079 | procedure Expand_Call_Helper (N : Node_Id; Post_Call : out List_Id) is |
70482933 | 3080 | Loc : constant Source_Ptr := Sloc (N); |
6dfc5592 | 3081 | Call_Node : Node_Id := N; |
70482933 | 3082 | Extra_Actuals : List_Id := No_List; |
fdce4bb7 | 3083 | Prev : Node_Id := Empty; |
758c442c | 3084 | |
70482933 RK |
3085 | procedure Add_Actual_Parameter (Insert_Param : Node_Id); |
3086 | -- Adds one entry to the end of the actual parameter list. Used for | |
2f1b20a9 ES |
3087 | -- default parameters and for extra actuals (for Extra_Formals). The |
3088 | -- argument is an N_Parameter_Association node. | |
70482933 | 3089 | |
d7e20130 JS |
3090 | procedure Add_Cond_Expression_Extra_Actual (Formal : Entity_Id); |
3091 | -- Adds extra accessibility actuals in the case of a conditional | |
3092 | -- expression corresponding to Formal. | |
3093 | ||
3094 | -- Note: Conditional expressions used as actuals for anonymous access | |
3095 | -- formals complicate the process of propagating extra accessibility | |
3096 | -- actuals and must be handled in a recursive fashion since they can | |
3097 | -- be embedded within each other. | |
3098 | ||
358e289d JM |
3099 | procedure Add_Dummy_Build_In_Place_Actuals |
3100 | (Function_Id : Entity_Id; | |
3101 | Num_Added_Extra_Actuals : Nat := 0); | |
3102 | -- Adds dummy actuals for the BIP extra formals of the called function. | |
3103 | -- Num_Added_Extra_Actuals is the number of non-BIP extra actuals added | |
3104 | -- to the actuals immediately before calling this subprogram. | |
3105 | ||
70482933 | 3106 | procedure Add_Extra_Actual (Expr : Node_Id; EF : Entity_Id); |
2f1b20a9 ES |
3107 | -- Adds an extra actual to the list of extra actuals. Expr is the |
3108 | -- expression for the value of the actual, EF is the entity for the | |
3109 | -- extra formal. | |
70482933 | 3110 | |
5f325af2 AC |
3111 | procedure Add_View_Conversion_Invariants |
3112 | (Formal : Entity_Id; | |
3113 | Actual : Node_Id); | |
10c2c151 AC |
3114 | -- Adds invariant checks for every intermediate type between the range |
3115 | -- of a view converted argument to its ancestor (from parent to child). | |
84e13614 | 3116 | |
a081ded4 ES |
3117 | function Can_Fold_Predicate_Call (P : Entity_Id) return Boolean; |
3118 | -- Try to constant-fold a predicate check, which often enough is a | |
3119 | -- simple arithmetic expression that can be computed statically if | |
3120 | -- its argument is static. This cleans up the output of CCG, even | |
3121 | -- though useless predicate checks will be generally removed by | |
3122 | -- back-end optimizations. | |
3123 | ||
afa1ffd4 PT |
3124 | procedure Check_Subprogram_Variant; |
3125 | -- Emit a call to the internally generated procedure with checks for | |
41a7b948 | 3126 | -- aspect Subprogram_Variant, if present and enabled. |
afa1ffd4 | 3127 | |
70482933 | 3128 | function Inherited_From_Formal (S : Entity_Id) return Entity_Id; |
1fb63e89 | 3129 | -- Within an instance, a type derived from an untagged formal derived |
70f91180 RD |
3130 | -- type inherits from the original parent, not from the actual. The |
3131 | -- current derivation mechanism has the derived type inherit from the | |
3132 | -- actual, which is only correct outside of the instance. If the | |
3133 | -- subprogram is inherited, we test for this particular case through a | |
3134 | -- convoluted tree traversal before setting the proper subprogram to be | |
3135 | -- called. | |
70482933 | 3136 | |
84f4072a JM |
3137 | function In_Unfrozen_Instance (E : Entity_Id) return Boolean; |
3138 | -- Return true if E comes from an instance that is not yet frozen | |
3139 | ||
5a644684 JM |
3140 | function Is_Class_Wide_Interface_Type (E : Entity_Id) return Boolean; |
3141 | -- Return True when E is a class-wide interface type or an access to | |
3142 | -- a class-wide interface type. | |
3143 | ||
df3e68b1 | 3144 | function Is_Direct_Deep_Call (Subp : Entity_Id) return Boolean; |
2c1b72d7 | 3145 | -- Determine if Subp denotes a non-dispatching call to a Deep routine |
df3e68b1 | 3146 | |
dd386db0 AC |
3147 | function New_Value (From : Node_Id) return Node_Id; |
3148 | -- From is the original Expression. New_Value is equivalent to a call | |
3149 | -- to Duplicate_Subexpr with an explicit dereference when From is an | |
3150 | -- access parameter. | |
3151 | ||
70482933 RK |
3152 | -------------------------- |
3153 | -- Add_Actual_Parameter -- | |
3154 | -------------------------- | |
3155 | ||
3156 | procedure Add_Actual_Parameter (Insert_Param : Node_Id) is | |
3157 | Actual_Expr : constant Node_Id := | |
3158 | Explicit_Actual_Parameter (Insert_Param); | |
3159 | ||
3160 | begin | |
3161 | -- Case of insertion is first named actual | |
3162 | ||
3163 | if No (Prev) or else | |
3164 | Nkind (Parent (Prev)) /= N_Parameter_Association | |
3165 | then | |
6dfc5592 RD |
3166 | Set_Next_Named_Actual |
3167 | (Insert_Param, First_Named_Actual (Call_Node)); | |
3168 | Set_First_Named_Actual (Call_Node, Actual_Expr); | |
70482933 RK |
3169 | |
3170 | if No (Prev) then | |
6dfc5592 RD |
3171 | if No (Parameter_Associations (Call_Node)) then |
3172 | Set_Parameter_Associations (Call_Node, New_List); | |
70482933 | 3173 | end if; |
57a3fca9 AC |
3174 | |
3175 | Append (Insert_Param, Parameter_Associations (Call_Node)); | |
3176 | ||
70482933 RK |
3177 | else |
3178 | Insert_After (Prev, Insert_Param); | |
3179 | end if; | |
3180 | ||
3181 | -- Case of insertion is not first named actual | |
3182 | ||
3183 | else | |
3184 | Set_Next_Named_Actual | |
3185 | (Insert_Param, Next_Named_Actual (Parent (Prev))); | |
3186 | Set_Next_Named_Actual (Parent (Prev), Actual_Expr); | |
6dfc5592 | 3187 | Append (Insert_Param, Parameter_Associations (Call_Node)); |
70482933 RK |
3188 | end if; |
3189 | ||
3190 | Prev := Actual_Expr; | |
3191 | end Add_Actual_Parameter; | |
3192 | ||
d7e20130 JS |
3193 | -------------------------------------- |
3194 | -- Add_Cond_Expression_Extra_Actual -- | |
3195 | -------------------------------------- | |
3196 | ||
3197 | procedure Add_Cond_Expression_Extra_Actual | |
3198 | (Formal : Entity_Id) | |
3199 | is | |
3200 | Decl : Node_Id; | |
d7e20130 | 3201 | Lvl : Entity_Id; |
d7e20130 JS |
3202 | |
3203 | procedure Insert_Level_Assign (Branch : Node_Id); | |
1cc9ecae | 3204 | -- Recursively add assignment of the level temporary on each branch |
d7e20130 JS |
3205 | -- while moving through nested conditional expressions. |
3206 | ||
3207 | ------------------------- | |
3208 | -- Insert_Level_Assign -- | |
3209 | ------------------------- | |
3210 | ||
3211 | procedure Insert_Level_Assign (Branch : Node_Id) is | |
3212 | ||
3213 | procedure Expand_Branch (Res_Assn : Node_Id); | |
3214 | -- Perform expansion or iterate further within nested | |
3215 | -- conditionals given the object declaration or assignment to | |
3216 | -- result object created during expansion which represents a | |
3217 | -- branch of the conditional expression. | |
3218 | ||
3219 | ------------------- | |
3220 | -- Expand_Branch -- | |
3221 | ------------------- | |
3222 | ||
3223 | procedure Expand_Branch (Res_Assn : Node_Id) is | |
3224 | begin | |
3225 | pragma Assert (Nkind (Res_Assn) in | |
3226 | N_Assignment_Statement | | |
3227 | N_Object_Declaration); | |
3228 | ||
3229 | -- There are more nested conditional expressions so we must go | |
3230 | -- deeper. | |
3231 | ||
1cc9ecae | 3232 | if Nkind (Expression (Res_Assn)) = N_Expression_With_Actions |
d7e20130 | 3233 | and then |
1cc9ecae AC |
3234 | Nkind (Original_Node (Expression (Res_Assn))) |
3235 | in N_Case_Expression | N_If_Expression | |
d7e20130 JS |
3236 | then |
3237 | Insert_Level_Assign | |
3238 | (Expression (Res_Assn)); | |
3239 | ||
3240 | -- Add the level assignment | |
3241 | ||
3242 | else | |
3243 | Insert_Before_And_Analyze (Res_Assn, | |
3244 | Make_Assignment_Statement (Loc, | |
1cc9ecae | 3245 | Name => New_Occurrence_Of (Lvl, Loc), |
d7e20130 | 3246 | Expression => |
66e97274 | 3247 | Accessibility_Level |
bcb8c3bb JS |
3248 | (Expr => Expression (Res_Assn), |
3249 | Level => Dynamic_Level, | |
3250 | Allow_Alt_Model => False))); | |
d7e20130 JS |
3251 | end if; |
3252 | end Expand_Branch; | |
3253 | ||
3254 | Cond : Node_Id; | |
3255 | Alt : Node_Id; | |
3256 | ||
3257 | -- Start of processing for Insert_Level_Assign | |
3258 | ||
3259 | begin | |
19668be0 | 3260 | -- Examine further nested conditionals |
d7e20130 JS |
3261 | |
3262 | pragma Assert (Nkind (Branch) = | |
3263 | N_Expression_With_Actions); | |
3264 | ||
3265 | -- Find the relevant statement in the actions | |
3266 | ||
3267 | Cond := First (Actions (Branch)); | |
3268 | while Present (Cond) loop | |
1cc9ecae | 3269 | exit when Nkind (Cond) in N_Case_Statement | N_If_Statement; |
d7e20130 JS |
3270 | Next (Cond); |
3271 | end loop; | |
3272 | ||
3273 | -- The conditional expression may have been optimized away, so | |
3274 | -- examine the actions in the branch. | |
3275 | ||
3276 | if No (Cond) then | |
3277 | Expand_Branch (Last (Actions (Branch))); | |
3278 | ||
3279 | -- Iterate through if expression branches | |
3280 | ||
3281 | elsif Nkind (Cond) = N_If_Statement then | |
3282 | Expand_Branch (Last (Then_Statements (Cond))); | |
3283 | Expand_Branch (Last (Else_Statements (Cond))); | |
3284 | ||
3285 | -- Iterate through case alternatives | |
3286 | ||
3287 | elsif Nkind (Cond) = N_Case_Statement then | |
3288 | ||
3289 | Alt := First (Alternatives (Cond)); | |
3290 | while Present (Alt) loop | |
3291 | Expand_Branch (Last (Statements (Alt))); | |
d7e20130 JS |
3292 | Next (Alt); |
3293 | end loop; | |
3294 | end if; | |
3295 | end Insert_Level_Assign; | |
3296 | ||
3297 | -- Start of processing for cond expression case | |
3298 | ||
3299 | begin | |
3300 | -- Create declaration of a temporary to store the accessibility | |
3301 | -- level of each branch of the conditional expression. | |
3302 | ||
3303 | Lvl := Make_Temporary (Loc, 'L'); | |
3304 | Decl := Make_Object_Declaration (Loc, | |
3305 | Defining_Identifier => Lvl, | |
3306 | Object_Definition => | |
3307 | New_Occurrence_Of (Standard_Natural, Loc)); | |
3308 | ||
3309 | -- Install the declaration and perform necessary expansion if we | |
1cc9ecae | 3310 | -- are dealing with a procedure call. |
d7e20130 JS |
3311 | |
3312 | if Nkind (Call_Node) = N_Procedure_Call_Statement then | |
3313 | -- Generate: | |
3314 | -- Lvl : Natural; | |
3315 | -- Call ( | |
3316 | -- {do | |
3317 | -- If_Exp_Res : Typ; | |
3318 | -- if Cond then | |
3319 | -- Lvl := 0; -- Access level | |
3320 | -- If_Exp_Res := Exp; | |
3321 | -- ... | |
3322 | -- in If_Exp_Res end;}, | |
3323 | -- Lvl, | |
3324 | -- ... | |
3325 | -- ) | |
3326 | ||
3327 | Insert_Before_And_Analyze (Call_Node, Decl); | |
3328 | ||
1cc9ecae AC |
3329 | -- Ditto for a function call. Note that we do not wrap the function |
3330 | -- call into an expression with action to avoid bad interactions with | |
3331 | -- Exp_Ch4.Process_Transient_In_Expression. | |
d7e20130 JS |
3332 | |
3333 | else | |
3334 | -- Generate: | |
1cc9ecae AC |
3335 | -- Lvl : Natural; -- placed above the function call |
3336 | -- ... | |
3337 | -- Func_Call ( | |
3338 | -- {do | |
3339 | -- If_Exp_Res : Typ | |
3340 | -- if Cond then | |
3341 | -- Lvl := 0; -- Access level | |
3342 | -- If_Exp_Res := Exp; | |
3343 | -- in If_Exp_Res end;}, | |
3344 | -- Lvl, | |
3345 | -- ... | |
3346 | -- ) | |
d7e20130 | 3347 | |
1cc9ecae AC |
3348 | Insert_Action (Call_Node, Decl); |
3349 | Analyze (Call_Node); | |
d7e20130 JS |
3350 | end if; |
3351 | ||
3352 | -- Decorate the conditional expression with assignments to our level | |
3353 | -- temporary. | |
3354 | ||
3355 | Insert_Level_Assign (Prev); | |
3356 | ||
3357 | -- Make our level temporary the passed actual | |
3358 | ||
3359 | Add_Extra_Actual | |
3360 | (Expr => New_Occurrence_Of (Lvl, Loc), | |
3361 | EF => Extra_Accessibility (Formal)); | |
3362 | end Add_Cond_Expression_Extra_Actual; | |
3363 | ||
358e289d JM |
3364 | -------------------------------------- |
3365 | -- Add_Dummy_Build_In_Place_Actuals -- | |
3366 | -------------------------------------- | |
3367 | ||
3368 | procedure Add_Dummy_Build_In_Place_Actuals | |
3369 | (Function_Id : Entity_Id; | |
3370 | Num_Added_Extra_Actuals : Nat := 0) | |
3371 | is | |
3372 | Loc : constant Source_Ptr := Sloc (Call_Node); | |
3373 | Formal : Entity_Id := Extra_Formals (Function_Id); | |
3374 | Actual : Node_Id; | |
3375 | Skip_Extra : Nat; | |
3376 | ||
3377 | begin | |
3378 | -- We never generate extra formals if expansion is not active because | |
3379 | -- we don't need them unless we are generating code. No action needed | |
3380 | -- for thunks since they propagate all their extra actuals. | |
3381 | ||
3382 | if not Expander_Active | |
3383 | or else Is_Thunk (Current_Scope) | |
3384 | then | |
3385 | return; | |
3386 | end if; | |
3387 | ||
3388 | -- Skip already-added non-BIP extra actuals | |
3389 | ||
3390 | Skip_Extra := Num_Added_Extra_Actuals; | |
3391 | while Skip_Extra > 0 loop | |
3392 | pragma Assert (not Is_Build_In_Place_Entity (Formal)); | |
3393 | Formal := Extra_Formal (Formal); | |
3394 | Skip_Extra := Skip_Extra - 1; | |
3395 | end loop; | |
3396 | ||
3397 | -- Append the dummy BIP extra actuals | |
3398 | ||
3399 | while Present (Formal) loop | |
3400 | pragma Assert (Is_Build_In_Place_Entity (Formal)); | |
3401 | ||
3402 | -- BIPalloc | |
3403 | ||
3404 | if Etype (Formal) = Standard_Natural then | |
3405 | Actual := Make_Integer_Literal (Loc, Uint_0); | |
3406 | Analyze_And_Resolve (Actual, Standard_Natural); | |
3407 | Add_Extra_Actual_To_Call (N, Formal, Actual); | |
3408 | ||
3409 | -- BIPtaskmaster | |
3410 | ||
3411 | elsif Etype (Formal) = Standard_Integer then | |
3412 | Actual := Make_Integer_Literal (Loc, Uint_0); | |
3413 | Analyze_And_Resolve (Actual, Standard_Integer); | |
3414 | Add_Extra_Actual_To_Call (N, Formal, Actual); | |
3415 | ||
3416 | -- BIPstoragepool, BIPfinalizationmaster, BIPactivationchain, | |
3417 | -- and BIPaccess. | |
3418 | ||
3419 | elsif Is_Access_Type (Etype (Formal)) then | |
3420 | Actual := Make_Null (Loc); | |
3421 | Analyze_And_Resolve (Actual, Etype (Formal)); | |
3422 | Add_Extra_Actual_To_Call (N, Formal, Actual); | |
3423 | ||
3424 | else | |
3425 | pragma Assert (False); | |
3426 | raise Program_Error; | |
3427 | end if; | |
3428 | ||
3429 | Formal := Extra_Formal (Formal); | |
3430 | end loop; | |
3431 | ||
3432 | -- Mark the call as processed build-in-place call; required | |
3433 | -- to avoid adding the extra formals twice. | |
3434 | ||
3435 | Set_Is_Expanded_Build_In_Place_Call (Call_Node); | |
3436 | ||
3437 | pragma Assert (Check_Number_Of_Actuals (Call_Node, Function_Id)); | |
3438 | pragma Assert (Check_BIP_Actuals (Call_Node, Function_Id)); | |
3439 | end Add_Dummy_Build_In_Place_Actuals; | |
3440 | ||
70482933 RK |
3441 | ---------------------- |
3442 | -- Add_Extra_Actual -- | |
3443 | ---------------------- | |
3444 | ||
3445 | procedure Add_Extra_Actual (Expr : Node_Id; EF : Entity_Id) is | |
3446 | Loc : constant Source_Ptr := Sloc (Expr); | |
3447 | ||
3448 | begin | |
3449 | if Extra_Actuals = No_List then | |
3450 | Extra_Actuals := New_List; | |
6dfc5592 | 3451 | Set_Parent (Extra_Actuals, Call_Node); |
70482933 RK |
3452 | end if; |
3453 | ||
3454 | Append_To (Extra_Actuals, | |
3455 | Make_Parameter_Association (Loc, | |
7a2c2277 | 3456 | Selector_Name => New_Occurrence_Of (EF, Loc), |
9d983bbf | 3457 | Explicit_Actual_Parameter => Expr)); |
70482933 RK |
3458 | |
3459 | Analyze_And_Resolve (Expr, Etype (EF)); | |
75a64833 | 3460 | |
6dfc5592 | 3461 | if Nkind (Call_Node) = N_Function_Call then |
75a64833 AC |
3462 | Set_Is_Accessibility_Actual (Parent (Expr)); |
3463 | end if; | |
70482933 RK |
3464 | end Add_Extra_Actual; |
3465 | ||
5f325af2 AC |
3466 | ------------------------------------ |
3467 | -- Add_View_Conversion_Invariants -- | |
3468 | ------------------------------------ | |
84e13614 | 3469 | |
5f325af2 AC |
3470 | procedure Add_View_Conversion_Invariants |
3471 | (Formal : Entity_Id; | |
3472 | Actual : Node_Id) | |
3473 | is | |
84e13614 | 3474 | Arg : Entity_Id; |
10c2c151 | 3475 | Curr_Typ : Entity_Id; |
84e13614 JS |
3476 | Inv_Checks : List_Id; |
3477 | Par_Typ : Entity_Id; | |
3478 | ||
3479 | begin | |
3480 | Inv_Checks := No_List; | |
3481 | ||
10c2c151 AC |
3482 | -- Extract the argument from a potentially nested set of view |
3483 | -- conversions. | |
84e13614 JS |
3484 | |
3485 | Arg := Actual; | |
3486 | while Nkind (Arg) = N_Type_Conversion loop | |
3487 | Arg := Expression (Arg); | |
3488 | end loop; | |
3489 | ||
10c2c151 AC |
3490 | -- Move up the derivation chain starting with the type of the formal |
3491 | -- parameter down to the type of the actual object. | |
84e13614 | 3492 | |
10c2c151 AC |
3493 | Curr_Typ := Empty; |
3494 | Par_Typ := Etype (Arg); | |
84e13614 JS |
3495 | while Par_Typ /= Etype (Formal) and Par_Typ /= Curr_Typ loop |
3496 | Curr_Typ := Par_Typ; | |
10c2c151 | 3497 | |
84e13614 JS |
3498 | if Has_Invariants (Curr_Typ) |
3499 | and then Present (Invariant_Procedure (Curr_Typ)) | |
3500 | then | |
23a9215f | 3501 | -- Verify the invariant of the current type. Generate: |
10c2c151 AC |
3502 | |
3503 | -- <Curr_Typ>Invariant (Curr_Typ (Arg)); | |
84e13614 JS |
3504 | |
3505 | Prepend_New_To (Inv_Checks, | |
3506 | Make_Procedure_Call_Statement (Loc, | |
3507 | Name => | |
3508 | New_Occurrence_Of | |
3509 | (Invariant_Procedure (Curr_Typ), Loc), | |
3510 | Parameter_Associations => New_List ( | |
3511 | Make_Type_Conversion (Loc, | |
3512 | Subtype_Mark => New_Occurrence_Of (Curr_Typ, Loc), | |
3513 | Expression => New_Copy_Tree (Arg))))); | |
3514 | end if; | |
3515 | ||
3516 | Par_Typ := Base_Type (Etype (Curr_Typ)); | |
3517 | end loop; | |
3518 | ||
5f396397 ES |
3519 | -- If the node is a function call the generated tests have been |
3520 | -- already handled in Insert_Post_Call_Actions. | |
3521 | ||
3522 | if not Is_Empty_List (Inv_Checks) | |
3523 | and then Nkind (Call_Node) = N_Procedure_Call_Statement | |
3524 | then | |
773e99ac | 3525 | Insert_Actions_After (Call_Node, Inv_Checks); |
84e13614 | 3526 | end if; |
5f325af2 | 3527 | end Add_View_Conversion_Invariants; |
84e13614 | 3528 | |
a081ded4 ES |
3529 | ----------------------------- |
3530 | -- Can_Fold_Predicate_Call -- | |
3531 | ----------------------------- | |
3532 | ||
3533 | function Can_Fold_Predicate_Call (P : Entity_Id) return Boolean is | |
6ef13c4f | 3534 | Actual : Node_Id; |
a081ded4 | 3535 | |
2ad5d5e3 SB |
3536 | function Augments_Other_Dynamic_Predicate (DP_Aspect_Spec : Node_Id) |
3537 | return Boolean; | |
3538 | -- Given a Dynamic_Predicate aspect aspecification for a | |
3539 | -- discrete type, returns True iff another DP specification | |
3540 | -- applies (indirectly, via a subtype type or a derived type) | |
3541 | -- to the same entity that this aspect spec applies to. | |
3542 | ||
a081ded4 ES |
3543 | function May_Fold (N : Node_Id) return Traverse_Result; |
3544 | -- The predicate expression is foldable if it only contains operators | |
3545 | -- and literals. During this check, we also replace occurrences of | |
3546 | -- the formal of the constructed predicate function with the static | |
3547 | -- value of the actual. This is done on a copy of the analyzed | |
3548 | -- expression for the predicate. | |
3549 | ||
2ad5d5e3 SB |
3550 | -------------------------------------- |
3551 | -- Augments_Other_Dynamic_Predicate -- | |
3552 | -------------------------------------- | |
3553 | ||
3554 | function Augments_Other_Dynamic_Predicate (DP_Aspect_Spec : Node_Id) | |
3555 | return Boolean | |
3556 | is | |
3557 | Aspect_Bearer : Entity_Id := Entity (DP_Aspect_Spec); | |
3558 | begin | |
3559 | loop | |
3560 | Aspect_Bearer := Nearest_Ancestor (Aspect_Bearer); | |
3561 | ||
7d0d27d9 | 3562 | if No (Aspect_Bearer) then |
2ad5d5e3 SB |
3563 | return False; |
3564 | end if; | |
3565 | ||
3566 | declare | |
3567 | Aspect_Spec : constant Node_Id := | |
3568 | Find_Aspect (Aspect_Bearer, Aspect_Dynamic_Predicate); | |
3569 | begin | |
3570 | if Present (Aspect_Spec) | |
3571 | and then Aspect_Spec /= DP_Aspect_Spec | |
3572 | then | |
3573 | -- Found another Dynamic_Predicate aspect spec | |
3574 | return True; | |
3575 | end if; | |
3576 | end; | |
3577 | end loop; | |
3578 | end Augments_Other_Dynamic_Predicate; | |
3579 | ||
29c64a0f HK |
3580 | -------------- |
3581 | -- May_Fold -- | |
3582 | -------------- | |
3583 | ||
a081ded4 ES |
3584 | function May_Fold (N : Node_Id) return Traverse_Result is |
3585 | begin | |
3586 | case Nkind (N) is | |
5a36f3d9 | 3587 | when N_Op => |
a081ded4 ES |
3588 | return OK; |
3589 | ||
29c64a0f HK |
3590 | when N_Expanded_Name |
3591 | | N_Identifier | |
3592 | => | |
a081ded4 ES |
3593 | if Ekind (Entity (N)) = E_In_Parameter |
3594 | and then Entity (N) = First_Entity (P) | |
3595 | then | |
3596 | Rewrite (N, New_Copy (Actual)); | |
3597 | Set_Is_Static_Expression (N); | |
3598 | return OK; | |
3599 | ||
3600 | elsif Ekind (Entity (N)) = E_Enumeration_Literal then | |
3601 | return OK; | |
3602 | ||
3603 | else | |
3604 | return Abandon; | |
3605 | end if; | |
3606 | ||
29c64a0f HK |
3607 | when N_Case_Expression |
3608 | | N_If_Expression | |
3609 | => | |
a081ded4 ES |
3610 | return OK; |
3611 | ||
3612 | when N_Integer_Literal => | |
3613 | return OK; | |
3614 | ||
3615 | when others => | |
3616 | return Abandon; | |
3617 | end case; | |
3618 | end May_Fold; | |
3619 | ||
3620 | function Try_Fold is new Traverse_Func (May_Fold); | |
3621 | ||
2ad5d5e3 | 3622 | -- Other Local variables |
29c64a0f | 3623 | |
6ef13c4f ES |
3624 | Subt : constant Entity_Id := Etype (First_Entity (P)); |
3625 | Aspect : Node_Id; | |
3626 | Pred : Node_Id; | |
29c64a0f | 3627 | |
a081ded4 ES |
3628 | -- Start of processing for Can_Fold_Predicate_Call |
3629 | ||
3630 | begin | |
3631 | -- Folding is only interesting if the actual is static and its type | |
3632 | -- has a Dynamic_Predicate aspect. For CodePeer we preserve the | |
3633 | -- function call. | |
3634 | ||
6ef13c4f ES |
3635 | Actual := First (Parameter_Associations (Call_Node)); |
3636 | Aspect := Find_Aspect (Subt, Aspect_Dynamic_Predicate); | |
3637 | ||
3638 | -- If actual is a declared constant, retrieve its value | |
3639 | ||
3640 | if Is_Entity_Name (Actual) | |
3641 | and then Ekind (Entity (Actual)) = E_Constant | |
3642 | then | |
3643 | Actual := Constant_Value (Entity (Actual)); | |
3644 | end if; | |
3645 | ||
3646 | if No (Actual) | |
3647 | or else Nkind (Actual) /= N_Integer_Literal | |
a081ded4 | 3648 | or else not Has_Dynamic_Predicate_Aspect (Subt) |
6ef13c4f | 3649 | or else No (Aspect) |
2ad5d5e3 SB |
3650 | |
3651 | -- Do not fold if multiple applicable predicate aspects | |
067d80d8 | 3652 | or else Has_Ghost_Predicate_Aspect (Subt) |
11f89257 PT |
3653 | or else Has_Aspect (Subt, Aspect_Static_Predicate) |
3654 | or else Has_Aspect (Subt, Aspect_Predicate) | |
2ad5d5e3 | 3655 | or else Augments_Other_Dynamic_Predicate (Aspect) |
a081ded4 ES |
3656 | or else CodePeer_Mode |
3657 | then | |
3658 | return False; | |
3659 | end if; | |
3660 | ||
3661 | -- Retrieve the analyzed expression for the predicate | |
3662 | ||
6ef13c4f | 3663 | Pred := New_Copy_Tree (Expression (Aspect)); |
a081ded4 ES |
3664 | |
3665 | if Try_Fold (Pred) = OK then | |
3666 | Rewrite (Call_Node, Pred); | |
3667 | Analyze_And_Resolve (Call_Node, Standard_Boolean); | |
3668 | return True; | |
3669 | ||
29c64a0f | 3670 | -- Otherwise continue the expansion of the function call |
a081ded4 | 3671 | |
29c64a0f | 3672 | else |
a081ded4 ES |
3673 | return False; |
3674 | end if; | |
3675 | end Can_Fold_Predicate_Call; | |
3676 | ||
afa1ffd4 PT |
3677 | ------------------------------ |
3678 | -- Check_Subprogram_Variant -- | |
3679 | ------------------------------ | |
3680 | ||
3681 | procedure Check_Subprogram_Variant is | |
f1668c3d JM |
3682 | |
3683 | function Duplicate_Params_Without_Extra_Actuals | |
3684 | (Call_Node : Node_Id) return List_Id; | |
3685 | -- Duplicate actual parameters of Call_Node into New_Call without | |
3686 | -- extra actuals. | |
3687 | ||
3688 | -------------------------------------------- | |
3689 | -- Duplicate_Params_Without_Extra_Actuals -- | |
3690 | -------------------------------------------- | |
3691 | ||
3692 | function Duplicate_Params_Without_Extra_Actuals | |
3693 | (Call_Node : Node_Id) return List_Id | |
3694 | is | |
3695 | Proc_Id : constant Entity_Id := Entity (Name (Call_Node)); | |
3696 | Actuals : constant List_Id := Parameter_Associations (Call_Node); | |
3697 | NL : List_Id; | |
3698 | Actual : Node_Or_Entity_Id; | |
3699 | Formal : Entity_Id; | |
3700 | ||
3701 | begin | |
3702 | if Actuals = No_List then | |
3703 | return No_List; | |
3704 | ||
3705 | else | |
3706 | NL := New_List; | |
3707 | Actual := First (Actuals); | |
3708 | Formal := First_Formal (Proc_Id); | |
3709 | ||
3710 | while Present (Formal) | |
3711 | and then Formal /= Extra_Formals (Proc_Id) | |
3712 | loop | |
3713 | Append (New_Copy (Actual), NL); | |
3714 | Next (Actual); | |
3715 | ||
3716 | Next_Formal (Formal); | |
3717 | end loop; | |
3718 | ||
3719 | return NL; | |
3720 | end if; | |
3721 | end Duplicate_Params_Without_Extra_Actuals; | |
3722 | ||
3723 | -- Local variables | |
3724 | ||
afa1ffd4 PT |
3725 | Variant_Prag : constant Node_Id := |
3726 | Get_Pragma (Current_Scope, Pragma_Subprogram_Variant); | |
3727 | ||
f1668c3d | 3728 | New_Call : Node_Id; |
576b7778 | 3729 | Pragma_Arg1 : Node_Id; |
afa1ffd4 PT |
3730 | Variant_Proc : Entity_Id; |
3731 | ||
3732 | begin | |
3733 | if Present (Variant_Prag) and then Is_Checked (Variant_Prag) then | |
3734 | ||
576b7778 PT |
3735 | Pragma_Arg1 := |
3736 | Expression (First (Pragma_Argument_Associations (Variant_Prag))); | |
3737 | ||
3738 | -- If pragma parameter is still an aggregate, it comes from a | |
3739 | -- structural variant, which is not expanded and ignored for | |
3740 | -- run-time execution. | |
3741 | ||
3742 | if Nkind (Pragma_Arg1) = N_Aggregate then | |
3743 | pragma Assert | |
3744 | (Chars | |
3745 | (First | |
3746 | (Choices | |
3747 | (First (Component_Associations (Pragma_Arg1))))) = | |
3748 | Name_Structural); | |
3749 | return; | |
3750 | end if; | |
3751 | ||
3752 | -- Otherwise, analysis of the pragma rewrites its argument with a | |
3753 | -- reference to the internally generated procedure. | |
afa1ffd4 | 3754 | |
576b7778 | 3755 | Variant_Proc := Entity (Pragma_Arg1); |
afa1ffd4 | 3756 | |
f1668c3d | 3757 | New_Call := |
afa1ffd4 PT |
3758 | Make_Procedure_Call_Statement (Loc, |
3759 | Name => | |
3760 | New_Occurrence_Of (Variant_Proc, Loc), | |
3761 | Parameter_Associations => | |
f1668c3d JM |
3762 | Duplicate_Params_Without_Extra_Actuals (Call_Node)); |
3763 | ||
3764 | Insert_Action (Call_Node, New_Call); | |
3765 | ||
3766 | pragma Assert (Etype (New_Call) /= Any_Type | |
3767 | or else Serious_Errors_Detected > 0); | |
afa1ffd4 PT |
3768 | end if; |
3769 | end Check_Subprogram_Variant; | |
3770 | ||
70482933 RK |
3771 | --------------------------- |
3772 | -- Inherited_From_Formal -- | |
3773 | --------------------------- | |
3774 | ||
3775 | function Inherited_From_Formal (S : Entity_Id) return Entity_Id is | |
3776 | Par : Entity_Id; | |
3777 | Gen_Par : Entity_Id; | |
3778 | Gen_Prim : Elist_Id; | |
3779 | Elmt : Elmt_Id; | |
3780 | Indic : Node_Id; | |
3781 | ||
3782 | begin | |
3783 | -- If the operation is inherited, it is attached to the corresponding | |
3784 | -- type derivation. If the parent in the derivation is a generic | |
3785 | -- actual, it is a subtype of the actual, and we have to recover the | |
3786 | -- original derived type declaration to find the proper parent. | |
3787 | ||
3788 | if Nkind (Parent (S)) /= N_Full_Type_Declaration | |
fbf5a39b | 3789 | or else not Is_Derived_Type (Defining_Identifier (Parent (S))) |
2f1b20a9 ES |
3790 | or else Nkind (Type_Definition (Original_Node (Parent (S)))) /= |
3791 | N_Derived_Type_Definition | |
fbf5a39b | 3792 | or else not In_Instance |
70482933 RK |
3793 | then |
3794 | return Empty; | |
3795 | ||
3796 | else | |
3797 | Indic := | |
e27b834b AC |
3798 | Subtype_Indication |
3799 | (Type_Definition (Original_Node (Parent (S)))); | |
70482933 RK |
3800 | |
3801 | if Nkind (Indic) = N_Subtype_Indication then | |
3802 | Par := Entity (Subtype_Mark (Indic)); | |
3803 | else | |
3804 | Par := Entity (Indic); | |
3805 | end if; | |
3806 | end if; | |
3807 | ||
3808 | if not Is_Generic_Actual_Type (Par) | |
3809 | or else Is_Tagged_Type (Par) | |
3810 | or else Nkind (Parent (Par)) /= N_Subtype_Declaration | |
3811 | or else not In_Open_Scopes (Scope (Par)) | |
70482933 RK |
3812 | then |
3813 | return Empty; | |
70482933 RK |
3814 | else |
3815 | Gen_Par := Generic_Parent_Type (Parent (Par)); | |
3816 | end if; | |
3817 | ||
7888a6ae GD |
3818 | -- If the actual has no generic parent type, the formal is not |
3819 | -- a formal derived type, so nothing to inherit. | |
3820 | ||
3821 | if No (Gen_Par) then | |
3822 | return Empty; | |
3823 | end if; | |
3824 | ||
2f1b20a9 ES |
3825 | -- If the generic parent type is still the generic type, this is a |
3826 | -- private formal, not a derived formal, and there are no operations | |
3827 | -- inherited from the formal. | |
fbf5a39b AC |
3828 | |
3829 | if Nkind (Parent (Gen_Par)) = N_Formal_Type_Declaration then | |
3830 | return Empty; | |
3831 | end if; | |
3832 | ||
70482933 | 3833 | Gen_Prim := Collect_Primitive_Operations (Gen_Par); |
70482933 | 3834 | |
2f1b20a9 | 3835 | Elmt := First_Elmt (Gen_Prim); |
70482933 RK |
3836 | while Present (Elmt) loop |
3837 | if Chars (Node (Elmt)) = Chars (S) then | |
3838 | declare | |
3839 | F1 : Entity_Id; | |
3840 | F2 : Entity_Id; | |
70482933 | 3841 | |
2f1b20a9 | 3842 | begin |
70482933 RK |
3843 | F1 := First_Formal (S); |
3844 | F2 := First_Formal (Node (Elmt)); | |
70482933 RK |
3845 | while Present (F1) |
3846 | and then Present (F2) | |
3847 | loop | |
70482933 RK |
3848 | if Etype (F1) = Etype (F2) |
3849 | or else Etype (F2) = Gen_Par | |
3850 | then | |
3851 | Next_Formal (F1); | |
3852 | Next_Formal (F2); | |
3853 | else | |
3854 | Next_Elmt (Elmt); | |
3855 | exit; -- not the right subprogram | |
3856 | end if; | |
3857 | ||
3858 | return Node (Elmt); | |
3859 | end loop; | |
3860 | end; | |
3861 | ||
3862 | else | |
3863 | Next_Elmt (Elmt); | |
3864 | end if; | |
3865 | end loop; | |
3866 | ||
3867 | raise Program_Error; | |
3868 | end Inherited_From_Formal; | |
3869 | ||
84f4072a JM |
3870 | -------------------------- |
3871 | -- In_Unfrozen_Instance -- | |
3872 | -------------------------- | |
3873 | ||
3874 | function In_Unfrozen_Instance (E : Entity_Id) return Boolean is | |
bde73c6b | 3875 | S : Entity_Id; |
84f4072a JM |
3876 | |
3877 | begin | |
bde73c6b AC |
3878 | S := E; |
3879 | while Present (S) and then S /= Standard_Standard loop | |
84f4072a JM |
3880 | if Is_Generic_Instance (S) |
3881 | and then Present (Freeze_Node (S)) | |
3882 | and then not Analyzed (Freeze_Node (S)) | |
3883 | then | |
3884 | return True; | |
3885 | end if; | |
3886 | ||
3887 | S := Scope (S); | |
3888 | end loop; | |
3889 | ||
3890 | return False; | |
3891 | end In_Unfrozen_Instance; | |
3892 | ||
5a644684 JM |
3893 | ---------------------------------- |
3894 | -- Is_Class_Wide_Interface_Type -- | |
3895 | ---------------------------------- | |
3896 | ||
3897 | function Is_Class_Wide_Interface_Type (E : Entity_Id) return Boolean is | |
5a644684 | 3898 | DDT : Entity_Id; |
7f8c1cd3 | 3899 | Typ : Entity_Id := E; |
5a644684 JM |
3900 | |
3901 | begin | |
3902 | if Has_Non_Limited_View (Typ) then | |
3903 | Typ := Non_Limited_View (Typ); | |
3904 | end if; | |
3905 | ||
3906 | if Ekind (Typ) = E_Anonymous_Access_Type then | |
3907 | DDT := Directly_Designated_Type (Typ); | |
3908 | ||
3909 | if Has_Non_Limited_View (DDT) then | |
3910 | DDT := Non_Limited_View (DDT); | |
3911 | end if; | |
3912 | ||
3913 | return Is_Class_Wide_Type (DDT) and then Is_Interface (DDT); | |
3914 | else | |
3915 | return Is_Class_Wide_Type (Typ) and then Is_Interface (Typ); | |
3916 | end if; | |
3917 | end Is_Class_Wide_Interface_Type; | |
3918 | ||
df3e68b1 HK |
3919 | ------------------------- |
3920 | -- Is_Direct_Deep_Call -- | |
3921 | ------------------------- | |
3922 | ||
3923 | function Is_Direct_Deep_Call (Subp : Entity_Id) return Boolean is | |
3924 | begin | |
3925 | if Is_TSS (Subp, TSS_Deep_Adjust) | |
3926 | or else Is_TSS (Subp, TSS_Deep_Finalize) | |
3927 | or else Is_TSS (Subp, TSS_Deep_Initialize) | |
3928 | then | |
3929 | declare | |
3930 | Actual : Node_Id; | |
b0fa1c68 | 3931 | Formal : Entity_Id; |
df3e68b1 HK |
3932 | |
3933 | begin | |
773e99ac | 3934 | Actual := First (Parameter_Associations (Call_Node)); |
df3e68b1 HK |
3935 | Formal := First_Formal (Subp); |
3936 | while Present (Actual) | |
3937 | and then Present (Formal) | |
3938 | loop | |
3939 | if Nkind (Actual) = N_Identifier | |
3940 | and then Is_Controlling_Actual (Actual) | |
3941 | and then Etype (Actual) = Etype (Formal) | |
3942 | then | |
3943 | return True; | |
3944 | end if; | |
3945 | ||
3946 | Next (Actual); | |
3947 | Next_Formal (Formal); | |
3948 | end loop; | |
3949 | end; | |
3950 | end if; | |
3951 | ||
3952 | return False; | |
3953 | end Is_Direct_Deep_Call; | |
3954 | ||
dd386db0 AC |
3955 | --------------- |
3956 | -- New_Value -- | |
3957 | --------------- | |
3958 | ||
3959 | function New_Value (From : Node_Id) return Node_Id is | |
3960 | Res : constant Node_Id := Duplicate_Subexpr (From); | |
3961 | begin | |
3962 | if Is_Access_Type (Etype (From)) then | |
bde73c6b | 3963 | return Make_Explicit_Dereference (Sloc (From), Prefix => Res); |
dd386db0 AC |
3964 | else |
3965 | return Res; | |
3966 | end if; | |
3967 | end New_Value; | |
3968 | ||
fdce4bb7 JM |
3969 | -- Local variables |
3970 | ||
888be6b1 | 3971 | Remote : constant Boolean := Is_Remote_Call (Call_Node); |
fdce4bb7 JM |
3972 | Actual : Node_Id; |
3973 | Formal : Entity_Id; | |
3974 | Orig_Subp : Entity_Id := Empty; | |
52ad13ba | 3975 | Param_Count : Positive; |
fdce4bb7 JM |
3976 | Parent_Formal : Entity_Id; |
3977 | Parent_Subp : Entity_Id; | |
3978 | Scop : Entity_Id; | |
3979 | Subp : Entity_Id; | |
3980 | ||
fdce4bb7 JM |
3981 | CW_Interface_Formals_Present : Boolean := False; |
3982 | ||
ca1f6b29 | 3983 | -- Start of processing for Expand_Call_Helper |
70482933 RK |
3984 | |
3985 | begin | |
ca1f6b29 BD |
3986 | Post_Call := New_List; |
3987 | ||
fc90cc62 AC |
3988 | -- Expand the function or procedure call if the first actual has a |
3989 | -- declared dimension aspect, and the subprogram is declared in one | |
3990 | -- of the dimension I/O packages. | |
dec6faf1 AC |
3991 | |
3992 | if Ada_Version >= Ada_2012 | |
612c48b1 | 3993 | and then Nkind (Call_Node) in N_Subprogram_Call |
dec6faf1 AC |
3994 | and then Present (Parameter_Associations (Call_Node)) |
3995 | then | |
df378148 | 3996 | Expand_Put_Call_With_Symbol (Call_Node); |
dec6faf1 AC |
3997 | end if; |
3998 | ||
07fc65c4 GB |
3999 | -- Ignore if previous error |
4000 | ||
6dfc5592 RD |
4001 | if Nkind (Call_Node) in N_Has_Etype |
4002 | and then Etype (Call_Node) = Any_Type | |
4003 | then | |
07fc65c4 GB |
4004 | return; |
4005 | end if; | |
4006 | ||
70482933 RK |
4007 | -- Call using access to subprogram with explicit dereference |
4008 | ||
6dfc5592 RD |
4009 | if Nkind (Name (Call_Node)) = N_Explicit_Dereference then |
4010 | Subp := Etype (Name (Call_Node)); | |
70482933 RK |
4011 | Parent_Subp := Empty; |
4012 | ||
4013 | -- Case of call to simple entry, where the Name is a selected component | |
4014 | -- whose prefix is the task, and whose selector name is the entry name | |
4015 | ||
6dfc5592 RD |
4016 | elsif Nkind (Name (Call_Node)) = N_Selected_Component then |
4017 | Subp := Entity (Selector_Name (Name (Call_Node))); | |
70482933 RK |
4018 | Parent_Subp := Empty; |
4019 | ||
4020 | -- Case of call to member of entry family, where Name is an indexed | |
4021 | -- component, with the prefix being a selected component giving the | |
4022 | -- task and entry family name, and the index being the entry index. | |
4023 | ||
6dfc5592 RD |
4024 | elsif Nkind (Name (Call_Node)) = N_Indexed_Component then |
4025 | Subp := Entity (Selector_Name (Prefix (Name (Call_Node)))); | |
70482933 RK |
4026 | Parent_Subp := Empty; |
4027 | ||
4028 | -- Normal case | |
4029 | ||
4030 | else | |
6dfc5592 | 4031 | Subp := Entity (Name (Call_Node)); |
70482933 RK |
4032 | Parent_Subp := Alias (Subp); |
4033 | ||
4034 | -- Replace call to Raise_Exception by call to Raise_Exception_Always | |
4035 | -- if we can tell that the first parameter cannot possibly be null. | |
70f91180 | 4036 | -- This improves efficiency by avoiding a run-time test. |
70482933 | 4037 | |
7888a6ae GD |
4038 | -- We do not do this if Raise_Exception_Always does not exist, which |
4039 | -- can happen in configurable run time profiles which provide only a | |
70f91180 | 4040 | -- Raise_Exception. |
7888a6ae GD |
4041 | |
4042 | if Is_RTE (Subp, RE_Raise_Exception) | |
4043 | and then RTE_Available (RE_Raise_Exception_Always) | |
70482933 RK |
4044 | then |
4045 | declare | |
3cae7f14 RD |
4046 | FA : constant Node_Id := |
4047 | Original_Node (First_Actual (Call_Node)); | |
4048 | ||
70482933 RK |
4049 | begin |
4050 | -- The case we catch is where the first argument is obtained | |
2f1b20a9 ES |
4051 | -- using the Identity attribute (which must always be |
4052 | -- non-null). | |
70482933 RK |
4053 | |
4054 | if Nkind (FA) = N_Attribute_Reference | |
4055 | and then Attribute_Name (FA) = Name_Identity | |
4056 | then | |
4057 | Subp := RTE (RE_Raise_Exception_Always); | |
6dfc5592 | 4058 | Set_Name (Call_Node, New_Occurrence_Of (Subp, Loc)); |
70482933 RK |
4059 | end if; |
4060 | end; | |
4061 | end if; | |
4062 | ||
4063 | if Ekind (Subp) = E_Entry then | |
4064 | Parent_Subp := Empty; | |
4065 | end if; | |
4066 | end if; | |
4067 | ||
f1668c3d JM |
4068 | -- Ensure that the called subprogram has all its formals |
4069 | ||
4070 | if not Is_Frozen (Subp) then | |
4071 | Create_Extra_Formals (Subp); | |
4072 | end if; | |
4073 | ||
f4d379b8 HK |
4074 | -- Ada 2005 (AI-345): We have a procedure call as a triggering |
4075 | -- alternative in an asynchronous select or as an entry call in | |
4076 | -- a conditional or timed select. Check whether the procedure call | |
4077 | -- is a renaming of an entry and rewrite it as an entry call. | |
4078 | ||
0791fbe9 | 4079 | if Ada_Version >= Ada_2005 |
6dfc5592 | 4080 | and then Nkind (Call_Node) = N_Procedure_Call_Statement |
f4d379b8 | 4081 | and then |
6dfc5592 | 4082 | ((Nkind (Parent (Call_Node)) = N_Triggering_Alternative |
3cae7f14 | 4083 | and then Triggering_Statement (Parent (Call_Node)) = Call_Node) |
f4d379b8 | 4084 | or else |
6dfc5592 | 4085 | (Nkind (Parent (Call_Node)) = N_Entry_Call_Alternative |
3cae7f14 | 4086 | and then Entry_Call_Statement (Parent (Call_Node)) = Call_Node)) |
f4d379b8 HK |
4087 | then |
4088 | declare | |
4089 | Ren_Decl : Node_Id; | |
4090 | Ren_Root : Entity_Id := Subp; | |
4091 | ||
4092 | begin | |
4093 | -- This may be a chain of renamings, find the root | |
4094 | ||
4095 | if Present (Alias (Ren_Root)) then | |
4096 | Ren_Root := Alias (Ren_Root); | |
4097 | end if; | |
4098 | ||
898edf75 BD |
4099 | if Present (Parent (Ren_Root)) |
4100 | and then Present (Original_Node (Parent (Parent (Ren_Root)))) | |
4101 | then | |
f4d379b8 HK |
4102 | Ren_Decl := Original_Node (Parent (Parent (Ren_Root))); |
4103 | ||
4104 | if Nkind (Ren_Decl) = N_Subprogram_Renaming_Declaration then | |
6dfc5592 | 4105 | Rewrite (Call_Node, |
f4d379b8 HK |
4106 | Make_Entry_Call_Statement (Loc, |
4107 | Name => | |
4108 | New_Copy_Tree (Name (Ren_Decl)), | |
4109 | Parameter_Associations => | |
6dfc5592 RD |
4110 | New_Copy_List_Tree |
4111 | (Parameter_Associations (Call_Node)))); | |
f4d379b8 HK |
4112 | |
4113 | return; | |
4114 | end if; | |
4115 | end if; | |
4116 | end; | |
4117 | end if; | |
4118 | ||
23a9215f | 4119 | -- If this is a call to a predicate function, try to constant fold it |
a081ded4 ES |
4120 | |
4121 | if Nkind (Call_Node) = N_Function_Call | |
4122 | and then Is_Entity_Name (Name (Call_Node)) | |
4123 | and then Is_Predicate_Function (Subp) | |
4124 | and then Can_Fold_Predicate_Call (Subp) | |
4125 | then | |
4126 | return; | |
4127 | end if; | |
4128 | ||
b36ec518 | 4129 | if Transform_Function_Array |
2700b9c1 AC |
4130 | and then Nkind (Call_Node) = N_Function_Call |
4131 | and then Is_Entity_Name (Name (Call_Node)) | |
2700b9c1 | 4132 | then |
780d73d7 AC |
4133 | declare |
4134 | Func_Id : constant Entity_Id := | |
4135 | Ultimate_Alias (Entity (Name (Call_Node))); | |
4136 | begin | |
4137 | -- When generating C code, transform a function call that returns | |
4138 | -- a constrained array type into procedure form. | |
aeb98f1d | 4139 | |
780d73d7 AC |
4140 | if Rewritten_For_C (Func_Id) then |
4141 | ||
4142 | -- For internally generated calls ensure that they reference | |
4143 | -- the entity of the spec of the called function (needed since | |
4144 | -- the expander may generate calls using the entity of their | |
b50706ef | 4145 | -- body). |
780d73d7 | 4146 | |
b50706ef | 4147 | if not Comes_From_Source (Call_Node) |
780d73d7 AC |
4148 | and then Nkind (Unit_Declaration_Node (Func_Id)) = |
4149 | N_Subprogram_Body | |
4150 | then | |
4151 | Set_Entity (Name (Call_Node), | |
4152 | Corresponding_Function | |
4153 | (Corresponding_Procedure (Func_Id))); | |
4154 | end if; | |
4155 | ||
4156 | Rewrite_Function_Call_For_C (Call_Node); | |
4157 | return; | |
4158 | ||
4159 | -- Also introduce a temporary for functions that return a record | |
4160 | -- called within another procedure or function call, since records | |
4161 | -- are passed by pointer in the generated C code, and we cannot | |
4162 | -- take a pointer from a subprogram call. | |
4163 | ||
d6a52e47 AC |
4164 | elsif Modify_Tree_For_C |
4165 | and then Nkind (Parent (Call_Node)) in N_Subprogram_Call | |
780d73d7 AC |
4166 | and then Is_Record_Type (Etype (Func_Id)) |
4167 | then | |
4168 | declare | |
4169 | Temp_Id : constant Entity_Id := Make_Temporary (Loc, 'T'); | |
4170 | Decl : Node_Id; | |
4171 | ||
4172 | begin | |
4173 | -- Generate: | |
4174 | -- Temp : ... := Func_Call (...); | |
4175 | ||
4176 | Decl := | |
4177 | Make_Object_Declaration (Loc, | |
4178 | Defining_Identifier => Temp_Id, | |
4179 | Object_Definition => | |
4180 | New_Occurrence_Of (Etype (Func_Id), Loc), | |
4181 | Expression => | |
4182 | Make_Function_Call (Loc, | |
4183 | Name => | |
4184 | New_Occurrence_Of (Func_Id, Loc), | |
4185 | Parameter_Associations => | |
4186 | Parameter_Associations (Call_Node))); | |
4187 | ||
4188 | Insert_Action (Parent (Call_Node), Decl); | |
4189 | Rewrite (Call_Node, New_Occurrence_Of (Temp_Id, Loc)); | |
4190 | return; | |
4191 | end; | |
4192 | end if; | |
4193 | end; | |
2700b9c1 AC |
4194 | end if; |
4195 | ||
e27b834b AC |
4196 | -- First step, compute extra actuals, corresponding to any Extra_Formals |
4197 | -- present. Note that we do not access Extra_Formals directly, instead | |
4198 | -- we simply note the presence of the extra formals as we process the | |
4199 | -- regular formals collecting corresponding actuals in Extra_Actuals. | |
70482933 | 4200 | |
c2369146 AC |
4201 | -- We also generate any required range checks for actuals for in formals |
4202 | -- as we go through the loop, since this is a convenient place to do it. | |
4203 | -- (Though it seems that this would be better done in Expand_Actuals???) | |
fbf5a39b | 4204 | |
e2441021 AC |
4205 | -- Special case: Thunks must not compute the extra actuals; they must |
4206 | -- just propagate to the target primitive their extra actuals. | |
4207 | ||
4208 | if Is_Thunk (Current_Scope) | |
4209 | and then Thunk_Entity (Current_Scope) = Subp | |
4210 | and then Present (Extra_Formals (Subp)) | |
4211 | then | |
f1668c3d | 4212 | pragma Assert (Extra_Formals_Match_OK (Current_Scope, Subp)); |
e2441021 AC |
4213 | |
4214 | declare | |
4215 | Target_Formal : Entity_Id; | |
4216 | Thunk_Formal : Entity_Id; | |
4217 | ||
4218 | begin | |
4219 | Target_Formal := Extra_Formals (Subp); | |
4220 | Thunk_Formal := Extra_Formals (Current_Scope); | |
4221 | while Present (Target_Formal) loop | |
4222 | Add_Extra_Actual | |
683af98c AC |
4223 | (Expr => New_Occurrence_Of (Thunk_Formal, Loc), |
4224 | EF => Thunk_Formal); | |
e2441021 AC |
4225 | |
4226 | Target_Formal := Extra_Formal (Target_Formal); | |
4227 | Thunk_Formal := Extra_Formal (Thunk_Formal); | |
4228 | end loop; | |
4229 | ||
4230 | while Is_Non_Empty_List (Extra_Actuals) loop | |
4231 | Add_Actual_Parameter (Remove_Head (Extra_Actuals)); | |
4232 | end loop; | |
4233 | ||
f1668c3d JM |
4234 | -- Mark the call as processed build-in-place call; required |
4235 | -- to avoid adding the extra formals twice. | |
4236 | ||
4237 | if Nkind (Call_Node) = N_Function_Call then | |
4238 | Set_Is_Expanded_Build_In_Place_Call (Call_Node); | |
4239 | end if; | |
4240 | ||
ca1f6b29 BD |
4241 | Expand_Actuals (Call_Node, Subp, Post_Call); |
4242 | pragma Assert (Is_Empty_List (Post_Call)); | |
82af7291 JM |
4243 | pragma Assert (Check_Number_Of_Actuals (Call_Node, Subp)); |
4244 | pragma Assert (Check_BIP_Actuals (Call_Node, Subp)); | |
e2441021 AC |
4245 | return; |
4246 | end; | |
4247 | end if; | |
4248 | ||
8c5b03a0 AC |
4249 | Formal := First_Formal (Subp); |
4250 | Actual := First_Actual (Call_Node); | |
fdce4bb7 | 4251 | Param_Count := 1; |
70482933 | 4252 | while Present (Formal) loop |
fbf5a39b AC |
4253 | -- Prepare to examine current entry |
4254 | ||
70482933 | 4255 | Prev := Actual; |
70482933 | 4256 | |
758c442c | 4257 | -- Ada 2005 (AI-251): Check if any formal is a class-wide interface |
2f1b20a9 | 4258 | -- to expand it in a further round. |
758c442c GD |
4259 | |
4260 | CW_Interface_Formals_Present := | |
4261 | CW_Interface_Formals_Present | |
5a644684 | 4262 | or else Is_Class_Wide_Interface_Type (Etype (Formal)); |
758c442c GD |
4263 | |
4264 | -- Create possible extra actual for constrained case. Usually, the | |
4265 | -- extra actual is of the form actual'constrained, but since this | |
4266 | -- attribute is only available for unconstrained records, TRUE is | |
4267 | -- expanded if the type of the formal happens to be constrained (for | |
4268 | -- instance when this procedure is inherited from an unconstrained | |
4269 | -- record to a constrained one) or if the actual has no discriminant | |
4270 | -- (its type is constrained). An exception to this is the case of a | |
4271 | -- private type without discriminants. In this case we pass FALSE | |
4272 | -- because the object has underlying discriminants with defaults. | |
70482933 RK |
4273 | |
4274 | if Present (Extra_Constrained (Formal)) then | |
131c9aff | 4275 | if Is_Private_Type (Etype (Prev)) |
70482933 RK |
4276 | and then not Has_Discriminants (Base_Type (Etype (Prev))) |
4277 | then | |
01aef5ad | 4278 | Add_Extra_Actual |
683af98c AC |
4279 | (Expr => New_Occurrence_Of (Standard_False, Loc), |
4280 | EF => Extra_Constrained (Formal)); | |
70482933 RK |
4281 | |
4282 | elsif Is_Constrained (Etype (Formal)) | |
4283 | or else not Has_Discriminants (Etype (Prev)) | |
4284 | then | |
01aef5ad | 4285 | Add_Extra_Actual |
683af98c AC |
4286 | (Expr => New_Occurrence_Of (Standard_True, Loc), |
4287 | EF => Extra_Constrained (Formal)); | |
70482933 | 4288 | |
5d09245e AC |
4289 | -- Do not produce extra actuals for Unchecked_Union parameters. |
4290 | -- Jump directly to the end of the loop. | |
4291 | ||
4292 | elsif Is_Unchecked_Union (Base_Type (Etype (Actual))) then | |
4293 | goto Skip_Extra_Actual_Generation; | |
4294 | ||
70482933 RK |
4295 | else |
4296 | -- If the actual is a type conversion, then the constrained | |
4297 | -- test applies to the actual, not the target type. | |
4298 | ||
4299 | declare | |
2f1b20a9 | 4300 | Act_Prev : Node_Id; |
70482933 RK |
4301 | |
4302 | begin | |
2f1b20a9 ES |
4303 | -- Test for unchecked conversions as well, which can occur |
4304 | -- as out parameter actuals on calls to stream procedures. | |
70482933 | 4305 | |
2f1b20a9 | 4306 | Act_Prev := Prev; |
4a08c95c AC |
4307 | while Nkind (Act_Prev) in N_Type_Conversion |
4308 | | N_Unchecked_Type_Conversion | |
fbf5a39b | 4309 | loop |
70482933 | 4310 | Act_Prev := Expression (Act_Prev); |
fbf5a39b | 4311 | end loop; |
70482933 | 4312 | |
3563739b AC |
4313 | -- If the expression is a conversion of a dereference, this |
4314 | -- is internally generated code that manipulates addresses, | |
4315 | -- e.g. when building interface tables. No check should | |
4316 | -- occur in this case, and the discriminated object is not | |
df5f901c | 4317 | -- directly at hand. |
f4d379b8 HK |
4318 | |
4319 | if not Comes_From_Source (Actual) | |
4320 | and then Nkind (Actual) = N_Unchecked_Type_Conversion | |
4321 | and then Nkind (Act_Prev) = N_Explicit_Dereference | |
4322 | then | |
4323 | Add_Extra_Actual | |
683af98c AC |
4324 | (Expr => New_Occurrence_Of (Standard_False, Loc), |
4325 | EF => Extra_Constrained (Formal)); | |
f4d379b8 HK |
4326 | |
4327 | else | |
4328 | Add_Extra_Actual | |
683af98c AC |
4329 | (Expr => |
4330 | Make_Attribute_Reference (Sloc (Prev), | |
4331 | Prefix => | |
4332 | Duplicate_Subexpr_No_Checks | |
4333 | (Act_Prev, Name_Req => True), | |
4334 | Attribute_Name => Name_Constrained), | |
4335 | EF => Extra_Constrained (Formal)); | |
f4d379b8 | 4336 | end if; |
70482933 RK |
4337 | end; |
4338 | end if; | |
4339 | end if; | |
4340 | ||
4341 | -- Create possible extra actual for accessibility level | |
4342 | ||
bd4dc93d | 4343 | if Present (Extra_Accessibility (Formal)) then |
9d983bbf AC |
4344 | -- Ada 2005 (AI-251): Thunks must propagate the extra actuals of |
4345 | -- accessibility levels. | |
fdce4bb7 | 4346 | |
da1c23dd | 4347 | if Is_Thunk (Current_Scope) then |
fdce4bb7 JM |
4348 | declare |
4349 | Parm_Ent : Entity_Id; | |
4350 | ||
4351 | begin | |
4352 | if Is_Controlling_Actual (Actual) then | |
4353 | ||
4354 | -- Find the corresponding actual of the thunk | |
4355 | ||
4356 | Parm_Ent := First_Entity (Current_Scope); | |
4357 | for J in 2 .. Param_Count loop | |
4358 | Next_Entity (Parm_Ent); | |
4359 | end loop; | |
4360 | ||
8a49a499 | 4361 | -- Handle unchecked conversion of access types generated |
5b5b27ad | 4362 | -- in thunks (cf. Expand_Interface_Thunk). |
8a49a499 AC |
4363 | |
4364 | elsif Is_Access_Type (Etype (Actual)) | |
4365 | and then Nkind (Actual) = N_Unchecked_Type_Conversion | |
4366 | then | |
4367 | Parm_Ent := Entity (Expression (Actual)); | |
4368 | ||
fdce4bb7 JM |
4369 | else pragma Assert (Is_Entity_Name (Actual)); |
4370 | Parm_Ent := Entity (Actual); | |
4371 | end if; | |
4372 | ||
4373 | Add_Extra_Actual | |
bcb8c3bb JS |
4374 | (Expr => Accessibility_Level |
4375 | (Expr => Parm_Ent, | |
4376 | Level => Dynamic_Level, | |
4377 | Allow_Alt_Model => False), | |
bd4dc93d | 4378 | EF => Extra_Accessibility (Formal)); |
fdce4bb7 JM |
4379 | end; |
4380 | ||
d7e20130 | 4381 | -- Conditional expressions |
01aef5ad | 4382 | |
d7e20130 | 4383 | elsif Nkind (Prev) = N_Expression_With_Actions |
66e97274 JS |
4384 | and then Nkind (Original_Node (Prev)) in |
4385 | N_If_Expression | N_Case_Expression | |
01aef5ad | 4386 | then |
d7e20130 | 4387 | Add_Cond_Expression_Extra_Actual (Formal); |
01aef5ad | 4388 | |
0053d729 JS |
4389 | -- Internal constant generated to remove side effects (normally |
4390 | -- from the expansion of dispatching calls). | |
4391 | ||
4392 | -- First verify the actual is internal | |
4393 | ||
4394 | elsif not Comes_From_Source (Prev) | |
d118bc58 | 4395 | and then not Is_Rewrite_Substitution (Prev) |
0053d729 JS |
4396 | |
4397 | -- Next check that the actual is a constant | |
4398 | ||
4399 | and then Nkind (Prev) = N_Identifier | |
4400 | and then Ekind (Entity (Prev)) = E_Constant | |
4401 | and then Nkind (Parent (Entity (Prev))) = N_Object_Declaration | |
4402 | then | |
4403 | -- Generate the accessibility level based on the expression in | |
4404 | -- the constant's declaration. | |
4405 | ||
52a7e4c7 JM |
4406 | declare |
4407 | Ent : Entity_Id := Entity (Prev); | |
4408 | ||
4409 | begin | |
4410 | -- Handle deferred constants | |
4411 | ||
4412 | if Present (Full_View (Ent)) then | |
4413 | Ent := Full_View (Ent); | |
4414 | end if; | |
4415 | ||
4416 | Add_Extra_Actual | |
4417 | (Expr => Accessibility_Level | |
4418 | (Expr => Expression (Parent (Ent)), | |
4419 | Level => Dynamic_Level, | |
4420 | Allow_Alt_Model => False), | |
4421 | EF => Extra_Accessibility (Formal)); | |
4422 | end; | |
0053d729 | 4423 | |
d7e20130 | 4424 | -- Normal case |
fdce4bb7 | 4425 | |
70482933 | 4426 | else |
d7e20130 | 4427 | Add_Extra_Actual |
bcb8c3bb JS |
4428 | (Expr => Accessibility_Level |
4429 | (Expr => Prev, | |
4430 | Level => Dynamic_Level, | |
4431 | Allow_Alt_Model => False), | |
d7e20130 | 4432 | EF => Extra_Accessibility (Formal)); |
70482933 RK |
4433 | end if; |
4434 | end if; | |
4435 | ||
2f1b20a9 | 4436 | -- Perform the check of 4.6(49) that prevents a null value from being |
b3f48fd4 AC |
4437 | -- passed as an actual to an access parameter. Note that the check |
4438 | -- is elided in the common cases of passing an access attribute or | |
2f1b20a9 ES |
4439 | -- access parameter as an actual. Also, we currently don't enforce |
4440 | -- this check for expander-generated actuals and when -gnatdj is set. | |
70482933 | 4441 | |
0791fbe9 | 4442 | if Ada_Version >= Ada_2005 then |
70482933 | 4443 | |
b3f48fd4 AC |
4444 | -- Ada 2005 (AI-231): Check null-excluding access types. Note that |
4445 | -- the intent of 6.4.1(13) is that null-exclusion checks should | |
4446 | -- not be done for 'out' parameters, even though it refers only | |
308e6f3a | 4447 | -- to constraint checks, and a null_exclusion is not a constraint. |
b3f48fd4 | 4448 | -- Note that AI05-0196-1 corrects this mistake in the RM. |
70482933 | 4449 | |
2f1b20a9 ES |
4450 | if Is_Access_Type (Etype (Formal)) |
4451 | and then Can_Never_Be_Null (Etype (Formal)) | |
b3f48fd4 | 4452 | and then Ekind (Formal) /= E_Out_Parameter |
2f1b20a9 | 4453 | and then Nkind (Prev) /= N_Raise_Constraint_Error |
d766cee3 | 4454 | and then (Known_Null (Prev) |
996c8821 | 4455 | or else not Can_Never_Be_Null (Etype (Prev))) |
2f1b20a9 ES |
4456 | then |
4457 | Install_Null_Excluding_Check (Prev); | |
4458 | end if; | |
70482933 | 4459 | |
0791fbe9 | 4460 | -- Ada_Version < Ada_2005 |
70482933 | 4461 | |
2f1b20a9 ES |
4462 | else |
4463 | if Ekind (Etype (Formal)) /= E_Anonymous_Access_Type | |
4464 | or else Access_Checks_Suppressed (Subp) | |
4465 | then | |
4466 | null; | |
70482933 | 4467 | |
2f1b20a9 ES |
4468 | elsif Debug_Flag_J then |
4469 | null; | |
70482933 | 4470 | |
2f1b20a9 ES |
4471 | elsif not Comes_From_Source (Prev) then |
4472 | null; | |
70482933 | 4473 | |
2f1b20a9 ES |
4474 | elsif Is_Entity_Name (Prev) |
4475 | and then Ekind (Etype (Prev)) = E_Anonymous_Access_Type | |
4476 | then | |
4477 | null; | |
2820d220 | 4478 | |
4a08c95c | 4479 | elsif Nkind (Prev) in N_Allocator | N_Attribute_Reference then |
2f1b20a9 ES |
4480 | null; |
4481 | ||
2f1b20a9 ES |
4482 | else |
4483 | Install_Null_Excluding_Check (Prev); | |
4484 | end if; | |
70482933 RK |
4485 | end if; |
4486 | ||
fbf5a39b AC |
4487 | -- Perform appropriate validity checks on parameters that |
4488 | -- are entities. | |
70482933 RK |
4489 | |
4490 | if Validity_Checks_On then | |
6cdb2c6e | 4491 | if (Ekind (Formal) = E_In_Parameter |
996c8821 | 4492 | and then Validity_Check_In_Params) |
6cdb2c6e AC |
4493 | or else |
4494 | (Ekind (Formal) = E_In_Out_Parameter | |
996c8821 | 4495 | and then Validity_Check_In_Out_Params) |
70482933 | 4496 | then |
7888a6ae GD |
4497 | -- If the actual is an indexed component of a packed type (or |
4498 | -- is an indexed or selected component whose prefix recursively | |
4499 | -- meets this condition), it has not been expanded yet. It will | |
4500 | -- be copied in the validity code that follows, and has to be | |
4501 | -- expanded appropriately, so reanalyze it. | |
08aa9a4a | 4502 | |
7888a6ae GD |
4503 | -- What we do is just to unset analyzed bits on prefixes till |
4504 | -- we reach something that does not have a prefix. | |
4505 | ||
4506 | declare | |
4507 | Nod : Node_Id; | |
4508 | ||
4509 | begin | |
4510 | Nod := Actual; | |
4a08c95c AC |
4511 | while Nkind (Nod) in |
4512 | N_Indexed_Component | N_Selected_Component | |
7888a6ae GD |
4513 | loop |
4514 | Set_Analyzed (Nod, False); | |
4515 | Nod := Prefix (Nod); | |
4516 | end loop; | |
4517 | end; | |
08aa9a4a | 4518 | |
70482933 | 4519 | Ensure_Valid (Actual); |
70482933 RK |
4520 | end if; |
4521 | end if; | |
4522 | ||
4523 | -- For IN OUT and OUT parameters, ensure that subscripts are valid | |
4524 | -- since this is a left side reference. We only do this for calls | |
4525 | -- from the source program since we assume that compiler generated | |
4526 | -- calls explicitly generate any required checks. We also need it | |
b3f48fd4 AC |
4527 | -- only if we are doing standard validity checks, since clearly it is |
4528 | -- not needed if validity checks are off, and in subscript validity | |
4529 | -- checking mode, all indexed components are checked with a call | |
4530 | -- directly from Expand_N_Indexed_Component. | |
70482933 | 4531 | |
6dfc5592 | 4532 | if Comes_From_Source (Call_Node) |
70482933 RK |
4533 | and then Ekind (Formal) /= E_In_Parameter |
4534 | and then Validity_Checks_On | |
4535 | and then Validity_Check_Default | |
4536 | and then not Validity_Check_Subscripts | |
4537 | then | |
4538 | Check_Valid_Lvalue_Subscripts (Actual); | |
4539 | end if; | |
4540 | ||
c8ef728f ES |
4541 | -- Mark any scalar OUT parameter that is a simple variable as no |
4542 | -- longer known to be valid (unless the type is always valid). This | |
4543 | -- reflects the fact that if an OUT parameter is never set in a | |
4544 | -- procedure, then it can become invalid on the procedure return. | |
fbf5a39b AC |
4545 | |
4546 | if Ekind (Formal) = E_Out_Parameter | |
4547 | and then Is_Entity_Name (Actual) | |
4548 | and then Ekind (Entity (Actual)) = E_Variable | |
4549 | and then not Is_Known_Valid (Etype (Actual)) | |
4550 | then | |
4551 | Set_Is_Known_Valid (Entity (Actual), False); | |
4552 | end if; | |
4553 | ||
c8ef728f ES |
4554 | -- For an OUT or IN OUT parameter, if the actual is an entity, then |
4555 | -- clear current values, since they can be clobbered. We are probably | |
4556 | -- doing this in more places than we need to, but better safe than | |
a90bd866 | 4557 | -- sorry when it comes to retaining bad current values. |
fbf5a39b AC |
4558 | |
4559 | if Ekind (Formal) /= E_In_Parameter | |
4560 | and then Is_Entity_Name (Actual) | |
67ce0d7e | 4561 | and then Present (Entity (Actual)) |
fbf5a39b | 4562 | then |
67ce0d7e RD |
4563 | declare |
4564 | Ent : constant Entity_Id := Entity (Actual); | |
4565 | Sav : Node_Id; | |
4566 | ||
4567 | begin | |
ac4d6407 RD |
4568 | -- For an OUT or IN OUT parameter that is an assignable entity, |
4569 | -- we do not want to clobber the Last_Assignment field, since | |
4570 | -- if it is set, it was precisely because it is indeed an OUT | |
a90bd866 | 4571 | -- or IN OUT parameter. We do reset the Is_Known_Valid flag |
75ba322d | 4572 | -- since the subprogram could have returned in invalid value. |
ac4d6407 | 4573 | |
13931a38 | 4574 | if Is_Assignable (Ent) then |
67ce0d7e RD |
4575 | Sav := Last_Assignment (Ent); |
4576 | Kill_Current_Values (Ent); | |
4577 | Set_Last_Assignment (Ent, Sav); | |
75ba322d | 4578 | Set_Is_Known_Valid (Ent, False); |
8f0303e7 | 4579 | Set_Is_True_Constant (Ent, False); |
67ce0d7e | 4580 | |
4bb43ffb | 4581 | -- For all other cases, just kill the current values |
67ce0d7e RD |
4582 | |
4583 | else | |
4584 | Kill_Current_Values (Ent); | |
4585 | end if; | |
4586 | end; | |
fbf5a39b AC |
4587 | end if; |
4588 | ||
475e1d24 | 4589 | -- If the formal is class-wide and the actual is an aggregate, force |
70482933 RK |
4590 | -- evaluation so that the back end who does not know about class-wide |
4591 | -- type, does not generate a temporary of the wrong size. | |
4592 | ||
4593 | if not Is_Class_Wide_Type (Etype (Formal)) then | |
4594 | null; | |
4595 | ||
4596 | elsif Nkind (Actual) = N_Aggregate | |
4597 | or else (Nkind (Actual) = N_Qualified_Expression | |
4598 | and then Nkind (Expression (Actual)) = N_Aggregate) | |
4599 | then | |
4600 | Force_Evaluation (Actual); | |
4601 | end if; | |
4602 | ||
4603 | -- In a remote call, if the formal is of a class-wide type, check | |
4604 | -- that the actual meets the requirements described in E.4(18). | |
4605 | ||
7888a6ae | 4606 | if Remote and then Is_Class_Wide_Type (Etype (Formal)) then |
70482933 | 4607 | Insert_Action (Actual, |
7888a6ae GD |
4608 | Make_Transportable_Check (Loc, |
4609 | Duplicate_Subexpr_Move_Checks (Actual))); | |
70482933 RK |
4610 | end if; |
4611 | ||
5f325af2 AC |
4612 | -- Perform invariant checks for all intermediate types in a view |
4613 | -- conversion after successful return from a call that passes the | |
4614 | -- view conversion as an IN OUT or OUT parameter (RM 7.3.2 (12/3, | |
4615 | -- 13/3, 14/3)). Consider only source conversion in order to avoid | |
4616 | -- generating spurious checks on complex expansion such as object | |
4617 | -- initialization through an extension aggregate. | |
84e13614 | 4618 | |
773e99ac | 4619 | if Comes_From_Source (Call_Node) |
5f325af2 | 4620 | and then Ekind (Formal) /= E_In_Parameter |
84e13614 JS |
4621 | and then Nkind (Actual) = N_Type_Conversion |
4622 | then | |
5f325af2 | 4623 | Add_View_Conversion_Invariants (Formal, Actual); |
84e13614 JS |
4624 | end if; |
4625 | ||
4f94fa11 AC |
4626 | -- Generating C the initialization of an allocator is performed by |
4627 | -- means of individual statements, and hence it must be done before | |
4628 | -- the call. | |
4629 | ||
4630 | if Modify_Tree_For_C | |
4631 | and then Nkind (Actual) = N_Allocator | |
4632 | and then Nkind (Expression (Actual)) = N_Qualified_Expression | |
4633 | then | |
4634 | Remove_Side_Effects (Actual); | |
4635 | end if; | |
4636 | ||
5d09245e AC |
4637 | -- This label is required when skipping extra actual generation for |
4638 | -- Unchecked_Union parameters. | |
4639 | ||
4640 | <<Skip_Extra_Actual_Generation>> | |
4641 | ||
fdce4bb7 | 4642 | Param_Count := Param_Count + 1; |
70482933 RK |
4643 | Next_Actual (Actual); |
4644 | Next_Formal (Formal); | |
4645 | end loop; | |
4646 | ||
bdf69d33 | 4647 | -- If we are calling an Ada 2012 function which needs to have the |
63585f75 SB |
4648 | -- "accessibility level determined by the point of call" (AI05-0234) |
4649 | -- passed in to it, then pass it in. | |
4650 | ||
4a08c95c | 4651 | if Ekind (Subp) in E_Function | E_Operator | E_Subprogram_Type |
57a3fca9 AC |
4652 | and then |
4653 | Present (Extra_Accessibility_Of_Result (Ultimate_Alias (Subp))) | |
63585f75 SB |
4654 | then |
4655 | declare | |
66e97274 JS |
4656 | Extra_Form : Node_Id := Empty; |
4657 | Level : Node_Id := Empty; | |
63585f75 SB |
4658 | |
4659 | begin | |
66e97274 JS |
4660 | -- Detect cases where the function call has been internally |
4661 | -- generated by examining the original node and return library | |
4662 | -- level - taking care to avoid ignoring function calls expanded | |
4663 | -- in prefix notation. | |
4664 | ||
4665 | if Nkind (Original_Node (Call_Node)) not in N_Function_Call | |
4666 | | N_Selected_Component | |
4667 | | N_Indexed_Component | |
4668 | then | |
4669 | Level := Make_Integer_Literal | |
4670 | (Loc, Scope_Depth (Standard_Standard)); | |
63585f75 | 4671 | |
66e97274 | 4672 | -- Otherwise get the level normally based on the call node |
63585f75 | 4673 | |
66e97274 | 4674 | else |
bcb8c3bb JS |
4675 | Level := Accessibility_Level |
4676 | (Expr => Call_Node, | |
4677 | Level => Dynamic_Level, | |
4678 | Allow_Alt_Model => False); | |
66e97274 | 4679 | end if; |
ebf494ec | 4680 | |
66e97274 JS |
4681 | -- It may be possible that we are re-expanding an already |
4682 | -- expanded call when are are dealing with dispatching ??? | |
63585f75 | 4683 | |
598409d3 | 4684 | if No (Parameter_Associations (Call_Node)) |
66e97274 JS |
4685 | or else Nkind (Last (Parameter_Associations (Call_Node))) |
4686 | /= N_Parameter_Association | |
4687 | or else not Is_Accessibility_Actual | |
4688 | (Last (Parameter_Associations (Call_Node))) | |
4689 | then | |
4690 | Extra_Form := Extra_Accessibility_Of_Result | |
4691 | (Ultimate_Alias (Subp)); | |
63585f75 | 4692 | |
57a3fca9 | 4693 | Add_Extra_Actual |
683af98c | 4694 | (Expr => Level, |
66e97274 | 4695 | EF => Extra_Form); |
63585f75 SB |
4696 | end if; |
4697 | end; | |
4698 | end if; | |
4699 | ||
4bb43ffb | 4700 | -- If we are expanding the RHS of an assignment we need to check if tag |
c8ef728f ES |
4701 | -- propagation is needed. You might expect this processing to be in |
4702 | -- Analyze_Assignment but has to be done earlier (bottom-up) because the | |
4703 | -- assignment might be transformed to a declaration for an unconstrained | |
4704 | -- value if the expression is classwide. | |
70482933 | 4705 | |
6dfc5592 RD |
4706 | if Nkind (Call_Node) = N_Function_Call |
4707 | and then Is_Tag_Indeterminate (Call_Node) | |
4708 | and then Is_Entity_Name (Name (Call_Node)) | |
70482933 RK |
4709 | then |
4710 | declare | |
4711 | Ass : Node_Id := Empty; | |
4712 | ||
4713 | begin | |
6dfc5592 RD |
4714 | if Nkind (Parent (Call_Node)) = N_Assignment_Statement then |
4715 | Ass := Parent (Call_Node); | |
70482933 | 4716 | |
6dfc5592 | 4717 | elsif Nkind (Parent (Call_Node)) = N_Qualified_Expression |
3cae7f14 RD |
4718 | and then Nkind (Parent (Parent (Call_Node))) = |
4719 | N_Assignment_Statement | |
70482933 | 4720 | then |
6dfc5592 | 4721 | Ass := Parent (Parent (Call_Node)); |
02822a92 | 4722 | |
6dfc5592 | 4723 | elsif Nkind (Parent (Call_Node)) = N_Explicit_Dereference |
3cae7f14 RD |
4724 | and then Nkind (Parent (Parent (Call_Node))) = |
4725 | N_Assignment_Statement | |
02822a92 | 4726 | then |
6dfc5592 | 4727 | Ass := Parent (Parent (Call_Node)); |
70482933 RK |
4728 | end if; |
4729 | ||
4730 | if Present (Ass) | |
4731 | and then Is_Class_Wide_Type (Etype (Name (Ass))) | |
4732 | then | |
2d6f6e08 AC |
4733 | -- Move the error messages below to sem??? |
4734 | ||
6dfc5592 RD |
4735 | if Is_Access_Type (Etype (Call_Node)) then |
4736 | if Designated_Type (Etype (Call_Node)) /= | |
02822a92 RD |
4737 | Root_Type (Etype (Name (Ass))) |
4738 | then | |
4739 | Error_Msg_NE | |
a4f4dbdb AC |
4740 | ("tag-indeterminate expression must have designated " |
4741 | & "type& (RM 5.2 (6))", | |
3cae7f14 | 4742 | Call_Node, Root_Type (Etype (Name (Ass)))); |
02822a92 | 4743 | else |
6dfc5592 | 4744 | Propagate_Tag (Name (Ass), Call_Node); |
02822a92 RD |
4745 | end if; |
4746 | ||
6dfc5592 | 4747 | elsif Etype (Call_Node) /= Root_Type (Etype (Name (Ass))) then |
fbf5a39b | 4748 | Error_Msg_NE |
a4f4dbdb AC |
4749 | ("tag-indeterminate expression must have type & " |
4750 | & "(RM 5.2 (6))", | |
6dfc5592 | 4751 | Call_Node, Root_Type (Etype (Name (Ass)))); |
02822a92 | 4752 | |
fbf5a39b | 4753 | else |
6dfc5592 | 4754 | Propagate_Tag (Name (Ass), Call_Node); |
fbf5a39b AC |
4755 | end if; |
4756 | ||
4757 | -- The call will be rewritten as a dispatching call, and | |
4758 | -- expanded as such. | |
4759 | ||
70482933 RK |
4760 | return; |
4761 | end if; | |
4762 | end; | |
4763 | end if; | |
4764 | ||
758c442c | 4765 | -- Ada 2005 (AI-251): If some formal is a class-wide interface, expand |
23a9215f | 4766 | -- it to point to the correct secondary virtual table. |
758c442c | 4767 | |
d3b00ce3 | 4768 | if Nkind (Call_Node) in N_Subprogram_Call |
758c442c GD |
4769 | and then CW_Interface_Formals_Present |
4770 | then | |
6dfc5592 | 4771 | Expand_Interface_Actuals (Call_Node); |
758c442c GD |
4772 | end if; |
4773 | ||
475e1d24 JM |
4774 | -- Install class-wide preconditions runtime check when this is a |
4775 | -- dispatching primitive that has or inherits class-wide preconditions; | |
4776 | -- otherwise no runtime check is installed. | |
4777 | ||
4778 | if Nkind (Call_Node) in N_Subprogram_Call | |
4779 | and then Is_Dispatching_Operation (Subp) | |
4780 | then | |
4781 | Install_Class_Preconditions_Check (Call_Node); | |
4782 | end if; | |
4783 | ||
70482933 RK |
4784 | -- Deals with Dispatch_Call if we still have a call, before expanding |
4785 | -- extra actuals since this will be done on the re-analysis of the | |
b3f48fd4 AC |
4786 | -- dispatching call. Note that we do not try to shorten the actual list |
4787 | -- for a dispatching call, it would not make sense to do so. Expansion | |
535a8637 | 4788 | -- of dispatching calls is suppressed for VM targets, because the VM |
b3f48fd4 AC |
4789 | -- back-ends directly handle the generation of dispatching calls and |
4790 | -- would have to undo any expansion to an indirect call. | |
70482933 | 4791 | |
d3b00ce3 | 4792 | if Nkind (Call_Node) in N_Subprogram_Call |
6dfc5592 | 4793 | and then Present (Controlling_Argument (Call_Node)) |
70482933 | 4794 | then |
a3064769 AC |
4795 | if Tagged_Type_Expansion then |
4796 | Expand_Dispatching_Call (Call_Node); | |
4797 | ||
4798 | -- Expand_Dispatching_Call takes care of all the needed processing | |
4799 | ||
4800 | return; | |
4801 | end if; | |
4802 | ||
4803 | -- VM targets | |
4804 | ||
6dfc5592 | 4805 | declare |
dd386db0 | 4806 | Call_Typ : constant Entity_Id := Etype (Call_Node); |
6dfc5592 RD |
4807 | Typ : constant Entity_Id := Find_Dispatching_Type (Subp); |
4808 | Eq_Prim_Op : Entity_Id := Empty; | |
dd386db0 AC |
4809 | New_Call : Node_Id; |
4810 | Param : Node_Id; | |
4811 | Prev_Call : Node_Id; | |
fbf5a39b | 4812 | |
6dfc5592 | 4813 | begin |
a3064769 AC |
4814 | Apply_Tag_Checks (Call_Node); |
4815 | ||
6dfc5592 RD |
4816 | if not Is_Limited_Type (Typ) then |
4817 | Eq_Prim_Op := Find_Prim_Op (Typ, Name_Op_Eq); | |
4818 | end if; | |
fbf5a39b | 4819 | |
a3064769 AC |
4820 | -- If this is a dispatching "=", we must first compare the |
4821 | -- tags so we generate: x.tag = y.tag and then x = y | |
6dfc5592 | 4822 | |
a3064769 | 4823 | if Subp = Eq_Prim_Op then |
dd386db0 | 4824 | |
a3064769 AC |
4825 | -- Mark the node as analyzed to avoid reanalyzing this |
4826 | -- dispatching call (which would cause a never-ending loop) | |
4827 | ||
4828 | Prev_Call := Relocate_Node (Call_Node); | |
4829 | Set_Analyzed (Prev_Call); | |
4830 | ||
4831 | Param := First_Actual (Call_Node); | |
4832 | New_Call := | |
4833 | Make_And_Then (Loc, | |
4834 | Left_Opnd => | |
4835 | Make_Op_Eq (Loc, | |
4836 | Left_Opnd => | |
4837 | Make_Selected_Component (Loc, | |
4838 | Prefix => New_Value (Param), | |
4839 | Selector_Name => | |
4840 | New_Occurrence_Of | |
4841 | (First_Tag_Component (Typ), Loc)), | |
4842 | ||
4843 | Right_Opnd => | |
4844 | Make_Selected_Component (Loc, | |
4845 | Prefix => | |
4846 | Unchecked_Convert_To (Typ, | |
4847 | New_Value (Next_Actual (Param))), | |
4848 | Selector_Name => | |
4849 | New_Occurrence_Of | |
4850 | (First_Tag_Component (Typ), Loc))), | |
4851 | Right_Opnd => Prev_Call); | |
4852 | ||
4853 | Rewrite (Call_Node, New_Call); | |
4854 | Analyze_And_Resolve | |
4855 | (Call_Node, Call_Typ, Suppress => All_Checks); | |
4856 | end if; | |
dd386db0 | 4857 | |
a3064769 AC |
4858 | -- Expansion of a dispatching call results in an indirect call, |
4859 | -- which in turn causes current values to be killed (see | |
4860 | -- Resolve_Call), so on VM targets we do the call here to | |
4861 | -- ensure consistent warnings between VM and non-VM targets. | |
6dfc5592 | 4862 | |
a3064769 | 4863 | Kill_Current_Values; |
6dfc5592 RD |
4864 | |
4865 | -- If this is a dispatching "=" then we must update the reference | |
4866 | -- to the call node because we generated: | |
4867 | -- x.tag = y.tag and then x = y | |
4868 | ||
dd386db0 | 4869 | if Subp = Eq_Prim_Op then |
6dfc5592 RD |
4870 | Call_Node := Right_Opnd (Call_Node); |
4871 | end if; | |
4872 | end; | |
70f91180 | 4873 | end if; |
70482933 RK |
4874 | |
4875 | -- Similarly, expand calls to RCI subprograms on which pragma | |
4876 | -- All_Calls_Remote applies. The rewriting will be reanalyzed | |
b3f48fd4 AC |
4877 | -- later. Do this only when the call comes from source since we |
4878 | -- do not want such a rewriting to occur in expanded code. | |
70482933 | 4879 | |
6dfc5592 RD |
4880 | if Is_All_Remote_Call (Call_Node) then |
4881 | Expand_All_Calls_Remote_Subprogram_Call (Call_Node); | |
70482933 RK |
4882 | |
4883 | -- Similarly, do not add extra actuals for an entry call whose entity | |
4884 | -- is a protected procedure, or for an internal protected subprogram | |
4885 | -- call, because it will be rewritten as a protected subprogram call | |
4886 | -- and reanalyzed (see Expand_Protected_Subprogram_Call). | |
4887 | ||
4888 | elsif Is_Protected_Type (Scope (Subp)) | |
4a08c95c | 4889 | and then Ekind (Subp) in E_Procedure | E_Function |
70482933 RK |
4890 | then |
4891 | null; | |
4892 | ||
4893 | -- During that loop we gathered the extra actuals (the ones that | |
4894 | -- correspond to Extra_Formals), so now they can be appended. | |
4895 | ||
358e289d JM |
4896 | elsif Is_Non_Empty_List (Extra_Actuals) then |
4897 | declare | |
4898 | Num_Extra_Actuals : constant Nat := List_Length (Extra_Actuals); | |
4899 | ||
4900 | begin | |
4901 | while Is_Non_Empty_List (Extra_Actuals) loop | |
4902 | Add_Actual_Parameter (Remove_Head (Extra_Actuals)); | |
4903 | end loop; | |
4904 | ||
4905 | -- Add dummy extra BIP actuals if we are calling a function that | |
4906 | -- inherited the BIP extra actuals but does not require them. | |
4907 | ||
4908 | if Nkind (Call_Node) = N_Function_Call | |
4909 | and then Is_Build_In_Place_Function_Call (Call_Node) | |
4910 | and then not Is_True_Build_In_Place_Function_Call (Call_Node) | |
4911 | then | |
4912 | Add_Dummy_Build_In_Place_Actuals (Subp, | |
4913 | Num_Added_Extra_Actuals => Num_Extra_Actuals); | |
4914 | end if; | |
4915 | end; | |
4916 | ||
4917 | -- Add dummy extra BIP actuals if we are calling a function that | |
4918 | -- inherited the BIP extra actuals but does not require them. | |
4919 | ||
4920 | elsif Nkind (Call_Node) = N_Function_Call | |
4921 | and then Is_Build_In_Place_Function_Call (Call_Node) | |
4922 | and then not Is_True_Build_In_Place_Function_Call (Call_Node) | |
4923 | then | |
4924 | Add_Dummy_Build_In_Place_Actuals (Subp); | |
70482933 RK |
4925 | end if; |
4926 | ||
b3f48fd4 AC |
4927 | -- At this point we have all the actuals, so this is the point at which |
4928 | -- the various expansion activities for actuals is carried out. | |
f44fe430 | 4929 | |
ca1f6b29 | 4930 | Expand_Actuals (Call_Node, Subp, Post_Call); |
70482933 | 4931 | |
afa1ffd4 PT |
4932 | -- If it is a recursive call then call the internal procedure that |
4933 | -- verifies Subprogram_Variant contract (if present and enabled). | |
4934 | -- Detecting calls to subprogram aliases is necessary for recursive | |
4935 | -- calls in instances of generic subprograms, where the renaming of | |
4936 | -- the current subprogram is called. | |
4937 | ||
4938 | if Is_Subprogram (Subp) | |
ea0b5b65 | 4939 | and then not Is_Ignored_Ghost_Entity (Subp) |
afa1ffd4 PT |
4940 | and then Same_Or_Aliased_Subprograms (Subp, Current_Scope) |
4941 | then | |
4942 | Check_Subprogram_Variant; | |
4943 | end if; | |
4944 | ||
5f49133f AC |
4945 | -- Verify that the actuals do not share storage. This check must be done |
4946 | -- on the caller side rather that inside the subprogram to avoid issues | |
4947 | -- of parameter passing. | |
4948 | ||
4949 | if Check_Aliasing_Of_Parameters then | |
4950 | Apply_Parameter_Aliasing_Checks (Call_Node, Subp); | |
4951 | end if; | |
4952 | ||
b3f48fd4 AC |
4953 | -- If the subprogram is a renaming, or if it is inherited, replace it in |
4954 | -- the call with the name of the actual subprogram being called. If this | |
4955 | -- is a dispatching call, the run-time decides what to call. The Alias | |
4956 | -- attribute does not apply to entries. | |
70482933 | 4957 | |
6dfc5592 RD |
4958 | if Nkind (Call_Node) /= N_Entry_Call_Statement |
4959 | and then No (Controlling_Argument (Call_Node)) | |
70482933 | 4960 | and then Present (Parent_Subp) |
df3e68b1 | 4961 | and then not Is_Direct_Deep_Call (Subp) |
70482933 RK |
4962 | then |
4963 | if Present (Inherited_From_Formal (Subp)) then | |
4964 | Parent_Subp := Inherited_From_Formal (Subp); | |
4965 | else | |
b81a5940 | 4966 | Parent_Subp := Ultimate_Alias (Parent_Subp); |
70482933 RK |
4967 | end if; |
4968 | ||
c8ef728f ES |
4969 | -- The below setting of Entity is suspect, see F109-018 discussion??? |
4970 | ||
6dfc5592 | 4971 | Set_Entity (Name (Call_Node), Parent_Subp); |
70482933 | 4972 | |
d4817e3f HK |
4973 | -- Inspect all formals of derived subprogram Subp. Compare parameter |
4974 | -- types with the parent subprogram and check whether an actual may | |
4975 | -- need a type conversion to the corresponding formal of the parent | |
4976 | -- subprogram. | |
70482933 | 4977 | |
d4817e3f | 4978 | -- Not clear whether intrinsic subprograms need such conversions. ??? |
70482933 RK |
4979 | |
4980 | if not Is_Intrinsic_Subprogram (Parent_Subp) | |
4981 | or else Is_Generic_Instance (Parent_Subp) | |
4982 | then | |
d4817e3f HK |
4983 | declare |
4984 | procedure Convert (Act : Node_Id; Typ : Entity_Id); | |
4985 | -- Rewrite node Act as a type conversion of Act to Typ. Analyze | |
4986 | -- and resolve the newly generated construct. | |
70482933 | 4987 | |
d4817e3f HK |
4988 | ------------- |
4989 | -- Convert -- | |
4990 | ------------- | |
70482933 | 4991 | |
d4817e3f HK |
4992 | procedure Convert (Act : Node_Id; Typ : Entity_Id) is |
4993 | begin | |
5126ca1f EB |
4994 | Rewrite (Act, OK_Convert_To (Typ, Act)); |
4995 | Analyze_And_Resolve (Act, Typ); | |
d4817e3f HK |
4996 | end Convert; |
4997 | ||
4998 | -- Local variables | |
4999 | ||
5000 | Actual_Typ : Entity_Id; | |
5001 | Formal_Typ : Entity_Id; | |
5002 | Parent_Typ : Entity_Id; | |
5003 | ||
5004 | begin | |
6dfc5592 | 5005 | Actual := First_Actual (Call_Node); |
d4817e3f HK |
5006 | Formal := First_Formal (Subp); |
5007 | Parent_Formal := First_Formal (Parent_Subp); | |
5008 | while Present (Formal) loop | |
5009 | Actual_Typ := Etype (Actual); | |
5010 | Formal_Typ := Etype (Formal); | |
5011 | Parent_Typ := Etype (Parent_Formal); | |
5012 | ||
5126ca1f EB |
5013 | -- For an IN parameter of a scalar type, the derived formal |
5014 | -- type and parent formal type differ, and the parent formal | |
d4817e3f HK |
5015 | -- type and actual type do not match statically. |
5016 | ||
5017 | if Is_Scalar_Type (Formal_Typ) | |
5018 | and then Ekind (Formal) = E_In_Parameter | |
5019 | and then Formal_Typ /= Parent_Typ | |
5020 | and then | |
5021 | not Subtypes_Statically_Match (Parent_Typ, Actual_Typ) | |
5022 | and then not Raises_Constraint_Error (Actual) | |
5023 | then | |
5024 | Convert (Actual, Parent_Typ); | |
d79e621a | 5025 | |
d4817e3f HK |
5026 | -- For access types, the parent formal type and actual type |
5027 | -- differ. | |
5028 | ||
5029 | elsif Is_Access_Type (Formal_Typ) | |
5030 | and then Base_Type (Parent_Typ) /= Base_Type (Actual_Typ) | |
70482933 | 5031 | then |
d4817e3f HK |
5032 | if Ekind (Formal) /= E_In_Parameter then |
5033 | Convert (Actual, Parent_Typ); | |
5034 | ||
5035 | elsif Ekind (Parent_Typ) = E_Anonymous_Access_Type | |
5036 | and then Designated_Type (Parent_Typ) /= | |
5037 | Designated_Type (Actual_Typ) | |
5038 | and then not Is_Controlling_Formal (Formal) | |
5039 | then | |
5040 | -- This unchecked conversion is not necessary unless | |
5041 | -- inlining is enabled, because in that case the type | |
5042 | -- mismatch may become visible in the body about to be | |
5043 | -- inlined. | |
5044 | ||
5045 | Rewrite (Actual, | |
5126ca1f EB |
5046 | Unchecked_Convert_To (Parent_Typ, Actual)); |
5047 | Analyze_And_Resolve (Actual, Parent_Typ); | |
d4817e3f | 5048 | end if; |
70482933 | 5049 | |
ab01e614 AC |
5050 | -- If there is a change of representation, then generate a |
5051 | -- warning, and do the change of representation. | |
5052 | ||
3968b02a | 5053 | elsif not Has_Compatible_Representation |
e2f7d58c EB |
5054 | (Target_Typ => Formal_Typ, |
5055 | Operand_Typ => Parent_Typ) | |
3968b02a | 5056 | then |
ab01e614 AC |
5057 | Error_Msg_N |
5058 | ("??change of representation required", Actual); | |
5059 | Convert (Actual, Parent_Typ); | |
5060 | ||
d4817e3f HK |
5061 | -- For array and record types, the parent formal type and |
5062 | -- derived formal type have different sizes or pragma Pack | |
5063 | -- status. | |
70482933 | 5064 | |
d4817e3f | 5065 | elsif ((Is_Array_Type (Formal_Typ) |
ab01e614 | 5066 | and then Is_Array_Type (Parent_Typ)) |
d4817e3f HK |
5067 | or else |
5068 | (Is_Record_Type (Formal_Typ) | |
ab01e614 | 5069 | and then Is_Record_Type (Parent_Typ))) |
b23cdc01 BD |
5070 | and then Known_Esize (Formal_Typ) |
5071 | and then Known_Esize (Parent_Typ) | |
d4817e3f HK |
5072 | and then |
5073 | (Esize (Formal_Typ) /= Esize (Parent_Typ) | |
ab01e614 AC |
5074 | or else Has_Pragma_Pack (Formal_Typ) /= |
5075 | Has_Pragma_Pack (Parent_Typ)) | |
d4817e3f HK |
5076 | then |
5077 | Convert (Actual, Parent_Typ); | |
70482933 | 5078 | end if; |
70482933 | 5079 | |
d4817e3f HK |
5080 | Next_Actual (Actual); |
5081 | Next_Formal (Formal); | |
5082 | Next_Formal (Parent_Formal); | |
5083 | end loop; | |
5084 | end; | |
70482933 RK |
5085 | end if; |
5086 | ||
5087 | Orig_Subp := Subp; | |
5088 | Subp := Parent_Subp; | |
5089 | end if; | |
5090 | ||
8a36a0cc AC |
5091 | -- Deal with case where call is an explicit dereference |
5092 | ||
6dfc5592 | 5093 | if Nkind (Name (Call_Node)) = N_Explicit_Dereference then |
70482933 | 5094 | |
773e99ac | 5095 | -- Handle case of access to protected subprogram type |
70482933 | 5096 | |
f937473f | 5097 | if Is_Access_Protected_Subprogram_Type |
6dfc5592 | 5098 | (Base_Type (Etype (Prefix (Name (Call_Node))))) |
70482933 | 5099 | then |
b3f48fd4 AC |
5100 | -- If this is a call through an access to protected operation, the |
5101 | -- prefix has the form (object'address, operation'access). Rewrite | |
5102 | -- as a for other protected calls: the object is the 1st parameter | |
5103 | -- of the list of actuals. | |
70482933 RK |
5104 | |
5105 | declare | |
5106 | Call : Node_Id; | |
5107 | Parm : List_Id; | |
5108 | Nam : Node_Id; | |
5109 | Obj : Node_Id; | |
6dfc5592 | 5110 | Ptr : constant Node_Id := Prefix (Name (Call_Node)); |
fbf5a39b AC |
5111 | |
5112 | T : constant Entity_Id := | |
5113 | Equivalent_Type (Base_Type (Etype (Ptr))); | |
5114 | ||
5115 | D_T : constant Entity_Id := | |
5116 | Designated_Type (Base_Type (Etype (Ptr))); | |
70482933 RK |
5117 | |
5118 | begin | |
f44fe430 RD |
5119 | Obj := |
5120 | Make_Selected_Component (Loc, | |
5121 | Prefix => Unchecked_Convert_To (T, Ptr), | |
5122 | Selector_Name => | |
5123 | New_Occurrence_Of (First_Entity (T), Loc)); | |
5124 | ||
5125 | Nam := | |
5126 | Make_Selected_Component (Loc, | |
5127 | Prefix => Unchecked_Convert_To (T, Ptr), | |
5128 | Selector_Name => | |
5129 | New_Occurrence_Of (Next_Entity (First_Entity (T)), Loc)); | |
70482933 | 5130 | |
02822a92 RD |
5131 | Nam := |
5132 | Make_Explicit_Dereference (Loc, | |
5133 | Prefix => Nam); | |
70482933 | 5134 | |
be035558 | 5135 | if Present (Parameter_Associations (Call_Node)) then |
6dfc5592 | 5136 | Parm := Parameter_Associations (Call_Node); |
70482933 RK |
5137 | else |
5138 | Parm := New_List; | |
5139 | end if; | |
5140 | ||
5141 | Prepend (Obj, Parm); | |
5142 | ||
5143 | if Etype (D_T) = Standard_Void_Type then | |
02822a92 RD |
5144 | Call := |
5145 | Make_Procedure_Call_Statement (Loc, | |
5146 | Name => Nam, | |
5147 | Parameter_Associations => Parm); | |
70482933 | 5148 | else |
02822a92 RD |
5149 | Call := |
5150 | Make_Function_Call (Loc, | |
5151 | Name => Nam, | |
5152 | Parameter_Associations => Parm); | |
70482933 RK |
5153 | end if; |
5154 | ||
6dfc5592 | 5155 | Set_First_Named_Actual (Call, First_Named_Actual (Call_Node)); |
70482933 RK |
5156 | Set_Etype (Call, Etype (D_T)); |
5157 | ||
5158 | -- We do not re-analyze the call to avoid infinite recursion. | |
5159 | -- We analyze separately the prefix and the object, and set | |
5160 | -- the checks on the prefix that would otherwise be emitted | |
5161 | -- when resolving a call. | |
5162 | ||
6dfc5592 | 5163 | Rewrite (Call_Node, Call); |
70482933 RK |
5164 | Analyze (Nam); |
5165 | Apply_Access_Check (Nam); | |
5166 | Analyze (Obj); | |
5167 | return; | |
5168 | end; | |
5169 | end if; | |
5170 | end if; | |
5171 | ||
5172 | -- If this is a call to an intrinsic subprogram, then perform the | |
5173 | -- appropriate expansion to the corresponding tree node and we | |
a90bd866 | 5174 | -- are all done (since after that the call is gone). |
70482933 | 5175 | |
98f01d53 AC |
5176 | -- In the case where the intrinsic is to be processed by the back end, |
5177 | -- the call to Expand_Intrinsic_Call will do nothing, which is fine, | |
b3f48fd4 AC |
5178 | -- since the idea in this case is to pass the call unchanged. If the |
5179 | -- intrinsic is an inherited unchecked conversion, and the derived type | |
5180 | -- is the target type of the conversion, we must retain it as the return | |
5181 | -- type of the expression. Otherwise the expansion below, which uses the | |
5182 | -- parent operation, will yield the wrong type. | |
98f01d53 | 5183 | |
70482933 | 5184 | if Is_Intrinsic_Subprogram (Subp) then |
6dfc5592 | 5185 | Expand_Intrinsic_Call (Call_Node, Subp); |
d766cee3 | 5186 | |
6dfc5592 | 5187 | if Nkind (Call_Node) = N_Unchecked_Type_Conversion |
d766cee3 RD |
5188 | and then Parent_Subp /= Orig_Subp |
5189 | and then Etype (Parent_Subp) /= Etype (Orig_Subp) | |
5190 | then | |
6dfc5592 | 5191 | Set_Etype (Call_Node, Etype (Orig_Subp)); |
d766cee3 RD |
5192 | end if; |
5193 | ||
70482933 RK |
5194 | return; |
5195 | end if; | |
5196 | ||
4a08c95c | 5197 | if Ekind (Subp) in E_Function | E_Procedure then |
b29def53 | 5198 | |
f68fc405 AC |
5199 | -- We perform a simple optimization on calls for To_Address by |
5200 | -- replacing them with an unchecked conversion. Not only is this | |
5201 | -- efficient, but it also avoids order of elaboration problems when | |
5202 | -- address clauses are inlined (address expression elaborated at the | |
ca1f6b29 | 5203 | -- wrong point). |
26a43556 | 5204 | |
f68fc405 | 5205 | -- We perform this optimization regardless of whether we are in the |
26a43556 | 5206 | -- main unit or in a unit in the context of the main unit, to ensure |
ca1f6b29 BD |
5207 | -- that the generated tree is the same in both cases, for CodePeer |
5208 | -- use. | |
26a43556 AC |
5209 | |
5210 | if Is_RTE (Subp, RE_To_Address) then | |
6dfc5592 | 5211 | Rewrite (Call_Node, |
26a43556 | 5212 | Unchecked_Convert_To |
6dfc5592 | 5213 | (RTE (RE_Address), Relocate_Node (First_Actual (Call_Node)))); |
26a43556 | 5214 | return; |
7d827255 | 5215 | |
7ec25b2b AC |
5216 | -- A call to a null procedure is replaced by a null statement, but we |
5217 | -- are not allowed to ignore possible side effects of the call, so we | |
5218 | -- make sure that actuals are evaluated. | |
23a9215f | 5219 | -- We also suppress this optimization for GNATcoverage. |
7d827255 | 5220 | |
66f95f60 AC |
5221 | elsif Is_Null_Procedure (Subp) |
5222 | and then not Opt.Suppress_Control_Flow_Optimizations | |
5223 | then | |
7d827255 AC |
5224 | Actual := First_Actual (Call_Node); |
5225 | while Present (Actual) loop | |
5226 | Remove_Side_Effects (Actual); | |
5227 | Next_Actual (Actual); | |
5228 | end loop; | |
5229 | ||
5230 | Rewrite (Call_Node, Make_Null_Statement (Loc)); | |
5231 | return; | |
8dbf3473 AC |
5232 | end if; |
5233 | ||
6c26bac2 | 5234 | -- Handle inlining. No action needed if the subprogram is not inlined |
f087ea44 | 5235 | |
6c26bac2 AC |
5236 | if not Is_Inlined (Subp) then |
5237 | null; | |
f087ea44 | 5238 | |
49209838 EB |
5239 | -- Front-end inlining of expression functions (performed also when |
5240 | -- back-end inlining is enabled). | |
b5f3c913 AC |
5241 | |
5242 | elsif Is_Inlinable_Expression_Function (Subp) then | |
773e99ac JS |
5243 | Rewrite |
5244 | (Call_Node, New_Copy (Expression_Of_Expression_Function (Subp))); | |
5245 | Analyze (Call_Node); | |
b5f3c913 AC |
5246 | return; |
5247 | ||
49209838 | 5248 | -- Handle front-end inlining |
84f4072a | 5249 | |
6c26bac2 | 5250 | elsif not Back_End_Inlining then |
a41ea816 | 5251 | Inlined_Subprogram : declare |
fbf5a39b AC |
5252 | Bod : Node_Id; |
5253 | Must_Inline : Boolean := False; | |
5254 | Spec : constant Node_Id := Unit_Declaration_Node (Subp); | |
a41ea816 | 5255 | |
70482933 | 5256 | begin |
2f1b20a9 ES |
5257 | -- Verify that the body to inline has already been seen, and |
5258 | -- that if the body is in the current unit the inlining does | |
5259 | -- not occur earlier. This avoids order-of-elaboration problems | |
5260 | -- in the back end. | |
5261 | ||
5262 | -- This should be documented in sinfo/einfo ??? | |
70482933 | 5263 | |
fbf5a39b AC |
5264 | if No (Spec) |
5265 | or else Nkind (Spec) /= N_Subprogram_Declaration | |
5266 | or else No (Body_To_Inline (Spec)) | |
70482933 | 5267 | then |
fbf5a39b AC |
5268 | Must_Inline := False; |
5269 | ||
26a43556 AC |
5270 | -- If this an inherited function that returns a private type, |
5271 | -- do not inline if the full view is an unconstrained array, | |
5272 | -- because such calls cannot be inlined. | |
5b4994bc AC |
5273 | |
5274 | elsif Present (Orig_Subp) | |
5275 | and then Is_Array_Type (Etype (Orig_Subp)) | |
5276 | and then not Is_Constrained (Etype (Orig_Subp)) | |
5277 | then | |
5278 | Must_Inline := False; | |
5279 | ||
84f4072a | 5280 | elsif In_Unfrozen_Instance (Scope (Subp)) then |
5b4994bc AC |
5281 | Must_Inline := False; |
5282 | ||
fbf5a39b AC |
5283 | else |
5284 | Bod := Body_To_Inline (Spec); | |
5285 | ||
6dfc5592 RD |
5286 | if (In_Extended_Main_Code_Unit (Call_Node) |
5287 | or else In_Extended_Main_Code_Unit (Parent (Call_Node)) | |
ac4d6407 | 5288 | or else Has_Pragma_Inline_Always (Subp)) |
fbf5a39b AC |
5289 | and then (not In_Same_Extended_Unit (Sloc (Bod), Loc) |
5290 | or else | |
5291 | Earlier_In_Extended_Unit (Sloc (Bod), Loc)) | |
5292 | then | |
5293 | Must_Inline := True; | |
5294 | ||
5295 | -- If we are compiling a package body that is not the main | |
5296 | -- unit, it must be for inlining/instantiation purposes, | |
5297 | -- in which case we inline the call to insure that the same | |
5298 | -- temporaries are generated when compiling the body by | |
5299 | -- itself. Otherwise link errors can occur. | |
5300 | ||
2820d220 AC |
5301 | -- If the function being called is itself in the main unit, |
5302 | -- we cannot inline, because there is a risk of double | |
5303 | -- elaboration and/or circularity: the inlining can make | |
5304 | -- visible a private entity in the body of the main unit, | |
5305 | -- that gigi will see before its sees its proper definition. | |
5306 | ||
7a1d54fa | 5307 | elsif not In_Extended_Main_Code_Unit (Call_Node) |
fbf5a39b AC |
5308 | and then In_Package_Body |
5309 | then | |
2820d220 | 5310 | Must_Inline := not In_Extended_Main_Source_Unit (Subp); |
1ba563f5 | 5311 | |
a968d80d | 5312 | -- Inline calls to _Wrapped_Statements when generating C |
1ba563f5 | 5313 | |
64f5d139 | 5314 | elsif Modify_Tree_For_C |
1ba563f5 | 5315 | and then In_Same_Extended_Unit (Sloc (Bod), Loc) |
a968d80d JS |
5316 | and then Chars (Name (Call_Node)) |
5317 | = Name_uWrapped_Statements | |
1ba563f5 AC |
5318 | then |
5319 | Must_Inline := True; | |
fbf5a39b AC |
5320 | end if; |
5321 | end if; | |
5322 | ||
5323 | if Must_Inline then | |
6dfc5592 | 5324 | Expand_Inlined_Call (Call_Node, Subp, Orig_Subp); |
70482933 RK |
5325 | |
5326 | else | |
fbf5a39b | 5327 | -- Let the back end handle it |
70482933 | 5328 | |
cf27c5a2 | 5329 | Add_Inlined_Body (Subp, Call_Node); |
70482933 RK |
5330 | |
5331 | if Front_End_Inlining | |
5332 | and then Nkind (Spec) = N_Subprogram_Declaration | |
7a1d54fa | 5333 | and then In_Extended_Main_Code_Unit (Call_Node) |
70482933 RK |
5334 | and then No (Body_To_Inline (Spec)) |
5335 | and then not Has_Completion (Subp) | |
5336 | and then In_Same_Extended_Unit (Sloc (Spec), Loc) | |
70482933 | 5337 | then |
fbf5a39b | 5338 | Cannot_Inline |
685bc70f AC |
5339 | ("cannot inline& (body not seen yet)?", |
5340 | Call_Node, Subp); | |
70482933 RK |
5341 | end if; |
5342 | end if; | |
a41ea816 | 5343 | end Inlined_Subprogram; |
84f4072a | 5344 | |
49209838 EB |
5345 | -- Front-end expansion of simple functions returning unconstrained |
5346 | -- types (see Check_And_Split_Unconstrained_Function). Note that the | |
5347 | -- case of a simple renaming (Body_To_Inline in N_Entity below, see | |
5348 | -- also Build_Renamed_Body) cannot be expanded here because this may | |
5349 | -- give rise to order-of-elaboration issues for the types of the | |
5350 | -- parameters of the subprogram, if any. | |
6c26bac2 | 5351 | |
49209838 EB |
5352 | elsif Present (Unit_Declaration_Node (Subp)) |
5353 | and then Nkind (Unit_Declaration_Node (Subp)) = | |
5354 | N_Subprogram_Declaration | |
5355 | and then Present (Body_To_Inline (Unit_Declaration_Node (Subp))) | |
5356 | and then | |
5357 | Nkind (Body_To_Inline (Unit_Declaration_Node (Subp))) not in | |
5358 | N_Entity | |
5359 | then | |
5360 | Expand_Inlined_Call (Call_Node, Subp, Orig_Subp); | |
5361 | ||
5362 | -- Back-end inlining either if optimization is enabled or the call is | |
5363 | -- required to be inlined. | |
5364 | ||
5365 | elsif Optimization_Level > 0 | |
5366 | or else Has_Pragma_Inline_Always (Subp) | |
6c26bac2 | 5367 | then |
cf27c5a2 | 5368 | Add_Inlined_Body (Subp, Call_Node); |
70482933 RK |
5369 | end if; |
5370 | end if; | |
5371 | ||
26a43556 AC |
5372 | -- Check for protected subprogram. This is either an intra-object call, |
5373 | -- or a protected function call. Protected procedure calls are rewritten | |
5374 | -- as entry calls and handled accordingly. | |
70482933 | 5375 | |
26a43556 AC |
5376 | -- In Ada 2005, this may be an indirect call to an access parameter that |
5377 | -- is an access_to_subprogram. In that case the anonymous type has a | |
5378 | -- scope that is a protected operation, but the call is a regular one. | |
6f76a257 | 5379 | -- In either case do not expand call if subprogram is eliminated. |
c8ef728f | 5380 | |
70482933 RK |
5381 | Scop := Scope (Subp); |
5382 | ||
6dfc5592 | 5383 | if Nkind (Call_Node) /= N_Entry_Call_Statement |
70482933 | 5384 | and then Is_Protected_Type (Scop) |
c8ef728f | 5385 | and then Ekind (Subp) /= E_Subprogram_Type |
6f76a257 | 5386 | and then not Is_Eliminated (Subp) |
70482933 | 5387 | then |
26a43556 AC |
5388 | -- If the call is an internal one, it is rewritten as a call to the |
5389 | -- corresponding unprotected subprogram. | |
70482933 | 5390 | |
6dfc5592 | 5391 | Expand_Protected_Subprogram_Call (Call_Node, Subp, Scop); |
70482933 RK |
5392 | end if; |
5393 | ||
df3e68b1 HK |
5394 | -- Functions returning controlled objects need special attention. If |
5395 | -- the return type is limited, then the context is initialization and | |
5396 | -- different processing applies. If the call is to a protected function, | |
5397 | -- the expansion above will call Expand_Call recursively. Otherwise the | |
8be71a90 | 5398 | -- function call is transformed into a reference to the result that has |
c901877f | 5399 | -- been built either on the primary or the secondary stack. |
70482933 | 5400 | |
c768e988 | 5401 | if Needs_Finalization (Etype (Subp)) then |
cd644ae2 PMR |
5402 | if not Is_Build_In_Place_Function_Call (Call_Node) |
5403 | and then | |
5404 | (No (First_Formal (Subp)) | |
3fc40cd7 PMR |
5405 | or else |
5406 | not Is_Concurrent_Record_Type (Etype (First_Formal (Subp)))) | |
cd644ae2 | 5407 | then |
c901877f EB |
5408 | Expand_Ctrl_Function_Call |
5409 | (Call_Node, Needs_Secondary_Stack (Etype (Subp))); | |
cd644ae2 | 5410 | |
c768e988 AC |
5411 | -- Build-in-place function calls which appear in anonymous contexts |
5412 | -- need a transient scope to ensure the proper finalization of the | |
5413 | -- intermediate result after its use. | |
5414 | ||
cd644ae2 | 5415 | elsif Is_Build_In_Place_Function_Call (Call_Node) |
4a08c95c AC |
5416 | and then Nkind (Parent (Unqual_Conv (Call_Node))) in |
5417 | N_Attribute_Reference | |
5418 | | N_Function_Call | |
5419 | | N_Indexed_Component | |
5420 | | N_Object_Renaming_Declaration | |
5421 | | N_Procedure_Call_Statement | |
5422 | | N_Selected_Component | |
5423 | | N_Slice | |
d2ca5779 PMR |
5424 | and then |
5425 | (Ekind (Current_Scope) /= E_Loop | |
773e99ac | 5426 | or else Nkind (Parent (Call_Node)) /= N_Function_Call |
bf0b180b EB |
5427 | or else not |
5428 | Is_Build_In_Place_Function_Call (Parent (Call_Node))) | |
c768e988 | 5429 | then |
bf0b180b | 5430 | Establish_Transient_Scope |
5cfde7a0 | 5431 | (Call_Node, Needs_Secondary_Stack (Etype (Subp))); |
c768e988 | 5432 | end if; |
70482933 | 5433 | end if; |
ca1f6b29 | 5434 | end Expand_Call_Helper; |
70482933 | 5435 | |
df3e68b1 HK |
5436 | ------------------------------- |
5437 | -- Expand_Ctrl_Function_Call -- | |
5438 | ------------------------------- | |
5439 | ||
c901877f EB |
5440 | procedure Expand_Ctrl_Function_Call (N : Node_Id; Use_Sec_Stack : Boolean) |
5441 | is | |
5442 | Par : constant Node_Id := Parent (N); | |
5443 | ||
df3e68b1 | 5444 | begin |
c901877f EB |
5445 | -- Optimization: if the returned value is returned again, then no need |
5446 | -- to copy/readjust/finalize, we can just pass the value through (see | |
5447 | -- Expand_N_Simple_Return_Statement), and thus no attachment is needed. | |
21b0ecb9 EB |
5448 | -- Note that simple return statements are distributed into conditional |
5449 | -- expressions but we may be invoked before this distribution is done. | |
c901877f | 5450 | |
21b0ecb9 EB |
5451 | if Nkind (Par) = N_Simple_Return_Statement |
5452 | or else (Nkind (Par) = N_If_Expression | |
5453 | and then Nkind (Parent (Par)) = N_Simple_Return_Statement) | |
5454 | or else (Nkind (Par) = N_Case_Expression_Alternative | |
5455 | and then | |
5456 | Nkind (Parent (Parent (Par))) = N_Simple_Return_Statement) | |
5457 | then | |
c901877f EB |
5458 | return; |
5459 | end if; | |
5460 | ||
5461 | -- Another optimization: if the returned value is used to initialize an | |
ea588d41 | 5462 | -- object, then no need to copy/readjust/finalize, we can initialize it |
1f038e84 EB |
5463 | -- in place. However, if the call returns on the secondary stack, then |
5464 | -- we need the expansion because we'll be renaming the temporary as the | |
f8f05af4 EB |
5465 | -- (permanent) object. We also apply it in the case of the expression of |
5466 | -- a delta aggregate, since it is used only to initialize a temporary. | |
ea588d41 | 5467 | |
f8f05af4 EB |
5468 | if Nkind (Par) in N_Object_Declaration | N_Delta_Aggregate |
5469 | and then Expression (Par) = N | |
5470 | and then not Use_Sec_Stack | |
5471 | then | |
df3e68b1 HK |
5472 | return; |
5473 | end if; | |
5474 | ||
5475 | -- Resolution is now finished, make sure we don't start analysis again | |
5476 | -- because of the duplication. | |
5477 | ||
5478 | Set_Analyzed (N); | |
5479 | ||
ca4b9801 | 5480 | -- Apply the transformation, unless it was already applied manually |
df3e68b1 | 5481 | |
ca4b9801 EB |
5482 | if Nkind (Par) /= N_Reference then |
5483 | Remove_Side_Effects (N); | |
5484 | end if; | |
df3e68b1 HK |
5485 | end Expand_Ctrl_Function_Call; |
5486 | ||
2b3d67a5 AC |
5487 | ---------------------------------------- |
5488 | -- Expand_N_Extended_Return_Statement -- | |
5489 | ---------------------------------------- | |
5490 | ||
5491 | -- If there is a Handled_Statement_Sequence, we rewrite this: | |
5492 | ||
5493 | -- return Result : T := <expression> do | |
5494 | -- <handled_seq_of_stms> | |
5495 | -- end return; | |
5496 | ||
5497 | -- to be: | |
5498 | ||
5499 | -- declare | |
5500 | -- Result : T := <expression>; | |
5501 | -- begin | |
5502 | -- <handled_seq_of_stms> | |
5503 | -- return Result; | |
5504 | -- end; | |
5505 | ||
5506 | -- Otherwise (no Handled_Statement_Sequence), we rewrite this: | |
5507 | ||
5508 | -- return Result : T := <expression>; | |
5509 | ||
5510 | -- to be: | |
5511 | ||
5512 | -- return <expression>; | |
5513 | ||
5514 | -- unless it's build-in-place or there's no <expression>, in which case | |
5515 | -- we generate: | |
5516 | ||
5517 | -- declare | |
5518 | -- Result : T := <expression>; | |
5519 | -- begin | |
5520 | -- return Result; | |
5521 | -- end; | |
5522 | ||
5523 | -- Note that this case could have been written by the user as an extended | |
5524 | -- return statement, or could have been transformed to this from a simple | |
5525 | -- return statement. | |
5526 | ||
5527 | -- That is, we need to have a reified return object if there are statements | |
5528 | -- (which might refer to it) or if we're doing build-in-place (so we can | |
5529 | -- set its address to the final resting place or if there is no expression | |
7d1d3a54 | 5530 | -- (in which case default initial values might need to be set)). |
2b3d67a5 AC |
5531 | |
5532 | procedure Expand_N_Extended_Return_Statement (N : Node_Id) is | |
4844a259 EB |
5533 | Loc : constant Source_Ptr := Sloc (N); |
5534 | Func_Id : constant Entity_Id := | |
5535 | Return_Applies_To (Return_Statement_Entity (N)); | |
5536 | Is_BIP_Func : constant Boolean := | |
5537 | Is_Build_In_Place_Function (Func_Id); | |
5538 | Ret_Obj_Id : constant Entity_Id := | |
5539 | First_Entity (Return_Statement_Entity (N)); | |
5540 | Ret_Obj_Decl : constant Node_Id := Parent (Ret_Obj_Id); | |
5541 | Ret_Typ : constant Entity_Id := Etype (Func_Id); | |
2b3d67a5 | 5542 | |
e5f2c03c | 5543 | function Move_Activation_Chain (Func_Id : Entity_Id) return Node_Id; |
2b3d67a5 AC |
5544 | -- Construct a call to System.Tasking.Stages.Move_Activation_Chain |
5545 | -- with parameters: | |
5546 | -- From current activation chain | |
5547 | -- To activation chain passed in by the caller | |
5548 | -- New_Master master passed in by the caller | |
e5f2c03c AC |
5549 | -- |
5550 | -- Func_Id is the entity of the function where the extended return | |
5551 | -- statement appears. | |
2b3d67a5 | 5552 | |
2b3d67a5 AC |
5553 | --------------------------- |
5554 | -- Move_Activation_Chain -- | |
5555 | --------------------------- | |
5556 | ||
e5f2c03c | 5557 | function Move_Activation_Chain (Func_Id : Entity_Id) return Node_Id is |
2b3d67a5 | 5558 | begin |
2b3d67a5 AC |
5559 | return |
5560 | Make_Procedure_Call_Statement (Loc, | |
2c1b72d7 | 5561 | Name => |
e4494292 | 5562 | New_Occurrence_Of (RTE (RE_Move_Activation_Chain), Loc), |
0613fb33 AC |
5563 | |
5564 | Parameter_Associations => New_List ( | |
5565 | ||
5566 | -- Source chain | |
5567 | ||
5568 | Make_Attribute_Reference (Loc, | |
5569 | Prefix => Make_Identifier (Loc, Name_uChain), | |
5570 | Attribute_Name => Name_Unrestricted_Access), | |
5571 | ||
5572 | -- Destination chain | |
5573 | ||
e4494292 | 5574 | New_Occurrence_Of |
e5f2c03c | 5575 | (Build_In_Place_Formal (Func_Id, BIP_Activation_Chain), Loc), |
0613fb33 AC |
5576 | |
5577 | -- New master | |
5578 | ||
e4494292 | 5579 | New_Occurrence_Of |
e5f2c03c | 5580 | (Build_In_Place_Formal (Func_Id, BIP_Task_Master), Loc))); |
2b3d67a5 AC |
5581 | end Move_Activation_Chain; |
5582 | ||
e5f2c03c AC |
5583 | -- Local variables |
5584 | ||
e5f2c03c AC |
5585 | Exp : Node_Id; |
5586 | HSS : Node_Id; | |
5587 | Result : Node_Id; | |
730814ed | 5588 | Stmts : List_Id := No_List; |
e5f2c03c | 5589 | |
dcd5fd67 PMR |
5590 | Return_Stmt : Node_Id := Empty; |
5591 | -- Force initialization to facilitate static analysis | |
5592 | ||
df3e68b1 | 5593 | -- Start of processing for Expand_N_Extended_Return_Statement |
2b3d67a5 | 5594 | |
df3e68b1 | 5595 | begin |
f6f4d8d4 JM |
5596 | -- Given that functionality of interface thunks is simple (just displace |
5597 | -- the pointer to the object) they are always handled by means of | |
5598 | -- simple return statements. | |
5599 | ||
76ed5f08 | 5600 | pragma Assert (not Is_Thunk (Current_Subprogram)); |
f6f4d8d4 | 5601 | |
df3e68b1 HK |
5602 | if Nkind (Ret_Obj_Decl) = N_Object_Declaration then |
5603 | Exp := Expression (Ret_Obj_Decl); | |
b3801819 PMR |
5604 | |
5605 | -- Assert that if F says "return R : T := G(...) do..." | |
5606 | -- then F and G are both b-i-p, or neither b-i-p. | |
5607 | ||
ea588d41 | 5608 | if Present (Exp) and then Nkind (Exp) = N_Function_Call then |
76ed5f08 | 5609 | pragma Assert (Ekind (Current_Subprogram) = E_Function); |
b3801819 | 5610 | pragma Assert |
76ed5f08 | 5611 | (Is_Build_In_Place_Function (Current_Subprogram) = |
358e289d | 5612 | Is_True_Build_In_Place_Function_Call (Exp)); |
b3801819 PMR |
5613 | null; |
5614 | end if; | |
c5a913d3 | 5615 | |
df3e68b1 HK |
5616 | else |
5617 | Exp := Empty; | |
5618 | end if; | |
2b3d67a5 | 5619 | |
df3e68b1 | 5620 | HSS := Handled_Statement_Sequence (N); |
2b3d67a5 | 5621 | |
df3e68b1 HK |
5622 | -- If the returned object needs finalization actions, the function must |
5623 | -- perform the appropriate cleanup should it fail to return. The state | |
5624 | -- of the function itself is tracked through a flag which is coupled | |
5625 | -- with the scope finalizer. There is one flag per each return object | |
f6bbf84e EB |
5626 | -- in case of multiple extended returns. Note that the flag has already |
5627 | -- been created if the extended return contains a nested return. | |
d4dfb005 | 5628 | |
f6bbf84e EB |
5629 | if Needs_Finalization (Etype (Ret_Obj_Id)) |
5630 | and then No (Status_Flag_Or_Transient_Decl (Ret_Obj_Id)) | |
5631 | then | |
5632 | Set_Status_Flag_Or_Transient_Decl | |
5633 | (Ret_Obj_Id, Build_Flag_For_Function (Func_Id)); | |
df3e68b1 | 5634 | end if; |
2b3d67a5 AC |
5635 | |
5636 | -- Build a simple_return_statement that returns the return object when | |
c1a69c98 EB |
5637 | -- there is a statement sequence, or no expression, or the analysis of |
5638 | -- the return object declaration generated extra actions, or the result | |
5639 | -- will be built in place. Note however that we currently do this for | |
5640 | -- all composite cases, even though they are not built in place. | |
2b3d67a5 | 5641 | |
df3e68b1 | 5642 | if Present (HSS) |
2b3d67a5 | 5643 | or else No (Exp) |
c1a69c98 EB |
5644 | or else List_Length (Return_Object_Declarations (N)) > 1 |
5645 | or else Is_Composite_Type (Ret_Typ) | |
2b3d67a5 | 5646 | then |
df3e68b1 HK |
5647 | if No (HSS) then |
5648 | Stmts := New_List; | |
2b3d67a5 AC |
5649 | |
5650 | -- If the extended return has a handled statement sequence, then wrap | |
5651 | -- it in a block and use the block as the first statement. | |
5652 | ||
5653 | else | |
df3e68b1 HK |
5654 | Stmts := New_List ( |
5655 | Make_Block_Statement (Loc, | |
2c1b72d7 | 5656 | Declarations => New_List, |
df3e68b1 | 5657 | Handled_Statement_Sequence => HSS)); |
2b3d67a5 AC |
5658 | end if; |
5659 | ||
df3e68b1 HK |
5660 | -- If the result type contains tasks, we call Move_Activation_Chain. |
5661 | -- Later, the cleanup code will call Complete_Master, which will | |
5662 | -- terminate any unactivated tasks belonging to the return statement | |
5663 | -- master. But Move_Activation_Chain updates their master to be that | |
5664 | -- of the caller, so they will not be terminated unless the return | |
5665 | -- statement completes unsuccessfully due to exception, abort, goto, | |
5666 | -- or exit. As a formality, we test whether the function requires the | |
5667 | -- result to be built in place, though that's necessarily true for | |
5668 | -- the case of result types with task parts. | |
2b3d67a5 | 5669 | |
e5f2c03c AC |
5670 | if Is_BIP_Func and then Has_Task (Ret_Typ) then |
5671 | ||
4a1bfefb AC |
5672 | -- The return expression is an aggregate for a complex type which |
5673 | -- contains tasks. This particular case is left unexpanded since | |
5674 | -- the regular expansion would insert all temporaries and | |
5675 | -- initialization code in the wrong block. | |
5676 | ||
5677 | if Nkind (Exp) = N_Aggregate then | |
5678 | Expand_N_Aggregate (Exp); | |
5679 | end if; | |
5680 | ||
1a36a0cd AC |
5681 | -- Do not move the activation chain if the return object does not |
5682 | -- contain tasks. | |
5683 | ||
5684 | if Has_Task (Etype (Ret_Obj_Id)) then | |
e5f2c03c | 5685 | Append_To (Stmts, Move_Activation_Chain (Func_Id)); |
1a36a0cd | 5686 | end if; |
2b3d67a5 AC |
5687 | end if; |
5688 | ||
df3e68b1 HK |
5689 | -- Update the state of the function right before the object is |
5690 | -- returned. | |
5691 | ||
2e135bdb | 5692 | if Needs_Finalization (Etype (Ret_Obj_Id)) then |
df3e68b1 | 5693 | declare |
35a1c212 | 5694 | Flag_Id : constant Entity_Id := |
3cebd1c0 | 5695 | Status_Flag_Or_Transient_Decl (Ret_Obj_Id); |
4fdebd93 | 5696 | |
df3e68b1 | 5697 | begin |
f6bbf84e EB |
5698 | pragma Assert (Present (Flag_Id)); |
5699 | ||
df3e68b1 HK |
5700 | -- Generate: |
5701 | -- Fnn := True; | |
5702 | ||
5703 | Append_To (Stmts, | |
5704 | Make_Assignment_Statement (Loc, | |
e4494292 RD |
5705 | Name => New_Occurrence_Of (Flag_Id, Loc), |
5706 | Expression => New_Occurrence_Of (Standard_True, Loc))); | |
df3e68b1 | 5707 | end; |
2b3d67a5 AC |
5708 | end if; |
5709 | ||
df3e68b1 | 5710 | HSS := Make_Handled_Sequence_Of_Statements (Loc, Stmts); |
2b3d67a5 AC |
5711 | end if; |
5712 | ||
df3e68b1 | 5713 | -- Case where we build a return statement block |
2b3d67a5 | 5714 | |
df3e68b1 | 5715 | if Present (HSS) then |
2b3d67a5 AC |
5716 | Result := |
5717 | Make_Block_Statement (Loc, | |
2c1b72d7 | 5718 | Declarations => Return_Object_Declarations (N), |
df3e68b1 | 5719 | Handled_Statement_Sequence => HSS); |
2b3d67a5 AC |
5720 | |
5721 | -- We set the entity of the new block statement to be that of the | |
5722 | -- return statement. This is necessary so that various fields, such | |
5723 | -- as Finalization_Chain_Entity carry over from the return statement | |
5724 | -- to the block. Note that this block is unusual, in that its entity | |
5725 | -- is an E_Return_Statement rather than an E_Block. | |
5726 | ||
5727 | Set_Identifier | |
5728 | (Result, New_Occurrence_Of (Return_Statement_Entity (N), Loc)); | |
5729 | ||
4844a259 | 5730 | -- Build a simple_return_statement that returns the return object |
2b3d67a5 | 5731 | |
4844a259 EB |
5732 | Return_Stmt := |
5733 | Make_Simple_Return_Statement (Loc, | |
5734 | Expression => New_Occurrence_Of (Ret_Obj_Id, Loc)); | |
5735 | Append_To (Stmts, Return_Stmt); | |
2b3d67a5 | 5736 | |
c1a69c98 EB |
5737 | -- Case where we do not need to build a block. But we're about to drop |
5738 | -- Return_Object_Declarations on the floor, so assert that it contains | |
5739 | -- only the return object declaration. | |
2b3d67a5 | 5740 | |
c1a69c98 | 5741 | else pragma Assert (List_Length (Return_Object_Declarations (N)) = 1); |
2b3d67a5 AC |
5742 | |
5743 | -- Build simple_return_statement that returns the expression directly | |
5744 | ||
df3e68b1 HK |
5745 | Return_Stmt := Make_Simple_Return_Statement (Loc, Expression => Exp); |
5746 | Result := Return_Stmt; | |
2b3d67a5 AC |
5747 | end if; |
5748 | ||
5749 | -- Set the flag to prevent infinite recursion | |
5750 | ||
df3e68b1 | 5751 | Set_Comes_From_Extended_Return_Statement (Return_Stmt); |
d315f859 | 5752 | Set_Return_Statement (Ret_Obj_Id, Return_Stmt); |
2b3d67a5 AC |
5753 | |
5754 | Rewrite (N, Result); | |
c5a913d3 EB |
5755 | |
5756 | -- AI12-043: The checks of 6.5(8.1/3) and 6.5(21/3) are made immediately | |
5757 | -- before an object is returned. A predicate that applies to the return | |
5758 | -- subtype is checked immediately before an object is returned. | |
5759 | ||
4844a259 | 5760 | Analyze (N); |
2b3d67a5 AC |
5761 | end Expand_N_Extended_Return_Statement; |
5762 | ||
70482933 RK |
5763 | ---------------------------- |
5764 | -- Expand_N_Function_Call -- | |
5765 | ---------------------------- | |
5766 | ||
5767 | procedure Expand_N_Function_Call (N : Node_Id) is | |
70482933 | 5768 | begin |
ac4d6407 | 5769 | Expand_Call (N); |
70482933 RK |
5770 | end Expand_N_Function_Call; |
5771 | ||
5772 | --------------------------------------- | |
5773 | -- Expand_N_Procedure_Call_Statement -- | |
5774 | --------------------------------------- | |
5775 | ||
5776 | procedure Expand_N_Procedure_Call_Statement (N : Node_Id) is | |
5777 | begin | |
1af4455a | 5778 | Expand_Call (N); |
70482933 RK |
5779 | end Expand_N_Procedure_Call_Statement; |
5780 | ||
eba1160f JS |
5781 | ------------------------------------ |
5782 | -- Expand_N_Return_When_Statement -- | |
5783 | ------------------------------------ | |
5784 | ||
5785 | procedure Expand_N_Return_When_Statement (N : Node_Id) is | |
5786 | Loc : constant Source_Ptr := Sloc (N); | |
5787 | begin | |
5788 | Rewrite (N, | |
5789 | Make_If_Statement (Loc, | |
5790 | Condition => Condition (N), | |
5791 | Then_Statements => New_List ( | |
5792 | Make_Simple_Return_Statement (Loc, | |
5793 | Expression => Expression (N))))); | |
5794 | ||
5795 | Analyze (N); | |
5796 | end Expand_N_Return_When_Statement; | |
5797 | ||
2b3d67a5 AC |
5798 | -------------------------------------- |
5799 | -- Expand_N_Simple_Return_Statement -- | |
5800 | -------------------------------------- | |
5801 | ||
5802 | procedure Expand_N_Simple_Return_Statement (N : Node_Id) is | |
5803 | begin | |
5804 | -- Defend against previous errors (i.e. the return statement calls a | |
5805 | -- function that is not available in configurable runtime). | |
5806 | ||
5807 | if Present (Expression (N)) | |
5808 | and then Nkind (Expression (N)) = N_Empty | |
5809 | then | |
ee2ba856 | 5810 | Check_Error_Detected; |
2b3d67a5 AC |
5811 | return; |
5812 | end if; | |
5813 | ||
5814 | -- Distinguish the function and non-function cases: | |
5815 | ||
5816 | case Ekind (Return_Applies_To (Return_Statement_Entity (N))) is | |
d8f43ee6 HK |
5817 | when E_Function |
5818 | | E_Generic_Function | |
5819 | => | |
2b3d67a5 AC |
5820 | Expand_Simple_Function_Return (N); |
5821 | ||
d8f43ee6 HK |
5822 | when E_Entry |
5823 | | E_Entry_Family | |
5824 | | E_Generic_Procedure | |
5825 | | E_Procedure | |
5826 | | E_Return_Statement | |
5827 | => | |
2b3d67a5 AC |
5828 | Expand_Non_Function_Return (N); |
5829 | ||
5830 | when others => | |
5831 | raise Program_Error; | |
5832 | end case; | |
5833 | ||
5834 | exception | |
5835 | when RE_Not_Available => | |
5836 | return; | |
5837 | end Expand_N_Simple_Return_Statement; | |
5838 | ||
70482933 RK |
5839 | ------------------------------ |
5840 | -- Expand_N_Subprogram_Body -- | |
5841 | ------------------------------ | |
5842 | ||
7888a6ae | 5843 | -- Add dummy push/pop label nodes at start and end to clear any local |
4a3b249c | 5844 | -- exception indications if local-exception-to-goto optimization is active. |
7888a6ae | 5845 | |
f44fe430 RD |
5846 | -- Add return statement if last statement in body is not a return statement |
5847 | -- (this makes things easier on Gigi which does not want to have to handle | |
5848 | -- a missing return). | |
70482933 RK |
5849 | |
5850 | -- Add call to Activate_Tasks if body is a task activator | |
5851 | ||
5852 | -- Deal with possible detection of infinite recursion | |
5853 | ||
5854 | -- Eliminate body completely if convention stubbed | |
5855 | ||
5856 | -- Encode entity names within body, since we will not need to reference | |
5857 | -- these entities any longer in the front end. | |
5858 | ||
5859 | -- Initialize scalar out parameters if Initialize/Normalize_Scalars | |
5860 | ||
c9a4817d | 5861 | -- Reset Pure indication if any parameter has root type System.Address |
199c6a10 AC |
5862 | -- or has any parameters of limited types, where limited means that the |
5863 | -- run-time view is limited (i.e. the full type is limited). | |
c9a4817d | 5864 | |
12e0c41c AC |
5865 | -- Wrap thread body |
5866 | ||
70482933 | 5867 | procedure Expand_N_Subprogram_Body (N : Node_Id) is |
1af4455a HK |
5868 | Body_Id : constant Entity_Id := Defining_Entity (N); |
5869 | HSS : constant Node_Id := Handled_Statement_Sequence (N); | |
5870 | Loc : constant Source_Ptr := Sloc (N); | |
70482933 | 5871 | |
2700b9c1 AC |
5872 | procedure Add_Return (Spec_Id : Entity_Id; Stmts : List_Id); |
5873 | -- Append a return statement to the statement sequence Stmts if the last | |
5874 | -- statement is not already a return or a goto statement. Note that the | |
5875 | -- latter test is not critical, it does not matter if we add a few extra | |
5876 | -- returns, since they get eliminated anyway later on. Spec_Id denotes | |
5877 | -- the corresponding spec of the subprogram body. | |
5878 | ||
70482933 RK |
5879 | ---------------- |
5880 | -- Add_Return -- | |
5881 | ---------------- | |
5882 | ||
2700b9c1 | 5883 | procedure Add_Return (Spec_Id : Entity_Id; Stmts : List_Id) is |
c9d70ab1 AC |
5884 | Last_Stmt : Node_Id; |
5885 | Loc : Source_Ptr; | |
5886 | Stmt : Node_Id; | |
12e0c41c AC |
5887 | |
5888 | begin | |
7888a6ae GD |
5889 | -- Get last statement, ignoring any Pop_xxx_Label nodes, which are |
5890 | -- not relevant in this context since they are not executable. | |
12e0c41c | 5891 | |
2700b9c1 | 5892 | Last_Stmt := Last (Stmts); |
c9d70ab1 AC |
5893 | while Nkind (Last_Stmt) in N_Pop_xxx_Label loop |
5894 | Prev (Last_Stmt); | |
7888a6ae | 5895 | end loop; |
12e0c41c | 5896 | |
7888a6ae | 5897 | -- Now insert return unless last statement is a transfer |
12e0c41c | 5898 | |
c9d70ab1 | 5899 | if not Is_Transfer (Last_Stmt) then |
12e0c41c | 5900 | |
7888a6ae GD |
5901 | -- The source location for the return is the end label of the |
5902 | -- procedure if present. Otherwise use the sloc of the last | |
5903 | -- statement in the list. If the list comes from a generated | |
5904 | -- exception handler and we are not debugging generated code, | |
5905 | -- all the statements within the handler are made invisible | |
5906 | -- to the debugger. | |
12e0c41c | 5907 | |
2700b9c1 AC |
5908 | if Nkind (Parent (Stmts)) = N_Exception_Handler |
5909 | and then not Comes_From_Source (Parent (Stmts)) | |
7888a6ae | 5910 | then |
c9d70ab1 | 5911 | Loc := Sloc (Last_Stmt); |
241ebe89 HK |
5912 | elsif Present (End_Label (HSS)) then |
5913 | Loc := Sloc (End_Label (HSS)); | |
7888a6ae | 5914 | else |
c9d70ab1 | 5915 | Loc := Sloc (Last_Stmt); |
7888a6ae | 5916 | end if; |
12e0c41c | 5917 | |
c9d70ab1 AC |
5918 | -- Append return statement, and set analyzed manually. We can't |
5919 | -- call Analyze on this return since the scope is wrong. | |
5334d18f | 5920 | |
c9d70ab1 AC |
5921 | -- Note: it almost works to push the scope and then do the Analyze |
5922 | -- call, but something goes wrong in some weird cases and it is | |
5923 | -- not worth worrying about ??? | |
5334d18f | 5924 | |
c9d70ab1 | 5925 | Stmt := Make_Simple_Return_Statement (Loc); |
5334d18f | 5926 | |
c9d70ab1 AC |
5927 | -- The return statement is handled properly, and the call to the |
5928 | -- postcondition, inserted below, does not require information | |
5929 | -- from the body either. However, that call is analyzed in the | |
5930 | -- enclosing scope, and an elaboration check might improperly be | |
5931 | -- added to it. A guard in Sem_Elab is needed to prevent that | |
5932 | -- spurious check, see Check_Elab_Call. | |
6a74a7b0 | 5933 | |
2700b9c1 | 5934 | Append_To (Stmts, Stmt); |
c9d70ab1 | 5935 | Set_Analyzed (Stmt); |
5334d18f | 5936 | |
81e68a19 | 5937 | -- Ada 2022 (AI12-0279): append the call to 'Yield unless this is |
8afbdb8a JM |
5938 | -- a generic subprogram (since in such case it will be added to |
5939 | -- the instantiations). | |
5940 | ||
5941 | if Has_Yield_Aspect (Spec_Id) | |
5942 | and then Ekind (Spec_Id) /= E_Generic_Procedure | |
5943 | and then RTE_Available (RE_Yield) | |
5944 | then | |
5945 | Insert_Action (Stmt, | |
5946 | Make_Procedure_Call_Statement (Loc, | |
5947 | New_Occurrence_Of (RTE (RE_Yield), Loc))); | |
5948 | end if; | |
12e0c41c | 5949 | end if; |
7888a6ae | 5950 | end Add_Return; |
12e0c41c | 5951 | |
4039e173 | 5952 | -- Local variables |
241ebe89 | 5953 | |
2700b9c1 AC |
5954 | Except_H : Node_Id; |
5955 | L : List_Id; | |
5956 | Spec_Id : Entity_Id; | |
5957 | ||
70482933 RK |
5958 | -- Start of processing for Expand_N_Subprogram_Body |
5959 | ||
5960 | begin | |
1af4455a HK |
5961 | if Present (Corresponding_Spec (N)) then |
5962 | Spec_Id := Corresponding_Spec (N); | |
5963 | else | |
5964 | Spec_Id := Body_Id; | |
5965 | end if; | |
241ebe89 | 5966 | |
90e7b558 AC |
5967 | -- If this is a Pure function which has any parameters whose root type |
5968 | -- is System.Address, reset the Pure indication. | |
5969 | -- This check is also performed when the subprogram is frozen, but we | |
5970 | -- repeat it on the body so that the indication is consistent, and so | |
5971 | -- it applies as well to bodies without separate specifications. | |
5972 | ||
5973 | if Is_Pure (Spec_Id) | |
5974 | and then Is_Subprogram (Spec_Id) | |
5975 | and then not Has_Pragma_Pure_Function (Spec_Id) | |
5976 | then | |
5977 | Check_Function_With_Address_Parameter (Spec_Id); | |
5978 | ||
5979 | if Spec_Id /= Body_Id then | |
5980 | Set_Is_Pure (Body_Id, Is_Pure (Spec_Id)); | |
5981 | end if; | |
5982 | end if; | |
5983 | ||
4a3b249c RD |
5984 | -- Set L to either the list of declarations if present, or to the list |
5985 | -- of statements if no declarations are present. This is used to insert | |
5986 | -- new stuff at the start. | |
70482933 RK |
5987 | |
5988 | if Is_Non_Empty_List (Declarations (N)) then | |
5989 | L := Declarations (N); | |
5990 | else | |
241ebe89 | 5991 | L := Statements (HSS); |
7888a6ae GD |
5992 | end if; |
5993 | ||
5994 | -- If local-exception-to-goto optimization active, insert dummy push | |
1adaea16 | 5995 | -- statements at start, and dummy pop statements at end, but inhibit |
2578936b PB |
5996 | -- this if we have No_Exception_Handlers or expanding a entry barrier |
5997 | -- function, since they are useless and interfere with analysis (e.g. by | |
5998 | -- CodePeer) and other optimizations. We also don't need these if we're | |
5999 | -- unnesting subprograms because the only purpose of these nodes is to | |
6000 | -- ensure we don't set a label in one subprogram and branch to it in | |
6001 | -- another. | |
7888a6ae GD |
6002 | |
6003 | if (Debug_Flag_Dot_G | |
6004 | or else Restriction_Active (No_Exception_Propagation)) | |
1adaea16 AC |
6005 | and then not Restriction_Active (No_Exception_Handlers) |
6006 | and then not CodePeer_Mode | |
2578936b | 6007 | and then not Is_Entry_Barrier_Function (N) |
3747db82 | 6008 | and then not Unnest_Subprogram_Mode |
7888a6ae GD |
6009 | and then Is_Non_Empty_List (L) |
6010 | then | |
6011 | declare | |
6012 | FS : constant Node_Id := First (L); | |
6013 | FL : constant Source_Ptr := Sloc (FS); | |
6014 | LS : Node_Id; | |
6015 | LL : Source_Ptr; | |
6016 | ||
6017 | begin | |
6018 | -- LS points to either last statement, if statements are present | |
6019 | -- or to the last declaration if there are no statements present. | |
6020 | -- It is the node after which the pop's are generated. | |
6021 | ||
241ebe89 HK |
6022 | if Is_Non_Empty_List (Statements (HSS)) then |
6023 | LS := Last (Statements (HSS)); | |
7888a6ae GD |
6024 | else |
6025 | LS := Last (L); | |
6026 | end if; | |
6027 | ||
6028 | LL := Sloc (LS); | |
6029 | ||
6030 | Insert_List_Before_And_Analyze (FS, New_List ( | |
6031 | Make_Push_Constraint_Error_Label (FL), | |
6032 | Make_Push_Program_Error_Label (FL), | |
6033 | Make_Push_Storage_Error_Label (FL))); | |
6034 | ||
6035 | Insert_List_After_And_Analyze (LS, New_List ( | |
6036 | Make_Pop_Constraint_Error_Label (LL), | |
6037 | Make_Pop_Program_Error_Label (LL), | |
6038 | Make_Pop_Storage_Error_Label (LL))); | |
6039 | end; | |
70482933 RK |
6040 | end if; |
6041 | ||
70482933 RK |
6042 | -- Initialize any scalar OUT args if Initialize/Normalize_Scalars |
6043 | ||
6044 | if Init_Or_Norm_Scalars and then Is_Subprogram (Spec_Id) then | |
6045 | declare | |
2f1b20a9 | 6046 | F : Entity_Id; |
05c064c1 | 6047 | A : Node_Id; |
70482933 RK |
6048 | |
6049 | begin | |
70482933 RK |
6050 | -- Loop through formals |
6051 | ||
2f1b20a9 | 6052 | F := First_Formal (Spec_Id); |
70482933 RK |
6053 | while Present (F) loop |
6054 | if Is_Scalar_Type (Etype (F)) | |
6055 | and then Ekind (F) = E_Out_Parameter | |
6056 | then | |
70f91180 RD |
6057 | Check_Restriction (No_Default_Initialization, F); |
6058 | ||
02822a92 RD |
6059 | -- Insert the initialization. We turn off validity checks |
6060 | -- for this assignment, since we do not want any check on | |
6061 | -- the initial value itself (which may well be invalid). | |
05c064c1 | 6062 | -- Predicate checks are disabled as well (RM 6.4.1 (13/3)) |
02822a92 | 6063 | |
c9d70ab1 AC |
6064 | A := |
6065 | Make_Assignment_Statement (Loc, | |
02822a92 | 6066 | Name => New_Occurrence_Of (F, Loc), |
05c064c1 AC |
6067 | Expression => Get_Simple_Init_Val (Etype (F), N)); |
6068 | Set_Suppress_Assignment_Checks (A); | |
6069 | ||
6070 | Insert_Before_And_Analyze (First (L), | |
6071 | A, Suppress => Validity_Check); | |
70482933 RK |
6072 | end if; |
6073 | ||
6074 | Next_Formal (F); | |
6075 | end loop; | |
70482933 RK |
6076 | end; |
6077 | end if; | |
6078 | ||
6079 | -- Clear out statement list for stubbed procedure | |
6080 | ||
6081 | if Present (Corresponding_Spec (N)) then | |
6082 | Set_Elaboration_Flag (N, Spec_Id); | |
6083 | ||
6084 | if Convention (Spec_Id) = Convention_Stubbed | |
6085 | or else Is_Eliminated (Spec_Id) | |
6086 | then | |
6087 | Set_Declarations (N, Empty_List); | |
6088 | Set_Handled_Statement_Sequence (N, | |
6089 | Make_Handled_Sequence_Of_Statements (Loc, | |
2c1b72d7 | 6090 | Statements => New_List (Make_Null_Statement (Loc)))); |
241ebe89 | 6091 | |
70482933 RK |
6092 | return; |
6093 | end if; | |
6094 | end if; | |
6095 | ||
70f91180 RD |
6096 | -- Create a set of discriminals for the next protected subprogram body |
6097 | ||
6098 | if Is_List_Member (N) | |
6099 | and then Present (Parent (List_Containing (N))) | |
6100 | and then Nkind (Parent (List_Containing (N))) = N_Protected_Body | |
6101 | and then Present (Next_Protected_Operation (N)) | |
6102 | then | |
6103 | Set_Discriminals (Parent (Base_Type (Scope (Spec_Id)))); | |
6104 | end if; | |
6105 | ||
4a3b249c RD |
6106 | -- Returns_By_Ref flag is normally set when the subprogram is frozen but |
6107 | -- subprograms with no specs are not frozen. | |
70482933 | 6108 | |
8926c29c | 6109 | Compute_Returns_By_Ref (Spec_Id); |
70482933 | 6110 | |
4a3b249c RD |
6111 | -- For a procedure, we add a return for all possible syntactic ends of |
6112 | -- the subprogram. | |
70482933 | 6113 | |
4a08c95c | 6114 | if Ekind (Spec_Id) in E_Procedure | E_Generic_Procedure then |
2700b9c1 | 6115 | Add_Return (Spec_Id, Statements (HSS)); |
70482933 | 6116 | |
241ebe89 HK |
6117 | if Present (Exception_Handlers (HSS)) then |
6118 | Except_H := First_Non_Pragma (Exception_Handlers (HSS)); | |
70482933 | 6119 | while Present (Except_H) loop |
2700b9c1 | 6120 | Add_Return (Spec_Id, Statements (Except_H)); |
70482933 RK |
6121 | Next_Non_Pragma (Except_H); |
6122 | end loop; | |
6123 | end if; | |
6124 | ||
98f01d53 AC |
6125 | -- For a function, we must deal with the case where there is at least |
6126 | -- one missing return. What we do is to wrap the entire body of the | |
6127 | -- function in a block: | |
70482933 RK |
6128 | |
6129 | -- begin | |
6130 | -- ... | |
6131 | -- end; | |
6132 | ||
6133 | -- becomes | |
6134 | ||
6135 | -- begin | |
6136 | -- begin | |
6137 | -- ... | |
6138 | -- end; | |
6139 | ||
6140 | -- raise Program_Error; | |
6141 | -- end; | |
6142 | ||
4a3b249c RD |
6143 | -- This approach is necessary because the raise must be signalled to the |
6144 | -- caller, not handled by any local handler (RM 6.4(11)). | |
70482933 | 6145 | |
4a3b249c RD |
6146 | -- Note: we do not need to analyze the constructed sequence here, since |
6147 | -- it has no handler, and an attempt to analyze the handled statement | |
6148 | -- sequence twice is risky in various ways (e.g. the issue of expanding | |
6149 | -- cleanup actions twice). | |
70482933 RK |
6150 | |
6151 | elsif Has_Missing_Return (Spec_Id) then | |
6152 | declare | |
241ebe89 | 6153 | Hloc : constant Source_Ptr := Sloc (HSS); |
70482933 RK |
6154 | Blok : constant Node_Id := |
6155 | Make_Block_Statement (Hloc, | |
241ebe89 | 6156 | Handled_Statement_Sequence => HSS); |
70482933 | 6157 | Rais : constant Node_Id := |
07fc65c4 GB |
6158 | Make_Raise_Program_Error (Hloc, |
6159 | Reason => PE_Missing_Return); | |
70482933 RK |
6160 | |
6161 | begin | |
6162 | Set_Handled_Statement_Sequence (N, | |
6163 | Make_Handled_Sequence_Of_Statements (Hloc, | |
6164 | Statements => New_List (Blok, Rais))); | |
6165 | ||
7888a6ae | 6166 | Push_Scope (Spec_Id); |
70482933 RK |
6167 | Analyze (Blok); |
6168 | Analyze (Rais); | |
6169 | Pop_Scope; | |
6170 | end; | |
6171 | end if; | |
6172 | ||
70482933 RK |
6173 | -- If subprogram contains a parameterless recursive call, then we may |
6174 | -- have an infinite recursion, so see if we can generate code to check | |
6175 | -- for this possibility if storage checks are not suppressed. | |
6176 | ||
6177 | if Ekind (Spec_Id) = E_Procedure | |
6178 | and then Has_Recursive_Call (Spec_Id) | |
6179 | and then not Storage_Checks_Suppressed (Spec_Id) | |
6180 | then | |
6181 | Detect_Infinite_Recursion (N, Spec_Id); | |
6182 | end if; | |
6183 | ||
70482933 RK |
6184 | -- Set to encode entity names in package body before gigi is called |
6185 | ||
6186 | Qualify_Entity_Names (N); | |
7327f5c2 AC |
6187 | |
6188 | -- If the body belongs to a nonabstract library-level source primitive | |
6189 | -- of a tagged type, install an elaboration check which ensures that a | |
6190 | -- dispatching call targeting the primitive will not execute the body | |
6191 | -- without it being previously elaborated. | |
6192 | ||
6193 | Install_Primitive_Elaboration_Check (N); | |
70482933 RK |
6194 | end Expand_N_Subprogram_Body; |
6195 | ||
6196 | ----------------------------------- | |
6197 | -- Expand_N_Subprogram_Body_Stub -- | |
6198 | ----------------------------------- | |
6199 | ||
6200 | procedure Expand_N_Subprogram_Body_Stub (N : Node_Id) is | |
31ae1b46 | 6201 | Bod : Node_Id; |
c37e6613 | 6202 | |
70482933 RK |
6203 | begin |
6204 | if Present (Corresponding_Body (N)) then | |
31ae1b46 AC |
6205 | Bod := Unit_Declaration_Node (Corresponding_Body (N)); |
6206 | ||
6207 | -- The body may have been expanded already when it is analyzed | |
6208 | -- through the subunit node. Do no expand again: it interferes | |
6209 | -- with the construction of unnesting tables when generating C. | |
6210 | ||
6211 | if not Analyzed (Bod) then | |
6212 | Expand_N_Subprogram_Body (Bod); | |
6213 | end if; | |
6214 | ||
6215 | -- Add full qualification to entities that may be created late | |
6216 | -- during unnesting. | |
6217 | ||
6218 | Qualify_Entity_Names (N); | |
70482933 | 6219 | end if; |
70482933 RK |
6220 | end Expand_N_Subprogram_Body_Stub; |
6221 | ||
6222 | ------------------------------------- | |
6223 | -- Expand_N_Subprogram_Declaration -- | |
6224 | ------------------------------------- | |
6225 | ||
70482933 RK |
6226 | -- If the declaration appears within a protected body, it is a private |
6227 | -- operation of the protected type. We must create the corresponding | |
6228 | -- protected subprogram an associated formals. For a normal protected | |
6229 | -- operation, this is done when expanding the protected type declaration. | |
6230 | ||
758c442c GD |
6231 | -- If the declaration is for a null procedure, emit null body |
6232 | ||
70482933 | 6233 | procedure Expand_N_Subprogram_Declaration (N : Node_Id) is |
2700b9c1 AC |
6234 | Loc : constant Source_Ptr := Sloc (N); |
6235 | Subp : constant Entity_Id := Defining_Entity (N); | |
6236 | ||
2700b9c1 AC |
6237 | -- Local variables |
6238 | ||
1af4455a | 6239 | Scop : constant Entity_Id := Scope (Subp); |
fbf5a39b | 6240 | Prot_Bod : Node_Id; |
241ebe89 | 6241 | Prot_Decl : Node_Id; |
fbf5a39b | 6242 | Prot_Id : Entity_Id; |
d79e7af5 | 6243 | Typ : Entity_Id; |
70482933 RK |
6244 | |
6245 | begin | |
2f1b20a9 ES |
6246 | -- Deal with case of protected subprogram. Do not generate protected |
6247 | -- operation if operation is flagged as eliminated. | |
70482933 RK |
6248 | |
6249 | if Is_List_Member (N) | |
6250 | and then Present (Parent (List_Containing (N))) | |
6251 | and then Nkind (Parent (List_Containing (N))) = N_Protected_Body | |
6252 | and then Is_Protected_Type (Scop) | |
6253 | then | |
6871ba5f AC |
6254 | if No (Protected_Body_Subprogram (Subp)) |
6255 | and then not Is_Eliminated (Subp) | |
6256 | then | |
fbf5a39b | 6257 | Prot_Decl := |
70482933 RK |
6258 | Make_Subprogram_Declaration (Loc, |
6259 | Specification => | |
6260 | Build_Protected_Sub_Specification | |
2f1b20a9 | 6261 | (N, Scop, Unprotected_Mode)); |
70482933 RK |
6262 | |
6263 | -- The protected subprogram is declared outside of the protected | |
6264 | -- body. Given that the body has frozen all entities so far, we | |
fbf5a39b | 6265 | -- analyze the subprogram and perform freezing actions explicitly. |
19590d70 GD |
6266 | -- including the generation of an explicit freeze node, to ensure |
6267 | -- that gigi has the proper order of elaboration. | |
fbf5a39b AC |
6268 | -- If the body is a subunit, the insertion point is before the |
6269 | -- stub in the parent. | |
70482933 RK |
6270 | |
6271 | Prot_Bod := Parent (List_Containing (N)); | |
6272 | ||
6273 | if Nkind (Parent (Prot_Bod)) = N_Subunit then | |
6274 | Prot_Bod := Corresponding_Stub (Parent (Prot_Bod)); | |
6275 | end if; | |
6276 | ||
fbf5a39b AC |
6277 | Insert_Before (Prot_Bod, Prot_Decl); |
6278 | Prot_Id := Defining_Unit_Name (Specification (Prot_Decl)); | |
19590d70 | 6279 | Set_Has_Delayed_Freeze (Prot_Id); |
70482933 | 6280 | |
7888a6ae | 6281 | Push_Scope (Scope (Scop)); |
fbf5a39b | 6282 | Analyze (Prot_Decl); |
6b958cec | 6283 | Freeze_Before (N, Prot_Id); |
fbf5a39b | 6284 | Set_Protected_Body_Subprogram (Subp, Prot_Id); |
70482933 RK |
6285 | Pop_Scope; |
6286 | end if; | |
758c442c | 6287 | |
54bf19e4 AC |
6288 | -- Ada 2005 (AI-348): Generate body for a null procedure. In most |
6289 | -- cases this is superfluous because calls to it will be automatically | |
6290 | -- inlined, but we definitely need the body if preconditions for the | |
b912db16 | 6291 | -- procedure are present, or if performing coverage analysis. |
02822a92 | 6292 | |
758c442c GD |
6293 | elsif Nkind (Specification (N)) = N_Procedure_Specification |
6294 | and then Null_Present (Specification (N)) | |
6295 | then | |
6296 | declare | |
e1f3cb58 | 6297 | Bod : constant Node_Id := Body_To_Inline (N); |
d6533e74 | 6298 | |
758c442c | 6299 | begin |
e1f3cb58 AC |
6300 | Set_Has_Completion (Subp, False); |
6301 | Append_Freeze_Action (Subp, Bod); | |
c73ae90f | 6302 | |
e1f3cb58 AC |
6303 | -- The body now contains raise statements, so calls to it will |
6304 | -- not be inlined. | |
c73ae90f | 6305 | |
e1f3cb58 | 6306 | Set_Is_Inlined (Subp, False); |
758c442c | 6307 | end; |
70482933 | 6308 | end if; |
2700b9c1 AC |
6309 | |
6310 | -- When generating C code, transform a function that returns a | |
6311 | -- constrained array type into a procedure with an out parameter | |
6312 | -- that carries the return value. | |
6313 | ||
638f5054 AC |
6314 | -- We skip this transformation for unchecked conversions, since they |
6315 | -- are not needed by the C generator (and this also produces cleaner | |
6316 | -- output). | |
6317 | ||
d79e7af5 AC |
6318 | Typ := Get_Fullest_View (Etype (Subp)); |
6319 | ||
b36ec518 | 6320 | if Transform_Function_Array |
2700b9c1 | 6321 | and then Nkind (Specification (N)) = N_Function_Specification |
d79e7af5 AC |
6322 | and then Is_Array_Type (Typ) |
6323 | and then Is_Constrained (Typ) | |
638f5054 | 6324 | and then not Is_Unchecked_Conversion_Instance (Subp) |
2700b9c1 | 6325 | then |
51b42ffa | 6326 | Build_Procedure_Form (N); |
2700b9c1 | 6327 | end if; |
70482933 RK |
6328 | end Expand_N_Subprogram_Declaration; |
6329 | ||
2b3d67a5 AC |
6330 | -------------------------------- |
6331 | -- Expand_Non_Function_Return -- | |
6332 | -------------------------------- | |
6333 | ||
6334 | procedure Expand_Non_Function_Return (N : Node_Id) is | |
6335 | pragma Assert (No (Expression (N))); | |
6336 | ||
c9d70ab1 AC |
6337 | Loc : constant Source_Ptr := Sloc (N); |
6338 | Scope_Id : Entity_Id := Return_Applies_To (Return_Statement_Entity (N)); | |
6339 | Kind : constant Entity_Kind := Ekind (Scope_Id); | |
6340 | Call : Node_Id; | |
6341 | Acc_Stat : Node_Id; | |
6342 | Goto_Stat : Node_Id; | |
6343 | Lab_Node : Node_Id; | |
2b3d67a5 AC |
6344 | |
6345 | begin | |
81e68a19 | 6346 | -- Ada 2022 (AI12-0279) |
8afbdb8a JM |
6347 | |
6348 | if Has_Yield_Aspect (Scope_Id) | |
6349 | and then RTE_Available (RE_Yield) | |
6350 | then | |
6351 | Insert_Action (N, | |
6352 | Make_Procedure_Call_Statement (Loc, | |
6353 | New_Occurrence_Of (RTE (RE_Yield), Loc))); | |
6354 | end if; | |
6355 | ||
2b3d67a5 AC |
6356 | -- If it is a return from a procedure do no extra steps |
6357 | ||
6358 | if Kind = E_Procedure or else Kind = E_Generic_Procedure then | |
6359 | return; | |
6360 | ||
6361 | -- If it is a nested return within an extended one, replace it with a | |
6362 | -- return of the previously declared return object. | |
6363 | ||
6364 | elsif Kind = E_Return_Statement then | |
f6bbf84e EB |
6365 | declare |
6366 | Ret_Obj_Id : constant Entity_Id := First_Entity (Scope_Id); | |
6367 | ||
6368 | Flag_Id : Entity_Id; | |
6369 | ||
6370 | begin | |
6371 | -- Apply the same processing as Expand_N_Extended_Return_Statement | |
6372 | -- if the returned object needs finalization actions. Note that we | |
6373 | -- are invoked before Expand_N_Extended_Return_Statement but there | |
6374 | -- may be multiple nested returns within the extended one. | |
6375 | ||
6376 | if Needs_Finalization (Etype (Ret_Obj_Id)) then | |
6377 | if Present (Status_Flag_Or_Transient_Decl (Ret_Obj_Id)) then | |
6378 | Flag_Id := Status_Flag_Or_Transient_Decl (Ret_Obj_Id); | |
6379 | else | |
6380 | Flag_Id := | |
6381 | Build_Flag_For_Function (Return_Applies_To (Scope_Id)); | |
6382 | Set_Status_Flag_Or_Transient_Decl (Ret_Obj_Id, Flag_Id); | |
6383 | end if; | |
6384 | ||
6385 | -- Generate: | |
6386 | -- Fnn := True; | |
6387 | ||
6388 | Insert_Action (N, | |
6389 | Make_Assignment_Statement (Loc, | |
6390 | Name => | |
6391 | New_Occurrence_Of (Flag_Id, Loc), | |
6392 | Expression => New_Occurrence_Of (Standard_True, Loc))); | |
6393 | end if; | |
6394 | ||
6395 | Rewrite (N, | |
6396 | Make_Simple_Return_Statement (Loc, | |
6397 | Expression => New_Occurrence_Of (Ret_Obj_Id, Loc))); | |
6398 | Set_Comes_From_Extended_Return_Statement (N); | |
6399 | Set_Return_Statement_Entity (N, Scope_Id); | |
6400 | Expand_Simple_Function_Return (N); | |
6401 | return; | |
6402 | end; | |
2b3d67a5 AC |
6403 | end if; |
6404 | ||
6405 | pragma Assert (Is_Entry (Scope_Id)); | |
6406 | ||
6407 | -- Look at the enclosing block to see whether the return is from an | |
6408 | -- accept statement or an entry body. | |
6409 | ||
6410 | for J in reverse 0 .. Scope_Stack.Last loop | |
6411 | Scope_Id := Scope_Stack.Table (J).Entity; | |
6412 | exit when Is_Concurrent_Type (Scope_Id); | |
6413 | end loop; | |
6414 | ||
6415 | -- If it is a return from accept statement it is expanded as call to | |
6416 | -- RTS Complete_Rendezvous and a goto to the end of the accept body. | |
6417 | ||
6418 | -- (cf : Expand_N_Accept_Statement, Expand_N_Selective_Accept, | |
6419 | -- Expand_N_Accept_Alternative in exp_ch9.adb) | |
6420 | ||
6421 | if Is_Task_Type (Scope_Id) then | |
6422 | ||
6423 | Call := | |
6424 | Make_Procedure_Call_Statement (Loc, | |
e4494292 | 6425 | Name => New_Occurrence_Of (RTE (RE_Complete_Rendezvous), Loc)); |
2b3d67a5 AC |
6426 | Insert_Before (N, Call); |
6427 | -- why not insert actions here??? | |
6428 | Analyze (Call); | |
6429 | ||
6430 | Acc_Stat := Parent (N); | |
6431 | while Nkind (Acc_Stat) /= N_Accept_Statement loop | |
6432 | Acc_Stat := Parent (Acc_Stat); | |
6433 | end loop; | |
6434 | ||
6435 | Lab_Node := Last (Statements | |
6436 | (Handled_Statement_Sequence (Acc_Stat))); | |
6437 | ||
6438 | Goto_Stat := Make_Goto_Statement (Loc, | |
6439 | Name => New_Occurrence_Of | |
6440 | (Entity (Identifier (Lab_Node)), Loc)); | |
6441 | ||
6442 | Set_Analyzed (Goto_Stat); | |
6443 | ||
6444 | Rewrite (N, Goto_Stat); | |
6445 | Analyze (N); | |
6446 | ||
6447 | -- If it is a return from an entry body, put a Complete_Entry_Body call | |
6448 | -- in front of the return. | |
6449 | ||
6450 | elsif Is_Protected_Type (Scope_Id) then | |
6451 | Call := | |
6452 | Make_Procedure_Call_Statement (Loc, | |
6453 | Name => | |
e4494292 | 6454 | New_Occurrence_Of (RTE (RE_Complete_Entry_Body), Loc), |
2b3d67a5 AC |
6455 | Parameter_Associations => New_List ( |
6456 | Make_Attribute_Reference (Loc, | |
2c1b72d7 | 6457 | Prefix => |
e4494292 | 6458 | New_Occurrence_Of |
2b3d67a5 | 6459 | (Find_Protection_Object (Current_Scope), Loc), |
2c1b72d7 | 6460 | Attribute_Name => Name_Unchecked_Access))); |
2b3d67a5 AC |
6461 | |
6462 | Insert_Before (N, Call); | |
6463 | Analyze (Call); | |
6464 | end if; | |
6465 | end Expand_Non_Function_Return; | |
6466 | ||
70482933 RK |
6467 | --------------------------------------- |
6468 | -- Expand_Protected_Object_Reference -- | |
6469 | --------------------------------------- | |
6470 | ||
6471 | function Expand_Protected_Object_Reference | |
6472 | (N : Node_Id; | |
02822a92 | 6473 | Scop : Entity_Id) return Node_Id |
70482933 RK |
6474 | is |
6475 | Loc : constant Source_Ptr := Sloc (N); | |
6476 | Corr : Entity_Id; | |
6477 | Rec : Node_Id; | |
6478 | Param : Entity_Id; | |
6479 | Proc : Entity_Id; | |
6480 | ||
6481 | begin | |
7675ad4f | 6482 | Rec := Make_Identifier (Loc, Name_uObject); |
70482933 RK |
6483 | Set_Etype (Rec, Corresponding_Record_Type (Scop)); |
6484 | ||
2f1b20a9 ES |
6485 | -- Find enclosing protected operation, and retrieve its first parameter, |
6486 | -- which denotes the enclosing protected object. If the enclosing | |
6487 | -- operation is an entry, we are immediately within the protected body, | |
6488 | -- and we can retrieve the object from the service entries procedure. A | |
16b05213 | 6489 | -- barrier function has the same signature as an entry. A barrier |
2f1b20a9 ES |
6490 | -- function is compiled within the protected object, but unlike |
6491 | -- protected operations its never needs locks, so that its protected | |
6492 | -- body subprogram points to itself. | |
70482933 RK |
6493 | |
6494 | Proc := Current_Scope; | |
ac243c84 | 6495 | while Present (Proc) and then Scope (Proc) /= Scop loop |
70482933 | 6496 | Proc := Scope (Proc); |
ac243c84 EB |
6497 | if Is_Subprogram (Proc) |
6498 | and then Present (Protected_Subprogram (Proc)) | |
6499 | then | |
6500 | Proc := Protected_Subprogram (Proc); | |
6501 | end if; | |
70482933 RK |
6502 | end loop; |
6503 | ||
6504 | Corr := Protected_Body_Subprogram (Proc); | |
6505 | ||
6506 | if No (Corr) then | |
6507 | ||
6508 | -- Previous error left expansion incomplete. | |
6509 | -- Nothing to do on this call. | |
6510 | ||
6511 | return Empty; | |
6512 | end if; | |
6513 | ||
6514 | Param := | |
6515 | Defining_Identifier | |
6516 | (First (Parameter_Specifications (Parent (Corr)))); | |
6517 | ||
b9696ffb AC |
6518 | if Is_Subprogram (Proc) and then Proc /= Corr then |
6519 | ||
98f01d53 | 6520 | -- Protected function or procedure |
70482933 RK |
6521 | |
6522 | Set_Entity (Rec, Param); | |
6523 | ||
2f1b20a9 ES |
6524 | -- Rec is a reference to an entity which will not be in scope when |
6525 | -- the call is reanalyzed, and needs no further analysis. | |
70482933 RK |
6526 | |
6527 | Set_Analyzed (Rec); | |
6528 | ||
6529 | else | |
2f1b20a9 ES |
6530 | -- Entry or barrier function for entry body. The first parameter of |
6531 | -- the entry body procedure is pointer to the object. We create a | |
6532 | -- local variable of the proper type, duplicating what is done to | |
6533 | -- define _object later on. | |
70482933 RK |
6534 | |
6535 | declare | |
c12beea0 | 6536 | Decls : List_Id; |
c8307596 | 6537 | Obj_Ptr : constant Entity_Id := Make_Temporary (Loc, 'T'); |
fbf5a39b | 6538 | |
70482933 RK |
6539 | begin |
6540 | Decls := New_List ( | |
6541 | Make_Full_Type_Declaration (Loc, | |
6542 | Defining_Identifier => Obj_Ptr, | |
2c1b72d7 | 6543 | Type_Definition => |
70482933 RK |
6544 | Make_Access_To_Object_Definition (Loc, |
6545 | Subtype_Indication => | |
e4494292 | 6546 | New_Occurrence_Of |
c12beea0 | 6547 | (Corresponding_Record_Type (Scop), Loc)))); |
70482933 RK |
6548 | |
6549 | Insert_Actions (N, Decls); | |
6b958cec | 6550 | Freeze_Before (N, Obj_Ptr); |
70482933 RK |
6551 | |
6552 | Rec := | |
6553 | Make_Explicit_Dereference (Loc, | |
2c1b72d7 AC |
6554 | Prefix => |
6555 | Unchecked_Convert_To (Obj_Ptr, | |
6556 | New_Occurrence_Of (Param, Loc))); | |
70482933 | 6557 | |
2f1b20a9 | 6558 | -- Analyze new actual. Other actuals in calls are already analyzed |
7888a6ae | 6559 | -- and the list of actuals is not reanalyzed after rewriting. |
70482933 RK |
6560 | |
6561 | Set_Parent (Rec, N); | |
6562 | Analyze (Rec); | |
6563 | end; | |
6564 | end if; | |
6565 | ||
6566 | return Rec; | |
6567 | end Expand_Protected_Object_Reference; | |
6568 | ||
6569 | -------------------------------------- | |
6570 | -- Expand_Protected_Subprogram_Call -- | |
6571 | -------------------------------------- | |
6572 | ||
6573 | procedure Expand_Protected_Subprogram_Call | |
6574 | (N : Node_Id; | |
6575 | Subp : Entity_Id; | |
6576 | Scop : Entity_Id) | |
6577 | is | |
f31dcd99 | 6578 | Rec : Node_Id; |
70482933 | 6579 | |
86ec3bfb AC |
6580 | procedure Expand_Internal_Init_Call; |
6581 | -- A call to an operation of the type may occur in the initialization | |
6582 | -- of a private component. In that case the prefix of the call is an | |
6583 | -- entity name and the call is treated as internal even though it | |
6584 | -- appears in code outside of the protected type. | |
6585 | ||
36295779 AC |
6586 | procedure Freeze_Called_Function; |
6587 | -- If it is a function call it can appear in elaboration code and | |
6588 | -- the called entity must be frozen before the call. This must be | |
6589 | -- done before the call is expanded, as the expansion may rewrite it | |
6590 | -- to something other than a call (e.g. a temporary initialized in a | |
6591 | -- transient block). | |
6592 | ||
86ec3bfb AC |
6593 | ------------------------------- |
6594 | -- Expand_Internal_Init_Call -- | |
6595 | ------------------------------- | |
6596 | ||
6597 | procedure Expand_Internal_Init_Call is | |
6598 | begin | |
6599 | -- If the context is a protected object (rather than a protected | |
6600 | -- type) the call itself is bound to raise program_error because | |
6601 | -- the protected body will not have been elaborated yet. This is | |
6602 | -- diagnosed subsequently in Sem_Elab. | |
6603 | ||
6604 | Freeze_Called_Function; | |
6605 | ||
6606 | -- The target of the internal call is the first formal of the | |
6607 | -- enclosing initialization procedure. | |
6608 | ||
6609 | Rec := New_Occurrence_Of (First_Formal (Current_Scope), Sloc (N)); | |
6610 | Build_Protected_Subprogram_Call (N, | |
6611 | Name => Name (N), | |
6612 | Rec => Rec, | |
6613 | External => False); | |
6614 | Analyze (N); | |
6615 | Resolve (N, Etype (Subp)); | |
6616 | end Expand_Internal_Init_Call; | |
6617 | ||
36295779 AC |
6618 | ---------------------------- |
6619 | -- Freeze_Called_Function -- | |
6620 | ---------------------------- | |
6621 | ||
6622 | procedure Freeze_Called_Function is | |
6623 | begin | |
6624 | if Ekind (Subp) = E_Function then | |
6625 | Freeze_Expression (Name (N)); | |
6626 | end if; | |
6627 | end Freeze_Called_Function; | |
6628 | ||
6629 | -- Start of processing for Expand_Protected_Subprogram_Call | |
6630 | ||
70482933 | 6631 | begin |
54bf19e4 AC |
6632 | -- If the protected object is not an enclosing scope, this is an inter- |
6633 | -- object function call. Inter-object procedure calls are expanded by | |
6634 | -- Exp_Ch9.Build_Simple_Entry_Call. The call is intra-object only if the | |
6635 | -- subprogram being called is in the protected body being compiled, and | |
6636 | -- if the protected object in the call is statically the enclosing type. | |
a77152ca | 6637 | -- The object may be a component of some other data structure, in which |
54bf19e4 | 6638 | -- case this must be handled as an inter-object call. |
70482933 | 6639 | |
7dee088c | 6640 | if not Scope_Within_Or_Same (Inner => Current_Scope, Outer => Scop) |
9ca67d3f | 6641 | or else Is_Entry_Wrapper (Current_Scope) |
f31dcd99 | 6642 | or else not Is_Entity_Name (Name (N)) |
70482933 RK |
6643 | then |
6644 | if Nkind (Name (N)) = N_Selected_Component then | |
6645 | Rec := Prefix (Name (N)); | |
6646 | ||
86ec3bfb | 6647 | elsif Nkind (Name (N)) = N_Indexed_Component then |
70482933 | 6648 | Rec := Prefix (Prefix (Name (N))); |
86ec3bfb | 6649 | |
5e127570 AC |
6650 | -- If this is a call within an entry wrapper, it appears within a |
6651 | -- precondition that calls another primitive of the synchronized | |
6652 | -- type. The target object of the call is the first actual on the | |
6653 | -- wrapper. Note that this is an external call, because the wrapper | |
6654 | -- is called outside of the synchronized object. This means that | |
6655 | -- an entry call to an entry with preconditions involves two | |
6656 | -- synchronized operations. | |
6657 | ||
6658 | elsif Ekind (Current_Scope) = E_Procedure | |
6659 | and then Is_Entry_Wrapper (Current_Scope) | |
6660 | then | |
6661 | Rec := New_Occurrence_Of (First_Entity (Current_Scope), Sloc (N)); | |
6662 | ||
6cdce506 ES |
6663 | -- A default parameter of a protected operation may be a call to |
6664 | -- a protected function of the type. This appears as an internal | |
6665 | -- call in the profile of the operation, but if the context is an | |
6666 | -- external call we must convert the call into an external one, | |
6667 | -- using the protected object that is the target, so that: | |
6668 | ||
6669 | -- Prot.P (F) | |
6670 | -- is transformed into | |
6671 | -- Prot.P (Prot.F) | |
6672 | ||
6673 | elsif Nkind (Parent (N)) = N_Procedure_Call_Statement | |
6674 | and then Nkind (Name (Parent (N))) = N_Selected_Component | |
6675 | and then Is_Protected_Type (Etype (Prefix (Name (Parent (N))))) | |
6676 | and then Is_Entity_Name (Name (N)) | |
6677 | and then Scope (Entity (Name (N))) = | |
92a68a04 | 6678 | Etype (Prefix (Name (Parent (N)))) |
6cdce506 ES |
6679 | then |
6680 | Rewrite (Name (N), | |
6681 | Make_Selected_Component (Sloc (N), | |
92a68a04 | 6682 | Prefix => New_Copy_Tree (Prefix (Name (Parent (N)))), |
6cdce506 | 6683 | Selector_Name => Relocate_Node (Name (N)))); |
92a68a04 | 6684 | |
6cdce506 ES |
6685 | Analyze_And_Resolve (N); |
6686 | return; | |
6687 | ||
86ec3bfb AC |
6688 | else |
6689 | -- If the context is the initialization procedure for a protected | |
6690 | -- type, the call is legal because the called entity must be a | |
6691 | -- function of that enclosing type, and this is treated as an | |
6692 | -- internal call. | |
6693 | ||
f31dcd99 HK |
6694 | pragma Assert |
6695 | (Is_Entity_Name (Name (N)) and then Inside_Init_Proc); | |
6696 | ||
86ec3bfb AC |
6697 | Expand_Internal_Init_Call; |
6698 | return; | |
70482933 RK |
6699 | end if; |
6700 | ||
36295779 | 6701 | Freeze_Called_Function; |
70482933 | 6702 | Build_Protected_Subprogram_Call (N, |
2c1b72d7 | 6703 | Name => New_Occurrence_Of (Subp, Sloc (N)), |
2ba1a7c7 | 6704 | Rec => Convert_Concurrent (Rec, Etype (Rec)), |
70482933 RK |
6705 | External => True); |
6706 | ||
6707 | else | |
6708 | Rec := Expand_Protected_Object_Reference (N, Scop); | |
6709 | ||
6710 | if No (Rec) then | |
6711 | return; | |
6712 | end if; | |
6713 | ||
36295779 | 6714 | Freeze_Called_Function; |
70482933 RK |
6715 | Build_Protected_Subprogram_Call (N, |
6716 | Name => Name (N), | |
6717 | Rec => Rec, | |
6718 | External => False); | |
70482933 RK |
6719 | end if; |
6720 | ||
811c6a85 | 6721 | -- Analyze and resolve the new call. The actuals have already been |
b0159fbe | 6722 | -- resolved, but expansion of a function call will add extra actuals |
811c6a85 AC |
6723 | -- if needed. Analysis of a procedure call already includes resolution. |
6724 | ||
6725 | Analyze (N); | |
6726 | ||
6727 | if Ekind (Subp) = E_Function then | |
6728 | Resolve (N, Etype (Subp)); | |
6729 | end if; | |
70482933 RK |
6730 | end Expand_Protected_Subprogram_Call; |
6731 | ||
2b3d67a5 AC |
6732 | ----------------------------------- |
6733 | -- Expand_Simple_Function_Return -- | |
6734 | ----------------------------------- | |
6735 | ||
54bf19e4 | 6736 | -- The "simple" comes from the syntax rule simple_return_statement. The |
a90bd866 | 6737 | -- semantics are not at all simple. |
2b3d67a5 AC |
6738 | |
6739 | procedure Expand_Simple_Function_Return (N : Node_Id) is | |
6740 | Loc : constant Source_Ptr := Sloc (N); | |
6741 | ||
6742 | Scope_Id : constant Entity_Id := | |
6743 | Return_Applies_To (Return_Statement_Entity (N)); | |
6744 | -- The function we are returning from | |
6745 | ||
6746 | R_Type : constant Entity_Id := Etype (Scope_Id); | |
6747 | -- The result type of the function | |
6748 | ||
6749 | Utyp : constant Entity_Id := Underlying_Type (R_Type); | |
de77a81b | 6750 | -- The underlying result type of the function |
2b3d67a5 | 6751 | |
81501d2b | 6752 | Exp : Node_Id := Expression (N); |
2b3d67a5 AC |
6753 | pragma Assert (Present (Exp)); |
6754 | ||
8861bdd5 | 6755 | Exp_Is_Function_Call : constant Boolean := |
de77a81b EB |
6756 | Nkind (Exp) = N_Function_Call |
6757 | or else | |
6758 | (Is_Captured_Function_Call (Exp) | |
6759 | and then Is_Related_To_Func_Return (Entity (Prefix (Exp)))); | |
6760 | -- If the expression is a captured function call, then we need to make | |
6761 | -- sure that the object doing the capture is properly recognized by the | |
6762 | -- Is_Related_To_Func_Return predicate; otherwise, if it is of a type | |
6763 | -- that needs finalization, Requires_Cleanup_Actions would return true | |
d990f34e | 6764 | -- because of this and Build_Finalizer would finalize it prematurely. |
8861bdd5 | 6765 | |
c5a913d3 | 6766 | Exp_Typ : constant Entity_Id := Etype (Exp); |
2b3d67a5 AC |
6767 | -- The type of the expression (not necessarily the same as R_Type) |
6768 | ||
6769 | Subtype_Ind : Node_Id; | |
54bf19e4 AC |
6770 | -- If the result type of the function is class-wide and the expression |
6771 | -- has a specific type, then we use the expression's type as the type of | |
6772 | -- the return object. In cases where the expression is an aggregate that | |
6773 | -- is built in place, this avoids the need for an expensive conversion | |
6774 | -- of the return object to the specific type on assignments to the | |
6775 | -- individual components. | |
2b3d67a5 | 6776 | |
da566eeb | 6777 | -- Start of processing for Expand_Simple_Function_Return |
c5a913d3 | 6778 | |
2b3d67a5 AC |
6779 | begin |
6780 | if Is_Class_Wide_Type (R_Type) | |
c5a913d3 | 6781 | and then not Is_Class_Wide_Type (Exp_Typ) |
81501d2b | 6782 | and then Nkind (Exp) /= N_Type_Conversion |
2b3d67a5 | 6783 | then |
c5a913d3 | 6784 | Subtype_Ind := New_Occurrence_Of (Exp_Typ, Loc); |
2b3d67a5 AC |
6785 | else |
6786 | Subtype_Ind := New_Occurrence_Of (R_Type, Loc); | |
81501d2b AC |
6787 | |
6788 | -- If the result type is class-wide and the expression is a view | |
6789 | -- conversion, the conversion plays no role in the expansion because | |
6790 | -- it does not modify the tag of the object. Remove the conversion | |
6791 | -- altogether to prevent tag overwriting. | |
6792 | ||
6793 | if Is_Class_Wide_Type (R_Type) | |
c5a913d3 | 6794 | and then not Is_Class_Wide_Type (Exp_Typ) |
81501d2b AC |
6795 | and then Nkind (Exp) = N_Type_Conversion |
6796 | then | |
6797 | Exp := Expression (Exp); | |
6798 | end if; | |
2b3d67a5 AC |
6799 | end if; |
6800 | ||
b3801819 PMR |
6801 | -- Assert that if F says "return G(...);" |
6802 | -- then F and G are both b-i-p, or neither b-i-p. | |
6803 | ||
6804 | if Nkind (Exp) = N_Function_Call then | |
6805 | pragma Assert (Ekind (Scope_Id) = E_Function); | |
6806 | pragma Assert | |
358e289d JM |
6807 | (Is_Build_In_Place_Function (Scope_Id) = |
6808 | Is_True_Build_In_Place_Function_Call (Exp)); | |
b3801819 PMR |
6809 | null; |
6810 | end if; | |
6811 | ||
cd644ae2 PMR |
6812 | -- For the case of a simple return that does not come from an |
6813 | -- extended return, in the case of build-in-place, we rewrite | |
6814 | -- "return <expression>;" to be: | |
2b3d67a5 AC |
6815 | |
6816 | -- return _anon_ : <return_subtype> := <expression> | |
6817 | ||
6818 | -- The expansion produced by Expand_N_Extended_Return_Statement will | |
6819 | -- contain simple return statements (for example, a block containing | |
6820 | -- simple return of the return object), which brings us back here with | |
6821 | -- Comes_From_Extended_Return_Statement set. The reason for the barrier | |
6822 | -- checking for a simple return that does not come from an extended | |
6823 | -- return is to avoid this infinite recursion. | |
6824 | ||
6825 | -- The reason for this design is that for Ada 2005 limited returns, we | |
6826 | -- need to reify the return object, so we can build it "in place", and | |
6827 | -- we need a block statement to hang finalization and tasking stuff. | |
6828 | ||
d4dfb005 BD |
6829 | pragma Assert |
6830 | (Comes_From_Extended_Return_Statement (N) | |
358e289d | 6831 | or else not Is_True_Build_In_Place_Function_Call (Exp) |
f1668c3d | 6832 | or else Has_BIP_Formals (Scope_Id)); |
d4dfb005 | 6833 | |
2b3d67a5 | 6834 | if not Comes_From_Extended_Return_Statement (N) |
d4dfb005 | 6835 | and then Is_Build_In_Place_Function (Scope_Id) |
f6f4d8d4 JM |
6836 | |
6837 | -- The functionality of interface thunks is simple and it is always | |
6838 | -- handled by means of simple return statements. This leaves their | |
6839 | -- expansion simple and clean. | |
6840 | ||
c5a913d3 | 6841 | and then not Is_Thunk (Scope_Id) |
2b3d67a5 AC |
6842 | then |
6843 | declare | |
6844 | Return_Object_Entity : constant Entity_Id := | |
6845 | Make_Temporary (Loc, 'R', Exp); | |
f6f4d8d4 | 6846 | |
2b3d67a5 AC |
6847 | Obj_Decl : constant Node_Id := |
6848 | Make_Object_Declaration (Loc, | |
6849 | Defining_Identifier => Return_Object_Entity, | |
6850 | Object_Definition => Subtype_Ind, | |
6851 | Expression => Exp); | |
6852 | ||
f6f4d8d4 JM |
6853 | Ext : constant Node_Id := |
6854 | Make_Extended_Return_Statement (Loc, | |
6855 | Return_Object_Declarations => New_List (Obj_Decl)); | |
2b3d67a5 AC |
6856 | -- Do not perform this high-level optimization if the result type |
6857 | -- is an interface because the "this" pointer must be displaced. | |
6858 | ||
6859 | begin | |
6860 | Rewrite (N, Ext); | |
6861 | Analyze (N); | |
6862 | return; | |
6863 | end; | |
6864 | end if; | |
6865 | ||
6866 | -- Here we have a simple return statement that is part of the expansion | |
6867 | -- of an extended return statement (either written by the user, or | |
6868 | -- generated by the above code). | |
6869 | ||
6870 | -- Always normalize C/Fortran boolean result. This is not always needed, | |
6871 | -- but it seems a good idea to minimize the passing around of non- | |
6872 | -- normalized values, and in any case this handles the processing of | |
6873 | -- barrier functions for protected types, which turn the condition into | |
6874 | -- a return statement. | |
6875 | ||
c5a913d3 | 6876 | if Is_Boolean_Type (Exp_Typ) and then Nonzero_Is_True (Exp_Typ) then |
2b3d67a5 | 6877 | Adjust_Condition (Exp); |
c5a913d3 | 6878 | Adjust_Result_Type (Exp, Exp_Typ); |
7c784ca0 EB |
6879 | |
6880 | -- The adjustment of the expression may have rewritten the return | |
6881 | -- statement itself, e.g. when it is turned into an if expression. | |
6882 | ||
6883 | if Nkind (N) /= N_Simple_Return_Statement then | |
6884 | return; | |
6885 | end if; | |
2b3d67a5 AC |
6886 | end if; |
6887 | ||
6888 | -- Do validity check if enabled for returns | |
6889 | ||
c5a913d3 | 6890 | if Validity_Checks_On and then Validity_Check_Returns then |
2b3d67a5 AC |
6891 | Ensure_Valid (Exp); |
6892 | end if; | |
6893 | ||
6894 | -- Check the result expression of a scalar function against the subtype | |
6895 | -- of the function by inserting a conversion. This conversion must | |
6896 | -- eventually be performed for other classes of types, but for now it's | |
17ea7fad | 6897 | -- only done for scalars ??? |
2b3d67a5 | 6898 | |
17ea7fad | 6899 | if Is_Scalar_Type (Exp_Typ) and then Exp_Typ /= R_Type then |
2b3d67a5 AC |
6900 | Rewrite (Exp, Convert_To (R_Type, Exp)); |
6901 | ||
6902 | -- The expression is resolved to ensure that the conversion gets | |
6903 | -- expanded to generate a possible constraint check. | |
6904 | ||
6905 | Analyze_And_Resolve (Exp, R_Type); | |
6906 | end if; | |
6907 | ||
6908 | -- Deal with returning variable length objects and controlled types | |
6909 | ||
89e037d0 | 6910 | -- Nothing to do if we are returning by reference |
2b3d67a5 | 6911 | |
89e037d0 EB |
6912 | if Is_Build_In_Place_Function (Scope_Id) then |
6913 | -- Prevent the reclamation of the secondary stack by all enclosing | |
6914 | -- blocks and loops as well as the related function; otherwise the | |
6915 | -- result would be reclaimed too early. | |
6916 | ||
6917 | if Needs_BIP_Alloc_Form (Scope_Id) then | |
6918 | Set_Enclosing_Sec_Stack_Return (N); | |
6919 | end if; | |
6920 | ||
36fcb4b9 | 6921 | elsif Is_Inherently_Limited_Type (R_Type) then |
2b3d67a5 AC |
6922 | null; |
6923 | ||
f6f4d8d4 JM |
6924 | -- No copy needed for thunks returning interface type objects since |
6925 | -- the object is returned by reference and the maximum functionality | |
6926 | -- required is just to displace the pointer. | |
6927 | ||
c5a913d3 | 6928 | elsif Is_Thunk (Scope_Id) and then Is_Interface (Exp_Typ) then |
f6f4d8d4 JM |
6929 | null; |
6930 | ||
ed09416f | 6931 | -- If the call is within a thunk and the type is a limited view, the |
89e037d0 | 6932 | -- back end will eventually see the non-limited view of the type. |
ed09416f | 6933 | |
c5a913d3 | 6934 | elsif Is_Thunk (Scope_Id) and then Is_Incomplete_Type (Exp_Typ) then |
ed09416f AC |
6935 | return; |
6936 | ||
bee69f33 YM |
6937 | -- A return statement from an ignored Ghost function does not use the |
6938 | -- secondary stack (or any other one). | |
95a79822 | 6939 | |
89e037d0 EB |
6940 | elsif (not Needs_Secondary_Stack (R_Type) |
6941 | and then not Is_Secondary_Stack_Thunk (Scope_Id)) | |
95a79822 ES |
6942 | or else Is_Ignored_Ghost_Entity (Scope_Id) |
6943 | then | |
d29f68cf AC |
6944 | -- Mutable records with variable-length components are not returned |
6945 | -- on the sec-stack, so we need to make sure that the back end will | |
6946 | -- only copy back the size of the actual value, and not the maximum | |
6947 | -- size. We create an actual subtype for this purpose. However we | |
6948 | -- need not do it if the expression is a function call since this | |
6949 | -- will be done in the called function and doing it here too would | |
de77a81b EB |
6950 | -- cause a temporary with maximum size to be created. Likewise for |
6951 | -- a special return object, since there is no copy in this case. | |
2b3d67a5 AC |
6952 | |
6953 | declare | |
c5a913d3 | 6954 | Ubt : constant Entity_Id := Underlying_Type (Base_Type (Exp_Typ)); |
2b3d67a5 AC |
6955 | Decl : Node_Id; |
6956 | Ent : Entity_Id; | |
c697f593 | 6957 | |
2b3d67a5 | 6958 | begin |
8861bdd5 | 6959 | if not Exp_Is_Function_Call |
de77a81b EB |
6960 | and then not (Is_Entity_Name (Exp) |
6961 | and then Is_Special_Return_Object (Entity (Exp))) | |
34d054d1 | 6962 | and then Has_Defaulted_Discriminants (Ubt) |
2b3d67a5 AC |
6963 | and then not Is_Constrained (Ubt) |
6964 | and then not Has_Unchecked_Union (Ubt) | |
6965 | then | |
6966 | Decl := Build_Actual_Subtype (Ubt, Exp); | |
6967 | Ent := Defining_Identifier (Decl); | |
6968 | Insert_Action (Exp, Decl); | |
6969 | Rewrite (Exp, Unchecked_Convert_To (Ent, Exp)); | |
6970 | Analyze_And_Resolve (Exp); | |
6971 | end if; | |
6972 | end; | |
6973 | ||
c697f593 EB |
6974 | -- For types which need finalization, do the allocation on the return |
6975 | -- stack manually in order to call Adjust at the right time: | |
6976 | ||
6977 | -- type Ann is access R_Type; | |
6978 | -- for Ann'Storage_pool use rs_pool; | |
ea588d41 | 6979 | -- Rnn : constant Ann := new Exp_Typ'(Exp); |
c697f593 EB |
6980 | -- return Rnn.all; |
6981 | ||
6982 | -- but optimize the case where the result is a function call that | |
89e037d0 | 6983 | -- also needs finalization. In this case the result can directly be |
a8bb495a | 6984 | -- allocated on the return stack of the caller and no further |
ea588d41 | 6985 | -- processing is required. Likewise if this is a return object. |
c697f593 | 6986 | |
ea588d41 EB |
6987 | if Comes_From_Extended_Return_Statement (N) then |
6988 | null; | |
6989 | ||
6990 | elsif Present (Utyp) | |
c697f593 | 6991 | and then Needs_Finalization (Utyp) |
8be71a90 | 6992 | and then not (Exp_Is_Function_Call |
c697f593 EB |
6993 | and then Needs_Finalization (Exp_Typ)) |
6994 | then | |
6995 | declare | |
dee004a9 EB |
6996 | Acc_Typ : constant Entity_Id := Make_Temporary (Loc, 'A'); |
6997 | ||
c697f593 EB |
6998 | Alloc_Node : Node_Id; |
6999 | Temp : Entity_Id; | |
7000 | ||
7001 | begin | |
7002 | Mutate_Ekind (Acc_Typ, E_Access_Type); | |
7003 | ||
7004 | Set_Associated_Storage_Pool (Acc_Typ, RTE (RE_RS_Pool)); | |
7005 | ||
7006 | -- This is an allocator for the return stack, and it's fine | |
7007 | -- to have Comes_From_Source set False on it, as gigi knows not | |
7008 | -- to flag it as a violation of No_Implicit_Heap_Allocations. | |
7009 | ||
7010 | Alloc_Node := | |
7011 | Make_Allocator (Loc, | |
7012 | Expression => | |
7013 | Make_Qualified_Expression (Loc, | |
7014 | Subtype_Mark => New_Occurrence_Of (Exp_Typ, Loc), | |
7015 | Expression => Relocate_Node (Exp))); | |
7016 | ||
7017 | -- We do not want discriminant checks on the declaration, | |
7018 | -- given that it gets its value from the allocator. | |
7019 | ||
7020 | Set_No_Initialization (Alloc_Node); | |
7021 | ||
7022 | Temp := Make_Temporary (Loc, 'R', Alloc_Node); | |
7023 | ||
7024 | Insert_Actions (Exp, New_List ( | |
7025 | Make_Full_Type_Declaration (Loc, | |
7026 | Defining_Identifier => Acc_Typ, | |
7027 | Type_Definition => | |
7028 | Make_Access_To_Object_Definition (Loc, | |
7029 | Subtype_Indication => Subtype_Ind)), | |
7030 | ||
7031 | Make_Object_Declaration (Loc, | |
7032 | Defining_Identifier => Temp, | |
ea588d41 | 7033 | Constant_Present => True, |
c697f593 EB |
7034 | Object_Definition => New_Occurrence_Of (Acc_Typ, Loc), |
7035 | Expression => Alloc_Node))); | |
7036 | ||
7037 | Rewrite (Exp, | |
7038 | Make_Explicit_Dereference (Loc, | |
7039 | Prefix => New_Occurrence_Of (Temp, Loc))); | |
7040 | ||
7041 | Analyze_And_Resolve (Exp, R_Type); | |
7042 | end; | |
7043 | end if; | |
7044 | ||
2b3d67a5 AC |
7045 | -- Here if secondary stack is used |
7046 | ||
7047 | else | |
c624298a | 7048 | -- Prevent the reclamation of the secondary stack by all enclosing |
c79f6efd BD |
7049 | -- blocks and loops as well as the related function; otherwise the |
7050 | -- result would be reclaimed too early. | |
adb252d8 | 7051 | |
c79f6efd | 7052 | Set_Enclosing_Sec_Stack_Return (N); |
2b3d67a5 | 7053 | |
ea588d41 EB |
7054 | -- Nothing else to do for a return object |
7055 | ||
7056 | if Comes_From_Extended_Return_Statement (N) then | |
7057 | null; | |
7058 | ||
7c092960 | 7059 | -- Optimize the case where the result is a function call that also |
1f038e84 | 7060 | -- returns on the secondary stack; in this case the result is already |
89e037d0 | 7061 | -- on the secondary stack and no further processing is required. |
2b3d67a5 | 7062 | |
ea588d41 | 7063 | elsif Exp_Is_Function_Call |
5cfde7a0 | 7064 | and then Needs_Secondary_Stack (Exp_Typ) |
2b3d67a5 | 7065 | then |
2b3d67a5 AC |
7066 | -- Remove side effects from the expression now so that other parts |
7067 | -- of the expander do not have to reanalyze this node without this | |
7068 | -- optimization | |
7069 | ||
7070 | Rewrite (Exp, Duplicate_Subexpr_No_Checks (Exp)); | |
7071 | ||
ec7f007c AC |
7072 | -- Ada 2005 (AI-251): If the type of the returned object is |
7073 | -- an interface then add an implicit type conversion to force | |
7074 | -- displacement of the "this" pointer. | |
7075 | ||
7076 | if Is_Interface (R_Type) then | |
7077 | Rewrite (Exp, Convert_To (R_Type, Relocate_Node (Exp))); | |
7078 | end if; | |
7079 | ||
7080 | Analyze_And_Resolve (Exp, R_Type); | |
7081 | ||
c697f593 EB |
7082 | -- For types which both need finalization and are returned on the |
7083 | -- secondary stack, do the allocation on secondary stack manually | |
7084 | -- in order to call Adjust at the right time: | |
2b3d67a5 | 7085 | |
c697f593 EB |
7086 | -- type Ann is access R_Type; |
7087 | -- for Ann'Storage_pool use ss_pool; | |
ea588d41 | 7088 | -- Rnn : constant Ann := new Exp_Typ'(Exp); |
c697f593 | 7089 | -- return Rnn.all; |
2b3d67a5 | 7090 | |
c697f593 | 7091 | -- And we do the same for class-wide types that are not potentially |
2b3d67a5 AC |
7092 | -- controlled (by the virtue of restriction No_Finalization) because |
7093 | -- gigi is not able to properly allocate class-wide types. | |
7094 | ||
89e037d0 | 7095 | -- But optimize the case where the result is a function call that |
1f038e84 | 7096 | -- also needs finalization; in this case the result can directly be |
89e037d0 | 7097 | -- allocated on the secondary stack and no further processing is |
1f038e84 | 7098 | -- required, unless the returned object is an interface. |
89e037d0 EB |
7099 | |
7100 | elsif CW_Or_Needs_Finalization (Utyp) | |
1f038e84 EB |
7101 | and then (Is_Interface (R_Type) |
7102 | or else not (Exp_Is_Function_Call | |
7103 | and then Needs_Finalization (Exp_Typ))) | |
89e037d0 | 7104 | then |
2b3d67a5 | 7105 | declare |
dee004a9 EB |
7106 | Acc_Typ : constant Entity_Id := Make_Temporary (Loc, 'A'); |
7107 | ||
2b3d67a5 AC |
7108 | Alloc_Node : Node_Id; |
7109 | Temp : Entity_Id; | |
7110 | ||
7111 | begin | |
2e02ab86 | 7112 | Mutate_Ekind (Acc_Typ, E_Access_Type); |
2b3d67a5 AC |
7113 | Set_Associated_Storage_Pool (Acc_Typ, RTE (RE_SS_Pool)); |
7114 | ||
7115 | -- This is an allocator for the secondary stack, and it's fine | |
7116 | -- to have Comes_From_Source set False on it, as gigi knows not | |
7117 | -- to flag it as a violation of No_Implicit_Heap_Allocations. | |
7118 | ||
7119 | Alloc_Node := | |
7120 | Make_Allocator (Loc, | |
7121 | Expression => | |
7122 | Make_Qualified_Expression (Loc, | |
e4494292 | 7123 | Subtype_Mark => New_Occurrence_Of (Etype (Exp), Loc), |
2b3d67a5 AC |
7124 | Expression => Relocate_Node (Exp))); |
7125 | ||
7126 | -- We do not want discriminant checks on the declaration, | |
7127 | -- given that it gets its value from the allocator. | |
7128 | ||
7129 | Set_No_Initialization (Alloc_Node); | |
7130 | ||
7131 | Temp := Make_Temporary (Loc, 'R', Alloc_Node); | |
7132 | ||
fe8b341f | 7133 | Insert_Actions (Exp, New_List ( |
2b3d67a5 AC |
7134 | Make_Full_Type_Declaration (Loc, |
7135 | Defining_Identifier => Acc_Typ, | |
7136 | Type_Definition => | |
7137 | Make_Access_To_Object_Definition (Loc, | |
7138 | Subtype_Indication => Subtype_Ind)), | |
7139 | ||
7140 | Make_Object_Declaration (Loc, | |
7141 | Defining_Identifier => Temp, | |
ea588d41 | 7142 | Constant_Present => True, |
e4494292 | 7143 | Object_Definition => New_Occurrence_Of (Acc_Typ, Loc), |
2b3d67a5 AC |
7144 | Expression => Alloc_Node))); |
7145 | ||
7146 | Rewrite (Exp, | |
7147 | Make_Explicit_Dereference (Loc, | |
e4494292 | 7148 | Prefix => New_Occurrence_Of (Temp, Loc))); |
2b3d67a5 | 7149 | |
a1092b48 AC |
7150 | -- Ada 2005 (AI-251): If the type of the returned object is |
7151 | -- an interface then add an implicit type conversion to force | |
7152 | -- displacement of the "this" pointer. | |
7153 | ||
7154 | if Is_Interface (R_Type) then | |
7155 | Rewrite (Exp, Convert_To (R_Type, Relocate_Node (Exp))); | |
7156 | end if; | |
7157 | ||
2b3d67a5 AC |
7158 | Analyze_And_Resolve (Exp, R_Type); |
7159 | end; | |
7160 | ||
7161 | -- Otherwise use the gigi mechanism to allocate result on the | |
7162 | -- secondary stack. | |
7163 | ||
7164 | else | |
7165 | Check_Restriction (No_Secondary_Stack, N); | |
7166 | Set_Storage_Pool (N, RTE (RE_SS_Pool)); | |
535a8637 | 7167 | Set_Procedure_To_Call (N, RTE (RE_SS_Allocate)); |
2b3d67a5 AC |
7168 | end if; |
7169 | end if; | |
7170 | ||
54bf19e4 AC |
7171 | -- Implement the rules of 6.5(8-10), which require a tag check in |
7172 | -- the case of a limited tagged return type, and tag reassignment for | |
2b3d67a5 AC |
7173 | -- nonlimited tagged results. These actions are needed when the return |
7174 | -- type is a specific tagged type and the result expression is a | |
54bf19e4 AC |
7175 | -- conversion or a formal parameter, because in that case the tag of |
7176 | -- the expression might differ from the tag of the specific result type. | |
2b3d67a5 | 7177 | |
320fbd1e JS |
7178 | -- We must also verify an underlying type exists for the return type in |
7179 | -- case it is incomplete - in which case is not necessary to generate a | |
7180 | -- check anyway since an incomplete limited tagged return type would | |
7181 | -- qualify as a premature usage. | |
7182 | ||
7183 | if Present (Utyp) | |
7184 | and then Is_Tagged_Type (Utyp) | |
2b3d67a5 | 7185 | and then not Is_Class_Wide_Type (Utyp) |
4a08c95c AC |
7186 | and then (Nkind (Exp) in |
7187 | N_Type_Conversion | N_Unchecked_Type_Conversion | |
16e307b9 JM |
7188 | or else (Nkind (Exp) = N_Explicit_Dereference |
7189 | and then Nkind (Prefix (Exp)) in | |
7190 | N_Type_Conversion | | |
7191 | N_Unchecked_Type_Conversion) | |
2b3d67a5 | 7192 | or else (Is_Entity_Name (Exp) |
bb6a856b | 7193 | and then Is_Formal (Entity (Exp)))) |
2b3d67a5 | 7194 | then |
54bf19e4 AC |
7195 | -- When the return type is limited, perform a check that the tag of |
7196 | -- the result is the same as the tag of the return type. | |
2b3d67a5 AC |
7197 | |
7198 | if Is_Limited_Type (R_Type) then | |
7199 | Insert_Action (Exp, | |
7200 | Make_Raise_Constraint_Error (Loc, | |
7201 | Condition => | |
7202 | Make_Op_Ne (Loc, | |
2c1b72d7 | 7203 | Left_Opnd => |
2b3d67a5 | 7204 | Make_Selected_Component (Loc, |
7675ad4f AC |
7205 | Prefix => Duplicate_Subexpr (Exp), |
7206 | Selector_Name => Make_Identifier (Loc, Name_uTag)), | |
2b3d67a5 AC |
7207 | Right_Opnd => |
7208 | Make_Attribute_Reference (Loc, | |
2c1b72d7 AC |
7209 | Prefix => |
7210 | New_Occurrence_Of (Base_Type (Utyp), Loc), | |
2b3d67a5 | 7211 | Attribute_Name => Name_Tag)), |
2c1b72d7 | 7212 | Reason => CE_Tag_Check_Failed)); |
2b3d67a5 AC |
7213 | |
7214 | -- If the result type is a specific nonlimited tagged type, then we | |
7215 | -- have to ensure that the tag of the result is that of the result | |
54bf19e4 AC |
7216 | -- type. This is handled by making a copy of the expression in |
7217 | -- the case where it might have a different tag, namely when the | |
2b3d67a5 AC |
7218 | -- expression is a conversion or a formal parameter. We create a new |
7219 | -- object of the result type and initialize it from the expression, | |
7220 | -- which will implicitly force the tag to be set appropriately. | |
7221 | ||
7222 | else | |
7223 | declare | |
7224 | ExpR : constant Node_Id := Relocate_Node (Exp); | |
7225 | Result_Id : constant Entity_Id := | |
7226 | Make_Temporary (Loc, 'R', ExpR); | |
7227 | Result_Exp : constant Node_Id := | |
e4494292 | 7228 | New_Occurrence_Of (Result_Id, Loc); |
2b3d67a5 AC |
7229 | Result_Obj : constant Node_Id := |
7230 | Make_Object_Declaration (Loc, | |
7231 | Defining_Identifier => Result_Id, | |
7232 | Object_Definition => | |
e4494292 | 7233 | New_Occurrence_Of (R_Type, Loc), |
2b3d67a5 AC |
7234 | Constant_Present => True, |
7235 | Expression => ExpR); | |
7236 | ||
7237 | begin | |
7238 | Set_Assignment_OK (Result_Obj); | |
7239 | Insert_Action (Exp, Result_Obj); | |
7240 | ||
7241 | Rewrite (Exp, Result_Exp); | |
7242 | Analyze_And_Resolve (Exp, R_Type); | |
7243 | end; | |
7244 | end if; | |
7245 | ||
c5a913d3 | 7246 | -- Ada 2005 (AI95-344): If the result type is class-wide, then insert |
2b3d67a5 AC |
7247 | -- a check that the level of the return expression's underlying type |
7248 | -- is not deeper than the level of the master enclosing the function. | |
c5a913d3 EB |
7249 | |
7250 | -- AI12-043: The check is made immediately after the return object is | |
7251 | -- created. This means that we do not apply it to the simple return | |
7252 | -- generated by the expansion of an extended return statement. | |
2b3d67a5 | 7253 | |
0a376301 JM |
7254 | -- No runtime check needed in interface thunks since it is performed |
7255 | -- by the target primitive associated with the thunk. | |
7256 | ||
c5a913d3 EB |
7257 | elsif Is_Class_Wide_Type (R_Type) |
7258 | and then not Comes_From_Extended_Return_Statement (N) | |
7259 | and then not Is_Thunk (Scope_Id) | |
2b3d67a5 | 7260 | then |
c5a913d3 | 7261 | Apply_CW_Accessibility_Check (Exp, Scope_Id); |
2b3d67a5 | 7262 | |
c5a913d3 EB |
7263 | -- Ada 2012 (AI05-0073): If the result subtype of the function is |
7264 | -- defined by an access_definition designating a specific tagged | |
7265 | -- type T, a check is made that the result value is null or the tag | |
7266 | -- of the object designated by the result value identifies T. | |
f7ea2603 RD |
7267 | |
7268 | -- The return expression is referenced twice in the code below, so it | |
7269 | -- must be made free of side effects. Given that different compilers | |
2b3d67a5 AC |
7270 | -- may evaluate these parameters in different order, both occurrences |
7271 | -- perform a copy. | |
7272 | ||
7273 | elsif Ekind (R_Type) = E_Anonymous_Access_Type | |
c5a913d3 EB |
7274 | and then Is_Tagged_Type (Designated_Type (R_Type)) |
7275 | and then not Is_Class_Wide_Type (Designated_Type (R_Type)) | |
7276 | and then Nkind (Original_Node (Exp)) /= N_Null | |
7277 | and then not Tag_Checks_Suppressed (Designated_Type (R_Type)) | |
2b3d67a5 | 7278 | then |
c5a913d3 EB |
7279 | -- Generate: |
7280 | -- [Constraint_Error | |
7281 | -- when Exp /= null | |
7282 | -- and then Exp.all not in Designated_Type] | |
7283 | ||
2b3d67a5 AC |
7284 | Insert_Action (N, |
7285 | Make_Raise_Constraint_Error (Loc, | |
7286 | Condition => | |
7287 | Make_And_Then (Loc, | |
7288 | Left_Opnd => | |
7289 | Make_Op_Ne (Loc, | |
7290 | Left_Opnd => Duplicate_Subexpr (Exp), | |
7291 | Right_Opnd => Make_Null (Loc)), | |
ebf494ec | 7292 | |
c5a913d3 EB |
7293 | Right_Opnd => |
7294 | Make_Not_In (Loc, | |
7295 | Left_Opnd => | |
7296 | Make_Explicit_Dereference (Loc, | |
7297 | Prefix => Duplicate_Subexpr (Exp)), | |
7298 | Right_Opnd => | |
7299 | New_Occurrence_Of (Designated_Type (R_Type), Loc))), | |
ebf494ec | 7300 | |
2b3d67a5 AC |
7301 | Reason => CE_Tag_Check_Failed), |
7302 | Suppress => All_Checks); | |
7303 | end if; | |
d32db3a7 GD |
7304 | |
7305 | -- If the result is of an unconstrained array subtype with fixed lower | |
7306 | -- bound, then sliding to that bound may be needed. | |
7307 | ||
7308 | if Is_Fixed_Lower_Bound_Array_Subtype (R_Type) then | |
7309 | Expand_Sliding_Conversion (Exp, R_Type); | |
7310 | end if; | |
2b3d67a5 | 7311 | |
00907026 EB |
7312 | -- If we are returning a nonscalar object that is possibly unaligned, |
7313 | -- then copy the value into a temporary first. This copy may need to | |
7314 | -- expand to a loop of component operations. | |
2b3d67a5 AC |
7315 | |
7316 | if Is_Possibly_Unaligned_Slice (Exp) | |
00907026 EB |
7317 | or else (Is_Possibly_Unaligned_Object (Exp) |
7318 | and then not Represented_As_Scalar (Etype (Exp))) | |
2b3d67a5 AC |
7319 | then |
7320 | declare | |
7321 | ExpR : constant Node_Id := Relocate_Node (Exp); | |
7322 | Tnn : constant Entity_Id := Make_Temporary (Loc, 'T', ExpR); | |
7323 | begin | |
7324 | Insert_Action (Exp, | |
7325 | Make_Object_Declaration (Loc, | |
7326 | Defining_Identifier => Tnn, | |
7327 | Constant_Present => True, | |
7328 | Object_Definition => New_Occurrence_Of (R_Type, Loc), | |
7329 | Expression => ExpR), | |
2c1b72d7 | 7330 | Suppress => All_Checks); |
2b3d67a5 AC |
7331 | Rewrite (Exp, New_Occurrence_Of (Tnn, Loc)); |
7332 | end; | |
7333 | end if; | |
7334 | ||
2b3d67a5 AC |
7335 | -- Ada 2005 (AI-251): If this return statement corresponds with an |
7336 | -- simple return statement associated with an extended return statement | |
7337 | -- and the type of the returned object is an interface then generate an | |
7338 | -- implicit conversion to force displacement of the "this" pointer. | |
7339 | ||
0791fbe9 | 7340 | if Ada_Version >= Ada_2005 |
2b3d67a5 AC |
7341 | and then Comes_From_Extended_Return_Statement (N) |
7342 | and then Nkind (Expression (N)) = N_Identifier | |
7343 | and then Is_Interface (Utyp) | |
c5a913d3 | 7344 | and then Utyp /= Underlying_Type (Exp_Typ) |
2b3d67a5 AC |
7345 | then |
7346 | Rewrite (Exp, Convert_To (Utyp, Relocate_Node (Exp))); | |
7347 | Analyze_And_Resolve (Exp); | |
7348 | end if; | |
bbab2db3 | 7349 | |
81e68a19 | 7350 | -- Ada 2022 (AI12-0279) |
8afbdb8a JM |
7351 | |
7352 | if Has_Yield_Aspect (Scope_Id) | |
7353 | and then RTE_Available (RE_Yield) | |
7354 | then | |
7355 | Insert_Action (N, | |
7356 | Make_Procedure_Call_Statement (Loc, | |
7357 | New_Occurrence_Of (RTE (RE_Yield), Loc))); | |
7358 | end if; | |
2b3d67a5 AC |
7359 | end Expand_Simple_Function_Return; |
7360 | ||
02822a92 RD |
7361 | ----------------------- |
7362 | -- Freeze_Subprogram -- | |
7363 | ----------------------- | |
758c442c | 7364 | |
02822a92 | 7365 | procedure Freeze_Subprogram (N : Node_Id) is |
a9f5f2cd | 7366 | Loc : constant Source_Ptr := Sloc (N); |
df3e68b1 | 7367 | Subp : constant Entity_Id := Entity (N); |
3ca505dc | 7368 | |
7888a6ae | 7369 | begin |
d766cee3 | 7370 | -- We suppress the initialization of the dispatch table entry when |
535a8637 AC |
7371 | -- not Tagged_Type_Expansion because the dispatching mechanism is |
7372 | -- handled internally by the target. | |
d766cee3 RD |
7373 | |
7374 | if Is_Dispatching_Operation (Subp) | |
7375 | and then not Is_Abstract_Subprogram (Subp) | |
7376 | and then Present (DTC_Entity (Subp)) | |
7377 | and then Present (Scope (DTC_Entity (Subp))) | |
1f110335 | 7378 | and then Tagged_Type_Expansion |
d766cee3 RD |
7379 | and then not Restriction_Active (No_Dispatching_Calls) |
7380 | and then RTE_Available (RE_Tag) | |
7381 | then | |
7888a6ae | 7382 | declare |
d766cee3 | 7383 | Typ : constant Entity_Id := Scope (DTC_Entity (Subp)); |
c8ef728f | 7384 | |
d4090614 EB |
7385 | L : List_Id; |
7386 | ||
7888a6ae | 7387 | begin |
8fc789c8 | 7388 | -- Handle private overridden primitives |
c8ef728f | 7389 | |
d766cee3 RD |
7390 | if not Is_CPP_Class (Typ) then |
7391 | Check_Overriding_Operation (Subp); | |
7888a6ae | 7392 | end if; |
c8ef728f | 7393 | |
d766cee3 RD |
7394 | -- We assume that imported CPP primitives correspond with objects |
7395 | -- whose constructor is in the CPP side; therefore we don't need | |
7396 | -- to generate code to register them in the dispatch table. | |
c8ef728f | 7397 | |
d766cee3 RD |
7398 | if Is_CPP_Class (Typ) then |
7399 | null; | |
3ca505dc | 7400 | |
d766cee3 RD |
7401 | -- Handle CPP primitives found in derivations of CPP_Class types. |
7402 | -- These primitives must have been inherited from some parent, and | |
7403 | -- there is no need to register them in the dispatch table because | |
5b6f12c7 | 7404 | -- Build_Inherit_Prims takes care of initializing these slots. |
3ca505dc | 7405 | |
d766cee3 | 7406 | elsif Is_Imported (Subp) |
fd664071 | 7407 | and then Convention (Subp) in Convention_C_Family |
d766cee3 RD |
7408 | then |
7409 | null; | |
7410 | ||
7411 | -- Generate code to register the primitive in non statically | |
7412 | -- allocated dispatch tables | |
7413 | ||
bfae1846 AC |
7414 | elsif not Building_Static_DT (Scope (DTC_Entity (Subp))) then |
7415 | ||
d766cee3 RD |
7416 | -- When a primitive is frozen, enter its name in its dispatch |
7417 | -- table slot. | |
f4d379b8 | 7418 | |
d766cee3 | 7419 | if not Is_Interface (Typ) |
ce2b6ba5 | 7420 | or else Present (Interface_Alias (Subp)) |
d766cee3 RD |
7421 | then |
7422 | if Is_Predefined_Dispatching_Operation (Subp) then | |
a9f5f2cd EB |
7423 | L := Register_Predefined_Primitive (Loc, Subp); |
7424 | else | |
7425 | L := New_List; | |
7888a6ae | 7426 | end if; |
d766cee3 | 7427 | |
a9f5f2cd | 7428 | Append_List_To (L, Register_Primitive (Loc, Subp)); |
d4090614 EB |
7429 | |
7430 | if Is_Empty_List (L) then | |
7431 | null; | |
7432 | ||
7433 | elsif No (Actions (N)) then | |
7434 | Set_Actions (N, L); | |
7435 | ||
7436 | else | |
7437 | Append_List (L, Actions (N)); | |
7438 | end if; | |
7888a6ae GD |
7439 | end if; |
7440 | end if; | |
7441 | end; | |
70482933 RK |
7442 | end if; |
7443 | ||
7888a6ae GD |
7444 | -- Mark functions that return by reference. Note that it cannot be part |
7445 | -- of the normal semantic analysis of the spec since the underlying | |
7446 | -- returned type may not be known yet (for private types). | |
70482933 | 7447 | |
8926c29c | 7448 | Compute_Returns_By_Ref (Subp); |
70482933 RK |
7449 | end Freeze_Subprogram; |
7450 | ||
765005dd JM |
7451 | -------------------------- |
7452 | -- Has_BIP_Extra_Formal -- | |
7453 | -------------------------- | |
7454 | ||
7455 | function Has_BIP_Extra_Formal | |
f1668c3d JM |
7456 | (E : Entity_Id; |
7457 | Kind : BIP_Formal_Kind; | |
7458 | Must_Be_Frozen : Boolean := True) return Boolean | |
765005dd JM |
7459 | is |
7460 | Extra_Formal : Entity_Id := Extra_Formals (E); | |
7461 | ||
7462 | begin | |
7463 | -- We can only rely on the availability of the extra formals in frozen | |
7464 | -- entities or in subprogram types of dispatching calls (since their | |
7465 | -- extra formals are added when the target subprogram is frozen; see | |
7466 | -- Expand_Dispatching_Call). | |
7467 | ||
f1668c3d | 7468 | pragma Assert ((Is_Frozen (E) or else not Must_Be_Frozen) |
765005dd JM |
7469 | or else (Ekind (E) = E_Subprogram_Type |
7470 | and then Is_Dispatch_Table_Entity (E)) | |
7471 | or else (Is_Dispatching_Operation (E) | |
7472 | and then Is_Frozen (Find_Dispatching_Type (E)))); | |
7473 | ||
7474 | while Present (Extra_Formal) loop | |
7475 | if Is_Build_In_Place_Entity (Extra_Formal) | |
7476 | and then BIP_Suffix_Kind (Extra_Formal) = Kind | |
7477 | then | |
7478 | return True; | |
7479 | end if; | |
7480 | ||
7481 | Next_Formal_With_Extras (Extra_Formal); | |
7482 | end loop; | |
7483 | ||
7484 | return False; | |
7485 | end Has_BIP_Extra_Formal; | |
7486 | ||
ca1f6b29 BD |
7487 | ------------------------------ |
7488 | -- Insert_Post_Call_Actions -- | |
7489 | ------------------------------ | |
7490 | ||
ec40b86c | 7491 | procedure Insert_Post_Call_Actions (N : Node_Id; Post_Call : List_Id) is |
40b4bc2d AC |
7492 | Context : constant Node_Id := Parent (N); |
7493 | ||
ca1f6b29 BD |
7494 | begin |
7495 | if Is_Empty_List (Post_Call) then | |
7496 | return; | |
7497 | end if; | |
7498 | ||
895cf059 EB |
7499 | -- Cases where the call is not a member of a statement list. This also |
7500 | -- includes the cases where the call is an actual in another function | |
7501 | -- call, or is an index, or is an operand of an if-expression, i.e. is | |
7502 | -- in an expression context. | |
ca1f6b29 BD |
7503 | |
7504 | if not Is_List_Member (N) | |
4a08c95c AC |
7505 | or else Nkind (Context) in N_Function_Call |
7506 | | N_If_Expression | |
7507 | | N_Indexed_Component | |
ca1f6b29 BD |
7508 | then |
7509 | -- In Ada 2012 the call may be a function call in an expression | |
ec40b86c HK |
7510 | -- (since OUT and IN OUT parameters are now allowed for such calls). |
7511 | -- The write-back of (in)-out parameters is handled by the back-end, | |
7512 | -- but the constraint checks generated when subtypes of formal and | |
7513 | -- actual don't match must be inserted in the form of assignments. | |
05eb5c61 GD |
7514 | -- Also do this in the case of explicit dereferences, which can occur |
7515 | -- due to rewritings of function calls with controlled results. | |
ca1f6b29 | 7516 | |
895cf059 EB |
7517 | if Nkind (N) = N_Function_Call |
7518 | or else Nkind (Original_Node (N)) = N_Function_Call | |
05eb5c61 | 7519 | or else Nkind (N) = N_Explicit_Dereference |
895cf059 | 7520 | then |
ca1f6b29 BD |
7521 | pragma Assert (Ada_Version >= Ada_2012); |
7522 | -- Functions with '[in] out' parameters are only allowed in Ada | |
7523 | -- 2012. | |
7524 | ||
7525 | -- We used to handle this by climbing up parents to a | |
7526 | -- non-statement/declaration and then simply making a call to | |
7527 | -- Insert_Actions_After (P, Post_Call), but that doesn't work | |
7528 | -- for Ada 2012. If we are in the middle of an expression, e.g. | |
7529 | -- the condition of an IF, this call would insert after the IF | |
ec40b86c HK |
7530 | -- statement, which is much too late to be doing the write back. |
7531 | -- For example: | |
ca1f6b29 BD |
7532 | |
7533 | -- if Clobber (X) then | |
7534 | -- Put_Line (X'Img); | |
7535 | -- else | |
7536 | -- goto Junk | |
7537 | -- end if; | |
7538 | ||
ec40b86c HK |
7539 | -- Now assume Clobber changes X, if we put the write back after |
7540 | -- the IF, the Put_Line gets the wrong value and the goto causes | |
7541 | -- the write back to be skipped completely. | |
ca1f6b29 BD |
7542 | |
7543 | -- To deal with this, we replace the call by | |
3d3378fb | 7544 | -- |
ca1f6b29 BD |
7545 | -- do |
7546 | -- Tnnn : constant function-result-type := function-call; | |
7547 | -- Post_Call actions | |
7548 | -- in | |
7549 | -- Tnnn; | |
7550 | -- end; | |
3d3378fb SB |
7551 | -- |
7552 | -- However, that doesn't work if function-result-type requires | |
7553 | -- finalization (because function-call's result never gets | |
7554 | -- finalized). So in that case, we instead replace the call by | |
7555 | -- | |
7556 | -- do | |
7557 | -- type Ref is access all function-result-type; | |
7558 | -- Ptr : constant Ref := function-call'Reference; | |
7559 | -- Tnnn : constant function-result-type := Ptr.all; | |
7560 | -- Finalize (Ptr.all); | |
7561 | -- Post_Call actions | |
7562 | -- in | |
7563 | -- Tnnn; | |
7564 | -- end; | |
7565 | -- | |
ca1f6b29 BD |
7566 | |
7567 | declare | |
7568 | Loc : constant Source_Ptr := Sloc (N); | |
7569 | Tnnn : constant Entity_Id := Make_Temporary (Loc, 'T'); | |
7570 | FRTyp : constant Entity_Id := Etype (N); | |
7571 | Name : constant Node_Id := Relocate_Node (N); | |
7572 | ||
7573 | begin | |
3d3378fb SB |
7574 | if Needs_Finalization (FRTyp) then |
7575 | declare | |
7576 | Ptr_Typ : constant Entity_Id := Make_Temporary (Loc, 'A'); | |
7577 | ||
7578 | Ptr_Typ_Decl : constant Node_Id := | |
7579 | Make_Full_Type_Declaration (Loc, | |
7580 | Defining_Identifier => Ptr_Typ, | |
7581 | Type_Definition => | |
7582 | Make_Access_To_Object_Definition (Loc, | |
7583 | All_Present => True, | |
7584 | Subtype_Indication => | |
7585 | New_Occurrence_Of (FRTyp, Loc))); | |
7586 | ||
7587 | Ptr_Obj : constant Entity_Id := | |
7588 | Make_Temporary (Loc, 'P'); | |
7589 | ||
7590 | Ptr_Obj_Decl : constant Node_Id := | |
7591 | Make_Object_Declaration (Loc, | |
7592 | Defining_Identifier => Ptr_Obj, | |
7593 | Object_Definition => | |
7594 | New_Occurrence_Of (Ptr_Typ, Loc), | |
7595 | Constant_Present => True, | |
7596 | Expression => | |
7597 | Make_Attribute_Reference (Loc, | |
7598 | Prefix => Name, | |
7599 | Attribute_Name => Name_Unrestricted_Access)); | |
7600 | ||
7601 | function Ptr_Dereference return Node_Id is | |
7602 | (Make_Explicit_Dereference (Loc, | |
7603 | Prefix => New_Occurrence_Of (Ptr_Obj, Loc))); | |
7604 | ||
7605 | Tnn_Decl : constant Node_Id := | |
7606 | Make_Object_Declaration (Loc, | |
7607 | Defining_Identifier => Tnnn, | |
7608 | Object_Definition => New_Occurrence_Of (FRTyp, Loc), | |
7609 | Constant_Present => True, | |
7610 | Expression => Ptr_Dereference); | |
7611 | ||
7612 | Finalize_Call : constant Node_Id := | |
7613 | Make_Final_Call | |
7614 | (Obj_Ref => Ptr_Dereference, Typ => FRTyp); | |
7615 | begin | |
7616 | -- Prepend in reverse order | |
7617 | ||
7618 | Prepend_To (Post_Call, Finalize_Call); | |
7619 | Prepend_To (Post_Call, Tnn_Decl); | |
7620 | Prepend_To (Post_Call, Ptr_Obj_Decl); | |
7621 | Prepend_To (Post_Call, Ptr_Typ_Decl); | |
7622 | end; | |
7623 | else | |
7624 | Prepend_To (Post_Call, | |
7625 | Make_Object_Declaration (Loc, | |
7626 | Defining_Identifier => Tnnn, | |
7627 | Object_Definition => New_Occurrence_Of (FRTyp, Loc), | |
7628 | Constant_Present => True, | |
7629 | Expression => Name)); | |
7630 | end if; | |
ca1f6b29 BD |
7631 | |
7632 | Rewrite (N, | |
7633 | Make_Expression_With_Actions (Loc, | |
7634 | Actions => Post_Call, | |
7635 | Expression => New_Occurrence_Of (Tnnn, Loc))); | |
7636 | ||
7637 | -- We don't want to just blindly call Analyze_And_Resolve | |
7638 | -- because that would cause unwanted recursion on the call. | |
7639 | -- So for a moment set the call as analyzed to prevent that | |
7640 | -- recursion, and get the rest analyzed properly, then reset | |
7641 | -- the analyzed flag, so our caller can continue. | |
7642 | ||
7643 | Set_Analyzed (Name, True); | |
7644 | Analyze_And_Resolve (N, FRTyp); | |
7645 | Set_Analyzed (Name, False); | |
7646 | end; | |
7647 | ||
ec40b86c HK |
7648 | -- If not the special Ada 2012 case of a function call, then we must |
7649 | -- have the triggering statement of a triggering alternative or an | |
7650 | -- entry call alternative, and we can add the post call stuff to the | |
7651 | -- corresponding statement list. | |
ca1f6b29 BD |
7652 | |
7653 | else | |
4a08c95c AC |
7654 | pragma Assert (Nkind (Context) in N_Entry_Call_Alternative |
7655 | | N_Triggering_Alternative); | |
ca1f6b29 | 7656 | |
40b4bc2d AC |
7657 | if Is_Non_Empty_List (Statements (Context)) then |
7658 | Insert_List_Before_And_Analyze | |
7659 | (First (Statements (Context)), Post_Call); | |
7660 | else | |
7661 | Set_Statements (Context, Post_Call); | |
7662 | end if; | |
ca1f6b29 BD |
7663 | end if; |
7664 | ||
40b4bc2d AC |
7665 | -- A procedure call is always part of a declarative or statement list, |
7666 | -- however a function call may appear nested within a construct. Most | |
7667 | -- cases of function call nesting are handled in the special case above. | |
7668 | -- The only exception is when the function call acts as an actual in a | |
7669 | -- procedure call. In this case the function call is in a list, but the | |
7670 | -- post-call actions must be inserted after the procedure call. | |
5f396397 | 7671 | -- What if the function call is an aggregate component ??? |
40b4bc2d AC |
7672 | |
7673 | elsif Nkind (Context) = N_Procedure_Call_Statement then | |
7674 | Insert_Actions_After (Context, Post_Call); | |
7675 | ||
ec40b86c HK |
7676 | -- Otherwise, normal case where N is in a statement sequence, just put |
7677 | -- the post-call stuff after the call statement. | |
ca1f6b29 BD |
7678 | |
7679 | else | |
7680 | Insert_Actions_After (N, Post_Call); | |
7681 | end if; | |
7682 | end Insert_Post_Call_Actions; | |
7683 | ||
475e1d24 JM |
7684 | --------------------------------------- |
7685 | -- Install_Class_Preconditions_Check -- | |
7686 | --------------------------------------- | |
7687 | ||
7688 | procedure Install_Class_Preconditions_Check (Call_Node : Node_Id) is | |
7689 | Loc : constant Source_Ptr := Sloc (Call_Node); | |
7690 | ||
7691 | function Build_Dynamic_Check_Helper_Call return Node_Id; | |
7692 | -- Build call to the helper runtime function of the nearest ancestor | |
7693 | -- of the target subprogram that dynamically evaluates the merged | |
7694 | -- or-else preconditions. | |
7695 | ||
7696 | function Build_Error_Message (Subp_Id : Entity_Id) return Node_Id; | |
7697 | -- Build message associated with the class-wide precondition of Subp_Id | |
7698 | -- indicating the call that caused it. | |
7699 | ||
7700 | function Build_Static_Check_Helper_Call return Node_Id; | |
7701 | -- Build call to the helper runtime function of the nearest ancestor | |
7702 | -- of the target subprogram that dynamically evaluates the merged | |
7703 | -- or-else preconditions. | |
7704 | ||
7705 | function Class_Preconditions_Subprogram | |
7706 | (Spec_Id : Entity_Id; | |
7707 | Dynamic : Boolean) return Node_Id; | |
7708 | -- Return the nearest ancestor of Spec_Id defining a helper function | |
7709 | -- that evaluates a combined or-else expression containing all the | |
7710 | -- inherited class-wide preconditions; Dynamic enables searching for | |
7711 | -- the helper that dynamically evaluates preconditions using dispatching | |
7712 | -- calls; if False it searches for the helper that statically evaluates | |
7713 | -- preconditions; return Empty when not available (which means that no | |
7714 | -- preconditions check is required). | |
7715 | ||
7716 | ------------------------------------- | |
7717 | -- Build_Dynamic_Check_Helper_Call -- | |
7718 | ------------------------------------- | |
7719 | ||
7720 | function Build_Dynamic_Check_Helper_Call return Node_Id is | |
7721 | Spec_Id : constant Entity_Id := Entity (Name (Call_Node)); | |
7722 | CW_Subp : constant Entity_Id := | |
7723 | Class_Preconditions_Subprogram (Spec_Id, | |
7724 | Dynamic => True); | |
7725 | Helper_Id : constant Entity_Id := | |
7726 | Dynamic_Call_Helper (CW_Subp); | |
7727 | Actuals : constant List_Id := New_List; | |
7728 | A : Node_Id := First_Actual (Call_Node); | |
7729 | F : Entity_Id := First_Formal (Helper_Id); | |
7730 | ||
7731 | begin | |
7732 | while Present (A) loop | |
7733 | ||
7734 | -- Ensure that the evaluation of the actuals will not produce | |
7735 | -- side effects. | |
7736 | ||
7737 | Remove_Side_Effects (A); | |
7738 | ||
7739 | Append_To (Actuals, New_Copy_Tree (A)); | |
7740 | Next_Formal (F); | |
7741 | Next_Actual (A); | |
7742 | end loop; | |
7743 | ||
7744 | return | |
7745 | Make_Function_Call (Loc, | |
7746 | Name => New_Occurrence_Of (Helper_Id, Loc), | |
7747 | Parameter_Associations => Actuals); | |
7748 | end Build_Dynamic_Check_Helper_Call; | |
7749 | ||
7750 | ------------------------- | |
7751 | -- Build_Error_Message -- | |
7752 | ------------------------- | |
7753 | ||
7754 | function Build_Error_Message (Subp_Id : Entity_Id) return Node_Id is | |
7755 | ||
7756 | procedure Append_Message | |
7757 | (Id : Entity_Id; | |
7758 | Is_First : in out Boolean); | |
7759 | -- Build the fragment of the message associated with subprogram Id; | |
7760 | -- Is_First facilitates identifying continuation messages. | |
7761 | ||
7762 | -------------------- | |
7763 | -- Append_Message -- | |
7764 | -------------------- | |
7765 | ||
7766 | procedure Append_Message | |
7767 | (Id : Entity_Id; | |
7768 | Is_First : in out Boolean) | |
7769 | is | |
7770 | Prag : constant Node_Id := Get_Class_Wide_Pragma (Id, | |
7771 | Pragma_Precondition); | |
7772 | Msg : Node_Id; | |
7773 | Str_Id : String_Id; | |
7774 | ||
7775 | begin | |
7776 | if No (Prag) or else Is_Ignored (Prag) then | |
7777 | return; | |
7778 | end if; | |
7779 | ||
7780 | Msg := Expression (Last (Pragma_Argument_Associations (Prag))); | |
7781 | Str_Id := Strval (Msg); | |
7782 | ||
7783 | if Is_First then | |
7784 | Is_First := False; | |
7785 | ||
7786 | Append (Global_Name_Buffer, Strval (Msg)); | |
7787 | ||
7788 | if Id /= Subp_Id | |
7789 | and then Name_Buffer (1 .. 19) = "failed precondition" | |
7790 | then | |
7791 | Insert_Str_In_Name_Buffer ("inherited ", 8); | |
7792 | end if; | |
7793 | ||
7794 | else | |
7795 | declare | |
7796 | Str : constant String := To_String (Str_Id); | |
7797 | From_Idx : Integer; | |
7798 | ||
7799 | begin | |
7800 | Append (Global_Name_Buffer, ASCII.LF); | |
7801 | Append (Global_Name_Buffer, " or "); | |
7802 | ||
7803 | From_Idx := Name_Len; | |
7804 | Append (Global_Name_Buffer, Str_Id); | |
7805 | ||
7806 | if Str (1 .. 19) = "failed precondition" then | |
7807 | Insert_Str_In_Name_Buffer ("inherited ", From_Idx + 8); | |
7808 | end if; | |
7809 | end; | |
7810 | end if; | |
7811 | end Append_Message; | |
7812 | ||
7813 | -- Local variables | |
7814 | ||
7815 | Str_Loc : constant String := Build_Location_String (Loc); | |
7816 | Subps : constant Subprogram_List := | |
7817 | Inherited_Subprograms (Subp_Id); | |
7818 | Is_First : Boolean := True; | |
7819 | ||
7820 | -- Start of processing for Build_Error_Message | |
7821 | ||
7822 | begin | |
7823 | Name_Len := 0; | |
7824 | Append_Message (Subp_Id, Is_First); | |
7825 | ||
7826 | for Index in Subps'Range loop | |
7827 | Append_Message (Subps (Index), Is_First); | |
7828 | end loop; | |
7829 | ||
7830 | if Present (Controlling_Argument (Call_Node)) then | |
7831 | Append (Global_Name_Buffer, " in dispatching call at "); | |
7832 | else | |
7833 | Append (Global_Name_Buffer, " in call at "); | |
7834 | end if; | |
7835 | ||
7836 | Append (Global_Name_Buffer, Str_Loc); | |
7837 | ||
7838 | return Make_String_Literal (Loc, Name_Buffer (1 .. Name_Len)); | |
7839 | end Build_Error_Message; | |
7840 | ||
7841 | ------------------------------------ | |
7842 | -- Build_Static_Check_Helper_Call -- | |
7843 | ------------------------------------ | |
7844 | ||
7845 | function Build_Static_Check_Helper_Call return Node_Id is | |
7846 | Actuals : constant List_Id := New_List; | |
7847 | A : Node_Id; | |
7848 | Helper_Id : Entity_Id; | |
7849 | F : Entity_Id; | |
7850 | CW_Subp : Entity_Id; | |
7851 | Spec_Id : constant Entity_Id := Entity (Name (Call_Node)); | |
7852 | ||
7853 | begin | |
7854 | -- The target is the wrapper built to support inheriting body but | |
7855 | -- overriding pre/postconditions (AI12-0195). | |
7856 | ||
7857 | if Is_Dispatch_Table_Wrapper (Spec_Id) then | |
7858 | CW_Subp := Spec_Id; | |
7859 | ||
7860 | -- Common case | |
7861 | ||
7862 | else | |
7863 | CW_Subp := Class_Preconditions_Subprogram (Spec_Id, | |
7864 | Dynamic => False); | |
7865 | end if; | |
7866 | ||
7867 | Helper_Id := Static_Call_Helper (CW_Subp); | |
7868 | ||
7869 | F := First_Formal (Helper_Id); | |
7870 | A := First_Actual (Call_Node); | |
7871 | while Present (A) loop | |
7872 | ||
7873 | -- Ensure that the evaluation of the actuals will not produce | |
7874 | -- side effects. | |
7875 | ||
7876 | Remove_Side_Effects (A); | |
7877 | ||
7dc44f28 JM |
7878 | -- Ensure matching types to avoid reporting spurious errors since |
7879 | -- the called helper may have been built for a parent type. | |
7880 | ||
7881 | if Etype (F) /= Etype (A) then | |
475e1d24 | 7882 | Append_To (Actuals, |
405ebd74 | 7883 | Unchecked_Convert_To (Etype (F), New_Copy_Tree (A))); |
475e1d24 JM |
7884 | else |
7885 | Append_To (Actuals, New_Copy_Tree (A)); | |
7886 | end if; | |
7887 | ||
7888 | Next_Formal (F); | |
7889 | Next_Actual (A); | |
7890 | end loop; | |
7891 | ||
7892 | return | |
7893 | Make_Function_Call (Loc, | |
7894 | Name => New_Occurrence_Of (Helper_Id, Loc), | |
7895 | Parameter_Associations => Actuals); | |
7896 | end Build_Static_Check_Helper_Call; | |
7897 | ||
7898 | ------------------------------------ | |
7899 | -- Class_Preconditions_Subprogram -- | |
7900 | ------------------------------------ | |
7901 | ||
7902 | function Class_Preconditions_Subprogram | |
7903 | (Spec_Id : Entity_Id; | |
7904 | Dynamic : Boolean) return Node_Id | |
7905 | is | |
7906 | Subp_Id : constant Entity_Id := Ultimate_Alias (Spec_Id); | |
7907 | ||
7908 | begin | |
7909 | -- Prevent cascaded errors | |
7910 | ||
7911 | if not Is_Dispatching_Operation (Subp_Id) then | |
7912 | return Empty; | |
7913 | ||
7914 | -- No need to search if this subprogram has the helper we are | |
7915 | -- searching | |
7916 | ||
7917 | elsif Dynamic then | |
7918 | if Present (Dynamic_Call_Helper (Subp_Id)) then | |
7919 | return Subp_Id; | |
7920 | end if; | |
7921 | else | |
7922 | if Present (Static_Call_Helper (Subp_Id)) then | |
7923 | return Subp_Id; | |
7924 | end if; | |
7925 | end if; | |
7926 | ||
7927 | -- Process inherited subprograms looking for class-wide | |
7928 | -- preconditions. | |
7929 | ||
7930 | declare | |
7931 | Subps : constant Subprogram_List := | |
7932 | Inherited_Subprograms (Subp_Id); | |
7933 | Subp_Id : Entity_Id; | |
7934 | ||
7935 | begin | |
7936 | for Index in Subps'Range loop | |
7937 | Subp_Id := Subps (Index); | |
7938 | ||
7939 | if Present (Alias (Subp_Id)) then | |
7940 | Subp_Id := Ultimate_Alias (Subp_Id); | |
7941 | end if; | |
7942 | ||
7943 | -- Wrappers of class-wide pre/postconditions reference the | |
7944 | -- parent primitive that has the inherited contract. | |
7945 | ||
7946 | if Is_Wrapper (Subp_Id) | |
7947 | and then Present (LSP_Subprogram (Subp_Id)) | |
7948 | then | |
7949 | Subp_Id := LSP_Subprogram (Subp_Id); | |
7950 | end if; | |
7951 | ||
7952 | if Dynamic then | |
7953 | if Present (Dynamic_Call_Helper (Subp_Id)) then | |
7954 | return Subp_Id; | |
7955 | end if; | |
7956 | else | |
7957 | if Present (Static_Call_Helper (Subp_Id)) then | |
7958 | return Subp_Id; | |
7959 | end if; | |
7960 | end if; | |
7961 | end loop; | |
7962 | end; | |
7963 | ||
7964 | return Empty; | |
7965 | end Class_Preconditions_Subprogram; | |
7966 | ||
7967 | -- Local variables | |
7968 | ||
7969 | Dynamic_Check : constant Boolean := | |
7970 | Present (Controlling_Argument (Call_Node)); | |
7971 | Class_Subp : Entity_Id; | |
7972 | Cond : Node_Id; | |
7973 | Subp : Entity_Id; | |
7974 | ||
7975 | -- Start of processing for Install_Class_Preconditions_Check | |
7976 | ||
7977 | begin | |
7978 | -- Do not expand the check if we are compiling under restriction | |
7979 | -- No_Dispatching_Calls; the semantic analyzer has previously | |
7980 | -- notified the violation of this restriction. | |
7981 | ||
7982 | if Dynamic_Check | |
7983 | and then Restriction_Active (No_Dispatching_Calls) | |
7984 | then | |
7985 | return; | |
7986 | ||
7987 | -- Class-wide precondition check not needed in interface thunks since | |
7988 | -- they are installed in the dispatching call that caused invoking the | |
7989 | -- thunk. | |
7990 | ||
7991 | elsif Is_Thunk (Current_Scope) then | |
7992 | return; | |
7993 | end if; | |
7994 | ||
7995 | Subp := Entity (Name (Call_Node)); | |
7996 | ||
7997 | -- No check needed for this subprogram call if no class-wide | |
7998 | -- preconditions apply (or if the unique available preconditions | |
7999 | -- are ignored preconditions). | |
8000 | ||
8001 | Class_Subp := Class_Preconditions_Subprogram (Subp, Dynamic_Check); | |
8002 | ||
8003 | if No (Class_Subp) | |
8004 | or else No (Class_Preconditions (Class_Subp)) | |
8005 | then | |
8006 | return; | |
8007 | end if; | |
8008 | ||
8009 | -- Build and install the check | |
8010 | ||
8011 | if Dynamic_Check then | |
8012 | Cond := Build_Dynamic_Check_Helper_Call; | |
8013 | else | |
8014 | Cond := Build_Static_Check_Helper_Call; | |
8015 | end if; | |
8016 | ||
8017 | if Exception_Locations_Suppressed then | |
8018 | Insert_Action (Call_Node, | |
8019 | Make_If_Statement (Loc, | |
8020 | Condition => Make_Op_Not (Loc, Cond), | |
8021 | Then_Statements => New_List ( | |
8022 | Make_Raise_Statement (Loc, | |
8023 | Name => | |
8024 | New_Occurrence_Of | |
8025 | (RTE (RE_Assert_Failure), Loc))))); | |
8026 | ||
8027 | -- Failed check with message indicating the failed precondition and the | |
8028 | -- call that caused it. | |
8029 | ||
8030 | else | |
8031 | Insert_Action (Call_Node, | |
8032 | Make_If_Statement (Loc, | |
8033 | Condition => Make_Op_Not (Loc, Cond), | |
8034 | Then_Statements => New_List ( | |
8035 | Make_Procedure_Call_Statement (Loc, | |
8036 | Name => | |
8037 | New_Occurrence_Of | |
8038 | (RTE (RE_Raise_Assert_Failure), Loc), | |
8039 | Parameter_Associations => | |
8040 | New_List (Build_Error_Message (Subp)))))); | |
8041 | end if; | |
8042 | end Install_Class_Preconditions_Check; | |
8043 | ||
82af7291 JM |
8044 | ------------------------------ |
8045 | -- Is_Build_In_Place_Entity -- | |
8046 | ------------------------------ | |
8047 | ||
8048 | function Is_Build_In_Place_Entity (E : Entity_Id) return Boolean is | |
8049 | Nam : constant String := Get_Name_String (Chars (E)); | |
8050 | ||
8051 | function Has_Suffix (Suffix : String) return Boolean; | |
8052 | -- Return True if Nam has suffix Suffix | |
8053 | ||
8054 | function Has_Suffix (Suffix : String) return Boolean is | |
8055 | Len : constant Natural := Suffix'Length; | |
8056 | begin | |
8057 | return Nam'Length > Len | |
8058 | and then Nam (Nam'Last - Len + 1 .. Nam'Last) = Suffix; | |
8059 | end Has_Suffix; | |
8060 | ||
8061 | -- Start of processing for Is_Build_In_Place_Entity | |
8062 | ||
8063 | begin | |
8064 | return Has_Suffix (BIP_Alloc_Suffix) | |
8065 | or else Has_Suffix (BIP_Storage_Pool_Suffix) | |
8066 | or else Has_Suffix (BIP_Finalization_Master_Suffix) | |
8067 | or else Has_Suffix (BIP_Task_Master_Suffix) | |
8068 | or else Has_Suffix (BIP_Activation_Chain_Suffix) | |
8069 | or else Has_Suffix (BIP_Object_Access_Suffix); | |
8070 | end Is_Build_In_Place_Entity; | |
8071 | ||
7d1d3a54 HK |
8072 | -------------------------------- |
8073 | -- Is_Build_In_Place_Function -- | |
8074 | -------------------------------- | |
8075 | ||
8076 | function Is_Build_In_Place_Function (E : Entity_Id) return Boolean is | |
02e41e69 EB |
8077 | Kind : constant Entity_Kind := Ekind (E); |
8078 | Typ : constant Entity_Id := Etype (E); | |
8079 | ||
7d1d3a54 HK |
8080 | begin |
8081 | -- This function is called from Expand_Subtype_From_Expr during | |
8082 | -- semantic analysis, even when expansion is off. In those cases | |
8083 | -- the build_in_place expansion will not take place. | |
8084 | ||
8085 | if not Expander_Active then | |
8086 | return False; | |
8087 | end if; | |
8088 | ||
bfe1ab22 EB |
8089 | -- We never use build-in-place if the convention is other than Ada, |
8090 | -- but note that it is OK for a build-in-place function to return a | |
8091 | -- type with a foreign convention because the machinery ensures there | |
8092 | -- is no copying. | |
02e41e69 EB |
8093 | |
8094 | return (Kind in E_Function | E_Generic_Function | |
8095 | or else | |
8096 | (Kind = E_Subprogram_Type and then Typ /= Standard_Void_Type)) | |
8097 | and then Is_Build_In_Place_Result_Type (Typ) | |
f1668c3d | 8098 | and then not Has_Foreign_Convention (E); |
7d1d3a54 HK |
8099 | end Is_Build_In_Place_Function; |
8100 | ||
8101 | ------------------------------------- | |
8102 | -- Is_Build_In_Place_Function_Call -- | |
8103 | ------------------------------------- | |
8104 | ||
8105 | function Is_Build_In_Place_Function_Call (N : Node_Id) return Boolean is | |
8106 | Exp_Node : constant Node_Id := Unqual_Conv (N); | |
8107 | Function_Id : Entity_Id; | |
8108 | ||
8109 | begin | |
8110 | -- Return False if the expander is currently inactive, since awareness | |
8111 | -- of build-in-place treatment is only relevant during expansion. Note | |
8112 | -- that Is_Build_In_Place_Function, which is called as part of this | |
8113 | -- function, is also conditioned this way, but we need to check here as | |
8114 | -- well to avoid blowing up on processing protected calls when expansion | |
8115 | -- is disabled (such as with -gnatc) since those would trip over the | |
8116 | -- raise of Program_Error below. | |
8117 | ||
8118 | -- In SPARK mode, build-in-place calls are not expanded, so that we | |
8119 | -- may end up with a call that is neither resolved to an entity, nor | |
8120 | -- an indirect call. | |
8121 | ||
8122 | if not Expander_Active or else Nkind (Exp_Node) /= N_Function_Call then | |
8123 | return False; | |
8124 | end if; | |
8125 | ||
8126 | if Is_Entity_Name (Name (Exp_Node)) then | |
8127 | Function_Id := Entity (Name (Exp_Node)); | |
8128 | ||
8129 | -- In the case of an explicitly dereferenced call, use the subprogram | |
8130 | -- type generated for the dereference. | |
8131 | ||
8132 | elsif Nkind (Name (Exp_Node)) = N_Explicit_Dereference then | |
8133 | Function_Id := Etype (Name (Exp_Node)); | |
8134 | ||
8135 | -- This may be a call to a protected function. | |
8136 | ||
8137 | elsif Nkind (Name (Exp_Node)) = N_Selected_Component then | |
66d43665 JS |
8138 | -- The selector in question might not have been analyzed due to a |
8139 | -- previous error, so analyze it here to output the appropriate | |
8140 | -- error message instead of crashing when attempting to fetch its | |
8141 | -- entity. | |
8142 | ||
8143 | if not Analyzed (Selector_Name (Name (Exp_Node))) then | |
8144 | Analyze (Selector_Name (Name (Exp_Node))); | |
8145 | end if; | |
8146 | ||
7d1d3a54 HK |
8147 | Function_Id := Etype (Entity (Selector_Name (Name (Exp_Node)))); |
8148 | ||
8149 | else | |
8150 | raise Program_Error; | |
8151 | end if; | |
8152 | ||
f1668c3d JM |
8153 | if Is_Build_In_Place_Function (Function_Id) then |
8154 | return True; | |
8155 | ||
8156 | -- True also if the function has BIP Formals | |
8157 | ||
8158 | else | |
8159 | declare | |
8160 | Kind : constant Entity_Kind := Ekind (Function_Id); | |
8161 | ||
8162 | begin | |
8163 | if (Kind in E_Function | E_Generic_Function | |
8164 | or else (Kind = E_Subprogram_Type | |
8165 | and then | |
8166 | Etype (Function_Id) /= Standard_Void_Type)) | |
8167 | and then Has_BIP_Formals (Function_Id) | |
8168 | then | |
8169 | -- So we can stop here in the debugger | |
8170 | return True; | |
8171 | else | |
8172 | return False; | |
8173 | end if; | |
8174 | end; | |
8175 | end if; | |
7d1d3a54 HK |
8176 | end Is_Build_In_Place_Function_Call; |
8177 | ||
358e289d JM |
8178 | ------------------------------------------ |
8179 | -- Is_True_Build_In_Place_Function_Call -- | |
8180 | ------------------------------------------ | |
8181 | ||
8182 | function Is_True_Build_In_Place_Function_Call (N : Node_Id) return Boolean | |
8183 | is | |
8184 | Exp_Node : Node_Id; | |
8185 | Function_Id : Entity_Id; | |
8186 | ||
8187 | begin | |
8188 | -- No action needed if we know that this is not a BIP function call | |
8189 | ||
8190 | if not Is_Build_In_Place_Function_Call (N) then | |
8191 | return False; | |
8192 | end if; | |
8193 | ||
8194 | Exp_Node := Unqual_Conv (N); | |
8195 | ||
8196 | if Is_Entity_Name (Name (Exp_Node)) then | |
8197 | Function_Id := Entity (Name (Exp_Node)); | |
8198 | ||
8199 | elsif Nkind (Name (Exp_Node)) = N_Explicit_Dereference then | |
8200 | Function_Id := Etype (Name (Exp_Node)); | |
8201 | ||
8202 | elsif Nkind (Name (Exp_Node)) = N_Selected_Component then | |
8203 | Function_Id := Etype (Entity (Selector_Name (Name (Exp_Node)))); | |
8204 | ||
8205 | else | |
8206 | raise Program_Error; | |
8207 | end if; | |
8208 | ||
8209 | return Is_Build_In_Place_Function (Function_Id); | |
8210 | end Is_True_Build_In_Place_Function_Call; | |
8211 | ||
4844a259 EB |
8212 | ----------------------------------- |
8213 | -- Is_Build_In_Place_Result_Type -- | |
8214 | ----------------------------------- | |
8215 | ||
8216 | function Is_Build_In_Place_Result_Type (Typ : Entity_Id) return Boolean is | |
8217 | begin | |
8218 | if not Expander_Active then | |
8219 | return False; | |
8220 | end if; | |
8221 | ||
8222 | -- In Ada 2005 all functions with an inherently limited return type | |
8223 | -- must be handled using a build-in-place profile, including the case | |
8224 | -- of a function with a limited interface result, where the function | |
8225 | -- may return objects of nonlimited descendants. | |
8226 | ||
36fcb4b9 | 8227 | return Is_Inherently_Limited_Type (Typ) |
4844a259 EB |
8228 | and then Ada_Version >= Ada_2005 |
8229 | and then not Debug_Flag_Dot_L; | |
8230 | end Is_Build_In_Place_Result_Type; | |
8231 | ||
8232 | ------------------------------------- | |
8233 | -- Is_Build_In_Place_Return_Object -- | |
8234 | ------------------------------------- | |
8235 | ||
8236 | function Is_Build_In_Place_Return_Object (E : Entity_Id) return Boolean is | |
8237 | begin | |
8238 | return Is_Return_Object (E) | |
8239 | and then Is_Build_In_Place_Function (Return_Applies_To (Scope (E))); | |
8240 | end Is_Build_In_Place_Return_Object; | |
8241 | ||
ea588d41 EB |
8242 | ----------------------------------- |
8243 | -- Is_By_Reference_Return_Object -- | |
8244 | ----------------------------------- | |
8245 | ||
8246 | function Is_By_Reference_Return_Object (E : Entity_Id) return Boolean is | |
8247 | begin | |
8248 | return Is_Return_Object (E) | |
8249 | and then Is_By_Reference_Type (Etype (Return_Applies_To (Scope (E)))); | |
8250 | end Is_By_Reference_Return_Object; | |
8251 | ||
8dbf3473 AC |
8252 | ----------------------- |
8253 | -- Is_Null_Procedure -- | |
8254 | ----------------------- | |
8255 | ||
8256 | function Is_Null_Procedure (Subp : Entity_Id) return Boolean is | |
8257 | Decl : constant Node_Id := Unit_Declaration_Node (Subp); | |
8258 | ||
8259 | begin | |
8260 | if Ekind (Subp) /= E_Procedure then | |
8261 | return False; | |
8262 | ||
8263 | -- Check if this is a declared null procedure | |
8264 | ||
8265 | elsif Nkind (Decl) = N_Subprogram_Declaration then | |
e1f3cb58 AC |
8266 | if not Null_Present (Specification (Decl)) then |
8267 | return False; | |
8dbf3473 AC |
8268 | |
8269 | elsif No (Body_To_Inline (Decl)) then | |
8270 | return False; | |
8271 | ||
8272 | -- Check if the body contains only a null statement, followed by | |
8273 | -- the return statement added during expansion. | |
8274 | ||
8275 | else | |
8276 | declare | |
8277 | Orig_Bod : constant Node_Id := Body_To_Inline (Decl); | |
8278 | ||
8279 | Stat : Node_Id; | |
8280 | Stat2 : Node_Id; | |
8281 | ||
8282 | begin | |
8283 | if Nkind (Orig_Bod) /= N_Subprogram_Body then | |
8284 | return False; | |
8285 | else | |
327503f1 JM |
8286 | -- We must skip SCIL nodes because they are currently |
8287 | -- implemented as special N_Null_Statement nodes. | |
8288 | ||
8dbf3473 | 8289 | Stat := |
327503f1 | 8290 | First_Non_SCIL_Node |
8dbf3473 | 8291 | (Statements (Handled_Statement_Sequence (Orig_Bod))); |
327503f1 | 8292 | Stat2 := Next_Non_SCIL_Node (Stat); |
8dbf3473 AC |
8293 | |
8294 | return | |
e1f3cb58 AC |
8295 | Is_Empty_List (Declarations (Orig_Bod)) |
8296 | and then Nkind (Stat) = N_Null_Statement | |
8297 | and then | |
8dbf3473 AC |
8298 | (No (Stat2) |
8299 | or else | |
8300 | (Nkind (Stat2) = N_Simple_Return_Statement | |
8301 | and then No (Next (Stat2)))); | |
8302 | end if; | |
8303 | end; | |
8304 | end if; | |
8305 | ||
8306 | else | |
8307 | return False; | |
8308 | end if; | |
8309 | end Is_Null_Procedure; | |
8310 | ||
ea588d41 EB |
8311 | -------------------------------------- |
8312 | -- Is_Secondary_Stack_Return_Object -- | |
8313 | -------------------------------------- | |
8314 | ||
8315 | function Is_Secondary_Stack_Return_Object (E : Entity_Id) return Boolean is | |
8316 | begin | |
8317 | return Is_Return_Object (E) | |
8318 | and then Needs_Secondary_Stack (Etype (Return_Applies_To (Scope (E)))); | |
8319 | end Is_Secondary_Stack_Return_Object; | |
8320 | ||
8321 | ------------------------------ | |
8322 | -- Is_Special_Return_Object -- | |
8323 | ------------------------------ | |
8324 | ||
8325 | function Is_Special_Return_Object (E : Entity_Id) return Boolean is | |
8326 | begin | |
8327 | return Is_Build_In_Place_Return_Object (E) | |
8328 | or else Is_Secondary_Stack_Return_Object (E) | |
8329 | or else (Back_End_Return_Slot | |
8330 | and then Is_By_Reference_Return_Object (E)); | |
8331 | end Is_Special_Return_Object; | |
8332 | ||
02822a92 RD |
8333 | ------------------------------------------- |
8334 | -- Make_Build_In_Place_Call_In_Allocator -- | |
8335 | ------------------------------------------- | |
8336 | ||
8337 | procedure Make_Build_In_Place_Call_In_Allocator | |
8338 | (Allocator : Node_Id; | |
8339 | Function_Call : Node_Id) | |
8340 | is | |
94bbf008 | 8341 | Acc_Type : constant Entity_Id := Etype (Allocator); |
90e491a7 | 8342 | Loc : constant Source_Ptr := Sloc (Function_Call); |
02822a92 | 8343 | Func_Call : Node_Id := Function_Call; |
1399d355 | 8344 | Ref_Func_Call : Node_Id; |
02822a92 RD |
8345 | Function_Id : Entity_Id; |
8346 | Result_Subt : Entity_Id; | |
02822a92 | 8347 | New_Allocator : Node_Id; |
1399d355 AC |
8348 | Return_Obj_Access : Entity_Id; -- temp for function result |
8349 | Temp_Init : Node_Id; -- initial value of Return_Obj_Access | |
8350 | Alloc_Form : BIP_Allocation_Form; | |
8351 | Pool : Node_Id; -- nonnull if Alloc_Form = User_Storage_Pool | |
8352 | Return_Obj_Actual : Node_Id; -- the temp.all, in caller-allocates case | |
8353 | Chain : Entity_Id; -- activation chain, in case of tasks | |
02822a92 RD |
8354 | |
8355 | begin | |
19590d70 GD |
8356 | -- Step past qualification or unchecked conversion (the latter can occur |
8357 | -- in cases of calls to 'Input). | |
8358 | ||
4a08c95c AC |
8359 | if Nkind (Func_Call) in N_Qualified_Expression |
8360 | | N_Type_Conversion | |
8361 | | N_Unchecked_Type_Conversion | |
19590d70 | 8362 | then |
02822a92 RD |
8363 | Func_Call := Expression (Func_Call); |
8364 | end if; | |
8365 | ||
358e289d JM |
8366 | -- No action needed if the called function inherited the BIP extra |
8367 | -- formals but it is not a true BIP function. | |
8368 | ||
8369 | if not Is_True_Build_In_Place_Function_Call (Func_Call) then | |
8370 | pragma Assert (Is_Expanded_Build_In_Place_Call (Func_Call)); | |
8371 | return; | |
8372 | end if; | |
8373 | ||
fdce4bb7 JM |
8374 | -- Mark the call as processed as a build-in-place call |
8375 | ||
d4dfb005 | 8376 | pragma Assert (not Is_Expanded_Build_In_Place_Call (Func_Call)); |
fdce4bb7 JM |
8377 | Set_Is_Expanded_Build_In_Place_Call (Func_Call); |
8378 | ||
02822a92 RD |
8379 | if Is_Entity_Name (Name (Func_Call)) then |
8380 | Function_Id := Entity (Name (Func_Call)); | |
8381 | ||
8382 | elsif Nkind (Name (Func_Call)) = N_Explicit_Dereference then | |
8383 | Function_Id := Etype (Name (Func_Call)); | |
8384 | ||
8385 | else | |
8386 | raise Program_Error; | |
8387 | end if; | |
8388 | ||
b19c922b VF |
8389 | Warn_BIP (Func_Call); |
8390 | ||
94bbf008 | 8391 | Result_Subt := Available_View (Etype (Function_Id)); |
02822a92 | 8392 | |
1399d355 AC |
8393 | -- Create a temp for the function result. In the caller-allocates case, |
8394 | -- this will be initialized to the result of a new uninitialized | |
8395 | -- allocator. Note: we do not use Allocator as the Related_Node of | |
8396 | -- Return_Obj_Access in call to Make_Temporary below as this would | |
8397 | -- create a sort of infinite "recursion". | |
0d566e01 | 8398 | |
1399d355 AC |
8399 | Return_Obj_Access := Make_Temporary (Loc, 'R'); |
8400 | Set_Etype (Return_Obj_Access, Acc_Type); | |
d4dfb005 | 8401 | Set_Can_Never_Be_Null (Acc_Type, False); |
3fc40cd7 | 8402 | -- It gets initialized to null, so we can't have that |
0d566e01 | 8403 | |
7d1d3a54 HK |
8404 | -- When the result subtype is constrained, the return object is created |
8405 | -- on the caller side, and access to it is passed to the function. This | |
8406 | -- optimization is disabled when the result subtype needs finalization | |
8407 | -- actions because the caller side allocation may result in undesirable | |
8408 | -- finalization. Consider the following example: | |
8409 | -- | |
8410 | -- function Make_Lim_Ctrl return Lim_Ctrl is | |
8411 | -- begin | |
8412 | -- return Result : Lim_Ctrl := raise Program_Error do | |
8413 | -- null; | |
8414 | -- end return; | |
8415 | -- end Make_Lim_Ctrl; | |
8416 | -- | |
8417 | -- Obj : Lim_Ctrl_Ptr := new Lim_Ctrl'(Make_Lim_Ctrl); | |
8418 | -- | |
8419 | -- Even though the size of limited controlled type Lim_Ctrl is known, | |
8420 | -- allocating Obj at the caller side will chain Obj on Lim_Ctrl_Ptr's | |
8421 | -- finalization master. The subsequent call to Make_Lim_Ctrl will fail | |
8422 | -- during the initialization actions for Result, which implies that | |
8423 | -- Result (and Obj by extension) should not be finalized. However Obj | |
8424 | -- will be finalized when access type Lim_Ctrl_Ptr goes out of scope | |
8425 | -- since it is already attached on the related finalization master. | |
02822a92 | 8426 | |
7888a6ae | 8427 | -- Here and in related routines, we must examine the full view of the |
cf0e5ca7 BD |
8428 | -- type, because the view at the point of call may differ from the |
8429 | -- one in the function body, and the expansion mechanism depends on | |
7888a6ae GD |
8430 | -- the characteristics of the full view. |
8431 | ||
cf0e5ca7 BD |
8432 | if Needs_BIP_Alloc_Form (Function_Id) then |
8433 | Temp_Init := Empty; | |
8434 | ||
8435 | -- Case of a user-defined storage pool. Pass an allocation parameter | |
8436 | -- indicating that the function should allocate its result in the | |
8437 | -- pool, and pass the pool. Use 'Unrestricted_Access because the | |
8438 | -- pool may not be aliased. | |
8439 | ||
8440 | if Present (Associated_Storage_Pool (Acc_Type)) then | |
8441 | Alloc_Form := User_Storage_Pool; | |
8442 | Pool := | |
8443 | Make_Attribute_Reference (Loc, | |
8444 | Prefix => | |
8445 | New_Occurrence_Of | |
8446 | (Associated_Storage_Pool (Acc_Type), Loc), | |
8447 | Attribute_Name => Name_Unrestricted_Access); | |
8448 | ||
8449 | -- No user-defined pool; pass an allocation parameter indicating that | |
8450 | -- the function should allocate its result on the heap. | |
8451 | ||
8452 | else | |
8453 | Alloc_Form := Global_Heap; | |
8454 | Pool := Make_Null (No_Location); | |
8455 | end if; | |
8456 | ||
8457 | -- The caller does not provide the return object in this case, so we | |
8458 | -- have to pass null for the object access actual. | |
8459 | ||
8460 | Return_Obj_Actual := Empty; | |
8461 | ||
8462 | else | |
f937473f RD |
8463 | -- Replace the initialized allocator of form "new T'(Func (...))" |
8464 | -- with an uninitialized allocator of form "new T", where T is the | |
8465 | -- result subtype of the called function. The call to the function | |
8466 | -- is handled separately further below. | |
02822a92 | 8467 | |
f937473f | 8468 | New_Allocator := |
fad0600d | 8469 | Make_Allocator (Loc, |
e4494292 | 8470 | Expression => New_Occurrence_Of (Result_Subt, Loc)); |
fad0600d AC |
8471 | Set_No_Initialization (New_Allocator); |
8472 | ||
8473 | -- Copy attributes to new allocator. Note that the new allocator | |
8474 | -- logically comes from source if the original one did, so copy the | |
8475 | -- relevant flag. This ensures proper treatment of the restriction | |
8476 | -- No_Implicit_Heap_Allocations in this case. | |
02822a92 | 8477 | |
fad0600d | 8478 | Set_Storage_Pool (New_Allocator, Storage_Pool (Allocator)); |
f937473f | 8479 | Set_Procedure_To_Call (New_Allocator, Procedure_To_Call (Allocator)); |
fad0600d | 8480 | Set_Comes_From_Source (New_Allocator, Comes_From_Source (Allocator)); |
02822a92 | 8481 | |
f937473f | 8482 | Rewrite (Allocator, New_Allocator); |
02822a92 | 8483 | |
1399d355 | 8484 | -- Initial value of the temp is the result of the uninitialized |
90e491a7 PMR |
8485 | -- allocator. Unchecked_Convert is needed for T'Input where T is |
8486 | -- derived from a controlled type. | |
02822a92 | 8487 | |
1399d355 | 8488 | Temp_Init := Relocate_Node (Allocator); |
f937473f | 8489 | |
4a08c95c AC |
8490 | if Nkind (Function_Call) in |
8491 | N_Type_Conversion | N_Unchecked_Type_Conversion | |
90e491a7 PMR |
8492 | then |
8493 | Temp_Init := Unchecked_Convert_To (Acc_Type, Temp_Init); | |
8494 | end if; | |
8495 | ||
1399d355 AC |
8496 | -- Indicate that caller allocates, and pass in the return object |
8497 | ||
8498 | Alloc_Form := Caller_Allocation; | |
8499 | Pool := Make_Null (No_Location); | |
738a0e8d BD |
8500 | Return_Obj_Actual := Unchecked_Convert_To |
8501 | (Result_Subt, | |
8502 | Make_Explicit_Dereference (Loc, | |
8503 | Prefix => New_Occurrence_Of (Return_Obj_Access, Loc))); | |
f937473f RD |
8504 | |
8505 | -- When the result subtype is unconstrained, the function itself must | |
8506 | -- perform the allocation of the return object, so we pass parameters | |
1399d355 | 8507 | -- indicating that. |
f937473f | 8508 | |
1399d355 AC |
8509 | end if; |
8510 | ||
8511 | -- Declare the temp object | |
8512 | ||
8513 | Insert_Action (Allocator, | |
8514 | Make_Object_Declaration (Loc, | |
8515 | Defining_Identifier => Return_Obj_Access, | |
8516 | Object_Definition => New_Occurrence_Of (Acc_Type, Loc), | |
8517 | Expression => Temp_Init)); | |
8518 | ||
8519 | Ref_Func_Call := Make_Reference (Loc, Func_Call); | |
8520 | ||
8521 | -- Ada 2005 (AI-251): If the type of the allocator is an interface | |
8522 | -- then generate an implicit conversion to force displacement of the | |
8523 | -- "this" pointer. | |
8524 | ||
8525 | if Is_Interface (Designated_Type (Acc_Type)) then | |
8526 | Rewrite | |
8527 | (Ref_Func_Call, | |
8528 | OK_Convert_To (Acc_Type, Ref_Func_Call)); | |
90e491a7 PMR |
8529 | |
8530 | -- If the types are incompatible, we need an unchecked conversion. Note | |
8531 | -- that the full types will be compatible, but the types not visibly | |
8532 | -- compatible. | |
8533 | ||
4a08c95c AC |
8534 | elsif Nkind (Function_Call) |
8535 | in N_Type_Conversion | N_Unchecked_Type_Conversion | |
90e491a7 PMR |
8536 | then |
8537 | Ref_Func_Call := Unchecked_Convert_To (Acc_Type, Ref_Func_Call); | |
f937473f | 8538 | end if; |
02822a92 | 8539 | |
1399d355 AC |
8540 | declare |
8541 | Assign : constant Node_Id := | |
7d1d3a54 HK |
8542 | Make_Assignment_Statement (Loc, |
8543 | Name => New_Occurrence_Of (Return_Obj_Access, Loc), | |
8544 | Expression => Ref_Func_Call); | |
1399d355 AC |
8545 | -- Assign the result of the function call into the temp. In the |
8546 | -- caller-allocates case, this is overwriting the temp with its | |
8547 | -- initial value, which has no effect. In the callee-allocates case, | |
8548 | -- this is setting the temp to point to the object allocated by the | |
90e491a7 PMR |
8549 | -- callee. Unchecked_Convert is needed for T'Input where T is derived |
8550 | -- from a controlled type. | |
1399d355 AC |
8551 | |
8552 | Actions : List_Id; | |
8553 | -- Actions to be inserted. If there are no tasks, this is just the | |
8554 | -- assignment statement. If the allocated object has tasks, we need | |
8555 | -- to wrap the assignment in a block that activates them. The | |
8556 | -- activation chain of that block must be passed to the function, | |
8557 | -- rather than some outer chain. | |
7d1d3a54 | 8558 | |
1399d355 | 8559 | begin |
95260403 | 8560 | if Might_Have_Tasks (Result_Subt) then |
1399d355 AC |
8561 | Actions := New_List; |
8562 | Build_Task_Allocate_Block_With_Init_Stmts | |
8563 | (Actions, Allocator, Init_Stmts => New_List (Assign)); | |
8564 | Chain := Activation_Chain_Entity (Last (Actions)); | |
8565 | else | |
8566 | Actions := New_List (Assign); | |
8567 | Chain := Empty; | |
8568 | end if; | |
8569 | ||
8570 | Insert_Actions (Allocator, Actions); | |
8571 | end; | |
8572 | ||
8573 | -- When the function has a controlling result, an allocation-form | |
8574 | -- parameter must be passed indicating that the caller is allocating | |
8575 | -- the result object. This is needed because such a function can be | |
8576 | -- called as a dispatching operation and must be treated similarly | |
8577 | -- to functions with unconstrained result subtypes. | |
8578 | ||
8579 | Add_Unconstrained_Actuals_To_Build_In_Place_Call | |
8580 | (Func_Call, Function_Id, Alloc_Form, Pool_Actual => Pool); | |
8581 | ||
8582 | Add_Finalization_Master_Actual_To_Build_In_Place_Call | |
8583 | (Func_Call, Function_Id, Acc_Type); | |
8584 | ||
8585 | Add_Task_Actuals_To_Build_In_Place_Call | |
8586 | (Func_Call, Function_Id, Master_Actual => Master_Id (Acc_Type), | |
8587 | Chain => Chain); | |
8588 | ||
8589 | -- Add an implicit actual to the function call that provides access | |
8590 | -- to the allocated object. An unchecked conversion to the (specific) | |
8591 | -- result subtype of the function is inserted to handle cases where | |
8592 | -- the access type of the allocator has a class-wide designated type. | |
8593 | ||
8594 | Add_Access_Actual_To_Build_In_Place_Call | |
8595 | (Func_Call, Function_Id, Return_Obj_Actual); | |
8596 | ||
1399d355 | 8597 | -- Finally, replace the allocator node with a reference to the temp |
02822a92 | 8598 | |
1399d355 | 8599 | Rewrite (Allocator, New_Occurrence_Of (Return_Obj_Access, Loc)); |
d2d4b355 | 8600 | |
02822a92 | 8601 | Analyze_And_Resolve (Allocator, Acc_Type); |
1ed19d98 | 8602 | pragma Assert (Check_Number_Of_Actuals (Func_Call, Function_Id)); |
82af7291 | 8603 | pragma Assert (Check_BIP_Actuals (Func_Call, Function_Id)); |
02822a92 RD |
8604 | end Make_Build_In_Place_Call_In_Allocator; |
8605 | ||
8606 | --------------------------------------------------- | |
8607 | -- Make_Build_In_Place_Call_In_Anonymous_Context -- | |
8608 | --------------------------------------------------- | |
8609 | ||
8610 | procedure Make_Build_In_Place_Call_In_Anonymous_Context | |
8611 | (Function_Call : Node_Id) | |
8612 | is | |
90e491a7 | 8613 | Loc : constant Source_Ptr := Sloc (Function_Call); |
0691ed6b | 8614 | Func_Call : constant Node_Id := Unqual_Conv (Function_Call); |
02822a92 RD |
8615 | Function_Id : Entity_Id; |
8616 | Result_Subt : Entity_Id; | |
8617 | Return_Obj_Id : Entity_Id; | |
8618 | Return_Obj_Decl : Entity_Id; | |
8619 | ||
8620 | begin | |
fdce4bb7 JM |
8621 | -- If the call has already been processed to add build-in-place actuals |
8622 | -- then return. One place this can occur is for calls to build-in-place | |
8623 | -- functions that occur within a call to a protected operation, where | |
8624 | -- due to rewriting and expansion of the protected call there can be | |
8625 | -- more than one call to Expand_Actuals for the same set of actuals. | |
8626 | ||
8627 | if Is_Expanded_Build_In_Place_Call (Func_Call) then | |
8628 | return; | |
8629 | end if; | |
8630 | ||
8631 | -- Mark the call as processed as a build-in-place call | |
8632 | ||
8633 | Set_Is_Expanded_Build_In_Place_Call (Func_Call); | |
8634 | ||
02822a92 RD |
8635 | if Is_Entity_Name (Name (Func_Call)) then |
8636 | Function_Id := Entity (Name (Func_Call)); | |
8637 | ||
8638 | elsif Nkind (Name (Func_Call)) = N_Explicit_Dereference then | |
8639 | Function_Id := Etype (Name (Func_Call)); | |
8640 | ||
8641 | else | |
8642 | raise Program_Error; | |
8643 | end if; | |
8644 | ||
b19c922b VF |
8645 | Warn_BIP (Func_Call); |
8646 | ||
02822a92 RD |
8647 | Result_Subt := Etype (Function_Id); |
8648 | ||
df3e68b1 HK |
8649 | -- If the build-in-place function returns a controlled object, then the |
8650 | -- object needs to be finalized immediately after the context. Since | |
8651 | -- this case produces a transient scope, the servicing finalizer needs | |
8652 | -- to name the returned object. Create a temporary which is initialized | |
8653 | -- with the function call: | |
8654 | -- | |
8655 | -- Temp_Id : Func_Type := BIP_Func_Call; | |
8656 | -- | |
8657 | -- The initialization expression of the temporary will be rewritten by | |
8658 | -- the expander using the appropriate mechanism in Make_Build_In_Place_ | |
8659 | -- Call_In_Object_Declaration. | |
8660 | ||
8661 | if Needs_Finalization (Result_Subt) then | |
8662 | declare | |
8663 | Temp_Id : constant Entity_Id := Make_Temporary (Loc, 'R'); | |
8664 | Temp_Decl : Node_Id; | |
8665 | ||
8666 | begin | |
8667 | -- Reset the guard on the function call since the following does | |
8668 | -- not perform actual call expansion. | |
8669 | ||
8670 | Set_Is_Expanded_Build_In_Place_Call (Func_Call, False); | |
8671 | ||
8672 | Temp_Decl := | |
8673 | Make_Object_Declaration (Loc, | |
8674 | Defining_Identifier => Temp_Id, | |
8675 | Object_Definition => | |
e4494292 | 8676 | New_Occurrence_Of (Result_Subt, Loc), |
df3e68b1 HK |
8677 | Expression => |
8678 | New_Copy_Tree (Function_Call)); | |
8679 | ||
8680 | Insert_Action (Function_Call, Temp_Decl); | |
8681 | ||
e4494292 | 8682 | Rewrite (Function_Call, New_Occurrence_Of (Temp_Id, Loc)); |
df3e68b1 HK |
8683 | Analyze (Function_Call); |
8684 | end; | |
8685 | ||
e51102b2 | 8686 | -- When the result subtype is definite, an object of the subtype is |
f937473f | 8687 | -- declared and an access value designating it is passed as an actual. |
02822a92 | 8688 | |
0691ed6b | 8689 | elsif Caller_Known_Size (Func_Call, Result_Subt) then |
02822a92 | 8690 | |
f937473f RD |
8691 | -- Create a temporary object to hold the function result |
8692 | ||
c12beea0 | 8693 | Return_Obj_Id := Make_Temporary (Loc, 'R'); |
f937473f | 8694 | Set_Etype (Return_Obj_Id, Result_Subt); |
02822a92 | 8695 | |
f937473f RD |
8696 | Return_Obj_Decl := |
8697 | Make_Object_Declaration (Loc, | |
8698 | Defining_Identifier => Return_Obj_Id, | |
8699 | Aliased_Present => True, | |
e4494292 | 8700 | Object_Definition => New_Occurrence_Of (Result_Subt, Loc)); |
02822a92 | 8701 | |
f937473f | 8702 | Set_No_Initialization (Return_Obj_Decl); |
02822a92 | 8703 | |
f937473f | 8704 | Insert_Action (Func_Call, Return_Obj_Decl); |
02822a92 | 8705 | |
7888a6ae GD |
8706 | -- When the function has a controlling result, an allocation-form |
8707 | -- parameter must be passed indicating that the caller is allocating | |
8708 | -- the result object. This is needed because such a function can be | |
8709 | -- called as a dispatching operation and must be treated similarly | |
8710 | -- to functions with unconstrained result subtypes. | |
8711 | ||
200b7162 | 8712 | Add_Unconstrained_Actuals_To_Build_In_Place_Call |
7888a6ae GD |
8713 | (Func_Call, Function_Id, Alloc_Form => Caller_Allocation); |
8714 | ||
d3f70b35 | 8715 | Add_Finalization_Master_Actual_To_Build_In_Place_Call |
df3e68b1 | 8716 | (Func_Call, Function_Id); |
f937473f | 8717 | |
f937473f RD |
8718 | Add_Task_Actuals_To_Build_In_Place_Call |
8719 | (Func_Call, Function_Id, Make_Identifier (Loc, Name_uMaster)); | |
7888a6ae GD |
8720 | |
8721 | -- Add an implicit actual to the function call that provides access | |
8722 | -- to the caller's return object. | |
8723 | ||
f937473f | 8724 | Add_Access_Actual_To_Build_In_Place_Call |
e4494292 | 8725 | (Func_Call, Function_Id, New_Occurrence_Of (Return_Obj_Id, Loc)); |
f937473f | 8726 | |
1ed19d98 | 8727 | pragma Assert (Check_Number_Of_Actuals (Func_Call, Function_Id)); |
82af7291 | 8728 | pragma Assert (Check_BIP_Actuals (Func_Call, Function_Id)); |
1ed19d98 | 8729 | |
f937473f RD |
8730 | -- When the result subtype is unconstrained, the function must allocate |
8731 | -- the return object in the secondary stack, so appropriate implicit | |
8732 | -- parameters are added to the call to indicate that. A transient | |
8733 | -- scope is established to ensure eventual cleanup of the result. | |
8734 | ||
8735 | else | |
8736 | -- Pass an allocation parameter indicating that the function should | |
8737 | -- allocate its result on the secondary stack. | |
8738 | ||
200b7162 | 8739 | Add_Unconstrained_Actuals_To_Build_In_Place_Call |
f937473f RD |
8740 | (Func_Call, Function_Id, Alloc_Form => Secondary_Stack); |
8741 | ||
d3f70b35 | 8742 | Add_Finalization_Master_Actual_To_Build_In_Place_Call |
df3e68b1 | 8743 | (Func_Call, Function_Id); |
f937473f | 8744 | |
f937473f RD |
8745 | Add_Task_Actuals_To_Build_In_Place_Call |
8746 | (Func_Call, Function_Id, Make_Identifier (Loc, Name_uMaster)); | |
7888a6ae GD |
8747 | |
8748 | -- Pass a null value to the function since no return object is | |
8749 | -- available on the caller side. | |
8750 | ||
f937473f RD |
8751 | Add_Access_Actual_To_Build_In_Place_Call |
8752 | (Func_Call, Function_Id, Empty); | |
1ed19d98 JM |
8753 | |
8754 | pragma Assert (Check_Number_Of_Actuals (Func_Call, Function_Id)); | |
82af7291 | 8755 | pragma Assert (Check_BIP_Actuals (Func_Call, Function_Id)); |
f937473f | 8756 | end if; |
02822a92 RD |
8757 | end Make_Build_In_Place_Call_In_Anonymous_Context; |
8758 | ||
ce2798e8 | 8759 | -------------------------------------------- |
02822a92 | 8760 | -- Make_Build_In_Place_Call_In_Assignment -- |
ce2798e8 | 8761 | -------------------------------------------- |
02822a92 RD |
8762 | |
8763 | procedure Make_Build_In_Place_Call_In_Assignment | |
8764 | (Assign : Node_Id; | |
8765 | Function_Call : Node_Id) | |
8766 | is | |
3fc40cd7 PMR |
8767 | Func_Call : constant Node_Id := Unqual_Conv (Function_Call); |
8768 | Lhs : constant Node_Id := Name (Assign); | |
d4dfb005 | 8769 | Loc : constant Source_Ptr := Sloc (Function_Call); |
3fc40cd7 | 8770 | Func_Id : Entity_Id; |
3a69b5ff AC |
8771 | Obj_Decl : Node_Id; |
8772 | Obj_Id : Entity_Id; | |
8773 | Ptr_Typ : Entity_Id; | |
8774 | Ptr_Typ_Decl : Node_Id; | |
74cab21a | 8775 | New_Expr : Node_Id; |
3a69b5ff | 8776 | Result_Subt : Entity_Id; |
02822a92 RD |
8777 | |
8778 | begin | |
358e289d JM |
8779 | -- No action needed if the called function inherited the BIP extra |
8780 | -- formals but it is not a true BIP function. | |
8781 | ||
8782 | if not Is_True_Build_In_Place_Function_Call (Func_Call) then | |
8783 | pragma Assert (Is_Expanded_Build_In_Place_Call (Func_Call)); | |
8784 | return; | |
8785 | end if; | |
8786 | ||
fdce4bb7 JM |
8787 | -- Mark the call as processed as a build-in-place call |
8788 | ||
d4dfb005 | 8789 | pragma Assert (not Is_Expanded_Build_In_Place_Call (Func_Call)); |
fdce4bb7 JM |
8790 | Set_Is_Expanded_Build_In_Place_Call (Func_Call); |
8791 | ||
02822a92 | 8792 | if Is_Entity_Name (Name (Func_Call)) then |
3a69b5ff | 8793 | Func_Id := Entity (Name (Func_Call)); |
02822a92 RD |
8794 | |
8795 | elsif Nkind (Name (Func_Call)) = N_Explicit_Dereference then | |
3a69b5ff | 8796 | Func_Id := Etype (Name (Func_Call)); |
02822a92 RD |
8797 | |
8798 | else | |
8799 | raise Program_Error; | |
8800 | end if; | |
8801 | ||
b19c922b VF |
8802 | Warn_BIP (Func_Call); |
8803 | ||
3a69b5ff | 8804 | Result_Subt := Etype (Func_Id); |
02822a92 | 8805 | |
f937473f RD |
8806 | -- When the result subtype is unconstrained, an additional actual must |
8807 | -- be passed to indicate that the caller is providing the return object. | |
7888a6ae GD |
8808 | -- This parameter must also be passed when the called function has a |
8809 | -- controlling result, because dispatching calls to the function needs | |
8810 | -- to be treated effectively the same as calls to class-wide functions. | |
f937473f | 8811 | |
200b7162 | 8812 | Add_Unconstrained_Actuals_To_Build_In_Place_Call |
3a69b5ff | 8813 | (Func_Call, Func_Id, Alloc_Form => Caller_Allocation); |
f937473f | 8814 | |
d3f70b35 | 8815 | Add_Finalization_Master_Actual_To_Build_In_Place_Call |
df3e68b1 | 8816 | (Func_Call, Func_Id); |
02822a92 | 8817 | |
f937473f | 8818 | Add_Task_Actuals_To_Build_In_Place_Call |
3a69b5ff | 8819 | (Func_Call, Func_Id, Make_Identifier (Loc, Name_uMaster)); |
7888a6ae GD |
8820 | |
8821 | -- Add an implicit actual to the function call that provides access to | |
8822 | -- the caller's return object. | |
8823 | ||
02822a92 | 8824 | Add_Access_Actual_To_Build_In_Place_Call |
738a0e8d | 8825 | (Func_Call, Func_Id, Unchecked_Convert_To (Result_Subt, Lhs)); |
02822a92 RD |
8826 | |
8827 | -- Create an access type designating the function's result subtype | |
8828 | ||
c12beea0 | 8829 | Ptr_Typ := Make_Temporary (Loc, 'A'); |
02822a92 RD |
8830 | |
8831 | Ptr_Typ_Decl := | |
8832 | Make_Full_Type_Declaration (Loc, | |
3a69b5ff | 8833 | Defining_Identifier => Ptr_Typ, |
2c1b72d7 | 8834 | Type_Definition => |
02822a92 | 8835 | Make_Access_To_Object_Definition (Loc, |
2c1b72d7 | 8836 | All_Present => True, |
02822a92 | 8837 | Subtype_Indication => |
e4494292 | 8838 | New_Occurrence_Of (Result_Subt, Loc))); |
02822a92 RD |
8839 | Insert_After_And_Analyze (Assign, Ptr_Typ_Decl); |
8840 | ||
8841 | -- Finally, create an access object initialized to a reference to the | |
03e1048e AC |
8842 | -- function call. We know this access value is non-null, so mark the |
8843 | -- entity accordingly to suppress junk access checks. | |
02822a92 | 8844 | |
74cab21a EB |
8845 | New_Expr := Make_Reference (Loc, Relocate_Node (Func_Call)); |
8846 | ||
d4dfb005 BD |
8847 | -- Add a conversion if it's the wrong type |
8848 | ||
738a0e8d | 8849 | New_Expr := Unchecked_Convert_To (Ptr_Typ, New_Expr); |
d4dfb005 | 8850 | |
74cab21a | 8851 | Obj_Id := Make_Temporary (Loc, 'R', New_Expr); |
3a69b5ff | 8852 | Set_Etype (Obj_Id, Ptr_Typ); |
74cab21a | 8853 | Set_Is_Known_Non_Null (Obj_Id); |
02822a92 | 8854 | |
3a69b5ff | 8855 | Obj_Decl := |
02822a92 | 8856 | Make_Object_Declaration (Loc, |
3a69b5ff | 8857 | Defining_Identifier => Obj_Id, |
e4494292 | 8858 | Object_Definition => New_Occurrence_Of (Ptr_Typ, Loc), |
74cab21a | 8859 | Expression => New_Expr); |
3a69b5ff | 8860 | Insert_After_And_Analyze (Ptr_Typ_Decl, Obj_Decl); |
02822a92 RD |
8861 | |
8862 | Rewrite (Assign, Make_Null_Statement (Loc)); | |
1ed19d98 | 8863 | pragma Assert (Check_Number_Of_Actuals (Func_Call, Func_Id)); |
82af7291 | 8864 | pragma Assert (Check_BIP_Actuals (Func_Call, Func_Id)); |
02822a92 RD |
8865 | end Make_Build_In_Place_Call_In_Assignment; |
8866 | ||
8867 | ---------------------------------------------------- | |
8868 | -- Make_Build_In_Place_Call_In_Object_Declaration -- | |
8869 | ---------------------------------------------------- | |
8870 | ||
8871 | procedure Make_Build_In_Place_Call_In_Object_Declaration | |
e5f2c03c | 8872 | (Obj_Decl : Node_Id; |
02822a92 RD |
8873 | Function_Call : Node_Id) |
8874 | is | |
15529d0a PMR |
8875 | function Get_Function_Id (Func_Call : Node_Id) return Entity_Id; |
8876 | -- Get the value of Function_Id, below | |
8877 | ||
3fc40cd7 PMR |
8878 | --------------------- |
8879 | -- Get_Function_Id -- | |
8880 | --------------------- | |
8881 | ||
15529d0a PMR |
8882 | function Get_Function_Id (Func_Call : Node_Id) return Entity_Id is |
8883 | begin | |
8884 | if Is_Entity_Name (Name (Func_Call)) then | |
8885 | return Entity (Name (Func_Call)); | |
8886 | ||
8887 | elsif Nkind (Name (Func_Call)) = N_Explicit_Dereference then | |
8888 | return Etype (Name (Func_Call)); | |
8889 | ||
8890 | else | |
8891 | raise Program_Error; | |
8892 | end if; | |
8893 | end Get_Function_Id; | |
8894 | ||
3fc40cd7 | 8895 | -- Local variables |
15529d0a | 8896 | |
3fc40cd7 PMR |
8897 | Func_Call : constant Node_Id := Unqual_Conv (Function_Call); |
8898 | Function_Id : constant Entity_Id := Get_Function_Id (Func_Call); | |
8899 | Loc : constant Source_Ptr := Sloc (Function_Call); | |
8900 | Obj_Loc : constant Source_Ptr := Sloc (Obj_Decl); | |
8901 | Obj_Def_Id : constant Entity_Id := Defining_Identifier (Obj_Decl); | |
8902 | Obj_Typ : constant Entity_Id := Etype (Obj_Def_Id); | |
8903 | Encl_Func : constant Entity_Id := Enclosing_Subprogram (Obj_Def_Id); | |
8904 | Result_Subt : constant Entity_Id := Etype (Function_Id); | |
e5f2c03c | 8905 | |
8417f4b2 AC |
8906 | Call_Deref : Node_Id; |
8907 | Caller_Object : Node_Id; | |
8908 | Def_Id : Entity_Id; | |
3fc40cd7 | 8909 | Designated_Type : Entity_Id; |
2c17ca0a | 8910 | Fmaster_Actual : Node_Id := Empty; |
8417f4b2 | 8911 | Pool_Actual : Node_Id; |
f65c67d3 | 8912 | Ptr_Typ : Entity_Id; |
8417f4b2 | 8913 | Ptr_Typ_Decl : Node_Id; |
f937473f | 8914 | Pass_Caller_Acc : Boolean := False; |
8c7ff9a0 | 8915 | Res_Decl : Node_Id; |
15529d0a PMR |
8916 | |
8917 | Definite : constant Boolean := | |
8918 | Caller_Known_Size (Func_Call, Result_Subt) | |
3fc40cd7 | 8919 | and then not Is_Class_Wide_Type (Obj_Typ); |
15529d0a PMR |
8920 | -- In the case of "X : T'Class := F(...);", where F returns a |
8921 | -- Caller_Known_Size (specific) tagged type, we treat it as | |
8922 | -- indefinite, because the code for the Definite case below sets the | |
8923 | -- initialization expression of the object to Empty, which would be | |
98b779ae PMR |
8924 | -- illegal Ada, and would cause gigi to misallocate X. |
8925 | ||
f1668c3d JM |
8926 | Is_OK_Return_Object : constant Boolean := |
8927 | Is_Return_Object (Obj_Def_Id) | |
8928 | and then | |
8929 | not Has_Foreign_Convention (Return_Applies_To (Scope (Obj_Def_Id))); | |
8930 | ||
98b779ae | 8931 | -- Start of processing for Make_Build_In_Place_Call_In_Object_Declaration |
b68cf874 | 8932 | |
02822a92 | 8933 | begin |
98b779ae PMR |
8934 | -- If the call has already been processed to add build-in-place actuals |
8935 | -- then return. | |
8936 | ||
8937 | if Is_Expanded_Build_In_Place_Call (Func_Call) then | |
8938 | return; | |
8939 | end if; | |
8940 | ||
fdce4bb7 JM |
8941 | -- Mark the call as processed as a build-in-place call |
8942 | ||
8943 | Set_Is_Expanded_Build_In_Place_Call (Func_Call); | |
8944 | ||
b19c922b VF |
8945 | Warn_BIP (Func_Call); |
8946 | ||
15529d0a PMR |
8947 | -- Create an access type designating the function's result subtype. |
8948 | -- We use the type of the original call because it may be a call to an | |
8949 | -- inherited operation, which the expansion has replaced with the parent | |
8950 | -- operation that yields the parent type. Note that this access type | |
8951 | -- must be declared before we establish a transient scope, so that it | |
8952 | -- receives the proper accessibility level. | |
02822a92 | 8953 | |
15529d0a PMR |
8954 | if Is_Class_Wide_Type (Obj_Typ) |
8955 | and then not Is_Interface (Obj_Typ) | |
8956 | and then not Is_Class_Wide_Type (Etype (Function_Call)) | |
8957 | then | |
8958 | Designated_Type := Obj_Typ; | |
8959 | else | |
8960 | Designated_Type := Etype (Function_Call); | |
8961 | end if; | |
02822a92 | 8962 | |
15529d0a PMR |
8963 | Ptr_Typ := Make_Temporary (Loc, 'A'); |
8964 | Ptr_Typ_Decl := | |
8965 | Make_Full_Type_Declaration (Loc, | |
8966 | Defining_Identifier => Ptr_Typ, | |
8967 | Type_Definition => | |
8968 | Make_Access_To_Object_Definition (Loc, | |
8969 | All_Present => True, | |
8970 | Subtype_Indication => | |
8971 | New_Occurrence_Of (Designated_Type, Loc))); | |
8972 | ||
8973 | -- The access type and its accompanying object must be inserted after | |
8974 | -- the object declaration in the constrained case, so that the function | |
8975 | -- call can be passed access to the object. In the indefinite case, or | |
8976 | -- if the object declaration is for a return object, the access type and | |
8977 | -- object must be inserted before the object, since the object | |
8978 | -- declaration is rewritten to be a renaming of a dereference of the | |
8979 | -- access object. Note: we need to freeze Ptr_Typ explicitly, because | |
8980 | -- the result object is in a different (transient) scope, so won't cause | |
8981 | -- freezing. | |
8982 | ||
f1668c3d | 8983 | if Definite and then not Is_OK_Return_Object then |
a2dbe7d5 ES |
8984 | |
8985 | -- The presence of an address clause complicates the build-in-place | |
8986 | -- expansion because the indicated address must be processed before | |
8987 | -- the indirect call is generated (including the definition of a | |
64ac53f4 | 8988 | -- local pointer to the object). The address clause may come from |
a2dbe7d5 ES |
8989 | -- an aspect specification or from an explicit attribute |
8990 | -- specification appearing after the object declaration. These two | |
8991 | -- cases require different processing. | |
8992 | ||
8993 | if Has_Aspect (Obj_Def_Id, Aspect_Address) then | |
8994 | ||
8995 | -- Skip non-delayed pragmas that correspond to other aspects, if | |
8996 | -- any, to find proper insertion point for freeze node of object. | |
8997 | ||
8998 | declare | |
8999 | D : Node_Id := Obj_Decl; | |
9000 | N : Node_Id := Next (D); | |
9001 | ||
9002 | begin | |
9003 | while Present (N) | |
4a08c95c | 9004 | and then Nkind (N) in N_Attribute_Reference | N_Pragma |
a2dbe7d5 ES |
9005 | loop |
9006 | Analyze (N); | |
9007 | D := N; | |
9008 | Next (N); | |
9009 | end loop; | |
9010 | ||
9011 | Insert_After (D, Ptr_Typ_Decl); | |
9012 | ||
9013 | -- Freeze object before pointer declaration, to ensure that | |
9014 | -- generated attribute for address is inserted at the proper | |
9015 | -- place. | |
9016 | ||
9017 | Freeze_Before (Ptr_Typ_Decl, Obj_Def_Id); | |
9018 | end; | |
9019 | ||
9020 | Analyze (Ptr_Typ_Decl); | |
9021 | ||
9022 | elsif Present (Following_Address_Clause (Obj_Decl)) then | |
9023 | ||
9024 | -- Locate explicit address clause, which may also follow pragmas | |
9025 | -- generated by other aspect specifications. | |
9026 | ||
9027 | declare | |
9028 | Addr : constant Node_Id := Following_Address_Clause (Obj_Decl); | |
9029 | D : Node_Id := Next (Obj_Decl); | |
9030 | ||
9031 | begin | |
9032 | while Present (D) loop | |
9033 | Analyze (D); | |
9034 | exit when D = Addr; | |
9035 | Next (D); | |
9036 | end loop; | |
9037 | ||
9038 | Insert_After_And_Analyze (Addr, Ptr_Typ_Decl); | |
9039 | end; | |
9040 | ||
9041 | else | |
9042 | Insert_After_And_Analyze (Obj_Decl, Ptr_Typ_Decl); | |
9043 | end if; | |
02822a92 | 9044 | else |
15529d0a | 9045 | Insert_Action (Obj_Decl, Ptr_Typ_Decl); |
02822a92 RD |
9046 | end if; |
9047 | ||
15529d0a PMR |
9048 | -- Force immediate freezing of Ptr_Typ because Res_Decl will be |
9049 | -- elaborated in an inner (transient) scope and thus won't cause | |
9050 | -- freezing by itself. It's not an itype, but it needs to be frozen | |
9051 | -- inside the current subprogram (see Freeze_Outside in freeze.adb). | |
9052 | ||
9053 | Freeze_Itype (Ptr_Typ, Ptr_Typ_Decl); | |
9054 | ||
9055 | -- If the object is a return object of an enclosing build-in-place | |
9056 | -- function, then the implicit build-in-place parameters of the | |
9057 | -- enclosing function are simply passed along to the called function. | |
9058 | -- (Unfortunately, this won't cover the case of extension aggregates | |
9059 | -- where the ancestor part is a build-in-place indefinite function | |
9060 | -- call that should be passed along the caller's parameters. | |
9061 | -- Currently those get mishandled by reassigning the result of the | |
9062 | -- call to the aggregate return object, when the call result should | |
9063 | -- really be directly built in place in the aggregate and not in a | |
9064 | -- temporary. ???) | |
9065 | ||
f1668c3d | 9066 | if Is_OK_Return_Object then |
15529d0a PMR |
9067 | Pass_Caller_Acc := True; |
9068 | ||
9069 | -- When the enclosing function has a BIP_Alloc_Form formal then we | |
3fc40cd7 PMR |
9070 | -- pass it along to the callee (such as when the enclosing function |
9071 | -- has an unconstrained or tagged result type). | |
15529d0a PMR |
9072 | |
9073 | if Needs_BIP_Alloc_Form (Encl_Func) then | |
9074 | if RTE_Available (RE_Root_Storage_Pool_Ptr) then | |
9075 | Pool_Actual := | |
9076 | New_Occurrence_Of | |
9077 | (Build_In_Place_Formal | |
9078 | (Encl_Func, BIP_Storage_Pool), Loc); | |
02822a92 | 9079 | |
15529d0a | 9080 | -- The build-in-place pool formal is not built on e.g. ZFP |
1155ae01 | 9081 | |
15529d0a PMR |
9082 | else |
9083 | Pool_Actual := Empty; | |
9084 | end if; | |
9085 | ||
9086 | Add_Unconstrained_Actuals_To_Build_In_Place_Call | |
9087 | (Function_Call => Func_Call, | |
9088 | Function_Id => Function_Id, | |
9089 | Alloc_Form_Exp => | |
9090 | New_Occurrence_Of | |
9091 | (Build_In_Place_Formal (Encl_Func, BIP_Alloc_Form), Loc), | |
9092 | Pool_Actual => Pool_Actual); | |
9093 | ||
9094 | -- Otherwise, if enclosing function has a definite result subtype, | |
9095 | -- then caller allocation will be used. | |
d4dfb005 | 9096 | |
0691ed6b | 9097 | else |
15529d0a PMR |
9098 | Add_Unconstrained_Actuals_To_Build_In_Place_Call |
9099 | (Func_Call, Function_Id, Alloc_Form => Caller_Allocation); | |
0691ed6b | 9100 | end if; |
f65c67d3 | 9101 | |
15529d0a PMR |
9102 | if Needs_BIP_Finalization_Master (Encl_Func) then |
9103 | Fmaster_Actual := | |
9104 | New_Occurrence_Of | |
9105 | (Build_In_Place_Formal | |
9106 | (Encl_Func, BIP_Finalization_Master), Loc); | |
9107 | end if; | |
f65c67d3 | 9108 | |
15529d0a PMR |
9109 | -- Retrieve the BIPacc formal from the enclosing function and convert |
9110 | -- it to the access type of the callee's BIP_Object_Access formal. | |
0691ed6b | 9111 | |
15529d0a | 9112 | Caller_Object := |
738a0e8d BD |
9113 | Unchecked_Convert_To |
9114 | (Etype (Build_In_Place_Formal (Function_Id, BIP_Object_Access)), | |
9115 | New_Occurrence_Of | |
9116 | (Build_In_Place_Formal (Encl_Func, BIP_Object_Access), Loc)); | |
0691ed6b | 9117 | |
15529d0a PMR |
9118 | -- In the definite case, add an implicit actual to the function call |
9119 | -- that provides access to the declared object. An unchecked conversion | |
9120 | -- to the (specific) result type of the function is inserted to handle | |
9121 | -- the case where the object is declared with a class-wide type. | |
0691ed6b | 9122 | |
15529d0a | 9123 | elsif Definite then |
738a0e8d BD |
9124 | Caller_Object := Unchecked_Convert_To |
9125 | (Result_Subt, New_Occurrence_Of (Obj_Def_Id, Loc)); | |
0691ed6b | 9126 | |
15529d0a PMR |
9127 | -- When the function has a controlling result, an allocation-form |
9128 | -- parameter must be passed indicating that the caller is allocating | |
9129 | -- the result object. This is needed because such a function can be | |
9130 | -- called as a dispatching operation and must be treated similarly to | |
9131 | -- functions with indefinite result subtypes. | |
f65c67d3 | 9132 | |
15529d0a PMR |
9133 | Add_Unconstrained_Actuals_To_Build_In_Place_Call |
9134 | (Func_Call, Function_Id, Alloc_Form => Caller_Allocation); | |
0691ed6b | 9135 | |
15529d0a PMR |
9136 | -- The allocation for indefinite library-level objects occurs on the |
9137 | -- heap as opposed to the secondary stack. This accommodates DLLs where | |
9138 | -- the secondary stack is destroyed after each library unload. This is a | |
9139 | -- hybrid mechanism where a stack-allocated object lives on the heap. | |
8417f4b2 | 9140 | |
15529d0a PMR |
9141 | elsif Is_Library_Level_Entity (Obj_Def_Id) |
9142 | and then not Restriction_Active (No_Implicit_Heap_Allocations) | |
9143 | then | |
9144 | Add_Unconstrained_Actuals_To_Build_In_Place_Call | |
9145 | (Func_Call, Function_Id, Alloc_Form => Global_Heap); | |
9146 | Caller_Object := Empty; | |
8417f4b2 | 9147 | |
15529d0a PMR |
9148 | -- Create a finalization master for the access result type to ensure |
9149 | -- that the heap allocation can properly chain the object and later | |
9150 | -- finalize it when the library unit goes out of scope. | |
8417f4b2 | 9151 | |
15529d0a PMR |
9152 | if Needs_Finalization (Etype (Func_Call)) then |
9153 | Build_Finalization_Master | |
9154 | (Typ => Ptr_Typ, | |
9155 | For_Lib_Level => True, | |
9156 | Insertion_Node => Ptr_Typ_Decl); | |
1bb6e262 | 9157 | |
15529d0a PMR |
9158 | Fmaster_Actual := |
9159 | Make_Attribute_Reference (Loc, | |
9160 | Prefix => | |
9161 | New_Occurrence_Of (Finalization_Master (Ptr_Typ), Loc), | |
9162 | Attribute_Name => Name_Unrestricted_Access); | |
9163 | end if; | |
1bb6e262 | 9164 | |
6560f851 HK |
9165 | -- In other indefinite cases, pass an indication to do the allocation |
9166 | -- on the secondary stack and set Caller_Object to Empty so that a null | |
15529d0a PMR |
9167 | -- value will be passed for the caller's object address. A transient |
9168 | -- scope is established to ensure eventual cleanup of the result. | |
1bb6e262 | 9169 | |
15529d0a PMR |
9170 | else |
9171 | Add_Unconstrained_Actuals_To_Build_In_Place_Call | |
9172 | (Func_Call, Function_Id, Alloc_Form => Secondary_Stack); | |
9173 | Caller_Object := Empty; | |
1bb6e262 | 9174 | |
6560f851 | 9175 | Establish_Transient_Scope (Obj_Decl, Manage_Sec_Stack => True); |
15529d0a | 9176 | end if; |
1bb6e262 | 9177 | |
15529d0a PMR |
9178 | -- Pass along any finalization master actual, which is needed in the |
9179 | -- case where the called function initializes a return object of an | |
9180 | -- enclosing build-in-place function. | |
1bb6e262 | 9181 | |
15529d0a PMR |
9182 | Add_Finalization_Master_Actual_To_Build_In_Place_Call |
9183 | (Func_Call => Func_Call, | |
9184 | Func_Id => Function_Id, | |
9185 | Master_Exp => Fmaster_Actual); | |
8434cfc7 | 9186 | |
15529d0a | 9187 | if Nkind (Parent (Obj_Decl)) = N_Extended_Return_Statement |
1ed19d98 | 9188 | and then Needs_BIP_Task_Actuals (Function_Id) |
15529d0a PMR |
9189 | then |
9190 | -- Here we're passing along the master that was passed in to this | |
9191 | -- function. | |
8434cfc7 | 9192 | |
15529d0a PMR |
9193 | Add_Task_Actuals_To_Build_In_Place_Call |
9194 | (Func_Call, Function_Id, | |
9195 | Master_Actual => | |
9196 | New_Occurrence_Of | |
9197 | (Build_In_Place_Formal (Encl_Func, BIP_Task_Master), Loc)); | |
8434cfc7 | 9198 | |
15529d0a PMR |
9199 | else |
9200 | Add_Task_Actuals_To_Build_In_Place_Call | |
9201 | (Func_Call, Function_Id, Make_Identifier (Loc, Name_uMaster)); | |
9202 | end if; | |
8434cfc7 | 9203 | |
15529d0a PMR |
9204 | Add_Access_Actual_To_Build_In_Place_Call |
9205 | (Func_Call, | |
9206 | Function_Id, | |
9207 | Caller_Object, | |
9208 | Is_Access => Pass_Caller_Acc); | |
8434cfc7 | 9209 | |
15529d0a PMR |
9210 | -- Finally, create an access object initialized to a reference to the |
9211 | -- function call. We know this access value cannot be null, so mark the | |
84adfddd BD |
9212 | -- entity accordingly to suppress the access check. We need to suppress |
9213 | -- warnings, because this can be part of the expansion of "for ... of" | |
9214 | -- and similar constructs that generate finalization actions. Such | |
9215 | -- finalization actions are safe, because they check a count that | |
9216 | -- indicates which objects should be finalized, but the back end | |
9217 | -- nonetheless warns about uninitialized objects. | |
2c17ca0a | 9218 | |
15529d0a | 9219 | Def_Id := Make_Temporary (Loc, 'R', Func_Call); |
84adfddd | 9220 | Set_Warnings_Off (Def_Id); |
15529d0a PMR |
9221 | Set_Etype (Def_Id, Ptr_Typ); |
9222 | Set_Is_Known_Non_Null (Def_Id); | |
7888a6ae | 9223 | |
4a08c95c AC |
9224 | if Nkind (Function_Call) in N_Type_Conversion |
9225 | | N_Unchecked_Type_Conversion | |
5d57846b | 9226 | then |
15529d0a PMR |
9227 | Res_Decl := |
9228 | Make_Object_Declaration (Loc, | |
9229 | Defining_Identifier => Def_Id, | |
9230 | Constant_Present => True, | |
9231 | Object_Definition => New_Occurrence_Of (Ptr_Typ, Loc), | |
9232 | Expression => | |
738a0e8d BD |
9233 | Unchecked_Convert_To |
9234 | (Ptr_Typ, Make_Reference (Loc, Relocate_Node (Func_Call)))); | |
15529d0a PMR |
9235 | else |
9236 | Res_Decl := | |
9237 | Make_Object_Declaration (Loc, | |
9238 | Defining_Identifier => Def_Id, | |
9239 | Constant_Present => True, | |
9240 | Object_Definition => New_Occurrence_Of (Ptr_Typ, Loc), | |
9241 | Expression => | |
9242 | Make_Reference (Loc, Relocate_Node (Func_Call))); | |
9243 | end if; | |
7888a6ae | 9244 | |
15529d0a | 9245 | Insert_After_And_Analyze (Ptr_Typ_Decl, Res_Decl); |
7888a6ae | 9246 | |
15529d0a PMR |
9247 | -- If the result subtype of the called function is definite and is not |
9248 | -- itself the return expression of an enclosing BIP function, then mark | |
9249 | -- the object as having no initialization. | |
7888a6ae | 9250 | |
f1668c3d | 9251 | if Definite and then not Is_OK_Return_Object then |
3fc40cd7 | 9252 | |
15529d0a PMR |
9253 | -- The related object declaration is encased in a transient block |
9254 | -- because the build-in-place function call contains at least one | |
9255 | -- nested function call that produces a controlled transient | |
9256 | -- temporary: | |
02822a92 | 9257 | |
15529d0a | 9258 | -- Obj : ... := BIP_Func_Call (Ctrl_Func_Call); |
02822a92 | 9259 | |
15529d0a PMR |
9260 | -- Since the build-in-place expansion decouples the call from the |
9261 | -- object declaration, the finalization machinery lacks the context | |
9262 | -- which prompted the generation of the transient block. To resolve | |
9263 | -- this scenario, store the build-in-place call. | |
c12beea0 | 9264 | |
7e8e3cb4 | 9265 | if Scope_Is_Transient then |
15529d0a | 9266 | Set_BIP_Initialization_Call (Obj_Def_Id, Res_Decl); |
d4dfb005 | 9267 | end if; |
f65c67d3 | 9268 | |
15529d0a PMR |
9269 | Set_Expression (Obj_Decl, Empty); |
9270 | Set_No_Initialization (Obj_Decl); | |
f937473f | 9271 | |
15529d0a PMR |
9272 | -- In case of an indefinite result subtype, or if the call is the |
9273 | -- return expression of an enclosing BIP function, rewrite the object | |
9274 | -- declaration as an object renaming where the renamed object is a | |
9275 | -- dereference of <function_Call>'reference: | |
9276 | -- | |
9277 | -- Obj : Subt renames <function_call>'Ref.all; | |
f937473f | 9278 | |
15529d0a PMR |
9279 | else |
9280 | Call_Deref := | |
9281 | Make_Explicit_Dereference (Obj_Loc, | |
9282 | Prefix => New_Occurrence_Of (Def_Id, Obj_Loc)); | |
9283 | ||
9284 | Rewrite (Obj_Decl, | |
9285 | Make_Object_Renaming_Declaration (Obj_Loc, | |
9286 | Defining_Identifier => Make_Temporary (Obj_Loc, 'D'), | |
3fc40cd7 | 9287 | Subtype_Mark => |
15529d0a | 9288 | New_Occurrence_Of (Designated_Type, Obj_Loc), |
3fc40cd7 | 9289 | Name => Call_Deref)); |
15529d0a | 9290 | |
90e491a7 PMR |
9291 | -- At this point, Defining_Identifier (Obj_Decl) is no longer equal |
9292 | -- to Obj_Def_Id. | |
9293 | ||
19e7eae5 BD |
9294 | pragma Assert (Ekind (Defining_Identifier (Obj_Decl)) = E_Void); |
9295 | Set_Renamed_Object_Of_Possibly_Void | |
9296 | (Defining_Identifier (Obj_Decl), Call_Deref); | |
15529d0a PMR |
9297 | |
9298 | -- If the original entity comes from source, then mark the new | |
9299 | -- entity as needing debug information, even though it's defined | |
9300 | -- by a generated renaming that does not come from source, so that | |
9301 | -- the Materialize_Entity flag will be set on the entity when | |
9302 | -- Debug_Renaming_Declaration is called during analysis. | |
9303 | ||
9304 | if Comes_From_Source (Obj_Def_Id) then | |
90e491a7 | 9305 | Set_Debug_Info_Needed (Defining_Identifier (Obj_Decl)); |
0691ed6b | 9306 | end if; |
cd644ae2 | 9307 | |
15529d0a PMR |
9308 | Analyze (Obj_Decl); |
9309 | Replace_Renaming_Declaration_Id | |
9310 | (Obj_Decl, Original_Node (Obj_Decl)); | |
cd644ae2 | 9311 | end if; |
1ed19d98 JM |
9312 | |
9313 | pragma Assert (Check_Number_Of_Actuals (Func_Call, Function_Id)); | |
82af7291 | 9314 | pragma Assert (Check_BIP_Actuals (Func_Call, Function_Id)); |
02822a92 RD |
9315 | end Make_Build_In_Place_Call_In_Object_Declaration; |
9316 | ||
4ac62786 AC |
9317 | ------------------------------------------------- |
9318 | -- Make_Build_In_Place_Iface_Call_In_Allocator -- | |
9319 | ------------------------------------------------- | |
9320 | ||
9321 | procedure Make_Build_In_Place_Iface_Call_In_Allocator | |
9322 | (Allocator : Node_Id; | |
9323 | Function_Call : Node_Id) | |
9324 | is | |
9325 | BIP_Func_Call : constant Node_Id := | |
9326 | Unqual_BIP_Iface_Function_Call (Function_Call); | |
9327 | Loc : constant Source_Ptr := Sloc (Function_Call); | |
9328 | ||
9329 | Anon_Type : Entity_Id; | |
9330 | Tmp_Decl : Node_Id; | |
9331 | Tmp_Id : Entity_Id; | |
9332 | ||
9333 | begin | |
68dd6649 | 9334 | -- No action if the call has already been processed |
4ac62786 AC |
9335 | |
9336 | if Is_Expanded_Build_In_Place_Call (BIP_Func_Call) then | |
9337 | return; | |
9338 | end if; | |
9339 | ||
9340 | Tmp_Id := Make_Temporary (Loc, 'D'); | |
9341 | ||
9342 | -- Insert a temporary before N initialized with the BIP function call | |
9343 | -- without its enclosing type conversions and analyze it without its | |
9344 | -- expansion. This temporary facilitates us reusing the BIP machinery, | |
9345 | -- which takes care of adding the extra build-in-place actuals and | |
9346 | -- transforms this object declaration into an object renaming | |
9347 | -- declaration. | |
9348 | ||
9349 | Anon_Type := Create_Itype (E_Anonymous_Access_Type, Function_Call); | |
84ae33e7 | 9350 | Set_Directly_Designated_Type (Anon_Type, Etype (BIP_Func_Call)); |
4ac62786 | 9351 | Set_Etype (Anon_Type, Anon_Type); |
a7837c08 | 9352 | Build_Class_Wide_Master (Anon_Type); |
4ac62786 AC |
9353 | |
9354 | Tmp_Decl := | |
9355 | Make_Object_Declaration (Loc, | |
9356 | Defining_Identifier => Tmp_Id, | |
9357 | Object_Definition => New_Occurrence_Of (Anon_Type, Loc), | |
9358 | Expression => | |
9359 | Make_Allocator (Loc, | |
9360 | Expression => | |
9361 | Make_Qualified_Expression (Loc, | |
9362 | Subtype_Mark => | |
9363 | New_Occurrence_Of (Etype (BIP_Func_Call), Loc), | |
9364 | Expression => New_Copy_Tree (BIP_Func_Call)))); | |
9365 | ||
3c30eac8 | 9366 | -- Manually set the associated node for the anonymous access type to |
0b4034c0 GD |
9367 | -- be its local declaration, to avoid confusing and complicating |
9368 | -- the accessibility machinery. | |
3c30eac8 JS |
9369 | |
9370 | Set_Associated_Node_For_Itype (Anon_Type, Tmp_Decl); | |
9371 | ||
4ac62786 AC |
9372 | Expander_Mode_Save_And_Set (False); |
9373 | Insert_Action (Allocator, Tmp_Decl); | |
9374 | Expander_Mode_Restore; | |
9375 | ||
9376 | Make_Build_In_Place_Call_In_Allocator | |
9377 | (Allocator => Expression (Tmp_Decl), | |
9378 | Function_Call => Expression (Expression (Tmp_Decl))); | |
9379 | ||
84ae33e7 JM |
9380 | -- Add a conversion to displace the pointer to the allocated object |
9381 | -- to reference the corresponding dispatch table. | |
9382 | ||
9383 | Rewrite (Allocator, | |
9384 | Convert_To (Etype (Allocator), | |
9385 | New_Occurrence_Of (Tmp_Id, Loc))); | |
4ac62786 AC |
9386 | end Make_Build_In_Place_Iface_Call_In_Allocator; |
9387 | ||
9388 | --------------------------------------------------------- | |
9389 | -- Make_Build_In_Place_Iface_Call_In_Anonymous_Context -- | |
9390 | --------------------------------------------------------- | |
9391 | ||
9392 | procedure Make_Build_In_Place_Iface_Call_In_Anonymous_Context | |
9393 | (Function_Call : Node_Id) | |
9394 | is | |
9395 | BIP_Func_Call : constant Node_Id := | |
9396 | Unqual_BIP_Iface_Function_Call (Function_Call); | |
9397 | Loc : constant Source_Ptr := Sloc (Function_Call); | |
9398 | ||
9399 | Tmp_Decl : Node_Id; | |
9400 | Tmp_Id : Entity_Id; | |
9401 | ||
9402 | begin | |
9403 | -- No action of the call has already been processed | |
9404 | ||
9405 | if Is_Expanded_Build_In_Place_Call (BIP_Func_Call) then | |
9406 | return; | |
9407 | end if; | |
9408 | ||
9409 | pragma Assert (Needs_Finalization (Etype (BIP_Func_Call))); | |
9410 | ||
9411 | -- Insert a temporary before the call initialized with function call to | |
9412 | -- reuse the BIP machinery which takes care of adding the extra build-in | |
9413 | -- place actuals and transforms this object declaration into an object | |
9414 | -- renaming declaration. | |
9415 | ||
9416 | Tmp_Id := Make_Temporary (Loc, 'D'); | |
9417 | ||
9418 | Tmp_Decl := | |
9419 | Make_Object_Declaration (Loc, | |
9420 | Defining_Identifier => Tmp_Id, | |
9421 | Object_Definition => | |
9422 | New_Occurrence_Of (Etype (Function_Call), Loc), | |
9423 | Expression => Relocate_Node (Function_Call)); | |
9424 | ||
9425 | Expander_Mode_Save_And_Set (False); | |
9426 | Insert_Action (Function_Call, Tmp_Decl); | |
9427 | Expander_Mode_Restore; | |
9428 | ||
9429 | Make_Build_In_Place_Iface_Call_In_Object_Declaration | |
9430 | (Obj_Decl => Tmp_Decl, | |
9431 | Function_Call => Expression (Tmp_Decl)); | |
9432 | end Make_Build_In_Place_Iface_Call_In_Anonymous_Context; | |
9433 | ||
9434 | ---------------------------------------------------------- | |
9435 | -- Make_Build_In_Place_Iface_Call_In_Object_Declaration -- | |
9436 | ---------------------------------------------------------- | |
9437 | ||
9438 | procedure Make_Build_In_Place_Iface_Call_In_Object_Declaration | |
9439 | (Obj_Decl : Node_Id; | |
9440 | Function_Call : Node_Id) | |
9441 | is | |
9442 | BIP_Func_Call : constant Node_Id := | |
9443 | Unqual_BIP_Iface_Function_Call (Function_Call); | |
9444 | Loc : constant Source_Ptr := Sloc (Function_Call); | |
9445 | Obj_Id : constant Entity_Id := Defining_Entity (Obj_Decl); | |
9446 | ||
9447 | Tmp_Decl : Node_Id; | |
9448 | Tmp_Id : Entity_Id; | |
9449 | ||
9450 | begin | |
9451 | -- No action of the call has already been processed | |
9452 | ||
9453 | if Is_Expanded_Build_In_Place_Call (BIP_Func_Call) then | |
9454 | return; | |
9455 | end if; | |
9456 | ||
9457 | Tmp_Id := Make_Temporary (Loc, 'D'); | |
9458 | ||
9459 | -- Insert a temporary before N initialized with the BIP function call | |
9460 | -- without its enclosing type conversions and analyze it without its | |
9461 | -- expansion. This temporary facilitates us reusing the BIP machinery, | |
9462 | -- which takes care of adding the extra build-in-place actuals and | |
9463 | -- transforms this object declaration into an object renaming | |
9464 | -- declaration. | |
9465 | ||
9466 | Tmp_Decl := | |
9467 | Make_Object_Declaration (Loc, | |
9468 | Defining_Identifier => Tmp_Id, | |
9469 | Object_Definition => | |
9470 | New_Occurrence_Of (Etype (BIP_Func_Call), Loc), | |
9471 | Expression => New_Copy_Tree (BIP_Func_Call)); | |
9472 | ||
9473 | Expander_Mode_Save_And_Set (False); | |
9474 | Insert_Action (Obj_Decl, Tmp_Decl); | |
9475 | Expander_Mode_Restore; | |
9476 | ||
9477 | Make_Build_In_Place_Call_In_Object_Declaration | |
9478 | (Obj_Decl => Tmp_Decl, | |
9479 | Function_Call => Expression (Tmp_Decl)); | |
9480 | ||
9481 | pragma Assert (Nkind (Tmp_Decl) = N_Object_Renaming_Declaration); | |
9482 | ||
9483 | -- Replace the original build-in-place function call by a reference to | |
9484 | -- the resulting temporary object renaming declaration. In this way, | |
9485 | -- all the interface conversions performed in the original Function_Call | |
9486 | -- on the build-in-place object are preserved. | |
9487 | ||
9488 | Rewrite (BIP_Func_Call, New_Occurrence_Of (Tmp_Id, Loc)); | |
9489 | ||
9490 | -- Replace the original object declaration by an internal object | |
9491 | -- renaming declaration. This leaves the generated code more clean (the | |
9492 | -- build-in-place function call in an object renaming declaration and | |
9493 | -- displacements of the pointer to the build-in-place object in another | |
9494 | -- renaming declaration) and allows us to invoke the routine that takes | |
9495 | -- care of replacing the identifier of the renaming declaration (routine | |
9496 | -- originally developed for the regular build-in-place management). | |
9497 | ||
9498 | Rewrite (Obj_Decl, | |
9499 | Make_Object_Renaming_Declaration (Loc, | |
9500 | Defining_Identifier => Make_Temporary (Loc, 'D'), | |
9501 | Subtype_Mark => New_Occurrence_Of (Etype (Obj_Id), Loc), | |
9502 | Name => Function_Call)); | |
9503 | Analyze (Obj_Decl); | |
9504 | ||
9505 | Replace_Renaming_Declaration_Id (Obj_Decl, Original_Node (Obj_Decl)); | |
9506 | end Make_Build_In_Place_Iface_Call_In_Object_Declaration; | |
9507 | ||
3bfb3c03 JM |
9508 | -------------------------------------------- |
9509 | -- Make_CPP_Constructor_Call_In_Allocator -- | |
9510 | -------------------------------------------- | |
9511 | ||
9512 | procedure Make_CPP_Constructor_Call_In_Allocator | |
9513 | (Allocator : Node_Id; | |
9514 | Function_Call : Node_Id) | |
9515 | is | |
9516 | Loc : constant Source_Ptr := Sloc (Function_Call); | |
9517 | Acc_Type : constant Entity_Id := Etype (Allocator); | |
9518 | Function_Id : constant Entity_Id := Entity (Name (Function_Call)); | |
9519 | Result_Subt : constant Entity_Id := Available_View (Etype (Function_Id)); | |
9520 | ||
9521 | New_Allocator : Node_Id; | |
9522 | Return_Obj_Access : Entity_Id; | |
9523 | Tmp_Obj : Node_Id; | |
9524 | ||
9525 | begin | |
9526 | pragma Assert (Nkind (Allocator) = N_Allocator | |
8c7ff9a0 | 9527 | and then Nkind (Function_Call) = N_Function_Call); |
3bfb3c03 | 9528 | pragma Assert (Convention (Function_Id) = Convention_CPP |
8c7ff9a0 | 9529 | and then Is_Constructor (Function_Id)); |
3bfb3c03 JM |
9530 | pragma Assert (Is_Constrained (Underlying_Type (Result_Subt))); |
9531 | ||
9532 | -- Replace the initialized allocator of form "new T'(Func (...))" with | |
9533 | -- an uninitialized allocator of form "new T", where T is the result | |
9534 | -- subtype of the called function. The call to the function is handled | |
9535 | -- separately further below. | |
9536 | ||
9537 | New_Allocator := | |
9538 | Make_Allocator (Loc, | |
e4494292 | 9539 | Expression => New_Occurrence_Of (Result_Subt, Loc)); |
3bfb3c03 JM |
9540 | Set_No_Initialization (New_Allocator); |
9541 | ||
9542 | -- Copy attributes to new allocator. Note that the new allocator | |
9543 | -- logically comes from source if the original one did, so copy the | |
9544 | -- relevant flag. This ensures proper treatment of the restriction | |
9545 | -- No_Implicit_Heap_Allocations in this case. | |
9546 | ||
9547 | Set_Storage_Pool (New_Allocator, Storage_Pool (Allocator)); | |
9548 | Set_Procedure_To_Call (New_Allocator, Procedure_To_Call (Allocator)); | |
9549 | Set_Comes_From_Source (New_Allocator, Comes_From_Source (Allocator)); | |
9550 | ||
9551 | Rewrite (Allocator, New_Allocator); | |
9552 | ||
9553 | -- Create a new access object and initialize it to the result of the | |
9554 | -- new uninitialized allocator. Note: we do not use Allocator as the | |
9555 | -- Related_Node of Return_Obj_Access in call to Make_Temporary below | |
9556 | -- as this would create a sort of infinite "recursion". | |
9557 | ||
9558 | Return_Obj_Access := Make_Temporary (Loc, 'R'); | |
9559 | Set_Etype (Return_Obj_Access, Acc_Type); | |
9560 | ||
9561 | -- Generate: | |
9562 | -- Rnnn : constant ptr_T := new (T); | |
9563 | -- Init (Rnn.all,...); | |
9564 | ||
9565 | Tmp_Obj := | |
9566 | Make_Object_Declaration (Loc, | |
9567 | Defining_Identifier => Return_Obj_Access, | |
9568 | Constant_Present => True, | |
e4494292 | 9569 | Object_Definition => New_Occurrence_Of (Acc_Type, Loc), |
3bfb3c03 JM |
9570 | Expression => Relocate_Node (Allocator)); |
9571 | Insert_Action (Allocator, Tmp_Obj); | |
9572 | ||
9573 | Insert_List_After_And_Analyze (Tmp_Obj, | |
9574 | Build_Initialization_Call (Loc, | |
9575 | Id_Ref => | |
9576 | Make_Explicit_Dereference (Loc, | |
e4494292 | 9577 | Prefix => New_Occurrence_Of (Return_Obj_Access, Loc)), |
3bfb3c03 JM |
9578 | Typ => Etype (Function_Id), |
9579 | Constructor_Ref => Function_Call)); | |
9580 | ||
9581 | -- Finally, replace the allocator node with a reference to the result of | |
9582 | -- the function call itself (which will effectively be an access to the | |
9583 | -- object created by the allocator). | |
9584 | ||
e4494292 | 9585 | Rewrite (Allocator, New_Occurrence_Of (Return_Obj_Access, Loc)); |
3bfb3c03 JM |
9586 | |
9587 | -- Ada 2005 (AI-251): If the type of the allocator is an interface then | |
9588 | -- generate an implicit conversion to force displacement of the "this" | |
9589 | -- pointer. | |
9590 | ||
9591 | if Is_Interface (Designated_Type (Acc_Type)) then | |
9592 | Rewrite (Allocator, Convert_To (Acc_Type, Relocate_Node (Allocator))); | |
9593 | end if; | |
9594 | ||
9595 | Analyze_And_Resolve (Allocator, Acc_Type); | |
9596 | end Make_CPP_Constructor_Call_In_Allocator; | |
9597 | ||
a7837c08 JM |
9598 | ---------------------- |
9599 | -- Might_Have_Tasks -- | |
9600 | ---------------------- | |
9601 | ||
9602 | function Might_Have_Tasks (Typ : Entity_Id) return Boolean is | |
9603 | begin | |
9604 | return not Global_No_Tasking | |
9605 | and then not No_Run_Time_Mode | |
95260403 JM |
9606 | and then (Has_Task (Typ) |
9607 | or else (Is_Class_Wide_Type (Typ) | |
4ca26401 | 9608 | and then Is_Limited_Record (Typ) |
811b8aa5 BD |
9609 | and then not Has_Aspect |
9610 | (Etype (Typ), Aspect_No_Task_Parts))); | |
a7837c08 JM |
9611 | end Might_Have_Tasks; |
9612 | ||
1ed19d98 JM |
9613 | ---------------------------- |
9614 | -- Needs_BIP_Task_Actuals -- | |
9615 | ---------------------------- | |
9616 | ||
9617 | function Needs_BIP_Task_Actuals (Func_Id : Entity_Id) return Boolean is | |
82af7291 JM |
9618 | Subp_Id : Entity_Id; |
9619 | Func_Typ : Entity_Id; | |
9620 | ||
1ed19d98 | 9621 | begin |
765005dd JM |
9622 | if Global_No_Tasking or else No_Run_Time_Mode then |
9623 | return False; | |
9624 | end if; | |
9625 | ||
82af7291 JM |
9626 | -- For thunks we must rely on their target entity; otherwise, given that |
9627 | -- the profile of thunks for functions returning a limited interface | |
9628 | -- type returns a class-wide type, we would erroneously add these extra | |
9629 | -- formals. | |
9630 | ||
9631 | if Is_Thunk (Func_Id) then | |
89e037d0 | 9632 | Subp_Id := Thunk_Target (Func_Id); |
82af7291 JM |
9633 | |
9634 | -- Common case | |
9635 | ||
9636 | else | |
9637 | Subp_Id := Func_Id; | |
9638 | end if; | |
9639 | ||
9640 | Func_Typ := Underlying_Type (Etype (Subp_Id)); | |
9641 | ||
f1668c3d JM |
9642 | -- Functions returning types with foreign convention don't have extra |
9643 | -- formals. | |
9644 | ||
9645 | if Has_Foreign_Convention (Func_Typ) then | |
9646 | return False; | |
9647 | ||
765005dd JM |
9648 | -- At first sight, for all the following cases, we could add assertions |
9649 | -- to ensure that if Func_Id is frozen then the computed result matches | |
9650 | -- with the availability of the task master extra formal; unfortunately | |
9651 | -- this is not feasible because we may be precisely freezing this entity | |
aaa3a675 GD |
9652 | -- (that is, Is_Frozen has been set by Freeze_Entity but it has not |
9653 | -- completed its work). | |
765005dd | 9654 | |
f1668c3d | 9655 | elsif Has_Task (Func_Typ) then |
765005dd JM |
9656 | return True; |
9657 | ||
9658 | elsif Ekind (Func_Id) = E_Function then | |
9659 | return Might_Have_Tasks (Func_Typ); | |
9660 | ||
9661 | -- Handle subprogram type internally generated for dispatching call. We | |
aaa3a675 | 9662 | -- cannot rely on the return type of the subprogram type of dispatching |
765005dd | 9663 | -- calls since it is always a class-wide type (cf. Expand_Dispatching_ |
aaa3a675 | 9664 | -- Call). |
765005dd JM |
9665 | |
9666 | elsif Ekind (Func_Id) = E_Subprogram_Type then | |
9667 | if Is_Dispatch_Table_Entity (Func_Id) then | |
9668 | return Has_BIP_Extra_Formal (Func_Id, BIP_Task_Master); | |
9669 | else | |
9670 | return Might_Have_Tasks (Func_Typ); | |
9671 | end if; | |
9672 | ||
9673 | else | |
9674 | raise Program_Error; | |
9675 | end if; | |
1ed19d98 JM |
9676 | end Needs_BIP_Task_Actuals; |
9677 | ||
d3f70b35 AC |
9678 | ----------------------------------- |
9679 | -- Needs_BIP_Finalization_Master -- | |
9680 | ----------------------------------- | |
8fb68c56 | 9681 | |
89e037d0 | 9682 | function Needs_BIP_Finalization_Master (Func_Id : Entity_Id) return Boolean |
d3f70b35 | 9683 | is |
89e037d0 EB |
9684 | Typ : constant Entity_Id := Underlying_Type (Etype (Func_Id)); |
9685 | ||
048e5cef | 9686 | begin |
66340e0e AC |
9687 | -- A formal giving the finalization master is needed for build-in-place |
9688 | -- functions whose result type needs finalization or is a tagged type. | |
9689 | -- Tagged primitive build-in-place functions need such a formal because | |
9690 | -- they can be called by a dispatching call, and extensions may require | |
89e037d0 EB |
9691 | -- finalization even if the root type doesn't. This means nonprimitive |
9692 | -- build-in-place functions with tagged results also need it, since such | |
9693 | -- functions can be called via access-to-function types, and those can | |
9694 | -- be used to call primitives, so the formal needs to be passed to all | |
9695 | -- such build-in-place functions, primitive or not. | |
9696 | ||
9697 | return not Restriction_Active (No_Finalization) | |
f1668c3d JM |
9698 | and then (Needs_Finalization (Typ) or else Is_Tagged_Type (Typ)) |
9699 | and then not Has_Foreign_Convention (Typ); | |
d3f70b35 | 9700 | end Needs_BIP_Finalization_Master; |
048e5cef | 9701 | |
1bb6e262 AC |
9702 | -------------------------- |
9703 | -- Needs_BIP_Alloc_Form -- | |
9704 | -------------------------- | |
9705 | ||
9706 | function Needs_BIP_Alloc_Form (Func_Id : Entity_Id) return Boolean is | |
89e037d0 EB |
9707 | Typ : constant Entity_Id := Underlying_Type (Etype (Func_Id)); |
9708 | ||
1bb6e262 | 9709 | begin |
89e037d0 EB |
9710 | -- A formal giving the allocation method is needed for build-in-place |
9711 | -- functions whose result type is returned on the secondary stack or | |
9712 | -- is a tagged type. Tagged primitive build-in-place functions need | |
9713 | -- such a formal because they can be called by a dispatching call, and | |
9714 | -- the secondary stack is always used for dispatching-on-result calls. | |
9715 | -- This means nonprimitive build-in-place functions with tagged results | |
9716 | -- also need it, as such functions can be called via access-to-function | |
9717 | -- types, and those can be used to call primitives, so the formal needs | |
9718 | -- to be passed to all such build-in-place functions, primitive or not. | |
9719 | ||
b979a474 JM |
9720 | -- We never use build-in-place if the function has foreign convention, |
9721 | -- but note that it is OK for a build-in-place function to return a | |
9722 | -- type with a foreign convention because the machinery ensures there | |
9723 | -- is no copying. | |
9724 | ||
89e037d0 | 9725 | return not Restriction_Active (No_Secondary_Stack) |
f1668c3d | 9726 | and then (Needs_Secondary_Stack (Typ) or else Is_Tagged_Type (Typ)) |
b979a474 | 9727 | and then not Has_Foreign_Convention (Func_Id); |
1bb6e262 AC |
9728 | end Needs_BIP_Alloc_Form; |
9729 | ||
4ac62786 AC |
9730 | ------------------------------------- |
9731 | -- Replace_Renaming_Declaration_Id -- | |
9732 | ------------------------------------- | |
9733 | ||
9734 | procedure Replace_Renaming_Declaration_Id | |
9735 | (New_Decl : Node_Id; | |
9736 | Orig_Decl : Node_Id) | |
9737 | is | |
9738 | New_Id : constant Entity_Id := Defining_Entity (New_Decl); | |
9739 | Orig_Id : constant Entity_Id := Defining_Entity (Orig_Decl); | |
9740 | ||
9741 | begin | |
9742 | Set_Chars (New_Id, Chars (Orig_Id)); | |
9743 | ||
9744 | -- Swap next entity links in preparation for exchanging entities | |
9745 | ||
9746 | declare | |
9747 | Next_Id : constant Entity_Id := Next_Entity (New_Id); | |
9748 | begin | |
3f6d1daa JS |
9749 | Link_Entities (New_Id, Next_Entity (Orig_Id)); |
9750 | Link_Entities (Orig_Id, Next_Id); | |
4ac62786 AC |
9751 | end; |
9752 | ||
9753 | Set_Homonym (New_Id, Homonym (Orig_Id)); | |
9754 | Exchange_Entities (New_Id, Orig_Id); | |
9755 | ||
9756 | -- Preserve source indication of original declaration, so that xref | |
9757 | -- information is properly generated for the right entity. | |
9758 | ||
9759 | Preserve_Comes_From_Source (New_Decl, Orig_Decl); | |
9760 | Preserve_Comes_From_Source (Orig_Id, Orig_Decl); | |
9761 | ||
9762 | Set_Comes_From_Source (New_Id, False); | |
83d52e6d EB |
9763 | |
9764 | -- Preserve aliased indication | |
9765 | ||
9766 | Set_Is_Aliased (Orig_Id, Is_Aliased (New_Id)); | |
4ac62786 AC |
9767 | end Replace_Renaming_Declaration_Id; |
9768 | ||
2700b9c1 AC |
9769 | --------------------------------- |
9770 | -- Rewrite_Function_Call_For_C -- | |
9771 | --------------------------------- | |
9772 | ||
9773 | procedure Rewrite_Function_Call_For_C (N : Node_Id) is | |
9b7924dd AC |
9774 | Orig_Func : constant Entity_Id := Entity (Name (N)); |
9775 | Func_Id : constant Entity_Id := Ultimate_Alias (Orig_Func); | |
5c12e9fb | 9776 | Par : constant Node_Id := Parent (N); |
888be6b1 | 9777 | Proc_Id : constant Entity_Id := Corresponding_Procedure (Func_Id); |
cdabbb52 | 9778 | Loc : constant Source_Ptr := Sloc (Par); |
5c12e9fb | 9779 | Actuals : List_Id; |
9b7924dd | 9780 | Last_Actual : Node_Id; |
5c12e9fb | 9781 | Last_Formal : Entity_Id; |
2700b9c1 | 9782 | |
aeb98f1d JM |
9783 | -- Start of processing for Rewrite_Function_Call_For_C |
9784 | ||
2700b9c1 | 9785 | begin |
cdabbb52 HK |
9786 | -- The actuals may be given by named associations, so the added actual |
9787 | -- that is the target of the return value of the call must be a named | |
9788 | -- association as well, so we retrieve the name of the generated | |
9789 | -- out_formal. | |
5c12e9fb AC |
9790 | |
9791 | Last_Formal := First_Formal (Proc_Id); | |
9792 | while Present (Next_Formal (Last_Formal)) loop | |
99859ea7 | 9793 | Next_Formal (Last_Formal); |
5c12e9fb AC |
9794 | end loop; |
9795 | ||
2700b9c1 AC |
9796 | Actuals := Parameter_Associations (N); |
9797 | ||
6f99dcec | 9798 | -- The original function may lack parameters |
241fac51 ES |
9799 | |
9800 | if No (Actuals) then | |
9801 | Actuals := New_List; | |
9802 | end if; | |
9803 | ||
2700b9c1 AC |
9804 | -- If the function call is the expression of an assignment statement, |
9805 | -- transform the assignment into a procedure call. Generate: | |
9806 | ||
9807 | -- LHS := Func_Call (...); | |
9808 | ||
9809 | -- Proc_Call (..., LHS); | |
9810 | ||
9b7924dd AC |
9811 | -- If function is inherited, a conversion may be necessary. |
9812 | ||
2700b9c1 | 9813 | if Nkind (Par) = N_Assignment_Statement then |
d43fbe01 | 9814 | Last_Actual := Name (Par); |
9b7924dd AC |
9815 | |
9816 | if not Comes_From_Source (Orig_Func) | |
9817 | and then Etype (Orig_Func) /= Etype (Func_Id) | |
9818 | then | |
2a253c5b AC |
9819 | Last_Actual := |
9820 | Make_Type_Conversion (Loc, | |
9821 | New_Occurrence_Of (Etype (Func_Id), Loc), | |
9822 | Last_Actual); | |
9b7924dd AC |
9823 | end if; |
9824 | ||
5c12e9fb AC |
9825 | Append_To (Actuals, |
9826 | Make_Parameter_Association (Loc, | |
cdabbb52 HK |
9827 | Selector_Name => |
9828 | Make_Identifier (Loc, Chars (Last_Formal)), | |
9b7924dd | 9829 | Explicit_Actual_Parameter => Last_Actual)); |
cdabbb52 | 9830 | |
2700b9c1 AC |
9831 | Rewrite (Par, |
9832 | Make_Procedure_Call_Statement (Loc, | |
9833 | Name => New_Occurrence_Of (Proc_Id, Loc), | |
9834 | Parameter_Associations => Actuals)); | |
9835 | Analyze (Par); | |
9836 | ||
9837 | -- Otherwise the context is an expression. Generate a temporary and a | |
9838 | -- procedure call to obtain the function result. Generate: | |
9839 | ||
9840 | -- ... Func_Call (...) ... | |
9841 | ||
9842 | -- Temp : ...; | |
9843 | -- Proc_Call (..., Temp); | |
9844 | -- ... Temp ... | |
9845 | ||
9846 | else | |
9847 | declare | |
9848 | Temp_Id : constant Entity_Id := Make_Temporary (Loc, 'T'); | |
9849 | Call : Node_Id; | |
9850 | Decl : Node_Id; | |
9851 | ||
9852 | begin | |
9853 | -- Generate: | |
9854 | -- Temp : ...; | |
9855 | ||
9856 | Decl := | |
9857 | Make_Object_Declaration (Loc, | |
9858 | Defining_Identifier => Temp_Id, | |
9859 | Object_Definition => | |
9860 | New_Occurrence_Of (Etype (Func_Id), Loc)); | |
9861 | ||
9862 | -- Generate: | |
9863 | -- Proc_Call (..., Temp); | |
9864 | ||
5c12e9fb AC |
9865 | Append_To (Actuals, |
9866 | Make_Parameter_Association (Loc, | |
cdabbb52 HK |
9867 | Selector_Name => |
9868 | Make_Identifier (Loc, Chars (Last_Formal)), | |
9869 | Explicit_Actual_Parameter => | |
9870 | New_Occurrence_Of (Temp_Id, Loc))); | |
9871 | ||
2700b9c1 AC |
9872 | Call := |
9873 | Make_Procedure_Call_Statement (Loc, | |
9874 | Name => New_Occurrence_Of (Proc_Id, Loc), | |
9875 | Parameter_Associations => Actuals); | |
9876 | ||
9877 | Insert_Actions (Par, New_List (Decl, Call)); | |
9878 | Rewrite (N, New_Occurrence_Of (Temp_Id, Loc)); | |
9879 | end; | |
9880 | end if; | |
9881 | end Rewrite_Function_Call_For_C; | |
9882 | ||
c79f6efd BD |
9883 | ------------------------------------ |
9884 | -- Set_Enclosing_Sec_Stack_Return -- | |
9885 | ------------------------------------ | |
9886 | ||
9887 | procedure Set_Enclosing_Sec_Stack_Return (N : Node_Id) is | |
9888 | P : Node_Id := N; | |
9889 | ||
9890 | begin | |
9891 | -- Due to a possible mix of internally generated blocks, source blocks | |
9892 | -- and loops, the scope stack may not be contiguous as all labels are | |
9893 | -- inserted at the top level within the related function. Instead, | |
9894 | -- perform a parent-based traversal and mark all appropriate constructs. | |
9895 | ||
9896 | while Present (P) loop | |
9897 | ||
9898 | -- Mark the label of a source or internally generated block or | |
9899 | -- loop. | |
9900 | ||
4a08c95c | 9901 | if Nkind (P) in N_Block_Statement | N_Loop_Statement then |
c79f6efd BD |
9902 | Set_Sec_Stack_Needed_For_Return (Entity (Identifier (P))); |
9903 | ||
9904 | -- Mark the enclosing function | |
9905 | ||
9906 | elsif Nkind (P) = N_Subprogram_Body then | |
9907 | if Present (Corresponding_Spec (P)) then | |
9908 | Set_Sec_Stack_Needed_For_Return (Corresponding_Spec (P)); | |
9909 | else | |
9910 | Set_Sec_Stack_Needed_For_Return (Defining_Entity (P)); | |
9911 | end if; | |
9912 | ||
9913 | -- Do not go beyond the enclosing function | |
9914 | ||
9915 | exit; | |
9916 | end if; | |
9917 | ||
9918 | P := Parent (P); | |
9919 | end loop; | |
9920 | end Set_Enclosing_Sec_Stack_Return; | |
9921 | ||
4ac62786 AC |
9922 | ------------------------------------ |
9923 | -- Unqual_BIP_Iface_Function_Call -- | |
9924 | ------------------------------------ | |
9925 | ||
9926 | function Unqual_BIP_Iface_Function_Call (Expr : Node_Id) return Node_Id is | |
9927 | Has_Pointer_Displacement : Boolean := False; | |
9928 | On_Object_Declaration : Boolean := False; | |
9929 | -- Remember if processing the renaming expressions on recursion we have | |
9930 | -- traversed an object declaration, since we can traverse many object | |
9931 | -- declaration renamings but just one regular object declaration. | |
9932 | ||
9933 | function Unqual_BIP_Function_Call (Expr : Node_Id) return Node_Id; | |
9934 | -- Search for a build-in-place function call skipping any qualification | |
9935 | -- including qualified expressions, type conversions, references, calls | |
9936 | -- to displace the pointer to the object, and renamings. Return Empty if | |
9937 | -- no build-in-place function call is found. | |
9938 | ||
9939 | ------------------------------ | |
9940 | -- Unqual_BIP_Function_Call -- | |
9941 | ------------------------------ | |
9942 | ||
9943 | function Unqual_BIP_Function_Call (Expr : Node_Id) return Node_Id is | |
9944 | begin | |
9945 | -- Recurse to handle case of multiple levels of qualification and/or | |
9946 | -- conversion. | |
9947 | ||
4a08c95c AC |
9948 | if Nkind (Expr) in N_Qualified_Expression |
9949 | | N_Type_Conversion | |
9950 | | N_Unchecked_Type_Conversion | |
4ac62786 AC |
9951 | then |
9952 | return Unqual_BIP_Function_Call (Expression (Expr)); | |
9953 | ||
9954 | -- Recurse to handle case of multiple levels of references and | |
9955 | -- explicit dereferences. | |
9956 | ||
4a08c95c AC |
9957 | elsif Nkind (Expr) in N_Attribute_Reference |
9958 | | N_Explicit_Dereference | |
9959 | | N_Reference | |
4ac62786 AC |
9960 | then |
9961 | return Unqual_BIP_Function_Call (Prefix (Expr)); | |
9962 | ||
9963 | -- Recurse on object renamings | |
9964 | ||
9965 | elsif Nkind (Expr) = N_Identifier | |
f63adaa7 | 9966 | and then Present (Entity (Expr)) |
4a08c95c | 9967 | and then Ekind (Entity (Expr)) in E_Constant | E_Variable |
4ac62786 AC |
9968 | and then Nkind (Parent (Entity (Expr))) = |
9969 | N_Object_Renaming_Declaration | |
9970 | and then Present (Renamed_Object (Entity (Expr))) | |
9971 | then | |
9972 | return Unqual_BIP_Function_Call (Renamed_Object (Entity (Expr))); | |
9973 | ||
9974 | -- Recurse on the initializing expression of the first reference of | |
9975 | -- an object declaration. | |
9976 | ||
9977 | elsif not On_Object_Declaration | |
9978 | and then Nkind (Expr) = N_Identifier | |
f63adaa7 | 9979 | and then Present (Entity (Expr)) |
4a08c95c | 9980 | and then Ekind (Entity (Expr)) in E_Constant | E_Variable |
4ac62786 AC |
9981 | and then Nkind (Parent (Entity (Expr))) = N_Object_Declaration |
9982 | and then Present (Expression (Parent (Entity (Expr)))) | |
9983 | then | |
9984 | On_Object_Declaration := True; | |
9985 | return | |
3fc40cd7 | 9986 | Unqual_BIP_Function_Call (Expression (Parent (Entity (Expr)))); |
4ac62786 AC |
9987 | |
9988 | -- Recurse to handle calls to displace the pointer to the object to | |
9989 | -- reference a secondary dispatch table. | |
9990 | ||
9991 | elsif Nkind (Expr) = N_Function_Call | |
9992 | and then Nkind (Name (Expr)) in N_Has_Entity | |
f63adaa7 | 9993 | and then Present (Entity (Name (Expr))) |
4ac62786 AC |
9994 | and then Is_RTE (Entity (Name (Expr)), RE_Displace) |
9995 | then | |
9996 | Has_Pointer_Displacement := True; | |
9997 | return | |
9998 | Unqual_BIP_Function_Call (First (Parameter_Associations (Expr))); | |
9999 | ||
10000 | -- Normal case: check if the inner expression is a BIP function call | |
10001 | -- and the pointer to the object is displaced. | |
10002 | ||
10003 | elsif Has_Pointer_Displacement | |
10004 | and then Is_Build_In_Place_Function_Call (Expr) | |
10005 | then | |
10006 | return Expr; | |
10007 | ||
10008 | else | |
10009 | return Empty; | |
10010 | end if; | |
10011 | end Unqual_BIP_Function_Call; | |
10012 | ||
10013 | -- Start of processing for Unqual_BIP_Iface_Function_Call | |
10014 | ||
10015 | begin | |
d4dfb005 | 10016 | if Nkind (Expr) = N_Identifier and then No (Entity (Expr)) then |
3fc40cd7 PMR |
10017 | |
10018 | -- Can happen for X'Elab_Spec in the binder-generated file | |
10019 | ||
d4dfb005 BD |
10020 | return Empty; |
10021 | end if; | |
10022 | ||
4ac62786 AC |
10023 | return Unqual_BIP_Function_Call (Expr); |
10024 | end Unqual_BIP_Iface_Function_Call; | |
10025 | ||
f1668c3d JM |
10026 | ------------------------------- |
10027 | -- Validate_Subprogram_Calls -- | |
10028 | ------------------------------- | |
10029 | ||
10030 | procedure Validate_Subprogram_Calls (N : Node_Id) is | |
10031 | ||
10032 | function Process_Node (Nod : Node_Id) return Traverse_Result; | |
10033 | -- Function to traverse the subtree of N using Traverse_Proc. | |
10034 | ||
10035 | ------------------ | |
10036 | -- Process_Node -- | |
10037 | ------------------ | |
10038 | ||
10039 | function Process_Node (Nod : Node_Id) return Traverse_Result is | |
10040 | begin | |
10041 | case Nkind (Nod) is | |
10042 | when N_Entry_Call_Statement | |
10043 | | N_Procedure_Call_Statement | |
10044 | | N_Function_Call | |
10045 | => | |
10046 | declare | |
10047 | Call_Node : Node_Id renames Nod; | |
10048 | Subp : Entity_Id; | |
10049 | ||
10050 | begin | |
10051 | -- Call using access to subprogram with explicit dereference | |
10052 | ||
10053 | if Nkind (Name (Call_Node)) = N_Explicit_Dereference then | |
10054 | Subp := Etype (Name (Call_Node)); | |
10055 | ||
10056 | -- Prefix notation calls | |
10057 | ||
10058 | elsif Nkind (Name (Call_Node)) = N_Selected_Component then | |
10059 | Subp := Entity (Selector_Name (Name (Call_Node))); | |
10060 | ||
10061 | -- Call to member of entry family, where Name is an indexed | |
10062 | -- component, with the prefix being a selected component | |
10063 | -- giving the task and entry family name, and the index | |
10064 | -- being the entry index. | |
10065 | ||
10066 | elsif Nkind (Name (Call_Node)) = N_Indexed_Component then | |
10067 | Subp := | |
10068 | Entity (Selector_Name (Prefix (Name (Call_Node)))); | |
10069 | ||
10070 | -- Normal case | |
10071 | ||
10072 | else | |
10073 | Subp := Entity (Name (Call_Node)); | |
10074 | end if; | |
10075 | ||
10076 | pragma Assert (Check_BIP_Actuals (Call_Node, Subp)); | |
10077 | end; | |
10078 | ||
10079 | -- Skip generic bodies | |
10080 | ||
10081 | when N_Package_Body => | |
10082 | if Ekind (Unique_Defining_Entity (Nod)) = E_Generic_Package then | |
10083 | return Skip; | |
10084 | end if; | |
10085 | ||
10086 | when N_Subprogram_Body => | |
10087 | if Ekind (Unique_Defining_Entity (Nod)) in E_Generic_Function | |
10088 | | E_Generic_Procedure | |
10089 | then | |
10090 | return Skip; | |
10091 | end if; | |
10092 | ||
10093 | -- Nodes we want to ignore | |
10094 | ||
10095 | -- Skip calls placed in the full declaration of record types since | |
10096 | -- the call will be performed by their Init Proc; for example, | |
10097 | -- calls initializing default values of discriminants or calls | |
10098 | -- providing the initial value of record type components. Other | |
10099 | -- full type declarations are processed because they may have | |
10100 | -- calls that must be checked. For example: | |
10101 | ||
10102 | -- type T is array (1 .. Some_Function_Call (...)) of Some_Type; | |
10103 | ||
10104 | -- ??? More work needed here to handle the following case: | |
10105 | ||
10106 | -- type Rec is record | |
10107 | -- F : String (1 .. <some complicated expression>); | |
10108 | -- end record; | |
10109 | ||
10110 | when N_Full_Type_Declaration => | |
10111 | if Is_Record_Type (Defining_Entity (Nod)) then | |
10112 | return Skip; | |
10113 | end if; | |
10114 | ||
10115 | -- Skip calls placed in subprogram specifications since function | |
10116 | -- calls initializing default parameter values will be processed | |
10117 | -- when the call to the subprogram is found (if the default actual | |
10118 | -- parameter is required), and calls found in aspects will be | |
10119 | -- processed when their corresponding pragma is found, or in the | |
10120 | -- specific case of class-wide pre-/postconditions, when their | |
10121 | -- helpers are found. | |
10122 | ||
10123 | when N_Procedure_Specification | |
10124 | | N_Function_Specification | |
10125 | => | |
10126 | return Skip; | |
10127 | ||
10128 | when N_Abstract_Subprogram_Declaration | |
76bf4321 | 10129 | | N_Aspect_Specification |
f1668c3d JM |
10130 | | N_At_Clause |
10131 | | N_Call_Marker | |
10132 | | N_Empty | |
10133 | | N_Enumeration_Representation_Clause | |
10134 | | N_Enumeration_Type_Definition | |
10135 | | N_Function_Instantiation | |
10136 | | N_Freeze_Generic_Entity | |
10137 | | N_Generic_Function_Renaming_Declaration | |
10138 | | N_Generic_Package_Renaming_Declaration | |
10139 | | N_Generic_Procedure_Renaming_Declaration | |
10140 | | N_Generic_Package_Declaration | |
10141 | | N_Generic_Subprogram_Declaration | |
10142 | | N_Itype_Reference | |
10143 | | N_Number_Declaration | |
10144 | | N_Package_Instantiation | |
10145 | | N_Package_Renaming_Declaration | |
10146 | | N_Pragma | |
10147 | | N_Procedure_Instantiation | |
10148 | | N_Protected_Type_Declaration | |
10149 | | N_Record_Representation_Clause | |
10150 | | N_Validate_Unchecked_Conversion | |
10151 | | N_Variable_Reference_Marker | |
10152 | | N_Use_Package_Clause | |
10153 | | N_Use_Type_Clause | |
10154 | | N_With_Clause | |
10155 | => | |
10156 | return Skip; | |
10157 | ||
10158 | when others => | |
10159 | null; | |
10160 | end case; | |
10161 | ||
10162 | return OK; | |
10163 | end Process_Node; | |
10164 | ||
10165 | procedure Check_Calls is new Traverse_Proc (Process_Node); | |
10166 | ||
10167 | -- Start of processing for Validate_Subprogram_Calls | |
10168 | ||
10169 | begin | |
10170 | -- No action required if we are not generating code or compiling sources | |
10171 | -- that have errors. | |
10172 | ||
10173 | if Serious_Errors_Detected > 0 | |
10174 | or else Operating_Mode /= Generate_Code | |
10175 | then | |
10176 | return; | |
10177 | end if; | |
10178 | ||
10179 | Check_Calls (N); | |
10180 | end Validate_Subprogram_Calls; | |
10181 | ||
b19c922b VF |
10182 | -------------- |
10183 | -- Warn_BIP -- | |
10184 | -------------- | |
10185 | ||
10186 | procedure Warn_BIP (Func_Call : Node_Id) is | |
10187 | begin | |
10188 | if Debug_Flag_Underscore_BB then | |
68dd6649 | 10189 | Error_Msg_N ("build-in-place function call??", Func_Call); |
b19c922b VF |
10190 | end if; |
10191 | end Warn_BIP; | |
10192 | ||
70482933 | 10193 | end Exp_Ch6; |