1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2020, 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 Aspects; use Aspects;
28 with Checks; use Checks;
29 with Contracts; use Contracts;
30 with Debug; use Debug;
31 with Einfo; use Einfo;
32 with Errout; use Errout;
33 with Elists; use Elists;
34 with Expander; use Expander;
35 with Exp_Aggr; use Exp_Aggr;
36 with Exp_Atag; use Exp_Atag;
37 with Exp_Ch2; use Exp_Ch2;
38 with Exp_Ch3; use Exp_Ch3;
39 with Exp_Ch7; use Exp_Ch7;
40 with Exp_Ch9; use Exp_Ch9;
41 with Exp_Dbug; use Exp_Dbug;
42 with Exp_Disp; use Exp_Disp;
43 with Exp_Dist; use Exp_Dist;
44 with Exp_Intr; use Exp_Intr;
45 with Exp_Pakd; use Exp_Pakd;
46 with Exp_Tss; use Exp_Tss;
47 with Exp_Util; use Exp_Util;
48 with Freeze; use Freeze;
49 with Inline; use Inline;
50 with Itypes; use Itypes;
52 with Namet; use Namet;
53 with Nlists; use Nlists;
54 with Nmake; use Nmake;
56 with Restrict; use Restrict;
57 with Rident; use Rident;
58 with Rtsfind; use Rtsfind;
60 with Sem_Aux; use Sem_Aux;
61 with Sem_Ch6; use Sem_Ch6;
62 with Sem_Ch8; use Sem_Ch8;
63 with Sem_Ch13; use Sem_Ch13;
64 with Sem_Dim; use Sem_Dim;
65 with Sem_Disp; use Sem_Disp;
66 with Sem_Dist; use Sem_Dist;
67 with Sem_Eval; use Sem_Eval;
68 with Sem_Mech; use Sem_Mech;
69 with Sem_Res; use Sem_Res;
70 with Sem_SCIL; use Sem_SCIL;
71 with Sem_Util; use Sem_Util;
72 with Sinfo; use Sinfo;
73 with Snames; use Snames;
74 with Stand; use Stand;
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 function Check_Number_Of_Actuals
150 (Subp_Call : Node_Id;
151 Subp_Id : Entity_Id) return Boolean;
152 -- Given a subprogram call to the given subprogram return True if the
153 -- number of actual parameters (including extra actuals) is correct.
155 procedure Check_Overriding_Operation (Subp : Entity_Id);
156 -- Subp is a dispatching operation. Check whether it may override an
157 -- inherited private operation, in which case its DT entry is that of
158 -- the hidden operation, not the one it may have received earlier.
159 -- This must be done before emitting the code to set the corresponding
160 -- DT to the address of the subprogram. The actual placement of Subp in
161 -- the proper place in the list of primitive operations is done in
162 -- Declare_Inherited_Private_Subprograms, which also has to deal with
163 -- implicit operations. This duplication is unavoidable for now???
165 procedure Detect_Infinite_Recursion (N : Node_Id; Spec : Entity_Id);
166 -- This procedure is called only if the subprogram body N, whose spec
167 -- has the given entity Spec, contains a parameterless recursive call.
168 -- It attempts to generate runtime code to detect if this a case of
169 -- infinite recursion.
171 -- The body is scanned to determine dependencies. If the only external
172 -- dependencies are on a small set of scalar variables, then the values
173 -- of these variables are captured on entry to the subprogram, and if
174 -- the values are not changed for the call, we know immediately that
175 -- we have an infinite recursion.
177 procedure Expand_Actuals
180 Post_Call : out List_Id);
181 -- Return a list of actions to take place after the call in Post_Call. The
182 -- call will later be rewritten as an Expression_With_Actions, with the
183 -- Post_Call actions inserted, and the call inside.
185 -- For each actual of an in-out or out parameter which is a numeric (view)
186 -- conversion of the form T (A), where A denotes a variable, we insert the
189 -- Temp : T[ := T (A)];
191 -- prior to the call. Then we replace the actual with a reference to Temp,
192 -- and append the assignment:
194 -- A := TypeA (Temp);
196 -- after the call. Here TypeA is the actual type of variable A. For out
197 -- parameters, the initial declaration has no expression. If A is not an
198 -- entity name, we generate instead:
200 -- Var : TypeA renames A;
201 -- Temp : T := Var; -- omitting expression for out parameter.
203 -- Var := TypeA (Temp);
205 -- For other in-out parameters, we emit the required constraint checks
206 -- before and/or after the call.
208 -- For all parameter modes, actuals that denote components and slices of
209 -- packed arrays are expanded into suitable temporaries.
211 -- For nonscalar objects that are possibly unaligned, add call by copy code
212 -- (copy in for IN and IN OUT, copy out for OUT and IN OUT).
214 -- For OUT and IN OUT parameters, add predicate checks after the call
215 -- based on the predicates of the actual type.
217 procedure Expand_Call_Helper (N : Node_Id; Post_Call : out List_Id);
218 -- Does the main work of Expand_Call. Post_Call is as for Expand_Actuals.
220 procedure Expand_Ctrl_Function_Call (N : Node_Id);
221 -- N is a function call which returns a controlled object. Transform the
222 -- call into a temporary which retrieves the returned object from the
223 -- secondary stack using 'reference.
225 procedure Expand_Non_Function_Return (N : Node_Id);
226 -- Expand a simple return statement found in a procedure body, entry body,
227 -- accept statement, or an extended return statement. Note that all non-
228 -- function returns are simple return statements.
230 function Expand_Protected_Object_Reference
232 Scop : Entity_Id) return Node_Id;
234 procedure Expand_Protected_Subprogram_Call
238 -- A call to a protected subprogram within the protected object may appear
239 -- as a regular call. The list of actuals must be expanded to contain a
240 -- reference to the object itself, and the call becomes a call to the
241 -- corresponding protected subprogram.
243 procedure Expand_Simple_Function_Return (N : Node_Id);
244 -- Expand simple return from function. In the case where we are returning
245 -- from a function body this is called by Expand_N_Simple_Return_Statement.
247 function Has_Unconstrained_Access_Discriminants
248 (Subtyp : Entity_Id) return Boolean;
249 -- Returns True if the given subtype is unconstrained and has one or more
250 -- access discriminants.
252 procedure Insert_Post_Call_Actions (N : Node_Id; Post_Call : List_Id);
253 -- Insert the Post_Call list previously produced by routine Expand_Actuals
254 -- or Expand_Call_Helper into the tree.
256 procedure Replace_Renaming_Declaration_Id
258 Orig_Decl : Node_Id);
259 -- Replace the internal identifier of the new renaming declaration New_Decl
260 -- with the identifier of its original declaration Orig_Decl exchanging the
261 -- entities containing their defining identifiers to ensure the correct
262 -- replacement of the object declaration by the object renaming declaration
263 -- to avoid homograph conflicts (since the object declaration's defining
264 -- identifier was already entered in the current scope). The Next_Entity
265 -- links of the two entities are also swapped since the entities are part
266 -- of the return scope's entity list and the list structure would otherwise
267 -- be corrupted. The homonym chain is preserved as well.
269 procedure Rewrite_Function_Call_For_C (N : Node_Id);
270 -- When generating C code, replace a call to a function that returns an
271 -- array into the generated procedure with an additional out parameter.
273 procedure Set_Enclosing_Sec_Stack_Return (N : Node_Id);
274 -- N is a return statement for a function that returns its result on the
275 -- secondary stack. This sets the Sec_Stack_Needed_For_Return flag on the
276 -- function and all blocks and loops that the return statement is jumping
277 -- out of. This ensures that the secondary stack is not released; otherwise
278 -- the function result would be reclaimed before returning to the caller.
280 ----------------------------------------------
281 -- Add_Access_Actual_To_Build_In_Place_Call --
282 ----------------------------------------------
284 procedure Add_Access_Actual_To_Build_In_Place_Call
285 (Function_Call : Node_Id;
286 Function_Id : Entity_Id;
287 Return_Object : Node_Id;
288 Is_Access : Boolean := False)
290 Loc : constant Source_Ptr := Sloc (Function_Call);
291 Obj_Address : Node_Id;
292 Obj_Acc_Formal : Entity_Id;
295 -- Locate the implicit access parameter in the called function
297 Obj_Acc_Formal := Build_In_Place_Formal (Function_Id, BIP_Object_Access);
299 -- If no return object is provided, then pass null
301 if not Present (Return_Object) then
302 Obj_Address := Make_Null (Loc);
303 Set_Parent (Obj_Address, Function_Call);
305 -- If Return_Object is already an expression of an access type, then use
306 -- it directly, since it must be an access value denoting the return
307 -- object, and couldn't possibly be the return object itself.
310 Obj_Address := Return_Object;
311 Set_Parent (Obj_Address, Function_Call);
313 -- Apply Unrestricted_Access to caller's return object
317 Make_Attribute_Reference (Loc,
318 Prefix => Return_Object,
319 Attribute_Name => Name_Unrestricted_Access);
321 Set_Parent (Return_Object, Obj_Address);
322 Set_Parent (Obj_Address, Function_Call);
325 Analyze_And_Resolve (Obj_Address, Etype (Obj_Acc_Formal));
327 -- Build the parameter association for the new actual and add it to the
328 -- end of the function's actuals.
330 Add_Extra_Actual_To_Call (Function_Call, Obj_Acc_Formal, Obj_Address);
331 end Add_Access_Actual_To_Build_In_Place_Call;
333 ------------------------------------------------------
334 -- Add_Unconstrained_Actuals_To_Build_In_Place_Call --
335 ------------------------------------------------------
337 procedure Add_Unconstrained_Actuals_To_Build_In_Place_Call
338 (Function_Call : Node_Id;
339 Function_Id : Entity_Id;
340 Alloc_Form : BIP_Allocation_Form := Unspecified;
341 Alloc_Form_Exp : Node_Id := Empty;
342 Pool_Actual : Node_Id := Make_Null (No_Location))
344 Loc : constant Source_Ptr := Sloc (Function_Call);
346 Alloc_Form_Actual : Node_Id;
347 Alloc_Form_Formal : Node_Id;
348 Pool_Formal : Node_Id;
351 -- Nothing to do when the size of the object is known, and the caller is
352 -- in charge of allocating it, and the callee doesn't unconditionally
353 -- require an allocation form (such as due to having a tagged result).
355 if not Needs_BIP_Alloc_Form (Function_Id) then
359 -- Locate the implicit allocation form parameter in the called function.
360 -- Maybe it would be better for each implicit formal of a build-in-place
361 -- function to have a flag or a Uint attribute to identify it. ???
363 Alloc_Form_Formal := Build_In_Place_Formal (Function_Id, BIP_Alloc_Form);
365 if Present (Alloc_Form_Exp) then
366 pragma Assert (Alloc_Form = Unspecified);
368 Alloc_Form_Actual := Alloc_Form_Exp;
371 pragma Assert (Alloc_Form /= Unspecified);
374 Make_Integer_Literal (Loc,
375 Intval => UI_From_Int (BIP_Allocation_Form'Pos (Alloc_Form)));
378 Analyze_And_Resolve (Alloc_Form_Actual, Etype (Alloc_Form_Formal));
380 -- Build the parameter association for the new actual and add it to the
381 -- end of the function's actuals.
383 Add_Extra_Actual_To_Call
384 (Function_Call, Alloc_Form_Formal, Alloc_Form_Actual);
386 -- Pass the Storage_Pool parameter. This parameter is omitted on ZFP as
387 -- those targets do not support pools.
389 if RTE_Available (RE_Root_Storage_Pool_Ptr) then
390 Pool_Formal := Build_In_Place_Formal (Function_Id, BIP_Storage_Pool);
391 Analyze_And_Resolve (Pool_Actual, Etype (Pool_Formal));
392 Add_Extra_Actual_To_Call
393 (Function_Call, Pool_Formal, Pool_Actual);
395 end Add_Unconstrained_Actuals_To_Build_In_Place_Call;
397 -----------------------------------------------------------
398 -- Add_Finalization_Master_Actual_To_Build_In_Place_Call --
399 -----------------------------------------------------------
401 procedure Add_Finalization_Master_Actual_To_Build_In_Place_Call
402 (Func_Call : Node_Id;
404 Ptr_Typ : Entity_Id := Empty;
405 Master_Exp : Node_Id := Empty)
408 if not Needs_BIP_Finalization_Master (Func_Id) then
413 Formal : constant Entity_Id :=
414 Build_In_Place_Formal (Func_Id, BIP_Finalization_Master);
415 Loc : constant Source_Ptr := Sloc (Func_Call);
418 Desig_Typ : Entity_Id;
421 -- If there is a finalization master actual, such as the implicit
422 -- finalization master of an enclosing build-in-place function,
423 -- then this must be added as an extra actual of the call.
425 if Present (Master_Exp) then
426 Actual := Master_Exp;
428 -- Case where the context does not require an actual master
430 elsif No (Ptr_Typ) then
431 Actual := Make_Null (Loc);
434 Desig_Typ := Directly_Designated_Type (Ptr_Typ);
436 -- Check for a library-level access type whose designated type has
437 -- suppressed finalization or the access type is subject to pragma
438 -- No_Heap_Finalization. Such an access type lacks a master. Pass
439 -- a null actual to callee in order to signal a missing master.
441 if Is_Library_Level_Entity (Ptr_Typ)
442 and then (Finalize_Storage_Only (Desig_Typ)
443 or else No_Heap_Finalization (Ptr_Typ))
445 Actual := Make_Null (Loc);
447 -- Types in need of finalization actions
449 elsif Needs_Finalization (Desig_Typ) then
451 -- The general mechanism of creating finalization masters for
452 -- anonymous access types is disabled by default, otherwise
453 -- finalization masters will pop all over the place. Such types
454 -- use context-specific masters.
456 if Ekind (Ptr_Typ) = E_Anonymous_Access_Type
457 and then No (Finalization_Master (Ptr_Typ))
459 Build_Anonymous_Master (Ptr_Typ);
462 -- Access-to-controlled types should always have a master
464 pragma Assert (Present (Finalization_Master (Ptr_Typ)));
467 Make_Attribute_Reference (Loc,
469 New_Occurrence_Of (Finalization_Master (Ptr_Typ), Loc),
470 Attribute_Name => Name_Unrestricted_Access);
475 Actual := Make_Null (Loc);
479 Analyze_And_Resolve (Actual, Etype (Formal));
481 -- Build the parameter association for the new actual and add it to
482 -- the end of the function's actuals.
484 Add_Extra_Actual_To_Call (Func_Call, Formal, Actual);
486 end Add_Finalization_Master_Actual_To_Build_In_Place_Call;
488 ------------------------------
489 -- Add_Extra_Actual_To_Call --
490 ------------------------------
492 procedure Add_Extra_Actual_To_Call
493 (Subprogram_Call : Node_Id;
494 Extra_Formal : Entity_Id;
495 Extra_Actual : Node_Id)
497 Loc : constant Source_Ptr := Sloc (Subprogram_Call);
498 Param_Assoc : Node_Id;
502 Make_Parameter_Association (Loc,
503 Selector_Name => New_Occurrence_Of (Extra_Formal, Loc),
504 Explicit_Actual_Parameter => Extra_Actual);
506 Set_Parent (Param_Assoc, Subprogram_Call);
507 Set_Parent (Extra_Actual, Param_Assoc);
509 if Present (Parameter_Associations (Subprogram_Call)) then
510 if Nkind (Last (Parameter_Associations (Subprogram_Call))) =
511 N_Parameter_Association
514 -- Find last named actual, and append
519 L := First_Actual (Subprogram_Call);
520 while Present (L) loop
521 if No (Next_Actual (L)) then
522 Set_Next_Named_Actual (Parent (L), Extra_Actual);
530 Set_First_Named_Actual (Subprogram_Call, Extra_Actual);
533 Append (Param_Assoc, To => Parameter_Associations (Subprogram_Call));
536 Set_Parameter_Associations (Subprogram_Call, New_List (Param_Assoc));
537 Set_First_Named_Actual (Subprogram_Call, Extra_Actual);
539 end Add_Extra_Actual_To_Call;
541 ---------------------------------------------
542 -- Add_Task_Actuals_To_Build_In_Place_Call --
543 ---------------------------------------------
545 procedure Add_Task_Actuals_To_Build_In_Place_Call
546 (Function_Call : Node_Id;
547 Function_Id : Entity_Id;
548 Master_Actual : Node_Id;
549 Chain : Node_Id := Empty)
551 Loc : constant Source_Ptr := Sloc (Function_Call);
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 Needs_BIP_Task_Actuals (Function_Id) 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_Number_Of_Actuals --
878 -----------------------------
880 function Check_Number_Of_Actuals
881 (Subp_Call : Node_Id;
882 Subp_Id : Entity_Id) return Boolean
888 pragma Assert (Nkind_In (Subp_Call, N_Entry_Call_Statement,
890 N_Procedure_Call_Statement));
892 Formal := First_Formal_With_Extras (Subp_Id);
893 Actual := First_Actual (Subp_Call);
895 while Present (Formal) and then Present (Actual) loop
896 Next_Formal_With_Extras (Formal);
897 Next_Actual (Actual);
900 return No (Formal) and then No (Actual);
901 end Check_Number_Of_Actuals;
903 --------------------------------
904 -- Check_Overriding_Operation --
905 --------------------------------
907 procedure Check_Overriding_Operation (Subp : Entity_Id) is
908 Typ : constant Entity_Id := Find_Dispatching_Type (Subp);
909 Op_List : constant Elist_Id := Primitive_Operations (Typ);
915 if Is_Derived_Type (Typ)
916 and then not Is_Private_Type (Typ)
917 and then In_Open_Scopes (Scope (Etype (Typ)))
918 and then Is_Base_Type (Typ)
920 -- Subp overrides an inherited private operation if there is an
921 -- inherited operation with a different name than Subp (see
922 -- Derive_Subprogram) whose Alias is a hidden subprogram with the
923 -- same name as Subp.
925 Op_Elmt := First_Elmt (Op_List);
926 while Present (Op_Elmt) loop
927 Prim_Op := Node (Op_Elmt);
928 Par_Op := Alias (Prim_Op);
931 and then not Comes_From_Source (Prim_Op)
932 and then Chars (Prim_Op) /= Chars (Par_Op)
933 and then Chars (Par_Op) = Chars (Subp)
934 and then Is_Hidden (Par_Op)
935 and then Type_Conformant (Prim_Op, Subp)
937 Set_DT_Position_Value (Subp, DT_Position (Prim_Op));
943 end Check_Overriding_Operation;
945 -------------------------------
946 -- Detect_Infinite_Recursion --
947 -------------------------------
949 procedure Detect_Infinite_Recursion (N : Node_Id; Spec : Entity_Id) is
950 Loc : constant Source_Ptr := Sloc (N);
952 Var_List : constant Elist_Id := New_Elmt_List;
953 -- List of globals referenced by body of procedure
955 Call_List : constant Elist_Id := New_Elmt_List;
956 -- List of recursive calls in body of procedure
958 Shad_List : constant Elist_Id := New_Elmt_List;
959 -- List of entity id's for entities created to capture the value of
960 -- referenced globals on entry to the procedure.
962 Scop : constant Uint := Scope_Depth (Spec);
963 -- This is used to record the scope depth of the current procedure, so
964 -- that we can identify global references.
966 Max_Vars : constant := 4;
967 -- Do not test more than four global variables
969 Count_Vars : Natural := 0;
970 -- Count variables found so far
982 function Process (Nod : Node_Id) return Traverse_Result;
983 -- Function to traverse the subprogram body (using Traverse_Func)
989 function Process (Nod : Node_Id) return Traverse_Result is
993 if Nkind (Nod) = N_Procedure_Call_Statement then
995 -- Case of one of the detected recursive calls
997 if Is_Entity_Name (Name (Nod))
998 and then Has_Recursive_Call (Entity (Name (Nod)))
999 and then Entity (Name (Nod)) = Spec
1001 Append_Elmt (Nod, Call_List);
1004 -- Any other procedure call may have side effects
1010 -- A call to a pure function can always be ignored
1012 elsif Nkind (Nod) = N_Function_Call
1013 and then Is_Entity_Name (Name (Nod))
1014 and then Is_Pure (Entity (Name (Nod)))
1018 -- Case of an identifier reference
1020 elsif Nkind (Nod) = N_Identifier then
1021 Ent := Entity (Nod);
1023 -- If no entity, then ignore the reference
1025 -- Not clear why this can happen. To investigate, remove this
1026 -- test and look at the crash that occurs here in 3401-004 ???
1031 -- Ignore entities with no Scope, again not clear how this
1032 -- can happen, to investigate, look at 4108-008 ???
1034 elsif No (Scope (Ent)) then
1037 -- Ignore the reference if not to a more global object
1039 elsif Scope_Depth (Scope (Ent)) >= Scop then
1042 -- References to types, exceptions and constants are always OK
1045 or else Ekind (Ent) = E_Exception
1046 or else Ekind (Ent) = E_Constant
1050 -- If other than a non-volatile scalar variable, we have some
1051 -- kind of global reference (e.g. to a function) that we cannot
1052 -- deal with so we forget the attempt.
1054 elsif Ekind (Ent) /= E_Variable
1055 or else not Is_Scalar_Type (Etype (Ent))
1056 or else Treat_As_Volatile (Ent)
1060 -- Otherwise we have a reference to a global scalar
1063 -- Loop through global entities already detected
1065 Elm := First_Elmt (Var_List);
1067 -- If not detected before, record this new global reference
1070 Count_Vars := Count_Vars + 1;
1072 if Count_Vars <= Max_Vars then
1073 Append_Elmt (Entity (Nod), Var_List);
1080 -- If recorded before, ignore
1082 elsif Node (Elm) = Entity (Nod) then
1085 -- Otherwise keep looking
1095 -- For all other node kinds, recursively visit syntactic children
1102 function Traverse_Body is new Traverse_Func (Process);
1104 -- Start of processing for Detect_Infinite_Recursion
1107 -- Do not attempt detection in No_Implicit_Conditional mode, since we
1108 -- won't be able to generate the code to handle the recursion in any
1111 if Restriction_Active (No_Implicit_Conditionals) then
1115 -- Otherwise do traversal and quit if we get abandon signal
1117 if Traverse_Body (N) = Abandon then
1120 -- We must have a call, since Has_Recursive_Call was set. If not just
1121 -- ignore (this is only an error check, so if we have a funny situation,
1122 -- due to bugs or errors, we do not want to bomb).
1124 elsif Is_Empty_Elmt_List (Call_List) then
1128 -- Here is the case where we detect recursion at compile time
1130 -- Push our current scope for analyzing the declarations and code that
1131 -- we will insert for the checking.
1135 -- This loop builds temporary variables for each of the referenced
1136 -- globals, so that at the end of the loop the list Shad_List contains
1137 -- these temporaries in one-to-one correspondence with the elements in
1141 Elm := First_Elmt (Var_List);
1142 while Present (Elm) loop
1144 Ent := Make_Temporary (Loc, 'S');
1145 Append_Elmt (Ent, Shad_List);
1147 -- Insert a declaration for this temporary at the start of the
1148 -- declarations for the procedure. The temporaries are declared as
1149 -- constant objects initialized to the current values of the
1150 -- corresponding temporaries.
1153 Make_Object_Declaration (Loc,
1154 Defining_Identifier => Ent,
1155 Object_Definition => New_Occurrence_Of (Etype (Var), Loc),
1156 Constant_Present => True,
1157 Expression => New_Occurrence_Of (Var, Loc));
1160 Prepend (Decl, Declarations (N));
1162 Insert_After (Last, Decl);
1170 -- Loop through calls
1172 Call := First_Elmt (Call_List);
1173 while Present (Call) loop
1175 -- Build a predicate expression of the form
1178 -- and then global1 = temp1
1179 -- and then global2 = temp2
1182 -- This predicate determines if any of the global values
1183 -- referenced by the procedure have changed since the
1184 -- current call, if not an infinite recursion is assured.
1186 Test := New_Occurrence_Of (Standard_True, Loc);
1188 Elm1 := First_Elmt (Var_List);
1189 Elm2 := First_Elmt (Shad_List);
1190 while Present (Elm1) loop
1196 Left_Opnd => New_Occurrence_Of (Node (Elm1), Loc),
1197 Right_Opnd => New_Occurrence_Of (Node (Elm2), Loc)));
1203 -- Now we replace the call with the sequence
1205 -- if no-changes (see above) then
1206 -- raise Storage_Error;
1211 Rewrite (Node (Call),
1212 Make_If_Statement (Loc,
1214 Then_Statements => New_List (
1215 Make_Raise_Storage_Error (Loc,
1216 Reason => SE_Infinite_Recursion)),
1218 Else_Statements => New_List (
1219 Relocate_Node (Node (Call)))));
1221 Analyze (Node (Call));
1226 -- Remove temporary scope stack entry used for analysis
1229 end Detect_Infinite_Recursion;
1231 --------------------
1232 -- Expand_Actuals --
1233 --------------------
1235 procedure Expand_Actuals
1238 Post_Call : out List_Id)
1240 Loc : constant Source_Ptr := Sloc (N);
1244 E_Actual : Entity_Id;
1245 E_Formal : Entity_Id;
1247 procedure Add_Call_By_Copy_Code;
1248 -- For cases where the parameter must be passed by copy, this routine
1249 -- generates a temporary variable into which the actual is copied and
1250 -- then passes this as the parameter. For an OUT or IN OUT parameter,
1251 -- an assignment is also generated to copy the result back. The call
1252 -- also takes care of any constraint checks required for the type
1253 -- conversion case (on both the way in and the way out).
1255 procedure Add_Simple_Call_By_Copy_Code (Bit_Packed_Array : Boolean);
1256 -- This is similar to the above, but is used in cases where we know
1257 -- that all that is needed is to simply create a temporary and copy
1258 -- the value in and out of the temporary. If Bit_Packed_Array is True,
1259 -- the procedure is called for a bit-packed array actual.
1261 procedure Add_Validation_Call_By_Copy_Code (Act : Node_Id);
1262 -- Perform copy-back for actual parameter Act which denotes a validation
1265 procedure Check_Fortran_Logical;
1266 -- A value of type Logical that is passed through a formal parameter
1267 -- must be normalized because .TRUE. usually does not have the same
1268 -- representation as True. We assume that .FALSE. = False = 0.
1269 -- What about functions that return a logical type ???
1271 function Is_Legal_Copy return Boolean;
1272 -- Check that an actual can be copied before generating the temporary
1273 -- to be used in the call. If the formal is of a by_reference type or
1274 -- is aliased, then the program is illegal (this can only happen in
1275 -- the presence of representation clauses that force a misalignment)
1276 -- If the formal is a by_reference parameter imposed by a DEC pragma,
1277 -- emit a warning that this might lead to unaligned arguments.
1279 function Make_Var (Actual : Node_Id) return Entity_Id;
1280 -- Returns an entity that refers to the given actual parameter, Actual
1281 -- (not including any type conversion). If Actual is an entity name,
1282 -- then this entity is returned unchanged, otherwise a renaming is
1283 -- created to provide an entity for the actual.
1285 procedure Reset_Packed_Prefix;
1286 -- The expansion of a packed array component reference is delayed in
1287 -- the context of a call. Now we need to complete the expansion, so we
1288 -- unmark the analyzed bits in all prefixes.
1290 function Requires_Atomic_Or_Volatile_Copy return Boolean;
1291 -- Returns whether a copy is required as per RM C.6(19) and gives a
1292 -- warning in this case.
1294 ---------------------------
1295 -- Add_Call_By_Copy_Code --
1296 ---------------------------
1298 procedure Add_Call_By_Copy_Code is
1301 F_Typ : Entity_Id := Etype (Formal);
1309 if not Is_Legal_Copy then
1313 Temp := Make_Temporary (Loc, 'T', Actual);
1315 -- Handle formals whose type comes from the limited view
1317 if From_Limited_With (F_Typ)
1318 and then Has_Non_Limited_View (F_Typ)
1320 F_Typ := Non_Limited_View (F_Typ);
1323 -- Use formal type for temp, unless formal type is an unconstrained
1324 -- array, in which case we don't have to worry about bounds checks,
1325 -- and we use the actual type, since that has appropriate bounds.
1327 if Is_Array_Type (F_Typ) and then not Is_Constrained (F_Typ) then
1328 Indic := New_Occurrence_Of (Etype (Actual), Loc);
1330 Indic := New_Occurrence_Of (F_Typ, Loc);
1333 -- The new code will be properly analyzed below and the setting of
1334 -- the Do_Range_Check flag recomputed so remove the obsolete one.
1336 Set_Do_Range_Check (Actual, False);
1338 if Nkind (Actual) = N_Type_Conversion then
1339 Set_Do_Range_Check (Expression (Actual), False);
1341 V_Typ := Etype (Expression (Actual));
1343 -- If the formal is an (in-)out parameter, capture the name
1344 -- of the variable in order to build the post-call assignment.
1346 Var := Make_Var (Expression (Actual));
1348 Crep := not Same_Representation
1349 (F_Typ, Etype (Expression (Actual)));
1352 V_Typ := Etype (Actual);
1353 Var := Make_Var (Actual);
1357 -- Setup initialization for case of in out parameter, or an out
1358 -- parameter where the formal is an unconstrained array (in the
1359 -- latter case, we have to pass in an object with bounds).
1361 -- If this is an out parameter, the initial copy is wasteful, so as
1362 -- an optimization for the one-dimensional case we extract the
1363 -- bounds of the actual and build an uninitialized temporary of the
1366 -- If the formal is an out parameter with discriminants, the
1367 -- discriminants must be captured even if the rest of the object
1368 -- is in principle uninitialized, because the discriminants may
1369 -- be read by the called subprogram.
1371 if Ekind (Formal) = E_In_Out_Parameter
1372 or else (Is_Array_Type (F_Typ) and then not Is_Constrained (F_Typ))
1373 or else Has_Discriminants (F_Typ)
1375 if Nkind (Actual) = N_Type_Conversion then
1376 if Conversion_OK (Actual) then
1377 Init := OK_Convert_To (F_Typ, New_Occurrence_Of (Var, Loc));
1379 Init := Convert_To (F_Typ, New_Occurrence_Of (Var, Loc));
1382 elsif Ekind (Formal) = E_Out_Parameter
1383 and then Is_Array_Type (F_Typ)
1384 and then Number_Dimensions (F_Typ) = 1
1385 and then not Has_Non_Null_Base_Init_Proc (F_Typ)
1387 -- Actual is a one-dimensional array or slice, and the type
1388 -- requires no initialization. Create a temporary of the
1389 -- right size, but do not copy actual into it (optimization).
1393 Make_Subtype_Indication (Loc,
1394 Subtype_Mark => New_Occurrence_Of (F_Typ, Loc),
1396 Make_Index_Or_Discriminant_Constraint (Loc,
1397 Constraints => New_List (
1400 Make_Attribute_Reference (Loc,
1401 Prefix => New_Occurrence_Of (Var, Loc),
1402 Attribute_Name => Name_First),
1404 Make_Attribute_Reference (Loc,
1405 Prefix => New_Occurrence_Of (Var, Loc),
1406 Attribute_Name => Name_Last)))));
1409 Init := New_Occurrence_Of (Var, Loc);
1412 -- An initialization is created for packed conversions as
1413 -- actuals for out parameters to enable Make_Object_Declaration
1414 -- to determine the proper subtype for N_Node. Note that this
1415 -- is wasteful because the extra copying on the call side is
1416 -- not required for such out parameters. ???
1418 elsif Ekind (Formal) = E_Out_Parameter
1419 and then Nkind (Actual) = N_Type_Conversion
1420 and then (Is_Bit_Packed_Array (F_Typ)
1422 Is_Bit_Packed_Array (Etype (Expression (Actual))))
1424 if Conversion_OK (Actual) then
1425 Init := OK_Convert_To (F_Typ, New_Occurrence_Of (Var, Loc));
1427 Init := Convert_To (F_Typ, New_Occurrence_Of (Var, Loc));
1430 elsif Ekind (Formal) = E_In_Parameter then
1432 -- Handle the case in which the actual is a type conversion
1434 if Nkind (Actual) = N_Type_Conversion then
1435 if Conversion_OK (Actual) then
1436 Init := OK_Convert_To (F_Typ, New_Occurrence_Of (Var, Loc));
1438 Init := Convert_To (F_Typ, New_Occurrence_Of (Var, Loc));
1441 Init := New_Occurrence_Of (Var, Loc);
1444 -- Access types are passed in without checks, but if a copy-back is
1445 -- required for a null-excluding check on an in-out or out parameter,
1446 -- then the initial value is that of the actual.
1448 elsif Is_Access_Type (E_Formal)
1449 and then Can_Never_Be_Null (Etype (Actual))
1450 and then not Can_Never_Be_Null (E_Formal)
1452 Init := New_Occurrence_Of (Var, Loc);
1459 Make_Object_Declaration (Loc,
1460 Defining_Identifier => Temp,
1461 Object_Definition => Indic,
1462 Expression => Init);
1463 Set_Assignment_OK (N_Node);
1464 Insert_Action (N, N_Node);
1466 -- Now, normally the deal here is that we use the defining
1467 -- identifier created by that object declaration. There is
1468 -- one exception to this. In the change of representation case
1469 -- the above declaration will end up looking like:
1471 -- temp : type := identifier;
1473 -- And in this case we might as well use the identifier directly
1474 -- and eliminate the temporary. Note that the analysis of the
1475 -- declaration was not a waste of time in that case, since it is
1476 -- what generated the necessary change of representation code. If
1477 -- the change of representation introduced additional code, as in
1478 -- a fixed-integer conversion, the expression is not an identifier
1479 -- and must be kept.
1482 and then Present (Expression (N_Node))
1483 and then Is_Entity_Name (Expression (N_Node))
1485 Temp := Entity (Expression (N_Node));
1486 Rewrite (N_Node, Make_Null_Statement (Loc));
1489 -- For IN parameter, all we do is to replace the actual
1491 if Ekind (Formal) = E_In_Parameter then
1492 Rewrite (Actual, New_Occurrence_Of (Temp, Loc));
1495 -- Processing for OUT or IN OUT parameter
1498 -- Kill current value indications for the temporary variable we
1499 -- created, since we just passed it as an OUT parameter.
1501 Kill_Current_Values (Temp);
1502 Set_Is_Known_Valid (Temp, False);
1503 Set_Is_True_Constant (Temp, False);
1505 -- If type conversion, use reverse conversion on exit
1507 if Nkind (Actual) = N_Type_Conversion then
1508 if Conversion_OK (Actual) then
1509 Expr := OK_Convert_To (V_Typ, New_Occurrence_Of (Temp, Loc));
1511 Expr := Convert_To (V_Typ, New_Occurrence_Of (Temp, Loc));
1514 Expr := New_Occurrence_Of (Temp, Loc);
1517 Rewrite (Actual, New_Occurrence_Of (Temp, Loc));
1520 -- If the actual is a conversion of a packed reference, it may
1521 -- already have been expanded by Remove_Side_Effects, and the
1522 -- resulting variable is a temporary which does not designate
1523 -- the proper out-parameter, which may not be addressable. In
1524 -- that case, generate an assignment to the original expression
1525 -- (before expansion of the packed reference) so that the proper
1526 -- expansion of assignment to a packed component can take place.
1533 if Is_Renaming_Of_Object (Var)
1534 and then Nkind (Renamed_Object (Var)) = N_Selected_Component
1535 and then Nkind (Original_Node (Prefix (Renamed_Object (Var))))
1536 = N_Indexed_Component
1538 Has_Non_Standard_Rep (Etype (Prefix (Renamed_Object (Var))))
1540 Obj := Renamed_Object (Var);
1542 Make_Selected_Component (Loc,
1544 New_Copy_Tree (Original_Node (Prefix (Obj))),
1545 Selector_Name => New_Copy (Selector_Name (Obj)));
1546 Reset_Analyzed_Flags (Lhs);
1549 Lhs := New_Occurrence_Of (Var, Loc);
1552 Set_Assignment_OK (Lhs);
1554 if Is_Access_Type (E_Formal)
1555 and then Is_Entity_Name (Lhs)
1557 Present (Effective_Extra_Accessibility (Entity (Lhs)))
1559 -- Copyback target is an Ada 2012 stand-alone object of an
1560 -- anonymous access type.
1562 pragma Assert (Ada_Version >= Ada_2012);
1564 if Type_Access_Level (E_Formal) >
1565 Object_Access_Level (Lhs)
1567 Append_To (Post_Call,
1568 Make_Raise_Program_Error (Loc,
1569 Reason => PE_Accessibility_Check_Failed));
1572 Append_To (Post_Call,
1573 Make_Assignment_Statement (Loc,
1575 Expression => Expr));
1577 -- We would like to somehow suppress generation of the
1578 -- extra_accessibility assignment generated by the expansion
1579 -- of the above assignment statement. It's not a correctness
1580 -- issue because the following assignment renders it dead,
1581 -- but generating back-to-back assignments to the same
1582 -- target is undesirable. ???
1584 Append_To (Post_Call,
1585 Make_Assignment_Statement (Loc,
1586 Name => New_Occurrence_Of (
1587 Effective_Extra_Accessibility (Entity (Lhs)), Loc),
1588 Expression => Make_Integer_Literal (Loc,
1589 Type_Access_Level (E_Formal))));
1592 if Is_Access_Type (E_Formal)
1593 and then Can_Never_Be_Null (Etype (Actual))
1594 and then not Can_Never_Be_Null (E_Formal)
1596 Append_To (Post_Call,
1597 Make_Raise_Constraint_Error (Loc,
1600 Left_Opnd => New_Occurrence_Of (Temp, Loc),
1601 Right_Opnd => Make_Null (Loc)),
1602 Reason => CE_Access_Check_Failed));
1605 Append_To (Post_Call,
1606 Make_Assignment_Statement (Loc,
1608 Expression => Expr));
1612 end Add_Call_By_Copy_Code;
1614 ----------------------------------
1615 -- Add_Simple_Call_By_Copy_Code --
1616 ----------------------------------
1618 procedure Add_Simple_Call_By_Copy_Code (Bit_Packed_Array : Boolean) is
1620 F_Typ : Entity_Id := Etype (Formal);
1629 -- ??? We need to do the copy for a bit-packed array because this is
1630 -- where the rewriting into a mask-and-shift sequence is done. But of
1631 -- course this may break the program if it expects bits to be really
1632 -- passed by reference. That's what we have done historically though.
1634 if not Bit_Packed_Array and then not Is_Legal_Copy then
1638 -- Handle formals whose type comes from the limited view
1640 if From_Limited_With (F_Typ)
1641 and then Has_Non_Limited_View (F_Typ)
1643 F_Typ := Non_Limited_View (F_Typ);
1646 -- Use formal type for temp, unless formal type is an unconstrained
1647 -- array, in which case we don't have to worry about bounds checks,
1648 -- and we use the actual type, since that has appropriate bounds.
1650 if Is_Array_Type (F_Typ) and then not Is_Constrained (F_Typ) then
1651 Indic := New_Occurrence_Of (Etype (Actual), Loc);
1653 Indic := New_Occurrence_Of (F_Typ, Loc);
1656 -- Prepare to generate code
1658 Reset_Packed_Prefix;
1660 Temp := Make_Temporary (Loc, 'T', Actual);
1661 Incod := Relocate_Node (Actual);
1662 Outcod := New_Copy_Tree (Incod);
1664 -- Generate declaration of temporary variable, initializing it
1665 -- with the input parameter unless we have an OUT formal or
1666 -- this is an initialization call.
1668 -- If the formal is an out parameter with discriminants, the
1669 -- discriminants must be captured even if the rest of the object
1670 -- is in principle uninitialized, because the discriminants may
1671 -- be read by the called subprogram.
1673 if Ekind (Formal) = E_Out_Parameter then
1676 if Has_Discriminants (F_Typ) then
1677 Indic := New_Occurrence_Of (Etype (Actual), Loc);
1680 elsif Inside_Init_Proc then
1682 -- Could use a comment here to match comment below ???
1684 if Nkind (Actual) /= N_Selected_Component
1686 not Has_Discriminant_Dependent_Constraint
1687 (Entity (Selector_Name (Actual)))
1691 -- Otherwise, keep the component in order to generate the proper
1692 -- actual subtype, that depends on enclosing discriminants.
1700 Make_Object_Declaration (Loc,
1701 Defining_Identifier => Temp,
1702 Object_Definition => Indic,
1703 Expression => Incod);
1708 -- If the call is to initialize a component of a composite type,
1709 -- and the component does not depend on discriminants, use the
1710 -- actual type of the component. This is required in case the
1711 -- component is constrained, because in general the formal of the
1712 -- initialization procedure will be unconstrained. Note that if
1713 -- the component being initialized is constrained by an enclosing
1714 -- discriminant, the presence of the initialization in the
1715 -- declaration will generate an expression for the actual subtype.
1717 Set_No_Initialization (Decl);
1718 Set_Object_Definition (Decl,
1719 New_Occurrence_Of (Etype (Actual), Loc));
1722 Insert_Action (N, Decl);
1724 -- The actual is simply a reference to the temporary
1726 Rewrite (Actual, New_Occurrence_Of (Temp, Loc));
1728 -- Generate copy out if OUT or IN OUT parameter
1730 if Ekind (Formal) /= E_In_Parameter then
1732 Rhs := New_Occurrence_Of (Temp, Loc);
1733 Set_Is_True_Constant (Temp, False);
1735 -- Deal with conversion
1737 if Nkind (Lhs) = N_Type_Conversion then
1738 Lhs := Expression (Lhs);
1739 Rhs := Convert_To (Etype (Actual), Rhs);
1742 Append_To (Post_Call,
1743 Make_Assignment_Statement (Loc,
1745 Expression => Rhs));
1746 Set_Assignment_OK (Name (Last (Post_Call)));
1748 end Add_Simple_Call_By_Copy_Code;
1750 --------------------------------------
1751 -- Add_Validation_Call_By_Copy_Code --
1752 --------------------------------------
1754 procedure Add_Validation_Call_By_Copy_Code (Act : Node_Id) is
1757 Obj_Typ : Entity_Id;
1758 Var : constant Node_Id := Unqual_Conv (Act);
1762 -- Generate range check if required
1764 if Do_Range_Check (Actual) then
1765 Generate_Range_Check (Actual, E_Formal, CE_Range_Check_Failed);
1768 -- If there is a type conversion in the actual, it will be reinstated
1769 -- below, the new instance will be properly analyzed and the setting
1770 -- of the Do_Range_Check flag recomputed so remove the obsolete one.
1772 if Nkind (Actual) = N_Type_Conversion then
1773 Set_Do_Range_Check (Expression (Actual), False);
1776 -- Copy the value of the validation variable back into the object
1779 if Is_Entity_Name (Var) then
1780 Var_Id := Entity (Var);
1781 Obj := Validated_Object (Var_Id);
1782 Obj_Typ := Etype (Obj);
1784 Expr := New_Occurrence_Of (Var_Id, Loc);
1786 -- A type conversion is needed when the validation variable and
1787 -- the validated object carry different types. This case occurs
1788 -- when the actual is qualified in some fashion.
1791 -- subtype Int is Integer range ...;
1792 -- procedure Call (Val : in out Integer);
1796 -- Call (Integer (Object));
1800 -- Var : Integer := Object; -- conversion to base type
1801 -- if not Var'Valid then -- validity check
1802 -- Call (Var); -- modify Var
1803 -- Object := Int (Var); -- conversion to subtype
1805 if Etype (Var_Id) /= Obj_Typ then
1807 Make_Type_Conversion (Loc,
1808 Subtype_Mark => New_Occurrence_Of (Obj_Typ, Loc),
1809 Expression => Expr);
1815 -- Object := Object_Type (Var);
1817 Append_To (Post_Call,
1818 Make_Assignment_Statement (Loc,
1820 Expression => Expr));
1822 -- If the flow reaches this point, then this routine was invoked with
1823 -- an actual which does not denote a validation variable.
1826 pragma Assert (False);
1829 end Add_Validation_Call_By_Copy_Code;
1831 ---------------------------
1832 -- Check_Fortran_Logical --
1833 ---------------------------
1835 procedure Check_Fortran_Logical is
1836 Logical : constant Entity_Id := Etype (Formal);
1839 -- Note: this is very incomplete, e.g. it does not handle arrays
1840 -- of logical values. This is really not the right approach at all???)
1843 if Convention (Subp) = Convention_Fortran
1844 and then Root_Type (Etype (Formal)) = Standard_Boolean
1845 and then Ekind (Formal) /= E_In_Parameter
1847 Var := Make_Var (Actual);
1848 Append_To (Post_Call,
1849 Make_Assignment_Statement (Loc,
1850 Name => New_Occurrence_Of (Var, Loc),
1852 Unchecked_Convert_To (
1855 Left_Opnd => New_Occurrence_Of (Var, Loc),
1857 Unchecked_Convert_To (
1859 New_Occurrence_Of (Standard_False, Loc))))));
1861 end Check_Fortran_Logical;
1867 function Is_Legal_Copy return Boolean is
1869 -- An attempt to copy a value of such a type can only occur if
1870 -- representation clauses give the actual a misaligned address.
1872 if Is_By_Reference_Type (Etype (Formal))
1873 or else Is_Aliased (Formal)
1874 or else (Mechanism (Formal) = By_Reference
1875 and then not Has_Foreign_Convention (Subp))
1878 -- The actual may in fact be properly aligned but there is not
1879 -- enough front-end information to determine this. In that case
1880 -- gigi will emit an error or a warning if a copy is not legal,
1881 -- or generate the proper code.
1885 -- For users of Starlet, we assume that the specification of by-
1886 -- reference mechanism is mandatory. This may lead to unaligned
1887 -- objects but at least for DEC legacy code it is known to work.
1888 -- The warning will alert users of this code that a problem may
1891 elsif Mechanism (Formal) = By_Reference
1892 and then Ekind (Scope (Formal)) = E_Procedure
1893 and then Is_Valued_Procedure (Scope (Formal))
1896 ("by_reference actual may be misaligned??", Actual);
1908 function Make_Var (Actual : Node_Id) return Entity_Id is
1912 if Is_Entity_Name (Actual) then
1913 return Entity (Actual);
1916 Var := Make_Temporary (Loc, 'T', Actual);
1919 Make_Object_Renaming_Declaration (Loc,
1920 Defining_Identifier => Var,
1922 New_Occurrence_Of (Etype (Actual), Loc),
1923 Name => Relocate_Node (Actual));
1925 Insert_Action (N, N_Node);
1930 -------------------------
1931 -- Reset_Packed_Prefix --
1932 -------------------------
1934 procedure Reset_Packed_Prefix is
1935 Pfx : Node_Id := Actual;
1938 Set_Analyzed (Pfx, False);
1940 not Nkind_In (Pfx, N_Selected_Component, N_Indexed_Component);
1941 Pfx := Prefix (Pfx);
1943 end Reset_Packed_Prefix;
1945 ----------------------------------------
1946 -- Requires_Atomic_Or_Volatile_Copy --
1947 ----------------------------------------
1949 function Requires_Atomic_Or_Volatile_Copy return Boolean is
1951 -- If the formal is already passed by copy, no need to do anything
1953 if Is_By_Copy_Type (E_Formal) then
1957 -- Check for atomicity mismatch
1959 if Is_Atomic_Object (Actual) and then not Is_Atomic (E_Formal)
1961 if Comes_From_Source (N) then
1963 ("?atomic actual passed by copy (RM C.6(19))", Actual);
1968 -- Check for volatility mismatch
1970 if Is_Volatile_Object (Actual) and then not Is_Volatile (E_Formal)
1972 if Comes_From_Source (N) then
1974 ("?volatile actual passed by copy (RM C.6(19))", Actual);
1980 end Requires_Atomic_Or_Volatile_Copy;
1982 -- Start of processing for Expand_Actuals
1985 Post_Call := New_List;
1987 Formal := First_Formal (Subp);
1988 Actual := First_Actual (N);
1989 while Present (Formal) loop
1990 E_Formal := Etype (Formal);
1991 E_Actual := Etype (Actual);
1993 -- Handle formals whose type comes from the limited view
1995 if From_Limited_With (E_Formal)
1996 and then Has_Non_Limited_View (E_Formal)
1998 E_Formal := Non_Limited_View (E_Formal);
2001 if Is_Scalar_Type (E_Formal)
2002 or else Nkind (Actual) = N_Slice
2004 Check_Fortran_Logical;
2008 elsif Ekind (Formal) /= E_Out_Parameter then
2010 -- The unusual case of the current instance of a protected type
2011 -- requires special handling. This can only occur in the context
2012 -- of a call within the body of a protected operation.
2014 if Is_Entity_Name (Actual)
2015 and then Ekind (Entity (Actual)) = E_Protected_Type
2016 and then In_Open_Scopes (Entity (Actual))
2018 if Scope (Subp) /= Entity (Actual) then
2020 ("operation outside protected type may not "
2021 & "call back its protected operations??", Actual);
2025 Expand_Protected_Object_Reference (N, Entity (Actual)));
2028 -- Ada 2005 (AI-318-02): If the actual parameter is a call to a
2029 -- build-in-place function, then a temporary return object needs
2030 -- to be created and access to it must be passed to the function.
2031 -- Currently we limit such functions to those with inherently
2032 -- limited result subtypes, but eventually we plan to expand the
2033 -- functions that are treated as build-in-place to include other
2034 -- composite result types.
2036 if Is_Build_In_Place_Function_Call (Actual) then
2037 Make_Build_In_Place_Call_In_Anonymous_Context (Actual);
2039 -- Ada 2005 (AI-318-02): Specialization of the previous case for
2040 -- actuals containing build-in-place function calls whose returned
2041 -- object covers interface types.
2043 elsif Present (Unqual_BIP_Iface_Function_Call (Actual)) then
2044 Make_Build_In_Place_Iface_Call_In_Anonymous_Context (Actual);
2047 Apply_Constraint_Check (Actual, E_Formal);
2049 -- Out parameter case. No constraint checks on access type
2050 -- RM 6.4.1 (13), but on return a null-excluding check may be
2051 -- required (see below).
2053 elsif Is_Access_Type (E_Formal) then
2058 elsif Has_Discriminants (Base_Type (E_Formal))
2059 or else Has_Non_Null_Base_Init_Proc (E_Formal)
2061 Apply_Constraint_Check (Actual, E_Formal);
2066 Apply_Constraint_Check (Actual, Base_Type (E_Formal));
2069 -- Processing for IN-OUT and OUT parameters
2071 if Ekind (Formal) /= E_In_Parameter then
2073 -- For type conversions of arrays, apply length/range checks
2075 if Is_Array_Type (E_Formal)
2076 and then Nkind (Actual) = N_Type_Conversion
2078 if Is_Constrained (E_Formal) then
2079 Apply_Length_Check (Expression (Actual), E_Formal);
2081 Apply_Range_Check (Expression (Actual), E_Formal);
2085 -- The actual denotes a variable which captures the value of an
2086 -- object for validation purposes. Add a copy-back to reflect any
2087 -- potential changes in value back into the original object.
2089 -- Var : ... := Object;
2090 -- if not Var'Valid then -- validity check
2091 -- Call (Var); -- modify var
2092 -- Object := Var; -- update Object
2094 -- This case is given higher priority because the subsequent check
2095 -- for type conversion may add an extra copy of the variable and
2096 -- prevent proper value propagation back in the original object.
2098 if Is_Validation_Variable_Reference (Actual) then
2099 Add_Validation_Call_By_Copy_Code (Actual);
2101 -- If argument is a type conversion for a type that is passed by
2102 -- copy, then we must pass the parameter by copy.
2104 elsif Nkind (Actual) = N_Type_Conversion
2106 (Is_Numeric_Type (E_Formal)
2107 or else Is_Access_Type (E_Formal)
2108 or else Is_Enumeration_Type (E_Formal)
2109 or else Is_Bit_Packed_Array (Etype (Formal))
2110 or else Is_Bit_Packed_Array (Etype (Expression (Actual)))
2112 -- Also pass by copy if change of representation
2114 or else not Same_Representation
2116 Etype (Expression (Actual))))
2118 Add_Call_By_Copy_Code;
2120 -- References to components of bit-packed arrays are expanded
2121 -- at this point, rather than at the point of analysis of the
2122 -- actuals, to handle the expansion of the assignment to
2123 -- [in] out parameters.
2125 elsif Is_Ref_To_Bit_Packed_Array (Actual) then
2126 Add_Simple_Call_By_Copy_Code (Bit_Packed_Array => True);
2128 -- If a nonscalar actual is possibly bit-aligned, we need a copy
2129 -- because the back-end cannot cope with such objects. In other
2130 -- cases where alignment forces a copy, the back-end generates
2131 -- it properly. It should not be generated unconditionally in the
2132 -- front-end because it does not know precisely the alignment
2133 -- requirements of the target, and makes too conservative an
2134 -- estimate, leading to superfluous copies or spurious errors
2135 -- on by-reference parameters.
2137 elsif Nkind (Actual) = N_Selected_Component
2139 Component_May_Be_Bit_Aligned (Entity (Selector_Name (Actual)))
2140 and then not Represented_As_Scalar (Etype (Formal))
2142 Add_Simple_Call_By_Copy_Code (Bit_Packed_Array => False);
2144 -- References to slices of bit-packed arrays are expanded
2146 elsif Is_Ref_To_Bit_Packed_Slice (Actual) then
2147 Add_Call_By_Copy_Code;
2149 -- References to possibly unaligned slices of arrays are expanded
2151 elsif Is_Possibly_Unaligned_Slice (Actual) then
2152 Add_Call_By_Copy_Code;
2154 -- Deal with access types where the actual subtype and the
2155 -- formal subtype are not the same, requiring a check.
2157 -- It is necessary to exclude tagged types because of "downward
2158 -- conversion" errors, but null-excluding checks on return may be
2161 elsif Is_Access_Type (E_Formal)
2162 and then not Is_Tagged_Type (Designated_Type (E_Formal))
2163 and then (not Same_Type (E_Formal, E_Actual)
2164 or else (Can_Never_Be_Null (E_Actual)
2165 and then not Can_Never_Be_Null (E_Formal)))
2167 Add_Call_By_Copy_Code;
2169 -- We may need to force a copy because of atomicity or volatility
2172 elsif Requires_Atomic_Or_Volatile_Copy then
2173 Add_Call_By_Copy_Code;
2175 -- Add call-by-copy code for the case of scalar out parameters
2176 -- when it is not known at compile time that the subtype of the
2177 -- formal is a subrange of the subtype of the actual (or vice
2178 -- versa for in out parameters), in order to get range checks
2179 -- on such actuals. (Maybe this case should be handled earlier
2180 -- in the if statement???)
2182 elsif Is_Scalar_Type (E_Formal)
2184 (not In_Subrange_Of (E_Formal, E_Actual)
2186 (Ekind (Formal) = E_In_Out_Parameter
2187 and then not In_Subrange_Of (E_Actual, E_Formal)))
2189 Add_Call_By_Copy_Code;
2192 -- RM 3.2.4 (23/3): A predicate is checked on in-out and out
2193 -- by-reference parameters on exit from the call. If the actual
2194 -- is a derived type and the operation is inherited, the body
2195 -- of the operation will not contain a call to the predicate
2196 -- function, so it must be done explicitly after the call. Ditto
2197 -- if the actual is an entity of a predicated subtype.
2199 -- The rule refers to by-reference types, but a check is needed
2200 -- for by-copy types as well. That check is subsumed by the rule
2201 -- for subtype conversion on assignment, but we can generate the
2202 -- required check now.
2204 -- Note also that Subp may be either a subprogram entity for
2205 -- direct calls, or a type entity for indirect calls, which must
2206 -- be handled separately because the name does not denote an
2207 -- overloadable entity.
2209 By_Ref_Predicate_Check : declare
2210 Aund : constant Entity_Id := Underlying_Type (E_Actual);
2213 function Is_Public_Subp return Boolean;
2214 -- Check whether the subprogram being called is a visible
2215 -- operation of the type of the actual. Used to determine
2216 -- whether an invariant check must be generated on the
2219 ---------------------
2220 -- Is_Public_Subp --
2221 ---------------------
2223 function Is_Public_Subp return Boolean is
2224 Pack : constant Entity_Id := Scope (Subp);
2225 Subp_Decl : Node_Id;
2228 if not Is_Subprogram (Subp) then
2231 -- The operation may be inherited, or a primitive of the
2235 Nkind_In (Parent (Subp), N_Private_Extension_Declaration,
2236 N_Full_Type_Declaration)
2238 Subp_Decl := Parent (Subp);
2241 Subp_Decl := Unit_Declaration_Node (Subp);
2244 return Ekind (Pack) = E_Package
2246 List_Containing (Subp_Decl) =
2247 Visible_Declarations
2248 (Specification (Unit_Declaration_Node (Pack)));
2251 -- Start of processing for By_Ref_Predicate_Check
2260 if Has_Predicates (Atyp)
2261 and then Present (Predicate_Function (Atyp))
2263 -- Skip predicate checks for special cases
2265 and then Predicate_Tests_On_Arguments (Subp)
2267 Append_To (Post_Call,
2268 Make_Predicate_Check (Atyp, Actual));
2271 -- We generated caller-side invariant checks in two cases:
2273 -- a) when calling an inherited operation, where there is an
2274 -- implicit view conversion of the actual to the parent type.
2276 -- b) When the conversion is explicit
2278 -- We treat these cases separately because the required
2279 -- conversion for a) is added later when expanding the call.
2281 if Has_Invariants (Etype (Actual))
2283 Nkind (Parent (Subp)) = N_Private_Extension_Declaration
2285 if Comes_From_Source (N) and then Is_Public_Subp then
2286 Append_To (Post_Call, Make_Invariant_Call (Actual));
2289 elsif Nkind (Actual) = N_Type_Conversion
2290 and then Has_Invariants (Etype (Expression (Actual)))
2292 if Comes_From_Source (N) and then Is_Public_Subp then
2293 Append_To (Post_Call,
2294 Make_Invariant_Call (Expression (Actual)));
2297 end By_Ref_Predicate_Check;
2299 -- Processing for IN parameters
2302 -- Generate range check if required
2304 if Do_Range_Check (Actual) then
2305 Generate_Range_Check (Actual, E_Formal, CE_Range_Check_Failed);
2308 -- For IN parameters in the bit-packed array case, we expand an
2309 -- indexed component (the circuit in Exp_Ch4 deliberately left
2310 -- indexed components appearing as actuals untouched, so that
2311 -- the special processing above for the OUT and IN OUT cases
2312 -- could be performed. We could make the test in Exp_Ch4 more
2313 -- complex and have it detect the parameter mode, but it is
2314 -- easier simply to handle all cases here.)
2316 if Nkind (Actual) = N_Indexed_Component
2317 and then Is_Bit_Packed_Array (Etype (Prefix (Actual)))
2319 Reset_Packed_Prefix;
2320 Expand_Packed_Element_Reference (Actual);
2322 -- If we have a reference to a bit-packed array, we copy it, since
2323 -- the actual must be byte aligned.
2325 -- Is this really necessary in all cases???
2327 elsif Is_Ref_To_Bit_Packed_Array (Actual) then
2328 Add_Simple_Call_By_Copy_Code (Bit_Packed_Array => True);
2330 -- If a nonscalar actual is possibly unaligned, we need a copy
2332 elsif Is_Possibly_Unaligned_Object (Actual)
2333 and then not Represented_As_Scalar (Etype (Formal))
2335 Add_Simple_Call_By_Copy_Code (Bit_Packed_Array => False);
2337 -- Similarly, we have to expand slices of packed arrays here
2338 -- because the result must be byte aligned.
2340 elsif Is_Ref_To_Bit_Packed_Slice (Actual) then
2341 Add_Call_By_Copy_Code;
2343 -- Only processing remaining is to pass by copy if this is a
2344 -- reference to a possibly unaligned slice, since the caller
2345 -- expects an appropriately aligned argument.
2347 elsif Is_Possibly_Unaligned_Slice (Actual) then
2348 Add_Call_By_Copy_Code;
2350 -- We may need to force a copy because of atomicity or volatility
2353 elsif Requires_Atomic_Or_Volatile_Copy then
2354 Add_Call_By_Copy_Code;
2356 -- An unusual case: a current instance of an enclosing task can be
2357 -- an actual, and must be replaced by a reference to self.
2359 elsif Is_Entity_Name (Actual)
2360 and then Is_Task_Type (Entity (Actual))
2362 if In_Open_Scopes (Entity (Actual)) then
2364 (Make_Function_Call (Loc,
2365 Name => New_Occurrence_Of (RTE (RE_Self), Loc))));
2368 -- A task type cannot otherwise appear as an actual
2371 raise Program_Error;
2376 Next_Formal (Formal);
2377 Next_Actual (Actual);
2385 procedure Expand_Call (N : Node_Id) is
2386 Post_Call : List_Id;
2389 pragma Assert (Nkind_In (N, N_Entry_Call_Statement,
2391 N_Procedure_Call_Statement));
2393 Expand_Call_Helper (N, Post_Call);
2394 Insert_Post_Call_Actions (N, Post_Call);
2397 ------------------------
2398 -- Expand_Call_Helper --
2399 ------------------------
2401 -- This procedure handles expansion of function calls and procedure call
2402 -- statements (i.e. it serves as the body for Expand_N_Function_Call and
2403 -- Expand_N_Procedure_Call_Statement). Processing for calls includes:
2405 -- Replace call to Raise_Exception by Raise_Exception_Always if possible
2406 -- Provide values of actuals for all formals in Extra_Formals list
2407 -- Replace "call" to enumeration literal function by literal itself
2408 -- Rewrite call to predefined operator as operator
2409 -- Replace actuals to in-out parameters that are numeric conversions,
2410 -- with explicit assignment to temporaries before and after the call.
2412 -- Note that the list of actuals has been filled with default expressions
2413 -- during semantic analysis of the call. Only the extra actuals required
2414 -- for the 'Constrained attribute and for accessibility checks are added
2417 procedure Expand_Call_Helper (N : Node_Id; Post_Call : out List_Id) is
2418 Loc : constant Source_Ptr := Sloc (N);
2419 Call_Node : Node_Id := N;
2420 Extra_Actuals : List_Id := No_List;
2421 Prev : Node_Id := Empty;
2423 procedure Add_Actual_Parameter (Insert_Param : Node_Id);
2424 -- Adds one entry to the end of the actual parameter list. Used for
2425 -- default parameters and for extra actuals (for Extra_Formals). The
2426 -- argument is an N_Parameter_Association node.
2428 procedure Add_Extra_Actual (Expr : Node_Id; EF : Entity_Id);
2429 -- Adds an extra actual to the list of extra actuals. Expr is the
2430 -- expression for the value of the actual, EF is the entity for the
2433 procedure Add_View_Conversion_Invariants
2434 (Formal : Entity_Id;
2436 -- Adds invariant checks for every intermediate type between the range
2437 -- of a view converted argument to its ancestor (from parent to child).
2439 function Can_Fold_Predicate_Call (P : Entity_Id) return Boolean;
2440 -- Try to constant-fold a predicate check, which often enough is a
2441 -- simple arithmetic expression that can be computed statically if
2442 -- its argument is static. This cleans up the output of CCG, even
2443 -- though useless predicate checks will be generally removed by
2444 -- back-end optimizations.
2446 function Inherited_From_Formal (S : Entity_Id) return Entity_Id;
2447 -- Within an instance, a type derived from an untagged formal derived
2448 -- type inherits from the original parent, not from the actual. The
2449 -- current derivation mechanism has the derived type inherit from the
2450 -- actual, which is only correct outside of the instance. If the
2451 -- subprogram is inherited, we test for this particular case through a
2452 -- convoluted tree traversal before setting the proper subprogram to be
2455 function In_Unfrozen_Instance (E : Entity_Id) return Boolean;
2456 -- Return true if E comes from an instance that is not yet frozen
2458 function Is_Class_Wide_Interface_Type (E : Entity_Id) return Boolean;
2459 -- Return True when E is a class-wide interface type or an access to
2460 -- a class-wide interface type.
2462 function Is_Direct_Deep_Call (Subp : Entity_Id) return Boolean;
2463 -- Determine if Subp denotes a non-dispatching call to a Deep routine
2465 function New_Value (From : Node_Id) return Node_Id;
2466 -- From is the original Expression. New_Value is equivalent to a call
2467 -- to Duplicate_Subexpr with an explicit dereference when From is an
2468 -- access parameter.
2470 --------------------------
2471 -- Add_Actual_Parameter --
2472 --------------------------
2474 procedure Add_Actual_Parameter (Insert_Param : Node_Id) is
2475 Actual_Expr : constant Node_Id :=
2476 Explicit_Actual_Parameter (Insert_Param);
2479 -- Case of insertion is first named actual
2481 if No (Prev) or else
2482 Nkind (Parent (Prev)) /= N_Parameter_Association
2484 Set_Next_Named_Actual
2485 (Insert_Param, First_Named_Actual (Call_Node));
2486 Set_First_Named_Actual (Call_Node, Actual_Expr);
2489 if No (Parameter_Associations (Call_Node)) then
2490 Set_Parameter_Associations (Call_Node, New_List);
2493 Append (Insert_Param, Parameter_Associations (Call_Node));
2496 Insert_After (Prev, Insert_Param);
2499 -- Case of insertion is not first named actual
2502 Set_Next_Named_Actual
2503 (Insert_Param, Next_Named_Actual (Parent (Prev)));
2504 Set_Next_Named_Actual (Parent (Prev), Actual_Expr);
2505 Append (Insert_Param, Parameter_Associations (Call_Node));
2508 Prev := Actual_Expr;
2509 end Add_Actual_Parameter;
2511 ----------------------
2512 -- Add_Extra_Actual --
2513 ----------------------
2515 procedure Add_Extra_Actual (Expr : Node_Id; EF : Entity_Id) is
2516 Loc : constant Source_Ptr := Sloc (Expr);
2519 if Extra_Actuals = No_List then
2520 Extra_Actuals := New_List;
2521 Set_Parent (Extra_Actuals, Call_Node);
2524 Append_To (Extra_Actuals,
2525 Make_Parameter_Association (Loc,
2526 Selector_Name => New_Occurrence_Of (EF, Loc),
2527 Explicit_Actual_Parameter => Expr));
2529 Analyze_And_Resolve (Expr, Etype (EF));
2531 if Nkind (Call_Node) = N_Function_Call then
2532 Set_Is_Accessibility_Actual (Parent (Expr));
2534 end Add_Extra_Actual;
2536 ------------------------------------
2537 -- Add_View_Conversion_Invariants --
2538 ------------------------------------
2540 procedure Add_View_Conversion_Invariants
2541 (Formal : Entity_Id;
2545 Curr_Typ : Entity_Id;
2546 Inv_Checks : List_Id;
2547 Par_Typ : Entity_Id;
2550 Inv_Checks := No_List;
2552 -- Extract the argument from a potentially nested set of view
2556 while Nkind (Arg) = N_Type_Conversion loop
2557 Arg := Expression (Arg);
2560 -- Move up the derivation chain starting with the type of the formal
2561 -- parameter down to the type of the actual object.
2564 Par_Typ := Etype (Arg);
2565 while Par_Typ /= Etype (Formal) and Par_Typ /= Curr_Typ loop
2566 Curr_Typ := Par_Typ;
2568 if Has_Invariants (Curr_Typ)
2569 and then Present (Invariant_Procedure (Curr_Typ))
2571 -- Verify the invariate of the current type. Generate:
2573 -- <Curr_Typ>Invariant (Curr_Typ (Arg));
2575 Prepend_New_To (Inv_Checks,
2576 Make_Procedure_Call_Statement (Loc,
2579 (Invariant_Procedure (Curr_Typ), Loc),
2580 Parameter_Associations => New_List (
2581 Make_Type_Conversion (Loc,
2582 Subtype_Mark => New_Occurrence_Of (Curr_Typ, Loc),
2583 Expression => New_Copy_Tree (Arg)))));
2586 Par_Typ := Base_Type (Etype (Curr_Typ));
2589 if not Is_Empty_List (Inv_Checks) then
2590 Insert_Actions_After (N, Inv_Checks);
2592 end Add_View_Conversion_Invariants;
2594 -----------------------------
2595 -- Can_Fold_Predicate_Call --
2596 -----------------------------
2598 function Can_Fold_Predicate_Call (P : Entity_Id) return Boolean is
2601 function May_Fold (N : Node_Id) return Traverse_Result;
2602 -- The predicate expression is foldable if it only contains operators
2603 -- and literals. During this check, we also replace occurrences of
2604 -- the formal of the constructed predicate function with the static
2605 -- value of the actual. This is done on a copy of the analyzed
2606 -- expression for the predicate.
2612 function May_Fold (N : Node_Id) return Traverse_Result is
2620 when N_Expanded_Name
2623 if Ekind (Entity (N)) = E_In_Parameter
2624 and then Entity (N) = First_Entity (P)
2626 Rewrite (N, New_Copy (Actual));
2627 Set_Is_Static_Expression (N);
2630 elsif Ekind (Entity (N)) = E_Enumeration_Literal then
2637 when N_Case_Expression
2642 when N_Integer_Literal =>
2650 function Try_Fold is new Traverse_Func (May_Fold);
2652 -- Other lLocal variables
2654 Subt : constant Entity_Id := Etype (First_Entity (P));
2658 -- Start of processing for Can_Fold_Predicate_Call
2661 -- Folding is only interesting if the actual is static and its type
2662 -- has a Dynamic_Predicate aspect. For CodePeer we preserve the
2665 Actual := First (Parameter_Associations (Call_Node));
2666 Aspect := Find_Aspect (Subt, Aspect_Dynamic_Predicate);
2668 -- If actual is a declared constant, retrieve its value
2670 if Is_Entity_Name (Actual)
2671 and then Ekind (Entity (Actual)) = E_Constant
2673 Actual := Constant_Value (Entity (Actual));
2677 or else Nkind (Actual) /= N_Integer_Literal
2678 or else not Has_Dynamic_Predicate_Aspect (Subt)
2680 or else CodePeer_Mode
2685 -- Retrieve the analyzed expression for the predicate
2687 Pred := New_Copy_Tree (Expression (Aspect));
2689 if Try_Fold (Pred) = OK then
2690 Rewrite (Call_Node, Pred);
2691 Analyze_And_Resolve (Call_Node, Standard_Boolean);
2694 -- Otherwise continue the expansion of the function call
2699 end Can_Fold_Predicate_Call;
2701 ---------------------------
2702 -- Inherited_From_Formal --
2703 ---------------------------
2705 function Inherited_From_Formal (S : Entity_Id) return Entity_Id is
2707 Gen_Par : Entity_Id;
2708 Gen_Prim : Elist_Id;
2713 -- If the operation is inherited, it is attached to the corresponding
2714 -- type derivation. If the parent in the derivation is a generic
2715 -- actual, it is a subtype of the actual, and we have to recover the
2716 -- original derived type declaration to find the proper parent.
2718 if Nkind (Parent (S)) /= N_Full_Type_Declaration
2719 or else not Is_Derived_Type (Defining_Identifier (Parent (S)))
2720 or else Nkind (Type_Definition (Original_Node (Parent (S)))) /=
2721 N_Derived_Type_Definition
2722 or else not In_Instance
2729 (Type_Definition (Original_Node (Parent (S))));
2731 if Nkind (Indic) = N_Subtype_Indication then
2732 Par := Entity (Subtype_Mark (Indic));
2734 Par := Entity (Indic);
2738 if not Is_Generic_Actual_Type (Par)
2739 or else Is_Tagged_Type (Par)
2740 or else Nkind (Parent (Par)) /= N_Subtype_Declaration
2741 or else not In_Open_Scopes (Scope (Par))
2745 Gen_Par := Generic_Parent_Type (Parent (Par));
2748 -- If the actual has no generic parent type, the formal is not
2749 -- a formal derived type, so nothing to inherit.
2751 if No (Gen_Par) then
2755 -- If the generic parent type is still the generic type, this is a
2756 -- private formal, not a derived formal, and there are no operations
2757 -- inherited from the formal.
2759 if Nkind (Parent (Gen_Par)) = N_Formal_Type_Declaration then
2763 Gen_Prim := Collect_Primitive_Operations (Gen_Par);
2765 Elmt := First_Elmt (Gen_Prim);
2766 while Present (Elmt) loop
2767 if Chars (Node (Elmt)) = Chars (S) then
2773 F1 := First_Formal (S);
2774 F2 := First_Formal (Node (Elmt));
2776 and then Present (F2)
2778 if Etype (F1) = Etype (F2)
2779 or else Etype (F2) = Gen_Par
2785 exit; -- not the right subprogram
2797 raise Program_Error;
2798 end Inherited_From_Formal;
2800 --------------------------
2801 -- In_Unfrozen_Instance --
2802 --------------------------
2804 function In_Unfrozen_Instance (E : Entity_Id) return Boolean is
2809 while Present (S) and then S /= Standard_Standard loop
2810 if Is_Generic_Instance (S)
2811 and then Present (Freeze_Node (S))
2812 and then not Analyzed (Freeze_Node (S))
2821 end In_Unfrozen_Instance;
2823 ----------------------------------
2824 -- Is_Class_Wide_Interface_Type --
2825 ----------------------------------
2827 function Is_Class_Wide_Interface_Type (E : Entity_Id) return Boolean is
2829 Typ : Entity_Id := E;
2832 if Has_Non_Limited_View (Typ) then
2833 Typ := Non_Limited_View (Typ);
2836 if Ekind (Typ) = E_Anonymous_Access_Type then
2837 DDT := Directly_Designated_Type (Typ);
2839 if Has_Non_Limited_View (DDT) then
2840 DDT := Non_Limited_View (DDT);
2843 return Is_Class_Wide_Type (DDT) and then Is_Interface (DDT);
2845 return Is_Class_Wide_Type (Typ) and then Is_Interface (Typ);
2847 end Is_Class_Wide_Interface_Type;
2849 -------------------------
2850 -- Is_Direct_Deep_Call --
2851 -------------------------
2853 function Is_Direct_Deep_Call (Subp : Entity_Id) return Boolean is
2855 if Is_TSS (Subp, TSS_Deep_Adjust)
2856 or else Is_TSS (Subp, TSS_Deep_Finalize)
2857 or else Is_TSS (Subp, TSS_Deep_Initialize)
2864 Actual := First (Parameter_Associations (N));
2865 Formal := First_Formal (Subp);
2866 while Present (Actual)
2867 and then Present (Formal)
2869 if Nkind (Actual) = N_Identifier
2870 and then Is_Controlling_Actual (Actual)
2871 and then Etype (Actual) = Etype (Formal)
2877 Next_Formal (Formal);
2883 end Is_Direct_Deep_Call;
2889 function New_Value (From : Node_Id) return Node_Id is
2890 Res : constant Node_Id := Duplicate_Subexpr (From);
2892 if Is_Access_Type (Etype (From)) then
2893 return Make_Explicit_Dereference (Sloc (From), Prefix => Res);
2901 Remote : constant Boolean := Is_Remote_Call (Call_Node);
2904 Orig_Subp : Entity_Id := Empty;
2905 Param_Count : Natural := 0;
2906 Parent_Formal : Entity_Id;
2907 Parent_Subp : Entity_Id;
2908 Pref_Entity : Entity_Id;
2912 Prev_Orig : Node_Id;
2913 -- Original node for an actual, which may have been rewritten. If the
2914 -- actual is a function call that has been transformed from a selected
2915 -- component, the original node is unanalyzed. Otherwise, it carries
2916 -- semantic information used to generate additional actuals.
2918 CW_Interface_Formals_Present : Boolean := False;
2920 -- Start of processing for Expand_Call_Helper
2923 Post_Call := New_List;
2925 -- Expand the function or procedure call if the first actual has a
2926 -- declared dimension aspect, and the subprogram is declared in one
2927 -- of the dimension I/O packages.
2929 if Ada_Version >= Ada_2012
2931 Nkind_In (Call_Node, N_Procedure_Call_Statement, N_Function_Call)
2932 and then Present (Parameter_Associations (Call_Node))
2934 Expand_Put_Call_With_Symbol (Call_Node);
2937 -- Ignore if previous error
2939 if Nkind (Call_Node) in N_Has_Etype
2940 and then Etype (Call_Node) = Any_Type
2945 -- Call using access to subprogram with explicit dereference
2947 if Nkind (Name (Call_Node)) = N_Explicit_Dereference then
2948 Subp := Etype (Name (Call_Node));
2949 Parent_Subp := Empty;
2951 -- Case of call to simple entry, where the Name is a selected component
2952 -- whose prefix is the task, and whose selector name is the entry name
2954 elsif Nkind (Name (Call_Node)) = N_Selected_Component then
2955 Subp := Entity (Selector_Name (Name (Call_Node)));
2956 Parent_Subp := Empty;
2958 -- Case of call to member of entry family, where Name is an indexed
2959 -- component, with the prefix being a selected component giving the
2960 -- task and entry family name, and the index being the entry index.
2962 elsif Nkind (Name (Call_Node)) = N_Indexed_Component then
2963 Subp := Entity (Selector_Name (Prefix (Name (Call_Node))));
2964 Parent_Subp := Empty;
2969 Subp := Entity (Name (Call_Node));
2970 Parent_Subp := Alias (Subp);
2972 -- Replace call to Raise_Exception by call to Raise_Exception_Always
2973 -- if we can tell that the first parameter cannot possibly be null.
2974 -- This improves efficiency by avoiding a run-time test.
2976 -- We do not do this if Raise_Exception_Always does not exist, which
2977 -- can happen in configurable run time profiles which provide only a
2980 if Is_RTE (Subp, RE_Raise_Exception)
2981 and then RTE_Available (RE_Raise_Exception_Always)
2984 FA : constant Node_Id :=
2985 Original_Node (First_Actual (Call_Node));
2988 -- The case we catch is where the first argument is obtained
2989 -- using the Identity attribute (which must always be
2992 if Nkind (FA) = N_Attribute_Reference
2993 and then Attribute_Name (FA) = Name_Identity
2995 Subp := RTE (RE_Raise_Exception_Always);
2996 Set_Name (Call_Node, New_Occurrence_Of (Subp, Loc));
3001 if Ekind (Subp) = E_Entry then
3002 Parent_Subp := Empty;
3006 -- Ada 2005 (AI-345): We have a procedure call as a triggering
3007 -- alternative in an asynchronous select or as an entry call in
3008 -- a conditional or timed select. Check whether the procedure call
3009 -- is a renaming of an entry and rewrite it as an entry call.
3011 if Ada_Version >= Ada_2005
3012 and then Nkind (Call_Node) = N_Procedure_Call_Statement
3014 ((Nkind (Parent (Call_Node)) = N_Triggering_Alternative
3015 and then Triggering_Statement (Parent (Call_Node)) = Call_Node)
3017 (Nkind (Parent (Call_Node)) = N_Entry_Call_Alternative
3018 and then Entry_Call_Statement (Parent (Call_Node)) = Call_Node))
3022 Ren_Root : Entity_Id := Subp;
3025 -- This may be a chain of renamings, find the root
3027 if Present (Alias (Ren_Root)) then
3028 Ren_Root := Alias (Ren_Root);
3031 if Present (Original_Node (Parent (Parent (Ren_Root)))) then
3032 Ren_Decl := Original_Node (Parent (Parent (Ren_Root)));
3034 if Nkind (Ren_Decl) = N_Subprogram_Renaming_Declaration then
3036 Make_Entry_Call_Statement (Loc,
3038 New_Copy_Tree (Name (Ren_Decl)),
3039 Parameter_Associations =>
3041 (Parameter_Associations (Call_Node))));
3049 -- if this is a call to a predicate function, try to constant
3052 if Nkind (Call_Node) = N_Function_Call
3053 and then Is_Entity_Name (Name (Call_Node))
3054 and then Is_Predicate_Function (Subp)
3055 and then Can_Fold_Predicate_Call (Subp)
3060 if Modify_Tree_For_C
3061 and then Nkind (Call_Node) = N_Function_Call
3062 and then Is_Entity_Name (Name (Call_Node))
3065 Func_Id : constant Entity_Id :=
3066 Ultimate_Alias (Entity (Name (Call_Node)));
3068 -- When generating C code, transform a function call that returns
3069 -- a constrained array type into procedure form.
3071 if Rewritten_For_C (Func_Id) then
3073 -- For internally generated calls ensure that they reference
3074 -- the entity of the spec of the called function (needed since
3075 -- the expander may generate calls using the entity of their
3076 -- body). See for example Expand_Boolean_Operator().
3078 if not (Comes_From_Source (Call_Node))
3079 and then Nkind (Unit_Declaration_Node (Func_Id)) =
3082 Set_Entity (Name (Call_Node),
3083 Corresponding_Function
3084 (Corresponding_Procedure (Func_Id)));
3087 Rewrite_Function_Call_For_C (Call_Node);
3090 -- Also introduce a temporary for functions that return a record
3091 -- called within another procedure or function call, since records
3092 -- are passed by pointer in the generated C code, and we cannot
3093 -- take a pointer from a subprogram call.
3095 elsif Nkind (Parent (Call_Node)) in N_Subprogram_Call
3096 and then Is_Record_Type (Etype (Func_Id))
3099 Temp_Id : constant Entity_Id := Make_Temporary (Loc, 'T');
3104 -- Temp : ... := Func_Call (...);
3107 Make_Object_Declaration (Loc,
3108 Defining_Identifier => Temp_Id,
3109 Object_Definition =>
3110 New_Occurrence_Of (Etype (Func_Id), Loc),
3112 Make_Function_Call (Loc,
3114 New_Occurrence_Of (Func_Id, Loc),
3115 Parameter_Associations =>
3116 Parameter_Associations (Call_Node)));
3118 Insert_Action (Parent (Call_Node), Decl);
3119 Rewrite (Call_Node, New_Occurrence_Of (Temp_Id, Loc));
3126 -- First step, compute extra actuals, corresponding to any Extra_Formals
3127 -- present. Note that we do not access Extra_Formals directly, instead
3128 -- we simply note the presence of the extra formals as we process the
3129 -- regular formals collecting corresponding actuals in Extra_Actuals.
3131 -- We also generate any required range checks for actuals for in formals
3132 -- as we go through the loop, since this is a convenient place to do it.
3133 -- (Though it seems that this would be better done in Expand_Actuals???)
3135 -- Special case: Thunks must not compute the extra actuals; they must
3136 -- just propagate to the target primitive their extra actuals.
3138 if Is_Thunk (Current_Scope)
3139 and then Thunk_Entity (Current_Scope) = Subp
3140 and then Present (Extra_Formals (Subp))
3142 pragma Assert (Present (Extra_Formals (Current_Scope)));
3145 Target_Formal : Entity_Id;
3146 Thunk_Formal : Entity_Id;
3149 Target_Formal := Extra_Formals (Subp);
3150 Thunk_Formal := Extra_Formals (Current_Scope);
3151 while Present (Target_Formal) loop
3153 (Expr => New_Occurrence_Of (Thunk_Formal, Loc),
3154 EF => Thunk_Formal);
3156 Target_Formal := Extra_Formal (Target_Formal);
3157 Thunk_Formal := Extra_Formal (Thunk_Formal);
3160 while Is_Non_Empty_List (Extra_Actuals) loop
3161 Add_Actual_Parameter (Remove_Head (Extra_Actuals));
3164 Expand_Actuals (Call_Node, Subp, Post_Call);
3165 pragma Assert (Is_Empty_List (Post_Call));
3170 Formal := First_Formal (Subp);
3171 Actual := First_Actual (Call_Node);
3173 while Present (Formal) loop
3174 -- Prepare to examine current entry
3177 Prev_Orig := Original_Node (Prev);
3179 -- Ada 2005 (AI-251): Check if any formal is a class-wide interface
3180 -- to expand it in a further round.
3182 CW_Interface_Formals_Present :=
3183 CW_Interface_Formals_Present
3184 or else Is_Class_Wide_Interface_Type (Etype (Formal));
3186 -- Create possible extra actual for constrained case. Usually, the
3187 -- extra actual is of the form actual'constrained, but since this
3188 -- attribute is only available for unconstrained records, TRUE is
3189 -- expanded if the type of the formal happens to be constrained (for
3190 -- instance when this procedure is inherited from an unconstrained
3191 -- record to a constrained one) or if the actual has no discriminant
3192 -- (its type is constrained). An exception to this is the case of a
3193 -- private type without discriminants. In this case we pass FALSE
3194 -- because the object has underlying discriminants with defaults.
3196 if Present (Extra_Constrained (Formal)) then
3197 if Ekind (Etype (Prev)) in Private_Kind
3198 and then not Has_Discriminants (Base_Type (Etype (Prev)))
3201 (Expr => New_Occurrence_Of (Standard_False, Loc),
3202 EF => Extra_Constrained (Formal));
3204 elsif Is_Constrained (Etype (Formal))
3205 or else not Has_Discriminants (Etype (Prev))
3208 (Expr => New_Occurrence_Of (Standard_True, Loc),
3209 EF => Extra_Constrained (Formal));
3211 -- Do not produce extra actuals for Unchecked_Union parameters.
3212 -- Jump directly to the end of the loop.
3214 elsif Is_Unchecked_Union (Base_Type (Etype (Actual))) then
3215 goto Skip_Extra_Actual_Generation;
3218 -- If the actual is a type conversion, then the constrained
3219 -- test applies to the actual, not the target type.
3225 -- Test for unchecked conversions as well, which can occur
3226 -- as out parameter actuals on calls to stream procedures.
3229 while Nkind_In (Act_Prev, N_Type_Conversion,
3230 N_Unchecked_Type_Conversion)
3232 Act_Prev := Expression (Act_Prev);
3235 -- If the expression is a conversion of a dereference, this
3236 -- is internally generated code that manipulates addresses,
3237 -- e.g. when building interface tables. No check should
3238 -- occur in this case, and the discriminated object is not
3241 if not Comes_From_Source (Actual)
3242 and then Nkind (Actual) = N_Unchecked_Type_Conversion
3243 and then Nkind (Act_Prev) = N_Explicit_Dereference
3246 (Expr => New_Occurrence_Of (Standard_False, Loc),
3247 EF => Extra_Constrained (Formal));
3252 Make_Attribute_Reference (Sloc (Prev),
3254 Duplicate_Subexpr_No_Checks
3255 (Act_Prev, Name_Req => True),
3256 Attribute_Name => Name_Constrained),
3257 EF => Extra_Constrained (Formal));
3263 -- Create possible extra actual for accessibility level
3265 if Present (Get_Accessibility (Formal)) then
3267 -- Ada 2005 (AI-252): If the actual was rewritten as an Access
3268 -- attribute, then the original actual may be an aliased object
3269 -- occurring as the prefix in a call using "Object.Operation"
3270 -- notation. In that case we must pass the level of the object,
3271 -- so Prev_Orig is reset to Prev and the attribute will be
3272 -- processed by the code for Access attributes further below.
3274 if Prev_Orig /= Prev
3275 and then Nkind (Prev) = N_Attribute_Reference
3276 and then Get_Attribute_Id (Attribute_Name (Prev)) =
3278 and then Is_Aliased_View (Prev_Orig)
3282 -- A class-wide precondition generates a test in which formals of
3283 -- the subprogram are replaced by actuals that came from source.
3284 -- In that case as well, the accessiblity comes from the actual.
3285 -- This is the one case in which there are references to formals
3286 -- outside of their subprogram.
3288 elsif Prev_Orig /= Prev
3289 and then Is_Entity_Name (Prev_Orig)
3290 and then Present (Entity (Prev_Orig))
3291 and then Is_Formal (Entity (Prev_Orig))
3292 and then not In_Open_Scopes (Scope (Entity (Prev_Orig)))
3296 -- If the actual is a formal of an enclosing subprogram it is
3297 -- the right entity, even if it is a rewriting. This happens
3298 -- when the call is within an inherited condition or predicate.
3300 elsif Is_Entity_Name (Actual)
3301 and then Is_Formal (Entity (Actual))
3302 and then In_Open_Scopes (Scope (Entity (Actual)))
3306 elsif Nkind (Prev_Orig) = N_Type_Conversion then
3307 Prev_Orig := Expression (Prev_Orig);
3310 -- Ada 2005 (AI-251): Thunks must propagate the extra actuals of
3311 -- accessibility levels.
3313 if Is_Thunk (Current_Scope) then
3315 Parm_Ent : Entity_Id;
3318 if Is_Controlling_Actual (Actual) then
3320 -- Find the corresponding actual of the thunk
3322 Parm_Ent := First_Entity (Current_Scope);
3323 for J in 2 .. Param_Count loop
3324 Next_Entity (Parm_Ent);
3327 -- Handle unchecked conversion of access types generated
3328 -- in thunks (cf. Expand_Interface_Thunk).
3330 elsif Is_Access_Type (Etype (Actual))
3331 and then Nkind (Actual) = N_Unchecked_Type_Conversion
3333 Parm_Ent := Entity (Expression (Actual));
3335 else pragma Assert (Is_Entity_Name (Actual));
3336 Parm_Ent := Entity (Actual);
3341 New_Occurrence_Of (Get_Accessibility (Parm_Ent), Loc),
3342 EF => Get_Accessibility (Formal));
3345 elsif Is_Entity_Name (Prev_Orig) then
3347 -- When passing an access parameter, or a renaming of an access
3348 -- parameter, as the actual to another access parameter we need
3349 -- to pass along the actual's own access level parameter. This
3350 -- is done if we are within the scope of the formal access
3351 -- parameter (if this is an inlined body the extra formal is
3354 if (Is_Formal (Entity (Prev_Orig))
3356 (Present (Renamed_Object (Entity (Prev_Orig)))
3358 Is_Entity_Name (Renamed_Object (Entity (Prev_Orig)))
3361 (Entity (Renamed_Object (Entity (Prev_Orig))))))
3362 and then Ekind (Etype (Prev_Orig)) = E_Anonymous_Access_Type
3363 and then In_Open_Scopes (Scope (Entity (Prev_Orig)))
3366 Parm_Ent : constant Entity_Id := Param_Entity (Prev_Orig);
3369 pragma Assert (Present (Parm_Ent));
3371 if Present (Get_Accessibility (Parm_Ent)) then
3375 (Get_Accessibility (Parm_Ent), Loc),
3376 EF => Get_Accessibility (Formal));
3378 -- If the actual access parameter does not have an
3379 -- associated extra formal providing its scope level,
3380 -- then treat the actual as having library-level
3386 Make_Integer_Literal (Loc,
3387 Intval => Scope_Depth (Standard_Standard)),
3388 EF => Get_Accessibility (Formal));
3392 -- The actual is a normal access value, so just pass the level
3393 -- of the actual's access type.
3397 (Expr => Dynamic_Accessibility_Level (Prev_Orig),
3398 EF => Get_Accessibility (Formal));
3401 -- If the actual is an access discriminant, then pass the level
3402 -- of the enclosing object (RM05-3.10.2(12.4/2)).
3404 elsif Nkind (Prev_Orig) = N_Selected_Component
3405 and then Ekind (Entity (Selector_Name (Prev_Orig))) =
3407 and then Ekind (Etype (Entity (Selector_Name (Prev_Orig)))) =
3408 E_Anonymous_Access_Type
3412 Make_Integer_Literal (Loc,
3413 Intval => Object_Access_Level (Prefix (Prev_Orig))),
3414 EF => Get_Accessibility (Formal));
3419 case Nkind (Prev_Orig) is
3420 when N_Attribute_Reference =>
3421 case Get_Attribute_Id (Attribute_Name (Prev_Orig)) is
3422 -- Ignore 'Result, 'Loop_Entry, and 'Old as they can
3423 -- be used to identify access objects and do not have
3424 -- an effect on accessibility level.
3426 when Attribute_Loop_Entry
3432 -- For X'Access, pass on the level of the prefix X
3434 when Attribute_Access =>
3436 -- Accessibility level of S'Access is that of A
3438 Prev_Orig := Prefix (Prev_Orig);
3440 -- If the expression is a view conversion, the
3441 -- accessibility level is that of the expression.
3443 if Nkind (Original_Node (Prev_Orig)) =
3446 Nkind (Expression (Original_Node (Prev_Orig))) =
3447 N_Explicit_Dereference
3450 Expression (Original_Node (Prev_Orig));
3453 -- If this is an Access attribute applied to the
3454 -- the current instance object passed to a type
3455 -- initialization procedure, then use the level
3456 -- of the type itself. This is not really correct,
3457 -- as there should be an extra level parameter
3458 -- passed in with _init formals (only in the case
3459 -- where the type is immutably limited), but we
3460 -- don't have an easy way currently to create such
3461 -- an extra formal (init procs aren't ever frozen).
3462 -- For now we just use the level of the type,
3463 -- which may be too shallow, but that works better
3464 -- than passing Object_Access_Level of the type,
3465 -- which can be one level too deep in some cases.
3468 -- A further case that requires special handling
3469 -- is the common idiom E.all'access. If E is a
3470 -- formal of the enclosing subprogram, the
3471 -- accessibility of the expression is that of E.
3473 if Is_Entity_Name (Prev_Orig) then
3474 Pref_Entity := Entity (Prev_Orig);
3476 elsif Nkind (Prev_Orig) = N_Explicit_Dereference
3477 and then Is_Entity_Name (Prefix (Prev_Orig))
3479 Pref_Entity := Entity (Prefix ((Prev_Orig)));
3482 Pref_Entity := Empty;
3485 if Is_Entity_Name (Prev_Orig)
3486 and then Is_Type (Entity (Prev_Orig))
3490 Make_Integer_Literal (Loc,
3492 Type_Access_Level (Pref_Entity)),
3493 EF => Get_Accessibility (Formal));
3495 elsif Nkind (Prev_Orig) = N_Explicit_Dereference
3496 and then Present (Pref_Entity)
3497 and then Is_Formal (Pref_Entity)
3499 (Get_Accessibility (Pref_Entity))
3504 (Get_Accessibility (Pref_Entity), Loc),
3505 EF => Get_Accessibility (Formal));
3510 Make_Integer_Literal (Loc,
3512 Object_Access_Level (Prev_Orig)),
3513 EF => Get_Accessibility (Formal));
3516 -- Treat the unchecked attributes as library-level
3518 when Attribute_Unchecked_Access
3519 | Attribute_Unrestricted_Access
3523 Make_Integer_Literal (Loc,
3524 Intval => Scope_Depth (Standard_Standard)),
3525 EF => Get_Accessibility (Formal));
3527 -- No other cases of attributes returning access
3528 -- values that can be passed to access parameters.
3531 raise Program_Error;
3535 -- For allocators we pass the level of the execution of the
3536 -- called subprogram, which is one greater than the current
3537 -- scope level. However, according to RM 3.10.2(14/3) this
3538 -- is wrong since for an anonymous allocator defining the
3539 -- value of an access parameter, the accessibility level is
3540 -- that of the innermost master of the call???
3545 Make_Integer_Literal (Loc,
3546 Intval => Scope_Depth (Current_Scope) + 1),
3547 EF => Get_Accessibility (Formal));
3549 -- For most other cases we simply pass the level of the
3550 -- actual's access type. The type is retrieved from
3551 -- Prev rather than Prev_Orig, because in some cases
3552 -- Prev_Orig denotes an original expression that has
3553 -- not been analyzed.
3557 (Expr => Dynamic_Accessibility_Level (Prev),
3558 EF => Get_Accessibility (Formal));
3563 -- Perform the check of 4.6(49) that prevents a null value from being
3564 -- passed as an actual to an access parameter. Note that the check
3565 -- is elided in the common cases of passing an access attribute or
3566 -- access parameter as an actual. Also, we currently don't enforce
3567 -- this check for expander-generated actuals and when -gnatdj is set.
3569 if Ada_Version >= Ada_2005 then
3571 -- Ada 2005 (AI-231): Check null-excluding access types. Note that
3572 -- the intent of 6.4.1(13) is that null-exclusion checks should
3573 -- not be done for 'out' parameters, even though it refers only
3574 -- to constraint checks, and a null_exclusion is not a constraint.
3575 -- Note that AI05-0196-1 corrects this mistake in the RM.
3577 if Is_Access_Type (Etype (Formal))
3578 and then Can_Never_Be_Null (Etype (Formal))
3579 and then Ekind (Formal) /= E_Out_Parameter
3580 and then Nkind (Prev) /= N_Raise_Constraint_Error
3581 and then (Known_Null (Prev)
3582 or else not Can_Never_Be_Null (Etype (Prev)))
3584 Install_Null_Excluding_Check (Prev);
3587 -- Ada_Version < Ada_2005
3590 if Ekind (Etype (Formal)) /= E_Anonymous_Access_Type
3591 or else Access_Checks_Suppressed (Subp)
3595 elsif Debug_Flag_J then
3598 elsif not Comes_From_Source (Prev) then
3601 elsif Is_Entity_Name (Prev)
3602 and then Ekind (Etype (Prev)) = E_Anonymous_Access_Type
3606 elsif Nkind_In (Prev, N_Allocator, N_Attribute_Reference) then
3610 Install_Null_Excluding_Check (Prev);
3614 -- Perform appropriate validity checks on parameters that
3617 if Validity_Checks_On then
3618 if (Ekind (Formal) = E_In_Parameter
3619 and then Validity_Check_In_Params)
3621 (Ekind (Formal) = E_In_Out_Parameter
3622 and then Validity_Check_In_Out_Params)
3624 -- If the actual is an indexed component of a packed type (or
3625 -- is an indexed or selected component whose prefix recursively
3626 -- meets this condition), it has not been expanded yet. It will
3627 -- be copied in the validity code that follows, and has to be
3628 -- expanded appropriately, so reanalyze it.
3630 -- What we do is just to unset analyzed bits on prefixes till
3631 -- we reach something that does not have a prefix.
3638 while Nkind_In (Nod, N_Indexed_Component,
3639 N_Selected_Component)
3641 Set_Analyzed (Nod, False);
3642 Nod := Prefix (Nod);
3646 Ensure_Valid (Actual);
3650 -- For IN OUT and OUT parameters, ensure that subscripts are valid
3651 -- since this is a left side reference. We only do this for calls
3652 -- from the source program since we assume that compiler generated
3653 -- calls explicitly generate any required checks. We also need it
3654 -- only if we are doing standard validity checks, since clearly it is
3655 -- not needed if validity checks are off, and in subscript validity
3656 -- checking mode, all indexed components are checked with a call
3657 -- directly from Expand_N_Indexed_Component.
3659 if Comes_From_Source (Call_Node)
3660 and then Ekind (Formal) /= E_In_Parameter
3661 and then Validity_Checks_On
3662 and then Validity_Check_Default
3663 and then not Validity_Check_Subscripts
3665 Check_Valid_Lvalue_Subscripts (Actual);
3668 -- Mark any scalar OUT parameter that is a simple variable as no
3669 -- longer known to be valid (unless the type is always valid). This
3670 -- reflects the fact that if an OUT parameter is never set in a
3671 -- procedure, then it can become invalid on the procedure return.
3673 if Ekind (Formal) = E_Out_Parameter
3674 and then Is_Entity_Name (Actual)
3675 and then Ekind (Entity (Actual)) = E_Variable
3676 and then not Is_Known_Valid (Etype (Actual))
3678 Set_Is_Known_Valid (Entity (Actual), False);
3681 -- For an OUT or IN OUT parameter, if the actual is an entity, then
3682 -- clear current values, since they can be clobbered. We are probably
3683 -- doing this in more places than we need to, but better safe than
3684 -- sorry when it comes to retaining bad current values.
3686 if Ekind (Formal) /= E_In_Parameter
3687 and then Is_Entity_Name (Actual)
3688 and then Present (Entity (Actual))
3691 Ent : constant Entity_Id := Entity (Actual);
3695 -- For an OUT or IN OUT parameter that is an assignable entity,
3696 -- we do not want to clobber the Last_Assignment field, since
3697 -- if it is set, it was precisely because it is indeed an OUT
3698 -- or IN OUT parameter. We do reset the Is_Known_Valid flag
3699 -- since the subprogram could have returned in invalid value.
3701 if Is_Assignable (Ent) then
3702 Sav := Last_Assignment (Ent);
3703 Kill_Current_Values (Ent);
3704 Set_Last_Assignment (Ent, Sav);
3705 Set_Is_Known_Valid (Ent, False);
3706 Set_Is_True_Constant (Ent, False);
3708 -- For all other cases, just kill the current values
3711 Kill_Current_Values (Ent);
3716 -- If the formal is class wide and the actual is an aggregate, force
3717 -- evaluation so that the back end who does not know about class-wide
3718 -- type, does not generate a temporary of the wrong size.
3720 if not Is_Class_Wide_Type (Etype (Formal)) then
3723 elsif Nkind (Actual) = N_Aggregate
3724 or else (Nkind (Actual) = N_Qualified_Expression
3725 and then Nkind (Expression (Actual)) = N_Aggregate)
3727 Force_Evaluation (Actual);
3730 -- In a remote call, if the formal is of a class-wide type, check
3731 -- that the actual meets the requirements described in E.4(18).
3733 if Remote and then Is_Class_Wide_Type (Etype (Formal)) then
3734 Insert_Action (Actual,
3735 Make_Transportable_Check (Loc,
3736 Duplicate_Subexpr_Move_Checks (Actual)));
3739 -- Perform invariant checks for all intermediate types in a view
3740 -- conversion after successful return from a call that passes the
3741 -- view conversion as an IN OUT or OUT parameter (RM 7.3.2 (12/3,
3742 -- 13/3, 14/3)). Consider only source conversion in order to avoid
3743 -- generating spurious checks on complex expansion such as object
3744 -- initialization through an extension aggregate.
3746 if Comes_From_Source (N)
3747 and then Ekind (Formal) /= E_In_Parameter
3748 and then Nkind (Actual) = N_Type_Conversion
3750 Add_View_Conversion_Invariants (Formal, Actual);
3753 -- Generating C the initialization of an allocator is performed by
3754 -- means of individual statements, and hence it must be done before
3757 if Modify_Tree_For_C
3758 and then Nkind (Actual) = N_Allocator
3759 and then Nkind (Expression (Actual)) = N_Qualified_Expression
3761 Remove_Side_Effects (Actual);
3764 -- This label is required when skipping extra actual generation for
3765 -- Unchecked_Union parameters.
3767 <<Skip_Extra_Actual_Generation>>
3769 Param_Count := Param_Count + 1;
3770 Next_Actual (Actual);
3771 Next_Formal (Formal);
3774 -- If we are calling an Ada 2012 function which needs to have the
3775 -- "accessibility level determined by the point of call" (AI05-0234)
3776 -- passed in to it, then pass it in.
3778 if Ekind_In (Subp, E_Function, E_Operator, E_Subprogram_Type)
3780 Present (Extra_Accessibility_Of_Result (Ultimate_Alias (Subp)))
3783 Ancestor : Node_Id := Parent (Call_Node);
3784 Level : Node_Id := Empty;
3785 Defer : Boolean := False;
3788 -- Unimplemented: if Subp returns an anonymous access type, then
3790 -- a) if the call is the operand of an explict conversion, then
3791 -- the target type of the conversion (a named access type)
3792 -- determines the accessibility level pass in;
3794 -- b) if the call defines an access discriminant of an object
3795 -- (e.g., the discriminant of an object being created by an
3796 -- allocator, or the discriminant of a function result),
3797 -- then the accessibility level to pass in is that of the
3798 -- discriminated object being initialized).
3802 while Nkind (Ancestor) = N_Qualified_Expression
3804 Ancestor := Parent (Ancestor);
3807 case Nkind (Ancestor) is
3810 -- At this point, we'd like to assign
3812 -- Level := Dynamic_Accessibility_Level (Ancestor);
3814 -- but Etype of Ancestor may not have been set yet,
3815 -- so that doesn't work.
3817 -- Handle this later in Expand_Allocator_Expression.
3821 when N_Object_Declaration
3822 | N_Object_Renaming_Declaration
3825 Def_Id : constant Entity_Id :=
3826 Defining_Identifier (Ancestor);
3829 if Is_Return_Object (Def_Id) then
3830 if Present (Extra_Accessibility_Of_Result
3831 (Return_Applies_To (Scope (Def_Id))))
3833 -- Pass along value that was passed in if the
3834 -- routine we are returning from also has an
3835 -- Accessibility_Of_Result formal.
3839 (Extra_Accessibility_Of_Result
3840 (Return_Applies_To (Scope (Def_Id))), Loc);
3844 Make_Integer_Literal (Loc,
3845 Intval => Object_Access_Level (Def_Id));
3849 when N_Simple_Return_Statement =>
3850 if Present (Extra_Accessibility_Of_Result
3852 (Return_Statement_Entity (Ancestor))))
3854 -- Pass along value that was passed in if the returned
3855 -- routine also has an Accessibility_Of_Result formal.
3859 (Extra_Accessibility_Of_Result
3861 (Return_Statement_Entity (Ancestor))), Loc);
3869 if not Present (Level) then
3871 -- The "innermost master that evaluates the function call".
3873 -- ??? - Should we use Integer'Last here instead in order
3874 -- to deal with (some of) the problems associated with
3875 -- calls to subps whose enclosing scope is unknown (e.g.,
3876 -- Anon_Access_To_Subp_Param.all)?
3879 Make_Integer_Literal (Loc,
3880 Intval => Scope_Depth (Current_Scope) + 1);
3886 Extra_Accessibility_Of_Result (Ultimate_Alias (Subp)));
3891 -- If we are expanding the RHS of an assignment we need to check if tag
3892 -- propagation is needed. You might expect this processing to be in
3893 -- Analyze_Assignment but has to be done earlier (bottom-up) because the
3894 -- assignment might be transformed to a declaration for an unconstrained
3895 -- value if the expression is classwide.
3897 if Nkind (Call_Node) = N_Function_Call
3898 and then Is_Tag_Indeterminate (Call_Node)
3899 and then Is_Entity_Name (Name (Call_Node))
3902 Ass : Node_Id := Empty;
3905 if Nkind (Parent (Call_Node)) = N_Assignment_Statement then
3906 Ass := Parent (Call_Node);
3908 elsif Nkind (Parent (Call_Node)) = N_Qualified_Expression
3909 and then Nkind (Parent (Parent (Call_Node))) =
3910 N_Assignment_Statement
3912 Ass := Parent (Parent (Call_Node));
3914 elsif Nkind (Parent (Call_Node)) = N_Explicit_Dereference
3915 and then Nkind (Parent (Parent (Call_Node))) =
3916 N_Assignment_Statement
3918 Ass := Parent (Parent (Call_Node));
3922 and then Is_Class_Wide_Type (Etype (Name (Ass)))
3924 if Is_Access_Type (Etype (Call_Node)) then
3925 if Designated_Type (Etype (Call_Node)) /=
3926 Root_Type (Etype (Name (Ass)))
3929 ("tag-indeterminate expression must have designated "
3930 & "type& (RM 5.2 (6))",
3931 Call_Node, Root_Type (Etype (Name (Ass))));
3933 Propagate_Tag (Name (Ass), Call_Node);
3936 elsif Etype (Call_Node) /= Root_Type (Etype (Name (Ass))) then
3938 ("tag-indeterminate expression must have type & "
3940 Call_Node, Root_Type (Etype (Name (Ass))));
3943 Propagate_Tag (Name (Ass), Call_Node);
3946 -- The call will be rewritten as a dispatching call, and
3947 -- expanded as such.
3954 -- Ada 2005 (AI-251): If some formal is a class-wide interface, expand
3955 -- it to point to the correct secondary virtual table
3957 if Nkind (Call_Node) in N_Subprogram_Call
3958 and then CW_Interface_Formals_Present
3960 Expand_Interface_Actuals (Call_Node);
3963 -- Deals with Dispatch_Call if we still have a call, before expanding
3964 -- extra actuals since this will be done on the re-analysis of the
3965 -- dispatching call. Note that we do not try to shorten the actual list
3966 -- for a dispatching call, it would not make sense to do so. Expansion
3967 -- of dispatching calls is suppressed for VM targets, because the VM
3968 -- back-ends directly handle the generation of dispatching calls and
3969 -- would have to undo any expansion to an indirect call.
3971 if Nkind (Call_Node) in N_Subprogram_Call
3972 and then Present (Controlling_Argument (Call_Node))
3975 Call_Typ : constant Entity_Id := Etype (Call_Node);
3976 Typ : constant Entity_Id := Find_Dispatching_Type (Subp);
3977 Eq_Prim_Op : Entity_Id := Empty;
3980 Prev_Call : Node_Id;
3983 if not Is_Limited_Type (Typ) then
3984 Eq_Prim_Op := Find_Prim_Op (Typ, Name_Op_Eq);
3987 if Tagged_Type_Expansion then
3988 Expand_Dispatching_Call (Call_Node);
3990 -- The following return is worrisome. Is it really OK to skip
3991 -- all remaining processing in this procedure ???
3998 Apply_Tag_Checks (Call_Node);
4000 -- If this is a dispatching "=", we must first compare the
4001 -- tags so we generate: x.tag = y.tag and then x = y
4003 if Subp = Eq_Prim_Op then
4005 -- Mark the node as analyzed to avoid reanalyzing this
4006 -- dispatching call (which would cause a never-ending loop)
4008 Prev_Call := Relocate_Node (Call_Node);
4009 Set_Analyzed (Prev_Call);
4011 Param := First_Actual (Call_Node);
4017 Make_Selected_Component (Loc,
4018 Prefix => New_Value (Param),
4021 (First_Tag_Component (Typ), Loc)),
4024 Make_Selected_Component (Loc,
4026 Unchecked_Convert_To (Typ,
4027 New_Value (Next_Actual (Param))),
4030 (First_Tag_Component (Typ), Loc))),
4031 Right_Opnd => Prev_Call);
4033 Rewrite (Call_Node, New_Call);
4036 (Call_Node, Call_Typ, Suppress => All_Checks);
4039 -- Expansion of a dispatching call results in an indirect call,
4040 -- which in turn causes current values to be killed (see
4041 -- Resolve_Call), so on VM targets we do the call here to
4042 -- ensure consistent warnings between VM and non-VM targets.
4044 Kill_Current_Values;
4047 -- If this is a dispatching "=" then we must update the reference
4048 -- to the call node because we generated:
4049 -- x.tag = y.tag and then x = y
4051 if Subp = Eq_Prim_Op then
4052 Call_Node := Right_Opnd (Call_Node);
4057 -- Similarly, expand calls to RCI subprograms on which pragma
4058 -- All_Calls_Remote applies. The rewriting will be reanalyzed
4059 -- later. Do this only when the call comes from source since we
4060 -- do not want such a rewriting to occur in expanded code.
4062 if Is_All_Remote_Call (Call_Node) then
4063 Expand_All_Calls_Remote_Subprogram_Call (Call_Node);
4065 -- Similarly, do not add extra actuals for an entry call whose entity
4066 -- is a protected procedure, or for an internal protected subprogram
4067 -- call, because it will be rewritten as a protected subprogram call
4068 -- and reanalyzed (see Expand_Protected_Subprogram_Call).
4070 elsif Is_Protected_Type (Scope (Subp))
4071 and then (Ekind (Subp) = E_Procedure
4072 or else Ekind (Subp) = E_Function)
4076 -- During that loop we gathered the extra actuals (the ones that
4077 -- correspond to Extra_Formals), so now they can be appended.
4080 while Is_Non_Empty_List (Extra_Actuals) loop
4081 Add_Actual_Parameter (Remove_Head (Extra_Actuals));
4085 -- At this point we have all the actuals, so this is the point at which
4086 -- the various expansion activities for actuals is carried out.
4088 Expand_Actuals (Call_Node, Subp, Post_Call);
4090 -- Verify that the actuals do not share storage. This check must be done
4091 -- on the caller side rather that inside the subprogram to avoid issues
4092 -- of parameter passing.
4094 if Check_Aliasing_Of_Parameters then
4095 Apply_Parameter_Aliasing_Checks (Call_Node, Subp);
4098 -- If the subprogram is a renaming, or if it is inherited, replace it in
4099 -- the call with the name of the actual subprogram being called. If this
4100 -- is a dispatching call, the run-time decides what to call. The Alias
4101 -- attribute does not apply to entries.
4103 if Nkind (Call_Node) /= N_Entry_Call_Statement
4104 and then No (Controlling_Argument (Call_Node))
4105 and then Present (Parent_Subp)
4106 and then not Is_Direct_Deep_Call (Subp)
4108 if Present (Inherited_From_Formal (Subp)) then
4109 Parent_Subp := Inherited_From_Formal (Subp);
4111 Parent_Subp := Ultimate_Alias (Parent_Subp);
4114 -- The below setting of Entity is suspect, see F109-018 discussion???
4116 Set_Entity (Name (Call_Node), Parent_Subp);
4118 if Is_Abstract_Subprogram (Parent_Subp)
4119 and then not In_Instance
4122 ("cannot call abstract subprogram &!",
4123 Name (Call_Node), Parent_Subp);
4126 -- Inspect all formals of derived subprogram Subp. Compare parameter
4127 -- types with the parent subprogram and check whether an actual may
4128 -- need a type conversion to the corresponding formal of the parent
4131 -- Not clear whether intrinsic subprograms need such conversions. ???
4133 if not Is_Intrinsic_Subprogram (Parent_Subp)
4134 or else Is_Generic_Instance (Parent_Subp)
4137 procedure Convert (Act : Node_Id; Typ : Entity_Id);
4138 -- Rewrite node Act as a type conversion of Act to Typ. Analyze
4139 -- and resolve the newly generated construct.
4145 procedure Convert (Act : Node_Id; Typ : Entity_Id) is
4147 Rewrite (Act, OK_Convert_To (Typ, Relocate_Node (Act)));
4154 Actual_Typ : Entity_Id;
4155 Formal_Typ : Entity_Id;
4156 Parent_Typ : Entity_Id;
4159 Actual := First_Actual (Call_Node);
4160 Formal := First_Formal (Subp);
4161 Parent_Formal := First_Formal (Parent_Subp);
4162 while Present (Formal) loop
4163 Actual_Typ := Etype (Actual);
4164 Formal_Typ := Etype (Formal);
4165 Parent_Typ := Etype (Parent_Formal);
4167 -- For an IN parameter of a scalar type, the parent formal
4168 -- type and derived formal type differ or the parent formal
4169 -- type and actual type do not match statically.
4171 if Is_Scalar_Type (Formal_Typ)
4172 and then Ekind (Formal) = E_In_Parameter
4173 and then Formal_Typ /= Parent_Typ
4175 not Subtypes_Statically_Match (Parent_Typ, Actual_Typ)
4176 and then not Raises_Constraint_Error (Actual)
4178 Convert (Actual, Parent_Typ);
4179 Enable_Range_Check (Actual);
4181 -- If the actual has been marked as requiring a range
4182 -- check, then generate it here.
4184 if Do_Range_Check (Actual) then
4185 Generate_Range_Check
4186 (Actual, Etype (Formal), CE_Range_Check_Failed);
4189 -- For access types, the parent formal type and actual type
4192 elsif Is_Access_Type (Formal_Typ)
4193 and then Base_Type (Parent_Typ) /= Base_Type (Actual_Typ)
4195 if Ekind (Formal) /= E_In_Parameter then
4196 Convert (Actual, Parent_Typ);
4198 elsif Ekind (Parent_Typ) = E_Anonymous_Access_Type
4199 and then Designated_Type (Parent_Typ) /=
4200 Designated_Type (Actual_Typ)
4201 and then not Is_Controlling_Formal (Formal)
4203 -- This unchecked conversion is not necessary unless
4204 -- inlining is enabled, because in that case the type
4205 -- mismatch may become visible in the body about to be
4209 Unchecked_Convert_To (Parent_Typ,
4210 Relocate_Node (Actual)));
4212 Resolve (Actual, Parent_Typ);
4215 -- If there is a change of representation, then generate a
4216 -- warning, and do the change of representation.
4218 elsif not Same_Representation (Formal_Typ, Parent_Typ) then
4220 ("??change of representation required", Actual);
4221 Convert (Actual, Parent_Typ);
4223 -- For array and record types, the parent formal type and
4224 -- derived formal type have different sizes or pragma Pack
4227 elsif ((Is_Array_Type (Formal_Typ)
4228 and then Is_Array_Type (Parent_Typ))
4230 (Is_Record_Type (Formal_Typ)
4231 and then Is_Record_Type (Parent_Typ)))
4233 (Esize (Formal_Typ) /= Esize (Parent_Typ)
4234 or else Has_Pragma_Pack (Formal_Typ) /=
4235 Has_Pragma_Pack (Parent_Typ))
4237 Convert (Actual, Parent_Typ);
4240 Next_Actual (Actual);
4241 Next_Formal (Formal);
4242 Next_Formal (Parent_Formal);
4248 Subp := Parent_Subp;
4251 -- Deal with case where call is an explicit dereference
4253 if Nkind (Name (Call_Node)) = N_Explicit_Dereference then
4255 -- Handle case of access to protected subprogram type
4257 if Is_Access_Protected_Subprogram_Type
4258 (Base_Type (Etype (Prefix (Name (Call_Node)))))
4260 -- If this is a call through an access to protected operation, the
4261 -- prefix has the form (object'address, operation'access). Rewrite
4262 -- as a for other protected calls: the object is the 1st parameter
4263 -- of the list of actuals.
4270 Ptr : constant Node_Id := Prefix (Name (Call_Node));
4272 T : constant Entity_Id :=
4273 Equivalent_Type (Base_Type (Etype (Ptr)));
4275 D_T : constant Entity_Id :=
4276 Designated_Type (Base_Type (Etype (Ptr)));
4280 Make_Selected_Component (Loc,
4281 Prefix => Unchecked_Convert_To (T, Ptr),
4283 New_Occurrence_Of (First_Entity (T), Loc));
4286 Make_Selected_Component (Loc,
4287 Prefix => Unchecked_Convert_To (T, Ptr),
4289 New_Occurrence_Of (Next_Entity (First_Entity (T)), Loc));
4292 Make_Explicit_Dereference (Loc,
4295 if Present (Parameter_Associations (Call_Node)) then
4296 Parm := Parameter_Associations (Call_Node);
4301 Prepend (Obj, Parm);
4303 if Etype (D_T) = Standard_Void_Type then
4305 Make_Procedure_Call_Statement (Loc,
4307 Parameter_Associations => Parm);
4310 Make_Function_Call (Loc,
4312 Parameter_Associations => Parm);
4315 Set_First_Named_Actual (Call, First_Named_Actual (Call_Node));
4316 Set_Etype (Call, Etype (D_T));
4318 -- We do not re-analyze the call to avoid infinite recursion.
4319 -- We analyze separately the prefix and the object, and set
4320 -- the checks on the prefix that would otherwise be emitted
4321 -- when resolving a call.
4323 Rewrite (Call_Node, Call);
4325 Apply_Access_Check (Nam);
4332 -- If this is a call to an intrinsic subprogram, then perform the
4333 -- appropriate expansion to the corresponding tree node and we
4334 -- are all done (since after that the call is gone).
4336 -- In the case where the intrinsic is to be processed by the back end,
4337 -- the call to Expand_Intrinsic_Call will do nothing, which is fine,
4338 -- since the idea in this case is to pass the call unchanged. If the
4339 -- intrinsic is an inherited unchecked conversion, and the derived type
4340 -- is the target type of the conversion, we must retain it as the return
4341 -- type of the expression. Otherwise the expansion below, which uses the
4342 -- parent operation, will yield the wrong type.
4344 if Is_Intrinsic_Subprogram (Subp) then
4345 Expand_Intrinsic_Call (Call_Node, Subp);
4347 if Nkind (Call_Node) = N_Unchecked_Type_Conversion
4348 and then Parent_Subp /= Orig_Subp
4349 and then Etype (Parent_Subp) /= Etype (Orig_Subp)
4351 Set_Etype (Call_Node, Etype (Orig_Subp));
4357 if Ekind_In (Subp, E_Function, E_Procedure) then
4359 -- We perform a simple optimization on calls for To_Address by
4360 -- replacing them with an unchecked conversion. Not only is this
4361 -- efficient, but it also avoids order of elaboration problems when
4362 -- address clauses are inlined (address expression elaborated at the
4365 -- We perform this optimization regardless of whether we are in the
4366 -- main unit or in a unit in the context of the main unit, to ensure
4367 -- that the generated tree is the same in both cases, for CodePeer
4370 if Is_RTE (Subp, RE_To_Address) then
4372 Unchecked_Convert_To
4373 (RTE (RE_Address), Relocate_Node (First_Actual (Call_Node))));
4376 -- A call to a null procedure is replaced by a null statement, but we
4377 -- are not allowed to ignore possible side effects of the call, so we
4378 -- make sure that actuals are evaluated.
4379 -- We also suppress this optimization for GNATCoverage.
4381 elsif Is_Null_Procedure (Subp)
4382 and then not Opt.Suppress_Control_Flow_Optimizations
4384 Actual := First_Actual (Call_Node);
4385 while Present (Actual) loop
4386 Remove_Side_Effects (Actual);
4387 Next_Actual (Actual);
4390 Rewrite (Call_Node, Make_Null_Statement (Loc));
4394 -- Handle inlining. No action needed if the subprogram is not inlined
4396 if not Is_Inlined (Subp) then
4399 -- Front-end inlining of expression functions (performed also when
4400 -- back-end inlining is enabled).
4402 elsif Is_Inlinable_Expression_Function (Subp) then
4403 Rewrite (N, New_Copy (Expression_Of_Expression_Function (Subp)));
4407 -- Handle front-end inlining
4409 elsif not Back_End_Inlining then
4410 Inlined_Subprogram : declare
4412 Must_Inline : Boolean := False;
4413 Spec : constant Node_Id := Unit_Declaration_Node (Subp);
4416 -- Verify that the body to inline has already been seen, and
4417 -- that if the body is in the current unit the inlining does
4418 -- not occur earlier. This avoids order-of-elaboration problems
4421 -- This should be documented in sinfo/einfo ???
4424 or else Nkind (Spec) /= N_Subprogram_Declaration
4425 or else No (Body_To_Inline (Spec))
4427 Must_Inline := False;
4429 -- If this an inherited function that returns a private type,
4430 -- do not inline if the full view is an unconstrained array,
4431 -- because such calls cannot be inlined.
4433 elsif Present (Orig_Subp)
4434 and then Is_Array_Type (Etype (Orig_Subp))
4435 and then not Is_Constrained (Etype (Orig_Subp))
4437 Must_Inline := False;
4439 elsif In_Unfrozen_Instance (Scope (Subp)) then
4440 Must_Inline := False;
4443 Bod := Body_To_Inline (Spec);
4445 if (In_Extended_Main_Code_Unit (Call_Node)
4446 or else In_Extended_Main_Code_Unit (Parent (Call_Node))
4447 or else Has_Pragma_Inline_Always (Subp))
4448 and then (not In_Same_Extended_Unit (Sloc (Bod), Loc)
4450 Earlier_In_Extended_Unit (Sloc (Bod), Loc))
4452 Must_Inline := True;
4454 -- If we are compiling a package body that is not the main
4455 -- unit, it must be for inlining/instantiation purposes,
4456 -- in which case we inline the call to insure that the same
4457 -- temporaries are generated when compiling the body by
4458 -- itself. Otherwise link errors can occur.
4460 -- If the function being called is itself in the main unit,
4461 -- we cannot inline, because there is a risk of double
4462 -- elaboration and/or circularity: the inlining can make
4463 -- visible a private entity in the body of the main unit,
4464 -- that gigi will see before its sees its proper definition.
4466 elsif not (In_Extended_Main_Code_Unit (Call_Node))
4467 and then In_Package_Body
4469 Must_Inline := not In_Extended_Main_Source_Unit (Subp);
4471 -- Inline calls to _postconditions when generating C code
4473 elsif Modify_Tree_For_C
4474 and then In_Same_Extended_Unit (Sloc (Bod), Loc)
4475 and then Chars (Name (N)) = Name_uPostconditions
4477 Must_Inline := True;
4482 Expand_Inlined_Call (Call_Node, Subp, Orig_Subp);
4485 -- Let the back end handle it
4487 Add_Inlined_Body (Subp, Call_Node);
4489 if Front_End_Inlining
4490 and then Nkind (Spec) = N_Subprogram_Declaration
4491 and then (In_Extended_Main_Code_Unit (Call_Node))
4492 and then No (Body_To_Inline (Spec))
4493 and then not Has_Completion (Subp)
4494 and then In_Same_Extended_Unit (Sloc (Spec), Loc)
4497 ("cannot inline& (body not seen yet)?",
4501 end Inlined_Subprogram;
4503 -- Front-end expansion of simple functions returning unconstrained
4504 -- types (see Check_And_Split_Unconstrained_Function). Note that the
4505 -- case of a simple renaming (Body_To_Inline in N_Entity below, see
4506 -- also Build_Renamed_Body) cannot be expanded here because this may
4507 -- give rise to order-of-elaboration issues for the types of the
4508 -- parameters of the subprogram, if any.
4510 elsif Present (Unit_Declaration_Node (Subp))
4511 and then Nkind (Unit_Declaration_Node (Subp)) =
4512 N_Subprogram_Declaration
4513 and then Present (Body_To_Inline (Unit_Declaration_Node (Subp)))
4515 Nkind (Body_To_Inline (Unit_Declaration_Node (Subp))) not in
4518 Expand_Inlined_Call (Call_Node, Subp, Orig_Subp);
4520 -- Back-end inlining either if optimization is enabled or the call is
4521 -- required to be inlined.
4523 elsif Optimization_Level > 0
4524 or else Has_Pragma_Inline_Always (Subp)
4526 Add_Inlined_Body (Subp, Call_Node);
4530 -- Check for protected subprogram. This is either an intra-object call,
4531 -- or a protected function call. Protected procedure calls are rewritten
4532 -- as entry calls and handled accordingly.
4534 -- In Ada 2005, this may be an indirect call to an access parameter that
4535 -- is an access_to_subprogram. In that case the anonymous type has a
4536 -- scope that is a protected operation, but the call is a regular one.
4537 -- In either case do not expand call if subprogram is eliminated.
4539 Scop := Scope (Subp);
4541 if Nkind (Call_Node) /= N_Entry_Call_Statement
4542 and then Is_Protected_Type (Scop)
4543 and then Ekind (Subp) /= E_Subprogram_Type
4544 and then not Is_Eliminated (Subp)
4546 -- If the call is an internal one, it is rewritten as a call to the
4547 -- corresponding unprotected subprogram.
4549 Expand_Protected_Subprogram_Call (Call_Node, Subp, Scop);
4552 -- Functions returning controlled objects need special attention. If
4553 -- the return type is limited, then the context is initialization and
4554 -- different processing applies. If the call is to a protected function,
4555 -- the expansion above will call Expand_Call recursively. Otherwise the
4556 -- function call is transformed into a temporary which obtains the
4557 -- result from the secondary stack.
4559 if Needs_Finalization (Etype (Subp)) then
4560 if not Is_Build_In_Place_Function_Call (Call_Node)
4562 (No (First_Formal (Subp))
4564 not Is_Concurrent_Record_Type (Etype (First_Formal (Subp))))
4566 Expand_Ctrl_Function_Call (Call_Node);
4568 -- Build-in-place function calls which appear in anonymous contexts
4569 -- need a transient scope to ensure the proper finalization of the
4570 -- intermediate result after its use.
4572 elsif Is_Build_In_Place_Function_Call (Call_Node)
4573 and then Nkind_In (Parent (Unqual_Conv (Call_Node)),
4574 N_Attribute_Reference,
4576 N_Indexed_Component,
4577 N_Object_Renaming_Declaration,
4578 N_Procedure_Call_Statement,
4579 N_Selected_Component,
4582 (Ekind (Current_Scope) /= E_Loop
4583 or else Nkind (Parent (N)) /= N_Function_Call
4584 or else not Is_Build_In_Place_Function_Call (Parent (N)))
4586 Establish_Transient_Scope (Call_Node, Manage_Sec_Stack => True);
4589 end Expand_Call_Helper;
4591 -------------------------------
4592 -- Expand_Ctrl_Function_Call --
4593 -------------------------------
4595 procedure Expand_Ctrl_Function_Call (N : Node_Id) is
4596 function Is_Element_Reference (N : Node_Id) return Boolean;
4597 -- Determine whether node N denotes a reference to an Ada 2012 container
4600 --------------------------
4601 -- Is_Element_Reference --
4602 --------------------------
4604 function Is_Element_Reference (N : Node_Id) return Boolean is
4605 Ref : constant Node_Id := Original_Node (N);
4608 -- Analysis marks an element reference by setting the generalized
4609 -- indexing attribute of an indexed component before the component
4610 -- is rewritten into a function call.
4613 Nkind (Ref) = N_Indexed_Component
4614 and then Present (Generalized_Indexing (Ref));
4615 end Is_Element_Reference;
4617 -- Start of processing for Expand_Ctrl_Function_Call
4620 -- Optimization, if the returned value (which is on the sec-stack) is
4621 -- returned again, no need to copy/readjust/finalize, we can just pass
4622 -- the value thru (see Expand_N_Simple_Return_Statement), and thus no
4623 -- attachment is needed
4625 if Nkind (Parent (N)) = N_Simple_Return_Statement then
4629 -- Resolution is now finished, make sure we don't start analysis again
4630 -- because of the duplication.
4634 -- A function which returns a controlled object uses the secondary
4635 -- stack. Rewrite the call into a temporary which obtains the result of
4636 -- the function using 'reference.
4638 Remove_Side_Effects (N);
4640 -- The side effect removal of the function call produced a temporary.
4641 -- When the context is a case expression, if expression, or expression
4642 -- with actions, the lifetime of the temporary must be extended to match
4643 -- that of the context. Otherwise the function result will be finalized
4644 -- too early and affect the result of the expression. To prevent this
4645 -- unwanted effect, the temporary should not be considered for clean up
4646 -- actions by the general finalization machinery.
4648 -- Exception to this rule are references to Ada 2012 container elements.
4649 -- Such references must be finalized at the end of each iteration of the
4650 -- related quantified expression, otherwise the container will remain
4653 if Nkind (N) = N_Explicit_Dereference
4654 and then Within_Case_Or_If_Expression (N)
4655 and then not Is_Element_Reference (N)
4657 Set_Is_Ignored_Transient (Entity (Prefix (N)));
4659 end Expand_Ctrl_Function_Call;
4661 ----------------------------------------
4662 -- Expand_N_Extended_Return_Statement --
4663 ----------------------------------------
4665 -- If there is a Handled_Statement_Sequence, we rewrite this:
4667 -- return Result : T := <expression> do
4668 -- <handled_seq_of_stms>
4674 -- Result : T := <expression>;
4676 -- <handled_seq_of_stms>
4680 -- Otherwise (no Handled_Statement_Sequence), we rewrite this:
4682 -- return Result : T := <expression>;
4686 -- return <expression>;
4688 -- unless it's build-in-place or there's no <expression>, in which case
4692 -- Result : T := <expression>;
4697 -- Note that this case could have been written by the user as an extended
4698 -- return statement, or could have been transformed to this from a simple
4699 -- return statement.
4701 -- That is, we need to have a reified return object if there are statements
4702 -- (which might refer to it) or if we're doing build-in-place (so we can
4703 -- set its address to the final resting place or if there is no expression
4704 -- (in which case default initial values might need to be set)).
4706 procedure Expand_N_Extended_Return_Statement (N : Node_Id) is
4707 Loc : constant Source_Ptr := Sloc (N);
4709 function Build_Heap_Or_Pool_Allocator
4710 (Temp_Id : Entity_Id;
4711 Temp_Typ : Entity_Id;
4712 Func_Id : Entity_Id;
4713 Ret_Typ : Entity_Id;
4714 Alloc_Expr : Node_Id) return Node_Id;
4715 -- Create the statements necessary to allocate a return object on the
4716 -- heap or user-defined storage pool. The object may need finalization
4717 -- actions depending on the return type.
4719 -- * Controlled case
4721 -- if BIPfinalizationmaster = null then
4722 -- Temp_Id := <Alloc_Expr>;
4725 -- type Ptr_Typ is access Ret_Typ;
4726 -- for Ptr_Typ'Storage_Pool use
4727 -- Base_Pool (BIPfinalizationmaster.all).all;
4731 -- procedure Allocate (...) is
4733 -- System.Storage_Pools.Subpools.Allocate_Any (...);
4736 -- Local := <Alloc_Expr>;
4737 -- Temp_Id := Temp_Typ (Local);
4741 -- * Non-controlled case
4743 -- Temp_Id := <Alloc_Expr>;
4745 -- Temp_Id is the temporary which is used to reference the internally
4746 -- created object in all allocation forms. Temp_Typ is the type of the
4747 -- temporary. Func_Id is the enclosing function. Ret_Typ is the return
4748 -- type of Func_Id. Alloc_Expr is the actual allocator.
4750 function Move_Activation_Chain (Func_Id : Entity_Id) return Node_Id;
4751 -- Construct a call to System.Tasking.Stages.Move_Activation_Chain
4753 -- From current activation chain
4754 -- To activation chain passed in by the caller
4755 -- New_Master master passed in by the caller
4757 -- Func_Id is the entity of the function where the extended return
4758 -- statement appears.
4760 ----------------------------------
4761 -- Build_Heap_Or_Pool_Allocator --
4762 ----------------------------------
4764 function Build_Heap_Or_Pool_Allocator
4765 (Temp_Id : Entity_Id;
4766 Temp_Typ : Entity_Id;
4767 Func_Id : Entity_Id;
4768 Ret_Typ : Entity_Id;
4769 Alloc_Expr : Node_Id) return Node_Id
4772 pragma Assert (Is_Build_In_Place_Function (Func_Id));
4774 -- Processing for objects that require finalization actions
4776 if Needs_Finalization (Ret_Typ) then
4778 Decls : constant List_Id := New_List;
4779 Fin_Mas_Id : constant Entity_Id :=
4780 Build_In_Place_Formal
4781 (Func_Id, BIP_Finalization_Master);
4782 Orig_Expr : constant Node_Id :=
4784 (Source => Alloc_Expr,
4785 Scopes_In_EWA_OK => True);
4786 Stmts : constant List_Id := New_List;
4787 Desig_Typ : Entity_Id;
4788 Local_Id : Entity_Id;
4789 Pool_Id : Entity_Id;
4790 Ptr_Typ : Entity_Id;
4794 -- Pool_Id renames Base_Pool (BIPfinalizationmaster.all).all;
4796 Pool_Id := Make_Temporary (Loc, 'P');
4799 Make_Object_Renaming_Declaration (Loc,
4800 Defining_Identifier => Pool_Id,
4802 New_Occurrence_Of (RTE (RE_Root_Storage_Pool), Loc),
4804 Make_Explicit_Dereference (Loc,
4806 Make_Function_Call (Loc,
4808 New_Occurrence_Of (RTE (RE_Base_Pool), Loc),
4809 Parameter_Associations => New_List (
4810 Make_Explicit_Dereference (Loc,
4812 New_Occurrence_Of (Fin_Mas_Id, Loc)))))));
4814 -- Create an access type which uses the storage pool of the
4815 -- caller's master. This additional type is necessary because
4816 -- the finalization master cannot be associated with the type
4817 -- of the temporary. Otherwise the secondary stack allocation
4820 Desig_Typ := Ret_Typ;
4822 -- Ensure that the build-in-place machinery uses a fat pointer
4823 -- when allocating an unconstrained array on the heap. In this
4824 -- case the result object type is a constrained array type even
4825 -- though the function type is unconstrained.
4827 if Ekind (Desig_Typ) = E_Array_Subtype then
4828 Desig_Typ := Base_Type (Desig_Typ);
4832 -- type Ptr_Typ is access Desig_Typ;
4834 Ptr_Typ := Make_Temporary (Loc, 'P');
4837 Make_Full_Type_Declaration (Loc,
4838 Defining_Identifier => Ptr_Typ,
4840 Make_Access_To_Object_Definition (Loc,
4841 Subtype_Indication =>
4842 New_Occurrence_Of (Desig_Typ, Loc))));
4844 -- Perform minor decoration in order to set the master and the
4845 -- storage pool attributes.
4847 Set_Ekind (Ptr_Typ, E_Access_Type);
4848 Set_Finalization_Master (Ptr_Typ, Fin_Mas_Id);
4849 Set_Associated_Storage_Pool (Ptr_Typ, Pool_Id);
4851 -- Create the temporary, generate:
4852 -- Local_Id : Ptr_Typ;
4854 Local_Id := Make_Temporary (Loc, 'T');
4857 Make_Object_Declaration (Loc,
4858 Defining_Identifier => Local_Id,
4859 Object_Definition =>
4860 New_Occurrence_Of (Ptr_Typ, Loc)));
4862 -- Allocate the object, generate:
4863 -- Local_Id := <Alloc_Expr>;
4866 Make_Assignment_Statement (Loc,
4867 Name => New_Occurrence_Of (Local_Id, Loc),
4868 Expression => Alloc_Expr));
4871 -- Temp_Id := Temp_Typ (Local_Id);
4874 Make_Assignment_Statement (Loc,
4875 Name => New_Occurrence_Of (Temp_Id, Loc),
4877 Unchecked_Convert_To (Temp_Typ,
4878 New_Occurrence_Of (Local_Id, Loc))));
4880 -- Wrap the allocation in a block. This is further conditioned
4881 -- by checking the caller finalization master at runtime. A
4882 -- null value indicates a non-existent master, most likely due
4883 -- to a Finalize_Storage_Only allocation.
4886 -- if BIPfinalizationmaster = null then
4887 -- Temp_Id := <Orig_Expr>;
4897 Make_If_Statement (Loc,
4900 Left_Opnd => New_Occurrence_Of (Fin_Mas_Id, Loc),
4901 Right_Opnd => Make_Null (Loc)),
4903 Then_Statements => New_List (
4904 Make_Assignment_Statement (Loc,
4905 Name => New_Occurrence_Of (Temp_Id, Loc),
4906 Expression => Orig_Expr)),
4908 Else_Statements => New_List (
4909 Make_Block_Statement (Loc,
4910 Declarations => Decls,
4911 Handled_Statement_Sequence =>
4912 Make_Handled_Sequence_Of_Statements (Loc,
4913 Statements => Stmts))));
4916 -- For all other cases, generate:
4917 -- Temp_Id := <Alloc_Expr>;
4921 Make_Assignment_Statement (Loc,
4922 Name => New_Occurrence_Of (Temp_Id, Loc),
4923 Expression => Alloc_Expr);
4925 end Build_Heap_Or_Pool_Allocator;
4927 ---------------------------
4928 -- Move_Activation_Chain --
4929 ---------------------------
4931 function Move_Activation_Chain (Func_Id : Entity_Id) return Node_Id is
4934 Make_Procedure_Call_Statement (Loc,
4936 New_Occurrence_Of (RTE (RE_Move_Activation_Chain), Loc),
4938 Parameter_Associations => New_List (
4942 Make_Attribute_Reference (Loc,
4943 Prefix => Make_Identifier (Loc, Name_uChain),
4944 Attribute_Name => Name_Unrestricted_Access),
4946 -- Destination chain
4949 (Build_In_Place_Formal (Func_Id, BIP_Activation_Chain), Loc),
4954 (Build_In_Place_Formal (Func_Id, BIP_Task_Master), Loc)));
4955 end Move_Activation_Chain;
4959 Func_Id : constant Entity_Id :=
4960 Return_Applies_To (Return_Statement_Entity (N));
4961 Is_BIP_Func : constant Boolean :=
4962 Is_Build_In_Place_Function (Func_Id);
4963 Ret_Obj_Id : constant Entity_Id :=
4964 First_Entity (Return_Statement_Entity (N));
4965 Ret_Obj_Decl : constant Node_Id := Parent (Ret_Obj_Id);
4966 Ret_Typ : constant Entity_Id := Etype (Func_Id);
4973 Return_Stmt : Node_Id := Empty;
4974 -- Force initialization to facilitate static analysis
4976 -- Start of processing for Expand_N_Extended_Return_Statement
4979 -- Given that functionality of interface thunks is simple (just displace
4980 -- the pointer to the object) they are always handled by means of
4981 -- simple return statements.
4983 pragma Assert (not Is_Thunk (Current_Subprogram));
4985 if Nkind (Ret_Obj_Decl) = N_Object_Declaration then
4986 Exp := Expression (Ret_Obj_Decl);
4988 -- Assert that if F says "return R : T := G(...) do..."
4989 -- then F and G are both b-i-p, or neither b-i-p.
4991 if Nkind (Exp) = N_Function_Call then
4992 pragma Assert (Ekind (Current_Subprogram) = E_Function);
4994 (Is_Build_In_Place_Function (Current_Subprogram) =
4995 Is_Build_In_Place_Function_Call (Exp));
5002 HSS := Handled_Statement_Sequence (N);
5004 -- If the returned object needs finalization actions, the function must
5005 -- perform the appropriate cleanup should it fail to return. The state
5006 -- of the function itself is tracked through a flag which is coupled
5007 -- with the scope finalizer. There is one flag per each return object
5008 -- in case of multiple returns.
5010 if Is_BIP_Func and then Needs_Finalization (Etype (Ret_Obj_Id)) then
5012 Flag_Decl : Node_Id;
5013 Flag_Id : Entity_Id;
5017 -- Recover the function body
5019 Func_Bod := Unit_Declaration_Node (Func_Id);
5021 if Nkind (Func_Bod) = N_Subprogram_Declaration then
5022 Func_Bod := Parent (Parent (Corresponding_Body (Func_Bod)));
5025 if Nkind (Func_Bod) = N_Function_Specification then
5026 Func_Bod := Parent (Func_Bod); -- one more level for child units
5029 pragma Assert (Nkind (Func_Bod) = N_Subprogram_Body);
5031 -- Create a flag to track the function state
5033 Flag_Id := Make_Temporary (Loc, 'F');
5034 Set_Status_Flag_Or_Transient_Decl (Ret_Obj_Id, Flag_Id);
5036 -- Insert the flag at the beginning of the function declarations,
5038 -- Fnn : Boolean := False;
5041 Make_Object_Declaration (Loc,
5042 Defining_Identifier => Flag_Id,
5043 Object_Definition =>
5044 New_Occurrence_Of (Standard_Boolean, Loc),
5046 New_Occurrence_Of (Standard_False, Loc));
5048 Prepend_To (Declarations (Func_Bod), Flag_Decl);
5049 Analyze (Flag_Decl);
5053 -- Build a simple_return_statement that returns the return object when
5054 -- there is a statement sequence, or no expression, or the result will
5055 -- be built in place. Note however that we currently do this for all
5056 -- composite cases, even though not all are built in place.
5059 or else Is_Composite_Type (Ret_Typ)
5065 -- If the extended return has a handled statement sequence, then wrap
5066 -- it in a block and use the block as the first statement.
5070 Make_Block_Statement (Loc,
5071 Declarations => New_List,
5072 Handled_Statement_Sequence => HSS));
5075 -- If the result type contains tasks, we call Move_Activation_Chain.
5076 -- Later, the cleanup code will call Complete_Master, which will
5077 -- terminate any unactivated tasks belonging to the return statement
5078 -- master. But Move_Activation_Chain updates their master to be that
5079 -- of the caller, so they will not be terminated unless the return
5080 -- statement completes unsuccessfully due to exception, abort, goto,
5081 -- or exit. As a formality, we test whether the function requires the
5082 -- result to be built in place, though that's necessarily true for
5083 -- the case of result types with task parts.
5085 if Is_BIP_Func and then Has_Task (Ret_Typ) then
5087 -- The return expression is an aggregate for a complex type which
5088 -- contains tasks. This particular case is left unexpanded since
5089 -- the regular expansion would insert all temporaries and
5090 -- initialization code in the wrong block.
5092 if Nkind (Exp) = N_Aggregate then
5093 Expand_N_Aggregate (Exp);
5096 -- Do not move the activation chain if the return object does not
5099 if Has_Task (Etype (Ret_Obj_Id)) then
5100 Append_To (Stmts, Move_Activation_Chain (Func_Id));
5104 -- Update the state of the function right before the object is
5107 if Is_BIP_Func and then Needs_Finalization (Etype (Ret_Obj_Id)) then
5109 Flag_Id : constant Entity_Id :=
5110 Status_Flag_Or_Transient_Decl (Ret_Obj_Id);
5117 Make_Assignment_Statement (Loc,
5118 Name => New_Occurrence_Of (Flag_Id, Loc),
5119 Expression => New_Occurrence_Of (Standard_True, Loc)));
5123 -- Build a simple_return_statement that returns the return object
5126 Make_Simple_Return_Statement (Loc,
5127 Expression => New_Occurrence_Of (Ret_Obj_Id, Loc));
5128 Append_To (Stmts, Return_Stmt);
5130 HSS := Make_Handled_Sequence_Of_Statements (Loc, Stmts);
5133 -- Case where we build a return statement block
5135 if Present (HSS) then
5137 Make_Block_Statement (Loc,
5138 Declarations => Return_Object_Declarations (N),
5139 Handled_Statement_Sequence => HSS);
5141 -- We set the entity of the new block statement to be that of the
5142 -- return statement. This is necessary so that various fields, such
5143 -- as Finalization_Chain_Entity carry over from the return statement
5144 -- to the block. Note that this block is unusual, in that its entity
5145 -- is an E_Return_Statement rather than an E_Block.
5148 (Result, New_Occurrence_Of (Return_Statement_Entity (N), Loc));
5150 -- If the object decl was already rewritten as a renaming, then we
5151 -- don't want to do the object allocation and transformation of
5152 -- the return object declaration to a renaming. This case occurs
5153 -- when the return object is initialized by a call to another
5154 -- build-in-place function, and that function is responsible for
5155 -- the allocation of the return object.
5158 and then Nkind (Ret_Obj_Decl) = N_Object_Renaming_Declaration
5161 (Nkind (Original_Node (Ret_Obj_Decl)) = N_Object_Declaration
5164 -- It is a regular BIP object declaration
5166 (Is_Build_In_Place_Function_Call
5167 (Expression (Original_Node (Ret_Obj_Decl)))
5169 -- It is a BIP object declaration that displaces the pointer
5170 -- to the object to reference a convered interface type.
5173 Present (Unqual_BIP_Iface_Function_Call
5174 (Expression (Original_Node (Ret_Obj_Decl))))));
5176 -- Return the build-in-place result by reference
5178 Set_By_Ref (Return_Stmt);
5180 elsif Is_BIP_Func then
5182 -- Locate the implicit access parameter associated with the
5183 -- caller-supplied return object and convert the return
5184 -- statement's return object declaration to a renaming of a
5185 -- dereference of the access parameter. If the return object's
5186 -- declaration includes an expression that has not already been
5187 -- expanded as separate assignments, then add an assignment
5188 -- statement to ensure the return object gets initialized.
5191 -- Result : T [:= <expression>];
5198 -- Result : T renames FuncRA.all;
5199 -- [Result := <expression;]
5204 Ret_Obj_Expr : constant Node_Id := Expression (Ret_Obj_Decl);
5205 Ret_Obj_Typ : constant Entity_Id := Etype (Ret_Obj_Id);
5207 Init_Assignment : Node_Id := Empty;
5208 Obj_Acc_Formal : Entity_Id;
5209 Obj_Acc_Deref : Node_Id;
5210 Obj_Alloc_Formal : Entity_Id;
5213 -- Build-in-place results must be returned by reference
5215 Set_By_Ref (Return_Stmt);
5217 -- Retrieve the implicit access parameter passed by the caller
5220 Build_In_Place_Formal (Func_Id, BIP_Object_Access);
5222 -- If the return object's declaration includes an expression
5223 -- and the declaration isn't marked as No_Initialization, then
5224 -- we need to generate an assignment to the object and insert
5225 -- it after the declaration before rewriting it as a renaming
5226 -- (otherwise we'll lose the initialization). The case where
5227 -- the result type is an interface (or class-wide interface)
5228 -- is also excluded because the context of the function call
5229 -- must be unconstrained, so the initialization will always
5230 -- be done as part of an allocator evaluation (storage pool
5231 -- or secondary stack), never to a constrained target object
5232 -- passed in by the caller. Besides the assignment being
5233 -- unneeded in this case, it avoids problems with trying to
5234 -- generate a dispatching assignment when the return expression
5235 -- is a nonlimited descendant of a limited interface (the
5236 -- interface has no assignment operation).
5238 if Present (Ret_Obj_Expr)
5239 and then not No_Initialization (Ret_Obj_Decl)
5240 and then not Is_Interface (Ret_Obj_Typ)
5243 Make_Assignment_Statement (Loc,
5244 Name => New_Occurrence_Of (Ret_Obj_Id, Loc),
5247 (Source => Ret_Obj_Expr,
5248 Scopes_In_EWA_OK => True));
5250 Set_Etype (Name (Init_Assignment), Etype (Ret_Obj_Id));
5251 Set_Assignment_OK (Name (Init_Assignment));
5252 Set_No_Ctrl_Actions (Init_Assignment);
5254 Set_Parent (Name (Init_Assignment), Init_Assignment);
5255 Set_Parent (Expression (Init_Assignment), Init_Assignment);
5257 Set_Expression (Ret_Obj_Decl, Empty);
5259 if Is_Class_Wide_Type (Etype (Ret_Obj_Id))
5260 and then not Is_Class_Wide_Type
5261 (Etype (Expression (Init_Assignment)))
5263 Rewrite (Expression (Init_Assignment),
5264 Make_Type_Conversion (Loc,
5266 New_Occurrence_Of (Etype (Ret_Obj_Id), Loc),
5268 Relocate_Node (Expression (Init_Assignment))));
5271 -- In the case of functions where the calling context can
5272 -- determine the form of allocation needed, initialization
5273 -- is done with each part of the if statement that handles
5274 -- the different forms of allocation (this is true for
5275 -- unconstrained, tagged, and controlled result subtypes).
5277 if not Needs_BIP_Alloc_Form (Func_Id) then
5278 Insert_After (Ret_Obj_Decl, Init_Assignment);
5282 -- When the function's subtype is unconstrained, a run-time
5283 -- test may be needed to decide the form of allocation to use
5284 -- for the return object. The function has an implicit formal
5285 -- parameter indicating this. If the BIP_Alloc_Form formal has
5286 -- the value one, then the caller has passed access to an
5287 -- existing object for use as the return object. If the value
5288 -- is two, then the return object must be allocated on the
5289 -- secondary stack. Otherwise, the object must be allocated in
5290 -- a storage pool. We generate an if statement to test the
5291 -- implicit allocation formal and initialize a local access
5292 -- value appropriately, creating allocators in the secondary
5293 -- stack and global heap cases. The special formal also exists
5294 -- and must be tested when the function has a tagged result,
5295 -- even when the result subtype is constrained, because in
5296 -- general such functions can be called in dispatching contexts
5297 -- and must be handled similarly to functions with a class-wide
5300 if Needs_BIP_Alloc_Form (Func_Id) then
5302 Build_In_Place_Formal (Func_Id, BIP_Alloc_Form);
5305 Pool_Id : constant Entity_Id :=
5306 Make_Temporary (Loc, 'P');
5307 Alloc_Obj_Id : Entity_Id;
5308 Alloc_Obj_Decl : Node_Id;
5309 Alloc_If_Stmt : Node_Id;
5310 Guard_Except : Node_Id;
5311 Heap_Allocator : Node_Id;
5312 Pool_Decl : Node_Id;
5313 Pool_Allocator : Node_Id;
5314 Ptr_Type_Decl : Node_Id;
5315 Ref_Type : Entity_Id;
5316 SS_Allocator : Node_Id;
5319 -- Create an access type designating the function's
5322 Ref_Type := Make_Temporary (Loc, 'A');
5325 Make_Full_Type_Declaration (Loc,
5326 Defining_Identifier => Ref_Type,
5328 Make_Access_To_Object_Definition (Loc,
5329 All_Present => True,
5330 Subtype_Indication =>
5331 New_Occurrence_Of (Ret_Obj_Typ, Loc)));
5333 Insert_Before (Ret_Obj_Decl, Ptr_Type_Decl);
5335 -- Create an access object that will be initialized to an
5336 -- access value denoting the return object, either coming
5337 -- from an implicit access value passed in by the caller
5338 -- or from the result of an allocator.
5340 Alloc_Obj_Id := Make_Temporary (Loc, 'R');
5341 Set_Etype (Alloc_Obj_Id, Ref_Type);
5344 Make_Object_Declaration (Loc,
5345 Defining_Identifier => Alloc_Obj_Id,
5346 Object_Definition =>
5347 New_Occurrence_Of (Ref_Type, Loc));
5349 Insert_Before (Ret_Obj_Decl, Alloc_Obj_Decl);
5351 -- Create allocators for both the secondary stack and
5352 -- global heap. If there's an initialization expression,
5353 -- then create these as initialized allocators.
5355 if Present (Ret_Obj_Expr)
5356 and then not No_Initialization (Ret_Obj_Decl)
5358 -- Always use the type of the expression for the
5359 -- qualified expression, rather than the result type.
5360 -- In general we cannot always use the result type
5361 -- for the allocator, because the expression might be
5362 -- of a specific type, such as in the case of an
5363 -- aggregate or even a nonlimited object when the
5364 -- result type is a limited class-wide interface type.
5367 Make_Allocator (Loc,
5369 Make_Qualified_Expression (Loc,
5372 (Etype (Ret_Obj_Expr), Loc),
5375 (Source => Ret_Obj_Expr,
5376 Scopes_In_EWA_OK => True)));
5379 -- If the function returns a class-wide type we cannot
5380 -- use the return type for the allocator. Instead we
5381 -- use the type of the expression, which must be an
5382 -- aggregate of a definite type.
5384 if Is_Class_Wide_Type (Ret_Obj_Typ) then
5386 Make_Allocator (Loc,
5389 (Etype (Ret_Obj_Expr), Loc));
5392 Make_Allocator (Loc,
5394 New_Occurrence_Of (Ret_Obj_Typ, Loc));
5397 -- If the object requires default initialization then
5398 -- that will happen later following the elaboration of
5399 -- the object renaming. If we don't turn it off here
5400 -- then the object will be default initialized twice.
5402 Set_No_Initialization (Heap_Allocator);
5405 -- Set the flag indicating that the allocator came from
5406 -- a build-in-place return statement, so we can avoid
5407 -- adjusting the allocated object. Note that this flag
5408 -- will be inherited by the copies made below.
5410 Set_Alloc_For_BIP_Return (Heap_Allocator);
5412 -- The Pool_Allocator is just like the Heap_Allocator,
5413 -- except we set Storage_Pool and Procedure_To_Call so
5414 -- it will use the user-defined storage pool.
5418 (Source => Heap_Allocator,
5419 Scopes_In_EWA_OK => True);
5421 pragma Assert (Alloc_For_BIP_Return (Pool_Allocator));
5423 -- Do not generate the renaming of the build-in-place
5424 -- pool parameter on ZFP because the parameter is not
5425 -- created in the first place.
5427 if RTE_Available (RE_Root_Storage_Pool_Ptr) then
5429 Make_Object_Renaming_Declaration (Loc,
5430 Defining_Identifier => Pool_Id,
5433 (RTE (RE_Root_Storage_Pool), Loc),
5435 Make_Explicit_Dereference (Loc,
5437 (Build_In_Place_Formal
5438 (Func_Id, BIP_Storage_Pool), Loc)));
5439 Set_Storage_Pool (Pool_Allocator, Pool_Id);
5440 Set_Procedure_To_Call
5441 (Pool_Allocator, RTE (RE_Allocate_Any));
5443 Pool_Decl := Make_Null_Statement (Loc);
5446 -- If the No_Allocators restriction is active, then only
5447 -- an allocator for secondary stack allocation is needed.
5448 -- It's OK for such allocators to have Comes_From_Source
5449 -- set to False, because gigi knows not to flag them as
5450 -- being a violation of No_Implicit_Heap_Allocations.
5452 if Restriction_Active (No_Allocators) then
5453 SS_Allocator := Heap_Allocator;
5454 Heap_Allocator := Make_Null (Loc);
5455 Pool_Allocator := Make_Null (Loc);
5457 -- Otherwise the heap and pool allocators may be needed,
5458 -- so we make another allocator for secondary stack
5464 (Source => Heap_Allocator,
5465 Scopes_In_EWA_OK => True);
5467 pragma Assert (Alloc_For_BIP_Return (SS_Allocator));
5469 -- The heap and pool allocators are marked as
5470 -- Comes_From_Source since they correspond to an
5471 -- explicit user-written allocator (that is, it will
5472 -- only be executed on behalf of callers that call the
5473 -- function as initialization for such an allocator).
5474 -- Prevents errors when No_Implicit_Heap_Allocations
5477 Set_Comes_From_Source (Heap_Allocator, True);
5478 Set_Comes_From_Source (Pool_Allocator, True);
5481 -- The allocator is returned on the secondary stack
5483 Check_Restriction (No_Secondary_Stack, N);
5484 Set_Storage_Pool (SS_Allocator, RTE (RE_SS_Pool));
5485 Set_Procedure_To_Call
5486 (SS_Allocator, RTE (RE_SS_Allocate));
5488 -- The allocator is returned on the secondary stack,
5489 -- so indicate that the function return, as well as
5490 -- all blocks that encloses the allocator, must not
5491 -- release it. The flags must be set now because
5492 -- the decision to use the secondary stack is done
5493 -- very late in the course of expanding the return
5494 -- statement, past the point where these flags are
5497 Set_Uses_Sec_Stack (Func_Id);
5498 Set_Uses_Sec_Stack (Return_Statement_Entity (N));
5499 Set_Sec_Stack_Needed_For_Return
5500 (Return_Statement_Entity (N));
5501 Set_Enclosing_Sec_Stack_Return (N);
5503 -- Guard against poor expansion on the caller side by
5504 -- using a raise statement to catch out-of-range values
5505 -- of formal parameter BIP_Alloc_Form.
5507 if Exceptions_OK then
5509 Make_Raise_Program_Error (Loc,
5510 Reason => PE_Build_In_Place_Mismatch);
5512 Guard_Except := Make_Null_Statement (Loc);
5515 -- Create an if statement to test the BIP_Alloc_Form
5516 -- formal and initialize the access object to either the
5517 -- BIP_Object_Access formal (BIP_Alloc_Form =
5518 -- Caller_Allocation), the result of allocating the
5519 -- object in the secondary stack (BIP_Alloc_Form =
5520 -- Secondary_Stack), or else an allocator to create the
5521 -- return object in the heap or user-defined pool
5522 -- (BIP_Alloc_Form = Global_Heap or User_Storage_Pool).
5524 -- ??? An unchecked type conversion must be made in the
5525 -- case of assigning the access object formal to the
5526 -- local access object, because a normal conversion would
5527 -- be illegal in some cases (such as converting access-
5528 -- to-unconstrained to access-to-constrained), but the
5529 -- the unchecked conversion will presumably fail to work
5530 -- right in just such cases. It's not clear at all how to
5534 Make_If_Statement (Loc,
5538 New_Occurrence_Of (Obj_Alloc_Formal, Loc),
5540 Make_Integer_Literal (Loc,
5541 UI_From_Int (BIP_Allocation_Form'Pos
5542 (Caller_Allocation)))),
5544 Then_Statements => New_List (
5545 Make_Assignment_Statement (Loc,
5547 New_Occurrence_Of (Alloc_Obj_Id, Loc),
5549 Make_Unchecked_Type_Conversion (Loc,
5551 New_Occurrence_Of (Ref_Type, Loc),
5553 New_Occurrence_Of (Obj_Acc_Formal, Loc)))),
5555 Elsif_Parts => New_List (
5556 Make_Elsif_Part (Loc,
5560 New_Occurrence_Of (Obj_Alloc_Formal, Loc),
5562 Make_Integer_Literal (Loc,
5563 UI_From_Int (BIP_Allocation_Form'Pos
5564 (Secondary_Stack)))),
5566 Then_Statements => New_List (
5567 Make_Assignment_Statement (Loc,
5569 New_Occurrence_Of (Alloc_Obj_Id, Loc),
5570 Expression => SS_Allocator))),
5572 Make_Elsif_Part (Loc,
5576 New_Occurrence_Of (Obj_Alloc_Formal, Loc),
5578 Make_Integer_Literal (Loc,
5579 UI_From_Int (BIP_Allocation_Form'Pos
5582 Then_Statements => New_List (
5583 Build_Heap_Or_Pool_Allocator
5584 (Temp_Id => Alloc_Obj_Id,
5585 Temp_Typ => Ref_Type,
5587 Ret_Typ => Ret_Obj_Typ,
5588 Alloc_Expr => Heap_Allocator))),
5590 -- ???If all is well, we can put the following
5591 -- 'elsif' in the 'else', but this is a useful
5592 -- self-check in case caller and callee don't agree
5593 -- on whether BIPAlloc and so on should be passed.
5595 Make_Elsif_Part (Loc,
5599 New_Occurrence_Of (Obj_Alloc_Formal, Loc),
5601 Make_Integer_Literal (Loc,
5602 UI_From_Int (BIP_Allocation_Form'Pos
5603 (User_Storage_Pool)))),
5605 Then_Statements => New_List (
5607 Build_Heap_Or_Pool_Allocator
5608 (Temp_Id => Alloc_Obj_Id,
5609 Temp_Typ => Ref_Type,
5611 Ret_Typ => Ret_Obj_Typ,
5612 Alloc_Expr => Pool_Allocator)))),
5614 -- Raise Program_Error if it's none of the above;
5615 -- this is a compiler bug.
5617 Else_Statements => New_List (Guard_Except));
5619 -- If a separate initialization assignment was created
5620 -- earlier, append that following the assignment of the
5621 -- implicit access formal to the access object, to ensure
5622 -- that the return object is initialized in that case. In
5623 -- this situation, the target of the assignment must be
5624 -- rewritten to denote a dereference of the access to the
5625 -- return object passed in by the caller.
5627 if Present (Init_Assignment) then
5628 Rewrite (Name (Init_Assignment),
5629 Make_Explicit_Dereference (Loc,
5630 Prefix => New_Occurrence_Of (Alloc_Obj_Id, Loc)));
5633 (Original_Node (Name (Init_Assignment))));
5634 Set_Assignment_OK (Name (Init_Assignment));
5636 Set_Etype (Name (Init_Assignment), Etype (Ret_Obj_Id));
5639 (Then_Statements (Alloc_If_Stmt), Init_Assignment);
5642 Insert_Before (Ret_Obj_Decl, Alloc_If_Stmt);
5644 -- Remember the local access object for use in the
5645 -- dereference of the renaming created below.
5647 Obj_Acc_Formal := Alloc_Obj_Id;
5650 -- When the function's subtype is unconstrained and a run-time
5651 -- test is not needed, we nevertheless need to build the return
5652 -- using the function's result subtype.
5654 elsif not Is_Constrained (Underlying_Type (Etype (Func_Id)))
5657 Alloc_Obj_Id : Entity_Id;
5658 Alloc_Obj_Decl : Node_Id;
5659 Ptr_Type_Decl : Node_Id;
5660 Ref_Type : Entity_Id;
5663 -- Create an access type designating the function's
5666 Ref_Type := Make_Temporary (Loc, 'A');
5669 Make_Full_Type_Declaration (Loc,
5670 Defining_Identifier => Ref_Type,
5672 Make_Access_To_Object_Definition (Loc,
5673 All_Present => True,
5674 Subtype_Indication =>
5675 New_Occurrence_Of (Ret_Obj_Typ, Loc)));
5677 Insert_Before (Ret_Obj_Decl, Ptr_Type_Decl);
5679 -- Create an access object initialized to the conversion
5680 -- of the implicit access value passed in by the caller.
5682 Alloc_Obj_Id := Make_Temporary (Loc, 'R');
5683 Set_Etype (Alloc_Obj_Id, Ref_Type);
5685 -- See the ??? comment a few lines above about the use of
5686 -- an unchecked conversion here.
5689 Make_Object_Declaration (Loc,
5690 Defining_Identifier => Alloc_Obj_Id,
5691 Object_Definition =>
5692 New_Occurrence_Of (Ref_Type, Loc),
5694 Make_Unchecked_Type_Conversion (Loc,
5696 New_Occurrence_Of (Ref_Type, Loc),
5698 New_Occurrence_Of (Obj_Acc_Formal, Loc)));
5700 Insert_Before (Ret_Obj_Decl, Alloc_Obj_Decl);
5702 -- Remember the local access object for use in the
5703 -- dereference of the renaming created below.
5705 Obj_Acc_Formal := Alloc_Obj_Id;
5709 -- Replace the return object declaration with a renaming of a
5710 -- dereference of the access value designating the return
5714 Make_Explicit_Dereference (Loc,
5715 Prefix => New_Occurrence_Of (Obj_Acc_Formal, Loc));
5717 Rewrite (Ret_Obj_Decl,
5718 Make_Object_Renaming_Declaration (Loc,
5719 Defining_Identifier => Ret_Obj_Id,
5720 Access_Definition => Empty,
5721 Subtype_Mark => New_Occurrence_Of (Ret_Obj_Typ, Loc),
5722 Name => Obj_Acc_Deref));
5724 Set_Renamed_Object (Ret_Obj_Id, Obj_Acc_Deref);
5728 -- Case where we do not build a block
5731 -- We're about to drop Return_Object_Declarations on the floor, so
5732 -- we need to insert it, in case it got expanded into useful code.
5733 -- Remove side effects from expression, which may be duplicated in
5734 -- subsequent checks (see Expand_Simple_Function_Return).
5736 Insert_List_Before (N, Return_Object_Declarations (N));
5737 Remove_Side_Effects (Exp);
5739 -- Build simple_return_statement that returns the expression directly
5741 Return_Stmt := Make_Simple_Return_Statement (Loc, Expression => Exp);
5742 Result := Return_Stmt;
5745 -- Set the flag to prevent infinite recursion
5747 Set_Comes_From_Extended_Return_Statement (Return_Stmt);
5749 Rewrite (N, Result);
5750 Analyze (N, Suppress => All_Checks);
5751 end Expand_N_Extended_Return_Statement;
5753 ----------------------------
5754 -- Expand_N_Function_Call --
5755 ----------------------------
5757 procedure Expand_N_Function_Call (N : Node_Id) is
5760 end Expand_N_Function_Call;
5762 ---------------------------------------
5763 -- Expand_N_Procedure_Call_Statement --
5764 ---------------------------------------
5766 procedure Expand_N_Procedure_Call_Statement (N : Node_Id) is
5769 end Expand_N_Procedure_Call_Statement;
5771 --------------------------------------
5772 -- Expand_N_Simple_Return_Statement --
5773 --------------------------------------
5775 procedure Expand_N_Simple_Return_Statement (N : Node_Id) is
5777 -- Defend against previous errors (i.e. the return statement calls a
5778 -- function that is not available in configurable runtime).
5780 if Present (Expression (N))
5781 and then Nkind (Expression (N)) = N_Empty
5783 Check_Error_Detected;
5787 -- Distinguish the function and non-function cases:
5789 case Ekind (Return_Applies_To (Return_Statement_Entity (N))) is
5791 | E_Generic_Function
5793 Expand_Simple_Function_Return (N);
5797 | E_Generic_Procedure
5799 | E_Return_Statement
5801 Expand_Non_Function_Return (N);
5804 raise Program_Error;
5808 when RE_Not_Available =>
5810 end Expand_N_Simple_Return_Statement;
5812 ------------------------------
5813 -- Expand_N_Subprogram_Body --
5814 ------------------------------
5816 -- Add poll call if ATC polling is enabled, unless the body will be inlined
5819 -- Add dummy push/pop label nodes at start and end to clear any local
5820 -- exception indications if local-exception-to-goto optimization is active.
5822 -- Add return statement if last statement in body is not a return statement
5823 -- (this makes things easier on Gigi which does not want to have to handle
5824 -- a missing return).
5826 -- Add call to Activate_Tasks if body is a task activator
5828 -- Deal with possible detection of infinite recursion
5830 -- Eliminate body completely if convention stubbed
5832 -- Encode entity names within body, since we will not need to reference
5833 -- these entities any longer in the front end.
5835 -- Initialize scalar out parameters if Initialize/Normalize_Scalars
5837 -- Reset Pure indication if any parameter has root type System.Address
5838 -- or has any parameters of limited types, where limited means that the
5839 -- run-time view is limited (i.e. the full type is limited).
5843 procedure Expand_N_Subprogram_Body (N : Node_Id) is
5844 Body_Id : constant Entity_Id := Defining_Entity (N);
5845 HSS : constant Node_Id := Handled_Statement_Sequence (N);
5846 Loc : constant Source_Ptr := Sloc (N);
5848 procedure Add_Return (Spec_Id : Entity_Id; Stmts : List_Id);
5849 -- Append a return statement to the statement sequence Stmts if the last
5850 -- statement is not already a return or a goto statement. Note that the
5851 -- latter test is not critical, it does not matter if we add a few extra
5852 -- returns, since they get eliminated anyway later on. Spec_Id denotes
5853 -- the corresponding spec of the subprogram body.
5859 procedure Add_Return (Spec_Id : Entity_Id; Stmts : List_Id) is
5860 Last_Stmt : Node_Id;
5865 -- Get last statement, ignoring any Pop_xxx_Label nodes, which are
5866 -- not relevant in this context since they are not executable.
5868 Last_Stmt := Last (Stmts);
5869 while Nkind (Last_Stmt) in N_Pop_xxx_Label loop
5873 -- Now insert return unless last statement is a transfer
5875 if not Is_Transfer (Last_Stmt) then
5877 -- The source location for the return is the end label of the
5878 -- procedure if present. Otherwise use the sloc of the last
5879 -- statement in the list. If the list comes from a generated
5880 -- exception handler and we are not debugging generated code,
5881 -- all the statements within the handler are made invisible
5884 if Nkind (Parent (Stmts)) = N_Exception_Handler
5885 and then not Comes_From_Source (Parent (Stmts))
5887 Loc := Sloc (Last_Stmt);
5888 elsif Present (End_Label (HSS)) then
5889 Loc := Sloc (End_Label (HSS));
5891 Loc := Sloc (Last_Stmt);
5894 -- Append return statement, and set analyzed manually. We can't
5895 -- call Analyze on this return since the scope is wrong.
5897 -- Note: it almost works to push the scope and then do the Analyze
5898 -- call, but something goes wrong in some weird cases and it is
5899 -- not worth worrying about ???
5901 Stmt := Make_Simple_Return_Statement (Loc);
5903 -- The return statement is handled properly, and the call to the
5904 -- postcondition, inserted below, does not require information
5905 -- from the body either. However, that call is analyzed in the
5906 -- enclosing scope, and an elaboration check might improperly be
5907 -- added to it. A guard in Sem_Elab is needed to prevent that
5908 -- spurious check, see Check_Elab_Call.
5910 Append_To (Stmts, Stmt);
5911 Set_Analyzed (Stmt);
5913 -- Call the _Postconditions procedure if the related subprogram
5914 -- has contract assertions that need to be verified on exit.
5916 if Ekind (Spec_Id) = E_Procedure
5917 and then Present (Postconditions_Proc (Spec_Id))
5919 Insert_Action (Stmt,
5920 Make_Procedure_Call_Statement (Loc,
5922 New_Occurrence_Of (Postconditions_Proc (Spec_Id), Loc)));
5931 Spec_Id : Entity_Id;
5933 -- Start of processing for Expand_N_Subprogram_Body
5936 if Present (Corresponding_Spec (N)) then
5937 Spec_Id := Corresponding_Spec (N);
5942 -- If this is a Pure function which has any parameters whose root type
5943 -- is System.Address, reset the Pure indication.
5944 -- This check is also performed when the subprogram is frozen, but we
5945 -- repeat it on the body so that the indication is consistent, and so
5946 -- it applies as well to bodies without separate specifications.
5948 if Is_Pure (Spec_Id)
5949 and then Is_Subprogram (Spec_Id)
5950 and then not Has_Pragma_Pure_Function (Spec_Id)
5952 Check_Function_With_Address_Parameter (Spec_Id);
5954 if Spec_Id /= Body_Id then
5955 Set_Is_Pure (Body_Id, Is_Pure (Spec_Id));
5959 -- Set L to either the list of declarations if present, or to the list
5960 -- of statements if no declarations are present. This is used to insert
5961 -- new stuff at the start.
5963 if Is_Non_Empty_List (Declarations (N)) then
5964 L := Declarations (N);
5966 L := Statements (HSS);
5969 -- If local-exception-to-goto optimization active, insert dummy push
5970 -- statements at start, and dummy pop statements at end, but inhibit
5971 -- this if we have No_Exception_Handlers, since they are useless and
5972 -- interfere with analysis, e.g. by CodePeer. We also don't need these
5973 -- if we're unnesting subprograms because the only purpose of these
5974 -- nodes is to ensure we don't set a label in one subprogram and branch
5975 -- to it in another.
5977 if (Debug_Flag_Dot_G
5978 or else Restriction_Active (No_Exception_Propagation))
5979 and then not Restriction_Active (No_Exception_Handlers)
5980 and then not CodePeer_Mode
5981 and then not Unnest_Subprogram_Mode
5982 and then Is_Non_Empty_List (L)
5985 FS : constant Node_Id := First (L);
5986 FL : constant Source_Ptr := Sloc (FS);
5991 -- LS points to either last statement, if statements are present
5992 -- or to the last declaration if there are no statements present.
5993 -- It is the node after which the pop's are generated.
5995 if Is_Non_Empty_List (Statements (HSS)) then
5996 LS := Last (Statements (HSS));
6003 Insert_List_Before_And_Analyze (FS, New_List (
6004 Make_Push_Constraint_Error_Label (FL),
6005 Make_Push_Program_Error_Label (FL),
6006 Make_Push_Storage_Error_Label (FL)));
6008 Insert_List_After_And_Analyze (LS, New_List (
6009 Make_Pop_Constraint_Error_Label (LL),
6010 Make_Pop_Program_Error_Label (LL),
6011 Make_Pop_Storage_Error_Label (LL)));
6015 -- Need poll on entry to subprogram if polling enabled. We only do this
6016 -- for non-empty subprograms, since it does not seem necessary to poll
6017 -- for a dummy null subprogram.
6019 if Is_Non_Empty_List (L) then
6021 -- Do not add a polling call if the subprogram is to be inlined by
6022 -- the back-end, to avoid repeated calls with multiple inlinings.
6024 if Is_Inlined (Spec_Id)
6025 and then Front_End_Inlining
6026 and then Optimization_Level > 1
6030 Generate_Poll_Call (First (L));
6034 -- Initialize any scalar OUT args if Initialize/Normalize_Scalars
6036 if Init_Or_Norm_Scalars and then Is_Subprogram (Spec_Id) then
6042 -- Loop through formals
6044 F := First_Formal (Spec_Id);
6045 while Present (F) loop
6046 if Is_Scalar_Type (Etype (F))
6047 and then Ekind (F) = E_Out_Parameter
6049 Check_Restriction (No_Default_Initialization, F);
6051 -- Insert the initialization. We turn off validity checks
6052 -- for this assignment, since we do not want any check on
6053 -- the initial value itself (which may well be invalid).
6054 -- Predicate checks are disabled as well (RM 6.4.1 (13/3))
6057 Make_Assignment_Statement (Loc,
6058 Name => New_Occurrence_Of (F, Loc),
6059 Expression => Get_Simple_Init_Val (Etype (F), N));
6060 Set_Suppress_Assignment_Checks (A);
6062 Insert_Before_And_Analyze (First (L),
6063 A, Suppress => Validity_Check);
6071 -- Clear out statement list for stubbed procedure
6073 if Present (Corresponding_Spec (N)) then
6074 Set_Elaboration_Flag (N, Spec_Id);
6076 if Convention (Spec_Id) = Convention_Stubbed
6077 or else Is_Eliminated (Spec_Id)
6079 Set_Declarations (N, Empty_List);
6080 Set_Handled_Statement_Sequence (N,
6081 Make_Handled_Sequence_Of_Statements (Loc,
6082 Statements => New_List (Make_Null_Statement (Loc))));
6088 -- Create a set of discriminals for the next protected subprogram body
6090 if Is_List_Member (N)
6091 and then Present (Parent (List_Containing (N)))
6092 and then Nkind (Parent (List_Containing (N))) = N_Protected_Body
6093 and then Present (Next_Protected_Operation (N))
6095 Set_Discriminals (Parent (Base_Type (Scope (Spec_Id))));
6098 -- Returns_By_Ref flag is normally set when the subprogram is frozen but
6099 -- subprograms with no specs are not frozen.
6102 Typ : constant Entity_Id := Etype (Spec_Id);
6103 Utyp : constant Entity_Id := Underlying_Type (Typ);
6106 if Is_Limited_View (Typ) then
6107 Set_Returns_By_Ref (Spec_Id);
6109 elsif Present (Utyp) and then CW_Or_Has_Controlled_Part (Utyp) then
6110 Set_Returns_By_Ref (Spec_Id);
6114 -- For a procedure, we add a return for all possible syntactic ends of
6117 if Ekind_In (Spec_Id, E_Procedure, E_Generic_Procedure) then
6118 Add_Return (Spec_Id, Statements (HSS));
6120 if Present (Exception_Handlers (HSS)) then
6121 Except_H := First_Non_Pragma (Exception_Handlers (HSS));
6122 while Present (Except_H) loop
6123 Add_Return (Spec_Id, Statements (Except_H));
6124 Next_Non_Pragma (Except_H);
6128 -- For a function, we must deal with the case where there is at least
6129 -- one missing return. What we do is to wrap the entire body of the
6130 -- function in a block:
6143 -- raise Program_Error;
6146 -- This approach is necessary because the raise must be signalled to the
6147 -- caller, not handled by any local handler (RM 6.4(11)).
6149 -- Note: we do not need to analyze the constructed sequence here, since
6150 -- it has no handler, and an attempt to analyze the handled statement
6151 -- sequence twice is risky in various ways (e.g. the issue of expanding
6152 -- cleanup actions twice).
6154 elsif Has_Missing_Return (Spec_Id) then
6156 Hloc : constant Source_Ptr := Sloc (HSS);
6157 Blok : constant Node_Id :=
6158 Make_Block_Statement (Hloc,
6159 Handled_Statement_Sequence => HSS);
6160 Rais : constant Node_Id :=
6161 Make_Raise_Program_Error (Hloc,
6162 Reason => PE_Missing_Return);
6165 Set_Handled_Statement_Sequence (N,
6166 Make_Handled_Sequence_Of_Statements (Hloc,
6167 Statements => New_List (Blok, Rais)));
6169 Push_Scope (Spec_Id);
6176 -- If subprogram contains a parameterless recursive call, then we may
6177 -- have an infinite recursion, so see if we can generate code to check
6178 -- for this possibility if storage checks are not suppressed.
6180 if Ekind (Spec_Id) = E_Procedure
6181 and then Has_Recursive_Call (Spec_Id)
6182 and then not Storage_Checks_Suppressed (Spec_Id)
6184 Detect_Infinite_Recursion (N, Spec_Id);
6187 -- Set to encode entity names in package body before gigi is called
6189 Qualify_Entity_Names (N);
6191 -- If the body belongs to a nonabstract library-level source primitive
6192 -- of a tagged type, install an elaboration check which ensures that a
6193 -- dispatching call targeting the primitive will not execute the body
6194 -- without it being previously elaborated.
6196 Install_Primitive_Elaboration_Check (N);
6197 end Expand_N_Subprogram_Body;
6199 -----------------------------------
6200 -- Expand_N_Subprogram_Body_Stub --
6201 -----------------------------------
6203 procedure Expand_N_Subprogram_Body_Stub (N : Node_Id) is
6207 if Present (Corresponding_Body (N)) then
6208 Bod := Unit_Declaration_Node (Corresponding_Body (N));
6210 -- The body may have been expanded already when it is analyzed
6211 -- through the subunit node. Do no expand again: it interferes
6212 -- with the construction of unnesting tables when generating C.
6214 if not Analyzed (Bod) then
6215 Expand_N_Subprogram_Body (Bod);
6218 -- Add full qualification to entities that may be created late
6219 -- during unnesting.
6221 Qualify_Entity_Names (N);
6223 end Expand_N_Subprogram_Body_Stub;
6225 -------------------------------------
6226 -- Expand_N_Subprogram_Declaration --
6227 -------------------------------------
6229 -- If the declaration appears within a protected body, it is a private
6230 -- operation of the protected type. We must create the corresponding
6231 -- protected subprogram an associated formals. For a normal protected
6232 -- operation, this is done when expanding the protected type declaration.
6234 -- If the declaration is for a null procedure, emit null body
6236 procedure Expand_N_Subprogram_Declaration (N : Node_Id) is
6237 Loc : constant Source_Ptr := Sloc (N);
6238 Subp : constant Entity_Id := Defining_Entity (N);
6242 Scop : constant Entity_Id := Scope (Subp);
6244 Prot_Decl : Node_Id;
6245 Prot_Id : Entity_Id;
6247 -- Start of processing for Expand_N_Subprogram_Declaration
6250 -- In SPARK, subprogram declarations are only allowed in package
6253 if Nkind (Parent (N)) /= N_Package_Specification then
6254 if Nkind (Parent (N)) = N_Compilation_Unit then
6255 Check_SPARK_05_Restriction
6256 ("subprogram declaration is not a library item", N);
6258 elsif Present (Next (N))
6259 and then Nkind (Next (N)) = N_Pragma
6260 and then Get_Pragma_Id (Next (N)) = Pragma_Import
6262 -- In SPARK, subprogram declarations are also permitted in
6263 -- declarative parts when immediately followed by a corresponding
6264 -- pragma Import. We only check here that there is some pragma
6269 Check_SPARK_05_Restriction
6270 ("subprogram declaration is not allowed here", N);
6274 -- Deal with case of protected subprogram. Do not generate protected
6275 -- operation if operation is flagged as eliminated.
6277 if Is_List_Member (N)
6278 and then Present (Parent (List_Containing (N)))
6279 and then Nkind (Parent (List_Containing (N))) = N_Protected_Body
6280 and then Is_Protected_Type (Scop)
6282 if No (Protected_Body_Subprogram (Subp))
6283 and then not Is_Eliminated (Subp)
6286 Make_Subprogram_Declaration (Loc,
6288 Build_Protected_Sub_Specification
6289 (N, Scop, Unprotected_Mode));
6291 -- The protected subprogram is declared outside of the protected
6292 -- body. Given that the body has frozen all entities so far, we
6293 -- analyze the subprogram and perform freezing actions explicitly.
6294 -- including the generation of an explicit freeze node, to ensure
6295 -- that gigi has the proper order of elaboration.
6296 -- If the body is a subunit, the insertion point is before the
6297 -- stub in the parent.
6299 Prot_Bod := Parent (List_Containing (N));
6301 if Nkind (Parent (Prot_Bod)) = N_Subunit then
6302 Prot_Bod := Corresponding_Stub (Parent (Prot_Bod));
6305 Insert_Before (Prot_Bod, Prot_Decl);
6306 Prot_Id := Defining_Unit_Name (Specification (Prot_Decl));
6307 Set_Has_Delayed_Freeze (Prot_Id);
6309 Push_Scope (Scope (Scop));
6310 Analyze (Prot_Decl);
6311 Freeze_Before (N, Prot_Id);
6312 Set_Protected_Body_Subprogram (Subp, Prot_Id);
6314 -- Create protected operation as well. Even though the operation
6315 -- is only accessible within the body, it is possible to make it
6316 -- available outside of the protected object by using 'Access to
6317 -- provide a callback, so build protected version in all cases.
6320 Make_Subprogram_Declaration (Loc,
6322 Build_Protected_Sub_Specification (N, Scop, Protected_Mode));
6323 Insert_Before (Prot_Bod, Prot_Decl);
6324 Analyze (Prot_Decl);
6329 -- Ada 2005 (AI-348): Generate body for a null procedure. In most
6330 -- cases this is superfluous because calls to it will be automatically
6331 -- inlined, but we definitely need the body if preconditions for the
6332 -- procedure are present, or if performing coverage analysis.
6334 elsif Nkind (Specification (N)) = N_Procedure_Specification
6335 and then Null_Present (Specification (N))
6338 Bod : constant Node_Id := Body_To_Inline (N);
6341 Set_Has_Completion (Subp, False);
6342 Append_Freeze_Action (Subp, Bod);
6344 -- The body now contains raise statements, so calls to it will
6347 Set_Is_Inlined (Subp, False);
6351 -- When generating C code, transform a function that returns a
6352 -- constrained array type into a procedure with an out parameter
6353 -- that carries the return value.
6355 -- We skip this transformation for unchecked conversions, since they
6356 -- are not needed by the C generator (and this also produces cleaner
6359 if Modify_Tree_For_C
6360 and then Nkind (Specification (N)) = N_Function_Specification
6361 and then Is_Array_Type (Etype (Subp))
6362 and then Is_Constrained (Etype (Subp))
6363 and then not Is_Unchecked_Conversion_Instance (Subp)
6365 Build_Procedure_Form (N);
6367 end Expand_N_Subprogram_Declaration;
6369 --------------------------------
6370 -- Expand_Non_Function_Return --
6371 --------------------------------
6373 procedure Expand_Non_Function_Return (N : Node_Id) is
6374 pragma Assert (No (Expression (N)));
6376 Loc : constant Source_Ptr := Sloc (N);
6377 Scope_Id : Entity_Id := Return_Applies_To (Return_Statement_Entity (N));
6378 Kind : constant Entity_Kind := Ekind (Scope_Id);
6381 Goto_Stat : Node_Id;
6385 -- Call the _Postconditions procedure if the related subprogram has
6386 -- contract assertions that need to be verified on exit.
6388 if Ekind_In (Scope_Id, E_Entry, E_Entry_Family, E_Procedure)
6389 and then Present (Postconditions_Proc (Scope_Id))
6392 Make_Procedure_Call_Statement (Loc,
6393 Name => New_Occurrence_Of (Postconditions_Proc (Scope_Id), Loc)));
6396 -- If it is a return from a procedure do no extra steps
6398 if Kind = E_Procedure or else Kind = E_Generic_Procedure then
6401 -- If it is a nested return within an extended one, replace it with a
6402 -- return of the previously declared return object.
6404 elsif Kind = E_Return_Statement then
6406 Make_Simple_Return_Statement (Loc,
6408 New_Occurrence_Of (First_Entity (Scope_Id), Loc)));
6409 Set_Comes_From_Extended_Return_Statement (N);
6410 Set_Return_Statement_Entity (N, Scope_Id);
6411 Expand_Simple_Function_Return (N);
6415 pragma Assert (Is_Entry (Scope_Id));
6417 -- Look at the enclosing block to see whether the return is from an
6418 -- accept statement or an entry body.
6420 for J in reverse 0 .. Scope_Stack.Last loop
6421 Scope_Id := Scope_Stack.Table (J).Entity;
6422 exit when Is_Concurrent_Type (Scope_Id);
6425 -- If it is a return from accept statement it is expanded as call to
6426 -- RTS Complete_Rendezvous and a goto to the end of the accept body.
6428 -- (cf : Expand_N_Accept_Statement, Expand_N_Selective_Accept,
6429 -- Expand_N_Accept_Alternative in exp_ch9.adb)
6431 if Is_Task_Type (Scope_Id) then
6434 Make_Procedure_Call_Statement (Loc,
6435 Name => New_Occurrence_Of (RTE (RE_Complete_Rendezvous), Loc));
6436 Insert_Before (N, Call);
6437 -- why not insert actions here???
6440 Acc_Stat := Parent (N);
6441 while Nkind (Acc_Stat) /= N_Accept_Statement loop
6442 Acc_Stat := Parent (Acc_Stat);
6445 Lab_Node := Last (Statements
6446 (Handled_Statement_Sequence (Acc_Stat)));
6448 Goto_Stat := Make_Goto_Statement (Loc,
6449 Name => New_Occurrence_Of
6450 (Entity (Identifier (Lab_Node)), Loc));
6452 Set_Analyzed (Goto_Stat);
6454 Rewrite (N, Goto_Stat);
6457 -- If it is a return from an entry body, put a Complete_Entry_Body call
6458 -- in front of the return.
6460 elsif Is_Protected_Type (Scope_Id) then
6462 Make_Procedure_Call_Statement (Loc,
6464 New_Occurrence_Of (RTE (RE_Complete_Entry_Body), Loc),
6465 Parameter_Associations => New_List (
6466 Make_Attribute_Reference (Loc,
6469 (Find_Protection_Object (Current_Scope), Loc),
6470 Attribute_Name => Name_Unchecked_Access)));
6472 Insert_Before (N, Call);
6475 end Expand_Non_Function_Return;
6477 ---------------------------------------
6478 -- Expand_Protected_Object_Reference --
6479 ---------------------------------------
6481 function Expand_Protected_Object_Reference
6483 Scop : Entity_Id) return Node_Id
6485 Loc : constant Source_Ptr := Sloc (N);
6492 Rec := Make_Identifier (Loc, Name_uObject);
6493 Set_Etype (Rec, Corresponding_Record_Type (Scop));
6495 -- Find enclosing protected operation, and retrieve its first parameter,
6496 -- which denotes the enclosing protected object. If the enclosing
6497 -- operation is an entry, we are immediately within the protected body,
6498 -- and we can retrieve the object from the service entries procedure. A
6499 -- barrier function has the same signature as an entry. A barrier
6500 -- function is compiled within the protected object, but unlike
6501 -- protected operations its never needs locks, so that its protected
6502 -- body subprogram points to itself.
6504 Proc := Current_Scope;
6505 while Present (Proc)
6506 and then Scope (Proc) /= Scop
6508 Proc := Scope (Proc);
6511 Corr := Protected_Body_Subprogram (Proc);
6515 -- Previous error left expansion incomplete.
6516 -- Nothing to do on this call.
6523 (First (Parameter_Specifications (Parent (Corr))));
6525 if Is_Subprogram (Proc) and then Proc /= Corr then
6527 -- Protected function or procedure
6529 Set_Entity (Rec, Param);
6531 -- Rec is a reference to an entity which will not be in scope when
6532 -- the call is reanalyzed, and needs no further analysis.
6537 -- Entry or barrier function for entry body. The first parameter of
6538 -- the entry body procedure is pointer to the object. We create a
6539 -- local variable of the proper type, duplicating what is done to
6540 -- define _object later on.
6544 Obj_Ptr : constant Entity_Id := Make_Temporary (Loc, 'T');
6548 Make_Full_Type_Declaration (Loc,
6549 Defining_Identifier => Obj_Ptr,
6551 Make_Access_To_Object_Definition (Loc,
6552 Subtype_Indication =>
6554 (Corresponding_Record_Type (Scop), Loc))));
6556 Insert_Actions (N, Decls);
6557 Freeze_Before (N, Obj_Ptr);
6560 Make_Explicit_Dereference (Loc,
6562 Unchecked_Convert_To (Obj_Ptr,
6563 New_Occurrence_Of (Param, Loc)));
6565 -- Analyze new actual. Other actuals in calls are already analyzed
6566 -- and the list of actuals is not reanalyzed after rewriting.
6568 Set_Parent (Rec, N);
6574 end Expand_Protected_Object_Reference;
6576 --------------------------------------
6577 -- Expand_Protected_Subprogram_Call --
6578 --------------------------------------
6580 procedure Expand_Protected_Subprogram_Call
6587 procedure Expand_Internal_Init_Call;
6588 -- A call to an operation of the type may occur in the initialization
6589 -- of a private component. In that case the prefix of the call is an
6590 -- entity name and the call is treated as internal even though it
6591 -- appears in code outside of the protected type.
6593 procedure Freeze_Called_Function;
6594 -- If it is a function call it can appear in elaboration code and
6595 -- the called entity must be frozen before the call. This must be
6596 -- done before the call is expanded, as the expansion may rewrite it
6597 -- to something other than a call (e.g. a temporary initialized in a
6598 -- transient block).
6600 -------------------------------
6601 -- Expand_Internal_Init_Call --
6602 -------------------------------
6604 procedure Expand_Internal_Init_Call is
6606 -- If the context is a protected object (rather than a protected
6607 -- type) the call itself is bound to raise program_error because
6608 -- the protected body will not have been elaborated yet. This is
6609 -- diagnosed subsequently in Sem_Elab.
6611 Freeze_Called_Function;
6613 -- The target of the internal call is the first formal of the
6614 -- enclosing initialization procedure.
6616 Rec := New_Occurrence_Of (First_Formal (Current_Scope), Sloc (N));
6617 Build_Protected_Subprogram_Call (N,
6622 Resolve (N, Etype (Subp));
6623 end Expand_Internal_Init_Call;
6625 ----------------------------
6626 -- Freeze_Called_Function --
6627 ----------------------------
6629 procedure Freeze_Called_Function is
6631 if Ekind (Subp) = E_Function then
6632 Freeze_Expression (Name (N));
6634 end Freeze_Called_Function;
6636 -- Start of processing for Expand_Protected_Subprogram_Call
6639 -- If the protected object is not an enclosing scope, this is an inter-
6640 -- object function call. Inter-object procedure calls are expanded by
6641 -- Exp_Ch9.Build_Simple_Entry_Call. The call is intra-object only if the
6642 -- subprogram being called is in the protected body being compiled, and
6643 -- if the protected object in the call is statically the enclosing type.
6644 -- The object may be a component of some other data structure, in which
6645 -- case this must be handled as an inter-object call.
6647 if not In_Open_Scopes (Scop)
6648 or else Is_Entry_Wrapper (Current_Scope)
6649 or else not Is_Entity_Name (Name (N))
6651 if Nkind (Name (N)) = N_Selected_Component then
6652 Rec := Prefix (Name (N));
6654 elsif Nkind (Name (N)) = N_Indexed_Component then
6655 Rec := Prefix (Prefix (Name (N)));
6657 -- If this is a call within an entry wrapper, it appears within a
6658 -- precondition that calls another primitive of the synchronized
6659 -- type. The target object of the call is the first actual on the
6660 -- wrapper. Note that this is an external call, because the wrapper
6661 -- is called outside of the synchronized object. This means that
6662 -- an entry call to an entry with preconditions involves two
6663 -- synchronized operations.
6665 elsif Ekind (Current_Scope) = E_Procedure
6666 and then Is_Entry_Wrapper (Current_Scope)
6668 Rec := New_Occurrence_Of (First_Entity (Current_Scope), Sloc (N));
6670 -- A default parameter of a protected operation may be a call to
6671 -- a protected function of the type. This appears as an internal
6672 -- call in the profile of the operation, but if the context is an
6673 -- external call we must convert the call into an external one,
6674 -- using the protected object that is the target, so that:
6677 -- is transformed into
6680 elsif Nkind (Parent (N)) = N_Procedure_Call_Statement
6681 and then Nkind (Name (Parent (N))) = N_Selected_Component
6682 and then Is_Protected_Type (Etype (Prefix (Name (Parent (N)))))
6683 and then Is_Entity_Name (Name (N))
6684 and then Scope (Entity (Name (N))) =
6685 Etype (Prefix (Name (Parent (N))))
6688 Make_Selected_Component (Sloc (N),
6689 Prefix => New_Copy_Tree (Prefix (Name (Parent (N)))),
6690 Selector_Name => Relocate_Node (Name (N))));
6692 Analyze_And_Resolve (N);
6696 -- If the context is the initialization procedure for a protected
6697 -- type, the call is legal because the called entity must be a
6698 -- function of that enclosing type, and this is treated as an
6702 (Is_Entity_Name (Name (N)) and then Inside_Init_Proc);
6704 Expand_Internal_Init_Call;
6708 Freeze_Called_Function;
6709 Build_Protected_Subprogram_Call (N,
6710 Name => New_Occurrence_Of (Subp, Sloc (N)),
6711 Rec => Convert_Concurrent (Rec, Etype (Rec)),
6715 Rec := Expand_Protected_Object_Reference (N, Scop);
6721 Freeze_Called_Function;
6722 Build_Protected_Subprogram_Call (N,
6728 -- Analyze and resolve the new call. The actuals have already been
6729 -- resolved, but expansion of a function call will add extra actuals
6730 -- if needed. Analysis of a procedure call already includes resolution.
6734 if Ekind (Subp) = E_Function then
6735 Resolve (N, Etype (Subp));
6737 end Expand_Protected_Subprogram_Call;
6739 -----------------------------------
6740 -- Expand_Simple_Function_Return --
6741 -----------------------------------
6743 -- The "simple" comes from the syntax rule simple_return_statement. The
6744 -- semantics are not at all simple.
6746 procedure Expand_Simple_Function_Return (N : Node_Id) is
6747 Loc : constant Source_Ptr := Sloc (N);
6749 Scope_Id : constant Entity_Id :=
6750 Return_Applies_To (Return_Statement_Entity (N));
6751 -- The function we are returning from
6753 R_Type : constant Entity_Id := Etype (Scope_Id);
6754 -- The result type of the function
6756 Utyp : constant Entity_Id := Underlying_Type (R_Type);
6758 Exp : Node_Id := Expression (N);
6759 pragma Assert (Present (Exp));
6761 Exptyp : constant Entity_Id := Etype (Exp);
6762 -- The type of the expression (not necessarily the same as R_Type)
6764 Subtype_Ind : Node_Id;
6765 -- If the result type of the function is class-wide and the expression
6766 -- has a specific type, then we use the expression's type as the type of
6767 -- the return object. In cases where the expression is an aggregate that
6768 -- is built in place, this avoids the need for an expensive conversion
6769 -- of the return object to the specific type on assignments to the
6770 -- individual components.
6773 if Is_Class_Wide_Type (R_Type)
6774 and then not Is_Class_Wide_Type (Exptyp)
6775 and then Nkind (Exp) /= N_Type_Conversion
6777 Subtype_Ind := New_Occurrence_Of (Exptyp, Loc);
6779 Subtype_Ind := New_Occurrence_Of (R_Type, Loc);
6781 -- If the result type is class-wide and the expression is a view
6782 -- conversion, the conversion plays no role in the expansion because
6783 -- it does not modify the tag of the object. Remove the conversion
6784 -- altogether to prevent tag overwriting.
6786 if Is_Class_Wide_Type (R_Type)
6787 and then not Is_Class_Wide_Type (Exptyp)
6788 and then Nkind (Exp) = N_Type_Conversion
6790 Exp := Expression (Exp);
6794 -- Assert that if F says "return G(...);"
6795 -- then F and G are both b-i-p, or neither b-i-p.
6797 if Nkind (Exp) = N_Function_Call then
6798 pragma Assert (Ekind (Scope_Id) = E_Function);
6800 (Is_Build_In_Place_Function (Scope_Id) =
6801 Is_Build_In_Place_Function_Call (Exp));
6805 -- For the case of a simple return that does not come from an
6806 -- extended return, in the case of build-in-place, we rewrite
6807 -- "return <expression>;" to be:
6809 -- return _anon_ : <return_subtype> := <expression>
6811 -- The expansion produced by Expand_N_Extended_Return_Statement will
6812 -- contain simple return statements (for example, a block containing
6813 -- simple return of the return object), which brings us back here with
6814 -- Comes_From_Extended_Return_Statement set. The reason for the barrier
6815 -- checking for a simple return that does not come from an extended
6816 -- return is to avoid this infinite recursion.
6818 -- The reason for this design is that for Ada 2005 limited returns, we
6819 -- need to reify the return object, so we can build it "in place", and
6820 -- we need a block statement to hang finalization and tasking stuff.
6822 -- ??? In order to avoid disruption, we avoid translating to extended
6823 -- return except in the cases where we really need to (Ada 2005 for
6824 -- inherently limited). We might prefer to do this translation in all
6825 -- cases (except perhaps for the case of Ada 95 inherently limited),
6826 -- in order to fully exercise the Expand_N_Extended_Return_Statement
6827 -- code. This would also allow us to do the build-in-place optimization
6828 -- for efficiency even in cases where it is semantically not required.
6830 -- As before, we check the type of the return expression rather than the
6831 -- return type of the function, because the latter may be a limited
6832 -- class-wide interface type, which is not a limited type, even though
6833 -- the type of the expression may be.
6836 (Comes_From_Extended_Return_Statement (N)
6837 or else not Is_Build_In_Place_Function_Call (Exp)
6838 or else Is_Build_In_Place_Function (Scope_Id));
6840 if not Comes_From_Extended_Return_Statement (N)
6841 and then Is_Build_In_Place_Function (Scope_Id)
6842 and then not Debug_Flag_Dot_L
6844 -- The functionality of interface thunks is simple and it is always
6845 -- handled by means of simple return statements. This leaves their
6846 -- expansion simple and clean.
6848 and then not Is_Thunk (Current_Scope)
6851 Return_Object_Entity : constant Entity_Id :=
6852 Make_Temporary (Loc, 'R', Exp);
6854 Obj_Decl : constant Node_Id :=
6855 Make_Object_Declaration (Loc,
6856 Defining_Identifier => Return_Object_Entity,
6857 Object_Definition => Subtype_Ind,
6860 Ext : constant Node_Id :=
6861 Make_Extended_Return_Statement (Loc,
6862 Return_Object_Declarations => New_List (Obj_Decl));
6863 -- Do not perform this high-level optimization if the result type
6864 -- is an interface because the "this" pointer must be displaced.
6873 -- Here we have a simple return statement that is part of the expansion
6874 -- of an extended return statement (either written by the user, or
6875 -- generated by the above code).
6877 -- Always normalize C/Fortran boolean result. This is not always needed,
6878 -- but it seems a good idea to minimize the passing around of non-
6879 -- normalized values, and in any case this handles the processing of
6880 -- barrier functions for protected types, which turn the condition into
6881 -- a return statement.
6883 if Is_Boolean_Type (Exptyp)
6884 and then Nonzero_Is_True (Exptyp)
6886 Adjust_Condition (Exp);
6887 Adjust_Result_Type (Exp, Exptyp);
6890 -- Do validity check if enabled for returns
6892 if Validity_Checks_On
6893 and then Validity_Check_Returns
6898 -- Check the result expression of a scalar function against the subtype
6899 -- of the function by inserting a conversion. This conversion must
6900 -- eventually be performed for other classes of types, but for now it's
6901 -- only done for scalars.
6904 if Is_Scalar_Type (Exptyp) then
6905 Rewrite (Exp, Convert_To (R_Type, Exp));
6907 -- The expression is resolved to ensure that the conversion gets
6908 -- expanded to generate a possible constraint check.
6910 Analyze_And_Resolve (Exp, R_Type);
6913 -- Deal with returning variable length objects and controlled types
6915 -- Nothing to do if we are returning by reference, or this is not a
6916 -- type that requires special processing (indicated by the fact that
6917 -- it requires a cleanup scope for the secondary stack case).
6919 if Is_Build_In_Place_Function (Scope_Id)
6920 or else Is_Limited_Interface (Exptyp)
6924 -- No copy needed for thunks returning interface type objects since
6925 -- the object is returned by reference and the maximum functionality
6926 -- required is just to displace the pointer.
6928 elsif Is_Thunk (Current_Scope) and then Is_Interface (Exptyp) then
6931 -- If the call is within a thunk and the type is a limited view, the
6932 -- backend will eventually see the non-limited view of the type.
6934 elsif Is_Thunk (Current_Scope) and then Is_Incomplete_Type (Exptyp) then
6937 -- A return statement from an ignored Ghost function does not use the
6938 -- secondary stack (or any other one).
6940 elsif not Requires_Transient_Scope (R_Type)
6941 or else Is_Ignored_Ghost_Entity (Scope_Id)
6944 -- Mutable records with variable-length components are not returned
6945 -- on the sec-stack, so we need to make sure that the back end will
6946 -- only copy back the size of the actual value, and not the maximum
6947 -- size. We create an actual subtype for this purpose. However we
6948 -- need not do it if the expression is a function call since this
6949 -- will be done in the called function and doing it here too would
6950 -- cause a temporary with maximum size to be created.
6953 Ubt : constant Entity_Id := Underlying_Type (Base_Type (Exptyp));
6957 if Nkind (Exp) /= N_Function_Call
6958 and then Has_Discriminants (Ubt)
6959 and then not Is_Constrained (Ubt)
6960 and then not Has_Unchecked_Union (Ubt)
6962 Decl := Build_Actual_Subtype (Ubt, Exp);
6963 Ent := Defining_Identifier (Decl);
6964 Insert_Action (Exp, Decl);
6965 Rewrite (Exp, Unchecked_Convert_To (Ent, Exp));
6966 Analyze_And_Resolve (Exp);
6970 -- Here if secondary stack is used
6973 -- Prevent the reclamation of the secondary stack by all enclosing
6974 -- blocks and loops as well as the related function; otherwise the
6975 -- result would be reclaimed too early.
6977 Set_Enclosing_Sec_Stack_Return (N);
6979 -- Optimize the case where the result is a function call. In this
6980 -- case either the result is already on the secondary stack, or is
6981 -- already being returned with the stack pointer depressed and no
6982 -- further processing is required except to set the By_Ref flag
6983 -- to ensure that gigi does not attempt an extra unnecessary copy.
6984 -- (actually not just unnecessary but harmfully wrong in the case
6985 -- of a controlled type, where gigi does not know how to do a copy).
6986 -- To make up for a gcc 2.8.1 deficiency (???), we perform the copy
6987 -- for array types if the constrained status of the target type is
6988 -- different from that of the expression.
6990 if Requires_Transient_Scope (Exptyp)
6992 (not Is_Array_Type (Exptyp)
6993 or else Is_Constrained (Exptyp) = Is_Constrained (R_Type)
6994 or else CW_Or_Has_Controlled_Part (Utyp))
6995 and then Nkind (Exp) = N_Function_Call
6999 -- Remove side effects from the expression now so that other parts
7000 -- of the expander do not have to reanalyze this node without this
7003 Rewrite (Exp, Duplicate_Subexpr_No_Checks (Exp));
7005 -- Ada 2005 (AI-251): If the type of the returned object is
7006 -- an interface then add an implicit type conversion to force
7007 -- displacement of the "this" pointer.
7009 if Is_Interface (R_Type) then
7010 Rewrite (Exp, Convert_To (R_Type, Relocate_Node (Exp)));
7013 Analyze_And_Resolve (Exp, R_Type);
7015 -- For controlled types, do the allocation on the secondary stack
7016 -- manually in order to call adjust at the right time:
7018 -- type Anon1 is access R_Type;
7019 -- for Anon1'Storage_pool use ss_pool;
7020 -- Anon2 : anon1 := new R_Type'(expr);
7021 -- return Anon2.all;
7023 -- We do the same for classwide types that are not potentially
7024 -- controlled (by the virtue of restriction No_Finalization) because
7025 -- gigi is not able to properly allocate class-wide types.
7027 elsif CW_Or_Has_Controlled_Part (Utyp) then
7029 Loc : constant Source_Ptr := Sloc (N);
7030 Acc_Typ : constant Entity_Id := Make_Temporary (Loc, 'A');
7031 Alloc_Node : Node_Id;
7035 Set_Ekind (Acc_Typ, E_Access_Type);
7037 Set_Associated_Storage_Pool (Acc_Typ, RTE (RE_SS_Pool));
7039 -- This is an allocator for the secondary stack, and it's fine
7040 -- to have Comes_From_Source set False on it, as gigi knows not
7041 -- to flag it as a violation of No_Implicit_Heap_Allocations.
7044 Make_Allocator (Loc,
7046 Make_Qualified_Expression (Loc,
7047 Subtype_Mark => New_Occurrence_Of (Etype (Exp), Loc),
7048 Expression => Relocate_Node (Exp)));
7050 -- We do not want discriminant checks on the declaration,
7051 -- given that it gets its value from the allocator.
7053 Set_No_Initialization (Alloc_Node);
7055 Temp := Make_Temporary (Loc, 'R', Alloc_Node);
7057 Insert_List_Before_And_Analyze (N, New_List (
7058 Make_Full_Type_Declaration (Loc,
7059 Defining_Identifier => Acc_Typ,
7061 Make_Access_To_Object_Definition (Loc,
7062 Subtype_Indication => Subtype_Ind)),
7064 Make_Object_Declaration (Loc,
7065 Defining_Identifier => Temp,
7066 Object_Definition => New_Occurrence_Of (Acc_Typ, Loc),
7067 Expression => Alloc_Node)));
7070 Make_Explicit_Dereference (Loc,
7071 Prefix => New_Occurrence_Of (Temp, Loc)));
7073 -- Ada 2005 (AI-251): If the type of the returned object is
7074 -- an interface then add an implicit type conversion to force
7075 -- displacement of the "this" pointer.
7077 if Is_Interface (R_Type) then
7078 Rewrite (Exp, Convert_To (R_Type, Relocate_Node (Exp)));
7081 Analyze_And_Resolve (Exp, R_Type);
7084 -- Otherwise use the gigi mechanism to allocate result on the
7088 Check_Restriction (No_Secondary_Stack, N);
7089 Set_Storage_Pool (N, RTE (RE_SS_Pool));
7090 Set_Procedure_To_Call (N, RTE (RE_SS_Allocate));
7094 -- Implement the rules of 6.5(8-10), which require a tag check in
7095 -- the case of a limited tagged return type, and tag reassignment for
7096 -- nonlimited tagged results. These actions are needed when the return
7097 -- type is a specific tagged type and the result expression is a
7098 -- conversion or a formal parameter, because in that case the tag of
7099 -- the expression might differ from the tag of the specific result type.
7101 -- We must also verify an underlying type exists for the return type in
7102 -- case it is incomplete - in which case is not necessary to generate a
7103 -- check anyway since an incomplete limited tagged return type would
7104 -- qualify as a premature usage.
7107 and then Is_Tagged_Type (Utyp)
7108 and then not Is_Class_Wide_Type (Utyp)
7109 and then (Nkind_In (Exp, N_Type_Conversion,
7110 N_Unchecked_Type_Conversion)
7111 or else (Is_Entity_Name (Exp)
7112 and then Is_Formal (Entity (Exp))))
7114 -- When the return type is limited, perform a check that the tag of
7115 -- the result is the same as the tag of the return type.
7117 if Is_Limited_Type (R_Type) then
7119 Make_Raise_Constraint_Error (Loc,
7123 Make_Selected_Component (Loc,
7124 Prefix => Duplicate_Subexpr (Exp),
7125 Selector_Name => Make_Identifier (Loc, Name_uTag)),
7127 Make_Attribute_Reference (Loc,
7129 New_Occurrence_Of (Base_Type (Utyp), Loc),
7130 Attribute_Name => Name_Tag)),
7131 Reason => CE_Tag_Check_Failed));
7133 -- If the result type is a specific nonlimited tagged type, then we
7134 -- have to ensure that the tag of the result is that of the result
7135 -- type. This is handled by making a copy of the expression in
7136 -- the case where it might have a different tag, namely when the
7137 -- expression is a conversion or a formal parameter. We create a new
7138 -- object of the result type and initialize it from the expression,
7139 -- which will implicitly force the tag to be set appropriately.
7143 ExpR : constant Node_Id := Relocate_Node (Exp);
7144 Result_Id : constant Entity_Id :=
7145 Make_Temporary (Loc, 'R', ExpR);
7146 Result_Exp : constant Node_Id :=
7147 New_Occurrence_Of (Result_Id, Loc);
7148 Result_Obj : constant Node_Id :=
7149 Make_Object_Declaration (Loc,
7150 Defining_Identifier => Result_Id,
7151 Object_Definition =>
7152 New_Occurrence_Of (R_Type, Loc),
7153 Constant_Present => True,
7154 Expression => ExpR);
7157 Set_Assignment_OK (Result_Obj);
7158 Insert_Action (Exp, Result_Obj);
7160 Rewrite (Exp, Result_Exp);
7161 Analyze_And_Resolve (Exp, R_Type);
7165 -- Ada 2005 (AI-344): If the result type is class-wide, then insert
7166 -- a check that the level of the return expression's underlying type
7167 -- is not deeper than the level of the master enclosing the function.
7168 -- Always generate the check when the type of the return expression
7169 -- is class-wide, when it's a type conversion, or when it's a formal
7170 -- parameter. Otherwise, suppress the check in the case where the
7171 -- return expression has a specific type whose level is known not to
7172 -- be statically deeper than the function's result type.
7174 -- No runtime check needed in interface thunks since it is performed
7175 -- by the target primitive associated with the thunk.
7177 -- Note: accessibility check is skipped in the VM case, since there
7178 -- does not seem to be any practical way to implement this check.
7180 elsif Ada_Version >= Ada_2005
7181 and then Tagged_Type_Expansion
7182 and then Is_Class_Wide_Type (R_Type)
7183 and then not Is_Thunk (Current_Scope)
7184 and then not Scope_Suppress.Suppress (Accessibility_Check)
7186 (Is_Class_Wide_Type (Etype (Exp))
7187 or else Nkind_In (Exp, N_Type_Conversion,
7188 N_Unchecked_Type_Conversion)
7189 or else (Is_Entity_Name (Exp)
7190 and then Is_Formal (Entity (Exp)))
7191 or else Scope_Depth (Enclosing_Dynamic_Scope (Etype (Exp))) >
7192 Scope_Depth (Enclosing_Dynamic_Scope (Scope_Id)))
7198 -- Ada 2005 (AI-251): In class-wide interface objects we displace
7199 -- "this" to reference the base of the object. This is required to
7200 -- get access to the TSD of the object.
7202 if Is_Class_Wide_Type (Etype (Exp))
7203 and then Is_Interface (Etype (Exp))
7205 -- If the expression is an explicit dereference then we can
7206 -- directly displace the pointer to reference the base of
7209 if Nkind (Exp) = N_Explicit_Dereference then
7211 Make_Explicit_Dereference (Loc,
7213 Unchecked_Convert_To (RTE (RE_Tag_Ptr),
7214 Make_Function_Call (Loc,
7216 New_Occurrence_Of (RTE (RE_Base_Address), Loc),
7217 Parameter_Associations => New_List (
7218 Unchecked_Convert_To (RTE (RE_Address),
7219 Duplicate_Subexpr (Prefix (Exp)))))));
7221 -- Similar case to the previous one but the expression is a
7222 -- renaming of an explicit dereference.
7224 elsif Nkind (Exp) = N_Identifier
7225 and then Present (Renamed_Object (Entity (Exp)))
7226 and then Nkind (Renamed_Object (Entity (Exp)))
7227 = N_Explicit_Dereference
7230 Make_Explicit_Dereference (Loc,
7232 Unchecked_Convert_To (RTE (RE_Tag_Ptr),
7233 Make_Function_Call (Loc,
7235 New_Occurrence_Of (RTE (RE_Base_Address), Loc),
7236 Parameter_Associations => New_List (
7237 Unchecked_Convert_To (RTE (RE_Address),
7240 (Renamed_Object (Entity (Exp)))))))));
7242 -- Common case: obtain the address of the actual object and
7243 -- displace the pointer to reference the base of the object.
7247 Make_Explicit_Dereference (Loc,
7249 Unchecked_Convert_To (RTE (RE_Tag_Ptr),
7250 Make_Function_Call (Loc,
7252 New_Occurrence_Of (RTE (RE_Base_Address), Loc),
7253 Parameter_Associations => New_List (
7254 Make_Attribute_Reference (Loc,
7255 Prefix => Duplicate_Subexpr (Exp),
7256 Attribute_Name => Name_Address)))));
7260 Make_Attribute_Reference (Loc,
7261 Prefix => Duplicate_Subexpr (Exp),
7262 Attribute_Name => Name_Tag);
7265 -- CodePeer does not do anything useful with
7266 -- Ada.Tags.Type_Specific_Data components.
7268 if not CodePeer_Mode then
7270 Make_Raise_Program_Error (Loc,
7273 Left_Opnd => Build_Get_Access_Level (Loc, Tag_Node),
7275 Make_Integer_Literal (Loc,
7276 Scope_Depth (Enclosing_Dynamic_Scope (Scope_Id)))),
7277 Reason => PE_Accessibility_Check_Failed));
7281 -- AI05-0073: If function has a controlling access result, check that
7282 -- the tag of the return value, if it is not null, matches designated
7283 -- type of return type.
7285 -- The return expression is referenced twice in the code below, so it
7286 -- must be made free of side effects. Given that different compilers
7287 -- may evaluate these parameters in different order, both occurrences
7290 elsif Ekind (R_Type) = E_Anonymous_Access_Type
7291 and then Has_Controlling_Result (Scope_Id)
7294 Make_Raise_Constraint_Error (Loc,
7299 Left_Opnd => Duplicate_Subexpr (Exp),
7300 Right_Opnd => Make_Null (Loc)),
7302 Right_Opnd => Make_Op_Ne (Loc,
7304 Make_Selected_Component (Loc,
7305 Prefix => Duplicate_Subexpr (Exp),
7306 Selector_Name => Make_Identifier (Loc, Name_uTag)),
7309 Make_Attribute_Reference (Loc,
7311 New_Occurrence_Of (Designated_Type (R_Type), Loc),
7312 Attribute_Name => Name_Tag))),
7314 Reason => CE_Tag_Check_Failed),
7315 Suppress => All_Checks);
7318 -- AI05-0234: RM 6.5(21/3). Check access discriminants to
7319 -- ensure that the function result does not outlive an
7320 -- object designated by one of it discriminants.
7322 if Present (Extra_Accessibility_Of_Result (Scope_Id))
7323 and then Has_Unconstrained_Access_Discriminants (R_Type)
7326 Discrim_Source : Node_Id;
7328 procedure Check_Against_Result_Level (Level : Node_Id);
7329 -- Check the given accessibility level against the level
7330 -- determined by the point of call. (AI05-0234).
7332 --------------------------------
7333 -- Check_Against_Result_Level --
7334 --------------------------------
7336 procedure Check_Against_Result_Level (Level : Node_Id) is
7339 Make_Raise_Program_Error (Loc,
7345 (Extra_Accessibility_Of_Result (Scope_Id), Loc)),
7346 Reason => PE_Accessibility_Check_Failed));
7347 end Check_Against_Result_Level;
7350 Discrim_Source := Exp;
7351 while Nkind (Discrim_Source) = N_Qualified_Expression loop
7352 Discrim_Source := Expression (Discrim_Source);
7355 if Nkind (Discrim_Source) = N_Identifier
7356 and then Is_Return_Object (Entity (Discrim_Source))
7358 Discrim_Source := Entity (Discrim_Source);
7360 if Is_Constrained (Etype (Discrim_Source)) then
7361 Discrim_Source := Etype (Discrim_Source);
7363 Discrim_Source := Expression (Parent (Discrim_Source));
7366 elsif Nkind (Discrim_Source) = N_Identifier
7367 and then Nkind_In (Original_Node (Discrim_Source),
7368 N_Aggregate, N_Extension_Aggregate)
7370 Discrim_Source := Original_Node (Discrim_Source);
7372 elsif Nkind (Discrim_Source) = N_Explicit_Dereference and then
7373 Nkind (Original_Node (Discrim_Source)) = N_Function_Call
7375 Discrim_Source := Original_Node (Discrim_Source);
7378 Discrim_Source := Unqual_Conv (Discrim_Source);
7380 case Nkind (Discrim_Source) is
7381 when N_Defining_Identifier =>
7382 pragma Assert (Is_Composite_Type (Discrim_Source)
7383 and then Has_Discriminants (Discrim_Source)
7384 and then Is_Constrained (Discrim_Source));
7387 Discrim : Entity_Id :=
7388 First_Discriminant (Base_Type (R_Type));
7389 Disc_Elmt : Elmt_Id :=
7390 First_Elmt (Discriminant_Constraint
7394 if Ekind (Etype (Discrim)) =
7395 E_Anonymous_Access_Type
7397 Check_Against_Result_Level
7398 (Dynamic_Accessibility_Level (Node (Disc_Elmt)));
7401 Next_Elmt (Disc_Elmt);
7402 Next_Discriminant (Discrim);
7403 exit when not Present (Discrim);
7408 | N_Extension_Aggregate
7410 -- Unimplemented: extension aggregate case where discrims
7411 -- come from ancestor part, not extension part.
7414 Discrim : Entity_Id :=
7415 First_Discriminant (Base_Type (R_Type));
7417 Disc_Exp : Node_Id := Empty;
7419 Positionals_Exhausted
7420 : Boolean := not Present (Expressions
7423 function Associated_Expr
7424 (Comp_Id : Entity_Id;
7425 Associations : List_Id) return Node_Id;
7427 -- Given a component and a component associations list,
7428 -- locate the expression for that component; returns
7429 -- Empty if no such expression is found.
7431 ---------------------
7432 -- Associated_Expr --
7433 ---------------------
7435 function Associated_Expr
7436 (Comp_Id : Entity_Id;
7437 Associations : List_Id) return Node_Id
7443 -- Simple linear search seems ok here
7445 Assoc := First (Associations);
7446 while Present (Assoc) loop
7447 Choice := First (Choices (Assoc));
7448 while Present (Choice) loop
7449 if (Nkind (Choice) = N_Identifier
7450 and then Chars (Choice) = Chars (Comp_Id))
7451 or else (Nkind (Choice) = N_Others_Choice)
7453 return Expression (Assoc);
7463 end Associated_Expr;
7466 if not Positionals_Exhausted then
7467 Disc_Exp := First (Expressions (Discrim_Source));
7471 if Positionals_Exhausted then
7475 Component_Associations (Discrim_Source));
7478 if Ekind (Etype (Discrim)) =
7479 E_Anonymous_Access_Type
7481 Check_Against_Result_Level
7482 (Dynamic_Accessibility_Level (Disc_Exp));
7485 Next_Discriminant (Discrim);
7486 exit when not Present (Discrim);
7488 if not Positionals_Exhausted then
7490 Positionals_Exhausted := not Present (Disc_Exp);
7495 when N_Function_Call =>
7497 -- No check needed (check performed by callee)
7503 Level : constant Node_Id :=
7504 Make_Integer_Literal (Loc,
7505 Object_Access_Level (Discrim_Source));
7508 -- Unimplemented: check for name prefix that includes
7509 -- a dereference of an access value with a dynamic
7510 -- accessibility level (e.g., an access param or a
7511 -- saooaaat) and use dynamic level in that case. For
7513 -- return Access_Param.all(Some_Index).Some_Component;
7516 Set_Etype (Level, Standard_Natural);
7517 Check_Against_Result_Level (Level);
7523 -- If we are returning a nonscalar object that is possibly unaligned,
7524 -- then copy the value into a temporary first. This copy may need to
7525 -- expand to a loop of component operations.
7527 if Is_Possibly_Unaligned_Slice (Exp)
7528 or else (Is_Possibly_Unaligned_Object (Exp)
7529 and then not Represented_As_Scalar (Etype (Exp)))
7532 ExpR : constant Node_Id := Relocate_Node (Exp);
7533 Tnn : constant Entity_Id := Make_Temporary (Loc, 'T', ExpR);
7536 Make_Object_Declaration (Loc,
7537 Defining_Identifier => Tnn,
7538 Constant_Present => True,
7539 Object_Definition => New_Occurrence_Of (R_Type, Loc),
7540 Expression => ExpR),
7541 Suppress => All_Checks);
7542 Rewrite (Exp, New_Occurrence_Of (Tnn, Loc));
7546 -- Call the _Postconditions procedure if the related function has
7547 -- contract assertions that need to be verified on exit.
7549 if Ekind (Scope_Id) = E_Function
7550 and then Present (Postconditions_Proc (Scope_Id))
7552 -- In the case of discriminated objects, we have created a
7553 -- constrained subtype above, and used the underlying type. This
7554 -- transformation is post-analysis and harmless, except that now the
7555 -- call to the post-condition will be analyzed and the type kinds
7558 if Nkind (Exp) = N_Unchecked_Type_Conversion
7559 and then Is_Private_Type (R_Type) /= Is_Private_Type (Etype (Exp))
7561 Rewrite (Exp, Expression (Relocate_Node (Exp)));
7564 -- We are going to reference the returned value twice in this case,
7565 -- once in the call to _Postconditions, and once in the actual return
7566 -- statement, but we can't have side effects happening twice.
7568 Force_Evaluation (Exp, Mode => Strict);
7570 -- Generate call to _Postconditions
7573 Make_Procedure_Call_Statement (Loc,
7575 New_Occurrence_Of (Postconditions_Proc (Scope_Id), Loc),
7576 Parameter_Associations => New_List (New_Copy_Tree (Exp))));
7579 -- Ada 2005 (AI-251): If this return statement corresponds with an
7580 -- simple return statement associated with an extended return statement
7581 -- and the type of the returned object is an interface then generate an
7582 -- implicit conversion to force displacement of the "this" pointer.
7584 if Ada_Version >= Ada_2005
7585 and then Comes_From_Extended_Return_Statement (N)
7586 and then Nkind (Expression (N)) = N_Identifier
7587 and then Is_Interface (Utyp)
7588 and then Utyp /= Underlying_Type (Exptyp)
7590 Rewrite (Exp, Convert_To (Utyp, Relocate_Node (Exp)));
7591 Analyze_And_Resolve (Exp);
7593 end Expand_Simple_Function_Return;
7595 -----------------------
7596 -- Freeze_Subprogram --
7597 -----------------------
7599 procedure Freeze_Subprogram (N : Node_Id) is
7600 Loc : constant Source_Ptr := Sloc (N);
7602 procedure Register_Predefined_DT_Entry (Prim : Entity_Id);
7603 -- (Ada 2005): Register a predefined primitive in all the secondary
7604 -- dispatch tables of its primitive type.
7606 ----------------------------------
7607 -- Register_Predefined_DT_Entry --
7608 ----------------------------------
7610 procedure Register_Predefined_DT_Entry (Prim : Entity_Id) is
7611 Iface_DT_Ptr : Elmt_Id;
7612 Tagged_Typ : Entity_Id;
7613 Thunk_Id : Entity_Id;
7614 Thunk_Code : Node_Id;
7617 Tagged_Typ := Find_Dispatching_Type (Prim);
7619 if No (Access_Disp_Table (Tagged_Typ))
7620 or else not Has_Interfaces (Tagged_Typ)
7621 or else not RTE_Available (RE_Interface_Tag)
7622 or else Restriction_Active (No_Dispatching_Calls)
7627 -- Skip the first two access-to-dispatch-table pointers since they
7628 -- leads to the primary dispatch table (predefined DT and user
7629 -- defined DT). We are only concerned with the secondary dispatch
7630 -- table pointers. Note that the access-to- dispatch-table pointer
7631 -- corresponds to the first implemented interface retrieved below.
7634 Next_Elmt (Next_Elmt (First_Elmt (Access_Disp_Table (Tagged_Typ))));
7636 while Present (Iface_DT_Ptr)
7637 and then Ekind (Node (Iface_DT_Ptr)) = E_Constant
7639 pragma Assert (Has_Thunks (Node (Iface_DT_Ptr)));
7640 Expand_Interface_Thunk (Prim, Thunk_Id, Thunk_Code,
7641 Iface => Related_Type (Node (Iface_DT_Ptr)));
7643 if Present (Thunk_Code) then
7644 Insert_Actions_After (N, New_List (
7647 Build_Set_Predefined_Prim_Op_Address (Loc,
7649 New_Occurrence_Of (Node (Next_Elmt (Iface_DT_Ptr)), Loc),
7650 Position => DT_Position (Prim),
7652 Unchecked_Convert_To (RTE (RE_Prim_Ptr),
7653 Make_Attribute_Reference (Loc,
7654 Prefix => New_Occurrence_Of (Thunk_Id, Loc),
7655 Attribute_Name => Name_Unrestricted_Access))),
7657 Build_Set_Predefined_Prim_Op_Address (Loc,
7660 (Node (Next_Elmt (Next_Elmt (Next_Elmt (Iface_DT_Ptr)))),
7662 Position => DT_Position (Prim),
7664 Unchecked_Convert_To (RTE (RE_Prim_Ptr),
7665 Make_Attribute_Reference (Loc,
7666 Prefix => New_Occurrence_Of (Prim, Loc),
7667 Attribute_Name => Name_Unrestricted_Access)))));
7670 -- Skip the tag of the predefined primitives dispatch table
7672 Next_Elmt (Iface_DT_Ptr);
7673 pragma Assert (Has_Thunks (Node (Iface_DT_Ptr)));
7675 -- Skip tag of the no-thunks dispatch table
7677 Next_Elmt (Iface_DT_Ptr);
7678 pragma Assert (not Has_Thunks (Node (Iface_DT_Ptr)));
7680 -- Skip tag of predefined primitives no-thunks dispatch table
7682 Next_Elmt (Iface_DT_Ptr);
7683 pragma Assert (not Has_Thunks (Node (Iface_DT_Ptr)));
7685 Next_Elmt (Iface_DT_Ptr);
7687 end Register_Predefined_DT_Entry;
7691 Subp : constant Entity_Id := Entity (N);
7693 -- Start of processing for Freeze_Subprogram
7696 -- We suppress the initialization of the dispatch table entry when
7697 -- not Tagged_Type_Expansion because the dispatching mechanism is
7698 -- handled internally by the target.
7700 if Is_Dispatching_Operation (Subp)
7701 and then not Is_Abstract_Subprogram (Subp)
7702 and then Present (DTC_Entity (Subp))
7703 and then Present (Scope (DTC_Entity (Subp)))
7704 and then Tagged_Type_Expansion
7705 and then not Restriction_Active (No_Dispatching_Calls)
7706 and then RTE_Available (RE_Tag)
7709 Typ : constant Entity_Id := Scope (DTC_Entity (Subp));
7712 -- Handle private overridden primitives
7714 if not Is_CPP_Class (Typ) then
7715 Check_Overriding_Operation (Subp);
7718 -- We assume that imported CPP primitives correspond with objects
7719 -- whose constructor is in the CPP side; therefore we don't need
7720 -- to generate code to register them in the dispatch table.
7722 if Is_CPP_Class (Typ) then
7725 -- Handle CPP primitives found in derivations of CPP_Class types.
7726 -- These primitives must have been inherited from some parent, and
7727 -- there is no need to register them in the dispatch table because
7728 -- Build_Inherit_Prims takes care of initializing these slots.
7730 elsif Is_Imported (Subp)
7731 and then (Convention (Subp) = Convention_CPP
7732 or else Convention (Subp) = Convention_C)
7736 -- Generate code to register the primitive in non statically
7737 -- allocated dispatch tables
7739 elsif not Building_Static_DT (Scope (DTC_Entity (Subp))) then
7741 -- When a primitive is frozen, enter its name in its dispatch
7744 if not Is_Interface (Typ)
7745 or else Present (Interface_Alias (Subp))
7747 if Is_Predefined_Dispatching_Operation (Subp) then
7748 Register_Predefined_DT_Entry (Subp);
7751 Insert_Actions_After (N,
7752 Register_Primitive (Loc, Prim => Subp));
7758 -- Mark functions that return by reference. Note that it cannot be part
7759 -- of the normal semantic analysis of the spec since the underlying
7760 -- returned type may not be known yet (for private types).
7763 Typ : constant Entity_Id := Etype (Subp);
7764 Utyp : constant Entity_Id := Underlying_Type (Typ);
7767 if Is_Limited_View (Typ) then
7768 Set_Returns_By_Ref (Subp);
7770 elsif Present (Utyp) and then CW_Or_Has_Controlled_Part (Utyp) then
7771 Set_Returns_By_Ref (Subp);
7775 -- Wnen freezing a null procedure, analyze its delayed aspects now
7776 -- because we may not have reached the end of the declarative list when
7777 -- delayed aspects are normally analyzed. This ensures that dispatching
7778 -- calls are properly rewritten when the generated _Postcondition
7779 -- procedure is analyzed in the null procedure body.
7781 if Nkind (Parent (Subp)) = N_Procedure_Specification
7782 and then Null_Present (Parent (Subp))
7784 Analyze_Entry_Or_Subprogram_Contract (Subp);
7786 end Freeze_Subprogram;
7788 --------------------------------------------
7789 -- Has_Unconstrained_Access_Discriminants --
7790 --------------------------------------------
7792 function Has_Unconstrained_Access_Discriminants
7793 (Subtyp : Entity_Id) return Boolean
7798 if Has_Discriminants (Subtyp)
7799 and then not Is_Constrained (Subtyp)
7801 Discr := First_Discriminant (Subtyp);
7802 while Present (Discr) loop
7803 if Ekind (Etype (Discr)) = E_Anonymous_Access_Type then
7807 Next_Discriminant (Discr);
7812 end Has_Unconstrained_Access_Discriminants;
7814 ------------------------------
7815 -- Insert_Post_Call_Actions --
7816 ------------------------------
7818 procedure Insert_Post_Call_Actions (N : Node_Id; Post_Call : List_Id) is
7819 Context : constant Node_Id := Parent (N);
7822 if Is_Empty_List (Post_Call) then
7826 -- Cases where the call is not a member of a statement list. This
7827 -- includes the case where the call is an actual in another function
7828 -- call or indexing, i.e. an expression context as well.
7830 if not Is_List_Member (N)
7831 or else Nkind_In (Context, N_Function_Call, N_Indexed_Component)
7833 -- In Ada 2012 the call may be a function call in an expression
7834 -- (since OUT and IN OUT parameters are now allowed for such calls).
7835 -- The write-back of (in)-out parameters is handled by the back-end,
7836 -- but the constraint checks generated when subtypes of formal and
7837 -- actual don't match must be inserted in the form of assignments.
7839 if Nkind (Original_Node (N)) = N_Function_Call then
7840 pragma Assert (Ada_Version >= Ada_2012);
7841 -- Functions with '[in] out' parameters are only allowed in Ada
7844 -- We used to handle this by climbing up parents to a
7845 -- non-statement/declaration and then simply making a call to
7846 -- Insert_Actions_After (P, Post_Call), but that doesn't work
7847 -- for Ada 2012. If we are in the middle of an expression, e.g.
7848 -- the condition of an IF, this call would insert after the IF
7849 -- statement, which is much too late to be doing the write back.
7852 -- if Clobber (X) then
7853 -- Put_Line (X'Img);
7858 -- Now assume Clobber changes X, if we put the write back after
7859 -- the IF, the Put_Line gets the wrong value and the goto causes
7860 -- the write back to be skipped completely.
7862 -- To deal with this, we replace the call by
7865 -- Tnnn : constant function-result-type := function-call;
7866 -- Post_Call actions
7872 Loc : constant Source_Ptr := Sloc (N);
7873 Tnnn : constant Entity_Id := Make_Temporary (Loc, 'T');
7874 FRTyp : constant Entity_Id := Etype (N);
7875 Name : constant Node_Id := Relocate_Node (N);
7878 Prepend_To (Post_Call,
7879 Make_Object_Declaration (Loc,
7880 Defining_Identifier => Tnnn,
7881 Object_Definition => New_Occurrence_Of (FRTyp, Loc),
7882 Constant_Present => True,
7883 Expression => Name));
7886 Make_Expression_With_Actions (Loc,
7887 Actions => Post_Call,
7888 Expression => New_Occurrence_Of (Tnnn, Loc)));
7890 -- We don't want to just blindly call Analyze_And_Resolve
7891 -- because that would cause unwanted recursion on the call.
7892 -- So for a moment set the call as analyzed to prevent that
7893 -- recursion, and get the rest analyzed properly, then reset
7894 -- the analyzed flag, so our caller can continue.
7896 Set_Analyzed (Name, True);
7897 Analyze_And_Resolve (N, FRTyp);
7898 Set_Analyzed (Name, False);
7901 -- If not the special Ada 2012 case of a function call, then we must
7902 -- have the triggering statement of a triggering alternative or an
7903 -- entry call alternative, and we can add the post call stuff to the
7904 -- corresponding statement list.
7907 pragma Assert (Nkind_In (Context, N_Entry_Call_Alternative,
7908 N_Triggering_Alternative));
7910 if Is_Non_Empty_List (Statements (Context)) then
7911 Insert_List_Before_And_Analyze
7912 (First (Statements (Context)), Post_Call);
7914 Set_Statements (Context, Post_Call);
7918 -- A procedure call is always part of a declarative or statement list,
7919 -- however a function call may appear nested within a construct. Most
7920 -- cases of function call nesting are handled in the special case above.
7921 -- The only exception is when the function call acts as an actual in a
7922 -- procedure call. In this case the function call is in a list, but the
7923 -- post-call actions must be inserted after the procedure call.
7925 elsif Nkind (Context) = N_Procedure_Call_Statement then
7926 Insert_Actions_After (Context, Post_Call);
7928 -- Otherwise, normal case where N is in a statement sequence, just put
7929 -- the post-call stuff after the call statement.
7932 Insert_Actions_After (N, Post_Call);
7934 end Insert_Post_Call_Actions;
7936 -----------------------------------
7937 -- Is_Build_In_Place_Result_Type --
7938 -----------------------------------
7940 function Is_Build_In_Place_Result_Type (Typ : Entity_Id) return Boolean is
7942 if not Expander_Active then
7946 -- In Ada 2005 all functions with an inherently limited return type
7947 -- must be handled using a build-in-place profile, including the case
7948 -- of a function with a limited interface result, where the function
7949 -- may return objects of nonlimited descendants.
7951 if Is_Limited_View (Typ) then
7952 return Ada_Version >= Ada_2005 and then not Debug_Flag_Dot_L;
7955 if Debug_Flag_Dot_9 then
7959 if Has_Interfaces (Typ) then
7964 T : Entity_Id := Typ;
7966 -- For T'Class, return True if it's True for T. This is necessary
7967 -- because a class-wide function might say "return F (...)", where
7968 -- F returns the corresponding specific type. We need a loop in
7969 -- case T is a subtype of a class-wide type.
7971 while Is_Class_Wide_Type (T) loop
7975 -- If this is a generic formal type in an instance, return True if
7976 -- it's True for the generic actual type.
7978 if Nkind (Parent (T)) = N_Subtype_Declaration
7979 and then Present (Generic_Parent_Type (Parent (T)))
7981 T := Entity (Subtype_Indication (Parent (T)));
7983 if Present (Full_View (T)) then
7988 if Present (Underlying_Type (T)) then
7989 T := Underlying_Type (T);
7994 -- So we can stop here in the debugger
7996 -- ???For now, enable build-in-place for a very narrow set of
7997 -- controlled types. Change "if True" to "if False" to
7998 -- experiment with more controlled types. Eventually, we might
7999 -- like to enable build-in-place for all tagged types, all
8000 -- types that need finalization, and all caller-unknown-size
8004 Result := Is_Controlled (T)
8005 and then Present (Enclosing_Subprogram (T))
8006 and then not Is_Compilation_Unit (Enclosing_Subprogram (T))
8007 and then Ekind (Enclosing_Subprogram (T)) = E_Procedure;
8009 Result := Is_Controlled (T);
8016 end Is_Build_In_Place_Result_Type;
8018 --------------------------------
8019 -- Is_Build_In_Place_Function --
8020 --------------------------------
8022 function Is_Build_In_Place_Function (E : Entity_Id) return Boolean is
8024 -- This function is called from Expand_Subtype_From_Expr during
8025 -- semantic analysis, even when expansion is off. In those cases
8026 -- the build_in_place expansion will not take place.
8028 if not Expander_Active then
8032 -- For now we test whether E denotes a function or access-to-function
8033 -- type whose result subtype is inherently limited. Later this test
8034 -- may be revised to allow composite nonlimited types.
8036 if Ekind_In (E, E_Function, E_Generic_Function)
8037 or else (Ekind (E) = E_Subprogram_Type
8038 and then Etype (E) /= Standard_Void_Type)
8040 -- If the function is imported from a foreign language, we don't do
8041 -- build-in-place. Note that Import (Ada) functions can do
8042 -- build-in-place. Note that it is OK for a build-in-place function
8043 -- to return a type with a foreign convention; the build-in-place
8044 -- machinery will ensure there is no copying.
8046 return Is_Build_In_Place_Result_Type (Etype (E))
8047 and then not (Has_Foreign_Convention (E) and then Is_Imported (E))
8048 and then not Debug_Flag_Dot_L;
8052 end Is_Build_In_Place_Function;
8054 -------------------------------------
8055 -- Is_Build_In_Place_Function_Call --
8056 -------------------------------------
8058 function Is_Build_In_Place_Function_Call (N : Node_Id) return Boolean is
8059 Exp_Node : constant Node_Id := Unqual_Conv (N);
8060 Function_Id : Entity_Id;
8063 -- Return False if the expander is currently inactive, since awareness
8064 -- of build-in-place treatment is only relevant during expansion. Note
8065 -- that Is_Build_In_Place_Function, which is called as part of this
8066 -- function, is also conditioned this way, but we need to check here as
8067 -- well to avoid blowing up on processing protected calls when expansion
8068 -- is disabled (such as with -gnatc) since those would trip over the
8069 -- raise of Program_Error below.
8071 -- In SPARK mode, build-in-place calls are not expanded, so that we
8072 -- may end up with a call that is neither resolved to an entity, nor
8073 -- an indirect call.
8075 if not Expander_Active or else Nkind (Exp_Node) /= N_Function_Call then
8079 if Is_Entity_Name (Name (Exp_Node)) then
8080 Function_Id := Entity (Name (Exp_Node));
8082 -- In the case of an explicitly dereferenced call, use the subprogram
8083 -- type generated for the dereference.
8085 elsif Nkind (Name (Exp_Node)) = N_Explicit_Dereference then
8086 Function_Id := Etype (Name (Exp_Node));
8088 -- This may be a call to a protected function.
8090 elsif Nkind (Name (Exp_Node)) = N_Selected_Component then
8091 Function_Id := Etype (Entity (Selector_Name (Name (Exp_Node))));
8094 raise Program_Error;
8098 Result : constant Boolean := Is_Build_In_Place_Function (Function_Id);
8099 -- So we can stop here in the debugger
8103 end Is_Build_In_Place_Function_Call;
8105 -----------------------
8106 -- Is_Null_Procedure --
8107 -----------------------
8109 function Is_Null_Procedure (Subp : Entity_Id) return Boolean is
8110 Decl : constant Node_Id := Unit_Declaration_Node (Subp);
8113 if Ekind (Subp) /= E_Procedure then
8116 -- Check if this is a declared null procedure
8118 elsif Nkind (Decl) = N_Subprogram_Declaration then
8119 if not Null_Present (Specification (Decl)) then
8122 elsif No (Body_To_Inline (Decl)) then
8125 -- Check if the body contains only a null statement, followed by
8126 -- the return statement added during expansion.
8130 Orig_Bod : constant Node_Id := Body_To_Inline (Decl);
8136 if Nkind (Orig_Bod) /= N_Subprogram_Body then
8139 -- We must skip SCIL nodes because they are currently
8140 -- implemented as special N_Null_Statement nodes.
8144 (Statements (Handled_Statement_Sequence (Orig_Bod)));
8145 Stat2 := Next_Non_SCIL_Node (Stat);
8148 Is_Empty_List (Declarations (Orig_Bod))
8149 and then Nkind (Stat) = N_Null_Statement
8153 (Nkind (Stat2) = N_Simple_Return_Statement
8154 and then No (Next (Stat2))));
8162 end Is_Null_Procedure;
8164 -------------------------------------------
8165 -- Make_Build_In_Place_Call_In_Allocator --
8166 -------------------------------------------
8168 procedure Make_Build_In_Place_Call_In_Allocator
8169 (Allocator : Node_Id;
8170 Function_Call : Node_Id)
8172 Acc_Type : constant Entity_Id := Etype (Allocator);
8173 Loc : constant Source_Ptr := Sloc (Function_Call);
8174 Func_Call : Node_Id := Function_Call;
8175 Ref_Func_Call : Node_Id;
8176 Function_Id : Entity_Id;
8177 Result_Subt : Entity_Id;
8178 New_Allocator : Node_Id;
8179 Return_Obj_Access : Entity_Id; -- temp for function result
8180 Temp_Init : Node_Id; -- initial value of Return_Obj_Access
8181 Alloc_Form : BIP_Allocation_Form;
8182 Pool : Node_Id; -- nonnull if Alloc_Form = User_Storage_Pool
8183 Return_Obj_Actual : Node_Id; -- the temp.all, in caller-allocates case
8184 Chain : Entity_Id; -- activation chain, in case of tasks
8187 -- Step past qualification or unchecked conversion (the latter can occur
8188 -- in cases of calls to 'Input).
8190 if Nkind_In (Func_Call, N_Qualified_Expression,
8192 N_Unchecked_Type_Conversion)
8194 Func_Call := Expression (Func_Call);
8197 -- Mark the call as processed as a build-in-place call
8199 pragma Assert (not Is_Expanded_Build_In_Place_Call (Func_Call));
8200 Set_Is_Expanded_Build_In_Place_Call (Func_Call);
8202 if Is_Entity_Name (Name (Func_Call)) then
8203 Function_Id := Entity (Name (Func_Call));
8205 elsif Nkind (Name (Func_Call)) = N_Explicit_Dereference then
8206 Function_Id := Etype (Name (Func_Call));
8209 raise Program_Error;
8212 Result_Subt := Available_View (Etype (Function_Id));
8214 -- Create a temp for the function result. In the caller-allocates case,
8215 -- this will be initialized to the result of a new uninitialized
8216 -- allocator. Note: we do not use Allocator as the Related_Node of
8217 -- Return_Obj_Access in call to Make_Temporary below as this would
8218 -- create a sort of infinite "recursion".
8220 Return_Obj_Access := Make_Temporary (Loc, 'R');
8221 Set_Etype (Return_Obj_Access, Acc_Type);
8222 Set_Can_Never_Be_Null (Acc_Type, False);
8223 -- It gets initialized to null, so we can't have that
8225 -- When the result subtype is constrained, the return object is created
8226 -- on the caller side, and access to it is passed to the function. This
8227 -- optimization is disabled when the result subtype needs finalization
8228 -- actions because the caller side allocation may result in undesirable
8229 -- finalization. Consider the following example:
8231 -- function Make_Lim_Ctrl return Lim_Ctrl is
8233 -- return Result : Lim_Ctrl := raise Program_Error do
8236 -- end Make_Lim_Ctrl;
8238 -- Obj : Lim_Ctrl_Ptr := new Lim_Ctrl'(Make_Lim_Ctrl);
8240 -- Even though the size of limited controlled type Lim_Ctrl is known,
8241 -- allocating Obj at the caller side will chain Obj on Lim_Ctrl_Ptr's
8242 -- finalization master. The subsequent call to Make_Lim_Ctrl will fail
8243 -- during the initialization actions for Result, which implies that
8244 -- Result (and Obj by extension) should not be finalized. However Obj
8245 -- will be finalized when access type Lim_Ctrl_Ptr goes out of scope
8246 -- since it is already attached on the related finalization master.
8248 -- Here and in related routines, we must examine the full view of the
8249 -- type, because the view at the point of call may differ from the
8250 -- one in the function body, and the expansion mechanism depends on
8251 -- the characteristics of the full view.
8253 if Needs_BIP_Alloc_Form (Function_Id) then
8256 -- Case of a user-defined storage pool. Pass an allocation parameter
8257 -- indicating that the function should allocate its result in the
8258 -- pool, and pass the pool. Use 'Unrestricted_Access because the
8259 -- pool may not be aliased.
8261 if Present (Associated_Storage_Pool (Acc_Type)) then
8262 Alloc_Form := User_Storage_Pool;
8264 Make_Attribute_Reference (Loc,
8267 (Associated_Storage_Pool (Acc_Type), Loc),
8268 Attribute_Name => Name_Unrestricted_Access);
8270 -- No user-defined pool; pass an allocation parameter indicating that
8271 -- the function should allocate its result on the heap.
8274 Alloc_Form := Global_Heap;
8275 Pool := Make_Null (No_Location);
8278 -- The caller does not provide the return object in this case, so we
8279 -- have to pass null for the object access actual.
8281 Return_Obj_Actual := Empty;
8284 -- Replace the initialized allocator of form "new T'(Func (...))"
8285 -- with an uninitialized allocator of form "new T", where T is the
8286 -- result subtype of the called function. The call to the function
8287 -- is handled separately further below.
8290 Make_Allocator (Loc,
8291 Expression => New_Occurrence_Of (Result_Subt, Loc));
8292 Set_No_Initialization (New_Allocator);
8294 -- Copy attributes to new allocator. Note that the new allocator
8295 -- logically comes from source if the original one did, so copy the
8296 -- relevant flag. This ensures proper treatment of the restriction
8297 -- No_Implicit_Heap_Allocations in this case.
8299 Set_Storage_Pool (New_Allocator, Storage_Pool (Allocator));
8300 Set_Procedure_To_Call (New_Allocator, Procedure_To_Call (Allocator));
8301 Set_Comes_From_Source (New_Allocator, Comes_From_Source (Allocator));
8303 Rewrite (Allocator, New_Allocator);
8305 -- Initial value of the temp is the result of the uninitialized
8306 -- allocator. Unchecked_Convert is needed for T'Input where T is
8307 -- derived from a controlled type.
8309 Temp_Init := Relocate_Node (Allocator);
8311 if Nkind_In (Function_Call, N_Type_Conversion,
8312 N_Unchecked_Type_Conversion)
8314 Temp_Init := Unchecked_Convert_To (Acc_Type, Temp_Init);
8317 -- Indicate that caller allocates, and pass in the return object
8319 Alloc_Form := Caller_Allocation;
8320 Pool := Make_Null (No_Location);
8321 Return_Obj_Actual :=
8322 Make_Unchecked_Type_Conversion (Loc,
8323 Subtype_Mark => New_Occurrence_Of (Result_Subt, Loc),
8325 Make_Explicit_Dereference (Loc,
8326 Prefix => New_Occurrence_Of (Return_Obj_Access, Loc)));
8328 -- When the result subtype is unconstrained, the function itself must
8329 -- perform the allocation of the return object, so we pass parameters
8334 -- Declare the temp object
8336 Insert_Action (Allocator,
8337 Make_Object_Declaration (Loc,
8338 Defining_Identifier => Return_Obj_Access,
8339 Object_Definition => New_Occurrence_Of (Acc_Type, Loc),
8340 Expression => Temp_Init));
8342 Ref_Func_Call := Make_Reference (Loc, Func_Call);
8344 -- Ada 2005 (AI-251): If the type of the allocator is an interface
8345 -- then generate an implicit conversion to force displacement of the
8348 if Is_Interface (Designated_Type (Acc_Type)) then
8351 OK_Convert_To (Acc_Type, Ref_Func_Call));
8353 -- If the types are incompatible, we need an unchecked conversion. Note
8354 -- that the full types will be compatible, but the types not visibly
8357 elsif Nkind_In (Function_Call, N_Type_Conversion,
8358 N_Unchecked_Type_Conversion)
8360 Ref_Func_Call := Unchecked_Convert_To (Acc_Type, Ref_Func_Call);
8364 Assign : constant Node_Id :=
8365 Make_Assignment_Statement (Loc,
8366 Name => New_Occurrence_Of (Return_Obj_Access, Loc),
8367 Expression => Ref_Func_Call);
8368 -- Assign the result of the function call into the temp. In the
8369 -- caller-allocates case, this is overwriting the temp with its
8370 -- initial value, which has no effect. In the callee-allocates case,
8371 -- this is setting the temp to point to the object allocated by the
8372 -- callee. Unchecked_Convert is needed for T'Input where T is derived
8373 -- from a controlled type.
8376 -- Actions to be inserted. If there are no tasks, this is just the
8377 -- assignment statement. If the allocated object has tasks, we need
8378 -- to wrap the assignment in a block that activates them. The
8379 -- activation chain of that block must be passed to the function,
8380 -- rather than some outer chain.
8383 if Has_Task (Result_Subt) then
8384 Actions := New_List;
8385 Build_Task_Allocate_Block_With_Init_Stmts
8386 (Actions, Allocator, Init_Stmts => New_List (Assign));
8387 Chain := Activation_Chain_Entity (Last (Actions));
8389 Actions := New_List (Assign);
8393 Insert_Actions (Allocator, Actions);
8396 -- When the function has a controlling result, an allocation-form
8397 -- parameter must be passed indicating that the caller is allocating
8398 -- the result object. This is needed because such a function can be
8399 -- called as a dispatching operation and must be treated similarly
8400 -- to functions with unconstrained result subtypes.
8402 Add_Unconstrained_Actuals_To_Build_In_Place_Call
8403 (Func_Call, Function_Id, Alloc_Form, Pool_Actual => Pool);
8405 Add_Finalization_Master_Actual_To_Build_In_Place_Call
8406 (Func_Call, Function_Id, Acc_Type);
8408 Add_Task_Actuals_To_Build_In_Place_Call
8409 (Func_Call, Function_Id, Master_Actual => Master_Id (Acc_Type),
8412 -- Add an implicit actual to the function call that provides access
8413 -- to the allocated object. An unchecked conversion to the (specific)
8414 -- result subtype of the function is inserted to handle cases where
8415 -- the access type of the allocator has a class-wide designated type.
8417 Add_Access_Actual_To_Build_In_Place_Call
8418 (Func_Call, Function_Id, Return_Obj_Actual);
8420 -- Finally, replace the allocator node with a reference to the temp
8422 Rewrite (Allocator, New_Occurrence_Of (Return_Obj_Access, Loc));
8424 Analyze_And_Resolve (Allocator, Acc_Type);
8425 pragma Assert (Check_Number_Of_Actuals (Func_Call, Function_Id));
8426 end Make_Build_In_Place_Call_In_Allocator;
8428 ---------------------------------------------------
8429 -- Make_Build_In_Place_Call_In_Anonymous_Context --
8430 ---------------------------------------------------
8432 procedure Make_Build_In_Place_Call_In_Anonymous_Context
8433 (Function_Call : Node_Id)
8435 Loc : constant Source_Ptr := Sloc (Function_Call);
8436 Func_Call : constant Node_Id := Unqual_Conv (Function_Call);
8437 Function_Id : Entity_Id;
8438 Result_Subt : Entity_Id;
8439 Return_Obj_Id : Entity_Id;
8440 Return_Obj_Decl : Entity_Id;
8443 -- If the call has already been processed to add build-in-place actuals
8444 -- then return. One place this can occur is for calls to build-in-place
8445 -- functions that occur within a call to a protected operation, where
8446 -- due to rewriting and expansion of the protected call there can be
8447 -- more than one call to Expand_Actuals for the same set of actuals.
8449 if Is_Expanded_Build_In_Place_Call (Func_Call) then
8453 -- Mark the call as processed as a build-in-place call
8455 Set_Is_Expanded_Build_In_Place_Call (Func_Call);
8457 if Is_Entity_Name (Name (Func_Call)) then
8458 Function_Id := Entity (Name (Func_Call));
8460 elsif Nkind (Name (Func_Call)) = N_Explicit_Dereference then
8461 Function_Id := Etype (Name (Func_Call));
8464 raise Program_Error;
8467 Result_Subt := Etype (Function_Id);
8469 -- If the build-in-place function returns a controlled object, then the
8470 -- object needs to be finalized immediately after the context. Since
8471 -- this case produces a transient scope, the servicing finalizer needs
8472 -- to name the returned object. Create a temporary which is initialized
8473 -- with the function call:
8475 -- Temp_Id : Func_Type := BIP_Func_Call;
8477 -- The initialization expression of the temporary will be rewritten by
8478 -- the expander using the appropriate mechanism in Make_Build_In_Place_
8479 -- Call_In_Object_Declaration.
8481 if Needs_Finalization (Result_Subt) then
8483 Temp_Id : constant Entity_Id := Make_Temporary (Loc, 'R');
8484 Temp_Decl : Node_Id;
8487 -- Reset the guard on the function call since the following does
8488 -- not perform actual call expansion.
8490 Set_Is_Expanded_Build_In_Place_Call (Func_Call, False);
8493 Make_Object_Declaration (Loc,
8494 Defining_Identifier => Temp_Id,
8495 Object_Definition =>
8496 New_Occurrence_Of (Result_Subt, Loc),
8498 New_Copy_Tree (Function_Call));
8500 Insert_Action (Function_Call, Temp_Decl);
8502 Rewrite (Function_Call, New_Occurrence_Of (Temp_Id, Loc));
8503 Analyze (Function_Call);
8506 -- When the result subtype is definite, an object of the subtype is
8507 -- declared and an access value designating it is passed as an actual.
8509 elsif Caller_Known_Size (Func_Call, Result_Subt) then
8511 -- Create a temporary object to hold the function result
8513 Return_Obj_Id := Make_Temporary (Loc, 'R');
8514 Set_Etype (Return_Obj_Id, Result_Subt);
8517 Make_Object_Declaration (Loc,
8518 Defining_Identifier => Return_Obj_Id,
8519 Aliased_Present => True,
8520 Object_Definition => New_Occurrence_Of (Result_Subt, Loc));
8522 Set_No_Initialization (Return_Obj_Decl);
8524 Insert_Action (Func_Call, Return_Obj_Decl);
8526 -- When the function has a controlling result, an allocation-form
8527 -- parameter must be passed indicating that the caller is allocating
8528 -- the result object. This is needed because such a function can be
8529 -- called as a dispatching operation and must be treated similarly
8530 -- to functions with unconstrained result subtypes.
8532 Add_Unconstrained_Actuals_To_Build_In_Place_Call
8533 (Func_Call, Function_Id, Alloc_Form => Caller_Allocation);
8535 Add_Finalization_Master_Actual_To_Build_In_Place_Call
8536 (Func_Call, Function_Id);
8538 Add_Task_Actuals_To_Build_In_Place_Call
8539 (Func_Call, Function_Id, Make_Identifier (Loc, Name_uMaster));
8541 -- Add an implicit actual to the function call that provides access
8542 -- to the caller's return object.
8544 Add_Access_Actual_To_Build_In_Place_Call
8545 (Func_Call, Function_Id, New_Occurrence_Of (Return_Obj_Id, Loc));
8547 pragma Assert (Check_Number_Of_Actuals (Func_Call, Function_Id));
8549 -- When the result subtype is unconstrained, the function must allocate
8550 -- the return object in the secondary stack, so appropriate implicit
8551 -- parameters are added to the call to indicate that. A transient
8552 -- scope is established to ensure eventual cleanup of the result.
8555 -- Pass an allocation parameter indicating that the function should
8556 -- allocate its result on the secondary stack.
8558 Add_Unconstrained_Actuals_To_Build_In_Place_Call
8559 (Func_Call, Function_Id, Alloc_Form => Secondary_Stack);
8561 Add_Finalization_Master_Actual_To_Build_In_Place_Call
8562 (Func_Call, Function_Id);
8564 Add_Task_Actuals_To_Build_In_Place_Call
8565 (Func_Call, Function_Id, Make_Identifier (Loc, Name_uMaster));
8567 -- Pass a null value to the function since no return object is
8568 -- available on the caller side.
8570 Add_Access_Actual_To_Build_In_Place_Call
8571 (Func_Call, Function_Id, Empty);
8573 pragma Assert (Check_Number_Of_Actuals (Func_Call, Function_Id));
8575 end Make_Build_In_Place_Call_In_Anonymous_Context;
8577 --------------------------------------------
8578 -- Make_Build_In_Place_Call_In_Assignment --
8579 --------------------------------------------
8581 procedure Make_Build_In_Place_Call_In_Assignment
8583 Function_Call : Node_Id)
8585 Func_Call : constant Node_Id := Unqual_Conv (Function_Call);
8586 Lhs : constant Node_Id := Name (Assign);
8587 Loc : constant Source_Ptr := Sloc (Function_Call);
8588 Func_Id : Entity_Id;
8591 Ptr_Typ : Entity_Id;
8592 Ptr_Typ_Decl : Node_Id;
8594 Result_Subt : Entity_Id;
8597 -- Mark the call as processed as a build-in-place call
8599 pragma Assert (not Is_Expanded_Build_In_Place_Call (Func_Call));
8600 Set_Is_Expanded_Build_In_Place_Call (Func_Call);
8602 if Is_Entity_Name (Name (Func_Call)) then
8603 Func_Id := Entity (Name (Func_Call));
8605 elsif Nkind (Name (Func_Call)) = N_Explicit_Dereference then
8606 Func_Id := Etype (Name (Func_Call));
8609 raise Program_Error;
8612 Result_Subt := Etype (Func_Id);
8614 -- When the result subtype is unconstrained, an additional actual must
8615 -- be passed to indicate that the caller is providing the return object.
8616 -- This parameter must also be passed when the called function has a
8617 -- controlling result, because dispatching calls to the function needs
8618 -- to be treated effectively the same as calls to class-wide functions.
8620 Add_Unconstrained_Actuals_To_Build_In_Place_Call
8621 (Func_Call, Func_Id, Alloc_Form => Caller_Allocation);
8623 Add_Finalization_Master_Actual_To_Build_In_Place_Call
8624 (Func_Call, Func_Id);
8626 Add_Task_Actuals_To_Build_In_Place_Call
8627 (Func_Call, Func_Id, Make_Identifier (Loc, Name_uMaster));
8629 -- Add an implicit actual to the function call that provides access to
8630 -- the caller's return object.
8632 Add_Access_Actual_To_Build_In_Place_Call
8635 Make_Unchecked_Type_Conversion (Loc,
8636 Subtype_Mark => New_Occurrence_Of (Result_Subt, Loc),
8637 Expression => Relocate_Node (Lhs)));
8639 -- Create an access type designating the function's result subtype
8641 Ptr_Typ := Make_Temporary (Loc, 'A');
8644 Make_Full_Type_Declaration (Loc,
8645 Defining_Identifier => Ptr_Typ,
8647 Make_Access_To_Object_Definition (Loc,
8648 All_Present => True,
8649 Subtype_Indication =>
8650 New_Occurrence_Of (Result_Subt, Loc)));
8651 Insert_After_And_Analyze (Assign, Ptr_Typ_Decl);
8653 -- Finally, create an access object initialized to a reference to the
8654 -- function call. We know this access value is non-null, so mark the
8655 -- entity accordingly to suppress junk access checks.
8657 New_Expr := Make_Reference (Loc, Relocate_Node (Func_Call));
8659 -- Add a conversion if it's the wrong type
8661 if Etype (New_Expr) /= Ptr_Typ then
8663 Make_Unchecked_Type_Conversion (Loc,
8664 New_Occurrence_Of (Ptr_Typ, Loc), New_Expr);
8667 Obj_Id := Make_Temporary (Loc, 'R', New_Expr);
8668 Set_Etype (Obj_Id, Ptr_Typ);
8669 Set_Is_Known_Non_Null (Obj_Id);
8672 Make_Object_Declaration (Loc,
8673 Defining_Identifier => Obj_Id,
8674 Object_Definition => New_Occurrence_Of (Ptr_Typ, Loc),
8675 Expression => New_Expr);
8676 Insert_After_And_Analyze (Ptr_Typ_Decl, Obj_Decl);
8678 Rewrite (Assign, Make_Null_Statement (Loc));
8679 pragma Assert (Check_Number_Of_Actuals (Func_Call, Func_Id));
8680 end Make_Build_In_Place_Call_In_Assignment;
8682 ----------------------------------------------------
8683 -- Make_Build_In_Place_Call_In_Object_Declaration --
8684 ----------------------------------------------------
8686 procedure Make_Build_In_Place_Call_In_Object_Declaration
8687 (Obj_Decl : Node_Id;
8688 Function_Call : Node_Id)
8690 function Get_Function_Id (Func_Call : Node_Id) return Entity_Id;
8691 -- Get the value of Function_Id, below
8693 ---------------------
8694 -- Get_Function_Id --
8695 ---------------------
8697 function Get_Function_Id (Func_Call : Node_Id) return Entity_Id is
8699 if Is_Entity_Name (Name (Func_Call)) then
8700 return Entity (Name (Func_Call));
8702 elsif Nkind (Name (Func_Call)) = N_Explicit_Dereference then
8703 return Etype (Name (Func_Call));
8706 raise Program_Error;
8708 end Get_Function_Id;
8712 Func_Call : constant Node_Id := Unqual_Conv (Function_Call);
8713 Function_Id : constant Entity_Id := Get_Function_Id (Func_Call);
8714 Loc : constant Source_Ptr := Sloc (Function_Call);
8715 Obj_Loc : constant Source_Ptr := Sloc (Obj_Decl);
8716 Obj_Def_Id : constant Entity_Id := Defining_Identifier (Obj_Decl);
8717 Obj_Typ : constant Entity_Id := Etype (Obj_Def_Id);
8718 Encl_Func : constant Entity_Id := Enclosing_Subprogram (Obj_Def_Id);
8719 Result_Subt : constant Entity_Id := Etype (Function_Id);
8721 Call_Deref : Node_Id;
8722 Caller_Object : Node_Id;
8724 Designated_Type : Entity_Id;
8725 Fmaster_Actual : Node_Id := Empty;
8726 Pool_Actual : Node_Id;
8727 Ptr_Typ : Entity_Id;
8728 Ptr_Typ_Decl : Node_Id;
8729 Pass_Caller_Acc : Boolean := False;
8732 Definite : constant Boolean :=
8733 Caller_Known_Size (Func_Call, Result_Subt)
8734 and then not Is_Class_Wide_Type (Obj_Typ);
8735 -- In the case of "X : T'Class := F(...);", where F returns a
8736 -- Caller_Known_Size (specific) tagged type, we treat it as
8737 -- indefinite, because the code for the Definite case below sets the
8738 -- initialization expression of the object to Empty, which would be
8739 -- illegal Ada, and would cause gigi to misallocate X.
8741 -- Start of processing for Make_Build_In_Place_Call_In_Object_Declaration
8744 -- If the call has already been processed to add build-in-place actuals
8747 if Is_Expanded_Build_In_Place_Call (Func_Call) then
8751 -- Mark the call as processed as a build-in-place call
8753 Set_Is_Expanded_Build_In_Place_Call (Func_Call);
8755 -- Create an access type designating the function's result subtype.
8756 -- We use the type of the original call because it may be a call to an
8757 -- inherited operation, which the expansion has replaced with the parent
8758 -- operation that yields the parent type. Note that this access type
8759 -- must be declared before we establish a transient scope, so that it
8760 -- receives the proper accessibility level.
8762 if Is_Class_Wide_Type (Obj_Typ)
8763 and then not Is_Interface (Obj_Typ)
8764 and then not Is_Class_Wide_Type (Etype (Function_Call))
8766 Designated_Type := Obj_Typ;
8768 Designated_Type := Etype (Function_Call);
8771 Ptr_Typ := Make_Temporary (Loc, 'A');
8773 Make_Full_Type_Declaration (Loc,
8774 Defining_Identifier => Ptr_Typ,
8776 Make_Access_To_Object_Definition (Loc,
8777 All_Present => True,
8778 Subtype_Indication =>
8779 New_Occurrence_Of (Designated_Type, Loc)));
8781 -- The access type and its accompanying object must be inserted after
8782 -- the object declaration in the constrained case, so that the function
8783 -- call can be passed access to the object. In the indefinite case, or
8784 -- if the object declaration is for a return object, the access type and
8785 -- object must be inserted before the object, since the object
8786 -- declaration is rewritten to be a renaming of a dereference of the
8787 -- access object. Note: we need to freeze Ptr_Typ explicitly, because
8788 -- the result object is in a different (transient) scope, so won't cause
8791 if Definite and then not Is_Return_Object (Obj_Def_Id) then
8793 -- The presence of an address clause complicates the build-in-place
8794 -- expansion because the indicated address must be processed before
8795 -- the indirect call is generated (including the definition of a
8796 -- local pointer to the object). The address clause may come from
8797 -- an aspect specification or from an explicit attribute
8798 -- specification appearing after the object declaration. These two
8799 -- cases require different processing.
8801 if Has_Aspect (Obj_Def_Id, Aspect_Address) then
8803 -- Skip non-delayed pragmas that correspond to other aspects, if
8804 -- any, to find proper insertion point for freeze node of object.
8807 D : Node_Id := Obj_Decl;
8808 N : Node_Id := Next (D);
8812 and then Nkind_In (N, N_Attribute_Reference, N_Pragma)
8819 Insert_After (D, Ptr_Typ_Decl);
8821 -- Freeze object before pointer declaration, to ensure that
8822 -- generated attribute for address is inserted at the proper
8825 Freeze_Before (Ptr_Typ_Decl, Obj_Def_Id);
8828 Analyze (Ptr_Typ_Decl);
8830 elsif Present (Following_Address_Clause (Obj_Decl)) then
8832 -- Locate explicit address clause, which may also follow pragmas
8833 -- generated by other aspect specifications.
8836 Addr : constant Node_Id := Following_Address_Clause (Obj_Decl);
8837 D : Node_Id := Next (Obj_Decl);
8840 while Present (D) loop
8846 Insert_After_And_Analyze (Addr, Ptr_Typ_Decl);
8850 Insert_After_And_Analyze (Obj_Decl, Ptr_Typ_Decl);
8853 Insert_Action (Obj_Decl, Ptr_Typ_Decl);
8856 -- Force immediate freezing of Ptr_Typ because Res_Decl will be
8857 -- elaborated in an inner (transient) scope and thus won't cause
8858 -- freezing by itself. It's not an itype, but it needs to be frozen
8859 -- inside the current subprogram (see Freeze_Outside in freeze.adb).
8861 Freeze_Itype (Ptr_Typ, Ptr_Typ_Decl);
8863 -- If the object is a return object of an enclosing build-in-place
8864 -- function, then the implicit build-in-place parameters of the
8865 -- enclosing function are simply passed along to the called function.
8866 -- (Unfortunately, this won't cover the case of extension aggregates
8867 -- where the ancestor part is a build-in-place indefinite function
8868 -- call that should be passed along the caller's parameters.
8869 -- Currently those get mishandled by reassigning the result of the
8870 -- call to the aggregate return object, when the call result should
8871 -- really be directly built in place in the aggregate and not in a
8874 if Is_Return_Object (Obj_Def_Id) then
8875 Pass_Caller_Acc := True;
8877 -- When the enclosing function has a BIP_Alloc_Form formal then we
8878 -- pass it along to the callee (such as when the enclosing function
8879 -- has an unconstrained or tagged result type).
8881 if Needs_BIP_Alloc_Form (Encl_Func) then
8882 if RTE_Available (RE_Root_Storage_Pool_Ptr) then
8885 (Build_In_Place_Formal
8886 (Encl_Func, BIP_Storage_Pool), Loc);
8888 -- The build-in-place pool formal is not built on e.g. ZFP
8891 Pool_Actual := Empty;
8894 Add_Unconstrained_Actuals_To_Build_In_Place_Call
8895 (Function_Call => Func_Call,
8896 Function_Id => Function_Id,
8899 (Build_In_Place_Formal (Encl_Func, BIP_Alloc_Form), Loc),
8900 Pool_Actual => Pool_Actual);
8902 -- Otherwise, if enclosing function has a definite result subtype,
8903 -- then caller allocation will be used.
8906 Add_Unconstrained_Actuals_To_Build_In_Place_Call
8907 (Func_Call, Function_Id, Alloc_Form => Caller_Allocation);
8910 if Needs_BIP_Finalization_Master (Encl_Func) then
8913 (Build_In_Place_Formal
8914 (Encl_Func, BIP_Finalization_Master), Loc);
8917 -- Retrieve the BIPacc formal from the enclosing function and convert
8918 -- it to the access type of the callee's BIP_Object_Access formal.
8921 Make_Unchecked_Type_Conversion (Loc,
8924 (Etype (Build_In_Place_Formal
8925 (Function_Id, BIP_Object_Access)),
8929 (Build_In_Place_Formal (Encl_Func, BIP_Object_Access),
8932 -- In the definite case, add an implicit actual to the function call
8933 -- that provides access to the declared object. An unchecked conversion
8934 -- to the (specific) result type of the function is inserted to handle
8935 -- the case where the object is declared with a class-wide type.
8939 Make_Unchecked_Type_Conversion (Loc,
8940 Subtype_Mark => New_Occurrence_Of (Result_Subt, Loc),
8941 Expression => New_Occurrence_Of (Obj_Def_Id, Loc));
8943 -- When the function has a controlling result, an allocation-form
8944 -- parameter must be passed indicating that the caller is allocating
8945 -- the result object. This is needed because such a function can be
8946 -- called as a dispatching operation and must be treated similarly to
8947 -- functions with indefinite result subtypes.
8949 Add_Unconstrained_Actuals_To_Build_In_Place_Call
8950 (Func_Call, Function_Id, Alloc_Form => Caller_Allocation);
8952 -- The allocation for indefinite library-level objects occurs on the
8953 -- heap as opposed to the secondary stack. This accommodates DLLs where
8954 -- the secondary stack is destroyed after each library unload. This is a
8955 -- hybrid mechanism where a stack-allocated object lives on the heap.
8957 elsif Is_Library_Level_Entity (Obj_Def_Id)
8958 and then not Restriction_Active (No_Implicit_Heap_Allocations)
8960 Add_Unconstrained_Actuals_To_Build_In_Place_Call
8961 (Func_Call, Function_Id, Alloc_Form => Global_Heap);
8962 Caller_Object := Empty;
8964 -- Create a finalization master for the access result type to ensure
8965 -- that the heap allocation can properly chain the object and later
8966 -- finalize it when the library unit goes out of scope.
8968 if Needs_Finalization (Etype (Func_Call)) then
8969 Build_Finalization_Master
8971 For_Lib_Level => True,
8972 Insertion_Node => Ptr_Typ_Decl);
8975 Make_Attribute_Reference (Loc,
8977 New_Occurrence_Of (Finalization_Master (Ptr_Typ), Loc),
8978 Attribute_Name => Name_Unrestricted_Access);
8981 -- In other indefinite cases, pass an indication to do the allocation
8982 -- on the secondary stack and set Caller_Object to Empty so that a null
8983 -- value will be passed for the caller's object address. A transient
8984 -- scope is established to ensure eventual cleanup of the result.
8987 Add_Unconstrained_Actuals_To_Build_In_Place_Call
8988 (Func_Call, Function_Id, Alloc_Form => Secondary_Stack);
8989 Caller_Object := Empty;
8991 Establish_Transient_Scope (Obj_Decl, Manage_Sec_Stack => True);
8994 -- Pass along any finalization master actual, which is needed in the
8995 -- case where the called function initializes a return object of an
8996 -- enclosing build-in-place function.
8998 Add_Finalization_Master_Actual_To_Build_In_Place_Call
8999 (Func_Call => Func_Call,
9000 Func_Id => Function_Id,
9001 Master_Exp => Fmaster_Actual);
9003 if Nkind (Parent (Obj_Decl)) = N_Extended_Return_Statement
9004 and then Needs_BIP_Task_Actuals (Function_Id)
9006 -- Here we're passing along the master that was passed in to this
9009 Add_Task_Actuals_To_Build_In_Place_Call
9010 (Func_Call, Function_Id,
9013 (Build_In_Place_Formal (Encl_Func, BIP_Task_Master), Loc));
9016 Add_Task_Actuals_To_Build_In_Place_Call
9017 (Func_Call, Function_Id, Make_Identifier (Loc, Name_uMaster));
9020 Add_Access_Actual_To_Build_In_Place_Call
9024 Is_Access => Pass_Caller_Acc);
9026 -- Finally, create an access object initialized to a reference to the
9027 -- function call. We know this access value cannot be null, so mark the
9028 -- entity accordingly to suppress the access check.
9030 Def_Id := Make_Temporary (Loc, 'R', Func_Call);
9031 Set_Etype (Def_Id, Ptr_Typ);
9032 Set_Is_Known_Non_Null (Def_Id);
9034 if Nkind_In (Function_Call, N_Type_Conversion,
9035 N_Unchecked_Type_Conversion)
9038 Make_Object_Declaration (Loc,
9039 Defining_Identifier => Def_Id,
9040 Constant_Present => True,
9041 Object_Definition => New_Occurrence_Of (Ptr_Typ, Loc),
9043 Make_Unchecked_Type_Conversion (Loc,
9044 New_Occurrence_Of (Ptr_Typ, Loc),
9045 Make_Reference (Loc, Relocate_Node (Func_Call))));
9048 Make_Object_Declaration (Loc,
9049 Defining_Identifier => Def_Id,
9050 Constant_Present => True,
9051 Object_Definition => New_Occurrence_Of (Ptr_Typ, Loc),
9053 Make_Reference (Loc, Relocate_Node (Func_Call)));
9056 Insert_After_And_Analyze (Ptr_Typ_Decl, Res_Decl);
9058 -- If the result subtype of the called function is definite and is not
9059 -- itself the return expression of an enclosing BIP function, then mark
9060 -- the object as having no initialization.
9062 if Definite and then not Is_Return_Object (Obj_Def_Id) then
9064 -- The related object declaration is encased in a transient block
9065 -- because the build-in-place function call contains at least one
9066 -- nested function call that produces a controlled transient
9069 -- Obj : ... := BIP_Func_Call (Ctrl_Func_Call);
9071 -- Since the build-in-place expansion decouples the call from the
9072 -- object declaration, the finalization machinery lacks the context
9073 -- which prompted the generation of the transient block. To resolve
9074 -- this scenario, store the build-in-place call.
9076 if Scope_Is_Transient and then Node_To_Be_Wrapped = Obj_Decl then
9077 Set_BIP_Initialization_Call (Obj_Def_Id, Res_Decl);
9080 Set_Expression (Obj_Decl, Empty);
9081 Set_No_Initialization (Obj_Decl);
9083 -- In case of an indefinite result subtype, or if the call is the
9084 -- return expression of an enclosing BIP function, rewrite the object
9085 -- declaration as an object renaming where the renamed object is a
9086 -- dereference of <function_Call>'reference:
9088 -- Obj : Subt renames <function_call>'Ref.all;
9092 Make_Explicit_Dereference (Obj_Loc,
9093 Prefix => New_Occurrence_Of (Def_Id, Obj_Loc));
9096 Make_Object_Renaming_Declaration (Obj_Loc,
9097 Defining_Identifier => Make_Temporary (Obj_Loc, 'D'),
9099 New_Occurrence_Of (Designated_Type, Obj_Loc),
9100 Name => Call_Deref));
9102 -- At this point, Defining_Identifier (Obj_Decl) is no longer equal
9105 Set_Renamed_Object (Defining_Identifier (Obj_Decl), Call_Deref);
9107 -- If the original entity comes from source, then mark the new
9108 -- entity as needing debug information, even though it's defined
9109 -- by a generated renaming that does not come from source, so that
9110 -- the Materialize_Entity flag will be set on the entity when
9111 -- Debug_Renaming_Declaration is called during analysis.
9113 if Comes_From_Source (Obj_Def_Id) then
9114 Set_Debug_Info_Needed (Defining_Identifier (Obj_Decl));
9118 Replace_Renaming_Declaration_Id
9119 (Obj_Decl, Original_Node (Obj_Decl));
9122 pragma Assert (Check_Number_Of_Actuals (Func_Call, Function_Id));
9123 end Make_Build_In_Place_Call_In_Object_Declaration;
9125 -------------------------------------------------
9126 -- Make_Build_In_Place_Iface_Call_In_Allocator --
9127 -------------------------------------------------
9129 procedure Make_Build_In_Place_Iface_Call_In_Allocator
9130 (Allocator : Node_Id;
9131 Function_Call : Node_Id)
9133 BIP_Func_Call : constant Node_Id :=
9134 Unqual_BIP_Iface_Function_Call (Function_Call);
9135 Loc : constant Source_Ptr := Sloc (Function_Call);
9137 Anon_Type : Entity_Id;
9142 -- No action of the call has already been processed
9144 if Is_Expanded_Build_In_Place_Call (BIP_Func_Call) then
9148 Tmp_Id := Make_Temporary (Loc, 'D');
9150 -- Insert a temporary before N initialized with the BIP function call
9151 -- without its enclosing type conversions and analyze it without its
9152 -- expansion. This temporary facilitates us reusing the BIP machinery,
9153 -- which takes care of adding the extra build-in-place actuals and
9154 -- transforms this object declaration into an object renaming
9157 Anon_Type := Create_Itype (E_Anonymous_Access_Type, Function_Call);
9158 Set_Directly_Designated_Type (Anon_Type, Etype (BIP_Func_Call));
9159 Set_Etype (Anon_Type, Anon_Type);
9162 Make_Object_Declaration (Loc,
9163 Defining_Identifier => Tmp_Id,
9164 Object_Definition => New_Occurrence_Of (Anon_Type, Loc),
9166 Make_Allocator (Loc,
9168 Make_Qualified_Expression (Loc,
9170 New_Occurrence_Of (Etype (BIP_Func_Call), Loc),
9171 Expression => New_Copy_Tree (BIP_Func_Call))));
9173 Expander_Mode_Save_And_Set (False);
9174 Insert_Action (Allocator, Tmp_Decl);
9175 Expander_Mode_Restore;
9177 Make_Build_In_Place_Call_In_Allocator
9178 (Allocator => Expression (Tmp_Decl),
9179 Function_Call => Expression (Expression (Tmp_Decl)));
9181 Rewrite (Allocator, New_Occurrence_Of (Tmp_Id, Loc));
9182 end Make_Build_In_Place_Iface_Call_In_Allocator;
9184 ---------------------------------------------------------
9185 -- Make_Build_In_Place_Iface_Call_In_Anonymous_Context --
9186 ---------------------------------------------------------
9188 procedure Make_Build_In_Place_Iface_Call_In_Anonymous_Context
9189 (Function_Call : Node_Id)
9191 BIP_Func_Call : constant Node_Id :=
9192 Unqual_BIP_Iface_Function_Call (Function_Call);
9193 Loc : constant Source_Ptr := Sloc (Function_Call);
9199 -- No action of the call has already been processed
9201 if Is_Expanded_Build_In_Place_Call (BIP_Func_Call) then
9205 pragma Assert (Needs_Finalization (Etype (BIP_Func_Call)));
9207 -- Insert a temporary before the call initialized with function call to
9208 -- reuse the BIP machinery which takes care of adding the extra build-in
9209 -- place actuals and transforms this object declaration into an object
9210 -- renaming declaration.
9212 Tmp_Id := Make_Temporary (Loc, 'D');
9215 Make_Object_Declaration (Loc,
9216 Defining_Identifier => Tmp_Id,
9217 Object_Definition =>
9218 New_Occurrence_Of (Etype (Function_Call), Loc),
9219 Expression => Relocate_Node (Function_Call));
9221 Expander_Mode_Save_And_Set (False);
9222 Insert_Action (Function_Call, Tmp_Decl);
9223 Expander_Mode_Restore;
9225 Make_Build_In_Place_Iface_Call_In_Object_Declaration
9226 (Obj_Decl => Tmp_Decl,
9227 Function_Call => Expression (Tmp_Decl));
9228 end Make_Build_In_Place_Iface_Call_In_Anonymous_Context;
9230 ----------------------------------------------------------
9231 -- Make_Build_In_Place_Iface_Call_In_Object_Declaration --
9232 ----------------------------------------------------------
9234 procedure Make_Build_In_Place_Iface_Call_In_Object_Declaration
9235 (Obj_Decl : Node_Id;
9236 Function_Call : Node_Id)
9238 BIP_Func_Call : constant Node_Id :=
9239 Unqual_BIP_Iface_Function_Call (Function_Call);
9240 Loc : constant Source_Ptr := Sloc (Function_Call);
9241 Obj_Id : constant Entity_Id := Defining_Entity (Obj_Decl);
9247 -- No action of the call has already been processed
9249 if Is_Expanded_Build_In_Place_Call (BIP_Func_Call) then
9253 Tmp_Id := Make_Temporary (Loc, 'D');
9255 -- Insert a temporary before N initialized with the BIP function call
9256 -- without its enclosing type conversions and analyze it without its
9257 -- expansion. This temporary facilitates us reusing the BIP machinery,
9258 -- which takes care of adding the extra build-in-place actuals and
9259 -- transforms this object declaration into an object renaming
9263 Make_Object_Declaration (Loc,
9264 Defining_Identifier => Tmp_Id,
9265 Object_Definition =>
9266 New_Occurrence_Of (Etype (BIP_Func_Call), Loc),
9267 Expression => New_Copy_Tree (BIP_Func_Call));
9269 Expander_Mode_Save_And_Set (False);
9270 Insert_Action (Obj_Decl, Tmp_Decl);
9271 Expander_Mode_Restore;
9273 Make_Build_In_Place_Call_In_Object_Declaration
9274 (Obj_Decl => Tmp_Decl,
9275 Function_Call => Expression (Tmp_Decl));
9277 pragma Assert (Nkind (Tmp_Decl) = N_Object_Renaming_Declaration);
9279 -- Replace the original build-in-place function call by a reference to
9280 -- the resulting temporary object renaming declaration. In this way,
9281 -- all the interface conversions performed in the original Function_Call
9282 -- on the build-in-place object are preserved.
9284 Rewrite (BIP_Func_Call, New_Occurrence_Of (Tmp_Id, Loc));
9286 -- Replace the original object declaration by an internal object
9287 -- renaming declaration. This leaves the generated code more clean (the
9288 -- build-in-place function call in an object renaming declaration and
9289 -- displacements of the pointer to the build-in-place object in another
9290 -- renaming declaration) and allows us to invoke the routine that takes
9291 -- care of replacing the identifier of the renaming declaration (routine
9292 -- originally developed for the regular build-in-place management).
9295 Make_Object_Renaming_Declaration (Loc,
9296 Defining_Identifier => Make_Temporary (Loc, 'D'),
9297 Subtype_Mark => New_Occurrence_Of (Etype (Obj_Id), Loc),
9298 Name => Function_Call));
9301 Replace_Renaming_Declaration_Id (Obj_Decl, Original_Node (Obj_Decl));
9302 end Make_Build_In_Place_Iface_Call_In_Object_Declaration;
9304 --------------------------------------------
9305 -- Make_CPP_Constructor_Call_In_Allocator --
9306 --------------------------------------------
9308 procedure Make_CPP_Constructor_Call_In_Allocator
9309 (Allocator : Node_Id;
9310 Function_Call : Node_Id)
9312 Loc : constant Source_Ptr := Sloc (Function_Call);
9313 Acc_Type : constant Entity_Id := Etype (Allocator);
9314 Function_Id : constant Entity_Id := Entity (Name (Function_Call));
9315 Result_Subt : constant Entity_Id := Available_View (Etype (Function_Id));
9317 New_Allocator : Node_Id;
9318 Return_Obj_Access : Entity_Id;
9322 pragma Assert (Nkind (Allocator) = N_Allocator
9323 and then Nkind (Function_Call) = N_Function_Call);
9324 pragma Assert (Convention (Function_Id) = Convention_CPP
9325 and then Is_Constructor (Function_Id));
9326 pragma Assert (Is_Constrained (Underlying_Type (Result_Subt)));
9328 -- Replace the initialized allocator of form "new T'(Func (...))" with
9329 -- an uninitialized allocator of form "new T", where T is the result
9330 -- subtype of the called function. The call to the function is handled
9331 -- separately further below.
9334 Make_Allocator (Loc,
9335 Expression => New_Occurrence_Of (Result_Subt, Loc));
9336 Set_No_Initialization (New_Allocator);
9338 -- Copy attributes to new allocator. Note that the new allocator
9339 -- logically comes from source if the original one did, so copy the
9340 -- relevant flag. This ensures proper treatment of the restriction
9341 -- No_Implicit_Heap_Allocations in this case.
9343 Set_Storage_Pool (New_Allocator, Storage_Pool (Allocator));
9344 Set_Procedure_To_Call (New_Allocator, Procedure_To_Call (Allocator));
9345 Set_Comes_From_Source (New_Allocator, Comes_From_Source (Allocator));
9347 Rewrite (Allocator, New_Allocator);
9349 -- Create a new access object and initialize it to the result of the
9350 -- new uninitialized allocator. Note: we do not use Allocator as the
9351 -- Related_Node of Return_Obj_Access in call to Make_Temporary below
9352 -- as this would create a sort of infinite "recursion".
9354 Return_Obj_Access := Make_Temporary (Loc, 'R');
9355 Set_Etype (Return_Obj_Access, Acc_Type);
9358 -- Rnnn : constant ptr_T := new (T);
9359 -- Init (Rnn.all,...);
9362 Make_Object_Declaration (Loc,
9363 Defining_Identifier => Return_Obj_Access,
9364 Constant_Present => True,
9365 Object_Definition => New_Occurrence_Of (Acc_Type, Loc),
9366 Expression => Relocate_Node (Allocator));
9367 Insert_Action (Allocator, Tmp_Obj);
9369 Insert_List_After_And_Analyze (Tmp_Obj,
9370 Build_Initialization_Call (Loc,
9372 Make_Explicit_Dereference (Loc,
9373 Prefix => New_Occurrence_Of (Return_Obj_Access, Loc)),
9374 Typ => Etype (Function_Id),
9375 Constructor_Ref => Function_Call));
9377 -- Finally, replace the allocator node with a reference to the result of
9378 -- the function call itself (which will effectively be an access to the
9379 -- object created by the allocator).
9381 Rewrite (Allocator, New_Occurrence_Of (Return_Obj_Access, Loc));
9383 -- Ada 2005 (AI-251): If the type of the allocator is an interface then
9384 -- generate an implicit conversion to force displacement of the "this"
9387 if Is_Interface (Designated_Type (Acc_Type)) then
9388 Rewrite (Allocator, Convert_To (Acc_Type, Relocate_Node (Allocator)));
9391 Analyze_And_Resolve (Allocator, Acc_Type);
9392 end Make_CPP_Constructor_Call_In_Allocator;
9394 ----------------------------
9395 -- Needs_BIP_Task_Actuals --
9396 ----------------------------
9398 function Needs_BIP_Task_Actuals (Func_Id : Entity_Id) return Boolean is
9399 pragma Assert (Is_Build_In_Place_Function (Func_Id));
9400 Func_Typ : constant Entity_Id := Underlying_Type (Etype (Func_Id));
9402 return Has_Task (Func_Typ);
9403 end Needs_BIP_Task_Actuals;
9405 -----------------------------------
9406 -- Needs_BIP_Finalization_Master --
9407 -----------------------------------
9409 function Needs_BIP_Finalization_Master
9410 (Func_Id : Entity_Id) return Boolean
9412 pragma Assert (Is_Build_In_Place_Function (Func_Id));
9413 Func_Typ : constant Entity_Id := Underlying_Type (Etype (Func_Id));
9415 -- A formal giving the finalization master is needed for build-in-place
9416 -- functions whose result type needs finalization or is a tagged type.
9417 -- Tagged primitive build-in-place functions need such a formal because
9418 -- they can be called by a dispatching call, and extensions may require
9419 -- finalization even if the root type doesn't. This means they're also
9420 -- needed for tagged nonprimitive build-in-place functions with tagged
9421 -- results, since such functions can be called via access-to-function
9422 -- types, and those can be used to call primitives, so masters have to
9423 -- be passed to all such build-in-place functions, primitive or not.
9426 not Restriction_Active (No_Finalization)
9427 and then (Needs_Finalization (Func_Typ)
9428 or else Is_Tagged_Type (Func_Typ));
9429 end Needs_BIP_Finalization_Master;
9431 --------------------------
9432 -- Needs_BIP_Alloc_Form --
9433 --------------------------
9435 function Needs_BIP_Alloc_Form (Func_Id : Entity_Id) return Boolean is
9436 pragma Assert (Is_Build_In_Place_Function (Func_Id));
9437 Func_Typ : constant Entity_Id := Underlying_Type (Etype (Func_Id));
9439 return Requires_Transient_Scope (Func_Typ);
9440 end Needs_BIP_Alloc_Form;
9442 --------------------------------------
9443 -- Needs_Result_Accessibility_Level --
9444 --------------------------------------
9446 function Needs_Result_Accessibility_Level
9447 (Func_Id : Entity_Id) return Boolean
9449 Func_Typ : constant Entity_Id := Underlying_Type (Etype (Func_Id));
9451 function Has_Unconstrained_Access_Discriminant_Component
9452 (Comp_Typ : Entity_Id) return Boolean;
9453 -- Returns True if any component of the type has an unconstrained access
9456 -----------------------------------------------------
9457 -- Has_Unconstrained_Access_Discriminant_Component --
9458 -----------------------------------------------------
9460 function Has_Unconstrained_Access_Discriminant_Component
9461 (Comp_Typ : Entity_Id) return Boolean
9464 if not Is_Limited_Type (Comp_Typ) then
9467 -- Only limited types can have access discriminants with
9470 elsif Has_Unconstrained_Access_Discriminants (Comp_Typ) then
9473 elsif Is_Array_Type (Comp_Typ) then
9474 return Has_Unconstrained_Access_Discriminant_Component
9475 (Underlying_Type (Component_Type (Comp_Typ)));
9477 elsif Is_Record_Type (Comp_Typ) then
9482 Comp := First_Component (Comp_Typ);
9483 while Present (Comp) loop
9484 if Has_Unconstrained_Access_Discriminant_Component
9485 (Underlying_Type (Etype (Comp)))
9490 Next_Component (Comp);
9496 end Has_Unconstrained_Access_Discriminant_Component;
9498 Disable_Coextension_Cases : constant Boolean := True;
9499 -- Flag used to temporarily disable a "True" result for types with
9500 -- access discriminants and related coextension cases.
9502 -- Start of processing for Needs_Result_Accessibility_Level
9505 -- False if completion unavailable (how does this happen???)
9507 if not Present (Func_Typ) then
9510 -- False if not a function, also handle enum-lit renames case
9512 elsif Func_Typ = Standard_Void_Type
9513 or else Is_Scalar_Type (Func_Typ)
9517 -- Handle a corner case, a cross-dialect subp renaming. For example,
9518 -- an Ada 2012 renaming of an Ada 2005 subprogram. This can occur when
9519 -- an Ada 2005 (or earlier) unit references predefined run-time units.
9521 elsif Present (Alias (Func_Id)) then
9523 -- Unimplemented: a cross-dialect subp renaming which does not set
9524 -- the Alias attribute (e.g., a rename of a dereference of an access
9525 -- to subprogram value). ???
9527 return Present (Extra_Accessibility_Of_Result (Alias (Func_Id)));
9529 -- Remaining cases require Ada 2012 mode
9531 elsif Ada_Version < Ada_2012 then
9534 -- Handle the situation where a result is an anonymous access type
9535 -- RM 3.10.2 (10.3/3).
9537 elsif Ekind (Func_Typ) = E_Anonymous_Access_Type then
9540 -- The following cases are related to coextensions and do not fully
9541 -- cover everything mentioned in RM 3.10.2 (12) ???
9543 -- Temporarily disabled ???
9545 elsif Disable_Coextension_Cases then
9548 -- In the case of, say, a null tagged record result type, the need for
9549 -- this extra parameter might not be obvious so this function returns
9550 -- True for all tagged types for compatibility reasons.
9552 -- A function with, say, a tagged null controlling result type might
9553 -- be overridden by a primitive of an extension having an access
9554 -- discriminant and the overrider and overridden must have compatible
9555 -- calling conventions (including implicitly declared parameters).
9557 -- Similarly, values of one access-to-subprogram type might designate
9558 -- both a primitive subprogram of a given type and a function which is,
9559 -- for example, not a primitive subprogram of any type. Again, this
9560 -- requires calling convention compatibility. It might be possible to
9561 -- solve these issues by introducing wrappers, but that is not the
9562 -- approach that was chosen.
9564 elsif Is_Tagged_Type (Func_Typ) then
9567 elsif Has_Unconstrained_Access_Discriminants (Func_Typ) then
9570 elsif Has_Unconstrained_Access_Discriminant_Component (Func_Typ) then
9573 -- False for all other cases
9578 end Needs_Result_Accessibility_Level;
9580 -------------------------------------
9581 -- Replace_Renaming_Declaration_Id --
9582 -------------------------------------
9584 procedure Replace_Renaming_Declaration_Id
9585 (New_Decl : Node_Id;
9586 Orig_Decl : Node_Id)
9588 New_Id : constant Entity_Id := Defining_Entity (New_Decl);
9589 Orig_Id : constant Entity_Id := Defining_Entity (Orig_Decl);
9592 Set_Chars (New_Id, Chars (Orig_Id));
9594 -- Swap next entity links in preparation for exchanging entities
9597 Next_Id : constant Entity_Id := Next_Entity (New_Id);
9599 Link_Entities (New_Id, Next_Entity (Orig_Id));
9600 Link_Entities (Orig_Id, Next_Id);
9603 Set_Homonym (New_Id, Homonym (Orig_Id));
9604 Exchange_Entities (New_Id, Orig_Id);
9606 -- Preserve source indication of original declaration, so that xref
9607 -- information is properly generated for the right entity.
9609 Preserve_Comes_From_Source (New_Decl, Orig_Decl);
9610 Preserve_Comes_From_Source (Orig_Id, Orig_Decl);
9612 Set_Comes_From_Source (New_Id, False);
9613 end Replace_Renaming_Declaration_Id;
9615 ---------------------------------
9616 -- Rewrite_Function_Call_For_C --
9617 ---------------------------------
9619 procedure Rewrite_Function_Call_For_C (N : Node_Id) is
9620 Orig_Func : constant Entity_Id := Entity (Name (N));
9621 Func_Id : constant Entity_Id := Ultimate_Alias (Orig_Func);
9622 Par : constant Node_Id := Parent (N);
9623 Proc_Id : constant Entity_Id := Corresponding_Procedure (Func_Id);
9624 Loc : constant Source_Ptr := Sloc (Par);
9626 Last_Actual : Node_Id;
9627 Last_Formal : Entity_Id;
9629 -- Start of processing for Rewrite_Function_Call_For_C
9632 -- The actuals may be given by named associations, so the added actual
9633 -- that is the target of the return value of the call must be a named
9634 -- association as well, so we retrieve the name of the generated
9637 Last_Formal := First_Formal (Proc_Id);
9638 while Present (Next_Formal (Last_Formal)) loop
9639 Last_Formal := Next_Formal (Last_Formal);
9642 Actuals := Parameter_Associations (N);
9644 -- The original function may lack parameters
9646 if No (Actuals) then
9647 Actuals := New_List;
9650 -- If the function call is the expression of an assignment statement,
9651 -- transform the assignment into a procedure call. Generate:
9653 -- LHS := Func_Call (...);
9655 -- Proc_Call (..., LHS);
9657 -- If function is inherited, a conversion may be necessary.
9659 if Nkind (Par) = N_Assignment_Statement then
9660 Last_Actual := Name (Par);
9662 if not Comes_From_Source (Orig_Func)
9663 and then Etype (Orig_Func) /= Etype (Func_Id)
9666 Make_Type_Conversion (Loc,
9667 New_Occurrence_Of (Etype (Func_Id), Loc),
9672 Make_Parameter_Association (Loc,
9674 Make_Identifier (Loc, Chars (Last_Formal)),
9675 Explicit_Actual_Parameter => Last_Actual));
9678 Make_Procedure_Call_Statement (Loc,
9679 Name => New_Occurrence_Of (Proc_Id, Loc),
9680 Parameter_Associations => Actuals));
9683 -- Otherwise the context is an expression. Generate a temporary and a
9684 -- procedure call to obtain the function result. Generate:
9686 -- ... Func_Call (...) ...
9689 -- Proc_Call (..., Temp);
9694 Temp_Id : constant Entity_Id := Make_Temporary (Loc, 'T');
9703 Make_Object_Declaration (Loc,
9704 Defining_Identifier => Temp_Id,
9705 Object_Definition =>
9706 New_Occurrence_Of (Etype (Func_Id), Loc));
9709 -- Proc_Call (..., Temp);
9712 Make_Parameter_Association (Loc,
9714 Make_Identifier (Loc, Chars (Last_Formal)),
9715 Explicit_Actual_Parameter =>
9716 New_Occurrence_Of (Temp_Id, Loc)));
9719 Make_Procedure_Call_Statement (Loc,
9720 Name => New_Occurrence_Of (Proc_Id, Loc),
9721 Parameter_Associations => Actuals);
9723 Insert_Actions (Par, New_List (Decl, Call));
9724 Rewrite (N, New_Occurrence_Of (Temp_Id, Loc));
9727 end Rewrite_Function_Call_For_C;
9729 ------------------------------------
9730 -- Set_Enclosing_Sec_Stack_Return --
9731 ------------------------------------
9733 procedure Set_Enclosing_Sec_Stack_Return (N : Node_Id) is
9737 -- Due to a possible mix of internally generated blocks, source blocks
9738 -- and loops, the scope stack may not be contiguous as all labels are
9739 -- inserted at the top level within the related function. Instead,
9740 -- perform a parent-based traversal and mark all appropriate constructs.
9742 while Present (P) loop
9744 -- Mark the label of a source or internally generated block or
9747 if Nkind_In (P, N_Block_Statement, N_Loop_Statement) then
9748 Set_Sec_Stack_Needed_For_Return (Entity (Identifier (P)));
9750 -- Mark the enclosing function
9752 elsif Nkind (P) = N_Subprogram_Body then
9753 if Present (Corresponding_Spec (P)) then
9754 Set_Sec_Stack_Needed_For_Return (Corresponding_Spec (P));
9756 Set_Sec_Stack_Needed_For_Return (Defining_Entity (P));
9759 -- Do not go beyond the enclosing function
9766 end Set_Enclosing_Sec_Stack_Return;
9768 ------------------------------------
9769 -- Unqual_BIP_Iface_Function_Call --
9770 ------------------------------------
9772 function Unqual_BIP_Iface_Function_Call (Expr : Node_Id) return Node_Id is
9773 Has_Pointer_Displacement : Boolean := False;
9774 On_Object_Declaration : Boolean := False;
9775 -- Remember if processing the renaming expressions on recursion we have
9776 -- traversed an object declaration, since we can traverse many object
9777 -- declaration renamings but just one regular object declaration.
9779 function Unqual_BIP_Function_Call (Expr : Node_Id) return Node_Id;
9780 -- Search for a build-in-place function call skipping any qualification
9781 -- including qualified expressions, type conversions, references, calls
9782 -- to displace the pointer to the object, and renamings. Return Empty if
9783 -- no build-in-place function call is found.
9785 ------------------------------
9786 -- Unqual_BIP_Function_Call --
9787 ------------------------------
9789 function Unqual_BIP_Function_Call (Expr : Node_Id) return Node_Id is
9791 -- Recurse to handle case of multiple levels of qualification and/or
9794 if Nkind_In (Expr, N_Qualified_Expression,
9796 N_Unchecked_Type_Conversion)
9798 return Unqual_BIP_Function_Call (Expression (Expr));
9800 -- Recurse to handle case of multiple levels of references and
9801 -- explicit dereferences.
9803 elsif Nkind_In (Expr, N_Attribute_Reference,
9804 N_Explicit_Dereference,
9807 return Unqual_BIP_Function_Call (Prefix (Expr));
9809 -- Recurse on object renamings
9811 elsif Nkind (Expr) = N_Identifier
9812 and then Present (Entity (Expr))
9813 and then Ekind_In (Entity (Expr), E_Constant, E_Variable)
9814 and then Nkind (Parent (Entity (Expr))) =
9815 N_Object_Renaming_Declaration
9816 and then Present (Renamed_Object (Entity (Expr)))
9818 return Unqual_BIP_Function_Call (Renamed_Object (Entity (Expr)));
9820 -- Recurse on the initializing expression of the first reference of
9821 -- an object declaration.
9823 elsif not On_Object_Declaration
9824 and then Nkind (Expr) = N_Identifier
9825 and then Present (Entity (Expr))
9826 and then Ekind_In (Entity (Expr), E_Constant, E_Variable)
9827 and then Nkind (Parent (Entity (Expr))) = N_Object_Declaration
9828 and then Present (Expression (Parent (Entity (Expr))))
9830 On_Object_Declaration := True;
9832 Unqual_BIP_Function_Call (Expression (Parent (Entity (Expr))));
9834 -- Recurse to handle calls to displace the pointer to the object to
9835 -- reference a secondary dispatch table.
9837 elsif Nkind (Expr) = N_Function_Call
9838 and then Nkind (Name (Expr)) in N_Has_Entity
9839 and then Present (Entity (Name (Expr)))
9840 and then RTU_Loaded (Ada_Tags)
9841 and then RTE_Available (RE_Displace)
9842 and then Is_RTE (Entity (Name (Expr)), RE_Displace)
9844 Has_Pointer_Displacement := True;
9846 Unqual_BIP_Function_Call (First (Parameter_Associations (Expr)));
9848 -- Normal case: check if the inner expression is a BIP function call
9849 -- and the pointer to the object is displaced.
9851 elsif Has_Pointer_Displacement
9852 and then Is_Build_In_Place_Function_Call (Expr)
9859 end Unqual_BIP_Function_Call;
9861 -- Start of processing for Unqual_BIP_Iface_Function_Call
9864 if Nkind (Expr) = N_Identifier and then No (Entity (Expr)) then
9866 -- Can happen for X'Elab_Spec in the binder-generated file
9871 return Unqual_BIP_Function_Call (Expr);
9872 end Unqual_BIP_Iface_Function_Call;