1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2017, Free Software Foundation, Inc. --
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. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
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 Expander; use Expander;
34 with Exp_Aggr; use Exp_Aggr;
35 with Exp_Atag; use Exp_Atag;
36 with Exp_Ch2; use Exp_Ch2;
37 with Exp_Ch3; use Exp_Ch3;
38 with Exp_Ch7; use Exp_Ch7;
39 with Exp_Ch9; use Exp_Ch9;
40 with Exp_Dbug; use Exp_Dbug;
41 with Exp_Disp; use Exp_Disp;
42 with Exp_Dist; use Exp_Dist;
43 with Exp_Intr; use Exp_Intr;
44 with Exp_Pakd; use Exp_Pakd;
45 with Exp_Tss; use Exp_Tss;
46 with Exp_Util; use Exp_Util;
47 with Freeze; use Freeze;
48 with Inline; use Inline;
49 with Itypes; use Itypes;
51 with Namet; use Namet;
52 with Nlists; use Nlists;
53 with Nmake; use Nmake;
55 with Restrict; use Restrict;
56 with Rident; use Rident;
57 with Rtsfind; use Rtsfind;
59 with Sem_Aux; use Sem_Aux;
60 with Sem_Ch6; use Sem_Ch6;
61 with Sem_Ch8; use Sem_Ch8;
62 with Sem_Ch12; use Sem_Ch12;
63 with Sem_Ch13; use Sem_Ch13;
64 with Sem_Dim; use Sem_Dim;
65 with Sem_Disp; use Sem_Disp;
66 with Sem_Dist; use Sem_Dist;
67 with Sem_Eval; use Sem_Eval;
68 with Sem_Mech; use Sem_Mech;
69 with Sem_Res; use Sem_Res;
70 with Sem_SCIL; use Sem_SCIL;
71 with Sem_Util; use Sem_Util;
72 with Sinfo; use Sinfo;
73 with Snames; use Snames;
74 with Stand; use Stand;
75 with Tbuild; use Tbuild;
76 with Uintp; use Uintp;
77 with Validsw; use Validsw;
79 package body Exp_Ch6 is
81 -----------------------
82 -- Local Subprograms --
83 -----------------------
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.
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.
111 procedure Add_Finalization_Master_Actual_To_Build_In_Place_Call
112 (Func_Call : Node_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.
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.
140 function Caller_Known_Size
141 (Func_Call : Node_Id;
142 Result_Subt : Entity_Id) return Boolean;
143 -- True if result subtype is definite, or has a size that does not require
144 -- secondary stack usage (i.e. no variant part or components whose type
145 -- depends on discriminants). In particular, untagged types with only
146 -- access discriminants do not require secondary stack use. Note we must
147 -- always use the secondary stack for dispatching-on-result calls.
149 procedure Check_Overriding_Operation (Subp : Entity_Id);
150 -- Subp is a dispatching operation. Check whether it may override an
151 -- inherited private operation, in which case its DT entry is that of
152 -- the hidden operation, not the one it may have received earlier.
153 -- This must be done before emitting the code to set the corresponding
154 -- DT to the address of the subprogram. The actual placement of Subp in
155 -- the proper place in the list of primitive operations is done in
156 -- Declare_Inherited_Private_Subprograms, which also has to deal with
157 -- implicit operations. This duplication is unavoidable for now???
159 procedure Detect_Infinite_Recursion (N : Node_Id; Spec : Entity_Id);
160 -- This procedure is called only if the subprogram body N, whose spec
161 -- has the given entity Spec, contains a parameterless recursive call.
162 -- It attempts to generate runtime code to detect if this a case of
163 -- infinite recursion.
165 -- The body is scanned to determine dependencies. If the only external
166 -- dependencies are on a small set of scalar variables, then the values
167 -- of these variables are captured on entry to the subprogram, and if
168 -- the values are not changed for the call, we know immediately that
169 -- we have an infinite recursion.
171 procedure Expand_Actuals
174 Post_Call : out List_Id);
175 -- Return a list of actions to take place after the call in Post_Call. The
176 -- call will later be rewritten as an Expression_With_Actions, with the
177 -- Post_Call actions inserted, and the call inside.
179 -- For each actual of an in-out or out parameter which is a numeric (view)
180 -- conversion of the form T (A), where A denotes a variable, we insert the
183 -- Temp : T[ := T (A)];
185 -- prior to the call. Then we replace the actual with a reference to Temp,
186 -- and append the assignment:
188 -- A := TypeA (Temp);
190 -- after the call. Here TypeA is the actual type of variable A. For out
191 -- parameters, the initial declaration has no expression. If A is not an
192 -- entity name, we generate instead:
194 -- Var : TypeA renames A;
195 -- Temp : T := Var; -- omitting expression for out parameter.
197 -- Var := TypeA (Temp);
199 -- For other in-out parameters, we emit the required constraint checks
200 -- before and/or after the call.
202 -- For all parameter modes, actuals that denote components and slices of
203 -- packed arrays are expanded into suitable temporaries.
205 -- For non-scalar objects that are possibly unaligned, add call by copy
206 -- code (copy in for IN and IN OUT, copy out for OUT and IN OUT).
208 -- For OUT and IN OUT parameters, add predicate checks after the call
209 -- based on the predicates of the actual type.
211 procedure Expand_Call_Helper (N : Node_Id; Post_Call : out List_Id);
212 -- Does the main work of Expand_Call. Post_Call is as for Expand_Actuals.
214 procedure Expand_Ctrl_Function_Call (N : Node_Id);
215 -- N is a function call which returns a controlled object. Transform the
216 -- call into a temporary which retrieves the returned object from the
217 -- secondary stack using 'reference.
219 procedure Expand_Non_Function_Return (N : Node_Id);
220 -- Expand a simple return statement found in a procedure body, entry body,
221 -- accept statement, or an extended return statement. Note that all non-
222 -- function returns are simple return statements.
224 function Expand_Protected_Object_Reference
226 Scop : Entity_Id) return Node_Id;
228 procedure Expand_Protected_Subprogram_Call
232 -- A call to a protected subprogram within the protected object may appear
233 -- as a regular call. The list of actuals must be expanded to contain a
234 -- reference to the object itself, and the call becomes a call to the
235 -- corresponding protected subprogram.
237 procedure Expand_Simple_Function_Return (N : Node_Id);
238 -- Expand simple return from function. In the case where we are returning
239 -- from a function body this is called by Expand_N_Simple_Return_Statement.
241 function Has_Unconstrained_Access_Discriminants
242 (Subtyp : Entity_Id) return Boolean;
243 -- Returns True if the given subtype is unconstrained and has one or more
244 -- access discriminants.
246 procedure Insert_Post_Call_Actions (N : Node_Id; Post_Call : List_Id);
247 -- Insert the Post_Call list previously produced by routine Expand_Actuals
248 -- or Expand_Call_Helper into the tree.
250 procedure Replace_Renaming_Declaration_Id
252 Orig_Decl : Node_Id);
253 -- Replace the internal identifier of the new renaming declaration New_Decl
254 -- with the identifier of its original declaration Orig_Decl exchanging the
255 -- entities containing their defining identifiers to ensure the correct
256 -- replacement of the object declaration by the object renaming declaration
257 -- to avoid homograph conflicts (since the object declaration's defining
258 -- identifier was already entered in the current scope). The Next_Entity
259 -- links of the two entities are also swapped since the entities are part
260 -- of the return scope's entity list and the list structure would otherwise
261 -- be corrupted. The homonym chain is preserved as well.
263 procedure Rewrite_Function_Call_For_C (N : Node_Id);
264 -- When generating C code, replace a call to a function that returns an
265 -- array into the generated procedure with an additional out parameter.
267 procedure Set_Enclosing_Sec_Stack_Return (N : Node_Id);
268 -- N is a return statement for a function that returns its result on the
269 -- secondary stack. This sets the Sec_Stack_Needed_For_Return flag on the
270 -- function and all blocks and loops that the return statement is jumping
271 -- out of. This ensures that the secondary stack is not released; otherwise
272 -- the function result would be reclaimed before returning to the caller.
274 ----------------------------------------------
275 -- Add_Access_Actual_To_Build_In_Place_Call --
276 ----------------------------------------------
278 procedure Add_Access_Actual_To_Build_In_Place_Call
279 (Function_Call : Node_Id;
280 Function_Id : Entity_Id;
281 Return_Object : Node_Id;
282 Is_Access : Boolean := False)
284 Loc : constant Source_Ptr := Sloc (Function_Call);
285 Obj_Address : Node_Id;
286 Obj_Acc_Formal : Entity_Id;
289 -- Locate the implicit access parameter in the called function
291 Obj_Acc_Formal := Build_In_Place_Formal (Function_Id, BIP_Object_Access);
293 -- If no return object is provided, then pass null
295 if not Present (Return_Object) then
296 Obj_Address := Make_Null (Loc);
297 Set_Parent (Obj_Address, Function_Call);
299 -- If Return_Object is already an expression of an access type, then use
300 -- it directly, since it must be an access value denoting the return
301 -- object, and couldn't possibly be the return object itself.
304 Obj_Address := Return_Object;
305 Set_Parent (Obj_Address, Function_Call);
307 -- Apply Unrestricted_Access to caller's return object
311 Make_Attribute_Reference (Loc,
312 Prefix => Return_Object,
313 Attribute_Name => Name_Unrestricted_Access);
315 Set_Parent (Return_Object, Obj_Address);
316 Set_Parent (Obj_Address, Function_Call);
319 Analyze_And_Resolve (Obj_Address, Etype (Obj_Acc_Formal));
321 -- Build the parameter association for the new actual and add it to the
322 -- end of the function's actuals.
324 Add_Extra_Actual_To_Call (Function_Call, Obj_Acc_Formal, Obj_Address);
325 end Add_Access_Actual_To_Build_In_Place_Call;
327 ------------------------------------------------------
328 -- Add_Unconstrained_Actuals_To_Build_In_Place_Call --
329 ------------------------------------------------------
331 procedure Add_Unconstrained_Actuals_To_Build_In_Place_Call
332 (Function_Call : Node_Id;
333 Function_Id : Entity_Id;
334 Alloc_Form : BIP_Allocation_Form := Unspecified;
335 Alloc_Form_Exp : Node_Id := Empty;
336 Pool_Actual : Node_Id := Make_Null (No_Location))
338 Loc : constant Source_Ptr := Sloc (Function_Call);
339 Alloc_Form_Actual : Node_Id;
340 Alloc_Form_Formal : Node_Id;
341 Pool_Formal : Node_Id;
344 -- The allocation form generally doesn't need to be passed in the case
345 -- of a constrained result subtype, since normally the caller performs
346 -- the allocation in that case. However this formal is still needed in
347 -- the case where the function has a tagged result, because generally
348 -- such functions can be called in a dispatching context and such calls
349 -- must be handled like calls to class-wide functions.
351 if Is_Constrained (Underlying_Type (Etype (Function_Id)))
352 and then not Is_Tagged_Type (Underlying_Type (Etype (Function_Id)))
357 -- Locate the implicit allocation form parameter in the called function.
358 -- Maybe it would be better for each implicit formal of a build-in-place
359 -- function to have a flag or a Uint attribute to identify it. ???
361 Alloc_Form_Formal := Build_In_Place_Formal (Function_Id, BIP_Alloc_Form);
363 if Present (Alloc_Form_Exp) then
364 pragma Assert (Alloc_Form = Unspecified);
366 Alloc_Form_Actual := Alloc_Form_Exp;
369 pragma Assert (Alloc_Form /= Unspecified);
372 Make_Integer_Literal (Loc,
373 Intval => UI_From_Int (BIP_Allocation_Form'Pos (Alloc_Form)));
376 Analyze_And_Resolve (Alloc_Form_Actual, Etype (Alloc_Form_Formal));
378 -- Build the parameter association for the new actual and add it to the
379 -- end of the function's actuals.
381 Add_Extra_Actual_To_Call
382 (Function_Call, Alloc_Form_Formal, Alloc_Form_Actual);
384 -- Pass the Storage_Pool parameter. This parameter is omitted on
385 -- ZFP as those targets do not support pools.
387 if RTE_Available (RE_Root_Storage_Pool_Ptr) then
388 Pool_Formal := Build_In_Place_Formal (Function_Id, BIP_Storage_Pool);
389 Analyze_And_Resolve (Pool_Actual, Etype (Pool_Formal));
390 Add_Extra_Actual_To_Call
391 (Function_Call, Pool_Formal, Pool_Actual);
393 end Add_Unconstrained_Actuals_To_Build_In_Place_Call;
395 -----------------------------------------------------------
396 -- Add_Finalization_Master_Actual_To_Build_In_Place_Call --
397 -----------------------------------------------------------
399 procedure Add_Finalization_Master_Actual_To_Build_In_Place_Call
400 (Func_Call : Node_Id;
402 Ptr_Typ : Entity_Id := Empty;
403 Master_Exp : Node_Id := Empty)
406 if not Needs_BIP_Finalization_Master (Func_Id) then
411 Formal : constant Entity_Id :=
412 Build_In_Place_Formal (Func_Id, BIP_Finalization_Master);
413 Loc : constant Source_Ptr := Sloc (Func_Call);
416 Desig_Typ : Entity_Id;
419 -- If there is a finalization master actual, such as the implicit
420 -- finalization master of an enclosing build-in-place function,
421 -- then this must be added as an extra actual of the call.
423 if Present (Master_Exp) then
424 Actual := Master_Exp;
426 -- Case where the context does not require an actual master
428 elsif No (Ptr_Typ) then
429 Actual := Make_Null (Loc);
432 Desig_Typ := Directly_Designated_Type (Ptr_Typ);
434 -- Check for a library-level access type whose designated type has
435 -- suppressed finalization or the access type is subject to pragma
436 -- No_Heap_Finalization. Such an access type lacks a master. Pass
437 -- a null actual to callee in order to signal a missing master.
439 if Is_Library_Level_Entity (Ptr_Typ)
440 and then (Finalize_Storage_Only (Desig_Typ)
441 or else No_Heap_Finalization (Ptr_Typ))
443 Actual := Make_Null (Loc);
445 -- Types in need of finalization actions
447 elsif Needs_Finalization (Desig_Typ) then
449 -- The general mechanism of creating finalization masters for
450 -- anonymous access types is disabled by default, otherwise
451 -- finalization masters will pop all over the place. Such types
452 -- use context-specific masters.
454 if Ekind (Ptr_Typ) = E_Anonymous_Access_Type
455 and then No (Finalization_Master (Ptr_Typ))
457 Build_Anonymous_Master (Ptr_Typ);
460 -- Access-to-controlled types should always have a master
462 pragma Assert (Present (Finalization_Master (Ptr_Typ)));
465 Make_Attribute_Reference (Loc,
467 New_Occurrence_Of (Finalization_Master (Ptr_Typ), Loc),
468 Attribute_Name => Name_Unrestricted_Access);
473 Actual := Make_Null (Loc);
477 Analyze_And_Resolve (Actual, Etype (Formal));
479 -- Build the parameter association for the new actual and add it to
480 -- the end of the function's actuals.
482 Add_Extra_Actual_To_Call (Func_Call, Formal, Actual);
484 end Add_Finalization_Master_Actual_To_Build_In_Place_Call;
486 ------------------------------
487 -- Add_Extra_Actual_To_Call --
488 ------------------------------
490 procedure Add_Extra_Actual_To_Call
491 (Subprogram_Call : Node_Id;
492 Extra_Formal : Entity_Id;
493 Extra_Actual : Node_Id)
495 Loc : constant Source_Ptr := Sloc (Subprogram_Call);
496 Param_Assoc : Node_Id;
500 Make_Parameter_Association (Loc,
501 Selector_Name => New_Occurrence_Of (Extra_Formal, Loc),
502 Explicit_Actual_Parameter => Extra_Actual);
504 Set_Parent (Param_Assoc, Subprogram_Call);
505 Set_Parent (Extra_Actual, Param_Assoc);
507 if Present (Parameter_Associations (Subprogram_Call)) then
508 if Nkind (Last (Parameter_Associations (Subprogram_Call))) =
509 N_Parameter_Association
512 -- Find last named actual, and append
517 L := First_Actual (Subprogram_Call);
518 while Present (L) loop
519 if No (Next_Actual (L)) then
520 Set_Next_Named_Actual (Parent (L), Extra_Actual);
528 Set_First_Named_Actual (Subprogram_Call, Extra_Actual);
531 Append (Param_Assoc, To => Parameter_Associations (Subprogram_Call));
534 Set_Parameter_Associations (Subprogram_Call, New_List (Param_Assoc));
535 Set_First_Named_Actual (Subprogram_Call, Extra_Actual);
537 end Add_Extra_Actual_To_Call;
539 ---------------------------------------------
540 -- Add_Task_Actuals_To_Build_In_Place_Call --
541 ---------------------------------------------
543 procedure Add_Task_Actuals_To_Build_In_Place_Call
544 (Function_Call : Node_Id;
545 Function_Id : Entity_Id;
546 Master_Actual : Node_Id;
547 Chain : Node_Id := Empty)
549 Loc : constant Source_Ptr := Sloc (Function_Call);
550 Result_Subt : constant Entity_Id :=
551 Available_View (Etype (Function_Id));
553 Chain_Actual : Node_Id;
554 Chain_Formal : Node_Id;
555 Master_Formal : Node_Id;
558 -- No such extra parameters are needed if there are no tasks
560 if not Has_Task (Result_Subt) then
564 Actual := Master_Actual;
566 -- Use a dummy _master actual in case of No_Task_Hierarchy
568 if Restriction_Active (No_Task_Hierarchy) then
569 Actual := New_Occurrence_Of (RTE (RE_Library_Task_Level), Loc);
571 -- In the case where we use the master associated with an access type,
572 -- the actual is an entity and requires an explicit reference.
574 elsif Nkind (Actual) = N_Defining_Identifier then
575 Actual := New_Occurrence_Of (Actual, Loc);
578 -- Locate the implicit master parameter in the called function
580 Master_Formal := Build_In_Place_Formal (Function_Id, BIP_Task_Master);
581 Analyze_And_Resolve (Actual, Etype (Master_Formal));
583 -- Build the parameter association for the new actual and add it to the
584 -- end of the function's actuals.
586 Add_Extra_Actual_To_Call (Function_Call, Master_Formal, Actual);
588 -- Locate the implicit activation chain parameter in the called function
591 Build_In_Place_Formal (Function_Id, BIP_Activation_Chain);
593 -- Create the actual which is a pointer to the current activation chain
597 Make_Attribute_Reference (Loc,
598 Prefix => Make_Identifier (Loc, Name_uChain),
599 Attribute_Name => Name_Unrestricted_Access);
601 -- Allocator case; make a reference to the Chain passed in by the caller
605 Make_Attribute_Reference (Loc,
606 Prefix => New_Occurrence_Of (Chain, Loc),
607 Attribute_Name => Name_Unrestricted_Access);
610 Analyze_And_Resolve (Chain_Actual, Etype (Chain_Formal));
612 -- Build the parameter association for the new actual and add it to the
613 -- end of the function's actuals.
615 Add_Extra_Actual_To_Call (Function_Call, Chain_Formal, Chain_Actual);
616 end Add_Task_Actuals_To_Build_In_Place_Call;
618 -----------------------
619 -- BIP_Formal_Suffix --
620 -----------------------
622 function BIP_Formal_Suffix (Kind : BIP_Formal_Kind) return String is
625 when BIP_Alloc_Form =>
628 when BIP_Storage_Pool =>
629 return "BIPstoragepool";
631 when BIP_Finalization_Master =>
632 return "BIPfinalizationmaster";
634 when BIP_Task_Master =>
635 return "BIPtaskmaster";
637 when BIP_Activation_Chain =>
638 return "BIPactivationchain";
640 when BIP_Object_Access =>
643 end BIP_Formal_Suffix;
645 ---------------------------
646 -- Build_In_Place_Formal --
647 ---------------------------
649 function Build_In_Place_Formal
651 Kind : BIP_Formal_Kind) return Entity_Id
653 Formal_Name : constant Name_Id :=
655 (Chars (Func), BIP_Formal_Suffix (Kind));
656 Extra_Formal : Entity_Id := Extra_Formals (Func);
659 -- Maybe it would be better for each implicit formal of a build-in-place
660 -- function to have a flag or a Uint attribute to identify it. ???
662 -- The return type in the function declaration may have been a limited
663 -- view, and the extra formals for the function were not generated at
664 -- that point. At the point of call the full view must be available and
665 -- the extra formals can be created.
667 if No (Extra_Formal) then
668 Create_Extra_Formals (Func);
669 Extra_Formal := Extra_Formals (Func);
673 pragma Assert (Present (Extra_Formal));
674 exit when Chars (Extra_Formal) = Formal_Name;
676 Next_Formal_With_Extras (Extra_Formal);
680 end Build_In_Place_Formal;
682 -------------------------------
683 -- Build_Procedure_Body_Form --
684 -------------------------------
686 function Build_Procedure_Body_Form
687 (Func_Id : Entity_Id;
688 Func_Body : Node_Id) return Node_Id
690 Loc : constant Source_Ptr := Sloc (Func_Body);
692 Proc_Decl : constant Node_Id :=
693 Next (Unit_Declaration_Node (Func_Id));
694 -- It is assumed that the next node following the declaration of the
695 -- corresponding subprogram spec is the declaration of the procedure
698 Proc_Id : constant Entity_Id := Defining_Entity (Proc_Decl);
700 procedure Replace_Returns (Param_Id : Entity_Id; Stmts : List_Id);
701 -- Replace each return statement found in the list Stmts with an
702 -- assignment of the return expression to parameter Param_Id.
704 ---------------------
705 -- Replace_Returns --
706 ---------------------
708 procedure Replace_Returns (Param_Id : Entity_Id; Stmts : List_Id) is
712 Stmt := First (Stmts);
713 while Present (Stmt) loop
714 if Nkind (Stmt) = N_Block_Statement then
715 Replace_Returns (Param_Id,
716 Statements (Handled_Statement_Sequence (Stmt)));
718 elsif Nkind (Stmt) = N_Case_Statement then
722 Alt := First (Alternatives (Stmt));
723 while Present (Alt) loop
724 Replace_Returns (Param_Id, Statements (Alt));
729 elsif Nkind (Stmt) = N_Extended_Return_Statement then
731 Ret_Obj : constant Entity_Id :=
733 (First (Return_Object_Declarations (Stmt)));
734 Assign : constant Node_Id :=
735 Make_Assignment_Statement (Sloc (Stmt),
737 New_Occurrence_Of (Param_Id, Loc),
739 New_Occurrence_Of (Ret_Obj, Sloc (Stmt)));
743 -- The extended return may just contain the declaration
745 if Present (Handled_Statement_Sequence (Stmt)) then
746 Stmts := Statements (Handled_Statement_Sequence (Stmt));
751 Set_Assignment_OK (Name (Assign));
754 Make_Block_Statement (Sloc (Stmt),
756 Return_Object_Declarations (Stmt),
757 Handled_Statement_Sequence =>
758 Make_Handled_Sequence_Of_Statements (Loc,
759 Statements => Stmts)));
761 Replace_Returns (Param_Id, Stmts);
763 Append_To (Stmts, Assign);
764 Append_To (Stmts, Make_Simple_Return_Statement (Loc));
767 elsif Nkind (Stmt) = N_If_Statement then
768 Replace_Returns (Param_Id, Then_Statements (Stmt));
769 Replace_Returns (Param_Id, Else_Statements (Stmt));
774 Part := First (Elsif_Parts (Stmt));
775 while Present (Part) loop
776 Replace_Returns (Param_Id, Then_Statements (Part));
781 elsif Nkind (Stmt) = N_Loop_Statement then
782 Replace_Returns (Param_Id, Statements (Stmt));
784 elsif Nkind (Stmt) = N_Simple_Return_Statement then
791 Make_Assignment_Statement (Sloc (Stmt),
792 Name => New_Occurrence_Of (Param_Id, Loc),
793 Expression => Relocate_Node (Expression (Stmt))));
795 Insert_After (Stmt, Make_Simple_Return_Statement (Loc));
797 -- Skip the added return
811 -- Start of processing for Build_Procedure_Body_Form
814 -- This routine replaces the original function body:
816 -- function F (...) return Array_Typ is
822 -- with the following:
824 -- procedure P (..., Result : out Array_Typ) is
827 -- Result := Something;
831 Statements (Handled_Statement_Sequence (Func_Body));
832 Replace_Returns (Last_Entity (Proc_Id), Stmts);
835 Make_Subprogram_Body (Loc,
837 Copy_Subprogram_Spec (Specification (Proc_Decl)),
838 Declarations => Declarations (Func_Body),
839 Handled_Statement_Sequence =>
840 Make_Handled_Sequence_Of_Statements (Loc,
841 Statements => Stmts));
843 -- If the function is a generic instance, so is the new procedure.
844 -- Set flag accordingly so that the proper renaming declarations are
847 Set_Is_Generic_Instance (Proc_Id, Is_Generic_Instance (Func_Id));
849 end Build_Procedure_Body_Form;
851 -----------------------
852 -- Caller_Known_Size --
853 -----------------------
855 function Caller_Known_Size
856 (Func_Call : Node_Id;
857 Result_Subt : Entity_Id) return Boolean
861 (Is_Definite_Subtype (Underlying_Type (Result_Subt))
862 and then No (Controlling_Argument (Func_Call)))
863 or else not Requires_Transient_Scope (Underlying_Type (Result_Subt));
864 end Caller_Known_Size;
866 --------------------------------
867 -- Check_Overriding_Operation --
868 --------------------------------
870 procedure Check_Overriding_Operation (Subp : Entity_Id) is
871 Typ : constant Entity_Id := Find_Dispatching_Type (Subp);
872 Op_List : constant Elist_Id := Primitive_Operations (Typ);
878 if Is_Derived_Type (Typ)
879 and then not Is_Private_Type (Typ)
880 and then In_Open_Scopes (Scope (Etype (Typ)))
881 and then Is_Base_Type (Typ)
883 -- Subp overrides an inherited private operation if there is an
884 -- inherited operation with a different name than Subp (see
885 -- Derive_Subprogram) whose Alias is a hidden subprogram with the
886 -- same name as Subp.
888 Op_Elmt := First_Elmt (Op_List);
889 while Present (Op_Elmt) loop
890 Prim_Op := Node (Op_Elmt);
891 Par_Op := Alias (Prim_Op);
894 and then not Comes_From_Source (Prim_Op)
895 and then Chars (Prim_Op) /= Chars (Par_Op)
896 and then Chars (Par_Op) = Chars (Subp)
897 and then Is_Hidden (Par_Op)
898 and then Type_Conformant (Prim_Op, Subp)
900 Set_DT_Position_Value (Subp, DT_Position (Prim_Op));
906 end Check_Overriding_Operation;
908 -------------------------------
909 -- Detect_Infinite_Recursion --
910 -------------------------------
912 procedure Detect_Infinite_Recursion (N : Node_Id; Spec : Entity_Id) is
913 Loc : constant Source_Ptr := Sloc (N);
915 Var_List : constant Elist_Id := New_Elmt_List;
916 -- List of globals referenced by body of procedure
918 Call_List : constant Elist_Id := New_Elmt_List;
919 -- List of recursive calls in body of procedure
921 Shad_List : constant Elist_Id := New_Elmt_List;
922 -- List of entity id's for entities created to capture the value of
923 -- referenced globals on entry to the procedure.
925 Scop : constant Uint := Scope_Depth (Spec);
926 -- This is used to record the scope depth of the current procedure, so
927 -- that we can identify global references.
929 Max_Vars : constant := 4;
930 -- Do not test more than four global variables
932 Count_Vars : Natural := 0;
933 -- Count variables found so far
945 function Process (Nod : Node_Id) return Traverse_Result;
946 -- Function to traverse the subprogram body (using Traverse_Func)
952 function Process (Nod : Node_Id) return Traverse_Result is
956 if Nkind (Nod) = N_Procedure_Call_Statement then
958 -- Case of one of the detected recursive calls
960 if Is_Entity_Name (Name (Nod))
961 and then Has_Recursive_Call (Entity (Name (Nod)))
962 and then Entity (Name (Nod)) = Spec
964 Append_Elmt (Nod, Call_List);
967 -- Any other procedure call may have side effects
973 -- A call to a pure function can always be ignored
975 elsif Nkind (Nod) = N_Function_Call
976 and then Is_Entity_Name (Name (Nod))
977 and then Is_Pure (Entity (Name (Nod)))
981 -- Case of an identifier reference
983 elsif Nkind (Nod) = N_Identifier then
986 -- If no entity, then ignore the reference
988 -- Not clear why this can happen. To investigate, remove this
989 -- test and look at the crash that occurs here in 3401-004 ???
994 -- Ignore entities with no Scope, again not clear how this
995 -- can happen, to investigate, look at 4108-008 ???
997 elsif No (Scope (Ent)) then
1000 -- Ignore the reference if not to a more global object
1002 elsif Scope_Depth (Scope (Ent)) >= Scop then
1005 -- References to types, exceptions and constants are always OK
1008 or else Ekind (Ent) = E_Exception
1009 or else Ekind (Ent) = E_Constant
1013 -- If other than a non-volatile scalar variable, we have some
1014 -- kind of global reference (e.g. to a function) that we cannot
1015 -- deal with so we forget the attempt.
1017 elsif Ekind (Ent) /= E_Variable
1018 or else not Is_Scalar_Type (Etype (Ent))
1019 or else Treat_As_Volatile (Ent)
1023 -- Otherwise we have a reference to a global scalar
1026 -- Loop through global entities already detected
1028 Elm := First_Elmt (Var_List);
1030 -- If not detected before, record this new global reference
1033 Count_Vars := Count_Vars + 1;
1035 if Count_Vars <= Max_Vars then
1036 Append_Elmt (Entity (Nod), Var_List);
1043 -- If recorded before, ignore
1045 elsif Node (Elm) = Entity (Nod) then
1048 -- Otherwise keep looking
1058 -- For all other node kinds, recursively visit syntactic children
1065 function Traverse_Body is new Traverse_Func (Process);
1067 -- Start of processing for Detect_Infinite_Recursion
1070 -- Do not attempt detection in No_Implicit_Conditional mode, since we
1071 -- won't be able to generate the code to handle the recursion in any
1074 if Restriction_Active (No_Implicit_Conditionals) then
1078 -- Otherwise do traversal and quit if we get abandon signal
1080 if Traverse_Body (N) = Abandon then
1083 -- We must have a call, since Has_Recursive_Call was set. If not just
1084 -- ignore (this is only an error check, so if we have a funny situation,
1085 -- due to bugs or errors, we do not want to bomb).
1087 elsif Is_Empty_Elmt_List (Call_List) then
1091 -- Here is the case where we detect recursion at compile time
1093 -- Push our current scope for analyzing the declarations and code that
1094 -- we will insert for the checking.
1098 -- This loop builds temporary variables for each of the referenced
1099 -- globals, so that at the end of the loop the list Shad_List contains
1100 -- these temporaries in one-to-one correspondence with the elements in
1104 Elm := First_Elmt (Var_List);
1105 while Present (Elm) loop
1107 Ent := Make_Temporary (Loc, 'S');
1108 Append_Elmt (Ent, Shad_List);
1110 -- Insert a declaration for this temporary at the start of the
1111 -- declarations for the procedure. The temporaries are declared as
1112 -- constant objects initialized to the current values of the
1113 -- corresponding temporaries.
1116 Make_Object_Declaration (Loc,
1117 Defining_Identifier => Ent,
1118 Object_Definition => New_Occurrence_Of (Etype (Var), Loc),
1119 Constant_Present => True,
1120 Expression => New_Occurrence_Of (Var, Loc));
1123 Prepend (Decl, Declarations (N));
1125 Insert_After (Last, Decl);
1133 -- Loop through calls
1135 Call := First_Elmt (Call_List);
1136 while Present (Call) loop
1138 -- Build a predicate expression of the form
1141 -- and then global1 = temp1
1142 -- and then global2 = temp2
1145 -- This predicate determines if any of the global values
1146 -- referenced by the procedure have changed since the
1147 -- current call, if not an infinite recursion is assured.
1149 Test := New_Occurrence_Of (Standard_True, Loc);
1151 Elm1 := First_Elmt (Var_List);
1152 Elm2 := First_Elmt (Shad_List);
1153 while Present (Elm1) loop
1159 Left_Opnd => New_Occurrence_Of (Node (Elm1), Loc),
1160 Right_Opnd => New_Occurrence_Of (Node (Elm2), Loc)));
1166 -- Now we replace the call with the sequence
1168 -- if no-changes (see above) then
1169 -- raise Storage_Error;
1174 Rewrite (Node (Call),
1175 Make_If_Statement (Loc,
1177 Then_Statements => New_List (
1178 Make_Raise_Storage_Error (Loc,
1179 Reason => SE_Infinite_Recursion)),
1181 Else_Statements => New_List (
1182 Relocate_Node (Node (Call)))));
1184 Analyze (Node (Call));
1189 -- Remove temporary scope stack entry used for analysis
1192 end Detect_Infinite_Recursion;
1194 --------------------
1195 -- Expand_Actuals --
1196 --------------------
1198 procedure Expand_Actuals
1201 Post_Call : out List_Id)
1203 Loc : constant Source_Ptr := Sloc (N);
1207 E_Actual : Entity_Id;
1208 E_Formal : Entity_Id;
1210 procedure Add_Call_By_Copy_Code;
1211 -- For cases where the parameter must be passed by copy, this routine
1212 -- generates a temporary variable into which the actual is copied and
1213 -- then passes this as the parameter. For an OUT or IN OUT parameter,
1214 -- an assignment is also generated to copy the result back. The call
1215 -- also takes care of any constraint checks required for the type
1216 -- conversion case (on both the way in and the way out).
1218 procedure Add_Simple_Call_By_Copy_Code;
1219 -- This is similar to the above, but is used in cases where we know
1220 -- that all that is needed is to simply create a temporary and copy
1221 -- the value in and out of the temporary.
1223 procedure Add_Validation_Call_By_Copy_Code (Act : Node_Id);
1224 -- Perform copy-back for actual parameter Act which denotes a validation
1227 procedure Check_Fortran_Logical;
1228 -- A value of type Logical that is passed through a formal parameter
1229 -- must be normalized because .TRUE. usually does not have the same
1230 -- representation as True. We assume that .FALSE. = False = 0.
1231 -- What about functions that return a logical type ???
1233 function Is_Legal_Copy return Boolean;
1234 -- Check that an actual can be copied before generating the temporary
1235 -- to be used in the call. If the actual is of a by_reference type then
1236 -- the program is illegal (this can only happen in the presence of
1237 -- rep. clauses that force an incorrect alignment). If the formal is
1238 -- a by_reference parameter imposed by a DEC pragma, emit a warning to
1239 -- the effect that this might lead to unaligned arguments.
1241 function Make_Var (Actual : Node_Id) return Entity_Id;
1242 -- Returns an entity that refers to the given actual parameter, Actual
1243 -- (not including any type conversion). If Actual is an entity name,
1244 -- then this entity is returned unchanged, otherwise a renaming is
1245 -- created to provide an entity for the actual.
1247 procedure Reset_Packed_Prefix;
1248 -- The expansion of a packed array component reference is delayed in
1249 -- the context of a call. Now we need to complete the expansion, so we
1250 -- unmark the analyzed bits in all prefixes.
1252 ---------------------------
1253 -- Add_Call_By_Copy_Code --
1254 ---------------------------
1256 procedure Add_Call_By_Copy_Code is
1259 F_Typ : Entity_Id := Etype (Formal);
1267 if not Is_Legal_Copy then
1271 Temp := Make_Temporary (Loc, 'T', Actual);
1273 -- Handle formals whose type comes from the limited view
1275 if From_Limited_With (F_Typ)
1276 and then Has_Non_Limited_View (F_Typ)
1278 F_Typ := Non_Limited_View (F_Typ);
1281 -- Use formal type for temp, unless formal type is an unconstrained
1282 -- array, in which case we don't have to worry about bounds checks,
1283 -- and we use the actual type, since that has appropriate bounds.
1285 if Is_Array_Type (F_Typ) and then not Is_Constrained (F_Typ) then
1286 Indic := New_Occurrence_Of (Etype (Actual), Loc);
1288 Indic := New_Occurrence_Of (F_Typ, Loc);
1291 if Nkind (Actual) = N_Type_Conversion then
1292 V_Typ := Etype (Expression (Actual));
1294 -- If the formal is an (in-)out parameter, capture the name
1295 -- of the variable in order to build the post-call assignment.
1297 Var := Make_Var (Expression (Actual));
1299 Crep := not Same_Representation
1300 (F_Typ, Etype (Expression (Actual)));
1303 V_Typ := Etype (Actual);
1304 Var := Make_Var (Actual);
1308 -- Setup initialization for case of in out parameter, or an out
1309 -- parameter where the formal is an unconstrained array (in the
1310 -- latter case, we have to pass in an object with bounds).
1312 -- If this is an out parameter, the initial copy is wasteful, so as
1313 -- an optimization for the one-dimensional case we extract the
1314 -- bounds of the actual and build an uninitialized temporary of the
1317 if Ekind (Formal) = E_In_Out_Parameter
1318 or else (Is_Array_Type (F_Typ) and then not Is_Constrained (F_Typ))
1320 if Nkind (Actual) = N_Type_Conversion then
1321 if Conversion_OK (Actual) then
1322 Init := OK_Convert_To (F_Typ, New_Occurrence_Of (Var, Loc));
1324 Init := Convert_To (F_Typ, New_Occurrence_Of (Var, Loc));
1327 elsif Ekind (Formal) = E_Out_Parameter
1328 and then Is_Array_Type (F_Typ)
1329 and then Number_Dimensions (F_Typ) = 1
1330 and then not Has_Non_Null_Base_Init_Proc (F_Typ)
1332 -- Actual is a one-dimensional array or slice, and the type
1333 -- requires no initialization. Create a temporary of the
1334 -- right size, but do not copy actual into it (optimization).
1338 Make_Subtype_Indication (Loc,
1339 Subtype_Mark => New_Occurrence_Of (F_Typ, Loc),
1341 Make_Index_Or_Discriminant_Constraint (Loc,
1342 Constraints => New_List (
1345 Make_Attribute_Reference (Loc,
1346 Prefix => New_Occurrence_Of (Var, Loc),
1347 Attribute_Name => Name_First),
1349 Make_Attribute_Reference (Loc,
1350 Prefix => New_Occurrence_Of (Var, Loc),
1351 Attribute_Name => Name_Last)))));
1354 Init := New_Occurrence_Of (Var, Loc);
1357 -- An initialization is created for packed conversions as
1358 -- actuals for out parameters to enable Make_Object_Declaration
1359 -- to determine the proper subtype for N_Node. Note that this
1360 -- is wasteful because the extra copying on the call side is
1361 -- not required for such out parameters. ???
1363 elsif Ekind (Formal) = E_Out_Parameter
1364 and then Nkind (Actual) = N_Type_Conversion
1365 and then (Is_Bit_Packed_Array (F_Typ)
1367 Is_Bit_Packed_Array (Etype (Expression (Actual))))
1369 if Conversion_OK (Actual) then
1370 Init := OK_Convert_To (F_Typ, New_Occurrence_Of (Var, Loc));
1372 Init := Convert_To (F_Typ, New_Occurrence_Of (Var, Loc));
1375 elsif Ekind (Formal) = E_In_Parameter then
1377 -- Handle the case in which the actual is a type conversion
1379 if Nkind (Actual) = N_Type_Conversion then
1380 if Conversion_OK (Actual) then
1381 Init := OK_Convert_To (F_Typ, New_Occurrence_Of (Var, Loc));
1383 Init := Convert_To (F_Typ, New_Occurrence_Of (Var, Loc));
1386 Init := New_Occurrence_Of (Var, Loc);
1394 Make_Object_Declaration (Loc,
1395 Defining_Identifier => Temp,
1396 Object_Definition => Indic,
1397 Expression => Init);
1398 Set_Assignment_OK (N_Node);
1399 Insert_Action (N, N_Node);
1401 -- Now, normally the deal here is that we use the defining
1402 -- identifier created by that object declaration. There is
1403 -- one exception to this. In the change of representation case
1404 -- the above declaration will end up looking like:
1406 -- temp : type := identifier;
1408 -- And in this case we might as well use the identifier directly
1409 -- and eliminate the temporary. Note that the analysis of the
1410 -- declaration was not a waste of time in that case, since it is
1411 -- what generated the necessary change of representation code. If
1412 -- the change of representation introduced additional code, as in
1413 -- a fixed-integer conversion, the expression is not an identifier
1414 -- and must be kept.
1417 and then Present (Expression (N_Node))
1418 and then Is_Entity_Name (Expression (N_Node))
1420 Temp := Entity (Expression (N_Node));
1421 Rewrite (N_Node, Make_Null_Statement (Loc));
1424 -- For IN parameter, all we do is to replace the actual
1426 if Ekind (Formal) = E_In_Parameter then
1427 Rewrite (Actual, New_Occurrence_Of (Temp, Loc));
1430 -- Processing for OUT or IN OUT parameter
1433 -- Kill current value indications for the temporary variable we
1434 -- created, since we just passed it as an OUT parameter.
1436 Kill_Current_Values (Temp);
1437 Set_Is_Known_Valid (Temp, False);
1439 -- If type conversion, use reverse conversion on exit
1441 if Nkind (Actual) = N_Type_Conversion then
1442 if Conversion_OK (Actual) then
1443 Expr := OK_Convert_To (V_Typ, New_Occurrence_Of (Temp, Loc));
1445 Expr := Convert_To (V_Typ, New_Occurrence_Of (Temp, Loc));
1448 Expr := New_Occurrence_Of (Temp, Loc);
1451 Rewrite (Actual, New_Occurrence_Of (Temp, Loc));
1454 -- If the actual is a conversion of a packed reference, it may
1455 -- already have been expanded by Remove_Side_Effects, and the
1456 -- resulting variable is a temporary which does not designate
1457 -- the proper out-parameter, which may not be addressable. In
1458 -- that case, generate an assignment to the original expression
1459 -- (before expansion of the packed reference) so that the proper
1460 -- expansion of assignment to a packed component can take place.
1467 if Is_Renaming_Of_Object (Var)
1468 and then Nkind (Renamed_Object (Var)) = N_Selected_Component
1469 and then Nkind (Original_Node (Prefix (Renamed_Object (Var))))
1470 = N_Indexed_Component
1472 Has_Non_Standard_Rep (Etype (Prefix (Renamed_Object (Var))))
1474 Obj := Renamed_Object (Var);
1476 Make_Selected_Component (Loc,
1478 New_Copy_Tree (Original_Node (Prefix (Obj))),
1479 Selector_Name => New_Copy (Selector_Name (Obj)));
1480 Reset_Analyzed_Flags (Lhs);
1483 Lhs := New_Occurrence_Of (Var, Loc);
1486 Set_Assignment_OK (Lhs);
1488 if Is_Access_Type (E_Formal)
1489 and then Is_Entity_Name (Lhs)
1491 Present (Effective_Extra_Accessibility (Entity (Lhs)))
1493 -- Copyback target is an Ada 2012 stand-alone object of an
1494 -- anonymous access type.
1496 pragma Assert (Ada_Version >= Ada_2012);
1498 if Type_Access_Level (E_Formal) >
1499 Object_Access_Level (Lhs)
1501 Append_To (Post_Call,
1502 Make_Raise_Program_Error (Loc,
1503 Reason => PE_Accessibility_Check_Failed));
1506 Append_To (Post_Call,
1507 Make_Assignment_Statement (Loc,
1509 Expression => Expr));
1511 -- We would like to somehow suppress generation of the
1512 -- extra_accessibility assignment generated by the expansion
1513 -- of the above assignment statement. It's not a correctness
1514 -- issue because the following assignment renders it dead,
1515 -- but generating back-to-back assignments to the same
1516 -- target is undesirable. ???
1518 Append_To (Post_Call,
1519 Make_Assignment_Statement (Loc,
1520 Name => New_Occurrence_Of (
1521 Effective_Extra_Accessibility (Entity (Lhs)), Loc),
1522 Expression => Make_Integer_Literal (Loc,
1523 Type_Access_Level (E_Formal))));
1526 Append_To (Post_Call,
1527 Make_Assignment_Statement (Loc,
1529 Expression => Expr));
1533 end Add_Call_By_Copy_Code;
1535 ----------------------------------
1536 -- Add_Simple_Call_By_Copy_Code --
1537 ----------------------------------
1539 procedure Add_Simple_Call_By_Copy_Code is
1541 F_Typ : Entity_Id := Etype (Formal);
1550 if not Is_Legal_Copy then
1554 -- Handle formals whose type comes from the limited view
1556 if From_Limited_With (F_Typ)
1557 and then Has_Non_Limited_View (F_Typ)
1559 F_Typ := Non_Limited_View (F_Typ);
1562 -- Use formal type for temp, unless formal type is an unconstrained
1563 -- array, in which case we don't have to worry about bounds checks,
1564 -- and we use the actual type, since that has appropriate bounds.
1566 if Is_Array_Type (F_Typ) and then not Is_Constrained (F_Typ) then
1567 Indic := New_Occurrence_Of (Etype (Actual), Loc);
1569 Indic := New_Occurrence_Of (F_Typ, Loc);
1572 -- Prepare to generate code
1574 Reset_Packed_Prefix;
1576 Temp := Make_Temporary (Loc, 'T', Actual);
1577 Incod := Relocate_Node (Actual);
1578 Outcod := New_Copy_Tree (Incod);
1580 -- Generate declaration of temporary variable, initializing it
1581 -- with the input parameter unless we have an OUT formal or
1582 -- this is an initialization call.
1584 -- If the formal is an out parameter with discriminants, the
1585 -- discriminants must be captured even if the rest of the object
1586 -- is in principle uninitialized, because the discriminants may
1587 -- be read by the called subprogram.
1589 if Ekind (Formal) = E_Out_Parameter then
1592 if Has_Discriminants (F_Typ) then
1593 Indic := New_Occurrence_Of (Etype (Actual), Loc);
1596 elsif Inside_Init_Proc then
1598 -- Could use a comment here to match comment below ???
1600 if Nkind (Actual) /= N_Selected_Component
1602 not Has_Discriminant_Dependent_Constraint
1603 (Entity (Selector_Name (Actual)))
1607 -- Otherwise, keep the component in order to generate the proper
1608 -- actual subtype, that depends on enclosing discriminants.
1616 Make_Object_Declaration (Loc,
1617 Defining_Identifier => Temp,
1618 Object_Definition => Indic,
1619 Expression => Incod);
1624 -- If the call is to initialize a component of a composite type,
1625 -- and the component does not depend on discriminants, use the
1626 -- actual type of the component. This is required in case the
1627 -- component is constrained, because in general the formal of the
1628 -- initialization procedure will be unconstrained. Note that if
1629 -- the component being initialized is constrained by an enclosing
1630 -- discriminant, the presence of the initialization in the
1631 -- declaration will generate an expression for the actual subtype.
1633 Set_No_Initialization (Decl);
1634 Set_Object_Definition (Decl,
1635 New_Occurrence_Of (Etype (Actual), Loc));
1638 Insert_Action (N, Decl);
1640 -- The actual is simply a reference to the temporary
1642 Rewrite (Actual, New_Occurrence_Of (Temp, Loc));
1644 -- Generate copy out if OUT or IN OUT parameter
1646 if Ekind (Formal) /= E_In_Parameter then
1648 Rhs := New_Occurrence_Of (Temp, Loc);
1650 -- Deal with conversion
1652 if Nkind (Lhs) = N_Type_Conversion then
1653 Lhs := Expression (Lhs);
1654 Rhs := Convert_To (Etype (Actual), Rhs);
1657 Append_To (Post_Call,
1658 Make_Assignment_Statement (Loc,
1660 Expression => Rhs));
1661 Set_Assignment_OK (Name (Last (Post_Call)));
1663 end Add_Simple_Call_By_Copy_Code;
1665 --------------------------------------
1666 -- Add_Validation_Call_By_Copy_Code --
1667 --------------------------------------
1669 procedure Add_Validation_Call_By_Copy_Code (Act : Node_Id) is
1672 Obj_Typ : Entity_Id;
1673 Var : constant Node_Id := Unqual_Conv (Act);
1677 -- Copy the value of the validation variable back into the object
1680 if Is_Entity_Name (Var) then
1681 Var_Id := Entity (Var);
1682 Obj := Validated_Object (Var_Id);
1683 Obj_Typ := Etype (Obj);
1685 Expr := New_Occurrence_Of (Var_Id, Loc);
1687 -- A type conversion is needed when the validation variable and
1688 -- the validated object carry different types. This case occurs
1689 -- when the actual is qualified in some fashion.
1692 -- subtype Int is Integer range ...;
1693 -- procedure Call (Val : in out Integer);
1697 -- Call (Integer (Object));
1701 -- Var : Integer := Object; -- conversion to base type
1702 -- if not Var'Valid then -- validity check
1703 -- Call (Var); -- modify Var
1704 -- Object := Int (Var); -- conversion to subtype
1706 if Etype (Var_Id) /= Obj_Typ then
1708 Make_Type_Conversion (Loc,
1709 Subtype_Mark => New_Occurrence_Of (Obj_Typ, Loc),
1710 Expression => Expr);
1716 -- Object := Object_Type (Var);
1718 Append_To (Post_Call,
1719 Make_Assignment_Statement (Loc,
1721 Expression => Expr));
1723 -- If the flow reaches this point, then this routine was invoked with
1724 -- an actual which does not denote a validation variable.
1727 pragma Assert (False);
1730 end Add_Validation_Call_By_Copy_Code;
1732 ---------------------------
1733 -- Check_Fortran_Logical --
1734 ---------------------------
1736 procedure Check_Fortran_Logical is
1737 Logical : constant Entity_Id := Etype (Formal);
1740 -- Note: this is very incomplete, e.g. it does not handle arrays
1741 -- of logical values. This is really not the right approach at all???)
1744 if Convention (Subp) = Convention_Fortran
1745 and then Root_Type (Etype (Formal)) = Standard_Boolean
1746 and then Ekind (Formal) /= E_In_Parameter
1748 Var := Make_Var (Actual);
1749 Append_To (Post_Call,
1750 Make_Assignment_Statement (Loc,
1751 Name => New_Occurrence_Of (Var, Loc),
1753 Unchecked_Convert_To (
1756 Left_Opnd => New_Occurrence_Of (Var, Loc),
1758 Unchecked_Convert_To (
1760 New_Occurrence_Of (Standard_False, Loc))))));
1762 end Check_Fortran_Logical;
1768 function Is_Legal_Copy return Boolean is
1770 -- An attempt to copy a value of such a type can only occur if
1771 -- representation clauses give the actual a misaligned address.
1773 if Is_By_Reference_Type (Etype (Formal)) then
1775 -- The actual may in fact be properly aligned but there is not
1776 -- enough front-end information to determine this. In that case
1777 -- gigi will emit an error if a copy is not legal, or generate
1782 -- For users of Starlet, we assume that the specification of by-
1783 -- reference mechanism is mandatory. This may lead to unaligned
1784 -- objects but at least for DEC legacy code it is known to work.
1785 -- The warning will alert users of this code that a problem may
1788 elsif Mechanism (Formal) = By_Reference
1789 and then Is_Valued_Procedure (Scope (Formal))
1792 ("by_reference actual may be misaligned??", Actual);
1804 function Make_Var (Actual : Node_Id) return Entity_Id is
1808 if Is_Entity_Name (Actual) then
1809 return Entity (Actual);
1812 Var := Make_Temporary (Loc, 'T', Actual);
1815 Make_Object_Renaming_Declaration (Loc,
1816 Defining_Identifier => Var,
1818 New_Occurrence_Of (Etype (Actual), Loc),
1819 Name => Relocate_Node (Actual));
1821 Insert_Action (N, N_Node);
1826 -------------------------
1827 -- Reset_Packed_Prefix --
1828 -------------------------
1830 procedure Reset_Packed_Prefix is
1831 Pfx : Node_Id := Actual;
1834 Set_Analyzed (Pfx, False);
1836 not Nkind_In (Pfx, N_Selected_Component, N_Indexed_Component);
1837 Pfx := Prefix (Pfx);
1839 end Reset_Packed_Prefix;
1841 -- Start of processing for Expand_Actuals
1844 Post_Call := New_List;
1846 Formal := First_Formal (Subp);
1847 Actual := First_Actual (N);
1848 while Present (Formal) loop
1849 E_Formal := Etype (Formal);
1850 E_Actual := Etype (Actual);
1852 -- Handle formals whose type comes from the limited view
1854 if From_Limited_With (E_Formal)
1855 and then Has_Non_Limited_View (E_Formal)
1857 E_Formal := Non_Limited_View (E_Formal);
1860 if Is_Scalar_Type (E_Formal)
1861 or else Nkind (Actual) = N_Slice
1863 Check_Fortran_Logical;
1867 elsif Ekind (Formal) /= E_Out_Parameter then
1869 -- The unusual case of the current instance of a protected type
1870 -- requires special handling. This can only occur in the context
1871 -- of a call within the body of a protected operation.
1873 if Is_Entity_Name (Actual)
1874 and then Ekind (Entity (Actual)) = E_Protected_Type
1875 and then In_Open_Scopes (Entity (Actual))
1877 if Scope (Subp) /= Entity (Actual) then
1879 ("operation outside protected type may not "
1880 & "call back its protected operations??", Actual);
1884 Expand_Protected_Object_Reference (N, Entity (Actual)));
1887 -- Ada 2005 (AI-318-02): If the actual parameter is a call to a
1888 -- build-in-place function, then a temporary return object needs
1889 -- to be created and access to it must be passed to the function.
1890 -- Currently we limit such functions to those with inherently
1891 -- limited result subtypes, but eventually we plan to expand the
1892 -- functions that are treated as build-in-place to include other
1893 -- composite result types.
1895 if Is_Build_In_Place_Function_Call (Actual) then
1896 Make_Build_In_Place_Call_In_Anonymous_Context (Actual);
1898 -- Ada 2005 (AI-318-02): Specialization of the previous case for
1899 -- actuals containing build-in-place function calls whose returned
1900 -- object covers interface types.
1902 elsif Present (Unqual_BIP_Iface_Function_Call (Actual)) then
1903 Make_Build_In_Place_Iface_Call_In_Anonymous_Context (Actual);
1906 Apply_Constraint_Check (Actual, E_Formal);
1908 -- Out parameter case. No constraint checks on access type
1911 elsif Is_Access_Type (E_Formal) then
1916 elsif Has_Discriminants (Base_Type (E_Formal))
1917 or else Has_Non_Null_Base_Init_Proc (E_Formal)
1919 Apply_Constraint_Check (Actual, E_Formal);
1924 Apply_Constraint_Check (Actual, Base_Type (E_Formal));
1927 -- Processing for IN-OUT and OUT parameters
1929 if Ekind (Formal) /= E_In_Parameter then
1931 -- For type conversions of arrays, apply length/range checks
1933 if Is_Array_Type (E_Formal)
1934 and then Nkind (Actual) = N_Type_Conversion
1936 if Is_Constrained (E_Formal) then
1937 Apply_Length_Check (Expression (Actual), E_Formal);
1939 Apply_Range_Check (Expression (Actual), E_Formal);
1943 -- The actual denotes a variable which captures the value of an
1944 -- object for validation purposes. Add a copy-back to reflect any
1945 -- potential changes in value back into the original object.
1947 -- Var : ... := Object;
1948 -- if not Var'Valid then -- validity check
1949 -- Call (Var); -- modify var
1950 -- Object := Var; -- update Object
1952 -- This case is given higher priority because the subsequent check
1953 -- for type conversion may add an extra copy of the variable and
1954 -- prevent proper value propagation back in the original object.
1956 if Is_Validation_Variable_Reference (Actual) then
1957 Add_Validation_Call_By_Copy_Code (Actual);
1959 -- If argument is a type conversion for a type that is passed by
1960 -- copy, then we must pass the parameter by copy.
1962 elsif Nkind (Actual) = N_Type_Conversion
1964 (Is_Numeric_Type (E_Formal)
1965 or else Is_Access_Type (E_Formal)
1966 or else Is_Enumeration_Type (E_Formal)
1967 or else Is_Bit_Packed_Array (Etype (Formal))
1968 or else Is_Bit_Packed_Array (Etype (Expression (Actual)))
1970 -- Also pass by copy if change of representation
1972 or else not Same_Representation
1974 Etype (Expression (Actual))))
1976 Add_Call_By_Copy_Code;
1978 -- References to components of bit-packed arrays are expanded
1979 -- at this point, rather than at the point of analysis of the
1980 -- actuals, to handle the expansion of the assignment to
1981 -- [in] out parameters.
1983 elsif Is_Ref_To_Bit_Packed_Array (Actual) then
1984 Add_Simple_Call_By_Copy_Code;
1986 -- If a non-scalar actual is possibly bit-aligned, we need a copy
1987 -- because the back-end cannot cope with such objects. In other
1988 -- cases where alignment forces a copy, the back-end generates
1989 -- it properly. It should not be generated unconditionally in the
1990 -- front-end because it does not know precisely the alignment
1991 -- requirements of the target, and makes too conservative an
1992 -- estimate, leading to superfluous copies or spurious errors
1993 -- on by-reference parameters.
1995 elsif Nkind (Actual) = N_Selected_Component
1997 Component_May_Be_Bit_Aligned (Entity (Selector_Name (Actual)))
1998 and then not Represented_As_Scalar (Etype (Formal))
2000 Add_Simple_Call_By_Copy_Code;
2002 -- References to slices of bit-packed arrays are expanded
2004 elsif Is_Ref_To_Bit_Packed_Slice (Actual) then
2005 Add_Call_By_Copy_Code;
2007 -- References to possibly unaligned slices of arrays are expanded
2009 elsif Is_Possibly_Unaligned_Slice (Actual) then
2010 Add_Call_By_Copy_Code;
2012 -- Deal with access types where the actual subtype and the
2013 -- formal subtype are not the same, requiring a check.
2015 -- It is necessary to exclude tagged types because of "downward
2016 -- conversion" errors.
2018 elsif Is_Access_Type (E_Formal)
2019 and then not Same_Type (E_Formal, E_Actual)
2020 and then not Is_Tagged_Type (Designated_Type (E_Formal))
2022 Add_Call_By_Copy_Code;
2024 -- If the actual is not a scalar and is marked for volatile
2025 -- treatment, whereas the formal is not volatile, then pass
2026 -- by copy unless it is a by-reference type.
2028 -- Note: we use Is_Volatile here rather than Treat_As_Volatile,
2029 -- because this is the enforcement of a language rule that applies
2030 -- only to "real" volatile variables, not e.g. to the address
2031 -- clause overlay case.
2033 elsif Is_Entity_Name (Actual)
2034 and then Is_Volatile (Entity (Actual))
2035 and then not Is_By_Reference_Type (E_Actual)
2036 and then not Is_Scalar_Type (Etype (Entity (Actual)))
2037 and then not Is_Volatile (E_Formal)
2039 Add_Call_By_Copy_Code;
2041 elsif Nkind (Actual) = N_Indexed_Component
2042 and then Is_Entity_Name (Prefix (Actual))
2043 and then Has_Volatile_Components (Entity (Prefix (Actual)))
2045 Add_Call_By_Copy_Code;
2047 -- Add call-by-copy code for the case of scalar out parameters
2048 -- when it is not known at compile time that the subtype of the
2049 -- formal is a subrange of the subtype of the actual (or vice
2050 -- versa for in out parameters), in order to get range checks
2051 -- on such actuals. (Maybe this case should be handled earlier
2052 -- in the if statement???)
2054 elsif Is_Scalar_Type (E_Formal)
2056 (not In_Subrange_Of (E_Formal, E_Actual)
2058 (Ekind (Formal) = E_In_Out_Parameter
2059 and then not In_Subrange_Of (E_Actual, E_Formal)))
2061 -- Perhaps the setting back to False should be done within
2062 -- Add_Call_By_Copy_Code, since it could get set on other
2063 -- cases occurring above???
2065 if Do_Range_Check (Actual) then
2066 Set_Do_Range_Check (Actual, False);
2069 Add_Call_By_Copy_Code;
2072 -- RM 3.2.4 (23/3): A predicate is checked on in-out and out
2073 -- by-reference parameters on exit from the call. If the actual
2074 -- is a derived type and the operation is inherited, the body
2075 -- of the operation will not contain a call to the predicate
2076 -- function, so it must be done explicitly after the call. Ditto
2077 -- if the actual is an entity of a predicated subtype.
2079 -- The rule refers to by-reference types, but a check is needed
2080 -- for by-copy types as well. That check is subsumed by the rule
2081 -- for subtype conversion on assignment, but we can generate the
2082 -- required check now.
2084 -- Note also that Subp may be either a subprogram entity for
2085 -- direct calls, or a type entity for indirect calls, which must
2086 -- be handled separately because the name does not denote an
2087 -- overloadable entity.
2089 By_Ref_Predicate_Check : declare
2090 Aund : constant Entity_Id := Underlying_Type (E_Actual);
2093 function Is_Public_Subp return Boolean;
2094 -- Check whether the subprogram being called is a visible
2095 -- operation of the type of the actual. Used to determine
2096 -- whether an invariant check must be generated on the
2099 ---------------------
2100 -- Is_Public_Subp --
2101 ---------------------
2103 function Is_Public_Subp return Boolean is
2104 Pack : constant Entity_Id := Scope (Subp);
2105 Subp_Decl : Node_Id;
2108 if not Is_Subprogram (Subp) then
2111 -- The operation may be inherited, or a primitive of the
2115 Nkind_In (Parent (Subp), N_Private_Extension_Declaration,
2116 N_Full_Type_Declaration)
2118 Subp_Decl := Parent (Subp);
2121 Subp_Decl := Unit_Declaration_Node (Subp);
2124 return Ekind (Pack) = E_Package
2126 List_Containing (Subp_Decl) =
2127 Visible_Declarations
2128 (Specification (Unit_Declaration_Node (Pack)));
2131 -- Start of processing for By_Ref_Predicate_Check
2140 if Has_Predicates (Atyp)
2141 and then Present (Predicate_Function (Atyp))
2143 -- Skip predicate checks for special cases
2145 and then Predicate_Tests_On_Arguments (Subp)
2147 Append_To (Post_Call,
2148 Make_Predicate_Check (Atyp, Actual));
2151 -- We generated caller-side invariant checks in two cases:
2153 -- a) when calling an inherited operation, where there is an
2154 -- implicit view conversion of the actual to the parent type.
2156 -- b) When the conversion is explicit
2158 -- We treat these cases separately because the required
2159 -- conversion for a) is added later when expanding the call.
2161 if Has_Invariants (Etype (Actual))
2163 Nkind (Parent (Subp)) = N_Private_Extension_Declaration
2165 if Comes_From_Source (N) and then Is_Public_Subp then
2166 Append_To (Post_Call, Make_Invariant_Call (Actual));
2169 elsif Nkind (Actual) = N_Type_Conversion
2170 and then Has_Invariants (Etype (Expression (Actual)))
2172 if Comes_From_Source (N) and then Is_Public_Subp then
2173 Append_To (Post_Call,
2174 Make_Invariant_Call (Expression (Actual)));
2177 end By_Ref_Predicate_Check;
2179 -- Processing for IN parameters
2182 -- For IN parameters in the bit-packed array case, we expand an
2183 -- indexed component (the circuit in Exp_Ch4 deliberately left
2184 -- indexed components appearing as actuals untouched, so that
2185 -- the special processing above for the OUT and IN OUT cases
2186 -- could be performed. We could make the test in Exp_Ch4 more
2187 -- complex and have it detect the parameter mode, but it is
2188 -- easier simply to handle all cases here.)
2190 if Nkind (Actual) = N_Indexed_Component
2191 and then Is_Bit_Packed_Array (Etype (Prefix (Actual)))
2193 Reset_Packed_Prefix;
2194 Expand_Packed_Element_Reference (Actual);
2196 -- If we have a reference to a bit-packed array, we copy it, since
2197 -- the actual must be byte aligned.
2199 -- Is this really necessary in all cases???
2201 elsif Is_Ref_To_Bit_Packed_Array (Actual) then
2202 Add_Simple_Call_By_Copy_Code;
2204 -- If a non-scalar actual is possibly unaligned, we need a copy
2206 elsif Is_Possibly_Unaligned_Object (Actual)
2207 and then not Represented_As_Scalar (Etype (Formal))
2209 Add_Simple_Call_By_Copy_Code;
2211 -- Similarly, we have to expand slices of packed arrays here
2212 -- because the result must be byte aligned.
2214 elsif Is_Ref_To_Bit_Packed_Slice (Actual) then
2215 Add_Call_By_Copy_Code;
2217 -- Only processing remaining is to pass by copy if this is a
2218 -- reference to a possibly unaligned slice, since the caller
2219 -- expects an appropriately aligned argument.
2221 elsif Is_Possibly_Unaligned_Slice (Actual) then
2222 Add_Call_By_Copy_Code;
2224 -- An unusual case: a current instance of an enclosing task can be
2225 -- an actual, and must be replaced by a reference to self.
2227 elsif Is_Entity_Name (Actual)
2228 and then Is_Task_Type (Entity (Actual))
2230 if In_Open_Scopes (Entity (Actual)) then
2232 (Make_Function_Call (Loc,
2233 Name => New_Occurrence_Of (RTE (RE_Self), Loc))));
2236 -- A task type cannot otherwise appear as an actual
2239 raise Program_Error;
2244 Next_Formal (Formal);
2245 Next_Actual (Actual);
2253 procedure Expand_Call (N : Node_Id) is
2254 Post_Call : List_Id;
2257 pragma Assert (Nkind_In (N, N_Entry_Call_Statement,
2259 N_Procedure_Call_Statement));
2261 Expand_Call_Helper (N, Post_Call);
2262 Insert_Post_Call_Actions (N, Post_Call);
2265 ------------------------
2266 -- Expand_Call_Helper --
2267 ------------------------
2269 -- This procedure handles expansion of function calls and procedure call
2270 -- statements (i.e. it serves as the body for Expand_N_Function_Call and
2271 -- Expand_N_Procedure_Call_Statement). Processing for calls includes:
2273 -- Replace call to Raise_Exception by Raise_Exception_Always if possible
2274 -- Provide values of actuals for all formals in Extra_Formals list
2275 -- Replace "call" to enumeration literal function by literal itself
2276 -- Rewrite call to predefined operator as operator
2277 -- Replace actuals to in-out parameters that are numeric conversions,
2278 -- with explicit assignment to temporaries before and after the call.
2280 -- Note that the list of actuals has been filled with default expressions
2281 -- during semantic analysis of the call. Only the extra actuals required
2282 -- for the 'Constrained attribute and for accessibility checks are added
2285 procedure Expand_Call_Helper (N : Node_Id; Post_Call : out List_Id) is
2286 Loc : constant Source_Ptr := Sloc (N);
2287 Call_Node : Node_Id := N;
2288 Extra_Actuals : List_Id := No_List;
2289 Prev : Node_Id := Empty;
2291 procedure Add_Actual_Parameter (Insert_Param : Node_Id);
2292 -- Adds one entry to the end of the actual parameter list. Used for
2293 -- default parameters and for extra actuals (for Extra_Formals). The
2294 -- argument is an N_Parameter_Association node.
2296 procedure Add_Extra_Actual (Expr : Node_Id; EF : Entity_Id);
2297 -- Adds an extra actual to the list of extra actuals. Expr is the
2298 -- expression for the value of the actual, EF is the entity for the
2301 procedure Add_View_Conversion_Invariants
2302 (Formal : Entity_Id;
2304 -- Adds invariant checks for every intermediate type between the range
2305 -- of a view converted argument to its ancestor (from parent to child).
2307 function Inherited_From_Formal (S : Entity_Id) return Entity_Id;
2308 -- Within an instance, a type derived from an untagged formal derived
2309 -- type inherits from the original parent, not from the actual. The
2310 -- current derivation mechanism has the derived type inherit from the
2311 -- actual, which is only correct outside of the instance. If the
2312 -- subprogram is inherited, we test for this particular case through a
2313 -- convoluted tree traversal before setting the proper subprogram to be
2316 function In_Unfrozen_Instance (E : Entity_Id) return Boolean;
2317 -- Return true if E comes from an instance that is not yet frozen
2319 function Is_Direct_Deep_Call (Subp : Entity_Id) return Boolean;
2320 -- Determine if Subp denotes a non-dispatching call to a Deep routine
2322 function New_Value (From : Node_Id) return Node_Id;
2323 -- From is the original Expression. New_Value is equivalent to a call
2324 -- to Duplicate_Subexpr with an explicit dereference when From is an
2325 -- access parameter.
2327 --------------------------
2328 -- Add_Actual_Parameter --
2329 --------------------------
2331 procedure Add_Actual_Parameter (Insert_Param : Node_Id) is
2332 Actual_Expr : constant Node_Id :=
2333 Explicit_Actual_Parameter (Insert_Param);
2336 -- Case of insertion is first named actual
2338 if No (Prev) or else
2339 Nkind (Parent (Prev)) /= N_Parameter_Association
2341 Set_Next_Named_Actual
2342 (Insert_Param, First_Named_Actual (Call_Node));
2343 Set_First_Named_Actual (Call_Node, Actual_Expr);
2346 if No (Parameter_Associations (Call_Node)) then
2347 Set_Parameter_Associations (Call_Node, New_List);
2350 Append (Insert_Param, Parameter_Associations (Call_Node));
2353 Insert_After (Prev, Insert_Param);
2356 -- Case of insertion is not first named actual
2359 Set_Next_Named_Actual
2360 (Insert_Param, Next_Named_Actual (Parent (Prev)));
2361 Set_Next_Named_Actual (Parent (Prev), Actual_Expr);
2362 Append (Insert_Param, Parameter_Associations (Call_Node));
2365 Prev := Actual_Expr;
2366 end Add_Actual_Parameter;
2368 ----------------------
2369 -- Add_Extra_Actual --
2370 ----------------------
2372 procedure Add_Extra_Actual (Expr : Node_Id; EF : Entity_Id) is
2373 Loc : constant Source_Ptr := Sloc (Expr);
2376 if Extra_Actuals = No_List then
2377 Extra_Actuals := New_List;
2378 Set_Parent (Extra_Actuals, Call_Node);
2381 Append_To (Extra_Actuals,
2382 Make_Parameter_Association (Loc,
2383 Selector_Name => New_Occurrence_Of (EF, Loc),
2384 Explicit_Actual_Parameter => Expr));
2386 Analyze_And_Resolve (Expr, Etype (EF));
2388 if Nkind (Call_Node) = N_Function_Call then
2389 Set_Is_Accessibility_Actual (Parent (Expr));
2391 end Add_Extra_Actual;
2393 ------------------------------------
2394 -- Add_View_Conversion_Invariants --
2395 ------------------------------------
2397 procedure Add_View_Conversion_Invariants
2398 (Formal : Entity_Id;
2402 Curr_Typ : Entity_Id;
2403 Inv_Checks : List_Id;
2404 Par_Typ : Entity_Id;
2407 Inv_Checks := No_List;
2409 -- Extract the argument from a potentially nested set of view
2413 while Nkind (Arg) = N_Type_Conversion loop
2414 Arg := Expression (Arg);
2417 -- Move up the derivation chain starting with the type of the formal
2418 -- parameter down to the type of the actual object.
2421 Par_Typ := Etype (Arg);
2422 while Par_Typ /= Etype (Formal) and Par_Typ /= Curr_Typ loop
2423 Curr_Typ := Par_Typ;
2425 if Has_Invariants (Curr_Typ)
2426 and then Present (Invariant_Procedure (Curr_Typ))
2428 -- Verify the invariate of the current type. Generate:
2430 -- <Curr_Typ>Invariant (Curr_Typ (Arg));
2432 Prepend_New_To (Inv_Checks,
2433 Make_Procedure_Call_Statement (Loc,
2436 (Invariant_Procedure (Curr_Typ), Loc),
2437 Parameter_Associations => New_List (
2438 Make_Type_Conversion (Loc,
2439 Subtype_Mark => New_Occurrence_Of (Curr_Typ, Loc),
2440 Expression => New_Copy_Tree (Arg)))));
2443 Par_Typ := Base_Type (Etype (Curr_Typ));
2446 if not Is_Empty_List (Inv_Checks) then
2447 Insert_Actions_After (N, Inv_Checks);
2449 end Add_View_Conversion_Invariants;
2451 ---------------------------
2452 -- Inherited_From_Formal --
2453 ---------------------------
2455 function Inherited_From_Formal (S : Entity_Id) return Entity_Id is
2457 Gen_Par : Entity_Id;
2458 Gen_Prim : Elist_Id;
2463 -- If the operation is inherited, it is attached to the corresponding
2464 -- type derivation. If the parent in the derivation is a generic
2465 -- actual, it is a subtype of the actual, and we have to recover the
2466 -- original derived type declaration to find the proper parent.
2468 if Nkind (Parent (S)) /= N_Full_Type_Declaration
2469 or else not Is_Derived_Type (Defining_Identifier (Parent (S)))
2470 or else Nkind (Type_Definition (Original_Node (Parent (S)))) /=
2471 N_Derived_Type_Definition
2472 or else not In_Instance
2479 (Type_Definition (Original_Node (Parent (S))));
2481 if Nkind (Indic) = N_Subtype_Indication then
2482 Par := Entity (Subtype_Mark (Indic));
2484 Par := Entity (Indic);
2488 if not Is_Generic_Actual_Type (Par)
2489 or else Is_Tagged_Type (Par)
2490 or else Nkind (Parent (Par)) /= N_Subtype_Declaration
2491 or else not In_Open_Scopes (Scope (Par))
2495 Gen_Par := Generic_Parent_Type (Parent (Par));
2498 -- If the actual has no generic parent type, the formal is not
2499 -- a formal derived type, so nothing to inherit.
2501 if No (Gen_Par) then
2505 -- If the generic parent type is still the generic type, this is a
2506 -- private formal, not a derived formal, and there are no operations
2507 -- inherited from the formal.
2509 if Nkind (Parent (Gen_Par)) = N_Formal_Type_Declaration then
2513 Gen_Prim := Collect_Primitive_Operations (Gen_Par);
2515 Elmt := First_Elmt (Gen_Prim);
2516 while Present (Elmt) loop
2517 if Chars (Node (Elmt)) = Chars (S) then
2523 F1 := First_Formal (S);
2524 F2 := First_Formal (Node (Elmt));
2526 and then Present (F2)
2528 if Etype (F1) = Etype (F2)
2529 or else Etype (F2) = Gen_Par
2535 exit; -- not the right subprogram
2547 raise Program_Error;
2548 end Inherited_From_Formal;
2550 --------------------------
2551 -- In_Unfrozen_Instance --
2552 --------------------------
2554 function In_Unfrozen_Instance (E : Entity_Id) return Boolean is
2559 while Present (S) and then S /= Standard_Standard loop
2560 if Is_Generic_Instance (S)
2561 and then Present (Freeze_Node (S))
2562 and then not Analyzed (Freeze_Node (S))
2571 end In_Unfrozen_Instance;
2573 -------------------------
2574 -- Is_Direct_Deep_Call --
2575 -------------------------
2577 function Is_Direct_Deep_Call (Subp : Entity_Id) return Boolean is
2579 if Is_TSS (Subp, TSS_Deep_Adjust)
2580 or else Is_TSS (Subp, TSS_Deep_Finalize)
2581 or else Is_TSS (Subp, TSS_Deep_Initialize)
2588 Actual := First (Parameter_Associations (N));
2589 Formal := First_Formal (Subp);
2590 while Present (Actual)
2591 and then Present (Formal)
2593 if Nkind (Actual) = N_Identifier
2594 and then Is_Controlling_Actual (Actual)
2595 and then Etype (Actual) = Etype (Formal)
2601 Next_Formal (Formal);
2607 end Is_Direct_Deep_Call;
2613 function New_Value (From : Node_Id) return Node_Id is
2614 Res : constant Node_Id := Duplicate_Subexpr (From);
2616 if Is_Access_Type (Etype (From)) then
2617 return Make_Explicit_Dereference (Sloc (From), Prefix => Res);
2625 Remote : constant Boolean := Is_Remote_Call (Call_Node);
2628 Orig_Subp : Entity_Id := Empty;
2629 Param_Count : Natural := 0;
2630 Parent_Formal : Entity_Id;
2631 Parent_Subp : Entity_Id;
2632 Pref_Entity : Entity_Id;
2636 Prev_Orig : Node_Id;
2637 -- Original node for an actual, which may have been rewritten. If the
2638 -- actual is a function call that has been transformed from a selected
2639 -- component, the original node is unanalyzed. Otherwise, it carries
2640 -- semantic information used to generate additional actuals.
2642 CW_Interface_Formals_Present : Boolean := False;
2644 -- Start of processing for Expand_Call_Helper
2647 Post_Call := New_List;
2649 -- Expand the function or procedure call if the first actual has a
2650 -- declared dimension aspect, and the subprogram is declared in one
2651 -- of the dimension I/O packages.
2653 if Ada_Version >= Ada_2012
2655 Nkind_In (Call_Node, N_Procedure_Call_Statement, N_Function_Call)
2656 and then Present (Parameter_Associations (Call_Node))
2658 Expand_Put_Call_With_Symbol (Call_Node);
2661 -- Ignore if previous error
2663 if Nkind (Call_Node) in N_Has_Etype
2664 and then Etype (Call_Node) = Any_Type
2669 -- Call using access to subprogram with explicit dereference
2671 if Nkind (Name (Call_Node)) = N_Explicit_Dereference then
2672 Subp := Etype (Name (Call_Node));
2673 Parent_Subp := Empty;
2675 -- Case of call to simple entry, where the Name is a selected component
2676 -- whose prefix is the task, and whose selector name is the entry name
2678 elsif Nkind (Name (Call_Node)) = N_Selected_Component then
2679 Subp := Entity (Selector_Name (Name (Call_Node)));
2680 Parent_Subp := Empty;
2682 -- Case of call to member of entry family, where Name is an indexed
2683 -- component, with the prefix being a selected component giving the
2684 -- task and entry family name, and the index being the entry index.
2686 elsif Nkind (Name (Call_Node)) = N_Indexed_Component then
2687 Subp := Entity (Selector_Name (Prefix (Name (Call_Node))));
2688 Parent_Subp := Empty;
2693 Subp := Entity (Name (Call_Node));
2694 Parent_Subp := Alias (Subp);
2696 -- Replace call to Raise_Exception by call to Raise_Exception_Always
2697 -- if we can tell that the first parameter cannot possibly be null.
2698 -- This improves efficiency by avoiding a run-time test.
2700 -- We do not do this if Raise_Exception_Always does not exist, which
2701 -- can happen in configurable run time profiles which provide only a
2704 if Is_RTE (Subp, RE_Raise_Exception)
2705 and then RTE_Available (RE_Raise_Exception_Always)
2708 FA : constant Node_Id :=
2709 Original_Node (First_Actual (Call_Node));
2712 -- The case we catch is where the first argument is obtained
2713 -- using the Identity attribute (which must always be
2716 if Nkind (FA) = N_Attribute_Reference
2717 and then Attribute_Name (FA) = Name_Identity
2719 Subp := RTE (RE_Raise_Exception_Always);
2720 Set_Name (Call_Node, New_Occurrence_Of (Subp, Loc));
2725 if Ekind (Subp) = E_Entry then
2726 Parent_Subp := Empty;
2730 -- Ada 2005 (AI-345): We have a procedure call as a triggering
2731 -- alternative in an asynchronous select or as an entry call in
2732 -- a conditional or timed select. Check whether the procedure call
2733 -- is a renaming of an entry and rewrite it as an entry call.
2735 if Ada_Version >= Ada_2005
2736 and then Nkind (Call_Node) = N_Procedure_Call_Statement
2738 ((Nkind (Parent (Call_Node)) = N_Triggering_Alternative
2739 and then Triggering_Statement (Parent (Call_Node)) = Call_Node)
2741 (Nkind (Parent (Call_Node)) = N_Entry_Call_Alternative
2742 and then Entry_Call_Statement (Parent (Call_Node)) = Call_Node))
2746 Ren_Root : Entity_Id := Subp;
2749 -- This may be a chain of renamings, find the root
2751 if Present (Alias (Ren_Root)) then
2752 Ren_Root := Alias (Ren_Root);
2755 if Present (Original_Node (Parent (Parent (Ren_Root)))) then
2756 Ren_Decl := Original_Node (Parent (Parent (Ren_Root)));
2758 if Nkind (Ren_Decl) = N_Subprogram_Renaming_Declaration then
2760 Make_Entry_Call_Statement (Loc,
2762 New_Copy_Tree (Name (Ren_Decl)),
2763 Parameter_Associations =>
2765 (Parameter_Associations (Call_Node))));
2773 if Modify_Tree_For_C
2774 and then Nkind (Call_Node) = N_Function_Call
2775 and then Is_Entity_Name (Name (Call_Node))
2778 Func_Id : constant Entity_Id :=
2779 Ultimate_Alias (Entity (Name (Call_Node)));
2781 -- When generating C code, transform a function call that returns
2782 -- a constrained array type into procedure form.
2784 if Rewritten_For_C (Func_Id) then
2786 -- For internally generated calls ensure that they reference
2787 -- the entity of the spec of the called function (needed since
2788 -- the expander may generate calls using the entity of their
2789 -- body). See for example Expand_Boolean_Operator().
2791 if not (Comes_From_Source (Call_Node))
2792 and then Nkind (Unit_Declaration_Node (Func_Id)) =
2795 Set_Entity (Name (Call_Node),
2796 Corresponding_Function
2797 (Corresponding_Procedure (Func_Id)));
2800 Rewrite_Function_Call_For_C (Call_Node);
2803 -- Also introduce a temporary for functions that return a record
2804 -- called within another procedure or function call, since records
2805 -- are passed by pointer in the generated C code, and we cannot
2806 -- take a pointer from a subprogram call.
2808 elsif Nkind (Parent (Call_Node)) in N_Subprogram_Call
2809 and then Is_Record_Type (Etype (Func_Id))
2812 Temp_Id : constant Entity_Id := Make_Temporary (Loc, 'T');
2817 -- Temp : ... := Func_Call (...);
2820 Make_Object_Declaration (Loc,
2821 Defining_Identifier => Temp_Id,
2822 Object_Definition =>
2823 New_Occurrence_Of (Etype (Func_Id), Loc),
2825 Make_Function_Call (Loc,
2827 New_Occurrence_Of (Func_Id, Loc),
2828 Parameter_Associations =>
2829 Parameter_Associations (Call_Node)));
2831 Insert_Action (Parent (Call_Node), Decl);
2832 Rewrite (Call_Node, New_Occurrence_Of (Temp_Id, Loc));
2839 -- First step, compute extra actuals, corresponding to any Extra_Formals
2840 -- present. Note that we do not access Extra_Formals directly, instead
2841 -- we simply note the presence of the extra formals as we process the
2842 -- regular formals collecting corresponding actuals in Extra_Actuals.
2844 -- We also generate any required range checks for actuals for in formals
2845 -- as we go through the loop, since this is a convenient place to do it.
2846 -- (Though it seems that this would be better done in Expand_Actuals???)
2848 -- Special case: Thunks must not compute the extra actuals; they must
2849 -- just propagate to the target primitive their extra actuals.
2851 if Is_Thunk (Current_Scope)
2852 and then Thunk_Entity (Current_Scope) = Subp
2853 and then Present (Extra_Formals (Subp))
2855 pragma Assert (Present (Extra_Formals (Current_Scope)));
2858 Target_Formal : Entity_Id;
2859 Thunk_Formal : Entity_Id;
2862 Target_Formal := Extra_Formals (Subp);
2863 Thunk_Formal := Extra_Formals (Current_Scope);
2864 while Present (Target_Formal) loop
2866 (Expr => New_Occurrence_Of (Thunk_Formal, Loc),
2867 EF => Thunk_Formal);
2869 Target_Formal := Extra_Formal (Target_Formal);
2870 Thunk_Formal := Extra_Formal (Thunk_Formal);
2873 while Is_Non_Empty_List (Extra_Actuals) loop
2874 Add_Actual_Parameter (Remove_Head (Extra_Actuals));
2877 Expand_Actuals (Call_Node, Subp, Post_Call);
2878 pragma Assert (Is_Empty_List (Post_Call));
2883 Formal := First_Formal (Subp);
2884 Actual := First_Actual (Call_Node);
2886 while Present (Formal) loop
2888 -- Generate range check if required
2890 if Do_Range_Check (Actual)
2891 and then Ekind (Formal) = E_In_Parameter
2893 Generate_Range_Check
2894 (Actual, Etype (Formal), CE_Range_Check_Failed);
2897 -- Prepare to examine current entry
2900 Prev_Orig := Original_Node (Prev);
2902 -- Ada 2005 (AI-251): Check if any formal is a class-wide interface
2903 -- to expand it in a further round.
2905 CW_Interface_Formals_Present :=
2906 CW_Interface_Formals_Present
2908 (Is_Class_Wide_Type (Etype (Formal))
2909 and then Is_Interface (Etype (Etype (Formal))))
2911 (Ekind (Etype (Formal)) = E_Anonymous_Access_Type
2912 and then Is_Class_Wide_Type (Directly_Designated_Type
2913 (Etype (Etype (Formal))))
2914 and then Is_Interface (Directly_Designated_Type
2915 (Etype (Etype (Formal)))));
2917 -- Create possible extra actual for constrained case. Usually, the
2918 -- extra actual is of the form actual'constrained, but since this
2919 -- attribute is only available for unconstrained records, TRUE is
2920 -- expanded if the type of the formal happens to be constrained (for
2921 -- instance when this procedure is inherited from an unconstrained
2922 -- record to a constrained one) or if the actual has no discriminant
2923 -- (its type is constrained). An exception to this is the case of a
2924 -- private type without discriminants. In this case we pass FALSE
2925 -- because the object has underlying discriminants with defaults.
2927 if Present (Extra_Constrained (Formal)) then
2928 if Ekind (Etype (Prev)) in Private_Kind
2929 and then not Has_Discriminants (Base_Type (Etype (Prev)))
2932 (Expr => New_Occurrence_Of (Standard_False, Loc),
2933 EF => Extra_Constrained (Formal));
2935 elsif Is_Constrained (Etype (Formal))
2936 or else not Has_Discriminants (Etype (Prev))
2939 (Expr => New_Occurrence_Of (Standard_True, Loc),
2940 EF => Extra_Constrained (Formal));
2942 -- Do not produce extra actuals for Unchecked_Union parameters.
2943 -- Jump directly to the end of the loop.
2945 elsif Is_Unchecked_Union (Base_Type (Etype (Actual))) then
2946 goto Skip_Extra_Actual_Generation;
2949 -- If the actual is a type conversion, then the constrained
2950 -- test applies to the actual, not the target type.
2956 -- Test for unchecked conversions as well, which can occur
2957 -- as out parameter actuals on calls to stream procedures.
2960 while Nkind_In (Act_Prev, N_Type_Conversion,
2961 N_Unchecked_Type_Conversion)
2963 Act_Prev := Expression (Act_Prev);
2966 -- If the expression is a conversion of a dereference, this
2967 -- is internally generated code that manipulates addresses,
2968 -- e.g. when building interface tables. No check should
2969 -- occur in this case, and the discriminated object is not
2972 if not Comes_From_Source (Actual)
2973 and then Nkind (Actual) = N_Unchecked_Type_Conversion
2974 and then Nkind (Act_Prev) = N_Explicit_Dereference
2977 (Expr => New_Occurrence_Of (Standard_False, Loc),
2978 EF => Extra_Constrained (Formal));
2983 Make_Attribute_Reference (Sloc (Prev),
2985 Duplicate_Subexpr_No_Checks
2986 (Act_Prev, Name_Req => True),
2987 Attribute_Name => Name_Constrained),
2988 EF => Extra_Constrained (Formal));
2994 -- Create possible extra actual for accessibility level
2996 if Present (Extra_Accessibility (Formal)) then
2998 -- Ada 2005 (AI-252): If the actual was rewritten as an Access
2999 -- attribute, then the original actual may be an aliased object
3000 -- occurring as the prefix in a call using "Object.Operation"
3001 -- notation. In that case we must pass the level of the object,
3002 -- so Prev_Orig is reset to Prev and the attribute will be
3003 -- processed by the code for Access attributes further below.
3005 if Prev_Orig /= Prev
3006 and then Nkind (Prev) = N_Attribute_Reference
3007 and then Get_Attribute_Id (Attribute_Name (Prev)) =
3009 and then Is_Aliased_View (Prev_Orig)
3013 -- A class-wide precondition generates a test in which formals of
3014 -- the subprogram are replaced by actuals that came from source.
3015 -- In that case as well, the accessiblity comes from the actual.
3016 -- This is the one case in which there are references to formals
3017 -- outside of their subprogram.
3019 elsif Prev_Orig /= Prev
3020 and then Is_Entity_Name (Prev_Orig)
3021 and then Present (Entity (Prev_Orig))
3022 and then Is_Formal (Entity (Prev_Orig))
3023 and then not In_Open_Scopes (Scope (Entity (Prev_Orig)))
3027 -- If the actual is a formal of an enclosing subprogram it is
3028 -- the right entity, even if it is a rewriting. This happens
3029 -- when the call is within an inherited condition or predicate.
3031 elsif Is_Entity_Name (Actual)
3032 and then Is_Formal (Entity (Actual))
3033 and then In_Open_Scopes (Scope (Entity (Actual)))
3037 elsif Nkind (Prev_Orig) = N_Type_Conversion then
3038 Prev_Orig := Expression (Prev_Orig);
3041 -- Ada 2005 (AI-251): Thunks must propagate the extra actuals of
3042 -- accessibility levels.
3044 if Is_Thunk (Current_Scope) then
3046 Parm_Ent : Entity_Id;
3049 if Is_Controlling_Actual (Actual) then
3051 -- Find the corresponding actual of the thunk
3053 Parm_Ent := First_Entity (Current_Scope);
3054 for J in 2 .. Param_Count loop
3055 Next_Entity (Parm_Ent);
3058 -- Handle unchecked conversion of access types generated
3059 -- in thunks (cf. Expand_Interface_Thunk).
3061 elsif Is_Access_Type (Etype (Actual))
3062 and then Nkind (Actual) = N_Unchecked_Type_Conversion
3064 Parm_Ent := Entity (Expression (Actual));
3066 else pragma Assert (Is_Entity_Name (Actual));
3067 Parm_Ent := Entity (Actual);
3072 New_Occurrence_Of (Extra_Accessibility (Parm_Ent), Loc),
3073 EF => Extra_Accessibility (Formal));
3076 elsif Is_Entity_Name (Prev_Orig) then
3078 -- When passing an access parameter, or a renaming of an access
3079 -- parameter, as the actual to another access parameter we need
3080 -- to pass along the actual's own access level parameter. This
3081 -- is done if we are within the scope of the formal access
3082 -- parameter (if this is an inlined body the extra formal is
3085 if (Is_Formal (Entity (Prev_Orig))
3087 (Present (Renamed_Object (Entity (Prev_Orig)))
3089 Is_Entity_Name (Renamed_Object (Entity (Prev_Orig)))
3092 (Entity (Renamed_Object (Entity (Prev_Orig))))))
3093 and then Ekind (Etype (Prev_Orig)) = E_Anonymous_Access_Type
3094 and then In_Open_Scopes (Scope (Entity (Prev_Orig)))
3097 Parm_Ent : constant Entity_Id := Param_Entity (Prev_Orig);
3100 pragma Assert (Present (Parm_Ent));
3102 if Present (Extra_Accessibility (Parm_Ent)) then
3106 (Extra_Accessibility (Parm_Ent), Loc),
3107 EF => Extra_Accessibility (Formal));
3109 -- If the actual access parameter does not have an
3110 -- associated extra formal providing its scope level,
3111 -- then treat the actual as having library-level
3117 Make_Integer_Literal (Loc,
3118 Intval => Scope_Depth (Standard_Standard)),
3119 EF => Extra_Accessibility (Formal));
3123 -- The actual is a normal access value, so just pass the level
3124 -- of the actual's access type.
3128 (Expr => Dynamic_Accessibility_Level (Prev_Orig),
3129 EF => Extra_Accessibility (Formal));
3132 -- If the actual is an access discriminant, then pass the level
3133 -- of the enclosing object (RM05-3.10.2(12.4/2)).
3135 elsif Nkind (Prev_Orig) = N_Selected_Component
3136 and then Ekind (Entity (Selector_Name (Prev_Orig))) =
3138 and then Ekind (Etype (Entity (Selector_Name (Prev_Orig)))) =
3139 E_Anonymous_Access_Type
3143 Make_Integer_Literal (Loc,
3144 Intval => Object_Access_Level (Prefix (Prev_Orig))),
3145 EF => Extra_Accessibility (Formal));
3150 case Nkind (Prev_Orig) is
3151 when N_Attribute_Reference =>
3152 case Get_Attribute_Id (Attribute_Name (Prev_Orig)) is
3154 -- For X'Access, pass on the level of the prefix X
3156 when Attribute_Access =>
3158 -- Accessibility level of S'Access is that of A
3160 Prev_Orig := Prefix (Prev_Orig);
3162 -- If the expression is a view conversion, the
3163 -- accessibility level is that of the expression.
3165 if Nkind (Original_Node (Prev_Orig)) =
3168 Nkind (Expression (Original_Node (Prev_Orig))) =
3169 N_Explicit_Dereference
3172 Expression (Original_Node (Prev_Orig));
3175 -- If this is an Access attribute applied to the
3176 -- the current instance object passed to a type
3177 -- initialization procedure, then use the level
3178 -- of the type itself. This is not really correct,
3179 -- as there should be an extra level parameter
3180 -- passed in with _init formals (only in the case
3181 -- where the type is immutably limited), but we
3182 -- don't have an easy way currently to create such
3183 -- an extra formal (init procs aren't ever frozen).
3184 -- For now we just use the level of the type,
3185 -- which may be too shallow, but that works better
3186 -- than passing Object_Access_Level of the type,
3187 -- which can be one level too deep in some cases.
3190 -- A further case that requires special handling
3191 -- is the common idiom E.all'access. If E is a
3192 -- formal of the enclosing subprogram, the
3193 -- accessibility of the expression is that of E.
3195 if Is_Entity_Name (Prev_Orig) then
3196 Pref_Entity := Entity (Prev_Orig);
3198 elsif Nkind (Prev_Orig) = N_Explicit_Dereference
3199 and then Is_Entity_Name (Prefix (Prev_Orig))
3201 Pref_Entity := Entity (Prefix ((Prev_Orig)));
3204 Pref_Entity := Empty;
3207 if Is_Entity_Name (Prev_Orig)
3208 and then Is_Type (Entity (Prev_Orig))
3212 Make_Integer_Literal (Loc,
3214 Type_Access_Level (Pref_Entity)),
3215 EF => Extra_Accessibility (Formal));
3217 elsif Nkind (Prev_Orig) = N_Explicit_Dereference
3218 and then Present (Pref_Entity)
3219 and then Is_Formal (Pref_Entity)
3221 (Extra_Accessibility (Pref_Entity))
3226 (Extra_Accessibility (Pref_Entity), Loc),
3227 EF => Extra_Accessibility (Formal));
3232 Make_Integer_Literal (Loc,
3234 Object_Access_Level (Prev_Orig)),
3235 EF => Extra_Accessibility (Formal));
3238 -- Treat the unchecked attributes as library-level
3240 when Attribute_Unchecked_Access
3241 | Attribute_Unrestricted_Access
3245 Make_Integer_Literal (Loc,
3246 Intval => Scope_Depth (Standard_Standard)),
3247 EF => Extra_Accessibility (Formal));
3249 -- No other cases of attributes returning access
3250 -- values that can be passed to access parameters.
3253 raise Program_Error;
3257 -- For allocators we pass the level of the execution of the
3258 -- called subprogram, which is one greater than the current
3264 Make_Integer_Literal (Loc,
3265 Intval => Scope_Depth (Current_Scope) + 1),
3266 EF => Extra_Accessibility (Formal));
3268 -- For most other cases we simply pass the level of the
3269 -- actual's access type. The type is retrieved from
3270 -- Prev rather than Prev_Orig, because in some cases
3271 -- Prev_Orig denotes an original expression that has
3272 -- not been analyzed.
3276 (Expr => Dynamic_Accessibility_Level (Prev),
3277 EF => Extra_Accessibility (Formal));
3282 -- Perform the check of 4.6(49) that prevents a null value from being
3283 -- passed as an actual to an access parameter. Note that the check
3284 -- is elided in the common cases of passing an access attribute or
3285 -- access parameter as an actual. Also, we currently don't enforce
3286 -- this check for expander-generated actuals and when -gnatdj is set.
3288 if Ada_Version >= Ada_2005 then
3290 -- Ada 2005 (AI-231): Check null-excluding access types. Note that
3291 -- the intent of 6.4.1(13) is that null-exclusion checks should
3292 -- not be done for 'out' parameters, even though it refers only
3293 -- to constraint checks, and a null_exclusion is not a constraint.
3294 -- Note that AI05-0196-1 corrects this mistake in the RM.
3296 if Is_Access_Type (Etype (Formal))
3297 and then Can_Never_Be_Null (Etype (Formal))
3298 and then Ekind (Formal) /= E_Out_Parameter
3299 and then Nkind (Prev) /= N_Raise_Constraint_Error
3300 and then (Known_Null (Prev)
3301 or else not Can_Never_Be_Null (Etype (Prev)))
3303 Install_Null_Excluding_Check (Prev);
3306 -- Ada_Version < Ada_2005
3309 if Ekind (Etype (Formal)) /= E_Anonymous_Access_Type
3310 or else Access_Checks_Suppressed (Subp)
3314 elsif Debug_Flag_J then
3317 elsif not Comes_From_Source (Prev) then
3320 elsif Is_Entity_Name (Prev)
3321 and then Ekind (Etype (Prev)) = E_Anonymous_Access_Type
3325 elsif Nkind_In (Prev, N_Allocator, N_Attribute_Reference) then
3329 Install_Null_Excluding_Check (Prev);
3333 -- Perform appropriate validity checks on parameters that
3336 if Validity_Checks_On then
3337 if (Ekind (Formal) = E_In_Parameter
3338 and then Validity_Check_In_Params)
3340 (Ekind (Formal) = E_In_Out_Parameter
3341 and then Validity_Check_In_Out_Params)
3343 -- If the actual is an indexed component of a packed type (or
3344 -- is an indexed or selected component whose prefix recursively
3345 -- meets this condition), it has not been expanded yet. It will
3346 -- be copied in the validity code that follows, and has to be
3347 -- expanded appropriately, so reanalyze it.
3349 -- What we do is just to unset analyzed bits on prefixes till
3350 -- we reach something that does not have a prefix.
3357 while Nkind_In (Nod, N_Indexed_Component,
3358 N_Selected_Component)
3360 Set_Analyzed (Nod, False);
3361 Nod := Prefix (Nod);
3365 Ensure_Valid (Actual);
3369 -- For IN OUT and OUT parameters, ensure that subscripts are valid
3370 -- since this is a left side reference. We only do this for calls
3371 -- from the source program since we assume that compiler generated
3372 -- calls explicitly generate any required checks. We also need it
3373 -- only if we are doing standard validity checks, since clearly it is
3374 -- not needed if validity checks are off, and in subscript validity
3375 -- checking mode, all indexed components are checked with a call
3376 -- directly from Expand_N_Indexed_Component.
3378 if Comes_From_Source (Call_Node)
3379 and then Ekind (Formal) /= E_In_Parameter
3380 and then Validity_Checks_On
3381 and then Validity_Check_Default
3382 and then not Validity_Check_Subscripts
3384 Check_Valid_Lvalue_Subscripts (Actual);
3387 -- Mark any scalar OUT parameter that is a simple variable as no
3388 -- longer known to be valid (unless the type is always valid). This
3389 -- reflects the fact that if an OUT parameter is never set in a
3390 -- procedure, then it can become invalid on the procedure return.
3392 if Ekind (Formal) = E_Out_Parameter
3393 and then Is_Entity_Name (Actual)
3394 and then Ekind (Entity (Actual)) = E_Variable
3395 and then not Is_Known_Valid (Etype (Actual))
3397 Set_Is_Known_Valid (Entity (Actual), False);
3400 -- For an OUT or IN OUT parameter, if the actual is an entity, then
3401 -- clear current values, since they can be clobbered. We are probably
3402 -- doing this in more places than we need to, but better safe than
3403 -- sorry when it comes to retaining bad current values.
3405 if Ekind (Formal) /= E_In_Parameter
3406 and then Is_Entity_Name (Actual)
3407 and then Present (Entity (Actual))
3410 Ent : constant Entity_Id := Entity (Actual);
3414 -- For an OUT or IN OUT parameter that is an assignable entity,
3415 -- we do not want to clobber the Last_Assignment field, since
3416 -- if it is set, it was precisely because it is indeed an OUT
3417 -- or IN OUT parameter. We do reset the Is_Known_Valid flag
3418 -- since the subprogram could have returned in invalid value.
3420 if Ekind_In (Formal, E_Out_Parameter, E_In_Out_Parameter)
3421 and then Is_Assignable (Ent)
3423 Sav := Last_Assignment (Ent);
3424 Kill_Current_Values (Ent);
3425 Set_Last_Assignment (Ent, Sav);
3426 Set_Is_Known_Valid (Ent, False);
3428 -- For all other cases, just kill the current values
3431 Kill_Current_Values (Ent);
3436 -- If the formal is class wide and the actual is an aggregate, force
3437 -- evaluation so that the back end who does not know about class-wide
3438 -- type, does not generate a temporary of the wrong size.
3440 if not Is_Class_Wide_Type (Etype (Formal)) then
3443 elsif Nkind (Actual) = N_Aggregate
3444 or else (Nkind (Actual) = N_Qualified_Expression
3445 and then Nkind (Expression (Actual)) = N_Aggregate)
3447 Force_Evaluation (Actual);
3450 -- In a remote call, if the formal is of a class-wide type, check
3451 -- that the actual meets the requirements described in E.4(18).
3453 if Remote and then Is_Class_Wide_Type (Etype (Formal)) then
3454 Insert_Action (Actual,
3455 Make_Transportable_Check (Loc,
3456 Duplicate_Subexpr_Move_Checks (Actual)));
3459 -- Perform invariant checks for all intermediate types in a view
3460 -- conversion after successful return from a call that passes the
3461 -- view conversion as an IN OUT or OUT parameter (RM 7.3.2 (12/3,
3462 -- 13/3, 14/3)). Consider only source conversion in order to avoid
3463 -- generating spurious checks on complex expansion such as object
3464 -- initialization through an extension aggregate.
3466 if Comes_From_Source (N)
3467 and then Ekind (Formal) /= E_In_Parameter
3468 and then Nkind (Actual) = N_Type_Conversion
3470 Add_View_Conversion_Invariants (Formal, Actual);
3473 -- Generating C the initialization of an allocator is performed by
3474 -- means of individual statements, and hence it must be done before
3477 if Modify_Tree_For_C
3478 and then Nkind (Actual) = N_Allocator
3479 and then Nkind (Expression (Actual)) = N_Qualified_Expression
3481 Remove_Side_Effects (Actual);
3484 -- This label is required when skipping extra actual generation for
3485 -- Unchecked_Union parameters.
3487 <<Skip_Extra_Actual_Generation>>
3489 Param_Count := Param_Count + 1;
3490 Next_Actual (Actual);
3491 Next_Formal (Formal);
3494 -- If we are calling an Ada 2012 function which needs to have the
3495 -- "accessibility level determined by the point of call" (AI05-0234)
3496 -- passed in to it, then pass it in.
3498 if Ekind_In (Subp, E_Function, E_Operator, E_Subprogram_Type)
3500 Present (Extra_Accessibility_Of_Result (Ultimate_Alias (Subp)))
3503 Ancestor : Node_Id := Parent (Call_Node);
3504 Level : Node_Id := Empty;
3505 Defer : Boolean := False;
3508 -- Unimplemented: if Subp returns an anonymous access type, then
3510 -- a) if the call is the operand of an explict conversion, then
3511 -- the target type of the conversion (a named access type)
3512 -- determines the accessibility level pass in;
3514 -- b) if the call defines an access discriminant of an object
3515 -- (e.g., the discriminant of an object being created by an
3516 -- allocator, or the discriminant of a function result),
3517 -- then the accessibility level to pass in is that of the
3518 -- discriminated object being initialized).
3522 while Nkind (Ancestor) = N_Qualified_Expression
3524 Ancestor := Parent (Ancestor);
3527 case Nkind (Ancestor) is
3530 -- At this point, we'd like to assign
3532 -- Level := Dynamic_Accessibility_Level (Ancestor);
3534 -- but Etype of Ancestor may not have been set yet,
3535 -- so that doesn't work.
3537 -- Handle this later in Expand_Allocator_Expression.
3541 when N_Object_Declaration
3542 | N_Object_Renaming_Declaration
3545 Def_Id : constant Entity_Id :=
3546 Defining_Identifier (Ancestor);
3549 if Is_Return_Object (Def_Id) then
3550 if Present (Extra_Accessibility_Of_Result
3551 (Return_Applies_To (Scope (Def_Id))))
3553 -- Pass along value that was passed in if the
3554 -- routine we are returning from also has an
3555 -- Accessibility_Of_Result formal.
3559 (Extra_Accessibility_Of_Result
3560 (Return_Applies_To (Scope (Def_Id))), Loc);
3564 Make_Integer_Literal (Loc,
3565 Intval => Object_Access_Level (Def_Id));
3569 when N_Simple_Return_Statement =>
3570 if Present (Extra_Accessibility_Of_Result
3572 (Return_Statement_Entity (Ancestor))))
3574 -- Pass along value that was passed in if the returned
3575 -- routine also has an Accessibility_Of_Result formal.
3579 (Extra_Accessibility_Of_Result
3581 (Return_Statement_Entity (Ancestor))), Loc);
3589 if not Present (Level) then
3591 -- The "innermost master that evaluates the function call".
3593 -- ??? - Should we use Integer'Last here instead in order
3594 -- to deal with (some of) the problems associated with
3595 -- calls to subps whose enclosing scope is unknown (e.g.,
3596 -- Anon_Access_To_Subp_Param.all)?
3599 Make_Integer_Literal (Loc,
3600 Intval => Scope_Depth (Current_Scope) + 1);
3606 Extra_Accessibility_Of_Result (Ultimate_Alias (Subp)));
3611 -- If we are expanding the RHS of an assignment we need to check if tag
3612 -- propagation is needed. You might expect this processing to be in
3613 -- Analyze_Assignment but has to be done earlier (bottom-up) because the
3614 -- assignment might be transformed to a declaration for an unconstrained
3615 -- value if the expression is classwide.
3617 if Nkind (Call_Node) = N_Function_Call
3618 and then Is_Tag_Indeterminate (Call_Node)
3619 and then Is_Entity_Name (Name (Call_Node))
3622 Ass : Node_Id := Empty;
3625 if Nkind (Parent (Call_Node)) = N_Assignment_Statement then
3626 Ass := Parent (Call_Node);
3628 elsif Nkind (Parent (Call_Node)) = N_Qualified_Expression
3629 and then Nkind (Parent (Parent (Call_Node))) =
3630 N_Assignment_Statement
3632 Ass := Parent (Parent (Call_Node));
3634 elsif Nkind (Parent (Call_Node)) = N_Explicit_Dereference
3635 and then Nkind (Parent (Parent (Call_Node))) =
3636 N_Assignment_Statement
3638 Ass := Parent (Parent (Call_Node));
3642 and then Is_Class_Wide_Type (Etype (Name (Ass)))
3644 if Is_Access_Type (Etype (Call_Node)) then
3645 if Designated_Type (Etype (Call_Node)) /=
3646 Root_Type (Etype (Name (Ass)))
3649 ("tag-indeterminate expression must have designated "
3650 & "type& (RM 5.2 (6))",
3651 Call_Node, Root_Type (Etype (Name (Ass))));
3653 Propagate_Tag (Name (Ass), Call_Node);
3656 elsif Etype (Call_Node) /= Root_Type (Etype (Name (Ass))) then
3658 ("tag-indeterminate expression must have type & "
3660 Call_Node, Root_Type (Etype (Name (Ass))));
3663 Propagate_Tag (Name (Ass), Call_Node);
3666 -- The call will be rewritten as a dispatching call, and
3667 -- expanded as such.
3674 -- Ada 2005 (AI-251): If some formal is a class-wide interface, expand
3675 -- it to point to the correct secondary virtual table
3677 if Nkind (Call_Node) in N_Subprogram_Call
3678 and then CW_Interface_Formals_Present
3680 Expand_Interface_Actuals (Call_Node);
3683 -- Deals with Dispatch_Call if we still have a call, before expanding
3684 -- extra actuals since this will be done on the re-analysis of the
3685 -- dispatching call. Note that we do not try to shorten the actual list
3686 -- for a dispatching call, it would not make sense to do so. Expansion
3687 -- of dispatching calls is suppressed for VM targets, because the VM
3688 -- back-ends directly handle the generation of dispatching calls and
3689 -- would have to undo any expansion to an indirect call.
3691 if Nkind (Call_Node) in N_Subprogram_Call
3692 and then Present (Controlling_Argument (Call_Node))
3695 Call_Typ : constant Entity_Id := Etype (Call_Node);
3696 Typ : constant Entity_Id := Find_Dispatching_Type (Subp);
3697 Eq_Prim_Op : Entity_Id := Empty;
3700 Prev_Call : Node_Id;
3703 if not Is_Limited_Type (Typ) then
3704 Eq_Prim_Op := Find_Prim_Op (Typ, Name_Op_Eq);
3707 if Tagged_Type_Expansion then
3708 Expand_Dispatching_Call (Call_Node);
3710 -- The following return is worrisome. Is it really OK to skip
3711 -- all remaining processing in this procedure ???
3718 Apply_Tag_Checks (Call_Node);
3720 -- If this is a dispatching "=", we must first compare the
3721 -- tags so we generate: x.tag = y.tag and then x = y
3723 if Subp = Eq_Prim_Op then
3725 -- Mark the node as analyzed to avoid reanalyzing this
3726 -- dispatching call (which would cause a never-ending loop)
3728 Prev_Call := Relocate_Node (Call_Node);
3729 Set_Analyzed (Prev_Call);
3731 Param := First_Actual (Call_Node);
3737 Make_Selected_Component (Loc,
3738 Prefix => New_Value (Param),
3741 (First_Tag_Component (Typ), Loc)),
3744 Make_Selected_Component (Loc,
3746 Unchecked_Convert_To (Typ,
3747 New_Value (Next_Actual (Param))),
3750 (First_Tag_Component (Typ), Loc))),
3751 Right_Opnd => Prev_Call);
3753 Rewrite (Call_Node, New_Call);
3756 (Call_Node, Call_Typ, Suppress => All_Checks);
3759 -- Expansion of a dispatching call results in an indirect call,
3760 -- which in turn causes current values to be killed (see
3761 -- Resolve_Call), so on VM targets we do the call here to
3762 -- ensure consistent warnings between VM and non-VM targets.
3764 Kill_Current_Values;
3767 -- If this is a dispatching "=" then we must update the reference
3768 -- to the call node because we generated:
3769 -- x.tag = y.tag and then x = y
3771 if Subp = Eq_Prim_Op then
3772 Call_Node := Right_Opnd (Call_Node);
3777 -- Similarly, expand calls to RCI subprograms on which pragma
3778 -- All_Calls_Remote applies. The rewriting will be reanalyzed
3779 -- later. Do this only when the call comes from source since we
3780 -- do not want such a rewriting to occur in expanded code.
3782 if Is_All_Remote_Call (Call_Node) then
3783 Expand_All_Calls_Remote_Subprogram_Call (Call_Node);
3785 -- Similarly, do not add extra actuals for an entry call whose entity
3786 -- is a protected procedure, or for an internal protected subprogram
3787 -- call, because it will be rewritten as a protected subprogram call
3788 -- and reanalyzed (see Expand_Protected_Subprogram_Call).
3790 elsif Is_Protected_Type (Scope (Subp))
3791 and then (Ekind (Subp) = E_Procedure
3792 or else Ekind (Subp) = E_Function)
3796 -- During that loop we gathered the extra actuals (the ones that
3797 -- correspond to Extra_Formals), so now they can be appended.
3800 while Is_Non_Empty_List (Extra_Actuals) loop
3801 Add_Actual_Parameter (Remove_Head (Extra_Actuals));
3805 -- At this point we have all the actuals, so this is the point at which
3806 -- the various expansion activities for actuals is carried out.
3808 Expand_Actuals (Call_Node, Subp, Post_Call);
3810 -- Verify that the actuals do not share storage. This check must be done
3811 -- on the caller side rather that inside the subprogram to avoid issues
3812 -- of parameter passing.
3814 if Check_Aliasing_Of_Parameters then
3815 Apply_Parameter_Aliasing_Checks (Call_Node, Subp);
3818 -- If the subprogram is a renaming, or if it is inherited, replace it in
3819 -- the call with the name of the actual subprogram being called. If this
3820 -- is a dispatching call, the run-time decides what to call. The Alias
3821 -- attribute does not apply to entries.
3823 if Nkind (Call_Node) /= N_Entry_Call_Statement
3824 and then No (Controlling_Argument (Call_Node))
3825 and then Present (Parent_Subp)
3826 and then not Is_Direct_Deep_Call (Subp)
3828 if Present (Inherited_From_Formal (Subp)) then
3829 Parent_Subp := Inherited_From_Formal (Subp);
3831 Parent_Subp := Ultimate_Alias (Parent_Subp);
3834 -- The below setting of Entity is suspect, see F109-018 discussion???
3836 Set_Entity (Name (Call_Node), Parent_Subp);
3838 if Is_Abstract_Subprogram (Parent_Subp)
3839 and then not In_Instance
3842 ("cannot call abstract subprogram &!",
3843 Name (Call_Node), Parent_Subp);
3846 -- Inspect all formals of derived subprogram Subp. Compare parameter
3847 -- types with the parent subprogram and check whether an actual may
3848 -- need a type conversion to the corresponding formal of the parent
3851 -- Not clear whether intrinsic subprograms need such conversions. ???
3853 if not Is_Intrinsic_Subprogram (Parent_Subp)
3854 or else Is_Generic_Instance (Parent_Subp)
3857 procedure Convert (Act : Node_Id; Typ : Entity_Id);
3858 -- Rewrite node Act as a type conversion of Act to Typ. Analyze
3859 -- and resolve the newly generated construct.
3865 procedure Convert (Act : Node_Id; Typ : Entity_Id) is
3867 Rewrite (Act, OK_Convert_To (Typ, Relocate_Node (Act)));
3874 Actual_Typ : Entity_Id;
3875 Formal_Typ : Entity_Id;
3876 Parent_Typ : Entity_Id;
3879 Actual := First_Actual (Call_Node);
3880 Formal := First_Formal (Subp);
3881 Parent_Formal := First_Formal (Parent_Subp);
3882 while Present (Formal) loop
3883 Actual_Typ := Etype (Actual);
3884 Formal_Typ := Etype (Formal);
3885 Parent_Typ := Etype (Parent_Formal);
3887 -- For an IN parameter of a scalar type, the parent formal
3888 -- type and derived formal type differ or the parent formal
3889 -- type and actual type do not match statically.
3891 if Is_Scalar_Type (Formal_Typ)
3892 and then Ekind (Formal) = E_In_Parameter
3893 and then Formal_Typ /= Parent_Typ
3895 not Subtypes_Statically_Match (Parent_Typ, Actual_Typ)
3896 and then not Raises_Constraint_Error (Actual)
3898 Convert (Actual, Parent_Typ);
3899 Enable_Range_Check (Actual);
3901 -- If the actual has been marked as requiring a range
3902 -- check, then generate it here.
3904 if Do_Range_Check (Actual) then
3905 Generate_Range_Check
3906 (Actual, Etype (Formal), CE_Range_Check_Failed);
3909 -- For access types, the parent formal type and actual type
3912 elsif Is_Access_Type (Formal_Typ)
3913 and then Base_Type (Parent_Typ) /= Base_Type (Actual_Typ)
3915 if Ekind (Formal) /= E_In_Parameter then
3916 Convert (Actual, Parent_Typ);
3918 elsif Ekind (Parent_Typ) = E_Anonymous_Access_Type
3919 and then Designated_Type (Parent_Typ) /=
3920 Designated_Type (Actual_Typ)
3921 and then not Is_Controlling_Formal (Formal)
3923 -- This unchecked conversion is not necessary unless
3924 -- inlining is enabled, because in that case the type
3925 -- mismatch may become visible in the body about to be
3929 Unchecked_Convert_To (Parent_Typ,
3930 Relocate_Node (Actual)));
3932 Resolve (Actual, Parent_Typ);
3935 -- If there is a change of representation, then generate a
3936 -- warning, and do the change of representation.
3938 elsif not Same_Representation (Formal_Typ, Parent_Typ) then
3940 ("??change of representation required", Actual);
3941 Convert (Actual, Parent_Typ);
3943 -- For array and record types, the parent formal type and
3944 -- derived formal type have different sizes or pragma Pack
3947 elsif ((Is_Array_Type (Formal_Typ)
3948 and then Is_Array_Type (Parent_Typ))
3950 (Is_Record_Type (Formal_Typ)
3951 and then Is_Record_Type (Parent_Typ)))
3953 (Esize (Formal_Typ) /= Esize (Parent_Typ)
3954 or else Has_Pragma_Pack (Formal_Typ) /=
3955 Has_Pragma_Pack (Parent_Typ))
3957 Convert (Actual, Parent_Typ);
3960 Next_Actual (Actual);
3961 Next_Formal (Formal);
3962 Next_Formal (Parent_Formal);
3968 Subp := Parent_Subp;
3971 -- Deal with case where call is an explicit dereference
3973 if Nkind (Name (Call_Node)) = N_Explicit_Dereference then
3975 -- Handle case of access to protected subprogram type
3977 if Is_Access_Protected_Subprogram_Type
3978 (Base_Type (Etype (Prefix (Name (Call_Node)))))
3980 -- If this is a call through an access to protected operation, the
3981 -- prefix has the form (object'address, operation'access). Rewrite
3982 -- as a for other protected calls: the object is the 1st parameter
3983 -- of the list of actuals.
3990 Ptr : constant Node_Id := Prefix (Name (Call_Node));
3992 T : constant Entity_Id :=
3993 Equivalent_Type (Base_Type (Etype (Ptr)));
3995 D_T : constant Entity_Id :=
3996 Designated_Type (Base_Type (Etype (Ptr)));
4000 Make_Selected_Component (Loc,
4001 Prefix => Unchecked_Convert_To (T, Ptr),
4003 New_Occurrence_Of (First_Entity (T), Loc));
4006 Make_Selected_Component (Loc,
4007 Prefix => Unchecked_Convert_To (T, Ptr),
4009 New_Occurrence_Of (Next_Entity (First_Entity (T)), Loc));
4012 Make_Explicit_Dereference (Loc,
4015 if Present (Parameter_Associations (Call_Node)) then
4016 Parm := Parameter_Associations (Call_Node);
4021 Prepend (Obj, Parm);
4023 if Etype (D_T) = Standard_Void_Type then
4025 Make_Procedure_Call_Statement (Loc,
4027 Parameter_Associations => Parm);
4030 Make_Function_Call (Loc,
4032 Parameter_Associations => Parm);
4035 Set_First_Named_Actual (Call, First_Named_Actual (Call_Node));
4036 Set_Etype (Call, Etype (D_T));
4038 -- We do not re-analyze the call to avoid infinite recursion.
4039 -- We analyze separately the prefix and the object, and set
4040 -- the checks on the prefix that would otherwise be emitted
4041 -- when resolving a call.
4043 Rewrite (Call_Node, Call);
4045 Apply_Access_Check (Nam);
4052 -- If this is a call to an intrinsic subprogram, then perform the
4053 -- appropriate expansion to the corresponding tree node and we
4054 -- are all done (since after that the call is gone).
4056 -- In the case where the intrinsic is to be processed by the back end,
4057 -- the call to Expand_Intrinsic_Call will do nothing, which is fine,
4058 -- since the idea in this case is to pass the call unchanged. If the
4059 -- intrinsic is an inherited unchecked conversion, and the derived type
4060 -- is the target type of the conversion, we must retain it as the return
4061 -- type of the expression. Otherwise the expansion below, which uses the
4062 -- parent operation, will yield the wrong type.
4064 if Is_Intrinsic_Subprogram (Subp) then
4065 Expand_Intrinsic_Call (Call_Node, Subp);
4067 if Nkind (Call_Node) = N_Unchecked_Type_Conversion
4068 and then Parent_Subp /= Orig_Subp
4069 and then Etype (Parent_Subp) /= Etype (Orig_Subp)
4071 Set_Etype (Call_Node, Etype (Orig_Subp));
4077 if Ekind_In (Subp, E_Function, E_Procedure) then
4079 -- We perform a simple optimization on calls for To_Address by
4080 -- replacing them with an unchecked conversion. Not only is this
4081 -- efficient, but it also avoids order of elaboration problems when
4082 -- address clauses are inlined (address expression elaborated at the
4085 -- We perform this optimization regardless of whether we are in the
4086 -- main unit or in a unit in the context of the main unit, to ensure
4087 -- that the generated tree is the same in both cases, for CodePeer
4090 if Is_RTE (Subp, RE_To_Address) then
4092 Unchecked_Convert_To
4093 (RTE (RE_Address), Relocate_Node (First_Actual (Call_Node))));
4096 -- A call to a null procedure is replaced by a null statement, but we
4097 -- are not allowed to ignore possible side effects of the call, so we
4098 -- make sure that actuals are evaluated.
4099 -- We also suppress this optimization for GNATCoverage.
4101 elsif Is_Null_Procedure (Subp)
4102 and then not Opt.Suppress_Control_Flow_Optimizations
4104 Actual := First_Actual (Call_Node);
4105 while Present (Actual) loop
4106 Remove_Side_Effects (Actual);
4107 Next_Actual (Actual);
4110 Rewrite (Call_Node, Make_Null_Statement (Loc));
4114 -- Handle inlining. No action needed if the subprogram is not inlined
4116 if not Is_Inlined (Subp) then
4119 -- Frontend inlining of expression functions (performed also when
4120 -- backend inlining is enabled).
4122 elsif Is_Inlinable_Expression_Function (Subp) then
4123 Rewrite (N, New_Copy (Expression_Of_Expression_Function (Subp)));
4127 -- Handle frontend inlining
4129 elsif not Back_End_Inlining then
4130 Inlined_Subprogram : declare
4132 Must_Inline : Boolean := False;
4133 Spec : constant Node_Id := Unit_Declaration_Node (Subp);
4136 -- Verify that the body to inline has already been seen, and
4137 -- that if the body is in the current unit the inlining does
4138 -- not occur earlier. This avoids order-of-elaboration problems
4141 -- This should be documented in sinfo/einfo ???
4144 or else Nkind (Spec) /= N_Subprogram_Declaration
4145 or else No (Body_To_Inline (Spec))
4147 Must_Inline := False;
4149 -- If this an inherited function that returns a private type,
4150 -- do not inline if the full view is an unconstrained array,
4151 -- because such calls cannot be inlined.
4153 elsif Present (Orig_Subp)
4154 and then Is_Array_Type (Etype (Orig_Subp))
4155 and then not Is_Constrained (Etype (Orig_Subp))
4157 Must_Inline := False;
4159 elsif In_Unfrozen_Instance (Scope (Subp)) then
4160 Must_Inline := False;
4163 Bod := Body_To_Inline (Spec);
4165 if (In_Extended_Main_Code_Unit (Call_Node)
4166 or else In_Extended_Main_Code_Unit (Parent (Call_Node))
4167 or else Has_Pragma_Inline_Always (Subp))
4168 and then (not In_Same_Extended_Unit (Sloc (Bod), Loc)
4170 Earlier_In_Extended_Unit (Sloc (Bod), Loc))
4172 Must_Inline := True;
4174 -- If we are compiling a package body that is not the main
4175 -- unit, it must be for inlining/instantiation purposes,
4176 -- in which case we inline the call to insure that the same
4177 -- temporaries are generated when compiling the body by
4178 -- itself. Otherwise link errors can occur.
4180 -- If the function being called is itself in the main unit,
4181 -- we cannot inline, because there is a risk of double
4182 -- elaboration and/or circularity: the inlining can make
4183 -- visible a private entity in the body of the main unit,
4184 -- that gigi will see before its sees its proper definition.
4186 elsif not (In_Extended_Main_Code_Unit (Call_Node))
4187 and then In_Package_Body
4189 Must_Inline := not In_Extended_Main_Source_Unit (Subp);
4191 -- Inline calls to _postconditions when generating C code
4193 elsif Modify_Tree_For_C
4194 and then In_Same_Extended_Unit (Sloc (Bod), Loc)
4195 and then Chars (Name (N)) = Name_uPostconditions
4197 Must_Inline := True;
4202 Expand_Inlined_Call (Call_Node, Subp, Orig_Subp);
4205 -- Let the back end handle it
4207 Add_Inlined_Body (Subp, Call_Node);
4209 if Front_End_Inlining
4210 and then Nkind (Spec) = N_Subprogram_Declaration
4211 and then (In_Extended_Main_Code_Unit (Call_Node))
4212 and then No (Body_To_Inline (Spec))
4213 and then not Has_Completion (Subp)
4214 and then In_Same_Extended_Unit (Sloc (Spec), Loc)
4217 ("cannot inline& (body not seen yet)?",
4221 end Inlined_Subprogram;
4223 -- Back end inlining: let the back end handle it
4225 elsif No (Unit_Declaration_Node (Subp))
4226 or else Nkind (Unit_Declaration_Node (Subp)) /=
4227 N_Subprogram_Declaration
4228 or else No (Body_To_Inline (Unit_Declaration_Node (Subp)))
4229 or else Nkind (Body_To_Inline (Unit_Declaration_Node (Subp))) in
4232 Add_Inlined_Body (Subp, Call_Node);
4234 -- If the inlined call appears within an instantiation and some
4235 -- level of optimization is required, ensure that the enclosing
4236 -- instance body is available so that the back-end can actually
4237 -- perform the inlining.
4240 and then Comes_From_Source (Subp)
4241 and then Optimization_Level > 0
4246 Inst_Node : Node_Id;
4249 Inst := Scope (Subp);
4251 -- Find enclosing instance
4253 while Present (Inst) and then Inst /= Standard_Standard loop
4254 exit when Is_Generic_Instance (Inst);
4255 Inst := Scope (Inst);
4259 and then Is_Generic_Instance (Inst)
4260 and then not Is_Inlined (Inst)
4262 Set_Is_Inlined (Inst);
4263 Decl := Unit_Declaration_Node (Inst);
4265 -- Do not add a pending instantiation if the body exits
4266 -- already, or if the instance is a compilation unit, or
4267 -- the instance node is missing.
4269 if Present (Corresponding_Body (Decl))
4270 or else Nkind (Parent (Decl)) = N_Compilation_Unit
4271 or else No (Next (Decl))
4276 -- The instantiation node usually follows the package
4277 -- declaration for the instance. If the generic unit
4278 -- has aspect specifications, they are transformed
4279 -- into pragmas in the instance, and the instance node
4280 -- appears after them.
4282 Inst_Node := Next (Decl);
4284 while Nkind (Inst_Node) /= N_Package_Instantiation loop
4285 Inst_Node := Next (Inst_Node);
4288 Add_Pending_Instantiation (Inst_Node, Decl);
4294 -- Front end expansion of simple functions returning unconstrained
4295 -- types (see Check_And_Split_Unconstrained_Function). Note that the
4296 -- case of a simple renaming (Body_To_Inline in N_Entity above, see
4297 -- also Build_Renamed_Body) cannot be expanded here because this may
4298 -- give rise to order-of-elaboration issues for the types of the
4299 -- parameters of the subprogram, if any.
4302 Expand_Inlined_Call (Call_Node, Subp, Orig_Subp);
4306 -- Check for protected subprogram. This is either an intra-object call,
4307 -- or a protected function call. Protected procedure calls are rewritten
4308 -- as entry calls and handled accordingly.
4310 -- In Ada 2005, this may be an indirect call to an access parameter that
4311 -- is an access_to_subprogram. In that case the anonymous type has a
4312 -- scope that is a protected operation, but the call is a regular one.
4313 -- In either case do not expand call if subprogram is eliminated.
4315 Scop := Scope (Subp);
4317 if Nkind (Call_Node) /= N_Entry_Call_Statement
4318 and then Is_Protected_Type (Scop)
4319 and then Ekind (Subp) /= E_Subprogram_Type
4320 and then not Is_Eliminated (Subp)
4322 -- If the call is an internal one, it is rewritten as a call to the
4323 -- corresponding unprotected subprogram.
4325 Expand_Protected_Subprogram_Call (Call_Node, Subp, Scop);
4328 -- Functions returning controlled objects need special attention. If
4329 -- the return type is limited, then the context is initialization and
4330 -- different processing applies. If the call is to a protected function,
4331 -- the expansion above will call Expand_Call recursively. Otherwise the
4332 -- function call is transformed into a temporary which obtains the
4333 -- result from the secondary stack.
4335 if Needs_Finalization (Etype (Subp)) then
4336 if not Is_Build_In_Place_Function_Call (Call_Node)
4338 (No (First_Formal (Subp))
4340 not Is_Concurrent_Record_Type (Etype (First_Formal (Subp))))
4342 Expand_Ctrl_Function_Call (Call_Node);
4344 -- Build-in-place function calls which appear in anonymous contexts
4345 -- need a transient scope to ensure the proper finalization of the
4346 -- intermediate result after its use.
4348 elsif Is_Build_In_Place_Function_Call (Call_Node)
4349 and then Nkind_In (Parent (Unqual_Conv (Call_Node)),
4350 N_Attribute_Reference,
4352 N_Indexed_Component,
4353 N_Object_Renaming_Declaration,
4354 N_Procedure_Call_Statement,
4355 N_Selected_Component,
4358 (Ekind (Current_Scope) /= E_Loop
4359 or else Nkind (Parent (N)) /= N_Function_Call
4360 or else not Is_Build_In_Place_Function_Call (Parent (N)))
4362 Establish_Transient_Scope (Call_Node, Sec_Stack => True);
4365 end Expand_Call_Helper;
4367 -------------------------------
4368 -- Expand_Ctrl_Function_Call --
4369 -------------------------------
4371 procedure Expand_Ctrl_Function_Call (N : Node_Id) is
4372 function Is_Element_Reference (N : Node_Id) return Boolean;
4373 -- Determine whether node N denotes a reference to an Ada 2012 container
4376 --------------------------
4377 -- Is_Element_Reference --
4378 --------------------------
4380 function Is_Element_Reference (N : Node_Id) return Boolean is
4381 Ref : constant Node_Id := Original_Node (N);
4384 -- Analysis marks an element reference by setting the generalized
4385 -- indexing attribute of an indexed component before the component
4386 -- is rewritten into a function call.
4389 Nkind (Ref) = N_Indexed_Component
4390 and then Present (Generalized_Indexing (Ref));
4391 end Is_Element_Reference;
4393 -- Start of processing for Expand_Ctrl_Function_Call
4396 -- Optimization, if the returned value (which is on the sec-stack) is
4397 -- returned again, no need to copy/readjust/finalize, we can just pass
4398 -- the value thru (see Expand_N_Simple_Return_Statement), and thus no
4399 -- attachment is needed
4401 if Nkind (Parent (N)) = N_Simple_Return_Statement then
4405 -- Resolution is now finished, make sure we don't start analysis again
4406 -- because of the duplication.
4410 -- A function which returns a controlled object uses the secondary
4411 -- stack. Rewrite the call into a temporary which obtains the result of
4412 -- the function using 'reference.
4414 Remove_Side_Effects (N);
4416 -- The side effect removal of the function call produced a temporary.
4417 -- When the context is a case expression, if expression, or expression
4418 -- with actions, the lifetime of the temporary must be extended to match
4419 -- that of the context. Otherwise the function result will be finalized
4420 -- too early and affect the result of the expression. To prevent this
4421 -- unwanted effect, the temporary should not be considered for clean up
4422 -- actions by the general finalization machinery.
4424 -- Exception to this rule are references to Ada 2012 container elements.
4425 -- Such references must be finalized at the end of each iteration of the
4426 -- related quantified expression, otherwise the container will remain
4429 if Nkind (N) = N_Explicit_Dereference
4430 and then Within_Case_Or_If_Expression (N)
4431 and then not Is_Element_Reference (N)
4433 Set_Is_Ignored_Transient (Entity (Prefix (N)));
4435 end Expand_Ctrl_Function_Call;
4437 ----------------------------------------
4438 -- Expand_N_Extended_Return_Statement --
4439 ----------------------------------------
4441 -- If there is a Handled_Statement_Sequence, we rewrite this:
4443 -- return Result : T := <expression> do
4444 -- <handled_seq_of_stms>
4450 -- Result : T := <expression>;
4452 -- <handled_seq_of_stms>
4456 -- Otherwise (no Handled_Statement_Sequence), we rewrite this:
4458 -- return Result : T := <expression>;
4462 -- return <expression>;
4464 -- unless it's build-in-place or there's no <expression>, in which case
4468 -- Result : T := <expression>;
4473 -- Note that this case could have been written by the user as an extended
4474 -- return statement, or could have been transformed to this from a simple
4475 -- return statement.
4477 -- That is, we need to have a reified return object if there are statements
4478 -- (which might refer to it) or if we're doing build-in-place (so we can
4479 -- set its address to the final resting place or if there is no expression
4480 -- (in which case default initial values might need to be set).
4482 procedure Expand_N_Extended_Return_Statement (N : Node_Id) is
4483 Loc : constant Source_Ptr := Sloc (N);
4485 function Build_Heap_Allocator
4486 (Temp_Id : Entity_Id;
4487 Temp_Typ : Entity_Id;
4488 Func_Id : Entity_Id;
4489 Ret_Typ : Entity_Id;
4490 Alloc_Expr : Node_Id) return Node_Id;
4491 -- Create the statements necessary to allocate a return object on the
4492 -- caller's master. The master is available through implicit parameter
4493 -- BIPfinalizationmaster.
4495 -- if BIPfinalizationmaster /= null then
4497 -- type Ptr_Typ is access Ret_Typ;
4498 -- for Ptr_Typ'Storage_Pool use
4499 -- Base_Pool (BIPfinalizationmaster.all).all;
4503 -- procedure Allocate (...) is
4505 -- System.Storage_Pools.Subpools.Allocate_Any (...);
4508 -- Local := <Alloc_Expr>;
4509 -- Temp_Id := Temp_Typ (Local);
4513 -- Temp_Id is the temporary which is used to reference the internally
4514 -- created object in all allocation forms. Temp_Typ is the type of the
4515 -- temporary. Func_Id is the enclosing function. Ret_Typ is the return
4516 -- type of Func_Id. Alloc_Expr is the actual allocator.
4518 function Move_Activation_Chain (Func_Id : Entity_Id) return Node_Id;
4519 -- Construct a call to System.Tasking.Stages.Move_Activation_Chain
4521 -- From current activation chain
4522 -- To activation chain passed in by the caller
4523 -- New_Master master passed in by the caller
4525 -- Func_Id is the entity of the function where the extended return
4526 -- statement appears.
4528 --------------------------
4529 -- Build_Heap_Allocator --
4530 --------------------------
4532 function Build_Heap_Allocator
4533 (Temp_Id : Entity_Id;
4534 Temp_Typ : Entity_Id;
4535 Func_Id : Entity_Id;
4536 Ret_Typ : Entity_Id;
4537 Alloc_Expr : Node_Id) return Node_Id
4540 pragma Assert (Is_Build_In_Place_Function (Func_Id));
4542 -- Processing for build-in-place object allocation.
4544 if Needs_Finalization (Ret_Typ) then
4546 Decls : constant List_Id := New_List;
4547 Fin_Mas_Id : constant Entity_Id :=
4548 Build_In_Place_Formal
4549 (Func_Id, BIP_Finalization_Master);
4550 Stmts : constant List_Id := New_List;
4551 Desig_Typ : Entity_Id;
4552 Local_Id : Entity_Id;
4553 Pool_Id : Entity_Id;
4554 Ptr_Typ : Entity_Id;
4558 -- Pool_Id renames Base_Pool (BIPfinalizationmaster.all).all;
4560 Pool_Id := Make_Temporary (Loc, 'P');
4563 Make_Object_Renaming_Declaration (Loc,
4564 Defining_Identifier => Pool_Id,
4566 New_Occurrence_Of (RTE (RE_Root_Storage_Pool), Loc),
4568 Make_Explicit_Dereference (Loc,
4570 Make_Function_Call (Loc,
4572 New_Occurrence_Of (RTE (RE_Base_Pool), Loc),
4573 Parameter_Associations => New_List (
4574 Make_Explicit_Dereference (Loc,
4576 New_Occurrence_Of (Fin_Mas_Id, Loc)))))));
4578 -- Create an access type which uses the storage pool of the
4579 -- caller's master. This additional type is necessary because
4580 -- the finalization master cannot be associated with the type
4581 -- of the temporary. Otherwise the secondary stack allocation
4584 Desig_Typ := Ret_Typ;
4586 -- Ensure that the build-in-place machinery uses a fat pointer
4587 -- when allocating an unconstrained array on the heap. In this
4588 -- case the result object type is a constrained array type even
4589 -- though the function type is unconstrained.
4591 if Ekind (Desig_Typ) = E_Array_Subtype then
4592 Desig_Typ := Base_Type (Desig_Typ);
4596 -- type Ptr_Typ is access Desig_Typ;
4598 Ptr_Typ := Make_Temporary (Loc, 'P');
4601 Make_Full_Type_Declaration (Loc,
4602 Defining_Identifier => Ptr_Typ,
4604 Make_Access_To_Object_Definition (Loc,
4605 Subtype_Indication =>
4606 New_Occurrence_Of (Desig_Typ, Loc))));
4608 -- Perform minor decoration in order to set the master and the
4609 -- storage pool attributes.
4611 Set_Ekind (Ptr_Typ, E_Access_Type);
4612 Set_Finalization_Master (Ptr_Typ, Fin_Mas_Id);
4613 Set_Associated_Storage_Pool (Ptr_Typ, Pool_Id);
4615 -- Create the temporary, generate:
4616 -- Local_Id : Ptr_Typ;
4618 Local_Id := Make_Temporary (Loc, 'T');
4621 Make_Object_Declaration (Loc,
4622 Defining_Identifier => Local_Id,
4623 Object_Definition =>
4624 New_Occurrence_Of (Ptr_Typ, Loc)));
4626 -- Allocate the object, generate:
4627 -- Local_Id := <Alloc_Expr>;
4630 Make_Assignment_Statement (Loc,
4631 Name => New_Occurrence_Of (Local_Id, Loc),
4632 Expression => Alloc_Expr));
4635 -- Temp_Id := Temp_Typ (Local_Id);
4638 Make_Assignment_Statement (Loc,
4639 Name => New_Occurrence_Of (Temp_Id, Loc),
4641 Unchecked_Convert_To (Temp_Typ,
4642 New_Occurrence_Of (Local_Id, Loc))));
4644 -- Wrap the allocation in a block. This is further conditioned
4645 -- by checking the caller finalization master at runtime. A
4646 -- null value indicates a non-existent master, most likely due
4647 -- to a Finalize_Storage_Only allocation.
4650 -- if BIPfinalizationmaster /= null then
4659 Make_If_Statement (Loc,
4662 Left_Opnd => New_Occurrence_Of (Fin_Mas_Id, Loc),
4663 Right_Opnd => Make_Null (Loc)),
4665 Then_Statements => New_List (
4666 Make_Block_Statement (Loc,
4667 Declarations => Decls,
4668 Handled_Statement_Sequence =>
4669 Make_Handled_Sequence_Of_Statements (Loc,
4670 Statements => Stmts))));
4673 -- For all other cases, generate:
4674 -- Temp_Id := <Alloc_Expr>;
4678 Make_Assignment_Statement (Loc,
4679 Name => New_Occurrence_Of (Temp_Id, Loc),
4680 Expression => Alloc_Expr);
4682 end Build_Heap_Allocator;
4684 ---------------------------
4685 -- Move_Activation_Chain --
4686 ---------------------------
4688 function Move_Activation_Chain (Func_Id : Entity_Id) return Node_Id is
4691 Make_Procedure_Call_Statement (Loc,
4693 New_Occurrence_Of (RTE (RE_Move_Activation_Chain), Loc),
4695 Parameter_Associations => New_List (
4699 Make_Attribute_Reference (Loc,
4700 Prefix => Make_Identifier (Loc, Name_uChain),
4701 Attribute_Name => Name_Unrestricted_Access),
4703 -- Destination chain
4706 (Build_In_Place_Formal (Func_Id, BIP_Activation_Chain), Loc),
4711 (Build_In_Place_Formal (Func_Id, BIP_Task_Master), Loc)));
4712 end Move_Activation_Chain;
4716 Func_Id : constant Entity_Id :=
4717 Return_Applies_To (Return_Statement_Entity (N));
4718 Is_BIP_Func : constant Boolean :=
4719 Is_Build_In_Place_Function (Func_Id);
4720 Ret_Obj_Id : constant Entity_Id :=
4721 First_Entity (Return_Statement_Entity (N));
4722 Ret_Obj_Decl : constant Node_Id := Parent (Ret_Obj_Id);
4723 Ret_Typ : constant Entity_Id := Etype (Func_Id);
4730 Return_Stmt : Node_Id := Empty;
4731 -- Force initialization to facilitate static analysis
4733 -- Start of processing for Expand_N_Extended_Return_Statement
4736 -- Given that functionality of interface thunks is simple (just displace
4737 -- the pointer to the object) they are always handled by means of
4738 -- simple return statements.
4740 pragma Assert (not Is_Thunk (Current_Scope));
4742 if Nkind (Ret_Obj_Decl) = N_Object_Declaration then
4743 Exp := Expression (Ret_Obj_Decl);
4748 HSS := Handled_Statement_Sequence (N);
4750 -- If the returned object needs finalization actions, the function must
4751 -- perform the appropriate cleanup should it fail to return. The state
4752 -- of the function itself is tracked through a flag which is coupled
4753 -- with the scope finalizer. There is one flag per each return object
4754 -- in case of multiple returns.
4756 if Is_BIP_Func and then Needs_Finalization (Etype (Ret_Obj_Id)) then
4758 Flag_Decl : Node_Id;
4759 Flag_Id : Entity_Id;
4763 -- Recover the function body
4765 Func_Bod := Unit_Declaration_Node (Func_Id);
4767 if Nkind (Func_Bod) = N_Subprogram_Declaration then
4768 Func_Bod := Parent (Parent (Corresponding_Body (Func_Bod)));
4771 if Nkind (Func_Bod) = N_Function_Specification then
4772 Func_Bod := Parent (Func_Bod); -- one more level for child units
4775 pragma Assert (Nkind (Func_Bod) = N_Subprogram_Body);
4777 -- Create a flag to track the function state
4779 Flag_Id := Make_Temporary (Loc, 'F');
4780 Set_Status_Flag_Or_Transient_Decl (Ret_Obj_Id, Flag_Id);
4782 -- Insert the flag at the beginning of the function declarations,
4784 -- Fnn : Boolean := False;
4787 Make_Object_Declaration (Loc,
4788 Defining_Identifier => Flag_Id,
4789 Object_Definition =>
4790 New_Occurrence_Of (Standard_Boolean, Loc),
4792 New_Occurrence_Of (Standard_False, Loc));
4794 Prepend_To (Declarations (Func_Bod), Flag_Decl);
4795 Analyze (Flag_Decl);
4799 -- Build a simple_return_statement that returns the return object when
4800 -- there is a statement sequence, or no expression, or the result will
4801 -- be built in place. Note however that we currently do this for all
4802 -- composite cases, even though not all are built in place.
4805 or else Is_Composite_Type (Ret_Typ)
4811 -- If the extended return has a handled statement sequence, then wrap
4812 -- it in a block and use the block as the first statement.
4816 Make_Block_Statement (Loc,
4817 Declarations => New_List,
4818 Handled_Statement_Sequence => HSS));
4821 -- If the result type contains tasks, we call Move_Activation_Chain.
4822 -- Later, the cleanup code will call Complete_Master, which will
4823 -- terminate any unactivated tasks belonging to the return statement
4824 -- master. But Move_Activation_Chain updates their master to be that
4825 -- of the caller, so they will not be terminated unless the return
4826 -- statement completes unsuccessfully due to exception, abort, goto,
4827 -- or exit. As a formality, we test whether the function requires the
4828 -- result to be built in place, though that's necessarily true for
4829 -- the case of result types with task parts.
4831 if Is_BIP_Func and then Has_Task (Ret_Typ) then
4833 -- The return expression is an aggregate for a complex type which
4834 -- contains tasks. This particular case is left unexpanded since
4835 -- the regular expansion would insert all temporaries and
4836 -- initialization code in the wrong block.
4838 if Nkind (Exp) = N_Aggregate then
4839 Expand_N_Aggregate (Exp);
4842 -- Do not move the activation chain if the return object does not
4845 if Has_Task (Etype (Ret_Obj_Id)) then
4846 Append_To (Stmts, Move_Activation_Chain (Func_Id));
4850 -- Update the state of the function right before the object is
4853 if Is_BIP_Func and then Needs_Finalization (Etype (Ret_Obj_Id)) then
4855 Flag_Id : constant Entity_Id :=
4856 Status_Flag_Or_Transient_Decl (Ret_Obj_Id);
4863 Make_Assignment_Statement (Loc,
4864 Name => New_Occurrence_Of (Flag_Id, Loc),
4865 Expression => New_Occurrence_Of (Standard_True, Loc)));
4869 -- Build a simple_return_statement that returns the return object
4872 Make_Simple_Return_Statement (Loc,
4873 Expression => New_Occurrence_Of (Ret_Obj_Id, Loc));
4874 Append_To (Stmts, Return_Stmt);
4876 HSS := Make_Handled_Sequence_Of_Statements (Loc, Stmts);
4879 -- Case where we build a return statement block
4881 if Present (HSS) then
4883 Make_Block_Statement (Loc,
4884 Declarations => Return_Object_Declarations (N),
4885 Handled_Statement_Sequence => HSS);
4887 -- We set the entity of the new block statement to be that of the
4888 -- return statement. This is necessary so that various fields, such
4889 -- as Finalization_Chain_Entity carry over from the return statement
4890 -- to the block. Note that this block is unusual, in that its entity
4891 -- is an E_Return_Statement rather than an E_Block.
4894 (Result, New_Occurrence_Of (Return_Statement_Entity (N), Loc));
4896 -- If the object decl was already rewritten as a renaming, then we
4897 -- don't want to do the object allocation and transformation of
4898 -- the return object declaration to a renaming. This case occurs
4899 -- when the return object is initialized by a call to another
4900 -- build-in-place function, and that function is responsible for
4901 -- the allocation of the return object.
4904 and then Nkind (Ret_Obj_Decl) = N_Object_Renaming_Declaration
4907 (Nkind (Original_Node (Ret_Obj_Decl)) = N_Object_Declaration
4910 -- It is a regular BIP object declaration
4912 (Is_Build_In_Place_Function_Call
4913 (Expression (Original_Node (Ret_Obj_Decl)))
4915 -- It is a BIP object declaration that displaces the pointer
4916 -- to the object to reference a convered interface type.
4919 Present (Unqual_BIP_Iface_Function_Call
4920 (Expression (Original_Node (Ret_Obj_Decl))))));
4922 -- Return the build-in-place result by reference
4924 Set_By_Ref (Return_Stmt);
4926 elsif Is_BIP_Func then
4928 -- Locate the implicit access parameter associated with the
4929 -- caller-supplied return object and convert the return
4930 -- statement's return object declaration to a renaming of a
4931 -- dereference of the access parameter. If the return object's
4932 -- declaration includes an expression that has not already been
4933 -- expanded as separate assignments, then add an assignment
4934 -- statement to ensure the return object gets initialized.
4937 -- Result : T [:= <expression>];
4944 -- Result : T renames FuncRA.all;
4945 -- [Result := <expression;]
4950 Ret_Obj_Expr : constant Node_Id := Expression (Ret_Obj_Decl);
4951 Ret_Obj_Typ : constant Entity_Id := Etype (Ret_Obj_Id);
4953 Init_Assignment : Node_Id := Empty;
4954 Obj_Acc_Formal : Entity_Id;
4955 Obj_Acc_Deref : Node_Id;
4956 Obj_Alloc_Formal : Entity_Id;
4959 -- Build-in-place results must be returned by reference
4961 Set_By_Ref (Return_Stmt);
4963 -- Retrieve the implicit access parameter passed by the caller
4966 Build_In_Place_Formal (Func_Id, BIP_Object_Access);
4968 -- If the return object's declaration includes an expression
4969 -- and the declaration isn't marked as No_Initialization, then
4970 -- we need to generate an assignment to the object and insert
4971 -- it after the declaration before rewriting it as a renaming
4972 -- (otherwise we'll lose the initialization). The case where
4973 -- the result type is an interface (or class-wide interface)
4974 -- is also excluded because the context of the function call
4975 -- must be unconstrained, so the initialization will always
4976 -- be done as part of an allocator evaluation (storage pool
4977 -- or secondary stack), never to a constrained target object
4978 -- passed in by the caller. Besides the assignment being
4979 -- unneeded in this case, it avoids problems with trying to
4980 -- generate a dispatching assignment when the return expression
4981 -- is a nonlimited descendant of a limited interface (the
4982 -- interface has no assignment operation).
4984 if Present (Ret_Obj_Expr)
4985 and then not No_Initialization (Ret_Obj_Decl)
4986 and then not Is_Interface (Ret_Obj_Typ)
4989 Make_Assignment_Statement (Loc,
4990 Name => New_Occurrence_Of (Ret_Obj_Id, Loc),
4991 Expression => New_Copy_Tree (Ret_Obj_Expr));
4993 Set_Etype (Name (Init_Assignment), Etype (Ret_Obj_Id));
4994 Set_Assignment_OK (Name (Init_Assignment));
4995 Set_No_Ctrl_Actions (Init_Assignment);
4997 Set_Parent (Name (Init_Assignment), Init_Assignment);
4998 Set_Parent (Expression (Init_Assignment), Init_Assignment);
5000 Set_Expression (Ret_Obj_Decl, Empty);
5002 if Is_Class_Wide_Type (Etype (Ret_Obj_Id))
5003 and then not Is_Class_Wide_Type
5004 (Etype (Expression (Init_Assignment)))
5006 Rewrite (Expression (Init_Assignment),
5007 Make_Type_Conversion (Loc,
5009 New_Occurrence_Of (Etype (Ret_Obj_Id), Loc),
5011 Relocate_Node (Expression (Init_Assignment))));
5014 -- In the case of functions where the calling context can
5015 -- determine the form of allocation needed, initialization
5016 -- is done with each part of the if statement that handles
5017 -- the different forms of allocation (this is true for
5018 -- unconstrained and tagged result subtypes).
5020 if Is_Constrained (Ret_Typ)
5021 and then not Is_Tagged_Type (Underlying_Type (Ret_Typ))
5023 Insert_After (Ret_Obj_Decl, Init_Assignment);
5027 -- When the function's subtype is unconstrained, a run-time
5028 -- test is needed to determine the form of allocation to use
5029 -- for the return object. The function has an implicit formal
5030 -- parameter indicating this. If the BIP_Alloc_Form formal has
5031 -- the value one, then the caller has passed access to an
5032 -- existing object for use as the return object. If the value
5033 -- is two, then the return object must be allocated on the
5034 -- secondary stack. Otherwise, the object must be allocated in
5035 -- a storage pool. We generate an if statement to test the
5036 -- implicit allocation formal and initialize a local access
5037 -- value appropriately, creating allocators in the secondary
5038 -- stack and global heap cases. The special formal also exists
5039 -- and must be tested when the function has a tagged result,
5040 -- even when the result subtype is constrained, because in
5041 -- general such functions can be called in dispatching contexts
5042 -- and must be handled similarly to functions with a class-wide
5045 if not Is_Constrained (Ret_Typ)
5046 or else Is_Tagged_Type (Underlying_Type (Ret_Typ))
5049 Build_In_Place_Formal (Func_Id, BIP_Alloc_Form);
5052 Pool_Id : constant Entity_Id :=
5053 Make_Temporary (Loc, 'P');
5054 Alloc_Obj_Id : Entity_Id;
5055 Alloc_Obj_Decl : Node_Id;
5056 Alloc_If_Stmt : Node_Id;
5057 Heap_Allocator : Node_Id;
5058 Pool_Decl : Node_Id;
5059 Pool_Allocator : Node_Id;
5060 Ptr_Type_Decl : Node_Id;
5061 Ref_Type : Entity_Id;
5062 SS_Allocator : Node_Id;
5065 -- Reuse the itype created for the function's implicit
5066 -- access formal. This avoids the need to create a new
5067 -- access type here, plus it allows assigning the access
5068 -- formal directly without applying a conversion.
5070 -- Ref_Type := Etype (Object_Access);
5072 -- Create an access type designating the function's
5075 Ref_Type := Make_Temporary (Loc, 'A');
5078 Make_Full_Type_Declaration (Loc,
5079 Defining_Identifier => Ref_Type,
5081 Make_Access_To_Object_Definition (Loc,
5082 All_Present => True,
5083 Subtype_Indication =>
5084 New_Occurrence_Of (Ret_Obj_Typ, Loc)));
5086 Insert_Before (Ret_Obj_Decl, Ptr_Type_Decl);
5088 -- Create an access object that will be initialized to an
5089 -- access value denoting the return object, either coming
5090 -- from an implicit access value passed in by the caller
5091 -- or from the result of an allocator.
5093 Alloc_Obj_Id := Make_Temporary (Loc, 'R');
5094 Set_Etype (Alloc_Obj_Id, Ref_Type);
5097 Make_Object_Declaration (Loc,
5098 Defining_Identifier => Alloc_Obj_Id,
5099 Object_Definition =>
5100 New_Occurrence_Of (Ref_Type, Loc));
5102 Insert_Before (Ret_Obj_Decl, Alloc_Obj_Decl);
5104 -- Create allocators for both the secondary stack and
5105 -- global heap. If there's an initialization expression,
5106 -- then create these as initialized allocators.
5108 if Present (Ret_Obj_Expr)
5109 and then not No_Initialization (Ret_Obj_Decl)
5111 -- Always use the type of the expression for the
5112 -- qualified expression, rather than the result type.
5113 -- In general we cannot always use the result type
5114 -- for the allocator, because the expression might be
5115 -- of a specific type, such as in the case of an
5116 -- aggregate or even a nonlimited object when the
5117 -- result type is a limited class-wide interface type.
5120 Make_Allocator (Loc,
5122 Make_Qualified_Expression (Loc,
5125 (Etype (Ret_Obj_Expr), Loc),
5126 Expression => New_Copy_Tree (Ret_Obj_Expr)));
5129 -- If the function returns a class-wide type we cannot
5130 -- use the return type for the allocator. Instead we
5131 -- use the type of the expression, which must be an
5132 -- aggregate of a definite type.
5134 if Is_Class_Wide_Type (Ret_Obj_Typ) then
5136 Make_Allocator (Loc,
5139 (Etype (Ret_Obj_Expr), Loc));
5142 Make_Allocator (Loc,
5144 New_Occurrence_Of (Ret_Obj_Typ, Loc));
5147 -- If the object requires default initialization then
5148 -- that will happen later following the elaboration of
5149 -- the object renaming. If we don't turn it off here
5150 -- then the object will be default initialized twice.
5152 Set_No_Initialization (Heap_Allocator);
5155 -- Set the flag indicating that the allocator came from
5156 -- a build-in-place return statement, so we can avoid
5157 -- adjusting the allocated object. Note that this flag
5158 -- will be inherited by the copies made below.
5160 Set_Alloc_For_BIP_Return (Heap_Allocator);
5162 -- The Pool_Allocator is just like the Heap_Allocator,
5163 -- except we set Storage_Pool and Procedure_To_Call so
5164 -- it will use the user-defined storage pool.
5166 Pool_Allocator := New_Copy_Tree (Heap_Allocator);
5167 pragma Assert (Alloc_For_BIP_Return (Pool_Allocator));
5169 -- Do not generate the renaming of the build-in-place
5170 -- pool parameter on ZFP because the parameter is not
5171 -- created in the first place.
5173 if RTE_Available (RE_Root_Storage_Pool_Ptr) then
5175 Make_Object_Renaming_Declaration (Loc,
5176 Defining_Identifier => Pool_Id,
5179 (RTE (RE_Root_Storage_Pool), Loc),
5181 Make_Explicit_Dereference (Loc,
5183 (Build_In_Place_Formal
5184 (Func_Id, BIP_Storage_Pool), Loc)));
5185 Set_Storage_Pool (Pool_Allocator, Pool_Id);
5186 Set_Procedure_To_Call
5187 (Pool_Allocator, RTE (RE_Allocate_Any));
5189 Pool_Decl := Make_Null_Statement (Loc);
5192 -- If the No_Allocators restriction is active, then only
5193 -- an allocator for secondary stack allocation is needed.
5194 -- It's OK for such allocators to have Comes_From_Source
5195 -- set to False, because gigi knows not to flag them as
5196 -- being a violation of No_Implicit_Heap_Allocations.
5198 if Restriction_Active (No_Allocators) then
5199 SS_Allocator := Heap_Allocator;
5200 Heap_Allocator := Make_Null (Loc);
5201 Pool_Allocator := Make_Null (Loc);
5203 -- Otherwise the heap and pool allocators may be needed,
5204 -- so we make another allocator for secondary stack
5208 SS_Allocator := New_Copy_Tree (Heap_Allocator);
5209 pragma Assert (Alloc_For_BIP_Return (SS_Allocator));
5211 -- The heap and pool allocators are marked as
5212 -- Comes_From_Source since they correspond to an
5213 -- explicit user-written allocator (that is, it will
5214 -- only be executed on behalf of callers that call the
5215 -- function as initialization for such an allocator).
5216 -- Prevents errors when No_Implicit_Heap_Allocations
5219 Set_Comes_From_Source (Heap_Allocator, True);
5220 Set_Comes_From_Source (Pool_Allocator, True);
5223 -- The allocator is returned on the secondary stack.
5225 Set_Storage_Pool (SS_Allocator, RTE (RE_SS_Pool));
5226 Set_Procedure_To_Call
5227 (SS_Allocator, RTE (RE_SS_Allocate));
5229 -- The allocator is returned on the secondary stack,
5230 -- so indicate that the function return, as well as
5231 -- all blocks that encloses the allocator, must not
5232 -- release it. The flags must be set now because
5233 -- the decision to use the secondary stack is done
5234 -- very late in the course of expanding the return
5235 -- statement, past the point where these flags are
5238 Set_Uses_Sec_Stack (Func_Id);
5239 Set_Uses_Sec_Stack (Return_Statement_Entity (N));
5240 Set_Sec_Stack_Needed_For_Return
5241 (Return_Statement_Entity (N));
5242 Set_Enclosing_Sec_Stack_Return (N);
5244 -- Create an if statement to test the BIP_Alloc_Form
5245 -- formal and initialize the access object to either the
5246 -- BIP_Object_Access formal (BIP_Alloc_Form =
5247 -- Caller_Allocation), the result of allocating the
5248 -- object in the secondary stack (BIP_Alloc_Form =
5249 -- Secondary_Stack), or else an allocator to create the
5250 -- return object in the heap or user-defined pool
5251 -- (BIP_Alloc_Form = Global_Heap or User_Storage_Pool).
5253 -- ??? An unchecked type conversion must be made in the
5254 -- case of assigning the access object formal to the
5255 -- local access object, because a normal conversion would
5256 -- be illegal in some cases (such as converting access-
5257 -- to-unconstrained to access-to-constrained), but the
5258 -- the unchecked conversion will presumably fail to work
5259 -- right in just such cases. It's not clear at all how to
5263 Make_If_Statement (Loc,
5267 New_Occurrence_Of (Obj_Alloc_Formal, Loc),
5269 Make_Integer_Literal (Loc,
5270 UI_From_Int (BIP_Allocation_Form'Pos
5271 (Caller_Allocation)))),
5273 Then_Statements => New_List (
5274 Make_Assignment_Statement (Loc,
5276 New_Occurrence_Of (Alloc_Obj_Id, Loc),
5278 Make_Unchecked_Type_Conversion (Loc,
5280 New_Occurrence_Of (Ref_Type, Loc),
5282 New_Occurrence_Of (Obj_Acc_Formal, Loc)))),
5284 Elsif_Parts => New_List (
5285 Make_Elsif_Part (Loc,
5289 New_Occurrence_Of (Obj_Alloc_Formal, Loc),
5291 Make_Integer_Literal (Loc,
5292 UI_From_Int (BIP_Allocation_Form'Pos
5293 (Secondary_Stack)))),
5295 Then_Statements => New_List (
5296 Make_Assignment_Statement (Loc,
5298 New_Occurrence_Of (Alloc_Obj_Id, Loc),
5299 Expression => SS_Allocator))),
5301 Make_Elsif_Part (Loc,
5305 New_Occurrence_Of (Obj_Alloc_Formal, Loc),
5307 Make_Integer_Literal (Loc,
5308 UI_From_Int (BIP_Allocation_Form'Pos
5311 Then_Statements => New_List (
5312 Build_Heap_Allocator
5313 (Temp_Id => Alloc_Obj_Id,
5314 Temp_Typ => Ref_Type,
5316 Ret_Typ => Ret_Obj_Typ,
5317 Alloc_Expr => Heap_Allocator))),
5319 -- ???If all is well, we can put the following
5320 -- 'elsif' in the 'else', but this is a useful
5321 -- self-check in case caller and callee don't agree
5322 -- on whether BIPAlloc and so on should be passed.
5324 Make_Elsif_Part (Loc,
5328 New_Occurrence_Of (Obj_Alloc_Formal, Loc),
5330 Make_Integer_Literal (Loc,
5331 UI_From_Int (BIP_Allocation_Form'Pos
5332 (User_Storage_Pool)))),
5334 Then_Statements => New_List (
5336 Build_Heap_Allocator
5337 (Temp_Id => Alloc_Obj_Id,
5338 Temp_Typ => Ref_Type,
5340 Ret_Typ => Ret_Obj_Typ,
5341 Alloc_Expr => Pool_Allocator)))),
5343 -- Raise Program_Error if it's none of the above;
5344 -- this is a compiler bug. ???PE_All_Guards_Closed
5345 -- is bogus; we should have a new code.
5347 Else_Statements => New_List (
5348 Make_Raise_Program_Error (Loc,
5349 Reason => PE_All_Guards_Closed)));
5351 -- If a separate initialization assignment was created
5352 -- earlier, append that following the assignment of the
5353 -- implicit access formal to the access object, to ensure
5354 -- that the return object is initialized in that case. In
5355 -- this situation, the target of the assignment must be
5356 -- rewritten to denote a dereference of the access to the
5357 -- return object passed in by the caller.
5359 if Present (Init_Assignment) then
5360 Rewrite (Name (Init_Assignment),
5361 Make_Explicit_Dereference (Loc,
5362 Prefix => New_Occurrence_Of (Alloc_Obj_Id, Loc)));
5364 Set_Etype (Name (Init_Assignment), Etype (Ret_Obj_Id));
5367 (Then_Statements (Alloc_If_Stmt), Init_Assignment);
5370 Insert_Before (Ret_Obj_Decl, Alloc_If_Stmt);
5372 -- Remember the local access object for use in the
5373 -- dereference of the renaming created below.
5375 Obj_Acc_Formal := Alloc_Obj_Id;
5379 -- Replace the return object declaration with a renaming of a
5380 -- dereference of the access value designating the return
5384 Make_Explicit_Dereference (Loc,
5385 Prefix => New_Occurrence_Of (Obj_Acc_Formal, Loc));
5387 Rewrite (Ret_Obj_Decl,
5388 Make_Object_Renaming_Declaration (Loc,
5389 Defining_Identifier => Ret_Obj_Id,
5390 Access_Definition => Empty,
5391 Subtype_Mark => New_Occurrence_Of (Ret_Obj_Typ, Loc),
5392 Name => Obj_Acc_Deref));
5394 Set_Renamed_Object (Ret_Obj_Id, Obj_Acc_Deref);
5398 -- Case where we do not build a block
5401 -- We're about to drop Return_Object_Declarations on the floor, so
5402 -- we need to insert it, in case it got expanded into useful code.
5403 -- Remove side effects from expression, which may be duplicated in
5404 -- subsequent checks (see Expand_Simple_Function_Return).
5406 Insert_List_Before (N, Return_Object_Declarations (N));
5407 Remove_Side_Effects (Exp);
5409 -- Build simple_return_statement that returns the expression directly
5411 Return_Stmt := Make_Simple_Return_Statement (Loc, Expression => Exp);
5412 Result := Return_Stmt;
5415 -- Set the flag to prevent infinite recursion
5417 Set_Comes_From_Extended_Return_Statement (Return_Stmt);
5419 Rewrite (N, Result);
5421 end Expand_N_Extended_Return_Statement;
5423 ----------------------------
5424 -- Expand_N_Function_Call --
5425 ----------------------------
5427 procedure Expand_N_Function_Call (N : Node_Id) is
5430 end Expand_N_Function_Call;
5432 ---------------------------------------
5433 -- Expand_N_Procedure_Call_Statement --
5434 ---------------------------------------
5436 procedure Expand_N_Procedure_Call_Statement (N : Node_Id) is
5439 end Expand_N_Procedure_Call_Statement;
5441 --------------------------------------
5442 -- Expand_N_Simple_Return_Statement --
5443 --------------------------------------
5445 procedure Expand_N_Simple_Return_Statement (N : Node_Id) is
5447 -- Defend against previous errors (i.e. the return statement calls a
5448 -- function that is not available in configurable runtime).
5450 if Present (Expression (N))
5451 and then Nkind (Expression (N)) = N_Empty
5453 Check_Error_Detected;
5457 -- Distinguish the function and non-function cases:
5459 case Ekind (Return_Applies_To (Return_Statement_Entity (N))) is
5461 | E_Generic_Function
5463 Expand_Simple_Function_Return (N);
5467 | E_Generic_Procedure
5469 | E_Return_Statement
5471 Expand_Non_Function_Return (N);
5474 raise Program_Error;
5478 when RE_Not_Available =>
5480 end Expand_N_Simple_Return_Statement;
5482 ------------------------------
5483 -- Expand_N_Subprogram_Body --
5484 ------------------------------
5486 -- Add poll call if ATC polling is enabled, unless the body will be inlined
5489 -- Add dummy push/pop label nodes at start and end to clear any local
5490 -- exception indications if local-exception-to-goto optimization is active.
5492 -- Add return statement if last statement in body is not a return statement
5493 -- (this makes things easier on Gigi which does not want to have to handle
5494 -- a missing return).
5496 -- Add call to Activate_Tasks if body is a task activator
5498 -- Deal with possible detection of infinite recursion
5500 -- Eliminate body completely if convention stubbed
5502 -- Encode entity names within body, since we will not need to reference
5503 -- these entities any longer in the front end.
5505 -- Initialize scalar out parameters if Initialize/Normalize_Scalars
5507 -- Reset Pure indication if any parameter has root type System.Address
5508 -- or has any parameters of limited types, where limited means that the
5509 -- run-time view is limited (i.e. the full type is limited).
5513 procedure Expand_N_Subprogram_Body (N : Node_Id) is
5514 Body_Id : constant Entity_Id := Defining_Entity (N);
5515 HSS : constant Node_Id := Handled_Statement_Sequence (N);
5516 Loc : constant Source_Ptr := Sloc (N);
5518 procedure Add_Return (Spec_Id : Entity_Id; Stmts : List_Id);
5519 -- Append a return statement to the statement sequence Stmts if the last
5520 -- statement is not already a return or a goto statement. Note that the
5521 -- latter test is not critical, it does not matter if we add a few extra
5522 -- returns, since they get eliminated anyway later on. Spec_Id denotes
5523 -- the corresponding spec of the subprogram body.
5529 procedure Add_Return (Spec_Id : Entity_Id; Stmts : List_Id) is
5530 Last_Stmt : Node_Id;
5535 -- Get last statement, ignoring any Pop_xxx_Label nodes, which are
5536 -- not relevant in this context since they are not executable.
5538 Last_Stmt := Last (Stmts);
5539 while Nkind (Last_Stmt) in N_Pop_xxx_Label loop
5543 -- Now insert return unless last statement is a transfer
5545 if not Is_Transfer (Last_Stmt) then
5547 -- The source location for the return is the end label of the
5548 -- procedure if present. Otherwise use the sloc of the last
5549 -- statement in the list. If the list comes from a generated
5550 -- exception handler and we are not debugging generated code,
5551 -- all the statements within the handler are made invisible
5554 if Nkind (Parent (Stmts)) = N_Exception_Handler
5555 and then not Comes_From_Source (Parent (Stmts))
5557 Loc := Sloc (Last_Stmt);
5558 elsif Present (End_Label (HSS)) then
5559 Loc := Sloc (End_Label (HSS));
5561 Loc := Sloc (Last_Stmt);
5564 -- Append return statement, and set analyzed manually. We can't
5565 -- call Analyze on this return since the scope is wrong.
5567 -- Note: it almost works to push the scope and then do the Analyze
5568 -- call, but something goes wrong in some weird cases and it is
5569 -- not worth worrying about ???
5571 Stmt := Make_Simple_Return_Statement (Loc);
5573 -- The return statement is handled properly, and the call to the
5574 -- postcondition, inserted below, does not require information
5575 -- from the body either. However, that call is analyzed in the
5576 -- enclosing scope, and an elaboration check might improperly be
5577 -- added to it. A guard in Sem_Elab is needed to prevent that
5578 -- spurious check, see Check_Elab_Call.
5580 Append_To (Stmts, Stmt);
5581 Set_Analyzed (Stmt);
5583 -- Call the _Postconditions procedure if the related subprogram
5584 -- has contract assertions that need to be verified on exit.
5586 if Ekind (Spec_Id) = E_Procedure
5587 and then Present (Postconditions_Proc (Spec_Id))
5589 Insert_Action (Stmt,
5590 Make_Procedure_Call_Statement (Loc,
5592 New_Occurrence_Of (Postconditions_Proc (Spec_Id), Loc)));
5601 Spec_Id : Entity_Id;
5603 -- Start of processing for Expand_N_Subprogram_Body
5606 if Present (Corresponding_Spec (N)) then
5607 Spec_Id := Corresponding_Spec (N);
5612 -- If this is a Pure function which has any parameters whose root type
5613 -- is System.Address, reset the Pure indication.
5614 -- This check is also performed when the subprogram is frozen, but we
5615 -- repeat it on the body so that the indication is consistent, and so
5616 -- it applies as well to bodies without separate specifications.
5618 if Is_Pure (Spec_Id)
5619 and then Is_Subprogram (Spec_Id)
5620 and then not Has_Pragma_Pure_Function (Spec_Id)
5622 Check_Function_With_Address_Parameter (Spec_Id);
5624 if Spec_Id /= Body_Id then
5625 Set_Is_Pure (Body_Id, Is_Pure (Spec_Id));
5629 -- Set L to either the list of declarations if present, or to the list
5630 -- of statements if no declarations are present. This is used to insert
5631 -- new stuff at the start.
5633 if Is_Non_Empty_List (Declarations (N)) then
5634 L := Declarations (N);
5636 L := Statements (HSS);
5639 -- If local-exception-to-goto optimization active, insert dummy push
5640 -- statements at start, and dummy pop statements at end, but inhibit
5641 -- this if we have No_Exception_Handlers, since they are useless and
5642 -- intefere with analysis, e.g. by codepeer.
5644 if (Debug_Flag_Dot_G
5645 or else Restriction_Active (No_Exception_Propagation))
5646 and then not Restriction_Active (No_Exception_Handlers)
5647 and then not CodePeer_Mode
5648 and then Is_Non_Empty_List (L)
5651 FS : constant Node_Id := First (L);
5652 FL : constant Source_Ptr := Sloc (FS);
5657 -- LS points to either last statement, if statements are present
5658 -- or to the last declaration if there are no statements present.
5659 -- It is the node after which the pop's are generated.
5661 if Is_Non_Empty_List (Statements (HSS)) then
5662 LS := Last (Statements (HSS));
5669 Insert_List_Before_And_Analyze (FS, New_List (
5670 Make_Push_Constraint_Error_Label (FL),
5671 Make_Push_Program_Error_Label (FL),
5672 Make_Push_Storage_Error_Label (FL)));
5674 Insert_List_After_And_Analyze (LS, New_List (
5675 Make_Pop_Constraint_Error_Label (LL),
5676 Make_Pop_Program_Error_Label (LL),
5677 Make_Pop_Storage_Error_Label (LL)));
5681 -- Need poll on entry to subprogram if polling enabled. We only do this
5682 -- for non-empty subprograms, since it does not seem necessary to poll
5683 -- for a dummy null subprogram.
5685 if Is_Non_Empty_List (L) then
5687 -- Do not add a polling call if the subprogram is to be inlined by
5688 -- the back-end, to avoid repeated calls with multiple inlinings.
5690 if Is_Inlined (Spec_Id)
5691 and then Front_End_Inlining
5692 and then Optimization_Level > 1
5696 Generate_Poll_Call (First (L));
5700 -- Initialize any scalar OUT args if Initialize/Normalize_Scalars
5702 if Init_Or_Norm_Scalars and then Is_Subprogram (Spec_Id) then
5708 -- Loop through formals
5710 F := First_Formal (Spec_Id);
5711 while Present (F) loop
5712 if Is_Scalar_Type (Etype (F))
5713 and then Ekind (F) = E_Out_Parameter
5715 Check_Restriction (No_Default_Initialization, F);
5717 -- Insert the initialization. We turn off validity checks
5718 -- for this assignment, since we do not want any check on
5719 -- the initial value itself (which may well be invalid).
5720 -- Predicate checks are disabled as well (RM 6.4.1 (13/3))
5723 Make_Assignment_Statement (Loc,
5724 Name => New_Occurrence_Of (F, Loc),
5725 Expression => Get_Simple_Init_Val (Etype (F), N));
5726 Set_Suppress_Assignment_Checks (A);
5728 Insert_Before_And_Analyze (First (L),
5729 A, Suppress => Validity_Check);
5737 -- Clear out statement list for stubbed procedure
5739 if Present (Corresponding_Spec (N)) then
5740 Set_Elaboration_Flag (N, Spec_Id);
5742 if Convention (Spec_Id) = Convention_Stubbed
5743 or else Is_Eliminated (Spec_Id)
5745 Set_Declarations (N, Empty_List);
5746 Set_Handled_Statement_Sequence (N,
5747 Make_Handled_Sequence_Of_Statements (Loc,
5748 Statements => New_List (Make_Null_Statement (Loc))));
5754 -- Create a set of discriminals for the next protected subprogram body
5756 if Is_List_Member (N)
5757 and then Present (Parent (List_Containing (N)))
5758 and then Nkind (Parent (List_Containing (N))) = N_Protected_Body
5759 and then Present (Next_Protected_Operation (N))
5761 Set_Discriminals (Parent (Base_Type (Scope (Spec_Id))));
5764 -- Returns_By_Ref flag is normally set when the subprogram is frozen but
5765 -- subprograms with no specs are not frozen.
5768 Typ : constant Entity_Id := Etype (Spec_Id);
5769 Utyp : constant Entity_Id := Underlying_Type (Typ);
5772 if Is_Limited_View (Typ) then
5773 Set_Returns_By_Ref (Spec_Id);
5775 elsif Present (Utyp) and then CW_Or_Has_Controlled_Part (Utyp) then
5776 Set_Returns_By_Ref (Spec_Id);
5780 -- For a procedure, we add a return for all possible syntactic ends of
5783 if Ekind_In (Spec_Id, E_Procedure, E_Generic_Procedure) then
5784 Add_Return (Spec_Id, Statements (HSS));
5786 if Present (Exception_Handlers (HSS)) then
5787 Except_H := First_Non_Pragma (Exception_Handlers (HSS));
5788 while Present (Except_H) loop
5789 Add_Return (Spec_Id, Statements (Except_H));
5790 Next_Non_Pragma (Except_H);
5794 -- For a function, we must deal with the case where there is at least
5795 -- one missing return. What we do is to wrap the entire body of the
5796 -- function in a block:
5809 -- raise Program_Error;
5812 -- This approach is necessary because the raise must be signalled to the
5813 -- caller, not handled by any local handler (RM 6.4(11)).
5815 -- Note: we do not need to analyze the constructed sequence here, since
5816 -- it has no handler, and an attempt to analyze the handled statement
5817 -- sequence twice is risky in various ways (e.g. the issue of expanding
5818 -- cleanup actions twice).
5820 elsif Has_Missing_Return (Spec_Id) then
5822 Hloc : constant Source_Ptr := Sloc (HSS);
5823 Blok : constant Node_Id :=
5824 Make_Block_Statement (Hloc,
5825 Handled_Statement_Sequence => HSS);
5826 Rais : constant Node_Id :=
5827 Make_Raise_Program_Error (Hloc,
5828 Reason => PE_Missing_Return);
5831 Set_Handled_Statement_Sequence (N,
5832 Make_Handled_Sequence_Of_Statements (Hloc,
5833 Statements => New_List (Blok, Rais)));
5835 Push_Scope (Spec_Id);
5842 -- If subprogram contains a parameterless recursive call, then we may
5843 -- have an infinite recursion, so see if we can generate code to check
5844 -- for this possibility if storage checks are not suppressed.
5846 if Ekind (Spec_Id) = E_Procedure
5847 and then Has_Recursive_Call (Spec_Id)
5848 and then not Storage_Checks_Suppressed (Spec_Id)
5850 Detect_Infinite_Recursion (N, Spec_Id);
5853 -- Set to encode entity names in package body before gigi is called
5855 Qualify_Entity_Names (N);
5857 -- If the body belongs to a nonabstract library-level source primitive
5858 -- of a tagged type, install an elaboration check which ensures that a
5859 -- dispatching call targeting the primitive will not execute the body
5860 -- without it being previously elaborated.
5862 Install_Primitive_Elaboration_Check (N);
5863 end Expand_N_Subprogram_Body;
5865 -----------------------------------
5866 -- Expand_N_Subprogram_Body_Stub --
5867 -----------------------------------
5869 procedure Expand_N_Subprogram_Body_Stub (N : Node_Id) is
5873 if Present (Corresponding_Body (N)) then
5874 Bod := Unit_Declaration_Node (Corresponding_Body (N));
5876 -- The body may have been expanded already when it is analyzed
5877 -- through the subunit node. Do no expand again: it interferes
5878 -- with the construction of unnesting tables when generating C.
5880 if not Analyzed (Bod) then
5881 Expand_N_Subprogram_Body (Bod);
5884 -- Add full qualification to entities that may be created late
5885 -- during unnesting.
5887 Qualify_Entity_Names (N);
5889 end Expand_N_Subprogram_Body_Stub;
5891 -------------------------------------
5892 -- Expand_N_Subprogram_Declaration --
5893 -------------------------------------
5895 -- If the declaration appears within a protected body, it is a private
5896 -- operation of the protected type. We must create the corresponding
5897 -- protected subprogram an associated formals. For a normal protected
5898 -- operation, this is done when expanding the protected type declaration.
5900 -- If the declaration is for a null procedure, emit null body
5902 procedure Expand_N_Subprogram_Declaration (N : Node_Id) is
5903 Loc : constant Source_Ptr := Sloc (N);
5904 Subp : constant Entity_Id := Defining_Entity (N);
5908 Scop : constant Entity_Id := Scope (Subp);
5910 Prot_Decl : Node_Id;
5911 Prot_Id : Entity_Id;
5913 -- Start of processing for Expand_N_Subprogram_Declaration
5916 -- In SPARK, subprogram declarations are only allowed in package
5919 if Nkind (Parent (N)) /= N_Package_Specification then
5920 if Nkind (Parent (N)) = N_Compilation_Unit then
5921 Check_SPARK_05_Restriction
5922 ("subprogram declaration is not a library item", N);
5924 elsif Present (Next (N))
5925 and then Nkind (Next (N)) = N_Pragma
5926 and then Get_Pragma_Id (Next (N)) = Pragma_Import
5928 -- In SPARK, subprogram declarations are also permitted in
5929 -- declarative parts when immediately followed by a corresponding
5930 -- pragma Import. We only check here that there is some pragma
5935 Check_SPARK_05_Restriction
5936 ("subprogram declaration is not allowed here", N);
5940 -- Deal with case of protected subprogram. Do not generate protected
5941 -- operation if operation is flagged as eliminated.
5943 if Is_List_Member (N)
5944 and then Present (Parent (List_Containing (N)))
5945 and then Nkind (Parent (List_Containing (N))) = N_Protected_Body
5946 and then Is_Protected_Type (Scop)
5948 if No (Protected_Body_Subprogram (Subp))
5949 and then not Is_Eliminated (Subp)
5952 Make_Subprogram_Declaration (Loc,
5954 Build_Protected_Sub_Specification
5955 (N, Scop, Unprotected_Mode));
5957 -- The protected subprogram is declared outside of the protected
5958 -- body. Given that the body has frozen all entities so far, we
5959 -- analyze the subprogram and perform freezing actions explicitly.
5960 -- including the generation of an explicit freeze node, to ensure
5961 -- that gigi has the proper order of elaboration.
5962 -- If the body is a subunit, the insertion point is before the
5963 -- stub in the parent.
5965 Prot_Bod := Parent (List_Containing (N));
5967 if Nkind (Parent (Prot_Bod)) = N_Subunit then
5968 Prot_Bod := Corresponding_Stub (Parent (Prot_Bod));
5971 Insert_Before (Prot_Bod, Prot_Decl);
5972 Prot_Id := Defining_Unit_Name (Specification (Prot_Decl));
5973 Set_Has_Delayed_Freeze (Prot_Id);
5975 Push_Scope (Scope (Scop));
5976 Analyze (Prot_Decl);
5977 Freeze_Before (N, Prot_Id);
5978 Set_Protected_Body_Subprogram (Subp, Prot_Id);
5980 -- Create protected operation as well. Even though the operation
5981 -- is only accessible within the body, it is possible to make it
5982 -- available outside of the protected object by using 'Access to
5983 -- provide a callback, so build protected version in all cases.
5986 Make_Subprogram_Declaration (Loc,
5988 Build_Protected_Sub_Specification (N, Scop, Protected_Mode));
5989 Insert_Before (Prot_Bod, Prot_Decl);
5990 Analyze (Prot_Decl);
5995 -- Ada 2005 (AI-348): Generate body for a null procedure. In most
5996 -- cases this is superfluous because calls to it will be automatically
5997 -- inlined, but we definitely need the body if preconditions for the
5998 -- procedure are present, or if performing coverage analysis.
6000 elsif Nkind (Specification (N)) = N_Procedure_Specification
6001 and then Null_Present (Specification (N))
6004 Bod : constant Node_Id := Body_To_Inline (N);
6007 Set_Has_Completion (Subp, False);
6008 Append_Freeze_Action (Subp, Bod);
6010 -- The body now contains raise statements, so calls to it will
6013 Set_Is_Inlined (Subp, False);
6017 -- When generating C code, transform a function that returns a
6018 -- constrained array type into a procedure with an out parameter
6019 -- that carries the return value.
6021 -- We skip this transformation for unchecked conversions, since they
6022 -- are not needed by the C generator (and this also produces cleaner
6025 if Modify_Tree_For_C
6026 and then Nkind (Specification (N)) = N_Function_Specification
6027 and then Is_Array_Type (Etype (Subp))
6028 and then Is_Constrained (Etype (Subp))
6029 and then not Is_Unchecked_Conversion_Instance (Subp)
6031 Build_Procedure_Form (N);
6033 end Expand_N_Subprogram_Declaration;
6035 --------------------------------
6036 -- Expand_Non_Function_Return --
6037 --------------------------------
6039 procedure Expand_Non_Function_Return (N : Node_Id) is
6040 pragma Assert (No (Expression (N)));
6042 Loc : constant Source_Ptr := Sloc (N);
6043 Scope_Id : Entity_Id := Return_Applies_To (Return_Statement_Entity (N));
6044 Kind : constant Entity_Kind := Ekind (Scope_Id);
6047 Goto_Stat : Node_Id;
6051 -- Call the _Postconditions procedure if the related subprogram has
6052 -- contract assertions that need to be verified on exit.
6054 if Ekind_In (Scope_Id, E_Entry, E_Entry_Family, E_Procedure)
6055 and then Present (Postconditions_Proc (Scope_Id))
6058 Make_Procedure_Call_Statement (Loc,
6059 Name => New_Occurrence_Of (Postconditions_Proc (Scope_Id), Loc)));
6062 -- If it is a return from a procedure do no extra steps
6064 if Kind = E_Procedure or else Kind = E_Generic_Procedure then
6067 -- If it is a nested return within an extended one, replace it with a
6068 -- return of the previously declared return object.
6070 elsif Kind = E_Return_Statement then
6072 Make_Simple_Return_Statement (Loc,
6074 New_Occurrence_Of (First_Entity (Scope_Id), Loc)));
6075 Set_Comes_From_Extended_Return_Statement (N);
6076 Set_Return_Statement_Entity (N, Scope_Id);
6077 Expand_Simple_Function_Return (N);
6081 pragma Assert (Is_Entry (Scope_Id));
6083 -- Look at the enclosing block to see whether the return is from an
6084 -- accept statement or an entry body.
6086 for J in reverse 0 .. Scope_Stack.Last loop
6087 Scope_Id := Scope_Stack.Table (J).Entity;
6088 exit when Is_Concurrent_Type (Scope_Id);
6091 -- If it is a return from accept statement it is expanded as call to
6092 -- RTS Complete_Rendezvous and a goto to the end of the accept body.
6094 -- (cf : Expand_N_Accept_Statement, Expand_N_Selective_Accept,
6095 -- Expand_N_Accept_Alternative in exp_ch9.adb)
6097 if Is_Task_Type (Scope_Id) then
6100 Make_Procedure_Call_Statement (Loc,
6101 Name => New_Occurrence_Of (RTE (RE_Complete_Rendezvous), Loc));
6102 Insert_Before (N, Call);
6103 -- why not insert actions here???
6106 Acc_Stat := Parent (N);
6107 while Nkind (Acc_Stat) /= N_Accept_Statement loop
6108 Acc_Stat := Parent (Acc_Stat);
6111 Lab_Node := Last (Statements
6112 (Handled_Statement_Sequence (Acc_Stat)));
6114 Goto_Stat := Make_Goto_Statement (Loc,
6115 Name => New_Occurrence_Of
6116 (Entity (Identifier (Lab_Node)), Loc));
6118 Set_Analyzed (Goto_Stat);
6120 Rewrite (N, Goto_Stat);
6123 -- If it is a return from an entry body, put a Complete_Entry_Body call
6124 -- in front of the return.
6126 elsif Is_Protected_Type (Scope_Id) then
6128 Make_Procedure_Call_Statement (Loc,
6130 New_Occurrence_Of (RTE (RE_Complete_Entry_Body), Loc),
6131 Parameter_Associations => New_List (
6132 Make_Attribute_Reference (Loc,
6135 (Find_Protection_Object (Current_Scope), Loc),
6136 Attribute_Name => Name_Unchecked_Access)));
6138 Insert_Before (N, Call);
6141 end Expand_Non_Function_Return;
6143 ---------------------------------------
6144 -- Expand_Protected_Object_Reference --
6145 ---------------------------------------
6147 function Expand_Protected_Object_Reference
6149 Scop : Entity_Id) return Node_Id
6151 Loc : constant Source_Ptr := Sloc (N);
6158 Rec := Make_Identifier (Loc, Name_uObject);
6159 Set_Etype (Rec, Corresponding_Record_Type (Scop));
6161 -- Find enclosing protected operation, and retrieve its first parameter,
6162 -- which denotes the enclosing protected object. If the enclosing
6163 -- operation is an entry, we are immediately within the protected body,
6164 -- and we can retrieve the object from the service entries procedure. A
6165 -- barrier function has the same signature as an entry. A barrier
6166 -- function is compiled within the protected object, but unlike
6167 -- protected operations its never needs locks, so that its protected
6168 -- body subprogram points to itself.
6170 Proc := Current_Scope;
6171 while Present (Proc)
6172 and then Scope (Proc) /= Scop
6174 Proc := Scope (Proc);
6177 Corr := Protected_Body_Subprogram (Proc);
6181 -- Previous error left expansion incomplete.
6182 -- Nothing to do on this call.
6189 (First (Parameter_Specifications (Parent (Corr))));
6191 if Is_Subprogram (Proc) and then Proc /= Corr then
6193 -- Protected function or procedure
6195 Set_Entity (Rec, Param);
6197 -- Rec is a reference to an entity which will not be in scope when
6198 -- the call is reanalyzed, and needs no further analysis.
6203 -- Entry or barrier function for entry body. The first parameter of
6204 -- the entry body procedure is pointer to the object. We create a
6205 -- local variable of the proper type, duplicating what is done to
6206 -- define _object later on.
6210 Obj_Ptr : constant Entity_Id := Make_Temporary (Loc, 'T');
6214 Make_Full_Type_Declaration (Loc,
6215 Defining_Identifier => Obj_Ptr,
6217 Make_Access_To_Object_Definition (Loc,
6218 Subtype_Indication =>
6220 (Corresponding_Record_Type (Scop), Loc))));
6222 Insert_Actions (N, Decls);
6223 Freeze_Before (N, Obj_Ptr);
6226 Make_Explicit_Dereference (Loc,
6228 Unchecked_Convert_To (Obj_Ptr,
6229 New_Occurrence_Of (Param, Loc)));
6231 -- Analyze new actual. Other actuals in calls are already analyzed
6232 -- and the list of actuals is not reanalyzed after rewriting.
6234 Set_Parent (Rec, N);
6240 end Expand_Protected_Object_Reference;
6242 --------------------------------------
6243 -- Expand_Protected_Subprogram_Call --
6244 --------------------------------------
6246 procedure Expand_Protected_Subprogram_Call
6253 procedure Expand_Internal_Init_Call;
6254 -- A call to an operation of the type may occur in the initialization
6255 -- of a private component. In that case the prefix of the call is an
6256 -- entity name and the call is treated as internal even though it
6257 -- appears in code outside of the protected type.
6259 procedure Freeze_Called_Function;
6260 -- If it is a function call it can appear in elaboration code and
6261 -- the called entity must be frozen before the call. This must be
6262 -- done before the call is expanded, as the expansion may rewrite it
6263 -- to something other than a call (e.g. a temporary initialized in a
6264 -- transient block).
6266 -------------------------------
6267 -- Expand_Internal_Init_Call --
6268 -------------------------------
6270 procedure Expand_Internal_Init_Call is
6272 -- If the context is a protected object (rather than a protected
6273 -- type) the call itself is bound to raise program_error because
6274 -- the protected body will not have been elaborated yet. This is
6275 -- diagnosed subsequently in Sem_Elab.
6277 Freeze_Called_Function;
6279 -- The target of the internal call is the first formal of the
6280 -- enclosing initialization procedure.
6282 Rec := New_Occurrence_Of (First_Formal (Current_Scope), Sloc (N));
6283 Build_Protected_Subprogram_Call (N,
6288 Resolve (N, Etype (Subp));
6289 end Expand_Internal_Init_Call;
6291 ----------------------------
6292 -- Freeze_Called_Function --
6293 ----------------------------
6295 procedure Freeze_Called_Function is
6297 if Ekind (Subp) = E_Function then
6298 Freeze_Expression (Name (N));
6300 end Freeze_Called_Function;
6302 -- Start of processing for Expand_Protected_Subprogram_Call
6305 -- If the protected object is not an enclosing scope, this is an inter-
6306 -- object function call. Inter-object procedure calls are expanded by
6307 -- Exp_Ch9.Build_Simple_Entry_Call. The call is intra-object only if the
6308 -- subprogram being called is in the protected body being compiled, and
6309 -- if the protected object in the call is statically the enclosing type.
6310 -- The object may be a component of some other data structure, in which
6311 -- case this must be handled as an inter-object call.
6313 if not In_Open_Scopes (Scop)
6314 or else Is_Entry_Wrapper (Current_Scope)
6315 or else not Is_Entity_Name (Name (N))
6317 if Nkind (Name (N)) = N_Selected_Component then
6318 Rec := Prefix (Name (N));
6320 elsif Nkind (Name (N)) = N_Indexed_Component then
6321 Rec := Prefix (Prefix (Name (N)));
6323 -- If this is a call within an entry wrapper, it appears within a
6324 -- precondition that calls another primitive of the synchronized
6325 -- type. The target object of the call is the first actual on the
6326 -- wrapper. Note that this is an external call, because the wrapper
6327 -- is called outside of the synchronized object. This means that
6328 -- an entry call to an entry with preconditions involves two
6329 -- synchronized operations.
6331 elsif Ekind (Current_Scope) = E_Procedure
6332 and then Is_Entry_Wrapper (Current_Scope)
6334 Rec := New_Occurrence_Of (First_Entity (Current_Scope), Sloc (N));
6337 -- If the context is the initialization procedure for a protected
6338 -- type, the call is legal because the called entity must be a
6339 -- function of that enclosing type, and this is treated as an
6343 (Is_Entity_Name (Name (N)) and then Inside_Init_Proc);
6345 Expand_Internal_Init_Call;
6349 Freeze_Called_Function;
6350 Build_Protected_Subprogram_Call (N,
6351 Name => New_Occurrence_Of (Subp, Sloc (N)),
6352 Rec => Convert_Concurrent (Rec, Etype (Rec)),
6356 Rec := Expand_Protected_Object_Reference (N, Scop);
6362 Freeze_Called_Function;
6363 Build_Protected_Subprogram_Call (N,
6369 -- Analyze and resolve the new call. The actuals have already been
6370 -- resolved, but expansion of a function call will add extra actuals
6371 -- if needed. Analysis of a procedure call already includes resolution.
6375 if Ekind (Subp) = E_Function then
6376 Resolve (N, Etype (Subp));
6378 end Expand_Protected_Subprogram_Call;
6380 -----------------------------------
6381 -- Expand_Simple_Function_Return --
6382 -----------------------------------
6384 -- The "simple" comes from the syntax rule simple_return_statement. The
6385 -- semantics are not at all simple.
6387 procedure Expand_Simple_Function_Return (N : Node_Id) is
6388 Loc : constant Source_Ptr := Sloc (N);
6390 Scope_Id : constant Entity_Id :=
6391 Return_Applies_To (Return_Statement_Entity (N));
6392 -- The function we are returning from
6394 R_Type : constant Entity_Id := Etype (Scope_Id);
6395 -- The result type of the function
6397 Utyp : constant Entity_Id := Underlying_Type (R_Type);
6399 Exp : Node_Id := Expression (N);
6400 pragma Assert (Present (Exp));
6402 Exptyp : constant Entity_Id := Etype (Exp);
6403 -- The type of the expression (not necessarily the same as R_Type)
6405 Subtype_Ind : Node_Id;
6406 -- If the result type of the function is class-wide and the expression
6407 -- has a specific type, then we use the expression's type as the type of
6408 -- the return object. In cases where the expression is an aggregate that
6409 -- is built in place, this avoids the need for an expensive conversion
6410 -- of the return object to the specific type on assignments to the
6411 -- individual components.
6414 if Is_Class_Wide_Type (R_Type)
6415 and then not Is_Class_Wide_Type (Exptyp)
6416 and then Nkind (Exp) /= N_Type_Conversion
6418 Subtype_Ind := New_Occurrence_Of (Exptyp, Loc);
6420 Subtype_Ind := New_Occurrence_Of (R_Type, Loc);
6422 -- If the result type is class-wide and the expression is a view
6423 -- conversion, the conversion plays no role in the expansion because
6424 -- it does not modify the tag of the object. Remove the conversion
6425 -- altogether to prevent tag overwriting.
6427 if Is_Class_Wide_Type (R_Type)
6428 and then not Is_Class_Wide_Type (Exptyp)
6429 and then Nkind (Exp) = N_Type_Conversion
6431 Exp := Expression (Exp);
6435 -- For the case of a simple return that does not come from an
6436 -- extended return, in the case of build-in-place, we rewrite
6437 -- "return <expression>;" to be:
6439 -- return _anon_ : <return_subtype> := <expression>
6441 -- The expansion produced by Expand_N_Extended_Return_Statement will
6442 -- contain simple return statements (for example, a block containing
6443 -- simple return of the return object), which brings us back here with
6444 -- Comes_From_Extended_Return_Statement set. The reason for the barrier
6445 -- checking for a simple return that does not come from an extended
6446 -- return is to avoid this infinite recursion.
6448 -- The reason for this design is that for Ada 2005 limited returns, we
6449 -- need to reify the return object, so we can build it "in place", and
6450 -- we need a block statement to hang finalization and tasking stuff.
6452 -- ??? In order to avoid disruption, we avoid translating to extended
6453 -- return except in the cases where we really need to (Ada 2005 for
6454 -- inherently limited). We might prefer to do this translation in all
6455 -- cases (except perhaps for the case of Ada 95 inherently limited),
6456 -- in order to fully exercise the Expand_N_Extended_Return_Statement
6457 -- code. This would also allow us to do the build-in-place optimization
6458 -- for efficiency even in cases where it is semantically not required.
6460 -- As before, we check the type of the return expression rather than the
6461 -- return type of the function, because the latter may be a limited
6462 -- class-wide interface type, which is not a limited type, even though
6463 -- the type of the expression may be.
6466 (Comes_From_Extended_Return_Statement (N)
6467 or else not Is_Build_In_Place_Function_Call (Exp)
6468 or else Is_Build_In_Place_Function (Scope_Id));
6470 if not Comes_From_Extended_Return_Statement (N)
6471 and then Is_Build_In_Place_Function (Scope_Id)
6472 and then not Debug_Flag_Dot_L
6474 -- The functionality of interface thunks is simple and it is always
6475 -- handled by means of simple return statements. This leaves their
6476 -- expansion simple and clean.
6478 and then not Is_Thunk (Current_Scope)
6481 Return_Object_Entity : constant Entity_Id :=
6482 Make_Temporary (Loc, 'R', Exp);
6484 Obj_Decl : constant Node_Id :=
6485 Make_Object_Declaration (Loc,
6486 Defining_Identifier => Return_Object_Entity,
6487 Object_Definition => Subtype_Ind,
6490 Ext : constant Node_Id :=
6491 Make_Extended_Return_Statement (Loc,
6492 Return_Object_Declarations => New_List (Obj_Decl));
6493 -- Do not perform this high-level optimization if the result type
6494 -- is an interface because the "this" pointer must be displaced.
6503 -- Here we have a simple return statement that is part of the expansion
6504 -- of an extended return statement (either written by the user, or
6505 -- generated by the above code).
6507 -- Always normalize C/Fortran boolean result. This is not always needed,
6508 -- but it seems a good idea to minimize the passing around of non-
6509 -- normalized values, and in any case this handles the processing of
6510 -- barrier functions for protected types, which turn the condition into
6511 -- a return statement.
6513 if Is_Boolean_Type (Exptyp)
6514 and then Nonzero_Is_True (Exptyp)
6516 Adjust_Condition (Exp);
6517 Adjust_Result_Type (Exp, Exptyp);
6520 -- Do validity check if enabled for returns
6522 if Validity_Checks_On
6523 and then Validity_Check_Returns
6528 -- Check the result expression of a scalar function against the subtype
6529 -- of the function by inserting a conversion. This conversion must
6530 -- eventually be performed for other classes of types, but for now it's
6531 -- only done for scalars.
6534 if Is_Scalar_Type (Exptyp) then
6535 Rewrite (Exp, Convert_To (R_Type, Exp));
6537 -- The expression is resolved to ensure that the conversion gets
6538 -- expanded to generate a possible constraint check.
6540 Analyze_And_Resolve (Exp, R_Type);
6543 -- Deal with returning variable length objects and controlled types
6545 -- Nothing to do if we are returning by reference, or this is not a
6546 -- type that requires special processing (indicated by the fact that
6547 -- it requires a cleanup scope for the secondary stack case).
6549 if Is_Build_In_Place_Function (Scope_Id)
6550 or else Is_Limited_Interface (Exptyp)
6554 -- No copy needed for thunks returning interface type objects since
6555 -- the object is returned by reference and the maximum functionality
6556 -- required is just to displace the pointer.
6558 elsif Is_Thunk (Current_Scope) and then Is_Interface (Exptyp) then
6561 -- If the call is within a thunk and the type is a limited view, the
6562 -- backend will eventually see the non-limited view of the type.
6564 elsif Is_Thunk (Current_Scope) and then Is_Incomplete_Type (Exptyp) then
6567 elsif not Requires_Transient_Scope (R_Type) then
6569 -- Mutable records with variable-length components are not returned
6570 -- on the sec-stack, so we need to make sure that the back end will
6571 -- only copy back the size of the actual value, and not the maximum
6572 -- size. We create an actual subtype for this purpose. However we
6573 -- need not do it if the expression is a function call since this
6574 -- will be done in the called function and doing it here too would
6575 -- cause a temporary with maximum size to be created.
6578 Ubt : constant Entity_Id := Underlying_Type (Base_Type (Exptyp));
6582 if Nkind (Exp) /= N_Function_Call
6583 and then Has_Discriminants (Ubt)
6584 and then not Is_Constrained (Ubt)
6585 and then not Has_Unchecked_Union (Ubt)
6587 Decl := Build_Actual_Subtype (Ubt, Exp);
6588 Ent := Defining_Identifier (Decl);
6589 Insert_Action (Exp, Decl);
6590 Rewrite (Exp, Unchecked_Convert_To (Ent, Exp));
6591 Analyze_And_Resolve (Exp);
6595 -- Here if secondary stack is used
6598 -- Prevent the reclamation of the secondary stack by all enclosing
6599 -- blocks and loops as well as the related function; otherwise the
6600 -- result would be reclaimed too early.
6602 Set_Enclosing_Sec_Stack_Return (N);
6604 -- Optimize the case where the result is a function call. In this
6605 -- case either the result is already on the secondary stack, or is
6606 -- already being returned with the stack pointer depressed and no
6607 -- further processing is required except to set the By_Ref flag
6608 -- to ensure that gigi does not attempt an extra unnecessary copy.
6609 -- (actually not just unnecessary but harmfully wrong in the case
6610 -- of a controlled type, where gigi does not know how to do a copy).
6611 -- To make up for a gcc 2.8.1 deficiency (???), we perform the copy
6612 -- for array types if the constrained status of the target type is
6613 -- different from that of the expression.
6615 if Requires_Transient_Scope (Exptyp)
6617 (not Is_Array_Type (Exptyp)
6618 or else Is_Constrained (Exptyp) = Is_Constrained (R_Type)
6619 or else CW_Or_Has_Controlled_Part (Utyp))
6620 and then Nkind (Exp) = N_Function_Call
6624 -- Remove side effects from the expression now so that other parts
6625 -- of the expander do not have to reanalyze this node without this
6628 Rewrite (Exp, Duplicate_Subexpr_No_Checks (Exp));
6630 -- Ada 2005 (AI-251): If the type of the returned object is
6631 -- an interface then add an implicit type conversion to force
6632 -- displacement of the "this" pointer.
6634 if Is_Interface (R_Type) then
6635 Rewrite (Exp, Convert_To (R_Type, Relocate_Node (Exp)));
6638 Analyze_And_Resolve (Exp, R_Type);
6640 -- For controlled types, do the allocation on the secondary stack
6641 -- manually in order to call adjust at the right time:
6643 -- type Anon1 is access R_Type;
6644 -- for Anon1'Storage_pool use ss_pool;
6645 -- Anon2 : anon1 := new R_Type'(expr);
6646 -- return Anon2.all;
6648 -- We do the same for classwide types that are not potentially
6649 -- controlled (by the virtue of restriction No_Finalization) because
6650 -- gigi is not able to properly allocate class-wide types.
6652 elsif CW_Or_Has_Controlled_Part (Utyp) then
6654 Loc : constant Source_Ptr := Sloc (N);
6655 Acc_Typ : constant Entity_Id := Make_Temporary (Loc, 'A');
6656 Alloc_Node : Node_Id;
6660 Set_Ekind (Acc_Typ, E_Access_Type);
6662 Set_Associated_Storage_Pool (Acc_Typ, RTE (RE_SS_Pool));
6664 -- This is an allocator for the secondary stack, and it's fine
6665 -- to have Comes_From_Source set False on it, as gigi knows not
6666 -- to flag it as a violation of No_Implicit_Heap_Allocations.
6669 Make_Allocator (Loc,
6671 Make_Qualified_Expression (Loc,
6672 Subtype_Mark => New_Occurrence_Of (Etype (Exp), Loc),
6673 Expression => Relocate_Node (Exp)));
6675 -- We do not want discriminant checks on the declaration,
6676 -- given that it gets its value from the allocator.
6678 Set_No_Initialization (Alloc_Node);
6680 Temp := Make_Temporary (Loc, 'R', Alloc_Node);
6682 Insert_List_Before_And_Analyze (N, New_List (
6683 Make_Full_Type_Declaration (Loc,
6684 Defining_Identifier => Acc_Typ,
6686 Make_Access_To_Object_Definition (Loc,
6687 Subtype_Indication => Subtype_Ind)),
6689 Make_Object_Declaration (Loc,
6690 Defining_Identifier => Temp,
6691 Object_Definition => New_Occurrence_Of (Acc_Typ, Loc),
6692 Expression => Alloc_Node)));
6695 Make_Explicit_Dereference (Loc,
6696 Prefix => New_Occurrence_Of (Temp, Loc)));
6698 -- Ada 2005 (AI-251): If the type of the returned object is
6699 -- an interface then add an implicit type conversion to force
6700 -- displacement of the "this" pointer.
6702 if Is_Interface (R_Type) then
6703 Rewrite (Exp, Convert_To (R_Type, Relocate_Node (Exp)));
6706 Analyze_And_Resolve (Exp, R_Type);
6709 -- Otherwise use the gigi mechanism to allocate result on the
6713 Check_Restriction (No_Secondary_Stack, N);
6714 Set_Storage_Pool (N, RTE (RE_SS_Pool));
6715 Set_Procedure_To_Call (N, RTE (RE_SS_Allocate));
6719 -- Implement the rules of 6.5(8-10), which require a tag check in
6720 -- the case of a limited tagged return type, and tag reassignment for
6721 -- nonlimited tagged results. These actions are needed when the return
6722 -- type is a specific tagged type and the result expression is a
6723 -- conversion or a formal parameter, because in that case the tag of
6724 -- the expression might differ from the tag of the specific result type.
6726 if Is_Tagged_Type (Utyp)
6727 and then not Is_Class_Wide_Type (Utyp)
6728 and then (Nkind_In (Exp, N_Type_Conversion,
6729 N_Unchecked_Type_Conversion)
6730 or else (Is_Entity_Name (Exp)
6731 and then Ekind (Entity (Exp)) in Formal_Kind))
6733 -- When the return type is limited, perform a check that the tag of
6734 -- the result is the same as the tag of the return type.
6736 if Is_Limited_Type (R_Type) then
6738 Make_Raise_Constraint_Error (Loc,
6742 Make_Selected_Component (Loc,
6743 Prefix => Duplicate_Subexpr (Exp),
6744 Selector_Name => Make_Identifier (Loc, Name_uTag)),
6746 Make_Attribute_Reference (Loc,
6748 New_Occurrence_Of (Base_Type (Utyp), Loc),
6749 Attribute_Name => Name_Tag)),
6750 Reason => CE_Tag_Check_Failed));
6752 -- If the result type is a specific nonlimited tagged type, then we
6753 -- have to ensure that the tag of the result is that of the result
6754 -- type. This is handled by making a copy of the expression in
6755 -- the case where it might have a different tag, namely when the
6756 -- expression is a conversion or a formal parameter. We create a new
6757 -- object of the result type and initialize it from the expression,
6758 -- which will implicitly force the tag to be set appropriately.
6762 ExpR : constant Node_Id := Relocate_Node (Exp);
6763 Result_Id : constant Entity_Id :=
6764 Make_Temporary (Loc, 'R', ExpR);
6765 Result_Exp : constant Node_Id :=
6766 New_Occurrence_Of (Result_Id, Loc);
6767 Result_Obj : constant Node_Id :=
6768 Make_Object_Declaration (Loc,
6769 Defining_Identifier => Result_Id,
6770 Object_Definition =>
6771 New_Occurrence_Of (R_Type, Loc),
6772 Constant_Present => True,
6773 Expression => ExpR);
6776 Set_Assignment_OK (Result_Obj);
6777 Insert_Action (Exp, Result_Obj);
6779 Rewrite (Exp, Result_Exp);
6780 Analyze_And_Resolve (Exp, R_Type);
6784 -- Ada 2005 (AI-344): If the result type is class-wide, then insert
6785 -- a check that the level of the return expression's underlying type
6786 -- is not deeper than the level of the master enclosing the function.
6787 -- Always generate the check when the type of the return expression
6788 -- is class-wide, when it's a type conversion, or when it's a formal
6789 -- parameter. Otherwise, suppress the check in the case where the
6790 -- return expression has a specific type whose level is known not to
6791 -- be statically deeper than the function's result type.
6793 -- No runtime check needed in interface thunks since it is performed
6794 -- by the target primitive associated with the thunk.
6796 -- Note: accessibility check is skipped in the VM case, since there
6797 -- does not seem to be any practical way to implement this check.
6799 elsif Ada_Version >= Ada_2005
6800 and then Tagged_Type_Expansion
6801 and then Is_Class_Wide_Type (R_Type)
6802 and then not Is_Thunk (Current_Scope)
6803 and then not Scope_Suppress.Suppress (Accessibility_Check)
6805 (Is_Class_Wide_Type (Etype (Exp))
6806 or else Nkind_In (Exp, N_Type_Conversion,
6807 N_Unchecked_Type_Conversion)
6808 or else (Is_Entity_Name (Exp)
6809 and then Ekind (Entity (Exp)) in Formal_Kind)
6810 or else Scope_Depth (Enclosing_Dynamic_Scope (Etype (Exp))) >
6811 Scope_Depth (Enclosing_Dynamic_Scope (Scope_Id)))
6817 -- Ada 2005 (AI-251): In class-wide interface objects we displace
6818 -- "this" to reference the base of the object. This is required to
6819 -- get access to the TSD of the object.
6821 if Is_Class_Wide_Type (Etype (Exp))
6822 and then Is_Interface (Etype (Exp))
6824 -- If the expression is an explicit dereference then we can
6825 -- directly displace the pointer to reference the base of
6828 if Nkind (Exp) = N_Explicit_Dereference then
6830 Make_Explicit_Dereference (Loc,
6832 Unchecked_Convert_To (RTE (RE_Tag_Ptr),
6833 Make_Function_Call (Loc,
6835 New_Occurrence_Of (RTE (RE_Base_Address), Loc),
6836 Parameter_Associations => New_List (
6837 Unchecked_Convert_To (RTE (RE_Address),
6838 Duplicate_Subexpr (Prefix (Exp)))))));
6840 -- Similar case to the previous one but the expression is a
6841 -- renaming of an explicit dereference.
6843 elsif Nkind (Exp) = N_Identifier
6844 and then Present (Renamed_Object (Entity (Exp)))
6845 and then Nkind (Renamed_Object (Entity (Exp)))
6846 = N_Explicit_Dereference
6849 Make_Explicit_Dereference (Loc,
6851 Unchecked_Convert_To (RTE (RE_Tag_Ptr),
6852 Make_Function_Call (Loc,
6854 New_Occurrence_Of (RTE (RE_Base_Address), Loc),
6855 Parameter_Associations => New_List (
6856 Unchecked_Convert_To (RTE (RE_Address),
6859 (Renamed_Object (Entity (Exp)))))))));
6861 -- Common case: obtain the address of the actual object and
6862 -- displace the pointer to reference the base of the object.
6866 Make_Explicit_Dereference (Loc,
6868 Unchecked_Convert_To (RTE (RE_Tag_Ptr),
6869 Make_Function_Call (Loc,
6871 New_Occurrence_Of (RTE (RE_Base_Address), Loc),
6872 Parameter_Associations => New_List (
6873 Make_Attribute_Reference (Loc,
6874 Prefix => Duplicate_Subexpr (Exp),
6875 Attribute_Name => Name_Address)))));
6879 Make_Attribute_Reference (Loc,
6880 Prefix => Duplicate_Subexpr (Exp),
6881 Attribute_Name => Name_Tag);
6884 -- CodePeer does not do anything useful with
6885 -- Ada.Tags.Type_Specific_Data components.
6887 if not CodePeer_Mode then
6889 Make_Raise_Program_Error (Loc,
6892 Left_Opnd => Build_Get_Access_Level (Loc, Tag_Node),
6894 Make_Integer_Literal (Loc,
6895 Scope_Depth (Enclosing_Dynamic_Scope (Scope_Id)))),
6896 Reason => PE_Accessibility_Check_Failed));
6900 -- AI05-0073: If function has a controlling access result, check that
6901 -- the tag of the return value, if it is not null, matches designated
6902 -- type of return type.
6904 -- The return expression is referenced twice in the code below, so it
6905 -- must be made free of side effects. Given that different compilers
6906 -- may evaluate these parameters in different order, both occurrences
6909 elsif Ekind (R_Type) = E_Anonymous_Access_Type
6910 and then Has_Controlling_Result (Scope_Id)
6913 Make_Raise_Constraint_Error (Loc,
6918 Left_Opnd => Duplicate_Subexpr (Exp),
6919 Right_Opnd => Make_Null (Loc)),
6921 Right_Opnd => Make_Op_Ne (Loc,
6923 Make_Selected_Component (Loc,
6924 Prefix => Duplicate_Subexpr (Exp),
6925 Selector_Name => Make_Identifier (Loc, Name_uTag)),
6928 Make_Attribute_Reference (Loc,
6930 New_Occurrence_Of (Designated_Type (R_Type), Loc),
6931 Attribute_Name => Name_Tag))),
6933 Reason => CE_Tag_Check_Failed),
6934 Suppress => All_Checks);
6937 -- AI05-0234: RM 6.5(21/3). Check access discriminants to
6938 -- ensure that the function result does not outlive an
6939 -- object designated by one of it discriminants.
6941 if Present (Extra_Accessibility_Of_Result (Scope_Id))
6942 and then Has_Unconstrained_Access_Discriminants (R_Type)
6945 Discrim_Source : Node_Id;
6947 procedure Check_Against_Result_Level (Level : Node_Id);
6948 -- Check the given accessibility level against the level
6949 -- determined by the point of call. (AI05-0234).
6951 --------------------------------
6952 -- Check_Against_Result_Level --
6953 --------------------------------
6955 procedure Check_Against_Result_Level (Level : Node_Id) is
6958 Make_Raise_Program_Error (Loc,
6964 (Extra_Accessibility_Of_Result (Scope_Id), Loc)),
6965 Reason => PE_Accessibility_Check_Failed));
6966 end Check_Against_Result_Level;
6969 Discrim_Source := Exp;
6970 while Nkind (Discrim_Source) = N_Qualified_Expression loop
6971 Discrim_Source := Expression (Discrim_Source);
6974 if Nkind (Discrim_Source) = N_Identifier
6975 and then Is_Return_Object (Entity (Discrim_Source))
6977 Discrim_Source := Entity (Discrim_Source);
6979 if Is_Constrained (Etype (Discrim_Source)) then
6980 Discrim_Source := Etype (Discrim_Source);
6982 Discrim_Source := Expression (Parent (Discrim_Source));
6985 elsif Nkind (Discrim_Source) = N_Identifier
6986 and then Nkind_In (Original_Node (Discrim_Source),
6987 N_Aggregate, N_Extension_Aggregate)
6989 Discrim_Source := Original_Node (Discrim_Source);
6991 elsif Nkind (Discrim_Source) = N_Explicit_Dereference and then
6992 Nkind (Original_Node (Discrim_Source)) = N_Function_Call
6994 Discrim_Source := Original_Node (Discrim_Source);
6997 Discrim_Source := Unqual_Conv (Discrim_Source);
6999 case Nkind (Discrim_Source) is
7000 when N_Defining_Identifier =>
7001 pragma Assert (Is_Composite_Type (Discrim_Source)
7002 and then Has_Discriminants (Discrim_Source)
7003 and then Is_Constrained (Discrim_Source));
7006 Discrim : Entity_Id :=
7007 First_Discriminant (Base_Type (R_Type));
7008 Disc_Elmt : Elmt_Id :=
7009 First_Elmt (Discriminant_Constraint
7013 if Ekind (Etype (Discrim)) =
7014 E_Anonymous_Access_Type
7016 Check_Against_Result_Level
7017 (Dynamic_Accessibility_Level (Node (Disc_Elmt)));
7020 Next_Elmt (Disc_Elmt);
7021 Next_Discriminant (Discrim);
7022 exit when not Present (Discrim);
7027 | N_Extension_Aggregate
7029 -- Unimplemented: extension aggregate case where discrims
7030 -- come from ancestor part, not extension part.
7033 Discrim : Entity_Id :=
7034 First_Discriminant (Base_Type (R_Type));
7036 Disc_Exp : Node_Id := Empty;
7038 Positionals_Exhausted
7039 : Boolean := not Present (Expressions
7042 function Associated_Expr
7043 (Comp_Id : Entity_Id;
7044 Associations : List_Id) return Node_Id;
7046 -- Given a component and a component associations list,
7047 -- locate the expression for that component; returns
7048 -- Empty if no such expression is found.
7050 ---------------------
7051 -- Associated_Expr --
7052 ---------------------
7054 function Associated_Expr
7055 (Comp_Id : Entity_Id;
7056 Associations : List_Id) return Node_Id
7062 -- Simple linear search seems ok here
7064 Assoc := First (Associations);
7065 while Present (Assoc) loop
7066 Choice := First (Choices (Assoc));
7067 while Present (Choice) loop
7068 if (Nkind (Choice) = N_Identifier
7069 and then Chars (Choice) = Chars (Comp_Id))
7070 or else (Nkind (Choice) = N_Others_Choice)
7072 return Expression (Assoc);
7082 end Associated_Expr;
7084 -- Start of processing for Expand_Simple_Function_Return
7087 if not Positionals_Exhausted then
7088 Disc_Exp := First (Expressions (Discrim_Source));
7092 if Positionals_Exhausted then
7096 Component_Associations (Discrim_Source));
7099 if Ekind (Etype (Discrim)) =
7100 E_Anonymous_Access_Type
7102 Check_Against_Result_Level
7103 (Dynamic_Accessibility_Level (Disc_Exp));
7106 Next_Discriminant (Discrim);
7107 exit when not Present (Discrim);
7109 if not Positionals_Exhausted then
7111 Positionals_Exhausted := not Present (Disc_Exp);
7116 when N_Function_Call =>
7118 -- No check needed (check performed by callee)
7124 Level : constant Node_Id :=
7125 Make_Integer_Literal (Loc,
7126 Object_Access_Level (Discrim_Source));
7129 -- Unimplemented: check for name prefix that includes
7130 -- a dereference of an access value with a dynamic
7131 -- accessibility level (e.g., an access param or a
7132 -- saooaaat) and use dynamic level in that case. For
7134 -- return Access_Param.all(Some_Index).Some_Component;
7137 Set_Etype (Level, Standard_Natural);
7138 Check_Against_Result_Level (Level);
7144 -- If we are returning an object that may not be bit-aligned, then copy
7145 -- the value into a temporary first. This copy may need to expand to a
7146 -- loop of component operations.
7148 if Is_Possibly_Unaligned_Slice (Exp)
7149 or else Is_Possibly_Unaligned_Object (Exp)
7152 ExpR : constant Node_Id := Relocate_Node (Exp);
7153 Tnn : constant Entity_Id := Make_Temporary (Loc, 'T', ExpR);
7156 Make_Object_Declaration (Loc,
7157 Defining_Identifier => Tnn,
7158 Constant_Present => True,
7159 Object_Definition => New_Occurrence_Of (R_Type, Loc),
7160 Expression => ExpR),
7161 Suppress => All_Checks);
7162 Rewrite (Exp, New_Occurrence_Of (Tnn, Loc));
7166 -- Call the _Postconditions procedure if the related function has
7167 -- contract assertions that need to be verified on exit.
7169 if Ekind (Scope_Id) = E_Function
7170 and then Present (Postconditions_Proc (Scope_Id))
7172 -- In the case of discriminated objects, we have created a
7173 -- constrained subtype above, and used the underlying type. This
7174 -- transformation is post-analysis and harmless, except that now the
7175 -- call to the post-condition will be analyzed and the type kinds
7178 if Nkind (Exp) = N_Unchecked_Type_Conversion
7179 and then Is_Private_Type (R_Type) /= Is_Private_Type (Etype (Exp))
7181 Rewrite (Exp, Expression (Relocate_Node (Exp)));
7184 -- We are going to reference the returned value twice in this case,
7185 -- once in the call to _Postconditions, and once in the actual return
7186 -- statement, but we can't have side effects happening twice.
7188 Force_Evaluation (Exp, Mode => Strict);
7190 -- Generate call to _Postconditions
7193 Make_Procedure_Call_Statement (Loc,
7195 New_Occurrence_Of (Postconditions_Proc (Scope_Id), Loc),
7196 Parameter_Associations => New_List (New_Copy_Tree (Exp))));
7199 -- Ada 2005 (AI-251): If this return statement corresponds with an
7200 -- simple return statement associated with an extended return statement
7201 -- and the type of the returned object is an interface then generate an
7202 -- implicit conversion to force displacement of the "this" pointer.
7204 if Ada_Version >= Ada_2005
7205 and then Comes_From_Extended_Return_Statement (N)
7206 and then Nkind (Expression (N)) = N_Identifier
7207 and then Is_Interface (Utyp)
7208 and then Utyp /= Underlying_Type (Exptyp)
7210 Rewrite (Exp, Convert_To (Utyp, Relocate_Node (Exp)));
7211 Analyze_And_Resolve (Exp);
7213 end Expand_Simple_Function_Return;
7215 --------------------------------------------
7216 -- Has_Unconstrained_Access_Discriminants --
7217 --------------------------------------------
7219 function Has_Unconstrained_Access_Discriminants
7220 (Subtyp : Entity_Id) return Boolean
7225 if Has_Discriminants (Subtyp)
7226 and then not Is_Constrained (Subtyp)
7228 Discr := First_Discriminant (Subtyp);
7229 while Present (Discr) loop
7230 if Ekind (Etype (Discr)) = E_Anonymous_Access_Type then
7234 Next_Discriminant (Discr);
7239 end Has_Unconstrained_Access_Discriminants;
7241 -----------------------------------
7242 -- Is_Build_In_Place_Result_Type --
7243 -----------------------------------
7245 function Is_Build_In_Place_Result_Type (Typ : Entity_Id) return Boolean is
7247 if not Expander_Active then
7251 -- In Ada 2005 all functions with an inherently limited return type
7252 -- must be handled using a build-in-place profile, including the case
7253 -- of a function with a limited interface result, where the function
7254 -- may return objects of nonlimited descendants.
7256 if Is_Limited_View (Typ) then
7257 return Ada_Version >= Ada_2005 and then not Debug_Flag_Dot_L;
7260 if Debug_Flag_Dot_9 then
7264 if Has_Interfaces (Typ) then
7269 T : Entity_Id := Typ;
7271 -- For T'Class, return True if it's True for T. This is necessary
7272 -- because a class-wide function might say "return F (...)", where
7273 -- F returns the corresponding specific type. We need a loop in
7274 -- case T is a subtype of a class-wide type.
7276 while Is_Class_Wide_Type (T) loop
7280 -- If this is a generic formal type in an instance, return True if
7281 -- it's True for the generic actual type.
7283 if Nkind (Parent (T)) = N_Subtype_Declaration
7284 and then Present (Generic_Parent_Type (Parent (T)))
7286 T := Entity (Subtype_Indication (Parent (T)));
7288 if Present (Full_View (T)) then
7293 if Present (Underlying_Type (T)) then
7294 T := Underlying_Type (T);
7299 -- So we can stop here in the debugger
7301 -- ???For now, enable build-in-place for a very narrow set of
7302 -- controlled types. Change "if True" to "if False" to
7303 -- experiment more controlled types. Eventually, we would
7304 -- like to enable build-in-place for all tagged types, all
7305 -- types that need finalization, and all caller-unknown-size
7309 Result := Is_Controlled (T)
7310 and then Present (Enclosing_Subprogram (T))
7311 and then not Is_Compilation_Unit (Enclosing_Subprogram (T))
7312 and then Ekind (Enclosing_Subprogram (T)) = E_Procedure;
7314 Result := Is_Controlled (T);
7321 end Is_Build_In_Place_Result_Type;
7323 --------------------------------
7324 -- Is_Build_In_Place_Function --
7325 --------------------------------
7327 function Is_Build_In_Place_Function (E : Entity_Id) return Boolean is
7329 -- This function is called from Expand_Subtype_From_Expr during
7330 -- semantic analysis, even when expansion is off. In those cases
7331 -- the build_in_place expansion will not take place.
7333 if not Expander_Active then
7337 -- For now we test whether E denotes a function or access-to-function
7338 -- type whose result subtype is inherently limited. Later this test
7339 -- may be revised to allow composite nonlimited types. Functions with
7340 -- a foreign convention or whose result type has a foreign convention
7343 if Ekind_In (E, E_Function, E_Generic_Function)
7344 or else (Ekind (E) = E_Subprogram_Type
7345 and then Etype (E) /= Standard_Void_Type)
7347 -- Note: If the function has a foreign convention, it cannot build
7348 -- its result in place, so you're on your own. On the other hand,
7349 -- if only the return type has a foreign convention, its layout is
7350 -- intended to be compatible with the other language, but the build-
7351 -- in place machinery can ensure that the object is not copied.
7353 return Is_Build_In_Place_Result_Type (Etype (E))
7354 and then not Has_Foreign_Convention (E)
7355 and then not Debug_Flag_Dot_L;
7360 end Is_Build_In_Place_Function;
7362 -------------------------------------
7363 -- Is_Build_In_Place_Function_Call --
7364 -------------------------------------
7366 function Is_Build_In_Place_Function_Call (N : Node_Id) return Boolean is
7367 Exp_Node : constant Node_Id := Unqual_Conv (N);
7368 Function_Id : Entity_Id;
7371 -- Return False if the expander is currently inactive, since awareness
7372 -- of build-in-place treatment is only relevant during expansion. Note
7373 -- that Is_Build_In_Place_Function, which is called as part of this
7374 -- function, is also conditioned this way, but we need to check here as
7375 -- well to avoid blowing up on processing protected calls when expansion
7376 -- is disabled (such as with -gnatc) since those would trip over the
7377 -- raise of Program_Error below.
7379 -- In SPARK mode, build-in-place calls are not expanded, so that we
7380 -- may end up with a call that is neither resolved to an entity, nor
7381 -- an indirect call.
7383 if not Expander_Active or else Nkind (Exp_Node) /= N_Function_Call then
7387 if Is_Entity_Name (Name (Exp_Node)) then
7388 Function_Id := Entity (Name (Exp_Node));
7390 -- In the case of an explicitly dereferenced call, use the subprogram
7391 -- type generated for the dereference.
7393 elsif Nkind (Name (Exp_Node)) = N_Explicit_Dereference then
7394 Function_Id := Etype (Name (Exp_Node));
7396 -- This may be a call to a protected function.
7398 elsif Nkind (Name (Exp_Node)) = N_Selected_Component then
7399 Function_Id := Etype (Entity (Selector_Name (Name (Exp_Node))));
7402 raise Program_Error;
7406 Result : constant Boolean := Is_Build_In_Place_Function (Function_Id);
7407 -- So we can stop here in the debugger
7411 end Is_Build_In_Place_Function_Call;
7413 -----------------------
7414 -- Freeze_Subprogram --
7415 -----------------------
7417 procedure Freeze_Subprogram (N : Node_Id) is
7418 Loc : constant Source_Ptr := Sloc (N);
7420 procedure Register_Predefined_DT_Entry (Prim : Entity_Id);
7421 -- (Ada 2005): Register a predefined primitive in all the secondary
7422 -- dispatch tables of its primitive type.
7424 ----------------------------------
7425 -- Register_Predefined_DT_Entry --
7426 ----------------------------------
7428 procedure Register_Predefined_DT_Entry (Prim : Entity_Id) is
7429 Iface_DT_Ptr : Elmt_Id;
7430 Tagged_Typ : Entity_Id;
7431 Thunk_Id : Entity_Id;
7432 Thunk_Code : Node_Id;
7435 Tagged_Typ := Find_Dispatching_Type (Prim);
7437 if No (Access_Disp_Table (Tagged_Typ))
7438 or else not Has_Interfaces (Tagged_Typ)
7439 or else not RTE_Available (RE_Interface_Tag)
7440 or else Restriction_Active (No_Dispatching_Calls)
7445 -- Skip the first two access-to-dispatch-table pointers since they
7446 -- leads to the primary dispatch table (predefined DT and user
7447 -- defined DT). We are only concerned with the secondary dispatch
7448 -- table pointers. Note that the access-to- dispatch-table pointer
7449 -- corresponds to the first implemented interface retrieved below.
7452 Next_Elmt (Next_Elmt (First_Elmt (Access_Disp_Table (Tagged_Typ))));
7454 while Present (Iface_DT_Ptr)
7455 and then Ekind (Node (Iface_DT_Ptr)) = E_Constant
7457 pragma Assert (Has_Thunks (Node (Iface_DT_Ptr)));
7458 Expand_Interface_Thunk (Prim, Thunk_Id, Thunk_Code);
7460 if Present (Thunk_Code) then
7461 Insert_Actions_After (N, New_List (
7464 Build_Set_Predefined_Prim_Op_Address (Loc,
7466 New_Occurrence_Of (Node (Next_Elmt (Iface_DT_Ptr)), Loc),
7467 Position => DT_Position (Prim),
7469 Unchecked_Convert_To (RTE (RE_Prim_Ptr),
7470 Make_Attribute_Reference (Loc,
7471 Prefix => New_Occurrence_Of (Thunk_Id, Loc),
7472 Attribute_Name => Name_Unrestricted_Access))),
7474 Build_Set_Predefined_Prim_Op_Address (Loc,
7477 (Node (Next_Elmt (Next_Elmt (Next_Elmt (Iface_DT_Ptr)))),
7479 Position => DT_Position (Prim),
7481 Unchecked_Convert_To (RTE (RE_Prim_Ptr),
7482 Make_Attribute_Reference (Loc,
7483 Prefix => New_Occurrence_Of (Prim, Loc),
7484 Attribute_Name => Name_Unrestricted_Access)))));
7487 -- Skip the tag of the predefined primitives dispatch table
7489 Next_Elmt (Iface_DT_Ptr);
7490 pragma Assert (Has_Thunks (Node (Iface_DT_Ptr)));
7492 -- Skip tag of the no-thunks dispatch table
7494 Next_Elmt (Iface_DT_Ptr);
7495 pragma Assert (not Has_Thunks (Node (Iface_DT_Ptr)));
7497 -- Skip tag of predefined primitives no-thunks dispatch table
7499 Next_Elmt (Iface_DT_Ptr);
7500 pragma Assert (not Has_Thunks (Node (Iface_DT_Ptr)));
7502 Next_Elmt (Iface_DT_Ptr);
7504 end Register_Predefined_DT_Entry;
7508 Subp : constant Entity_Id := Entity (N);
7510 -- Start of processing for Freeze_Subprogram
7513 -- We suppress the initialization of the dispatch table entry when
7514 -- not Tagged_Type_Expansion because the dispatching mechanism is
7515 -- handled internally by the target.
7517 if Is_Dispatching_Operation (Subp)
7518 and then not Is_Abstract_Subprogram (Subp)
7519 and then Present (DTC_Entity (Subp))
7520 and then Present (Scope (DTC_Entity (Subp)))
7521 and then Tagged_Type_Expansion
7522 and then not Restriction_Active (No_Dispatching_Calls)
7523 and then RTE_Available (RE_Tag)
7526 Typ : constant Entity_Id := Scope (DTC_Entity (Subp));
7529 -- Handle private overridden primitives
7531 if not Is_CPP_Class (Typ) then
7532 Check_Overriding_Operation (Subp);
7535 -- We assume that imported CPP primitives correspond with objects
7536 -- whose constructor is in the CPP side; therefore we don't need
7537 -- to generate code to register them in the dispatch table.
7539 if Is_CPP_Class (Typ) then
7542 -- Handle CPP primitives found in derivations of CPP_Class types.
7543 -- These primitives must have been inherited from some parent, and
7544 -- there is no need to register them in the dispatch table because
7545 -- Build_Inherit_Prims takes care of initializing these slots.
7547 elsif Is_Imported (Subp)
7548 and then (Convention (Subp) = Convention_CPP
7549 or else Convention (Subp) = Convention_C)
7553 -- Generate code to register the primitive in non statically
7554 -- allocated dispatch tables
7556 elsif not Building_Static_DT (Scope (DTC_Entity (Subp))) then
7558 -- When a primitive is frozen, enter its name in its dispatch
7561 if not Is_Interface (Typ)
7562 or else Present (Interface_Alias (Subp))
7564 if Is_Predefined_Dispatching_Operation (Subp) then
7565 Register_Predefined_DT_Entry (Subp);
7568 Insert_Actions_After (N,
7569 Register_Primitive (Loc, Prim => Subp));
7575 -- Mark functions that return by reference. Note that it cannot be part
7576 -- of the normal semantic analysis of the spec since the underlying
7577 -- returned type may not be known yet (for private types).
7580 Typ : constant Entity_Id := Etype (Subp);
7581 Utyp : constant Entity_Id := Underlying_Type (Typ);
7584 if Is_Limited_View (Typ) then
7585 Set_Returns_By_Ref (Subp);
7587 elsif Present (Utyp) and then CW_Or_Has_Controlled_Part (Utyp) then
7588 Set_Returns_By_Ref (Subp);
7592 -- Wnen freezing a null procedure, analyze its delayed aspects now
7593 -- because we may not have reached the end of the declarative list when
7594 -- delayed aspects are normally analyzed. This ensures that dispatching
7595 -- calls are properly rewritten when the generated _Postcondition
7596 -- procedure is analyzed in the null procedure body.
7598 if Nkind (Parent (Subp)) = N_Procedure_Specification
7599 and then Null_Present (Parent (Subp))
7601 Analyze_Entry_Or_Subprogram_Contract (Subp);
7603 end Freeze_Subprogram;
7605 ------------------------------
7606 -- Insert_Post_Call_Actions --
7607 ------------------------------
7609 procedure Insert_Post_Call_Actions (N : Node_Id; Post_Call : List_Id) is
7610 Context : constant Node_Id := Parent (N);
7613 if Is_Empty_List (Post_Call) then
7617 -- Cases where the call is not a member of a statement list. This
7618 -- includes the case where the call is an actual in another function
7619 -- call or indexing, i.e. an expression context as well.
7621 if not Is_List_Member (N)
7622 or else Nkind_In (Context, N_Function_Call, N_Indexed_Component)
7624 -- In Ada 2012 the call may be a function call in an expression
7625 -- (since OUT and IN OUT parameters are now allowed for such calls).
7626 -- The write-back of (in)-out parameters is handled by the back-end,
7627 -- but the constraint checks generated when subtypes of formal and
7628 -- actual don't match must be inserted in the form of assignments.
7630 if Nkind (Original_Node (N)) = N_Function_Call then
7631 pragma Assert (Ada_Version >= Ada_2012);
7632 -- Functions with '[in] out' parameters are only allowed in Ada
7635 -- We used to handle this by climbing up parents to a
7636 -- non-statement/declaration and then simply making a call to
7637 -- Insert_Actions_After (P, Post_Call), but that doesn't work
7638 -- for Ada 2012. If we are in the middle of an expression, e.g.
7639 -- the condition of an IF, this call would insert after the IF
7640 -- statement, which is much too late to be doing the write back.
7643 -- if Clobber (X) then
7644 -- Put_Line (X'Img);
7649 -- Now assume Clobber changes X, if we put the write back after
7650 -- the IF, the Put_Line gets the wrong value and the goto causes
7651 -- the write back to be skipped completely.
7653 -- To deal with this, we replace the call by
7656 -- Tnnn : constant function-result-type := function-call;
7657 -- Post_Call actions
7663 Loc : constant Source_Ptr := Sloc (N);
7664 Tnnn : constant Entity_Id := Make_Temporary (Loc, 'T');
7665 FRTyp : constant Entity_Id := Etype (N);
7666 Name : constant Node_Id := Relocate_Node (N);
7669 Prepend_To (Post_Call,
7670 Make_Object_Declaration (Loc,
7671 Defining_Identifier => Tnnn,
7672 Object_Definition => New_Occurrence_Of (FRTyp, Loc),
7673 Constant_Present => True,
7674 Expression => Name));
7677 Make_Expression_With_Actions (Loc,
7678 Actions => Post_Call,
7679 Expression => New_Occurrence_Of (Tnnn, Loc)));
7681 -- We don't want to just blindly call Analyze_And_Resolve
7682 -- because that would cause unwanted recursion on the call.
7683 -- So for a moment set the call as analyzed to prevent that
7684 -- recursion, and get the rest analyzed properly, then reset
7685 -- the analyzed flag, so our caller can continue.
7687 Set_Analyzed (Name, True);
7688 Analyze_And_Resolve (N, FRTyp);
7689 Set_Analyzed (Name, False);
7692 -- If not the special Ada 2012 case of a function call, then we must
7693 -- have the triggering statement of a triggering alternative or an
7694 -- entry call alternative, and we can add the post call stuff to the
7695 -- corresponding statement list.
7698 pragma Assert (Nkind_In (Context, N_Entry_Call_Alternative,
7699 N_Triggering_Alternative));
7701 if Is_Non_Empty_List (Statements (Context)) then
7702 Insert_List_Before_And_Analyze
7703 (First (Statements (Context)), Post_Call);
7705 Set_Statements (Context, Post_Call);
7709 -- A procedure call is always part of a declarative or statement list,
7710 -- however a function call may appear nested within a construct. Most
7711 -- cases of function call nesting are handled in the special case above.
7712 -- The only exception is when the function call acts as an actual in a
7713 -- procedure call. In this case the function call is in a list, but the
7714 -- post-call actions must be inserted after the procedure call.
7716 elsif Nkind (Context) = N_Procedure_Call_Statement then
7717 Insert_Actions_After (Context, Post_Call);
7719 -- Otherwise, normal case where N is in a statement sequence, just put
7720 -- the post-call stuff after the call statement.
7723 Insert_Actions_After (N, Post_Call);
7725 end Insert_Post_Call_Actions;
7727 -----------------------
7728 -- Is_Null_Procedure --
7729 -----------------------
7731 function Is_Null_Procedure (Subp : Entity_Id) return Boolean is
7732 Decl : constant Node_Id := Unit_Declaration_Node (Subp);
7735 if Ekind (Subp) /= E_Procedure then
7738 -- Check if this is a declared null procedure
7740 elsif Nkind (Decl) = N_Subprogram_Declaration then
7741 if not Null_Present (Specification (Decl)) then
7744 elsif No (Body_To_Inline (Decl)) then
7747 -- Check if the body contains only a null statement, followed by
7748 -- the return statement added during expansion.
7752 Orig_Bod : constant Node_Id := Body_To_Inline (Decl);
7758 if Nkind (Orig_Bod) /= N_Subprogram_Body then
7761 -- We must skip SCIL nodes because they are currently
7762 -- implemented as special N_Null_Statement nodes.
7766 (Statements (Handled_Statement_Sequence (Orig_Bod)));
7767 Stat2 := Next_Non_SCIL_Node (Stat);
7770 Is_Empty_List (Declarations (Orig_Bod))
7771 and then Nkind (Stat) = N_Null_Statement
7775 (Nkind (Stat2) = N_Simple_Return_Statement
7776 and then No (Next (Stat2))));
7784 end Is_Null_Procedure;
7786 -------------------------------------------
7787 -- Make_Build_In_Place_Call_In_Allocator --
7788 -------------------------------------------
7790 procedure Make_Build_In_Place_Call_In_Allocator
7791 (Allocator : Node_Id;
7792 Function_Call : Node_Id)
7794 Acc_Type : constant Entity_Id := Etype (Allocator);
7795 Loc : constant Source_Ptr := Sloc (Function_Call);
7796 Func_Call : Node_Id := Function_Call;
7797 Ref_Func_Call : Node_Id;
7798 Function_Id : Entity_Id;
7799 Result_Subt : Entity_Id;
7800 New_Allocator : Node_Id;
7801 Return_Obj_Access : Entity_Id; -- temp for function result
7802 Temp_Init : Node_Id; -- initial value of Return_Obj_Access
7803 Alloc_Form : BIP_Allocation_Form;
7804 Pool : Node_Id; -- nonnull if Alloc_Form = User_Storage_Pool
7805 Return_Obj_Actual : Node_Id; -- the temp.all, in caller-allocates case
7806 Chain : Entity_Id; -- activation chain, in case of tasks
7809 -- Step past qualification or unchecked conversion (the latter can occur
7810 -- in cases of calls to 'Input).
7812 if Nkind_In (Func_Call,
7813 N_Qualified_Expression,
7815 N_Unchecked_Type_Conversion)
7817 Func_Call := Expression (Func_Call);
7820 -- Mark the call as processed as a build-in-place call
7822 pragma Assert (not Is_Expanded_Build_In_Place_Call (Func_Call));
7823 Set_Is_Expanded_Build_In_Place_Call (Func_Call);
7825 if Is_Entity_Name (Name (Func_Call)) then
7826 Function_Id := Entity (Name (Func_Call));
7828 elsif Nkind (Name (Func_Call)) = N_Explicit_Dereference then
7829 Function_Id := Etype (Name (Func_Call));
7832 raise Program_Error;
7835 Result_Subt := Available_View (Etype (Function_Id));
7837 -- Create a temp for the function result. In the caller-allocates case,
7838 -- this will be initialized to the result of a new uninitialized
7839 -- allocator. Note: we do not use Allocator as the Related_Node of
7840 -- Return_Obj_Access in call to Make_Temporary below as this would
7841 -- create a sort of infinite "recursion".
7843 Return_Obj_Access := Make_Temporary (Loc, 'R');
7844 Set_Etype (Return_Obj_Access, Acc_Type);
7845 Set_Can_Never_Be_Null (Acc_Type, False);
7846 -- It gets initialized to null, so we can't have that
7848 -- When the result subtype is constrained, the return object is
7849 -- allocated on the caller side, and access to it is passed to the
7852 -- Here and in related routines, we must examine the full view of the
7853 -- type, because the view at the point of call may differ from that
7854 -- that in the function body, and the expansion mechanism depends on
7855 -- the characteristics of the full view.
7857 if Is_Constrained (Underlying_Type (Result_Subt)) then
7858 -- Replace the initialized allocator of form "new T'(Func (...))"
7859 -- with an uninitialized allocator of form "new T", where T is the
7860 -- result subtype of the called function. The call to the function
7861 -- is handled separately further below.
7864 Make_Allocator (Loc,
7865 Expression => New_Occurrence_Of (Result_Subt, Loc));
7866 Set_No_Initialization (New_Allocator);
7868 -- Copy attributes to new allocator. Note that the new allocator
7869 -- logically comes from source if the original one did, so copy the
7870 -- relevant flag. This ensures proper treatment of the restriction
7871 -- No_Implicit_Heap_Allocations in this case.
7873 Set_Storage_Pool (New_Allocator, Storage_Pool (Allocator));
7874 Set_Procedure_To_Call (New_Allocator, Procedure_To_Call (Allocator));
7875 Set_Comes_From_Source (New_Allocator, Comes_From_Source (Allocator));
7877 Rewrite (Allocator, New_Allocator);
7879 -- Initial value of the temp is the result of the uninitialized
7880 -- allocator. Unchecked_Convert is needed for T'Input where T is
7881 -- derived from a controlled type.
7883 Temp_Init := Relocate_Node (Allocator);
7886 (Function_Call, N_Type_Conversion, N_Unchecked_Type_Conversion)
7888 Temp_Init := Unchecked_Convert_To (Acc_Type, Temp_Init);
7891 -- Indicate that caller allocates, and pass in the return object
7893 Alloc_Form := Caller_Allocation;
7894 Pool := Make_Null (No_Location);
7895 Return_Obj_Actual :=
7896 Make_Unchecked_Type_Conversion (Loc,
7897 Subtype_Mark => New_Occurrence_Of (Result_Subt, Loc),
7899 Make_Explicit_Dereference (Loc,
7900 Prefix => New_Occurrence_Of (Return_Obj_Access, Loc)));
7902 -- When the result subtype is unconstrained, the function itself must
7903 -- perform the allocation of the return object, so we pass parameters
7909 -- Case of a user-defined storage pool. Pass an allocation parameter
7910 -- indicating that the function should allocate its result in the
7911 -- pool, and pass the pool. Use 'Unrestricted_Access because the
7912 -- pool may not be aliased.
7914 if Present (Associated_Storage_Pool (Acc_Type)) then
7915 Alloc_Form := User_Storage_Pool;
7917 Make_Attribute_Reference (Loc,
7920 (Associated_Storage_Pool (Acc_Type), Loc),
7921 Attribute_Name => Name_Unrestricted_Access);
7923 -- No user-defined pool; pass an allocation parameter indicating that
7924 -- the function should allocate its result on the heap.
7927 Alloc_Form := Global_Heap;
7928 Pool := Make_Null (No_Location);
7931 -- The caller does not provide the return object in this case, so we
7932 -- have to pass null for the object access actual.
7934 Return_Obj_Actual := Empty;
7937 -- Declare the temp object
7939 Insert_Action (Allocator,
7940 Make_Object_Declaration (Loc,
7941 Defining_Identifier => Return_Obj_Access,
7942 Object_Definition => New_Occurrence_Of (Acc_Type, Loc),
7943 Expression => Temp_Init));
7945 Ref_Func_Call := Make_Reference (Loc, Func_Call);
7947 -- Ada 2005 (AI-251): If the type of the allocator is an interface
7948 -- then generate an implicit conversion to force displacement of the
7951 if Is_Interface (Designated_Type (Acc_Type)) then
7954 OK_Convert_To (Acc_Type, Ref_Func_Call));
7956 -- If the types are incompatible, we need an unchecked conversion. Note
7957 -- that the full types will be compatible, but the types not visibly
7961 (Function_Call, N_Type_Conversion, N_Unchecked_Type_Conversion)
7963 Ref_Func_Call := Unchecked_Convert_To (Acc_Type, Ref_Func_Call);
7967 Assign : constant Node_Id :=
7968 Make_Assignment_Statement (Loc,
7969 Name => New_Occurrence_Of (Return_Obj_Access, Loc),
7970 Expression => Ref_Func_Call);
7971 -- Assign the result of the function call into the temp. In the
7972 -- caller-allocates case, this is overwriting the temp with its
7973 -- initial value, which has no effect. In the callee-allocates case,
7974 -- this is setting the temp to point to the object allocated by the
7975 -- callee. Unchecked_Convert is needed for T'Input where T is derived
7976 -- from a controlled type.
7979 -- Actions to be inserted. If there are no tasks, this is just the
7980 -- assignment statement. If the allocated object has tasks, we need
7981 -- to wrap the assignment in a block that activates them. The
7982 -- activation chain of that block must be passed to the function,
7983 -- rather than some outer chain.
7985 if Has_Task (Result_Subt) then
7986 Actions := New_List;
7987 Build_Task_Allocate_Block_With_Init_Stmts
7988 (Actions, Allocator, Init_Stmts => New_List (Assign));
7989 Chain := Activation_Chain_Entity (Last (Actions));
7991 Actions := New_List (Assign);
7995 Insert_Actions (Allocator, Actions);
7998 -- When the function has a controlling result, an allocation-form
7999 -- parameter must be passed indicating that the caller is allocating
8000 -- the result object. This is needed because such a function can be
8001 -- called as a dispatching operation and must be treated similarly
8002 -- to functions with unconstrained result subtypes.
8004 Add_Unconstrained_Actuals_To_Build_In_Place_Call
8005 (Func_Call, Function_Id, Alloc_Form, Pool_Actual => Pool);
8007 Add_Finalization_Master_Actual_To_Build_In_Place_Call
8008 (Func_Call, Function_Id, Acc_Type);
8010 Add_Task_Actuals_To_Build_In_Place_Call
8011 (Func_Call, Function_Id, Master_Actual => Master_Id (Acc_Type),
8014 -- Add an implicit actual to the function call that provides access
8015 -- to the allocated object. An unchecked conversion to the (specific)
8016 -- result subtype of the function is inserted to handle cases where
8017 -- the access type of the allocator has a class-wide designated type.
8019 Add_Access_Actual_To_Build_In_Place_Call
8020 (Func_Call, Function_Id, Return_Obj_Actual);
8022 -- Finally, replace the allocator node with a reference to the temp
8024 Rewrite (Allocator, New_Occurrence_Of (Return_Obj_Access, Loc));
8026 Analyze_And_Resolve (Allocator, Acc_Type);
8027 end Make_Build_In_Place_Call_In_Allocator;
8029 ---------------------------------------------------
8030 -- Make_Build_In_Place_Call_In_Anonymous_Context --
8031 ---------------------------------------------------
8033 procedure Make_Build_In_Place_Call_In_Anonymous_Context
8034 (Function_Call : Node_Id)
8036 Loc : constant Source_Ptr := Sloc (Function_Call);
8037 Func_Call : constant Node_Id := Unqual_Conv (Function_Call);
8038 Function_Id : Entity_Id;
8039 Result_Subt : Entity_Id;
8040 Return_Obj_Id : Entity_Id;
8041 Return_Obj_Decl : Entity_Id;
8044 -- If the call has already been processed to add build-in-place actuals
8045 -- then return. One place this can occur is for calls to build-in-place
8046 -- functions that occur within a call to a protected operation, where
8047 -- due to rewriting and expansion of the protected call there can be
8048 -- more than one call to Expand_Actuals for the same set of actuals.
8050 if Is_Expanded_Build_In_Place_Call (Func_Call) then
8054 -- Mark the call as processed as a build-in-place call
8056 Set_Is_Expanded_Build_In_Place_Call (Func_Call);
8058 if Is_Entity_Name (Name (Func_Call)) then
8059 Function_Id := Entity (Name (Func_Call));
8061 elsif Nkind (Name (Func_Call)) = N_Explicit_Dereference then
8062 Function_Id := Etype (Name (Func_Call));
8065 raise Program_Error;
8068 Result_Subt := Etype (Function_Id);
8070 -- If the build-in-place function returns a controlled object, then the
8071 -- object needs to be finalized immediately after the context. Since
8072 -- this case produces a transient scope, the servicing finalizer needs
8073 -- to name the returned object. Create a temporary which is initialized
8074 -- with the function call:
8076 -- Temp_Id : Func_Type := BIP_Func_Call;
8078 -- The initialization expression of the temporary will be rewritten by
8079 -- the expander using the appropriate mechanism in Make_Build_In_Place_
8080 -- Call_In_Object_Declaration.
8082 if Needs_Finalization (Result_Subt) then
8084 Temp_Id : constant Entity_Id := Make_Temporary (Loc, 'R');
8085 Temp_Decl : Node_Id;
8088 -- Reset the guard on the function call since the following does
8089 -- not perform actual call expansion.
8091 Set_Is_Expanded_Build_In_Place_Call (Func_Call, False);
8094 Make_Object_Declaration (Loc,
8095 Defining_Identifier => Temp_Id,
8096 Object_Definition =>
8097 New_Occurrence_Of (Result_Subt, Loc),
8099 New_Copy_Tree (Function_Call));
8101 Insert_Action (Function_Call, Temp_Decl);
8103 Rewrite (Function_Call, New_Occurrence_Of (Temp_Id, Loc));
8104 Analyze (Function_Call);
8107 -- When the result subtype is definite, an object of the subtype is
8108 -- declared and an access value designating it is passed as an actual.
8110 elsif Caller_Known_Size (Func_Call, Result_Subt) then
8112 -- Create a temporary object to hold the function result
8114 Return_Obj_Id := Make_Temporary (Loc, 'R');
8115 Set_Etype (Return_Obj_Id, Result_Subt);
8118 Make_Object_Declaration (Loc,
8119 Defining_Identifier => Return_Obj_Id,
8120 Aliased_Present => True,
8121 Object_Definition => New_Occurrence_Of (Result_Subt, Loc));
8123 Set_No_Initialization (Return_Obj_Decl);
8125 Insert_Action (Func_Call, Return_Obj_Decl);
8127 -- When the function has a controlling result, an allocation-form
8128 -- parameter must be passed indicating that the caller is allocating
8129 -- the result object. This is needed because such a function can be
8130 -- called as a dispatching operation and must be treated similarly
8131 -- to functions with unconstrained result subtypes.
8133 Add_Unconstrained_Actuals_To_Build_In_Place_Call
8134 (Func_Call, Function_Id, Alloc_Form => Caller_Allocation);
8136 Add_Finalization_Master_Actual_To_Build_In_Place_Call
8137 (Func_Call, Function_Id);
8139 Add_Task_Actuals_To_Build_In_Place_Call
8140 (Func_Call, Function_Id, Make_Identifier (Loc, Name_uMaster));
8142 -- Add an implicit actual to the function call that provides access
8143 -- to the caller's return object.
8145 Add_Access_Actual_To_Build_In_Place_Call
8146 (Func_Call, Function_Id, New_Occurrence_Of (Return_Obj_Id, Loc));
8148 -- When the result subtype is unconstrained, the function must allocate
8149 -- the return object in the secondary stack, so appropriate implicit
8150 -- parameters are added to the call to indicate that. A transient
8151 -- scope is established to ensure eventual cleanup of the result.
8154 -- Pass an allocation parameter indicating that the function should
8155 -- allocate its result on the secondary stack.
8157 Add_Unconstrained_Actuals_To_Build_In_Place_Call
8158 (Func_Call, Function_Id, Alloc_Form => Secondary_Stack);
8160 Add_Finalization_Master_Actual_To_Build_In_Place_Call
8161 (Func_Call, Function_Id);
8163 Add_Task_Actuals_To_Build_In_Place_Call
8164 (Func_Call, Function_Id, Make_Identifier (Loc, Name_uMaster));
8166 -- Pass a null value to the function since no return object is
8167 -- available on the caller side.
8169 Add_Access_Actual_To_Build_In_Place_Call
8170 (Func_Call, Function_Id, Empty);
8172 end Make_Build_In_Place_Call_In_Anonymous_Context;
8174 --------------------------------------------
8175 -- Make_Build_In_Place_Call_In_Assignment --
8176 --------------------------------------------
8178 procedure Make_Build_In_Place_Call_In_Assignment
8180 Function_Call : Node_Id)
8182 Func_Call : constant Node_Id := Unqual_Conv (Function_Call);
8183 Lhs : constant Node_Id := Name (Assign);
8184 Loc : constant Source_Ptr := Sloc (Function_Call);
8185 Func_Id : Entity_Id;
8188 Ptr_Typ : Entity_Id;
8189 Ptr_Typ_Decl : Node_Id;
8191 Result_Subt : Entity_Id;
8194 -- Mark the call as processed as a build-in-place call
8196 pragma Assert (not Is_Expanded_Build_In_Place_Call (Func_Call));
8197 Set_Is_Expanded_Build_In_Place_Call (Func_Call);
8199 if Is_Entity_Name (Name (Func_Call)) then
8200 Func_Id := Entity (Name (Func_Call));
8202 elsif Nkind (Name (Func_Call)) = N_Explicit_Dereference then
8203 Func_Id := Etype (Name (Func_Call));
8206 raise Program_Error;
8209 Result_Subt := Etype (Func_Id);
8211 -- When the result subtype is unconstrained, an additional actual must
8212 -- be passed to indicate that the caller is providing the return object.
8213 -- This parameter must also be passed when the called function has a
8214 -- controlling result, because dispatching calls to the function needs
8215 -- to be treated effectively the same as calls to class-wide functions.
8217 Add_Unconstrained_Actuals_To_Build_In_Place_Call
8218 (Func_Call, Func_Id, Alloc_Form => Caller_Allocation);
8220 Add_Finalization_Master_Actual_To_Build_In_Place_Call
8221 (Func_Call, Func_Id);
8223 Add_Task_Actuals_To_Build_In_Place_Call
8224 (Func_Call, Func_Id, Make_Identifier (Loc, Name_uMaster));
8226 -- Add an implicit actual to the function call that provides access to
8227 -- the caller's return object.
8229 Add_Access_Actual_To_Build_In_Place_Call
8232 Make_Unchecked_Type_Conversion (Loc,
8233 Subtype_Mark => New_Occurrence_Of (Result_Subt, Loc),
8234 Expression => Relocate_Node (Lhs)));
8236 -- Create an access type designating the function's result subtype
8238 Ptr_Typ := Make_Temporary (Loc, 'A');
8241 Make_Full_Type_Declaration (Loc,
8242 Defining_Identifier => Ptr_Typ,
8244 Make_Access_To_Object_Definition (Loc,
8245 All_Present => True,
8246 Subtype_Indication =>
8247 New_Occurrence_Of (Result_Subt, Loc)));
8248 Insert_After_And_Analyze (Assign, Ptr_Typ_Decl);
8250 -- Finally, create an access object initialized to a reference to the
8251 -- function call. We know this access value is non-null, so mark the
8252 -- entity accordingly to suppress junk access checks.
8254 New_Expr := Make_Reference (Loc, Relocate_Node (Func_Call));
8256 -- Add a conversion if it's the wrong type
8258 if Etype (New_Expr) /= Ptr_Typ then
8260 Make_Unchecked_Type_Conversion (Loc,
8261 New_Occurrence_Of (Ptr_Typ, Loc), New_Expr);
8264 Obj_Id := Make_Temporary (Loc, 'R', New_Expr);
8265 Set_Etype (Obj_Id, Ptr_Typ);
8266 Set_Is_Known_Non_Null (Obj_Id);
8269 Make_Object_Declaration (Loc,
8270 Defining_Identifier => Obj_Id,
8271 Object_Definition => New_Occurrence_Of (Ptr_Typ, Loc),
8272 Expression => New_Expr);
8273 Insert_After_And_Analyze (Ptr_Typ_Decl, Obj_Decl);
8275 Rewrite (Assign, Make_Null_Statement (Loc));
8276 end Make_Build_In_Place_Call_In_Assignment;
8278 ----------------------------------------------------
8279 -- Make_Build_In_Place_Call_In_Object_Declaration --
8280 ----------------------------------------------------
8282 procedure Make_Build_In_Place_Call_In_Object_Declaration
8283 (Obj_Decl : Node_Id;
8284 Function_Call : Node_Id)
8286 function Get_Function_Id (Func_Call : Node_Id) return Entity_Id;
8287 -- Get the value of Function_Id, below
8289 ---------------------
8290 -- Get_Function_Id --
8291 ---------------------
8293 function Get_Function_Id (Func_Call : Node_Id) return Entity_Id is
8295 if Is_Entity_Name (Name (Func_Call)) then
8296 return Entity (Name (Func_Call));
8298 elsif Nkind (Name (Func_Call)) = N_Explicit_Dereference then
8299 return Etype (Name (Func_Call));
8302 raise Program_Error;
8304 end Get_Function_Id;
8308 Func_Call : constant Node_Id := Unqual_Conv (Function_Call);
8309 Function_Id : constant Entity_Id := Get_Function_Id (Func_Call);
8310 Loc : constant Source_Ptr := Sloc (Function_Call);
8311 Obj_Loc : constant Source_Ptr := Sloc (Obj_Decl);
8312 Obj_Def_Id : constant Entity_Id := Defining_Identifier (Obj_Decl);
8313 Obj_Typ : constant Entity_Id := Etype (Obj_Def_Id);
8314 Encl_Func : constant Entity_Id := Enclosing_Subprogram (Obj_Def_Id);
8315 Result_Subt : constant Entity_Id := Etype (Function_Id);
8317 Call_Deref : Node_Id;
8318 Caller_Object : Node_Id;
8320 Designated_Type : Entity_Id;
8321 Fmaster_Actual : Node_Id := Empty;
8322 Pool_Actual : Node_Id;
8323 Ptr_Typ : Entity_Id;
8324 Ptr_Typ_Decl : Node_Id;
8325 Pass_Caller_Acc : Boolean := False;
8328 Definite : constant Boolean :=
8329 Caller_Known_Size (Func_Call, Result_Subt)
8330 and then not Is_Class_Wide_Type (Obj_Typ);
8331 -- In the case of "X : T'Class := F(...);", where F returns a
8332 -- Caller_Known_Size (specific) tagged type, we treat it as
8333 -- indefinite, because the code for the Definite case below sets the
8334 -- initialization expression of the object to Empty, which would be
8335 -- illegal Ada, and would cause gigi to misallocate X.
8337 -- Start of processing for Make_Build_In_Place_Call_In_Object_Declaration
8340 -- If the call has already been processed to add build-in-place actuals
8343 if Is_Expanded_Build_In_Place_Call (Func_Call) then
8347 -- Mark the call as processed as a build-in-place call
8349 Set_Is_Expanded_Build_In_Place_Call (Func_Call);
8351 -- Create an access type designating the function's result subtype.
8352 -- We use the type of the original call because it may be a call to an
8353 -- inherited operation, which the expansion has replaced with the parent
8354 -- operation that yields the parent type. Note that this access type
8355 -- must be declared before we establish a transient scope, so that it
8356 -- receives the proper accessibility level.
8358 if Is_Class_Wide_Type (Obj_Typ)
8359 and then not Is_Interface (Obj_Typ)
8360 and then not Is_Class_Wide_Type (Etype (Function_Call))
8362 Designated_Type := Obj_Typ;
8364 Designated_Type := Etype (Function_Call);
8367 Ptr_Typ := Make_Temporary (Loc, 'A');
8369 Make_Full_Type_Declaration (Loc,
8370 Defining_Identifier => Ptr_Typ,
8372 Make_Access_To_Object_Definition (Loc,
8373 All_Present => True,
8374 Subtype_Indication =>
8375 New_Occurrence_Of (Designated_Type, Loc)));
8377 -- The access type and its accompanying object must be inserted after
8378 -- the object declaration in the constrained case, so that the function
8379 -- call can be passed access to the object. In the indefinite case, or
8380 -- if the object declaration is for a return object, the access type and
8381 -- object must be inserted before the object, since the object
8382 -- declaration is rewritten to be a renaming of a dereference of the
8383 -- access object. Note: we need to freeze Ptr_Typ explicitly, because
8384 -- the result object is in a different (transient) scope, so won't cause
8387 if Definite and then not Is_Return_Object (Obj_Def_Id) then
8388 Insert_After_And_Analyze (Obj_Decl, Ptr_Typ_Decl);
8390 Insert_Action (Obj_Decl, Ptr_Typ_Decl);
8393 -- Force immediate freezing of Ptr_Typ because Res_Decl will be
8394 -- elaborated in an inner (transient) scope and thus won't cause
8395 -- freezing by itself. It's not an itype, but it needs to be frozen
8396 -- inside the current subprogram (see Freeze_Outside in freeze.adb).
8398 Freeze_Itype (Ptr_Typ, Ptr_Typ_Decl);
8400 -- If the object is a return object of an enclosing build-in-place
8401 -- function, then the implicit build-in-place parameters of the
8402 -- enclosing function are simply passed along to the called function.
8403 -- (Unfortunately, this won't cover the case of extension aggregates
8404 -- where the ancestor part is a build-in-place indefinite function
8405 -- call that should be passed along the caller's parameters.
8406 -- Currently those get mishandled by reassigning the result of the
8407 -- call to the aggregate return object, when the call result should
8408 -- really be directly built in place in the aggregate and not in a
8411 if Is_Return_Object (Obj_Def_Id) then
8412 Pass_Caller_Acc := True;
8414 -- When the enclosing function has a BIP_Alloc_Form formal then we
8415 -- pass it along to the callee (such as when the enclosing function
8416 -- has an unconstrained or tagged result type).
8418 if Needs_BIP_Alloc_Form (Encl_Func) then
8419 if RTE_Available (RE_Root_Storage_Pool_Ptr) then
8422 (Build_In_Place_Formal
8423 (Encl_Func, BIP_Storage_Pool), Loc);
8425 -- The build-in-place pool formal is not built on e.g. ZFP
8428 Pool_Actual := Empty;
8431 Add_Unconstrained_Actuals_To_Build_In_Place_Call
8432 (Function_Call => Func_Call,
8433 Function_Id => Function_Id,
8436 (Build_In_Place_Formal (Encl_Func, BIP_Alloc_Form), Loc),
8437 Pool_Actual => Pool_Actual);
8439 -- Otherwise, if enclosing function has a definite result subtype,
8440 -- then caller allocation will be used.
8443 Add_Unconstrained_Actuals_To_Build_In_Place_Call
8444 (Func_Call, Function_Id, Alloc_Form => Caller_Allocation);
8447 if Needs_BIP_Finalization_Master (Encl_Func) then
8450 (Build_In_Place_Formal
8451 (Encl_Func, BIP_Finalization_Master), Loc);
8454 -- Retrieve the BIPacc formal from the enclosing function and convert
8455 -- it to the access type of the callee's BIP_Object_Access formal.
8458 Make_Unchecked_Type_Conversion (Loc,
8461 (Etype (Build_In_Place_Formal
8462 (Function_Id, BIP_Object_Access)),
8466 (Build_In_Place_Formal (Encl_Func, BIP_Object_Access),
8469 -- In the definite case, add an implicit actual to the function call
8470 -- that provides access to the declared object. An unchecked conversion
8471 -- to the (specific) result type of the function is inserted to handle
8472 -- the case where the object is declared with a class-wide type.
8476 Make_Unchecked_Type_Conversion (Loc,
8477 Subtype_Mark => New_Occurrence_Of (Result_Subt, Loc),
8478 Expression => New_Occurrence_Of (Obj_Def_Id, Loc));
8480 -- When the function has a controlling result, an allocation-form
8481 -- parameter must be passed indicating that the caller is allocating
8482 -- the result object. This is needed because such a function can be
8483 -- called as a dispatching operation and must be treated similarly to
8484 -- functions with indefinite result subtypes.
8486 Add_Unconstrained_Actuals_To_Build_In_Place_Call
8487 (Func_Call, Function_Id, Alloc_Form => Caller_Allocation);
8489 -- The allocation for indefinite library-level objects occurs on the
8490 -- heap as opposed to the secondary stack. This accommodates DLLs where
8491 -- the secondary stack is destroyed after each library unload. This is a
8492 -- hybrid mechanism where a stack-allocated object lives on the heap.
8494 elsif Is_Library_Level_Entity (Obj_Def_Id)
8495 and then not Restriction_Active (No_Implicit_Heap_Allocations)
8497 Add_Unconstrained_Actuals_To_Build_In_Place_Call
8498 (Func_Call, Function_Id, Alloc_Form => Global_Heap);
8499 Caller_Object := Empty;
8501 -- Create a finalization master for the access result type to ensure
8502 -- that the heap allocation can properly chain the object and later
8503 -- finalize it when the library unit goes out of scope.
8505 if Needs_Finalization (Etype (Func_Call)) then
8506 Build_Finalization_Master
8508 For_Lib_Level => True,
8509 Insertion_Node => Ptr_Typ_Decl);
8512 Make_Attribute_Reference (Loc,
8514 New_Occurrence_Of (Finalization_Master (Ptr_Typ), Loc),
8515 Attribute_Name => Name_Unrestricted_Access);
8518 -- In other indefinite cases, pass an indication to do the allocation on
8519 -- the secondary stack and set Caller_Object to Empty so that a null
8520 -- value will be passed for the caller's object address. A transient
8521 -- scope is established to ensure eventual cleanup of the result.
8524 Add_Unconstrained_Actuals_To_Build_In_Place_Call
8525 (Func_Call, Function_Id, Alloc_Form => Secondary_Stack);
8526 Caller_Object := Empty;
8528 Establish_Transient_Scope (Obj_Decl, Sec_Stack => True);
8531 -- Pass along any finalization master actual, which is needed in the
8532 -- case where the called function initializes a return object of an
8533 -- enclosing build-in-place function.
8535 Add_Finalization_Master_Actual_To_Build_In_Place_Call
8536 (Func_Call => Func_Call,
8537 Func_Id => Function_Id,
8538 Master_Exp => Fmaster_Actual);
8540 if Nkind (Parent (Obj_Decl)) = N_Extended_Return_Statement
8541 and then Has_Task (Result_Subt)
8543 -- Here we're passing along the master that was passed in to this
8546 Add_Task_Actuals_To_Build_In_Place_Call
8547 (Func_Call, Function_Id,
8550 (Build_In_Place_Formal (Encl_Func, BIP_Task_Master), Loc));
8553 Add_Task_Actuals_To_Build_In_Place_Call
8554 (Func_Call, Function_Id, Make_Identifier (Loc, Name_uMaster));
8557 Add_Access_Actual_To_Build_In_Place_Call
8561 Is_Access => Pass_Caller_Acc);
8563 -- Finally, create an access object initialized to a reference to the
8564 -- function call. We know this access value cannot be null, so mark the
8565 -- entity accordingly to suppress the access check.
8567 Def_Id := Make_Temporary (Loc, 'R', Func_Call);
8568 Set_Etype (Def_Id, Ptr_Typ);
8569 Set_Is_Known_Non_Null (Def_Id);
8571 if Nkind_In (Function_Call, N_Type_Conversion,
8572 N_Unchecked_Type_Conversion)
8575 Make_Object_Declaration (Loc,
8576 Defining_Identifier => Def_Id,
8577 Constant_Present => True,
8578 Object_Definition => New_Occurrence_Of (Ptr_Typ, Loc),
8580 Make_Unchecked_Type_Conversion (Loc,
8581 New_Occurrence_Of (Ptr_Typ, Loc),
8582 Make_Reference (Loc, Relocate_Node (Func_Call))));
8585 Make_Object_Declaration (Loc,
8586 Defining_Identifier => Def_Id,
8587 Constant_Present => True,
8588 Object_Definition => New_Occurrence_Of (Ptr_Typ, Loc),
8590 Make_Reference (Loc, Relocate_Node (Func_Call)));
8593 Insert_After_And_Analyze (Ptr_Typ_Decl, Res_Decl);
8595 -- If the result subtype of the called function is definite and is not
8596 -- itself the return expression of an enclosing BIP function, then mark
8597 -- the object as having no initialization.
8599 if Definite and then not Is_Return_Object (Obj_Def_Id) then
8601 -- The related object declaration is encased in a transient block
8602 -- because the build-in-place function call contains at least one
8603 -- nested function call that produces a controlled transient
8606 -- Obj : ... := BIP_Func_Call (Ctrl_Func_Call);
8608 -- Since the build-in-place expansion decouples the call from the
8609 -- object declaration, the finalization machinery lacks the context
8610 -- which prompted the generation of the transient block. To resolve
8611 -- this scenario, store the build-in-place call.
8613 if Scope_Is_Transient and then Node_To_Be_Wrapped = Obj_Decl then
8614 Set_BIP_Initialization_Call (Obj_Def_Id, Res_Decl);
8617 Set_Expression (Obj_Decl, Empty);
8618 Set_No_Initialization (Obj_Decl);
8620 -- In case of an indefinite result subtype, or if the call is the
8621 -- return expression of an enclosing BIP function, rewrite the object
8622 -- declaration as an object renaming where the renamed object is a
8623 -- dereference of <function_Call>'reference:
8625 -- Obj : Subt renames <function_call>'Ref.all;
8629 Make_Explicit_Dereference (Obj_Loc,
8630 Prefix => New_Occurrence_Of (Def_Id, Obj_Loc));
8633 Make_Object_Renaming_Declaration (Obj_Loc,
8634 Defining_Identifier => Make_Temporary (Obj_Loc, 'D'),
8636 New_Occurrence_Of (Designated_Type, Obj_Loc),
8637 Name => Call_Deref));
8639 -- At this point, Defining_Identifier (Obj_Decl) is no longer equal
8642 Set_Renamed_Object (Defining_Identifier (Obj_Decl), Call_Deref);
8644 -- If the original entity comes from source, then mark the new
8645 -- entity as needing debug information, even though it's defined
8646 -- by a generated renaming that does not come from source, so that
8647 -- the Materialize_Entity flag will be set on the entity when
8648 -- Debug_Renaming_Declaration is called during analysis.
8650 if Comes_From_Source (Obj_Def_Id) then
8651 Set_Debug_Info_Needed (Defining_Identifier (Obj_Decl));
8655 Replace_Renaming_Declaration_Id
8656 (Obj_Decl, Original_Node (Obj_Decl));
8658 end Make_Build_In_Place_Call_In_Object_Declaration;
8660 -------------------------------------------------
8661 -- Make_Build_In_Place_Iface_Call_In_Allocator --
8662 -------------------------------------------------
8664 procedure Make_Build_In_Place_Iface_Call_In_Allocator
8665 (Allocator : Node_Id;
8666 Function_Call : Node_Id)
8668 BIP_Func_Call : constant Node_Id :=
8669 Unqual_BIP_Iface_Function_Call (Function_Call);
8670 Loc : constant Source_Ptr := Sloc (Function_Call);
8672 Anon_Type : Entity_Id;
8677 -- No action of the call has already been processed
8679 if Is_Expanded_Build_In_Place_Call (BIP_Func_Call) then
8683 Tmp_Id := Make_Temporary (Loc, 'D');
8685 -- Insert a temporary before N initialized with the BIP function call
8686 -- without its enclosing type conversions and analyze it without its
8687 -- expansion. This temporary facilitates us reusing the BIP machinery,
8688 -- which takes care of adding the extra build-in-place actuals and
8689 -- transforms this object declaration into an object renaming
8692 Anon_Type := Create_Itype (E_Anonymous_Access_Type, Function_Call);
8693 Set_Directly_Designated_Type (Anon_Type, Etype (BIP_Func_Call));
8694 Set_Etype (Anon_Type, Anon_Type);
8697 Make_Object_Declaration (Loc,
8698 Defining_Identifier => Tmp_Id,
8699 Object_Definition => New_Occurrence_Of (Anon_Type, Loc),
8701 Make_Allocator (Loc,
8703 Make_Qualified_Expression (Loc,
8705 New_Occurrence_Of (Etype (BIP_Func_Call), Loc),
8706 Expression => New_Copy_Tree (BIP_Func_Call))));
8708 Expander_Mode_Save_And_Set (False);
8709 Insert_Action (Allocator, Tmp_Decl);
8710 Expander_Mode_Restore;
8712 Make_Build_In_Place_Call_In_Allocator
8713 (Allocator => Expression (Tmp_Decl),
8714 Function_Call => Expression (Expression (Tmp_Decl)));
8716 Rewrite (Allocator, New_Occurrence_Of (Tmp_Id, Loc));
8717 end Make_Build_In_Place_Iface_Call_In_Allocator;
8719 ---------------------------------------------------------
8720 -- Make_Build_In_Place_Iface_Call_In_Anonymous_Context --
8721 ---------------------------------------------------------
8723 procedure Make_Build_In_Place_Iface_Call_In_Anonymous_Context
8724 (Function_Call : Node_Id)
8726 BIP_Func_Call : constant Node_Id :=
8727 Unqual_BIP_Iface_Function_Call (Function_Call);
8728 Loc : constant Source_Ptr := Sloc (Function_Call);
8734 -- No action of the call has already been processed
8736 if Is_Expanded_Build_In_Place_Call (BIP_Func_Call) then
8740 pragma Assert (Needs_Finalization (Etype (BIP_Func_Call)));
8742 -- Insert a temporary before the call initialized with function call to
8743 -- reuse the BIP machinery which takes care of adding the extra build-in
8744 -- place actuals and transforms this object declaration into an object
8745 -- renaming declaration.
8747 Tmp_Id := Make_Temporary (Loc, 'D');
8750 Make_Object_Declaration (Loc,
8751 Defining_Identifier => Tmp_Id,
8752 Object_Definition =>
8753 New_Occurrence_Of (Etype (Function_Call), Loc),
8754 Expression => Relocate_Node (Function_Call));
8756 Expander_Mode_Save_And_Set (False);
8757 Insert_Action (Function_Call, Tmp_Decl);
8758 Expander_Mode_Restore;
8760 Make_Build_In_Place_Iface_Call_In_Object_Declaration
8761 (Obj_Decl => Tmp_Decl,
8762 Function_Call => Expression (Tmp_Decl));
8763 end Make_Build_In_Place_Iface_Call_In_Anonymous_Context;
8765 ----------------------------------------------------------
8766 -- Make_Build_In_Place_Iface_Call_In_Object_Declaration --
8767 ----------------------------------------------------------
8769 procedure Make_Build_In_Place_Iface_Call_In_Object_Declaration
8770 (Obj_Decl : Node_Id;
8771 Function_Call : Node_Id)
8773 BIP_Func_Call : constant Node_Id :=
8774 Unqual_BIP_Iface_Function_Call (Function_Call);
8775 Loc : constant Source_Ptr := Sloc (Function_Call);
8776 Obj_Id : constant Entity_Id := Defining_Entity (Obj_Decl);
8782 -- No action of the call has already been processed
8784 if Is_Expanded_Build_In_Place_Call (BIP_Func_Call) then
8788 Tmp_Id := Make_Temporary (Loc, 'D');
8790 -- Insert a temporary before N initialized with the BIP function call
8791 -- without its enclosing type conversions and analyze it without its
8792 -- expansion. This temporary facilitates us reusing the BIP machinery,
8793 -- which takes care of adding the extra build-in-place actuals and
8794 -- transforms this object declaration into an object renaming
8798 Make_Object_Declaration (Loc,
8799 Defining_Identifier => Tmp_Id,
8800 Object_Definition =>
8801 New_Occurrence_Of (Etype (BIP_Func_Call), Loc),
8802 Expression => New_Copy_Tree (BIP_Func_Call));
8804 Expander_Mode_Save_And_Set (False);
8805 Insert_Action (Obj_Decl, Tmp_Decl);
8806 Expander_Mode_Restore;
8808 Make_Build_In_Place_Call_In_Object_Declaration
8809 (Obj_Decl => Tmp_Decl,
8810 Function_Call => Expression (Tmp_Decl));
8812 pragma Assert (Nkind (Tmp_Decl) = N_Object_Renaming_Declaration);
8814 -- Replace the original build-in-place function call by a reference to
8815 -- the resulting temporary object renaming declaration. In this way,
8816 -- all the interface conversions performed in the original Function_Call
8817 -- on the build-in-place object are preserved.
8819 Rewrite (BIP_Func_Call, New_Occurrence_Of (Tmp_Id, Loc));
8821 -- Replace the original object declaration by an internal object
8822 -- renaming declaration. This leaves the generated code more clean (the
8823 -- build-in-place function call in an object renaming declaration and
8824 -- displacements of the pointer to the build-in-place object in another
8825 -- renaming declaration) and allows us to invoke the routine that takes
8826 -- care of replacing the identifier of the renaming declaration (routine
8827 -- originally developed for the regular build-in-place management).
8830 Make_Object_Renaming_Declaration (Loc,
8831 Defining_Identifier => Make_Temporary (Loc, 'D'),
8832 Subtype_Mark => New_Occurrence_Of (Etype (Obj_Id), Loc),
8833 Name => Function_Call));
8836 Replace_Renaming_Declaration_Id (Obj_Decl, Original_Node (Obj_Decl));
8837 end Make_Build_In_Place_Iface_Call_In_Object_Declaration;
8839 --------------------------------------------
8840 -- Make_CPP_Constructor_Call_In_Allocator --
8841 --------------------------------------------
8843 procedure Make_CPP_Constructor_Call_In_Allocator
8844 (Allocator : Node_Id;
8845 Function_Call : Node_Id)
8847 Loc : constant Source_Ptr := Sloc (Function_Call);
8848 Acc_Type : constant Entity_Id := Etype (Allocator);
8849 Function_Id : constant Entity_Id := Entity (Name (Function_Call));
8850 Result_Subt : constant Entity_Id := Available_View (Etype (Function_Id));
8852 New_Allocator : Node_Id;
8853 Return_Obj_Access : Entity_Id;
8857 pragma Assert (Nkind (Allocator) = N_Allocator
8858 and then Nkind (Function_Call) = N_Function_Call);
8859 pragma Assert (Convention (Function_Id) = Convention_CPP
8860 and then Is_Constructor (Function_Id));
8861 pragma Assert (Is_Constrained (Underlying_Type (Result_Subt)));
8863 -- Replace the initialized allocator of form "new T'(Func (...))" with
8864 -- an uninitialized allocator of form "new T", where T is the result
8865 -- subtype of the called function. The call to the function is handled
8866 -- separately further below.
8869 Make_Allocator (Loc,
8870 Expression => New_Occurrence_Of (Result_Subt, Loc));
8871 Set_No_Initialization (New_Allocator);
8873 -- Copy attributes to new allocator. Note that the new allocator
8874 -- logically comes from source if the original one did, so copy the
8875 -- relevant flag. This ensures proper treatment of the restriction
8876 -- No_Implicit_Heap_Allocations in this case.
8878 Set_Storage_Pool (New_Allocator, Storage_Pool (Allocator));
8879 Set_Procedure_To_Call (New_Allocator, Procedure_To_Call (Allocator));
8880 Set_Comes_From_Source (New_Allocator, Comes_From_Source (Allocator));
8882 Rewrite (Allocator, New_Allocator);
8884 -- Create a new access object and initialize it to the result of the
8885 -- new uninitialized allocator. Note: we do not use Allocator as the
8886 -- Related_Node of Return_Obj_Access in call to Make_Temporary below
8887 -- as this would create a sort of infinite "recursion".
8889 Return_Obj_Access := Make_Temporary (Loc, 'R');
8890 Set_Etype (Return_Obj_Access, Acc_Type);
8893 -- Rnnn : constant ptr_T := new (T);
8894 -- Init (Rnn.all,...);
8897 Make_Object_Declaration (Loc,
8898 Defining_Identifier => Return_Obj_Access,
8899 Constant_Present => True,
8900 Object_Definition => New_Occurrence_Of (Acc_Type, Loc),
8901 Expression => Relocate_Node (Allocator));
8902 Insert_Action (Allocator, Tmp_Obj);
8904 Insert_List_After_And_Analyze (Tmp_Obj,
8905 Build_Initialization_Call (Loc,
8907 Make_Explicit_Dereference (Loc,
8908 Prefix => New_Occurrence_Of (Return_Obj_Access, Loc)),
8909 Typ => Etype (Function_Id),
8910 Constructor_Ref => Function_Call));
8912 -- Finally, replace the allocator node with a reference to the result of
8913 -- the function call itself (which will effectively be an access to the
8914 -- object created by the allocator).
8916 Rewrite (Allocator, New_Occurrence_Of (Return_Obj_Access, Loc));
8918 -- Ada 2005 (AI-251): If the type of the allocator is an interface then
8919 -- generate an implicit conversion to force displacement of the "this"
8922 if Is_Interface (Designated_Type (Acc_Type)) then
8923 Rewrite (Allocator, Convert_To (Acc_Type, Relocate_Node (Allocator)));
8926 Analyze_And_Resolve (Allocator, Acc_Type);
8927 end Make_CPP_Constructor_Call_In_Allocator;
8929 -----------------------------------
8930 -- Needs_BIP_Finalization_Master --
8931 -----------------------------------
8933 function Needs_BIP_Finalization_Master
8934 (Func_Id : Entity_Id) return Boolean
8936 pragma Assert (Is_Build_In_Place_Function (Func_Id));
8937 Func_Typ : constant Entity_Id := Underlying_Type (Etype (Func_Id));
8939 -- A formal giving the finalization master is needed for build-in-place
8940 -- functions whose result type needs finalization or is a tagged type.
8941 -- Tagged primitive build-in-place functions need such a formal because
8942 -- they can be called by a dispatching call, and extensions may require
8943 -- finalization even if the root type doesn't. This means they're also
8944 -- needed for tagged nonprimitive build-in-place functions with tagged
8945 -- results, since such functions can be called via access-to-function
8946 -- types, and those can be used to call primitives, so masters have to
8947 -- be passed to all such build-in-place functions, primitive or not.
8950 not Restriction_Active (No_Finalization)
8951 and then (Needs_Finalization (Func_Typ)
8952 or else Is_Tagged_Type (Func_Typ));
8953 end Needs_BIP_Finalization_Master;
8955 --------------------------
8956 -- Needs_BIP_Alloc_Form --
8957 --------------------------
8959 function Needs_BIP_Alloc_Form (Func_Id : Entity_Id) return Boolean is
8960 pragma Assert (Is_Build_In_Place_Function (Func_Id));
8961 Func_Typ : constant Entity_Id := Underlying_Type (Etype (Func_Id));
8963 return not Is_Constrained (Func_Typ) or else Is_Tagged_Type (Func_Typ);
8964 end Needs_BIP_Alloc_Form;
8966 --------------------------------------
8967 -- Needs_Result_Accessibility_Level --
8968 --------------------------------------
8970 function Needs_Result_Accessibility_Level
8971 (Func_Id : Entity_Id) return Boolean
8973 Func_Typ : constant Entity_Id := Underlying_Type (Etype (Func_Id));
8975 function Has_Unconstrained_Access_Discriminant_Component
8976 (Comp_Typ : Entity_Id) return Boolean;
8977 -- Returns True if any component of the type has an unconstrained access
8980 -----------------------------------------------------
8981 -- Has_Unconstrained_Access_Discriminant_Component --
8982 -----------------------------------------------------
8984 function Has_Unconstrained_Access_Discriminant_Component
8985 (Comp_Typ : Entity_Id) return Boolean
8988 if not Is_Limited_Type (Comp_Typ) then
8991 -- Only limited types can have access discriminants with
8994 elsif Has_Unconstrained_Access_Discriminants (Comp_Typ) then
8997 elsif Is_Array_Type (Comp_Typ) then
8998 return Has_Unconstrained_Access_Discriminant_Component
8999 (Underlying_Type (Component_Type (Comp_Typ)));
9001 elsif Is_Record_Type (Comp_Typ) then
9006 Comp := First_Component (Comp_Typ);
9007 while Present (Comp) loop
9008 if Has_Unconstrained_Access_Discriminant_Component
9009 (Underlying_Type (Etype (Comp)))
9014 Next_Component (Comp);
9020 end Has_Unconstrained_Access_Discriminant_Component;
9022 Feature_Disabled : constant Boolean := True;
9025 -- Start of processing for Needs_Result_Accessibility_Level
9028 -- False if completion unavailable (how does this happen???)
9030 if not Present (Func_Typ) then
9033 elsif Feature_Disabled then
9036 -- False if not a function, also handle enum-lit renames case
9038 elsif Func_Typ = Standard_Void_Type
9039 or else Is_Scalar_Type (Func_Typ)
9043 -- Handle a corner case, a cross-dialect subp renaming. For example,
9044 -- an Ada 2012 renaming of an Ada 2005 subprogram. This can occur when
9045 -- an Ada 2005 (or earlier) unit references predefined run-time units.
9047 elsif Present (Alias (Func_Id)) then
9049 -- Unimplemented: a cross-dialect subp renaming which does not set
9050 -- the Alias attribute (e.g., a rename of a dereference of an access
9051 -- to subprogram value). ???
9053 return Present (Extra_Accessibility_Of_Result (Alias (Func_Id)));
9055 -- Remaining cases require Ada 2012 mode
9057 elsif Ada_Version < Ada_2012 then
9060 elsif Ekind (Func_Typ) = E_Anonymous_Access_Type
9061 or else Is_Tagged_Type (Func_Typ)
9063 -- In the case of, say, a null tagged record result type, the need
9064 -- for this extra parameter might not be obvious. This function
9065 -- returns True for all tagged types for compatibility reasons.
9066 -- A function with, say, a tagged null controlling result type might
9067 -- be overridden by a primitive of an extension having an access
9068 -- discriminant and the overrider and overridden must have compatible
9069 -- calling conventions (including implicitly declared parameters).
9070 -- Similarly, values of one access-to-subprogram type might designate
9071 -- both a primitive subprogram of a given type and a function
9072 -- which is, for example, not a primitive subprogram of any type.
9073 -- Again, this requires calling convention compatibility.
9074 -- It might be possible to solve these issues by introducing
9075 -- wrappers, but that is not the approach that was chosen.
9079 elsif Has_Unconstrained_Access_Discriminants (Func_Typ) then
9082 elsif Has_Unconstrained_Access_Discriminant_Component (Func_Typ) then
9085 -- False for all other cases
9090 end Needs_Result_Accessibility_Level;
9092 -------------------------------------
9093 -- Replace_Renaming_Declaration_Id --
9094 -------------------------------------
9096 procedure Replace_Renaming_Declaration_Id
9097 (New_Decl : Node_Id;
9098 Orig_Decl : Node_Id)
9100 New_Id : constant Entity_Id := Defining_Entity (New_Decl);
9101 Orig_Id : constant Entity_Id := Defining_Entity (Orig_Decl);
9104 Set_Chars (New_Id, Chars (Orig_Id));
9106 -- Swap next entity links in preparation for exchanging entities
9109 Next_Id : constant Entity_Id := Next_Entity (New_Id);
9111 Set_Next_Entity (New_Id, Next_Entity (Orig_Id));
9112 Set_Next_Entity (Orig_Id, Next_Id);
9115 Set_Homonym (New_Id, Homonym (Orig_Id));
9116 Exchange_Entities (New_Id, Orig_Id);
9118 -- Preserve source indication of original declaration, so that xref
9119 -- information is properly generated for the right entity.
9121 Preserve_Comes_From_Source (New_Decl, Orig_Decl);
9122 Preserve_Comes_From_Source (Orig_Id, Orig_Decl);
9124 Set_Comes_From_Source (New_Id, False);
9125 end Replace_Renaming_Declaration_Id;
9127 ---------------------------------
9128 -- Rewrite_Function_Call_For_C --
9129 ---------------------------------
9131 procedure Rewrite_Function_Call_For_C (N : Node_Id) is
9132 Orig_Func : constant Entity_Id := Entity (Name (N));
9133 Func_Id : constant Entity_Id := Ultimate_Alias (Orig_Func);
9134 Par : constant Node_Id := Parent (N);
9135 Proc_Id : constant Entity_Id := Corresponding_Procedure (Func_Id);
9136 Loc : constant Source_Ptr := Sloc (Par);
9138 Last_Actual : Node_Id;
9139 Last_Formal : Entity_Id;
9141 -- Start of processing for Rewrite_Function_Call_For_C
9144 -- The actuals may be given by named associations, so the added actual
9145 -- that is the target of the return value of the call must be a named
9146 -- association as well, so we retrieve the name of the generated
9149 Last_Formal := First_Formal (Proc_Id);
9150 while Present (Next_Formal (Last_Formal)) loop
9151 Last_Formal := Next_Formal (Last_Formal);
9154 Actuals := Parameter_Associations (N);
9156 -- The original function may lack parameters
9158 if No (Actuals) then
9159 Actuals := New_List;
9162 -- If the function call is the expression of an assignment statement,
9163 -- transform the assignment into a procedure call. Generate:
9165 -- LHS := Func_Call (...);
9167 -- Proc_Call (..., LHS);
9169 -- If function is inherited, a conversion may be necessary.
9171 if Nkind (Par) = N_Assignment_Statement then
9172 Last_Actual := Name (Par);
9174 if not Comes_From_Source (Orig_Func)
9175 and then Etype (Orig_Func) /= Etype (Func_Id)
9178 Make_Type_Conversion (Loc,
9179 New_Occurrence_Of (Etype (Func_Id), Loc),
9184 Make_Parameter_Association (Loc,
9186 Make_Identifier (Loc, Chars (Last_Formal)),
9187 Explicit_Actual_Parameter => Last_Actual));
9190 Make_Procedure_Call_Statement (Loc,
9191 Name => New_Occurrence_Of (Proc_Id, Loc),
9192 Parameter_Associations => Actuals));
9195 -- Otherwise the context is an expression. Generate a temporary and a
9196 -- procedure call to obtain the function result. Generate:
9198 -- ... Func_Call (...) ...
9201 -- Proc_Call (..., Temp);
9206 Temp_Id : constant Entity_Id := Make_Temporary (Loc, 'T');
9215 Make_Object_Declaration (Loc,
9216 Defining_Identifier => Temp_Id,
9217 Object_Definition =>
9218 New_Occurrence_Of (Etype (Func_Id), Loc));
9221 -- Proc_Call (..., Temp);
9224 Make_Parameter_Association (Loc,
9226 Make_Identifier (Loc, Chars (Last_Formal)),
9227 Explicit_Actual_Parameter =>
9228 New_Occurrence_Of (Temp_Id, Loc)));
9231 Make_Procedure_Call_Statement (Loc,
9232 Name => New_Occurrence_Of (Proc_Id, Loc),
9233 Parameter_Associations => Actuals);
9235 Insert_Actions (Par, New_List (Decl, Call));
9236 Rewrite (N, New_Occurrence_Of (Temp_Id, Loc));
9239 end Rewrite_Function_Call_For_C;
9241 ------------------------------------
9242 -- Set_Enclosing_Sec_Stack_Return --
9243 ------------------------------------
9245 procedure Set_Enclosing_Sec_Stack_Return (N : Node_Id) is
9249 -- Due to a possible mix of internally generated blocks, source blocks
9250 -- and loops, the scope stack may not be contiguous as all labels are
9251 -- inserted at the top level within the related function. Instead,
9252 -- perform a parent-based traversal and mark all appropriate constructs.
9254 while Present (P) loop
9256 -- Mark the label of a source or internally generated block or
9259 if Nkind_In (P, N_Block_Statement, N_Loop_Statement) then
9260 Set_Sec_Stack_Needed_For_Return (Entity (Identifier (P)));
9262 -- Mark the enclosing function
9264 elsif Nkind (P) = N_Subprogram_Body then
9265 if Present (Corresponding_Spec (P)) then
9266 Set_Sec_Stack_Needed_For_Return (Corresponding_Spec (P));
9268 Set_Sec_Stack_Needed_For_Return (Defining_Entity (P));
9271 -- Do not go beyond the enclosing function
9278 end Set_Enclosing_Sec_Stack_Return;
9280 ------------------------------------
9281 -- Unqual_BIP_Iface_Function_Call --
9282 ------------------------------------
9284 function Unqual_BIP_Iface_Function_Call (Expr : Node_Id) return Node_Id is
9285 Has_Pointer_Displacement : Boolean := False;
9286 On_Object_Declaration : Boolean := False;
9287 -- Remember if processing the renaming expressions on recursion we have
9288 -- traversed an object declaration, since we can traverse many object
9289 -- declaration renamings but just one regular object declaration.
9291 function Unqual_BIP_Function_Call (Expr : Node_Id) return Node_Id;
9292 -- Search for a build-in-place function call skipping any qualification
9293 -- including qualified expressions, type conversions, references, calls
9294 -- to displace the pointer to the object, and renamings. Return Empty if
9295 -- no build-in-place function call is found.
9297 ------------------------------
9298 -- Unqual_BIP_Function_Call --
9299 ------------------------------
9301 function Unqual_BIP_Function_Call (Expr : Node_Id) return Node_Id is
9303 -- Recurse to handle case of multiple levels of qualification and/or
9306 if Nkind_In (Expr, N_Qualified_Expression,
9308 N_Unchecked_Type_Conversion)
9310 return Unqual_BIP_Function_Call (Expression (Expr));
9312 -- Recurse to handle case of multiple levels of references and
9313 -- explicit dereferences.
9315 elsif Nkind_In (Expr, N_Attribute_Reference,
9316 N_Explicit_Dereference,
9319 return Unqual_BIP_Function_Call (Prefix (Expr));
9321 -- Recurse on object renamings
9323 elsif Nkind (Expr) = N_Identifier
9324 and then Present (Entity (Expr))
9325 and then Ekind_In (Entity (Expr), E_Constant, E_Variable)
9326 and then Nkind (Parent (Entity (Expr))) =
9327 N_Object_Renaming_Declaration
9328 and then Present (Renamed_Object (Entity (Expr)))
9330 return Unqual_BIP_Function_Call (Renamed_Object (Entity (Expr)));
9332 -- Recurse on the initializing expression of the first reference of
9333 -- an object declaration.
9335 elsif not On_Object_Declaration
9336 and then Nkind (Expr) = N_Identifier
9337 and then Present (Entity (Expr))
9338 and then Ekind_In (Entity (Expr), E_Constant, E_Variable)
9339 and then Nkind (Parent (Entity (Expr))) = N_Object_Declaration
9340 and then Present (Expression (Parent (Entity (Expr))))
9342 On_Object_Declaration := True;
9344 Unqual_BIP_Function_Call (Expression (Parent (Entity (Expr))));
9346 -- Recurse to handle calls to displace the pointer to the object to
9347 -- reference a secondary dispatch table.
9349 elsif Nkind (Expr) = N_Function_Call
9350 and then Nkind (Name (Expr)) in N_Has_Entity
9351 and then Present (Entity (Name (Expr)))
9352 and then RTU_Loaded (Ada_Tags)
9353 and then RTE_Available (RE_Displace)
9354 and then Is_RTE (Entity (Name (Expr)), RE_Displace)
9356 Has_Pointer_Displacement := True;
9358 Unqual_BIP_Function_Call (First (Parameter_Associations (Expr)));
9360 -- Normal case: check if the inner expression is a BIP function call
9361 -- and the pointer to the object is displaced.
9363 elsif Has_Pointer_Displacement
9364 and then Is_Build_In_Place_Function_Call (Expr)
9371 end Unqual_BIP_Function_Call;
9373 -- Start of processing for Unqual_BIP_Iface_Function_Call
9376 if Nkind (Expr) = N_Identifier and then No (Entity (Expr)) then
9378 -- Can happen for X'Elab_Spec in the binder-generated file
9383 return Unqual_BIP_Function_Call (Expr);
9384 end Unqual_BIP_Iface_Function_Call;