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