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 -- Suffix for BIP formals
83 BIP_Alloc_Suffix : constant String := "BIPalloc";
84 BIP_Storage_Pool_Suffix : constant String := "BIPstoragepool";
85 BIP_Finalization_Master_Suffix : constant String := "BIPfinalizationmaster";
86 BIP_Task_Master_Suffix : constant String := "BIPtaskmaster";
87 BIP_Activation_Chain_Suffix : constant String := "BIPactivationchain";
88 BIP_Object_Access_Suffix : constant String := "BIPaccess";
90 -----------------------
91 -- Local Subprograms --
92 -----------------------
94 procedure Add_Access_Actual_To_Build_In_Place_Call
95 (Function_Call : Node_Id;
96 Function_Id : Entity_Id;
97 Return_Object : Node_Id;
98 Is_Access : Boolean := False);
99 -- Ada 2005 (AI-318-02): Apply the Unrestricted_Access attribute to the
100 -- object name given by Return_Object and add the attribute to the end of
101 -- the actual parameter list associated with the build-in-place function
102 -- call denoted by Function_Call. However, if Is_Access is True, then
103 -- Return_Object is already an access expression, in which case it's passed
104 -- along directly to the build-in-place function. Finally, if Return_Object
105 -- is empty, then pass a null literal as the actual.
107 procedure Add_Unconstrained_Actuals_To_Build_In_Place_Call
108 (Function_Call : Node_Id;
109 Function_Id : Entity_Id;
110 Alloc_Form : BIP_Allocation_Form := Unspecified;
111 Alloc_Form_Exp : Node_Id := Empty;
112 Pool_Actual : Node_Id := Make_Null (No_Location));
113 -- Ada 2005 (AI-318-02): Add the actuals needed for a build-in-place
114 -- function call that returns a caller-unknown-size result (BIP_Alloc_Form
115 -- and BIP_Storage_Pool). If Alloc_Form_Exp is present, then use it,
116 -- otherwise pass a literal corresponding to the Alloc_Form parameter
117 -- (which must not be Unspecified in that case). Pool_Actual is the
118 -- parameter to pass to BIP_Storage_Pool.
120 procedure Add_Finalization_Master_Actual_To_Build_In_Place_Call
121 (Func_Call : Node_Id;
123 Ptr_Typ : Entity_Id := Empty;
124 Master_Exp : Node_Id := Empty);
125 -- Ada 2005 (AI-318-02): If the result type of a build-in-place call needs
126 -- finalization actions, add an actual parameter which is a pointer to the
127 -- finalization master of the caller. If Master_Exp is not Empty, then that
128 -- will be passed as the actual. Otherwise, if Ptr_Typ is left Empty, this
129 -- will result in an automatic "null" value for the actual.
131 procedure Add_Task_Actuals_To_Build_In_Place_Call
132 (Function_Call : Node_Id;
133 Function_Id : Entity_Id;
134 Master_Actual : Node_Id;
135 Chain : Node_Id := Empty);
136 -- Ada 2005 (AI-318-02): For a build-in-place call, if the result type
137 -- contains tasks, add two actual parameters: the master, and a pointer to
138 -- the caller's activation chain. Master_Actual is the actual parameter
139 -- expression to pass for the master. In most cases, this is the current
140 -- master (_master). The two exceptions are: If the function call is the
141 -- initialization expression for an allocator, we pass the master of the
142 -- access type. If the function call is the initialization expression for a
143 -- return object, we pass along the master passed in by the caller. In most
144 -- contexts, the activation chain to pass is the local one, which is
145 -- indicated by No (Chain). However, in an allocator, the caller passes in
146 -- the activation Chain. Note: Master_Actual can be Empty, but only if
147 -- there are no tasks.
149 procedure Apply_CW_Accessibility_Check (Exp : Node_Id; Func : Entity_Id);
150 -- Ada 2005 (AI95-344): If the result type is class-wide, insert a check
151 -- that the level of the return expression's underlying type is not deeper
152 -- than the level of the master enclosing the function. Always generate the
153 -- check when the type of the return expression is class-wide, when it's a
154 -- type conversion, or when it's a formal parameter. Otherwise suppress the
155 -- check in the case where the return expression has a specific type whose
156 -- level is known not to be statically deeper than the result type of the
159 function Caller_Known_Size
160 (Func_Call : Node_Id;
161 Result_Subt : Entity_Id) return Boolean;
162 -- True if result subtype is definite, or has a size that does not require
163 -- secondary stack usage (i.e. no variant part or components whose type
164 -- depends on discriminants). In particular, untagged types with only
165 -- access discriminants do not require secondary stack use. Note we must
166 -- always use the secondary stack for dispatching-on-result calls.
168 function Check_BIP_Actuals
169 (Subp_Call : Node_Id;
170 Subp_Id : Entity_Id) return Boolean;
171 -- Given a subprogram call to the given subprogram return True if the
172 -- names of BIP extra actual and formal parameters match.
174 function Check_Number_Of_Actuals
175 (Subp_Call : Node_Id;
176 Subp_Id : Entity_Id) return Boolean;
177 -- Given a subprogram call to the given subprogram return True if the
178 -- number of actual parameters (including extra actuals) is correct.
180 procedure Check_Overriding_Operation (Subp : Entity_Id);
181 -- Subp is a dispatching operation. Check whether it may override an
182 -- inherited private operation, in which case its DT entry is that of
183 -- the hidden operation, not the one it may have received earlier.
184 -- This must be done before emitting the code to set the corresponding
185 -- DT to the address of the subprogram. The actual placement of Subp in
186 -- the proper place in the list of primitive operations is done in
187 -- Declare_Inherited_Private_Subprograms, which also has to deal with
188 -- implicit operations. This duplication is unavoidable for now???
190 procedure Detect_Infinite_Recursion (N : Node_Id; Spec : Entity_Id);
191 -- This procedure is called only if the subprogram body N, whose spec
192 -- has the given entity Spec, contains a parameterless recursive call.
193 -- It attempts to generate runtime code to detect if this a case of
194 -- infinite recursion.
196 -- The body is scanned to determine dependencies. If the only external
197 -- dependencies are on a small set of scalar variables, then the values
198 -- of these variables are captured on entry to the subprogram, and if
199 -- the values are not changed for the call, we know immediately that
200 -- we have an infinite recursion.
202 procedure Expand_Actuals
205 Post_Call : out List_Id);
206 -- Return a list of actions to take place after the call in Post_Call. The
207 -- call will later be rewritten as an Expression_With_Actions, with the
208 -- Post_Call actions inserted, and the call inside.
210 -- For each actual of an in-out or out parameter which is a numeric (view)
211 -- conversion of the form T (A), where A denotes a variable, we insert the
214 -- Temp : T[ := T (A)];
216 -- prior to the call. Then we replace the actual with a reference to Temp,
217 -- and append the assignment:
219 -- A := TypeA (Temp);
221 -- after the call. Here TypeA is the actual type of variable A. For out
222 -- parameters, the initial declaration has no expression. If A is not an
223 -- entity name, we generate instead:
225 -- Var : TypeA renames A;
226 -- Temp : T := Var; -- omitting expression for out parameter.
228 -- Var := TypeA (Temp);
230 -- For other in-out parameters, we emit the required constraint checks
231 -- before and/or after the call.
233 -- For all parameter modes, actuals that denote components and slices of
234 -- packed arrays are expanded into suitable temporaries.
236 -- For nonscalar objects that are possibly unaligned, add call by copy code
237 -- (copy in for IN and IN OUT, copy out for OUT and IN OUT).
239 -- For OUT and IN OUT parameters, add predicate checks after the call
240 -- based on the predicates of the actual type.
242 procedure Expand_Call_Helper (N : Node_Id; Post_Call : out List_Id);
243 -- Does the main work of Expand_Call. Post_Call is as for Expand_Actuals.
245 procedure Expand_Ctrl_Function_Call (N : Node_Id);
246 -- N is a function call which returns a controlled object. Transform the
247 -- call into a temporary which retrieves the returned object from the
248 -- secondary stack using 'reference.
250 procedure Expand_Non_Function_Return (N : Node_Id);
251 -- Expand a simple return statement found in a procedure body, entry body,
252 -- accept statement, or an extended return statement. Note that all non-
253 -- function returns are simple return statements.
255 function Expand_Protected_Object_Reference
257 Scop : Entity_Id) return Node_Id;
259 procedure Expand_Protected_Subprogram_Call
263 -- A call to a protected subprogram within the protected object may appear
264 -- as a regular call. The list of actuals must be expanded to contain a
265 -- reference to the object itself, and the call becomes a call to the
266 -- corresponding protected subprogram.
268 procedure Expand_Simple_Function_Return (N : Node_Id);
269 -- Expand simple return from function. In the case where we are returning
270 -- from a function body this is called by Expand_N_Simple_Return_Statement.
272 function Has_BIP_Extra_Formal
274 Kind : BIP_Formal_Kind) return Boolean;
275 -- Given a frozen subprogram, subprogram type, entry or entry family,
276 -- return True if E has the BIP extra formal associated with Kind. It must
277 -- be invoked with a frozen entity or a subprogram type of a dispatching
278 -- call since we can only rely on the availability of the extra formals
279 -- on these entities.
281 procedure Insert_Post_Call_Actions (N : Node_Id; Post_Call : List_Id);
282 -- Insert the Post_Call list previously produced by routine Expand_Actuals
283 -- or Expand_Call_Helper into the tree.
285 procedure Replace_Renaming_Declaration_Id
287 Orig_Decl : Node_Id);
288 -- Replace the internal identifier of the new renaming declaration New_Decl
289 -- with the identifier of its original declaration Orig_Decl exchanging the
290 -- entities containing their defining identifiers to ensure the correct
291 -- replacement of the object declaration by the object renaming declaration
292 -- to avoid homograph conflicts (since the object declaration's defining
293 -- identifier was already entered in the current scope). The Next_Entity
294 -- links of the two entities are also swapped since the entities are part
295 -- of the return scope's entity list and the list structure would otherwise
296 -- be corrupted. The homonym chain is preserved as well.
298 procedure Rewrite_Function_Call_For_C (N : Node_Id);
299 -- When generating C code, replace a call to a function that returns an
300 -- array into the generated procedure with an additional out parameter.
302 procedure Set_Enclosing_Sec_Stack_Return (N : Node_Id);
303 -- N is a return statement for a function that returns its result on the
304 -- secondary stack. This sets the Sec_Stack_Needed_For_Return flag on the
305 -- function and all blocks and loops that the return statement is jumping
306 -- out of. This ensures that the secondary stack is not released; otherwise
307 -- the function result would be reclaimed before returning to the caller.
309 procedure Warn_BIP (Func_Call : Node_Id);
310 -- Give a warning on a build-in-place function call if the -gnatd_B switch
313 ----------------------------------------------
314 -- Add_Access_Actual_To_Build_In_Place_Call --
315 ----------------------------------------------
317 procedure Add_Access_Actual_To_Build_In_Place_Call
318 (Function_Call : Node_Id;
319 Function_Id : Entity_Id;
320 Return_Object : Node_Id;
321 Is_Access : Boolean := False)
323 Loc : constant Source_Ptr := Sloc (Function_Call);
324 Obj_Address : Node_Id;
325 Obj_Acc_Formal : Entity_Id;
328 -- Locate the implicit access parameter in the called function
330 Obj_Acc_Formal := Build_In_Place_Formal (Function_Id, BIP_Object_Access);
332 -- If no return object is provided, then pass null
334 if not Present (Return_Object) then
335 Obj_Address := Make_Null (Loc);
336 Set_Parent (Obj_Address, Function_Call);
338 -- If Return_Object is already an expression of an access type, then use
339 -- it directly, since it must be an access value denoting the return
340 -- object, and couldn't possibly be the return object itself.
343 Obj_Address := Return_Object;
344 Set_Parent (Obj_Address, Function_Call);
346 -- Apply Unrestricted_Access to caller's return object
350 Make_Attribute_Reference (Loc,
351 Prefix => Return_Object,
352 Attribute_Name => Name_Unrestricted_Access);
354 Set_Parent (Return_Object, Obj_Address);
355 Set_Parent (Obj_Address, Function_Call);
358 Analyze_And_Resolve (Obj_Address, Etype (Obj_Acc_Formal));
360 -- Build the parameter association for the new actual and add it to the
361 -- end of the function's actuals.
363 Add_Extra_Actual_To_Call (Function_Call, Obj_Acc_Formal, Obj_Address);
364 end Add_Access_Actual_To_Build_In_Place_Call;
366 ------------------------------------------------------
367 -- Add_Unconstrained_Actuals_To_Build_In_Place_Call --
368 ------------------------------------------------------
370 procedure Add_Unconstrained_Actuals_To_Build_In_Place_Call
371 (Function_Call : Node_Id;
372 Function_Id : Entity_Id;
373 Alloc_Form : BIP_Allocation_Form := Unspecified;
374 Alloc_Form_Exp : Node_Id := Empty;
375 Pool_Actual : Node_Id := Make_Null (No_Location))
377 Loc : constant Source_Ptr := Sloc (Function_Call);
379 Alloc_Form_Actual : Node_Id;
380 Alloc_Form_Formal : Node_Id;
381 Pool_Formal : Node_Id;
384 -- Nothing to do when the size of the object is known, and the caller is
385 -- in charge of allocating it, and the callee doesn't unconditionally
386 -- require an allocation form (such as due to having a tagged result).
388 if not Needs_BIP_Alloc_Form (Function_Id) then
392 -- Locate the implicit allocation form parameter in the called function.
393 -- Maybe it would be better for each implicit formal of a build-in-place
394 -- function to have a flag or a Uint attribute to identify it. ???
396 Alloc_Form_Formal := Build_In_Place_Formal (Function_Id, BIP_Alloc_Form);
398 if Present (Alloc_Form_Exp) then
399 pragma Assert (Alloc_Form = Unspecified);
401 Alloc_Form_Actual := Alloc_Form_Exp;
404 pragma Assert (Alloc_Form /= Unspecified);
407 Make_Integer_Literal (Loc,
408 Intval => UI_From_Int (BIP_Allocation_Form'Pos (Alloc_Form)));
411 Analyze_And_Resolve (Alloc_Form_Actual, Etype (Alloc_Form_Formal));
413 -- Build the parameter association for the new actual and add it to the
414 -- end of the function's actuals.
416 Add_Extra_Actual_To_Call
417 (Function_Call, Alloc_Form_Formal, Alloc_Form_Actual);
419 -- Pass the Storage_Pool parameter. This parameter is omitted on ZFP as
420 -- those targets do not support pools.
422 if RTE_Available (RE_Root_Storage_Pool_Ptr) then
423 Pool_Formal := Build_In_Place_Formal (Function_Id, BIP_Storage_Pool);
424 Analyze_And_Resolve (Pool_Actual, Etype (Pool_Formal));
425 Add_Extra_Actual_To_Call
426 (Function_Call, Pool_Formal, Pool_Actual);
428 end Add_Unconstrained_Actuals_To_Build_In_Place_Call;
430 -----------------------------------------------------------
431 -- Add_Finalization_Master_Actual_To_Build_In_Place_Call --
432 -----------------------------------------------------------
434 procedure Add_Finalization_Master_Actual_To_Build_In_Place_Call
435 (Func_Call : Node_Id;
437 Ptr_Typ : Entity_Id := Empty;
438 Master_Exp : Node_Id := Empty)
441 if not Needs_BIP_Finalization_Master (Func_Id) then
446 Formal : constant Entity_Id :=
447 Build_In_Place_Formal (Func_Id, BIP_Finalization_Master);
448 Loc : constant Source_Ptr := Sloc (Func_Call);
451 Desig_Typ : Entity_Id;
454 -- If there is a finalization master actual, such as the implicit
455 -- finalization master of an enclosing build-in-place function,
456 -- then this must be added as an extra actual of the call.
458 if Present (Master_Exp) then
459 Actual := Master_Exp;
461 -- Case where the context does not require an actual master
463 elsif No (Ptr_Typ) then
464 Actual := Make_Null (Loc);
467 Desig_Typ := Directly_Designated_Type (Ptr_Typ);
469 -- Check for a library-level access type whose designated type has
470 -- suppressed finalization or the access type is subject to pragma
471 -- No_Heap_Finalization. Such an access type lacks a master. Pass
472 -- a null actual to callee in order to signal a missing master.
474 if Is_Library_Level_Entity (Ptr_Typ)
475 and then (Finalize_Storage_Only (Desig_Typ)
476 or else No_Heap_Finalization (Ptr_Typ))
478 Actual := Make_Null (Loc);
480 -- Types in need of finalization actions
482 elsif Needs_Finalization (Desig_Typ) then
484 -- The general mechanism of creating finalization masters for
485 -- anonymous access types is disabled by default, otherwise
486 -- finalization masters will pop all over the place. Such types
487 -- use context-specific masters.
489 if Ekind (Ptr_Typ) = E_Anonymous_Access_Type
490 and then No (Finalization_Master (Ptr_Typ))
492 Build_Anonymous_Master (Ptr_Typ);
495 -- Access-to-controlled types should always have a master
497 pragma Assert (Present (Finalization_Master (Ptr_Typ)));
500 Make_Attribute_Reference (Loc,
502 New_Occurrence_Of (Finalization_Master (Ptr_Typ), Loc),
503 Attribute_Name => Name_Unrestricted_Access);
508 Actual := Make_Null (Loc);
512 Analyze_And_Resolve (Actual, Etype (Formal));
514 -- Build the parameter association for the new actual and add it to
515 -- the end of the function's actuals.
517 Add_Extra_Actual_To_Call (Func_Call, Formal, Actual);
519 end Add_Finalization_Master_Actual_To_Build_In_Place_Call;
521 ------------------------------
522 -- Add_Extra_Actual_To_Call --
523 ------------------------------
525 procedure Add_Extra_Actual_To_Call
526 (Subprogram_Call : Node_Id;
527 Extra_Formal : Entity_Id;
528 Extra_Actual : Node_Id)
530 Loc : constant Source_Ptr := Sloc (Subprogram_Call);
531 Param_Assoc : Node_Id;
535 Make_Parameter_Association (Loc,
536 Selector_Name => New_Occurrence_Of (Extra_Formal, Loc),
537 Explicit_Actual_Parameter => Extra_Actual);
539 Set_Parent (Param_Assoc, Subprogram_Call);
540 Set_Parent (Extra_Actual, Param_Assoc);
542 if Present (Parameter_Associations (Subprogram_Call)) then
543 if Nkind (Last (Parameter_Associations (Subprogram_Call))) =
544 N_Parameter_Association
547 -- Find last named actual, and append
552 L := First_Actual (Subprogram_Call);
553 while Present (L) loop
554 if No (Next_Actual (L)) then
555 Set_Next_Named_Actual (Parent (L), Extra_Actual);
563 Set_First_Named_Actual (Subprogram_Call, Extra_Actual);
566 Append (Param_Assoc, To => Parameter_Associations (Subprogram_Call));
569 Set_Parameter_Associations (Subprogram_Call, New_List (Param_Assoc));
570 Set_First_Named_Actual (Subprogram_Call, Extra_Actual);
572 end Add_Extra_Actual_To_Call;
574 ---------------------------------------------
575 -- Add_Task_Actuals_To_Build_In_Place_Call --
576 ---------------------------------------------
578 procedure Add_Task_Actuals_To_Build_In_Place_Call
579 (Function_Call : Node_Id;
580 Function_Id : Entity_Id;
581 Master_Actual : Node_Id;
582 Chain : Node_Id := Empty)
584 Loc : constant Source_Ptr := Sloc (Function_Call);
586 Chain_Actual : Node_Id;
587 Chain_Formal : Node_Id;
588 Master_Formal : Node_Id;
591 -- No such extra parameters are needed if there are no tasks
593 if not Needs_BIP_Task_Actuals (Function_Id) then
597 Actual := Master_Actual;
599 -- Use a dummy _master actual in case of No_Task_Hierarchy
601 if Restriction_Active (No_Task_Hierarchy) then
602 Actual := New_Occurrence_Of (RTE (RE_Library_Task_Level), Loc);
604 -- In the case where we use the master associated with an access type,
605 -- the actual is an entity and requires an explicit reference.
607 elsif Nkind (Actual) = N_Defining_Identifier then
608 Actual := New_Occurrence_Of (Actual, Loc);
611 -- Locate the implicit master parameter in the called function
613 Master_Formal := Build_In_Place_Formal (Function_Id, BIP_Task_Master);
614 Analyze_And_Resolve (Actual, Etype (Master_Formal));
616 -- Build the parameter association for the new actual and add it to the
617 -- end of the function's actuals.
619 Add_Extra_Actual_To_Call (Function_Call, Master_Formal, Actual);
621 -- Locate the implicit activation chain parameter in the called function
624 Build_In_Place_Formal (Function_Id, BIP_Activation_Chain);
626 -- Create the actual which is a pointer to the current activation chain
630 Make_Attribute_Reference (Loc,
631 Prefix => Make_Identifier (Loc, Name_uChain),
632 Attribute_Name => Name_Unrestricted_Access);
634 -- Allocator case; make a reference to the Chain passed in by the caller
638 Make_Attribute_Reference (Loc,
639 Prefix => New_Occurrence_Of (Chain, Loc),
640 Attribute_Name => Name_Unrestricted_Access);
643 Analyze_And_Resolve (Chain_Actual, Etype (Chain_Formal));
645 -- Build the parameter association for the new actual and add it to the
646 -- end of the function's actuals.
648 Add_Extra_Actual_To_Call (Function_Call, Chain_Formal, Chain_Actual);
649 end Add_Task_Actuals_To_Build_In_Place_Call;
651 ----------------------------------
652 -- Apply_CW_Accessibility_Check --
653 ----------------------------------
655 procedure Apply_CW_Accessibility_Check (Exp : Node_Id; Func : Entity_Id) is
656 Loc : constant Source_Ptr := Sloc (Exp);
659 if Ada_Version >= Ada_2005
660 and then Tagged_Type_Expansion
661 and then not Scope_Suppress.Suppress (Accessibility_Check)
663 (Is_Class_Wide_Type (Etype (Exp))
664 or else Nkind (Exp) in
665 N_Type_Conversion | N_Unchecked_Type_Conversion
666 or else (Is_Entity_Name (Exp)
667 and then Is_Formal (Entity (Exp)))
668 or else Scope_Depth (Enclosing_Dynamic_Scope (Etype (Exp))) >
669 Scope_Depth (Enclosing_Dynamic_Scope (Func)))
675 -- Ada 2005 (AI-251): In class-wide interface objects we displace
676 -- "this" to reference the base of the object. This is required to
677 -- get access to the TSD of the object.
679 if Is_Class_Wide_Type (Etype (Exp))
680 and then Is_Interface (Etype (Exp))
682 -- If the expression is an explicit dereference then we can
683 -- directly displace the pointer to reference the base of
686 if Nkind (Exp) = N_Explicit_Dereference then
688 Make_Explicit_Dereference (Loc,
690 Unchecked_Convert_To (RTE (RE_Tag_Ptr),
691 Make_Function_Call (Loc,
693 New_Occurrence_Of (RTE (RE_Base_Address), Loc),
694 Parameter_Associations => New_List (
695 Unchecked_Convert_To (RTE (RE_Address),
696 Duplicate_Subexpr (Prefix (Exp)))))));
698 -- Similar case to the previous one but the expression is a
699 -- renaming of an explicit dereference.
701 elsif Nkind (Exp) = N_Identifier
702 and then Present (Renamed_Object (Entity (Exp)))
703 and then Nkind (Renamed_Object (Entity (Exp)))
704 = N_Explicit_Dereference
707 Make_Explicit_Dereference (Loc,
709 Unchecked_Convert_To (RTE (RE_Tag_Ptr),
710 Make_Function_Call (Loc,
712 New_Occurrence_Of (RTE (RE_Base_Address), Loc),
713 Parameter_Associations => New_List (
714 Unchecked_Convert_To (RTE (RE_Address),
717 (Renamed_Object (Entity (Exp)))))))));
719 -- Common case: obtain the address of the actual object and
720 -- displace the pointer to reference the base of the object.
724 Make_Explicit_Dereference (Loc,
726 Unchecked_Convert_To (RTE (RE_Tag_Ptr),
727 Make_Function_Call (Loc,
729 New_Occurrence_Of (RTE (RE_Base_Address), Loc),
730 Parameter_Associations => New_List (
731 Make_Attribute_Reference (Loc,
732 Prefix => Duplicate_Subexpr (Exp),
733 Attribute_Name => Name_Address)))));
737 Make_Attribute_Reference (Loc,
738 Prefix => Duplicate_Subexpr (Exp),
739 Attribute_Name => Name_Tag);
742 -- CodePeer does not do anything useful with
743 -- Ada.Tags.Type_Specific_Data components.
745 if not CodePeer_Mode then
747 Make_Raise_Program_Error (Loc,
750 Left_Opnd => Build_Get_Access_Level (Loc, Tag_Node),
752 Make_Integer_Literal (Loc,
753 Scope_Depth (Enclosing_Dynamic_Scope (Func)))),
754 Reason => PE_Accessibility_Check_Failed));
758 end Apply_CW_Accessibility_Check;
760 -----------------------
761 -- BIP_Formal_Suffix --
762 -----------------------
764 function BIP_Formal_Suffix (Kind : BIP_Formal_Kind) return String is
767 when BIP_Alloc_Form =>
768 return BIP_Alloc_Suffix;
770 when BIP_Storage_Pool =>
771 return BIP_Storage_Pool_Suffix;
773 when BIP_Finalization_Master =>
774 return BIP_Finalization_Master_Suffix;
776 when BIP_Task_Master =>
777 return BIP_Task_Master_Suffix;
779 when BIP_Activation_Chain =>
780 return BIP_Activation_Chain_Suffix;
782 when BIP_Object_Access =>
783 return BIP_Object_Access_Suffix;
785 end BIP_Formal_Suffix;
787 ---------------------
788 -- BIP_Suffix_Kind --
789 ---------------------
791 function BIP_Suffix_Kind (E : Entity_Id) return BIP_Formal_Kind is
792 Nam : constant String := Get_Name_String (Chars (E));
794 function Has_Suffix (Suffix : String) return Boolean;
795 -- Return True if Nam has suffix Suffix
797 function Has_Suffix (Suffix : String) return Boolean is
798 Len : constant Natural := Suffix'Length;
800 return Nam'Length > Len
801 and then Nam (Nam'Last - Len + 1 .. Nam'Last) = Suffix;
804 -- Start of processing for BIP_Suffix_Kind
807 if Has_Suffix (BIP_Alloc_Suffix) then
808 return BIP_Alloc_Form;
810 elsif Has_Suffix (BIP_Storage_Pool_Suffix) then
811 return BIP_Storage_Pool;
813 elsif Has_Suffix (BIP_Finalization_Master_Suffix) then
814 return BIP_Finalization_Master;
816 elsif Has_Suffix (BIP_Task_Master_Suffix) then
817 return BIP_Task_Master;
819 elsif Has_Suffix (BIP_Activation_Chain_Suffix) then
820 return BIP_Activation_Chain;
822 elsif Has_Suffix (BIP_Object_Access_Suffix) then
823 return BIP_Object_Access;
830 ---------------------------
831 -- Build_In_Place_Formal --
832 ---------------------------
834 function Build_In_Place_Formal
836 Kind : BIP_Formal_Kind) return Entity_Id
838 Extra_Formal : Entity_Id := Extra_Formals (Func);
839 Formal_Suffix : constant String := BIP_Formal_Suffix (Kind);
842 -- Maybe it would be better for each implicit formal of a build-in-place
843 -- function to have a flag or a Uint attribute to identify it. ???
845 -- The return type in the function declaration may have been a limited
846 -- view, and the extra formals for the function were not generated at
847 -- that point. At the point of call the full view must be available and
848 -- the extra formals can be created.
850 if No (Extra_Formal) then
851 Create_Extra_Formals (Func);
852 Extra_Formal := Extra_Formals (Func);
855 -- We search for a formal with a matching suffix. We can't search
856 -- for the full name, because of the code at the end of Sem_Ch6.-
857 -- Create_Extra_Formals, which copies the Extra_Formals over to
858 -- the Alias of an instance, which will cause the formals to have
859 -- "incorrect" names.
862 pragma Assert (Present (Extra_Formal));
864 Name : constant String := Get_Name_String (Chars (Extra_Formal));
866 exit when Name'Length >= Formal_Suffix'Length
867 and then Formal_Suffix =
868 Name (Name'Last - Formal_Suffix'Length + 1 .. Name'Last);
871 Next_Formal_With_Extras (Extra_Formal);
875 end Build_In_Place_Formal;
877 -------------------------------
878 -- Build_Procedure_Body_Form --
879 -------------------------------
881 function Build_Procedure_Body_Form
882 (Func_Id : Entity_Id;
883 Func_Body : Node_Id) return Node_Id
885 Loc : constant Source_Ptr := Sloc (Func_Body);
887 Proc_Decl : constant Node_Id :=
888 Next (Unit_Declaration_Node (Func_Id));
889 -- It is assumed that the next node following the declaration of the
890 -- corresponding subprogram spec is the declaration of the procedure
893 Proc_Id : constant Entity_Id := Defining_Entity (Proc_Decl);
895 procedure Replace_Returns (Param_Id : Entity_Id; Stmts : List_Id);
896 -- Replace each return statement found in the list Stmts with an
897 -- assignment of the return expression to parameter Param_Id.
899 ---------------------
900 -- Replace_Returns --
901 ---------------------
903 procedure Replace_Returns (Param_Id : Entity_Id; Stmts : List_Id) is
907 Stmt := First (Stmts);
908 while Present (Stmt) loop
909 if Nkind (Stmt) = N_Block_Statement then
910 Replace_Returns (Param_Id,
911 Statements (Handled_Statement_Sequence (Stmt)));
913 elsif Nkind (Stmt) = N_Case_Statement then
917 Alt := First (Alternatives (Stmt));
918 while Present (Alt) loop
919 Replace_Returns (Param_Id, Statements (Alt));
924 elsif Nkind (Stmt) = N_Extended_Return_Statement then
926 Ret_Obj : constant Entity_Id :=
928 (First (Return_Object_Declarations (Stmt)));
929 Assign : constant Node_Id :=
930 Make_Assignment_Statement (Sloc (Stmt),
932 New_Occurrence_Of (Param_Id, Loc),
934 New_Occurrence_Of (Ret_Obj, Sloc (Stmt)));
938 -- The extended return may just contain the declaration
940 if Present (Handled_Statement_Sequence (Stmt)) then
941 Stmts := Statements (Handled_Statement_Sequence (Stmt));
946 Set_Assignment_OK (Name (Assign));
949 Make_Block_Statement (Sloc (Stmt),
951 Return_Object_Declarations (Stmt),
952 Handled_Statement_Sequence =>
953 Make_Handled_Sequence_Of_Statements (Loc,
954 Statements => Stmts)));
956 Replace_Returns (Param_Id, Stmts);
958 Append_To (Stmts, Assign);
959 Append_To (Stmts, Make_Simple_Return_Statement (Loc));
962 elsif Nkind (Stmt) = N_If_Statement then
963 Replace_Returns (Param_Id, Then_Statements (Stmt));
964 Replace_Returns (Param_Id, Else_Statements (Stmt));
969 Part := First (Elsif_Parts (Stmt));
970 while Present (Part) loop
971 Replace_Returns (Param_Id, Then_Statements (Part));
976 elsif Nkind (Stmt) = N_Loop_Statement then
977 Replace_Returns (Param_Id, Statements (Stmt));
979 elsif Nkind (Stmt) = N_Simple_Return_Statement then
986 Make_Assignment_Statement (Sloc (Stmt),
987 Name => New_Occurrence_Of (Param_Id, Loc),
988 Expression => Relocate_Node (Expression (Stmt))));
990 Insert_After (Stmt, Make_Simple_Return_Statement (Loc));
992 -- Skip the added return
1006 -- Start of processing for Build_Procedure_Body_Form
1009 -- This routine replaces the original function body:
1011 -- function F (...) return Array_Typ is
1014 -- return Something;
1017 -- with the following:
1019 -- procedure P (..., Result : out Array_Typ) is
1022 -- Result := Something;
1026 Statements (Handled_Statement_Sequence (Func_Body));
1027 Replace_Returns (Last_Entity (Proc_Id), Stmts);
1030 Make_Subprogram_Body (Loc,
1032 Copy_Subprogram_Spec (Specification (Proc_Decl)),
1033 Declarations => Declarations (Func_Body),
1034 Handled_Statement_Sequence =>
1035 Make_Handled_Sequence_Of_Statements (Loc,
1036 Statements => Stmts));
1038 -- If the function is a generic instance, so is the new procedure.
1039 -- Set flag accordingly so that the proper renaming declarations are
1042 Set_Is_Generic_Instance (Proc_Id, Is_Generic_Instance (Func_Id));
1044 end Build_Procedure_Body_Form;
1046 -----------------------
1047 -- Caller_Known_Size --
1048 -----------------------
1050 function Caller_Known_Size
1051 (Func_Call : Node_Id;
1052 Result_Subt : Entity_Id) return Boolean
1056 (Is_Definite_Subtype (Underlying_Type (Result_Subt))
1057 and then No (Controlling_Argument (Func_Call)))
1058 or else not Requires_Transient_Scope (Underlying_Type (Result_Subt));
1059 end Caller_Known_Size;
1061 -----------------------
1062 -- Check_BIP_Actuals --
1063 -----------------------
1065 function Check_BIP_Actuals
1066 (Subp_Call : Node_Id;
1067 Subp_Id : Entity_Id) return Boolean
1073 pragma Assert (Nkind (Subp_Call) in N_Entry_Call_Statement
1075 | N_Procedure_Call_Statement);
1077 Formal := First_Formal_With_Extras (Subp_Id);
1078 Actual := First_Actual (Subp_Call);
1080 while Present (Formal) and then Present (Actual) loop
1081 if Is_Build_In_Place_Entity (Formal)
1082 and then Nkind (Actual) = N_Identifier
1083 and then Is_Build_In_Place_Entity (Entity (Actual))
1084 and then BIP_Suffix_Kind (Formal)
1085 /= BIP_Suffix_Kind (Entity (Actual))
1090 Next_Formal_With_Extras (Formal);
1091 Next_Actual (Actual);
1094 return No (Formal) and then No (Actual);
1095 end Check_BIP_Actuals;
1097 -----------------------------
1098 -- Check_Number_Of_Actuals --
1099 -----------------------------
1101 function Check_Number_Of_Actuals
1102 (Subp_Call : Node_Id;
1103 Subp_Id : Entity_Id) return Boolean
1109 pragma Assert (Nkind (Subp_Call) in N_Entry_Call_Statement
1111 | N_Procedure_Call_Statement);
1113 Formal := First_Formal_With_Extras (Subp_Id);
1114 Actual := First_Actual (Subp_Call);
1116 while Present (Formal) and then Present (Actual) loop
1117 Next_Formal_With_Extras (Formal);
1118 Next_Actual (Actual);
1121 return No (Formal) and then No (Actual);
1122 end Check_Number_Of_Actuals;
1124 --------------------------------
1125 -- Check_Overriding_Operation --
1126 --------------------------------
1128 procedure Check_Overriding_Operation (Subp : Entity_Id) is
1129 Typ : constant Entity_Id := Find_Dispatching_Type (Subp);
1130 Op_List : constant Elist_Id := Primitive_Operations (Typ);
1132 Prim_Op : Entity_Id;
1136 if Is_Derived_Type (Typ)
1137 and then not Is_Private_Type (Typ)
1138 and then In_Open_Scopes (Scope (Etype (Typ)))
1139 and then Is_Base_Type (Typ)
1141 -- Subp overrides an inherited private operation if there is an
1142 -- inherited operation with a different name than Subp (see
1143 -- Derive_Subprogram) whose Alias is a hidden subprogram with the
1144 -- same name as Subp.
1146 Op_Elmt := First_Elmt (Op_List);
1147 while Present (Op_Elmt) loop
1148 Prim_Op := Node (Op_Elmt);
1149 Par_Op := Alias (Prim_Op);
1152 and then not Comes_From_Source (Prim_Op)
1153 and then Chars (Prim_Op) /= Chars (Par_Op)
1154 and then Chars (Par_Op) = Chars (Subp)
1155 and then Is_Hidden (Par_Op)
1156 and then Type_Conformant (Prim_Op, Subp)
1158 Set_DT_Position_Value (Subp, DT_Position (Prim_Op));
1161 Next_Elmt (Op_Elmt);
1164 end Check_Overriding_Operation;
1166 -------------------------------
1167 -- Detect_Infinite_Recursion --
1168 -------------------------------
1170 procedure Detect_Infinite_Recursion (N : Node_Id; Spec : Entity_Id) is
1171 Loc : constant Source_Ptr := Sloc (N);
1173 Var_List : constant Elist_Id := New_Elmt_List;
1174 -- List of globals referenced by body of procedure
1176 Call_List : constant Elist_Id := New_Elmt_List;
1177 -- List of recursive calls in body of procedure
1179 Shad_List : constant Elist_Id := New_Elmt_List;
1180 -- List of entity id's for entities created to capture the value of
1181 -- referenced globals on entry to the procedure.
1183 Scop : constant Uint := Scope_Depth (Spec);
1184 -- This is used to record the scope depth of the current procedure, so
1185 -- that we can identify global references.
1187 Max_Vars : constant := 4;
1188 -- Do not test more than four global variables
1190 Count_Vars : Natural := 0;
1191 -- Count variables found so far
1203 function Process (Nod : Node_Id) return Traverse_Result;
1204 -- Function to traverse the subprogram body (using Traverse_Func)
1210 function Process (Nod : Node_Id) return Traverse_Result is
1214 if Nkind (Nod) = N_Procedure_Call_Statement then
1216 -- Case of one of the detected recursive calls
1218 if Is_Entity_Name (Name (Nod))
1219 and then Has_Recursive_Call (Entity (Name (Nod)))
1220 and then Entity (Name (Nod)) = Spec
1222 Append_Elmt (Nod, Call_List);
1225 -- Any other procedure call may have side effects
1231 -- A call to a pure function can always be ignored
1233 elsif Nkind (Nod) = N_Function_Call
1234 and then Is_Entity_Name (Name (Nod))
1235 and then Is_Pure (Entity (Name (Nod)))
1239 -- Case of an identifier reference
1241 elsif Nkind (Nod) = N_Identifier then
1242 Ent := Entity (Nod);
1244 -- If no entity, then ignore the reference
1246 -- Not clear why this can happen. To investigate, remove this
1247 -- test and look at the crash that occurs here in 3401-004 ???
1252 -- Ignore entities with no Scope, again not clear how this
1253 -- can happen, to investigate, look at 4108-008 ???
1255 elsif No (Scope (Ent)) then
1258 -- Ignore the reference if not to a more global object
1260 elsif Scope_Depth (Scope (Ent)) >= Scop then
1263 -- References to types, exceptions and constants are always OK
1266 or else Ekind (Ent) = E_Exception
1267 or else Ekind (Ent) = E_Constant
1271 -- If other than a non-volatile scalar variable, we have some
1272 -- kind of global reference (e.g. to a function) that we cannot
1273 -- deal with so we forget the attempt.
1275 elsif Ekind (Ent) /= E_Variable
1276 or else not Is_Scalar_Type (Etype (Ent))
1277 or else Treat_As_Volatile (Ent)
1281 -- Otherwise we have a reference to a global scalar
1284 -- Loop through global entities already detected
1286 Elm := First_Elmt (Var_List);
1288 -- If not detected before, record this new global reference
1291 Count_Vars := Count_Vars + 1;
1293 if Count_Vars <= Max_Vars then
1294 Append_Elmt (Entity (Nod), Var_List);
1301 -- If recorded before, ignore
1303 elsif Node (Elm) = Entity (Nod) then
1306 -- Otherwise keep looking
1316 -- For all other node kinds, recursively visit syntactic children
1323 function Traverse_Body is new Traverse_Func (Process);
1325 -- Start of processing for Detect_Infinite_Recursion
1328 -- Do not attempt detection in No_Implicit_Conditional mode, since we
1329 -- won't be able to generate the code to handle the recursion in any
1332 if Restriction_Active (No_Implicit_Conditionals) then
1336 -- Otherwise do traversal and quit if we get abandon signal
1338 if Traverse_Body (N) = Abandon then
1341 -- We must have a call, since Has_Recursive_Call was set. If not just
1342 -- ignore (this is only an error check, so if we have a funny situation,
1343 -- due to bugs or errors, we do not want to bomb).
1345 elsif Is_Empty_Elmt_List (Call_List) then
1349 -- Here is the case where we detect recursion at compile time
1351 -- Push our current scope for analyzing the declarations and code that
1352 -- we will insert for the checking.
1356 -- This loop builds temporary variables for each of the referenced
1357 -- globals, so that at the end of the loop the list Shad_List contains
1358 -- these temporaries in one-to-one correspondence with the elements in
1362 Elm := First_Elmt (Var_List);
1363 while Present (Elm) loop
1365 Ent := Make_Temporary (Loc, 'S');
1366 Append_Elmt (Ent, Shad_List);
1368 -- Insert a declaration for this temporary at the start of the
1369 -- declarations for the procedure. The temporaries are declared as
1370 -- constant objects initialized to the current values of the
1371 -- corresponding temporaries.
1374 Make_Object_Declaration (Loc,
1375 Defining_Identifier => Ent,
1376 Object_Definition => New_Occurrence_Of (Etype (Var), Loc),
1377 Constant_Present => True,
1378 Expression => New_Occurrence_Of (Var, Loc));
1381 Prepend (Decl, Declarations (N));
1383 Insert_After (Last, Decl);
1391 -- Loop through calls
1393 Call := First_Elmt (Call_List);
1394 while Present (Call) loop
1396 -- Build a predicate expression of the form
1399 -- and then global1 = temp1
1400 -- and then global2 = temp2
1403 -- This predicate determines if any of the global values
1404 -- referenced by the procedure have changed since the
1405 -- current call, if not an infinite recursion is assured.
1407 Test := New_Occurrence_Of (Standard_True, Loc);
1409 Elm1 := First_Elmt (Var_List);
1410 Elm2 := First_Elmt (Shad_List);
1411 while Present (Elm1) loop
1417 Left_Opnd => New_Occurrence_Of (Node (Elm1), Loc),
1418 Right_Opnd => New_Occurrence_Of (Node (Elm2), Loc)));
1424 -- Now we replace the call with the sequence
1426 -- if no-changes (see above) then
1427 -- raise Storage_Error;
1432 Rewrite (Node (Call),
1433 Make_If_Statement (Loc,
1435 Then_Statements => New_List (
1436 Make_Raise_Storage_Error (Loc,
1437 Reason => SE_Infinite_Recursion)),
1439 Else_Statements => New_List (
1440 Relocate_Node (Node (Call)))));
1442 Analyze (Node (Call));
1447 -- Remove temporary scope stack entry used for analysis
1450 end Detect_Infinite_Recursion;
1452 --------------------
1453 -- Expand_Actuals --
1454 --------------------
1456 procedure Expand_Actuals
1459 Post_Call : out List_Id)
1461 Loc : constant Source_Ptr := Sloc (N);
1465 E_Actual : Entity_Id;
1466 E_Formal : Entity_Id;
1468 procedure Add_Call_By_Copy_Code;
1469 -- For cases where the parameter must be passed by copy, this routine
1470 -- generates a temporary variable into which the actual is copied and
1471 -- then passes this as the parameter. For an OUT or IN OUT parameter,
1472 -- an assignment is also generated to copy the result back. The call
1473 -- also takes care of any constraint checks required for the type
1474 -- conversion case (on both the way in and the way out).
1476 procedure Add_Simple_Call_By_Copy_Code (Force : Boolean);
1477 -- This is similar to the above, but is used in cases where we know
1478 -- that all that is needed is to simply create a temporary and copy
1479 -- the value in and out of the temporary. If Force is True, then the
1480 -- procedure may disregard legality considerations.
1482 -- ??? We need to do the copy for a bit-packed array because this is
1483 -- where the rewriting into a mask-and-shift sequence is done. But of
1484 -- course this may break the program if it expects bits to be really
1485 -- passed by reference. That's what we have done historically though.
1487 procedure Add_Validation_Call_By_Copy_Code (Act : Node_Id);
1488 -- Perform copy-back for actual parameter Act which denotes a validation
1491 procedure Check_Fortran_Logical;
1492 -- A value of type Logical that is passed through a formal parameter
1493 -- must be normalized because .TRUE. usually does not have the same
1494 -- representation as True. We assume that .FALSE. = False = 0.
1495 -- What about functions that return a logical type ???
1497 function Is_Legal_Copy return Boolean;
1498 -- Check that an actual can be copied before generating the temporary
1499 -- to be used in the call. If the formal is of a by_reference type or
1500 -- is aliased, then the program is illegal (this can only happen in
1501 -- the presence of representation clauses that force a misalignment)
1502 -- If the formal is a by_reference parameter imposed by a DEC pragma,
1503 -- emit a warning that this might lead to unaligned arguments.
1505 function Make_Var (Actual : Node_Id) return Entity_Id;
1506 -- Returns an entity that refers to the given actual parameter, Actual
1507 -- (not including any type conversion). If Actual is an entity name,
1508 -- then this entity is returned unchanged, otherwise a renaming is
1509 -- created to provide an entity for the actual.
1511 procedure Reset_Packed_Prefix;
1512 -- The expansion of a packed array component reference is delayed in
1513 -- the context of a call. Now we need to complete the expansion, so we
1514 -- unmark the analyzed bits in all prefixes.
1516 function Requires_Atomic_Or_Volatile_Copy return Boolean;
1517 -- Returns whether a copy is required as per RM C.6(19) and gives a
1518 -- warning in this case.
1520 ---------------------------
1521 -- Add_Call_By_Copy_Code --
1522 ---------------------------
1524 procedure Add_Call_By_Copy_Code is
1527 F_Typ : Entity_Id := Etype (Formal);
1535 if not Is_Legal_Copy then
1539 Temp := Make_Temporary (Loc, 'T', Actual);
1541 -- Handle formals whose type comes from the limited view
1543 if From_Limited_With (F_Typ)
1544 and then Has_Non_Limited_View (F_Typ)
1546 F_Typ := Non_Limited_View (F_Typ);
1549 -- Use formal type for temp, unless formal type is an unconstrained
1550 -- array, in which case we don't have to worry about bounds checks,
1551 -- and we use the actual type, since that has appropriate bounds.
1553 if Is_Array_Type (F_Typ) and then not Is_Constrained (F_Typ) then
1554 Indic := New_Occurrence_Of (Etype (Actual), Loc);
1556 Indic := New_Occurrence_Of (F_Typ, Loc);
1559 -- The new code will be properly analyzed below and the setting of
1560 -- the Do_Range_Check flag recomputed so remove the obsolete one.
1562 Set_Do_Range_Check (Actual, False);
1564 if Nkind (Actual) = N_Type_Conversion then
1565 Set_Do_Range_Check (Expression (Actual), False);
1567 V_Typ := Etype (Expression (Actual));
1569 -- If the formal is an (in-)out parameter, capture the name
1570 -- of the variable in order to build the post-call assignment.
1572 Var := Make_Var (Expression (Actual));
1574 Crep := not Has_Compatible_Representation
1575 (Target_Type => F_Typ,
1576 Operand_Type => Etype (Expression (Actual)));
1579 V_Typ := Etype (Actual);
1580 Var := Make_Var (Actual);
1584 -- Setup initialization for case of in out parameter, or an out
1585 -- parameter where the formal is an unconstrained array (in the
1586 -- latter case, we have to pass in an object with bounds).
1588 -- If this is an out parameter, the initial copy is wasteful, so as
1589 -- an optimization for the one-dimensional case we extract the
1590 -- bounds of the actual and build an uninitialized temporary of the
1593 -- If the formal is an out parameter with discriminants, the
1594 -- discriminants must be captured even if the rest of the object
1595 -- is in principle uninitialized, because the discriminants may
1596 -- be read by the called subprogram.
1598 if Ekind (Formal) = E_In_Out_Parameter
1599 or else (Is_Array_Type (F_Typ) and then not Is_Constrained (F_Typ))
1600 or else Has_Discriminants (F_Typ)
1602 if Nkind (Actual) = N_Type_Conversion then
1603 if Conversion_OK (Actual) then
1604 Init := OK_Convert_To (F_Typ, New_Occurrence_Of (Var, Loc));
1606 Init := Convert_To (F_Typ, New_Occurrence_Of (Var, Loc));
1609 elsif Ekind (Formal) = E_Out_Parameter
1610 and then Is_Array_Type (F_Typ)
1611 and then Number_Dimensions (F_Typ) = 1
1612 and then not Has_Non_Null_Base_Init_Proc (F_Typ)
1614 -- Actual is a one-dimensional array or slice, and the type
1615 -- requires no initialization. Create a temporary of the
1616 -- right size, but do not copy actual into it (optimization).
1620 Make_Subtype_Indication (Loc,
1621 Subtype_Mark => New_Occurrence_Of (F_Typ, Loc),
1623 Make_Index_Or_Discriminant_Constraint (Loc,
1624 Constraints => New_List (
1627 Make_Attribute_Reference (Loc,
1628 Prefix => New_Occurrence_Of (Var, Loc),
1629 Attribute_Name => Name_First),
1631 Make_Attribute_Reference (Loc,
1632 Prefix => New_Occurrence_Of (Var, Loc),
1633 Attribute_Name => Name_Last)))));
1636 Init := New_Occurrence_Of (Var, Loc);
1639 -- An initialization is created for packed conversions as
1640 -- actuals for out parameters to enable Make_Object_Declaration
1641 -- to determine the proper subtype for N_Node. Note that this
1642 -- is wasteful because the extra copying on the call side is
1643 -- not required for such out parameters. ???
1645 elsif Ekind (Formal) = E_Out_Parameter
1646 and then Nkind (Actual) = N_Type_Conversion
1647 and then (Is_Bit_Packed_Array (F_Typ)
1649 Is_Bit_Packed_Array (Etype (Expression (Actual))))
1651 if Conversion_OK (Actual) then
1652 Init := OK_Convert_To (F_Typ, New_Occurrence_Of (Var, Loc));
1654 Init := Convert_To (F_Typ, New_Occurrence_Of (Var, Loc));
1657 elsif Ekind (Formal) = E_In_Parameter then
1659 -- Handle the case in which the actual is a type conversion
1661 if Nkind (Actual) = N_Type_Conversion then
1662 if Conversion_OK (Actual) then
1663 Init := OK_Convert_To (F_Typ, New_Occurrence_Of (Var, Loc));
1665 Init := Convert_To (F_Typ, New_Occurrence_Of (Var, Loc));
1668 Init := New_Occurrence_Of (Var, Loc);
1671 -- Access types are passed in without checks, but if a copy-back is
1672 -- required for a null-excluding check on an in-out or out parameter,
1673 -- then the initial value is that of the actual.
1675 elsif Is_Access_Type (E_Formal)
1676 and then Can_Never_Be_Null (Etype (Actual))
1677 and then not Can_Never_Be_Null (E_Formal)
1679 Init := New_Occurrence_Of (Var, Loc);
1681 -- View conversions when the formal type has the Default_Value aspect
1682 -- require passing in the value of the conversion's operand. The type
1683 -- of that operand also has Default_Value, as required by AI12-0074
1684 -- (RM 6.4.1(5.3/4)). The subtype denoted by the subtype_indication
1685 -- is changed to the base type of the formal subtype, to ensure that
1686 -- the actual's value can be assigned without a constraint check
1687 -- (note that no check is done on passing to an out parameter). Also
1688 -- note that the two types necessarily share the same ancestor type,
1689 -- as required by 6.4.1(5.2/4), so underlying base types will match.
1691 elsif Ekind (Formal) = E_Out_Parameter
1692 and then Is_Scalar_Type (Etype (F_Typ))
1693 and then Nkind (Actual) = N_Type_Conversion
1694 and then Present (Default_Aspect_Value (Etype (F_Typ)))
1696 Indic := New_Occurrence_Of (Base_Type (F_Typ), Loc);
1698 (Base_Type (F_Typ), New_Occurrence_Of (Var, Loc));
1705 Make_Object_Declaration (Loc,
1706 Defining_Identifier => Temp,
1707 Object_Definition => Indic,
1708 Expression => Init);
1709 Set_Assignment_OK (N_Node);
1710 Insert_Action (N, N_Node);
1712 -- Now, normally the deal here is that we use the defining
1713 -- identifier created by that object declaration. There is
1714 -- one exception to this. In the change of representation case
1715 -- the above declaration will end up looking like:
1717 -- temp : type := identifier;
1719 -- And in this case we might as well use the identifier directly
1720 -- and eliminate the temporary. Note that the analysis of the
1721 -- declaration was not a waste of time in that case, since it is
1722 -- what generated the necessary change of representation code. If
1723 -- the change of representation introduced additional code, as in
1724 -- a fixed-integer conversion, the expression is not an identifier
1725 -- and must be kept.
1728 and then Present (Expression (N_Node))
1729 and then Is_Entity_Name (Expression (N_Node))
1731 Temp := Entity (Expression (N_Node));
1732 Rewrite (N_Node, Make_Null_Statement (Loc));
1735 -- For IN parameter, all we do is to replace the actual
1737 if Ekind (Formal) = E_In_Parameter then
1738 Rewrite (Actual, New_Occurrence_Of (Temp, Loc));
1741 -- Processing for OUT or IN OUT parameter
1744 -- Kill current value indications for the temporary variable we
1745 -- created, since we just passed it as an OUT parameter.
1747 Kill_Current_Values (Temp);
1748 Set_Is_Known_Valid (Temp, False);
1749 Set_Is_True_Constant (Temp, False);
1751 -- If type conversion, use reverse conversion on exit
1753 if Nkind (Actual) = N_Type_Conversion then
1754 if Conversion_OK (Actual) then
1755 Expr := OK_Convert_To (V_Typ, New_Occurrence_Of (Temp, Loc));
1757 Expr := Convert_To (V_Typ, New_Occurrence_Of (Temp, Loc));
1760 Expr := New_Occurrence_Of (Temp, Loc);
1763 Rewrite (Actual, New_Occurrence_Of (Temp, Loc));
1766 -- If the actual is a conversion of a packed reference, it may
1767 -- already have been expanded by Remove_Side_Effects, and the
1768 -- resulting variable is a temporary which does not designate
1769 -- the proper out-parameter, which may not be addressable. In
1770 -- that case, generate an assignment to the original expression
1771 -- (before expansion of the packed reference) so that the proper
1772 -- expansion of assignment to a packed component can take place.
1779 if Is_Renaming_Of_Object (Var)
1780 and then Nkind (Renamed_Object (Var)) = N_Selected_Component
1781 and then Nkind (Original_Node (Prefix (Renamed_Object (Var))))
1782 = N_Indexed_Component
1784 Has_Non_Standard_Rep (Etype (Prefix (Renamed_Object (Var))))
1786 Obj := Renamed_Object (Var);
1788 Make_Selected_Component (Loc,
1790 New_Copy_Tree (Original_Node (Prefix (Obj))),
1791 Selector_Name => New_Copy (Selector_Name (Obj)));
1792 Reset_Analyzed_Flags (Lhs);
1795 Lhs := New_Occurrence_Of (Var, Loc);
1798 Set_Assignment_OK (Lhs);
1800 if Is_Access_Type (E_Formal)
1801 and then Is_Entity_Name (Lhs)
1803 Present (Effective_Extra_Accessibility (Entity (Lhs)))
1805 -- Copyback target is an Ada 2012 stand-alone object of an
1806 -- anonymous access type.
1808 pragma Assert (Ada_Version >= Ada_2012);
1810 if Type_Access_Level (E_Formal) >
1811 Object_Access_Level (Lhs)
1813 Append_To (Post_Call,
1814 Make_Raise_Program_Error (Loc,
1815 Reason => PE_Accessibility_Check_Failed));
1818 Append_To (Post_Call,
1819 Make_Assignment_Statement (Loc,
1821 Expression => Expr));
1823 -- We would like to somehow suppress generation of the
1824 -- extra_accessibility assignment generated by the expansion
1825 -- of the above assignment statement. It's not a correctness
1826 -- issue because the following assignment renders it dead,
1827 -- but generating back-to-back assignments to the same
1828 -- target is undesirable. ???
1830 Append_To (Post_Call,
1831 Make_Assignment_Statement (Loc,
1832 Name => New_Occurrence_Of (
1833 Effective_Extra_Accessibility (Entity (Lhs)), Loc),
1834 Expression => Make_Integer_Literal (Loc,
1835 Type_Access_Level (E_Formal))));
1838 if Is_Access_Type (E_Formal)
1839 and then Can_Never_Be_Null (Etype (Actual))
1840 and then not Can_Never_Be_Null (E_Formal)
1842 Append_To (Post_Call,
1843 Make_Raise_Constraint_Error (Loc,
1846 Left_Opnd => New_Occurrence_Of (Temp, Loc),
1847 Right_Opnd => Make_Null (Loc)),
1848 Reason => CE_Access_Check_Failed));
1851 Append_To (Post_Call,
1852 Make_Assignment_Statement (Loc,
1854 Expression => Expr));
1858 end Add_Call_By_Copy_Code;
1860 ----------------------------------
1861 -- Add_Simple_Call_By_Copy_Code --
1862 ----------------------------------
1864 procedure Add_Simple_Call_By_Copy_Code (Force : Boolean) is
1866 F_Typ : Entity_Id := Etype (Formal);
1875 -- Unless forced not to, check the legality of the copy operation
1877 if not Force and then not Is_Legal_Copy then
1881 -- Handle formals whose type comes from the limited view
1883 if From_Limited_With (F_Typ)
1884 and then Has_Non_Limited_View (F_Typ)
1886 F_Typ := Non_Limited_View (F_Typ);
1889 -- Use formal type for temp, unless formal type is an unconstrained
1890 -- array, in which case we don't have to worry about bounds checks,
1891 -- and we use the actual type, since that has appropriate bounds.
1893 if Is_Array_Type (F_Typ) and then not Is_Constrained (F_Typ) then
1894 Indic := New_Occurrence_Of (Etype (Actual), Loc);
1896 Indic := New_Occurrence_Of (F_Typ, Loc);
1899 -- Prepare to generate code
1901 Reset_Packed_Prefix;
1903 Temp := Make_Temporary (Loc, 'T', Actual);
1904 Incod := Relocate_Node (Actual);
1905 Outcod := New_Copy_Tree (Incod);
1907 -- Generate declaration of temporary variable, initializing it
1908 -- with the input parameter unless we have an OUT formal or
1909 -- this is an initialization call.
1911 -- If the formal is an out parameter with discriminants, the
1912 -- discriminants must be captured even if the rest of the object
1913 -- is in principle uninitialized, because the discriminants may
1914 -- be read by the called subprogram.
1916 if Ekind (Formal) = E_Out_Parameter then
1919 if Has_Discriminants (F_Typ) then
1920 Indic := New_Occurrence_Of (Etype (Actual), Loc);
1923 elsif Inside_Init_Proc then
1925 -- Could use a comment here to match comment below ???
1927 if Nkind (Actual) /= N_Selected_Component
1929 not Has_Discriminant_Dependent_Constraint
1930 (Entity (Selector_Name (Actual)))
1934 -- Otherwise, keep the component in order to generate the proper
1935 -- actual subtype, that depends on enclosing discriminants.
1943 Make_Object_Declaration (Loc,
1944 Defining_Identifier => Temp,
1945 Object_Definition => Indic,
1946 Expression => Incod);
1951 -- If the call is to initialize a component of a composite type,
1952 -- and the component does not depend on discriminants, use the
1953 -- actual type of the component. This is required in case the
1954 -- component is constrained, because in general the formal of the
1955 -- initialization procedure will be unconstrained. Note that if
1956 -- the component being initialized is constrained by an enclosing
1957 -- discriminant, the presence of the initialization in the
1958 -- declaration will generate an expression for the actual subtype.
1960 Set_No_Initialization (Decl);
1961 Set_Object_Definition (Decl,
1962 New_Occurrence_Of (Etype (Actual), Loc));
1965 Insert_Action (N, Decl);
1967 -- The actual is simply a reference to the temporary
1969 Rewrite (Actual, New_Occurrence_Of (Temp, Loc));
1971 -- Generate copy out if OUT or IN OUT parameter
1973 if Ekind (Formal) /= E_In_Parameter then
1975 Rhs := New_Occurrence_Of (Temp, Loc);
1976 Set_Is_True_Constant (Temp, False);
1978 -- Deal with conversion
1980 if Nkind (Lhs) = N_Type_Conversion then
1981 Lhs := Expression (Lhs);
1982 Rhs := Convert_To (Etype (Actual), Rhs);
1985 Append_To (Post_Call,
1986 Make_Assignment_Statement (Loc,
1988 Expression => Rhs));
1989 Set_Assignment_OK (Name (Last (Post_Call)));
1991 end Add_Simple_Call_By_Copy_Code;
1993 --------------------------------------
1994 -- Add_Validation_Call_By_Copy_Code --
1995 --------------------------------------
1997 procedure Add_Validation_Call_By_Copy_Code (Act : Node_Id) is
2000 Obj_Typ : Entity_Id;
2001 Var : constant Node_Id := Unqual_Conv (Act);
2005 -- Generate range check if required
2007 if Do_Range_Check (Actual) then
2008 Generate_Range_Check (Actual, E_Formal, CE_Range_Check_Failed);
2011 -- If there is a type conversion in the actual, it will be reinstated
2012 -- below, the new instance will be properly analyzed and the setting
2013 -- of the Do_Range_Check flag recomputed so remove the obsolete one.
2015 if Nkind (Actual) = N_Type_Conversion then
2016 Set_Do_Range_Check (Expression (Actual), False);
2019 -- Copy the value of the validation variable back into the object
2022 if Is_Entity_Name (Var) then
2023 Var_Id := Entity (Var);
2024 Obj := Validated_Object (Var_Id);
2025 Obj_Typ := Etype (Obj);
2027 Expr := New_Occurrence_Of (Var_Id, Loc);
2029 -- A type conversion is needed when the validation variable and
2030 -- the validated object carry different types. This case occurs
2031 -- when the actual is qualified in some fashion.
2034 -- subtype Int is Integer range ...;
2035 -- procedure Call (Val : in out Integer);
2039 -- Call (Integer (Object));
2043 -- Var : Integer := Object; -- conversion to base type
2044 -- if not Var'Valid then -- validity check
2045 -- Call (Var); -- modify Var
2046 -- Object := Int (Var); -- conversion to subtype
2048 if Etype (Var_Id) /= Obj_Typ then
2050 Make_Type_Conversion (Loc,
2051 Subtype_Mark => New_Occurrence_Of (Obj_Typ, Loc),
2052 Expression => Expr);
2058 -- Object := Object_Type (Var);
2060 Append_To (Post_Call,
2061 Make_Assignment_Statement (Loc,
2063 Expression => Expr));
2065 -- If the flow reaches this point, then this routine was invoked with
2066 -- an actual which does not denote a validation variable.
2069 pragma Assert (False);
2072 end Add_Validation_Call_By_Copy_Code;
2074 ---------------------------
2075 -- Check_Fortran_Logical --
2076 ---------------------------
2078 procedure Check_Fortran_Logical is
2079 Logical : constant Entity_Id := Etype (Formal);
2082 -- Note: this is very incomplete, e.g. it does not handle arrays
2083 -- of logical values. This is really not the right approach at all???)
2086 if Convention (Subp) = Convention_Fortran
2087 and then Root_Type (Etype (Formal)) = Standard_Boolean
2088 and then Ekind (Formal) /= E_In_Parameter
2090 Var := Make_Var (Actual);
2091 Append_To (Post_Call,
2092 Make_Assignment_Statement (Loc,
2093 Name => New_Occurrence_Of (Var, Loc),
2095 Unchecked_Convert_To (
2098 Left_Opnd => New_Occurrence_Of (Var, Loc),
2100 Unchecked_Convert_To (
2102 New_Occurrence_Of (Standard_False, Loc))))));
2104 end Check_Fortran_Logical;
2110 function Is_Legal_Copy return Boolean is
2112 -- An attempt to copy a value of such a type can only occur if
2113 -- representation clauses give the actual a misaligned address.
2115 if Is_By_Reference_Type (Etype (Formal))
2116 or else Is_Aliased (Formal)
2117 or else (Mechanism (Formal) = By_Reference
2118 and then not Has_Foreign_Convention (Subp))
2121 -- The actual may in fact be properly aligned but there is not
2122 -- enough front-end information to determine this. In that case
2123 -- gigi will emit an error or a warning if a copy is not legal,
2124 -- or generate the proper code.
2128 -- For users of Starlet, we assume that the specification of by-
2129 -- reference mechanism is mandatory. This may lead to unaligned
2130 -- objects but at least for DEC legacy code it is known to work.
2131 -- The warning will alert users of this code that a problem may
2134 elsif Mechanism (Formal) = By_Reference
2135 and then Ekind (Scope (Formal)) = E_Procedure
2136 and then Is_Valued_Procedure (Scope (Formal))
2139 ("by_reference actual may be misaligned??", Actual);
2151 function Make_Var (Actual : Node_Id) return Entity_Id is
2155 if Is_Entity_Name (Actual) then
2156 return Entity (Actual);
2159 Var := Make_Temporary (Loc, 'T', Actual);
2162 Make_Object_Renaming_Declaration (Loc,
2163 Defining_Identifier => Var,
2165 New_Occurrence_Of (Etype (Actual), Loc),
2166 Name => Relocate_Node (Actual));
2168 Insert_Action (N, N_Node);
2173 -------------------------
2174 -- Reset_Packed_Prefix --
2175 -------------------------
2177 procedure Reset_Packed_Prefix is
2178 Pfx : Node_Id := Actual;
2181 Set_Analyzed (Pfx, False);
2183 Nkind (Pfx) not in N_Selected_Component | N_Indexed_Component;
2184 Pfx := Prefix (Pfx);
2186 end Reset_Packed_Prefix;
2188 ----------------------------------------
2189 -- Requires_Atomic_Or_Volatile_Copy --
2190 ----------------------------------------
2192 function Requires_Atomic_Or_Volatile_Copy return Boolean is
2194 -- If the formal is already passed by copy, no need to do anything
2196 if Is_By_Copy_Type (E_Formal) then
2200 -- There is no requirement inside initialization procedures and this
2201 -- would generate copies for atomic or volatile composite components.
2203 if Inside_Init_Proc then
2207 -- Check for atomicity mismatch
2209 if Is_Atomic_Object (Actual) and then not Is_Atomic (E_Formal)
2211 if Comes_From_Source (N) then
2213 ("??atomic actual passed by copy (RM C.6(19))", Actual);
2218 -- Check for volatility mismatch
2220 if Is_Volatile_Object (Actual) and then not Is_Volatile (E_Formal)
2222 if Comes_From_Source (N) then
2224 ("??volatile actual passed by copy (RM C.6(19))", Actual);
2230 end Requires_Atomic_Or_Volatile_Copy;
2232 -- Start of processing for Expand_Actuals
2235 Post_Call := New_List;
2237 Formal := First_Formal (Subp);
2238 Actual := First_Actual (N);
2239 while Present (Formal) loop
2240 E_Formal := Etype (Formal);
2241 E_Actual := Etype (Actual);
2243 -- Handle formals whose type comes from the limited view
2245 if From_Limited_With (E_Formal)
2246 and then Has_Non_Limited_View (E_Formal)
2248 E_Formal := Non_Limited_View (E_Formal);
2251 if Is_Scalar_Type (E_Formal)
2252 or else Nkind (Actual) = N_Slice
2254 Check_Fortran_Logical;
2258 elsif Ekind (Formal) /= E_Out_Parameter then
2260 -- The unusual case of the current instance of a protected type
2261 -- requires special handling. This can only occur in the context
2262 -- of a call within the body of a protected operation.
2264 if Is_Entity_Name (Actual)
2265 and then Ekind (Entity (Actual)) = E_Protected_Type
2266 and then In_Open_Scopes (Entity (Actual))
2268 if Scope (Subp) /= Entity (Actual) then
2270 ("operation outside protected type may not "
2271 & "call back its protected operations??", Actual);
2275 Expand_Protected_Object_Reference (N, Entity (Actual)));
2278 -- Ada 2005 (AI-318-02): If the actual parameter is a call to a
2279 -- build-in-place function, then a temporary return object needs
2280 -- to be created and access to it must be passed to the function
2281 -- (and ensure that we have an activation chain defined for tasks
2282 -- and a Master variable).
2284 -- Currently we limit such functions to those with inherently
2285 -- limited result subtypes, but eventually we plan to expand the
2286 -- functions that are treated as build-in-place to include other
2287 -- composite result types.
2289 -- But do not do it here for intrinsic subprograms since this will
2290 -- be done properly after the subprogram is expanded.
2292 if Is_Intrinsic_Subprogram (Subp) then
2295 elsif Is_Build_In_Place_Function_Call (Actual) then
2296 Build_Activation_Chain_Entity (N);
2297 Build_Master_Entity (Etype (Actual));
2298 Make_Build_In_Place_Call_In_Anonymous_Context (Actual);
2300 -- Ada 2005 (AI-318-02): Specialization of the previous case for
2301 -- actuals containing build-in-place function calls whose returned
2302 -- object covers interface types.
2304 elsif Present (Unqual_BIP_Iface_Function_Call (Actual)) then
2305 Build_Activation_Chain_Entity (N);
2306 Build_Master_Entity (Etype (Actual));
2307 Make_Build_In_Place_Iface_Call_In_Anonymous_Context (Actual);
2310 Apply_Constraint_Check (Actual, E_Formal);
2312 -- Out parameter case. No constraint checks on access type
2313 -- RM 6.4.1 (13), but on return a null-excluding check may be
2314 -- required (see below).
2316 elsif Is_Access_Type (E_Formal) then
2321 elsif Has_Discriminants (Base_Type (E_Formal))
2322 or else Has_Non_Null_Base_Init_Proc (E_Formal)
2324 Apply_Constraint_Check (Actual, E_Formal);
2329 Apply_Constraint_Check (Actual, Base_Type (E_Formal));
2332 -- Processing for IN-OUT and OUT parameters
2334 if Ekind (Formal) /= E_In_Parameter then
2336 -- For type conversions of arrays, apply length/range checks
2338 if Is_Array_Type (E_Formal)
2339 and then Nkind (Actual) = N_Type_Conversion
2341 if Is_Constrained (E_Formal) then
2342 Apply_Length_Check (Expression (Actual), E_Formal);
2344 Apply_Range_Check (Expression (Actual), E_Formal);
2348 -- The actual denotes a variable which captures the value of an
2349 -- object for validation purposes. Add a copy-back to reflect any
2350 -- potential changes in value back into the original object.
2352 -- Var : ... := Object;
2353 -- if not Var'Valid then -- validity check
2354 -- Call (Var); -- modify var
2355 -- Object := Var; -- update Object
2357 -- This case is given higher priority because the subsequent check
2358 -- for type conversion may add an extra copy of the variable and
2359 -- prevent proper value propagation back in the original object.
2361 if Is_Validation_Variable_Reference (Actual) then
2362 Add_Validation_Call_By_Copy_Code (Actual);
2364 -- If argument is a type conversion for a type that is passed by
2365 -- copy, then we must pass the parameter by copy.
2367 elsif Nkind (Actual) = N_Type_Conversion
2369 (Is_Numeric_Type (E_Formal)
2370 or else Is_Access_Type (E_Formal)
2371 or else Is_Enumeration_Type (E_Formal)
2372 or else Is_Bit_Packed_Array (Etype (Formal))
2373 or else Is_Bit_Packed_Array (Etype (Expression (Actual)))
2375 -- Also pass by copy if change of representation
2377 or else not Has_Compatible_Representation
2378 (Target_Type => Etype (Formal),
2379 Operand_Type => Etype (Expression (Actual))))
2381 Add_Call_By_Copy_Code;
2383 -- References to components of bit-packed arrays are expanded
2384 -- at this point, rather than at the point of analysis of the
2385 -- actuals, to handle the expansion of the assignment to
2386 -- [in] out parameters.
2388 elsif Is_Ref_To_Bit_Packed_Array (Actual) then
2389 Add_Simple_Call_By_Copy_Code (Force => True);
2391 -- If a nonscalar actual is possibly bit-aligned, we need a copy
2392 -- because the back-end cannot cope with such objects. In other
2393 -- cases where alignment forces a copy, the back-end generates
2394 -- it properly. It should not be generated unconditionally in the
2395 -- front-end because it does not know precisely the alignment
2396 -- requirements of the target, and makes too conservative an
2397 -- estimate, leading to superfluous copies or spurious errors
2398 -- on by-reference parameters.
2400 elsif Nkind (Actual) = N_Selected_Component
2402 Component_May_Be_Bit_Aligned (Entity (Selector_Name (Actual)))
2403 and then not Represented_As_Scalar (Etype (Formal))
2405 Add_Simple_Call_By_Copy_Code (Force => False);
2407 -- References to slices of bit-packed arrays are expanded
2409 elsif Is_Ref_To_Bit_Packed_Slice (Actual) then
2410 Add_Call_By_Copy_Code;
2412 -- References to possibly unaligned slices of arrays are expanded
2414 elsif Is_Possibly_Unaligned_Slice (Actual) then
2415 Add_Call_By_Copy_Code;
2417 -- Deal with access types where the actual subtype and the
2418 -- formal subtype are not the same, requiring a check.
2420 -- It is necessary to exclude tagged types because of "downward
2421 -- conversion" errors, but null-excluding checks on return may be
2424 elsif Is_Access_Type (E_Formal)
2425 and then not Is_Tagged_Type (Designated_Type (E_Formal))
2426 and then (not Same_Type (E_Formal, E_Actual)
2427 or else (Can_Never_Be_Null (E_Actual)
2428 and then not Can_Never_Be_Null (E_Formal)))
2430 Add_Call_By_Copy_Code;
2432 -- We may need to force a copy because of atomicity or volatility
2435 elsif Requires_Atomic_Or_Volatile_Copy then
2436 Add_Call_By_Copy_Code;
2438 -- Add call-by-copy code for the case of scalar out parameters
2439 -- when it is not known at compile time that the subtype of the
2440 -- formal is a subrange of the subtype of the actual (or vice
2441 -- versa for in out parameters), in order to get range checks
2442 -- on such actuals. (Maybe this case should be handled earlier
2443 -- in the if statement???)
2445 elsif Is_Scalar_Type (E_Formal)
2447 (not In_Subrange_Of (E_Formal, E_Actual)
2449 (Ekind (Formal) = E_In_Out_Parameter
2450 and then not In_Subrange_Of (E_Actual, E_Formal)))
2452 Add_Call_By_Copy_Code;
2455 -- RM 3.2.4 (23/3): A predicate is checked on in-out and out
2456 -- by-reference parameters on exit from the call. If the actual
2457 -- is a derived type and the operation is inherited, the body
2458 -- of the operation will not contain a call to the predicate
2459 -- function, so it must be done explicitly after the call. Ditto
2460 -- if the actual is an entity of a predicated subtype.
2462 -- The rule refers to by-reference types, but a check is needed
2463 -- for by-copy types as well. That check is subsumed by the rule
2464 -- for subtype conversion on assignment, but we can generate the
2465 -- required check now.
2467 -- Note also that Subp may be either a subprogram entity for
2468 -- direct calls, or a type entity for indirect calls, which must
2469 -- be handled separately because the name does not denote an
2470 -- overloadable entity.
2472 By_Ref_Predicate_Check : declare
2473 Aund : constant Entity_Id := Underlying_Type (E_Actual);
2483 if Predicate_Enabled (Atyp)
2485 -- Skip predicate checks for special cases
2487 and then Predicate_Tests_On_Arguments (Subp)
2489 Append_To (Post_Call,
2490 Make_Predicate_Check (Atyp, Actual));
2492 end By_Ref_Predicate_Check;
2494 -- Processing for IN parameters
2497 -- Generate range check if required
2499 if Do_Range_Check (Actual) then
2500 Generate_Range_Check (Actual, E_Formal, CE_Range_Check_Failed);
2503 -- For IN parameters in the bit-packed array case, we expand an
2504 -- indexed component (the circuit in Exp_Ch4 deliberately left
2505 -- indexed components appearing as actuals untouched, so that
2506 -- the special processing above for the OUT and IN OUT cases
2507 -- could be performed. We could make the test in Exp_Ch4 more
2508 -- complex and have it detect the parameter mode, but it is
2509 -- easier simply to handle all cases here.)
2511 if Nkind (Actual) = N_Indexed_Component
2512 and then Is_Bit_Packed_Array (Etype (Prefix (Actual)))
2514 Reset_Packed_Prefix;
2515 Expand_Packed_Element_Reference (Actual);
2517 -- If we have a reference to a bit-packed array, we copy it, since
2518 -- the actual must be byte aligned.
2520 -- Is this really necessary in all cases???
2522 elsif Is_Ref_To_Bit_Packed_Array (Actual) then
2523 Add_Simple_Call_By_Copy_Code (Force => True);
2525 -- If we have a C++ constructor call, we need to create the object
2527 elsif Is_CPP_Constructor_Call (Actual) then
2528 Add_Simple_Call_By_Copy_Code (Force => True);
2530 -- If a nonscalar actual is possibly unaligned, we need a copy
2532 elsif Is_Possibly_Unaligned_Object (Actual)
2533 and then not Represented_As_Scalar (Etype (Formal))
2535 Add_Simple_Call_By_Copy_Code (Force => False);
2537 -- Similarly, we have to expand slices of packed arrays here
2538 -- because the result must be byte aligned.
2540 elsif Is_Ref_To_Bit_Packed_Slice (Actual) then
2541 Add_Call_By_Copy_Code;
2543 -- Only processing remaining is to pass by copy if this is a
2544 -- reference to a possibly unaligned slice, since the caller
2545 -- expects an appropriately aligned argument.
2547 elsif Is_Possibly_Unaligned_Slice (Actual) then
2548 Add_Call_By_Copy_Code;
2550 -- We may need to force a copy because of atomicity or volatility
2553 elsif Requires_Atomic_Or_Volatile_Copy then
2554 Add_Call_By_Copy_Code;
2556 -- An unusual case: a current instance of an enclosing task can be
2557 -- an actual, and must be replaced by a reference to self.
2559 elsif Is_Entity_Name (Actual)
2560 and then Is_Task_Type (Entity (Actual))
2562 if In_Open_Scopes (Entity (Actual)) then
2564 (Make_Function_Call (Loc,
2565 Name => New_Occurrence_Of (RTE (RE_Self), Loc))));
2568 -- A task type cannot otherwise appear as an actual
2571 raise Program_Error;
2576 -- Type-invariant checks for in-out and out parameters, as well as
2577 -- for in parameters of procedures (AI05-0289 and AI12-0044).
2579 if Ekind (Formal) /= E_In_Parameter
2580 or else Ekind (Subp) = E_Procedure
2582 Caller_Side_Invariant_Checks : declare
2584 function Is_Public_Subp return Boolean;
2585 -- Check whether the subprogram being called is a visible
2586 -- operation of the type of the actual. Used to determine
2587 -- whether an invariant check must be generated on the
2590 ---------------------
2591 -- Is_Public_Subp --
2592 ---------------------
2594 function Is_Public_Subp return Boolean is
2595 Pack : constant Entity_Id := Scope (Subp);
2596 Subp_Decl : Node_Id;
2599 if not Is_Subprogram (Subp) then
2602 -- The operation may be inherited, or a primitive of the
2606 Nkind (Parent (Subp)) in N_Private_Extension_Declaration
2607 | N_Full_Type_Declaration
2609 Subp_Decl := Parent (Subp);
2612 Subp_Decl := Unit_Declaration_Node (Subp);
2615 return Ekind (Pack) = E_Package
2617 List_Containing (Subp_Decl) =
2618 Visible_Declarations
2619 (Specification (Unit_Declaration_Node (Pack)));
2622 -- Start of processing for Caller_Side_Invariant_Checks
2625 -- We generate caller-side invariant checks in two cases:
2627 -- a) when calling an inherited operation, where there is an
2628 -- implicit view conversion of the actual to the parent type.
2630 -- b) When the conversion is explicit
2632 -- We treat these cases separately because the required
2633 -- conversion for a) is added later when expanding the call.
2635 if Has_Invariants (Etype (Actual))
2637 Nkind (Parent (Etype (Actual)))
2638 = N_Private_Extension_Declaration
2640 if Comes_From_Source (N) and then Is_Public_Subp then
2641 Append_To (Post_Call, Make_Invariant_Call (Actual));
2644 elsif Nkind (Actual) = N_Type_Conversion
2645 and then Has_Invariants (Etype (Expression (Actual)))
2647 if Comes_From_Source (N) and then Is_Public_Subp then
2649 (Post_Call, Make_Invariant_Call (Expression (Actual)));
2652 end Caller_Side_Invariant_Checks;
2655 Next_Formal (Formal);
2656 Next_Actual (Actual);
2664 procedure Expand_Call (N : Node_Id) is
2665 Post_Call : List_Id;
2667 -- If this is an indirect call through an Access_To_Subprogram
2668 -- with contract specifications, it is rewritten as a call to
2669 -- the corresponding Access_Subprogram_Wrapper with the same
2670 -- actuals, whose body contains a naked indirect call (which
2671 -- itself must not be rewritten, to prevent infinite recursion).
2673 Must_Rewrite_Indirect_Call : constant Boolean :=
2674 Ada_Version >= Ada_2020
2675 and then Nkind (Name (N)) = N_Explicit_Dereference
2676 and then Ekind (Etype (Name (N))) = E_Subprogram_Type
2678 (Access_Subprogram_Wrapper (Etype (Name (N))));
2681 pragma Assert (Nkind (N) in N_Entry_Call_Statement
2683 | N_Procedure_Call_Statement);
2685 -- Check that this is not the call in the body of the wrapper.
2687 if Must_Rewrite_Indirect_Call
2688 and then (not Is_Overloadable (Current_Scope)
2689 or else not Is_Access_Subprogram_Wrapper (Current_Scope))
2692 Loc : constant Source_Ptr := Sloc (N);
2693 Wrapper : constant Entity_Id :=
2694 Access_Subprogram_Wrapper (Etype (Name (N)));
2695 Ptr : constant Node_Id := Prefix (Name (N));
2696 Ptr_Type : constant Entity_Id := Etype (Ptr);
2697 Typ : constant Entity_Id := Etype (N);
2700 Parms : List_Id := Parameter_Associations (N);
2704 -- The last actual in the call is the pointer itself.
2705 -- If the aspect is inherited, convert the pointer to the
2706 -- parent type that specifies the contract.
2707 -- If the original access_to_subprogram has defaults for
2708 -- in_parameters, the call may include named associations, so
2709 -- we create one for the pointer as well.
2711 if Is_Derived_Type (Ptr_Type)
2712 and then Ptr_Type /= Etype (Last_Formal (Wrapper))
2715 Make_Type_Conversion (Loc,
2717 (Etype (Last_Formal (Wrapper)), Loc), Ptr);
2723 -- Handle parameterless subprogram.
2730 (Make_Parameter_Association (Loc,
2731 Selector_Name => Make_Identifier (Loc,
2732 Chars (Last_Formal (Wrapper))),
2733 Explicit_Actual_Parameter => Ptr_Act),
2736 if Nkind (N) = N_Procedure_Call_Statement then
2737 New_N := Make_Procedure_Call_Statement (Loc,
2738 Name => New_Occurrence_Of (Wrapper, Loc),
2739 Parameter_Associations => Parms);
2741 New_N := Make_Function_Call (Loc,
2742 Name => New_Occurrence_Of (Wrapper, Loc),
2743 Parameter_Associations => Parms);
2747 Analyze_And_Resolve (N, Typ);
2751 Expand_Call_Helper (N, Post_Call);
2752 Insert_Post_Call_Actions (N, Post_Call);
2756 ------------------------
2757 -- Expand_Call_Helper --
2758 ------------------------
2760 -- This procedure handles expansion of function calls and procedure call
2761 -- statements (i.e. it serves as the body for Expand_N_Function_Call and
2762 -- Expand_N_Procedure_Call_Statement). Processing for calls includes:
2764 -- Replace call to Raise_Exception by Raise_Exception_Always if possible
2765 -- Provide values of actuals for all formals in Extra_Formals list
2766 -- Replace "call" to enumeration literal function by literal itself
2767 -- Rewrite call to predefined operator as operator
2768 -- Replace actuals to in-out parameters that are numeric conversions,
2769 -- with explicit assignment to temporaries before and after the call.
2771 -- Note that the list of actuals has been filled with default expressions
2772 -- during semantic analysis of the call. Only the extra actuals required
2773 -- for the 'Constrained attribute and for accessibility checks are added
2776 procedure Expand_Call_Helper (N : Node_Id; Post_Call : out List_Id) is
2777 Loc : constant Source_Ptr := Sloc (N);
2778 Call_Node : Node_Id := N;
2779 Extra_Actuals : List_Id := No_List;
2780 Prev : Node_Id := Empty;
2782 procedure Add_Actual_Parameter (Insert_Param : Node_Id);
2783 -- Adds one entry to the end of the actual parameter list. Used for
2784 -- default parameters and for extra actuals (for Extra_Formals). The
2785 -- argument is an N_Parameter_Association node.
2787 procedure Add_Extra_Actual (Expr : Node_Id; EF : Entity_Id);
2788 -- Adds an extra actual to the list of extra actuals. Expr is the
2789 -- expression for the value of the actual, EF is the entity for the
2792 procedure Add_View_Conversion_Invariants
2793 (Formal : Entity_Id;
2795 -- Adds invariant checks for every intermediate type between the range
2796 -- of a view converted argument to its ancestor (from parent to child).
2798 function Can_Fold_Predicate_Call (P : Entity_Id) return Boolean;
2799 -- Try to constant-fold a predicate check, which often enough is a
2800 -- simple arithmetic expression that can be computed statically if
2801 -- its argument is static. This cleans up the output of CCG, even
2802 -- though useless predicate checks will be generally removed by
2803 -- back-end optimizations.
2805 function Inherited_From_Formal (S : Entity_Id) return Entity_Id;
2806 -- Within an instance, a type derived from an untagged formal derived
2807 -- type inherits from the original parent, not from the actual. The
2808 -- current derivation mechanism has the derived type inherit from the
2809 -- actual, which is only correct outside of the instance. If the
2810 -- subprogram is inherited, we test for this particular case through a
2811 -- convoluted tree traversal before setting the proper subprogram to be
2814 function In_Unfrozen_Instance (E : Entity_Id) return Boolean;
2815 -- Return true if E comes from an instance that is not yet frozen
2817 function Is_Class_Wide_Interface_Type (E : Entity_Id) return Boolean;
2818 -- Return True when E is a class-wide interface type or an access to
2819 -- a class-wide interface type.
2821 function Is_Direct_Deep_Call (Subp : Entity_Id) return Boolean;
2822 -- Determine if Subp denotes a non-dispatching call to a Deep routine
2824 function New_Value (From : Node_Id) return Node_Id;
2825 -- From is the original Expression. New_Value is equivalent to a call
2826 -- to Duplicate_Subexpr with an explicit dereference when From is an
2827 -- access parameter.
2829 --------------------------
2830 -- Add_Actual_Parameter --
2831 --------------------------
2833 procedure Add_Actual_Parameter (Insert_Param : Node_Id) is
2834 Actual_Expr : constant Node_Id :=
2835 Explicit_Actual_Parameter (Insert_Param);
2838 -- Case of insertion is first named actual
2840 if No (Prev) or else
2841 Nkind (Parent (Prev)) /= N_Parameter_Association
2843 Set_Next_Named_Actual
2844 (Insert_Param, First_Named_Actual (Call_Node));
2845 Set_First_Named_Actual (Call_Node, Actual_Expr);
2848 if No (Parameter_Associations (Call_Node)) then
2849 Set_Parameter_Associations (Call_Node, New_List);
2852 Append (Insert_Param, Parameter_Associations (Call_Node));
2855 Insert_After (Prev, Insert_Param);
2858 -- Case of insertion is not first named actual
2861 Set_Next_Named_Actual
2862 (Insert_Param, Next_Named_Actual (Parent (Prev)));
2863 Set_Next_Named_Actual (Parent (Prev), Actual_Expr);
2864 Append (Insert_Param, Parameter_Associations (Call_Node));
2867 Prev := Actual_Expr;
2868 end Add_Actual_Parameter;
2870 ----------------------
2871 -- Add_Extra_Actual --
2872 ----------------------
2874 procedure Add_Extra_Actual (Expr : Node_Id; EF : Entity_Id) is
2875 Loc : constant Source_Ptr := Sloc (Expr);
2878 if Extra_Actuals = No_List then
2879 Extra_Actuals := New_List;
2880 Set_Parent (Extra_Actuals, Call_Node);
2883 Append_To (Extra_Actuals,
2884 Make_Parameter_Association (Loc,
2885 Selector_Name => New_Occurrence_Of (EF, Loc),
2886 Explicit_Actual_Parameter => Expr));
2888 Analyze_And_Resolve (Expr, Etype (EF));
2890 if Nkind (Call_Node) = N_Function_Call then
2891 Set_Is_Accessibility_Actual (Parent (Expr));
2893 end Add_Extra_Actual;
2895 ------------------------------------
2896 -- Add_View_Conversion_Invariants --
2897 ------------------------------------
2899 procedure Add_View_Conversion_Invariants
2900 (Formal : Entity_Id;
2904 Curr_Typ : Entity_Id;
2905 Inv_Checks : List_Id;
2906 Par_Typ : Entity_Id;
2909 Inv_Checks := No_List;
2911 -- Extract the argument from a potentially nested set of view
2915 while Nkind (Arg) = N_Type_Conversion loop
2916 Arg := Expression (Arg);
2919 -- Move up the derivation chain starting with the type of the formal
2920 -- parameter down to the type of the actual object.
2923 Par_Typ := Etype (Arg);
2924 while Par_Typ /= Etype (Formal) and Par_Typ /= Curr_Typ loop
2925 Curr_Typ := Par_Typ;
2927 if Has_Invariants (Curr_Typ)
2928 and then Present (Invariant_Procedure (Curr_Typ))
2930 -- Verify the invariate of the current type. Generate:
2932 -- <Curr_Typ>Invariant (Curr_Typ (Arg));
2934 Prepend_New_To (Inv_Checks,
2935 Make_Procedure_Call_Statement (Loc,
2938 (Invariant_Procedure (Curr_Typ), Loc),
2939 Parameter_Associations => New_List (
2940 Make_Type_Conversion (Loc,
2941 Subtype_Mark => New_Occurrence_Of (Curr_Typ, Loc),
2942 Expression => New_Copy_Tree (Arg)))));
2945 Par_Typ := Base_Type (Etype (Curr_Typ));
2948 if not Is_Empty_List (Inv_Checks) then
2949 Insert_Actions_After (Call_Node, Inv_Checks);
2951 end Add_View_Conversion_Invariants;
2953 -----------------------------
2954 -- Can_Fold_Predicate_Call --
2955 -----------------------------
2957 function Can_Fold_Predicate_Call (P : Entity_Id) return Boolean is
2960 function May_Fold (N : Node_Id) return Traverse_Result;
2961 -- The predicate expression is foldable if it only contains operators
2962 -- and literals. During this check, we also replace occurrences of
2963 -- the formal of the constructed predicate function with the static
2964 -- value of the actual. This is done on a copy of the analyzed
2965 -- expression for the predicate.
2971 function May_Fold (N : Node_Id) return Traverse_Result is
2979 when N_Expanded_Name
2982 if Ekind (Entity (N)) = E_In_Parameter
2983 and then Entity (N) = First_Entity (P)
2985 Rewrite (N, New_Copy (Actual));
2986 Set_Is_Static_Expression (N);
2989 elsif Ekind (Entity (N)) = E_Enumeration_Literal then
2996 when N_Case_Expression
3001 when N_Integer_Literal =>
3009 function Try_Fold is new Traverse_Func (May_Fold);
3011 -- Other lLocal variables
3013 Subt : constant Entity_Id := Etype (First_Entity (P));
3017 -- Start of processing for Can_Fold_Predicate_Call
3020 -- Folding is only interesting if the actual is static and its type
3021 -- has a Dynamic_Predicate aspect. For CodePeer we preserve the
3024 Actual := First (Parameter_Associations (Call_Node));
3025 Aspect := Find_Aspect (Subt, Aspect_Dynamic_Predicate);
3027 -- If actual is a declared constant, retrieve its value
3029 if Is_Entity_Name (Actual)
3030 and then Ekind (Entity (Actual)) = E_Constant
3032 Actual := Constant_Value (Entity (Actual));
3036 or else Nkind (Actual) /= N_Integer_Literal
3037 or else not Has_Dynamic_Predicate_Aspect (Subt)
3039 or else CodePeer_Mode
3044 -- Retrieve the analyzed expression for the predicate
3046 Pred := New_Copy_Tree (Expression (Aspect));
3048 if Try_Fold (Pred) = OK then
3049 Rewrite (Call_Node, Pred);
3050 Analyze_And_Resolve (Call_Node, Standard_Boolean);
3053 -- Otherwise continue the expansion of the function call
3058 end Can_Fold_Predicate_Call;
3060 ---------------------------
3061 -- Inherited_From_Formal --
3062 ---------------------------
3064 function Inherited_From_Formal (S : Entity_Id) return Entity_Id is
3066 Gen_Par : Entity_Id;
3067 Gen_Prim : Elist_Id;
3072 -- If the operation is inherited, it is attached to the corresponding
3073 -- type derivation. If the parent in the derivation is a generic
3074 -- actual, it is a subtype of the actual, and we have to recover the
3075 -- original derived type declaration to find the proper parent.
3077 if Nkind (Parent (S)) /= N_Full_Type_Declaration
3078 or else not Is_Derived_Type (Defining_Identifier (Parent (S)))
3079 or else Nkind (Type_Definition (Original_Node (Parent (S)))) /=
3080 N_Derived_Type_Definition
3081 or else not In_Instance
3088 (Type_Definition (Original_Node (Parent (S))));
3090 if Nkind (Indic) = N_Subtype_Indication then
3091 Par := Entity (Subtype_Mark (Indic));
3093 Par := Entity (Indic);
3097 if not Is_Generic_Actual_Type (Par)
3098 or else Is_Tagged_Type (Par)
3099 or else Nkind (Parent (Par)) /= N_Subtype_Declaration
3100 or else not In_Open_Scopes (Scope (Par))
3104 Gen_Par := Generic_Parent_Type (Parent (Par));
3107 -- If the actual has no generic parent type, the formal is not
3108 -- a formal derived type, so nothing to inherit.
3110 if No (Gen_Par) then
3114 -- If the generic parent type is still the generic type, this is a
3115 -- private formal, not a derived formal, and there are no operations
3116 -- inherited from the formal.
3118 if Nkind (Parent (Gen_Par)) = N_Formal_Type_Declaration then
3122 Gen_Prim := Collect_Primitive_Operations (Gen_Par);
3124 Elmt := First_Elmt (Gen_Prim);
3125 while Present (Elmt) loop
3126 if Chars (Node (Elmt)) = Chars (S) then
3132 F1 := First_Formal (S);
3133 F2 := First_Formal (Node (Elmt));
3135 and then Present (F2)
3137 if Etype (F1) = Etype (F2)
3138 or else Etype (F2) = Gen_Par
3144 exit; -- not the right subprogram
3156 raise Program_Error;
3157 end Inherited_From_Formal;
3159 --------------------------
3160 -- In_Unfrozen_Instance --
3161 --------------------------
3163 function In_Unfrozen_Instance (E : Entity_Id) return Boolean is
3168 while Present (S) and then S /= Standard_Standard loop
3169 if Is_Generic_Instance (S)
3170 and then Present (Freeze_Node (S))
3171 and then not Analyzed (Freeze_Node (S))
3180 end In_Unfrozen_Instance;
3182 ----------------------------------
3183 -- Is_Class_Wide_Interface_Type --
3184 ----------------------------------
3186 function Is_Class_Wide_Interface_Type (E : Entity_Id) return Boolean is
3188 Typ : Entity_Id := E;
3191 if Has_Non_Limited_View (Typ) then
3192 Typ := Non_Limited_View (Typ);
3195 if Ekind (Typ) = E_Anonymous_Access_Type then
3196 DDT := Directly_Designated_Type (Typ);
3198 if Has_Non_Limited_View (DDT) then
3199 DDT := Non_Limited_View (DDT);
3202 return Is_Class_Wide_Type (DDT) and then Is_Interface (DDT);
3204 return Is_Class_Wide_Type (Typ) and then Is_Interface (Typ);
3206 end Is_Class_Wide_Interface_Type;
3208 -------------------------
3209 -- Is_Direct_Deep_Call --
3210 -------------------------
3212 function Is_Direct_Deep_Call (Subp : Entity_Id) return Boolean is
3214 if Is_TSS (Subp, TSS_Deep_Adjust)
3215 or else Is_TSS (Subp, TSS_Deep_Finalize)
3216 or else Is_TSS (Subp, TSS_Deep_Initialize)
3223 Actual := First (Parameter_Associations (Call_Node));
3224 Formal := First_Formal (Subp);
3225 while Present (Actual)
3226 and then Present (Formal)
3228 if Nkind (Actual) = N_Identifier
3229 and then Is_Controlling_Actual (Actual)
3230 and then Etype (Actual) = Etype (Formal)
3236 Next_Formal (Formal);
3242 end Is_Direct_Deep_Call;
3248 function New_Value (From : Node_Id) return Node_Id is
3249 Res : constant Node_Id := Duplicate_Subexpr (From);
3251 if Is_Access_Type (Etype (From)) then
3252 return Make_Explicit_Dereference (Sloc (From), Prefix => Res);
3260 Remote : constant Boolean := Is_Remote_Call (Call_Node);
3263 Orig_Subp : Entity_Id := Empty;
3264 Param_Count : Natural := 0;
3265 Parent_Formal : Entity_Id;
3266 Parent_Subp : Entity_Id;
3271 Prev_Orig : Node_Id;
3272 -- Original node for an actual, which may have been rewritten. If the
3273 -- actual is a function call that has been transformed from a selected
3274 -- component, the original node is unanalyzed. Otherwise, it carries
3275 -- semantic information used to generate additional actuals.
3277 CW_Interface_Formals_Present : Boolean := False;
3279 -- Start of processing for Expand_Call_Helper
3282 Post_Call := New_List;
3284 -- Expand the function or procedure call if the first actual has a
3285 -- declared dimension aspect, and the subprogram is declared in one
3286 -- of the dimension I/O packages.
3288 if Ada_Version >= Ada_2012
3290 Nkind (Call_Node) in N_Procedure_Call_Statement | N_Function_Call
3291 and then Present (Parameter_Associations (Call_Node))
3293 Expand_Put_Call_With_Symbol (Call_Node);
3296 -- Ignore if previous error
3298 if Nkind (Call_Node) in N_Has_Etype
3299 and then Etype (Call_Node) = Any_Type
3304 -- Call using access to subprogram with explicit dereference
3306 if Nkind (Name (Call_Node)) = N_Explicit_Dereference then
3307 Subp := Etype (Name (Call_Node));
3308 Parent_Subp := Empty;
3310 -- Case of call to simple entry, where the Name is a selected component
3311 -- whose prefix is the task, and whose selector name is the entry name
3313 elsif Nkind (Name (Call_Node)) = N_Selected_Component then
3314 Subp := Entity (Selector_Name (Name (Call_Node)));
3315 Parent_Subp := Empty;
3317 -- Case of call to member of entry family, where Name is an indexed
3318 -- component, with the prefix being a selected component giving the
3319 -- task and entry family name, and the index being the entry index.
3321 elsif Nkind (Name (Call_Node)) = N_Indexed_Component then
3322 Subp := Entity (Selector_Name (Prefix (Name (Call_Node))));
3323 Parent_Subp := Empty;
3328 Subp := Entity (Name (Call_Node));
3329 Parent_Subp := Alias (Subp);
3331 -- Replace call to Raise_Exception by call to Raise_Exception_Always
3332 -- if we can tell that the first parameter cannot possibly be null.
3333 -- This improves efficiency by avoiding a run-time test.
3335 -- We do not do this if Raise_Exception_Always does not exist, which
3336 -- can happen in configurable run time profiles which provide only a
3339 if Is_RTE (Subp, RE_Raise_Exception)
3340 and then RTE_Available (RE_Raise_Exception_Always)
3343 FA : constant Node_Id :=
3344 Original_Node (First_Actual (Call_Node));
3347 -- The case we catch is where the first argument is obtained
3348 -- using the Identity attribute (which must always be
3351 if Nkind (FA) = N_Attribute_Reference
3352 and then Attribute_Name (FA) = Name_Identity
3354 Subp := RTE (RE_Raise_Exception_Always);
3355 Set_Name (Call_Node, New_Occurrence_Of (Subp, Loc));
3360 if Ekind (Subp) = E_Entry then
3361 Parent_Subp := Empty;
3365 -- Ada 2005 (AI-345): We have a procedure call as a triggering
3366 -- alternative in an asynchronous select or as an entry call in
3367 -- a conditional or timed select. Check whether the procedure call
3368 -- is a renaming of an entry and rewrite it as an entry call.
3370 if Ada_Version >= Ada_2005
3371 and then Nkind (Call_Node) = N_Procedure_Call_Statement
3373 ((Nkind (Parent (Call_Node)) = N_Triggering_Alternative
3374 and then Triggering_Statement (Parent (Call_Node)) = Call_Node)
3376 (Nkind (Parent (Call_Node)) = N_Entry_Call_Alternative
3377 and then Entry_Call_Statement (Parent (Call_Node)) = Call_Node))
3381 Ren_Root : Entity_Id := Subp;
3384 -- This may be a chain of renamings, find the root
3386 if Present (Alias (Ren_Root)) then
3387 Ren_Root := Alias (Ren_Root);
3390 if Present (Original_Node (Parent (Parent (Ren_Root)))) then
3391 Ren_Decl := Original_Node (Parent (Parent (Ren_Root)));
3393 if Nkind (Ren_Decl) = N_Subprogram_Renaming_Declaration then
3395 Make_Entry_Call_Statement (Loc,
3397 New_Copy_Tree (Name (Ren_Decl)),
3398 Parameter_Associations =>
3400 (Parameter_Associations (Call_Node))));
3408 -- if this is a call to a predicate function, try to constant
3411 if Nkind (Call_Node) = N_Function_Call
3412 and then Is_Entity_Name (Name (Call_Node))
3413 and then Is_Predicate_Function (Subp)
3414 and then Can_Fold_Predicate_Call (Subp)
3419 if Modify_Tree_For_C
3420 and then Nkind (Call_Node) = N_Function_Call
3421 and then Is_Entity_Name (Name (Call_Node))
3424 Func_Id : constant Entity_Id :=
3425 Ultimate_Alias (Entity (Name (Call_Node)));
3427 -- When generating C code, transform a function call that returns
3428 -- a constrained array type into procedure form.
3430 if Rewritten_For_C (Func_Id) then
3432 -- For internally generated calls ensure that they reference
3433 -- the entity of the spec of the called function (needed since
3434 -- the expander may generate calls using the entity of their
3435 -- body). See for example Expand_Boolean_Operator().
3437 if not (Comes_From_Source (Call_Node))
3438 and then Nkind (Unit_Declaration_Node (Func_Id)) =
3441 Set_Entity (Name (Call_Node),
3442 Corresponding_Function
3443 (Corresponding_Procedure (Func_Id)));
3446 Rewrite_Function_Call_For_C (Call_Node);
3449 -- Also introduce a temporary for functions that return a record
3450 -- called within another procedure or function call, since records
3451 -- are passed by pointer in the generated C code, and we cannot
3452 -- take a pointer from a subprogram call.
3454 elsif Nkind (Parent (Call_Node)) in N_Subprogram_Call
3455 and then Is_Record_Type (Etype (Func_Id))
3458 Temp_Id : constant Entity_Id := Make_Temporary (Loc, 'T');
3463 -- Temp : ... := Func_Call (...);
3466 Make_Object_Declaration (Loc,
3467 Defining_Identifier => Temp_Id,
3468 Object_Definition =>
3469 New_Occurrence_Of (Etype (Func_Id), Loc),
3471 Make_Function_Call (Loc,
3473 New_Occurrence_Of (Func_Id, Loc),
3474 Parameter_Associations =>
3475 Parameter_Associations (Call_Node)));
3477 Insert_Action (Parent (Call_Node), Decl);
3478 Rewrite (Call_Node, New_Occurrence_Of (Temp_Id, Loc));
3485 -- First step, compute extra actuals, corresponding to any Extra_Formals
3486 -- present. Note that we do not access Extra_Formals directly, instead
3487 -- we simply note the presence of the extra formals as we process the
3488 -- regular formals collecting corresponding actuals in Extra_Actuals.
3490 -- We also generate any required range checks for actuals for in formals
3491 -- as we go through the loop, since this is a convenient place to do it.
3492 -- (Though it seems that this would be better done in Expand_Actuals???)
3494 -- Special case: Thunks must not compute the extra actuals; they must
3495 -- just propagate to the target primitive their extra actuals.
3497 if Is_Thunk (Current_Scope)
3498 and then Thunk_Entity (Current_Scope) = Subp
3499 and then Present (Extra_Formals (Subp))
3501 pragma Assert (Present (Extra_Formals (Current_Scope)));
3504 Target_Formal : Entity_Id;
3505 Thunk_Formal : Entity_Id;
3508 Target_Formal := Extra_Formals (Subp);
3509 Thunk_Formal := Extra_Formals (Current_Scope);
3510 while Present (Target_Formal) loop
3512 (Expr => New_Occurrence_Of (Thunk_Formal, Loc),
3513 EF => Thunk_Formal);
3515 Target_Formal := Extra_Formal (Target_Formal);
3516 Thunk_Formal := Extra_Formal (Thunk_Formal);
3519 while Is_Non_Empty_List (Extra_Actuals) loop
3520 Add_Actual_Parameter (Remove_Head (Extra_Actuals));
3523 Expand_Actuals (Call_Node, Subp, Post_Call);
3524 pragma Assert (Is_Empty_List (Post_Call));
3525 pragma Assert (Check_Number_Of_Actuals (Call_Node, Subp));
3526 pragma Assert (Check_BIP_Actuals (Call_Node, Subp));
3531 Formal := First_Formal (Subp);
3532 Actual := First_Actual (Call_Node);
3534 while Present (Formal) loop
3535 -- Prepare to examine current entry
3538 Prev_Orig := Original_Node (Prev);
3540 -- Ada 2005 (AI-251): Check if any formal is a class-wide interface
3541 -- to expand it in a further round.
3543 CW_Interface_Formals_Present :=
3544 CW_Interface_Formals_Present
3545 or else Is_Class_Wide_Interface_Type (Etype (Formal));
3547 -- Create possible extra actual for constrained case. Usually, the
3548 -- extra actual is of the form actual'constrained, but since this
3549 -- attribute is only available for unconstrained records, TRUE is
3550 -- expanded if the type of the formal happens to be constrained (for
3551 -- instance when this procedure is inherited from an unconstrained
3552 -- record to a constrained one) or if the actual has no discriminant
3553 -- (its type is constrained). An exception to this is the case of a
3554 -- private type without discriminants. In this case we pass FALSE
3555 -- because the object has underlying discriminants with defaults.
3557 if Present (Extra_Constrained (Formal)) then
3558 if Ekind (Etype (Prev)) in Private_Kind
3559 and then not Has_Discriminants (Base_Type (Etype (Prev)))
3562 (Expr => New_Occurrence_Of (Standard_False, Loc),
3563 EF => Extra_Constrained (Formal));
3565 elsif Is_Constrained (Etype (Formal))
3566 or else not Has_Discriminants (Etype (Prev))
3569 (Expr => New_Occurrence_Of (Standard_True, Loc),
3570 EF => Extra_Constrained (Formal));
3572 -- Do not produce extra actuals for Unchecked_Union parameters.
3573 -- Jump directly to the end of the loop.
3575 elsif Is_Unchecked_Union (Base_Type (Etype (Actual))) then
3576 goto Skip_Extra_Actual_Generation;
3579 -- If the actual is a type conversion, then the constrained
3580 -- test applies to the actual, not the target type.
3586 -- Test for unchecked conversions as well, which can occur
3587 -- as out parameter actuals on calls to stream procedures.
3590 while Nkind (Act_Prev) in N_Type_Conversion
3591 | N_Unchecked_Type_Conversion
3593 Act_Prev := Expression (Act_Prev);
3596 -- If the expression is a conversion of a dereference, this
3597 -- is internally generated code that manipulates addresses,
3598 -- e.g. when building interface tables. No check should
3599 -- occur in this case, and the discriminated object is not
3602 if not Comes_From_Source (Actual)
3603 and then Nkind (Actual) = N_Unchecked_Type_Conversion
3604 and then Nkind (Act_Prev) = N_Explicit_Dereference
3607 (Expr => New_Occurrence_Of (Standard_False, Loc),
3608 EF => Extra_Constrained (Formal));
3613 Make_Attribute_Reference (Sloc (Prev),
3615 Duplicate_Subexpr_No_Checks
3616 (Act_Prev, Name_Req => True),
3617 Attribute_Name => Name_Constrained),
3618 EF => Extra_Constrained (Formal));
3624 -- Create possible extra actual for accessibility level
3626 if Present (Get_Accessibility (Formal)) then
3628 -- Ada 2005 (AI-252): If the actual was rewritten as an Access
3629 -- attribute, then the original actual may be an aliased object
3630 -- occurring as the prefix in a call using "Object.Operation"
3631 -- notation. In that case we must pass the level of the object,
3632 -- so Prev_Orig is reset to Prev and the attribute will be
3633 -- processed by the code for Access attributes further below.
3635 if Prev_Orig /= Prev
3636 and then Nkind (Prev) = N_Attribute_Reference
3637 and then Get_Attribute_Id (Attribute_Name (Prev)) =
3639 and then Is_Aliased_View (Prev_Orig)
3643 -- A class-wide precondition generates a test in which formals of
3644 -- the subprogram are replaced by actuals that came from source.
3645 -- In that case as well, the accessiblity comes from the actual.
3646 -- This is the one case in which there are references to formals
3647 -- outside of their subprogram.
3649 elsif Prev_Orig /= Prev
3650 and then Is_Entity_Name (Prev_Orig)
3651 and then Present (Entity (Prev_Orig))
3652 and then Is_Formal (Entity (Prev_Orig))
3653 and then not In_Open_Scopes (Scope (Entity (Prev_Orig)))
3657 -- If the actual is a formal of an enclosing subprogram it is
3658 -- the right entity, even if it is a rewriting. This happens
3659 -- when the call is within an inherited condition or predicate.
3661 elsif Is_Entity_Name (Actual)
3662 and then Is_Formal (Entity (Actual))
3663 and then In_Open_Scopes (Scope (Entity (Actual)))
3667 -- If the actual is an attribute reference that was expanded
3668 -- into a reference to an entity, then get accessibility level
3669 -- from that entity. AARM 6.1.1(27.d) says "... the implicit
3670 -- constant declaration defines the accessibility level of X'Old".
3672 elsif Nkind (Prev_Orig) = N_Attribute_Reference
3673 and then Attribute_Name (Prev_Orig) in Name_Old | Name_Loop_Entry
3674 and then Is_Entity_Name (Prev)
3675 and then Present (Entity (Prev))
3676 and then Is_Object (Entity (Prev))
3680 elsif Nkind (Prev_Orig) = N_Type_Conversion then
3681 Prev_Orig := Expression (Prev_Orig);
3684 -- Ada 2005 (AI-251): Thunks must propagate the extra actuals of
3685 -- accessibility levels.
3687 if Is_Thunk (Current_Scope) then
3689 Parm_Ent : Entity_Id;
3692 if Is_Controlling_Actual (Actual) then
3694 -- Find the corresponding actual of the thunk
3696 Parm_Ent := First_Entity (Current_Scope);
3697 for J in 2 .. Param_Count loop
3698 Next_Entity (Parm_Ent);
3701 -- Handle unchecked conversion of access types generated
3702 -- in thunks (cf. Expand_Interface_Thunk).
3704 elsif Is_Access_Type (Etype (Actual))
3705 and then Nkind (Actual) = N_Unchecked_Type_Conversion
3707 Parm_Ent := Entity (Expression (Actual));
3709 else pragma Assert (Is_Entity_Name (Actual));
3710 Parm_Ent := Entity (Actual);
3715 New_Occurrence_Of (Get_Accessibility (Parm_Ent), Loc),
3716 EF => Get_Accessibility (Formal));
3719 elsif Is_Entity_Name (Prev_Orig) then
3721 -- When passing an access parameter, or a renaming of an access
3722 -- parameter, as the actual to another access parameter we need
3723 -- to pass along the actual's own access level parameter. This
3724 -- is done if we are within the scope of the formal access
3725 -- parameter (if this is an inlined body the extra formal is
3728 if (Is_Formal (Entity (Prev_Orig))
3730 (Present (Renamed_Object (Entity (Prev_Orig)))
3732 Is_Entity_Name (Renamed_Object (Entity (Prev_Orig)))
3735 (Entity (Renamed_Object (Entity (Prev_Orig))))))
3736 and then Ekind (Etype (Prev_Orig)) = E_Anonymous_Access_Type
3737 and then In_Open_Scopes (Scope (Entity (Prev_Orig)))
3740 Parm_Ent : constant Entity_Id := Param_Entity (Prev_Orig);
3743 pragma Assert (Present (Parm_Ent));
3745 if Present (Get_Accessibility (Parm_Ent)) then
3749 (Get_Accessibility (Parm_Ent), Loc),
3750 EF => Get_Accessibility (Formal));
3752 -- If the actual access parameter does not have an
3753 -- associated extra formal providing its scope level,
3754 -- then treat the actual as having library-level
3760 Make_Integer_Literal (Loc,
3761 Intval => Scope_Depth (Standard_Standard)),
3762 EF => Get_Accessibility (Formal));
3766 -- The actual is a normal access value, so just pass the level
3767 -- of the actual's access type.
3771 (Expr => Dynamic_Accessibility_Level (Prev_Orig),
3772 EF => Get_Accessibility (Formal));
3775 -- If the actual is an access discriminant, then pass the level
3776 -- of the enclosing object (RM05-3.10.2(12.4/2)).
3778 elsif Nkind (Prev_Orig) = N_Selected_Component
3779 and then Ekind (Entity (Selector_Name (Prev_Orig))) =
3781 and then Ekind (Etype (Entity (Selector_Name (Prev_Orig)))) =
3782 E_Anonymous_Access_Type
3786 Make_Integer_Literal (Loc,
3787 Intval => Object_Access_Level (Prefix (Prev_Orig))),
3788 EF => Get_Accessibility (Formal));
3793 case Nkind (Prev_Orig) is
3794 when N_Attribute_Reference =>
3795 case Get_Attribute_Id (Attribute_Name (Prev_Orig)) is
3796 -- Ignore 'Result, 'Loop_Entry, and 'Old as they can
3797 -- be used to identify access objects and do not have
3798 -- an effect on accessibility level.
3800 when Attribute_Loop_Entry
3806 -- For X'Access, pass on the level of the prefix X
3808 when Attribute_Access =>
3810 -- Accessibility level of S'Access is that of A
3812 Prev_Orig := Prefix (Prev_Orig);
3814 -- If the expression is a view conversion, the
3815 -- accessibility level is that of the expression.
3817 if Nkind (Original_Node (Prev_Orig)) =
3820 Nkind (Expression (Original_Node (Prev_Orig))) =
3821 N_Explicit_Dereference
3824 Expression (Original_Node (Prev_Orig));
3827 -- Obtain the ultimate prefix so we can check for
3828 -- the case where we are taking 'Access of a
3829 -- component of an anonymous access formal - which
3830 -- would mean we need to pass said formal's
3831 -- corresponding extra accessibility formal.
3833 Prev_Ult := Ultimate_Prefix (Prev_Orig);
3835 if Is_Entity_Name (Prev_Ult)
3836 and then not Is_Type (Entity (Prev_Ult))
3839 (Entity (Prev_Ult)))
3845 (Entity (Prev_Ult)), Loc),
3846 EF => Get_Accessibility (Formal));
3848 -- Normal case, call Object_Access_Level. Note:
3849 -- should be Dynamic_Accessibility_Level ???
3854 Make_Integer_Literal (Loc,
3856 Object_Access_Level (Prev_Orig)),
3857 EF => Get_Accessibility (Formal));
3860 -- Treat the unchecked attributes as library-level
3862 when Attribute_Unchecked_Access
3863 | Attribute_Unrestricted_Access
3867 Make_Integer_Literal (Loc,
3868 Intval => Scope_Depth (Standard_Standard)),
3869 EF => Get_Accessibility (Formal));
3871 -- No other cases of attributes returning access
3872 -- values that can be passed to access parameters.
3875 raise Program_Error;
3879 -- For allocators we pass the level of the execution of the
3880 -- called subprogram, which is one greater than the current
3881 -- scope level. However, according to RM 3.10.2(14/3) this
3882 -- is wrong since for an anonymous allocator defining the
3883 -- value of an access parameter, the accessibility level is
3884 -- that of the innermost master of the call???
3889 Make_Integer_Literal (Loc,
3890 Intval => Scope_Depth (Current_Scope) + 1),
3891 EF => Get_Accessibility (Formal));
3893 -- For most other cases we simply pass the level of the
3894 -- actual's access type. The type is retrieved from
3895 -- Prev rather than Prev_Orig, because in some cases
3896 -- Prev_Orig denotes an original expression that has
3897 -- not been analyzed.
3899 -- However, when the actual is wrapped in a conditional
3900 -- expression we must add a local temporary to store the
3901 -- level at each branch, and, possibly, expand the call
3902 -- into an expression with actions.
3905 if Nkind (Prev) = N_Expression_With_Actions
3906 and then Nkind (Original_Node (Prev)) in
3907 N_If_Expression | N_Case_Expression
3911 pragma Warnings (Off, Decl);
3912 -- Suppress warning for the final removal loop
3918 procedure Insert_Level_Assign (Branch : Node_Id);
3919 -- Recursivly add assignment of the level temporary
3920 -- on each branch while moving through nested
3921 -- conditional expressions.
3923 -------------------------
3924 -- Insert_Level_Assign --
3925 -------------------------
3927 procedure Insert_Level_Assign (Branch : Node_Id) is
3929 procedure Expand_Branch (Assn : Node_Id);
3930 -- Perform expansion or iterate further within
3931 -- nested conditionals.
3937 procedure Expand_Branch (Assn : Node_Id) is
3939 pragma Assert (Nkind (Assn) =
3940 N_Assignment_Statement);
3942 -- There are more nested conditional
3943 -- expressions so we must go deeper.
3945 if Nkind (Expression (Assn)) =
3946 N_Expression_With_Actions
3949 (Original_Node (Expression (Assn))) in
3950 N_Case_Expression | N_If_Expression
3952 Insert_Level_Assign (Expression (Assn));
3954 -- Add the level assignment
3957 Insert_Before_And_Analyze (Assn,
3958 Make_Assignment_Statement (Loc,
3963 Dynamic_Accessibility_Level
3964 (Expression (Assn))));
3971 -- Start of processing for Insert_Level_Assign
3974 -- Examine further nested condtionals
3976 pragma Assert (Nkind (Branch) =
3977 N_Expression_With_Actions);
3979 -- Find the relevant statement in the actions
3981 Cond := First (Actions (Branch));
3983 exit when Nkind (Cond) in
3984 N_Case_Statement | N_If_Statement;
3989 raise Program_Error;
3993 -- Iterate through if expression branches
3995 if Nkind (Cond) = N_If_Statement then
3996 Expand_Branch (Last (Then_Statements (Cond)));
3997 Expand_Branch (Last (Else_Statements (Cond)));
3999 -- Iterate through case alternatives
4001 elsif Nkind (Cond) = N_Case_Statement then
4003 Alt := First (Alternatives (Cond));
4004 while Present (Alt) loop
4005 Expand_Branch (Last (Statements (Alt)));
4010 end Insert_Level_Assign;
4012 -- Start of processing for cond expression case
4015 -- Create declaration of a temporary to store the
4016 -- accessibility level of each branch of the
4017 -- conditional expression.
4019 Lvl := Make_Temporary (Loc, 'L');
4021 Make_Object_Declaration (Loc,
4022 Defining_Identifier => Lvl,
4023 Object_Definition =>
4024 New_Occurrence_Of (Standard_Natural, Loc));
4026 -- Install the declaration and perform necessary
4027 -- expansion if we are dealing with a function
4030 if Nkind (Call_Node) = N_Procedure_Call_Statement
4036 -- If_Exp_Res : Typ;
4038 -- Lvl := 0; -- Access level
4039 -- If_Exp_Res := Exp;
4041 -- in If_Exp_Res end;},
4046 Insert_Before_And_Analyze (Call_Node, Decl);
4048 -- A function call must be transformed into an
4049 -- expression with actions.
4058 -- Lvl := 0; -- Access level
4059 -- If_Exp_Res := Exp;
4060 -- in If_Exp_Res end;},
4066 Res := Make_Temporary (Loc, 'R');
4067 Typ := Etype (Call_Node);
4068 Temp := Relocate_Node (Call_Node);
4070 -- Perform the rewrite with the dummy
4074 Make_Expression_With_Actions (Loc,
4075 Expression => New_Occurrence_Of (Res, Loc),
4076 Actions => New_List (
4079 Make_Object_Declaration (Loc,
4080 Defining_Identifier => Res,
4081 Object_Definition =>
4082 New_Occurrence_Of (Typ, Loc)))));
4084 -- Analyze the expression with the dummy
4086 Analyze_And_Resolve (Call_Node, Typ);
4088 -- Properly set the expression and move our view
4091 Set_Expression (Call_Node, Relocate_Node (Temp));
4092 Call_Node := Expression (Call_Node);
4094 -- Remove the declaration of the dummy and the
4095 -- subsequent actions its analysis has created.
4097 while Present (Remove_Next (Decl)) loop
4102 -- Decorate the conditional expression with
4103 -- assignments to our level temporary.
4105 Insert_Level_Assign (Prev);
4107 -- Make our level temporary the passed actual
4110 (Expr => New_Occurrence_Of (Lvl, Loc),
4111 EF => Get_Accessibility (Formal));
4114 -- General case uncomplicated by conditional expressions
4118 (Expr => Dynamic_Accessibility_Level (Prev),
4119 EF => Get_Accessibility (Formal));
4125 -- Perform the check of 4.6(49) that prevents a null value from being
4126 -- passed as an actual to an access parameter. Note that the check
4127 -- is elided in the common cases of passing an access attribute or
4128 -- access parameter as an actual. Also, we currently don't enforce
4129 -- this check for expander-generated actuals and when -gnatdj is set.
4131 if Ada_Version >= Ada_2005 then
4133 -- Ada 2005 (AI-231): Check null-excluding access types. Note that
4134 -- the intent of 6.4.1(13) is that null-exclusion checks should
4135 -- not be done for 'out' parameters, even though it refers only
4136 -- to constraint checks, and a null_exclusion is not a constraint.
4137 -- Note that AI05-0196-1 corrects this mistake in the RM.
4139 if Is_Access_Type (Etype (Formal))
4140 and then Can_Never_Be_Null (Etype (Formal))
4141 and then Ekind (Formal) /= E_Out_Parameter
4142 and then Nkind (Prev) /= N_Raise_Constraint_Error
4143 and then (Known_Null (Prev)
4144 or else not Can_Never_Be_Null (Etype (Prev)))
4146 Install_Null_Excluding_Check (Prev);
4149 -- Ada_Version < Ada_2005
4152 if Ekind (Etype (Formal)) /= E_Anonymous_Access_Type
4153 or else Access_Checks_Suppressed (Subp)
4157 elsif Debug_Flag_J then
4160 elsif not Comes_From_Source (Prev) then
4163 elsif Is_Entity_Name (Prev)
4164 and then Ekind (Etype (Prev)) = E_Anonymous_Access_Type
4168 elsif Nkind (Prev) in N_Allocator | N_Attribute_Reference then
4172 Install_Null_Excluding_Check (Prev);
4176 -- Perform appropriate validity checks on parameters that
4179 if Validity_Checks_On then
4180 if (Ekind (Formal) = E_In_Parameter
4181 and then Validity_Check_In_Params)
4183 (Ekind (Formal) = E_In_Out_Parameter
4184 and then Validity_Check_In_Out_Params)
4186 -- If the actual is an indexed component of a packed type (or
4187 -- is an indexed or selected component whose prefix recursively
4188 -- meets this condition), it has not been expanded yet. It will
4189 -- be copied in the validity code that follows, and has to be
4190 -- expanded appropriately, so reanalyze it.
4192 -- What we do is just to unset analyzed bits on prefixes till
4193 -- we reach something that does not have a prefix.
4200 while Nkind (Nod) in
4201 N_Indexed_Component | N_Selected_Component
4203 Set_Analyzed (Nod, False);
4204 Nod := Prefix (Nod);
4208 Ensure_Valid (Actual);
4212 -- For IN OUT and OUT parameters, ensure that subscripts are valid
4213 -- since this is a left side reference. We only do this for calls
4214 -- from the source program since we assume that compiler generated
4215 -- calls explicitly generate any required checks. We also need it
4216 -- only if we are doing standard validity checks, since clearly it is
4217 -- not needed if validity checks are off, and in subscript validity
4218 -- checking mode, all indexed components are checked with a call
4219 -- directly from Expand_N_Indexed_Component.
4221 if Comes_From_Source (Call_Node)
4222 and then Ekind (Formal) /= E_In_Parameter
4223 and then Validity_Checks_On
4224 and then Validity_Check_Default
4225 and then not Validity_Check_Subscripts
4227 Check_Valid_Lvalue_Subscripts (Actual);
4230 -- Mark any scalar OUT parameter that is a simple variable as no
4231 -- longer known to be valid (unless the type is always valid). This
4232 -- reflects the fact that if an OUT parameter is never set in a
4233 -- procedure, then it can become invalid on the procedure return.
4235 if Ekind (Formal) = E_Out_Parameter
4236 and then Is_Entity_Name (Actual)
4237 and then Ekind (Entity (Actual)) = E_Variable
4238 and then not Is_Known_Valid (Etype (Actual))
4240 Set_Is_Known_Valid (Entity (Actual), False);
4243 -- For an OUT or IN OUT parameter, if the actual is an entity, then
4244 -- clear current values, since they can be clobbered. We are probably
4245 -- doing this in more places than we need to, but better safe than
4246 -- sorry when it comes to retaining bad current values.
4248 if Ekind (Formal) /= E_In_Parameter
4249 and then Is_Entity_Name (Actual)
4250 and then Present (Entity (Actual))
4253 Ent : constant Entity_Id := Entity (Actual);
4257 -- For an OUT or IN OUT parameter that is an assignable entity,
4258 -- we do not want to clobber the Last_Assignment field, since
4259 -- if it is set, it was precisely because it is indeed an OUT
4260 -- or IN OUT parameter. We do reset the Is_Known_Valid flag
4261 -- since the subprogram could have returned in invalid value.
4263 if Is_Assignable (Ent) then
4264 Sav := Last_Assignment (Ent);
4265 Kill_Current_Values (Ent);
4266 Set_Last_Assignment (Ent, Sav);
4267 Set_Is_Known_Valid (Ent, False);
4268 Set_Is_True_Constant (Ent, False);
4270 -- For all other cases, just kill the current values
4273 Kill_Current_Values (Ent);
4278 -- If the formal is class wide and the actual is an aggregate, force
4279 -- evaluation so that the back end who does not know about class-wide
4280 -- type, does not generate a temporary of the wrong size.
4282 if not Is_Class_Wide_Type (Etype (Formal)) then
4285 elsif Nkind (Actual) = N_Aggregate
4286 or else (Nkind (Actual) = N_Qualified_Expression
4287 and then Nkind (Expression (Actual)) = N_Aggregate)
4289 Force_Evaluation (Actual);
4292 -- In a remote call, if the formal is of a class-wide type, check
4293 -- that the actual meets the requirements described in E.4(18).
4295 if Remote and then Is_Class_Wide_Type (Etype (Formal)) then
4296 Insert_Action (Actual,
4297 Make_Transportable_Check (Loc,
4298 Duplicate_Subexpr_Move_Checks (Actual)));
4301 -- Perform invariant checks for all intermediate types in a view
4302 -- conversion after successful return from a call that passes the
4303 -- view conversion as an IN OUT or OUT parameter (RM 7.3.2 (12/3,
4304 -- 13/3, 14/3)). Consider only source conversion in order to avoid
4305 -- generating spurious checks on complex expansion such as object
4306 -- initialization through an extension aggregate.
4308 if Comes_From_Source (Call_Node)
4309 and then Ekind (Formal) /= E_In_Parameter
4310 and then Nkind (Actual) = N_Type_Conversion
4312 Add_View_Conversion_Invariants (Formal, Actual);
4315 -- Generating C the initialization of an allocator is performed by
4316 -- means of individual statements, and hence it must be done before
4319 if Modify_Tree_For_C
4320 and then Nkind (Actual) = N_Allocator
4321 and then Nkind (Expression (Actual)) = N_Qualified_Expression
4323 Remove_Side_Effects (Actual);
4326 -- This label is required when skipping extra actual generation for
4327 -- Unchecked_Union parameters.
4329 <<Skip_Extra_Actual_Generation>>
4331 Param_Count := Param_Count + 1;
4332 Next_Actual (Actual);
4333 Next_Formal (Formal);
4336 -- If we are calling an Ada 2012 function which needs to have the
4337 -- "accessibility level determined by the point of call" (AI05-0234)
4338 -- passed in to it, then pass it in.
4340 if Ekind (Subp) in E_Function | E_Operator | E_Subprogram_Type
4342 Present (Extra_Accessibility_Of_Result (Ultimate_Alias (Subp)))
4345 Ancestor : Node_Id := Parent (Call_Node);
4346 Level : Node_Id := Empty;
4347 Defer : Boolean := False;
4350 -- Unimplemented: if Subp returns an anonymous access type, then
4352 -- a) if the call is the operand of an explict conversion, then
4353 -- the target type of the conversion (a named access type)
4354 -- determines the accessibility level pass in;
4356 -- b) if the call defines an access discriminant of an object
4357 -- (e.g., the discriminant of an object being created by an
4358 -- allocator, or the discriminant of a function result),
4359 -- then the accessibility level to pass in is that of the
4360 -- discriminated object being initialized).
4364 while Nkind (Ancestor) = N_Qualified_Expression
4366 Ancestor := Parent (Ancestor);
4369 case Nkind (Ancestor) is
4372 -- At this point, we'd like to assign
4374 -- Level := Dynamic_Accessibility_Level (Ancestor);
4376 -- but Etype of Ancestor may not have been set yet,
4377 -- so that doesn't work.
4379 -- Handle this later in Expand_Allocator_Expression.
4383 when N_Object_Declaration
4384 | N_Object_Renaming_Declaration
4387 Def_Id : constant Entity_Id :=
4388 Defining_Identifier (Ancestor);
4391 if Is_Return_Object (Def_Id) then
4392 if Present (Extra_Accessibility_Of_Result
4393 (Return_Applies_To (Scope (Def_Id))))
4395 -- Pass along value that was passed in if the
4396 -- routine we are returning from also has an
4397 -- Accessibility_Of_Result formal.
4401 (Extra_Accessibility_Of_Result
4402 (Return_Applies_To (Scope (Def_Id))), Loc);
4406 Make_Integer_Literal (Loc,
4407 Intval => Object_Access_Level (Def_Id));
4411 when N_Simple_Return_Statement =>
4412 if Present (Extra_Accessibility_Of_Result
4414 (Return_Statement_Entity (Ancestor))))
4416 -- Pass along value that was passed in if the returned
4417 -- routine also has an Accessibility_Of_Result formal.
4421 (Extra_Accessibility_Of_Result
4423 (Return_Statement_Entity (Ancestor))), Loc);
4431 if not Present (Level) then
4433 -- The "innermost master that evaluates the function call".
4435 -- ??? - Should we use Integer'Last here instead in order
4436 -- to deal with (some of) the problems associated with
4437 -- calls to subps whose enclosing scope is unknown (e.g.,
4438 -- Anon_Access_To_Subp_Param.all)?
4441 Make_Integer_Literal (Loc,
4442 Intval => Scope_Depth (Current_Scope) + 1);
4448 Extra_Accessibility_Of_Result (Ultimate_Alias (Subp)));
4453 -- If we are expanding the RHS of an assignment we need to check if tag
4454 -- propagation is needed. You might expect this processing to be in
4455 -- Analyze_Assignment but has to be done earlier (bottom-up) because the
4456 -- assignment might be transformed to a declaration for an unconstrained
4457 -- value if the expression is classwide.
4459 if Nkind (Call_Node) = N_Function_Call
4460 and then Is_Tag_Indeterminate (Call_Node)
4461 and then Is_Entity_Name (Name (Call_Node))
4464 Ass : Node_Id := Empty;
4467 if Nkind (Parent (Call_Node)) = N_Assignment_Statement then
4468 Ass := Parent (Call_Node);
4470 elsif Nkind (Parent (Call_Node)) = N_Qualified_Expression
4471 and then Nkind (Parent (Parent (Call_Node))) =
4472 N_Assignment_Statement
4474 Ass := Parent (Parent (Call_Node));
4476 elsif Nkind (Parent (Call_Node)) = N_Explicit_Dereference
4477 and then Nkind (Parent (Parent (Call_Node))) =
4478 N_Assignment_Statement
4480 Ass := Parent (Parent (Call_Node));
4484 and then Is_Class_Wide_Type (Etype (Name (Ass)))
4486 -- Move the error messages below to sem???
4488 if Is_Access_Type (Etype (Call_Node)) then
4489 if Designated_Type (Etype (Call_Node)) /=
4490 Root_Type (Etype (Name (Ass)))
4493 ("tag-indeterminate expression must have designated "
4494 & "type& (RM 5.2 (6))",
4495 Call_Node, Root_Type (Etype (Name (Ass))));
4497 Propagate_Tag (Name (Ass), Call_Node);
4500 elsif Etype (Call_Node) /= Root_Type (Etype (Name (Ass))) then
4502 ("tag-indeterminate expression must have type & "
4504 Call_Node, Root_Type (Etype (Name (Ass))));
4507 Propagate_Tag (Name (Ass), Call_Node);
4510 -- The call will be rewritten as a dispatching call, and
4511 -- expanded as such.
4518 -- Ada 2005 (AI-251): If some formal is a class-wide interface, expand
4519 -- it to point to the correct secondary virtual table
4521 if Nkind (Call_Node) in N_Subprogram_Call
4522 and then CW_Interface_Formals_Present
4524 Expand_Interface_Actuals (Call_Node);
4527 -- Deals with Dispatch_Call if we still have a call, before expanding
4528 -- extra actuals since this will be done on the re-analysis of the
4529 -- dispatching call. Note that we do not try to shorten the actual list
4530 -- for a dispatching call, it would not make sense to do so. Expansion
4531 -- of dispatching calls is suppressed for VM targets, because the VM
4532 -- back-ends directly handle the generation of dispatching calls and
4533 -- would have to undo any expansion to an indirect call.
4535 if Nkind (Call_Node) in N_Subprogram_Call
4536 and then Present (Controlling_Argument (Call_Node))
4539 Call_Typ : constant Entity_Id := Etype (Call_Node);
4540 Typ : constant Entity_Id := Find_Dispatching_Type (Subp);
4541 Eq_Prim_Op : Entity_Id := Empty;
4544 Prev_Call : Node_Id;
4547 if not Is_Limited_Type (Typ) then
4548 Eq_Prim_Op := Find_Prim_Op (Typ, Name_Op_Eq);
4551 if Tagged_Type_Expansion then
4552 Expand_Dispatching_Call (Call_Node);
4554 -- The following return is worrisome. Is it really OK to skip
4555 -- all remaining processing in this procedure ???
4562 Apply_Tag_Checks (Call_Node);
4564 -- If this is a dispatching "=", we must first compare the
4565 -- tags so we generate: x.tag = y.tag and then x = y
4567 if Subp = Eq_Prim_Op then
4569 -- Mark the node as analyzed to avoid reanalyzing this
4570 -- dispatching call (which would cause a never-ending loop)
4572 Prev_Call := Relocate_Node (Call_Node);
4573 Set_Analyzed (Prev_Call);
4575 Param := First_Actual (Call_Node);
4581 Make_Selected_Component (Loc,
4582 Prefix => New_Value (Param),
4585 (First_Tag_Component (Typ), Loc)),
4588 Make_Selected_Component (Loc,
4590 Unchecked_Convert_To (Typ,
4591 New_Value (Next_Actual (Param))),
4594 (First_Tag_Component (Typ), Loc))),
4595 Right_Opnd => Prev_Call);
4597 Rewrite (Call_Node, New_Call);
4600 (Call_Node, Call_Typ, Suppress => All_Checks);
4603 -- Expansion of a dispatching call results in an indirect call,
4604 -- which in turn causes current values to be killed (see
4605 -- Resolve_Call), so on VM targets we do the call here to
4606 -- ensure consistent warnings between VM and non-VM targets.
4608 Kill_Current_Values;
4611 -- If this is a dispatching "=" then we must update the reference
4612 -- to the call node because we generated:
4613 -- x.tag = y.tag and then x = y
4615 if Subp = Eq_Prim_Op then
4616 Call_Node := Right_Opnd (Call_Node);
4621 -- Similarly, expand calls to RCI subprograms on which pragma
4622 -- All_Calls_Remote applies. The rewriting will be reanalyzed
4623 -- later. Do this only when the call comes from source since we
4624 -- do not want such a rewriting to occur in expanded code.
4626 if Is_All_Remote_Call (Call_Node) then
4627 Expand_All_Calls_Remote_Subprogram_Call (Call_Node);
4629 -- Similarly, do not add extra actuals for an entry call whose entity
4630 -- is a protected procedure, or for an internal protected subprogram
4631 -- call, because it will be rewritten as a protected subprogram call
4632 -- and reanalyzed (see Expand_Protected_Subprogram_Call).
4634 elsif Is_Protected_Type (Scope (Subp))
4635 and then Ekind (Subp) in E_Procedure | E_Function
4639 -- During that loop we gathered the extra actuals (the ones that
4640 -- correspond to Extra_Formals), so now they can be appended.
4643 while Is_Non_Empty_List (Extra_Actuals) loop
4644 Add_Actual_Parameter (Remove_Head (Extra_Actuals));
4648 -- At this point we have all the actuals, so this is the point at which
4649 -- the various expansion activities for actuals is carried out.
4651 Expand_Actuals (Call_Node, Subp, Post_Call);
4653 -- Verify that the actuals do not share storage. This check must be done
4654 -- on the caller side rather that inside the subprogram to avoid issues
4655 -- of parameter passing.
4657 if Check_Aliasing_Of_Parameters then
4658 Apply_Parameter_Aliasing_Checks (Call_Node, Subp);
4661 -- If the subprogram is a renaming, or if it is inherited, replace it in
4662 -- the call with the name of the actual subprogram being called. If this
4663 -- is a dispatching call, the run-time decides what to call. The Alias
4664 -- attribute does not apply to entries.
4666 if Nkind (Call_Node) /= N_Entry_Call_Statement
4667 and then No (Controlling_Argument (Call_Node))
4668 and then Present (Parent_Subp)
4669 and then not Is_Direct_Deep_Call (Subp)
4671 if Present (Inherited_From_Formal (Subp)) then
4672 Parent_Subp := Inherited_From_Formal (Subp);
4674 Parent_Subp := Ultimate_Alias (Parent_Subp);
4677 -- The below setting of Entity is suspect, see F109-018 discussion???
4679 Set_Entity (Name (Call_Node), Parent_Subp);
4681 -- Move this check to sem???
4683 if Is_Abstract_Subprogram (Parent_Subp)
4684 and then not In_Instance
4687 ("cannot call abstract subprogram &!",
4688 Name (Call_Node), Parent_Subp);
4691 -- Inspect all formals of derived subprogram Subp. Compare parameter
4692 -- types with the parent subprogram and check whether an actual may
4693 -- need a type conversion to the corresponding formal of the parent
4696 -- Not clear whether intrinsic subprograms need such conversions. ???
4698 if not Is_Intrinsic_Subprogram (Parent_Subp)
4699 or else Is_Generic_Instance (Parent_Subp)
4702 procedure Convert (Act : Node_Id; Typ : Entity_Id);
4703 -- Rewrite node Act as a type conversion of Act to Typ. Analyze
4704 -- and resolve the newly generated construct.
4710 procedure Convert (Act : Node_Id; Typ : Entity_Id) is
4712 Rewrite (Act, OK_Convert_To (Typ, Act));
4713 Analyze_And_Resolve (Act, Typ);
4718 Actual_Typ : Entity_Id;
4719 Formal_Typ : Entity_Id;
4720 Parent_Typ : Entity_Id;
4723 Actual := First_Actual (Call_Node);
4724 Formal := First_Formal (Subp);
4725 Parent_Formal := First_Formal (Parent_Subp);
4726 while Present (Formal) loop
4727 Actual_Typ := Etype (Actual);
4728 Formal_Typ := Etype (Formal);
4729 Parent_Typ := Etype (Parent_Formal);
4731 -- For an IN parameter of a scalar type, the derived formal
4732 -- type and parent formal type differ, and the parent formal
4733 -- type and actual type do not match statically.
4735 if Is_Scalar_Type (Formal_Typ)
4736 and then Ekind (Formal) = E_In_Parameter
4737 and then Formal_Typ /= Parent_Typ
4739 not Subtypes_Statically_Match (Parent_Typ, Actual_Typ)
4740 and then not Raises_Constraint_Error (Actual)
4742 Convert (Actual, Parent_Typ);
4744 -- For access types, the parent formal type and actual type
4747 elsif Is_Access_Type (Formal_Typ)
4748 and then Base_Type (Parent_Typ) /= Base_Type (Actual_Typ)
4750 if Ekind (Formal) /= E_In_Parameter then
4751 Convert (Actual, Parent_Typ);
4753 elsif Ekind (Parent_Typ) = E_Anonymous_Access_Type
4754 and then Designated_Type (Parent_Typ) /=
4755 Designated_Type (Actual_Typ)
4756 and then not Is_Controlling_Formal (Formal)
4758 -- This unchecked conversion is not necessary unless
4759 -- inlining is enabled, because in that case the type
4760 -- mismatch may become visible in the body about to be
4764 Unchecked_Convert_To (Parent_Typ, Actual));
4765 Analyze_And_Resolve (Actual, Parent_Typ);
4768 -- If there is a change of representation, then generate a
4769 -- warning, and do the change of representation.
4771 elsif not Has_Compatible_Representation
4772 (Target_Type => Formal_Typ,
4773 Operand_Type => Parent_Typ)
4776 ("??change of representation required", Actual);
4777 Convert (Actual, Parent_Typ);
4779 -- For array and record types, the parent formal type and
4780 -- derived formal type have different sizes or pragma Pack
4783 elsif ((Is_Array_Type (Formal_Typ)
4784 and then Is_Array_Type (Parent_Typ))
4786 (Is_Record_Type (Formal_Typ)
4787 and then Is_Record_Type (Parent_Typ)))
4789 (Esize (Formal_Typ) /= Esize (Parent_Typ)
4790 or else Has_Pragma_Pack (Formal_Typ) /=
4791 Has_Pragma_Pack (Parent_Typ))
4793 Convert (Actual, Parent_Typ);
4796 Next_Actual (Actual);
4797 Next_Formal (Formal);
4798 Next_Formal (Parent_Formal);
4804 Subp := Parent_Subp;
4807 -- Deal with case where call is an explicit dereference
4809 if Nkind (Name (Call_Node)) = N_Explicit_Dereference then
4811 -- Handle case of access to protected subprogram type
4813 if Is_Access_Protected_Subprogram_Type
4814 (Base_Type (Etype (Prefix (Name (Call_Node)))))
4816 -- If this is a call through an access to protected operation, the
4817 -- prefix has the form (object'address, operation'access). Rewrite
4818 -- as a for other protected calls: the object is the 1st parameter
4819 -- of the list of actuals.
4826 Ptr : constant Node_Id := Prefix (Name (Call_Node));
4828 T : constant Entity_Id :=
4829 Equivalent_Type (Base_Type (Etype (Ptr)));
4831 D_T : constant Entity_Id :=
4832 Designated_Type (Base_Type (Etype (Ptr)));
4836 Make_Selected_Component (Loc,
4837 Prefix => Unchecked_Convert_To (T, Ptr),
4839 New_Occurrence_Of (First_Entity (T), Loc));
4842 Make_Selected_Component (Loc,
4843 Prefix => Unchecked_Convert_To (T, Ptr),
4845 New_Occurrence_Of (Next_Entity (First_Entity (T)), Loc));
4848 Make_Explicit_Dereference (Loc,
4851 if Present (Parameter_Associations (Call_Node)) then
4852 Parm := Parameter_Associations (Call_Node);
4857 Prepend (Obj, Parm);
4859 if Etype (D_T) = Standard_Void_Type then
4861 Make_Procedure_Call_Statement (Loc,
4863 Parameter_Associations => Parm);
4866 Make_Function_Call (Loc,
4868 Parameter_Associations => Parm);
4871 Set_First_Named_Actual (Call, First_Named_Actual (Call_Node));
4872 Set_Etype (Call, Etype (D_T));
4874 -- We do not re-analyze the call to avoid infinite recursion.
4875 -- We analyze separately the prefix and the object, and set
4876 -- the checks on the prefix that would otherwise be emitted
4877 -- when resolving a call.
4879 Rewrite (Call_Node, Call);
4881 Apply_Access_Check (Nam);
4888 -- If this is a call to an intrinsic subprogram, then perform the
4889 -- appropriate expansion to the corresponding tree node and we
4890 -- are all done (since after that the call is gone).
4892 -- In the case where the intrinsic is to be processed by the back end,
4893 -- the call to Expand_Intrinsic_Call will do nothing, which is fine,
4894 -- since the idea in this case is to pass the call unchanged. If the
4895 -- intrinsic is an inherited unchecked conversion, and the derived type
4896 -- is the target type of the conversion, we must retain it as the return
4897 -- type of the expression. Otherwise the expansion below, which uses the
4898 -- parent operation, will yield the wrong type.
4900 if Is_Intrinsic_Subprogram (Subp) then
4901 Expand_Intrinsic_Call (Call_Node, Subp);
4903 if Nkind (Call_Node) = N_Unchecked_Type_Conversion
4904 and then Parent_Subp /= Orig_Subp
4905 and then Etype (Parent_Subp) /= Etype (Orig_Subp)
4907 Set_Etype (Call_Node, Etype (Orig_Subp));
4913 if Ekind (Subp) in E_Function | E_Procedure then
4915 -- We perform a simple optimization on calls for To_Address by
4916 -- replacing them with an unchecked conversion. Not only is this
4917 -- efficient, but it also avoids order of elaboration problems when
4918 -- address clauses are inlined (address expression elaborated at the
4921 -- We perform this optimization regardless of whether we are in the
4922 -- main unit or in a unit in the context of the main unit, to ensure
4923 -- that the generated tree is the same in both cases, for CodePeer
4926 if Is_RTE (Subp, RE_To_Address) then
4928 Unchecked_Convert_To
4929 (RTE (RE_Address), Relocate_Node (First_Actual (Call_Node))));
4932 -- A call to a null procedure is replaced by a null statement, but we
4933 -- are not allowed to ignore possible side effects of the call, so we
4934 -- make sure that actuals are evaluated.
4935 -- We also suppress this optimization for GNATCoverage.
4937 elsif Is_Null_Procedure (Subp)
4938 and then not Opt.Suppress_Control_Flow_Optimizations
4940 Actual := First_Actual (Call_Node);
4941 while Present (Actual) loop
4942 Remove_Side_Effects (Actual);
4943 Next_Actual (Actual);
4946 Rewrite (Call_Node, Make_Null_Statement (Loc));
4950 -- Handle inlining. No action needed if the subprogram is not inlined
4952 if not Is_Inlined (Subp) then
4955 -- Front-end inlining of expression functions (performed also when
4956 -- back-end inlining is enabled).
4958 elsif Is_Inlinable_Expression_Function (Subp) then
4960 (Call_Node, New_Copy (Expression_Of_Expression_Function (Subp)));
4961 Analyze (Call_Node);
4964 -- Handle front-end inlining
4966 elsif not Back_End_Inlining then
4967 Inlined_Subprogram : declare
4969 Must_Inline : Boolean := False;
4970 Spec : constant Node_Id := Unit_Declaration_Node (Subp);
4973 -- Verify that the body to inline has already been seen, and
4974 -- that if the body is in the current unit the inlining does
4975 -- not occur earlier. This avoids order-of-elaboration problems
4978 -- This should be documented in sinfo/einfo ???
4981 or else Nkind (Spec) /= N_Subprogram_Declaration
4982 or else No (Body_To_Inline (Spec))
4984 Must_Inline := False;
4986 -- If this an inherited function that returns a private type,
4987 -- do not inline if the full view is an unconstrained array,
4988 -- because such calls cannot be inlined.
4990 elsif Present (Orig_Subp)
4991 and then Is_Array_Type (Etype (Orig_Subp))
4992 and then not Is_Constrained (Etype (Orig_Subp))
4994 Must_Inline := False;
4996 elsif In_Unfrozen_Instance (Scope (Subp)) then
4997 Must_Inline := False;
5000 Bod := Body_To_Inline (Spec);
5002 if (In_Extended_Main_Code_Unit (Call_Node)
5003 or else In_Extended_Main_Code_Unit (Parent (Call_Node))
5004 or else Has_Pragma_Inline_Always (Subp))
5005 and then (not In_Same_Extended_Unit (Sloc (Bod), Loc)
5007 Earlier_In_Extended_Unit (Sloc (Bod), Loc))
5009 Must_Inline := True;
5011 -- If we are compiling a package body that is not the main
5012 -- unit, it must be for inlining/instantiation purposes,
5013 -- in which case we inline the call to insure that the same
5014 -- temporaries are generated when compiling the body by
5015 -- itself. Otherwise link errors can occur.
5017 -- If the function being called is itself in the main unit,
5018 -- we cannot inline, because there is a risk of double
5019 -- elaboration and/or circularity: the inlining can make
5020 -- visible a private entity in the body of the main unit,
5021 -- that gigi will see before its sees its proper definition.
5023 elsif not In_Extended_Main_Code_Unit (Call_Node)
5024 and then In_Package_Body
5026 Must_Inline := not In_Extended_Main_Source_Unit (Subp);
5028 -- Inline calls to _postconditions when generating C code
5030 elsif Modify_Tree_For_C
5031 and then In_Same_Extended_Unit (Sloc (Bod), Loc)
5032 and then Chars (Name (Call_Node)) = Name_uPostconditions
5034 Must_Inline := True;
5039 Expand_Inlined_Call (Call_Node, Subp, Orig_Subp);
5042 -- Let the back end handle it
5044 Add_Inlined_Body (Subp, Call_Node);
5046 if Front_End_Inlining
5047 and then Nkind (Spec) = N_Subprogram_Declaration
5048 and then In_Extended_Main_Code_Unit (Call_Node)
5049 and then No (Body_To_Inline (Spec))
5050 and then not Has_Completion (Subp)
5051 and then In_Same_Extended_Unit (Sloc (Spec), Loc)
5054 ("cannot inline& (body not seen yet)?",
5058 end Inlined_Subprogram;
5060 -- Front-end expansion of simple functions returning unconstrained
5061 -- types (see Check_And_Split_Unconstrained_Function). Note that the
5062 -- case of a simple renaming (Body_To_Inline in N_Entity below, see
5063 -- also Build_Renamed_Body) cannot be expanded here because this may
5064 -- give rise to order-of-elaboration issues for the types of the
5065 -- parameters of the subprogram, if any.
5067 elsif Present (Unit_Declaration_Node (Subp))
5068 and then Nkind (Unit_Declaration_Node (Subp)) =
5069 N_Subprogram_Declaration
5070 and then Present (Body_To_Inline (Unit_Declaration_Node (Subp)))
5072 Nkind (Body_To_Inline (Unit_Declaration_Node (Subp))) not in
5075 Expand_Inlined_Call (Call_Node, Subp, Orig_Subp);
5077 -- Back-end inlining either if optimization is enabled or the call is
5078 -- required to be inlined.
5080 elsif Optimization_Level > 0
5081 or else Has_Pragma_Inline_Always (Subp)
5083 Add_Inlined_Body (Subp, Call_Node);
5087 -- Check for protected subprogram. This is either an intra-object call,
5088 -- or a protected function call. Protected procedure calls are rewritten
5089 -- as entry calls and handled accordingly.
5091 -- In Ada 2005, this may be an indirect call to an access parameter that
5092 -- is an access_to_subprogram. In that case the anonymous type has a
5093 -- scope that is a protected operation, but the call is a regular one.
5094 -- In either case do not expand call if subprogram is eliminated.
5096 Scop := Scope (Subp);
5098 if Nkind (Call_Node) /= N_Entry_Call_Statement
5099 and then Is_Protected_Type (Scop)
5100 and then Ekind (Subp) /= E_Subprogram_Type
5101 and then not Is_Eliminated (Subp)
5103 -- If the call is an internal one, it is rewritten as a call to the
5104 -- corresponding unprotected subprogram.
5106 Expand_Protected_Subprogram_Call (Call_Node, Subp, Scop);
5109 -- Functions returning controlled objects need special attention. If
5110 -- the return type is limited, then the context is initialization and
5111 -- different processing applies. If the call is to a protected function,
5112 -- the expansion above will call Expand_Call recursively. Otherwise the
5113 -- function call is transformed into a temporary which obtains the
5114 -- result from the secondary stack.
5116 if Needs_Finalization (Etype (Subp)) then
5117 if not Is_Build_In_Place_Function_Call (Call_Node)
5119 (No (First_Formal (Subp))
5121 not Is_Concurrent_Record_Type (Etype (First_Formal (Subp))))
5123 Expand_Ctrl_Function_Call (Call_Node);
5125 -- Build-in-place function calls which appear in anonymous contexts
5126 -- need a transient scope to ensure the proper finalization of the
5127 -- intermediate result after its use.
5129 elsif Is_Build_In_Place_Function_Call (Call_Node)
5130 and then Nkind (Parent (Unqual_Conv (Call_Node))) in
5131 N_Attribute_Reference
5133 | N_Indexed_Component
5134 | N_Object_Renaming_Declaration
5135 | N_Procedure_Call_Statement
5136 | N_Selected_Component
5139 (Ekind (Current_Scope) /= E_Loop
5140 or else Nkind (Parent (Call_Node)) /= N_Function_Call
5141 or else not Is_Build_In_Place_Function_Call
5142 (Parent (Call_Node)))
5144 Establish_Transient_Scope (Call_Node, Manage_Sec_Stack => True);
5147 end Expand_Call_Helper;
5149 -------------------------------
5150 -- Expand_Ctrl_Function_Call --
5151 -------------------------------
5153 procedure Expand_Ctrl_Function_Call (N : Node_Id) is
5154 function Is_Element_Reference (N : Node_Id) return Boolean;
5155 -- Determine whether node N denotes a reference to an Ada 2012 container
5158 --------------------------
5159 -- Is_Element_Reference --
5160 --------------------------
5162 function Is_Element_Reference (N : Node_Id) return Boolean is
5163 Ref : constant Node_Id := Original_Node (N);
5166 -- Analysis marks an element reference by setting the generalized
5167 -- indexing attribute of an indexed component before the component
5168 -- is rewritten into a function call.
5171 Nkind (Ref) = N_Indexed_Component
5172 and then Present (Generalized_Indexing (Ref));
5173 end Is_Element_Reference;
5175 -- Start of processing for Expand_Ctrl_Function_Call
5178 -- Optimization, if the returned value (which is on the sec-stack) is
5179 -- returned again, no need to copy/readjust/finalize, we can just pass
5180 -- the value thru (see Expand_N_Simple_Return_Statement), and thus no
5181 -- attachment is needed
5183 if Nkind (Parent (N)) = N_Simple_Return_Statement then
5187 -- Resolution is now finished, make sure we don't start analysis again
5188 -- because of the duplication.
5192 -- A function which returns a controlled object uses the secondary
5193 -- stack. Rewrite the call into a temporary which obtains the result of
5194 -- the function using 'reference.
5196 Remove_Side_Effects (N);
5198 -- The side effect removal of the function call produced a temporary.
5199 -- When the context is a case expression, if expression, or expression
5200 -- with actions, the lifetime of the temporary must be extended to match
5201 -- that of the context. Otherwise the function result will be finalized
5202 -- too early and affect the result of the expression. To prevent this
5203 -- unwanted effect, the temporary should not be considered for clean up
5204 -- actions by the general finalization machinery.
5206 -- Exception to this rule are references to Ada 2012 container elements.
5207 -- Such references must be finalized at the end of each iteration of the
5208 -- related quantified expression, otherwise the container will remain
5211 if Nkind (N) = N_Explicit_Dereference
5212 and then Within_Case_Or_If_Expression (N)
5213 and then not Is_Element_Reference (N)
5215 Set_Is_Ignored_Transient (Entity (Prefix (N)));
5217 end Expand_Ctrl_Function_Call;
5219 ----------------------------------------
5220 -- Expand_N_Extended_Return_Statement --
5221 ----------------------------------------
5223 -- If there is a Handled_Statement_Sequence, we rewrite this:
5225 -- return Result : T := <expression> do
5226 -- <handled_seq_of_stms>
5232 -- Result : T := <expression>;
5234 -- <handled_seq_of_stms>
5238 -- Otherwise (no Handled_Statement_Sequence), we rewrite this:
5240 -- return Result : T := <expression>;
5244 -- return <expression>;
5246 -- unless it's build-in-place or there's no <expression>, in which case
5250 -- Result : T := <expression>;
5255 -- Note that this case could have been written by the user as an extended
5256 -- return statement, or could have been transformed to this from a simple
5257 -- return statement.
5259 -- That is, we need to have a reified return object if there are statements
5260 -- (which might refer to it) or if we're doing build-in-place (so we can
5261 -- set its address to the final resting place or if there is no expression
5262 -- (in which case default initial values might need to be set)).
5264 procedure Expand_N_Extended_Return_Statement (N : Node_Id) is
5265 Loc : constant Source_Ptr := Sloc (N);
5267 function Build_Heap_Or_Pool_Allocator
5268 (Temp_Id : Entity_Id;
5269 Temp_Typ : Entity_Id;
5270 Func_Id : Entity_Id;
5271 Ret_Typ : Entity_Id;
5272 Alloc_Expr : Node_Id) return Node_Id;
5273 -- Create the statements necessary to allocate a return object on the
5274 -- heap or user-defined storage pool. The object may need finalization
5275 -- actions depending on the return type.
5277 -- * Controlled case
5279 -- if BIPfinalizationmaster = null then
5280 -- Temp_Id := <Alloc_Expr>;
5283 -- type Ptr_Typ is access Ret_Typ;
5284 -- for Ptr_Typ'Storage_Pool use
5285 -- Base_Pool (BIPfinalizationmaster.all).all;
5289 -- procedure Allocate (...) is
5291 -- System.Storage_Pools.Subpools.Allocate_Any (...);
5294 -- Local := <Alloc_Expr>;
5295 -- Temp_Id := Temp_Typ (Local);
5299 -- * Non-controlled case
5301 -- Temp_Id := <Alloc_Expr>;
5303 -- Temp_Id is the temporary which is used to reference the internally
5304 -- created object in all allocation forms. Temp_Typ is the type of the
5305 -- temporary. Func_Id is the enclosing function. Ret_Typ is the return
5306 -- type of Func_Id. Alloc_Expr is the actual allocator.
5308 function Move_Activation_Chain (Func_Id : Entity_Id) return Node_Id;
5309 -- Construct a call to System.Tasking.Stages.Move_Activation_Chain
5311 -- From current activation chain
5312 -- To activation chain passed in by the caller
5313 -- New_Master master passed in by the caller
5315 -- Func_Id is the entity of the function where the extended return
5316 -- statement appears.
5318 ----------------------------------
5319 -- Build_Heap_Or_Pool_Allocator --
5320 ----------------------------------
5322 function Build_Heap_Or_Pool_Allocator
5323 (Temp_Id : Entity_Id;
5324 Temp_Typ : Entity_Id;
5325 Func_Id : Entity_Id;
5326 Ret_Typ : Entity_Id;
5327 Alloc_Expr : Node_Id) return Node_Id
5330 pragma Assert (Is_Build_In_Place_Function (Func_Id));
5332 -- Processing for objects that require finalization actions
5334 if Needs_Finalization (Ret_Typ) then
5336 Decls : constant List_Id := New_List;
5337 Fin_Mas_Id : constant Entity_Id :=
5338 Build_In_Place_Formal
5339 (Func_Id, BIP_Finalization_Master);
5340 Orig_Expr : constant Node_Id :=
5342 (Source => Alloc_Expr,
5343 Scopes_In_EWA_OK => True);
5344 Stmts : constant List_Id := New_List;
5345 Desig_Typ : Entity_Id;
5346 Local_Id : Entity_Id;
5347 Pool_Id : Entity_Id;
5348 Ptr_Typ : Entity_Id;
5352 -- Pool_Id renames Base_Pool (BIPfinalizationmaster.all).all;
5354 Pool_Id := Make_Temporary (Loc, 'P');
5357 Make_Object_Renaming_Declaration (Loc,
5358 Defining_Identifier => Pool_Id,
5360 New_Occurrence_Of (RTE (RE_Root_Storage_Pool), Loc),
5362 Make_Explicit_Dereference (Loc,
5364 Make_Function_Call (Loc,
5366 New_Occurrence_Of (RTE (RE_Base_Pool), Loc),
5367 Parameter_Associations => New_List (
5368 Make_Explicit_Dereference (Loc,
5370 New_Occurrence_Of (Fin_Mas_Id, Loc)))))));
5372 -- Create an access type which uses the storage pool of the
5373 -- caller's master. This additional type is necessary because
5374 -- the finalization master cannot be associated with the type
5375 -- of the temporary. Otherwise the secondary stack allocation
5378 Desig_Typ := Ret_Typ;
5380 -- Ensure that the build-in-place machinery uses a fat pointer
5381 -- when allocating an unconstrained array on the heap. In this
5382 -- case the result object type is a constrained array type even
5383 -- though the function type is unconstrained.
5385 if Ekind (Desig_Typ) = E_Array_Subtype then
5386 Desig_Typ := Base_Type (Desig_Typ);
5390 -- type Ptr_Typ is access Desig_Typ;
5392 Ptr_Typ := Make_Temporary (Loc, 'P');
5395 Make_Full_Type_Declaration (Loc,
5396 Defining_Identifier => Ptr_Typ,
5398 Make_Access_To_Object_Definition (Loc,
5399 Subtype_Indication =>
5400 New_Occurrence_Of (Desig_Typ, Loc))));
5402 -- Perform minor decoration in order to set the master and the
5403 -- storage pool attributes.
5405 Set_Ekind (Ptr_Typ, E_Access_Type);
5406 Set_Finalization_Master (Ptr_Typ, Fin_Mas_Id);
5407 Set_Associated_Storage_Pool (Ptr_Typ, Pool_Id);
5409 -- Create the temporary, generate:
5410 -- Local_Id : Ptr_Typ;
5412 Local_Id := Make_Temporary (Loc, 'T');
5415 Make_Object_Declaration (Loc,
5416 Defining_Identifier => Local_Id,
5417 Object_Definition =>
5418 New_Occurrence_Of (Ptr_Typ, Loc)));
5420 -- Allocate the object, generate:
5421 -- Local_Id := <Alloc_Expr>;
5424 Make_Assignment_Statement (Loc,
5425 Name => New_Occurrence_Of (Local_Id, Loc),
5426 Expression => Alloc_Expr));
5429 -- Temp_Id := Temp_Typ (Local_Id);
5432 Make_Assignment_Statement (Loc,
5433 Name => New_Occurrence_Of (Temp_Id, Loc),
5435 Unchecked_Convert_To (Temp_Typ,
5436 New_Occurrence_Of (Local_Id, Loc))));
5438 -- Wrap the allocation in a block. This is further conditioned
5439 -- by checking the caller finalization master at runtime. A
5440 -- null value indicates a non-existent master, most likely due
5441 -- to a Finalize_Storage_Only allocation.
5444 -- if BIPfinalizationmaster = null then
5445 -- Temp_Id := <Orig_Expr>;
5455 Make_If_Statement (Loc,
5458 Left_Opnd => New_Occurrence_Of (Fin_Mas_Id, Loc),
5459 Right_Opnd => Make_Null (Loc)),
5461 Then_Statements => New_List (
5462 Make_Assignment_Statement (Loc,
5463 Name => New_Occurrence_Of (Temp_Id, Loc),
5464 Expression => Orig_Expr)),
5466 Else_Statements => New_List (
5467 Make_Block_Statement (Loc,
5468 Declarations => Decls,
5469 Handled_Statement_Sequence =>
5470 Make_Handled_Sequence_Of_Statements (Loc,
5471 Statements => Stmts))));
5474 -- For all other cases, generate:
5475 -- Temp_Id := <Alloc_Expr>;
5479 Make_Assignment_Statement (Loc,
5480 Name => New_Occurrence_Of (Temp_Id, Loc),
5481 Expression => Alloc_Expr);
5483 end Build_Heap_Or_Pool_Allocator;
5485 ---------------------------
5486 -- Move_Activation_Chain --
5487 ---------------------------
5489 function Move_Activation_Chain (Func_Id : Entity_Id) return Node_Id is
5492 Make_Procedure_Call_Statement (Loc,
5494 New_Occurrence_Of (RTE (RE_Move_Activation_Chain), Loc),
5496 Parameter_Associations => New_List (
5500 Make_Attribute_Reference (Loc,
5501 Prefix => Make_Identifier (Loc, Name_uChain),
5502 Attribute_Name => Name_Unrestricted_Access),
5504 -- Destination chain
5507 (Build_In_Place_Formal (Func_Id, BIP_Activation_Chain), Loc),
5512 (Build_In_Place_Formal (Func_Id, BIP_Task_Master), Loc)));
5513 end Move_Activation_Chain;
5517 Func_Id : constant Entity_Id :=
5518 Return_Applies_To (Return_Statement_Entity (N));
5519 Is_BIP_Func : constant Boolean :=
5520 Is_Build_In_Place_Function (Func_Id);
5521 Ret_Obj_Id : constant Entity_Id :=
5522 First_Entity (Return_Statement_Entity (N));
5523 Ret_Obj_Decl : constant Node_Id := Parent (Ret_Obj_Id);
5524 Ret_Typ : constant Entity_Id := Etype (Func_Id);
5531 Return_Stmt : Node_Id := Empty;
5532 -- Force initialization to facilitate static analysis
5534 -- Start of processing for Expand_N_Extended_Return_Statement
5537 -- Given that functionality of interface thunks is simple (just displace
5538 -- the pointer to the object) they are always handled by means of
5539 -- simple return statements.
5541 pragma Assert (not Is_Thunk (Current_Subprogram));
5543 if Nkind (Ret_Obj_Decl) = N_Object_Declaration then
5544 Exp := Expression (Ret_Obj_Decl);
5546 -- Assert that if F says "return R : T := G(...) do..."
5547 -- then F and G are both b-i-p, or neither b-i-p.
5549 if Nkind (Exp) = N_Function_Call then
5550 pragma Assert (Ekind (Current_Subprogram) = E_Function);
5552 (Is_Build_In_Place_Function (Current_Subprogram) =
5553 Is_Build_In_Place_Function_Call (Exp));
5557 -- Ada 2005 (AI95-344): If the result type is class-wide, then insert
5558 -- a check that the level of the return expression's underlying type
5559 -- is not deeper than the level of the master enclosing the function.
5561 -- AI12-043: The check is made immediately after the return object
5564 if Present (Exp) and then Is_Class_Wide_Type (Ret_Typ) then
5565 Apply_CW_Accessibility_Check (Exp, Func_Id);
5571 HSS := Handled_Statement_Sequence (N);
5573 -- If the returned object needs finalization actions, the function must
5574 -- perform the appropriate cleanup should it fail to return. The state
5575 -- of the function itself is tracked through a flag which is coupled
5576 -- with the scope finalizer. There is one flag per each return object
5577 -- in case of multiple returns.
5579 if Is_BIP_Func and then Needs_Finalization (Etype (Ret_Obj_Id)) then
5581 Flag_Decl : Node_Id;
5582 Flag_Id : Entity_Id;
5586 -- Recover the function body
5588 Func_Bod := Unit_Declaration_Node (Func_Id);
5590 if Nkind (Func_Bod) = N_Subprogram_Declaration then
5591 Func_Bod := Parent (Parent (Corresponding_Body (Func_Bod)));
5594 if Nkind (Func_Bod) = N_Function_Specification then
5595 Func_Bod := Parent (Func_Bod); -- one more level for child units
5598 pragma Assert (Nkind (Func_Bod) = N_Subprogram_Body);
5600 -- Create a flag to track the function state
5602 Flag_Id := Make_Temporary (Loc, 'F');
5603 Set_Status_Flag_Or_Transient_Decl (Ret_Obj_Id, Flag_Id);
5605 -- Insert the flag at the beginning of the function declarations,
5607 -- Fnn : Boolean := False;
5610 Make_Object_Declaration (Loc,
5611 Defining_Identifier => Flag_Id,
5612 Object_Definition =>
5613 New_Occurrence_Of (Standard_Boolean, Loc),
5615 New_Occurrence_Of (Standard_False, Loc));
5617 Prepend_To (Declarations (Func_Bod), Flag_Decl);
5618 Analyze (Flag_Decl);
5622 -- Build a simple_return_statement that returns the return object when
5623 -- there is a statement sequence, or no expression, or the result will
5624 -- be built in place. Note however that we currently do this for all
5625 -- composite cases, even though not all are built in place.
5628 or else Is_Composite_Type (Ret_Typ)
5634 -- If the extended return has a handled statement sequence, then wrap
5635 -- it in a block and use the block as the first statement.
5639 Make_Block_Statement (Loc,
5640 Declarations => New_List,
5641 Handled_Statement_Sequence => HSS));
5644 -- If the result type contains tasks, we call Move_Activation_Chain.
5645 -- Later, the cleanup code will call Complete_Master, which will
5646 -- terminate any unactivated tasks belonging to the return statement
5647 -- master. But Move_Activation_Chain updates their master to be that
5648 -- of the caller, so they will not be terminated unless the return
5649 -- statement completes unsuccessfully due to exception, abort, goto,
5650 -- or exit. As a formality, we test whether the function requires the
5651 -- result to be built in place, though that's necessarily true for
5652 -- the case of result types with task parts.
5654 if Is_BIP_Func and then Has_Task (Ret_Typ) then
5656 -- The return expression is an aggregate for a complex type which
5657 -- contains tasks. This particular case is left unexpanded since
5658 -- the regular expansion would insert all temporaries and
5659 -- initialization code in the wrong block.
5661 if Nkind (Exp) = N_Aggregate then
5662 Expand_N_Aggregate (Exp);
5665 -- Do not move the activation chain if the return object does not
5668 if Has_Task (Etype (Ret_Obj_Id)) then
5669 Append_To (Stmts, Move_Activation_Chain (Func_Id));
5673 -- Update the state of the function right before the object is
5676 if Is_BIP_Func and then Needs_Finalization (Etype (Ret_Obj_Id)) then
5678 Flag_Id : constant Entity_Id :=
5679 Status_Flag_Or_Transient_Decl (Ret_Obj_Id);
5686 Make_Assignment_Statement (Loc,
5687 Name => New_Occurrence_Of (Flag_Id, Loc),
5688 Expression => New_Occurrence_Of (Standard_True, Loc)));
5692 -- Build a simple_return_statement that returns the return object
5695 Make_Simple_Return_Statement (Loc,
5696 Expression => New_Occurrence_Of (Ret_Obj_Id, Loc));
5697 Append_To (Stmts, Return_Stmt);
5699 HSS := Make_Handled_Sequence_Of_Statements (Loc, Stmts);
5702 -- Case where we build a return statement block
5704 if Present (HSS) then
5706 Make_Block_Statement (Loc,
5707 Declarations => Return_Object_Declarations (N),
5708 Handled_Statement_Sequence => HSS);
5710 -- We set the entity of the new block statement to be that of the
5711 -- return statement. This is necessary so that various fields, such
5712 -- as Finalization_Chain_Entity carry over from the return statement
5713 -- to the block. Note that this block is unusual, in that its entity
5714 -- is an E_Return_Statement rather than an E_Block.
5717 (Result, New_Occurrence_Of (Return_Statement_Entity (N), Loc));
5719 -- If the object decl was already rewritten as a renaming, then we
5720 -- don't want to do the object allocation and transformation of
5721 -- the return object declaration to a renaming. This case occurs
5722 -- when the return object is initialized by a call to another
5723 -- build-in-place function, and that function is responsible for
5724 -- the allocation of the return object.
5727 and then Nkind (Ret_Obj_Decl) = N_Object_Renaming_Declaration
5730 (Nkind (Original_Node (Ret_Obj_Decl)) = N_Object_Declaration
5733 -- It is a regular BIP object declaration
5735 (Is_Build_In_Place_Function_Call
5736 (Expression (Original_Node (Ret_Obj_Decl)))
5738 -- It is a BIP object declaration that displaces the pointer
5739 -- to the object to reference a convered interface type.
5742 Present (Unqual_BIP_Iface_Function_Call
5743 (Expression (Original_Node (Ret_Obj_Decl))))));
5745 -- Return the build-in-place result by reference
5747 Set_By_Ref (Return_Stmt);
5749 elsif Is_BIP_Func then
5751 -- Locate the implicit access parameter associated with the
5752 -- caller-supplied return object and convert the return
5753 -- statement's return object declaration to a renaming of a
5754 -- dereference of the access parameter. If the return object's
5755 -- declaration includes an expression that has not already been
5756 -- expanded as separate assignments, then add an assignment
5757 -- statement to ensure the return object gets initialized.
5760 -- Result : T [:= <expression>];
5767 -- Result : T renames FuncRA.all;
5768 -- [Result := <expression;]
5773 Ret_Obj_Expr : constant Node_Id := Expression (Ret_Obj_Decl);
5774 Ret_Obj_Typ : constant Entity_Id := Etype (Ret_Obj_Id);
5776 Init_Assignment : Node_Id := Empty;
5777 Obj_Acc_Formal : Entity_Id;
5778 Obj_Acc_Deref : Node_Id;
5779 Obj_Alloc_Formal : Entity_Id;
5782 -- Build-in-place results must be returned by reference
5784 Set_By_Ref (Return_Stmt);
5786 -- Retrieve the implicit access parameter passed by the caller
5789 Build_In_Place_Formal (Func_Id, BIP_Object_Access);
5791 -- If the return object's declaration includes an expression
5792 -- and the declaration isn't marked as No_Initialization, then
5793 -- we need to generate an assignment to the object and insert
5794 -- it after the declaration before rewriting it as a renaming
5795 -- (otherwise we'll lose the initialization). The case where
5796 -- the result type is an interface (or class-wide interface)
5797 -- is also excluded because the context of the function call
5798 -- must be unconstrained, so the initialization will always
5799 -- be done as part of an allocator evaluation (storage pool
5800 -- or secondary stack), never to a constrained target object
5801 -- passed in by the caller. Besides the assignment being
5802 -- unneeded in this case, it avoids problems with trying to
5803 -- generate a dispatching assignment when the return expression
5804 -- is a nonlimited descendant of a limited interface (the
5805 -- interface has no assignment operation).
5807 if Present (Ret_Obj_Expr)
5808 and then not No_Initialization (Ret_Obj_Decl)
5809 and then not Is_Interface (Ret_Obj_Typ)
5812 Make_Assignment_Statement (Loc,
5813 Name => New_Occurrence_Of (Ret_Obj_Id, Loc),
5816 (Source => Ret_Obj_Expr,
5817 Scopes_In_EWA_OK => True));
5819 Set_Etype (Name (Init_Assignment), Etype (Ret_Obj_Id));
5820 Set_Assignment_OK (Name (Init_Assignment));
5821 Set_No_Ctrl_Actions (Init_Assignment);
5823 Set_Parent (Name (Init_Assignment), Init_Assignment);
5824 Set_Parent (Expression (Init_Assignment), Init_Assignment);
5826 Set_Expression (Ret_Obj_Decl, Empty);
5828 if Is_Class_Wide_Type (Etype (Ret_Obj_Id))
5829 and then not Is_Class_Wide_Type
5830 (Etype (Expression (Init_Assignment)))
5832 Rewrite (Expression (Init_Assignment),
5833 Make_Type_Conversion (Loc,
5835 New_Occurrence_Of (Etype (Ret_Obj_Id), Loc),
5837 Relocate_Node (Expression (Init_Assignment))));
5840 -- In the case of functions where the calling context can
5841 -- determine the form of allocation needed, initialization
5842 -- is done with each part of the if statement that handles
5843 -- the different forms of allocation (this is true for
5844 -- unconstrained, tagged, and controlled result subtypes).
5846 if not Needs_BIP_Alloc_Form (Func_Id) then
5847 Insert_After (Ret_Obj_Decl, Init_Assignment);
5851 -- When the function's subtype is unconstrained, a run-time
5852 -- test may be needed to decide the form of allocation to use
5853 -- for the return object. The function has an implicit formal
5854 -- parameter indicating this. If the BIP_Alloc_Form formal has
5855 -- the value one, then the caller has passed access to an
5856 -- existing object for use as the return object. If the value
5857 -- is two, then the return object must be allocated on the
5858 -- secondary stack. Otherwise, the object must be allocated in
5859 -- a storage pool. We generate an if statement to test the
5860 -- implicit allocation formal and initialize a local access
5861 -- value appropriately, creating allocators in the secondary
5862 -- stack and global heap cases. The special formal also exists
5863 -- and must be tested when the function has a tagged result,
5864 -- even when the result subtype is constrained, because in
5865 -- general such functions can be called in dispatching contexts
5866 -- and must be handled similarly to functions with a class-wide
5869 if Needs_BIP_Alloc_Form (Func_Id) then
5871 Build_In_Place_Formal (Func_Id, BIP_Alloc_Form);
5874 Pool_Id : constant Entity_Id :=
5875 Make_Temporary (Loc, 'P');
5876 Alloc_Obj_Id : Entity_Id;
5877 Alloc_Obj_Decl : Node_Id;
5878 Alloc_If_Stmt : Node_Id;
5879 Guard_Except : Node_Id;
5880 Heap_Allocator : Node_Id;
5881 Pool_Decl : Node_Id;
5882 Pool_Allocator : Node_Id;
5883 Ptr_Type_Decl : Node_Id;
5884 Ref_Type : Entity_Id;
5885 SS_Allocator : Node_Id;
5888 -- Create an access type designating the function's
5891 Ref_Type := Make_Temporary (Loc, 'A');
5894 Make_Full_Type_Declaration (Loc,
5895 Defining_Identifier => Ref_Type,
5897 Make_Access_To_Object_Definition (Loc,
5898 All_Present => True,
5899 Subtype_Indication =>
5900 New_Occurrence_Of (Ret_Obj_Typ, Loc)));
5902 Insert_Before (Ret_Obj_Decl, Ptr_Type_Decl);
5904 -- Create an access object that will be initialized to an
5905 -- access value denoting the return object, either coming
5906 -- from an implicit access value passed in by the caller
5907 -- or from the result of an allocator.
5909 Alloc_Obj_Id := Make_Temporary (Loc, 'R');
5910 Set_Etype (Alloc_Obj_Id, Ref_Type);
5913 Make_Object_Declaration (Loc,
5914 Defining_Identifier => Alloc_Obj_Id,
5915 Object_Definition =>
5916 New_Occurrence_Of (Ref_Type, Loc));
5918 Insert_Before (Ret_Obj_Decl, Alloc_Obj_Decl);
5920 -- Create allocators for both the secondary stack and
5921 -- global heap. If there's an initialization expression,
5922 -- then create these as initialized allocators.
5924 if Present (Ret_Obj_Expr)
5925 and then not No_Initialization (Ret_Obj_Decl)
5927 -- Always use the type of the expression for the
5928 -- qualified expression, rather than the result type.
5929 -- In general we cannot always use the result type
5930 -- for the allocator, because the expression might be
5931 -- of a specific type, such as in the case of an
5932 -- aggregate or even a nonlimited object when the
5933 -- result type is a limited class-wide interface type.
5936 Make_Allocator (Loc,
5938 Make_Qualified_Expression (Loc,
5941 (Etype (Ret_Obj_Expr), Loc),
5944 (Source => Ret_Obj_Expr,
5945 Scopes_In_EWA_OK => True)));
5948 -- If the function returns a class-wide type we cannot
5949 -- use the return type for the allocator. Instead we
5950 -- use the type of the expression, which must be an
5951 -- aggregate of a definite type.
5953 if Is_Class_Wide_Type (Ret_Obj_Typ) then
5955 Make_Allocator (Loc,
5958 (Etype (Ret_Obj_Expr), Loc));
5961 Make_Allocator (Loc,
5963 New_Occurrence_Of (Ret_Obj_Typ, Loc));
5966 -- If the object requires default initialization then
5967 -- that will happen later following the elaboration of
5968 -- the object renaming. If we don't turn it off here
5969 -- then the object will be default initialized twice.
5971 Set_No_Initialization (Heap_Allocator);
5974 -- Set the flag indicating that the allocator came from
5975 -- a build-in-place return statement, so we can avoid
5976 -- adjusting the allocated object. Note that this flag
5977 -- will be inherited by the copies made below.
5979 Set_Alloc_For_BIP_Return (Heap_Allocator);
5981 -- The Pool_Allocator is just like the Heap_Allocator,
5982 -- except we set Storage_Pool and Procedure_To_Call so
5983 -- it will use the user-defined storage pool.
5987 (Source => Heap_Allocator,
5988 Scopes_In_EWA_OK => True);
5990 pragma Assert (Alloc_For_BIP_Return (Pool_Allocator));
5992 -- Do not generate the renaming of the build-in-place
5993 -- pool parameter on ZFP because the parameter is not
5994 -- created in the first place.
5996 if RTE_Available (RE_Root_Storage_Pool_Ptr) then
5998 Make_Object_Renaming_Declaration (Loc,
5999 Defining_Identifier => Pool_Id,
6002 (RTE (RE_Root_Storage_Pool), Loc),
6004 Make_Explicit_Dereference (Loc,
6006 (Build_In_Place_Formal
6007 (Func_Id, BIP_Storage_Pool), Loc)));
6008 Set_Storage_Pool (Pool_Allocator, Pool_Id);
6009 Set_Procedure_To_Call
6010 (Pool_Allocator, RTE (RE_Allocate_Any));
6012 Pool_Decl := Make_Null_Statement (Loc);
6015 -- If the No_Allocators restriction is active, then only
6016 -- an allocator for secondary stack allocation is needed.
6017 -- It's OK for such allocators to have Comes_From_Source
6018 -- set to False, because gigi knows not to flag them as
6019 -- being a violation of No_Implicit_Heap_Allocations.
6021 if Restriction_Active (No_Allocators) then
6022 SS_Allocator := Heap_Allocator;
6023 Heap_Allocator := Make_Null (Loc);
6024 Pool_Allocator := Make_Null (Loc);
6026 -- Otherwise the heap and pool allocators may be needed,
6027 -- so we make another allocator for secondary stack
6033 (Source => Heap_Allocator,
6034 Scopes_In_EWA_OK => True);
6036 pragma Assert (Alloc_For_BIP_Return (SS_Allocator));
6038 -- The heap and pool allocators are marked as
6039 -- Comes_From_Source since they correspond to an
6040 -- explicit user-written allocator (that is, it will
6041 -- only be executed on behalf of callers that call the
6042 -- function as initialization for such an allocator).
6043 -- Prevents errors when No_Implicit_Heap_Allocations
6046 Set_Comes_From_Source (Heap_Allocator, True);
6047 Set_Comes_From_Source (Pool_Allocator, True);
6050 -- The allocator is returned on the secondary stack
6052 Check_Restriction (No_Secondary_Stack, N);
6053 Set_Storage_Pool (SS_Allocator, RTE (RE_SS_Pool));
6054 Set_Procedure_To_Call
6055 (SS_Allocator, RTE (RE_SS_Allocate));
6057 -- The allocator is returned on the secondary stack,
6058 -- so indicate that the function return, as well as
6059 -- all blocks that encloses the allocator, must not
6060 -- release it. The flags must be set now because
6061 -- the decision to use the secondary stack is done
6062 -- very late in the course of expanding the return
6063 -- statement, past the point where these flags are
6066 Set_Uses_Sec_Stack (Func_Id);
6067 Set_Uses_Sec_Stack (Return_Statement_Entity (N));
6068 Set_Sec_Stack_Needed_For_Return
6069 (Return_Statement_Entity (N));
6070 Set_Enclosing_Sec_Stack_Return (N);
6072 -- Guard against poor expansion on the caller side by
6073 -- using a raise statement to catch out-of-range values
6074 -- of formal parameter BIP_Alloc_Form.
6076 if Exceptions_OK then
6078 Make_Raise_Program_Error (Loc,
6079 Reason => PE_Build_In_Place_Mismatch);
6081 Guard_Except := Make_Null_Statement (Loc);
6084 -- Create an if statement to test the BIP_Alloc_Form
6085 -- formal and initialize the access object to either the
6086 -- BIP_Object_Access formal (BIP_Alloc_Form =
6087 -- Caller_Allocation), the result of allocating the
6088 -- object in the secondary stack (BIP_Alloc_Form =
6089 -- Secondary_Stack), or else an allocator to create the
6090 -- return object in the heap or user-defined pool
6091 -- (BIP_Alloc_Form = Global_Heap or User_Storage_Pool).
6093 -- ??? An unchecked type conversion must be made in the
6094 -- case of assigning the access object formal to the
6095 -- local access object, because a normal conversion would
6096 -- be illegal in some cases (such as converting access-
6097 -- to-unconstrained to access-to-constrained), but the
6098 -- the unchecked conversion will presumably fail to work
6099 -- right in just such cases. It's not clear at all how to
6103 Make_If_Statement (Loc,
6107 New_Occurrence_Of (Obj_Alloc_Formal, Loc),
6109 Make_Integer_Literal (Loc,
6110 UI_From_Int (BIP_Allocation_Form'Pos
6111 (Caller_Allocation)))),
6113 Then_Statements => New_List (
6114 Make_Assignment_Statement (Loc,
6116 New_Occurrence_Of (Alloc_Obj_Id, Loc),
6118 Make_Unchecked_Type_Conversion (Loc,
6120 New_Occurrence_Of (Ref_Type, Loc),
6122 New_Occurrence_Of (Obj_Acc_Formal, Loc)))),
6124 Elsif_Parts => New_List (
6125 Make_Elsif_Part (Loc,
6129 New_Occurrence_Of (Obj_Alloc_Formal, Loc),
6131 Make_Integer_Literal (Loc,
6132 UI_From_Int (BIP_Allocation_Form'Pos
6133 (Secondary_Stack)))),
6135 Then_Statements => New_List (
6136 Make_Assignment_Statement (Loc,
6138 New_Occurrence_Of (Alloc_Obj_Id, Loc),
6139 Expression => SS_Allocator))),
6141 Make_Elsif_Part (Loc,
6145 New_Occurrence_Of (Obj_Alloc_Formal, Loc),
6147 Make_Integer_Literal (Loc,
6148 UI_From_Int (BIP_Allocation_Form'Pos
6151 Then_Statements => New_List (
6152 Build_Heap_Or_Pool_Allocator
6153 (Temp_Id => Alloc_Obj_Id,
6154 Temp_Typ => Ref_Type,
6156 Ret_Typ => Ret_Obj_Typ,
6157 Alloc_Expr => Heap_Allocator))),
6159 -- ???If all is well, we can put the following
6160 -- 'elsif' in the 'else', but this is a useful
6161 -- self-check in case caller and callee don't agree
6162 -- on whether BIPAlloc and so on should be passed.
6164 Make_Elsif_Part (Loc,
6168 New_Occurrence_Of (Obj_Alloc_Formal, Loc),
6170 Make_Integer_Literal (Loc,
6171 UI_From_Int (BIP_Allocation_Form'Pos
6172 (User_Storage_Pool)))),
6174 Then_Statements => New_List (
6176 Build_Heap_Or_Pool_Allocator
6177 (Temp_Id => Alloc_Obj_Id,
6178 Temp_Typ => Ref_Type,
6180 Ret_Typ => Ret_Obj_Typ,
6181 Alloc_Expr => Pool_Allocator)))),
6183 -- Raise Program_Error if it's none of the above;
6184 -- this is a compiler bug.
6186 Else_Statements => New_List (Guard_Except));
6188 -- If a separate initialization assignment was created
6189 -- earlier, append that following the assignment of the
6190 -- implicit access formal to the access object, to ensure
6191 -- that the return object is initialized in that case. In
6192 -- this situation, the target of the assignment must be
6193 -- rewritten to denote a dereference of the access to the
6194 -- return object passed in by the caller.
6196 if Present (Init_Assignment) then
6197 Rewrite (Name (Init_Assignment),
6198 Make_Explicit_Dereference (Loc,
6199 Prefix => New_Occurrence_Of (Alloc_Obj_Id, Loc)));
6202 (Original_Node (Name (Init_Assignment))));
6203 Set_Assignment_OK (Name (Init_Assignment));
6205 Set_Etype (Name (Init_Assignment), Etype (Ret_Obj_Id));
6208 (Then_Statements (Alloc_If_Stmt), Init_Assignment);
6211 Insert_Before (Ret_Obj_Decl, Alloc_If_Stmt);
6213 -- Remember the local access object for use in the
6214 -- dereference of the renaming created below.
6216 Obj_Acc_Formal := Alloc_Obj_Id;
6219 -- When the function's subtype is unconstrained and a run-time
6220 -- test is not needed, we nevertheless need to build the return
6221 -- using the function's result subtype.
6223 elsif not Is_Constrained (Underlying_Type (Etype (Func_Id)))
6226 Alloc_Obj_Id : Entity_Id;
6227 Alloc_Obj_Decl : Node_Id;
6228 Ptr_Type_Decl : Node_Id;
6229 Ref_Type : Entity_Id;
6232 -- Create an access type designating the function's
6235 Ref_Type := Make_Temporary (Loc, 'A');
6238 Make_Full_Type_Declaration (Loc,
6239 Defining_Identifier => Ref_Type,
6241 Make_Access_To_Object_Definition (Loc,
6242 All_Present => True,
6243 Subtype_Indication =>
6244 New_Occurrence_Of (Ret_Obj_Typ, Loc)));
6246 Insert_Before (Ret_Obj_Decl, Ptr_Type_Decl);
6248 -- Create an access object initialized to the conversion
6249 -- of the implicit access value passed in by the caller.
6251 Alloc_Obj_Id := Make_Temporary (Loc, 'R');
6252 Set_Etype (Alloc_Obj_Id, Ref_Type);
6254 -- See the ??? comment a few lines above about the use of
6255 -- an unchecked conversion here.
6258 Make_Object_Declaration (Loc,
6259 Defining_Identifier => Alloc_Obj_Id,
6260 Object_Definition =>
6261 New_Occurrence_Of (Ref_Type, Loc),
6263 Make_Unchecked_Type_Conversion (Loc,
6265 New_Occurrence_Of (Ref_Type, Loc),
6267 New_Occurrence_Of (Obj_Acc_Formal, Loc)));
6269 Insert_Before (Ret_Obj_Decl, Alloc_Obj_Decl);
6271 -- Remember the local access object for use in the
6272 -- dereference of the renaming created below.
6274 Obj_Acc_Formal := Alloc_Obj_Id;
6278 -- Replace the return object declaration with a renaming of a
6279 -- dereference of the access value designating the return
6283 Make_Explicit_Dereference (Loc,
6284 Prefix => New_Occurrence_Of (Obj_Acc_Formal, Loc));
6286 Rewrite (Ret_Obj_Decl,
6287 Make_Object_Renaming_Declaration (Loc,
6288 Defining_Identifier => Ret_Obj_Id,
6289 Access_Definition => Empty,
6290 Subtype_Mark => New_Occurrence_Of (Ret_Obj_Typ, Loc),
6291 Name => Obj_Acc_Deref));
6293 Set_Renamed_Object (Ret_Obj_Id, Obj_Acc_Deref);
6297 -- Case where we do not build a block
6300 -- We're about to drop Return_Object_Declarations on the floor, so
6301 -- we need to insert it, in case it got expanded into useful code.
6302 -- Remove side effects from expression, which may be duplicated in
6303 -- subsequent checks (see Expand_Simple_Function_Return).
6305 Insert_List_Before (N, Return_Object_Declarations (N));
6306 Remove_Side_Effects (Exp);
6308 -- Build simple_return_statement that returns the expression directly
6310 Return_Stmt := Make_Simple_Return_Statement (Loc, Expression => Exp);
6311 Result := Return_Stmt;
6314 -- Set the flag to prevent infinite recursion
6316 Set_Comes_From_Extended_Return_Statement (Return_Stmt);
6318 Rewrite (N, Result);
6320 -- AI12-043: The checks of 6.5(8.1/3) and 6.5(21/3) are made immediately
6321 -- before an object is returned. A predicate that applies to the return
6322 -- subtype is checked immediately before an object is returned.
6324 -- Suppress access checks to avoid generating extra checks for b-i-p.
6326 Analyze (N, Suppress => Access_Check);
6327 end Expand_N_Extended_Return_Statement;
6329 ----------------------------
6330 -- Expand_N_Function_Call --
6331 ----------------------------
6333 procedure Expand_N_Function_Call (N : Node_Id) is
6336 end Expand_N_Function_Call;
6338 ---------------------------------------
6339 -- Expand_N_Procedure_Call_Statement --
6340 ---------------------------------------
6342 procedure Expand_N_Procedure_Call_Statement (N : Node_Id) is
6345 end Expand_N_Procedure_Call_Statement;
6347 --------------------------------------
6348 -- Expand_N_Simple_Return_Statement --
6349 --------------------------------------
6351 procedure Expand_N_Simple_Return_Statement (N : Node_Id) is
6353 -- Defend against previous errors (i.e. the return statement calls a
6354 -- function that is not available in configurable runtime).
6356 if Present (Expression (N))
6357 and then Nkind (Expression (N)) = N_Empty
6359 Check_Error_Detected;
6363 -- Distinguish the function and non-function cases:
6365 case Ekind (Return_Applies_To (Return_Statement_Entity (N))) is
6367 | E_Generic_Function
6369 Expand_Simple_Function_Return (N);
6373 | E_Generic_Procedure
6375 | E_Return_Statement
6377 Expand_Non_Function_Return (N);
6380 raise Program_Error;
6384 when RE_Not_Available =>
6386 end Expand_N_Simple_Return_Statement;
6388 ------------------------------
6389 -- Expand_N_Subprogram_Body --
6390 ------------------------------
6392 -- Add poll call if ATC polling is enabled, unless the body will be inlined
6395 -- Add dummy push/pop label nodes at start and end to clear any local
6396 -- exception indications if local-exception-to-goto optimization is active.
6398 -- Add return statement if last statement in body is not a return statement
6399 -- (this makes things easier on Gigi which does not want to have to handle
6400 -- a missing return).
6402 -- Add call to Activate_Tasks if body is a task activator
6404 -- Deal with possible detection of infinite recursion
6406 -- Eliminate body completely if convention stubbed
6408 -- Encode entity names within body, since we will not need to reference
6409 -- these entities any longer in the front end.
6411 -- Initialize scalar out parameters if Initialize/Normalize_Scalars
6413 -- Reset Pure indication if any parameter has root type System.Address
6414 -- or has any parameters of limited types, where limited means that the
6415 -- run-time view is limited (i.e. the full type is limited).
6419 procedure Expand_N_Subprogram_Body (N : Node_Id) is
6420 Body_Id : constant Entity_Id := Defining_Entity (N);
6421 HSS : constant Node_Id := Handled_Statement_Sequence (N);
6422 Loc : constant Source_Ptr := Sloc (N);
6424 procedure Add_Return (Spec_Id : Entity_Id; Stmts : List_Id);
6425 -- Append a return statement to the statement sequence Stmts if the last
6426 -- statement is not already a return or a goto statement. Note that the
6427 -- latter test is not critical, it does not matter if we add a few extra
6428 -- returns, since they get eliminated anyway later on. Spec_Id denotes
6429 -- the corresponding spec of the subprogram body.
6435 procedure Add_Return (Spec_Id : Entity_Id; Stmts : List_Id) is
6436 Last_Stmt : Node_Id;
6441 -- Get last statement, ignoring any Pop_xxx_Label nodes, which are
6442 -- not relevant in this context since they are not executable.
6444 Last_Stmt := Last (Stmts);
6445 while Nkind (Last_Stmt) in N_Pop_xxx_Label loop
6449 -- Now insert return unless last statement is a transfer
6451 if not Is_Transfer (Last_Stmt) then
6453 -- The source location for the return is the end label of the
6454 -- procedure if present. Otherwise use the sloc of the last
6455 -- statement in the list. If the list comes from a generated
6456 -- exception handler and we are not debugging generated code,
6457 -- all the statements within the handler are made invisible
6460 if Nkind (Parent (Stmts)) = N_Exception_Handler
6461 and then not Comes_From_Source (Parent (Stmts))
6463 Loc := Sloc (Last_Stmt);
6464 elsif Present (End_Label (HSS)) then
6465 Loc := Sloc (End_Label (HSS));
6467 Loc := Sloc (Last_Stmt);
6470 -- Append return statement, and set analyzed manually. We can't
6471 -- call Analyze on this return since the scope is wrong.
6473 -- Note: it almost works to push the scope and then do the Analyze
6474 -- call, but something goes wrong in some weird cases and it is
6475 -- not worth worrying about ???
6477 Stmt := Make_Simple_Return_Statement (Loc);
6479 -- The return statement is handled properly, and the call to the
6480 -- postcondition, inserted below, does not require information
6481 -- from the body either. However, that call is analyzed in the
6482 -- enclosing scope, and an elaboration check might improperly be
6483 -- added to it. A guard in Sem_Elab is needed to prevent that
6484 -- spurious check, see Check_Elab_Call.
6486 Append_To (Stmts, Stmt);
6487 Set_Analyzed (Stmt);
6489 -- Call the _Postconditions procedure if the related subprogram
6490 -- has contract assertions that need to be verified on exit.
6492 if Ekind (Spec_Id) = E_Procedure
6493 and then Present (Postconditions_Proc (Spec_Id))
6495 Insert_Action (Stmt,
6496 Make_Procedure_Call_Statement (Loc,
6498 New_Occurrence_Of (Postconditions_Proc (Spec_Id), Loc)));
6501 -- Ada 2020 (AI12-0279): append the call to 'Yield unless this is
6502 -- a generic subprogram (since in such case it will be added to
6503 -- the instantiations).
6505 if Has_Yield_Aspect (Spec_Id)
6506 and then Ekind (Spec_Id) /= E_Generic_Procedure
6507 and then RTE_Available (RE_Yield)
6509 Insert_Action (Stmt,
6510 Make_Procedure_Call_Statement (Loc,
6511 New_Occurrence_Of (RTE (RE_Yield), Loc)));
6520 Spec_Id : Entity_Id;
6522 -- Start of processing for Expand_N_Subprogram_Body
6525 if Present (Corresponding_Spec (N)) then
6526 Spec_Id := Corresponding_Spec (N);
6531 -- If this is a Pure function which has any parameters whose root type
6532 -- is System.Address, reset the Pure indication.
6533 -- This check is also performed when the subprogram is frozen, but we
6534 -- repeat it on the body so that the indication is consistent, and so
6535 -- it applies as well to bodies without separate specifications.
6537 if Is_Pure (Spec_Id)
6538 and then Is_Subprogram (Spec_Id)
6539 and then not Has_Pragma_Pure_Function (Spec_Id)
6541 Check_Function_With_Address_Parameter (Spec_Id);
6543 if Spec_Id /= Body_Id then
6544 Set_Is_Pure (Body_Id, Is_Pure (Spec_Id));
6548 -- Set L to either the list of declarations if present, or to the list
6549 -- of statements if no declarations are present. This is used to insert
6550 -- new stuff at the start.
6552 if Is_Non_Empty_List (Declarations (N)) then
6553 L := Declarations (N);
6555 L := Statements (HSS);
6558 -- If local-exception-to-goto optimization active, insert dummy push
6559 -- statements at start, and dummy pop statements at end, but inhibit
6560 -- this if we have No_Exception_Handlers, since they are useless and
6561 -- interfere with analysis, e.g. by CodePeer. We also don't need these
6562 -- if we're unnesting subprograms because the only purpose of these
6563 -- nodes is to ensure we don't set a label in one subprogram and branch
6564 -- to it in another.
6566 if (Debug_Flag_Dot_G
6567 or else Restriction_Active (No_Exception_Propagation))
6568 and then not Restriction_Active (No_Exception_Handlers)
6569 and then not CodePeer_Mode
6570 and then not Unnest_Subprogram_Mode
6571 and then Is_Non_Empty_List (L)
6574 FS : constant Node_Id := First (L);
6575 FL : constant Source_Ptr := Sloc (FS);
6580 -- LS points to either last statement, if statements are present
6581 -- or to the last declaration if there are no statements present.
6582 -- It is the node after which the pop's are generated.
6584 if Is_Non_Empty_List (Statements (HSS)) then
6585 LS := Last (Statements (HSS));
6592 Insert_List_Before_And_Analyze (FS, New_List (
6593 Make_Push_Constraint_Error_Label (FL),
6594 Make_Push_Program_Error_Label (FL),
6595 Make_Push_Storage_Error_Label (FL)));
6597 Insert_List_After_And_Analyze (LS, New_List (
6598 Make_Pop_Constraint_Error_Label (LL),
6599 Make_Pop_Program_Error_Label (LL),
6600 Make_Pop_Storage_Error_Label (LL)));
6604 -- Need poll on entry to subprogram if polling enabled. We only do this
6605 -- for non-empty subprograms, since it does not seem necessary to poll
6606 -- for a dummy null subprogram.
6608 if Is_Non_Empty_List (L) then
6610 -- Do not add a polling call if the subprogram is to be inlined by
6611 -- the back-end, to avoid repeated calls with multiple inlinings.
6613 if Is_Inlined (Spec_Id)
6614 and then Front_End_Inlining
6615 and then Optimization_Level > 1
6619 Generate_Poll_Call (First (L));
6623 -- Initialize any scalar OUT args if Initialize/Normalize_Scalars
6625 if Init_Or_Norm_Scalars and then Is_Subprogram (Spec_Id) then
6631 -- Loop through formals
6633 F := First_Formal (Spec_Id);
6634 while Present (F) loop
6635 if Is_Scalar_Type (Etype (F))
6636 and then Ekind (F) = E_Out_Parameter
6638 Check_Restriction (No_Default_Initialization, F);
6640 -- Insert the initialization. We turn off validity checks
6641 -- for this assignment, since we do not want any check on
6642 -- the initial value itself (which may well be invalid).
6643 -- Predicate checks are disabled as well (RM 6.4.1 (13/3))
6646 Make_Assignment_Statement (Loc,
6647 Name => New_Occurrence_Of (F, Loc),
6648 Expression => Get_Simple_Init_Val (Etype (F), N));
6649 Set_Suppress_Assignment_Checks (A);
6651 Insert_Before_And_Analyze (First (L),
6652 A, Suppress => Validity_Check);
6660 -- Clear out statement list for stubbed procedure
6662 if Present (Corresponding_Spec (N)) then
6663 Set_Elaboration_Flag (N, Spec_Id);
6665 if Convention (Spec_Id) = Convention_Stubbed
6666 or else Is_Eliminated (Spec_Id)
6668 Set_Declarations (N, Empty_List);
6669 Set_Handled_Statement_Sequence (N,
6670 Make_Handled_Sequence_Of_Statements (Loc,
6671 Statements => New_List (Make_Null_Statement (Loc))));
6677 -- Create a set of discriminals for the next protected subprogram body
6679 if Is_List_Member (N)
6680 and then Present (Parent (List_Containing (N)))
6681 and then Nkind (Parent (List_Containing (N))) = N_Protected_Body
6682 and then Present (Next_Protected_Operation (N))
6684 Set_Discriminals (Parent (Base_Type (Scope (Spec_Id))));
6687 -- Returns_By_Ref flag is normally set when the subprogram is frozen but
6688 -- subprograms with no specs are not frozen.
6691 Typ : constant Entity_Id := Etype (Spec_Id);
6692 Utyp : constant Entity_Id := Underlying_Type (Typ);
6695 if Is_Limited_View (Typ) then
6696 Set_Returns_By_Ref (Spec_Id);
6698 elsif Present (Utyp) and then CW_Or_Has_Controlled_Part (Utyp) then
6699 Set_Returns_By_Ref (Spec_Id);
6703 -- For a procedure, we add a return for all possible syntactic ends of
6706 if Ekind (Spec_Id) in E_Procedure | E_Generic_Procedure then
6707 Add_Return (Spec_Id, Statements (HSS));
6709 if Present (Exception_Handlers (HSS)) then
6710 Except_H := First_Non_Pragma (Exception_Handlers (HSS));
6711 while Present (Except_H) loop
6712 Add_Return (Spec_Id, Statements (Except_H));
6713 Next_Non_Pragma (Except_H);
6717 -- For a function, we must deal with the case where there is at least
6718 -- one missing return. What we do is to wrap the entire body of the
6719 -- function in a block:
6732 -- raise Program_Error;
6735 -- This approach is necessary because the raise must be signalled to the
6736 -- caller, not handled by any local handler (RM 6.4(11)).
6738 -- Note: we do not need to analyze the constructed sequence here, since
6739 -- it has no handler, and an attempt to analyze the handled statement
6740 -- sequence twice is risky in various ways (e.g. the issue of expanding
6741 -- cleanup actions twice).
6743 elsif Has_Missing_Return (Spec_Id) then
6745 Hloc : constant Source_Ptr := Sloc (HSS);
6746 Blok : constant Node_Id :=
6747 Make_Block_Statement (Hloc,
6748 Handled_Statement_Sequence => HSS);
6749 Rais : constant Node_Id :=
6750 Make_Raise_Program_Error (Hloc,
6751 Reason => PE_Missing_Return);
6754 Set_Handled_Statement_Sequence (N,
6755 Make_Handled_Sequence_Of_Statements (Hloc,
6756 Statements => New_List (Blok, Rais)));
6758 Push_Scope (Spec_Id);
6765 -- If subprogram contains a parameterless recursive call, then we may
6766 -- have an infinite recursion, so see if we can generate code to check
6767 -- for this possibility if storage checks are not suppressed.
6769 if Ekind (Spec_Id) = E_Procedure
6770 and then Has_Recursive_Call (Spec_Id)
6771 and then not Storage_Checks_Suppressed (Spec_Id)
6773 Detect_Infinite_Recursion (N, Spec_Id);
6776 -- Set to encode entity names in package body before gigi is called
6778 Qualify_Entity_Names (N);
6780 -- If the body belongs to a nonabstract library-level source primitive
6781 -- of a tagged type, install an elaboration check which ensures that a
6782 -- dispatching call targeting the primitive will not execute the body
6783 -- without it being previously elaborated.
6785 Install_Primitive_Elaboration_Check (N);
6786 end Expand_N_Subprogram_Body;
6788 -----------------------------------
6789 -- Expand_N_Subprogram_Body_Stub --
6790 -----------------------------------
6792 procedure Expand_N_Subprogram_Body_Stub (N : Node_Id) is
6796 if Present (Corresponding_Body (N)) then
6797 Bod := Unit_Declaration_Node (Corresponding_Body (N));
6799 -- The body may have been expanded already when it is analyzed
6800 -- through the subunit node. Do no expand again: it interferes
6801 -- with the construction of unnesting tables when generating C.
6803 if not Analyzed (Bod) then
6804 Expand_N_Subprogram_Body (Bod);
6807 -- Add full qualification to entities that may be created late
6808 -- during unnesting.
6810 Qualify_Entity_Names (N);
6812 end Expand_N_Subprogram_Body_Stub;
6814 -------------------------------------
6815 -- Expand_N_Subprogram_Declaration --
6816 -------------------------------------
6818 -- If the declaration appears within a protected body, it is a private
6819 -- operation of the protected type. We must create the corresponding
6820 -- protected subprogram an associated formals. For a normal protected
6821 -- operation, this is done when expanding the protected type declaration.
6823 -- If the declaration is for a null procedure, emit null body
6825 procedure Expand_N_Subprogram_Declaration (N : Node_Id) is
6826 Loc : constant Source_Ptr := Sloc (N);
6827 Subp : constant Entity_Id := Defining_Entity (N);
6831 Scop : constant Entity_Id := Scope (Subp);
6833 Prot_Decl : Node_Id;
6834 Prot_Id : Entity_Id;
6837 -- Deal with case of protected subprogram. Do not generate protected
6838 -- operation if operation is flagged as eliminated.
6840 if Is_List_Member (N)
6841 and then Present (Parent (List_Containing (N)))
6842 and then Nkind (Parent (List_Containing (N))) = N_Protected_Body
6843 and then Is_Protected_Type (Scop)
6845 if No (Protected_Body_Subprogram (Subp))
6846 and then not Is_Eliminated (Subp)
6849 Make_Subprogram_Declaration (Loc,
6851 Build_Protected_Sub_Specification
6852 (N, Scop, Unprotected_Mode));
6854 -- The protected subprogram is declared outside of the protected
6855 -- body. Given that the body has frozen all entities so far, we
6856 -- analyze the subprogram and perform freezing actions explicitly.
6857 -- including the generation of an explicit freeze node, to ensure
6858 -- that gigi has the proper order of elaboration.
6859 -- If the body is a subunit, the insertion point is before the
6860 -- stub in the parent.
6862 Prot_Bod := Parent (List_Containing (N));
6864 if Nkind (Parent (Prot_Bod)) = N_Subunit then
6865 Prot_Bod := Corresponding_Stub (Parent (Prot_Bod));
6868 Insert_Before (Prot_Bod, Prot_Decl);
6869 Prot_Id := Defining_Unit_Name (Specification (Prot_Decl));
6870 Set_Has_Delayed_Freeze (Prot_Id);
6872 Push_Scope (Scope (Scop));
6873 Analyze (Prot_Decl);
6874 Freeze_Before (N, Prot_Id);
6875 Set_Protected_Body_Subprogram (Subp, Prot_Id);
6879 -- Ada 2005 (AI-348): Generate body for a null procedure. In most
6880 -- cases this is superfluous because calls to it will be automatically
6881 -- inlined, but we definitely need the body if preconditions for the
6882 -- procedure are present, or if performing coverage analysis.
6884 elsif Nkind (Specification (N)) = N_Procedure_Specification
6885 and then Null_Present (Specification (N))
6888 Bod : constant Node_Id := Body_To_Inline (N);
6891 Set_Has_Completion (Subp, False);
6892 Append_Freeze_Action (Subp, Bod);
6894 -- The body now contains raise statements, so calls to it will
6897 Set_Is_Inlined (Subp, False);
6901 -- When generating C code, transform a function that returns a
6902 -- constrained array type into a procedure with an out parameter
6903 -- that carries the return value.
6905 -- We skip this transformation for unchecked conversions, since they
6906 -- are not needed by the C generator (and this also produces cleaner
6909 if Modify_Tree_For_C
6910 and then Nkind (Specification (N)) = N_Function_Specification
6911 and then Is_Array_Type (Etype (Subp))
6912 and then Is_Constrained (Etype (Subp))
6913 and then not Is_Unchecked_Conversion_Instance (Subp)
6915 Build_Procedure_Form (N);
6917 end Expand_N_Subprogram_Declaration;
6919 --------------------------------
6920 -- Expand_Non_Function_Return --
6921 --------------------------------
6923 procedure Expand_Non_Function_Return (N : Node_Id) is
6924 pragma Assert (No (Expression (N)));
6926 Loc : constant Source_Ptr := Sloc (N);
6927 Scope_Id : Entity_Id := Return_Applies_To (Return_Statement_Entity (N));
6928 Kind : constant Entity_Kind := Ekind (Scope_Id);
6931 Goto_Stat : Node_Id;
6935 -- Call the _Postconditions procedure if the related subprogram has
6936 -- contract assertions that need to be verified on exit.
6938 if Ekind (Scope_Id) in E_Entry | E_Entry_Family | E_Procedure
6939 and then Present (Postconditions_Proc (Scope_Id))
6942 Make_Procedure_Call_Statement (Loc,
6943 Name => New_Occurrence_Of (Postconditions_Proc (Scope_Id), Loc)));
6946 -- Ada 2020 (AI12-0279)
6948 if Has_Yield_Aspect (Scope_Id)
6949 and then RTE_Available (RE_Yield)
6952 Make_Procedure_Call_Statement (Loc,
6953 New_Occurrence_Of (RTE (RE_Yield), Loc)));
6956 -- If it is a return from a procedure do no extra steps
6958 if Kind = E_Procedure or else Kind = E_Generic_Procedure then
6961 -- If it is a nested return within an extended one, replace it with a
6962 -- return of the previously declared return object.
6964 elsif Kind = E_Return_Statement then
6966 Make_Simple_Return_Statement (Loc,
6968 New_Occurrence_Of (First_Entity (Scope_Id), Loc)));
6969 Set_Comes_From_Extended_Return_Statement (N);
6970 Set_Return_Statement_Entity (N, Scope_Id);
6971 Expand_Simple_Function_Return (N);
6975 pragma Assert (Is_Entry (Scope_Id));
6977 -- Look at the enclosing block to see whether the return is from an
6978 -- accept statement or an entry body.
6980 for J in reverse 0 .. Scope_Stack.Last loop
6981 Scope_Id := Scope_Stack.Table (J).Entity;
6982 exit when Is_Concurrent_Type (Scope_Id);
6985 -- If it is a return from accept statement it is expanded as call to
6986 -- RTS Complete_Rendezvous and a goto to the end of the accept body.
6988 -- (cf : Expand_N_Accept_Statement, Expand_N_Selective_Accept,
6989 -- Expand_N_Accept_Alternative in exp_ch9.adb)
6991 if Is_Task_Type (Scope_Id) then
6994 Make_Procedure_Call_Statement (Loc,
6995 Name => New_Occurrence_Of (RTE (RE_Complete_Rendezvous), Loc));
6996 Insert_Before (N, Call);
6997 -- why not insert actions here???
7000 Acc_Stat := Parent (N);
7001 while Nkind (Acc_Stat) /= N_Accept_Statement loop
7002 Acc_Stat := Parent (Acc_Stat);
7005 Lab_Node := Last (Statements
7006 (Handled_Statement_Sequence (Acc_Stat)));
7008 Goto_Stat := Make_Goto_Statement (Loc,
7009 Name => New_Occurrence_Of
7010 (Entity (Identifier (Lab_Node)), Loc));
7012 Set_Analyzed (Goto_Stat);
7014 Rewrite (N, Goto_Stat);
7017 -- If it is a return from an entry body, put a Complete_Entry_Body call
7018 -- in front of the return.
7020 elsif Is_Protected_Type (Scope_Id) then
7022 Make_Procedure_Call_Statement (Loc,
7024 New_Occurrence_Of (RTE (RE_Complete_Entry_Body), Loc),
7025 Parameter_Associations => New_List (
7026 Make_Attribute_Reference (Loc,
7029 (Find_Protection_Object (Current_Scope), Loc),
7030 Attribute_Name => Name_Unchecked_Access)));
7032 Insert_Before (N, Call);
7035 end Expand_Non_Function_Return;
7037 ---------------------------------------
7038 -- Expand_Protected_Object_Reference --
7039 ---------------------------------------
7041 function Expand_Protected_Object_Reference
7043 Scop : Entity_Id) return Node_Id
7045 Loc : constant Source_Ptr := Sloc (N);
7052 Rec := Make_Identifier (Loc, Name_uObject);
7053 Set_Etype (Rec, Corresponding_Record_Type (Scop));
7055 -- Find enclosing protected operation, and retrieve its first parameter,
7056 -- which denotes the enclosing protected object. If the enclosing
7057 -- operation is an entry, we are immediately within the protected body,
7058 -- and we can retrieve the object from the service entries procedure. A
7059 -- barrier function has the same signature as an entry. A barrier
7060 -- function is compiled within the protected object, but unlike
7061 -- protected operations its never needs locks, so that its protected
7062 -- body subprogram points to itself.
7064 Proc := Current_Scope;
7065 while Present (Proc)
7066 and then Scope (Proc) /= Scop
7068 Proc := Scope (Proc);
7071 Corr := Protected_Body_Subprogram (Proc);
7075 -- Previous error left expansion incomplete.
7076 -- Nothing to do on this call.
7083 (First (Parameter_Specifications (Parent (Corr))));
7085 if Is_Subprogram (Proc) and then Proc /= Corr then
7087 -- Protected function or procedure
7089 Set_Entity (Rec, Param);
7091 -- Rec is a reference to an entity which will not be in scope when
7092 -- the call is reanalyzed, and needs no further analysis.
7097 -- Entry or barrier function for entry body. The first parameter of
7098 -- the entry body procedure is pointer to the object. We create a
7099 -- local variable of the proper type, duplicating what is done to
7100 -- define _object later on.
7104 Obj_Ptr : constant Entity_Id := Make_Temporary (Loc, 'T');
7108 Make_Full_Type_Declaration (Loc,
7109 Defining_Identifier => Obj_Ptr,
7111 Make_Access_To_Object_Definition (Loc,
7112 Subtype_Indication =>
7114 (Corresponding_Record_Type (Scop), Loc))));
7116 Insert_Actions (N, Decls);
7117 Freeze_Before (N, Obj_Ptr);
7120 Make_Explicit_Dereference (Loc,
7122 Unchecked_Convert_To (Obj_Ptr,
7123 New_Occurrence_Of (Param, Loc)));
7125 -- Analyze new actual. Other actuals in calls are already analyzed
7126 -- and the list of actuals is not reanalyzed after rewriting.
7128 Set_Parent (Rec, N);
7134 end Expand_Protected_Object_Reference;
7136 --------------------------------------
7137 -- Expand_Protected_Subprogram_Call --
7138 --------------------------------------
7140 procedure Expand_Protected_Subprogram_Call
7147 procedure Expand_Internal_Init_Call;
7148 -- A call to an operation of the type may occur in the initialization
7149 -- of a private component. In that case the prefix of the call is an
7150 -- entity name and the call is treated as internal even though it
7151 -- appears in code outside of the protected type.
7153 procedure Freeze_Called_Function;
7154 -- If it is a function call it can appear in elaboration code and
7155 -- the called entity must be frozen before the call. This must be
7156 -- done before the call is expanded, as the expansion may rewrite it
7157 -- to something other than a call (e.g. a temporary initialized in a
7158 -- transient block).
7160 -------------------------------
7161 -- Expand_Internal_Init_Call --
7162 -------------------------------
7164 procedure Expand_Internal_Init_Call is
7166 -- If the context is a protected object (rather than a protected
7167 -- type) the call itself is bound to raise program_error because
7168 -- the protected body will not have been elaborated yet. This is
7169 -- diagnosed subsequently in Sem_Elab.
7171 Freeze_Called_Function;
7173 -- The target of the internal call is the first formal of the
7174 -- enclosing initialization procedure.
7176 Rec := New_Occurrence_Of (First_Formal (Current_Scope), Sloc (N));
7177 Build_Protected_Subprogram_Call (N,
7182 Resolve (N, Etype (Subp));
7183 end Expand_Internal_Init_Call;
7185 ----------------------------
7186 -- Freeze_Called_Function --
7187 ----------------------------
7189 procedure Freeze_Called_Function is
7191 if Ekind (Subp) = E_Function then
7192 Freeze_Expression (Name (N));
7194 end Freeze_Called_Function;
7196 -- Start of processing for Expand_Protected_Subprogram_Call
7199 -- If the protected object is not an enclosing scope, this is an inter-
7200 -- object function call. Inter-object procedure calls are expanded by
7201 -- Exp_Ch9.Build_Simple_Entry_Call. The call is intra-object only if the
7202 -- subprogram being called is in the protected body being compiled, and
7203 -- if the protected object in the call is statically the enclosing type.
7204 -- The object may be a component of some other data structure, in which
7205 -- case this must be handled as an inter-object call.
7207 if not In_Open_Scopes (Scop)
7208 or else Is_Entry_Wrapper (Current_Scope)
7209 or else not Is_Entity_Name (Name (N))
7211 if Nkind (Name (N)) = N_Selected_Component then
7212 Rec := Prefix (Name (N));
7214 elsif Nkind (Name (N)) = N_Indexed_Component then
7215 Rec := Prefix (Prefix (Name (N)));
7217 -- If this is a call within an entry wrapper, it appears within a
7218 -- precondition that calls another primitive of the synchronized
7219 -- type. The target object of the call is the first actual on the
7220 -- wrapper. Note that this is an external call, because the wrapper
7221 -- is called outside of the synchronized object. This means that
7222 -- an entry call to an entry with preconditions involves two
7223 -- synchronized operations.
7225 elsif Ekind (Current_Scope) = E_Procedure
7226 and then Is_Entry_Wrapper (Current_Scope)
7228 Rec := New_Occurrence_Of (First_Entity (Current_Scope), Sloc (N));
7230 -- A default parameter of a protected operation may be a call to
7231 -- a protected function of the type. This appears as an internal
7232 -- call in the profile of the operation, but if the context is an
7233 -- external call we must convert the call into an external one,
7234 -- using the protected object that is the target, so that:
7237 -- is transformed into
7240 elsif Nkind (Parent (N)) = N_Procedure_Call_Statement
7241 and then Nkind (Name (Parent (N))) = N_Selected_Component
7242 and then Is_Protected_Type (Etype (Prefix (Name (Parent (N)))))
7243 and then Is_Entity_Name (Name (N))
7244 and then Scope (Entity (Name (N))) =
7245 Etype (Prefix (Name (Parent (N))))
7248 Make_Selected_Component (Sloc (N),
7249 Prefix => New_Copy_Tree (Prefix (Name (Parent (N)))),
7250 Selector_Name => Relocate_Node (Name (N))));
7252 Analyze_And_Resolve (N);
7256 -- If the context is the initialization procedure for a protected
7257 -- type, the call is legal because the called entity must be a
7258 -- function of that enclosing type, and this is treated as an
7262 (Is_Entity_Name (Name (N)) and then Inside_Init_Proc);
7264 Expand_Internal_Init_Call;
7268 Freeze_Called_Function;
7269 Build_Protected_Subprogram_Call (N,
7270 Name => New_Occurrence_Of (Subp, Sloc (N)),
7271 Rec => Convert_Concurrent (Rec, Etype (Rec)),
7275 Rec := Expand_Protected_Object_Reference (N, Scop);
7281 Freeze_Called_Function;
7282 Build_Protected_Subprogram_Call (N,
7288 -- Analyze and resolve the new call. The actuals have already been
7289 -- resolved, but expansion of a function call will add extra actuals
7290 -- if needed. Analysis of a procedure call already includes resolution.
7294 if Ekind (Subp) = E_Function then
7295 Resolve (N, Etype (Subp));
7297 end Expand_Protected_Subprogram_Call;
7299 -----------------------------------
7300 -- Expand_Simple_Function_Return --
7301 -----------------------------------
7303 -- The "simple" comes from the syntax rule simple_return_statement. The
7304 -- semantics are not at all simple.
7306 procedure Expand_Simple_Function_Return (N : Node_Id) is
7307 Loc : constant Source_Ptr := Sloc (N);
7309 Scope_Id : constant Entity_Id :=
7310 Return_Applies_To (Return_Statement_Entity (N));
7311 -- The function we are returning from
7313 R_Type : constant Entity_Id := Etype (Scope_Id);
7314 -- The result type of the function
7316 Utyp : constant Entity_Id := Underlying_Type (R_Type);
7318 Exp : Node_Id := Expression (N);
7319 pragma Assert (Present (Exp));
7321 Exp_Is_Function_Call : constant Boolean :=
7322 Nkind (Exp) = N_Function_Call
7323 or else (Nkind (Exp) = N_Explicit_Dereference
7324 and then Is_Entity_Name (Prefix (Exp))
7325 and then Ekind (Entity (Prefix (Exp))) = E_Constant
7326 and then Is_Related_To_Func_Return (Entity (Prefix (Exp))));
7328 Exp_Typ : constant Entity_Id := Etype (Exp);
7329 -- The type of the expression (not necessarily the same as R_Type)
7331 Subtype_Ind : Node_Id;
7332 -- If the result type of the function is class-wide and the expression
7333 -- has a specific type, then we use the expression's type as the type of
7334 -- the return object. In cases where the expression is an aggregate that
7335 -- is built in place, this avoids the need for an expensive conversion
7336 -- of the return object to the specific type on assignments to the
7337 -- individual components.
7339 procedure Check_Against_Result_Level (Level : Node_Id);
7340 -- Check the given accessibility level against the level
7341 -- determined by the point of call. (AI05-0234).
7343 --------------------------------
7344 -- Check_Against_Result_Level --
7345 --------------------------------
7347 procedure Check_Against_Result_Level (Level : Node_Id) is
7350 Make_Raise_Program_Error (Loc,
7356 (Extra_Accessibility_Of_Result (Scope_Id), Loc)),
7357 Reason => PE_Accessibility_Check_Failed));
7358 end Check_Against_Result_Level;
7360 -- Start of processing for Expand_Simple_Function_Return
7363 if Is_Class_Wide_Type (R_Type)
7364 and then not Is_Class_Wide_Type (Exp_Typ)
7365 and then Nkind (Exp) /= N_Type_Conversion
7367 Subtype_Ind := New_Occurrence_Of (Exp_Typ, Loc);
7369 Subtype_Ind := New_Occurrence_Of (R_Type, Loc);
7371 -- If the result type is class-wide and the expression is a view
7372 -- conversion, the conversion plays no role in the expansion because
7373 -- it does not modify the tag of the object. Remove the conversion
7374 -- altogether to prevent tag overwriting.
7376 if Is_Class_Wide_Type (R_Type)
7377 and then not Is_Class_Wide_Type (Exp_Typ)
7378 and then Nkind (Exp) = N_Type_Conversion
7380 Exp := Expression (Exp);
7384 -- Assert that if F says "return G(...);"
7385 -- then F and G are both b-i-p, or neither b-i-p.
7387 if Nkind (Exp) = N_Function_Call then
7388 pragma Assert (Ekind (Scope_Id) = E_Function);
7390 (Is_Build_In_Place_Function (Scope_Id) =
7391 Is_Build_In_Place_Function_Call (Exp));
7395 -- For the case of a simple return that does not come from an
7396 -- extended return, in the case of build-in-place, we rewrite
7397 -- "return <expression>;" to be:
7399 -- return _anon_ : <return_subtype> := <expression>
7401 -- The expansion produced by Expand_N_Extended_Return_Statement will
7402 -- contain simple return statements (for example, a block containing
7403 -- simple return of the return object), which brings us back here with
7404 -- Comes_From_Extended_Return_Statement set. The reason for the barrier
7405 -- checking for a simple return that does not come from an extended
7406 -- return is to avoid this infinite recursion.
7408 -- The reason for this design is that for Ada 2005 limited returns, we
7409 -- need to reify the return object, so we can build it "in place", and
7410 -- we need a block statement to hang finalization and tasking stuff.
7412 -- ??? In order to avoid disruption, we avoid translating to extended
7413 -- return except in the cases where we really need to (Ada 2005 for
7414 -- inherently limited). We might prefer to do this translation in all
7415 -- cases (except perhaps for the case of Ada 95 inherently limited),
7416 -- in order to fully exercise the Expand_N_Extended_Return_Statement
7417 -- code. This would also allow us to do the build-in-place optimization
7418 -- for efficiency even in cases where it is semantically not required.
7420 -- As before, we check the type of the return expression rather than the
7421 -- return type of the function, because the latter may be a limited
7422 -- class-wide interface type, which is not a limited type, even though
7423 -- the type of the expression may be.
7426 (Comes_From_Extended_Return_Statement (N)
7427 or else not Is_Build_In_Place_Function_Call (Exp)
7428 or else Is_Build_In_Place_Function (Scope_Id));
7430 if not Comes_From_Extended_Return_Statement (N)
7431 and then Is_Build_In_Place_Function (Scope_Id)
7432 and then not Debug_Flag_Dot_L
7434 -- The functionality of interface thunks is simple and it is always
7435 -- handled by means of simple return statements. This leaves their
7436 -- expansion simple and clean.
7438 and then not Is_Thunk (Scope_Id)
7441 Return_Object_Entity : constant Entity_Id :=
7442 Make_Temporary (Loc, 'R', Exp);
7444 Obj_Decl : constant Node_Id :=
7445 Make_Object_Declaration (Loc,
7446 Defining_Identifier => Return_Object_Entity,
7447 Object_Definition => Subtype_Ind,
7450 Ext : constant Node_Id :=
7451 Make_Extended_Return_Statement (Loc,
7452 Return_Object_Declarations => New_List (Obj_Decl));
7453 -- Do not perform this high-level optimization if the result type
7454 -- is an interface because the "this" pointer must be displaced.
7463 -- Here we have a simple return statement that is part of the expansion
7464 -- of an extended return statement (either written by the user, or
7465 -- generated by the above code).
7467 -- Always normalize C/Fortran boolean result. This is not always needed,
7468 -- but it seems a good idea to minimize the passing around of non-
7469 -- normalized values, and in any case this handles the processing of
7470 -- barrier functions for protected types, which turn the condition into
7471 -- a return statement.
7473 if Is_Boolean_Type (Exp_Typ) and then Nonzero_Is_True (Exp_Typ) then
7474 Adjust_Condition (Exp);
7475 Adjust_Result_Type (Exp, Exp_Typ);
7478 -- Do validity check if enabled for returns
7480 if Validity_Checks_On and then Validity_Check_Returns then
7484 -- Check the result expression of a scalar function against the subtype
7485 -- of the function by inserting a conversion. This conversion must
7486 -- eventually be performed for other classes of types, but for now it's
7487 -- only done for scalars.
7490 if Is_Scalar_Type (Exp_Typ) then
7491 Rewrite (Exp, Convert_To (R_Type, Exp));
7493 -- The expression is resolved to ensure that the conversion gets
7494 -- expanded to generate a possible constraint check.
7496 Analyze_And_Resolve (Exp, R_Type);
7499 -- Deal with returning variable length objects and controlled types
7501 -- Nothing to do if we are returning by reference, or this is not a
7502 -- type that requires special processing (indicated by the fact that
7503 -- it requires a cleanup scope for the secondary stack case).
7505 if Is_Build_In_Place_Function (Scope_Id)
7506 or else Is_Limited_Interface (Exp_Typ)
7510 -- No copy needed for thunks returning interface type objects since
7511 -- the object is returned by reference and the maximum functionality
7512 -- required is just to displace the pointer.
7514 elsif Is_Thunk (Scope_Id) and then Is_Interface (Exp_Typ) then
7517 -- If the call is within a thunk and the type is a limited view, the
7518 -- backend will eventually see the non-limited view of the type.
7520 elsif Is_Thunk (Scope_Id) and then Is_Incomplete_Type (Exp_Typ) then
7523 -- A return statement from an ignored Ghost function does not use the
7524 -- secondary stack (or any other one).
7526 elsif not Requires_Transient_Scope (R_Type)
7527 or else Is_Ignored_Ghost_Entity (Scope_Id)
7530 -- Mutable records with variable-length components are not returned
7531 -- on the sec-stack, so we need to make sure that the back end will
7532 -- only copy back the size of the actual value, and not the maximum
7533 -- size. We create an actual subtype for this purpose. However we
7534 -- need not do it if the expression is a function call since this
7535 -- will be done in the called function and doing it here too would
7536 -- cause a temporary with maximum size to be created.
7539 Ubt : constant Entity_Id := Underlying_Type (Base_Type (Exp_Typ));
7543 if not Exp_Is_Function_Call
7544 and then Has_Discriminants (Ubt)
7545 and then not Is_Constrained (Ubt)
7546 and then not Has_Unchecked_Union (Ubt)
7548 Decl := Build_Actual_Subtype (Ubt, Exp);
7549 Ent := Defining_Identifier (Decl);
7550 Insert_Action (Exp, Decl);
7551 Rewrite (Exp, Unchecked_Convert_To (Ent, Exp));
7552 Analyze_And_Resolve (Exp);
7556 -- Here if secondary stack is used
7559 -- Prevent the reclamation of the secondary stack by all enclosing
7560 -- blocks and loops as well as the related function; otherwise the
7561 -- result would be reclaimed too early.
7563 Set_Enclosing_Sec_Stack_Return (N);
7565 -- Optimize the case where the result is a function call. In this
7566 -- case the result is already on the secondary stack and no further
7567 -- processing is required except to set the By_Ref flag to ensure
7568 -- that gigi does not attempt an extra unnecessary copy. (Actually
7569 -- not just unnecessary but wrong in the case of a controlled type,
7570 -- where gigi does not know how to do a copy.) To make up for a gcc
7571 -- 2.8.1 deficiency (???), we perform the copy for array types if the
7572 -- constrained status of the target type is different from that of
7575 if Requires_Transient_Scope (Exp_Typ)
7577 (not Is_Array_Type (Exp_Typ)
7578 or else Is_Constrained (Exp_Typ) = Is_Constrained (R_Type)
7579 or else CW_Or_Has_Controlled_Part (Utyp))
7580 and then Exp_Is_Function_Call
7584 -- Remove side effects from the expression now so that other parts
7585 -- of the expander do not have to reanalyze this node without this
7588 Rewrite (Exp, Duplicate_Subexpr_No_Checks (Exp));
7590 -- Ada 2005 (AI-251): If the type of the returned object is
7591 -- an interface then add an implicit type conversion to force
7592 -- displacement of the "this" pointer.
7594 if Is_Interface (R_Type) then
7595 Rewrite (Exp, Convert_To (R_Type, Relocate_Node (Exp)));
7598 Analyze_And_Resolve (Exp, R_Type);
7600 -- For controlled types, do the allocation on the secondary stack
7601 -- manually in order to call adjust at the right time:
7603 -- type Anon1 is access R_Type;
7604 -- for Anon1'Storage_pool use ss_pool;
7605 -- Anon2 : anon1 := new R_Type'(expr);
7606 -- return Anon2.all;
7608 -- We do the same for classwide types that are not potentially
7609 -- controlled (by the virtue of restriction No_Finalization) because
7610 -- gigi is not able to properly allocate class-wide types.
7612 elsif CW_Or_Has_Controlled_Part (Utyp) then
7614 Loc : constant Source_Ptr := Sloc (N);
7615 Acc_Typ : constant Entity_Id := Make_Temporary (Loc, 'A');
7616 Alloc_Node : Node_Id;
7620 Set_Ekind (Acc_Typ, E_Access_Type);
7622 Set_Associated_Storage_Pool (Acc_Typ, RTE (RE_SS_Pool));
7624 -- This is an allocator for the secondary stack, and it's fine
7625 -- to have Comes_From_Source set False on it, as gigi knows not
7626 -- to flag it as a violation of No_Implicit_Heap_Allocations.
7629 Make_Allocator (Loc,
7631 Make_Qualified_Expression (Loc,
7632 Subtype_Mark => New_Occurrence_Of (Etype (Exp), Loc),
7633 Expression => Relocate_Node (Exp)));
7635 -- We do not want discriminant checks on the declaration,
7636 -- given that it gets its value from the allocator.
7638 Set_No_Initialization (Alloc_Node);
7640 Temp := Make_Temporary (Loc, 'R', Alloc_Node);
7642 Insert_List_Before_And_Analyze (N, New_List (
7643 Make_Full_Type_Declaration (Loc,
7644 Defining_Identifier => Acc_Typ,
7646 Make_Access_To_Object_Definition (Loc,
7647 Subtype_Indication => Subtype_Ind)),
7649 Make_Object_Declaration (Loc,
7650 Defining_Identifier => Temp,
7651 Object_Definition => New_Occurrence_Of (Acc_Typ, Loc),
7652 Expression => Alloc_Node)));
7655 Make_Explicit_Dereference (Loc,
7656 Prefix => New_Occurrence_Of (Temp, Loc)));
7658 -- Ada 2005 (AI-251): If the type of the returned object is
7659 -- an interface then add an implicit type conversion to force
7660 -- displacement of the "this" pointer.
7662 if Is_Interface (R_Type) then
7663 Rewrite (Exp, Convert_To (R_Type, Relocate_Node (Exp)));
7666 Analyze_And_Resolve (Exp, R_Type);
7669 -- Otherwise use the gigi mechanism to allocate result on the
7673 Check_Restriction (No_Secondary_Stack, N);
7674 Set_Storage_Pool (N, RTE (RE_SS_Pool));
7675 Set_Procedure_To_Call (N, RTE (RE_SS_Allocate));
7679 -- Implement the rules of 6.5(8-10), which require a tag check in
7680 -- the case of a limited tagged return type, and tag reassignment for
7681 -- nonlimited tagged results. These actions are needed when the return
7682 -- type is a specific tagged type and the result expression is a
7683 -- conversion or a formal parameter, because in that case the tag of
7684 -- the expression might differ from the tag of the specific result type.
7686 -- We must also verify an underlying type exists for the return type in
7687 -- case it is incomplete - in which case is not necessary to generate a
7688 -- check anyway since an incomplete limited tagged return type would
7689 -- qualify as a premature usage.
7692 and then Is_Tagged_Type (Utyp)
7693 and then not Is_Class_Wide_Type (Utyp)
7694 and then (Nkind (Exp) in
7695 N_Type_Conversion | N_Unchecked_Type_Conversion
7696 or else (Is_Entity_Name (Exp)
7697 and then Is_Formal (Entity (Exp))))
7699 -- When the return type is limited, perform a check that the tag of
7700 -- the result is the same as the tag of the return type.
7702 if Is_Limited_Type (R_Type) then
7704 Make_Raise_Constraint_Error (Loc,
7708 Make_Selected_Component (Loc,
7709 Prefix => Duplicate_Subexpr (Exp),
7710 Selector_Name => Make_Identifier (Loc, Name_uTag)),
7712 Make_Attribute_Reference (Loc,
7714 New_Occurrence_Of (Base_Type (Utyp), Loc),
7715 Attribute_Name => Name_Tag)),
7716 Reason => CE_Tag_Check_Failed));
7718 -- If the result type is a specific nonlimited tagged type, then we
7719 -- have to ensure that the tag of the result is that of the result
7720 -- type. This is handled by making a copy of the expression in
7721 -- the case where it might have a different tag, namely when the
7722 -- expression is a conversion or a formal parameter. We create a new
7723 -- object of the result type and initialize it from the expression,
7724 -- which will implicitly force the tag to be set appropriately.
7728 ExpR : constant Node_Id := Relocate_Node (Exp);
7729 Result_Id : constant Entity_Id :=
7730 Make_Temporary (Loc, 'R', ExpR);
7731 Result_Exp : constant Node_Id :=
7732 New_Occurrence_Of (Result_Id, Loc);
7733 Result_Obj : constant Node_Id :=
7734 Make_Object_Declaration (Loc,
7735 Defining_Identifier => Result_Id,
7736 Object_Definition =>
7737 New_Occurrence_Of (R_Type, Loc),
7738 Constant_Present => True,
7739 Expression => ExpR);
7742 Set_Assignment_OK (Result_Obj);
7743 Insert_Action (Exp, Result_Obj);
7745 Rewrite (Exp, Result_Exp);
7746 Analyze_And_Resolve (Exp, R_Type);
7750 -- Ada 2005 (AI95-344): If the result type is class-wide, then insert
7751 -- a check that the level of the return expression's underlying type
7752 -- is not deeper than the level of the master enclosing the function.
7754 -- AI12-043: The check is made immediately after the return object is
7755 -- created. This means that we do not apply it to the simple return
7756 -- generated by the expansion of an extended return statement.
7758 -- No runtime check needed in interface thunks since it is performed
7759 -- by the target primitive associated with the thunk.
7761 elsif Is_Class_Wide_Type (R_Type)
7762 and then not Comes_From_Extended_Return_Statement (N)
7763 and then not Is_Thunk (Scope_Id)
7765 Apply_CW_Accessibility_Check (Exp, Scope_Id);
7767 -- Ada 2012 (AI05-0073): If the result subtype of the function is
7768 -- defined by an access_definition designating a specific tagged
7769 -- type T, a check is made that the result value is null or the tag
7770 -- of the object designated by the result value identifies T.
7772 -- The return expression is referenced twice in the code below, so it
7773 -- must be made free of side effects. Given that different compilers
7774 -- may evaluate these parameters in different order, both occurrences
7777 elsif Ekind (R_Type) = E_Anonymous_Access_Type
7778 and then Is_Tagged_Type (Designated_Type (R_Type))
7779 and then not Is_Class_Wide_Type (Designated_Type (R_Type))
7780 and then Nkind (Original_Node (Exp)) /= N_Null
7781 and then not Tag_Checks_Suppressed (Designated_Type (R_Type))
7784 -- [Constraint_Error
7786 -- and then Exp.all not in Designated_Type]
7789 Make_Raise_Constraint_Error (Loc,
7794 Left_Opnd => Duplicate_Subexpr (Exp),
7795 Right_Opnd => Make_Null (Loc)),
7800 Make_Explicit_Dereference (Loc,
7801 Prefix => Duplicate_Subexpr (Exp)),
7803 New_Occurrence_Of (Designated_Type (R_Type), Loc))),
7805 Reason => CE_Tag_Check_Failed),
7806 Suppress => All_Checks);
7809 -- Determine if the special rules within RM 3.10.2 for explicitly
7810 -- aliased formals apply to Exp - in which case we require a dynamic
7811 -- check to be generated.
7813 if Is_Special_Aliased_Formal_Access (Exp, Scope_Id) then
7814 Check_Against_Result_Level
7815 (Make_Integer_Literal (Loc,
7816 Object_Access_Level (Entity (Ultimate_Prefix (Prefix (Exp))))));
7819 -- AI05-0234: Check unconstrained access discriminants to ensure
7820 -- that the result does not outlive an object designated by one
7821 -- of its discriminants (RM 6.5(21/3)).
7823 if Present (Extra_Accessibility_Of_Result (Scope_Id))
7824 and then Has_Unconstrained_Access_Discriminants (R_Type)
7827 Discrim_Source : Node_Id;
7829 Discrim_Source := Exp;
7830 while Nkind (Discrim_Source) = N_Qualified_Expression loop
7831 Discrim_Source := Expression (Discrim_Source);
7834 if Nkind (Discrim_Source) = N_Identifier
7835 and then Is_Return_Object (Entity (Discrim_Source))
7837 Discrim_Source := Entity (Discrim_Source);
7839 if Is_Constrained (Etype (Discrim_Source)) then
7840 Discrim_Source := Etype (Discrim_Source);
7842 Discrim_Source := Expression (Parent (Discrim_Source));
7845 elsif Nkind (Discrim_Source) = N_Identifier
7846 and then Nkind (Original_Node (Discrim_Source)) in
7847 N_Aggregate | N_Extension_Aggregate
7849 Discrim_Source := Original_Node (Discrim_Source);
7851 elsif Nkind (Discrim_Source) = N_Explicit_Dereference and then
7852 Nkind (Original_Node (Discrim_Source)) = N_Function_Call
7854 Discrim_Source := Original_Node (Discrim_Source);
7857 Discrim_Source := Unqual_Conv (Discrim_Source);
7859 case Nkind (Discrim_Source) is
7860 when N_Defining_Identifier =>
7861 pragma Assert (Is_Composite_Type (Discrim_Source)
7862 and then Has_Discriminants (Discrim_Source)
7863 and then Is_Constrained (Discrim_Source));
7866 Discrim : Entity_Id :=
7867 First_Discriminant (Base_Type (R_Type));
7868 Disc_Elmt : Elmt_Id :=
7869 First_Elmt (Discriminant_Constraint
7873 if Ekind (Etype (Discrim)) =
7874 E_Anonymous_Access_Type
7876 Check_Against_Result_Level
7877 (Dynamic_Accessibility_Level (Node (Disc_Elmt)));
7880 Next_Elmt (Disc_Elmt);
7881 Next_Discriminant (Discrim);
7882 exit when not Present (Discrim);
7887 | N_Extension_Aggregate
7889 -- Unimplemented: extension aggregate case where discrims
7890 -- come from ancestor part, not extension part.
7893 Discrim : Entity_Id :=
7894 First_Discriminant (Base_Type (R_Type));
7896 Disc_Exp : Node_Id := Empty;
7898 Positionals_Exhausted
7899 : Boolean := not Present (Expressions
7902 function Associated_Expr
7903 (Comp_Id : Entity_Id;
7904 Associations : List_Id) return Node_Id;
7906 -- Given a component and a component associations list,
7907 -- locate the expression for that component; returns
7908 -- Empty if no such expression is found.
7910 ---------------------
7911 -- Associated_Expr --
7912 ---------------------
7914 function Associated_Expr
7915 (Comp_Id : Entity_Id;
7916 Associations : List_Id) return Node_Id
7922 -- Simple linear search seems ok here
7924 Assoc := First (Associations);
7925 while Present (Assoc) loop
7926 Choice := First (Choices (Assoc));
7927 while Present (Choice) loop
7928 if (Nkind (Choice) = N_Identifier
7929 and then Chars (Choice) = Chars (Comp_Id))
7930 or else (Nkind (Choice) = N_Others_Choice)
7932 return Expression (Assoc);
7942 end Associated_Expr;
7945 if not Positionals_Exhausted then
7946 Disc_Exp := First (Expressions (Discrim_Source));
7950 if Positionals_Exhausted then
7954 Component_Associations (Discrim_Source));
7957 if Ekind (Etype (Discrim)) =
7958 E_Anonymous_Access_Type
7960 Check_Against_Result_Level
7961 (Dynamic_Accessibility_Level (Disc_Exp));
7964 Next_Discriminant (Discrim);
7965 exit when not Present (Discrim);
7967 if not Positionals_Exhausted then
7969 Positionals_Exhausted := not Present (Disc_Exp);
7974 when N_Function_Call =>
7976 -- No check needed (check performed by callee)
7982 Level : constant Node_Id :=
7983 Make_Integer_Literal (Loc,
7984 Object_Access_Level (Discrim_Source));
7987 -- Unimplemented: check for name prefix that includes
7988 -- a dereference of an access value with a dynamic
7989 -- accessibility level (e.g., an access param or a
7990 -- saooaaat) and use dynamic level in that case. For
7992 -- return Access_Param.all(Some_Index).Some_Component;
7995 Set_Etype (Level, Standard_Natural);
7996 Check_Against_Result_Level (Level);
8002 -- If we are returning a nonscalar object that is possibly unaligned,
8003 -- then copy the value into a temporary first. This copy may need to
8004 -- expand to a loop of component operations.
8006 if Is_Possibly_Unaligned_Slice (Exp)
8007 or else (Is_Possibly_Unaligned_Object (Exp)
8008 and then not Represented_As_Scalar (Etype (Exp)))
8011 ExpR : constant Node_Id := Relocate_Node (Exp);
8012 Tnn : constant Entity_Id := Make_Temporary (Loc, 'T', ExpR);
8015 Make_Object_Declaration (Loc,
8016 Defining_Identifier => Tnn,
8017 Constant_Present => True,
8018 Object_Definition => New_Occurrence_Of (R_Type, Loc),
8019 Expression => ExpR),
8020 Suppress => All_Checks);
8021 Rewrite (Exp, New_Occurrence_Of (Tnn, Loc));
8025 -- Call the _Postconditions procedure if the related function has
8026 -- contract assertions that need to be verified on exit.
8028 if Ekind (Scope_Id) = E_Function
8029 and then Present (Postconditions_Proc (Scope_Id))
8031 -- In the case of discriminated objects, we have created a
8032 -- constrained subtype above, and used the underlying type. This
8033 -- transformation is post-analysis and harmless, except that now the
8034 -- call to the post-condition will be analyzed and the type kinds
8037 if Nkind (Exp) = N_Unchecked_Type_Conversion
8038 and then Is_Private_Type (R_Type) /= Is_Private_Type (Etype (Exp))
8040 Rewrite (Exp, Expression (Relocate_Node (Exp)));
8043 -- We are going to reference the returned value twice in this case,
8044 -- once in the call to _Postconditions, and once in the actual return
8045 -- statement, but we can't have side effects happening twice.
8047 Force_Evaluation (Exp, Mode => Strict);
8049 -- Generate call to _Postconditions
8052 Make_Procedure_Call_Statement (Loc,
8054 New_Occurrence_Of (Postconditions_Proc (Scope_Id), Loc),
8055 Parameter_Associations => New_List (New_Copy_Tree (Exp))));
8058 -- Ada 2005 (AI-251): If this return statement corresponds with an
8059 -- simple return statement associated with an extended return statement
8060 -- and the type of the returned object is an interface then generate an
8061 -- implicit conversion to force displacement of the "this" pointer.
8063 if Ada_Version >= Ada_2005
8064 and then Comes_From_Extended_Return_Statement (N)
8065 and then Nkind (Expression (N)) = N_Identifier
8066 and then Is_Interface (Utyp)
8067 and then Utyp /= Underlying_Type (Exp_Typ)
8069 Rewrite (Exp, Convert_To (Utyp, Relocate_Node (Exp)));
8070 Analyze_And_Resolve (Exp);
8073 -- Ada 2020 (AI12-0279)
8075 if Has_Yield_Aspect (Scope_Id)
8076 and then RTE_Available (RE_Yield)
8079 Make_Procedure_Call_Statement (Loc,
8080 New_Occurrence_Of (RTE (RE_Yield), Loc)));
8082 end Expand_Simple_Function_Return;
8084 -----------------------
8085 -- Freeze_Subprogram --
8086 -----------------------
8088 procedure Freeze_Subprogram (N : Node_Id) is
8089 Loc : constant Source_Ptr := Sloc (N);
8091 procedure Register_Predefined_DT_Entry (Prim : Entity_Id);
8092 -- (Ada 2005): Register a predefined primitive in all the secondary
8093 -- dispatch tables of its primitive type.
8095 ----------------------------------
8096 -- Register_Predefined_DT_Entry --
8097 ----------------------------------
8099 procedure Register_Predefined_DT_Entry (Prim : Entity_Id) is
8100 Iface_DT_Ptr : Elmt_Id;
8101 Tagged_Typ : Entity_Id;
8102 Thunk_Id : Entity_Id;
8103 Thunk_Code : Node_Id;
8106 Tagged_Typ := Find_Dispatching_Type (Prim);
8108 if No (Access_Disp_Table (Tagged_Typ))
8109 or else not Has_Interfaces (Tagged_Typ)
8110 or else not RTE_Available (RE_Interface_Tag)
8111 or else Restriction_Active (No_Dispatching_Calls)
8116 -- Skip the first two access-to-dispatch-table pointers since they
8117 -- leads to the primary dispatch table (predefined DT and user
8118 -- defined DT). We are only concerned with the secondary dispatch
8119 -- table pointers. Note that the access-to- dispatch-table pointer
8120 -- corresponds to the first implemented interface retrieved below.
8123 Next_Elmt (Next_Elmt (First_Elmt (Access_Disp_Table (Tagged_Typ))));
8125 while Present (Iface_DT_Ptr)
8126 and then Ekind (Node (Iface_DT_Ptr)) = E_Constant
8128 pragma Assert (Has_Thunks (Node (Iface_DT_Ptr)));
8129 Expand_Interface_Thunk (Prim, Thunk_Id, Thunk_Code,
8130 Iface => Related_Type (Node (Iface_DT_Ptr)));
8132 if Present (Thunk_Code) then
8133 Insert_Actions_After (N, New_List (
8136 Build_Set_Predefined_Prim_Op_Address (Loc,
8138 New_Occurrence_Of (Node (Next_Elmt (Iface_DT_Ptr)), Loc),
8139 Position => DT_Position (Prim),
8141 Unchecked_Convert_To (RTE (RE_Prim_Ptr),
8142 Make_Attribute_Reference (Loc,
8143 Prefix => New_Occurrence_Of (Thunk_Id, Loc),
8144 Attribute_Name => Name_Unrestricted_Access))),
8146 Build_Set_Predefined_Prim_Op_Address (Loc,
8149 (Node (Next_Elmt (Next_Elmt (Next_Elmt (Iface_DT_Ptr)))),
8151 Position => DT_Position (Prim),
8153 Unchecked_Convert_To (RTE (RE_Prim_Ptr),
8154 Make_Attribute_Reference (Loc,
8155 Prefix => New_Occurrence_Of (Prim, Loc),
8156 Attribute_Name => Name_Unrestricted_Access)))));
8159 -- Skip the tag of the predefined primitives dispatch table
8161 Next_Elmt (Iface_DT_Ptr);
8162 pragma Assert (Has_Thunks (Node (Iface_DT_Ptr)));
8164 -- Skip tag of the no-thunks dispatch table
8166 Next_Elmt (Iface_DT_Ptr);
8167 pragma Assert (not Has_Thunks (Node (Iface_DT_Ptr)));
8169 -- Skip tag of predefined primitives no-thunks dispatch table
8171 Next_Elmt (Iface_DT_Ptr);
8172 pragma Assert (not Has_Thunks (Node (Iface_DT_Ptr)));
8174 Next_Elmt (Iface_DT_Ptr);
8176 end Register_Predefined_DT_Entry;
8180 Subp : constant Entity_Id := Entity (N);
8182 -- Start of processing for Freeze_Subprogram
8185 -- We suppress the initialization of the dispatch table entry when
8186 -- not Tagged_Type_Expansion because the dispatching mechanism is
8187 -- handled internally by the target.
8189 if Is_Dispatching_Operation (Subp)
8190 and then not Is_Abstract_Subprogram (Subp)
8191 and then Present (DTC_Entity (Subp))
8192 and then Present (Scope (DTC_Entity (Subp)))
8193 and then Tagged_Type_Expansion
8194 and then not Restriction_Active (No_Dispatching_Calls)
8195 and then RTE_Available (RE_Tag)
8198 Typ : constant Entity_Id := Scope (DTC_Entity (Subp));
8201 -- Handle private overridden primitives
8203 if not Is_CPP_Class (Typ) then
8204 Check_Overriding_Operation (Subp);
8207 -- We assume that imported CPP primitives correspond with objects
8208 -- whose constructor is in the CPP side; therefore we don't need
8209 -- to generate code to register them in the dispatch table.
8211 if Is_CPP_Class (Typ) then
8214 -- Handle CPP primitives found in derivations of CPP_Class types.
8215 -- These primitives must have been inherited from some parent, and
8216 -- there is no need to register them in the dispatch table because
8217 -- Build_Inherit_Prims takes care of initializing these slots.
8219 elsif Is_Imported (Subp)
8220 and then Convention (Subp) in Convention_C_Family
8224 -- Generate code to register the primitive in non statically
8225 -- allocated dispatch tables
8227 elsif not Building_Static_DT (Scope (DTC_Entity (Subp))) then
8229 -- When a primitive is frozen, enter its name in its dispatch
8232 if not Is_Interface (Typ)
8233 or else Present (Interface_Alias (Subp))
8235 if Is_Predefined_Dispatching_Operation (Subp) then
8236 Register_Predefined_DT_Entry (Subp);
8239 Insert_Actions_After (N,
8240 Register_Primitive (Loc, Prim => Subp));
8246 -- Mark functions that return by reference. Note that it cannot be part
8247 -- of the normal semantic analysis of the spec since the underlying
8248 -- returned type may not be known yet (for private types).
8251 Typ : constant Entity_Id := Etype (Subp);
8252 Utyp : constant Entity_Id := Underlying_Type (Typ);
8255 if Is_Limited_View (Typ) then
8256 Set_Returns_By_Ref (Subp);
8258 elsif Present (Utyp) and then CW_Or_Has_Controlled_Part (Utyp) then
8259 Set_Returns_By_Ref (Subp);
8263 -- Wnen freezing a null procedure, analyze its delayed aspects now
8264 -- because we may not have reached the end of the declarative list when
8265 -- delayed aspects are normally analyzed. This ensures that dispatching
8266 -- calls are properly rewritten when the generated _Postcondition
8267 -- procedure is analyzed in the null procedure body.
8269 if Nkind (Parent (Subp)) = N_Procedure_Specification
8270 and then Null_Present (Parent (Subp))
8272 Analyze_Entry_Or_Subprogram_Contract (Subp);
8274 end Freeze_Subprogram;
8276 --------------------------
8277 -- Has_BIP_Extra_Formal --
8278 --------------------------
8280 function Has_BIP_Extra_Formal
8282 Kind : BIP_Formal_Kind) return Boolean
8284 Extra_Formal : Entity_Id := Extra_Formals (E);
8287 -- We can only rely on the availability of the extra formals in frozen
8288 -- entities or in subprogram types of dispatching calls (since their
8289 -- extra formals are added when the target subprogram is frozen; see
8290 -- Expand_Dispatching_Call).
8292 pragma Assert (Is_Frozen (E)
8293 or else (Ekind (E) = E_Subprogram_Type
8294 and then Is_Dispatch_Table_Entity (E))
8295 or else (Is_Dispatching_Operation (E)
8296 and then Is_Frozen (Find_Dispatching_Type (E))));
8298 while Present (Extra_Formal) loop
8299 if Is_Build_In_Place_Entity (Extra_Formal)
8300 and then BIP_Suffix_Kind (Extra_Formal) = Kind
8305 Next_Formal_With_Extras (Extra_Formal);
8309 end Has_BIP_Extra_Formal;
8311 ------------------------------
8312 -- Insert_Post_Call_Actions --
8313 ------------------------------
8315 procedure Insert_Post_Call_Actions (N : Node_Id; Post_Call : List_Id) is
8316 Context : constant Node_Id := Parent (N);
8319 if Is_Empty_List (Post_Call) then
8323 -- Cases where the call is not a member of a statement list. This also
8324 -- includes the cases where the call is an actual in another function
8325 -- call, or is an index, or is an operand of an if-expression, i.e. is
8326 -- in an expression context.
8328 if not Is_List_Member (N)
8329 or else Nkind (Context) in N_Function_Call
8331 | N_Indexed_Component
8333 -- In Ada 2012 the call may be a function call in an expression
8334 -- (since OUT and IN OUT parameters are now allowed for such calls).
8335 -- The write-back of (in)-out parameters is handled by the back-end,
8336 -- but the constraint checks generated when subtypes of formal and
8337 -- actual don't match must be inserted in the form of assignments.
8339 if Nkind (N) = N_Function_Call
8340 or else Nkind (Original_Node (N)) = N_Function_Call
8342 pragma Assert (Ada_Version >= Ada_2012);
8343 -- Functions with '[in] out' parameters are only allowed in Ada
8346 -- We used to handle this by climbing up parents to a
8347 -- non-statement/declaration and then simply making a call to
8348 -- Insert_Actions_After (P, Post_Call), but that doesn't work
8349 -- for Ada 2012. If we are in the middle of an expression, e.g.
8350 -- the condition of an IF, this call would insert after the IF
8351 -- statement, which is much too late to be doing the write back.
8354 -- if Clobber (X) then
8355 -- Put_Line (X'Img);
8360 -- Now assume Clobber changes X, if we put the write back after
8361 -- the IF, the Put_Line gets the wrong value and the goto causes
8362 -- the write back to be skipped completely.
8364 -- To deal with this, we replace the call by
8367 -- Tnnn : constant function-result-type := function-call;
8368 -- Post_Call actions
8374 Loc : constant Source_Ptr := Sloc (N);
8375 Tnnn : constant Entity_Id := Make_Temporary (Loc, 'T');
8376 FRTyp : constant Entity_Id := Etype (N);
8377 Name : constant Node_Id := Relocate_Node (N);
8380 Prepend_To (Post_Call,
8381 Make_Object_Declaration (Loc,
8382 Defining_Identifier => Tnnn,
8383 Object_Definition => New_Occurrence_Of (FRTyp, Loc),
8384 Constant_Present => True,
8385 Expression => Name));
8388 Make_Expression_With_Actions (Loc,
8389 Actions => Post_Call,
8390 Expression => New_Occurrence_Of (Tnnn, Loc)));
8392 -- We don't want to just blindly call Analyze_And_Resolve
8393 -- because that would cause unwanted recursion on the call.
8394 -- So for a moment set the call as analyzed to prevent that
8395 -- recursion, and get the rest analyzed properly, then reset
8396 -- the analyzed flag, so our caller can continue.
8398 Set_Analyzed (Name, True);
8399 Analyze_And_Resolve (N, FRTyp);
8400 Set_Analyzed (Name, False);
8403 -- If not the special Ada 2012 case of a function call, then we must
8404 -- have the triggering statement of a triggering alternative or an
8405 -- entry call alternative, and we can add the post call stuff to the
8406 -- corresponding statement list.
8409 pragma Assert (Nkind (Context) in N_Entry_Call_Alternative
8410 | N_Triggering_Alternative);
8412 if Is_Non_Empty_List (Statements (Context)) then
8413 Insert_List_Before_And_Analyze
8414 (First (Statements (Context)), Post_Call);
8416 Set_Statements (Context, Post_Call);
8420 -- A procedure call is always part of a declarative or statement list,
8421 -- however a function call may appear nested within a construct. Most
8422 -- cases of function call nesting are handled in the special case above.
8423 -- The only exception is when the function call acts as an actual in a
8424 -- procedure call. In this case the function call is in a list, but the
8425 -- post-call actions must be inserted after the procedure call.
8427 elsif Nkind (Context) = N_Procedure_Call_Statement then
8428 Insert_Actions_After (Context, Post_Call);
8430 -- Otherwise, normal case where N is in a statement sequence, just put
8431 -- the post-call stuff after the call statement.
8434 Insert_Actions_After (N, Post_Call);
8436 end Insert_Post_Call_Actions;
8438 -----------------------------------
8439 -- Is_Build_In_Place_Result_Type --
8440 -----------------------------------
8442 function Is_Build_In_Place_Result_Type (Typ : Entity_Id) return Boolean is
8444 if not Expander_Active then
8448 -- In Ada 2005 all functions with an inherently limited return type
8449 -- must be handled using a build-in-place profile, including the case
8450 -- of a function with a limited interface result, where the function
8451 -- may return objects of nonlimited descendants.
8453 if Is_Limited_View (Typ) then
8454 return Ada_Version >= Ada_2005 and then not Debug_Flag_Dot_L;
8457 if Debug_Flag_Dot_9 then
8461 if Has_Interfaces (Typ) then
8466 T : Entity_Id := Typ;
8468 -- For T'Class, return True if it's True for T. This is necessary
8469 -- because a class-wide function might say "return F (...)", where
8470 -- F returns the corresponding specific type. We need a loop in
8471 -- case T is a subtype of a class-wide type.
8473 while Is_Class_Wide_Type (T) loop
8477 -- If this is a generic formal type in an instance, return True if
8478 -- it's True for the generic actual type.
8480 if Nkind (Parent (T)) = N_Subtype_Declaration
8481 and then Present (Generic_Parent_Type (Parent (T)))
8483 T := Entity (Subtype_Indication (Parent (T)));
8485 if Present (Full_View (T)) then
8490 if Present (Underlying_Type (T)) then
8491 T := Underlying_Type (T);
8496 -- So we can stop here in the debugger
8498 -- ???For now, enable build-in-place for a very narrow set of
8499 -- controlled types. Change "if True" to "if False" to
8500 -- experiment with more controlled types. Eventually, we might
8501 -- like to enable build-in-place for all tagged types, all
8502 -- types that need finalization, and all caller-unknown-size
8506 Result := Is_Controlled (T)
8507 and then Present (Enclosing_Subprogram (T))
8508 and then not Is_Compilation_Unit (Enclosing_Subprogram (T))
8509 and then Ekind (Enclosing_Subprogram (T)) = E_Procedure;
8511 Result := Is_Controlled (T);
8518 end Is_Build_In_Place_Result_Type;
8520 ------------------------------
8521 -- Is_Build_In_Place_Entity --
8522 ------------------------------
8524 function Is_Build_In_Place_Entity (E : Entity_Id) return Boolean is
8525 Nam : constant String := Get_Name_String (Chars (E));
8527 function Has_Suffix (Suffix : String) return Boolean;
8528 -- Return True if Nam has suffix Suffix
8530 function Has_Suffix (Suffix : String) return Boolean is
8531 Len : constant Natural := Suffix'Length;
8533 return Nam'Length > Len
8534 and then Nam (Nam'Last - Len + 1 .. Nam'Last) = Suffix;
8537 -- Start of processing for Is_Build_In_Place_Entity
8540 return Has_Suffix (BIP_Alloc_Suffix)
8541 or else Has_Suffix (BIP_Storage_Pool_Suffix)
8542 or else Has_Suffix (BIP_Finalization_Master_Suffix)
8543 or else Has_Suffix (BIP_Task_Master_Suffix)
8544 or else Has_Suffix (BIP_Activation_Chain_Suffix)
8545 or else Has_Suffix (BIP_Object_Access_Suffix);
8546 end Is_Build_In_Place_Entity;
8548 --------------------------------
8549 -- Is_Build_In_Place_Function --
8550 --------------------------------
8552 function Is_Build_In_Place_Function (E : Entity_Id) return Boolean is
8554 -- This function is called from Expand_Subtype_From_Expr during
8555 -- semantic analysis, even when expansion is off. In those cases
8556 -- the build_in_place expansion will not take place.
8558 if not Expander_Active then
8562 -- For now we test whether E denotes a function or access-to-function
8563 -- type whose result subtype is inherently limited. Later this test
8564 -- may be revised to allow composite nonlimited types.
8566 if Ekind (E) in E_Function | E_Generic_Function
8567 or else (Ekind (E) = E_Subprogram_Type
8568 and then Etype (E) /= Standard_Void_Type)
8570 -- If the function is imported from a foreign language, we don't do
8571 -- build-in-place. Note that Import (Ada) functions can do
8572 -- build-in-place. Note that it is OK for a build-in-place function
8573 -- to return a type with a foreign convention; the build-in-place
8574 -- machinery will ensure there is no copying.
8576 return Is_Build_In_Place_Result_Type (Etype (E))
8577 and then not (Has_Foreign_Convention (E) and then Is_Imported (E))
8578 and then not Debug_Flag_Dot_L;
8582 end Is_Build_In_Place_Function;
8584 -------------------------------------
8585 -- Is_Build_In_Place_Function_Call --
8586 -------------------------------------
8588 function Is_Build_In_Place_Function_Call (N : Node_Id) return Boolean is
8589 Exp_Node : constant Node_Id := Unqual_Conv (N);
8590 Function_Id : Entity_Id;
8593 -- Return False if the expander is currently inactive, since awareness
8594 -- of build-in-place treatment is only relevant during expansion. Note
8595 -- that Is_Build_In_Place_Function, which is called as part of this
8596 -- function, is also conditioned this way, but we need to check here as
8597 -- well to avoid blowing up on processing protected calls when expansion
8598 -- is disabled (such as with -gnatc) since those would trip over the
8599 -- raise of Program_Error below.
8601 -- In SPARK mode, build-in-place calls are not expanded, so that we
8602 -- may end up with a call that is neither resolved to an entity, nor
8603 -- an indirect call.
8605 if not Expander_Active or else Nkind (Exp_Node) /= N_Function_Call then
8609 if Is_Entity_Name (Name (Exp_Node)) then
8610 Function_Id := Entity (Name (Exp_Node));
8612 -- In the case of an explicitly dereferenced call, use the subprogram
8613 -- type generated for the dereference.
8615 elsif Nkind (Name (Exp_Node)) = N_Explicit_Dereference then
8616 Function_Id := Etype (Name (Exp_Node));
8618 -- This may be a call to a protected function.
8620 elsif Nkind (Name (Exp_Node)) = N_Selected_Component then
8621 Function_Id := Etype (Entity (Selector_Name (Name (Exp_Node))));
8624 raise Program_Error;
8628 Result : constant Boolean := Is_Build_In_Place_Function (Function_Id);
8629 -- So we can stop here in the debugger
8633 end Is_Build_In_Place_Function_Call;
8635 -----------------------
8636 -- Is_Null_Procedure --
8637 -----------------------
8639 function Is_Null_Procedure (Subp : Entity_Id) return Boolean is
8640 Decl : constant Node_Id := Unit_Declaration_Node (Subp);
8643 if Ekind (Subp) /= E_Procedure then
8646 -- Check if this is a declared null procedure
8648 elsif Nkind (Decl) = N_Subprogram_Declaration then
8649 if not Null_Present (Specification (Decl)) then
8652 elsif No (Body_To_Inline (Decl)) then
8655 -- Check if the body contains only a null statement, followed by
8656 -- the return statement added during expansion.
8660 Orig_Bod : constant Node_Id := Body_To_Inline (Decl);
8666 if Nkind (Orig_Bod) /= N_Subprogram_Body then
8669 -- We must skip SCIL nodes because they are currently
8670 -- implemented as special N_Null_Statement nodes.
8674 (Statements (Handled_Statement_Sequence (Orig_Bod)));
8675 Stat2 := Next_Non_SCIL_Node (Stat);
8678 Is_Empty_List (Declarations (Orig_Bod))
8679 and then Nkind (Stat) = N_Null_Statement
8683 (Nkind (Stat2) = N_Simple_Return_Statement
8684 and then No (Next (Stat2))));
8692 end Is_Null_Procedure;
8694 -------------------------------------------
8695 -- Make_Build_In_Place_Call_In_Allocator --
8696 -------------------------------------------
8698 procedure Make_Build_In_Place_Call_In_Allocator
8699 (Allocator : Node_Id;
8700 Function_Call : Node_Id)
8702 Acc_Type : constant Entity_Id := Etype (Allocator);
8703 Loc : constant Source_Ptr := Sloc (Function_Call);
8704 Func_Call : Node_Id := Function_Call;
8705 Ref_Func_Call : Node_Id;
8706 Function_Id : Entity_Id;
8707 Result_Subt : Entity_Id;
8708 New_Allocator : Node_Id;
8709 Return_Obj_Access : Entity_Id; -- temp for function result
8710 Temp_Init : Node_Id; -- initial value of Return_Obj_Access
8711 Alloc_Form : BIP_Allocation_Form;
8712 Pool : Node_Id; -- nonnull if Alloc_Form = User_Storage_Pool
8713 Return_Obj_Actual : Node_Id; -- the temp.all, in caller-allocates case
8714 Chain : Entity_Id; -- activation chain, in case of tasks
8717 -- Step past qualification or unchecked conversion (the latter can occur
8718 -- in cases of calls to 'Input).
8720 if Nkind (Func_Call) in N_Qualified_Expression
8722 | N_Unchecked_Type_Conversion
8724 Func_Call := Expression (Func_Call);
8727 -- Mark the call as processed as a build-in-place call
8729 pragma Assert (not Is_Expanded_Build_In_Place_Call (Func_Call));
8730 Set_Is_Expanded_Build_In_Place_Call (Func_Call);
8732 if Is_Entity_Name (Name (Func_Call)) then
8733 Function_Id := Entity (Name (Func_Call));
8735 elsif Nkind (Name (Func_Call)) = N_Explicit_Dereference then
8736 Function_Id := Etype (Name (Func_Call));
8739 raise Program_Error;
8742 Warn_BIP (Func_Call);
8744 Result_Subt := Available_View (Etype (Function_Id));
8746 -- Create a temp for the function result. In the caller-allocates case,
8747 -- this will be initialized to the result of a new uninitialized
8748 -- allocator. Note: we do not use Allocator as the Related_Node of
8749 -- Return_Obj_Access in call to Make_Temporary below as this would
8750 -- create a sort of infinite "recursion".
8752 Return_Obj_Access := Make_Temporary (Loc, 'R');
8753 Set_Etype (Return_Obj_Access, Acc_Type);
8754 Set_Can_Never_Be_Null (Acc_Type, False);
8755 -- It gets initialized to null, so we can't have that
8757 -- When the result subtype is constrained, the return object is created
8758 -- on the caller side, and access to it is passed to the function. This
8759 -- optimization is disabled when the result subtype needs finalization
8760 -- actions because the caller side allocation may result in undesirable
8761 -- finalization. Consider the following example:
8763 -- function Make_Lim_Ctrl return Lim_Ctrl is
8765 -- return Result : Lim_Ctrl := raise Program_Error do
8768 -- end Make_Lim_Ctrl;
8770 -- Obj : Lim_Ctrl_Ptr := new Lim_Ctrl'(Make_Lim_Ctrl);
8772 -- Even though the size of limited controlled type Lim_Ctrl is known,
8773 -- allocating Obj at the caller side will chain Obj on Lim_Ctrl_Ptr's
8774 -- finalization master. The subsequent call to Make_Lim_Ctrl will fail
8775 -- during the initialization actions for Result, which implies that
8776 -- Result (and Obj by extension) should not be finalized. However Obj
8777 -- will be finalized when access type Lim_Ctrl_Ptr goes out of scope
8778 -- since it is already attached on the related finalization master.
8780 -- Here and in related routines, we must examine the full view of the
8781 -- type, because the view at the point of call may differ from the
8782 -- one in the function body, and the expansion mechanism depends on
8783 -- the characteristics of the full view.
8785 if Needs_BIP_Alloc_Form (Function_Id) then
8788 -- Case of a user-defined storage pool. Pass an allocation parameter
8789 -- indicating that the function should allocate its result in the
8790 -- pool, and pass the pool. Use 'Unrestricted_Access because the
8791 -- pool may not be aliased.
8793 if Present (Associated_Storage_Pool (Acc_Type)) then
8794 Alloc_Form := User_Storage_Pool;
8796 Make_Attribute_Reference (Loc,
8799 (Associated_Storage_Pool (Acc_Type), Loc),
8800 Attribute_Name => Name_Unrestricted_Access);
8802 -- No user-defined pool; pass an allocation parameter indicating that
8803 -- the function should allocate its result on the heap.
8806 Alloc_Form := Global_Heap;
8807 Pool := Make_Null (No_Location);
8810 -- The caller does not provide the return object in this case, so we
8811 -- have to pass null for the object access actual.
8813 Return_Obj_Actual := Empty;
8816 -- Replace the initialized allocator of form "new T'(Func (...))"
8817 -- with an uninitialized allocator of form "new T", where T is the
8818 -- result subtype of the called function. The call to the function
8819 -- is handled separately further below.
8822 Make_Allocator (Loc,
8823 Expression => New_Occurrence_Of (Result_Subt, Loc));
8824 Set_No_Initialization (New_Allocator);
8826 -- Copy attributes to new allocator. Note that the new allocator
8827 -- logically comes from source if the original one did, so copy the
8828 -- relevant flag. This ensures proper treatment of the restriction
8829 -- No_Implicit_Heap_Allocations in this case.
8831 Set_Storage_Pool (New_Allocator, Storage_Pool (Allocator));
8832 Set_Procedure_To_Call (New_Allocator, Procedure_To_Call (Allocator));
8833 Set_Comes_From_Source (New_Allocator, Comes_From_Source (Allocator));
8835 Rewrite (Allocator, New_Allocator);
8837 -- Initial value of the temp is the result of the uninitialized
8838 -- allocator. Unchecked_Convert is needed for T'Input where T is
8839 -- derived from a controlled type.
8841 Temp_Init := Relocate_Node (Allocator);
8843 if Nkind (Function_Call) in
8844 N_Type_Conversion | N_Unchecked_Type_Conversion
8846 Temp_Init := Unchecked_Convert_To (Acc_Type, Temp_Init);
8849 -- Indicate that caller allocates, and pass in the return object
8851 Alloc_Form := Caller_Allocation;
8852 Pool := Make_Null (No_Location);
8853 Return_Obj_Actual :=
8854 Make_Unchecked_Type_Conversion (Loc,
8855 Subtype_Mark => New_Occurrence_Of (Result_Subt, Loc),
8857 Make_Explicit_Dereference (Loc,
8858 Prefix => New_Occurrence_Of (Return_Obj_Access, Loc)));
8860 -- When the result subtype is unconstrained, the function itself must
8861 -- perform the allocation of the return object, so we pass parameters
8866 -- Declare the temp object
8868 Insert_Action (Allocator,
8869 Make_Object_Declaration (Loc,
8870 Defining_Identifier => Return_Obj_Access,
8871 Object_Definition => New_Occurrence_Of (Acc_Type, Loc),
8872 Expression => Temp_Init));
8874 Ref_Func_Call := Make_Reference (Loc, Func_Call);
8876 -- Ada 2005 (AI-251): If the type of the allocator is an interface
8877 -- then generate an implicit conversion to force displacement of the
8880 if Is_Interface (Designated_Type (Acc_Type)) then
8883 OK_Convert_To (Acc_Type, Ref_Func_Call));
8885 -- If the types are incompatible, we need an unchecked conversion. Note
8886 -- that the full types will be compatible, but the types not visibly
8889 elsif Nkind (Function_Call)
8890 in N_Type_Conversion | N_Unchecked_Type_Conversion
8892 Ref_Func_Call := Unchecked_Convert_To (Acc_Type, Ref_Func_Call);
8896 Assign : constant Node_Id :=
8897 Make_Assignment_Statement (Loc,
8898 Name => New_Occurrence_Of (Return_Obj_Access, Loc),
8899 Expression => Ref_Func_Call);
8900 -- Assign the result of the function call into the temp. In the
8901 -- caller-allocates case, this is overwriting the temp with its
8902 -- initial value, which has no effect. In the callee-allocates case,
8903 -- this is setting the temp to point to the object allocated by the
8904 -- callee. Unchecked_Convert is needed for T'Input where T is derived
8905 -- from a controlled type.
8908 -- Actions to be inserted. If there are no tasks, this is just the
8909 -- assignment statement. If the allocated object has tasks, we need
8910 -- to wrap the assignment in a block that activates them. The
8911 -- activation chain of that block must be passed to the function,
8912 -- rather than some outer chain.
8915 if Has_Task (Result_Subt) or else Might_Have_Tasks (Result_Subt) then
8916 Actions := New_List;
8917 Build_Task_Allocate_Block_With_Init_Stmts
8918 (Actions, Allocator, Init_Stmts => New_List (Assign));
8919 Chain := Activation_Chain_Entity (Last (Actions));
8921 Actions := New_List (Assign);
8925 Insert_Actions (Allocator, Actions);
8928 -- When the function has a controlling result, an allocation-form
8929 -- parameter must be passed indicating that the caller is allocating
8930 -- the result object. This is needed because such a function can be
8931 -- called as a dispatching operation and must be treated similarly
8932 -- to functions with unconstrained result subtypes.
8934 Add_Unconstrained_Actuals_To_Build_In_Place_Call
8935 (Func_Call, Function_Id, Alloc_Form, Pool_Actual => Pool);
8937 Add_Finalization_Master_Actual_To_Build_In_Place_Call
8938 (Func_Call, Function_Id, Acc_Type);
8940 Add_Task_Actuals_To_Build_In_Place_Call
8941 (Func_Call, Function_Id, Master_Actual => Master_Id (Acc_Type),
8944 -- Add an implicit actual to the function call that provides access
8945 -- to the allocated object. An unchecked conversion to the (specific)
8946 -- result subtype of the function is inserted to handle cases where
8947 -- the access type of the allocator has a class-wide designated type.
8949 Add_Access_Actual_To_Build_In_Place_Call
8950 (Func_Call, Function_Id, Return_Obj_Actual);
8952 -- Finally, replace the allocator node with a reference to the temp
8954 Rewrite (Allocator, New_Occurrence_Of (Return_Obj_Access, Loc));
8956 Analyze_And_Resolve (Allocator, Acc_Type);
8957 pragma Assert (Check_Number_Of_Actuals (Func_Call, Function_Id));
8958 pragma Assert (Check_BIP_Actuals (Func_Call, Function_Id));
8959 end Make_Build_In_Place_Call_In_Allocator;
8961 ---------------------------------------------------
8962 -- Make_Build_In_Place_Call_In_Anonymous_Context --
8963 ---------------------------------------------------
8965 procedure Make_Build_In_Place_Call_In_Anonymous_Context
8966 (Function_Call : Node_Id)
8968 Loc : constant Source_Ptr := Sloc (Function_Call);
8969 Func_Call : constant Node_Id := Unqual_Conv (Function_Call);
8970 Function_Id : Entity_Id;
8971 Result_Subt : Entity_Id;
8972 Return_Obj_Id : Entity_Id;
8973 Return_Obj_Decl : Entity_Id;
8976 -- If the call has already been processed to add build-in-place actuals
8977 -- then return. One place this can occur is for calls to build-in-place
8978 -- functions that occur within a call to a protected operation, where
8979 -- due to rewriting and expansion of the protected call there can be
8980 -- more than one call to Expand_Actuals for the same set of actuals.
8982 if Is_Expanded_Build_In_Place_Call (Func_Call) then
8986 -- Mark the call as processed as a build-in-place call
8988 Set_Is_Expanded_Build_In_Place_Call (Func_Call);
8990 if Is_Entity_Name (Name (Func_Call)) then
8991 Function_Id := Entity (Name (Func_Call));
8993 elsif Nkind (Name (Func_Call)) = N_Explicit_Dereference then
8994 Function_Id := Etype (Name (Func_Call));
8997 raise Program_Error;
9000 Warn_BIP (Func_Call);
9002 Result_Subt := Etype (Function_Id);
9004 -- If the build-in-place function returns a controlled object, then the
9005 -- object needs to be finalized immediately after the context. Since
9006 -- this case produces a transient scope, the servicing finalizer needs
9007 -- to name the returned object. Create a temporary which is initialized
9008 -- with the function call:
9010 -- Temp_Id : Func_Type := BIP_Func_Call;
9012 -- The initialization expression of the temporary will be rewritten by
9013 -- the expander using the appropriate mechanism in Make_Build_In_Place_
9014 -- Call_In_Object_Declaration.
9016 if Needs_Finalization (Result_Subt) then
9018 Temp_Id : constant Entity_Id := Make_Temporary (Loc, 'R');
9019 Temp_Decl : Node_Id;
9022 -- Reset the guard on the function call since the following does
9023 -- not perform actual call expansion.
9025 Set_Is_Expanded_Build_In_Place_Call (Func_Call, False);
9028 Make_Object_Declaration (Loc,
9029 Defining_Identifier => Temp_Id,
9030 Object_Definition =>
9031 New_Occurrence_Of (Result_Subt, Loc),
9033 New_Copy_Tree (Function_Call));
9035 Insert_Action (Function_Call, Temp_Decl);
9037 Rewrite (Function_Call, New_Occurrence_Of (Temp_Id, Loc));
9038 Analyze (Function_Call);
9041 -- When the result subtype is definite, an object of the subtype is
9042 -- declared and an access value designating it is passed as an actual.
9044 elsif Caller_Known_Size (Func_Call, Result_Subt) then
9046 -- Create a temporary object to hold the function result
9048 Return_Obj_Id := Make_Temporary (Loc, 'R');
9049 Set_Etype (Return_Obj_Id, Result_Subt);
9052 Make_Object_Declaration (Loc,
9053 Defining_Identifier => Return_Obj_Id,
9054 Aliased_Present => True,
9055 Object_Definition => New_Occurrence_Of (Result_Subt, Loc));
9057 Set_No_Initialization (Return_Obj_Decl);
9059 Insert_Action (Func_Call, Return_Obj_Decl);
9061 -- When the function has a controlling result, an allocation-form
9062 -- parameter must be passed indicating that the caller is allocating
9063 -- the result object. This is needed because such a function can be
9064 -- called as a dispatching operation and must be treated similarly
9065 -- to functions with unconstrained result subtypes.
9067 Add_Unconstrained_Actuals_To_Build_In_Place_Call
9068 (Func_Call, Function_Id, Alloc_Form => Caller_Allocation);
9070 Add_Finalization_Master_Actual_To_Build_In_Place_Call
9071 (Func_Call, Function_Id);
9073 Add_Task_Actuals_To_Build_In_Place_Call
9074 (Func_Call, Function_Id, Make_Identifier (Loc, Name_uMaster));
9076 -- Add an implicit actual to the function call that provides access
9077 -- to the caller's return object.
9079 Add_Access_Actual_To_Build_In_Place_Call
9080 (Func_Call, Function_Id, New_Occurrence_Of (Return_Obj_Id, Loc));
9082 pragma Assert (Check_Number_Of_Actuals (Func_Call, Function_Id));
9083 pragma Assert (Check_BIP_Actuals (Func_Call, Function_Id));
9085 -- When the result subtype is unconstrained, the function must allocate
9086 -- the return object in the secondary stack, so appropriate implicit
9087 -- parameters are added to the call to indicate that. A transient
9088 -- scope is established to ensure eventual cleanup of the result.
9091 -- Pass an allocation parameter indicating that the function should
9092 -- allocate its result on the secondary stack.
9094 Add_Unconstrained_Actuals_To_Build_In_Place_Call
9095 (Func_Call, Function_Id, Alloc_Form => Secondary_Stack);
9097 Add_Finalization_Master_Actual_To_Build_In_Place_Call
9098 (Func_Call, Function_Id);
9100 Add_Task_Actuals_To_Build_In_Place_Call
9101 (Func_Call, Function_Id, Make_Identifier (Loc, Name_uMaster));
9103 -- Pass a null value to the function since no return object is
9104 -- available on the caller side.
9106 Add_Access_Actual_To_Build_In_Place_Call
9107 (Func_Call, Function_Id, Empty);
9109 pragma Assert (Check_Number_Of_Actuals (Func_Call, Function_Id));
9110 pragma Assert (Check_BIP_Actuals (Func_Call, Function_Id));
9112 end Make_Build_In_Place_Call_In_Anonymous_Context;
9114 --------------------------------------------
9115 -- Make_Build_In_Place_Call_In_Assignment --
9116 --------------------------------------------
9118 procedure Make_Build_In_Place_Call_In_Assignment
9120 Function_Call : Node_Id)
9122 Func_Call : constant Node_Id := Unqual_Conv (Function_Call);
9123 Lhs : constant Node_Id := Name (Assign);
9124 Loc : constant Source_Ptr := Sloc (Function_Call);
9125 Func_Id : Entity_Id;
9128 Ptr_Typ : Entity_Id;
9129 Ptr_Typ_Decl : Node_Id;
9131 Result_Subt : Entity_Id;
9134 -- Mark the call as processed as a build-in-place call
9136 pragma Assert (not Is_Expanded_Build_In_Place_Call (Func_Call));
9137 Set_Is_Expanded_Build_In_Place_Call (Func_Call);
9139 if Is_Entity_Name (Name (Func_Call)) then
9140 Func_Id := Entity (Name (Func_Call));
9142 elsif Nkind (Name (Func_Call)) = N_Explicit_Dereference then
9143 Func_Id := Etype (Name (Func_Call));
9146 raise Program_Error;
9149 Warn_BIP (Func_Call);
9151 Result_Subt := Etype (Func_Id);
9153 -- When the result subtype is unconstrained, an additional actual must
9154 -- be passed to indicate that the caller is providing the return object.
9155 -- This parameter must also be passed when the called function has a
9156 -- controlling result, because dispatching calls to the function needs
9157 -- to be treated effectively the same as calls to class-wide functions.
9159 Add_Unconstrained_Actuals_To_Build_In_Place_Call
9160 (Func_Call, Func_Id, Alloc_Form => Caller_Allocation);
9162 Add_Finalization_Master_Actual_To_Build_In_Place_Call
9163 (Func_Call, Func_Id);
9165 Add_Task_Actuals_To_Build_In_Place_Call
9166 (Func_Call, Func_Id, Make_Identifier (Loc, Name_uMaster));
9168 -- Add an implicit actual to the function call that provides access to
9169 -- the caller's return object.
9171 Add_Access_Actual_To_Build_In_Place_Call
9174 Make_Unchecked_Type_Conversion (Loc,
9175 Subtype_Mark => New_Occurrence_Of (Result_Subt, Loc),
9176 Expression => Relocate_Node (Lhs)));
9178 -- Create an access type designating the function's result subtype
9180 Ptr_Typ := Make_Temporary (Loc, 'A');
9183 Make_Full_Type_Declaration (Loc,
9184 Defining_Identifier => Ptr_Typ,
9186 Make_Access_To_Object_Definition (Loc,
9187 All_Present => True,
9188 Subtype_Indication =>
9189 New_Occurrence_Of (Result_Subt, Loc)));
9190 Insert_After_And_Analyze (Assign, Ptr_Typ_Decl);
9192 -- Finally, create an access object initialized to a reference to the
9193 -- function call. We know this access value is non-null, so mark the
9194 -- entity accordingly to suppress junk access checks.
9196 New_Expr := Make_Reference (Loc, Relocate_Node (Func_Call));
9198 -- Add a conversion if it's the wrong type
9200 if Etype (New_Expr) /= Ptr_Typ then
9202 Make_Unchecked_Type_Conversion (Loc,
9203 New_Occurrence_Of (Ptr_Typ, Loc), New_Expr);
9206 Obj_Id := Make_Temporary (Loc, 'R', New_Expr);
9207 Set_Etype (Obj_Id, Ptr_Typ);
9208 Set_Is_Known_Non_Null (Obj_Id);
9211 Make_Object_Declaration (Loc,
9212 Defining_Identifier => Obj_Id,
9213 Object_Definition => New_Occurrence_Of (Ptr_Typ, Loc),
9214 Expression => New_Expr);
9215 Insert_After_And_Analyze (Ptr_Typ_Decl, Obj_Decl);
9217 Rewrite (Assign, Make_Null_Statement (Loc));
9218 pragma Assert (Check_Number_Of_Actuals (Func_Call, Func_Id));
9219 pragma Assert (Check_BIP_Actuals (Func_Call, Func_Id));
9220 end Make_Build_In_Place_Call_In_Assignment;
9222 ----------------------------------------------------
9223 -- Make_Build_In_Place_Call_In_Object_Declaration --
9224 ----------------------------------------------------
9226 procedure Make_Build_In_Place_Call_In_Object_Declaration
9227 (Obj_Decl : Node_Id;
9228 Function_Call : Node_Id)
9230 function Get_Function_Id (Func_Call : Node_Id) return Entity_Id;
9231 -- Get the value of Function_Id, below
9233 ---------------------
9234 -- Get_Function_Id --
9235 ---------------------
9237 function Get_Function_Id (Func_Call : Node_Id) return Entity_Id is
9239 if Is_Entity_Name (Name (Func_Call)) then
9240 return Entity (Name (Func_Call));
9242 elsif Nkind (Name (Func_Call)) = N_Explicit_Dereference then
9243 return Etype (Name (Func_Call));
9246 raise Program_Error;
9248 end Get_Function_Id;
9252 Func_Call : constant Node_Id := Unqual_Conv (Function_Call);
9253 Function_Id : constant Entity_Id := Get_Function_Id (Func_Call);
9254 Loc : constant Source_Ptr := Sloc (Function_Call);
9255 Obj_Loc : constant Source_Ptr := Sloc (Obj_Decl);
9256 Obj_Def_Id : constant Entity_Id := Defining_Identifier (Obj_Decl);
9257 Obj_Typ : constant Entity_Id := Etype (Obj_Def_Id);
9258 Encl_Func : constant Entity_Id := Enclosing_Subprogram (Obj_Def_Id);
9259 Result_Subt : constant Entity_Id := Etype (Function_Id);
9261 Call_Deref : Node_Id;
9262 Caller_Object : Node_Id;
9264 Designated_Type : Entity_Id;
9265 Fmaster_Actual : Node_Id := Empty;
9266 Pool_Actual : Node_Id;
9267 Ptr_Typ : Entity_Id;
9268 Ptr_Typ_Decl : Node_Id;
9269 Pass_Caller_Acc : Boolean := False;
9272 Definite : constant Boolean :=
9273 Caller_Known_Size (Func_Call, Result_Subt)
9274 and then not Is_Class_Wide_Type (Obj_Typ);
9275 -- In the case of "X : T'Class := F(...);", where F returns a
9276 -- Caller_Known_Size (specific) tagged type, we treat it as
9277 -- indefinite, because the code for the Definite case below sets the
9278 -- initialization expression of the object to Empty, which would be
9279 -- illegal Ada, and would cause gigi to misallocate X.
9281 -- Start of processing for Make_Build_In_Place_Call_In_Object_Declaration
9284 -- If the call has already been processed to add build-in-place actuals
9287 if Is_Expanded_Build_In_Place_Call (Func_Call) then
9291 -- Mark the call as processed as a build-in-place call
9293 Set_Is_Expanded_Build_In_Place_Call (Func_Call);
9295 Warn_BIP (Func_Call);
9297 -- Create an access type designating the function's result subtype.
9298 -- We use the type of the original call because it may be a call to an
9299 -- inherited operation, which the expansion has replaced with the parent
9300 -- operation that yields the parent type. Note that this access type
9301 -- must be declared before we establish a transient scope, so that it
9302 -- receives the proper accessibility level.
9304 if Is_Class_Wide_Type (Obj_Typ)
9305 and then not Is_Interface (Obj_Typ)
9306 and then not Is_Class_Wide_Type (Etype (Function_Call))
9308 Designated_Type := Obj_Typ;
9310 Designated_Type := Etype (Function_Call);
9313 Ptr_Typ := Make_Temporary (Loc, 'A');
9315 Make_Full_Type_Declaration (Loc,
9316 Defining_Identifier => Ptr_Typ,
9318 Make_Access_To_Object_Definition (Loc,
9319 All_Present => True,
9320 Subtype_Indication =>
9321 New_Occurrence_Of (Designated_Type, Loc)));
9323 -- The access type and its accompanying object must be inserted after
9324 -- the object declaration in the constrained case, so that the function
9325 -- call can be passed access to the object. In the indefinite case, or
9326 -- if the object declaration is for a return object, the access type and
9327 -- object must be inserted before the object, since the object
9328 -- declaration is rewritten to be a renaming of a dereference of the
9329 -- access object. Note: we need to freeze Ptr_Typ explicitly, because
9330 -- the result object is in a different (transient) scope, so won't cause
9333 if Definite and then not Is_Return_Object (Obj_Def_Id) then
9335 -- The presence of an address clause complicates the build-in-place
9336 -- expansion because the indicated address must be processed before
9337 -- the indirect call is generated (including the definition of a
9338 -- local pointer to the object). The address clause may come from
9339 -- an aspect specification or from an explicit attribute
9340 -- specification appearing after the object declaration. These two
9341 -- cases require different processing.
9343 if Has_Aspect (Obj_Def_Id, Aspect_Address) then
9345 -- Skip non-delayed pragmas that correspond to other aspects, if
9346 -- any, to find proper insertion point for freeze node of object.
9349 D : Node_Id := Obj_Decl;
9350 N : Node_Id := Next (D);
9354 and then Nkind (N) in N_Attribute_Reference | N_Pragma
9361 Insert_After (D, Ptr_Typ_Decl);
9363 -- Freeze object before pointer declaration, to ensure that
9364 -- generated attribute for address is inserted at the proper
9367 Freeze_Before (Ptr_Typ_Decl, Obj_Def_Id);
9370 Analyze (Ptr_Typ_Decl);
9372 elsif Present (Following_Address_Clause (Obj_Decl)) then
9374 -- Locate explicit address clause, which may also follow pragmas
9375 -- generated by other aspect specifications.
9378 Addr : constant Node_Id := Following_Address_Clause (Obj_Decl);
9379 D : Node_Id := Next (Obj_Decl);
9382 while Present (D) loop
9388 Insert_After_And_Analyze (Addr, Ptr_Typ_Decl);
9392 Insert_After_And_Analyze (Obj_Decl, Ptr_Typ_Decl);
9395 Insert_Action (Obj_Decl, Ptr_Typ_Decl);
9398 -- Force immediate freezing of Ptr_Typ because Res_Decl will be
9399 -- elaborated in an inner (transient) scope and thus won't cause
9400 -- freezing by itself. It's not an itype, but it needs to be frozen
9401 -- inside the current subprogram (see Freeze_Outside in freeze.adb).
9403 Freeze_Itype (Ptr_Typ, Ptr_Typ_Decl);
9405 -- If the object is a return object of an enclosing build-in-place
9406 -- function, then the implicit build-in-place parameters of the
9407 -- enclosing function are simply passed along to the called function.
9408 -- (Unfortunately, this won't cover the case of extension aggregates
9409 -- where the ancestor part is a build-in-place indefinite function
9410 -- call that should be passed along the caller's parameters.
9411 -- Currently those get mishandled by reassigning the result of the
9412 -- call to the aggregate return object, when the call result should
9413 -- really be directly built in place in the aggregate and not in a
9416 if Is_Return_Object (Obj_Def_Id) then
9417 Pass_Caller_Acc := True;
9419 -- When the enclosing function has a BIP_Alloc_Form formal then we
9420 -- pass it along to the callee (such as when the enclosing function
9421 -- has an unconstrained or tagged result type).
9423 if Needs_BIP_Alloc_Form (Encl_Func) then
9424 if RTE_Available (RE_Root_Storage_Pool_Ptr) then
9427 (Build_In_Place_Formal
9428 (Encl_Func, BIP_Storage_Pool), Loc);
9430 -- The build-in-place pool formal is not built on e.g. ZFP
9433 Pool_Actual := Empty;
9436 Add_Unconstrained_Actuals_To_Build_In_Place_Call
9437 (Function_Call => Func_Call,
9438 Function_Id => Function_Id,
9441 (Build_In_Place_Formal (Encl_Func, BIP_Alloc_Form), Loc),
9442 Pool_Actual => Pool_Actual);
9444 -- Otherwise, if enclosing function has a definite result subtype,
9445 -- then caller allocation will be used.
9448 Add_Unconstrained_Actuals_To_Build_In_Place_Call
9449 (Func_Call, Function_Id, Alloc_Form => Caller_Allocation);
9452 if Needs_BIP_Finalization_Master (Encl_Func) then
9455 (Build_In_Place_Formal
9456 (Encl_Func, BIP_Finalization_Master), Loc);
9459 -- Retrieve the BIPacc formal from the enclosing function and convert
9460 -- it to the access type of the callee's BIP_Object_Access formal.
9463 Make_Unchecked_Type_Conversion (Loc,
9466 (Etype (Build_In_Place_Formal
9467 (Function_Id, BIP_Object_Access)),
9471 (Build_In_Place_Formal (Encl_Func, BIP_Object_Access),
9474 -- In the definite case, add an implicit actual to the function call
9475 -- that provides access to the declared object. An unchecked conversion
9476 -- to the (specific) result type of the function is inserted to handle
9477 -- the case where the object is declared with a class-wide type.
9481 Make_Unchecked_Type_Conversion (Loc,
9482 Subtype_Mark => New_Occurrence_Of (Result_Subt, Loc),
9483 Expression => New_Occurrence_Of (Obj_Def_Id, Loc));
9485 -- When the function has a controlling result, an allocation-form
9486 -- parameter must be passed indicating that the caller is allocating
9487 -- the result object. This is needed because such a function can be
9488 -- called as a dispatching operation and must be treated similarly to
9489 -- functions with indefinite result subtypes.
9491 Add_Unconstrained_Actuals_To_Build_In_Place_Call
9492 (Func_Call, Function_Id, Alloc_Form => Caller_Allocation);
9494 -- The allocation for indefinite library-level objects occurs on the
9495 -- heap as opposed to the secondary stack. This accommodates DLLs where
9496 -- the secondary stack is destroyed after each library unload. This is a
9497 -- hybrid mechanism where a stack-allocated object lives on the heap.
9499 elsif Is_Library_Level_Entity (Obj_Def_Id)
9500 and then not Restriction_Active (No_Implicit_Heap_Allocations)
9502 Add_Unconstrained_Actuals_To_Build_In_Place_Call
9503 (Func_Call, Function_Id, Alloc_Form => Global_Heap);
9504 Caller_Object := Empty;
9506 -- Create a finalization master for the access result type to ensure
9507 -- that the heap allocation can properly chain the object and later
9508 -- finalize it when the library unit goes out of scope.
9510 if Needs_Finalization (Etype (Func_Call)) then
9511 Build_Finalization_Master
9513 For_Lib_Level => True,
9514 Insertion_Node => Ptr_Typ_Decl);
9517 Make_Attribute_Reference (Loc,
9519 New_Occurrence_Of (Finalization_Master (Ptr_Typ), Loc),
9520 Attribute_Name => Name_Unrestricted_Access);
9523 -- In other indefinite cases, pass an indication to do the allocation
9524 -- on the secondary stack and set Caller_Object to Empty so that a null
9525 -- value will be passed for the caller's object address. A transient
9526 -- scope is established to ensure eventual cleanup of the result.
9529 Add_Unconstrained_Actuals_To_Build_In_Place_Call
9530 (Func_Call, Function_Id, Alloc_Form => Secondary_Stack);
9531 Caller_Object := Empty;
9533 Establish_Transient_Scope (Obj_Decl, Manage_Sec_Stack => True);
9536 -- Pass along any finalization master actual, which is needed in the
9537 -- case where the called function initializes a return object of an
9538 -- enclosing build-in-place function.
9540 Add_Finalization_Master_Actual_To_Build_In_Place_Call
9541 (Func_Call => Func_Call,
9542 Func_Id => Function_Id,
9543 Master_Exp => Fmaster_Actual);
9545 if Nkind (Parent (Obj_Decl)) = N_Extended_Return_Statement
9546 and then Needs_BIP_Task_Actuals (Function_Id)
9548 -- Here we're passing along the master that was passed in to this
9551 Add_Task_Actuals_To_Build_In_Place_Call
9552 (Func_Call, Function_Id,
9555 (Build_In_Place_Formal (Encl_Func, BIP_Task_Master), Loc));
9558 Add_Task_Actuals_To_Build_In_Place_Call
9559 (Func_Call, Function_Id, Make_Identifier (Loc, Name_uMaster));
9562 Add_Access_Actual_To_Build_In_Place_Call
9566 Is_Access => Pass_Caller_Acc);
9568 -- Finally, create an access object initialized to a reference to the
9569 -- function call. We know this access value cannot be null, so mark the
9570 -- entity accordingly to suppress the access check.
9572 Def_Id := Make_Temporary (Loc, 'R', Func_Call);
9573 Set_Etype (Def_Id, Ptr_Typ);
9574 Set_Is_Known_Non_Null (Def_Id);
9576 if Nkind (Function_Call) in N_Type_Conversion
9577 | N_Unchecked_Type_Conversion
9580 Make_Object_Declaration (Loc,
9581 Defining_Identifier => Def_Id,
9582 Constant_Present => True,
9583 Object_Definition => New_Occurrence_Of (Ptr_Typ, Loc),
9585 Make_Unchecked_Type_Conversion (Loc,
9586 New_Occurrence_Of (Ptr_Typ, Loc),
9587 Make_Reference (Loc, Relocate_Node (Func_Call))));
9590 Make_Object_Declaration (Loc,
9591 Defining_Identifier => Def_Id,
9592 Constant_Present => True,
9593 Object_Definition => New_Occurrence_Of (Ptr_Typ, Loc),
9595 Make_Reference (Loc, Relocate_Node (Func_Call)));
9598 Insert_After_And_Analyze (Ptr_Typ_Decl, Res_Decl);
9600 -- If the result subtype of the called function is definite and is not
9601 -- itself the return expression of an enclosing BIP function, then mark
9602 -- the object as having no initialization.
9604 if Definite and then not Is_Return_Object (Obj_Def_Id) then
9606 -- The related object declaration is encased in a transient block
9607 -- because the build-in-place function call contains at least one
9608 -- nested function call that produces a controlled transient
9611 -- Obj : ... := BIP_Func_Call (Ctrl_Func_Call);
9613 -- Since the build-in-place expansion decouples the call from the
9614 -- object declaration, the finalization machinery lacks the context
9615 -- which prompted the generation of the transient block. To resolve
9616 -- this scenario, store the build-in-place call.
9618 if Scope_Is_Transient and then Node_To_Be_Wrapped = Obj_Decl then
9619 Set_BIP_Initialization_Call (Obj_Def_Id, Res_Decl);
9622 Set_Expression (Obj_Decl, Empty);
9623 Set_No_Initialization (Obj_Decl);
9625 -- In case of an indefinite result subtype, or if the call is the
9626 -- return expression of an enclosing BIP function, rewrite the object
9627 -- declaration as an object renaming where the renamed object is a
9628 -- dereference of <function_Call>'reference:
9630 -- Obj : Subt renames <function_call>'Ref.all;
9634 Make_Explicit_Dereference (Obj_Loc,
9635 Prefix => New_Occurrence_Of (Def_Id, Obj_Loc));
9638 Make_Object_Renaming_Declaration (Obj_Loc,
9639 Defining_Identifier => Make_Temporary (Obj_Loc, 'D'),
9641 New_Occurrence_Of (Designated_Type, Obj_Loc),
9642 Name => Call_Deref));
9644 -- At this point, Defining_Identifier (Obj_Decl) is no longer equal
9647 Set_Renamed_Object (Defining_Identifier (Obj_Decl), Call_Deref);
9649 -- If the original entity comes from source, then mark the new
9650 -- entity as needing debug information, even though it's defined
9651 -- by a generated renaming that does not come from source, so that
9652 -- the Materialize_Entity flag will be set on the entity when
9653 -- Debug_Renaming_Declaration is called during analysis.
9655 if Comes_From_Source (Obj_Def_Id) then
9656 Set_Debug_Info_Needed (Defining_Identifier (Obj_Decl));
9660 Replace_Renaming_Declaration_Id
9661 (Obj_Decl, Original_Node (Obj_Decl));
9664 pragma Assert (Check_Number_Of_Actuals (Func_Call, Function_Id));
9665 pragma Assert (Check_BIP_Actuals (Func_Call, Function_Id));
9666 end Make_Build_In_Place_Call_In_Object_Declaration;
9668 -------------------------------------------------
9669 -- Make_Build_In_Place_Iface_Call_In_Allocator --
9670 -------------------------------------------------
9672 procedure Make_Build_In_Place_Iface_Call_In_Allocator
9673 (Allocator : Node_Id;
9674 Function_Call : Node_Id)
9676 BIP_Func_Call : constant Node_Id :=
9677 Unqual_BIP_Iface_Function_Call (Function_Call);
9678 Loc : constant Source_Ptr := Sloc (Function_Call);
9680 Anon_Type : Entity_Id;
9685 -- No action of the call has already been processed
9687 if Is_Expanded_Build_In_Place_Call (BIP_Func_Call) then
9691 Tmp_Id := Make_Temporary (Loc, 'D');
9693 -- Insert a temporary before N initialized with the BIP function call
9694 -- without its enclosing type conversions and analyze it without its
9695 -- expansion. This temporary facilitates us reusing the BIP machinery,
9696 -- which takes care of adding the extra build-in-place actuals and
9697 -- transforms this object declaration into an object renaming
9700 Anon_Type := Create_Itype (E_Anonymous_Access_Type, Function_Call);
9701 Set_Directly_Designated_Type (Anon_Type, Etype (BIP_Func_Call));
9702 Set_Etype (Anon_Type, Anon_Type);
9703 Build_Class_Wide_Master (Anon_Type);
9706 Make_Object_Declaration (Loc,
9707 Defining_Identifier => Tmp_Id,
9708 Object_Definition => New_Occurrence_Of (Anon_Type, Loc),
9710 Make_Allocator (Loc,
9712 Make_Qualified_Expression (Loc,
9714 New_Occurrence_Of (Etype (BIP_Func_Call), Loc),
9715 Expression => New_Copy_Tree (BIP_Func_Call))));
9717 -- Manually set the associated node for the anonymous access type to
9718 -- be its local declaration, to avoid confusing and complicating
9719 -- the accessibility machinery.
9721 Set_Associated_Node_For_Itype (Anon_Type, Tmp_Decl);
9723 Expander_Mode_Save_And_Set (False);
9724 Insert_Action (Allocator, Tmp_Decl);
9725 Expander_Mode_Restore;
9727 Make_Build_In_Place_Call_In_Allocator
9728 (Allocator => Expression (Tmp_Decl),
9729 Function_Call => Expression (Expression (Tmp_Decl)));
9731 -- Add a conversion to displace the pointer to the allocated object
9732 -- to reference the corresponding dispatch table.
9735 Convert_To (Etype (Allocator),
9736 New_Occurrence_Of (Tmp_Id, Loc)));
9737 end Make_Build_In_Place_Iface_Call_In_Allocator;
9739 ---------------------------------------------------------
9740 -- Make_Build_In_Place_Iface_Call_In_Anonymous_Context --
9741 ---------------------------------------------------------
9743 procedure Make_Build_In_Place_Iface_Call_In_Anonymous_Context
9744 (Function_Call : Node_Id)
9746 BIP_Func_Call : constant Node_Id :=
9747 Unqual_BIP_Iface_Function_Call (Function_Call);
9748 Loc : constant Source_Ptr := Sloc (Function_Call);
9754 -- No action of the call has already been processed
9756 if Is_Expanded_Build_In_Place_Call (BIP_Func_Call) then
9760 pragma Assert (Needs_Finalization (Etype (BIP_Func_Call)));
9762 -- Insert a temporary before the call initialized with function call to
9763 -- reuse the BIP machinery which takes care of adding the extra build-in
9764 -- place actuals and transforms this object declaration into an object
9765 -- renaming declaration.
9767 Tmp_Id := Make_Temporary (Loc, 'D');
9770 Make_Object_Declaration (Loc,
9771 Defining_Identifier => Tmp_Id,
9772 Object_Definition =>
9773 New_Occurrence_Of (Etype (Function_Call), Loc),
9774 Expression => Relocate_Node (Function_Call));
9776 Expander_Mode_Save_And_Set (False);
9777 Insert_Action (Function_Call, Tmp_Decl);
9778 Expander_Mode_Restore;
9780 Make_Build_In_Place_Iface_Call_In_Object_Declaration
9781 (Obj_Decl => Tmp_Decl,
9782 Function_Call => Expression (Tmp_Decl));
9783 end Make_Build_In_Place_Iface_Call_In_Anonymous_Context;
9785 ----------------------------------------------------------
9786 -- Make_Build_In_Place_Iface_Call_In_Object_Declaration --
9787 ----------------------------------------------------------
9789 procedure Make_Build_In_Place_Iface_Call_In_Object_Declaration
9790 (Obj_Decl : Node_Id;
9791 Function_Call : Node_Id)
9793 BIP_Func_Call : constant Node_Id :=
9794 Unqual_BIP_Iface_Function_Call (Function_Call);
9795 Loc : constant Source_Ptr := Sloc (Function_Call);
9796 Obj_Id : constant Entity_Id := Defining_Entity (Obj_Decl);
9802 -- No action of the call has already been processed
9804 if Is_Expanded_Build_In_Place_Call (BIP_Func_Call) then
9808 Tmp_Id := Make_Temporary (Loc, 'D');
9810 -- Insert a temporary before N initialized with the BIP function call
9811 -- without its enclosing type conversions and analyze it without its
9812 -- expansion. This temporary facilitates us reusing the BIP machinery,
9813 -- which takes care of adding the extra build-in-place actuals and
9814 -- transforms this object declaration into an object renaming
9818 Make_Object_Declaration (Loc,
9819 Defining_Identifier => Tmp_Id,
9820 Object_Definition =>
9821 New_Occurrence_Of (Etype (BIP_Func_Call), Loc),
9822 Expression => New_Copy_Tree (BIP_Func_Call));
9824 Expander_Mode_Save_And_Set (False);
9825 Insert_Action (Obj_Decl, Tmp_Decl);
9826 Expander_Mode_Restore;
9828 Make_Build_In_Place_Call_In_Object_Declaration
9829 (Obj_Decl => Tmp_Decl,
9830 Function_Call => Expression (Tmp_Decl));
9832 pragma Assert (Nkind (Tmp_Decl) = N_Object_Renaming_Declaration);
9834 -- Replace the original build-in-place function call by a reference to
9835 -- the resulting temporary object renaming declaration. In this way,
9836 -- all the interface conversions performed in the original Function_Call
9837 -- on the build-in-place object are preserved.
9839 Rewrite (BIP_Func_Call, New_Occurrence_Of (Tmp_Id, Loc));
9841 -- Replace the original object declaration by an internal object
9842 -- renaming declaration. This leaves the generated code more clean (the
9843 -- build-in-place function call in an object renaming declaration and
9844 -- displacements of the pointer to the build-in-place object in another
9845 -- renaming declaration) and allows us to invoke the routine that takes
9846 -- care of replacing the identifier of the renaming declaration (routine
9847 -- originally developed for the regular build-in-place management).
9850 Make_Object_Renaming_Declaration (Loc,
9851 Defining_Identifier => Make_Temporary (Loc, 'D'),
9852 Subtype_Mark => New_Occurrence_Of (Etype (Obj_Id), Loc),
9853 Name => Function_Call));
9856 Replace_Renaming_Declaration_Id (Obj_Decl, Original_Node (Obj_Decl));
9857 end Make_Build_In_Place_Iface_Call_In_Object_Declaration;
9859 --------------------------------------------
9860 -- Make_CPP_Constructor_Call_In_Allocator --
9861 --------------------------------------------
9863 procedure Make_CPP_Constructor_Call_In_Allocator
9864 (Allocator : Node_Id;
9865 Function_Call : Node_Id)
9867 Loc : constant Source_Ptr := Sloc (Function_Call);
9868 Acc_Type : constant Entity_Id := Etype (Allocator);
9869 Function_Id : constant Entity_Id := Entity (Name (Function_Call));
9870 Result_Subt : constant Entity_Id := Available_View (Etype (Function_Id));
9872 New_Allocator : Node_Id;
9873 Return_Obj_Access : Entity_Id;
9877 pragma Assert (Nkind (Allocator) = N_Allocator
9878 and then Nkind (Function_Call) = N_Function_Call);
9879 pragma Assert (Convention (Function_Id) = Convention_CPP
9880 and then Is_Constructor (Function_Id));
9881 pragma Assert (Is_Constrained (Underlying_Type (Result_Subt)));
9883 -- Replace the initialized allocator of form "new T'(Func (...))" with
9884 -- an uninitialized allocator of form "new T", where T is the result
9885 -- subtype of the called function. The call to the function is handled
9886 -- separately further below.
9889 Make_Allocator (Loc,
9890 Expression => New_Occurrence_Of (Result_Subt, Loc));
9891 Set_No_Initialization (New_Allocator);
9893 -- Copy attributes to new allocator. Note that the new allocator
9894 -- logically comes from source if the original one did, so copy the
9895 -- relevant flag. This ensures proper treatment of the restriction
9896 -- No_Implicit_Heap_Allocations in this case.
9898 Set_Storage_Pool (New_Allocator, Storage_Pool (Allocator));
9899 Set_Procedure_To_Call (New_Allocator, Procedure_To_Call (Allocator));
9900 Set_Comes_From_Source (New_Allocator, Comes_From_Source (Allocator));
9902 Rewrite (Allocator, New_Allocator);
9904 -- Create a new access object and initialize it to the result of the
9905 -- new uninitialized allocator. Note: we do not use Allocator as the
9906 -- Related_Node of Return_Obj_Access in call to Make_Temporary below
9907 -- as this would create a sort of infinite "recursion".
9909 Return_Obj_Access := Make_Temporary (Loc, 'R');
9910 Set_Etype (Return_Obj_Access, Acc_Type);
9913 -- Rnnn : constant ptr_T := new (T);
9914 -- Init (Rnn.all,...);
9917 Make_Object_Declaration (Loc,
9918 Defining_Identifier => Return_Obj_Access,
9919 Constant_Present => True,
9920 Object_Definition => New_Occurrence_Of (Acc_Type, Loc),
9921 Expression => Relocate_Node (Allocator));
9922 Insert_Action (Allocator, Tmp_Obj);
9924 Insert_List_After_And_Analyze (Tmp_Obj,
9925 Build_Initialization_Call (Loc,
9927 Make_Explicit_Dereference (Loc,
9928 Prefix => New_Occurrence_Of (Return_Obj_Access, Loc)),
9929 Typ => Etype (Function_Id),
9930 Constructor_Ref => Function_Call));
9932 -- Finally, replace the allocator node with a reference to the result of
9933 -- the function call itself (which will effectively be an access to the
9934 -- object created by the allocator).
9936 Rewrite (Allocator, New_Occurrence_Of (Return_Obj_Access, Loc));
9938 -- Ada 2005 (AI-251): If the type of the allocator is an interface then
9939 -- generate an implicit conversion to force displacement of the "this"
9942 if Is_Interface (Designated_Type (Acc_Type)) then
9943 Rewrite (Allocator, Convert_To (Acc_Type, Relocate_Node (Allocator)));
9946 Analyze_And_Resolve (Allocator, Acc_Type);
9947 end Make_CPP_Constructor_Call_In_Allocator;
9949 ----------------------
9950 -- Might_Have_Tasks --
9951 ----------------------
9953 function Might_Have_Tasks (Typ : Entity_Id) return Boolean is
9955 return not Global_No_Tasking
9956 and then not No_Run_Time_Mode
9957 and then Is_Class_Wide_Type (Typ)
9958 and then Is_Limited_Record (Typ);
9959 end Might_Have_Tasks;
9961 ----------------------------
9962 -- Needs_BIP_Task_Actuals --
9963 ----------------------------
9965 function Needs_BIP_Task_Actuals (Func_Id : Entity_Id) return Boolean is
9966 pragma Assert (Is_Build_In_Place_Function (Func_Id));
9967 Subp_Id : Entity_Id;
9968 Func_Typ : Entity_Id;
9971 if Global_No_Tasking or else No_Run_Time_Mode then
9975 -- For thunks we must rely on their target entity; otherwise, given that
9976 -- the profile of thunks for functions returning a limited interface
9977 -- type returns a class-wide type, we would erroneously add these extra
9980 if Is_Thunk (Func_Id) then
9981 Subp_Id := Thunk_Entity (Func_Id);
9989 Func_Typ := Underlying_Type (Etype (Subp_Id));
9991 -- At first sight, for all the following cases, we could add assertions
9992 -- to ensure that if Func_Id is frozen then the computed result matches
9993 -- with the availability of the task master extra formal; unfortunately
9994 -- this is not feasible because we may be precisely freezing this entity
9995 -- (that is, Is_Frozen has been set by Freeze_Entity but it has not
9996 -- completed its work).
9998 if Has_Task (Func_Typ) then
10001 elsif Ekind (Func_Id) = E_Function then
10002 return Might_Have_Tasks (Func_Typ);
10004 -- Handle subprogram type internally generated for dispatching call. We
10005 -- cannot rely on the return type of the subprogram type of dispatching
10006 -- calls since it is always a class-wide type (cf. Expand_Dispatching_
10009 elsif Ekind (Func_Id) = E_Subprogram_Type then
10010 if Is_Dispatch_Table_Entity (Func_Id) then
10011 return Has_BIP_Extra_Formal (Func_Id, BIP_Task_Master);
10013 return Might_Have_Tasks (Func_Typ);
10017 raise Program_Error;
10019 end Needs_BIP_Task_Actuals;
10021 -----------------------------------
10022 -- Needs_BIP_Finalization_Master --
10023 -----------------------------------
10025 function Needs_BIP_Finalization_Master
10026 (Func_Id : Entity_Id) return Boolean
10028 pragma Assert (Is_Build_In_Place_Function (Func_Id));
10029 Func_Typ : constant Entity_Id := Underlying_Type (Etype (Func_Id));
10031 -- A formal giving the finalization master is needed for build-in-place
10032 -- functions whose result type needs finalization or is a tagged type.
10033 -- Tagged primitive build-in-place functions need such a formal because
10034 -- they can be called by a dispatching call, and extensions may require
10035 -- finalization even if the root type doesn't. This means they're also
10036 -- needed for tagged nonprimitive build-in-place functions with tagged
10037 -- results, since such functions can be called via access-to-function
10038 -- types, and those can be used to call primitives, so masters have to
10039 -- be passed to all such build-in-place functions, primitive or not.
10042 not Restriction_Active (No_Finalization)
10043 and then (Needs_Finalization (Func_Typ)
10044 or else Is_Tagged_Type (Func_Typ));
10045 end Needs_BIP_Finalization_Master;
10047 --------------------------
10048 -- Needs_BIP_Alloc_Form --
10049 --------------------------
10051 function Needs_BIP_Alloc_Form (Func_Id : Entity_Id) return Boolean is
10052 pragma Assert (Is_Build_In_Place_Function (Func_Id));
10053 Func_Typ : constant Entity_Id := Underlying_Type (Etype (Func_Id));
10055 return Requires_Transient_Scope (Func_Typ);
10056 end Needs_BIP_Alloc_Form;
10058 -------------------------------------
10059 -- Replace_Renaming_Declaration_Id --
10060 -------------------------------------
10062 procedure Replace_Renaming_Declaration_Id
10063 (New_Decl : Node_Id;
10064 Orig_Decl : Node_Id)
10066 New_Id : constant Entity_Id := Defining_Entity (New_Decl);
10067 Orig_Id : constant Entity_Id := Defining_Entity (Orig_Decl);
10070 Set_Chars (New_Id, Chars (Orig_Id));
10072 -- Swap next entity links in preparation for exchanging entities
10075 Next_Id : constant Entity_Id := Next_Entity (New_Id);
10077 Link_Entities (New_Id, Next_Entity (Orig_Id));
10078 Link_Entities (Orig_Id, Next_Id);
10081 Set_Homonym (New_Id, Homonym (Orig_Id));
10082 Exchange_Entities (New_Id, Orig_Id);
10084 -- Preserve source indication of original declaration, so that xref
10085 -- information is properly generated for the right entity.
10087 Preserve_Comes_From_Source (New_Decl, Orig_Decl);
10088 Preserve_Comes_From_Source (Orig_Id, Orig_Decl);
10090 Set_Comes_From_Source (New_Id, False);
10091 end Replace_Renaming_Declaration_Id;
10093 ---------------------------------
10094 -- Rewrite_Function_Call_For_C --
10095 ---------------------------------
10097 procedure Rewrite_Function_Call_For_C (N : Node_Id) is
10098 Orig_Func : constant Entity_Id := Entity (Name (N));
10099 Func_Id : constant Entity_Id := Ultimate_Alias (Orig_Func);
10100 Par : constant Node_Id := Parent (N);
10101 Proc_Id : constant Entity_Id := Corresponding_Procedure (Func_Id);
10102 Loc : constant Source_Ptr := Sloc (Par);
10104 Last_Actual : Node_Id;
10105 Last_Formal : Entity_Id;
10107 -- Start of processing for Rewrite_Function_Call_For_C
10110 -- The actuals may be given by named associations, so the added actual
10111 -- that is the target of the return value of the call must be a named
10112 -- association as well, so we retrieve the name of the generated
10115 Last_Formal := First_Formal (Proc_Id);
10116 while Present (Next_Formal (Last_Formal)) loop
10117 Next_Formal (Last_Formal);
10120 Actuals := Parameter_Associations (N);
10122 -- The original function may lack parameters
10124 if No (Actuals) then
10125 Actuals := New_List;
10128 -- If the function call is the expression of an assignment statement,
10129 -- transform the assignment into a procedure call. Generate:
10131 -- LHS := Func_Call (...);
10133 -- Proc_Call (..., LHS);
10135 -- If function is inherited, a conversion may be necessary.
10137 if Nkind (Par) = N_Assignment_Statement then
10138 Last_Actual := Name (Par);
10140 if not Comes_From_Source (Orig_Func)
10141 and then Etype (Orig_Func) /= Etype (Func_Id)
10144 Make_Type_Conversion (Loc,
10145 New_Occurrence_Of (Etype (Func_Id), Loc),
10149 Append_To (Actuals,
10150 Make_Parameter_Association (Loc,
10152 Make_Identifier (Loc, Chars (Last_Formal)),
10153 Explicit_Actual_Parameter => Last_Actual));
10156 Make_Procedure_Call_Statement (Loc,
10157 Name => New_Occurrence_Of (Proc_Id, Loc),
10158 Parameter_Associations => Actuals));
10161 -- Otherwise the context is an expression. Generate a temporary and a
10162 -- procedure call to obtain the function result. Generate:
10164 -- ... Func_Call (...) ...
10167 -- Proc_Call (..., Temp);
10172 Temp_Id : constant Entity_Id := Make_Temporary (Loc, 'T');
10181 Make_Object_Declaration (Loc,
10182 Defining_Identifier => Temp_Id,
10183 Object_Definition =>
10184 New_Occurrence_Of (Etype (Func_Id), Loc));
10187 -- Proc_Call (..., Temp);
10189 Append_To (Actuals,
10190 Make_Parameter_Association (Loc,
10192 Make_Identifier (Loc, Chars (Last_Formal)),
10193 Explicit_Actual_Parameter =>
10194 New_Occurrence_Of (Temp_Id, Loc)));
10197 Make_Procedure_Call_Statement (Loc,
10198 Name => New_Occurrence_Of (Proc_Id, Loc),
10199 Parameter_Associations => Actuals);
10201 Insert_Actions (Par, New_List (Decl, Call));
10202 Rewrite (N, New_Occurrence_Of (Temp_Id, Loc));
10205 end Rewrite_Function_Call_For_C;
10207 ------------------------------------
10208 -- Set_Enclosing_Sec_Stack_Return --
10209 ------------------------------------
10211 procedure Set_Enclosing_Sec_Stack_Return (N : Node_Id) is
10215 -- Due to a possible mix of internally generated blocks, source blocks
10216 -- and loops, the scope stack may not be contiguous as all labels are
10217 -- inserted at the top level within the related function. Instead,
10218 -- perform a parent-based traversal and mark all appropriate constructs.
10220 while Present (P) loop
10222 -- Mark the label of a source or internally generated block or
10225 if Nkind (P) in N_Block_Statement | N_Loop_Statement then
10226 Set_Sec_Stack_Needed_For_Return (Entity (Identifier (P)));
10228 -- Mark the enclosing function
10230 elsif Nkind (P) = N_Subprogram_Body then
10231 if Present (Corresponding_Spec (P)) then
10232 Set_Sec_Stack_Needed_For_Return (Corresponding_Spec (P));
10234 Set_Sec_Stack_Needed_For_Return (Defining_Entity (P));
10237 -- Do not go beyond the enclosing function
10244 end Set_Enclosing_Sec_Stack_Return;
10246 ------------------------------------
10247 -- Unqual_BIP_Iface_Function_Call --
10248 ------------------------------------
10250 function Unqual_BIP_Iface_Function_Call (Expr : Node_Id) return Node_Id is
10251 Has_Pointer_Displacement : Boolean := False;
10252 On_Object_Declaration : Boolean := False;
10253 -- Remember if processing the renaming expressions on recursion we have
10254 -- traversed an object declaration, since we can traverse many object
10255 -- declaration renamings but just one regular object declaration.
10257 function Unqual_BIP_Function_Call (Expr : Node_Id) return Node_Id;
10258 -- Search for a build-in-place function call skipping any qualification
10259 -- including qualified expressions, type conversions, references, calls
10260 -- to displace the pointer to the object, and renamings. Return Empty if
10261 -- no build-in-place function call is found.
10263 ------------------------------
10264 -- Unqual_BIP_Function_Call --
10265 ------------------------------
10267 function Unqual_BIP_Function_Call (Expr : Node_Id) return Node_Id is
10269 -- Recurse to handle case of multiple levels of qualification and/or
10272 if Nkind (Expr) in N_Qualified_Expression
10273 | N_Type_Conversion
10274 | N_Unchecked_Type_Conversion
10276 return Unqual_BIP_Function_Call (Expression (Expr));
10278 -- Recurse to handle case of multiple levels of references and
10279 -- explicit dereferences.
10281 elsif Nkind (Expr) in N_Attribute_Reference
10282 | N_Explicit_Dereference
10285 return Unqual_BIP_Function_Call (Prefix (Expr));
10287 -- Recurse on object renamings
10289 elsif Nkind (Expr) = N_Identifier
10290 and then Present (Entity (Expr))
10291 and then Ekind (Entity (Expr)) in E_Constant | E_Variable
10292 and then Nkind (Parent (Entity (Expr))) =
10293 N_Object_Renaming_Declaration
10294 and then Present (Renamed_Object (Entity (Expr)))
10296 return Unqual_BIP_Function_Call (Renamed_Object (Entity (Expr)));
10298 -- Recurse on the initializing expression of the first reference of
10299 -- an object declaration.
10301 elsif not On_Object_Declaration
10302 and then Nkind (Expr) = N_Identifier
10303 and then Present (Entity (Expr))
10304 and then Ekind (Entity (Expr)) in E_Constant | E_Variable
10305 and then Nkind (Parent (Entity (Expr))) = N_Object_Declaration
10306 and then Present (Expression (Parent (Entity (Expr))))
10308 On_Object_Declaration := True;
10310 Unqual_BIP_Function_Call (Expression (Parent (Entity (Expr))));
10312 -- Recurse to handle calls to displace the pointer to the object to
10313 -- reference a secondary dispatch table.
10315 elsif Nkind (Expr) = N_Function_Call
10316 and then Nkind (Name (Expr)) in N_Has_Entity
10317 and then Present (Entity (Name (Expr)))
10318 and then RTU_Loaded (Ada_Tags)
10319 and then RTE_Available (RE_Displace)
10320 and then Is_RTE (Entity (Name (Expr)), RE_Displace)
10322 Has_Pointer_Displacement := True;
10324 Unqual_BIP_Function_Call (First (Parameter_Associations (Expr)));
10326 -- Normal case: check if the inner expression is a BIP function call
10327 -- and the pointer to the object is displaced.
10329 elsif Has_Pointer_Displacement
10330 and then Is_Build_In_Place_Function_Call (Expr)
10337 end Unqual_BIP_Function_Call;
10339 -- Start of processing for Unqual_BIP_Iface_Function_Call
10342 if Nkind (Expr) = N_Identifier and then No (Entity (Expr)) then
10344 -- Can happen for X'Elab_Spec in the binder-generated file
10349 return Unqual_BIP_Function_Call (Expr);
10350 end Unqual_BIP_Iface_Function_Call;
10356 procedure Warn_BIP (Func_Call : Node_Id) is
10358 if Debug_Flag_Underscore_BB then
10359 Error_Msg_N ("build-in-place function call?", Func_Call);