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_Suffix : constant String := BIP_Formal_Suffix (Kind);
654 Extra_Formal : Entity_Id := Extra_Formals (Func);
657 -- Maybe it would be better for each implicit formal of a build-in-place
658 -- function to have a flag or a Uint attribute to identify it. ???
660 -- The return type in the function declaration may have been a limited
661 -- view, and the extra formals for the function were not generated at
662 -- that point. At the point of call the full view must be available and
663 -- the extra formals can be created.
665 if No (Extra_Formal) then
666 Create_Extra_Formals (Func);
667 Extra_Formal := Extra_Formals (Func);
670 -- We search for a formal with a matching suffix. We can't search
671 -- for the full name, because of the code at the end of Sem_Ch6.-
672 -- Create_Extra_Formals, which copies the Extra_Formals over to
673 -- the Alias of an instance, which will cause the formals to have
674 -- "incorrect" names.
677 pragma Assert (Present (Extra_Formal));
679 Name : constant String := Get_Name_String (Chars (Extra_Formal));
681 exit when Name'Length >= Formal_Suffix'Length
682 and then Formal_Suffix =
683 Name (Name'Last - Formal_Suffix'Length + 1 .. Name'Last);
686 Next_Formal_With_Extras (Extra_Formal);
690 end Build_In_Place_Formal;
692 -------------------------------
693 -- Build_Procedure_Body_Form --
694 -------------------------------
696 function Build_Procedure_Body_Form
697 (Func_Id : Entity_Id;
698 Func_Body : Node_Id) return Node_Id
700 Loc : constant Source_Ptr := Sloc (Func_Body);
702 Proc_Decl : constant Node_Id :=
703 Next (Unit_Declaration_Node (Func_Id));
704 -- It is assumed that the next node following the declaration of the
705 -- corresponding subprogram spec is the declaration of the procedure
708 Proc_Id : constant Entity_Id := Defining_Entity (Proc_Decl);
710 procedure Replace_Returns (Param_Id : Entity_Id; Stmts : List_Id);
711 -- Replace each return statement found in the list Stmts with an
712 -- assignment of the return expression to parameter Param_Id.
714 ---------------------
715 -- Replace_Returns --
716 ---------------------
718 procedure Replace_Returns (Param_Id : Entity_Id; Stmts : List_Id) is
722 Stmt := First (Stmts);
723 while Present (Stmt) loop
724 if Nkind (Stmt) = N_Block_Statement then
725 Replace_Returns (Param_Id,
726 Statements (Handled_Statement_Sequence (Stmt)));
728 elsif Nkind (Stmt) = N_Case_Statement then
732 Alt := First (Alternatives (Stmt));
733 while Present (Alt) loop
734 Replace_Returns (Param_Id, Statements (Alt));
739 elsif Nkind (Stmt) = N_Extended_Return_Statement then
741 Ret_Obj : constant Entity_Id :=
743 (First (Return_Object_Declarations (Stmt)));
744 Assign : constant Node_Id :=
745 Make_Assignment_Statement (Sloc (Stmt),
747 New_Occurrence_Of (Param_Id, Loc),
749 New_Occurrence_Of (Ret_Obj, Sloc (Stmt)));
753 -- The extended return may just contain the declaration
755 if Present (Handled_Statement_Sequence (Stmt)) then
756 Stmts := Statements (Handled_Statement_Sequence (Stmt));
761 Set_Assignment_OK (Name (Assign));
764 Make_Block_Statement (Sloc (Stmt),
766 Return_Object_Declarations (Stmt),
767 Handled_Statement_Sequence =>
768 Make_Handled_Sequence_Of_Statements (Loc,
769 Statements => Stmts)));
771 Replace_Returns (Param_Id, Stmts);
773 Append_To (Stmts, Assign);
774 Append_To (Stmts, Make_Simple_Return_Statement (Loc));
777 elsif Nkind (Stmt) = N_If_Statement then
778 Replace_Returns (Param_Id, Then_Statements (Stmt));
779 Replace_Returns (Param_Id, Else_Statements (Stmt));
784 Part := First (Elsif_Parts (Stmt));
785 while Present (Part) loop
786 Replace_Returns (Param_Id, Then_Statements (Part));
791 elsif Nkind (Stmt) = N_Loop_Statement then
792 Replace_Returns (Param_Id, Statements (Stmt));
794 elsif Nkind (Stmt) = N_Simple_Return_Statement then
801 Make_Assignment_Statement (Sloc (Stmt),
802 Name => New_Occurrence_Of (Param_Id, Loc),
803 Expression => Relocate_Node (Expression (Stmt))));
805 Insert_After (Stmt, Make_Simple_Return_Statement (Loc));
807 -- Skip the added return
821 -- Start of processing for Build_Procedure_Body_Form
824 -- This routine replaces the original function body:
826 -- function F (...) return Array_Typ is
832 -- with the following:
834 -- procedure P (..., Result : out Array_Typ) is
837 -- Result := Something;
841 Statements (Handled_Statement_Sequence (Func_Body));
842 Replace_Returns (Last_Entity (Proc_Id), Stmts);
845 Make_Subprogram_Body (Loc,
847 Copy_Subprogram_Spec (Specification (Proc_Decl)),
848 Declarations => Declarations (Func_Body),
849 Handled_Statement_Sequence =>
850 Make_Handled_Sequence_Of_Statements (Loc,
851 Statements => Stmts));
853 -- If the function is a generic instance, so is the new procedure.
854 -- Set flag accordingly so that the proper renaming declarations are
857 Set_Is_Generic_Instance (Proc_Id, Is_Generic_Instance (Func_Id));
859 end Build_Procedure_Body_Form;
861 -----------------------
862 -- Caller_Known_Size --
863 -----------------------
865 function Caller_Known_Size
866 (Func_Call : Node_Id;
867 Result_Subt : Entity_Id) return Boolean
871 (Is_Definite_Subtype (Underlying_Type (Result_Subt))
872 and then No (Controlling_Argument (Func_Call)))
873 or else not Requires_Transient_Scope (Underlying_Type (Result_Subt));
874 end Caller_Known_Size;
876 --------------------------------
877 -- Check_Overriding_Operation --
878 --------------------------------
880 procedure Check_Overriding_Operation (Subp : Entity_Id) is
881 Typ : constant Entity_Id := Find_Dispatching_Type (Subp);
882 Op_List : constant Elist_Id := Primitive_Operations (Typ);
888 if Is_Derived_Type (Typ)
889 and then not Is_Private_Type (Typ)
890 and then In_Open_Scopes (Scope (Etype (Typ)))
891 and then Is_Base_Type (Typ)
893 -- Subp overrides an inherited private operation if there is an
894 -- inherited operation with a different name than Subp (see
895 -- Derive_Subprogram) whose Alias is a hidden subprogram with the
896 -- same name as Subp.
898 Op_Elmt := First_Elmt (Op_List);
899 while Present (Op_Elmt) loop
900 Prim_Op := Node (Op_Elmt);
901 Par_Op := Alias (Prim_Op);
904 and then not Comes_From_Source (Prim_Op)
905 and then Chars (Prim_Op) /= Chars (Par_Op)
906 and then Chars (Par_Op) = Chars (Subp)
907 and then Is_Hidden (Par_Op)
908 and then Type_Conformant (Prim_Op, Subp)
910 Set_DT_Position_Value (Subp, DT_Position (Prim_Op));
916 end Check_Overriding_Operation;
918 -------------------------------
919 -- Detect_Infinite_Recursion --
920 -------------------------------
922 procedure Detect_Infinite_Recursion (N : Node_Id; Spec : Entity_Id) is
923 Loc : constant Source_Ptr := Sloc (N);
925 Var_List : constant Elist_Id := New_Elmt_List;
926 -- List of globals referenced by body of procedure
928 Call_List : constant Elist_Id := New_Elmt_List;
929 -- List of recursive calls in body of procedure
931 Shad_List : constant Elist_Id := New_Elmt_List;
932 -- List of entity id's for entities created to capture the value of
933 -- referenced globals on entry to the procedure.
935 Scop : constant Uint := Scope_Depth (Spec);
936 -- This is used to record the scope depth of the current procedure, so
937 -- that we can identify global references.
939 Max_Vars : constant := 4;
940 -- Do not test more than four global variables
942 Count_Vars : Natural := 0;
943 -- Count variables found so far
955 function Process (Nod : Node_Id) return Traverse_Result;
956 -- Function to traverse the subprogram body (using Traverse_Func)
962 function Process (Nod : Node_Id) return Traverse_Result is
966 if Nkind (Nod) = N_Procedure_Call_Statement then
968 -- Case of one of the detected recursive calls
970 if Is_Entity_Name (Name (Nod))
971 and then Has_Recursive_Call (Entity (Name (Nod)))
972 and then Entity (Name (Nod)) = Spec
974 Append_Elmt (Nod, Call_List);
977 -- Any other procedure call may have side effects
983 -- A call to a pure function can always be ignored
985 elsif Nkind (Nod) = N_Function_Call
986 and then Is_Entity_Name (Name (Nod))
987 and then Is_Pure (Entity (Name (Nod)))
991 -- Case of an identifier reference
993 elsif Nkind (Nod) = N_Identifier then
996 -- If no entity, then ignore the reference
998 -- Not clear why this can happen. To investigate, remove this
999 -- test and look at the crash that occurs here in 3401-004 ???
1004 -- Ignore entities with no Scope, again not clear how this
1005 -- can happen, to investigate, look at 4108-008 ???
1007 elsif No (Scope (Ent)) then
1010 -- Ignore the reference if not to a more global object
1012 elsif Scope_Depth (Scope (Ent)) >= Scop then
1015 -- References to types, exceptions and constants are always OK
1018 or else Ekind (Ent) = E_Exception
1019 or else Ekind (Ent) = E_Constant
1023 -- If other than a non-volatile scalar variable, we have some
1024 -- kind of global reference (e.g. to a function) that we cannot
1025 -- deal with so we forget the attempt.
1027 elsif Ekind (Ent) /= E_Variable
1028 or else not Is_Scalar_Type (Etype (Ent))
1029 or else Treat_As_Volatile (Ent)
1033 -- Otherwise we have a reference to a global scalar
1036 -- Loop through global entities already detected
1038 Elm := First_Elmt (Var_List);
1040 -- If not detected before, record this new global reference
1043 Count_Vars := Count_Vars + 1;
1045 if Count_Vars <= Max_Vars then
1046 Append_Elmt (Entity (Nod), Var_List);
1053 -- If recorded before, ignore
1055 elsif Node (Elm) = Entity (Nod) then
1058 -- Otherwise keep looking
1068 -- For all other node kinds, recursively visit syntactic children
1075 function Traverse_Body is new Traverse_Func (Process);
1077 -- Start of processing for Detect_Infinite_Recursion
1080 -- Do not attempt detection in No_Implicit_Conditional mode, since we
1081 -- won't be able to generate the code to handle the recursion in any
1084 if Restriction_Active (No_Implicit_Conditionals) then
1088 -- Otherwise do traversal and quit if we get abandon signal
1090 if Traverse_Body (N) = Abandon then
1093 -- We must have a call, since Has_Recursive_Call was set. If not just
1094 -- ignore (this is only an error check, so if we have a funny situation,
1095 -- due to bugs or errors, we do not want to bomb).
1097 elsif Is_Empty_Elmt_List (Call_List) then
1101 -- Here is the case where we detect recursion at compile time
1103 -- Push our current scope for analyzing the declarations and code that
1104 -- we will insert for the checking.
1108 -- This loop builds temporary variables for each of the referenced
1109 -- globals, so that at the end of the loop the list Shad_List contains
1110 -- these temporaries in one-to-one correspondence with the elements in
1114 Elm := First_Elmt (Var_List);
1115 while Present (Elm) loop
1117 Ent := Make_Temporary (Loc, 'S');
1118 Append_Elmt (Ent, Shad_List);
1120 -- Insert a declaration for this temporary at the start of the
1121 -- declarations for the procedure. The temporaries are declared as
1122 -- constant objects initialized to the current values of the
1123 -- corresponding temporaries.
1126 Make_Object_Declaration (Loc,
1127 Defining_Identifier => Ent,
1128 Object_Definition => New_Occurrence_Of (Etype (Var), Loc),
1129 Constant_Present => True,
1130 Expression => New_Occurrence_Of (Var, Loc));
1133 Prepend (Decl, Declarations (N));
1135 Insert_After (Last, Decl);
1143 -- Loop through calls
1145 Call := First_Elmt (Call_List);
1146 while Present (Call) loop
1148 -- Build a predicate expression of the form
1151 -- and then global1 = temp1
1152 -- and then global2 = temp2
1155 -- This predicate determines if any of the global values
1156 -- referenced by the procedure have changed since the
1157 -- current call, if not an infinite recursion is assured.
1159 Test := New_Occurrence_Of (Standard_True, Loc);
1161 Elm1 := First_Elmt (Var_List);
1162 Elm2 := First_Elmt (Shad_List);
1163 while Present (Elm1) loop
1169 Left_Opnd => New_Occurrence_Of (Node (Elm1), Loc),
1170 Right_Opnd => New_Occurrence_Of (Node (Elm2), Loc)));
1176 -- Now we replace the call with the sequence
1178 -- if no-changes (see above) then
1179 -- raise Storage_Error;
1184 Rewrite (Node (Call),
1185 Make_If_Statement (Loc,
1187 Then_Statements => New_List (
1188 Make_Raise_Storage_Error (Loc,
1189 Reason => SE_Infinite_Recursion)),
1191 Else_Statements => New_List (
1192 Relocate_Node (Node (Call)))));
1194 Analyze (Node (Call));
1199 -- Remove temporary scope stack entry used for analysis
1202 end Detect_Infinite_Recursion;
1204 --------------------
1205 -- Expand_Actuals --
1206 --------------------
1208 procedure Expand_Actuals
1211 Post_Call : out List_Id)
1213 Loc : constant Source_Ptr := Sloc (N);
1217 E_Actual : Entity_Id;
1218 E_Formal : Entity_Id;
1220 procedure Add_Call_By_Copy_Code;
1221 -- For cases where the parameter must be passed by copy, this routine
1222 -- generates a temporary variable into which the actual is copied and
1223 -- then passes this as the parameter. For an OUT or IN OUT parameter,
1224 -- an assignment is also generated to copy the result back. The call
1225 -- also takes care of any constraint checks required for the type
1226 -- conversion case (on both the way in and the way out).
1228 procedure Add_Simple_Call_By_Copy_Code;
1229 -- This is similar to the above, but is used in cases where we know
1230 -- that all that is needed is to simply create a temporary and copy
1231 -- the value in and out of the temporary.
1233 procedure Add_Validation_Call_By_Copy_Code (Act : Node_Id);
1234 -- Perform copy-back for actual parameter Act which denotes a validation
1237 procedure Check_Fortran_Logical;
1238 -- A value of type Logical that is passed through a formal parameter
1239 -- must be normalized because .TRUE. usually does not have the same
1240 -- representation as True. We assume that .FALSE. = False = 0.
1241 -- What about functions that return a logical type ???
1243 function Is_Legal_Copy return Boolean;
1244 -- Check that an actual can be copied before generating the temporary
1245 -- to be used in the call. If the actual is of a by_reference type then
1246 -- the program is illegal (this can only happen in the presence of
1247 -- rep. clauses that force an incorrect alignment). If the formal is
1248 -- a by_reference parameter imposed by a DEC pragma, emit a warning to
1249 -- the effect that this might lead to unaligned arguments.
1251 function Make_Var (Actual : Node_Id) return Entity_Id;
1252 -- Returns an entity that refers to the given actual parameter, Actual
1253 -- (not including any type conversion). If Actual is an entity name,
1254 -- then this entity is returned unchanged, otherwise a renaming is
1255 -- created to provide an entity for the actual.
1257 procedure Reset_Packed_Prefix;
1258 -- The expansion of a packed array component reference is delayed in
1259 -- the context of a call. Now we need to complete the expansion, so we
1260 -- unmark the analyzed bits in all prefixes.
1262 ---------------------------
1263 -- Add_Call_By_Copy_Code --
1264 ---------------------------
1266 procedure Add_Call_By_Copy_Code is
1269 F_Typ : Entity_Id := Etype (Formal);
1277 if not Is_Legal_Copy then
1281 Temp := Make_Temporary (Loc, 'T', Actual);
1283 -- Handle formals whose type comes from the limited view
1285 if From_Limited_With (F_Typ)
1286 and then Has_Non_Limited_View (F_Typ)
1288 F_Typ := Non_Limited_View (F_Typ);
1291 -- Use formal type for temp, unless formal type is an unconstrained
1292 -- array, in which case we don't have to worry about bounds checks,
1293 -- and we use the actual type, since that has appropriate bounds.
1295 if Is_Array_Type (F_Typ) and then not Is_Constrained (F_Typ) then
1296 Indic := New_Occurrence_Of (Etype (Actual), Loc);
1298 Indic := New_Occurrence_Of (F_Typ, Loc);
1301 if Nkind (Actual) = N_Type_Conversion then
1302 V_Typ := Etype (Expression (Actual));
1304 -- If the formal is an (in-)out parameter, capture the name
1305 -- of the variable in order to build the post-call assignment.
1307 Var := Make_Var (Expression (Actual));
1309 Crep := not Same_Representation
1310 (F_Typ, Etype (Expression (Actual)));
1313 V_Typ := Etype (Actual);
1314 Var := Make_Var (Actual);
1318 -- Setup initialization for case of in out parameter, or an out
1319 -- parameter where the formal is an unconstrained array (in the
1320 -- latter case, we have to pass in an object with bounds).
1322 -- If this is an out parameter, the initial copy is wasteful, so as
1323 -- an optimization for the one-dimensional case we extract the
1324 -- bounds of the actual and build an uninitialized temporary of the
1327 if Ekind (Formal) = E_In_Out_Parameter
1328 or else (Is_Array_Type (F_Typ) and then not Is_Constrained (F_Typ))
1330 if Nkind (Actual) = N_Type_Conversion then
1331 if Conversion_OK (Actual) then
1332 Init := OK_Convert_To (F_Typ, New_Occurrence_Of (Var, Loc));
1334 Init := Convert_To (F_Typ, New_Occurrence_Of (Var, Loc));
1337 elsif Ekind (Formal) = E_Out_Parameter
1338 and then Is_Array_Type (F_Typ)
1339 and then Number_Dimensions (F_Typ) = 1
1340 and then not Has_Non_Null_Base_Init_Proc (F_Typ)
1342 -- Actual is a one-dimensional array or slice, and the type
1343 -- requires no initialization. Create a temporary of the
1344 -- right size, but do not copy actual into it (optimization).
1348 Make_Subtype_Indication (Loc,
1349 Subtype_Mark => New_Occurrence_Of (F_Typ, Loc),
1351 Make_Index_Or_Discriminant_Constraint (Loc,
1352 Constraints => New_List (
1355 Make_Attribute_Reference (Loc,
1356 Prefix => New_Occurrence_Of (Var, Loc),
1357 Attribute_Name => Name_First),
1359 Make_Attribute_Reference (Loc,
1360 Prefix => New_Occurrence_Of (Var, Loc),
1361 Attribute_Name => Name_Last)))));
1364 Init := New_Occurrence_Of (Var, Loc);
1367 -- An initialization is created for packed conversions as
1368 -- actuals for out parameters to enable Make_Object_Declaration
1369 -- to determine the proper subtype for N_Node. Note that this
1370 -- is wasteful because the extra copying on the call side is
1371 -- not required for such out parameters. ???
1373 elsif Ekind (Formal) = E_Out_Parameter
1374 and then Nkind (Actual) = N_Type_Conversion
1375 and then (Is_Bit_Packed_Array (F_Typ)
1377 Is_Bit_Packed_Array (Etype (Expression (Actual))))
1379 if Conversion_OK (Actual) then
1380 Init := OK_Convert_To (F_Typ, New_Occurrence_Of (Var, Loc));
1382 Init := Convert_To (F_Typ, New_Occurrence_Of (Var, Loc));
1385 elsif Ekind (Formal) = E_In_Parameter then
1387 -- Handle the case in which the actual is a type conversion
1389 if Nkind (Actual) = N_Type_Conversion then
1390 if Conversion_OK (Actual) then
1391 Init := OK_Convert_To (F_Typ, New_Occurrence_Of (Var, Loc));
1393 Init := Convert_To (F_Typ, New_Occurrence_Of (Var, Loc));
1396 Init := New_Occurrence_Of (Var, Loc);
1404 Make_Object_Declaration (Loc,
1405 Defining_Identifier => Temp,
1406 Object_Definition => Indic,
1407 Expression => Init);
1408 Set_Assignment_OK (N_Node);
1409 Insert_Action (N, N_Node);
1411 -- Now, normally the deal here is that we use the defining
1412 -- identifier created by that object declaration. There is
1413 -- one exception to this. In the change of representation case
1414 -- the above declaration will end up looking like:
1416 -- temp : type := identifier;
1418 -- And in this case we might as well use the identifier directly
1419 -- and eliminate the temporary. Note that the analysis of the
1420 -- declaration was not a waste of time in that case, since it is
1421 -- what generated the necessary change of representation code. If
1422 -- the change of representation introduced additional code, as in
1423 -- a fixed-integer conversion, the expression is not an identifier
1424 -- and must be kept.
1427 and then Present (Expression (N_Node))
1428 and then Is_Entity_Name (Expression (N_Node))
1430 Temp := Entity (Expression (N_Node));
1431 Rewrite (N_Node, Make_Null_Statement (Loc));
1434 -- For IN parameter, all we do is to replace the actual
1436 if Ekind (Formal) = E_In_Parameter then
1437 Rewrite (Actual, New_Occurrence_Of (Temp, Loc));
1440 -- Processing for OUT or IN OUT parameter
1443 -- Kill current value indications for the temporary variable we
1444 -- created, since we just passed it as an OUT parameter.
1446 Kill_Current_Values (Temp);
1447 Set_Is_Known_Valid (Temp, False);
1449 -- If type conversion, use reverse conversion on exit
1451 if Nkind (Actual) = N_Type_Conversion then
1452 if Conversion_OK (Actual) then
1453 Expr := OK_Convert_To (V_Typ, New_Occurrence_Of (Temp, Loc));
1455 Expr := Convert_To (V_Typ, New_Occurrence_Of (Temp, Loc));
1458 Expr := New_Occurrence_Of (Temp, Loc);
1461 Rewrite (Actual, New_Occurrence_Of (Temp, Loc));
1464 -- If the actual is a conversion of a packed reference, it may
1465 -- already have been expanded by Remove_Side_Effects, and the
1466 -- resulting variable is a temporary which does not designate
1467 -- the proper out-parameter, which may not be addressable. In
1468 -- that case, generate an assignment to the original expression
1469 -- (before expansion of the packed reference) so that the proper
1470 -- expansion of assignment to a packed component can take place.
1477 if Is_Renaming_Of_Object (Var)
1478 and then Nkind (Renamed_Object (Var)) = N_Selected_Component
1479 and then Nkind (Original_Node (Prefix (Renamed_Object (Var))))
1480 = N_Indexed_Component
1482 Has_Non_Standard_Rep (Etype (Prefix (Renamed_Object (Var))))
1484 Obj := Renamed_Object (Var);
1486 Make_Selected_Component (Loc,
1488 New_Copy_Tree (Original_Node (Prefix (Obj))),
1489 Selector_Name => New_Copy (Selector_Name (Obj)));
1490 Reset_Analyzed_Flags (Lhs);
1493 Lhs := New_Occurrence_Of (Var, Loc);
1496 Set_Assignment_OK (Lhs);
1498 if Is_Access_Type (E_Formal)
1499 and then Is_Entity_Name (Lhs)
1501 Present (Effective_Extra_Accessibility (Entity (Lhs)))
1503 -- Copyback target is an Ada 2012 stand-alone object of an
1504 -- anonymous access type.
1506 pragma Assert (Ada_Version >= Ada_2012);
1508 if Type_Access_Level (E_Formal) >
1509 Object_Access_Level (Lhs)
1511 Append_To (Post_Call,
1512 Make_Raise_Program_Error (Loc,
1513 Reason => PE_Accessibility_Check_Failed));
1516 Append_To (Post_Call,
1517 Make_Assignment_Statement (Loc,
1519 Expression => Expr));
1521 -- We would like to somehow suppress generation of the
1522 -- extra_accessibility assignment generated by the expansion
1523 -- of the above assignment statement. It's not a correctness
1524 -- issue because the following assignment renders it dead,
1525 -- but generating back-to-back assignments to the same
1526 -- target is undesirable. ???
1528 Append_To (Post_Call,
1529 Make_Assignment_Statement (Loc,
1530 Name => New_Occurrence_Of (
1531 Effective_Extra_Accessibility (Entity (Lhs)), Loc),
1532 Expression => Make_Integer_Literal (Loc,
1533 Type_Access_Level (E_Formal))));
1536 Append_To (Post_Call,
1537 Make_Assignment_Statement (Loc,
1539 Expression => Expr));
1543 end Add_Call_By_Copy_Code;
1545 ----------------------------------
1546 -- Add_Simple_Call_By_Copy_Code --
1547 ----------------------------------
1549 procedure Add_Simple_Call_By_Copy_Code is
1551 F_Typ : Entity_Id := Etype (Formal);
1560 if not Is_Legal_Copy then
1564 -- Handle formals whose type comes from the limited view
1566 if From_Limited_With (F_Typ)
1567 and then Has_Non_Limited_View (F_Typ)
1569 F_Typ := Non_Limited_View (F_Typ);
1572 -- Use formal type for temp, unless formal type is an unconstrained
1573 -- array, in which case we don't have to worry about bounds checks,
1574 -- and we use the actual type, since that has appropriate bounds.
1576 if Is_Array_Type (F_Typ) and then not Is_Constrained (F_Typ) then
1577 Indic := New_Occurrence_Of (Etype (Actual), Loc);
1579 Indic := New_Occurrence_Of (F_Typ, Loc);
1582 -- Prepare to generate code
1584 Reset_Packed_Prefix;
1586 Temp := Make_Temporary (Loc, 'T', Actual);
1587 Incod := Relocate_Node (Actual);
1588 Outcod := New_Copy_Tree (Incod);
1590 -- Generate declaration of temporary variable, initializing it
1591 -- with the input parameter unless we have an OUT formal or
1592 -- this is an initialization call.
1594 -- If the formal is an out parameter with discriminants, the
1595 -- discriminants must be captured even if the rest of the object
1596 -- is in principle uninitialized, because the discriminants may
1597 -- be read by the called subprogram.
1599 if Ekind (Formal) = E_Out_Parameter then
1602 if Has_Discriminants (F_Typ) then
1603 Indic := New_Occurrence_Of (Etype (Actual), Loc);
1606 elsif Inside_Init_Proc then
1608 -- Could use a comment here to match comment below ???
1610 if Nkind (Actual) /= N_Selected_Component
1612 not Has_Discriminant_Dependent_Constraint
1613 (Entity (Selector_Name (Actual)))
1617 -- Otherwise, keep the component in order to generate the proper
1618 -- actual subtype, that depends on enclosing discriminants.
1626 Make_Object_Declaration (Loc,
1627 Defining_Identifier => Temp,
1628 Object_Definition => Indic,
1629 Expression => Incod);
1634 -- If the call is to initialize a component of a composite type,
1635 -- and the component does not depend on discriminants, use the
1636 -- actual type of the component. This is required in case the
1637 -- component is constrained, because in general the formal of the
1638 -- initialization procedure will be unconstrained. Note that if
1639 -- the component being initialized is constrained by an enclosing
1640 -- discriminant, the presence of the initialization in the
1641 -- declaration will generate an expression for the actual subtype.
1643 Set_No_Initialization (Decl);
1644 Set_Object_Definition (Decl,
1645 New_Occurrence_Of (Etype (Actual), Loc));
1648 Insert_Action (N, Decl);
1650 -- The actual is simply a reference to the temporary
1652 Rewrite (Actual, New_Occurrence_Of (Temp, Loc));
1654 -- Generate copy out if OUT or IN OUT parameter
1656 if Ekind (Formal) /= E_In_Parameter then
1658 Rhs := New_Occurrence_Of (Temp, Loc);
1660 -- Deal with conversion
1662 if Nkind (Lhs) = N_Type_Conversion then
1663 Lhs := Expression (Lhs);
1664 Rhs := Convert_To (Etype (Actual), Rhs);
1667 Append_To (Post_Call,
1668 Make_Assignment_Statement (Loc,
1670 Expression => Rhs));
1671 Set_Assignment_OK (Name (Last (Post_Call)));
1673 end Add_Simple_Call_By_Copy_Code;
1675 --------------------------------------
1676 -- Add_Validation_Call_By_Copy_Code --
1677 --------------------------------------
1679 procedure Add_Validation_Call_By_Copy_Code (Act : Node_Id) is
1682 Obj_Typ : Entity_Id;
1683 Var : constant Node_Id := Unqual_Conv (Act);
1687 -- Copy the value of the validation variable back into the object
1690 if Is_Entity_Name (Var) then
1691 Var_Id := Entity (Var);
1692 Obj := Validated_Object (Var_Id);
1693 Obj_Typ := Etype (Obj);
1695 Expr := New_Occurrence_Of (Var_Id, Loc);
1697 -- A type conversion is needed when the validation variable and
1698 -- the validated object carry different types. This case occurs
1699 -- when the actual is qualified in some fashion.
1702 -- subtype Int is Integer range ...;
1703 -- procedure Call (Val : in out Integer);
1707 -- Call (Integer (Object));
1711 -- Var : Integer := Object; -- conversion to base type
1712 -- if not Var'Valid then -- validity check
1713 -- Call (Var); -- modify Var
1714 -- Object := Int (Var); -- conversion to subtype
1716 if Etype (Var_Id) /= Obj_Typ then
1718 Make_Type_Conversion (Loc,
1719 Subtype_Mark => New_Occurrence_Of (Obj_Typ, Loc),
1720 Expression => Expr);
1726 -- Object := Object_Type (Var);
1728 Append_To (Post_Call,
1729 Make_Assignment_Statement (Loc,
1731 Expression => Expr));
1733 -- If the flow reaches this point, then this routine was invoked with
1734 -- an actual which does not denote a validation variable.
1737 pragma Assert (False);
1740 end Add_Validation_Call_By_Copy_Code;
1742 ---------------------------
1743 -- Check_Fortran_Logical --
1744 ---------------------------
1746 procedure Check_Fortran_Logical is
1747 Logical : constant Entity_Id := Etype (Formal);
1750 -- Note: this is very incomplete, e.g. it does not handle arrays
1751 -- of logical values. This is really not the right approach at all???)
1754 if Convention (Subp) = Convention_Fortran
1755 and then Root_Type (Etype (Formal)) = Standard_Boolean
1756 and then Ekind (Formal) /= E_In_Parameter
1758 Var := Make_Var (Actual);
1759 Append_To (Post_Call,
1760 Make_Assignment_Statement (Loc,
1761 Name => New_Occurrence_Of (Var, Loc),
1763 Unchecked_Convert_To (
1766 Left_Opnd => New_Occurrence_Of (Var, Loc),
1768 Unchecked_Convert_To (
1770 New_Occurrence_Of (Standard_False, Loc))))));
1772 end Check_Fortran_Logical;
1778 function Is_Legal_Copy return Boolean is
1780 -- An attempt to copy a value of such a type can only occur if
1781 -- representation clauses give the actual a misaligned address.
1783 if Is_By_Reference_Type (Etype (Formal)) then
1785 -- The actual may in fact be properly aligned but there is not
1786 -- enough front-end information to determine this. In that case
1787 -- gigi will emit an error if a copy is not legal, or generate
1792 -- For users of Starlet, we assume that the specification of by-
1793 -- reference mechanism is mandatory. This may lead to unaligned
1794 -- objects but at least for DEC legacy code it is known to work.
1795 -- The warning will alert users of this code that a problem may
1798 elsif Mechanism (Formal) = By_Reference
1799 and then Is_Valued_Procedure (Scope (Formal))
1802 ("by_reference actual may be misaligned??", Actual);
1814 function Make_Var (Actual : Node_Id) return Entity_Id is
1818 if Is_Entity_Name (Actual) then
1819 return Entity (Actual);
1822 Var := Make_Temporary (Loc, 'T', Actual);
1825 Make_Object_Renaming_Declaration (Loc,
1826 Defining_Identifier => Var,
1828 New_Occurrence_Of (Etype (Actual), Loc),
1829 Name => Relocate_Node (Actual));
1831 Insert_Action (N, N_Node);
1836 -------------------------
1837 -- Reset_Packed_Prefix --
1838 -------------------------
1840 procedure Reset_Packed_Prefix is
1841 Pfx : Node_Id := Actual;
1844 Set_Analyzed (Pfx, False);
1846 not Nkind_In (Pfx, N_Selected_Component, N_Indexed_Component);
1847 Pfx := Prefix (Pfx);
1849 end Reset_Packed_Prefix;
1851 -- Start of processing for Expand_Actuals
1854 Post_Call := New_List;
1856 Formal := First_Formal (Subp);
1857 Actual := First_Actual (N);
1858 while Present (Formal) loop
1859 E_Formal := Etype (Formal);
1860 E_Actual := Etype (Actual);
1862 -- Handle formals whose type comes from the limited view
1864 if From_Limited_With (E_Formal)
1865 and then Has_Non_Limited_View (E_Formal)
1867 E_Formal := Non_Limited_View (E_Formal);
1870 if Is_Scalar_Type (E_Formal)
1871 or else Nkind (Actual) = N_Slice
1873 Check_Fortran_Logical;
1877 elsif Ekind (Formal) /= E_Out_Parameter then
1879 -- The unusual case of the current instance of a protected type
1880 -- requires special handling. This can only occur in the context
1881 -- of a call within the body of a protected operation.
1883 if Is_Entity_Name (Actual)
1884 and then Ekind (Entity (Actual)) = E_Protected_Type
1885 and then In_Open_Scopes (Entity (Actual))
1887 if Scope (Subp) /= Entity (Actual) then
1889 ("operation outside protected type may not "
1890 & "call back its protected operations??", Actual);
1894 Expand_Protected_Object_Reference (N, Entity (Actual)));
1897 -- Ada 2005 (AI-318-02): If the actual parameter is a call to a
1898 -- build-in-place function, then a temporary return object needs
1899 -- to be created and access to it must be passed to the function.
1900 -- Currently we limit such functions to those with inherently
1901 -- limited result subtypes, but eventually we plan to expand the
1902 -- functions that are treated as build-in-place to include other
1903 -- composite result types.
1905 if Is_Build_In_Place_Function_Call (Actual) then
1906 Make_Build_In_Place_Call_In_Anonymous_Context (Actual);
1908 -- Ada 2005 (AI-318-02): Specialization of the previous case for
1909 -- actuals containing build-in-place function calls whose returned
1910 -- object covers interface types.
1912 elsif Present (Unqual_BIP_Iface_Function_Call (Actual)) then
1913 Make_Build_In_Place_Iface_Call_In_Anonymous_Context (Actual);
1916 Apply_Constraint_Check (Actual, E_Formal);
1918 -- Out parameter case. No constraint checks on access type
1921 elsif Is_Access_Type (E_Formal) then
1926 elsif Has_Discriminants (Base_Type (E_Formal))
1927 or else Has_Non_Null_Base_Init_Proc (E_Formal)
1929 Apply_Constraint_Check (Actual, E_Formal);
1934 Apply_Constraint_Check (Actual, Base_Type (E_Formal));
1937 -- Processing for IN-OUT and OUT parameters
1939 if Ekind (Formal) /= E_In_Parameter then
1941 -- For type conversions of arrays, apply length/range checks
1943 if Is_Array_Type (E_Formal)
1944 and then Nkind (Actual) = N_Type_Conversion
1946 if Is_Constrained (E_Formal) then
1947 Apply_Length_Check (Expression (Actual), E_Formal);
1949 Apply_Range_Check (Expression (Actual), E_Formal);
1953 -- The actual denotes a variable which captures the value of an
1954 -- object for validation purposes. Add a copy-back to reflect any
1955 -- potential changes in value back into the original object.
1957 -- Var : ... := Object;
1958 -- if not Var'Valid then -- validity check
1959 -- Call (Var); -- modify var
1960 -- Object := Var; -- update Object
1962 -- This case is given higher priority because the subsequent check
1963 -- for type conversion may add an extra copy of the variable and
1964 -- prevent proper value propagation back in the original object.
1966 if Is_Validation_Variable_Reference (Actual) then
1967 Add_Validation_Call_By_Copy_Code (Actual);
1969 -- If argument is a type conversion for a type that is passed by
1970 -- copy, then we must pass the parameter by copy.
1972 elsif Nkind (Actual) = N_Type_Conversion
1974 (Is_Numeric_Type (E_Formal)
1975 or else Is_Access_Type (E_Formal)
1976 or else Is_Enumeration_Type (E_Formal)
1977 or else Is_Bit_Packed_Array (Etype (Formal))
1978 or else Is_Bit_Packed_Array (Etype (Expression (Actual)))
1980 -- Also pass by copy if change of representation
1982 or else not Same_Representation
1984 Etype (Expression (Actual))))
1986 Add_Call_By_Copy_Code;
1988 -- References to components of bit-packed arrays are expanded
1989 -- at this point, rather than at the point of analysis of the
1990 -- actuals, to handle the expansion of the assignment to
1991 -- [in] out parameters.
1993 elsif Is_Ref_To_Bit_Packed_Array (Actual) then
1994 Add_Simple_Call_By_Copy_Code;
1996 -- If a non-scalar actual is possibly bit-aligned, we need a copy
1997 -- because the back-end cannot cope with such objects. In other
1998 -- cases where alignment forces a copy, the back-end generates
1999 -- it properly. It should not be generated unconditionally in the
2000 -- front-end because it does not know precisely the alignment
2001 -- requirements of the target, and makes too conservative an
2002 -- estimate, leading to superfluous copies or spurious errors
2003 -- on by-reference parameters.
2005 elsif Nkind (Actual) = N_Selected_Component
2007 Component_May_Be_Bit_Aligned (Entity (Selector_Name (Actual)))
2008 and then not Represented_As_Scalar (Etype (Formal))
2010 Add_Simple_Call_By_Copy_Code;
2012 -- References to slices of bit-packed arrays are expanded
2014 elsif Is_Ref_To_Bit_Packed_Slice (Actual) then
2015 Add_Call_By_Copy_Code;
2017 -- References to possibly unaligned slices of arrays are expanded
2019 elsif Is_Possibly_Unaligned_Slice (Actual) then
2020 Add_Call_By_Copy_Code;
2022 -- Deal with access types where the actual subtype and the
2023 -- formal subtype are not the same, requiring a check.
2025 -- It is necessary to exclude tagged types because of "downward
2026 -- conversion" errors.
2028 elsif Is_Access_Type (E_Formal)
2029 and then not Same_Type (E_Formal, E_Actual)
2030 and then not Is_Tagged_Type (Designated_Type (E_Formal))
2032 Add_Call_By_Copy_Code;
2034 -- If the actual is not a scalar and is marked for volatile
2035 -- treatment, whereas the formal is not volatile, then pass
2036 -- by copy unless it is a by-reference type.
2038 -- Note: we use Is_Volatile here rather than Treat_As_Volatile,
2039 -- because this is the enforcement of a language rule that applies
2040 -- only to "real" volatile variables, not e.g. to the address
2041 -- clause overlay case.
2043 elsif Is_Entity_Name (Actual)
2044 and then Is_Volatile (Entity (Actual))
2045 and then not Is_By_Reference_Type (E_Actual)
2046 and then not Is_Scalar_Type (Etype (Entity (Actual)))
2047 and then not Is_Volatile (E_Formal)
2049 Add_Call_By_Copy_Code;
2051 elsif Nkind (Actual) = N_Indexed_Component
2052 and then Is_Entity_Name (Prefix (Actual))
2053 and then Has_Volatile_Components (Entity (Prefix (Actual)))
2055 Add_Call_By_Copy_Code;
2057 -- Add call-by-copy code for the case of scalar out parameters
2058 -- when it is not known at compile time that the subtype of the
2059 -- formal is a subrange of the subtype of the actual (or vice
2060 -- versa for in out parameters), in order to get range checks
2061 -- on such actuals. (Maybe this case should be handled earlier
2062 -- in the if statement???)
2064 elsif Is_Scalar_Type (E_Formal)
2066 (not In_Subrange_Of (E_Formal, E_Actual)
2068 (Ekind (Formal) = E_In_Out_Parameter
2069 and then not In_Subrange_Of (E_Actual, E_Formal)))
2071 -- Perhaps the setting back to False should be done within
2072 -- Add_Call_By_Copy_Code, since it could get set on other
2073 -- cases occurring above???
2075 if Do_Range_Check (Actual) then
2076 Set_Do_Range_Check (Actual, False);
2079 Add_Call_By_Copy_Code;
2082 -- RM 3.2.4 (23/3): A predicate is checked on in-out and out
2083 -- by-reference parameters on exit from the call. If the actual
2084 -- is a derived type and the operation is inherited, the body
2085 -- of the operation will not contain a call to the predicate
2086 -- function, so it must be done explicitly after the call. Ditto
2087 -- if the actual is an entity of a predicated subtype.
2089 -- The rule refers to by-reference types, but a check is needed
2090 -- for by-copy types as well. That check is subsumed by the rule
2091 -- for subtype conversion on assignment, but we can generate the
2092 -- required check now.
2094 -- Note also that Subp may be either a subprogram entity for
2095 -- direct calls, or a type entity for indirect calls, which must
2096 -- be handled separately because the name does not denote an
2097 -- overloadable entity.
2099 By_Ref_Predicate_Check : declare
2100 Aund : constant Entity_Id := Underlying_Type (E_Actual);
2103 function Is_Public_Subp return Boolean;
2104 -- Check whether the subprogram being called is a visible
2105 -- operation of the type of the actual. Used to determine
2106 -- whether an invariant check must be generated on the
2109 ---------------------
2110 -- Is_Public_Subp --
2111 ---------------------
2113 function Is_Public_Subp return Boolean is
2114 Pack : constant Entity_Id := Scope (Subp);
2115 Subp_Decl : Node_Id;
2118 if not Is_Subprogram (Subp) then
2121 -- The operation may be inherited, or a primitive of the
2125 Nkind_In (Parent (Subp), N_Private_Extension_Declaration,
2126 N_Full_Type_Declaration)
2128 Subp_Decl := Parent (Subp);
2131 Subp_Decl := Unit_Declaration_Node (Subp);
2134 return Ekind (Pack) = E_Package
2136 List_Containing (Subp_Decl) =
2137 Visible_Declarations
2138 (Specification (Unit_Declaration_Node (Pack)));
2141 -- Start of processing for By_Ref_Predicate_Check
2150 if Has_Predicates (Atyp)
2151 and then Present (Predicate_Function (Atyp))
2153 -- Skip predicate checks for special cases
2155 and then Predicate_Tests_On_Arguments (Subp)
2157 Append_To (Post_Call,
2158 Make_Predicate_Check (Atyp, Actual));
2161 -- We generated caller-side invariant checks in two cases:
2163 -- a) when calling an inherited operation, where there is an
2164 -- implicit view conversion of the actual to the parent type.
2166 -- b) When the conversion is explicit
2168 -- We treat these cases separately because the required
2169 -- conversion for a) is added later when expanding the call.
2171 if Has_Invariants (Etype (Actual))
2173 Nkind (Parent (Subp)) = N_Private_Extension_Declaration
2175 if Comes_From_Source (N) and then Is_Public_Subp then
2176 Append_To (Post_Call, Make_Invariant_Call (Actual));
2179 elsif Nkind (Actual) = N_Type_Conversion
2180 and then Has_Invariants (Etype (Expression (Actual)))
2182 if Comes_From_Source (N) and then Is_Public_Subp then
2183 Append_To (Post_Call,
2184 Make_Invariant_Call (Expression (Actual)));
2187 end By_Ref_Predicate_Check;
2189 -- Processing for IN parameters
2192 -- For IN parameters in the bit-packed array case, we expand an
2193 -- indexed component (the circuit in Exp_Ch4 deliberately left
2194 -- indexed components appearing as actuals untouched, so that
2195 -- the special processing above for the OUT and IN OUT cases
2196 -- could be performed. We could make the test in Exp_Ch4 more
2197 -- complex and have it detect the parameter mode, but it is
2198 -- easier simply to handle all cases here.)
2200 if Nkind (Actual) = N_Indexed_Component
2201 and then Is_Bit_Packed_Array (Etype (Prefix (Actual)))
2203 Reset_Packed_Prefix;
2204 Expand_Packed_Element_Reference (Actual);
2206 -- If we have a reference to a bit-packed array, we copy it, since
2207 -- the actual must be byte aligned.
2209 -- Is this really necessary in all cases???
2211 elsif Is_Ref_To_Bit_Packed_Array (Actual) then
2212 Add_Simple_Call_By_Copy_Code;
2214 -- If a non-scalar actual is possibly unaligned, we need a copy
2216 elsif Is_Possibly_Unaligned_Object (Actual)
2217 and then not Represented_As_Scalar (Etype (Formal))
2219 Add_Simple_Call_By_Copy_Code;
2221 -- Similarly, we have to expand slices of packed arrays here
2222 -- because the result must be byte aligned.
2224 elsif Is_Ref_To_Bit_Packed_Slice (Actual) then
2225 Add_Call_By_Copy_Code;
2227 -- Only processing remaining is to pass by copy if this is a
2228 -- reference to a possibly unaligned slice, since the caller
2229 -- expects an appropriately aligned argument.
2231 elsif Is_Possibly_Unaligned_Slice (Actual) then
2232 Add_Call_By_Copy_Code;
2234 -- An unusual case: a current instance of an enclosing task can be
2235 -- an actual, and must be replaced by a reference to self.
2237 elsif Is_Entity_Name (Actual)
2238 and then Is_Task_Type (Entity (Actual))
2240 if In_Open_Scopes (Entity (Actual)) then
2242 (Make_Function_Call (Loc,
2243 Name => New_Occurrence_Of (RTE (RE_Self), Loc))));
2246 -- A task type cannot otherwise appear as an actual
2249 raise Program_Error;
2254 Next_Formal (Formal);
2255 Next_Actual (Actual);
2263 procedure Expand_Call (N : Node_Id) is
2264 Post_Call : List_Id;
2267 pragma Assert (Nkind_In (N, N_Entry_Call_Statement,
2269 N_Procedure_Call_Statement));
2271 Expand_Call_Helper (N, Post_Call);
2272 Insert_Post_Call_Actions (N, Post_Call);
2275 ------------------------
2276 -- Expand_Call_Helper --
2277 ------------------------
2279 -- This procedure handles expansion of function calls and procedure call
2280 -- statements (i.e. it serves as the body for Expand_N_Function_Call and
2281 -- Expand_N_Procedure_Call_Statement). Processing for calls includes:
2283 -- Replace call to Raise_Exception by Raise_Exception_Always if possible
2284 -- Provide values of actuals for all formals in Extra_Formals list
2285 -- Replace "call" to enumeration literal function by literal itself
2286 -- Rewrite call to predefined operator as operator
2287 -- Replace actuals to in-out parameters that are numeric conversions,
2288 -- with explicit assignment to temporaries before and after the call.
2290 -- Note that the list of actuals has been filled with default expressions
2291 -- during semantic analysis of the call. Only the extra actuals required
2292 -- for the 'Constrained attribute and for accessibility checks are added
2295 procedure Expand_Call_Helper (N : Node_Id; Post_Call : out List_Id) is
2296 Loc : constant Source_Ptr := Sloc (N);
2297 Call_Node : Node_Id := N;
2298 Extra_Actuals : List_Id := No_List;
2299 Prev : Node_Id := Empty;
2301 procedure Add_Actual_Parameter (Insert_Param : Node_Id);
2302 -- Adds one entry to the end of the actual parameter list. Used for
2303 -- default parameters and for extra actuals (for Extra_Formals). The
2304 -- argument is an N_Parameter_Association node.
2306 procedure Add_Extra_Actual (Expr : Node_Id; EF : Entity_Id);
2307 -- Adds an extra actual to the list of extra actuals. Expr is the
2308 -- expression for the value of the actual, EF is the entity for the
2311 procedure Add_View_Conversion_Invariants
2312 (Formal : Entity_Id;
2314 -- Adds invariant checks for every intermediate type between the range
2315 -- of a view converted argument to its ancestor (from parent to child).
2317 function Inherited_From_Formal (S : Entity_Id) return Entity_Id;
2318 -- Within an instance, a type derived from an untagged formal derived
2319 -- type inherits from the original parent, not from the actual. The
2320 -- current derivation mechanism has the derived type inherit from the
2321 -- actual, which is only correct outside of the instance. If the
2322 -- subprogram is inherited, we test for this particular case through a
2323 -- convoluted tree traversal before setting the proper subprogram to be
2326 function In_Unfrozen_Instance (E : Entity_Id) return Boolean;
2327 -- Return true if E comes from an instance that is not yet frozen
2329 function Is_Direct_Deep_Call (Subp : Entity_Id) return Boolean;
2330 -- Determine if Subp denotes a non-dispatching call to a Deep routine
2332 function New_Value (From : Node_Id) return Node_Id;
2333 -- From is the original Expression. New_Value is equivalent to a call
2334 -- to Duplicate_Subexpr with an explicit dereference when From is an
2335 -- access parameter.
2337 --------------------------
2338 -- Add_Actual_Parameter --
2339 --------------------------
2341 procedure Add_Actual_Parameter (Insert_Param : Node_Id) is
2342 Actual_Expr : constant Node_Id :=
2343 Explicit_Actual_Parameter (Insert_Param);
2346 -- Case of insertion is first named actual
2348 if No (Prev) or else
2349 Nkind (Parent (Prev)) /= N_Parameter_Association
2351 Set_Next_Named_Actual
2352 (Insert_Param, First_Named_Actual (Call_Node));
2353 Set_First_Named_Actual (Call_Node, Actual_Expr);
2356 if No (Parameter_Associations (Call_Node)) then
2357 Set_Parameter_Associations (Call_Node, New_List);
2360 Append (Insert_Param, Parameter_Associations (Call_Node));
2363 Insert_After (Prev, Insert_Param);
2366 -- Case of insertion is not first named actual
2369 Set_Next_Named_Actual
2370 (Insert_Param, Next_Named_Actual (Parent (Prev)));
2371 Set_Next_Named_Actual (Parent (Prev), Actual_Expr);
2372 Append (Insert_Param, Parameter_Associations (Call_Node));
2375 Prev := Actual_Expr;
2376 end Add_Actual_Parameter;
2378 ----------------------
2379 -- Add_Extra_Actual --
2380 ----------------------
2382 procedure Add_Extra_Actual (Expr : Node_Id; EF : Entity_Id) is
2383 Loc : constant Source_Ptr := Sloc (Expr);
2386 if Extra_Actuals = No_List then
2387 Extra_Actuals := New_List;
2388 Set_Parent (Extra_Actuals, Call_Node);
2391 Append_To (Extra_Actuals,
2392 Make_Parameter_Association (Loc,
2393 Selector_Name => New_Occurrence_Of (EF, Loc),
2394 Explicit_Actual_Parameter => Expr));
2396 Analyze_And_Resolve (Expr, Etype (EF));
2398 if Nkind (Call_Node) = N_Function_Call then
2399 Set_Is_Accessibility_Actual (Parent (Expr));
2401 end Add_Extra_Actual;
2403 ------------------------------------
2404 -- Add_View_Conversion_Invariants --
2405 ------------------------------------
2407 procedure Add_View_Conversion_Invariants
2408 (Formal : Entity_Id;
2412 Curr_Typ : Entity_Id;
2413 Inv_Checks : List_Id;
2414 Par_Typ : Entity_Id;
2417 Inv_Checks := No_List;
2419 -- Extract the argument from a potentially nested set of view
2423 while Nkind (Arg) = N_Type_Conversion loop
2424 Arg := Expression (Arg);
2427 -- Move up the derivation chain starting with the type of the formal
2428 -- parameter down to the type of the actual object.
2431 Par_Typ := Etype (Arg);
2432 while Par_Typ /= Etype (Formal) and Par_Typ /= Curr_Typ loop
2433 Curr_Typ := Par_Typ;
2435 if Has_Invariants (Curr_Typ)
2436 and then Present (Invariant_Procedure (Curr_Typ))
2438 -- Verify the invariate of the current type. Generate:
2440 -- <Curr_Typ>Invariant (Curr_Typ (Arg));
2442 Prepend_New_To (Inv_Checks,
2443 Make_Procedure_Call_Statement (Loc,
2446 (Invariant_Procedure (Curr_Typ), Loc),
2447 Parameter_Associations => New_List (
2448 Make_Type_Conversion (Loc,
2449 Subtype_Mark => New_Occurrence_Of (Curr_Typ, Loc),
2450 Expression => New_Copy_Tree (Arg)))));
2453 Par_Typ := Base_Type (Etype (Curr_Typ));
2456 if not Is_Empty_List (Inv_Checks) then
2457 Insert_Actions_After (N, Inv_Checks);
2459 end Add_View_Conversion_Invariants;
2461 ---------------------------
2462 -- Inherited_From_Formal --
2463 ---------------------------
2465 function Inherited_From_Formal (S : Entity_Id) return Entity_Id is
2467 Gen_Par : Entity_Id;
2468 Gen_Prim : Elist_Id;
2473 -- If the operation is inherited, it is attached to the corresponding
2474 -- type derivation. If the parent in the derivation is a generic
2475 -- actual, it is a subtype of the actual, and we have to recover the
2476 -- original derived type declaration to find the proper parent.
2478 if Nkind (Parent (S)) /= N_Full_Type_Declaration
2479 or else not Is_Derived_Type (Defining_Identifier (Parent (S)))
2480 or else Nkind (Type_Definition (Original_Node (Parent (S)))) /=
2481 N_Derived_Type_Definition
2482 or else not In_Instance
2489 (Type_Definition (Original_Node (Parent (S))));
2491 if Nkind (Indic) = N_Subtype_Indication then
2492 Par := Entity (Subtype_Mark (Indic));
2494 Par := Entity (Indic);
2498 if not Is_Generic_Actual_Type (Par)
2499 or else Is_Tagged_Type (Par)
2500 or else Nkind (Parent (Par)) /= N_Subtype_Declaration
2501 or else not In_Open_Scopes (Scope (Par))
2505 Gen_Par := Generic_Parent_Type (Parent (Par));
2508 -- If the actual has no generic parent type, the formal is not
2509 -- a formal derived type, so nothing to inherit.
2511 if No (Gen_Par) then
2515 -- If the generic parent type is still the generic type, this is a
2516 -- private formal, not a derived formal, and there are no operations
2517 -- inherited from the formal.
2519 if Nkind (Parent (Gen_Par)) = N_Formal_Type_Declaration then
2523 Gen_Prim := Collect_Primitive_Operations (Gen_Par);
2525 Elmt := First_Elmt (Gen_Prim);
2526 while Present (Elmt) loop
2527 if Chars (Node (Elmt)) = Chars (S) then
2533 F1 := First_Formal (S);
2534 F2 := First_Formal (Node (Elmt));
2536 and then Present (F2)
2538 if Etype (F1) = Etype (F2)
2539 or else Etype (F2) = Gen_Par
2545 exit; -- not the right subprogram
2557 raise Program_Error;
2558 end Inherited_From_Formal;
2560 --------------------------
2561 -- In_Unfrozen_Instance --
2562 --------------------------
2564 function In_Unfrozen_Instance (E : Entity_Id) return Boolean is
2569 while Present (S) and then S /= Standard_Standard loop
2570 if Is_Generic_Instance (S)
2571 and then Present (Freeze_Node (S))
2572 and then not Analyzed (Freeze_Node (S))
2581 end In_Unfrozen_Instance;
2583 -------------------------
2584 -- Is_Direct_Deep_Call --
2585 -------------------------
2587 function Is_Direct_Deep_Call (Subp : Entity_Id) return Boolean is
2589 if Is_TSS (Subp, TSS_Deep_Adjust)
2590 or else Is_TSS (Subp, TSS_Deep_Finalize)
2591 or else Is_TSS (Subp, TSS_Deep_Initialize)
2598 Actual := First (Parameter_Associations (N));
2599 Formal := First_Formal (Subp);
2600 while Present (Actual)
2601 and then Present (Formal)
2603 if Nkind (Actual) = N_Identifier
2604 and then Is_Controlling_Actual (Actual)
2605 and then Etype (Actual) = Etype (Formal)
2611 Next_Formal (Formal);
2617 end Is_Direct_Deep_Call;
2623 function New_Value (From : Node_Id) return Node_Id is
2624 Res : constant Node_Id := Duplicate_Subexpr (From);
2626 if Is_Access_Type (Etype (From)) then
2627 return Make_Explicit_Dereference (Sloc (From), Prefix => Res);
2635 Remote : constant Boolean := Is_Remote_Call (Call_Node);
2638 Orig_Subp : Entity_Id := Empty;
2639 Param_Count : Natural := 0;
2640 Parent_Formal : Entity_Id;
2641 Parent_Subp : Entity_Id;
2642 Pref_Entity : Entity_Id;
2646 Prev_Orig : Node_Id;
2647 -- Original node for an actual, which may have been rewritten. If the
2648 -- actual is a function call that has been transformed from a selected
2649 -- component, the original node is unanalyzed. Otherwise, it carries
2650 -- semantic information used to generate additional actuals.
2652 CW_Interface_Formals_Present : Boolean := False;
2654 -- Start of processing for Expand_Call_Helper
2657 Post_Call := New_List;
2659 -- Expand the function or procedure call if the first actual has a
2660 -- declared dimension aspect, and the subprogram is declared in one
2661 -- of the dimension I/O packages.
2663 if Ada_Version >= Ada_2012
2665 Nkind_In (Call_Node, N_Procedure_Call_Statement, N_Function_Call)
2666 and then Present (Parameter_Associations (Call_Node))
2668 Expand_Put_Call_With_Symbol (Call_Node);
2671 -- Ignore if previous error
2673 if Nkind (Call_Node) in N_Has_Etype
2674 and then Etype (Call_Node) = Any_Type
2679 -- Call using access to subprogram with explicit dereference
2681 if Nkind (Name (Call_Node)) = N_Explicit_Dereference then
2682 Subp := Etype (Name (Call_Node));
2683 Parent_Subp := Empty;
2685 -- Case of call to simple entry, where the Name is a selected component
2686 -- whose prefix is the task, and whose selector name is the entry name
2688 elsif Nkind (Name (Call_Node)) = N_Selected_Component then
2689 Subp := Entity (Selector_Name (Name (Call_Node)));
2690 Parent_Subp := Empty;
2692 -- Case of call to member of entry family, where Name is an indexed
2693 -- component, with the prefix being a selected component giving the
2694 -- task and entry family name, and the index being the entry index.
2696 elsif Nkind (Name (Call_Node)) = N_Indexed_Component then
2697 Subp := Entity (Selector_Name (Prefix (Name (Call_Node))));
2698 Parent_Subp := Empty;
2703 Subp := Entity (Name (Call_Node));
2704 Parent_Subp := Alias (Subp);
2706 -- Replace call to Raise_Exception by call to Raise_Exception_Always
2707 -- if we can tell that the first parameter cannot possibly be null.
2708 -- This improves efficiency by avoiding a run-time test.
2710 -- We do not do this if Raise_Exception_Always does not exist, which
2711 -- can happen in configurable run time profiles which provide only a
2714 if Is_RTE (Subp, RE_Raise_Exception)
2715 and then RTE_Available (RE_Raise_Exception_Always)
2718 FA : constant Node_Id :=
2719 Original_Node (First_Actual (Call_Node));
2722 -- The case we catch is where the first argument is obtained
2723 -- using the Identity attribute (which must always be
2726 if Nkind (FA) = N_Attribute_Reference
2727 and then Attribute_Name (FA) = Name_Identity
2729 Subp := RTE (RE_Raise_Exception_Always);
2730 Set_Name (Call_Node, New_Occurrence_Of (Subp, Loc));
2735 if Ekind (Subp) = E_Entry then
2736 Parent_Subp := Empty;
2740 -- Ada 2005 (AI-345): We have a procedure call as a triggering
2741 -- alternative in an asynchronous select or as an entry call in
2742 -- a conditional or timed select. Check whether the procedure call
2743 -- is a renaming of an entry and rewrite it as an entry call.
2745 if Ada_Version >= Ada_2005
2746 and then Nkind (Call_Node) = N_Procedure_Call_Statement
2748 ((Nkind (Parent (Call_Node)) = N_Triggering_Alternative
2749 and then Triggering_Statement (Parent (Call_Node)) = Call_Node)
2751 (Nkind (Parent (Call_Node)) = N_Entry_Call_Alternative
2752 and then Entry_Call_Statement (Parent (Call_Node)) = Call_Node))
2756 Ren_Root : Entity_Id := Subp;
2759 -- This may be a chain of renamings, find the root
2761 if Present (Alias (Ren_Root)) then
2762 Ren_Root := Alias (Ren_Root);
2765 if Present (Original_Node (Parent (Parent (Ren_Root)))) then
2766 Ren_Decl := Original_Node (Parent (Parent (Ren_Root)));
2768 if Nkind (Ren_Decl) = N_Subprogram_Renaming_Declaration then
2770 Make_Entry_Call_Statement (Loc,
2772 New_Copy_Tree (Name (Ren_Decl)),
2773 Parameter_Associations =>
2775 (Parameter_Associations (Call_Node))));
2783 if Modify_Tree_For_C
2784 and then Nkind (Call_Node) = N_Function_Call
2785 and then Is_Entity_Name (Name (Call_Node))
2788 Func_Id : constant Entity_Id :=
2789 Ultimate_Alias (Entity (Name (Call_Node)));
2791 -- When generating C code, transform a function call that returns
2792 -- a constrained array type into procedure form.
2794 if Rewritten_For_C (Func_Id) then
2796 -- For internally generated calls ensure that they reference
2797 -- the entity of the spec of the called function (needed since
2798 -- the expander may generate calls using the entity of their
2799 -- body). See for example Expand_Boolean_Operator().
2801 if not (Comes_From_Source (Call_Node))
2802 and then Nkind (Unit_Declaration_Node (Func_Id)) =
2805 Set_Entity (Name (Call_Node),
2806 Corresponding_Function
2807 (Corresponding_Procedure (Func_Id)));
2810 Rewrite_Function_Call_For_C (Call_Node);
2813 -- Also introduce a temporary for functions that return a record
2814 -- called within another procedure or function call, since records
2815 -- are passed by pointer in the generated C code, and we cannot
2816 -- take a pointer from a subprogram call.
2818 elsif Nkind (Parent (Call_Node)) in N_Subprogram_Call
2819 and then Is_Record_Type (Etype (Func_Id))
2822 Temp_Id : constant Entity_Id := Make_Temporary (Loc, 'T');
2827 -- Temp : ... := Func_Call (...);
2830 Make_Object_Declaration (Loc,
2831 Defining_Identifier => Temp_Id,
2832 Object_Definition =>
2833 New_Occurrence_Of (Etype (Func_Id), Loc),
2835 Make_Function_Call (Loc,
2837 New_Occurrence_Of (Func_Id, Loc),
2838 Parameter_Associations =>
2839 Parameter_Associations (Call_Node)));
2841 Insert_Action (Parent (Call_Node), Decl);
2842 Rewrite (Call_Node, New_Occurrence_Of (Temp_Id, Loc));
2849 -- First step, compute extra actuals, corresponding to any Extra_Formals
2850 -- present. Note that we do not access Extra_Formals directly, instead
2851 -- we simply note the presence of the extra formals as we process the
2852 -- regular formals collecting corresponding actuals in Extra_Actuals.
2854 -- We also generate any required range checks for actuals for in formals
2855 -- as we go through the loop, since this is a convenient place to do it.
2856 -- (Though it seems that this would be better done in Expand_Actuals???)
2858 -- Special case: Thunks must not compute the extra actuals; they must
2859 -- just propagate to the target primitive their extra actuals.
2861 if Is_Thunk (Current_Scope)
2862 and then Thunk_Entity (Current_Scope) = Subp
2863 and then Present (Extra_Formals (Subp))
2865 pragma Assert (Present (Extra_Formals (Current_Scope)));
2868 Target_Formal : Entity_Id;
2869 Thunk_Formal : Entity_Id;
2872 Target_Formal := Extra_Formals (Subp);
2873 Thunk_Formal := Extra_Formals (Current_Scope);
2874 while Present (Target_Formal) loop
2876 (Expr => New_Occurrence_Of (Thunk_Formal, Loc),
2877 EF => Thunk_Formal);
2879 Target_Formal := Extra_Formal (Target_Formal);
2880 Thunk_Formal := Extra_Formal (Thunk_Formal);
2883 while Is_Non_Empty_List (Extra_Actuals) loop
2884 Add_Actual_Parameter (Remove_Head (Extra_Actuals));
2887 Expand_Actuals (Call_Node, Subp, Post_Call);
2888 pragma Assert (Is_Empty_List (Post_Call));
2893 Formal := First_Formal (Subp);
2894 Actual := First_Actual (Call_Node);
2896 while Present (Formal) loop
2898 -- Generate range check if required
2900 if Do_Range_Check (Actual)
2901 and then Ekind (Formal) = E_In_Parameter
2903 Generate_Range_Check
2904 (Actual, Etype (Formal), CE_Range_Check_Failed);
2907 -- Prepare to examine current entry
2910 Prev_Orig := Original_Node (Prev);
2912 -- Ada 2005 (AI-251): Check if any formal is a class-wide interface
2913 -- to expand it in a further round.
2915 CW_Interface_Formals_Present :=
2916 CW_Interface_Formals_Present
2918 (Is_Class_Wide_Type (Etype (Formal))
2919 and then Is_Interface (Etype (Etype (Formal))))
2921 (Ekind (Etype (Formal)) = E_Anonymous_Access_Type
2922 and then Is_Class_Wide_Type (Directly_Designated_Type
2923 (Etype (Etype (Formal))))
2924 and then Is_Interface (Directly_Designated_Type
2925 (Etype (Etype (Formal)))));
2927 -- Create possible extra actual for constrained case. Usually, the
2928 -- extra actual is of the form actual'constrained, but since this
2929 -- attribute is only available for unconstrained records, TRUE is
2930 -- expanded if the type of the formal happens to be constrained (for
2931 -- instance when this procedure is inherited from an unconstrained
2932 -- record to a constrained one) or if the actual has no discriminant
2933 -- (its type is constrained). An exception to this is the case of a
2934 -- private type without discriminants. In this case we pass FALSE
2935 -- because the object has underlying discriminants with defaults.
2937 if Present (Extra_Constrained (Formal)) then
2938 if Ekind (Etype (Prev)) in Private_Kind
2939 and then not Has_Discriminants (Base_Type (Etype (Prev)))
2942 (Expr => New_Occurrence_Of (Standard_False, Loc),
2943 EF => Extra_Constrained (Formal));
2945 elsif Is_Constrained (Etype (Formal))
2946 or else not Has_Discriminants (Etype (Prev))
2949 (Expr => New_Occurrence_Of (Standard_True, Loc),
2950 EF => Extra_Constrained (Formal));
2952 -- Do not produce extra actuals for Unchecked_Union parameters.
2953 -- Jump directly to the end of the loop.
2955 elsif Is_Unchecked_Union (Base_Type (Etype (Actual))) then
2956 goto Skip_Extra_Actual_Generation;
2959 -- If the actual is a type conversion, then the constrained
2960 -- test applies to the actual, not the target type.
2966 -- Test for unchecked conversions as well, which can occur
2967 -- as out parameter actuals on calls to stream procedures.
2970 while Nkind_In (Act_Prev, N_Type_Conversion,
2971 N_Unchecked_Type_Conversion)
2973 Act_Prev := Expression (Act_Prev);
2976 -- If the expression is a conversion of a dereference, this
2977 -- is internally generated code that manipulates addresses,
2978 -- e.g. when building interface tables. No check should
2979 -- occur in this case, and the discriminated object is not
2982 if not Comes_From_Source (Actual)
2983 and then Nkind (Actual) = N_Unchecked_Type_Conversion
2984 and then Nkind (Act_Prev) = N_Explicit_Dereference
2987 (Expr => New_Occurrence_Of (Standard_False, Loc),
2988 EF => Extra_Constrained (Formal));
2993 Make_Attribute_Reference (Sloc (Prev),
2995 Duplicate_Subexpr_No_Checks
2996 (Act_Prev, Name_Req => True),
2997 Attribute_Name => Name_Constrained),
2998 EF => Extra_Constrained (Formal));
3004 -- Create possible extra actual for accessibility level
3006 if Present (Extra_Accessibility (Formal)) then
3008 -- Ada 2005 (AI-252): If the actual was rewritten as an Access
3009 -- attribute, then the original actual may be an aliased object
3010 -- occurring as the prefix in a call using "Object.Operation"
3011 -- notation. In that case we must pass the level of the object,
3012 -- so Prev_Orig is reset to Prev and the attribute will be
3013 -- processed by the code for Access attributes further below.
3015 if Prev_Orig /= Prev
3016 and then Nkind (Prev) = N_Attribute_Reference
3017 and then Get_Attribute_Id (Attribute_Name (Prev)) =
3019 and then Is_Aliased_View (Prev_Orig)
3023 -- A class-wide precondition generates a test in which formals of
3024 -- the subprogram are replaced by actuals that came from source.
3025 -- In that case as well, the accessiblity comes from the actual.
3026 -- This is the one case in which there are references to formals
3027 -- outside of their subprogram.
3029 elsif Prev_Orig /= Prev
3030 and then Is_Entity_Name (Prev_Orig)
3031 and then Present (Entity (Prev_Orig))
3032 and then Is_Formal (Entity (Prev_Orig))
3033 and then not In_Open_Scopes (Scope (Entity (Prev_Orig)))
3037 -- If the actual is a formal of an enclosing subprogram it is
3038 -- the right entity, even if it is a rewriting. This happens
3039 -- when the call is within an inherited condition or predicate.
3041 elsif Is_Entity_Name (Actual)
3042 and then Is_Formal (Entity (Actual))
3043 and then In_Open_Scopes (Scope (Entity (Actual)))
3047 elsif Nkind (Prev_Orig) = N_Type_Conversion then
3048 Prev_Orig := Expression (Prev_Orig);
3051 -- Ada 2005 (AI-251): Thunks must propagate the extra actuals of
3052 -- accessibility levels.
3054 if Is_Thunk (Current_Scope) then
3056 Parm_Ent : Entity_Id;
3059 if Is_Controlling_Actual (Actual) then
3061 -- Find the corresponding actual of the thunk
3063 Parm_Ent := First_Entity (Current_Scope);
3064 for J in 2 .. Param_Count loop
3065 Next_Entity (Parm_Ent);
3068 -- Handle unchecked conversion of access types generated
3069 -- in thunks (cf. Expand_Interface_Thunk).
3071 elsif Is_Access_Type (Etype (Actual))
3072 and then Nkind (Actual) = N_Unchecked_Type_Conversion
3074 Parm_Ent := Entity (Expression (Actual));
3076 else pragma Assert (Is_Entity_Name (Actual));
3077 Parm_Ent := Entity (Actual);
3082 New_Occurrence_Of (Extra_Accessibility (Parm_Ent), Loc),
3083 EF => Extra_Accessibility (Formal));
3086 elsif Is_Entity_Name (Prev_Orig) then
3088 -- When passing an access parameter, or a renaming of an access
3089 -- parameter, as the actual to another access parameter we need
3090 -- to pass along the actual's own access level parameter. This
3091 -- is done if we are within the scope of the formal access
3092 -- parameter (if this is an inlined body the extra formal is
3095 if (Is_Formal (Entity (Prev_Orig))
3097 (Present (Renamed_Object (Entity (Prev_Orig)))
3099 Is_Entity_Name (Renamed_Object (Entity (Prev_Orig)))
3102 (Entity (Renamed_Object (Entity (Prev_Orig))))))
3103 and then Ekind (Etype (Prev_Orig)) = E_Anonymous_Access_Type
3104 and then In_Open_Scopes (Scope (Entity (Prev_Orig)))
3107 Parm_Ent : constant Entity_Id := Param_Entity (Prev_Orig);
3110 pragma Assert (Present (Parm_Ent));
3112 if Present (Extra_Accessibility (Parm_Ent)) then
3116 (Extra_Accessibility (Parm_Ent), Loc),
3117 EF => Extra_Accessibility (Formal));
3119 -- If the actual access parameter does not have an
3120 -- associated extra formal providing its scope level,
3121 -- then treat the actual as having library-level
3127 Make_Integer_Literal (Loc,
3128 Intval => Scope_Depth (Standard_Standard)),
3129 EF => Extra_Accessibility (Formal));
3133 -- The actual is a normal access value, so just pass the level
3134 -- of the actual's access type.
3138 (Expr => Dynamic_Accessibility_Level (Prev_Orig),
3139 EF => Extra_Accessibility (Formal));
3142 -- If the actual is an access discriminant, then pass the level
3143 -- of the enclosing object (RM05-3.10.2(12.4/2)).
3145 elsif Nkind (Prev_Orig) = N_Selected_Component
3146 and then Ekind (Entity (Selector_Name (Prev_Orig))) =
3148 and then Ekind (Etype (Entity (Selector_Name (Prev_Orig)))) =
3149 E_Anonymous_Access_Type
3153 Make_Integer_Literal (Loc,
3154 Intval => Object_Access_Level (Prefix (Prev_Orig))),
3155 EF => Extra_Accessibility (Formal));
3160 case Nkind (Prev_Orig) is
3161 when N_Attribute_Reference =>
3162 case Get_Attribute_Id (Attribute_Name (Prev_Orig)) is
3164 -- For X'Access, pass on the level of the prefix X
3166 when Attribute_Access =>
3168 -- Accessibility level of S'Access is that of A
3170 Prev_Orig := Prefix (Prev_Orig);
3172 -- If the expression is a view conversion, the
3173 -- accessibility level is that of the expression.
3175 if Nkind (Original_Node (Prev_Orig)) =
3178 Nkind (Expression (Original_Node (Prev_Orig))) =
3179 N_Explicit_Dereference
3182 Expression (Original_Node (Prev_Orig));
3185 -- If this is an Access attribute applied to the
3186 -- the current instance object passed to a type
3187 -- initialization procedure, then use the level
3188 -- of the type itself. This is not really correct,
3189 -- as there should be an extra level parameter
3190 -- passed in with _init formals (only in the case
3191 -- where the type is immutably limited), but we
3192 -- don't have an easy way currently to create such
3193 -- an extra formal (init procs aren't ever frozen).
3194 -- For now we just use the level of the type,
3195 -- which may be too shallow, but that works better
3196 -- than passing Object_Access_Level of the type,
3197 -- which can be one level too deep in some cases.
3200 -- A further case that requires special handling
3201 -- is the common idiom E.all'access. If E is a
3202 -- formal of the enclosing subprogram, the
3203 -- accessibility of the expression is that of E.
3205 if Is_Entity_Name (Prev_Orig) then
3206 Pref_Entity := Entity (Prev_Orig);
3208 elsif Nkind (Prev_Orig) = N_Explicit_Dereference
3209 and then Is_Entity_Name (Prefix (Prev_Orig))
3211 Pref_Entity := Entity (Prefix ((Prev_Orig)));
3214 Pref_Entity := Empty;
3217 if Is_Entity_Name (Prev_Orig)
3218 and then Is_Type (Entity (Prev_Orig))
3222 Make_Integer_Literal (Loc,
3224 Type_Access_Level (Pref_Entity)),
3225 EF => Extra_Accessibility (Formal));
3227 elsif Nkind (Prev_Orig) = N_Explicit_Dereference
3228 and then Present (Pref_Entity)
3229 and then Is_Formal (Pref_Entity)
3231 (Extra_Accessibility (Pref_Entity))
3236 (Extra_Accessibility (Pref_Entity), Loc),
3237 EF => Extra_Accessibility (Formal));
3242 Make_Integer_Literal (Loc,
3244 Object_Access_Level (Prev_Orig)),
3245 EF => Extra_Accessibility (Formal));
3248 -- Treat the unchecked attributes as library-level
3250 when Attribute_Unchecked_Access
3251 | Attribute_Unrestricted_Access
3255 Make_Integer_Literal (Loc,
3256 Intval => Scope_Depth (Standard_Standard)),
3257 EF => Extra_Accessibility (Formal));
3259 -- No other cases of attributes returning access
3260 -- values that can be passed to access parameters.
3263 raise Program_Error;
3267 -- For allocators we pass the level of the execution of the
3268 -- called subprogram, which is one greater than the current
3274 Make_Integer_Literal (Loc,
3275 Intval => Scope_Depth (Current_Scope) + 1),
3276 EF => Extra_Accessibility (Formal));
3278 -- For most other cases we simply pass the level of the
3279 -- actual's access type. The type is retrieved from
3280 -- Prev rather than Prev_Orig, because in some cases
3281 -- Prev_Orig denotes an original expression that has
3282 -- not been analyzed.
3286 (Expr => Dynamic_Accessibility_Level (Prev),
3287 EF => Extra_Accessibility (Formal));
3292 -- Perform the check of 4.6(49) that prevents a null value from being
3293 -- passed as an actual to an access parameter. Note that the check
3294 -- is elided in the common cases of passing an access attribute or
3295 -- access parameter as an actual. Also, we currently don't enforce
3296 -- this check for expander-generated actuals and when -gnatdj is set.
3298 if Ada_Version >= Ada_2005 then
3300 -- Ada 2005 (AI-231): Check null-excluding access types. Note that
3301 -- the intent of 6.4.1(13) is that null-exclusion checks should
3302 -- not be done for 'out' parameters, even though it refers only
3303 -- to constraint checks, and a null_exclusion is not a constraint.
3304 -- Note that AI05-0196-1 corrects this mistake in the RM.
3306 if Is_Access_Type (Etype (Formal))
3307 and then Can_Never_Be_Null (Etype (Formal))
3308 and then Ekind (Formal) /= E_Out_Parameter
3309 and then Nkind (Prev) /= N_Raise_Constraint_Error
3310 and then (Known_Null (Prev)
3311 or else not Can_Never_Be_Null (Etype (Prev)))
3313 Install_Null_Excluding_Check (Prev);
3316 -- Ada_Version < Ada_2005
3319 if Ekind (Etype (Formal)) /= E_Anonymous_Access_Type
3320 or else Access_Checks_Suppressed (Subp)
3324 elsif Debug_Flag_J then
3327 elsif not Comes_From_Source (Prev) then
3330 elsif Is_Entity_Name (Prev)
3331 and then Ekind (Etype (Prev)) = E_Anonymous_Access_Type
3335 elsif Nkind_In (Prev, N_Allocator, N_Attribute_Reference) then
3339 Install_Null_Excluding_Check (Prev);
3343 -- Perform appropriate validity checks on parameters that
3346 if Validity_Checks_On then
3347 if (Ekind (Formal) = E_In_Parameter
3348 and then Validity_Check_In_Params)
3350 (Ekind (Formal) = E_In_Out_Parameter
3351 and then Validity_Check_In_Out_Params)
3353 -- If the actual is an indexed component of a packed type (or
3354 -- is an indexed or selected component whose prefix recursively
3355 -- meets this condition), it has not been expanded yet. It will
3356 -- be copied in the validity code that follows, and has to be
3357 -- expanded appropriately, so reanalyze it.
3359 -- What we do is just to unset analyzed bits on prefixes till
3360 -- we reach something that does not have a prefix.
3367 while Nkind_In (Nod, N_Indexed_Component,
3368 N_Selected_Component)
3370 Set_Analyzed (Nod, False);
3371 Nod := Prefix (Nod);
3375 Ensure_Valid (Actual);
3379 -- For IN OUT and OUT parameters, ensure that subscripts are valid
3380 -- since this is a left side reference. We only do this for calls
3381 -- from the source program since we assume that compiler generated
3382 -- calls explicitly generate any required checks. We also need it
3383 -- only if we are doing standard validity checks, since clearly it is
3384 -- not needed if validity checks are off, and in subscript validity
3385 -- checking mode, all indexed components are checked with a call
3386 -- directly from Expand_N_Indexed_Component.
3388 if Comes_From_Source (Call_Node)
3389 and then Ekind (Formal) /= E_In_Parameter
3390 and then Validity_Checks_On
3391 and then Validity_Check_Default
3392 and then not Validity_Check_Subscripts
3394 Check_Valid_Lvalue_Subscripts (Actual);
3397 -- Mark any scalar OUT parameter that is a simple variable as no
3398 -- longer known to be valid (unless the type is always valid). This
3399 -- reflects the fact that if an OUT parameter is never set in a
3400 -- procedure, then it can become invalid on the procedure return.
3402 if Ekind (Formal) = E_Out_Parameter
3403 and then Is_Entity_Name (Actual)
3404 and then Ekind (Entity (Actual)) = E_Variable
3405 and then not Is_Known_Valid (Etype (Actual))
3407 Set_Is_Known_Valid (Entity (Actual), False);
3410 -- For an OUT or IN OUT parameter, if the actual is an entity, then
3411 -- clear current values, since they can be clobbered. We are probably
3412 -- doing this in more places than we need to, but better safe than
3413 -- sorry when it comes to retaining bad current values.
3415 if Ekind (Formal) /= E_In_Parameter
3416 and then Is_Entity_Name (Actual)
3417 and then Present (Entity (Actual))
3420 Ent : constant Entity_Id := Entity (Actual);
3424 -- For an OUT or IN OUT parameter that is an assignable entity,
3425 -- we do not want to clobber the Last_Assignment field, since
3426 -- if it is set, it was precisely because it is indeed an OUT
3427 -- or IN OUT parameter. We do reset the Is_Known_Valid flag
3428 -- since the subprogram could have returned in invalid value.
3430 if Ekind_In (Formal, E_Out_Parameter, E_In_Out_Parameter)
3431 and then Is_Assignable (Ent)
3433 Sav := Last_Assignment (Ent);
3434 Kill_Current_Values (Ent);
3435 Set_Last_Assignment (Ent, Sav);
3436 Set_Is_Known_Valid (Ent, False);
3438 -- For all other cases, just kill the current values
3441 Kill_Current_Values (Ent);
3446 -- If the formal is class wide and the actual is an aggregate, force
3447 -- evaluation so that the back end who does not know about class-wide
3448 -- type, does not generate a temporary of the wrong size.
3450 if not Is_Class_Wide_Type (Etype (Formal)) then
3453 elsif Nkind (Actual) = N_Aggregate
3454 or else (Nkind (Actual) = N_Qualified_Expression
3455 and then Nkind (Expression (Actual)) = N_Aggregate)
3457 Force_Evaluation (Actual);
3460 -- In a remote call, if the formal is of a class-wide type, check
3461 -- that the actual meets the requirements described in E.4(18).
3463 if Remote and then Is_Class_Wide_Type (Etype (Formal)) then
3464 Insert_Action (Actual,
3465 Make_Transportable_Check (Loc,
3466 Duplicate_Subexpr_Move_Checks (Actual)));
3469 -- Perform invariant checks for all intermediate types in a view
3470 -- conversion after successful return from a call that passes the
3471 -- view conversion as an IN OUT or OUT parameter (RM 7.3.2 (12/3,
3472 -- 13/3, 14/3)). Consider only source conversion in order to avoid
3473 -- generating spurious checks on complex expansion such as object
3474 -- initialization through an extension aggregate.
3476 if Comes_From_Source (N)
3477 and then Ekind (Formal) /= E_In_Parameter
3478 and then Nkind (Actual) = N_Type_Conversion
3480 Add_View_Conversion_Invariants (Formal, Actual);
3483 -- Generating C the initialization of an allocator is performed by
3484 -- means of individual statements, and hence it must be done before
3487 if Modify_Tree_For_C
3488 and then Nkind (Actual) = N_Allocator
3489 and then Nkind (Expression (Actual)) = N_Qualified_Expression
3491 Remove_Side_Effects (Actual);
3494 -- This label is required when skipping extra actual generation for
3495 -- Unchecked_Union parameters.
3497 <<Skip_Extra_Actual_Generation>>
3499 Param_Count := Param_Count + 1;
3500 Next_Actual (Actual);
3501 Next_Formal (Formal);
3504 -- If we are calling an Ada 2012 function which needs to have the
3505 -- "accessibility level determined by the point of call" (AI05-0234)
3506 -- passed in to it, then pass it in.
3508 if Ekind_In (Subp, E_Function, E_Operator, E_Subprogram_Type)
3510 Present (Extra_Accessibility_Of_Result (Ultimate_Alias (Subp)))
3513 Ancestor : Node_Id := Parent (Call_Node);
3514 Level : Node_Id := Empty;
3515 Defer : Boolean := False;
3518 -- Unimplemented: if Subp returns an anonymous access type, then
3520 -- a) if the call is the operand of an explict conversion, then
3521 -- the target type of the conversion (a named access type)
3522 -- determines the accessibility level pass in;
3524 -- b) if the call defines an access discriminant of an object
3525 -- (e.g., the discriminant of an object being created by an
3526 -- allocator, or the discriminant of a function result),
3527 -- then the accessibility level to pass in is that of the
3528 -- discriminated object being initialized).
3532 while Nkind (Ancestor) = N_Qualified_Expression
3534 Ancestor := Parent (Ancestor);
3537 case Nkind (Ancestor) is
3540 -- At this point, we'd like to assign
3542 -- Level := Dynamic_Accessibility_Level (Ancestor);
3544 -- but Etype of Ancestor may not have been set yet,
3545 -- so that doesn't work.
3547 -- Handle this later in Expand_Allocator_Expression.
3551 when N_Object_Declaration
3552 | N_Object_Renaming_Declaration
3555 Def_Id : constant Entity_Id :=
3556 Defining_Identifier (Ancestor);
3559 if Is_Return_Object (Def_Id) then
3560 if Present (Extra_Accessibility_Of_Result
3561 (Return_Applies_To (Scope (Def_Id))))
3563 -- Pass along value that was passed in if the
3564 -- routine we are returning from also has an
3565 -- Accessibility_Of_Result formal.
3569 (Extra_Accessibility_Of_Result
3570 (Return_Applies_To (Scope (Def_Id))), Loc);
3574 Make_Integer_Literal (Loc,
3575 Intval => Object_Access_Level (Def_Id));
3579 when N_Simple_Return_Statement =>
3580 if Present (Extra_Accessibility_Of_Result
3582 (Return_Statement_Entity (Ancestor))))
3584 -- Pass along value that was passed in if the returned
3585 -- routine also has an Accessibility_Of_Result formal.
3589 (Extra_Accessibility_Of_Result
3591 (Return_Statement_Entity (Ancestor))), Loc);
3599 if not Present (Level) then
3601 -- The "innermost master that evaluates the function call".
3603 -- ??? - Should we use Integer'Last here instead in order
3604 -- to deal with (some of) the problems associated with
3605 -- calls to subps whose enclosing scope is unknown (e.g.,
3606 -- Anon_Access_To_Subp_Param.all)?
3609 Make_Integer_Literal (Loc,
3610 Intval => Scope_Depth (Current_Scope) + 1);
3616 Extra_Accessibility_Of_Result (Ultimate_Alias (Subp)));
3621 -- If we are expanding the RHS of an assignment we need to check if tag
3622 -- propagation is needed. You might expect this processing to be in
3623 -- Analyze_Assignment but has to be done earlier (bottom-up) because the
3624 -- assignment might be transformed to a declaration for an unconstrained
3625 -- value if the expression is classwide.
3627 if Nkind (Call_Node) = N_Function_Call
3628 and then Is_Tag_Indeterminate (Call_Node)
3629 and then Is_Entity_Name (Name (Call_Node))
3632 Ass : Node_Id := Empty;
3635 if Nkind (Parent (Call_Node)) = N_Assignment_Statement then
3636 Ass := Parent (Call_Node);
3638 elsif Nkind (Parent (Call_Node)) = N_Qualified_Expression
3639 and then Nkind (Parent (Parent (Call_Node))) =
3640 N_Assignment_Statement
3642 Ass := Parent (Parent (Call_Node));
3644 elsif Nkind (Parent (Call_Node)) = N_Explicit_Dereference
3645 and then Nkind (Parent (Parent (Call_Node))) =
3646 N_Assignment_Statement
3648 Ass := Parent (Parent (Call_Node));
3652 and then Is_Class_Wide_Type (Etype (Name (Ass)))
3654 if Is_Access_Type (Etype (Call_Node)) then
3655 if Designated_Type (Etype (Call_Node)) /=
3656 Root_Type (Etype (Name (Ass)))
3659 ("tag-indeterminate expression must have designated "
3660 & "type& (RM 5.2 (6))",
3661 Call_Node, Root_Type (Etype (Name (Ass))));
3663 Propagate_Tag (Name (Ass), Call_Node);
3666 elsif Etype (Call_Node) /= Root_Type (Etype (Name (Ass))) then
3668 ("tag-indeterminate expression must have type & "
3670 Call_Node, Root_Type (Etype (Name (Ass))));
3673 Propagate_Tag (Name (Ass), Call_Node);
3676 -- The call will be rewritten as a dispatching call, and
3677 -- expanded as such.
3684 -- Ada 2005 (AI-251): If some formal is a class-wide interface, expand
3685 -- it to point to the correct secondary virtual table
3687 if Nkind (Call_Node) in N_Subprogram_Call
3688 and then CW_Interface_Formals_Present
3690 Expand_Interface_Actuals (Call_Node);
3693 -- Deals with Dispatch_Call if we still have a call, before expanding
3694 -- extra actuals since this will be done on the re-analysis of the
3695 -- dispatching call. Note that we do not try to shorten the actual list
3696 -- for a dispatching call, it would not make sense to do so. Expansion
3697 -- of dispatching calls is suppressed for VM targets, because the VM
3698 -- back-ends directly handle the generation of dispatching calls and
3699 -- would have to undo any expansion to an indirect call.
3701 if Nkind (Call_Node) in N_Subprogram_Call
3702 and then Present (Controlling_Argument (Call_Node))
3705 Call_Typ : constant Entity_Id := Etype (Call_Node);
3706 Typ : constant Entity_Id := Find_Dispatching_Type (Subp);
3707 Eq_Prim_Op : Entity_Id := Empty;
3710 Prev_Call : Node_Id;
3713 if not Is_Limited_Type (Typ) then
3714 Eq_Prim_Op := Find_Prim_Op (Typ, Name_Op_Eq);
3717 if Tagged_Type_Expansion then
3718 Expand_Dispatching_Call (Call_Node);
3720 -- The following return is worrisome. Is it really OK to skip
3721 -- all remaining processing in this procedure ???
3728 Apply_Tag_Checks (Call_Node);
3730 -- If this is a dispatching "=", we must first compare the
3731 -- tags so we generate: x.tag = y.tag and then x = y
3733 if Subp = Eq_Prim_Op then
3735 -- Mark the node as analyzed to avoid reanalyzing this
3736 -- dispatching call (which would cause a never-ending loop)
3738 Prev_Call := Relocate_Node (Call_Node);
3739 Set_Analyzed (Prev_Call);
3741 Param := First_Actual (Call_Node);
3747 Make_Selected_Component (Loc,
3748 Prefix => New_Value (Param),
3751 (First_Tag_Component (Typ), Loc)),
3754 Make_Selected_Component (Loc,
3756 Unchecked_Convert_To (Typ,
3757 New_Value (Next_Actual (Param))),
3760 (First_Tag_Component (Typ), Loc))),
3761 Right_Opnd => Prev_Call);
3763 Rewrite (Call_Node, New_Call);
3766 (Call_Node, Call_Typ, Suppress => All_Checks);
3769 -- Expansion of a dispatching call results in an indirect call,
3770 -- which in turn causes current values to be killed (see
3771 -- Resolve_Call), so on VM targets we do the call here to
3772 -- ensure consistent warnings between VM and non-VM targets.
3774 Kill_Current_Values;
3777 -- If this is a dispatching "=" then we must update the reference
3778 -- to the call node because we generated:
3779 -- x.tag = y.tag and then x = y
3781 if Subp = Eq_Prim_Op then
3782 Call_Node := Right_Opnd (Call_Node);
3787 -- Similarly, expand calls to RCI subprograms on which pragma
3788 -- All_Calls_Remote applies. The rewriting will be reanalyzed
3789 -- later. Do this only when the call comes from source since we
3790 -- do not want such a rewriting to occur in expanded code.
3792 if Is_All_Remote_Call (Call_Node) then
3793 Expand_All_Calls_Remote_Subprogram_Call (Call_Node);
3795 -- Similarly, do not add extra actuals for an entry call whose entity
3796 -- is a protected procedure, or for an internal protected subprogram
3797 -- call, because it will be rewritten as a protected subprogram call
3798 -- and reanalyzed (see Expand_Protected_Subprogram_Call).
3800 elsif Is_Protected_Type (Scope (Subp))
3801 and then (Ekind (Subp) = E_Procedure
3802 or else Ekind (Subp) = E_Function)
3806 -- During that loop we gathered the extra actuals (the ones that
3807 -- correspond to Extra_Formals), so now they can be appended.
3810 while Is_Non_Empty_List (Extra_Actuals) loop
3811 Add_Actual_Parameter (Remove_Head (Extra_Actuals));
3815 -- At this point we have all the actuals, so this is the point at which
3816 -- the various expansion activities for actuals is carried out.
3818 Expand_Actuals (Call_Node, Subp, Post_Call);
3820 -- Verify that the actuals do not share storage. This check must be done
3821 -- on the caller side rather that inside the subprogram to avoid issues
3822 -- of parameter passing.
3824 if Check_Aliasing_Of_Parameters then
3825 Apply_Parameter_Aliasing_Checks (Call_Node, Subp);
3828 -- If the subprogram is a renaming, or if it is inherited, replace it in
3829 -- the call with the name of the actual subprogram being called. If this
3830 -- is a dispatching call, the run-time decides what to call. The Alias
3831 -- attribute does not apply to entries.
3833 if Nkind (Call_Node) /= N_Entry_Call_Statement
3834 and then No (Controlling_Argument (Call_Node))
3835 and then Present (Parent_Subp)
3836 and then not Is_Direct_Deep_Call (Subp)
3838 if Present (Inherited_From_Formal (Subp)) then
3839 Parent_Subp := Inherited_From_Formal (Subp);
3841 Parent_Subp := Ultimate_Alias (Parent_Subp);
3844 -- The below setting of Entity is suspect, see F109-018 discussion???
3846 Set_Entity (Name (Call_Node), Parent_Subp);
3848 if Is_Abstract_Subprogram (Parent_Subp)
3849 and then not In_Instance
3852 ("cannot call abstract subprogram &!",
3853 Name (Call_Node), Parent_Subp);
3856 -- Inspect all formals of derived subprogram Subp. Compare parameter
3857 -- types with the parent subprogram and check whether an actual may
3858 -- need a type conversion to the corresponding formal of the parent
3861 -- Not clear whether intrinsic subprograms need such conversions. ???
3863 if not Is_Intrinsic_Subprogram (Parent_Subp)
3864 or else Is_Generic_Instance (Parent_Subp)
3867 procedure Convert (Act : Node_Id; Typ : Entity_Id);
3868 -- Rewrite node Act as a type conversion of Act to Typ. Analyze
3869 -- and resolve the newly generated construct.
3875 procedure Convert (Act : Node_Id; Typ : Entity_Id) is
3877 Rewrite (Act, OK_Convert_To (Typ, Relocate_Node (Act)));
3884 Actual_Typ : Entity_Id;
3885 Formal_Typ : Entity_Id;
3886 Parent_Typ : Entity_Id;
3889 Actual := First_Actual (Call_Node);
3890 Formal := First_Formal (Subp);
3891 Parent_Formal := First_Formal (Parent_Subp);
3892 while Present (Formal) loop
3893 Actual_Typ := Etype (Actual);
3894 Formal_Typ := Etype (Formal);
3895 Parent_Typ := Etype (Parent_Formal);
3897 -- For an IN parameter of a scalar type, the parent formal
3898 -- type and derived formal type differ or the parent formal
3899 -- type and actual type do not match statically.
3901 if Is_Scalar_Type (Formal_Typ)
3902 and then Ekind (Formal) = E_In_Parameter
3903 and then Formal_Typ /= Parent_Typ
3905 not Subtypes_Statically_Match (Parent_Typ, Actual_Typ)
3906 and then not Raises_Constraint_Error (Actual)
3908 Convert (Actual, Parent_Typ);
3909 Enable_Range_Check (Actual);
3911 -- If the actual has been marked as requiring a range
3912 -- check, then generate it here.
3914 if Do_Range_Check (Actual) then
3915 Generate_Range_Check
3916 (Actual, Etype (Formal), CE_Range_Check_Failed);
3919 -- For access types, the parent formal type and actual type
3922 elsif Is_Access_Type (Formal_Typ)
3923 and then Base_Type (Parent_Typ) /= Base_Type (Actual_Typ)
3925 if Ekind (Formal) /= E_In_Parameter then
3926 Convert (Actual, Parent_Typ);
3928 elsif Ekind (Parent_Typ) = E_Anonymous_Access_Type
3929 and then Designated_Type (Parent_Typ) /=
3930 Designated_Type (Actual_Typ)
3931 and then not Is_Controlling_Formal (Formal)
3933 -- This unchecked conversion is not necessary unless
3934 -- inlining is enabled, because in that case the type
3935 -- mismatch may become visible in the body about to be
3939 Unchecked_Convert_To (Parent_Typ,
3940 Relocate_Node (Actual)));
3942 Resolve (Actual, Parent_Typ);
3945 -- If there is a change of representation, then generate a
3946 -- warning, and do the change of representation.
3948 elsif not Same_Representation (Formal_Typ, Parent_Typ) then
3950 ("??change of representation required", Actual);
3951 Convert (Actual, Parent_Typ);
3953 -- For array and record types, the parent formal type and
3954 -- derived formal type have different sizes or pragma Pack
3957 elsif ((Is_Array_Type (Formal_Typ)
3958 and then Is_Array_Type (Parent_Typ))
3960 (Is_Record_Type (Formal_Typ)
3961 and then Is_Record_Type (Parent_Typ)))
3963 (Esize (Formal_Typ) /= Esize (Parent_Typ)
3964 or else Has_Pragma_Pack (Formal_Typ) /=
3965 Has_Pragma_Pack (Parent_Typ))
3967 Convert (Actual, Parent_Typ);
3970 Next_Actual (Actual);
3971 Next_Formal (Formal);
3972 Next_Formal (Parent_Formal);
3978 Subp := Parent_Subp;
3981 -- Deal with case where call is an explicit dereference
3983 if Nkind (Name (Call_Node)) = N_Explicit_Dereference then
3985 -- Handle case of access to protected subprogram type
3987 if Is_Access_Protected_Subprogram_Type
3988 (Base_Type (Etype (Prefix (Name (Call_Node)))))
3990 -- If this is a call through an access to protected operation, the
3991 -- prefix has the form (object'address, operation'access). Rewrite
3992 -- as a for other protected calls: the object is the 1st parameter
3993 -- of the list of actuals.
4000 Ptr : constant Node_Id := Prefix (Name (Call_Node));
4002 T : constant Entity_Id :=
4003 Equivalent_Type (Base_Type (Etype (Ptr)));
4005 D_T : constant Entity_Id :=
4006 Designated_Type (Base_Type (Etype (Ptr)));
4010 Make_Selected_Component (Loc,
4011 Prefix => Unchecked_Convert_To (T, Ptr),
4013 New_Occurrence_Of (First_Entity (T), Loc));
4016 Make_Selected_Component (Loc,
4017 Prefix => Unchecked_Convert_To (T, Ptr),
4019 New_Occurrence_Of (Next_Entity (First_Entity (T)), Loc));
4022 Make_Explicit_Dereference (Loc,
4025 if Present (Parameter_Associations (Call_Node)) then
4026 Parm := Parameter_Associations (Call_Node);
4031 Prepend (Obj, Parm);
4033 if Etype (D_T) = Standard_Void_Type then
4035 Make_Procedure_Call_Statement (Loc,
4037 Parameter_Associations => Parm);
4040 Make_Function_Call (Loc,
4042 Parameter_Associations => Parm);
4045 Set_First_Named_Actual (Call, First_Named_Actual (Call_Node));
4046 Set_Etype (Call, Etype (D_T));
4048 -- We do not re-analyze the call to avoid infinite recursion.
4049 -- We analyze separately the prefix and the object, and set
4050 -- the checks on the prefix that would otherwise be emitted
4051 -- when resolving a call.
4053 Rewrite (Call_Node, Call);
4055 Apply_Access_Check (Nam);
4062 -- If this is a call to an intrinsic subprogram, then perform the
4063 -- appropriate expansion to the corresponding tree node and we
4064 -- are all done (since after that the call is gone).
4066 -- In the case where the intrinsic is to be processed by the back end,
4067 -- the call to Expand_Intrinsic_Call will do nothing, which is fine,
4068 -- since the idea in this case is to pass the call unchanged. If the
4069 -- intrinsic is an inherited unchecked conversion, and the derived type
4070 -- is the target type of the conversion, we must retain it as the return
4071 -- type of the expression. Otherwise the expansion below, which uses the
4072 -- parent operation, will yield the wrong type.
4074 if Is_Intrinsic_Subprogram (Subp) then
4075 Expand_Intrinsic_Call (Call_Node, Subp);
4077 if Nkind (Call_Node) = N_Unchecked_Type_Conversion
4078 and then Parent_Subp /= Orig_Subp
4079 and then Etype (Parent_Subp) /= Etype (Orig_Subp)
4081 Set_Etype (Call_Node, Etype (Orig_Subp));
4087 if Ekind_In (Subp, E_Function, E_Procedure) then
4089 -- We perform a simple optimization on calls for To_Address by
4090 -- replacing them with an unchecked conversion. Not only is this
4091 -- efficient, but it also avoids order of elaboration problems when
4092 -- address clauses are inlined (address expression elaborated at the
4095 -- We perform this optimization regardless of whether we are in the
4096 -- main unit or in a unit in the context of the main unit, to ensure
4097 -- that the generated tree is the same in both cases, for CodePeer
4100 if Is_RTE (Subp, RE_To_Address) then
4102 Unchecked_Convert_To
4103 (RTE (RE_Address), Relocate_Node (First_Actual (Call_Node))));
4106 -- A call to a null procedure is replaced by a null statement, but we
4107 -- are not allowed to ignore possible side effects of the call, so we
4108 -- make sure that actuals are evaluated.
4109 -- We also suppress this optimization for GNATCoverage.
4111 elsif Is_Null_Procedure (Subp)
4112 and then not Opt.Suppress_Control_Flow_Optimizations
4114 Actual := First_Actual (Call_Node);
4115 while Present (Actual) loop
4116 Remove_Side_Effects (Actual);
4117 Next_Actual (Actual);
4120 Rewrite (Call_Node, Make_Null_Statement (Loc));
4124 -- Handle inlining. No action needed if the subprogram is not inlined
4126 if not Is_Inlined (Subp) then
4129 -- Frontend inlining of expression functions (performed also when
4130 -- backend inlining is enabled).
4132 elsif Is_Inlinable_Expression_Function (Subp) then
4133 Rewrite (N, New_Copy (Expression_Of_Expression_Function (Subp)));
4137 -- Handle frontend inlining
4139 elsif not Back_End_Inlining then
4140 Inlined_Subprogram : declare
4142 Must_Inline : Boolean := False;
4143 Spec : constant Node_Id := Unit_Declaration_Node (Subp);
4146 -- Verify that the body to inline has already been seen, and
4147 -- that if the body is in the current unit the inlining does
4148 -- not occur earlier. This avoids order-of-elaboration problems
4151 -- This should be documented in sinfo/einfo ???
4154 or else Nkind (Spec) /= N_Subprogram_Declaration
4155 or else No (Body_To_Inline (Spec))
4157 Must_Inline := False;
4159 -- If this an inherited function that returns a private type,
4160 -- do not inline if the full view is an unconstrained array,
4161 -- because such calls cannot be inlined.
4163 elsif Present (Orig_Subp)
4164 and then Is_Array_Type (Etype (Orig_Subp))
4165 and then not Is_Constrained (Etype (Orig_Subp))
4167 Must_Inline := False;
4169 elsif In_Unfrozen_Instance (Scope (Subp)) then
4170 Must_Inline := False;
4173 Bod := Body_To_Inline (Spec);
4175 if (In_Extended_Main_Code_Unit (Call_Node)
4176 or else In_Extended_Main_Code_Unit (Parent (Call_Node))
4177 or else Has_Pragma_Inline_Always (Subp))
4178 and then (not In_Same_Extended_Unit (Sloc (Bod), Loc)
4180 Earlier_In_Extended_Unit (Sloc (Bod), Loc))
4182 Must_Inline := True;
4184 -- If we are compiling a package body that is not the main
4185 -- unit, it must be for inlining/instantiation purposes,
4186 -- in which case we inline the call to insure that the same
4187 -- temporaries are generated when compiling the body by
4188 -- itself. Otherwise link errors can occur.
4190 -- If the function being called is itself in the main unit,
4191 -- we cannot inline, because there is a risk of double
4192 -- elaboration and/or circularity: the inlining can make
4193 -- visible a private entity in the body of the main unit,
4194 -- that gigi will see before its sees its proper definition.
4196 elsif not (In_Extended_Main_Code_Unit (Call_Node))
4197 and then In_Package_Body
4199 Must_Inline := not In_Extended_Main_Source_Unit (Subp);
4201 -- Inline calls to _postconditions when generating C code
4203 elsif Modify_Tree_For_C
4204 and then In_Same_Extended_Unit (Sloc (Bod), Loc)
4205 and then Chars (Name (N)) = Name_uPostconditions
4207 Must_Inline := True;
4212 Expand_Inlined_Call (Call_Node, Subp, Orig_Subp);
4215 -- Let the back end handle it
4217 Add_Inlined_Body (Subp, Call_Node);
4219 if Front_End_Inlining
4220 and then Nkind (Spec) = N_Subprogram_Declaration
4221 and then (In_Extended_Main_Code_Unit (Call_Node))
4222 and then No (Body_To_Inline (Spec))
4223 and then not Has_Completion (Subp)
4224 and then In_Same_Extended_Unit (Sloc (Spec), Loc)
4227 ("cannot inline& (body not seen yet)?",
4231 end Inlined_Subprogram;
4233 -- Back end inlining: let the back end handle it
4235 elsif No (Unit_Declaration_Node (Subp))
4236 or else Nkind (Unit_Declaration_Node (Subp)) /=
4237 N_Subprogram_Declaration
4238 or else No (Body_To_Inline (Unit_Declaration_Node (Subp)))
4239 or else Nkind (Body_To_Inline (Unit_Declaration_Node (Subp))) in
4242 Add_Inlined_Body (Subp, Call_Node);
4244 -- If the inlined call appears within an instantiation and some
4245 -- level of optimization is required, ensure that the enclosing
4246 -- instance body is available so that the back-end can actually
4247 -- perform the inlining.
4250 and then Comes_From_Source (Subp)
4251 and then Optimization_Level > 0
4256 Inst_Node : Node_Id;
4259 Inst := Scope (Subp);
4261 -- Find enclosing instance
4263 while Present (Inst) and then Inst /= Standard_Standard loop
4264 exit when Is_Generic_Instance (Inst);
4265 Inst := Scope (Inst);
4269 and then Is_Generic_Instance (Inst)
4270 and then not Is_Inlined (Inst)
4272 Set_Is_Inlined (Inst);
4273 Decl := Unit_Declaration_Node (Inst);
4275 -- Do not add a pending instantiation if the body exits
4276 -- already, or if the instance is a compilation unit, or
4277 -- the instance node is missing.
4279 if Present (Corresponding_Body (Decl))
4280 or else Nkind (Parent (Decl)) = N_Compilation_Unit
4281 or else No (Next (Decl))
4286 -- The instantiation node usually follows the package
4287 -- declaration for the instance. If the generic unit
4288 -- has aspect specifications, they are transformed
4289 -- into pragmas in the instance, and the instance node
4290 -- appears after them.
4292 Inst_Node := Next (Decl);
4294 while Nkind (Inst_Node) /= N_Package_Instantiation loop
4295 Inst_Node := Next (Inst_Node);
4298 Add_Pending_Instantiation (Inst_Node, Decl);
4304 -- Front end expansion of simple functions returning unconstrained
4305 -- types (see Check_And_Split_Unconstrained_Function). Note that the
4306 -- case of a simple renaming (Body_To_Inline in N_Entity above, see
4307 -- also Build_Renamed_Body) cannot be expanded here because this may
4308 -- give rise to order-of-elaboration issues for the types of the
4309 -- parameters of the subprogram, if any.
4312 Expand_Inlined_Call (Call_Node, Subp, Orig_Subp);
4316 -- Check for protected subprogram. This is either an intra-object call,
4317 -- or a protected function call. Protected procedure calls are rewritten
4318 -- as entry calls and handled accordingly.
4320 -- In Ada 2005, this may be an indirect call to an access parameter that
4321 -- is an access_to_subprogram. In that case the anonymous type has a
4322 -- scope that is a protected operation, but the call is a regular one.
4323 -- In either case do not expand call if subprogram is eliminated.
4325 Scop := Scope (Subp);
4327 if Nkind (Call_Node) /= N_Entry_Call_Statement
4328 and then Is_Protected_Type (Scop)
4329 and then Ekind (Subp) /= E_Subprogram_Type
4330 and then not Is_Eliminated (Subp)
4332 -- If the call is an internal one, it is rewritten as a call to the
4333 -- corresponding unprotected subprogram.
4335 Expand_Protected_Subprogram_Call (Call_Node, Subp, Scop);
4338 -- Functions returning controlled objects need special attention. If
4339 -- the return type is limited, then the context is initialization and
4340 -- different processing applies. If the call is to a protected function,
4341 -- the expansion above will call Expand_Call recursively. Otherwise the
4342 -- function call is transformed into a temporary which obtains the
4343 -- result from the secondary stack.
4345 if Needs_Finalization (Etype (Subp)) then
4346 if not Is_Build_In_Place_Function_Call (Call_Node)
4348 (No (First_Formal (Subp))
4350 not Is_Concurrent_Record_Type (Etype (First_Formal (Subp))))
4352 Expand_Ctrl_Function_Call (Call_Node);
4354 -- Build-in-place function calls which appear in anonymous contexts
4355 -- need a transient scope to ensure the proper finalization of the
4356 -- intermediate result after its use.
4358 elsif Is_Build_In_Place_Function_Call (Call_Node)
4359 and then Nkind_In (Parent (Unqual_Conv (Call_Node)),
4360 N_Attribute_Reference,
4362 N_Indexed_Component,
4363 N_Object_Renaming_Declaration,
4364 N_Procedure_Call_Statement,
4365 N_Selected_Component,
4368 (Ekind (Current_Scope) /= E_Loop
4369 or else Nkind (Parent (N)) /= N_Function_Call
4370 or else not Is_Build_In_Place_Function_Call (Parent (N)))
4372 Establish_Transient_Scope (Call_Node, Sec_Stack => True);
4375 end Expand_Call_Helper;
4377 -------------------------------
4378 -- Expand_Ctrl_Function_Call --
4379 -------------------------------
4381 procedure Expand_Ctrl_Function_Call (N : Node_Id) is
4382 function Is_Element_Reference (N : Node_Id) return Boolean;
4383 -- Determine whether node N denotes a reference to an Ada 2012 container
4386 --------------------------
4387 -- Is_Element_Reference --
4388 --------------------------
4390 function Is_Element_Reference (N : Node_Id) return Boolean is
4391 Ref : constant Node_Id := Original_Node (N);
4394 -- Analysis marks an element reference by setting the generalized
4395 -- indexing attribute of an indexed component before the component
4396 -- is rewritten into a function call.
4399 Nkind (Ref) = N_Indexed_Component
4400 and then Present (Generalized_Indexing (Ref));
4401 end Is_Element_Reference;
4403 -- Start of processing for Expand_Ctrl_Function_Call
4406 -- Optimization, if the returned value (which is on the sec-stack) is
4407 -- returned again, no need to copy/readjust/finalize, we can just pass
4408 -- the value thru (see Expand_N_Simple_Return_Statement), and thus no
4409 -- attachment is needed
4411 if Nkind (Parent (N)) = N_Simple_Return_Statement then
4415 -- Resolution is now finished, make sure we don't start analysis again
4416 -- because of the duplication.
4420 -- A function which returns a controlled object uses the secondary
4421 -- stack. Rewrite the call into a temporary which obtains the result of
4422 -- the function using 'reference.
4424 Remove_Side_Effects (N);
4426 -- The side effect removal of the function call produced a temporary.
4427 -- When the context is a case expression, if expression, or expression
4428 -- with actions, the lifetime of the temporary must be extended to match
4429 -- that of the context. Otherwise the function result will be finalized
4430 -- too early and affect the result of the expression. To prevent this
4431 -- unwanted effect, the temporary should not be considered for clean up
4432 -- actions by the general finalization machinery.
4434 -- Exception to this rule are references to Ada 2012 container elements.
4435 -- Such references must be finalized at the end of each iteration of the
4436 -- related quantified expression, otherwise the container will remain
4439 if Nkind (N) = N_Explicit_Dereference
4440 and then Within_Case_Or_If_Expression (N)
4441 and then not Is_Element_Reference (N)
4443 Set_Is_Ignored_Transient (Entity (Prefix (N)));
4445 end Expand_Ctrl_Function_Call;
4447 ----------------------------------------
4448 -- Expand_N_Extended_Return_Statement --
4449 ----------------------------------------
4451 -- If there is a Handled_Statement_Sequence, we rewrite this:
4453 -- return Result : T := <expression> do
4454 -- <handled_seq_of_stms>
4460 -- Result : T := <expression>;
4462 -- <handled_seq_of_stms>
4466 -- Otherwise (no Handled_Statement_Sequence), we rewrite this:
4468 -- return Result : T := <expression>;
4472 -- return <expression>;
4474 -- unless it's build-in-place or there's no <expression>, in which case
4478 -- Result : T := <expression>;
4483 -- Note that this case could have been written by the user as an extended
4484 -- return statement, or could have been transformed to this from a simple
4485 -- return statement.
4487 -- That is, we need to have a reified return object if there are statements
4488 -- (which might refer to it) or if we're doing build-in-place (so we can
4489 -- set its address to the final resting place or if there is no expression
4490 -- (in which case default initial values might need to be set).
4492 procedure Expand_N_Extended_Return_Statement (N : Node_Id) is
4493 Loc : constant Source_Ptr := Sloc (N);
4495 function Build_Heap_Allocator
4496 (Temp_Id : Entity_Id;
4497 Temp_Typ : Entity_Id;
4498 Func_Id : Entity_Id;
4499 Ret_Typ : Entity_Id;
4500 Alloc_Expr : Node_Id) return Node_Id;
4501 -- Create the statements necessary to allocate a return object on the
4502 -- caller's master. The master is available through implicit parameter
4503 -- BIPfinalizationmaster.
4505 -- if BIPfinalizationmaster /= null then
4507 -- type Ptr_Typ is access Ret_Typ;
4508 -- for Ptr_Typ'Storage_Pool use
4509 -- Base_Pool (BIPfinalizationmaster.all).all;
4513 -- procedure Allocate (...) is
4515 -- System.Storage_Pools.Subpools.Allocate_Any (...);
4518 -- Local := <Alloc_Expr>;
4519 -- Temp_Id := Temp_Typ (Local);
4523 -- Temp_Id is the temporary which is used to reference the internally
4524 -- created object in all allocation forms. Temp_Typ is the type of the
4525 -- temporary. Func_Id is the enclosing function. Ret_Typ is the return
4526 -- type of Func_Id. Alloc_Expr is the actual allocator.
4528 function Move_Activation_Chain (Func_Id : Entity_Id) return Node_Id;
4529 -- Construct a call to System.Tasking.Stages.Move_Activation_Chain
4531 -- From current activation chain
4532 -- To activation chain passed in by the caller
4533 -- New_Master master passed in by the caller
4535 -- Func_Id is the entity of the function where the extended return
4536 -- statement appears.
4538 --------------------------
4539 -- Build_Heap_Allocator --
4540 --------------------------
4542 function Build_Heap_Allocator
4543 (Temp_Id : Entity_Id;
4544 Temp_Typ : Entity_Id;
4545 Func_Id : Entity_Id;
4546 Ret_Typ : Entity_Id;
4547 Alloc_Expr : Node_Id) return Node_Id
4550 pragma Assert (Is_Build_In_Place_Function (Func_Id));
4552 -- Processing for build-in-place object allocation.
4554 if Needs_Finalization (Ret_Typ) then
4556 Decls : constant List_Id := New_List;
4557 Fin_Mas_Id : constant Entity_Id :=
4558 Build_In_Place_Formal
4559 (Func_Id, BIP_Finalization_Master);
4560 Stmts : constant List_Id := New_List;
4561 Desig_Typ : Entity_Id;
4562 Local_Id : Entity_Id;
4563 Pool_Id : Entity_Id;
4564 Ptr_Typ : Entity_Id;
4568 -- Pool_Id renames Base_Pool (BIPfinalizationmaster.all).all;
4570 Pool_Id := Make_Temporary (Loc, 'P');
4573 Make_Object_Renaming_Declaration (Loc,
4574 Defining_Identifier => Pool_Id,
4576 New_Occurrence_Of (RTE (RE_Root_Storage_Pool), Loc),
4578 Make_Explicit_Dereference (Loc,
4580 Make_Function_Call (Loc,
4582 New_Occurrence_Of (RTE (RE_Base_Pool), Loc),
4583 Parameter_Associations => New_List (
4584 Make_Explicit_Dereference (Loc,
4586 New_Occurrence_Of (Fin_Mas_Id, Loc)))))));
4588 -- Create an access type which uses the storage pool of the
4589 -- caller's master. This additional type is necessary because
4590 -- the finalization master cannot be associated with the type
4591 -- of the temporary. Otherwise the secondary stack allocation
4594 Desig_Typ := Ret_Typ;
4596 -- Ensure that the build-in-place machinery uses a fat pointer
4597 -- when allocating an unconstrained array on the heap. In this
4598 -- case the result object type is a constrained array type even
4599 -- though the function type is unconstrained.
4601 if Ekind (Desig_Typ) = E_Array_Subtype then
4602 Desig_Typ := Base_Type (Desig_Typ);
4606 -- type Ptr_Typ is access Desig_Typ;
4608 Ptr_Typ := Make_Temporary (Loc, 'P');
4611 Make_Full_Type_Declaration (Loc,
4612 Defining_Identifier => Ptr_Typ,
4614 Make_Access_To_Object_Definition (Loc,
4615 Subtype_Indication =>
4616 New_Occurrence_Of (Desig_Typ, Loc))));
4618 -- Perform minor decoration in order to set the master and the
4619 -- storage pool attributes.
4621 Set_Ekind (Ptr_Typ, E_Access_Type);
4622 Set_Finalization_Master (Ptr_Typ, Fin_Mas_Id);
4623 Set_Associated_Storage_Pool (Ptr_Typ, Pool_Id);
4625 -- Create the temporary, generate:
4626 -- Local_Id : Ptr_Typ;
4628 Local_Id := Make_Temporary (Loc, 'T');
4631 Make_Object_Declaration (Loc,
4632 Defining_Identifier => Local_Id,
4633 Object_Definition =>
4634 New_Occurrence_Of (Ptr_Typ, Loc)));
4636 -- Allocate the object, generate:
4637 -- Local_Id := <Alloc_Expr>;
4640 Make_Assignment_Statement (Loc,
4641 Name => New_Occurrence_Of (Local_Id, Loc),
4642 Expression => Alloc_Expr));
4645 -- Temp_Id := Temp_Typ (Local_Id);
4648 Make_Assignment_Statement (Loc,
4649 Name => New_Occurrence_Of (Temp_Id, Loc),
4651 Unchecked_Convert_To (Temp_Typ,
4652 New_Occurrence_Of (Local_Id, Loc))));
4654 -- Wrap the allocation in a block. This is further conditioned
4655 -- by checking the caller finalization master at runtime. A
4656 -- null value indicates a non-existent master, most likely due
4657 -- to a Finalize_Storage_Only allocation.
4660 -- if BIPfinalizationmaster /= null then
4669 Make_If_Statement (Loc,
4672 Left_Opnd => New_Occurrence_Of (Fin_Mas_Id, Loc),
4673 Right_Opnd => Make_Null (Loc)),
4675 Then_Statements => New_List (
4676 Make_Block_Statement (Loc,
4677 Declarations => Decls,
4678 Handled_Statement_Sequence =>
4679 Make_Handled_Sequence_Of_Statements (Loc,
4680 Statements => Stmts))));
4683 -- For all other cases, generate:
4684 -- Temp_Id := <Alloc_Expr>;
4688 Make_Assignment_Statement (Loc,
4689 Name => New_Occurrence_Of (Temp_Id, Loc),
4690 Expression => Alloc_Expr);
4692 end Build_Heap_Allocator;
4694 ---------------------------
4695 -- Move_Activation_Chain --
4696 ---------------------------
4698 function Move_Activation_Chain (Func_Id : Entity_Id) return Node_Id is
4701 Make_Procedure_Call_Statement (Loc,
4703 New_Occurrence_Of (RTE (RE_Move_Activation_Chain), Loc),
4705 Parameter_Associations => New_List (
4709 Make_Attribute_Reference (Loc,
4710 Prefix => Make_Identifier (Loc, Name_uChain),
4711 Attribute_Name => Name_Unrestricted_Access),
4713 -- Destination chain
4716 (Build_In_Place_Formal (Func_Id, BIP_Activation_Chain), Loc),
4721 (Build_In_Place_Formal (Func_Id, BIP_Task_Master), Loc)));
4722 end Move_Activation_Chain;
4726 Func_Id : constant Entity_Id :=
4727 Return_Applies_To (Return_Statement_Entity (N));
4728 Is_BIP_Func : constant Boolean :=
4729 Is_Build_In_Place_Function (Func_Id);
4730 Ret_Obj_Id : constant Entity_Id :=
4731 First_Entity (Return_Statement_Entity (N));
4732 Ret_Obj_Decl : constant Node_Id := Parent (Ret_Obj_Id);
4733 Ret_Typ : constant Entity_Id := Etype (Func_Id);
4740 Return_Stmt : Node_Id := Empty;
4741 -- Force initialization to facilitate static analysis
4743 -- Start of processing for Expand_N_Extended_Return_Statement
4746 -- Given that functionality of interface thunks is simple (just displace
4747 -- the pointer to the object) they are always handled by means of
4748 -- simple return statements.
4750 pragma Assert (not Is_Thunk (Current_Scope));
4752 if Nkind (Ret_Obj_Decl) = N_Object_Declaration then
4753 Exp := Expression (Ret_Obj_Decl);
4758 HSS := Handled_Statement_Sequence (N);
4760 -- If the returned object needs finalization actions, the function must
4761 -- perform the appropriate cleanup should it fail to return. The state
4762 -- of the function itself is tracked through a flag which is coupled
4763 -- with the scope finalizer. There is one flag per each return object
4764 -- in case of multiple returns.
4766 if Is_BIP_Func and then Needs_Finalization (Etype (Ret_Obj_Id)) then
4768 Flag_Decl : Node_Id;
4769 Flag_Id : Entity_Id;
4773 -- Recover the function body
4775 Func_Bod := Unit_Declaration_Node (Func_Id);
4777 if Nkind (Func_Bod) = N_Subprogram_Declaration then
4778 Func_Bod := Parent (Parent (Corresponding_Body (Func_Bod)));
4781 if Nkind (Func_Bod) = N_Function_Specification then
4782 Func_Bod := Parent (Func_Bod); -- one more level for child units
4785 pragma Assert (Nkind (Func_Bod) = N_Subprogram_Body);
4787 -- Create a flag to track the function state
4789 Flag_Id := Make_Temporary (Loc, 'F');
4790 Set_Status_Flag_Or_Transient_Decl (Ret_Obj_Id, Flag_Id);
4792 -- Insert the flag at the beginning of the function declarations,
4794 -- Fnn : Boolean := False;
4797 Make_Object_Declaration (Loc,
4798 Defining_Identifier => Flag_Id,
4799 Object_Definition =>
4800 New_Occurrence_Of (Standard_Boolean, Loc),
4802 New_Occurrence_Of (Standard_False, Loc));
4804 Prepend_To (Declarations (Func_Bod), Flag_Decl);
4805 Analyze (Flag_Decl);
4809 -- Build a simple_return_statement that returns the return object when
4810 -- there is a statement sequence, or no expression, or the result will
4811 -- be built in place. Note however that we currently do this for all
4812 -- composite cases, even though not all are built in place.
4815 or else Is_Composite_Type (Ret_Typ)
4821 -- If the extended return has a handled statement sequence, then wrap
4822 -- it in a block and use the block as the first statement.
4826 Make_Block_Statement (Loc,
4827 Declarations => New_List,
4828 Handled_Statement_Sequence => HSS));
4831 -- If the result type contains tasks, we call Move_Activation_Chain.
4832 -- Later, the cleanup code will call Complete_Master, which will
4833 -- terminate any unactivated tasks belonging to the return statement
4834 -- master. But Move_Activation_Chain updates their master to be that
4835 -- of the caller, so they will not be terminated unless the return
4836 -- statement completes unsuccessfully due to exception, abort, goto,
4837 -- or exit. As a formality, we test whether the function requires the
4838 -- result to be built in place, though that's necessarily true for
4839 -- the case of result types with task parts.
4841 if Is_BIP_Func and then Has_Task (Ret_Typ) then
4843 -- The return expression is an aggregate for a complex type which
4844 -- contains tasks. This particular case is left unexpanded since
4845 -- the regular expansion would insert all temporaries and
4846 -- initialization code in the wrong block.
4848 if Nkind (Exp) = N_Aggregate then
4849 Expand_N_Aggregate (Exp);
4852 -- Do not move the activation chain if the return object does not
4855 if Has_Task (Etype (Ret_Obj_Id)) then
4856 Append_To (Stmts, Move_Activation_Chain (Func_Id));
4860 -- Update the state of the function right before the object is
4863 if Is_BIP_Func and then Needs_Finalization (Etype (Ret_Obj_Id)) then
4865 Flag_Id : constant Entity_Id :=
4866 Status_Flag_Or_Transient_Decl (Ret_Obj_Id);
4873 Make_Assignment_Statement (Loc,
4874 Name => New_Occurrence_Of (Flag_Id, Loc),
4875 Expression => New_Occurrence_Of (Standard_True, Loc)));
4879 -- Build a simple_return_statement that returns the return object
4882 Make_Simple_Return_Statement (Loc,
4883 Expression => New_Occurrence_Of (Ret_Obj_Id, Loc));
4884 Append_To (Stmts, Return_Stmt);
4886 HSS := Make_Handled_Sequence_Of_Statements (Loc, Stmts);
4889 -- Case where we build a return statement block
4891 if Present (HSS) then
4893 Make_Block_Statement (Loc,
4894 Declarations => Return_Object_Declarations (N),
4895 Handled_Statement_Sequence => HSS);
4897 -- We set the entity of the new block statement to be that of the
4898 -- return statement. This is necessary so that various fields, such
4899 -- as Finalization_Chain_Entity carry over from the return statement
4900 -- to the block. Note that this block is unusual, in that its entity
4901 -- is an E_Return_Statement rather than an E_Block.
4904 (Result, New_Occurrence_Of (Return_Statement_Entity (N), Loc));
4906 -- If the object decl was already rewritten as a renaming, then we
4907 -- don't want to do the object allocation and transformation of
4908 -- the return object declaration to a renaming. This case occurs
4909 -- when the return object is initialized by a call to another
4910 -- build-in-place function, and that function is responsible for
4911 -- the allocation of the return object.
4914 and then Nkind (Ret_Obj_Decl) = N_Object_Renaming_Declaration
4917 (Nkind (Original_Node (Ret_Obj_Decl)) = N_Object_Declaration
4920 -- It is a regular BIP object declaration
4922 (Is_Build_In_Place_Function_Call
4923 (Expression (Original_Node (Ret_Obj_Decl)))
4925 -- It is a BIP object declaration that displaces the pointer
4926 -- to the object to reference a convered interface type.
4929 Present (Unqual_BIP_Iface_Function_Call
4930 (Expression (Original_Node (Ret_Obj_Decl))))));
4932 -- Return the build-in-place result by reference
4934 Set_By_Ref (Return_Stmt);
4936 elsif Is_BIP_Func then
4938 -- Locate the implicit access parameter associated with the
4939 -- caller-supplied return object and convert the return
4940 -- statement's return object declaration to a renaming of a
4941 -- dereference of the access parameter. If the return object's
4942 -- declaration includes an expression that has not already been
4943 -- expanded as separate assignments, then add an assignment
4944 -- statement to ensure the return object gets initialized.
4947 -- Result : T [:= <expression>];
4954 -- Result : T renames FuncRA.all;
4955 -- [Result := <expression;]
4960 Ret_Obj_Expr : constant Node_Id := Expression (Ret_Obj_Decl);
4961 Ret_Obj_Typ : constant Entity_Id := Etype (Ret_Obj_Id);
4963 Init_Assignment : Node_Id := Empty;
4964 Obj_Acc_Formal : Entity_Id;
4965 Obj_Acc_Deref : Node_Id;
4966 Obj_Alloc_Formal : Entity_Id;
4969 -- Build-in-place results must be returned by reference
4971 Set_By_Ref (Return_Stmt);
4973 -- Retrieve the implicit access parameter passed by the caller
4976 Build_In_Place_Formal (Func_Id, BIP_Object_Access);
4978 -- If the return object's declaration includes an expression
4979 -- and the declaration isn't marked as No_Initialization, then
4980 -- we need to generate an assignment to the object and insert
4981 -- it after the declaration before rewriting it as a renaming
4982 -- (otherwise we'll lose the initialization). The case where
4983 -- the result type is an interface (or class-wide interface)
4984 -- is also excluded because the context of the function call
4985 -- must be unconstrained, so the initialization will always
4986 -- be done as part of an allocator evaluation (storage pool
4987 -- or secondary stack), never to a constrained target object
4988 -- passed in by the caller. Besides the assignment being
4989 -- unneeded in this case, it avoids problems with trying to
4990 -- generate a dispatching assignment when the return expression
4991 -- is a nonlimited descendant of a limited interface (the
4992 -- interface has no assignment operation).
4994 if Present (Ret_Obj_Expr)
4995 and then not No_Initialization (Ret_Obj_Decl)
4996 and then not Is_Interface (Ret_Obj_Typ)
4999 Make_Assignment_Statement (Loc,
5000 Name => New_Occurrence_Of (Ret_Obj_Id, Loc),
5001 Expression => New_Copy_Tree (Ret_Obj_Expr));
5003 Set_Etype (Name (Init_Assignment), Etype (Ret_Obj_Id));
5004 Set_Assignment_OK (Name (Init_Assignment));
5005 Set_No_Ctrl_Actions (Init_Assignment);
5007 Set_Parent (Name (Init_Assignment), Init_Assignment);
5008 Set_Parent (Expression (Init_Assignment), Init_Assignment);
5010 Set_Expression (Ret_Obj_Decl, Empty);
5012 if Is_Class_Wide_Type (Etype (Ret_Obj_Id))
5013 and then not Is_Class_Wide_Type
5014 (Etype (Expression (Init_Assignment)))
5016 Rewrite (Expression (Init_Assignment),
5017 Make_Type_Conversion (Loc,
5019 New_Occurrence_Of (Etype (Ret_Obj_Id), Loc),
5021 Relocate_Node (Expression (Init_Assignment))));
5024 -- In the case of functions where the calling context can
5025 -- determine the form of allocation needed, initialization
5026 -- is done with each part of the if statement that handles
5027 -- the different forms of allocation (this is true for
5028 -- unconstrained and tagged result subtypes).
5030 if Is_Constrained (Ret_Typ)
5031 and then not Is_Tagged_Type (Underlying_Type (Ret_Typ))
5033 Insert_After (Ret_Obj_Decl, Init_Assignment);
5037 -- When the function's subtype is unconstrained, a run-time
5038 -- test is needed to determine the form of allocation to use
5039 -- for the return object. The function has an implicit formal
5040 -- parameter indicating this. If the BIP_Alloc_Form formal has
5041 -- the value one, then the caller has passed access to an
5042 -- existing object for use as the return object. If the value
5043 -- is two, then the return object must be allocated on the
5044 -- secondary stack. Otherwise, the object must be allocated in
5045 -- a storage pool. We generate an if statement to test the
5046 -- implicit allocation formal and initialize a local access
5047 -- value appropriately, creating allocators in the secondary
5048 -- stack and global heap cases. The special formal also exists
5049 -- and must be tested when the function has a tagged result,
5050 -- even when the result subtype is constrained, because in
5051 -- general such functions can be called in dispatching contexts
5052 -- and must be handled similarly to functions with a class-wide
5055 if not Is_Constrained (Ret_Typ)
5056 or else Is_Tagged_Type (Underlying_Type (Ret_Typ))
5059 Build_In_Place_Formal (Func_Id, BIP_Alloc_Form);
5062 Pool_Id : constant Entity_Id :=
5063 Make_Temporary (Loc, 'P');
5064 Alloc_Obj_Id : Entity_Id;
5065 Alloc_Obj_Decl : Node_Id;
5066 Alloc_If_Stmt : Node_Id;
5067 Heap_Allocator : Node_Id;
5068 Pool_Decl : Node_Id;
5069 Pool_Allocator : Node_Id;
5070 Ptr_Type_Decl : Node_Id;
5071 Ref_Type : Entity_Id;
5072 SS_Allocator : Node_Id;
5075 -- Reuse the itype created for the function's implicit
5076 -- access formal. This avoids the need to create a new
5077 -- access type here, plus it allows assigning the access
5078 -- formal directly without applying a conversion.
5080 -- Ref_Type := Etype (Object_Access);
5082 -- Create an access type designating the function's
5085 Ref_Type := Make_Temporary (Loc, 'A');
5088 Make_Full_Type_Declaration (Loc,
5089 Defining_Identifier => Ref_Type,
5091 Make_Access_To_Object_Definition (Loc,
5092 All_Present => True,
5093 Subtype_Indication =>
5094 New_Occurrence_Of (Ret_Obj_Typ, Loc)));
5096 Insert_Before (Ret_Obj_Decl, Ptr_Type_Decl);
5098 -- Create an access object that will be initialized to an
5099 -- access value denoting the return object, either coming
5100 -- from an implicit access value passed in by the caller
5101 -- or from the result of an allocator.
5103 Alloc_Obj_Id := Make_Temporary (Loc, 'R');
5104 Set_Etype (Alloc_Obj_Id, Ref_Type);
5107 Make_Object_Declaration (Loc,
5108 Defining_Identifier => Alloc_Obj_Id,
5109 Object_Definition =>
5110 New_Occurrence_Of (Ref_Type, Loc));
5112 Insert_Before (Ret_Obj_Decl, Alloc_Obj_Decl);
5114 -- Create allocators for both the secondary stack and
5115 -- global heap. If there's an initialization expression,
5116 -- then create these as initialized allocators.
5118 if Present (Ret_Obj_Expr)
5119 and then not No_Initialization (Ret_Obj_Decl)
5121 -- Always use the type of the expression for the
5122 -- qualified expression, rather than the result type.
5123 -- In general we cannot always use the result type
5124 -- for the allocator, because the expression might be
5125 -- of a specific type, such as in the case of an
5126 -- aggregate or even a nonlimited object when the
5127 -- result type is a limited class-wide interface type.
5130 Make_Allocator (Loc,
5132 Make_Qualified_Expression (Loc,
5135 (Etype (Ret_Obj_Expr), Loc),
5136 Expression => New_Copy_Tree (Ret_Obj_Expr)));
5139 -- If the function returns a class-wide type we cannot
5140 -- use the return type for the allocator. Instead we
5141 -- use the type of the expression, which must be an
5142 -- aggregate of a definite type.
5144 if Is_Class_Wide_Type (Ret_Obj_Typ) then
5146 Make_Allocator (Loc,
5149 (Etype (Ret_Obj_Expr), Loc));
5152 Make_Allocator (Loc,
5154 New_Occurrence_Of (Ret_Obj_Typ, Loc));
5157 -- If the object requires default initialization then
5158 -- that will happen later following the elaboration of
5159 -- the object renaming. If we don't turn it off here
5160 -- then the object will be default initialized twice.
5162 Set_No_Initialization (Heap_Allocator);
5165 -- Set the flag indicating that the allocator came from
5166 -- a build-in-place return statement, so we can avoid
5167 -- adjusting the allocated object. Note that this flag
5168 -- will be inherited by the copies made below.
5170 Set_Alloc_For_BIP_Return (Heap_Allocator);
5172 -- The Pool_Allocator is just like the Heap_Allocator,
5173 -- except we set Storage_Pool and Procedure_To_Call so
5174 -- it will use the user-defined storage pool.
5176 Pool_Allocator := New_Copy_Tree (Heap_Allocator);
5177 pragma Assert (Alloc_For_BIP_Return (Pool_Allocator));
5179 -- Do not generate the renaming of the build-in-place
5180 -- pool parameter on ZFP because the parameter is not
5181 -- created in the first place.
5183 if RTE_Available (RE_Root_Storage_Pool_Ptr) then
5185 Make_Object_Renaming_Declaration (Loc,
5186 Defining_Identifier => Pool_Id,
5189 (RTE (RE_Root_Storage_Pool), Loc),
5191 Make_Explicit_Dereference (Loc,
5193 (Build_In_Place_Formal
5194 (Func_Id, BIP_Storage_Pool), Loc)));
5195 Set_Storage_Pool (Pool_Allocator, Pool_Id);
5196 Set_Procedure_To_Call
5197 (Pool_Allocator, RTE (RE_Allocate_Any));
5199 Pool_Decl := Make_Null_Statement (Loc);
5202 -- If the No_Allocators restriction is active, then only
5203 -- an allocator for secondary stack allocation is needed.
5204 -- It's OK for such allocators to have Comes_From_Source
5205 -- set to False, because gigi knows not to flag them as
5206 -- being a violation of No_Implicit_Heap_Allocations.
5208 if Restriction_Active (No_Allocators) then
5209 SS_Allocator := Heap_Allocator;
5210 Heap_Allocator := Make_Null (Loc);
5211 Pool_Allocator := Make_Null (Loc);
5213 -- Otherwise the heap and pool allocators may be needed,
5214 -- so we make another allocator for secondary stack
5218 SS_Allocator := New_Copy_Tree (Heap_Allocator);
5219 pragma Assert (Alloc_For_BIP_Return (SS_Allocator));
5221 -- The heap and pool allocators are marked as
5222 -- Comes_From_Source since they correspond to an
5223 -- explicit user-written allocator (that is, it will
5224 -- only be executed on behalf of callers that call the
5225 -- function as initialization for such an allocator).
5226 -- Prevents errors when No_Implicit_Heap_Allocations
5229 Set_Comes_From_Source (Heap_Allocator, True);
5230 Set_Comes_From_Source (Pool_Allocator, True);
5233 -- The allocator is returned on the secondary stack.
5235 Set_Storage_Pool (SS_Allocator, RTE (RE_SS_Pool));
5236 Set_Procedure_To_Call
5237 (SS_Allocator, RTE (RE_SS_Allocate));
5239 -- The allocator is returned on the secondary stack,
5240 -- so indicate that the function return, as well as
5241 -- all blocks that encloses the allocator, must not
5242 -- release it. The flags must be set now because
5243 -- the decision to use the secondary stack is done
5244 -- very late in the course of expanding the return
5245 -- statement, past the point where these flags are
5248 Set_Uses_Sec_Stack (Func_Id);
5249 Set_Uses_Sec_Stack (Return_Statement_Entity (N));
5250 Set_Sec_Stack_Needed_For_Return
5251 (Return_Statement_Entity (N));
5252 Set_Enclosing_Sec_Stack_Return (N);
5254 -- Create an if statement to test the BIP_Alloc_Form
5255 -- formal and initialize the access object to either the
5256 -- BIP_Object_Access formal (BIP_Alloc_Form =
5257 -- Caller_Allocation), the result of allocating the
5258 -- object in the secondary stack (BIP_Alloc_Form =
5259 -- Secondary_Stack), or else an allocator to create the
5260 -- return object in the heap or user-defined pool
5261 -- (BIP_Alloc_Form = Global_Heap or User_Storage_Pool).
5263 -- ??? An unchecked type conversion must be made in the
5264 -- case of assigning the access object formal to the
5265 -- local access object, because a normal conversion would
5266 -- be illegal in some cases (such as converting access-
5267 -- to-unconstrained to access-to-constrained), but the
5268 -- the unchecked conversion will presumably fail to work
5269 -- right in just such cases. It's not clear at all how to
5273 Make_If_Statement (Loc,
5277 New_Occurrence_Of (Obj_Alloc_Formal, Loc),
5279 Make_Integer_Literal (Loc,
5280 UI_From_Int (BIP_Allocation_Form'Pos
5281 (Caller_Allocation)))),
5283 Then_Statements => New_List (
5284 Make_Assignment_Statement (Loc,
5286 New_Occurrence_Of (Alloc_Obj_Id, Loc),
5288 Make_Unchecked_Type_Conversion (Loc,
5290 New_Occurrence_Of (Ref_Type, Loc),
5292 New_Occurrence_Of (Obj_Acc_Formal, Loc)))),
5294 Elsif_Parts => New_List (
5295 Make_Elsif_Part (Loc,
5299 New_Occurrence_Of (Obj_Alloc_Formal, Loc),
5301 Make_Integer_Literal (Loc,
5302 UI_From_Int (BIP_Allocation_Form'Pos
5303 (Secondary_Stack)))),
5305 Then_Statements => New_List (
5306 Make_Assignment_Statement (Loc,
5308 New_Occurrence_Of (Alloc_Obj_Id, Loc),
5309 Expression => SS_Allocator))),
5311 Make_Elsif_Part (Loc,
5315 New_Occurrence_Of (Obj_Alloc_Formal, Loc),
5317 Make_Integer_Literal (Loc,
5318 UI_From_Int (BIP_Allocation_Form'Pos
5321 Then_Statements => New_List (
5322 Build_Heap_Allocator
5323 (Temp_Id => Alloc_Obj_Id,
5324 Temp_Typ => Ref_Type,
5326 Ret_Typ => Ret_Obj_Typ,
5327 Alloc_Expr => Heap_Allocator))),
5329 -- ???If all is well, we can put the following
5330 -- 'elsif' in the 'else', but this is a useful
5331 -- self-check in case caller and callee don't agree
5332 -- on whether BIPAlloc and so on should be passed.
5334 Make_Elsif_Part (Loc,
5338 New_Occurrence_Of (Obj_Alloc_Formal, Loc),
5340 Make_Integer_Literal (Loc,
5341 UI_From_Int (BIP_Allocation_Form'Pos
5342 (User_Storage_Pool)))),
5344 Then_Statements => New_List (
5346 Build_Heap_Allocator
5347 (Temp_Id => Alloc_Obj_Id,
5348 Temp_Typ => Ref_Type,
5350 Ret_Typ => Ret_Obj_Typ,
5351 Alloc_Expr => Pool_Allocator)))),
5353 -- Raise Program_Error if it's none of the above;
5354 -- this is a compiler bug. ???PE_All_Guards_Closed
5355 -- is bogus; we should have a new code.
5357 Else_Statements => New_List (
5358 Make_Raise_Program_Error (Loc,
5359 Reason => PE_All_Guards_Closed)));
5361 -- If a separate initialization assignment was created
5362 -- earlier, append that following the assignment of the
5363 -- implicit access formal to the access object, to ensure
5364 -- that the return object is initialized in that case. In
5365 -- this situation, the target of the assignment must be
5366 -- rewritten to denote a dereference of the access to the
5367 -- return object passed in by the caller.
5369 if Present (Init_Assignment) then
5370 Rewrite (Name (Init_Assignment),
5371 Make_Explicit_Dereference (Loc,
5372 Prefix => New_Occurrence_Of (Alloc_Obj_Id, Loc)));
5374 Set_Etype (Name (Init_Assignment), Etype (Ret_Obj_Id));
5377 (Then_Statements (Alloc_If_Stmt), Init_Assignment);
5380 Insert_Before (Ret_Obj_Decl, Alloc_If_Stmt);
5382 -- Remember the local access object for use in the
5383 -- dereference of the renaming created below.
5385 Obj_Acc_Formal := Alloc_Obj_Id;
5389 -- Replace the return object declaration with a renaming of a
5390 -- dereference of the access value designating the return
5394 Make_Explicit_Dereference (Loc,
5395 Prefix => New_Occurrence_Of (Obj_Acc_Formal, Loc));
5397 Rewrite (Ret_Obj_Decl,
5398 Make_Object_Renaming_Declaration (Loc,
5399 Defining_Identifier => Ret_Obj_Id,
5400 Access_Definition => Empty,
5401 Subtype_Mark => New_Occurrence_Of (Ret_Obj_Typ, Loc),
5402 Name => Obj_Acc_Deref));
5404 Set_Renamed_Object (Ret_Obj_Id, Obj_Acc_Deref);
5408 -- Case where we do not build a block
5411 -- We're about to drop Return_Object_Declarations on the floor, so
5412 -- we need to insert it, in case it got expanded into useful code.
5413 -- Remove side effects from expression, which may be duplicated in
5414 -- subsequent checks (see Expand_Simple_Function_Return).
5416 Insert_List_Before (N, Return_Object_Declarations (N));
5417 Remove_Side_Effects (Exp);
5419 -- Build simple_return_statement that returns the expression directly
5421 Return_Stmt := Make_Simple_Return_Statement (Loc, Expression => Exp);
5422 Result := Return_Stmt;
5425 -- Set the flag to prevent infinite recursion
5427 Set_Comes_From_Extended_Return_Statement (Return_Stmt);
5429 Rewrite (N, Result);
5431 end Expand_N_Extended_Return_Statement;
5433 ----------------------------
5434 -- Expand_N_Function_Call --
5435 ----------------------------
5437 procedure Expand_N_Function_Call (N : Node_Id) is
5440 end Expand_N_Function_Call;
5442 ---------------------------------------
5443 -- Expand_N_Procedure_Call_Statement --
5444 ---------------------------------------
5446 procedure Expand_N_Procedure_Call_Statement (N : Node_Id) is
5449 end Expand_N_Procedure_Call_Statement;
5451 --------------------------------------
5452 -- Expand_N_Simple_Return_Statement --
5453 --------------------------------------
5455 procedure Expand_N_Simple_Return_Statement (N : Node_Id) is
5457 -- Defend against previous errors (i.e. the return statement calls a
5458 -- function that is not available in configurable runtime).
5460 if Present (Expression (N))
5461 and then Nkind (Expression (N)) = N_Empty
5463 Check_Error_Detected;
5467 -- Distinguish the function and non-function cases:
5469 case Ekind (Return_Applies_To (Return_Statement_Entity (N))) is
5471 | E_Generic_Function
5473 Expand_Simple_Function_Return (N);
5477 | E_Generic_Procedure
5479 | E_Return_Statement
5481 Expand_Non_Function_Return (N);
5484 raise Program_Error;
5488 when RE_Not_Available =>
5490 end Expand_N_Simple_Return_Statement;
5492 ------------------------------
5493 -- Expand_N_Subprogram_Body --
5494 ------------------------------
5496 -- Add poll call if ATC polling is enabled, unless the body will be inlined
5499 -- Add dummy push/pop label nodes at start and end to clear any local
5500 -- exception indications if local-exception-to-goto optimization is active.
5502 -- Add return statement if last statement in body is not a return statement
5503 -- (this makes things easier on Gigi which does not want to have to handle
5504 -- a missing return).
5506 -- Add call to Activate_Tasks if body is a task activator
5508 -- Deal with possible detection of infinite recursion
5510 -- Eliminate body completely if convention stubbed
5512 -- Encode entity names within body, since we will not need to reference
5513 -- these entities any longer in the front end.
5515 -- Initialize scalar out parameters if Initialize/Normalize_Scalars
5517 -- Reset Pure indication if any parameter has root type System.Address
5518 -- or has any parameters of limited types, where limited means that the
5519 -- run-time view is limited (i.e. the full type is limited).
5523 procedure Expand_N_Subprogram_Body (N : Node_Id) is
5524 Body_Id : constant Entity_Id := Defining_Entity (N);
5525 HSS : constant Node_Id := Handled_Statement_Sequence (N);
5526 Loc : constant Source_Ptr := Sloc (N);
5528 procedure Add_Return (Spec_Id : Entity_Id; Stmts : List_Id);
5529 -- Append a return statement to the statement sequence Stmts if the last
5530 -- statement is not already a return or a goto statement. Note that the
5531 -- latter test is not critical, it does not matter if we add a few extra
5532 -- returns, since they get eliminated anyway later on. Spec_Id denotes
5533 -- the corresponding spec of the subprogram body.
5539 procedure Add_Return (Spec_Id : Entity_Id; Stmts : List_Id) is
5540 Last_Stmt : Node_Id;
5545 -- Get last statement, ignoring any Pop_xxx_Label nodes, which are
5546 -- not relevant in this context since they are not executable.
5548 Last_Stmt := Last (Stmts);
5549 while Nkind (Last_Stmt) in N_Pop_xxx_Label loop
5553 -- Now insert return unless last statement is a transfer
5555 if not Is_Transfer (Last_Stmt) then
5557 -- The source location for the return is the end label of the
5558 -- procedure if present. Otherwise use the sloc of the last
5559 -- statement in the list. If the list comes from a generated
5560 -- exception handler and we are not debugging generated code,
5561 -- all the statements within the handler are made invisible
5564 if Nkind (Parent (Stmts)) = N_Exception_Handler
5565 and then not Comes_From_Source (Parent (Stmts))
5567 Loc := Sloc (Last_Stmt);
5568 elsif Present (End_Label (HSS)) then
5569 Loc := Sloc (End_Label (HSS));
5571 Loc := Sloc (Last_Stmt);
5574 -- Append return statement, and set analyzed manually. We can't
5575 -- call Analyze on this return since the scope is wrong.
5577 -- Note: it almost works to push the scope and then do the Analyze
5578 -- call, but something goes wrong in some weird cases and it is
5579 -- not worth worrying about ???
5581 Stmt := Make_Simple_Return_Statement (Loc);
5583 -- The return statement is handled properly, and the call to the
5584 -- postcondition, inserted below, does not require information
5585 -- from the body either. However, that call is analyzed in the
5586 -- enclosing scope, and an elaboration check might improperly be
5587 -- added to it. A guard in Sem_Elab is needed to prevent that
5588 -- spurious check, see Check_Elab_Call.
5590 Append_To (Stmts, Stmt);
5591 Set_Analyzed (Stmt);
5593 -- Call the _Postconditions procedure if the related subprogram
5594 -- has contract assertions that need to be verified on exit.
5596 if Ekind (Spec_Id) = E_Procedure
5597 and then Present (Postconditions_Proc (Spec_Id))
5599 Insert_Action (Stmt,
5600 Make_Procedure_Call_Statement (Loc,
5602 New_Occurrence_Of (Postconditions_Proc (Spec_Id), Loc)));
5611 Spec_Id : Entity_Id;
5613 -- Start of processing for Expand_N_Subprogram_Body
5616 if Present (Corresponding_Spec (N)) then
5617 Spec_Id := Corresponding_Spec (N);
5622 -- If this is a Pure function which has any parameters whose root type
5623 -- is System.Address, reset the Pure indication.
5624 -- This check is also performed when the subprogram is frozen, but we
5625 -- repeat it on the body so that the indication is consistent, and so
5626 -- it applies as well to bodies without separate specifications.
5628 if Is_Pure (Spec_Id)
5629 and then Is_Subprogram (Spec_Id)
5630 and then not Has_Pragma_Pure_Function (Spec_Id)
5632 Check_Function_With_Address_Parameter (Spec_Id);
5634 if Spec_Id /= Body_Id then
5635 Set_Is_Pure (Body_Id, Is_Pure (Spec_Id));
5639 -- Set L to either the list of declarations if present, or to the list
5640 -- of statements if no declarations are present. This is used to insert
5641 -- new stuff at the start.
5643 if Is_Non_Empty_List (Declarations (N)) then
5644 L := Declarations (N);
5646 L := Statements (HSS);
5649 -- If local-exception-to-goto optimization active, insert dummy push
5650 -- statements at start, and dummy pop statements at end, but inhibit
5651 -- this if we have No_Exception_Handlers, since they are useless and
5652 -- intefere with analysis, e.g. by codepeer.
5654 if (Debug_Flag_Dot_G
5655 or else Restriction_Active (No_Exception_Propagation))
5656 and then not Restriction_Active (No_Exception_Handlers)
5657 and then not CodePeer_Mode
5658 and then Is_Non_Empty_List (L)
5661 FS : constant Node_Id := First (L);
5662 FL : constant Source_Ptr := Sloc (FS);
5667 -- LS points to either last statement, if statements are present
5668 -- or to the last declaration if there are no statements present.
5669 -- It is the node after which the pop's are generated.
5671 if Is_Non_Empty_List (Statements (HSS)) then
5672 LS := Last (Statements (HSS));
5679 Insert_List_Before_And_Analyze (FS, New_List (
5680 Make_Push_Constraint_Error_Label (FL),
5681 Make_Push_Program_Error_Label (FL),
5682 Make_Push_Storage_Error_Label (FL)));
5684 Insert_List_After_And_Analyze (LS, New_List (
5685 Make_Pop_Constraint_Error_Label (LL),
5686 Make_Pop_Program_Error_Label (LL),
5687 Make_Pop_Storage_Error_Label (LL)));
5691 -- Need poll on entry to subprogram if polling enabled. We only do this
5692 -- for non-empty subprograms, since it does not seem necessary to poll
5693 -- for a dummy null subprogram.
5695 if Is_Non_Empty_List (L) then
5697 -- Do not add a polling call if the subprogram is to be inlined by
5698 -- the back-end, to avoid repeated calls with multiple inlinings.
5700 if Is_Inlined (Spec_Id)
5701 and then Front_End_Inlining
5702 and then Optimization_Level > 1
5706 Generate_Poll_Call (First (L));
5710 -- Initialize any scalar OUT args if Initialize/Normalize_Scalars
5712 if Init_Or_Norm_Scalars and then Is_Subprogram (Spec_Id) then
5718 -- Loop through formals
5720 F := First_Formal (Spec_Id);
5721 while Present (F) loop
5722 if Is_Scalar_Type (Etype (F))
5723 and then Ekind (F) = E_Out_Parameter
5725 Check_Restriction (No_Default_Initialization, F);
5727 -- Insert the initialization. We turn off validity checks
5728 -- for this assignment, since we do not want any check on
5729 -- the initial value itself (which may well be invalid).
5730 -- Predicate checks are disabled as well (RM 6.4.1 (13/3))
5733 Make_Assignment_Statement (Loc,
5734 Name => New_Occurrence_Of (F, Loc),
5735 Expression => Get_Simple_Init_Val (Etype (F), N));
5736 Set_Suppress_Assignment_Checks (A);
5738 Insert_Before_And_Analyze (First (L),
5739 A, Suppress => Validity_Check);
5747 -- Clear out statement list for stubbed procedure
5749 if Present (Corresponding_Spec (N)) then
5750 Set_Elaboration_Flag (N, Spec_Id);
5752 if Convention (Spec_Id) = Convention_Stubbed
5753 or else Is_Eliminated (Spec_Id)
5755 Set_Declarations (N, Empty_List);
5756 Set_Handled_Statement_Sequence (N,
5757 Make_Handled_Sequence_Of_Statements (Loc,
5758 Statements => New_List (Make_Null_Statement (Loc))));
5764 -- Create a set of discriminals for the next protected subprogram body
5766 if Is_List_Member (N)
5767 and then Present (Parent (List_Containing (N)))
5768 and then Nkind (Parent (List_Containing (N))) = N_Protected_Body
5769 and then Present (Next_Protected_Operation (N))
5771 Set_Discriminals (Parent (Base_Type (Scope (Spec_Id))));
5774 -- Returns_By_Ref flag is normally set when the subprogram is frozen but
5775 -- subprograms with no specs are not frozen.
5778 Typ : constant Entity_Id := Etype (Spec_Id);
5779 Utyp : constant Entity_Id := Underlying_Type (Typ);
5782 if Is_Limited_View (Typ) then
5783 Set_Returns_By_Ref (Spec_Id);
5785 elsif Present (Utyp) and then CW_Or_Has_Controlled_Part (Utyp) then
5786 Set_Returns_By_Ref (Spec_Id);
5790 -- For a procedure, we add a return for all possible syntactic ends of
5793 if Ekind_In (Spec_Id, E_Procedure, E_Generic_Procedure) then
5794 Add_Return (Spec_Id, Statements (HSS));
5796 if Present (Exception_Handlers (HSS)) then
5797 Except_H := First_Non_Pragma (Exception_Handlers (HSS));
5798 while Present (Except_H) loop
5799 Add_Return (Spec_Id, Statements (Except_H));
5800 Next_Non_Pragma (Except_H);
5804 -- For a function, we must deal with the case where there is at least
5805 -- one missing return. What we do is to wrap the entire body of the
5806 -- function in a block:
5819 -- raise Program_Error;
5822 -- This approach is necessary because the raise must be signalled to the
5823 -- caller, not handled by any local handler (RM 6.4(11)).
5825 -- Note: we do not need to analyze the constructed sequence here, since
5826 -- it has no handler, and an attempt to analyze the handled statement
5827 -- sequence twice is risky in various ways (e.g. the issue of expanding
5828 -- cleanup actions twice).
5830 elsif Has_Missing_Return (Spec_Id) then
5832 Hloc : constant Source_Ptr := Sloc (HSS);
5833 Blok : constant Node_Id :=
5834 Make_Block_Statement (Hloc,
5835 Handled_Statement_Sequence => HSS);
5836 Rais : constant Node_Id :=
5837 Make_Raise_Program_Error (Hloc,
5838 Reason => PE_Missing_Return);
5841 Set_Handled_Statement_Sequence (N,
5842 Make_Handled_Sequence_Of_Statements (Hloc,
5843 Statements => New_List (Blok, Rais)));
5845 Push_Scope (Spec_Id);
5852 -- If subprogram contains a parameterless recursive call, then we may
5853 -- have an infinite recursion, so see if we can generate code to check
5854 -- for this possibility if storage checks are not suppressed.
5856 if Ekind (Spec_Id) = E_Procedure
5857 and then Has_Recursive_Call (Spec_Id)
5858 and then not Storage_Checks_Suppressed (Spec_Id)
5860 Detect_Infinite_Recursion (N, Spec_Id);
5863 -- Set to encode entity names in package body before gigi is called
5865 Qualify_Entity_Names (N);
5867 -- If the body belongs to a nonabstract library-level source primitive
5868 -- of a tagged type, install an elaboration check which ensures that a
5869 -- dispatching call targeting the primitive will not execute the body
5870 -- without it being previously elaborated.
5872 Install_Primitive_Elaboration_Check (N);
5873 end Expand_N_Subprogram_Body;
5875 -----------------------------------
5876 -- Expand_N_Subprogram_Body_Stub --
5877 -----------------------------------
5879 procedure Expand_N_Subprogram_Body_Stub (N : Node_Id) is
5883 if Present (Corresponding_Body (N)) then
5884 Bod := Unit_Declaration_Node (Corresponding_Body (N));
5886 -- The body may have been expanded already when it is analyzed
5887 -- through the subunit node. Do no expand again: it interferes
5888 -- with the construction of unnesting tables when generating C.
5890 if not Analyzed (Bod) then
5891 Expand_N_Subprogram_Body (Bod);
5894 -- Add full qualification to entities that may be created late
5895 -- during unnesting.
5897 Qualify_Entity_Names (N);
5899 end Expand_N_Subprogram_Body_Stub;
5901 -------------------------------------
5902 -- Expand_N_Subprogram_Declaration --
5903 -------------------------------------
5905 -- If the declaration appears within a protected body, it is a private
5906 -- operation of the protected type. We must create the corresponding
5907 -- protected subprogram an associated formals. For a normal protected
5908 -- operation, this is done when expanding the protected type declaration.
5910 -- If the declaration is for a null procedure, emit null body
5912 procedure Expand_N_Subprogram_Declaration (N : Node_Id) is
5913 Loc : constant Source_Ptr := Sloc (N);
5914 Subp : constant Entity_Id := Defining_Entity (N);
5918 Scop : constant Entity_Id := Scope (Subp);
5920 Prot_Decl : Node_Id;
5921 Prot_Id : Entity_Id;
5923 -- Start of processing for Expand_N_Subprogram_Declaration
5926 -- In SPARK, subprogram declarations are only allowed in package
5929 if Nkind (Parent (N)) /= N_Package_Specification then
5930 if Nkind (Parent (N)) = N_Compilation_Unit then
5931 Check_SPARK_05_Restriction
5932 ("subprogram declaration is not a library item", N);
5934 elsif Present (Next (N))
5935 and then Nkind (Next (N)) = N_Pragma
5936 and then Get_Pragma_Id (Next (N)) = Pragma_Import
5938 -- In SPARK, subprogram declarations are also permitted in
5939 -- declarative parts when immediately followed by a corresponding
5940 -- pragma Import. We only check here that there is some pragma
5945 Check_SPARK_05_Restriction
5946 ("subprogram declaration is not allowed here", N);
5950 -- Deal with case of protected subprogram. Do not generate protected
5951 -- operation if operation is flagged as eliminated.
5953 if Is_List_Member (N)
5954 and then Present (Parent (List_Containing (N)))
5955 and then Nkind (Parent (List_Containing (N))) = N_Protected_Body
5956 and then Is_Protected_Type (Scop)
5958 if No (Protected_Body_Subprogram (Subp))
5959 and then not Is_Eliminated (Subp)
5962 Make_Subprogram_Declaration (Loc,
5964 Build_Protected_Sub_Specification
5965 (N, Scop, Unprotected_Mode));
5967 -- The protected subprogram is declared outside of the protected
5968 -- body. Given that the body has frozen all entities so far, we
5969 -- analyze the subprogram and perform freezing actions explicitly.
5970 -- including the generation of an explicit freeze node, to ensure
5971 -- that gigi has the proper order of elaboration.
5972 -- If the body is a subunit, the insertion point is before the
5973 -- stub in the parent.
5975 Prot_Bod := Parent (List_Containing (N));
5977 if Nkind (Parent (Prot_Bod)) = N_Subunit then
5978 Prot_Bod := Corresponding_Stub (Parent (Prot_Bod));
5981 Insert_Before (Prot_Bod, Prot_Decl);
5982 Prot_Id := Defining_Unit_Name (Specification (Prot_Decl));
5983 Set_Has_Delayed_Freeze (Prot_Id);
5985 Push_Scope (Scope (Scop));
5986 Analyze (Prot_Decl);
5987 Freeze_Before (N, Prot_Id);
5988 Set_Protected_Body_Subprogram (Subp, Prot_Id);
5990 -- Create protected operation as well. Even though the operation
5991 -- is only accessible within the body, it is possible to make it
5992 -- available outside of the protected object by using 'Access to
5993 -- provide a callback, so build protected version in all cases.
5996 Make_Subprogram_Declaration (Loc,
5998 Build_Protected_Sub_Specification (N, Scop, Protected_Mode));
5999 Insert_Before (Prot_Bod, Prot_Decl);
6000 Analyze (Prot_Decl);
6005 -- Ada 2005 (AI-348): Generate body for a null procedure. In most
6006 -- cases this is superfluous because calls to it will be automatically
6007 -- inlined, but we definitely need the body if preconditions for the
6008 -- procedure are present, or if performing coverage analysis.
6010 elsif Nkind (Specification (N)) = N_Procedure_Specification
6011 and then Null_Present (Specification (N))
6014 Bod : constant Node_Id := Body_To_Inline (N);
6017 Set_Has_Completion (Subp, False);
6018 Append_Freeze_Action (Subp, Bod);
6020 -- The body now contains raise statements, so calls to it will
6023 Set_Is_Inlined (Subp, False);
6027 -- When generating C code, transform a function that returns a
6028 -- constrained array type into a procedure with an out parameter
6029 -- that carries the return value.
6031 -- We skip this transformation for unchecked conversions, since they
6032 -- are not needed by the C generator (and this also produces cleaner
6035 if Modify_Tree_For_C
6036 and then Nkind (Specification (N)) = N_Function_Specification
6037 and then Is_Array_Type (Etype (Subp))
6038 and then Is_Constrained (Etype (Subp))
6039 and then not Is_Unchecked_Conversion_Instance (Subp)
6041 Build_Procedure_Form (N);
6043 end Expand_N_Subprogram_Declaration;
6045 --------------------------------
6046 -- Expand_Non_Function_Return --
6047 --------------------------------
6049 procedure Expand_Non_Function_Return (N : Node_Id) is
6050 pragma Assert (No (Expression (N)));
6052 Loc : constant Source_Ptr := Sloc (N);
6053 Scope_Id : Entity_Id := Return_Applies_To (Return_Statement_Entity (N));
6054 Kind : constant Entity_Kind := Ekind (Scope_Id);
6057 Goto_Stat : Node_Id;
6061 -- Call the _Postconditions procedure if the related subprogram has
6062 -- contract assertions that need to be verified on exit.
6064 if Ekind_In (Scope_Id, E_Entry, E_Entry_Family, E_Procedure)
6065 and then Present (Postconditions_Proc (Scope_Id))
6068 Make_Procedure_Call_Statement (Loc,
6069 Name => New_Occurrence_Of (Postconditions_Proc (Scope_Id), Loc)));
6072 -- If it is a return from a procedure do no extra steps
6074 if Kind = E_Procedure or else Kind = E_Generic_Procedure then
6077 -- If it is a nested return within an extended one, replace it with a
6078 -- return of the previously declared return object.
6080 elsif Kind = E_Return_Statement then
6082 Make_Simple_Return_Statement (Loc,
6084 New_Occurrence_Of (First_Entity (Scope_Id), Loc)));
6085 Set_Comes_From_Extended_Return_Statement (N);
6086 Set_Return_Statement_Entity (N, Scope_Id);
6087 Expand_Simple_Function_Return (N);
6091 pragma Assert (Is_Entry (Scope_Id));
6093 -- Look at the enclosing block to see whether the return is from an
6094 -- accept statement or an entry body.
6096 for J in reverse 0 .. Scope_Stack.Last loop
6097 Scope_Id := Scope_Stack.Table (J).Entity;
6098 exit when Is_Concurrent_Type (Scope_Id);
6101 -- If it is a return from accept statement it is expanded as call to
6102 -- RTS Complete_Rendezvous and a goto to the end of the accept body.
6104 -- (cf : Expand_N_Accept_Statement, Expand_N_Selective_Accept,
6105 -- Expand_N_Accept_Alternative in exp_ch9.adb)
6107 if Is_Task_Type (Scope_Id) then
6110 Make_Procedure_Call_Statement (Loc,
6111 Name => New_Occurrence_Of (RTE (RE_Complete_Rendezvous), Loc));
6112 Insert_Before (N, Call);
6113 -- why not insert actions here???
6116 Acc_Stat := Parent (N);
6117 while Nkind (Acc_Stat) /= N_Accept_Statement loop
6118 Acc_Stat := Parent (Acc_Stat);
6121 Lab_Node := Last (Statements
6122 (Handled_Statement_Sequence (Acc_Stat)));
6124 Goto_Stat := Make_Goto_Statement (Loc,
6125 Name => New_Occurrence_Of
6126 (Entity (Identifier (Lab_Node)), Loc));
6128 Set_Analyzed (Goto_Stat);
6130 Rewrite (N, Goto_Stat);
6133 -- If it is a return from an entry body, put a Complete_Entry_Body call
6134 -- in front of the return.
6136 elsif Is_Protected_Type (Scope_Id) then
6138 Make_Procedure_Call_Statement (Loc,
6140 New_Occurrence_Of (RTE (RE_Complete_Entry_Body), Loc),
6141 Parameter_Associations => New_List (
6142 Make_Attribute_Reference (Loc,
6145 (Find_Protection_Object (Current_Scope), Loc),
6146 Attribute_Name => Name_Unchecked_Access)));
6148 Insert_Before (N, Call);
6151 end Expand_Non_Function_Return;
6153 ---------------------------------------
6154 -- Expand_Protected_Object_Reference --
6155 ---------------------------------------
6157 function Expand_Protected_Object_Reference
6159 Scop : Entity_Id) return Node_Id
6161 Loc : constant Source_Ptr := Sloc (N);
6168 Rec := Make_Identifier (Loc, Name_uObject);
6169 Set_Etype (Rec, Corresponding_Record_Type (Scop));
6171 -- Find enclosing protected operation, and retrieve its first parameter,
6172 -- which denotes the enclosing protected object. If the enclosing
6173 -- operation is an entry, we are immediately within the protected body,
6174 -- and we can retrieve the object from the service entries procedure. A
6175 -- barrier function has the same signature as an entry. A barrier
6176 -- function is compiled within the protected object, but unlike
6177 -- protected operations its never needs locks, so that its protected
6178 -- body subprogram points to itself.
6180 Proc := Current_Scope;
6181 while Present (Proc)
6182 and then Scope (Proc) /= Scop
6184 Proc := Scope (Proc);
6187 Corr := Protected_Body_Subprogram (Proc);
6191 -- Previous error left expansion incomplete.
6192 -- Nothing to do on this call.
6199 (First (Parameter_Specifications (Parent (Corr))));
6201 if Is_Subprogram (Proc) and then Proc /= Corr then
6203 -- Protected function or procedure
6205 Set_Entity (Rec, Param);
6207 -- Rec is a reference to an entity which will not be in scope when
6208 -- the call is reanalyzed, and needs no further analysis.
6213 -- Entry or barrier function for entry body. The first parameter of
6214 -- the entry body procedure is pointer to the object. We create a
6215 -- local variable of the proper type, duplicating what is done to
6216 -- define _object later on.
6220 Obj_Ptr : constant Entity_Id := Make_Temporary (Loc, 'T');
6224 Make_Full_Type_Declaration (Loc,
6225 Defining_Identifier => Obj_Ptr,
6227 Make_Access_To_Object_Definition (Loc,
6228 Subtype_Indication =>
6230 (Corresponding_Record_Type (Scop), Loc))));
6232 Insert_Actions (N, Decls);
6233 Freeze_Before (N, Obj_Ptr);
6236 Make_Explicit_Dereference (Loc,
6238 Unchecked_Convert_To (Obj_Ptr,
6239 New_Occurrence_Of (Param, Loc)));
6241 -- Analyze new actual. Other actuals in calls are already analyzed
6242 -- and the list of actuals is not reanalyzed after rewriting.
6244 Set_Parent (Rec, N);
6250 end Expand_Protected_Object_Reference;
6252 --------------------------------------
6253 -- Expand_Protected_Subprogram_Call --
6254 --------------------------------------
6256 procedure Expand_Protected_Subprogram_Call
6263 procedure Expand_Internal_Init_Call;
6264 -- A call to an operation of the type may occur in the initialization
6265 -- of a private component. In that case the prefix of the call is an
6266 -- entity name and the call is treated as internal even though it
6267 -- appears in code outside of the protected type.
6269 procedure Freeze_Called_Function;
6270 -- If it is a function call it can appear in elaboration code and
6271 -- the called entity must be frozen before the call. This must be
6272 -- done before the call is expanded, as the expansion may rewrite it
6273 -- to something other than a call (e.g. a temporary initialized in a
6274 -- transient block).
6276 -------------------------------
6277 -- Expand_Internal_Init_Call --
6278 -------------------------------
6280 procedure Expand_Internal_Init_Call is
6282 -- If the context is a protected object (rather than a protected
6283 -- type) the call itself is bound to raise program_error because
6284 -- the protected body will not have been elaborated yet. This is
6285 -- diagnosed subsequently in Sem_Elab.
6287 Freeze_Called_Function;
6289 -- The target of the internal call is the first formal of the
6290 -- enclosing initialization procedure.
6292 Rec := New_Occurrence_Of (First_Formal (Current_Scope), Sloc (N));
6293 Build_Protected_Subprogram_Call (N,
6298 Resolve (N, Etype (Subp));
6299 end Expand_Internal_Init_Call;
6301 ----------------------------
6302 -- Freeze_Called_Function --
6303 ----------------------------
6305 procedure Freeze_Called_Function is
6307 if Ekind (Subp) = E_Function then
6308 Freeze_Expression (Name (N));
6310 end Freeze_Called_Function;
6312 -- Start of processing for Expand_Protected_Subprogram_Call
6315 -- If the protected object is not an enclosing scope, this is an inter-
6316 -- object function call. Inter-object procedure calls are expanded by
6317 -- Exp_Ch9.Build_Simple_Entry_Call. The call is intra-object only if the
6318 -- subprogram being called is in the protected body being compiled, and
6319 -- if the protected object in the call is statically the enclosing type.
6320 -- The object may be a component of some other data structure, in which
6321 -- case this must be handled as an inter-object call.
6323 if not In_Open_Scopes (Scop)
6324 or else Is_Entry_Wrapper (Current_Scope)
6325 or else not Is_Entity_Name (Name (N))
6327 if Nkind (Name (N)) = N_Selected_Component then
6328 Rec := Prefix (Name (N));
6330 elsif Nkind (Name (N)) = N_Indexed_Component then
6331 Rec := Prefix (Prefix (Name (N)));
6333 -- If this is a call within an entry wrapper, it appears within a
6334 -- precondition that calls another primitive of the synchronized
6335 -- type. The target object of the call is the first actual on the
6336 -- wrapper. Note that this is an external call, because the wrapper
6337 -- is called outside of the synchronized object. This means that
6338 -- an entry call to an entry with preconditions involves two
6339 -- synchronized operations.
6341 elsif Ekind (Current_Scope) = E_Procedure
6342 and then Is_Entry_Wrapper (Current_Scope)
6344 Rec := New_Occurrence_Of (First_Entity (Current_Scope), Sloc (N));
6347 -- If the context is the initialization procedure for a protected
6348 -- type, the call is legal because the called entity must be a
6349 -- function of that enclosing type, and this is treated as an
6353 (Is_Entity_Name (Name (N)) and then Inside_Init_Proc);
6355 Expand_Internal_Init_Call;
6359 Freeze_Called_Function;
6360 Build_Protected_Subprogram_Call (N,
6361 Name => New_Occurrence_Of (Subp, Sloc (N)),
6362 Rec => Convert_Concurrent (Rec, Etype (Rec)),
6366 Rec := Expand_Protected_Object_Reference (N, Scop);
6372 Freeze_Called_Function;
6373 Build_Protected_Subprogram_Call (N,
6379 -- Analyze and resolve the new call. The actuals have already been
6380 -- resolved, but expansion of a function call will add extra actuals
6381 -- if needed. Analysis of a procedure call already includes resolution.
6385 if Ekind (Subp) = E_Function then
6386 Resolve (N, Etype (Subp));
6388 end Expand_Protected_Subprogram_Call;
6390 -----------------------------------
6391 -- Expand_Simple_Function_Return --
6392 -----------------------------------
6394 -- The "simple" comes from the syntax rule simple_return_statement. The
6395 -- semantics are not at all simple.
6397 procedure Expand_Simple_Function_Return (N : Node_Id) is
6398 Loc : constant Source_Ptr := Sloc (N);
6400 Scope_Id : constant Entity_Id :=
6401 Return_Applies_To (Return_Statement_Entity (N));
6402 -- The function we are returning from
6404 R_Type : constant Entity_Id := Etype (Scope_Id);
6405 -- The result type of the function
6407 Utyp : constant Entity_Id := Underlying_Type (R_Type);
6409 Exp : Node_Id := Expression (N);
6410 pragma Assert (Present (Exp));
6412 Exptyp : constant Entity_Id := Etype (Exp);
6413 -- The type of the expression (not necessarily the same as R_Type)
6415 Subtype_Ind : Node_Id;
6416 -- If the result type of the function is class-wide and the expression
6417 -- has a specific type, then we use the expression's type as the type of
6418 -- the return object. In cases where the expression is an aggregate that
6419 -- is built in place, this avoids the need for an expensive conversion
6420 -- of the return object to the specific type on assignments to the
6421 -- individual components.
6424 if Is_Class_Wide_Type (R_Type)
6425 and then not Is_Class_Wide_Type (Exptyp)
6426 and then Nkind (Exp) /= N_Type_Conversion
6428 Subtype_Ind := New_Occurrence_Of (Exptyp, Loc);
6430 Subtype_Ind := New_Occurrence_Of (R_Type, Loc);
6432 -- If the result type is class-wide and the expression is a view
6433 -- conversion, the conversion plays no role in the expansion because
6434 -- it does not modify the tag of the object. Remove the conversion
6435 -- altogether to prevent tag overwriting.
6437 if Is_Class_Wide_Type (R_Type)
6438 and then not Is_Class_Wide_Type (Exptyp)
6439 and then Nkind (Exp) = N_Type_Conversion
6441 Exp := Expression (Exp);
6445 -- For the case of a simple return that does not come from an
6446 -- extended return, in the case of build-in-place, we rewrite
6447 -- "return <expression>;" to be:
6449 -- return _anon_ : <return_subtype> := <expression>
6451 -- The expansion produced by Expand_N_Extended_Return_Statement will
6452 -- contain simple return statements (for example, a block containing
6453 -- simple return of the return object), which brings us back here with
6454 -- Comes_From_Extended_Return_Statement set. The reason for the barrier
6455 -- checking for a simple return that does not come from an extended
6456 -- return is to avoid this infinite recursion.
6458 -- The reason for this design is that for Ada 2005 limited returns, we
6459 -- need to reify the return object, so we can build it "in place", and
6460 -- we need a block statement to hang finalization and tasking stuff.
6462 -- ??? In order to avoid disruption, we avoid translating to extended
6463 -- return except in the cases where we really need to (Ada 2005 for
6464 -- inherently limited). We might prefer to do this translation in all
6465 -- cases (except perhaps for the case of Ada 95 inherently limited),
6466 -- in order to fully exercise the Expand_N_Extended_Return_Statement
6467 -- code. This would also allow us to do the build-in-place optimization
6468 -- for efficiency even in cases where it is semantically not required.
6470 -- As before, we check the type of the return expression rather than the
6471 -- return type of the function, because the latter may be a limited
6472 -- class-wide interface type, which is not a limited type, even though
6473 -- the type of the expression may be.
6476 (Comes_From_Extended_Return_Statement (N)
6477 or else not Is_Build_In_Place_Function_Call (Exp)
6478 or else Is_Build_In_Place_Function (Scope_Id));
6480 if not Comes_From_Extended_Return_Statement (N)
6481 and then Is_Build_In_Place_Function (Scope_Id)
6482 and then not Debug_Flag_Dot_L
6484 -- The functionality of interface thunks is simple and it is always
6485 -- handled by means of simple return statements. This leaves their
6486 -- expansion simple and clean.
6488 and then not Is_Thunk (Current_Scope)
6491 Return_Object_Entity : constant Entity_Id :=
6492 Make_Temporary (Loc, 'R', Exp);
6494 Obj_Decl : constant Node_Id :=
6495 Make_Object_Declaration (Loc,
6496 Defining_Identifier => Return_Object_Entity,
6497 Object_Definition => Subtype_Ind,
6500 Ext : constant Node_Id :=
6501 Make_Extended_Return_Statement (Loc,
6502 Return_Object_Declarations => New_List (Obj_Decl));
6503 -- Do not perform this high-level optimization if the result type
6504 -- is an interface because the "this" pointer must be displaced.
6513 -- Here we have a simple return statement that is part of the expansion
6514 -- of an extended return statement (either written by the user, or
6515 -- generated by the above code).
6517 -- Always normalize C/Fortran boolean result. This is not always needed,
6518 -- but it seems a good idea to minimize the passing around of non-
6519 -- normalized values, and in any case this handles the processing of
6520 -- barrier functions for protected types, which turn the condition into
6521 -- a return statement.
6523 if Is_Boolean_Type (Exptyp)
6524 and then Nonzero_Is_True (Exptyp)
6526 Adjust_Condition (Exp);
6527 Adjust_Result_Type (Exp, Exptyp);
6530 -- Do validity check if enabled for returns
6532 if Validity_Checks_On
6533 and then Validity_Check_Returns
6538 -- Check the result expression of a scalar function against the subtype
6539 -- of the function by inserting a conversion. This conversion must
6540 -- eventually be performed for other classes of types, but for now it's
6541 -- only done for scalars.
6544 if Is_Scalar_Type (Exptyp) then
6545 Rewrite (Exp, Convert_To (R_Type, Exp));
6547 -- The expression is resolved to ensure that the conversion gets
6548 -- expanded to generate a possible constraint check.
6550 Analyze_And_Resolve (Exp, R_Type);
6553 -- Deal with returning variable length objects and controlled types
6555 -- Nothing to do if we are returning by reference, or this is not a
6556 -- type that requires special processing (indicated by the fact that
6557 -- it requires a cleanup scope for the secondary stack case).
6559 if Is_Build_In_Place_Function (Scope_Id)
6560 or else Is_Limited_Interface (Exptyp)
6564 -- No copy needed for thunks returning interface type objects since
6565 -- the object is returned by reference and the maximum functionality
6566 -- required is just to displace the pointer.
6568 elsif Is_Thunk (Current_Scope) and then Is_Interface (Exptyp) then
6571 -- If the call is within a thunk and the type is a limited view, the
6572 -- backend will eventually see the non-limited view of the type.
6574 elsif Is_Thunk (Current_Scope) and then Is_Incomplete_Type (Exptyp) then
6577 elsif not Requires_Transient_Scope (R_Type) then
6579 -- Mutable records with variable-length components are not returned
6580 -- on the sec-stack, so we need to make sure that the back end will
6581 -- only copy back the size of the actual value, and not the maximum
6582 -- size. We create an actual subtype for this purpose. However we
6583 -- need not do it if the expression is a function call since this
6584 -- will be done in the called function and doing it here too would
6585 -- cause a temporary with maximum size to be created.
6588 Ubt : constant Entity_Id := Underlying_Type (Base_Type (Exptyp));
6592 if Nkind (Exp) /= N_Function_Call
6593 and then Has_Discriminants (Ubt)
6594 and then not Is_Constrained (Ubt)
6595 and then not Has_Unchecked_Union (Ubt)
6597 Decl := Build_Actual_Subtype (Ubt, Exp);
6598 Ent := Defining_Identifier (Decl);
6599 Insert_Action (Exp, Decl);
6600 Rewrite (Exp, Unchecked_Convert_To (Ent, Exp));
6601 Analyze_And_Resolve (Exp);
6605 -- Here if secondary stack is used
6608 -- Prevent the reclamation of the secondary stack by all enclosing
6609 -- blocks and loops as well as the related function; otherwise the
6610 -- result would be reclaimed too early.
6612 Set_Enclosing_Sec_Stack_Return (N);
6614 -- Optimize the case where the result is a function call. In this
6615 -- case either the result is already on the secondary stack, or is
6616 -- already being returned with the stack pointer depressed and no
6617 -- further processing is required except to set the By_Ref flag
6618 -- to ensure that gigi does not attempt an extra unnecessary copy.
6619 -- (actually not just unnecessary but harmfully wrong in the case
6620 -- of a controlled type, where gigi does not know how to do a copy).
6621 -- To make up for a gcc 2.8.1 deficiency (???), we perform the copy
6622 -- for array types if the constrained status of the target type is
6623 -- different from that of the expression.
6625 if Requires_Transient_Scope (Exptyp)
6627 (not Is_Array_Type (Exptyp)
6628 or else Is_Constrained (Exptyp) = Is_Constrained (R_Type)
6629 or else CW_Or_Has_Controlled_Part (Utyp))
6630 and then Nkind (Exp) = N_Function_Call
6634 -- Remove side effects from the expression now so that other parts
6635 -- of the expander do not have to reanalyze this node without this
6638 Rewrite (Exp, Duplicate_Subexpr_No_Checks (Exp));
6640 -- Ada 2005 (AI-251): If the type of the returned object is
6641 -- an interface then add an implicit type conversion to force
6642 -- displacement of the "this" pointer.
6644 if Is_Interface (R_Type) then
6645 Rewrite (Exp, Convert_To (R_Type, Relocate_Node (Exp)));
6648 Analyze_And_Resolve (Exp, R_Type);
6650 -- For controlled types, do the allocation on the secondary stack
6651 -- manually in order to call adjust at the right time:
6653 -- type Anon1 is access R_Type;
6654 -- for Anon1'Storage_pool use ss_pool;
6655 -- Anon2 : anon1 := new R_Type'(expr);
6656 -- return Anon2.all;
6658 -- We do the same for classwide types that are not potentially
6659 -- controlled (by the virtue of restriction No_Finalization) because
6660 -- gigi is not able to properly allocate class-wide types.
6662 elsif CW_Or_Has_Controlled_Part (Utyp) then
6664 Loc : constant Source_Ptr := Sloc (N);
6665 Acc_Typ : constant Entity_Id := Make_Temporary (Loc, 'A');
6666 Alloc_Node : Node_Id;
6670 Set_Ekind (Acc_Typ, E_Access_Type);
6672 Set_Associated_Storage_Pool (Acc_Typ, RTE (RE_SS_Pool));
6674 -- This is an allocator for the secondary stack, and it's fine
6675 -- to have Comes_From_Source set False on it, as gigi knows not
6676 -- to flag it as a violation of No_Implicit_Heap_Allocations.
6679 Make_Allocator (Loc,
6681 Make_Qualified_Expression (Loc,
6682 Subtype_Mark => New_Occurrence_Of (Etype (Exp), Loc),
6683 Expression => Relocate_Node (Exp)));
6685 -- We do not want discriminant checks on the declaration,
6686 -- given that it gets its value from the allocator.
6688 Set_No_Initialization (Alloc_Node);
6690 Temp := Make_Temporary (Loc, 'R', Alloc_Node);
6692 Insert_List_Before_And_Analyze (N, New_List (
6693 Make_Full_Type_Declaration (Loc,
6694 Defining_Identifier => Acc_Typ,
6696 Make_Access_To_Object_Definition (Loc,
6697 Subtype_Indication => Subtype_Ind)),
6699 Make_Object_Declaration (Loc,
6700 Defining_Identifier => Temp,
6701 Object_Definition => New_Occurrence_Of (Acc_Typ, Loc),
6702 Expression => Alloc_Node)));
6705 Make_Explicit_Dereference (Loc,
6706 Prefix => New_Occurrence_Of (Temp, Loc)));
6708 -- Ada 2005 (AI-251): If the type of the returned object is
6709 -- an interface then add an implicit type conversion to force
6710 -- displacement of the "this" pointer.
6712 if Is_Interface (R_Type) then
6713 Rewrite (Exp, Convert_To (R_Type, Relocate_Node (Exp)));
6716 Analyze_And_Resolve (Exp, R_Type);
6719 -- Otherwise use the gigi mechanism to allocate result on the
6723 Check_Restriction (No_Secondary_Stack, N);
6724 Set_Storage_Pool (N, RTE (RE_SS_Pool));
6725 Set_Procedure_To_Call (N, RTE (RE_SS_Allocate));
6729 -- Implement the rules of 6.5(8-10), which require a tag check in
6730 -- the case of a limited tagged return type, and tag reassignment for
6731 -- nonlimited tagged results. These actions are needed when the return
6732 -- type is a specific tagged type and the result expression is a
6733 -- conversion or a formal parameter, because in that case the tag of
6734 -- the expression might differ from the tag of the specific result type.
6736 if Is_Tagged_Type (Utyp)
6737 and then not Is_Class_Wide_Type (Utyp)
6738 and then (Nkind_In (Exp, N_Type_Conversion,
6739 N_Unchecked_Type_Conversion)
6740 or else (Is_Entity_Name (Exp)
6741 and then Ekind (Entity (Exp)) in Formal_Kind))
6743 -- When the return type is limited, perform a check that the tag of
6744 -- the result is the same as the tag of the return type.
6746 if Is_Limited_Type (R_Type) then
6748 Make_Raise_Constraint_Error (Loc,
6752 Make_Selected_Component (Loc,
6753 Prefix => Duplicate_Subexpr (Exp),
6754 Selector_Name => Make_Identifier (Loc, Name_uTag)),
6756 Make_Attribute_Reference (Loc,
6758 New_Occurrence_Of (Base_Type (Utyp), Loc),
6759 Attribute_Name => Name_Tag)),
6760 Reason => CE_Tag_Check_Failed));
6762 -- If the result type is a specific nonlimited tagged type, then we
6763 -- have to ensure that the tag of the result is that of the result
6764 -- type. This is handled by making a copy of the expression in
6765 -- the case where it might have a different tag, namely when the
6766 -- expression is a conversion or a formal parameter. We create a new
6767 -- object of the result type and initialize it from the expression,
6768 -- which will implicitly force the tag to be set appropriately.
6772 ExpR : constant Node_Id := Relocate_Node (Exp);
6773 Result_Id : constant Entity_Id :=
6774 Make_Temporary (Loc, 'R', ExpR);
6775 Result_Exp : constant Node_Id :=
6776 New_Occurrence_Of (Result_Id, Loc);
6777 Result_Obj : constant Node_Id :=
6778 Make_Object_Declaration (Loc,
6779 Defining_Identifier => Result_Id,
6780 Object_Definition =>
6781 New_Occurrence_Of (R_Type, Loc),
6782 Constant_Present => True,
6783 Expression => ExpR);
6786 Set_Assignment_OK (Result_Obj);
6787 Insert_Action (Exp, Result_Obj);
6789 Rewrite (Exp, Result_Exp);
6790 Analyze_And_Resolve (Exp, R_Type);
6794 -- Ada 2005 (AI-344): If the result type is class-wide, then insert
6795 -- a check that the level of the return expression's underlying type
6796 -- is not deeper than the level of the master enclosing the function.
6797 -- Always generate the check when the type of the return expression
6798 -- is class-wide, when it's a type conversion, or when it's a formal
6799 -- parameter. Otherwise, suppress the check in the case where the
6800 -- return expression has a specific type whose level is known not to
6801 -- be statically deeper than the function's result type.
6803 -- No runtime check needed in interface thunks since it is performed
6804 -- by the target primitive associated with the thunk.
6806 -- Note: accessibility check is skipped in the VM case, since there
6807 -- does not seem to be any practical way to implement this check.
6809 elsif Ada_Version >= Ada_2005
6810 and then Tagged_Type_Expansion
6811 and then Is_Class_Wide_Type (R_Type)
6812 and then not Is_Thunk (Current_Scope)
6813 and then not Scope_Suppress.Suppress (Accessibility_Check)
6815 (Is_Class_Wide_Type (Etype (Exp))
6816 or else Nkind_In (Exp, N_Type_Conversion,
6817 N_Unchecked_Type_Conversion)
6818 or else (Is_Entity_Name (Exp)
6819 and then Ekind (Entity (Exp)) in Formal_Kind)
6820 or else Scope_Depth (Enclosing_Dynamic_Scope (Etype (Exp))) >
6821 Scope_Depth (Enclosing_Dynamic_Scope (Scope_Id)))
6827 -- Ada 2005 (AI-251): In class-wide interface objects we displace
6828 -- "this" to reference the base of the object. This is required to
6829 -- get access to the TSD of the object.
6831 if Is_Class_Wide_Type (Etype (Exp))
6832 and then Is_Interface (Etype (Exp))
6834 -- If the expression is an explicit dereference then we can
6835 -- directly displace the pointer to reference the base of
6838 if Nkind (Exp) = N_Explicit_Dereference then
6840 Make_Explicit_Dereference (Loc,
6842 Unchecked_Convert_To (RTE (RE_Tag_Ptr),
6843 Make_Function_Call (Loc,
6845 New_Occurrence_Of (RTE (RE_Base_Address), Loc),
6846 Parameter_Associations => New_List (
6847 Unchecked_Convert_To (RTE (RE_Address),
6848 Duplicate_Subexpr (Prefix (Exp)))))));
6850 -- Similar case to the previous one but the expression is a
6851 -- renaming of an explicit dereference.
6853 elsif Nkind (Exp) = N_Identifier
6854 and then Present (Renamed_Object (Entity (Exp)))
6855 and then Nkind (Renamed_Object (Entity (Exp)))
6856 = N_Explicit_Dereference
6859 Make_Explicit_Dereference (Loc,
6861 Unchecked_Convert_To (RTE (RE_Tag_Ptr),
6862 Make_Function_Call (Loc,
6864 New_Occurrence_Of (RTE (RE_Base_Address), Loc),
6865 Parameter_Associations => New_List (
6866 Unchecked_Convert_To (RTE (RE_Address),
6869 (Renamed_Object (Entity (Exp)))))))));
6871 -- Common case: obtain the address of the actual object and
6872 -- displace the pointer to reference the base of the object.
6876 Make_Explicit_Dereference (Loc,
6878 Unchecked_Convert_To (RTE (RE_Tag_Ptr),
6879 Make_Function_Call (Loc,
6881 New_Occurrence_Of (RTE (RE_Base_Address), Loc),
6882 Parameter_Associations => New_List (
6883 Make_Attribute_Reference (Loc,
6884 Prefix => Duplicate_Subexpr (Exp),
6885 Attribute_Name => Name_Address)))));
6889 Make_Attribute_Reference (Loc,
6890 Prefix => Duplicate_Subexpr (Exp),
6891 Attribute_Name => Name_Tag);
6894 -- CodePeer does not do anything useful with
6895 -- Ada.Tags.Type_Specific_Data components.
6897 if not CodePeer_Mode then
6899 Make_Raise_Program_Error (Loc,
6902 Left_Opnd => Build_Get_Access_Level (Loc, Tag_Node),
6904 Make_Integer_Literal (Loc,
6905 Scope_Depth (Enclosing_Dynamic_Scope (Scope_Id)))),
6906 Reason => PE_Accessibility_Check_Failed));
6910 -- AI05-0073: If function has a controlling access result, check that
6911 -- the tag of the return value, if it is not null, matches designated
6912 -- type of return type.
6914 -- The return expression is referenced twice in the code below, so it
6915 -- must be made free of side effects. Given that different compilers
6916 -- may evaluate these parameters in different order, both occurrences
6919 elsif Ekind (R_Type) = E_Anonymous_Access_Type
6920 and then Has_Controlling_Result (Scope_Id)
6923 Make_Raise_Constraint_Error (Loc,
6928 Left_Opnd => Duplicate_Subexpr (Exp),
6929 Right_Opnd => Make_Null (Loc)),
6931 Right_Opnd => Make_Op_Ne (Loc,
6933 Make_Selected_Component (Loc,
6934 Prefix => Duplicate_Subexpr (Exp),
6935 Selector_Name => Make_Identifier (Loc, Name_uTag)),
6938 Make_Attribute_Reference (Loc,
6940 New_Occurrence_Of (Designated_Type (R_Type), Loc),
6941 Attribute_Name => Name_Tag))),
6943 Reason => CE_Tag_Check_Failed),
6944 Suppress => All_Checks);
6947 -- AI05-0234: RM 6.5(21/3). Check access discriminants to
6948 -- ensure that the function result does not outlive an
6949 -- object designated by one of it discriminants.
6951 if Present (Extra_Accessibility_Of_Result (Scope_Id))
6952 and then Has_Unconstrained_Access_Discriminants (R_Type)
6955 Discrim_Source : Node_Id;
6957 procedure Check_Against_Result_Level (Level : Node_Id);
6958 -- Check the given accessibility level against the level
6959 -- determined by the point of call. (AI05-0234).
6961 --------------------------------
6962 -- Check_Against_Result_Level --
6963 --------------------------------
6965 procedure Check_Against_Result_Level (Level : Node_Id) is
6968 Make_Raise_Program_Error (Loc,
6974 (Extra_Accessibility_Of_Result (Scope_Id), Loc)),
6975 Reason => PE_Accessibility_Check_Failed));
6976 end Check_Against_Result_Level;
6979 Discrim_Source := Exp;
6980 while Nkind (Discrim_Source) = N_Qualified_Expression loop
6981 Discrim_Source := Expression (Discrim_Source);
6984 if Nkind (Discrim_Source) = N_Identifier
6985 and then Is_Return_Object (Entity (Discrim_Source))
6987 Discrim_Source := Entity (Discrim_Source);
6989 if Is_Constrained (Etype (Discrim_Source)) then
6990 Discrim_Source := Etype (Discrim_Source);
6992 Discrim_Source := Expression (Parent (Discrim_Source));
6995 elsif Nkind (Discrim_Source) = N_Identifier
6996 and then Nkind_In (Original_Node (Discrim_Source),
6997 N_Aggregate, N_Extension_Aggregate)
6999 Discrim_Source := Original_Node (Discrim_Source);
7001 elsif Nkind (Discrim_Source) = N_Explicit_Dereference and then
7002 Nkind (Original_Node (Discrim_Source)) = N_Function_Call
7004 Discrim_Source := Original_Node (Discrim_Source);
7007 Discrim_Source := Unqual_Conv (Discrim_Source);
7009 case Nkind (Discrim_Source) is
7010 when N_Defining_Identifier =>
7011 pragma Assert (Is_Composite_Type (Discrim_Source)
7012 and then Has_Discriminants (Discrim_Source)
7013 and then Is_Constrained (Discrim_Source));
7016 Discrim : Entity_Id :=
7017 First_Discriminant (Base_Type (R_Type));
7018 Disc_Elmt : Elmt_Id :=
7019 First_Elmt (Discriminant_Constraint
7023 if Ekind (Etype (Discrim)) =
7024 E_Anonymous_Access_Type
7026 Check_Against_Result_Level
7027 (Dynamic_Accessibility_Level (Node (Disc_Elmt)));
7030 Next_Elmt (Disc_Elmt);
7031 Next_Discriminant (Discrim);
7032 exit when not Present (Discrim);
7037 | N_Extension_Aggregate
7039 -- Unimplemented: extension aggregate case where discrims
7040 -- come from ancestor part, not extension part.
7043 Discrim : Entity_Id :=
7044 First_Discriminant (Base_Type (R_Type));
7046 Disc_Exp : Node_Id := Empty;
7048 Positionals_Exhausted
7049 : Boolean := not Present (Expressions
7052 function Associated_Expr
7053 (Comp_Id : Entity_Id;
7054 Associations : List_Id) return Node_Id;
7056 -- Given a component and a component associations list,
7057 -- locate the expression for that component; returns
7058 -- Empty if no such expression is found.
7060 ---------------------
7061 -- Associated_Expr --
7062 ---------------------
7064 function Associated_Expr
7065 (Comp_Id : Entity_Id;
7066 Associations : List_Id) return Node_Id
7072 -- Simple linear search seems ok here
7074 Assoc := First (Associations);
7075 while Present (Assoc) loop
7076 Choice := First (Choices (Assoc));
7077 while Present (Choice) loop
7078 if (Nkind (Choice) = N_Identifier
7079 and then Chars (Choice) = Chars (Comp_Id))
7080 or else (Nkind (Choice) = N_Others_Choice)
7082 return Expression (Assoc);
7092 end Associated_Expr;
7094 -- Start of processing for Expand_Simple_Function_Return
7097 if not Positionals_Exhausted then
7098 Disc_Exp := First (Expressions (Discrim_Source));
7102 if Positionals_Exhausted then
7106 Component_Associations (Discrim_Source));
7109 if Ekind (Etype (Discrim)) =
7110 E_Anonymous_Access_Type
7112 Check_Against_Result_Level
7113 (Dynamic_Accessibility_Level (Disc_Exp));
7116 Next_Discriminant (Discrim);
7117 exit when not Present (Discrim);
7119 if not Positionals_Exhausted then
7121 Positionals_Exhausted := not Present (Disc_Exp);
7126 when N_Function_Call =>
7128 -- No check needed (check performed by callee)
7134 Level : constant Node_Id :=
7135 Make_Integer_Literal (Loc,
7136 Object_Access_Level (Discrim_Source));
7139 -- Unimplemented: check for name prefix that includes
7140 -- a dereference of an access value with a dynamic
7141 -- accessibility level (e.g., an access param or a
7142 -- saooaaat) and use dynamic level in that case. For
7144 -- return Access_Param.all(Some_Index).Some_Component;
7147 Set_Etype (Level, Standard_Natural);
7148 Check_Against_Result_Level (Level);
7154 -- If we are returning an object that may not be bit-aligned, then copy
7155 -- the value into a temporary first. This copy may need to expand to a
7156 -- loop of component operations.
7158 if Is_Possibly_Unaligned_Slice (Exp)
7159 or else Is_Possibly_Unaligned_Object (Exp)
7162 ExpR : constant Node_Id := Relocate_Node (Exp);
7163 Tnn : constant Entity_Id := Make_Temporary (Loc, 'T', ExpR);
7166 Make_Object_Declaration (Loc,
7167 Defining_Identifier => Tnn,
7168 Constant_Present => True,
7169 Object_Definition => New_Occurrence_Of (R_Type, Loc),
7170 Expression => ExpR),
7171 Suppress => All_Checks);
7172 Rewrite (Exp, New_Occurrence_Of (Tnn, Loc));
7176 -- Call the _Postconditions procedure if the related function has
7177 -- contract assertions that need to be verified on exit.
7179 if Ekind (Scope_Id) = E_Function
7180 and then Present (Postconditions_Proc (Scope_Id))
7182 -- In the case of discriminated objects, we have created a
7183 -- constrained subtype above, and used the underlying type. This
7184 -- transformation is post-analysis and harmless, except that now the
7185 -- call to the post-condition will be analyzed and the type kinds
7188 if Nkind (Exp) = N_Unchecked_Type_Conversion
7189 and then Is_Private_Type (R_Type) /= Is_Private_Type (Etype (Exp))
7191 Rewrite (Exp, Expression (Relocate_Node (Exp)));
7194 -- We are going to reference the returned value twice in this case,
7195 -- once in the call to _Postconditions, and once in the actual return
7196 -- statement, but we can't have side effects happening twice.
7198 Force_Evaluation (Exp, Mode => Strict);
7200 -- Generate call to _Postconditions
7203 Make_Procedure_Call_Statement (Loc,
7205 New_Occurrence_Of (Postconditions_Proc (Scope_Id), Loc),
7206 Parameter_Associations => New_List (New_Copy_Tree (Exp))));
7209 -- Ada 2005 (AI-251): If this return statement corresponds with an
7210 -- simple return statement associated with an extended return statement
7211 -- and the type of the returned object is an interface then generate an
7212 -- implicit conversion to force displacement of the "this" pointer.
7214 if Ada_Version >= Ada_2005
7215 and then Comes_From_Extended_Return_Statement (N)
7216 and then Nkind (Expression (N)) = N_Identifier
7217 and then Is_Interface (Utyp)
7218 and then Utyp /= Underlying_Type (Exptyp)
7220 Rewrite (Exp, Convert_To (Utyp, Relocate_Node (Exp)));
7221 Analyze_And_Resolve (Exp);
7223 end Expand_Simple_Function_Return;
7225 --------------------------------------------
7226 -- Has_Unconstrained_Access_Discriminants --
7227 --------------------------------------------
7229 function Has_Unconstrained_Access_Discriminants
7230 (Subtyp : Entity_Id) return Boolean
7235 if Has_Discriminants (Subtyp)
7236 and then not Is_Constrained (Subtyp)
7238 Discr := First_Discriminant (Subtyp);
7239 while Present (Discr) loop
7240 if Ekind (Etype (Discr)) = E_Anonymous_Access_Type then
7244 Next_Discriminant (Discr);
7249 end Has_Unconstrained_Access_Discriminants;
7251 -----------------------------------
7252 -- Is_Build_In_Place_Result_Type --
7253 -----------------------------------
7255 function Is_Build_In_Place_Result_Type (Typ : Entity_Id) return Boolean is
7257 if not Expander_Active then
7261 -- In Ada 2005 all functions with an inherently limited return type
7262 -- must be handled using a build-in-place profile, including the case
7263 -- of a function with a limited interface result, where the function
7264 -- may return objects of nonlimited descendants.
7266 if Is_Limited_View (Typ) then
7267 return Ada_Version >= Ada_2005 and then not Debug_Flag_Dot_L;
7270 if Debug_Flag_Dot_9 then
7274 if Has_Interfaces (Typ) then
7279 T : Entity_Id := Typ;
7281 -- For T'Class, return True if it's True for T. This is necessary
7282 -- because a class-wide function might say "return F (...)", where
7283 -- F returns the corresponding specific type. We need a loop in
7284 -- case T is a subtype of a class-wide type.
7286 while Is_Class_Wide_Type (T) loop
7290 -- If this is a generic formal type in an instance, return True if
7291 -- it's True for the generic actual type.
7293 if Nkind (Parent (T)) = N_Subtype_Declaration
7294 and then Present (Generic_Parent_Type (Parent (T)))
7296 T := Entity (Subtype_Indication (Parent (T)));
7298 if Present (Full_View (T)) then
7303 if Present (Underlying_Type (T)) then
7304 T := Underlying_Type (T);
7309 -- So we can stop here in the debugger
7311 -- ???For now, enable build-in-place for a very narrow set of
7312 -- controlled types. Change "if True" to "if False" to
7313 -- experiment more controlled types. Eventually, we would
7314 -- like to enable build-in-place for all tagged types, all
7315 -- types that need finalization, and all caller-unknown-size
7319 Result := Is_Controlled (T)
7320 and then Present (Enclosing_Subprogram (T))
7321 and then not Is_Compilation_Unit (Enclosing_Subprogram (T))
7322 and then Ekind (Enclosing_Subprogram (T)) = E_Procedure;
7324 Result := Is_Controlled (T);
7331 end Is_Build_In_Place_Result_Type;
7333 --------------------------------
7334 -- Is_Build_In_Place_Function --
7335 --------------------------------
7337 function Is_Build_In_Place_Function (E : Entity_Id) return Boolean is
7339 -- This function is called from Expand_Subtype_From_Expr during
7340 -- semantic analysis, even when expansion is off. In those cases
7341 -- the build_in_place expansion will not take place.
7343 if not Expander_Active then
7347 -- For now we test whether E denotes a function or access-to-function
7348 -- type whose result subtype is inherently limited. Later this test
7349 -- may be revised to allow composite nonlimited types. Functions with
7350 -- a foreign convention or whose result type has a foreign convention
7353 if Ekind_In (E, E_Function, E_Generic_Function)
7354 or else (Ekind (E) = E_Subprogram_Type
7355 and then Etype (E) /= Standard_Void_Type)
7357 -- Note: If the function has a foreign convention, it cannot build
7358 -- its result in place, so you're on your own. On the other hand,
7359 -- if only the return type has a foreign convention, its layout is
7360 -- intended to be compatible with the other language, but the build-
7361 -- in place machinery can ensure that the object is not copied.
7363 return Is_Build_In_Place_Result_Type (Etype (E))
7364 and then not Has_Foreign_Convention (E)
7365 and then not Debug_Flag_Dot_L;
7370 end Is_Build_In_Place_Function;
7372 -------------------------------------
7373 -- Is_Build_In_Place_Function_Call --
7374 -------------------------------------
7376 function Is_Build_In_Place_Function_Call (N : Node_Id) return Boolean is
7377 Exp_Node : constant Node_Id := Unqual_Conv (N);
7378 Function_Id : Entity_Id;
7381 -- Return False if the expander is currently inactive, since awareness
7382 -- of build-in-place treatment is only relevant during expansion. Note
7383 -- that Is_Build_In_Place_Function, which is called as part of this
7384 -- function, is also conditioned this way, but we need to check here as
7385 -- well to avoid blowing up on processing protected calls when expansion
7386 -- is disabled (such as with -gnatc) since those would trip over the
7387 -- raise of Program_Error below.
7389 -- In SPARK mode, build-in-place calls are not expanded, so that we
7390 -- may end up with a call that is neither resolved to an entity, nor
7391 -- an indirect call.
7393 if not Expander_Active or else Nkind (Exp_Node) /= N_Function_Call then
7397 if Is_Entity_Name (Name (Exp_Node)) then
7398 Function_Id := Entity (Name (Exp_Node));
7400 -- In the case of an explicitly dereferenced call, use the subprogram
7401 -- type generated for the dereference.
7403 elsif Nkind (Name (Exp_Node)) = N_Explicit_Dereference then
7404 Function_Id := Etype (Name (Exp_Node));
7406 -- This may be a call to a protected function.
7408 elsif Nkind (Name (Exp_Node)) = N_Selected_Component then
7409 Function_Id := Etype (Entity (Selector_Name (Name (Exp_Node))));
7412 raise Program_Error;
7416 Result : constant Boolean := Is_Build_In_Place_Function (Function_Id);
7417 -- So we can stop here in the debugger
7421 end Is_Build_In_Place_Function_Call;
7423 -----------------------
7424 -- Freeze_Subprogram --
7425 -----------------------
7427 procedure Freeze_Subprogram (N : Node_Id) is
7428 Loc : constant Source_Ptr := Sloc (N);
7430 procedure Register_Predefined_DT_Entry (Prim : Entity_Id);
7431 -- (Ada 2005): Register a predefined primitive in all the secondary
7432 -- dispatch tables of its primitive type.
7434 ----------------------------------
7435 -- Register_Predefined_DT_Entry --
7436 ----------------------------------
7438 procedure Register_Predefined_DT_Entry (Prim : Entity_Id) is
7439 Iface_DT_Ptr : Elmt_Id;
7440 Tagged_Typ : Entity_Id;
7441 Thunk_Id : Entity_Id;
7442 Thunk_Code : Node_Id;
7445 Tagged_Typ := Find_Dispatching_Type (Prim);
7447 if No (Access_Disp_Table (Tagged_Typ))
7448 or else not Has_Interfaces (Tagged_Typ)
7449 or else not RTE_Available (RE_Interface_Tag)
7450 or else Restriction_Active (No_Dispatching_Calls)
7455 -- Skip the first two access-to-dispatch-table pointers since they
7456 -- leads to the primary dispatch table (predefined DT and user
7457 -- defined DT). We are only concerned with the secondary dispatch
7458 -- table pointers. Note that the access-to- dispatch-table pointer
7459 -- corresponds to the first implemented interface retrieved below.
7462 Next_Elmt (Next_Elmt (First_Elmt (Access_Disp_Table (Tagged_Typ))));
7464 while Present (Iface_DT_Ptr)
7465 and then Ekind (Node (Iface_DT_Ptr)) = E_Constant
7467 pragma Assert (Has_Thunks (Node (Iface_DT_Ptr)));
7468 Expand_Interface_Thunk (Prim, Thunk_Id, Thunk_Code);
7470 if Present (Thunk_Code) then
7471 Insert_Actions_After (N, New_List (
7474 Build_Set_Predefined_Prim_Op_Address (Loc,
7476 New_Occurrence_Of (Node (Next_Elmt (Iface_DT_Ptr)), Loc),
7477 Position => DT_Position (Prim),
7479 Unchecked_Convert_To (RTE (RE_Prim_Ptr),
7480 Make_Attribute_Reference (Loc,
7481 Prefix => New_Occurrence_Of (Thunk_Id, Loc),
7482 Attribute_Name => Name_Unrestricted_Access))),
7484 Build_Set_Predefined_Prim_Op_Address (Loc,
7487 (Node (Next_Elmt (Next_Elmt (Next_Elmt (Iface_DT_Ptr)))),
7489 Position => DT_Position (Prim),
7491 Unchecked_Convert_To (RTE (RE_Prim_Ptr),
7492 Make_Attribute_Reference (Loc,
7493 Prefix => New_Occurrence_Of (Prim, Loc),
7494 Attribute_Name => Name_Unrestricted_Access)))));
7497 -- Skip the tag of the predefined primitives dispatch table
7499 Next_Elmt (Iface_DT_Ptr);
7500 pragma Assert (Has_Thunks (Node (Iface_DT_Ptr)));
7502 -- Skip tag of the no-thunks dispatch table
7504 Next_Elmt (Iface_DT_Ptr);
7505 pragma Assert (not Has_Thunks (Node (Iface_DT_Ptr)));
7507 -- Skip tag of predefined primitives no-thunks dispatch table
7509 Next_Elmt (Iface_DT_Ptr);
7510 pragma Assert (not Has_Thunks (Node (Iface_DT_Ptr)));
7512 Next_Elmt (Iface_DT_Ptr);
7514 end Register_Predefined_DT_Entry;
7518 Subp : constant Entity_Id := Entity (N);
7520 -- Start of processing for Freeze_Subprogram
7523 -- We suppress the initialization of the dispatch table entry when
7524 -- not Tagged_Type_Expansion because the dispatching mechanism is
7525 -- handled internally by the target.
7527 if Is_Dispatching_Operation (Subp)
7528 and then not Is_Abstract_Subprogram (Subp)
7529 and then Present (DTC_Entity (Subp))
7530 and then Present (Scope (DTC_Entity (Subp)))
7531 and then Tagged_Type_Expansion
7532 and then not Restriction_Active (No_Dispatching_Calls)
7533 and then RTE_Available (RE_Tag)
7536 Typ : constant Entity_Id := Scope (DTC_Entity (Subp));
7539 -- Handle private overridden primitives
7541 if not Is_CPP_Class (Typ) then
7542 Check_Overriding_Operation (Subp);
7545 -- We assume that imported CPP primitives correspond with objects
7546 -- whose constructor is in the CPP side; therefore we don't need
7547 -- to generate code to register them in the dispatch table.
7549 if Is_CPP_Class (Typ) then
7552 -- Handle CPP primitives found in derivations of CPP_Class types.
7553 -- These primitives must have been inherited from some parent, and
7554 -- there is no need to register them in the dispatch table because
7555 -- Build_Inherit_Prims takes care of initializing these slots.
7557 elsif Is_Imported (Subp)
7558 and then (Convention (Subp) = Convention_CPP
7559 or else Convention (Subp) = Convention_C)
7563 -- Generate code to register the primitive in non statically
7564 -- allocated dispatch tables
7566 elsif not Building_Static_DT (Scope (DTC_Entity (Subp))) then
7568 -- When a primitive is frozen, enter its name in its dispatch
7571 if not Is_Interface (Typ)
7572 or else Present (Interface_Alias (Subp))
7574 if Is_Predefined_Dispatching_Operation (Subp) then
7575 Register_Predefined_DT_Entry (Subp);
7578 Insert_Actions_After (N,
7579 Register_Primitive (Loc, Prim => Subp));
7585 -- Mark functions that return by reference. Note that it cannot be part
7586 -- of the normal semantic analysis of the spec since the underlying
7587 -- returned type may not be known yet (for private types).
7590 Typ : constant Entity_Id := Etype (Subp);
7591 Utyp : constant Entity_Id := Underlying_Type (Typ);
7594 if Is_Limited_View (Typ) then
7595 Set_Returns_By_Ref (Subp);
7597 elsif Present (Utyp) and then CW_Or_Has_Controlled_Part (Utyp) then
7598 Set_Returns_By_Ref (Subp);
7602 -- Wnen freezing a null procedure, analyze its delayed aspects now
7603 -- because we may not have reached the end of the declarative list when
7604 -- delayed aspects are normally analyzed. This ensures that dispatching
7605 -- calls are properly rewritten when the generated _Postcondition
7606 -- procedure is analyzed in the null procedure body.
7608 if Nkind (Parent (Subp)) = N_Procedure_Specification
7609 and then Null_Present (Parent (Subp))
7611 Analyze_Entry_Or_Subprogram_Contract (Subp);
7613 end Freeze_Subprogram;
7615 ------------------------------
7616 -- Insert_Post_Call_Actions --
7617 ------------------------------
7619 procedure Insert_Post_Call_Actions (N : Node_Id; Post_Call : List_Id) is
7620 Context : constant Node_Id := Parent (N);
7623 if Is_Empty_List (Post_Call) then
7627 -- Cases where the call is not a member of a statement list. This
7628 -- includes the case where the call is an actual in another function
7629 -- call or indexing, i.e. an expression context as well.
7631 if not Is_List_Member (N)
7632 or else Nkind_In (Context, N_Function_Call, N_Indexed_Component)
7634 -- In Ada 2012 the call may be a function call in an expression
7635 -- (since OUT and IN OUT parameters are now allowed for such calls).
7636 -- The write-back of (in)-out parameters is handled by the back-end,
7637 -- but the constraint checks generated when subtypes of formal and
7638 -- actual don't match must be inserted in the form of assignments.
7640 if Nkind (Original_Node (N)) = N_Function_Call then
7641 pragma Assert (Ada_Version >= Ada_2012);
7642 -- Functions with '[in] out' parameters are only allowed in Ada
7645 -- We used to handle this by climbing up parents to a
7646 -- non-statement/declaration and then simply making a call to
7647 -- Insert_Actions_After (P, Post_Call), but that doesn't work
7648 -- for Ada 2012. If we are in the middle of an expression, e.g.
7649 -- the condition of an IF, this call would insert after the IF
7650 -- statement, which is much too late to be doing the write back.
7653 -- if Clobber (X) then
7654 -- Put_Line (X'Img);
7659 -- Now assume Clobber changes X, if we put the write back after
7660 -- the IF, the Put_Line gets the wrong value and the goto causes
7661 -- the write back to be skipped completely.
7663 -- To deal with this, we replace the call by
7666 -- Tnnn : constant function-result-type := function-call;
7667 -- Post_Call actions
7673 Loc : constant Source_Ptr := Sloc (N);
7674 Tnnn : constant Entity_Id := Make_Temporary (Loc, 'T');
7675 FRTyp : constant Entity_Id := Etype (N);
7676 Name : constant Node_Id := Relocate_Node (N);
7679 Prepend_To (Post_Call,
7680 Make_Object_Declaration (Loc,
7681 Defining_Identifier => Tnnn,
7682 Object_Definition => New_Occurrence_Of (FRTyp, Loc),
7683 Constant_Present => True,
7684 Expression => Name));
7687 Make_Expression_With_Actions (Loc,
7688 Actions => Post_Call,
7689 Expression => New_Occurrence_Of (Tnnn, Loc)));
7691 -- We don't want to just blindly call Analyze_And_Resolve
7692 -- because that would cause unwanted recursion on the call.
7693 -- So for a moment set the call as analyzed to prevent that
7694 -- recursion, and get the rest analyzed properly, then reset
7695 -- the analyzed flag, so our caller can continue.
7697 Set_Analyzed (Name, True);
7698 Analyze_And_Resolve (N, FRTyp);
7699 Set_Analyzed (Name, False);
7702 -- If not the special Ada 2012 case of a function call, then we must
7703 -- have the triggering statement of a triggering alternative or an
7704 -- entry call alternative, and we can add the post call stuff to the
7705 -- corresponding statement list.
7708 pragma Assert (Nkind_In (Context, N_Entry_Call_Alternative,
7709 N_Triggering_Alternative));
7711 if Is_Non_Empty_List (Statements (Context)) then
7712 Insert_List_Before_And_Analyze
7713 (First (Statements (Context)), Post_Call);
7715 Set_Statements (Context, Post_Call);
7719 -- A procedure call is always part of a declarative or statement list,
7720 -- however a function call may appear nested within a construct. Most
7721 -- cases of function call nesting are handled in the special case above.
7722 -- The only exception is when the function call acts as an actual in a
7723 -- procedure call. In this case the function call is in a list, but the
7724 -- post-call actions must be inserted after the procedure call.
7726 elsif Nkind (Context) = N_Procedure_Call_Statement then
7727 Insert_Actions_After (Context, Post_Call);
7729 -- Otherwise, normal case where N is in a statement sequence, just put
7730 -- the post-call stuff after the call statement.
7733 Insert_Actions_After (N, Post_Call);
7735 end Insert_Post_Call_Actions;
7737 -----------------------
7738 -- Is_Null_Procedure --
7739 -----------------------
7741 function Is_Null_Procedure (Subp : Entity_Id) return Boolean is
7742 Decl : constant Node_Id := Unit_Declaration_Node (Subp);
7745 if Ekind (Subp) /= E_Procedure then
7748 -- Check if this is a declared null procedure
7750 elsif Nkind (Decl) = N_Subprogram_Declaration then
7751 if not Null_Present (Specification (Decl)) then
7754 elsif No (Body_To_Inline (Decl)) then
7757 -- Check if the body contains only a null statement, followed by
7758 -- the return statement added during expansion.
7762 Orig_Bod : constant Node_Id := Body_To_Inline (Decl);
7768 if Nkind (Orig_Bod) /= N_Subprogram_Body then
7771 -- We must skip SCIL nodes because they are currently
7772 -- implemented as special N_Null_Statement nodes.
7776 (Statements (Handled_Statement_Sequence (Orig_Bod)));
7777 Stat2 := Next_Non_SCIL_Node (Stat);
7780 Is_Empty_List (Declarations (Orig_Bod))
7781 and then Nkind (Stat) = N_Null_Statement
7785 (Nkind (Stat2) = N_Simple_Return_Statement
7786 and then No (Next (Stat2))));
7794 end Is_Null_Procedure;
7796 -------------------------------------------
7797 -- Make_Build_In_Place_Call_In_Allocator --
7798 -------------------------------------------
7800 procedure Make_Build_In_Place_Call_In_Allocator
7801 (Allocator : Node_Id;
7802 Function_Call : Node_Id)
7804 Acc_Type : constant Entity_Id := Etype (Allocator);
7805 Loc : constant Source_Ptr := Sloc (Function_Call);
7806 Func_Call : Node_Id := Function_Call;
7807 Ref_Func_Call : Node_Id;
7808 Function_Id : Entity_Id;
7809 Result_Subt : Entity_Id;
7810 New_Allocator : Node_Id;
7811 Return_Obj_Access : Entity_Id; -- temp for function result
7812 Temp_Init : Node_Id; -- initial value of Return_Obj_Access
7813 Alloc_Form : BIP_Allocation_Form;
7814 Pool : Node_Id; -- nonnull if Alloc_Form = User_Storage_Pool
7815 Return_Obj_Actual : Node_Id; -- the temp.all, in caller-allocates case
7816 Chain : Entity_Id; -- activation chain, in case of tasks
7819 -- Step past qualification or unchecked conversion (the latter can occur
7820 -- in cases of calls to 'Input).
7822 if Nkind_In (Func_Call,
7823 N_Qualified_Expression,
7825 N_Unchecked_Type_Conversion)
7827 Func_Call := Expression (Func_Call);
7830 -- Mark the call as processed as a build-in-place call
7832 pragma Assert (not Is_Expanded_Build_In_Place_Call (Func_Call));
7833 Set_Is_Expanded_Build_In_Place_Call (Func_Call);
7835 if Is_Entity_Name (Name (Func_Call)) then
7836 Function_Id := Entity (Name (Func_Call));
7838 elsif Nkind (Name (Func_Call)) = N_Explicit_Dereference then
7839 Function_Id := Etype (Name (Func_Call));
7842 raise Program_Error;
7845 Result_Subt := Available_View (Etype (Function_Id));
7847 -- Create a temp for the function result. In the caller-allocates case,
7848 -- this will be initialized to the result of a new uninitialized
7849 -- allocator. Note: we do not use Allocator as the Related_Node of
7850 -- Return_Obj_Access in call to Make_Temporary below as this would
7851 -- create a sort of infinite "recursion".
7853 Return_Obj_Access := Make_Temporary (Loc, 'R');
7854 Set_Etype (Return_Obj_Access, Acc_Type);
7855 Set_Can_Never_Be_Null (Acc_Type, False);
7856 -- It gets initialized to null, so we can't have that
7858 -- When the result subtype is constrained, the return object is
7859 -- allocated on the caller side, and access to it is passed to the
7862 -- Here and in related routines, we must examine the full view of the
7863 -- type, because the view at the point of call may differ from that
7864 -- that in the function body, and the expansion mechanism depends on
7865 -- the characteristics of the full view.
7867 if Is_Constrained (Underlying_Type (Result_Subt)) then
7868 -- Replace the initialized allocator of form "new T'(Func (...))"
7869 -- with an uninitialized allocator of form "new T", where T is the
7870 -- result subtype of the called function. The call to the function
7871 -- is handled separately further below.
7874 Make_Allocator (Loc,
7875 Expression => New_Occurrence_Of (Result_Subt, Loc));
7876 Set_No_Initialization (New_Allocator);
7878 -- Copy attributes to new allocator. Note that the new allocator
7879 -- logically comes from source if the original one did, so copy the
7880 -- relevant flag. This ensures proper treatment of the restriction
7881 -- No_Implicit_Heap_Allocations in this case.
7883 Set_Storage_Pool (New_Allocator, Storage_Pool (Allocator));
7884 Set_Procedure_To_Call (New_Allocator, Procedure_To_Call (Allocator));
7885 Set_Comes_From_Source (New_Allocator, Comes_From_Source (Allocator));
7887 Rewrite (Allocator, New_Allocator);
7889 -- Initial value of the temp is the result of the uninitialized
7890 -- allocator. Unchecked_Convert is needed for T'Input where T is
7891 -- derived from a controlled type.
7893 Temp_Init := Relocate_Node (Allocator);
7896 (Function_Call, N_Type_Conversion, N_Unchecked_Type_Conversion)
7898 Temp_Init := Unchecked_Convert_To (Acc_Type, Temp_Init);
7901 -- Indicate that caller allocates, and pass in the return object
7903 Alloc_Form := Caller_Allocation;
7904 Pool := Make_Null (No_Location);
7905 Return_Obj_Actual :=
7906 Make_Unchecked_Type_Conversion (Loc,
7907 Subtype_Mark => New_Occurrence_Of (Result_Subt, Loc),
7909 Make_Explicit_Dereference (Loc,
7910 Prefix => New_Occurrence_Of (Return_Obj_Access, Loc)));
7912 -- When the result subtype is unconstrained, the function itself must
7913 -- perform the allocation of the return object, so we pass parameters
7919 -- Case of a user-defined storage pool. Pass an allocation parameter
7920 -- indicating that the function should allocate its result in the
7921 -- pool, and pass the pool. Use 'Unrestricted_Access because the
7922 -- pool may not be aliased.
7924 if Present (Associated_Storage_Pool (Acc_Type)) then
7925 Alloc_Form := User_Storage_Pool;
7927 Make_Attribute_Reference (Loc,
7930 (Associated_Storage_Pool (Acc_Type), Loc),
7931 Attribute_Name => Name_Unrestricted_Access);
7933 -- No user-defined pool; pass an allocation parameter indicating that
7934 -- the function should allocate its result on the heap.
7937 Alloc_Form := Global_Heap;
7938 Pool := Make_Null (No_Location);
7941 -- The caller does not provide the return object in this case, so we
7942 -- have to pass null for the object access actual.
7944 Return_Obj_Actual := Empty;
7947 -- Declare the temp object
7949 Insert_Action (Allocator,
7950 Make_Object_Declaration (Loc,
7951 Defining_Identifier => Return_Obj_Access,
7952 Object_Definition => New_Occurrence_Of (Acc_Type, Loc),
7953 Expression => Temp_Init));
7955 Ref_Func_Call := Make_Reference (Loc, Func_Call);
7957 -- Ada 2005 (AI-251): If the type of the allocator is an interface
7958 -- then generate an implicit conversion to force displacement of the
7961 if Is_Interface (Designated_Type (Acc_Type)) then
7964 OK_Convert_To (Acc_Type, Ref_Func_Call));
7966 -- If the types are incompatible, we need an unchecked conversion. Note
7967 -- that the full types will be compatible, but the types not visibly
7971 (Function_Call, N_Type_Conversion, N_Unchecked_Type_Conversion)
7973 Ref_Func_Call := Unchecked_Convert_To (Acc_Type, Ref_Func_Call);
7977 Assign : constant Node_Id :=
7978 Make_Assignment_Statement (Loc,
7979 Name => New_Occurrence_Of (Return_Obj_Access, Loc),
7980 Expression => Ref_Func_Call);
7981 -- Assign the result of the function call into the temp. In the
7982 -- caller-allocates case, this is overwriting the temp with its
7983 -- initial value, which has no effect. In the callee-allocates case,
7984 -- this is setting the temp to point to the object allocated by the
7985 -- callee. Unchecked_Convert is needed for T'Input where T is derived
7986 -- from a controlled type.
7989 -- Actions to be inserted. If there are no tasks, this is just the
7990 -- assignment statement. If the allocated object has tasks, we need
7991 -- to wrap the assignment in a block that activates them. The
7992 -- activation chain of that block must be passed to the function,
7993 -- rather than some outer chain.
7995 if Has_Task (Result_Subt) then
7996 Actions := New_List;
7997 Build_Task_Allocate_Block_With_Init_Stmts
7998 (Actions, Allocator, Init_Stmts => New_List (Assign));
7999 Chain := Activation_Chain_Entity (Last (Actions));
8001 Actions := New_List (Assign);
8005 Insert_Actions (Allocator, Actions);
8008 -- When the function has a controlling result, an allocation-form
8009 -- parameter must be passed indicating that the caller is allocating
8010 -- the result object. This is needed because such a function can be
8011 -- called as a dispatching operation and must be treated similarly
8012 -- to functions with unconstrained result subtypes.
8014 Add_Unconstrained_Actuals_To_Build_In_Place_Call
8015 (Func_Call, Function_Id, Alloc_Form, Pool_Actual => Pool);
8017 Add_Finalization_Master_Actual_To_Build_In_Place_Call
8018 (Func_Call, Function_Id, Acc_Type);
8020 Add_Task_Actuals_To_Build_In_Place_Call
8021 (Func_Call, Function_Id, Master_Actual => Master_Id (Acc_Type),
8024 -- Add an implicit actual to the function call that provides access
8025 -- to the allocated object. An unchecked conversion to the (specific)
8026 -- result subtype of the function is inserted to handle cases where
8027 -- the access type of the allocator has a class-wide designated type.
8029 Add_Access_Actual_To_Build_In_Place_Call
8030 (Func_Call, Function_Id, Return_Obj_Actual);
8032 -- Finally, replace the allocator node with a reference to the temp
8034 Rewrite (Allocator, New_Occurrence_Of (Return_Obj_Access, Loc));
8036 Analyze_And_Resolve (Allocator, Acc_Type);
8037 end Make_Build_In_Place_Call_In_Allocator;
8039 ---------------------------------------------------
8040 -- Make_Build_In_Place_Call_In_Anonymous_Context --
8041 ---------------------------------------------------
8043 procedure Make_Build_In_Place_Call_In_Anonymous_Context
8044 (Function_Call : Node_Id)
8046 Loc : constant Source_Ptr := Sloc (Function_Call);
8047 Func_Call : constant Node_Id := Unqual_Conv (Function_Call);
8048 Function_Id : Entity_Id;
8049 Result_Subt : Entity_Id;
8050 Return_Obj_Id : Entity_Id;
8051 Return_Obj_Decl : Entity_Id;
8054 -- If the call has already been processed to add build-in-place actuals
8055 -- then return. One place this can occur is for calls to build-in-place
8056 -- functions that occur within a call to a protected operation, where
8057 -- due to rewriting and expansion of the protected call there can be
8058 -- more than one call to Expand_Actuals for the same set of actuals.
8060 if Is_Expanded_Build_In_Place_Call (Func_Call) then
8064 -- Mark the call as processed as a build-in-place call
8066 Set_Is_Expanded_Build_In_Place_Call (Func_Call);
8068 if Is_Entity_Name (Name (Func_Call)) then
8069 Function_Id := Entity (Name (Func_Call));
8071 elsif Nkind (Name (Func_Call)) = N_Explicit_Dereference then
8072 Function_Id := Etype (Name (Func_Call));
8075 raise Program_Error;
8078 Result_Subt := Etype (Function_Id);
8080 -- If the build-in-place function returns a controlled object, then the
8081 -- object needs to be finalized immediately after the context. Since
8082 -- this case produces a transient scope, the servicing finalizer needs
8083 -- to name the returned object. Create a temporary which is initialized
8084 -- with the function call:
8086 -- Temp_Id : Func_Type := BIP_Func_Call;
8088 -- The initialization expression of the temporary will be rewritten by
8089 -- the expander using the appropriate mechanism in Make_Build_In_Place_
8090 -- Call_In_Object_Declaration.
8092 if Needs_Finalization (Result_Subt) then
8094 Temp_Id : constant Entity_Id := Make_Temporary (Loc, 'R');
8095 Temp_Decl : Node_Id;
8098 -- Reset the guard on the function call since the following does
8099 -- not perform actual call expansion.
8101 Set_Is_Expanded_Build_In_Place_Call (Func_Call, False);
8104 Make_Object_Declaration (Loc,
8105 Defining_Identifier => Temp_Id,
8106 Object_Definition =>
8107 New_Occurrence_Of (Result_Subt, Loc),
8109 New_Copy_Tree (Function_Call));
8111 Insert_Action (Function_Call, Temp_Decl);
8113 Rewrite (Function_Call, New_Occurrence_Of (Temp_Id, Loc));
8114 Analyze (Function_Call);
8117 -- When the result subtype is definite, an object of the subtype is
8118 -- declared and an access value designating it is passed as an actual.
8120 elsif Caller_Known_Size (Func_Call, Result_Subt) then
8122 -- Create a temporary object to hold the function result
8124 Return_Obj_Id := Make_Temporary (Loc, 'R');
8125 Set_Etype (Return_Obj_Id, Result_Subt);
8128 Make_Object_Declaration (Loc,
8129 Defining_Identifier => Return_Obj_Id,
8130 Aliased_Present => True,
8131 Object_Definition => New_Occurrence_Of (Result_Subt, Loc));
8133 Set_No_Initialization (Return_Obj_Decl);
8135 Insert_Action (Func_Call, Return_Obj_Decl);
8137 -- When the function has a controlling result, an allocation-form
8138 -- parameter must be passed indicating that the caller is allocating
8139 -- the result object. This is needed because such a function can be
8140 -- called as a dispatching operation and must be treated similarly
8141 -- to functions with unconstrained result subtypes.
8143 Add_Unconstrained_Actuals_To_Build_In_Place_Call
8144 (Func_Call, Function_Id, Alloc_Form => Caller_Allocation);
8146 Add_Finalization_Master_Actual_To_Build_In_Place_Call
8147 (Func_Call, Function_Id);
8149 Add_Task_Actuals_To_Build_In_Place_Call
8150 (Func_Call, Function_Id, Make_Identifier (Loc, Name_uMaster));
8152 -- Add an implicit actual to the function call that provides access
8153 -- to the caller's return object.
8155 Add_Access_Actual_To_Build_In_Place_Call
8156 (Func_Call, Function_Id, New_Occurrence_Of (Return_Obj_Id, Loc));
8158 -- When the result subtype is unconstrained, the function must allocate
8159 -- the return object in the secondary stack, so appropriate implicit
8160 -- parameters are added to the call to indicate that. A transient
8161 -- scope is established to ensure eventual cleanup of the result.
8164 -- Pass an allocation parameter indicating that the function should
8165 -- allocate its result on the secondary stack.
8167 Add_Unconstrained_Actuals_To_Build_In_Place_Call
8168 (Func_Call, Function_Id, Alloc_Form => Secondary_Stack);
8170 Add_Finalization_Master_Actual_To_Build_In_Place_Call
8171 (Func_Call, Function_Id);
8173 Add_Task_Actuals_To_Build_In_Place_Call
8174 (Func_Call, Function_Id, Make_Identifier (Loc, Name_uMaster));
8176 -- Pass a null value to the function since no return object is
8177 -- available on the caller side.
8179 Add_Access_Actual_To_Build_In_Place_Call
8180 (Func_Call, Function_Id, Empty);
8182 end Make_Build_In_Place_Call_In_Anonymous_Context;
8184 --------------------------------------------
8185 -- Make_Build_In_Place_Call_In_Assignment --
8186 --------------------------------------------
8188 procedure Make_Build_In_Place_Call_In_Assignment
8190 Function_Call : Node_Id)
8192 Func_Call : constant Node_Id := Unqual_Conv (Function_Call);
8193 Lhs : constant Node_Id := Name (Assign);
8194 Loc : constant Source_Ptr := Sloc (Function_Call);
8195 Func_Id : Entity_Id;
8198 Ptr_Typ : Entity_Id;
8199 Ptr_Typ_Decl : Node_Id;
8201 Result_Subt : Entity_Id;
8204 -- Mark the call as processed as a build-in-place call
8206 pragma Assert (not Is_Expanded_Build_In_Place_Call (Func_Call));
8207 Set_Is_Expanded_Build_In_Place_Call (Func_Call);
8209 if Is_Entity_Name (Name (Func_Call)) then
8210 Func_Id := Entity (Name (Func_Call));
8212 elsif Nkind (Name (Func_Call)) = N_Explicit_Dereference then
8213 Func_Id := Etype (Name (Func_Call));
8216 raise Program_Error;
8219 Result_Subt := Etype (Func_Id);
8221 -- When the result subtype is unconstrained, an additional actual must
8222 -- be passed to indicate that the caller is providing the return object.
8223 -- This parameter must also be passed when the called function has a
8224 -- controlling result, because dispatching calls to the function needs
8225 -- to be treated effectively the same as calls to class-wide functions.
8227 Add_Unconstrained_Actuals_To_Build_In_Place_Call
8228 (Func_Call, Func_Id, Alloc_Form => Caller_Allocation);
8230 Add_Finalization_Master_Actual_To_Build_In_Place_Call
8231 (Func_Call, Func_Id);
8233 Add_Task_Actuals_To_Build_In_Place_Call
8234 (Func_Call, Func_Id, Make_Identifier (Loc, Name_uMaster));
8236 -- Add an implicit actual to the function call that provides access to
8237 -- the caller's return object.
8239 Add_Access_Actual_To_Build_In_Place_Call
8242 Make_Unchecked_Type_Conversion (Loc,
8243 Subtype_Mark => New_Occurrence_Of (Result_Subt, Loc),
8244 Expression => Relocate_Node (Lhs)));
8246 -- Create an access type designating the function's result subtype
8248 Ptr_Typ := Make_Temporary (Loc, 'A');
8251 Make_Full_Type_Declaration (Loc,
8252 Defining_Identifier => Ptr_Typ,
8254 Make_Access_To_Object_Definition (Loc,
8255 All_Present => True,
8256 Subtype_Indication =>
8257 New_Occurrence_Of (Result_Subt, Loc)));
8258 Insert_After_And_Analyze (Assign, Ptr_Typ_Decl);
8260 -- Finally, create an access object initialized to a reference to the
8261 -- function call. We know this access value is non-null, so mark the
8262 -- entity accordingly to suppress junk access checks.
8264 New_Expr := Make_Reference (Loc, Relocate_Node (Func_Call));
8266 -- Add a conversion if it's the wrong type
8268 if Etype (New_Expr) /= Ptr_Typ then
8270 Make_Unchecked_Type_Conversion (Loc,
8271 New_Occurrence_Of (Ptr_Typ, Loc), New_Expr);
8274 Obj_Id := Make_Temporary (Loc, 'R', New_Expr);
8275 Set_Etype (Obj_Id, Ptr_Typ);
8276 Set_Is_Known_Non_Null (Obj_Id);
8279 Make_Object_Declaration (Loc,
8280 Defining_Identifier => Obj_Id,
8281 Object_Definition => New_Occurrence_Of (Ptr_Typ, Loc),
8282 Expression => New_Expr);
8283 Insert_After_And_Analyze (Ptr_Typ_Decl, Obj_Decl);
8285 Rewrite (Assign, Make_Null_Statement (Loc));
8286 end Make_Build_In_Place_Call_In_Assignment;
8288 ----------------------------------------------------
8289 -- Make_Build_In_Place_Call_In_Object_Declaration --
8290 ----------------------------------------------------
8292 procedure Make_Build_In_Place_Call_In_Object_Declaration
8293 (Obj_Decl : Node_Id;
8294 Function_Call : Node_Id)
8296 function Get_Function_Id (Func_Call : Node_Id) return Entity_Id;
8297 -- Get the value of Function_Id, below
8299 ---------------------
8300 -- Get_Function_Id --
8301 ---------------------
8303 function Get_Function_Id (Func_Call : Node_Id) return Entity_Id is
8305 if Is_Entity_Name (Name (Func_Call)) then
8306 return Entity (Name (Func_Call));
8308 elsif Nkind (Name (Func_Call)) = N_Explicit_Dereference then
8309 return Etype (Name (Func_Call));
8312 raise Program_Error;
8314 end Get_Function_Id;
8318 Func_Call : constant Node_Id := Unqual_Conv (Function_Call);
8319 Function_Id : constant Entity_Id := Get_Function_Id (Func_Call);
8320 Loc : constant Source_Ptr := Sloc (Function_Call);
8321 Obj_Loc : constant Source_Ptr := Sloc (Obj_Decl);
8322 Obj_Def_Id : constant Entity_Id := Defining_Identifier (Obj_Decl);
8323 Obj_Typ : constant Entity_Id := Etype (Obj_Def_Id);
8324 Encl_Func : constant Entity_Id := Enclosing_Subprogram (Obj_Def_Id);
8325 Result_Subt : constant Entity_Id := Etype (Function_Id);
8327 Call_Deref : Node_Id;
8328 Caller_Object : Node_Id;
8330 Designated_Type : Entity_Id;
8331 Fmaster_Actual : Node_Id := Empty;
8332 Pool_Actual : Node_Id;
8333 Ptr_Typ : Entity_Id;
8334 Ptr_Typ_Decl : Node_Id;
8335 Pass_Caller_Acc : Boolean := False;
8338 Definite : constant Boolean :=
8339 Caller_Known_Size (Func_Call, Result_Subt)
8340 and then not Is_Class_Wide_Type (Obj_Typ);
8341 -- In the case of "X : T'Class := F(...);", where F returns a
8342 -- Caller_Known_Size (specific) tagged type, we treat it as
8343 -- indefinite, because the code for the Definite case below sets the
8344 -- initialization expression of the object to Empty, which would be
8345 -- illegal Ada, and would cause gigi to misallocate X.
8347 -- Start of processing for Make_Build_In_Place_Call_In_Object_Declaration
8350 -- If the call has already been processed to add build-in-place actuals
8353 if Is_Expanded_Build_In_Place_Call (Func_Call) then
8357 -- Mark the call as processed as a build-in-place call
8359 Set_Is_Expanded_Build_In_Place_Call (Func_Call);
8361 -- Create an access type designating the function's result subtype.
8362 -- We use the type of the original call because it may be a call to an
8363 -- inherited operation, which the expansion has replaced with the parent
8364 -- operation that yields the parent type. Note that this access type
8365 -- must be declared before we establish a transient scope, so that it
8366 -- receives the proper accessibility level.
8368 if Is_Class_Wide_Type (Obj_Typ)
8369 and then not Is_Interface (Obj_Typ)
8370 and then not Is_Class_Wide_Type (Etype (Function_Call))
8372 Designated_Type := Obj_Typ;
8374 Designated_Type := Etype (Function_Call);
8377 Ptr_Typ := Make_Temporary (Loc, 'A');
8379 Make_Full_Type_Declaration (Loc,
8380 Defining_Identifier => Ptr_Typ,
8382 Make_Access_To_Object_Definition (Loc,
8383 All_Present => True,
8384 Subtype_Indication =>
8385 New_Occurrence_Of (Designated_Type, Loc)));
8387 -- The access type and its accompanying object must be inserted after
8388 -- the object declaration in the constrained case, so that the function
8389 -- call can be passed access to the object. In the indefinite case, or
8390 -- if the object declaration is for a return object, the access type and
8391 -- object must be inserted before the object, since the object
8392 -- declaration is rewritten to be a renaming of a dereference of the
8393 -- access object. Note: we need to freeze Ptr_Typ explicitly, because
8394 -- the result object is in a different (transient) scope, so won't cause
8397 if Definite and then not Is_Return_Object (Obj_Def_Id) then
8398 Insert_After_And_Analyze (Obj_Decl, Ptr_Typ_Decl);
8400 Insert_Action (Obj_Decl, Ptr_Typ_Decl);
8403 -- Force immediate freezing of Ptr_Typ because Res_Decl will be
8404 -- elaborated in an inner (transient) scope and thus won't cause
8405 -- freezing by itself. It's not an itype, but it needs to be frozen
8406 -- inside the current subprogram (see Freeze_Outside in freeze.adb).
8408 Freeze_Itype (Ptr_Typ, Ptr_Typ_Decl);
8410 -- If the object is a return object of an enclosing build-in-place
8411 -- function, then the implicit build-in-place parameters of the
8412 -- enclosing function are simply passed along to the called function.
8413 -- (Unfortunately, this won't cover the case of extension aggregates
8414 -- where the ancestor part is a build-in-place indefinite function
8415 -- call that should be passed along the caller's parameters.
8416 -- Currently those get mishandled by reassigning the result of the
8417 -- call to the aggregate return object, when the call result should
8418 -- really be directly built in place in the aggregate and not in a
8421 if Is_Return_Object (Obj_Def_Id) then
8422 Pass_Caller_Acc := True;
8424 -- When the enclosing function has a BIP_Alloc_Form formal then we
8425 -- pass it along to the callee (such as when the enclosing function
8426 -- has an unconstrained or tagged result type).
8428 if Needs_BIP_Alloc_Form (Encl_Func) then
8429 if RTE_Available (RE_Root_Storage_Pool_Ptr) then
8432 (Build_In_Place_Formal
8433 (Encl_Func, BIP_Storage_Pool), Loc);
8435 -- The build-in-place pool formal is not built on e.g. ZFP
8438 Pool_Actual := Empty;
8441 Add_Unconstrained_Actuals_To_Build_In_Place_Call
8442 (Function_Call => Func_Call,
8443 Function_Id => Function_Id,
8446 (Build_In_Place_Formal (Encl_Func, BIP_Alloc_Form), Loc),
8447 Pool_Actual => Pool_Actual);
8449 -- Otherwise, if enclosing function has a definite result subtype,
8450 -- then caller allocation will be used.
8453 Add_Unconstrained_Actuals_To_Build_In_Place_Call
8454 (Func_Call, Function_Id, Alloc_Form => Caller_Allocation);
8457 if Needs_BIP_Finalization_Master (Encl_Func) then
8460 (Build_In_Place_Formal
8461 (Encl_Func, BIP_Finalization_Master), Loc);
8464 -- Retrieve the BIPacc formal from the enclosing function and convert
8465 -- it to the access type of the callee's BIP_Object_Access formal.
8468 Make_Unchecked_Type_Conversion (Loc,
8471 (Etype (Build_In_Place_Formal
8472 (Function_Id, BIP_Object_Access)),
8476 (Build_In_Place_Formal (Encl_Func, BIP_Object_Access),
8479 -- In the definite case, add an implicit actual to the function call
8480 -- that provides access to the declared object. An unchecked conversion
8481 -- to the (specific) result type of the function is inserted to handle
8482 -- the case where the object is declared with a class-wide type.
8486 Make_Unchecked_Type_Conversion (Loc,
8487 Subtype_Mark => New_Occurrence_Of (Result_Subt, Loc),
8488 Expression => New_Occurrence_Of (Obj_Def_Id, Loc));
8490 -- When the function has a controlling result, an allocation-form
8491 -- parameter must be passed indicating that the caller is allocating
8492 -- the result object. This is needed because such a function can be
8493 -- called as a dispatching operation and must be treated similarly to
8494 -- functions with indefinite result subtypes.
8496 Add_Unconstrained_Actuals_To_Build_In_Place_Call
8497 (Func_Call, Function_Id, Alloc_Form => Caller_Allocation);
8499 -- The allocation for indefinite library-level objects occurs on the
8500 -- heap as opposed to the secondary stack. This accommodates DLLs where
8501 -- the secondary stack is destroyed after each library unload. This is a
8502 -- hybrid mechanism where a stack-allocated object lives on the heap.
8504 elsif Is_Library_Level_Entity (Obj_Def_Id)
8505 and then not Restriction_Active (No_Implicit_Heap_Allocations)
8507 Add_Unconstrained_Actuals_To_Build_In_Place_Call
8508 (Func_Call, Function_Id, Alloc_Form => Global_Heap);
8509 Caller_Object := Empty;
8511 -- Create a finalization master for the access result type to ensure
8512 -- that the heap allocation can properly chain the object and later
8513 -- finalize it when the library unit goes out of scope.
8515 if Needs_Finalization (Etype (Func_Call)) then
8516 Build_Finalization_Master
8518 For_Lib_Level => True,
8519 Insertion_Node => Ptr_Typ_Decl);
8522 Make_Attribute_Reference (Loc,
8524 New_Occurrence_Of (Finalization_Master (Ptr_Typ), Loc),
8525 Attribute_Name => Name_Unrestricted_Access);
8528 -- In other indefinite cases, pass an indication to do the allocation on
8529 -- the secondary stack and set Caller_Object to Empty so that a null
8530 -- value will be passed for the caller's object address. A transient
8531 -- scope is established to ensure eventual cleanup of the result.
8534 Add_Unconstrained_Actuals_To_Build_In_Place_Call
8535 (Func_Call, Function_Id, Alloc_Form => Secondary_Stack);
8536 Caller_Object := Empty;
8538 Establish_Transient_Scope (Obj_Decl, Sec_Stack => True);
8541 -- Pass along any finalization master actual, which is needed in the
8542 -- case where the called function initializes a return object of an
8543 -- enclosing build-in-place function.
8545 Add_Finalization_Master_Actual_To_Build_In_Place_Call
8546 (Func_Call => Func_Call,
8547 Func_Id => Function_Id,
8548 Master_Exp => Fmaster_Actual);
8550 if Nkind (Parent (Obj_Decl)) = N_Extended_Return_Statement
8551 and then Has_Task (Result_Subt)
8553 -- Here we're passing along the master that was passed in to this
8556 Add_Task_Actuals_To_Build_In_Place_Call
8557 (Func_Call, Function_Id,
8560 (Build_In_Place_Formal (Encl_Func, BIP_Task_Master), Loc));
8563 Add_Task_Actuals_To_Build_In_Place_Call
8564 (Func_Call, Function_Id, Make_Identifier (Loc, Name_uMaster));
8567 Add_Access_Actual_To_Build_In_Place_Call
8571 Is_Access => Pass_Caller_Acc);
8573 -- Finally, create an access object initialized to a reference to the
8574 -- function call. We know this access value cannot be null, so mark the
8575 -- entity accordingly to suppress the access check.
8577 Def_Id := Make_Temporary (Loc, 'R', Func_Call);
8578 Set_Etype (Def_Id, Ptr_Typ);
8579 Set_Is_Known_Non_Null (Def_Id);
8581 if Nkind_In (Function_Call, N_Type_Conversion,
8582 N_Unchecked_Type_Conversion)
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_Unchecked_Type_Conversion (Loc,
8591 New_Occurrence_Of (Ptr_Typ, Loc),
8592 Make_Reference (Loc, Relocate_Node (Func_Call))));
8595 Make_Object_Declaration (Loc,
8596 Defining_Identifier => Def_Id,
8597 Constant_Present => True,
8598 Object_Definition => New_Occurrence_Of (Ptr_Typ, Loc),
8600 Make_Reference (Loc, Relocate_Node (Func_Call)));
8603 Insert_After_And_Analyze (Ptr_Typ_Decl, Res_Decl);
8605 -- If the result subtype of the called function is definite and is not
8606 -- itself the return expression of an enclosing BIP function, then mark
8607 -- the object as having no initialization.
8609 if Definite and then not Is_Return_Object (Obj_Def_Id) then
8611 -- The related object declaration is encased in a transient block
8612 -- because the build-in-place function call contains at least one
8613 -- nested function call that produces a controlled transient
8616 -- Obj : ... := BIP_Func_Call (Ctrl_Func_Call);
8618 -- Since the build-in-place expansion decouples the call from the
8619 -- object declaration, the finalization machinery lacks the context
8620 -- which prompted the generation of the transient block. To resolve
8621 -- this scenario, store the build-in-place call.
8623 if Scope_Is_Transient and then Node_To_Be_Wrapped = Obj_Decl then
8624 Set_BIP_Initialization_Call (Obj_Def_Id, Res_Decl);
8627 Set_Expression (Obj_Decl, Empty);
8628 Set_No_Initialization (Obj_Decl);
8630 -- In case of an indefinite result subtype, or if the call is the
8631 -- return expression of an enclosing BIP function, rewrite the object
8632 -- declaration as an object renaming where the renamed object is a
8633 -- dereference of <function_Call>'reference:
8635 -- Obj : Subt renames <function_call>'Ref.all;
8639 Make_Explicit_Dereference (Obj_Loc,
8640 Prefix => New_Occurrence_Of (Def_Id, Obj_Loc));
8643 Make_Object_Renaming_Declaration (Obj_Loc,
8644 Defining_Identifier => Make_Temporary (Obj_Loc, 'D'),
8646 New_Occurrence_Of (Designated_Type, Obj_Loc),
8647 Name => Call_Deref));
8649 -- At this point, Defining_Identifier (Obj_Decl) is no longer equal
8652 Set_Renamed_Object (Defining_Identifier (Obj_Decl), Call_Deref);
8654 -- If the original entity comes from source, then mark the new
8655 -- entity as needing debug information, even though it's defined
8656 -- by a generated renaming that does not come from source, so that
8657 -- the Materialize_Entity flag will be set on the entity when
8658 -- Debug_Renaming_Declaration is called during analysis.
8660 if Comes_From_Source (Obj_Def_Id) then
8661 Set_Debug_Info_Needed (Defining_Identifier (Obj_Decl));
8665 Replace_Renaming_Declaration_Id
8666 (Obj_Decl, Original_Node (Obj_Decl));
8668 end Make_Build_In_Place_Call_In_Object_Declaration;
8670 -------------------------------------------------
8671 -- Make_Build_In_Place_Iface_Call_In_Allocator --
8672 -------------------------------------------------
8674 procedure Make_Build_In_Place_Iface_Call_In_Allocator
8675 (Allocator : Node_Id;
8676 Function_Call : Node_Id)
8678 BIP_Func_Call : constant Node_Id :=
8679 Unqual_BIP_Iface_Function_Call (Function_Call);
8680 Loc : constant Source_Ptr := Sloc (Function_Call);
8682 Anon_Type : Entity_Id;
8687 -- No action of the call has already been processed
8689 if Is_Expanded_Build_In_Place_Call (BIP_Func_Call) then
8693 Tmp_Id := Make_Temporary (Loc, 'D');
8695 -- Insert a temporary before N initialized with the BIP function call
8696 -- without its enclosing type conversions and analyze it without its
8697 -- expansion. This temporary facilitates us reusing the BIP machinery,
8698 -- which takes care of adding the extra build-in-place actuals and
8699 -- transforms this object declaration into an object renaming
8702 Anon_Type := Create_Itype (E_Anonymous_Access_Type, Function_Call);
8703 Set_Directly_Designated_Type (Anon_Type, Etype (BIP_Func_Call));
8704 Set_Etype (Anon_Type, Anon_Type);
8707 Make_Object_Declaration (Loc,
8708 Defining_Identifier => Tmp_Id,
8709 Object_Definition => New_Occurrence_Of (Anon_Type, Loc),
8711 Make_Allocator (Loc,
8713 Make_Qualified_Expression (Loc,
8715 New_Occurrence_Of (Etype (BIP_Func_Call), Loc),
8716 Expression => New_Copy_Tree (BIP_Func_Call))));
8718 Expander_Mode_Save_And_Set (False);
8719 Insert_Action (Allocator, Tmp_Decl);
8720 Expander_Mode_Restore;
8722 Make_Build_In_Place_Call_In_Allocator
8723 (Allocator => Expression (Tmp_Decl),
8724 Function_Call => Expression (Expression (Tmp_Decl)));
8726 Rewrite (Allocator, New_Occurrence_Of (Tmp_Id, Loc));
8727 end Make_Build_In_Place_Iface_Call_In_Allocator;
8729 ---------------------------------------------------------
8730 -- Make_Build_In_Place_Iface_Call_In_Anonymous_Context --
8731 ---------------------------------------------------------
8733 procedure Make_Build_In_Place_Iface_Call_In_Anonymous_Context
8734 (Function_Call : Node_Id)
8736 BIP_Func_Call : constant Node_Id :=
8737 Unqual_BIP_Iface_Function_Call (Function_Call);
8738 Loc : constant Source_Ptr := Sloc (Function_Call);
8744 -- No action of the call has already been processed
8746 if Is_Expanded_Build_In_Place_Call (BIP_Func_Call) then
8750 pragma Assert (Needs_Finalization (Etype (BIP_Func_Call)));
8752 -- Insert a temporary before the call initialized with function call to
8753 -- reuse the BIP machinery which takes care of adding the extra build-in
8754 -- place actuals and transforms this object declaration into an object
8755 -- renaming declaration.
8757 Tmp_Id := Make_Temporary (Loc, 'D');
8760 Make_Object_Declaration (Loc,
8761 Defining_Identifier => Tmp_Id,
8762 Object_Definition =>
8763 New_Occurrence_Of (Etype (Function_Call), Loc),
8764 Expression => Relocate_Node (Function_Call));
8766 Expander_Mode_Save_And_Set (False);
8767 Insert_Action (Function_Call, Tmp_Decl);
8768 Expander_Mode_Restore;
8770 Make_Build_In_Place_Iface_Call_In_Object_Declaration
8771 (Obj_Decl => Tmp_Decl,
8772 Function_Call => Expression (Tmp_Decl));
8773 end Make_Build_In_Place_Iface_Call_In_Anonymous_Context;
8775 ----------------------------------------------------------
8776 -- Make_Build_In_Place_Iface_Call_In_Object_Declaration --
8777 ----------------------------------------------------------
8779 procedure Make_Build_In_Place_Iface_Call_In_Object_Declaration
8780 (Obj_Decl : Node_Id;
8781 Function_Call : Node_Id)
8783 BIP_Func_Call : constant Node_Id :=
8784 Unqual_BIP_Iface_Function_Call (Function_Call);
8785 Loc : constant Source_Ptr := Sloc (Function_Call);
8786 Obj_Id : constant Entity_Id := Defining_Entity (Obj_Decl);
8792 -- No action of the call has already been processed
8794 if Is_Expanded_Build_In_Place_Call (BIP_Func_Call) then
8798 Tmp_Id := Make_Temporary (Loc, 'D');
8800 -- Insert a temporary before N initialized with the BIP function call
8801 -- without its enclosing type conversions and analyze it without its
8802 -- expansion. This temporary facilitates us reusing the BIP machinery,
8803 -- which takes care of adding the extra build-in-place actuals and
8804 -- transforms this object declaration into an object renaming
8808 Make_Object_Declaration (Loc,
8809 Defining_Identifier => Tmp_Id,
8810 Object_Definition =>
8811 New_Occurrence_Of (Etype (BIP_Func_Call), Loc),
8812 Expression => New_Copy_Tree (BIP_Func_Call));
8814 Expander_Mode_Save_And_Set (False);
8815 Insert_Action (Obj_Decl, Tmp_Decl);
8816 Expander_Mode_Restore;
8818 Make_Build_In_Place_Call_In_Object_Declaration
8819 (Obj_Decl => Tmp_Decl,
8820 Function_Call => Expression (Tmp_Decl));
8822 pragma Assert (Nkind (Tmp_Decl) = N_Object_Renaming_Declaration);
8824 -- Replace the original build-in-place function call by a reference to
8825 -- the resulting temporary object renaming declaration. In this way,
8826 -- all the interface conversions performed in the original Function_Call
8827 -- on the build-in-place object are preserved.
8829 Rewrite (BIP_Func_Call, New_Occurrence_Of (Tmp_Id, Loc));
8831 -- Replace the original object declaration by an internal object
8832 -- renaming declaration. This leaves the generated code more clean (the
8833 -- build-in-place function call in an object renaming declaration and
8834 -- displacements of the pointer to the build-in-place object in another
8835 -- renaming declaration) and allows us to invoke the routine that takes
8836 -- care of replacing the identifier of the renaming declaration (routine
8837 -- originally developed for the regular build-in-place management).
8840 Make_Object_Renaming_Declaration (Loc,
8841 Defining_Identifier => Make_Temporary (Loc, 'D'),
8842 Subtype_Mark => New_Occurrence_Of (Etype (Obj_Id), Loc),
8843 Name => Function_Call));
8846 Replace_Renaming_Declaration_Id (Obj_Decl, Original_Node (Obj_Decl));
8847 end Make_Build_In_Place_Iface_Call_In_Object_Declaration;
8849 --------------------------------------------
8850 -- Make_CPP_Constructor_Call_In_Allocator --
8851 --------------------------------------------
8853 procedure Make_CPP_Constructor_Call_In_Allocator
8854 (Allocator : Node_Id;
8855 Function_Call : Node_Id)
8857 Loc : constant Source_Ptr := Sloc (Function_Call);
8858 Acc_Type : constant Entity_Id := Etype (Allocator);
8859 Function_Id : constant Entity_Id := Entity (Name (Function_Call));
8860 Result_Subt : constant Entity_Id := Available_View (Etype (Function_Id));
8862 New_Allocator : Node_Id;
8863 Return_Obj_Access : Entity_Id;
8867 pragma Assert (Nkind (Allocator) = N_Allocator
8868 and then Nkind (Function_Call) = N_Function_Call);
8869 pragma Assert (Convention (Function_Id) = Convention_CPP
8870 and then Is_Constructor (Function_Id));
8871 pragma Assert (Is_Constrained (Underlying_Type (Result_Subt)));
8873 -- Replace the initialized allocator of form "new T'(Func (...))" with
8874 -- an uninitialized allocator of form "new T", where T is the result
8875 -- subtype of the called function. The call to the function is handled
8876 -- separately further below.
8879 Make_Allocator (Loc,
8880 Expression => New_Occurrence_Of (Result_Subt, Loc));
8881 Set_No_Initialization (New_Allocator);
8883 -- Copy attributes to new allocator. Note that the new allocator
8884 -- logically comes from source if the original one did, so copy the
8885 -- relevant flag. This ensures proper treatment of the restriction
8886 -- No_Implicit_Heap_Allocations in this case.
8888 Set_Storage_Pool (New_Allocator, Storage_Pool (Allocator));
8889 Set_Procedure_To_Call (New_Allocator, Procedure_To_Call (Allocator));
8890 Set_Comes_From_Source (New_Allocator, Comes_From_Source (Allocator));
8892 Rewrite (Allocator, New_Allocator);
8894 -- Create a new access object and initialize it to the result of the
8895 -- new uninitialized allocator. Note: we do not use Allocator as the
8896 -- Related_Node of Return_Obj_Access in call to Make_Temporary below
8897 -- as this would create a sort of infinite "recursion".
8899 Return_Obj_Access := Make_Temporary (Loc, 'R');
8900 Set_Etype (Return_Obj_Access, Acc_Type);
8903 -- Rnnn : constant ptr_T := new (T);
8904 -- Init (Rnn.all,...);
8907 Make_Object_Declaration (Loc,
8908 Defining_Identifier => Return_Obj_Access,
8909 Constant_Present => True,
8910 Object_Definition => New_Occurrence_Of (Acc_Type, Loc),
8911 Expression => Relocate_Node (Allocator));
8912 Insert_Action (Allocator, Tmp_Obj);
8914 Insert_List_After_And_Analyze (Tmp_Obj,
8915 Build_Initialization_Call (Loc,
8917 Make_Explicit_Dereference (Loc,
8918 Prefix => New_Occurrence_Of (Return_Obj_Access, Loc)),
8919 Typ => Etype (Function_Id),
8920 Constructor_Ref => Function_Call));
8922 -- Finally, replace the allocator node with a reference to the result of
8923 -- the function call itself (which will effectively be an access to the
8924 -- object created by the allocator).
8926 Rewrite (Allocator, New_Occurrence_Of (Return_Obj_Access, Loc));
8928 -- Ada 2005 (AI-251): If the type of the allocator is an interface then
8929 -- generate an implicit conversion to force displacement of the "this"
8932 if Is_Interface (Designated_Type (Acc_Type)) then
8933 Rewrite (Allocator, Convert_To (Acc_Type, Relocate_Node (Allocator)));
8936 Analyze_And_Resolve (Allocator, Acc_Type);
8937 end Make_CPP_Constructor_Call_In_Allocator;
8939 -----------------------------------
8940 -- Needs_BIP_Finalization_Master --
8941 -----------------------------------
8943 function Needs_BIP_Finalization_Master
8944 (Func_Id : Entity_Id) return Boolean
8946 pragma Assert (Is_Build_In_Place_Function (Func_Id));
8947 Func_Typ : constant Entity_Id := Underlying_Type (Etype (Func_Id));
8949 -- A formal giving the finalization master is needed for build-in-place
8950 -- functions whose result type needs finalization or is a tagged type.
8951 -- Tagged primitive build-in-place functions need such a formal because
8952 -- they can be called by a dispatching call, and extensions may require
8953 -- finalization even if the root type doesn't. This means they're also
8954 -- needed for tagged nonprimitive build-in-place functions with tagged
8955 -- results, since such functions can be called via access-to-function
8956 -- types, and those can be used to call primitives, so masters have to
8957 -- be passed to all such build-in-place functions, primitive or not.
8960 not Restriction_Active (No_Finalization)
8961 and then (Needs_Finalization (Func_Typ)
8962 or else Is_Tagged_Type (Func_Typ));
8963 end Needs_BIP_Finalization_Master;
8965 --------------------------
8966 -- Needs_BIP_Alloc_Form --
8967 --------------------------
8969 function Needs_BIP_Alloc_Form (Func_Id : Entity_Id) return Boolean is
8970 pragma Assert (Is_Build_In_Place_Function (Func_Id));
8971 Func_Typ : constant Entity_Id := Underlying_Type (Etype (Func_Id));
8973 return not Is_Constrained (Func_Typ) or else Is_Tagged_Type (Func_Typ);
8974 end Needs_BIP_Alloc_Form;
8976 --------------------------------------
8977 -- Needs_Result_Accessibility_Level --
8978 --------------------------------------
8980 function Needs_Result_Accessibility_Level
8981 (Func_Id : Entity_Id) return Boolean
8983 Func_Typ : constant Entity_Id := Underlying_Type (Etype (Func_Id));
8985 function Has_Unconstrained_Access_Discriminant_Component
8986 (Comp_Typ : Entity_Id) return Boolean;
8987 -- Returns True if any component of the type has an unconstrained access
8990 -----------------------------------------------------
8991 -- Has_Unconstrained_Access_Discriminant_Component --
8992 -----------------------------------------------------
8994 function Has_Unconstrained_Access_Discriminant_Component
8995 (Comp_Typ : Entity_Id) return Boolean
8998 if not Is_Limited_Type (Comp_Typ) then
9001 -- Only limited types can have access discriminants with
9004 elsif Has_Unconstrained_Access_Discriminants (Comp_Typ) then
9007 elsif Is_Array_Type (Comp_Typ) then
9008 return Has_Unconstrained_Access_Discriminant_Component
9009 (Underlying_Type (Component_Type (Comp_Typ)));
9011 elsif Is_Record_Type (Comp_Typ) then
9016 Comp := First_Component (Comp_Typ);
9017 while Present (Comp) loop
9018 if Has_Unconstrained_Access_Discriminant_Component
9019 (Underlying_Type (Etype (Comp)))
9024 Next_Component (Comp);
9030 end Has_Unconstrained_Access_Discriminant_Component;
9032 Feature_Disabled : constant Boolean := True;
9035 -- Start of processing for Needs_Result_Accessibility_Level
9038 -- False if completion unavailable (how does this happen???)
9040 if not Present (Func_Typ) then
9043 elsif Feature_Disabled then
9046 -- False if not a function, also handle enum-lit renames case
9048 elsif Func_Typ = Standard_Void_Type
9049 or else Is_Scalar_Type (Func_Typ)
9053 -- Handle a corner case, a cross-dialect subp renaming. For example,
9054 -- an Ada 2012 renaming of an Ada 2005 subprogram. This can occur when
9055 -- an Ada 2005 (or earlier) unit references predefined run-time units.
9057 elsif Present (Alias (Func_Id)) then
9059 -- Unimplemented: a cross-dialect subp renaming which does not set
9060 -- the Alias attribute (e.g., a rename of a dereference of an access
9061 -- to subprogram value). ???
9063 return Present (Extra_Accessibility_Of_Result (Alias (Func_Id)));
9065 -- Remaining cases require Ada 2012 mode
9067 elsif Ada_Version < Ada_2012 then
9070 elsif Ekind (Func_Typ) = E_Anonymous_Access_Type
9071 or else Is_Tagged_Type (Func_Typ)
9073 -- In the case of, say, a null tagged record result type, the need
9074 -- for this extra parameter might not be obvious. This function
9075 -- returns True for all tagged types for compatibility reasons.
9076 -- A function with, say, a tagged null controlling result type might
9077 -- be overridden by a primitive of an extension having an access
9078 -- discriminant and the overrider and overridden must have compatible
9079 -- calling conventions (including implicitly declared parameters).
9080 -- Similarly, values of one access-to-subprogram type might designate
9081 -- both a primitive subprogram of a given type and a function
9082 -- which is, for example, not a primitive subprogram of any type.
9083 -- Again, this requires calling convention compatibility.
9084 -- It might be possible to solve these issues by introducing
9085 -- wrappers, but that is not the approach that was chosen.
9089 elsif Has_Unconstrained_Access_Discriminants (Func_Typ) then
9092 elsif Has_Unconstrained_Access_Discriminant_Component (Func_Typ) then
9095 -- False for all other cases
9100 end Needs_Result_Accessibility_Level;
9102 -------------------------------------
9103 -- Replace_Renaming_Declaration_Id --
9104 -------------------------------------
9106 procedure Replace_Renaming_Declaration_Id
9107 (New_Decl : Node_Id;
9108 Orig_Decl : Node_Id)
9110 New_Id : constant Entity_Id := Defining_Entity (New_Decl);
9111 Orig_Id : constant Entity_Id := Defining_Entity (Orig_Decl);
9114 Set_Chars (New_Id, Chars (Orig_Id));
9116 -- Swap next entity links in preparation for exchanging entities
9119 Next_Id : constant Entity_Id := Next_Entity (New_Id);
9121 Set_Next_Entity (New_Id, Next_Entity (Orig_Id));
9122 Set_Next_Entity (Orig_Id, Next_Id);
9125 Set_Homonym (New_Id, Homonym (Orig_Id));
9126 Exchange_Entities (New_Id, Orig_Id);
9128 -- Preserve source indication of original declaration, so that xref
9129 -- information is properly generated for the right entity.
9131 Preserve_Comes_From_Source (New_Decl, Orig_Decl);
9132 Preserve_Comes_From_Source (Orig_Id, Orig_Decl);
9134 Set_Comes_From_Source (New_Id, False);
9135 end Replace_Renaming_Declaration_Id;
9137 ---------------------------------
9138 -- Rewrite_Function_Call_For_C --
9139 ---------------------------------
9141 procedure Rewrite_Function_Call_For_C (N : Node_Id) is
9142 Orig_Func : constant Entity_Id := Entity (Name (N));
9143 Func_Id : constant Entity_Id := Ultimate_Alias (Orig_Func);
9144 Par : constant Node_Id := Parent (N);
9145 Proc_Id : constant Entity_Id := Corresponding_Procedure (Func_Id);
9146 Loc : constant Source_Ptr := Sloc (Par);
9148 Last_Actual : Node_Id;
9149 Last_Formal : Entity_Id;
9151 -- Start of processing for Rewrite_Function_Call_For_C
9154 -- The actuals may be given by named associations, so the added actual
9155 -- that is the target of the return value of the call must be a named
9156 -- association as well, so we retrieve the name of the generated
9159 Last_Formal := First_Formal (Proc_Id);
9160 while Present (Next_Formal (Last_Formal)) loop
9161 Last_Formal := Next_Formal (Last_Formal);
9164 Actuals := Parameter_Associations (N);
9166 -- The original function may lack parameters
9168 if No (Actuals) then
9169 Actuals := New_List;
9172 -- If the function call is the expression of an assignment statement,
9173 -- transform the assignment into a procedure call. Generate:
9175 -- LHS := Func_Call (...);
9177 -- Proc_Call (..., LHS);
9179 -- If function is inherited, a conversion may be necessary.
9181 if Nkind (Par) = N_Assignment_Statement then
9182 Last_Actual := Name (Par);
9184 if not Comes_From_Source (Orig_Func)
9185 and then Etype (Orig_Func) /= Etype (Func_Id)
9188 Make_Type_Conversion (Loc,
9189 New_Occurrence_Of (Etype (Func_Id), Loc),
9194 Make_Parameter_Association (Loc,
9196 Make_Identifier (Loc, Chars (Last_Formal)),
9197 Explicit_Actual_Parameter => Last_Actual));
9200 Make_Procedure_Call_Statement (Loc,
9201 Name => New_Occurrence_Of (Proc_Id, Loc),
9202 Parameter_Associations => Actuals));
9205 -- Otherwise the context is an expression. Generate a temporary and a
9206 -- procedure call to obtain the function result. Generate:
9208 -- ... Func_Call (...) ...
9211 -- Proc_Call (..., Temp);
9216 Temp_Id : constant Entity_Id := Make_Temporary (Loc, 'T');
9225 Make_Object_Declaration (Loc,
9226 Defining_Identifier => Temp_Id,
9227 Object_Definition =>
9228 New_Occurrence_Of (Etype (Func_Id), Loc));
9231 -- Proc_Call (..., Temp);
9234 Make_Parameter_Association (Loc,
9236 Make_Identifier (Loc, Chars (Last_Formal)),
9237 Explicit_Actual_Parameter =>
9238 New_Occurrence_Of (Temp_Id, Loc)));
9241 Make_Procedure_Call_Statement (Loc,
9242 Name => New_Occurrence_Of (Proc_Id, Loc),
9243 Parameter_Associations => Actuals);
9245 Insert_Actions (Par, New_List (Decl, Call));
9246 Rewrite (N, New_Occurrence_Of (Temp_Id, Loc));
9249 end Rewrite_Function_Call_For_C;
9251 ------------------------------------
9252 -- Set_Enclosing_Sec_Stack_Return --
9253 ------------------------------------
9255 procedure Set_Enclosing_Sec_Stack_Return (N : Node_Id) is
9259 -- Due to a possible mix of internally generated blocks, source blocks
9260 -- and loops, the scope stack may not be contiguous as all labels are
9261 -- inserted at the top level within the related function. Instead,
9262 -- perform a parent-based traversal and mark all appropriate constructs.
9264 while Present (P) loop
9266 -- Mark the label of a source or internally generated block or
9269 if Nkind_In (P, N_Block_Statement, N_Loop_Statement) then
9270 Set_Sec_Stack_Needed_For_Return (Entity (Identifier (P)));
9272 -- Mark the enclosing function
9274 elsif Nkind (P) = N_Subprogram_Body then
9275 if Present (Corresponding_Spec (P)) then
9276 Set_Sec_Stack_Needed_For_Return (Corresponding_Spec (P));
9278 Set_Sec_Stack_Needed_For_Return (Defining_Entity (P));
9281 -- Do not go beyond the enclosing function
9288 end Set_Enclosing_Sec_Stack_Return;
9290 ------------------------------------
9291 -- Unqual_BIP_Iface_Function_Call --
9292 ------------------------------------
9294 function Unqual_BIP_Iface_Function_Call (Expr : Node_Id) return Node_Id is
9295 Has_Pointer_Displacement : Boolean := False;
9296 On_Object_Declaration : Boolean := False;
9297 -- Remember if processing the renaming expressions on recursion we have
9298 -- traversed an object declaration, since we can traverse many object
9299 -- declaration renamings but just one regular object declaration.
9301 function Unqual_BIP_Function_Call (Expr : Node_Id) return Node_Id;
9302 -- Search for a build-in-place function call skipping any qualification
9303 -- including qualified expressions, type conversions, references, calls
9304 -- to displace the pointer to the object, and renamings. Return Empty if
9305 -- no build-in-place function call is found.
9307 ------------------------------
9308 -- Unqual_BIP_Function_Call --
9309 ------------------------------
9311 function Unqual_BIP_Function_Call (Expr : Node_Id) return Node_Id is
9313 -- Recurse to handle case of multiple levels of qualification and/or
9316 if Nkind_In (Expr, N_Qualified_Expression,
9318 N_Unchecked_Type_Conversion)
9320 return Unqual_BIP_Function_Call (Expression (Expr));
9322 -- Recurse to handle case of multiple levels of references and
9323 -- explicit dereferences.
9325 elsif Nkind_In (Expr, N_Attribute_Reference,
9326 N_Explicit_Dereference,
9329 return Unqual_BIP_Function_Call (Prefix (Expr));
9331 -- Recurse on object renamings
9333 elsif Nkind (Expr) = N_Identifier
9334 and then Present (Entity (Expr))
9335 and then Ekind_In (Entity (Expr), E_Constant, E_Variable)
9336 and then Nkind (Parent (Entity (Expr))) =
9337 N_Object_Renaming_Declaration
9338 and then Present (Renamed_Object (Entity (Expr)))
9340 return Unqual_BIP_Function_Call (Renamed_Object (Entity (Expr)));
9342 -- Recurse on the initializing expression of the first reference of
9343 -- an object declaration.
9345 elsif not On_Object_Declaration
9346 and then Nkind (Expr) = N_Identifier
9347 and then Present (Entity (Expr))
9348 and then Ekind_In (Entity (Expr), E_Constant, E_Variable)
9349 and then Nkind (Parent (Entity (Expr))) = N_Object_Declaration
9350 and then Present (Expression (Parent (Entity (Expr))))
9352 On_Object_Declaration := True;
9354 Unqual_BIP_Function_Call (Expression (Parent (Entity (Expr))));
9356 -- Recurse to handle calls to displace the pointer to the object to
9357 -- reference a secondary dispatch table.
9359 elsif Nkind (Expr) = N_Function_Call
9360 and then Nkind (Name (Expr)) in N_Has_Entity
9361 and then Present (Entity (Name (Expr)))
9362 and then RTU_Loaded (Ada_Tags)
9363 and then RTE_Available (RE_Displace)
9364 and then Is_RTE (Entity (Name (Expr)), RE_Displace)
9366 Has_Pointer_Displacement := True;
9368 Unqual_BIP_Function_Call (First (Parameter_Associations (Expr)));
9370 -- Normal case: check if the inner expression is a BIP function call
9371 -- and the pointer to the object is displaced.
9373 elsif Has_Pointer_Displacement
9374 and then Is_Build_In_Place_Function_Call (Expr)
9381 end Unqual_BIP_Function_Call;
9383 -- Start of processing for Unqual_BIP_Iface_Function_Call
9386 if Nkind (Expr) = N_Identifier and then No (Entity (Expr)) then
9388 -- Can happen for X'Elab_Spec in the binder-generated file
9393 return Unqual_BIP_Function_Call (Expr);
9394 end Unqual_BIP_Iface_Function_Call;