1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 with Atree; use Atree;
27 with Checks; use Checks;
28 with Debug; use Debug;
29 with Einfo; use Einfo;
30 with Errout; use Errout;
31 with Elists; use Elists;
32 with Exp_Atag; use Exp_Atag;
33 with Exp_Ch2; use Exp_Ch2;
34 with Exp_Ch3; use Exp_Ch3;
35 with Exp_Ch7; use Exp_Ch7;
36 with Exp_Ch9; use Exp_Ch9;
37 with Exp_Dbug; use Exp_Dbug;
38 with Exp_Disp; use Exp_Disp;
39 with Exp_Dist; use Exp_Dist;
40 with Exp_Intr; use Exp_Intr;
41 with Exp_Pakd; use Exp_Pakd;
42 with Exp_Tss; use Exp_Tss;
43 with Exp_Util; use Exp_Util;
44 with Exp_VFpt; use Exp_VFpt;
45 with Fname; use Fname;
46 with Freeze; use Freeze;
47 with Inline; use Inline;
49 with Namet; use Namet;
50 with Nlists; use Nlists;
51 with Nmake; use Nmake;
53 with Restrict; use Restrict;
54 with Rident; use Rident;
55 with Rtsfind; use Rtsfind;
57 with Sem_Aux; use Sem_Aux;
58 with Sem_Ch6; use Sem_Ch6;
59 with Sem_Ch8; use Sem_Ch8;
60 with Sem_Ch12; use Sem_Ch12;
61 with Sem_Ch13; use Sem_Ch13;
62 with Sem_Eval; use Sem_Eval;
63 with Sem_Disp; use Sem_Disp;
64 with Sem_Dist; use Sem_Dist;
65 with Sem_Mech; use Sem_Mech;
66 with Sem_Res; use Sem_Res;
67 with Sem_SCIL; use Sem_SCIL;
68 with Sem_Util; use Sem_Util;
69 with Sinfo; use Sinfo;
70 with Snames; use Snames;
71 with Stand; use Stand;
72 with Tbuild; use Tbuild;
73 with Uintp; use Uintp;
74 with Validsw; use Validsw;
76 package body Exp_Ch6 is
78 -----------------------
79 -- Local Subprograms --
80 -----------------------
82 procedure Add_Access_Actual_To_Build_In_Place_Call
83 (Function_Call : Node_Id;
84 Function_Id : Entity_Id;
85 Return_Object : Node_Id;
86 Is_Access : Boolean := False);
87 -- Ada 2005 (AI-318-02): Apply the Unrestricted_Access attribute to the
88 -- object name given by Return_Object and add the attribute to the end of
89 -- the actual parameter list associated with the build-in-place function
90 -- call denoted by Function_Call. However, if Is_Access is True, then
91 -- Return_Object is already an access expression, in which case it's passed
92 -- along directly to the build-in-place function. Finally, if Return_Object
93 -- is empty, then pass a null literal as the actual.
95 procedure Add_Alloc_Form_Actual_To_Build_In_Place_Call
96 (Function_Call : Node_Id;
97 Function_Id : Entity_Id;
98 Alloc_Form : BIP_Allocation_Form := Unspecified;
99 Alloc_Form_Exp : Node_Id := Empty);
100 -- Ada 2005 (AI-318-02): Add an actual indicating the form of allocation,
101 -- if any, to be done by a build-in-place function. If Alloc_Form_Exp is
102 -- present, then use it, otherwise pass a literal corresponding to the
103 -- Alloc_Form parameter (which must not be Unspecified in that case).
105 procedure Add_Extra_Actual_To_Call
106 (Subprogram_Call : Node_Id;
107 Extra_Formal : Entity_Id;
108 Extra_Actual : Node_Id);
109 -- Adds Extra_Actual as a named parameter association for the formal
110 -- Extra_Formal in Subprogram_Call.
112 procedure Add_Final_List_Actual_To_Build_In_Place_Call
113 (Function_Call : Node_Id;
114 Function_Id : Entity_Id;
115 Acc_Type : Entity_Id;
116 Sel_Comp : Node_Id := Empty);
117 -- Ada 2005 (AI-318-02): For a build-in-place call, if the result type has
118 -- controlled parts, add an actual parameter that is a pointer to
119 -- appropriate finalization list. The finalization list is that of the
120 -- current scope, except for "new Acc'(F(...))" in which case it's the
121 -- finalization list of the access type returned by the allocator. Acc_Type
122 -- is that type in the allocator case; Empty otherwise. If Sel_Comp is
123 -- not Empty, then it denotes a selected component and the finalization
124 -- list is obtained from the _controller list of the prefix object.
126 procedure Add_Task_Actuals_To_Build_In_Place_Call
127 (Function_Call : Node_Id;
128 Function_Id : Entity_Id;
129 Master_Actual : Node_Id);
130 -- Ada 2005 (AI-318-02): For a build-in-place call, if the result type
131 -- contains tasks, add two actual parameters: the master, and a pointer to
132 -- the caller's activation chain. Master_Actual is the actual parameter
133 -- expression to pass for the master. In most cases, this is the current
134 -- master (_master). The two exceptions are: If the function call is the
135 -- initialization expression for an allocator, we pass the master of the
136 -- access type. If the function call is the initialization expression for
137 -- a return object, we pass along the master passed in by the caller. The
138 -- activation chain to pass is always the local one.
140 procedure Check_Overriding_Operation (Subp : Entity_Id);
141 -- Subp is a dispatching operation. Check whether it may override an
142 -- inherited private operation, in which case its DT entry is that of
143 -- the hidden operation, not the one it may have received earlier.
144 -- This must be done before emitting the code to set the corresponding
145 -- DT to the address of the subprogram. The actual placement of Subp in
146 -- the proper place in the list of primitive operations is done in
147 -- Declare_Inherited_Private_Subprograms, which also has to deal with
148 -- implicit operations. This duplication is unavoidable for now???
150 procedure Detect_Infinite_Recursion (N : Node_Id; Spec : Entity_Id);
151 -- This procedure is called only if the subprogram body N, whose spec
152 -- has the given entity Spec, contains a parameterless recursive call.
153 -- It attempts to generate runtime code to detect if this a case of
154 -- infinite recursion.
156 -- The body is scanned to determine dependencies. If the only external
157 -- dependencies are on a small set of scalar variables, then the values
158 -- of these variables are captured on entry to the subprogram, and if
159 -- the values are not changed for the call, we know immediately that
160 -- we have an infinite recursion.
162 procedure Expand_Actuals (N : Node_Id; Subp : Entity_Id);
163 -- For each actual of an in-out or out parameter which is a numeric
164 -- (view) conversion of the form T (A), where A denotes a variable,
165 -- we insert the declaration:
167 -- Temp : T[ := T (A)];
169 -- prior to the call. Then we replace the actual with a reference to Temp,
170 -- and append the assignment:
172 -- A := TypeA (Temp);
174 -- after the call. Here TypeA is the actual type of variable A.
175 -- For out parameters, the initial declaration has no expression.
176 -- If A is not an entity name, we generate instead:
178 -- Var : TypeA renames A;
179 -- Temp : T := Var; -- omitting expression for out parameter.
181 -- Var := TypeA (Temp);
183 -- For other in-out parameters, we emit the required constraint checks
184 -- before and/or after the call.
186 -- For all parameter modes, actuals that denote components and slices
187 -- of packed arrays are expanded into suitable temporaries.
189 -- For non-scalar objects that are possibly unaligned, add call by copy
190 -- code (copy in for IN and IN OUT, copy out for OUT and IN OUT).
192 procedure Expand_Inlined_Call
195 Orig_Subp : Entity_Id);
196 -- If called subprogram can be inlined by the front-end, retrieve the
197 -- analyzed body, replace formals with actuals and expand call in place.
198 -- Generate thunks for actuals that are expressions, and insert the
199 -- corresponding constant declarations before the call. If the original
200 -- call is to a derived operation, the return type is the one of the
201 -- derived operation, but the body is that of the original, so return
202 -- expressions in the body must be converted to the desired type (which
203 -- is simply not noted in the tree without inline expansion).
205 function Expand_Protected_Object_Reference
207 Scop : Entity_Id) return Node_Id;
209 procedure Expand_Protected_Subprogram_Call
213 -- A call to a protected subprogram within the protected object may appear
214 -- as a regular call. The list of actuals must be expanded to contain a
215 -- reference to the object itself, and the call becomes a call to the
216 -- corresponding protected subprogram.
218 function Is_Null_Procedure (Subp : Entity_Id) return Boolean;
219 -- Predicate to recognize stubbed procedures and null procedures, which
220 -- can be inlined unconditionally in all cases.
222 ----------------------------------------------
223 -- Add_Access_Actual_To_Build_In_Place_Call --
224 ----------------------------------------------
226 procedure Add_Access_Actual_To_Build_In_Place_Call
227 (Function_Call : Node_Id;
228 Function_Id : Entity_Id;
229 Return_Object : Node_Id;
230 Is_Access : Boolean := False)
232 Loc : constant Source_Ptr := Sloc (Function_Call);
233 Obj_Address : Node_Id;
234 Obj_Acc_Formal : Entity_Id;
237 -- Locate the implicit access parameter in the called function
239 Obj_Acc_Formal := Build_In_Place_Formal (Function_Id, BIP_Object_Access);
241 -- If no return object is provided, then pass null
243 if not Present (Return_Object) then
244 Obj_Address := Make_Null (Loc);
245 Set_Parent (Obj_Address, Function_Call);
247 -- If Return_Object is already an expression of an access type, then use
248 -- it directly, since it must be an access value denoting the return
249 -- object, and couldn't possibly be the return object itself.
252 Obj_Address := Return_Object;
253 Set_Parent (Obj_Address, Function_Call);
255 -- Apply Unrestricted_Access to caller's return object
259 Make_Attribute_Reference (Loc,
260 Prefix => Return_Object,
261 Attribute_Name => Name_Unrestricted_Access);
263 Set_Parent (Return_Object, Obj_Address);
264 Set_Parent (Obj_Address, Function_Call);
267 Analyze_And_Resolve (Obj_Address, Etype (Obj_Acc_Formal));
269 -- Build the parameter association for the new actual and add it to the
270 -- end of the function's actuals.
272 Add_Extra_Actual_To_Call (Function_Call, Obj_Acc_Formal, Obj_Address);
273 end Add_Access_Actual_To_Build_In_Place_Call;
275 --------------------------------------------------
276 -- Add_Alloc_Form_Actual_To_Build_In_Place_Call --
277 --------------------------------------------------
279 procedure Add_Alloc_Form_Actual_To_Build_In_Place_Call
280 (Function_Call : Node_Id;
281 Function_Id : Entity_Id;
282 Alloc_Form : BIP_Allocation_Form := Unspecified;
283 Alloc_Form_Exp : Node_Id := Empty)
285 Loc : constant Source_Ptr := Sloc (Function_Call);
286 Alloc_Form_Actual : Node_Id;
287 Alloc_Form_Formal : Node_Id;
290 -- The allocation form generally doesn't need to be passed in the case
291 -- of a constrained result subtype, since normally the caller performs
292 -- the allocation in that case. However this formal is still needed in
293 -- the case where the function has a tagged result, because generally
294 -- such functions can be called in a dispatching context and such calls
295 -- must be handled like calls to class-wide functions.
297 if Is_Constrained (Underlying_Type (Etype (Function_Id)))
298 and then not Is_Tagged_Type (Underlying_Type (Etype (Function_Id)))
303 -- Locate the implicit allocation form parameter in the called function.
304 -- Maybe it would be better for each implicit formal of a build-in-place
305 -- function to have a flag or a Uint attribute to identify it. ???
307 Alloc_Form_Formal := Build_In_Place_Formal (Function_Id, BIP_Alloc_Form);
309 if Present (Alloc_Form_Exp) then
310 pragma Assert (Alloc_Form = Unspecified);
312 Alloc_Form_Actual := Alloc_Form_Exp;
315 pragma Assert (Alloc_Form /= Unspecified);
318 Make_Integer_Literal (Loc,
319 Intval => UI_From_Int (BIP_Allocation_Form'Pos (Alloc_Form)));
322 Analyze_And_Resolve (Alloc_Form_Actual, Etype (Alloc_Form_Formal));
324 -- Build the parameter association for the new actual and add it to the
325 -- end of the function's actuals.
327 Add_Extra_Actual_To_Call
328 (Function_Call, Alloc_Form_Formal, Alloc_Form_Actual);
329 end Add_Alloc_Form_Actual_To_Build_In_Place_Call;
331 ------------------------------
332 -- Add_Extra_Actual_To_Call --
333 ------------------------------
335 procedure Add_Extra_Actual_To_Call
336 (Subprogram_Call : Node_Id;
337 Extra_Formal : Entity_Id;
338 Extra_Actual : Node_Id)
340 Loc : constant Source_Ptr := Sloc (Subprogram_Call);
341 Param_Assoc : Node_Id;
345 Make_Parameter_Association (Loc,
346 Selector_Name => New_Occurrence_Of (Extra_Formal, Loc),
347 Explicit_Actual_Parameter => Extra_Actual);
349 Set_Parent (Param_Assoc, Subprogram_Call);
350 Set_Parent (Extra_Actual, Param_Assoc);
352 if Present (Parameter_Associations (Subprogram_Call)) then
353 if Nkind (Last (Parameter_Associations (Subprogram_Call))) =
354 N_Parameter_Association
357 -- Find last named actual, and append
362 L := First_Actual (Subprogram_Call);
363 while Present (L) loop
364 if No (Next_Actual (L)) then
365 Set_Next_Named_Actual (Parent (L), Extra_Actual);
373 Set_First_Named_Actual (Subprogram_Call, Extra_Actual);
376 Append (Param_Assoc, To => Parameter_Associations (Subprogram_Call));
379 Set_Parameter_Associations (Subprogram_Call, New_List (Param_Assoc));
380 Set_First_Named_Actual (Subprogram_Call, Extra_Actual);
382 end Add_Extra_Actual_To_Call;
384 --------------------------------------------------
385 -- Add_Final_List_Actual_To_Build_In_Place_Call --
386 --------------------------------------------------
388 procedure Add_Final_List_Actual_To_Build_In_Place_Call
389 (Function_Call : Node_Id;
390 Function_Id : Entity_Id;
391 Acc_Type : Entity_Id;
392 Sel_Comp : Node_Id := Empty)
394 Loc : constant Source_Ptr := Sloc (Function_Call);
395 Final_List : Node_Id;
396 Final_List_Actual : Node_Id;
397 Final_List_Formal : Node_Id;
398 Is_Ctrl_Result : constant Boolean :=
400 (Underlying_Type (Etype (Function_Id)));
403 -- No such extra parameter is needed if there are no controlled parts.
404 -- The test for Needs_Finalization accounts for class-wide results
405 -- (which potentially have controlled parts, even if the root type
406 -- doesn't), and the test for a tagged result type is needed because
407 -- calls to such a function can in general occur in dispatching
408 -- contexts, which must be treated the same as a call to class-wide
409 -- functions. Both of these situations require that a finalization list
412 if not Needs_BIP_Final_List (Function_Id) then
416 -- Locate implicit finalization list parameter in the called function
418 Final_List_Formal := Build_In_Place_Formal (Function_Id, BIP_Final_List);
420 -- Create the actual which is a pointer to the appropriate finalization
421 -- list. Acc_Type is present if and only if this call is the
422 -- initialization of an allocator. Use the Current_Scope or the Acc_Type
425 if Present (Acc_Type)
426 and then (Ekind (Acc_Type) = E_Anonymous_Access_Type
428 Present (Associated_Final_Chain (Base_Type (Acc_Type))))
430 Final_List := Find_Final_List (Acc_Type);
432 -- If Sel_Comp is present and the function result is controlled, then
433 -- the finalization list will be obtained from the _controller list of
434 -- the selected component's prefix object.
436 elsif Present (Sel_Comp) and then Is_Ctrl_Result then
437 Final_List := Find_Final_List (Current_Scope, Sel_Comp);
440 Final_List := Find_Final_List (Current_Scope);
444 Make_Attribute_Reference (Loc,
445 Prefix => Final_List,
446 Attribute_Name => Name_Unrestricted_Access);
448 Analyze_And_Resolve (Final_List_Actual, Etype (Final_List_Formal));
450 -- Build the parameter association for the new actual and add it to the
451 -- end of the function's actuals.
453 Add_Extra_Actual_To_Call
454 (Function_Call, Final_List_Formal, Final_List_Actual);
455 end Add_Final_List_Actual_To_Build_In_Place_Call;
457 ---------------------------------------------
458 -- Add_Task_Actuals_To_Build_In_Place_Call --
459 ---------------------------------------------
461 procedure Add_Task_Actuals_To_Build_In_Place_Call
462 (Function_Call : Node_Id;
463 Function_Id : Entity_Id;
464 Master_Actual : Node_Id)
465 -- Note: Master_Actual can be Empty, but only if there are no tasks
467 Loc : constant Source_Ptr := Sloc (Function_Call);
470 -- No such extra parameters are needed if there are no tasks
472 if not Has_Task (Etype (Function_Id)) then
479 Master_Formal : Node_Id;
481 -- Locate implicit master parameter in the called function
483 Master_Formal := Build_In_Place_Formal (Function_Id, BIP_Master);
485 Analyze_And_Resolve (Master_Actual, Etype (Master_Formal));
487 -- Build the parameter association for the new actual and add it to
488 -- the end of the function's actuals.
490 Add_Extra_Actual_To_Call
491 (Function_Call, Master_Formal, Master_Actual);
494 -- The activation chain
497 Activation_Chain_Actual : Node_Id;
498 Activation_Chain_Formal : Node_Id;
500 -- Locate implicit activation chain parameter in the called function
502 Activation_Chain_Formal := Build_In_Place_Formal
503 (Function_Id, BIP_Activation_Chain);
505 -- Create the actual which is a pointer to the current activation
508 Activation_Chain_Actual :=
509 Make_Attribute_Reference (Loc,
510 Prefix => Make_Identifier (Loc, Name_uChain),
511 Attribute_Name => Name_Unrestricted_Access);
514 (Activation_Chain_Actual, Etype (Activation_Chain_Formal));
516 -- Build the parameter association for the new actual and add it to
517 -- the end of the function's actuals.
519 Add_Extra_Actual_To_Call
520 (Function_Call, Activation_Chain_Formal, Activation_Chain_Actual);
522 end Add_Task_Actuals_To_Build_In_Place_Call;
524 -----------------------
525 -- BIP_Formal_Suffix --
526 -----------------------
528 function BIP_Formal_Suffix (Kind : BIP_Formal_Kind) return String is
531 when BIP_Alloc_Form =>
533 when BIP_Final_List =>
534 return "BIPfinallist";
537 when BIP_Activation_Chain =>
538 return "BIPactivationchain";
539 when BIP_Object_Access =>
542 end BIP_Formal_Suffix;
544 ---------------------------
545 -- Build_In_Place_Formal --
546 ---------------------------
548 function Build_In_Place_Formal
550 Kind : BIP_Formal_Kind) return Entity_Id
552 Extra_Formal : Entity_Id := Extra_Formals (Func);
555 -- Maybe it would be better for each implicit formal of a build-in-place
556 -- function to have a flag or a Uint attribute to identify it. ???
559 pragma Assert (Present (Extra_Formal));
561 Chars (Extra_Formal) =
562 New_External_Name (Chars (Func), BIP_Formal_Suffix (Kind));
563 Next_Formal_With_Extras (Extra_Formal);
567 end Build_In_Place_Formal;
569 --------------------------------
570 -- Check_Overriding_Operation --
571 --------------------------------
573 procedure Check_Overriding_Operation (Subp : Entity_Id) is
574 Typ : constant Entity_Id := Find_Dispatching_Type (Subp);
575 Op_List : constant Elist_Id := Primitive_Operations (Typ);
581 if Is_Derived_Type (Typ)
582 and then not Is_Private_Type (Typ)
583 and then In_Open_Scopes (Scope (Etype (Typ)))
584 and then Typ = Base_Type (Typ)
586 -- Subp overrides an inherited private operation if there is an
587 -- inherited operation with a different name than Subp (see
588 -- Derive_Subprogram) whose Alias is a hidden subprogram with the
589 -- same name as Subp.
591 Op_Elmt := First_Elmt (Op_List);
592 while Present (Op_Elmt) loop
593 Prim_Op := Node (Op_Elmt);
594 Par_Op := Alias (Prim_Op);
597 and then not Comes_From_Source (Prim_Op)
598 and then Chars (Prim_Op) /= Chars (Par_Op)
599 and then Chars (Par_Op) = Chars (Subp)
600 and then Is_Hidden (Par_Op)
601 and then Type_Conformant (Prim_Op, Subp)
603 Set_DT_Position (Subp, DT_Position (Prim_Op));
609 end Check_Overriding_Operation;
611 -------------------------------
612 -- Detect_Infinite_Recursion --
613 -------------------------------
615 procedure Detect_Infinite_Recursion (N : Node_Id; Spec : Entity_Id) is
616 Loc : constant Source_Ptr := Sloc (N);
618 Var_List : constant Elist_Id := New_Elmt_List;
619 -- List of globals referenced by body of procedure
621 Call_List : constant Elist_Id := New_Elmt_List;
622 -- List of recursive calls in body of procedure
624 Shad_List : constant Elist_Id := New_Elmt_List;
625 -- List of entity id's for entities created to capture the value of
626 -- referenced globals on entry to the procedure.
628 Scop : constant Uint := Scope_Depth (Spec);
629 -- This is used to record the scope depth of the current procedure, so
630 -- that we can identify global references.
632 Max_Vars : constant := 4;
633 -- Do not test more than four global variables
635 Count_Vars : Natural := 0;
636 -- Count variables found so far
648 function Process (Nod : Node_Id) return Traverse_Result;
649 -- Function to traverse the subprogram body (using Traverse_Func)
655 function Process (Nod : Node_Id) return Traverse_Result is
659 if Nkind (Nod) = N_Procedure_Call_Statement then
661 -- Case of one of the detected recursive calls
663 if Is_Entity_Name (Name (Nod))
664 and then Has_Recursive_Call (Entity (Name (Nod)))
665 and then Entity (Name (Nod)) = Spec
667 Append_Elmt (Nod, Call_List);
670 -- Any other procedure call may have side effects
676 -- A call to a pure function can always be ignored
678 elsif Nkind (Nod) = N_Function_Call
679 and then Is_Entity_Name (Name (Nod))
680 and then Is_Pure (Entity (Name (Nod)))
684 -- Case of an identifier reference
686 elsif Nkind (Nod) = N_Identifier then
689 -- If no entity, then ignore the reference
691 -- Not clear why this can happen. To investigate, remove this
692 -- test and look at the crash that occurs here in 3401-004 ???
697 -- Ignore entities with no Scope, again not clear how this
698 -- can happen, to investigate, look at 4108-008 ???
700 elsif No (Scope (Ent)) then
703 -- Ignore the reference if not to a more global object
705 elsif Scope_Depth (Scope (Ent)) >= Scop then
708 -- References to types, exceptions and constants are always OK
711 or else Ekind (Ent) = E_Exception
712 or else Ekind (Ent) = E_Constant
716 -- If other than a non-volatile scalar variable, we have some
717 -- kind of global reference (e.g. to a function) that we cannot
718 -- deal with so we forget the attempt.
720 elsif Ekind (Ent) /= E_Variable
721 or else not Is_Scalar_Type (Etype (Ent))
722 or else Treat_As_Volatile (Ent)
726 -- Otherwise we have a reference to a global scalar
729 -- Loop through global entities already detected
731 Elm := First_Elmt (Var_List);
733 -- If not detected before, record this new global reference
736 Count_Vars := Count_Vars + 1;
738 if Count_Vars <= Max_Vars then
739 Append_Elmt (Entity (Nod), Var_List);
746 -- If recorded before, ignore
748 elsif Node (Elm) = Entity (Nod) then
751 -- Otherwise keep looking
761 -- For all other node kinds, recursively visit syntactic children
768 function Traverse_Body is new Traverse_Func (Process);
770 -- Start of processing for Detect_Infinite_Recursion
773 -- Do not attempt detection in No_Implicit_Conditional mode, since we
774 -- won't be able to generate the code to handle the recursion in any
777 if Restriction_Active (No_Implicit_Conditionals) then
781 -- Otherwise do traversal and quit if we get abandon signal
783 if Traverse_Body (N) = Abandon then
786 -- We must have a call, since Has_Recursive_Call was set. If not just
787 -- ignore (this is only an error check, so if we have a funny situation,
788 -- due to bugs or errors, we do not want to bomb!)
790 elsif Is_Empty_Elmt_List (Call_List) then
794 -- Here is the case where we detect recursion at compile time
796 -- Push our current scope for analyzing the declarations and code that
797 -- we will insert for the checking.
801 -- This loop builds temporary variables for each of the referenced
802 -- globals, so that at the end of the loop the list Shad_List contains
803 -- these temporaries in one-to-one correspondence with the elements in
807 Elm := First_Elmt (Var_List);
808 while Present (Elm) loop
811 Make_Defining_Identifier (Loc,
812 Chars => New_Internal_Name ('S'));
813 Append_Elmt (Ent, Shad_List);
815 -- Insert a declaration for this temporary at the start of the
816 -- declarations for the procedure. The temporaries are declared as
817 -- constant objects initialized to the current values of the
818 -- corresponding temporaries.
821 Make_Object_Declaration (Loc,
822 Defining_Identifier => Ent,
823 Object_Definition => New_Occurrence_Of (Etype (Var), Loc),
824 Constant_Present => True,
825 Expression => New_Occurrence_Of (Var, Loc));
828 Prepend (Decl, Declarations (N));
830 Insert_After (Last, Decl);
838 -- Loop through calls
840 Call := First_Elmt (Call_List);
841 while Present (Call) loop
843 -- Build a predicate expression of the form
846 -- and then global1 = temp1
847 -- and then global2 = temp2
850 -- This predicate determines if any of the global values
851 -- referenced by the procedure have changed since the
852 -- current call, if not an infinite recursion is assured.
854 Test := New_Occurrence_Of (Standard_True, Loc);
856 Elm1 := First_Elmt (Var_List);
857 Elm2 := First_Elmt (Shad_List);
858 while Present (Elm1) loop
864 Left_Opnd => New_Occurrence_Of (Node (Elm1), Loc),
865 Right_Opnd => New_Occurrence_Of (Node (Elm2), Loc)));
871 -- Now we replace the call with the sequence
873 -- if no-changes (see above) then
874 -- raise Storage_Error;
879 Rewrite (Node (Call),
880 Make_If_Statement (Loc,
882 Then_Statements => New_List (
883 Make_Raise_Storage_Error (Loc,
884 Reason => SE_Infinite_Recursion)),
886 Else_Statements => New_List (
887 Relocate_Node (Node (Call)))));
889 Analyze (Node (Call));
894 -- Remove temporary scope stack entry used for analysis
897 end Detect_Infinite_Recursion;
903 procedure Expand_Actuals (N : Node_Id; Subp : Entity_Id) is
904 Loc : constant Source_Ptr := Sloc (N);
909 E_Formal : Entity_Id;
911 procedure Add_Call_By_Copy_Code;
912 -- For cases where the parameter must be passed by copy, this routine
913 -- generates a temporary variable into which the actual is copied and
914 -- then passes this as the parameter. For an OUT or IN OUT parameter,
915 -- an assignment is also generated to copy the result back. The call
916 -- also takes care of any constraint checks required for the type
917 -- conversion case (on both the way in and the way out).
919 procedure Add_Simple_Call_By_Copy_Code;
920 -- This is similar to the above, but is used in cases where we know
921 -- that all that is needed is to simply create a temporary and copy
922 -- the value in and out of the temporary.
924 procedure Check_Fortran_Logical;
925 -- A value of type Logical that is passed through a formal parameter
926 -- must be normalized because .TRUE. usually does not have the same
927 -- representation as True. We assume that .FALSE. = False = 0.
928 -- What about functions that return a logical type ???
930 function Is_Legal_Copy return Boolean;
931 -- Check that an actual can be copied before generating the temporary
932 -- to be used in the call. If the actual is of a by_reference type then
933 -- the program is illegal (this can only happen in the presence of
934 -- rep. clauses that force an incorrect alignment). If the formal is
935 -- a by_reference parameter imposed by a DEC pragma, emit a warning to
936 -- the effect that this might lead to unaligned arguments.
938 function Make_Var (Actual : Node_Id) return Entity_Id;
939 -- Returns an entity that refers to the given actual parameter,
940 -- Actual (not including any type conversion). If Actual is an
941 -- entity name, then this entity is returned unchanged, otherwise
942 -- a renaming is created to provide an entity for the actual.
944 procedure Reset_Packed_Prefix;
945 -- The expansion of a packed array component reference is delayed in
946 -- the context of a call. Now we need to complete the expansion, so we
947 -- unmark the analyzed bits in all prefixes.
949 ---------------------------
950 -- Add_Call_By_Copy_Code --
951 ---------------------------
953 procedure Add_Call_By_Copy_Code is
959 F_Typ : constant Entity_Id := Etype (Formal);
964 if not Is_Legal_Copy then
969 Make_Defining_Identifier (Loc,
970 Chars => New_Internal_Name ('T'));
972 -- Use formal type for temp, unless formal type is an unconstrained
973 -- array, in which case we don't have to worry about bounds checks,
974 -- and we use the actual type, since that has appropriate bounds.
976 if Is_Array_Type (F_Typ) and then not Is_Constrained (F_Typ) then
977 Indic := New_Occurrence_Of (Etype (Actual), Loc);
979 Indic := New_Occurrence_Of (Etype (Formal), Loc);
982 if Nkind (Actual) = N_Type_Conversion then
983 V_Typ := Etype (Expression (Actual));
985 -- If the formal is an (in-)out parameter, capture the name
986 -- of the variable in order to build the post-call assignment.
988 Var := Make_Var (Expression (Actual));
990 Crep := not Same_Representation
991 (F_Typ, Etype (Expression (Actual)));
994 V_Typ := Etype (Actual);
995 Var := Make_Var (Actual);
999 -- Setup initialization for case of in out parameter, or an out
1000 -- parameter where the formal is an unconstrained array (in the
1001 -- latter case, we have to pass in an object with bounds).
1003 -- If this is an out parameter, the initial copy is wasteful, so as
1004 -- an optimization for the one-dimensional case we extract the
1005 -- bounds of the actual and build an uninitialized temporary of the
1008 if Ekind (Formal) = E_In_Out_Parameter
1009 or else (Is_Array_Type (F_Typ) and then not Is_Constrained (F_Typ))
1011 if Nkind (Actual) = N_Type_Conversion then
1012 if Conversion_OK (Actual) then
1013 Init := OK_Convert_To (F_Typ, New_Occurrence_Of (Var, Loc));
1015 Init := Convert_To (F_Typ, New_Occurrence_Of (Var, Loc));
1018 elsif Ekind (Formal) = E_Out_Parameter
1019 and then Is_Array_Type (F_Typ)
1020 and then Number_Dimensions (F_Typ) = 1
1021 and then not Has_Non_Null_Base_Init_Proc (F_Typ)
1023 -- Actual is a one-dimensional array or slice, and the type
1024 -- requires no initialization. Create a temporary of the
1025 -- right size, but do not copy actual into it (optimization).
1029 Make_Subtype_Indication (Loc,
1031 New_Occurrence_Of (F_Typ, Loc),
1033 Make_Index_Or_Discriminant_Constraint (Loc,
1034 Constraints => New_List (
1037 Make_Attribute_Reference (Loc,
1038 Prefix => New_Occurrence_Of (Var, Loc),
1039 Attribute_Name => Name_First),
1041 Make_Attribute_Reference (Loc,
1042 Prefix => New_Occurrence_Of (Var, Loc),
1043 Attribute_Name => Name_Last)))));
1046 Init := New_Occurrence_Of (Var, Loc);
1049 -- An initialization is created for packed conversions as
1050 -- actuals for out parameters to enable Make_Object_Declaration
1051 -- to determine the proper subtype for N_Node. Note that this
1052 -- is wasteful because the extra copying on the call side is
1053 -- not required for such out parameters. ???
1055 elsif Ekind (Formal) = E_Out_Parameter
1056 and then Nkind (Actual) = N_Type_Conversion
1057 and then (Is_Bit_Packed_Array (F_Typ)
1059 Is_Bit_Packed_Array (Etype (Expression (Actual))))
1061 if Conversion_OK (Actual) then
1062 Init := OK_Convert_To (F_Typ, New_Occurrence_Of (Var, Loc));
1064 Init := Convert_To (F_Typ, New_Occurrence_Of (Var, Loc));
1067 elsif Ekind (Formal) = E_In_Parameter then
1069 -- Handle the case in which the actual is a type conversion
1071 if Nkind (Actual) = N_Type_Conversion then
1072 if Conversion_OK (Actual) then
1073 Init := OK_Convert_To (F_Typ, New_Occurrence_Of (Var, Loc));
1075 Init := Convert_To (F_Typ, New_Occurrence_Of (Var, Loc));
1078 Init := New_Occurrence_Of (Var, Loc);
1086 Make_Object_Declaration (Loc,
1087 Defining_Identifier => Temp,
1088 Object_Definition => Indic,
1089 Expression => Init);
1090 Set_Assignment_OK (N_Node);
1091 Insert_Action (N, N_Node);
1093 -- Now, normally the deal here is that we use the defining
1094 -- identifier created by that object declaration. There is
1095 -- one exception to this. In the change of representation case
1096 -- the above declaration will end up looking like:
1098 -- temp : type := identifier;
1100 -- And in this case we might as well use the identifier directly
1101 -- and eliminate the temporary. Note that the analysis of the
1102 -- declaration was not a waste of time in that case, since it is
1103 -- what generated the necessary change of representation code. If
1104 -- the change of representation introduced additional code, as in
1105 -- a fixed-integer conversion, the expression is not an identifier
1106 -- and must be kept.
1109 and then Present (Expression (N_Node))
1110 and then Is_Entity_Name (Expression (N_Node))
1112 Temp := Entity (Expression (N_Node));
1113 Rewrite (N_Node, Make_Null_Statement (Loc));
1116 -- For IN parameter, all we do is to replace the actual
1118 if Ekind (Formal) = E_In_Parameter then
1119 Rewrite (Actual, New_Reference_To (Temp, Loc));
1122 -- Processing for OUT or IN OUT parameter
1125 -- Kill current value indications for the temporary variable we
1126 -- created, since we just passed it as an OUT parameter.
1128 Kill_Current_Values (Temp);
1129 Set_Is_Known_Valid (Temp, False);
1131 -- If type conversion, use reverse conversion on exit
1133 if Nkind (Actual) = N_Type_Conversion then
1134 if Conversion_OK (Actual) then
1135 Expr := OK_Convert_To (V_Typ, New_Occurrence_Of (Temp, Loc));
1137 Expr := Convert_To (V_Typ, New_Occurrence_Of (Temp, Loc));
1140 Expr := New_Occurrence_Of (Temp, Loc);
1143 Rewrite (Actual, New_Reference_To (Temp, Loc));
1146 -- If the actual is a conversion of a packed reference, it may
1147 -- already have been expanded by Remove_Side_Effects, and the
1148 -- resulting variable is a temporary which does not designate
1149 -- the proper out-parameter, which may not be addressable. In
1150 -- that case, generate an assignment to the original expression
1151 -- (before expansion of the packed reference) so that the proper
1152 -- expansion of assignment to a packed component can take place.
1159 if Is_Renaming_Of_Object (Var)
1160 and then Nkind (Renamed_Object (Var)) = N_Selected_Component
1161 and then Is_Entity_Name (Prefix (Renamed_Object (Var)))
1162 and then Nkind (Original_Node (Prefix (Renamed_Object (Var))))
1163 = N_Indexed_Component
1165 Has_Non_Standard_Rep (Etype (Prefix (Renamed_Object (Var))))
1167 Obj := Renamed_Object (Var);
1169 Make_Selected_Component (Loc,
1171 New_Copy_Tree (Original_Node (Prefix (Obj))),
1172 Selector_Name => New_Copy (Selector_Name (Obj)));
1173 Reset_Analyzed_Flags (Lhs);
1176 Lhs := New_Occurrence_Of (Var, Loc);
1179 Set_Assignment_OK (Lhs);
1181 Append_To (Post_Call,
1182 Make_Assignment_Statement (Loc,
1184 Expression => Expr));
1187 end Add_Call_By_Copy_Code;
1189 ----------------------------------
1190 -- Add_Simple_Call_By_Copy_Code --
1191 ----------------------------------
1193 procedure Add_Simple_Call_By_Copy_Code is
1201 F_Typ : constant Entity_Id := Etype (Formal);
1204 if not Is_Legal_Copy then
1208 -- Use formal type for temp, unless formal type is an unconstrained
1209 -- array, in which case we don't have to worry about bounds checks,
1210 -- and we use the actual type, since that has appropriate bounds.
1212 if Is_Array_Type (F_Typ) and then not Is_Constrained (F_Typ) then
1213 Indic := New_Occurrence_Of (Etype (Actual), Loc);
1215 Indic := New_Occurrence_Of (Etype (Formal), Loc);
1218 -- Prepare to generate code
1220 Reset_Packed_Prefix;
1223 Make_Defining_Identifier (Loc,
1224 Chars => New_Internal_Name ('T'));
1225 Incod := Relocate_Node (Actual);
1226 Outcod := New_Copy_Tree (Incod);
1228 -- Generate declaration of temporary variable, initializing it
1229 -- with the input parameter unless we have an OUT formal or
1230 -- this is an initialization call.
1232 -- If the formal is an out parameter with discriminants, the
1233 -- discriminants must be captured even if the rest of the object
1234 -- is in principle uninitialized, because the discriminants may
1235 -- be read by the called subprogram.
1237 if Ekind (Formal) = E_Out_Parameter then
1240 if Has_Discriminants (Etype (Formal)) then
1241 Indic := New_Occurrence_Of (Etype (Actual), Loc);
1244 elsif Inside_Init_Proc then
1246 -- Could use a comment here to match comment below ???
1248 if Nkind (Actual) /= N_Selected_Component
1250 not Has_Discriminant_Dependent_Constraint
1251 (Entity (Selector_Name (Actual)))
1255 -- Otherwise, keep the component in order to generate the proper
1256 -- actual subtype, that depends on enclosing discriminants.
1264 Make_Object_Declaration (Loc,
1265 Defining_Identifier => Temp,
1266 Object_Definition => Indic,
1267 Expression => Incod);
1272 -- If the call is to initialize a component of a composite type,
1273 -- and the component does not depend on discriminants, use the
1274 -- actual type of the component. This is required in case the
1275 -- component is constrained, because in general the formal of the
1276 -- initialization procedure will be unconstrained. Note that if
1277 -- the component being initialized is constrained by an enclosing
1278 -- discriminant, the presence of the initialization in the
1279 -- declaration will generate an expression for the actual subtype.
1281 Set_No_Initialization (Decl);
1282 Set_Object_Definition (Decl,
1283 New_Occurrence_Of (Etype (Actual), Loc));
1286 Insert_Action (N, Decl);
1288 -- The actual is simply a reference to the temporary
1290 Rewrite (Actual, New_Occurrence_Of (Temp, Loc));
1292 -- Generate copy out if OUT or IN OUT parameter
1294 if Ekind (Formal) /= E_In_Parameter then
1296 Rhs := New_Occurrence_Of (Temp, Loc);
1298 -- Deal with conversion
1300 if Nkind (Lhs) = N_Type_Conversion then
1301 Lhs := Expression (Lhs);
1302 Rhs := Convert_To (Etype (Actual), Rhs);
1305 Append_To (Post_Call,
1306 Make_Assignment_Statement (Loc,
1308 Expression => Rhs));
1309 Set_Assignment_OK (Name (Last (Post_Call)));
1311 end Add_Simple_Call_By_Copy_Code;
1313 ---------------------------
1314 -- Check_Fortran_Logical --
1315 ---------------------------
1317 procedure Check_Fortran_Logical is
1318 Logical : constant Entity_Id := Etype (Formal);
1321 -- Note: this is very incomplete, e.g. it does not handle arrays
1322 -- of logical values. This is really not the right approach at all???)
1325 if Convention (Subp) = Convention_Fortran
1326 and then Root_Type (Etype (Formal)) = Standard_Boolean
1327 and then Ekind (Formal) /= E_In_Parameter
1329 Var := Make_Var (Actual);
1330 Append_To (Post_Call,
1331 Make_Assignment_Statement (Loc,
1332 Name => New_Occurrence_Of (Var, Loc),
1334 Unchecked_Convert_To (
1337 Left_Opnd => New_Occurrence_Of (Var, Loc),
1339 Unchecked_Convert_To (
1341 New_Occurrence_Of (Standard_False, Loc))))));
1343 end Check_Fortran_Logical;
1349 function Is_Legal_Copy return Boolean is
1351 -- An attempt to copy a value of such a type can only occur if
1352 -- representation clauses give the actual a misaligned address.
1354 if Is_By_Reference_Type (Etype (Formal)) then
1356 ("misaligned actual cannot be passed by reference", Actual);
1359 -- For users of Starlet, we assume that the specification of by-
1360 -- reference mechanism is mandatory. This may lead to unaligned
1361 -- objects but at least for DEC legacy code it is known to work.
1362 -- The warning will alert users of this code that a problem may
1365 elsif Mechanism (Formal) = By_Reference
1366 and then Is_Valued_Procedure (Scope (Formal))
1369 ("by_reference actual may be misaligned?", Actual);
1381 function Make_Var (Actual : Node_Id) return Entity_Id is
1385 if Is_Entity_Name (Actual) then
1386 return Entity (Actual);
1390 Make_Defining_Identifier (Loc,
1391 Chars => New_Internal_Name ('T'));
1394 Make_Object_Renaming_Declaration (Loc,
1395 Defining_Identifier => Var,
1397 New_Occurrence_Of (Etype (Actual), Loc),
1398 Name => Relocate_Node (Actual));
1400 Insert_Action (N, N_Node);
1405 -------------------------
1406 -- Reset_Packed_Prefix --
1407 -------------------------
1409 procedure Reset_Packed_Prefix is
1410 Pfx : Node_Id := Actual;
1413 Set_Analyzed (Pfx, False);
1415 not Nkind_In (Pfx, N_Selected_Component, N_Indexed_Component);
1416 Pfx := Prefix (Pfx);
1418 end Reset_Packed_Prefix;
1420 -- Start of processing for Expand_Actuals
1423 Post_Call := New_List;
1425 Formal := First_Formal (Subp);
1426 Actual := First_Actual (N);
1427 while Present (Formal) loop
1428 E_Formal := Etype (Formal);
1430 if Is_Scalar_Type (E_Formal)
1431 or else Nkind (Actual) = N_Slice
1433 Check_Fortran_Logical;
1437 elsif Ekind (Formal) /= E_Out_Parameter then
1439 -- The unusual case of the current instance of a protected type
1440 -- requires special handling. This can only occur in the context
1441 -- of a call within the body of a protected operation.
1443 if Is_Entity_Name (Actual)
1444 and then Ekind (Entity (Actual)) = E_Protected_Type
1445 and then In_Open_Scopes (Entity (Actual))
1447 if Scope (Subp) /= Entity (Actual) then
1448 Error_Msg_N ("operation outside protected type may not "
1449 & "call back its protected operations?", Actual);
1453 Expand_Protected_Object_Reference (N, Entity (Actual)));
1456 -- Ada 2005 (AI-318-02): If the actual parameter is a call to a
1457 -- build-in-place function, then a temporary return object needs
1458 -- to be created and access to it must be passed to the function.
1459 -- Currently we limit such functions to those with inherently
1460 -- limited result subtypes, but eventually we plan to expand the
1461 -- functions that are treated as build-in-place to include other
1462 -- composite result types.
1464 if Ada_Version >= Ada_05
1465 and then Is_Build_In_Place_Function_Call (Actual)
1467 Make_Build_In_Place_Call_In_Anonymous_Context (Actual);
1470 Apply_Constraint_Check (Actual, E_Formal);
1472 -- Out parameter case. No constraint checks on access type
1475 elsif Is_Access_Type (E_Formal) then
1480 elsif Has_Discriminants (Base_Type (E_Formal))
1481 or else Has_Non_Null_Base_Init_Proc (E_Formal)
1483 Apply_Constraint_Check (Actual, E_Formal);
1488 Apply_Constraint_Check (Actual, Base_Type (E_Formal));
1491 -- Processing for IN-OUT and OUT parameters
1493 if Ekind (Formal) /= E_In_Parameter then
1495 -- For type conversions of arrays, apply length/range checks
1497 if Is_Array_Type (E_Formal)
1498 and then Nkind (Actual) = N_Type_Conversion
1500 if Is_Constrained (E_Formal) then
1501 Apply_Length_Check (Expression (Actual), E_Formal);
1503 Apply_Range_Check (Expression (Actual), E_Formal);
1507 -- If argument is a type conversion for a type that is passed
1508 -- by copy, then we must pass the parameter by copy.
1510 if Nkind (Actual) = N_Type_Conversion
1512 (Is_Numeric_Type (E_Formal)
1513 or else Is_Access_Type (E_Formal)
1514 or else Is_Enumeration_Type (E_Formal)
1515 or else Is_Bit_Packed_Array (Etype (Formal))
1516 or else Is_Bit_Packed_Array (Etype (Expression (Actual)))
1518 -- Also pass by copy if change of representation
1520 or else not Same_Representation
1522 Etype (Expression (Actual))))
1524 Add_Call_By_Copy_Code;
1526 -- References to components of bit packed arrays are expanded
1527 -- at this point, rather than at the point of analysis of the
1528 -- actuals, to handle the expansion of the assignment to
1529 -- [in] out parameters.
1531 elsif Is_Ref_To_Bit_Packed_Array (Actual) then
1532 Add_Simple_Call_By_Copy_Code;
1534 -- If a non-scalar actual is possibly bit-aligned, we need a copy
1535 -- because the back-end cannot cope with such objects. In other
1536 -- cases where alignment forces a copy, the back-end generates
1537 -- it properly. It should not be generated unconditionally in the
1538 -- front-end because it does not know precisely the alignment
1539 -- requirements of the target, and makes too conservative an
1540 -- estimate, leading to superfluous copies or spurious errors
1541 -- on by-reference parameters.
1543 elsif Nkind (Actual) = N_Selected_Component
1545 Component_May_Be_Bit_Aligned (Entity (Selector_Name (Actual)))
1546 and then not Represented_As_Scalar (Etype (Formal))
1548 Add_Simple_Call_By_Copy_Code;
1550 -- References to slices of bit packed arrays are expanded
1552 elsif Is_Ref_To_Bit_Packed_Slice (Actual) then
1553 Add_Call_By_Copy_Code;
1555 -- References to possibly unaligned slices of arrays are expanded
1557 elsif Is_Possibly_Unaligned_Slice (Actual) then
1558 Add_Call_By_Copy_Code;
1560 -- Deal with access types where the actual subtype and the
1561 -- formal subtype are not the same, requiring a check.
1563 -- It is necessary to exclude tagged types because of "downward
1564 -- conversion" errors.
1566 elsif Is_Access_Type (E_Formal)
1567 and then not Same_Type (E_Formal, Etype (Actual))
1568 and then not Is_Tagged_Type (Designated_Type (E_Formal))
1570 Add_Call_By_Copy_Code;
1572 -- If the actual is not a scalar and is marked for volatile
1573 -- treatment, whereas the formal is not volatile, then pass
1574 -- by copy unless it is a by-reference type.
1576 -- Note: we use Is_Volatile here rather than Treat_As_Volatile,
1577 -- because this is the enforcement of a language rule that applies
1578 -- only to "real" volatile variables, not e.g. to the address
1579 -- clause overlay case.
1581 elsif Is_Entity_Name (Actual)
1582 and then Is_Volatile (Entity (Actual))
1583 and then not Is_By_Reference_Type (Etype (Actual))
1584 and then not Is_Scalar_Type (Etype (Entity (Actual)))
1585 and then not Is_Volatile (E_Formal)
1587 Add_Call_By_Copy_Code;
1589 elsif Nkind (Actual) = N_Indexed_Component
1590 and then Is_Entity_Name (Prefix (Actual))
1591 and then Has_Volatile_Components (Entity (Prefix (Actual)))
1593 Add_Call_By_Copy_Code;
1595 -- Add call-by-copy code for the case of scalar out parameters
1596 -- when it is not known at compile time that the subtype of the
1597 -- formal is a subrange of the subtype of the actual (or vice
1598 -- versa for in out parameters), in order to get range checks
1599 -- on such actuals. (Maybe this case should be handled earlier
1600 -- in the if statement???)
1602 elsif Is_Scalar_Type (E_Formal)
1604 (not In_Subrange_Of (E_Formal, Etype (Actual))
1606 (Ekind (Formal) = E_In_Out_Parameter
1607 and then not In_Subrange_Of (Etype (Actual), E_Formal)))
1609 -- Perhaps the setting back to False should be done within
1610 -- Add_Call_By_Copy_Code, since it could get set on other
1611 -- cases occurring above???
1613 if Do_Range_Check (Actual) then
1614 Set_Do_Range_Check (Actual, False);
1617 Add_Call_By_Copy_Code;
1620 -- Processing for IN parameters
1623 -- For IN parameters is in the packed array case, we expand an
1624 -- indexed component (the circuit in Exp_Ch4 deliberately left
1625 -- indexed components appearing as actuals untouched, so that
1626 -- the special processing above for the OUT and IN OUT cases
1627 -- could be performed. We could make the test in Exp_Ch4 more
1628 -- complex and have it detect the parameter mode, but it is
1629 -- easier simply to handle all cases here.)
1631 if Nkind (Actual) = N_Indexed_Component
1632 and then Is_Packed (Etype (Prefix (Actual)))
1634 Reset_Packed_Prefix;
1635 Expand_Packed_Element_Reference (Actual);
1637 -- If we have a reference to a bit packed array, we copy it, since
1638 -- the actual must be byte aligned.
1640 -- Is this really necessary in all cases???
1642 elsif Is_Ref_To_Bit_Packed_Array (Actual) then
1643 Add_Simple_Call_By_Copy_Code;
1645 -- If a non-scalar actual is possibly unaligned, we need a copy
1647 elsif Is_Possibly_Unaligned_Object (Actual)
1648 and then not Represented_As_Scalar (Etype (Formal))
1650 Add_Simple_Call_By_Copy_Code;
1652 -- Similarly, we have to expand slices of packed arrays here
1653 -- because the result must be byte aligned.
1655 elsif Is_Ref_To_Bit_Packed_Slice (Actual) then
1656 Add_Call_By_Copy_Code;
1658 -- Only processing remaining is to pass by copy if this is a
1659 -- reference to a possibly unaligned slice, since the caller
1660 -- expects an appropriately aligned argument.
1662 elsif Is_Possibly_Unaligned_Slice (Actual) then
1663 Add_Call_By_Copy_Code;
1667 Next_Formal (Formal);
1668 Next_Actual (Actual);
1671 -- Find right place to put post call stuff if it is present
1673 if not Is_Empty_List (Post_Call) then
1675 -- If call is not a list member, it must be the triggering statement
1676 -- of a triggering alternative or an entry call alternative, and we
1677 -- can add the post call stuff to the corresponding statement list.
1679 if not Is_List_Member (N) then
1681 P : constant Node_Id := Parent (N);
1684 pragma Assert (Nkind_In (P, N_Triggering_Alternative,
1685 N_Entry_Call_Alternative));
1687 if Is_Non_Empty_List (Statements (P)) then
1688 Insert_List_Before_And_Analyze
1689 (First (Statements (P)), Post_Call);
1691 Set_Statements (P, Post_Call);
1695 -- Otherwise, normal case where N is in a statement sequence,
1696 -- just put the post-call stuff after the call statement.
1699 Insert_Actions_After (N, Post_Call);
1703 -- The call node itself is re-analyzed in Expand_Call
1711 -- This procedure handles expansion of function calls and procedure call
1712 -- statements (i.e. it serves as the body for Expand_N_Function_Call and
1713 -- Expand_N_Procedure_Call_Statement). Processing for calls includes:
1715 -- Replace call to Raise_Exception by Raise_Exception_Always if possible
1716 -- Provide values of actuals for all formals in Extra_Formals list
1717 -- Replace "call" to enumeration literal function by literal itself
1718 -- Rewrite call to predefined operator as operator
1719 -- Replace actuals to in-out parameters that are numeric conversions,
1720 -- with explicit assignment to temporaries before and after the call.
1721 -- Remove optional actuals if First_Optional_Parameter specified.
1723 -- Note that the list of actuals has been filled with default expressions
1724 -- during semantic analysis of the call. Only the extra actuals required
1725 -- for the 'Constrained attribute and for accessibility checks are added
1728 procedure Expand_Call (N : Node_Id) is
1729 Loc : constant Source_Ptr := Sloc (N);
1730 Extra_Actuals : List_Id := No_List;
1731 Prev : Node_Id := Empty;
1733 procedure Add_Actual_Parameter (Insert_Param : Node_Id);
1734 -- Adds one entry to the end of the actual parameter list. Used for
1735 -- default parameters and for extra actuals (for Extra_Formals). The
1736 -- argument is an N_Parameter_Association node.
1738 procedure Add_Extra_Actual (Expr : Node_Id; EF : Entity_Id);
1739 -- Adds an extra actual to the list of extra actuals. Expr is the
1740 -- expression for the value of the actual, EF is the entity for the
1743 function Inherited_From_Formal (S : Entity_Id) return Entity_Id;
1744 -- Within an instance, a type derived from a non-tagged formal derived
1745 -- type inherits from the original parent, not from the actual. The
1746 -- current derivation mechanism has the derived type inherit from the
1747 -- actual, which is only correct outside of the instance. If the
1748 -- subprogram is inherited, we test for this particular case through a
1749 -- convoluted tree traversal before setting the proper subprogram to be
1752 --------------------------
1753 -- Add_Actual_Parameter --
1754 --------------------------
1756 procedure Add_Actual_Parameter (Insert_Param : Node_Id) is
1757 Actual_Expr : constant Node_Id :=
1758 Explicit_Actual_Parameter (Insert_Param);
1761 -- Case of insertion is first named actual
1763 if No (Prev) or else
1764 Nkind (Parent (Prev)) /= N_Parameter_Association
1766 Set_Next_Named_Actual (Insert_Param, First_Named_Actual (N));
1767 Set_First_Named_Actual (N, Actual_Expr);
1770 if No (Parameter_Associations (N)) then
1771 Set_Parameter_Associations (N, New_List);
1772 Append (Insert_Param, Parameter_Associations (N));
1775 Insert_After (Prev, Insert_Param);
1778 -- Case of insertion is not first named actual
1781 Set_Next_Named_Actual
1782 (Insert_Param, Next_Named_Actual (Parent (Prev)));
1783 Set_Next_Named_Actual (Parent (Prev), Actual_Expr);
1784 Append (Insert_Param, Parameter_Associations (N));
1787 Prev := Actual_Expr;
1788 end Add_Actual_Parameter;
1790 ----------------------
1791 -- Add_Extra_Actual --
1792 ----------------------
1794 procedure Add_Extra_Actual (Expr : Node_Id; EF : Entity_Id) is
1795 Loc : constant Source_Ptr := Sloc (Expr);
1798 if Extra_Actuals = No_List then
1799 Extra_Actuals := New_List;
1800 Set_Parent (Extra_Actuals, N);
1803 Append_To (Extra_Actuals,
1804 Make_Parameter_Association (Loc,
1805 Explicit_Actual_Parameter => Expr,
1807 Make_Identifier (Loc, Chars (EF))));
1809 Analyze_And_Resolve (Expr, Etype (EF));
1810 end Add_Extra_Actual;
1812 ---------------------------
1813 -- Inherited_From_Formal --
1814 ---------------------------
1816 function Inherited_From_Formal (S : Entity_Id) return Entity_Id is
1818 Gen_Par : Entity_Id;
1819 Gen_Prim : Elist_Id;
1824 -- If the operation is inherited, it is attached to the corresponding
1825 -- type derivation. If the parent in the derivation is a generic
1826 -- actual, it is a subtype of the actual, and we have to recover the
1827 -- original derived type declaration to find the proper parent.
1829 if Nkind (Parent (S)) /= N_Full_Type_Declaration
1830 or else not Is_Derived_Type (Defining_Identifier (Parent (S)))
1831 or else Nkind (Type_Definition (Original_Node (Parent (S)))) /=
1832 N_Derived_Type_Definition
1833 or else not In_Instance
1840 (Type_Definition (Original_Node (Parent (S))));
1842 if Nkind (Indic) = N_Subtype_Indication then
1843 Par := Entity (Subtype_Mark (Indic));
1845 Par := Entity (Indic);
1849 if not Is_Generic_Actual_Type (Par)
1850 or else Is_Tagged_Type (Par)
1851 or else Nkind (Parent (Par)) /= N_Subtype_Declaration
1852 or else not In_Open_Scopes (Scope (Par))
1856 Gen_Par := Generic_Parent_Type (Parent (Par));
1859 -- If the actual has no generic parent type, the formal is not
1860 -- a formal derived type, so nothing to inherit.
1862 if No (Gen_Par) then
1866 -- If the generic parent type is still the generic type, this is a
1867 -- private formal, not a derived formal, and there are no operations
1868 -- inherited from the formal.
1870 if Nkind (Parent (Gen_Par)) = N_Formal_Type_Declaration then
1874 Gen_Prim := Collect_Primitive_Operations (Gen_Par);
1876 Elmt := First_Elmt (Gen_Prim);
1877 while Present (Elmt) loop
1878 if Chars (Node (Elmt)) = Chars (S) then
1884 F1 := First_Formal (S);
1885 F2 := First_Formal (Node (Elmt));
1887 and then Present (F2)
1889 if Etype (F1) = Etype (F2)
1890 or else Etype (F2) = Gen_Par
1896 exit; -- not the right subprogram
1908 raise Program_Error;
1909 end Inherited_From_Formal;
1913 Remote : constant Boolean := Is_Remote_Call (N);
1916 Orig_Subp : Entity_Id := Empty;
1917 Param_Count : Natural := 0;
1918 Parent_Formal : Entity_Id;
1919 Parent_Subp : Entity_Id;
1923 Prev_Orig : Node_Id;
1924 -- Original node for an actual, which may have been rewritten. If the
1925 -- actual is a function call that has been transformed from a selected
1926 -- component, the original node is unanalyzed. Otherwise, it carries
1927 -- semantic information used to generate additional actuals.
1929 CW_Interface_Formals_Present : Boolean := False;
1931 -- Start of processing for Expand_Call
1934 -- Ignore if previous error
1936 if Nkind (N) in N_Has_Etype and then Etype (N) = Any_Type then
1940 -- Call using access to subprogram with explicit dereference
1942 if Nkind (Name (N)) = N_Explicit_Dereference then
1943 Subp := Etype (Name (N));
1944 Parent_Subp := Empty;
1946 -- Case of call to simple entry, where the Name is a selected component
1947 -- whose prefix is the task, and whose selector name is the entry name
1949 elsif Nkind (Name (N)) = N_Selected_Component then
1950 Subp := Entity (Selector_Name (Name (N)));
1951 Parent_Subp := Empty;
1953 -- Case of call to member of entry family, where Name is an indexed
1954 -- component, with the prefix being a selected component giving the
1955 -- task and entry family name, and the index being the entry index.
1957 elsif Nkind (Name (N)) = N_Indexed_Component then
1958 Subp := Entity (Selector_Name (Prefix (Name (N))));
1959 Parent_Subp := Empty;
1964 Subp := Entity (Name (N));
1965 Parent_Subp := Alias (Subp);
1967 -- Replace call to Raise_Exception by call to Raise_Exception_Always
1968 -- if we can tell that the first parameter cannot possibly be null.
1969 -- This improves efficiency by avoiding a run-time test.
1971 -- We do not do this if Raise_Exception_Always does not exist, which
1972 -- can happen in configurable run time profiles which provide only a
1975 if Is_RTE (Subp, RE_Raise_Exception)
1976 and then RTE_Available (RE_Raise_Exception_Always)
1979 FA : constant Node_Id := Original_Node (First_Actual (N));
1982 -- The case we catch is where the first argument is obtained
1983 -- using the Identity attribute (which must always be
1986 if Nkind (FA) = N_Attribute_Reference
1987 and then Attribute_Name (FA) = Name_Identity
1989 Subp := RTE (RE_Raise_Exception_Always);
1990 Set_Name (N, New_Occurrence_Of (Subp, Loc));
1995 if Ekind (Subp) = E_Entry then
1996 Parent_Subp := Empty;
2000 -- Ada 2005 (AI-345): We have a procedure call as a triggering
2001 -- alternative in an asynchronous select or as an entry call in
2002 -- a conditional or timed select. Check whether the procedure call
2003 -- is a renaming of an entry and rewrite it as an entry call.
2005 if Ada_Version >= Ada_05
2006 and then Nkind (N) = N_Procedure_Call_Statement
2008 ((Nkind (Parent (N)) = N_Triggering_Alternative
2009 and then Triggering_Statement (Parent (N)) = N)
2011 (Nkind (Parent (N)) = N_Entry_Call_Alternative
2012 and then Entry_Call_Statement (Parent (N)) = N))
2016 Ren_Root : Entity_Id := Subp;
2019 -- This may be a chain of renamings, find the root
2021 if Present (Alias (Ren_Root)) then
2022 Ren_Root := Alias (Ren_Root);
2025 if Present (Original_Node (Parent (Parent (Ren_Root)))) then
2026 Ren_Decl := Original_Node (Parent (Parent (Ren_Root)));
2028 if Nkind (Ren_Decl) = N_Subprogram_Renaming_Declaration then
2030 Make_Entry_Call_Statement (Loc,
2032 New_Copy_Tree (Name (Ren_Decl)),
2033 Parameter_Associations =>
2034 New_Copy_List_Tree (Parameter_Associations (N))));
2042 -- First step, compute extra actuals, corresponding to any Extra_Formals
2043 -- present. Note that we do not access Extra_Formals directly, instead
2044 -- we simply note the presence of the extra formals as we process the
2045 -- regular formals collecting corresponding actuals in Extra_Actuals.
2047 -- We also generate any required range checks for actuals for in formals
2048 -- as we go through the loop, since this is a convenient place to do it.
2049 -- (Though it seems that this would be better done in Expand_Actuals???)
2051 Formal := First_Formal (Subp);
2052 Actual := First_Actual (N);
2054 while Present (Formal) loop
2056 -- Generate range check if required
2058 if Do_Range_Check (Actual)
2059 and then Ekind (Formal) = E_In_Parameter
2061 Set_Do_Range_Check (Actual, False);
2062 Generate_Range_Check
2063 (Actual, Etype (Formal), CE_Range_Check_Failed);
2066 -- Prepare to examine current entry
2069 Prev_Orig := Original_Node (Prev);
2071 -- Ada 2005 (AI-251): Check if any formal is a class-wide interface
2072 -- to expand it in a further round.
2074 CW_Interface_Formals_Present :=
2075 CW_Interface_Formals_Present
2077 (Ekind (Etype (Formal)) = E_Class_Wide_Type
2078 and then Is_Interface (Etype (Etype (Formal))))
2080 (Ekind (Etype (Formal)) = E_Anonymous_Access_Type
2081 and then Is_Interface (Directly_Designated_Type
2082 (Etype (Etype (Formal)))));
2084 -- Create possible extra actual for constrained case. Usually, the
2085 -- extra actual is of the form actual'constrained, but since this
2086 -- attribute is only available for unconstrained records, TRUE is
2087 -- expanded if the type of the formal happens to be constrained (for
2088 -- instance when this procedure is inherited from an unconstrained
2089 -- record to a constrained one) or if the actual has no discriminant
2090 -- (its type is constrained). An exception to this is the case of a
2091 -- private type without discriminants. In this case we pass FALSE
2092 -- because the object has underlying discriminants with defaults.
2094 if Present (Extra_Constrained (Formal)) then
2095 if Ekind (Etype (Prev)) in Private_Kind
2096 and then not Has_Discriminants (Base_Type (Etype (Prev)))
2099 (New_Occurrence_Of (Standard_False, Loc),
2100 Extra_Constrained (Formal));
2102 elsif Is_Constrained (Etype (Formal))
2103 or else not Has_Discriminants (Etype (Prev))
2106 (New_Occurrence_Of (Standard_True, Loc),
2107 Extra_Constrained (Formal));
2109 -- Do not produce extra actuals for Unchecked_Union parameters.
2110 -- Jump directly to the end of the loop.
2112 elsif Is_Unchecked_Union (Base_Type (Etype (Actual))) then
2113 goto Skip_Extra_Actual_Generation;
2116 -- If the actual is a type conversion, then the constrained
2117 -- test applies to the actual, not the target type.
2123 -- Test for unchecked conversions as well, which can occur
2124 -- as out parameter actuals on calls to stream procedures.
2127 while Nkind_In (Act_Prev, N_Type_Conversion,
2128 N_Unchecked_Type_Conversion)
2130 Act_Prev := Expression (Act_Prev);
2133 -- If the expression is a conversion of a dereference, this
2134 -- is internally generated code that manipulates addresses,
2135 -- e.g. when building interface tables. No check should
2136 -- occur in this case, and the discriminated object is not
2139 if not Comes_From_Source (Actual)
2140 and then Nkind (Actual) = N_Unchecked_Type_Conversion
2141 and then Nkind (Act_Prev) = N_Explicit_Dereference
2144 (New_Occurrence_Of (Standard_False, Loc),
2145 Extra_Constrained (Formal));
2149 (Make_Attribute_Reference (Sloc (Prev),
2151 Duplicate_Subexpr_No_Checks
2152 (Act_Prev, Name_Req => True),
2153 Attribute_Name => Name_Constrained),
2154 Extra_Constrained (Formal));
2160 -- Create possible extra actual for accessibility level
2162 if Present (Extra_Accessibility (Formal)) then
2164 -- Ada 2005 (AI-252): If the actual was rewritten as an Access
2165 -- attribute, then the original actual may be an aliased object
2166 -- occurring as the prefix in a call using "Object.Operation"
2167 -- notation. In that case we must pass the level of the object,
2168 -- so Prev_Orig is reset to Prev and the attribute will be
2169 -- processed by the code for Access attributes further below.
2171 if Prev_Orig /= Prev
2172 and then Nkind (Prev) = N_Attribute_Reference
2174 Get_Attribute_Id (Attribute_Name (Prev)) = Attribute_Access
2175 and then Is_Aliased_View (Prev_Orig)
2180 -- Ada 2005 (AI-251): Thunks must propagate the extra actuals
2181 -- of accessibility levels.
2183 if Ekind (Current_Scope) in Subprogram_Kind
2184 and then Is_Thunk (Current_Scope)
2187 Parm_Ent : Entity_Id;
2190 if Is_Controlling_Actual (Actual) then
2192 -- Find the corresponding actual of the thunk
2194 Parm_Ent := First_Entity (Current_Scope);
2195 for J in 2 .. Param_Count loop
2196 Next_Entity (Parm_Ent);
2199 else pragma Assert (Is_Entity_Name (Actual));
2200 Parm_Ent := Entity (Actual);
2204 (New_Occurrence_Of (Extra_Accessibility (Parm_Ent), Loc),
2205 Extra_Accessibility (Formal));
2208 elsif Is_Entity_Name (Prev_Orig) then
2210 -- When passing an access parameter, or a renaming of an access
2211 -- parameter, as the actual to another access parameter we need
2212 -- to pass along the actual's own access level parameter. This
2213 -- is done if we are within the scope of the formal access
2214 -- parameter (if this is an inlined body the extra formal is
2217 if (Is_Formal (Entity (Prev_Orig))
2219 (Present (Renamed_Object (Entity (Prev_Orig)))
2221 Is_Entity_Name (Renamed_Object (Entity (Prev_Orig)))
2224 (Entity (Renamed_Object (Entity (Prev_Orig))))))
2225 and then Ekind (Etype (Prev_Orig)) = E_Anonymous_Access_Type
2226 and then In_Open_Scopes (Scope (Entity (Prev_Orig)))
2229 Parm_Ent : constant Entity_Id := Param_Entity (Prev_Orig);
2232 pragma Assert (Present (Parm_Ent));
2234 if Present (Extra_Accessibility (Parm_Ent)) then
2237 (Extra_Accessibility (Parm_Ent), Loc),
2238 Extra_Accessibility (Formal));
2240 -- If the actual access parameter does not have an
2241 -- associated extra formal providing its scope level,
2242 -- then treat the actual as having library-level
2247 (Make_Integer_Literal (Loc,
2248 Intval => Scope_Depth (Standard_Standard)),
2249 Extra_Accessibility (Formal));
2253 -- The actual is a normal access value, so just pass the level
2254 -- of the actual's access type.
2258 (Make_Integer_Literal (Loc,
2259 Intval => Type_Access_Level (Etype (Prev_Orig))),
2260 Extra_Accessibility (Formal));
2263 -- If the actual is an access discriminant, then pass the level
2264 -- of the enclosing object (RM05-3.10.2(12.4/2)).
2266 elsif Nkind (Prev_Orig) = N_Selected_Component
2267 and then Ekind (Entity (Selector_Name (Prev_Orig))) =
2269 and then Ekind (Etype (Entity (Selector_Name (Prev_Orig)))) =
2270 E_Anonymous_Access_Type
2273 (Make_Integer_Literal (Loc,
2274 Intval => Object_Access_Level (Prefix (Prev_Orig))),
2275 Extra_Accessibility (Formal));
2280 case Nkind (Prev_Orig) is
2282 when N_Attribute_Reference =>
2283 case Get_Attribute_Id (Attribute_Name (Prev_Orig)) is
2285 -- For X'Access, pass on the level of the prefix X
2287 when Attribute_Access =>
2289 (Make_Integer_Literal (Loc,
2291 Object_Access_Level (Prefix (Prev_Orig))),
2292 Extra_Accessibility (Formal));
2294 -- Treat the unchecked attributes as library-level
2296 when Attribute_Unchecked_Access |
2297 Attribute_Unrestricted_Access =>
2299 (Make_Integer_Literal (Loc,
2300 Intval => Scope_Depth (Standard_Standard)),
2301 Extra_Accessibility (Formal));
2303 -- No other cases of attributes returning access
2304 -- values that can be passed to access parameters
2307 raise Program_Error;
2311 -- For allocators we pass the level of the execution of
2312 -- the called subprogram, which is one greater than the
2313 -- current scope level.
2317 (Make_Integer_Literal (Loc,
2318 Intval => Scope_Depth (Current_Scope) + 1),
2319 Extra_Accessibility (Formal));
2321 -- For other cases we simply pass the level of the actual's
2322 -- access type. The type is retrieved from Prev rather than
2323 -- Prev_Orig, because in some cases Prev_Orig denotes an
2324 -- original expression that has not been analyzed.
2328 (Make_Integer_Literal (Loc,
2329 Intval => Type_Access_Level (Etype (Prev))),
2330 Extra_Accessibility (Formal));
2336 -- Perform the check of 4.6(49) that prevents a null value from being
2337 -- passed as an actual to an access parameter. Note that the check is
2338 -- elided in the common cases of passing an access attribute or
2339 -- access parameter as an actual. Also, we currently don't enforce
2340 -- this check for expander-generated actuals and when -gnatdj is set.
2342 if Ada_Version >= Ada_05 then
2344 -- Ada 2005 (AI-231): Check null-excluding access types
2346 if Is_Access_Type (Etype (Formal))
2347 and then Can_Never_Be_Null (Etype (Formal))
2348 and then Nkind (Prev) /= N_Raise_Constraint_Error
2349 and then (Known_Null (Prev)
2350 or else not Can_Never_Be_Null (Etype (Prev)))
2352 Install_Null_Excluding_Check (Prev);
2355 -- Ada_Version < Ada_05
2358 if Ekind (Etype (Formal)) /= E_Anonymous_Access_Type
2359 or else Access_Checks_Suppressed (Subp)
2363 elsif Debug_Flag_J then
2366 elsif not Comes_From_Source (Prev) then
2369 elsif Is_Entity_Name (Prev)
2370 and then Ekind (Etype (Prev)) = E_Anonymous_Access_Type
2374 elsif Nkind_In (Prev, N_Allocator, N_Attribute_Reference) then
2377 -- Suppress null checks when passing to access parameters of Java
2378 -- and CIL subprograms. (Should this be done for other foreign
2379 -- conventions as well ???)
2381 elsif Convention (Subp) = Convention_Java
2382 or else Convention (Subp) = Convention_CIL
2387 Install_Null_Excluding_Check (Prev);
2391 -- Perform appropriate validity checks on parameters that
2394 if Validity_Checks_On then
2395 if (Ekind (Formal) = E_In_Parameter
2396 and then Validity_Check_In_Params)
2398 (Ekind (Formal) = E_In_Out_Parameter
2399 and then Validity_Check_In_Out_Params)
2401 -- If the actual is an indexed component of a packed type (or
2402 -- is an indexed or selected component whose prefix recursively
2403 -- meets this condition), it has not been expanded yet. It will
2404 -- be copied in the validity code that follows, and has to be
2405 -- expanded appropriately, so reanalyze it.
2407 -- What we do is just to unset analyzed bits on prefixes till
2408 -- we reach something that does not have a prefix.
2415 while Nkind_In (Nod, N_Indexed_Component,
2416 N_Selected_Component)
2418 Set_Analyzed (Nod, False);
2419 Nod := Prefix (Nod);
2423 Ensure_Valid (Actual);
2427 -- For IN OUT and OUT parameters, ensure that subscripts are valid
2428 -- since this is a left side reference. We only do this for calls
2429 -- from the source program since we assume that compiler generated
2430 -- calls explicitly generate any required checks. We also need it
2431 -- only if we are doing standard validity checks, since clearly it
2432 -- is not needed if validity checks are off, and in subscript
2433 -- validity checking mode, all indexed components are checked with
2434 -- a call directly from Expand_N_Indexed_Component.
2436 if Comes_From_Source (N)
2437 and then Ekind (Formal) /= E_In_Parameter
2438 and then Validity_Checks_On
2439 and then Validity_Check_Default
2440 and then not Validity_Check_Subscripts
2442 Check_Valid_Lvalue_Subscripts (Actual);
2445 -- Mark any scalar OUT parameter that is a simple variable as no
2446 -- longer known to be valid (unless the type is always valid). This
2447 -- reflects the fact that if an OUT parameter is never set in a
2448 -- procedure, then it can become invalid on the procedure return.
2450 if Ekind (Formal) = E_Out_Parameter
2451 and then Is_Entity_Name (Actual)
2452 and then Ekind (Entity (Actual)) = E_Variable
2453 and then not Is_Known_Valid (Etype (Actual))
2455 Set_Is_Known_Valid (Entity (Actual), False);
2458 -- For an OUT or IN OUT parameter, if the actual is an entity, then
2459 -- clear current values, since they can be clobbered. We are probably
2460 -- doing this in more places than we need to, but better safe than
2461 -- sorry when it comes to retaining bad current values!
2463 if Ekind (Formal) /= E_In_Parameter
2464 and then Is_Entity_Name (Actual)
2465 and then Present (Entity (Actual))
2468 Ent : constant Entity_Id := Entity (Actual);
2472 -- For an OUT or IN OUT parameter that is an assignable entity,
2473 -- we do not want to clobber the Last_Assignment field, since
2474 -- if it is set, it was precisely because it is indeed an OUT
2475 -- or IN OUT parameter! We do reset the Is_Known_Valid flag
2476 -- since the subprogram could have returned in invalid value.
2478 if (Ekind (Formal) = E_Out_Parameter
2480 Ekind (Formal) = E_In_Out_Parameter)
2481 and then Is_Assignable (Ent)
2483 Sav := Last_Assignment (Ent);
2484 Kill_Current_Values (Ent);
2485 Set_Last_Assignment (Ent, Sav);
2486 Set_Is_Known_Valid (Ent, False);
2488 -- For all other cases, just kill the current values
2491 Kill_Current_Values (Ent);
2496 -- If the formal is class wide and the actual is an aggregate, force
2497 -- evaluation so that the back end who does not know about class-wide
2498 -- type, does not generate a temporary of the wrong size.
2500 if not Is_Class_Wide_Type (Etype (Formal)) then
2503 elsif Nkind (Actual) = N_Aggregate
2504 or else (Nkind (Actual) = N_Qualified_Expression
2505 and then Nkind (Expression (Actual)) = N_Aggregate)
2507 Force_Evaluation (Actual);
2510 -- In a remote call, if the formal is of a class-wide type, check
2511 -- that the actual meets the requirements described in E.4(18).
2513 if Remote and then Is_Class_Wide_Type (Etype (Formal)) then
2514 Insert_Action (Actual,
2515 Make_Transportable_Check (Loc,
2516 Duplicate_Subexpr_Move_Checks (Actual)));
2519 -- This label is required when skipping extra actual generation for
2520 -- Unchecked_Union parameters.
2522 <<Skip_Extra_Actual_Generation>>
2524 Param_Count := Param_Count + 1;
2525 Next_Actual (Actual);
2526 Next_Formal (Formal);
2529 -- If we are expanding a rhs of an assignment we need to check if tag
2530 -- propagation is needed. You might expect this processing to be in
2531 -- Analyze_Assignment but has to be done earlier (bottom-up) because the
2532 -- assignment might be transformed to a declaration for an unconstrained
2533 -- value if the expression is classwide.
2535 if Nkind (N) = N_Function_Call
2536 and then Is_Tag_Indeterminate (N)
2537 and then Is_Entity_Name (Name (N))
2540 Ass : Node_Id := Empty;
2543 if Nkind (Parent (N)) = N_Assignment_Statement then
2546 elsif Nkind (Parent (N)) = N_Qualified_Expression
2547 and then Nkind (Parent (Parent (N))) = N_Assignment_Statement
2549 Ass := Parent (Parent (N));
2551 elsif Nkind (Parent (N)) = N_Explicit_Dereference
2552 and then Nkind (Parent (Parent (N))) = N_Assignment_Statement
2554 Ass := Parent (Parent (N));
2558 and then Is_Class_Wide_Type (Etype (Name (Ass)))
2560 if Is_Access_Type (Etype (N)) then
2561 if Designated_Type (Etype (N)) /=
2562 Root_Type (Etype (Name (Ass)))
2565 ("tag-indeterminate expression "
2566 & " must have designated type& (RM 5.2 (6))",
2567 N, Root_Type (Etype (Name (Ass))));
2569 Propagate_Tag (Name (Ass), N);
2572 elsif Etype (N) /= Root_Type (Etype (Name (Ass))) then
2574 ("tag-indeterminate expression must have type&"
2575 & "(RM 5.2 (6))", N, Root_Type (Etype (Name (Ass))));
2578 Propagate_Tag (Name (Ass), N);
2581 -- The call will be rewritten as a dispatching call, and
2582 -- expanded as such.
2589 -- Ada 2005 (AI-251): If some formal is a class-wide interface, expand
2590 -- it to point to the correct secondary virtual table
2592 if Nkind_In (N, N_Function_Call, N_Procedure_Call_Statement)
2593 and then CW_Interface_Formals_Present
2595 Expand_Interface_Actuals (N);
2598 -- Deals with Dispatch_Call if we still have a call, before expanding
2599 -- extra actuals since this will be done on the re-analysis of the
2600 -- dispatching call. Note that we do not try to shorten the actual
2601 -- list for a dispatching call, it would not make sense to do so.
2602 -- Expansion of dispatching calls is suppressed when VM_Target, because
2603 -- the VM back-ends directly handle the generation of dispatching
2604 -- calls and would have to undo any expansion to an indirect call.
2606 if Nkind_In (N, N_Function_Call, N_Procedure_Call_Statement)
2607 and then Present (Controlling_Argument (N))
2609 if Tagged_Type_Expansion then
2610 Expand_Dispatching_Call (N);
2612 -- The following return is worrisome. Is it really OK to
2613 -- skip all remaining processing in this procedure ???
2618 Apply_Tag_Checks (N);
2620 -- Expansion of a dispatching call results in an indirect call,
2621 -- which in turn causes current values to be killed (see
2622 -- Resolve_Call), so on VM targets we do the call here to ensure
2623 -- consistent warnings between VM and non-VM targets.
2625 Kill_Current_Values;
2629 -- Similarly, expand calls to RCI subprograms on which pragma
2630 -- All_Calls_Remote applies. The rewriting will be reanalyzed
2631 -- later. Do this only when the call comes from source since we do
2632 -- not want such a rewriting to occur in expanded code.
2634 if Is_All_Remote_Call (N) then
2635 Expand_All_Calls_Remote_Subprogram_Call (N);
2637 -- Similarly, do not add extra actuals for an entry call whose entity
2638 -- is a protected procedure, or for an internal protected subprogram
2639 -- call, because it will be rewritten as a protected subprogram call
2640 -- and reanalyzed (see Expand_Protected_Subprogram_Call).
2642 elsif Is_Protected_Type (Scope (Subp))
2643 and then (Ekind (Subp) = E_Procedure
2644 or else Ekind (Subp) = E_Function)
2648 -- During that loop we gathered the extra actuals (the ones that
2649 -- correspond to Extra_Formals), so now they can be appended.
2652 while Is_Non_Empty_List (Extra_Actuals) loop
2653 Add_Actual_Parameter (Remove_Head (Extra_Actuals));
2657 -- At this point we have all the actuals, so this is the point at
2658 -- which the various expansion activities for actuals is carried out.
2660 Expand_Actuals (N, Subp);
2662 -- If the subprogram is a renaming, or if it is inherited, replace it
2663 -- in the call with the name of the actual subprogram being called.
2664 -- If this is a dispatching call, the run-time decides what to call.
2665 -- The Alias attribute does not apply to entries.
2667 if Nkind (N) /= N_Entry_Call_Statement
2668 and then No (Controlling_Argument (N))
2669 and then Present (Parent_Subp)
2671 if Present (Inherited_From_Formal (Subp)) then
2672 Parent_Subp := Inherited_From_Formal (Subp);
2674 while Present (Alias (Parent_Subp)) loop
2675 Parent_Subp := Alias (Parent_Subp);
2679 -- The below setting of Entity is suspect, see F109-018 discussion???
2681 Set_Entity (Name (N), Parent_Subp);
2683 if Is_Abstract_Subprogram (Parent_Subp)
2684 and then not In_Instance
2687 ("cannot call abstract subprogram &!", Name (N), Parent_Subp);
2690 -- Inspect all formals of derived subprogram Subp. Compare parameter
2691 -- types with the parent subprogram and check whether an actual may
2692 -- need a type conversion to the corresponding formal of the parent
2695 -- Not clear whether intrinsic subprograms need such conversions. ???
2697 if not Is_Intrinsic_Subprogram (Parent_Subp)
2698 or else Is_Generic_Instance (Parent_Subp)
2701 procedure Convert (Act : Node_Id; Typ : Entity_Id);
2702 -- Rewrite node Act as a type conversion of Act to Typ. Analyze
2703 -- and resolve the newly generated construct.
2709 procedure Convert (Act : Node_Id; Typ : Entity_Id) is
2711 Rewrite (Act, OK_Convert_To (Typ, Relocate_Node (Act)));
2718 Actual_Typ : Entity_Id;
2719 Formal_Typ : Entity_Id;
2720 Parent_Typ : Entity_Id;
2723 Actual := First_Actual (N);
2724 Formal := First_Formal (Subp);
2725 Parent_Formal := First_Formal (Parent_Subp);
2726 while Present (Formal) loop
2727 Actual_Typ := Etype (Actual);
2728 Formal_Typ := Etype (Formal);
2729 Parent_Typ := Etype (Parent_Formal);
2731 -- For an IN parameter of a scalar type, the parent formal
2732 -- type and derived formal type differ or the parent formal
2733 -- type and actual type do not match statically.
2735 if Is_Scalar_Type (Formal_Typ)
2736 and then Ekind (Formal) = E_In_Parameter
2737 and then Formal_Typ /= Parent_Typ
2739 not Subtypes_Statically_Match (Parent_Typ, Actual_Typ)
2740 and then not Raises_Constraint_Error (Actual)
2742 Convert (Actual, Parent_Typ);
2743 Enable_Range_Check (Actual);
2745 -- If the actual has been marked as requiring a range
2746 -- check, then generate it here.
2748 if Do_Range_Check (Actual) then
2749 Set_Do_Range_Check (Actual, False);
2750 Generate_Range_Check
2751 (Actual, Etype (Formal), CE_Range_Check_Failed);
2754 -- For access types, the parent formal type and actual type
2757 elsif Is_Access_Type (Formal_Typ)
2758 and then Base_Type (Parent_Typ) /= Base_Type (Actual_Typ)
2760 if Ekind (Formal) /= E_In_Parameter then
2761 Convert (Actual, Parent_Typ);
2763 elsif Ekind (Parent_Typ) = E_Anonymous_Access_Type
2764 and then Designated_Type (Parent_Typ) /=
2765 Designated_Type (Actual_Typ)
2766 and then not Is_Controlling_Formal (Formal)
2768 -- This unchecked conversion is not necessary unless
2769 -- inlining is enabled, because in that case the type
2770 -- mismatch may become visible in the body about to be
2774 Unchecked_Convert_To (Parent_Typ,
2775 Relocate_Node (Actual)));
2778 Resolve (Actual, Parent_Typ);
2781 -- For array and record types, the parent formal type and
2782 -- derived formal type have different sizes or pragma Pack
2785 elsif ((Is_Array_Type (Formal_Typ)
2786 and then Is_Array_Type (Parent_Typ))
2788 (Is_Record_Type (Formal_Typ)
2789 and then Is_Record_Type (Parent_Typ)))
2791 (Esize (Formal_Typ) /= Esize (Parent_Typ)
2792 or else Has_Pragma_Pack (Formal_Typ) /=
2793 Has_Pragma_Pack (Parent_Typ))
2795 Convert (Actual, Parent_Typ);
2798 Next_Actual (Actual);
2799 Next_Formal (Formal);
2800 Next_Formal (Parent_Formal);
2806 Subp := Parent_Subp;
2809 -- Check for violation of No_Abort_Statements
2811 if Is_RTE (Subp, RE_Abort_Task) then
2812 Check_Restriction (No_Abort_Statements, N);
2814 -- Check for violation of No_Dynamic_Attachment
2816 elsif RTU_Loaded (Ada_Interrupts)
2817 and then (Is_RTE (Subp, RE_Is_Reserved) or else
2818 Is_RTE (Subp, RE_Is_Attached) or else
2819 Is_RTE (Subp, RE_Current_Handler) or else
2820 Is_RTE (Subp, RE_Attach_Handler) or else
2821 Is_RTE (Subp, RE_Exchange_Handler) or else
2822 Is_RTE (Subp, RE_Detach_Handler) or else
2823 Is_RTE (Subp, RE_Reference))
2825 Check_Restriction (No_Dynamic_Attachment, N);
2828 -- Deal with case where call is an explicit dereference
2830 if Nkind (Name (N)) = N_Explicit_Dereference then
2832 -- Handle case of access to protected subprogram type
2834 if Is_Access_Protected_Subprogram_Type
2835 (Base_Type (Etype (Prefix (Name (N)))))
2837 -- If this is a call through an access to protected operation,
2838 -- the prefix has the form (object'address, operation'access).
2839 -- Rewrite as a for other protected calls: the object is the
2840 -- first parameter of the list of actuals.
2847 Ptr : constant Node_Id := Prefix (Name (N));
2849 T : constant Entity_Id :=
2850 Equivalent_Type (Base_Type (Etype (Ptr)));
2852 D_T : constant Entity_Id :=
2853 Designated_Type (Base_Type (Etype (Ptr)));
2857 Make_Selected_Component (Loc,
2858 Prefix => Unchecked_Convert_To (T, Ptr),
2860 New_Occurrence_Of (First_Entity (T), Loc));
2863 Make_Selected_Component (Loc,
2864 Prefix => Unchecked_Convert_To (T, Ptr),
2866 New_Occurrence_Of (Next_Entity (First_Entity (T)), Loc));
2869 Make_Explicit_Dereference (Loc,
2872 if Present (Parameter_Associations (N)) then
2873 Parm := Parameter_Associations (N);
2878 Prepend (Obj, Parm);
2880 if Etype (D_T) = Standard_Void_Type then
2882 Make_Procedure_Call_Statement (Loc,
2884 Parameter_Associations => Parm);
2887 Make_Function_Call (Loc,
2889 Parameter_Associations => Parm);
2892 Set_First_Named_Actual (Call, First_Named_Actual (N));
2893 Set_Etype (Call, Etype (D_T));
2895 -- We do not re-analyze the call to avoid infinite recursion.
2896 -- We analyze separately the prefix and the object, and set
2897 -- the checks on the prefix that would otherwise be emitted
2898 -- when resolving a call.
2902 Apply_Access_Check (Nam);
2909 -- If this is a call to an intrinsic subprogram, then perform the
2910 -- appropriate expansion to the corresponding tree node and we
2911 -- are all done (since after that the call is gone!)
2913 -- In the case where the intrinsic is to be processed by the back end,
2914 -- the call to Expand_Intrinsic_Call will do nothing, which is fine,
2915 -- since the idea in this case is to pass the call unchanged.
2916 -- If the intrinsic is an inherited unchecked conversion, and the
2917 -- derived type is the target type of the conversion, we must retain
2918 -- it as the return type of the expression. Otherwise the expansion
2919 -- below, which uses the parent operation, will yield the wrong type.
2921 if Is_Intrinsic_Subprogram (Subp) then
2922 Expand_Intrinsic_Call (N, Subp);
2924 if Nkind (N) = N_Unchecked_Type_Conversion
2925 and then Parent_Subp /= Orig_Subp
2926 and then Etype (Parent_Subp) /= Etype (Orig_Subp)
2928 Set_Etype (N, Etype (Orig_Subp));
2934 if Ekind (Subp) = E_Function
2935 or else Ekind (Subp) = E_Procedure
2937 -- We perform two simple optimization on calls:
2939 -- a) replace calls to null procedures unconditionally;
2941 -- b) for To_Address, just do an unchecked conversion. Not only is
2942 -- this efficient, but it also avoids order of elaboration problems
2943 -- when address clauses are inlined (address expression elaborated
2944 -- at the wrong point).
2946 -- We perform these optimization regardless of whether we are in the
2947 -- main unit or in a unit in the context of the main unit, to ensure
2948 -- that tree generated is the same in both cases, for Inspector use.
2950 if Is_RTE (Subp, RE_To_Address) then
2952 Unchecked_Convert_To
2953 (RTE (RE_Address), Relocate_Node (First_Actual (N))));
2956 elsif Is_Null_Procedure (Subp) then
2957 Rewrite (N, Make_Null_Statement (Loc));
2961 if Is_Inlined (Subp) then
2963 Inlined_Subprogram : declare
2965 Must_Inline : Boolean := False;
2966 Spec : constant Node_Id := Unit_Declaration_Node (Subp);
2967 Scop : constant Entity_Id := Scope (Subp);
2969 function In_Unfrozen_Instance return Boolean;
2970 -- If the subprogram comes from an instance in the same unit,
2971 -- and the instance is not yet frozen, inlining might trigger
2972 -- order-of-elaboration problems in gigi.
2974 --------------------------
2975 -- In_Unfrozen_Instance --
2976 --------------------------
2978 function In_Unfrozen_Instance return Boolean is
2984 and then S /= Standard_Standard
2986 if Is_Generic_Instance (S)
2987 and then Present (Freeze_Node (S))
2988 and then not Analyzed (Freeze_Node (S))
2997 end In_Unfrozen_Instance;
2999 -- Start of processing for Inlined_Subprogram
3002 -- Verify that the body to inline has already been seen, and
3003 -- that if the body is in the current unit the inlining does
3004 -- not occur earlier. This avoids order-of-elaboration problems
3007 -- This should be documented in sinfo/einfo ???
3010 or else Nkind (Spec) /= N_Subprogram_Declaration
3011 or else No (Body_To_Inline (Spec))
3013 Must_Inline := False;
3015 -- If this an inherited function that returns a private type,
3016 -- do not inline if the full view is an unconstrained array,
3017 -- because such calls cannot be inlined.
3019 elsif Present (Orig_Subp)
3020 and then Is_Array_Type (Etype (Orig_Subp))
3021 and then not Is_Constrained (Etype (Orig_Subp))
3023 Must_Inline := False;
3025 elsif In_Unfrozen_Instance then
3026 Must_Inline := False;
3029 Bod := Body_To_Inline (Spec);
3031 if (In_Extended_Main_Code_Unit (N)
3032 or else In_Extended_Main_Code_Unit (Parent (N))
3033 or else Has_Pragma_Inline_Always (Subp))
3034 and then (not In_Same_Extended_Unit (Sloc (Bod), Loc)
3036 Earlier_In_Extended_Unit (Sloc (Bod), Loc))
3038 Must_Inline := True;
3040 -- If we are compiling a package body that is not the main
3041 -- unit, it must be for inlining/instantiation purposes,
3042 -- in which case we inline the call to insure that the same
3043 -- temporaries are generated when compiling the body by
3044 -- itself. Otherwise link errors can occur.
3046 -- If the function being called is itself in the main unit,
3047 -- we cannot inline, because there is a risk of double
3048 -- elaboration and/or circularity: the inlining can make
3049 -- visible a private entity in the body of the main unit,
3050 -- that gigi will see before its sees its proper definition.
3052 elsif not (In_Extended_Main_Code_Unit (N))
3053 and then In_Package_Body
3055 Must_Inline := not In_Extended_Main_Source_Unit (Subp);
3060 Expand_Inlined_Call (N, Subp, Orig_Subp);
3063 -- Let the back end handle it
3065 Add_Inlined_Body (Subp);
3067 if Front_End_Inlining
3068 and then Nkind (Spec) = N_Subprogram_Declaration
3069 and then (In_Extended_Main_Code_Unit (N))
3070 and then No (Body_To_Inline (Spec))
3071 and then not Has_Completion (Subp)
3072 and then In_Same_Extended_Unit (Sloc (Spec), Loc)
3075 ("cannot inline& (body not seen yet)?", N, Subp);
3078 end Inlined_Subprogram;
3082 -- Check for protected subprogram. This is either an intra-object call,
3083 -- or a protected function call. Protected procedure calls are rewritten
3084 -- as entry calls and handled accordingly.
3086 -- In Ada 2005, this may be an indirect call to an access parameter that
3087 -- is an access_to_subprogram. In that case the anonymous type has a
3088 -- scope that is a protected operation, but the call is a regular one.
3090 Scop := Scope (Subp);
3092 if Nkind (N) /= N_Entry_Call_Statement
3093 and then Is_Protected_Type (Scop)
3094 and then Ekind (Subp) /= E_Subprogram_Type
3096 -- If the call is an internal one, it is rewritten as a call to the
3097 -- corresponding unprotected subprogram.
3099 Expand_Protected_Subprogram_Call (N, Subp, Scop);
3102 -- Functions returning controlled objects need special attention:
3103 -- if the return type is limited, the context is an initialization
3104 -- and different processing applies. If the call is to a protected
3105 -- function, the expansion above will call Expand_Call recusively.
3106 -- To prevent a double attachment, check that the current call is
3107 -- not a rewriting of a protected function call.
3109 if Needs_Finalization (Etype (Subp))
3110 and then not Is_Inherently_Limited_Type (Etype (Subp))
3112 (No (First_Formal (Subp))
3114 not Is_Concurrent_Record_Type (Etype (First_Formal (Subp))))
3116 Expand_Ctrl_Function_Call (N);
3119 -- Test for First_Optional_Parameter, and if so, truncate parameter list
3120 -- if there are optional parameters at the trailing end.
3121 -- Note: we never delete procedures for call via a pointer.
3123 if (Ekind (Subp) = E_Procedure or else Ekind (Subp) = E_Function)
3124 and then Present (First_Optional_Parameter (Subp))
3127 Last_Keep_Arg : Node_Id;
3130 -- Last_Keep_Arg will hold the last actual that should be kept.
3131 -- If it remains empty at the end, it means that all parameters
3134 Last_Keep_Arg := Empty;
3136 -- Find first optional parameter, must be present since we checked
3137 -- the validity of the parameter before setting it.
3139 Formal := First_Formal (Subp);
3140 Actual := First_Actual (N);
3141 while Formal /= First_Optional_Parameter (Subp) loop
3142 Last_Keep_Arg := Actual;
3143 Next_Formal (Formal);
3144 Next_Actual (Actual);
3147 -- We have Formal and Actual pointing to the first potentially
3148 -- droppable argument. We can drop all the trailing arguments
3149 -- whose actual matches the default. Note that we know that all
3150 -- remaining formals have defaults, because we checked that this
3151 -- requirement was met before setting First_Optional_Parameter.
3153 -- We use Fully_Conformant_Expressions to check for identity
3154 -- between formals and actuals, which may miss some cases, but
3155 -- on the other hand, this is only an optimization (if we fail
3156 -- to truncate a parameter it does not affect functionality).
3157 -- So if the default is 3 and the actual is 1+2, we consider
3158 -- them unequal, which hardly seems worrisome.
3160 while Present (Formal) loop
3161 if not Fully_Conformant_Expressions
3162 (Actual, Default_Value (Formal))
3164 Last_Keep_Arg := Actual;
3167 Next_Formal (Formal);
3168 Next_Actual (Actual);
3171 -- If no arguments, delete entire list, this is the easy case
3173 if No (Last_Keep_Arg) then
3174 Set_Parameter_Associations (N, No_List);
3175 Set_First_Named_Actual (N, Empty);
3177 -- Case where at the last retained argument is positional. This
3178 -- is also an easy case, since the retained arguments are already
3179 -- in the right form, and we don't need to worry about the order
3180 -- of arguments that get eliminated.
3182 elsif Is_List_Member (Last_Keep_Arg) then
3183 while Present (Next (Last_Keep_Arg)) loop
3184 Discard_Node (Remove_Next (Last_Keep_Arg));
3187 Set_First_Named_Actual (N, Empty);
3189 -- This is the annoying case where the last retained argument
3190 -- is a named parameter. Since the original arguments are not
3191 -- in declaration order, we may have to delete some fairly
3192 -- random collection of arguments.
3200 -- First step, remove all the named parameters from the
3201 -- list (they are still chained using First_Named_Actual
3202 -- and Next_Named_Actual, so we have not lost them!)
3204 Temp := First (Parameter_Associations (N));
3206 -- Case of all parameters named, remove them all
3208 if Nkind (Temp) = N_Parameter_Association then
3209 while Is_Non_Empty_List (Parameter_Associations (N)) loop
3210 Temp := Remove_Head (Parameter_Associations (N));
3213 -- Case of mixed positional/named, remove named parameters
3216 while Nkind (Next (Temp)) /= N_Parameter_Association loop
3220 while Present (Next (Temp)) loop
3221 Remove (Next (Temp));
3225 -- Now we loop through the named parameters, till we get
3226 -- to the last one to be retained, adding them to the list.
3227 -- Note that the Next_Named_Actual list does not need to be
3228 -- touched since we are only reordering them on the actual
3229 -- parameter association list.
3231 Passoc := Parent (First_Named_Actual (N));
3233 Temp := Relocate_Node (Passoc);
3235 (Parameter_Associations (N), Temp);
3237 Last_Keep_Arg = Explicit_Actual_Parameter (Passoc);
3238 Passoc := Parent (Next_Named_Actual (Passoc));
3241 Set_Next_Named_Actual (Temp, Empty);
3244 Temp := Next_Named_Actual (Passoc);
3245 exit when No (Temp);
3246 Set_Next_Named_Actual
3247 (Passoc, Next_Named_Actual (Parent (Temp)));
3256 --------------------------
3257 -- Expand_Inlined_Call --
3258 --------------------------
3260 procedure Expand_Inlined_Call
3263 Orig_Subp : Entity_Id)
3265 Loc : constant Source_Ptr := Sloc (N);
3266 Is_Predef : constant Boolean :=
3267 Is_Predefined_File_Name
3268 (Unit_File_Name (Get_Source_Unit (Subp)));
3269 Orig_Bod : constant Node_Id :=
3270 Body_To_Inline (Unit_Declaration_Node (Subp));
3275 Decls : constant List_Id := New_List;
3276 Exit_Lab : Entity_Id := Empty;
3283 Ret_Type : Entity_Id;
3287 Temp_Typ : Entity_Id;
3289 Is_Unc : constant Boolean :=
3290 Is_Array_Type (Etype (Subp))
3291 and then not Is_Constrained (Etype (Subp));
3292 -- If the type returned by the function is unconstrained and the call
3293 -- can be inlined, special processing is required.
3295 procedure Make_Exit_Label;
3296 -- Build declaration for exit label to be used in Return statements,
3297 -- sets Exit_Lab (the label node) and Lab_Decl (corresponding implcit
3300 function Process_Formals (N : Node_Id) return Traverse_Result;
3301 -- Replace occurrence of a formal with the corresponding actual, or the
3302 -- thunk generated for it.
3304 function Process_Sloc (Nod : Node_Id) return Traverse_Result;
3305 -- If the call being expanded is that of an internal subprogram, set the
3306 -- sloc of the generated block to that of the call itself, so that the
3307 -- expansion is skipped by the "next" command in gdb.
3308 -- Same processing for a subprogram in a predefined file, e.g.
3309 -- Ada.Tags. If Debug_Generated_Code is true, suppress this change to
3310 -- simplify our own development.
3312 procedure Rewrite_Function_Call (N : Node_Id; Blk : Node_Id);
3313 -- If the function body is a single expression, replace call with
3314 -- expression, else insert block appropriately.
3316 procedure Rewrite_Procedure_Call (N : Node_Id; Blk : Node_Id);
3317 -- If procedure body has no local variables, inline body without
3318 -- creating block, otherwise rewrite call with block.
3320 function Formal_Is_Used_Once (Formal : Entity_Id) return Boolean;
3321 -- Determine whether a formal parameter is used only once in Orig_Bod
3323 ---------------------
3324 -- Make_Exit_Label --
3325 ---------------------
3327 procedure Make_Exit_Label is
3329 -- Create exit label for subprogram if one does not exist yet
3331 if No (Exit_Lab) then
3333 Make_Identifier (Loc,
3334 Chars => New_Internal_Name ('L'));
3336 Make_Defining_Identifier (Loc, Chars (Lab_Id)));
3337 Exit_Lab := Make_Label (Loc, Lab_Id);
3340 Make_Implicit_Label_Declaration (Loc,
3341 Defining_Identifier => Entity (Lab_Id),
3342 Label_Construct => Exit_Lab);
3344 end Make_Exit_Label;
3346 ---------------------
3347 -- Process_Formals --
3348 ---------------------
3350 function Process_Formals (N : Node_Id) return Traverse_Result is
3356 if Is_Entity_Name (N)
3357 and then Present (Entity (N))
3362 and then Scope (E) = Subp
3364 A := Renamed_Object (E);
3366 -- Rewrite the occurrence of the formal into an occurrence of
3367 -- the actual. Also establish visibility on the proper view of
3368 -- the actual's subtype for the body's context (if the actual's
3369 -- subtype is private at the call point but its full view is
3370 -- visible to the body, then the inlined tree here must be
3371 -- analyzed with the full view).
3373 if Is_Entity_Name (A) then
3374 Rewrite (N, New_Occurrence_Of (Entity (A), Loc));
3375 Check_Private_View (N);
3377 elsif Nkind (A) = N_Defining_Identifier then
3378 Rewrite (N, New_Occurrence_Of (A, Loc));
3379 Check_Private_View (N);
3384 Rewrite (N, New_Copy (A));
3390 elsif Nkind (N) = N_Simple_Return_Statement then
3391 if No (Expression (N)) then
3394 Make_Goto_Statement (Loc,
3395 Name => New_Copy (Lab_Id)));
3398 if Nkind (Parent (N)) = N_Handled_Sequence_Of_Statements
3399 and then Nkind (Parent (Parent (N))) = N_Subprogram_Body
3401 -- Function body is a single expression. No need for
3407 Num_Ret := Num_Ret + 1;
3411 -- Because of the presence of private types, the views of the
3412 -- expression and the context may be different, so place an
3413 -- unchecked conversion to the context type to avoid spurious
3414 -- errors, e.g. when the expression is a numeric literal and
3415 -- the context is private. If the expression is an aggregate,
3416 -- use a qualified expression, because an aggregate is not a
3417 -- legal argument of a conversion.
3419 if Nkind_In (Expression (N), N_Aggregate, N_Null) then
3421 Make_Qualified_Expression (Sloc (N),
3422 Subtype_Mark => New_Occurrence_Of (Ret_Type, Sloc (N)),
3423 Expression => Relocate_Node (Expression (N)));
3426 Unchecked_Convert_To
3427 (Ret_Type, Relocate_Node (Expression (N)));
3430 if Nkind (Targ) = N_Defining_Identifier then
3432 Make_Assignment_Statement (Loc,
3433 Name => New_Occurrence_Of (Targ, Loc),
3434 Expression => Ret));
3437 Make_Assignment_Statement (Loc,
3438 Name => New_Copy (Targ),
3439 Expression => Ret));
3442 Set_Assignment_OK (Name (N));
3444 if Present (Exit_Lab) then
3446 Make_Goto_Statement (Loc,
3447 Name => New_Copy (Lab_Id)));
3453 -- Remove pragma Unreferenced since it may refer to formals that
3454 -- are not visible in the inlined body, and in any case we will
3455 -- not be posting warnings on the inlined body so it is unneeded.
3457 elsif Nkind (N) = N_Pragma
3458 and then Pragma_Name (N) = Name_Unreferenced
3460 Rewrite (N, Make_Null_Statement (Sloc (N)));
3466 end Process_Formals;
3468 procedure Replace_Formals is new Traverse_Proc (Process_Formals);
3474 function Process_Sloc (Nod : Node_Id) return Traverse_Result is
3476 if not Debug_Generated_Code then
3477 Set_Sloc (Nod, Sloc (N));
3478 Set_Comes_From_Source (Nod, False);
3484 procedure Reset_Slocs is new Traverse_Proc (Process_Sloc);
3486 ---------------------------
3487 -- Rewrite_Function_Call --
3488 ---------------------------
3490 procedure Rewrite_Function_Call (N : Node_Id; Blk : Node_Id) is
3491 HSS : constant Node_Id := Handled_Statement_Sequence (Blk);
3492 Fst : constant Node_Id := First (Statements (HSS));
3495 -- Optimize simple case: function body is a single return statement,
3496 -- which has been expanded into an assignment.
3498 if Is_Empty_List (Declarations (Blk))
3499 and then Nkind (Fst) = N_Assignment_Statement
3500 and then No (Next (Fst))
3503 -- The function call may have been rewritten as the temporary
3504 -- that holds the result of the call, in which case remove the
3505 -- now useless declaration.
3507 if Nkind (N) = N_Identifier
3508 and then Nkind (Parent (Entity (N))) = N_Object_Declaration
3510 Rewrite (Parent (Entity (N)), Make_Null_Statement (Loc));
3513 Rewrite (N, Expression (Fst));
3515 elsif Nkind (N) = N_Identifier
3516 and then Nkind (Parent (Entity (N))) = N_Object_Declaration
3518 -- The block assigns the result of the call to the temporary
3520 Insert_After (Parent (Entity (N)), Blk);
3522 elsif Nkind (Parent (N)) = N_Assignment_Statement
3524 (Is_Entity_Name (Name (Parent (N)))
3526 (Nkind (Name (Parent (N))) = N_Explicit_Dereference
3527 and then Is_Entity_Name (Prefix (Name (Parent (N))))))
3529 -- Replace assignment with the block
3532 Original_Assignment : constant Node_Id := Parent (N);
3535 -- Preserve the original assignment node to keep the complete
3536 -- assignment subtree consistent enough for Analyze_Assignment
3537 -- to proceed (specifically, the original Lhs node must still
3538 -- have an assignment statement as its parent).
3540 -- We cannot rely on Original_Node to go back from the block
3541 -- node to the assignment node, because the assignment might
3542 -- already be a rewrite substitution.
3544 Discard_Node (Relocate_Node (Original_Assignment));
3545 Rewrite (Original_Assignment, Blk);
3548 elsif Nkind (Parent (N)) = N_Object_Declaration then
3549 Set_Expression (Parent (N), Empty);
3550 Insert_After (Parent (N), Blk);
3553 Insert_Before (Parent (N), Blk);
3555 end Rewrite_Function_Call;
3557 ----------------------------
3558 -- Rewrite_Procedure_Call --
3559 ----------------------------
3561 procedure Rewrite_Procedure_Call (N : Node_Id; Blk : Node_Id) is
3562 HSS : constant Node_Id := Handled_Statement_Sequence (Blk);
3564 -- If there is a transient scope for N, this will be the scope of the
3565 -- actions for N, and the statements in Blk need to be within this
3566 -- scope. For example, they need to have visibility on the constant
3567 -- declarations created for the formals.
3569 -- If N needs no transient scope, and if there are no declarations in
3570 -- the inlined body, we can do a little optimization and insert the
3571 -- statements for the body directly after N, and rewrite N to a
3572 -- null statement, instead of rewriting N into a full-blown block
3575 if not Scope_Is_Transient
3576 and then Is_Empty_List (Declarations (Blk))
3578 Insert_List_After (N, Statements (HSS));
3579 Rewrite (N, Make_Null_Statement (Loc));
3583 end Rewrite_Procedure_Call;
3585 -------------------------
3586 -- Formal_Is_Used_Once --
3587 -------------------------
3589 function Formal_Is_Used_Once (Formal : Entity_Id) return Boolean is
3590 Use_Counter : Int := 0;
3592 function Count_Uses (N : Node_Id) return Traverse_Result;
3593 -- Traverse the tree and count the uses of the formal parameter.
3594 -- In this case, for optimization purposes, we do not need to
3595 -- continue the traversal once more than one use is encountered.
3601 function Count_Uses (N : Node_Id) return Traverse_Result is
3603 -- The original node is an identifier
3605 if Nkind (N) = N_Identifier
3606 and then Present (Entity (N))
3608 -- Original node's entity points to the one in the copied body
3610 and then Nkind (Entity (N)) = N_Identifier
3611 and then Present (Entity (Entity (N)))
3613 -- The entity of the copied node is the formal parameter
3615 and then Entity (Entity (N)) = Formal
3617 Use_Counter := Use_Counter + 1;
3619 if Use_Counter > 1 then
3621 -- Denote more than one use and abandon the traversal
3632 procedure Count_Formal_Uses is new Traverse_Proc (Count_Uses);
3634 -- Start of processing for Formal_Is_Used_Once
3637 Count_Formal_Uses (Orig_Bod);
3638 return Use_Counter = 1;
3639 end Formal_Is_Used_Once;
3641 -- Start of processing for Expand_Inlined_Call
3645 -- Check for an illegal attempt to inline a recursive procedure. If the
3646 -- subprogram has parameters this is detected when trying to supply a
3647 -- binding for parameters that already have one. For parameterless
3648 -- subprograms this must be done explicitly.
3650 if In_Open_Scopes (Subp) then
3651 Error_Msg_N ("call to recursive subprogram cannot be inlined?", N);
3652 Set_Is_Inlined (Subp, False);
3656 if Nkind (Orig_Bod) = N_Defining_Identifier
3657 or else Nkind (Orig_Bod) = N_Defining_Operator_Symbol
3659 -- Subprogram is a renaming_as_body. Calls appearing after the
3660 -- renaming can be replaced with calls to the renamed entity
3661 -- directly, because the subprograms are subtype conformant. If
3662 -- the renamed subprogram is an inherited operation, we must redo
3663 -- the expansion because implicit conversions may be needed.
3665 Set_Name (N, New_Occurrence_Of (Orig_Bod, Loc));
3667 if Present (Alias (Orig_Bod)) then
3674 -- Use generic machinery to copy body of inlined subprogram, as if it
3675 -- were an instantiation, resetting source locations appropriately, so
3676 -- that nested inlined calls appear in the main unit.
3678 Save_Env (Subp, Empty);
3679 Set_Copied_Sloc_For_Inlined_Body (N, Defining_Entity (Orig_Bod));
3681 Bod := Copy_Generic_Node (Orig_Bod, Empty, Instantiating => True);
3683 Make_Block_Statement (Loc,
3684 Declarations => Declarations (Bod),
3685 Handled_Statement_Sequence => Handled_Statement_Sequence (Bod));
3687 if No (Declarations (Bod)) then
3688 Set_Declarations (Blk, New_List);
3691 -- For the unconstrained case, capture the name of the local
3692 -- variable that holds the result. This must be the first declaration
3693 -- in the block, because its bounds cannot depend on local variables.
3694 -- Otherwise there is no way to declare the result outside of the
3695 -- block. Needless to say, in general the bounds will depend on the
3696 -- actuals in the call.
3699 Targ1 := Defining_Identifier (First (Declarations (Blk)));
3702 -- If this is a derived function, establish the proper return type
3704 if Present (Orig_Subp)
3705 and then Orig_Subp /= Subp
3707 Ret_Type := Etype (Orig_Subp);
3709 Ret_Type := Etype (Subp);
3712 -- Create temporaries for the actuals that are expressions, or that
3713 -- are scalars and require copying to preserve semantics.
3715 F := First_Formal (Subp);
3716 A := First_Actual (N);
3717 while Present (F) loop
3718 if Present (Renamed_Object (F)) then
3719 Error_Msg_N ("cannot inline call to recursive subprogram", N);
3723 -- If the argument may be a controlling argument in a call within
3724 -- the inlined body, we must preserve its classwide nature to insure
3725 -- that dynamic dispatching take place subsequently. If the formal
3726 -- has a constraint it must be preserved to retain the semantics of
3729 if Is_Class_Wide_Type (Etype (F))
3730 or else (Is_Access_Type (Etype (F))
3732 Is_Class_Wide_Type (Designated_Type (Etype (F))))
3734 Temp_Typ := Etype (F);
3736 elsif Base_Type (Etype (F)) = Base_Type (Etype (A))
3737 and then Etype (F) /= Base_Type (Etype (F))
3739 Temp_Typ := Etype (F);
3742 Temp_Typ := Etype (A);
3745 -- If the actual is a simple name or a literal, no need to
3746 -- create a temporary, object can be used directly.
3748 -- If the actual is a literal and the formal has its address taken,
3749 -- we cannot pass the literal itself as an argument, so its value
3750 -- must be captured in a temporary.
3752 if (Is_Entity_Name (A)
3754 (not Is_Scalar_Type (Etype (A))
3755 or else Ekind (Entity (A)) = E_Enumeration_Literal))
3757 -- When the actual is an identifier and the corresponding formal
3758 -- is used only once in the original body, the formal can be
3759 -- substituted directly with the actual parameter.
3761 or else (Nkind (A) = N_Identifier
3762 and then Formal_Is_Used_Once (F))
3765 (Nkind_In (A, N_Real_Literal,
3767 N_Character_Literal)
3768 and then not Address_Taken (F))
3770 if Etype (F) /= Etype (A) then
3772 (F, Unchecked_Convert_To (Etype (F), Relocate_Node (A)));
3774 Set_Renamed_Object (F, A);
3779 Make_Defining_Identifier (Loc,
3780 Chars => New_Internal_Name ('C'));
3782 -- If the actual for an in/in-out parameter is a view conversion,
3783 -- make it into an unchecked conversion, given that an untagged
3784 -- type conversion is not a proper object for a renaming.
3786 -- In-out conversions that involve real conversions have already
3787 -- been transformed in Expand_Actuals.
3789 if Nkind (A) = N_Type_Conversion
3790 and then Ekind (F) /= E_In_Parameter
3793 Make_Unchecked_Type_Conversion (Loc,
3794 Subtype_Mark => New_Occurrence_Of (Etype (F), Loc),
3795 Expression => Relocate_Node (Expression (A)));
3797 elsif Etype (F) /= Etype (A) then
3798 New_A := Unchecked_Convert_To (Etype (F), Relocate_Node (A));
3799 Temp_Typ := Etype (F);
3802 New_A := Relocate_Node (A);
3805 Set_Sloc (New_A, Sloc (N));
3807 -- If the actual has a by-reference type, it cannot be copied, so
3808 -- its value is captured in a renaming declaration. Otherwise
3809 -- declare a local constant initialized with the actual.
3811 -- We also use a renaming declaration for expressions of an array
3812 -- type that is not bit-packed, both for efficiency reasons and to
3813 -- respect the semantics of the call: in most cases the original
3814 -- call will pass the parameter by reference, and thus the inlined
3815 -- code will have the same semantics.
3817 if Ekind (F) = E_In_Parameter
3818 and then not Is_Limited_Type (Etype (A))
3819 and then not Is_Tagged_Type (Etype (A))
3821 (not Is_Array_Type (Etype (A))
3822 or else not Is_Object_Reference (A)
3823 or else Is_Bit_Packed_Array (Etype (A)))
3826 Make_Object_Declaration (Loc,
3827 Defining_Identifier => Temp,
3828 Constant_Present => True,
3829 Object_Definition => New_Occurrence_Of (Temp_Typ, Loc),
3830 Expression => New_A);
3833 Make_Object_Renaming_Declaration (Loc,
3834 Defining_Identifier => Temp,
3835 Subtype_Mark => New_Occurrence_Of (Temp_Typ, Loc),
3839 Append (Decl, Decls);
3840 Set_Renamed_Object (F, Temp);
3847 -- Establish target of function call. If context is not assignment or
3848 -- declaration, create a temporary as a target. The declaration for
3849 -- the temporary may be subsequently optimized away if the body is a
3850 -- single expression, or if the left-hand side of the assignment is
3851 -- simple enough, i.e. an entity or an explicit dereference of one.
3853 if Ekind (Subp) = E_Function then
3854 if Nkind (Parent (N)) = N_Assignment_Statement
3855 and then Is_Entity_Name (Name (Parent (N)))
3857 Targ := Name (Parent (N));
3859 elsif Nkind (Parent (N)) = N_Assignment_Statement
3860 and then Nkind (Name (Parent (N))) = N_Explicit_Dereference
3861 and then Is_Entity_Name (Prefix (Name (Parent (N))))
3863 Targ := Name (Parent (N));
3866 -- Replace call with temporary and create its declaration
3869 Make_Defining_Identifier (Loc, New_Internal_Name ('C'));
3870 Set_Is_Internal (Temp);
3872 -- For the unconstrained case, the generated temporary has the
3873 -- same constrained declaration as the result variable. It may
3874 -- eventually be possible to remove that temporary and use the
3875 -- result variable directly.
3879 Make_Object_Declaration (Loc,
3880 Defining_Identifier => Temp,
3881 Object_Definition =>
3882 New_Copy_Tree (Object_Definition (Parent (Targ1))));
3884 Replace_Formals (Decl);
3888 Make_Object_Declaration (Loc,
3889 Defining_Identifier => Temp,
3890 Object_Definition =>
3891 New_Occurrence_Of (Ret_Type, Loc));
3893 Set_Etype (Temp, Ret_Type);
3896 Set_No_Initialization (Decl);
3897 Append (Decl, Decls);
3898 Rewrite (N, New_Occurrence_Of (Temp, Loc));
3903 Insert_Actions (N, Decls);
3905 -- Traverse the tree and replace formals with actuals or their thunks.
3906 -- Attach block to tree before analysis and rewriting.
3908 Replace_Formals (Blk);
3909 Set_Parent (Blk, N);
3911 if not Comes_From_Source (Subp)
3917 if Present (Exit_Lab) then
3919 -- If the body was a single expression, the single return statement
3920 -- and the corresponding label are useless.
3924 Nkind (Last (Statements (Handled_Statement_Sequence (Blk)))) =
3927 Remove (Last (Statements (Handled_Statement_Sequence (Blk))));
3929 Append (Lab_Decl, (Declarations (Blk)));
3930 Append (Exit_Lab, Statements (Handled_Statement_Sequence (Blk)));
3934 -- Analyze Blk with In_Inlined_Body set, to avoid spurious errors on
3935 -- conflicting private views that Gigi would ignore. If this is a
3936 -- predefined unit, analyze with checks off, as is done in the non-
3937 -- inlined run-time units.
3940 I_Flag : constant Boolean := In_Inlined_Body;
3943 In_Inlined_Body := True;
3947 Style : constant Boolean := Style_Check;
3949 Style_Check := False;
3950 Analyze (Blk, Suppress => All_Checks);
3951 Style_Check := Style;
3958 In_Inlined_Body := I_Flag;
3961 if Ekind (Subp) = E_Procedure then
3962 Rewrite_Procedure_Call (N, Blk);
3964 Rewrite_Function_Call (N, Blk);
3966 -- For the unconstrained case, the replacement of the call has been
3967 -- made prior to the complete analysis of the generated declarations.
3968 -- Propagate the proper type now.
3971 if Nkind (N) = N_Identifier then
3972 Set_Etype (N, Etype (Entity (N)));
3974 Set_Etype (N, Etype (Targ1));
3981 -- Cleanup mapping between formals and actuals for other expansions
3983 F := First_Formal (Subp);
3984 while Present (F) loop
3985 Set_Renamed_Object (F, Empty);
3988 end Expand_Inlined_Call;
3990 ----------------------------
3991 -- Expand_N_Function_Call --
3992 ----------------------------
3994 procedure Expand_N_Function_Call (N : Node_Id) is
3998 -- If the return value of a foreign compiled function is VAX Float, then
3999 -- expand the return (adjusts the location of the return value on
4000 -- Alpha/VMS, no-op everywhere else).
4001 -- Comes_From_Source intercepts recursive expansion.
4003 if Vax_Float (Etype (N))
4004 and then Nkind (N) = N_Function_Call
4005 and then Present (Name (N))
4006 and then Present (Entity (Name (N)))
4007 and then Has_Foreign_Convention (Entity (Name (N)))
4008 and then Comes_From_Source (Parent (N))
4010 Expand_Vax_Foreign_Return (N);
4012 end Expand_N_Function_Call;
4014 ---------------------------------------
4015 -- Expand_N_Procedure_Call_Statement --
4016 ---------------------------------------
4018 procedure Expand_N_Procedure_Call_Statement (N : Node_Id) is
4021 end Expand_N_Procedure_Call_Statement;
4023 ------------------------------
4024 -- Expand_N_Subprogram_Body --
4025 ------------------------------
4027 -- Add poll call if ATC polling is enabled, unless the body will be inlined
4030 -- Add dummy push/pop label nodes at start and end to clear any local
4031 -- exception indications if local-exception-to-goto optimization is active.
4033 -- Add return statement if last statement in body is not a return statement
4034 -- (this makes things easier on Gigi which does not want to have to handle
4035 -- a missing return).
4037 -- Add call to Activate_Tasks if body is a task activator
4039 -- Deal with possible detection of infinite recursion
4041 -- Eliminate body completely if convention stubbed
4043 -- Encode entity names within body, since we will not need to reference
4044 -- these entities any longer in the front end.
4046 -- Initialize scalar out parameters if Initialize/Normalize_Scalars
4048 -- Reset Pure indication if any parameter has root type System.Address
4052 procedure Expand_N_Subprogram_Body (N : Node_Id) is
4053 Loc : constant Source_Ptr := Sloc (N);
4054 H : constant Node_Id := Handled_Statement_Sequence (N);
4055 Body_Id : Entity_Id;
4058 Spec_Id : Entity_Id;
4060 procedure Add_Return (S : List_Id);
4061 -- Append a return statement to the statement sequence S if the last
4062 -- statement is not already a return or a goto statement. Note that
4063 -- the latter test is not critical, it does not matter if we add a few
4064 -- extra returns, since they get eliminated anyway later on.
4070 procedure Add_Return (S : List_Id) is
4075 -- Get last statement, ignoring any Pop_xxx_Label nodes, which are
4076 -- not relevant in this context since they are not executable.
4078 Last_Stm := Last (S);
4079 while Nkind (Last_Stm) in N_Pop_xxx_Label loop
4083 -- Now insert return unless last statement is a transfer
4085 if not Is_Transfer (Last_Stm) then
4087 -- The source location for the return is the end label of the
4088 -- procedure if present. Otherwise use the sloc of the last
4089 -- statement in the list. If the list comes from a generated
4090 -- exception handler and we are not debugging generated code,
4091 -- all the statements within the handler are made invisible
4094 if Nkind (Parent (S)) = N_Exception_Handler
4095 and then not Comes_From_Source (Parent (S))
4097 Loc := Sloc (Last_Stm);
4099 elsif Present (End_Label (H)) then
4100 Loc := Sloc (End_Label (H));
4103 Loc := Sloc (Last_Stm);
4107 Rtn : constant Node_Id := Make_Simple_Return_Statement (Loc);
4110 -- Append return statement, and set analyzed manually. We can't
4111 -- call Analyze on this return since the scope is wrong.
4113 -- Note: it almost works to push the scope and then do the
4114 -- Analyze call, but something goes wrong in some weird cases
4115 -- and it is not worth worrying about ???
4120 -- Call _Postconditions procedure if appropriate. We need to
4121 -- do this explicitly because we did not analyze the generated
4122 -- return statement above, so the call did not get inserted.
4124 if Ekind (Spec_Id) = E_Procedure
4125 and then Has_Postconditions (Spec_Id)
4127 pragma Assert (Present (Postcondition_Proc (Spec_Id)));
4129 Make_Procedure_Call_Statement (Loc,
4131 New_Reference_To (Postcondition_Proc (Spec_Id), Loc)));
4137 -- Start of processing for Expand_N_Subprogram_Body
4140 -- Set L to either the list of declarations if present, or to the list
4141 -- of statements if no declarations are present. This is used to insert
4142 -- new stuff at the start.
4144 if Is_Non_Empty_List (Declarations (N)) then
4145 L := Declarations (N);
4147 L := Statements (H);
4150 -- If local-exception-to-goto optimization active, insert dummy push
4151 -- statements at start, and dummy pop statements at end.
4153 if (Debug_Flag_Dot_G
4154 or else Restriction_Active (No_Exception_Propagation))
4155 and then Is_Non_Empty_List (L)
4158 FS : constant Node_Id := First (L);
4159 FL : constant Source_Ptr := Sloc (FS);
4164 -- LS points to either last statement, if statements are present
4165 -- or to the last declaration if there are no statements present.
4166 -- It is the node after which the pop's are generated.
4168 if Is_Non_Empty_List (Statements (H)) then
4169 LS := Last (Statements (H));
4176 Insert_List_Before_And_Analyze (FS, New_List (
4177 Make_Push_Constraint_Error_Label (FL),
4178 Make_Push_Program_Error_Label (FL),
4179 Make_Push_Storage_Error_Label (FL)));
4181 Insert_List_After_And_Analyze (LS, New_List (
4182 Make_Pop_Constraint_Error_Label (LL),
4183 Make_Pop_Program_Error_Label (LL),
4184 Make_Pop_Storage_Error_Label (LL)));
4188 -- Find entity for subprogram
4190 Body_Id := Defining_Entity (N);
4192 if Present (Corresponding_Spec (N)) then
4193 Spec_Id := Corresponding_Spec (N);
4198 -- Need poll on entry to subprogram if polling enabled. We only do this
4199 -- for non-empty subprograms, since it does not seem necessary to poll
4200 -- for a dummy null subprogram.
4202 if Is_Non_Empty_List (L) then
4204 -- Do not add a polling call if the subprogram is to be inlined by
4205 -- the back-end, to avoid repeated calls with multiple inlinings.
4207 if Is_Inlined (Spec_Id)
4208 and then Front_End_Inlining
4209 and then Optimization_Level > 1
4213 Generate_Poll_Call (First (L));
4217 -- If this is a Pure function which has any parameters whose root type
4218 -- is System.Address, reset the Pure indication, since it will likely
4219 -- cause incorrect code to be generated as the parameter is probably
4220 -- a pointer, and the fact that the same pointer is passed does not mean
4221 -- that the same value is being referenced.
4223 -- Note that if the programmer gave an explicit Pure_Function pragma,
4224 -- then we believe the programmer, and leave the subprogram Pure.
4226 -- This code should probably be at the freeze point, so that it happens
4227 -- even on a -gnatc (or more importantly -gnatt) compile, so that the
4228 -- semantic tree has Is_Pure set properly ???
4230 if Is_Pure (Spec_Id)
4231 and then Is_Subprogram (Spec_Id)
4232 and then not Has_Pragma_Pure_Function (Spec_Id)
4238 F := First_Formal (Spec_Id);
4239 while Present (F) loop
4240 if Is_Descendent_Of_Address (Etype (F)) then
4241 Set_Is_Pure (Spec_Id, False);
4243 if Spec_Id /= Body_Id then
4244 Set_Is_Pure (Body_Id, False);
4255 -- Initialize any scalar OUT args if Initialize/Normalize_Scalars
4257 if Init_Or_Norm_Scalars and then Is_Subprogram (Spec_Id) then
4262 -- Loop through formals
4264 F := First_Formal (Spec_Id);
4265 while Present (F) loop
4266 if Is_Scalar_Type (Etype (F))
4267 and then Ekind (F) = E_Out_Parameter
4269 Check_Restriction (No_Default_Initialization, F);
4271 -- Insert the initialization. We turn off validity checks
4272 -- for this assignment, since we do not want any check on
4273 -- the initial value itself (which may well be invalid).
4275 Insert_Before_And_Analyze (First (L),
4276 Make_Assignment_Statement (Loc,
4277 Name => New_Occurrence_Of (F, Loc),
4278 Expression => Get_Simple_Init_Val (Etype (F), N)),
4279 Suppress => Validity_Check);
4287 -- Clear out statement list for stubbed procedure
4289 if Present (Corresponding_Spec (N)) then
4290 Set_Elaboration_Flag (N, Spec_Id);
4292 if Convention (Spec_Id) = Convention_Stubbed
4293 or else Is_Eliminated (Spec_Id)
4295 Set_Declarations (N, Empty_List);
4296 Set_Handled_Statement_Sequence (N,
4297 Make_Handled_Sequence_Of_Statements (Loc,
4298 Statements => New_List (
4299 Make_Null_Statement (Loc))));
4304 -- Create a set of discriminals for the next protected subprogram body
4306 if Is_List_Member (N)
4307 and then Present (Parent (List_Containing (N)))
4308 and then Nkind (Parent (List_Containing (N))) = N_Protected_Body
4309 and then Present (Next_Protected_Operation (N))
4311 Set_Discriminals (Parent (Base_Type (Scope (Spec_Id))));
4314 -- Returns_By_Ref flag is normally set when the subprogram is frozen but
4315 -- subprograms with no specs are not frozen.
4318 Typ : constant Entity_Id := Etype (Spec_Id);
4319 Utyp : constant Entity_Id := Underlying_Type (Typ);
4322 if not Acts_As_Spec (N)
4323 and then Nkind (Parent (Parent (Spec_Id))) /=
4324 N_Subprogram_Body_Stub
4328 elsif Is_Inherently_Limited_Type (Typ) then
4329 Set_Returns_By_Ref (Spec_Id);
4331 elsif Present (Utyp) and then CW_Or_Has_Controlled_Part (Utyp) then
4332 Set_Returns_By_Ref (Spec_Id);
4336 -- For a procedure, we add a return for all possible syntactic ends of
4339 if Ekind (Spec_Id) = E_Procedure
4340 or else Ekind (Spec_Id) = E_Generic_Procedure
4342 Add_Return (Statements (H));
4344 if Present (Exception_Handlers (H)) then
4345 Except_H := First_Non_Pragma (Exception_Handlers (H));
4346 while Present (Except_H) loop
4347 Add_Return (Statements (Except_H));
4348 Next_Non_Pragma (Except_H);
4352 -- For a function, we must deal with the case where there is at least
4353 -- one missing return. What we do is to wrap the entire body of the
4354 -- function in a block:
4367 -- raise Program_Error;
4370 -- This approach is necessary because the raise must be signalled to the
4371 -- caller, not handled by any local handler (RM 6.4(11)).
4373 -- Note: we do not need to analyze the constructed sequence here, since
4374 -- it has no handler, and an attempt to analyze the handled statement
4375 -- sequence twice is risky in various ways (e.g. the issue of expanding
4376 -- cleanup actions twice).
4378 elsif Has_Missing_Return (Spec_Id) then
4380 Hloc : constant Source_Ptr := Sloc (H);
4381 Blok : constant Node_Id :=
4382 Make_Block_Statement (Hloc,
4383 Handled_Statement_Sequence => H);
4384 Rais : constant Node_Id :=
4385 Make_Raise_Program_Error (Hloc,
4386 Reason => PE_Missing_Return);
4389 Set_Handled_Statement_Sequence (N,
4390 Make_Handled_Sequence_Of_Statements (Hloc,
4391 Statements => New_List (Blok, Rais)));
4393 Push_Scope (Spec_Id);
4400 -- If subprogram contains a parameterless recursive call, then we may
4401 -- have an infinite recursion, so see if we can generate code to check
4402 -- for this possibility if storage checks are not suppressed.
4404 if Ekind (Spec_Id) = E_Procedure
4405 and then Has_Recursive_Call (Spec_Id)
4406 and then not Storage_Checks_Suppressed (Spec_Id)
4408 Detect_Infinite_Recursion (N, Spec_Id);
4411 -- Set to encode entity names in package body before gigi is called
4413 Qualify_Entity_Names (N);
4414 end Expand_N_Subprogram_Body;
4416 -----------------------------------
4417 -- Expand_N_Subprogram_Body_Stub --
4418 -----------------------------------
4420 procedure Expand_N_Subprogram_Body_Stub (N : Node_Id) is
4422 if Present (Corresponding_Body (N)) then
4423 Expand_N_Subprogram_Body (
4424 Unit_Declaration_Node (Corresponding_Body (N)));
4426 end Expand_N_Subprogram_Body_Stub;
4428 -------------------------------------
4429 -- Expand_N_Subprogram_Declaration --
4430 -------------------------------------
4432 -- If the declaration appears within a protected body, it is a private
4433 -- operation of the protected type. We must create the corresponding
4434 -- protected subprogram an associated formals. For a normal protected
4435 -- operation, this is done when expanding the protected type declaration.
4437 -- If the declaration is for a null procedure, emit null body
4439 procedure Expand_N_Subprogram_Declaration (N : Node_Id) is
4440 Loc : constant Source_Ptr := Sloc (N);
4441 Subp : constant Entity_Id := Defining_Entity (N);
4442 Scop : constant Entity_Id := Scope (Subp);
4443 Prot_Decl : Node_Id;
4445 Prot_Id : Entity_Id;
4448 -- Deal with case of protected subprogram. Do not generate protected
4449 -- operation if operation is flagged as eliminated.
4451 if Is_List_Member (N)
4452 and then Present (Parent (List_Containing (N)))
4453 and then Nkind (Parent (List_Containing (N))) = N_Protected_Body
4454 and then Is_Protected_Type (Scop)
4456 if No (Protected_Body_Subprogram (Subp))
4457 and then not Is_Eliminated (Subp)
4460 Make_Subprogram_Declaration (Loc,
4462 Build_Protected_Sub_Specification
4463 (N, Scop, Unprotected_Mode));
4465 -- The protected subprogram is declared outside of the protected
4466 -- body. Given that the body has frozen all entities so far, we
4467 -- analyze the subprogram and perform freezing actions explicitly.
4468 -- including the generation of an explicit freeze node, to ensure
4469 -- that gigi has the proper order of elaboration.
4470 -- If the body is a subunit, the insertion point is before the
4471 -- stub in the parent.
4473 Prot_Bod := Parent (List_Containing (N));
4475 if Nkind (Parent (Prot_Bod)) = N_Subunit then
4476 Prot_Bod := Corresponding_Stub (Parent (Prot_Bod));
4479 Insert_Before (Prot_Bod, Prot_Decl);
4480 Prot_Id := Defining_Unit_Name (Specification (Prot_Decl));
4481 Set_Has_Delayed_Freeze (Prot_Id);
4483 Push_Scope (Scope (Scop));
4484 Analyze (Prot_Decl);
4485 Insert_Actions (N, Freeze_Entity (Prot_Id, Loc));
4486 Set_Protected_Body_Subprogram (Subp, Prot_Id);
4490 -- Ada 2005 (AI-348): Generate body for a null procedure.
4491 -- In most cases this is superfluous because calls to it
4492 -- will be automatically inlined, but we definitely need
4493 -- the body if preconditions for the procedure are present.
4495 elsif Nkind (Specification (N)) = N_Procedure_Specification
4496 and then Null_Present (Specification (N))
4499 Bod : constant Node_Id := Body_To_Inline (N);
4502 Set_Has_Completion (Subp, False);
4503 Append_Freeze_Action (Subp, Bod);
4505 -- The body now contains raise statements, so calls to it will
4508 Set_Is_Inlined (Subp, False);
4511 end Expand_N_Subprogram_Declaration;
4513 ---------------------------------------
4514 -- Expand_Protected_Object_Reference --
4515 ---------------------------------------
4517 function Expand_Protected_Object_Reference
4519 Scop : Entity_Id) return Node_Id
4521 Loc : constant Source_Ptr := Sloc (N);
4529 Make_Identifier (Loc,
4530 Chars => Name_uObject);
4531 Set_Etype (Rec, Corresponding_Record_Type (Scop));
4533 -- Find enclosing protected operation, and retrieve its first parameter,
4534 -- which denotes the enclosing protected object. If the enclosing
4535 -- operation is an entry, we are immediately within the protected body,
4536 -- and we can retrieve the object from the service entries procedure. A
4537 -- barrier function has the same signature as an entry. A barrier
4538 -- function is compiled within the protected object, but unlike
4539 -- protected operations its never needs locks, so that its protected
4540 -- body subprogram points to itself.
4542 Proc := Current_Scope;
4543 while Present (Proc)
4544 and then Scope (Proc) /= Scop
4546 Proc := Scope (Proc);
4549 Corr := Protected_Body_Subprogram (Proc);
4553 -- Previous error left expansion incomplete.
4554 -- Nothing to do on this call.
4561 (First (Parameter_Specifications (Parent (Corr))));
4563 if Is_Subprogram (Proc)
4564 and then Proc /= Corr
4566 -- Protected function or procedure
4568 Set_Entity (Rec, Param);
4570 -- Rec is a reference to an entity which will not be in scope when
4571 -- the call is reanalyzed, and needs no further analysis.
4576 -- Entry or barrier function for entry body. The first parameter of
4577 -- the entry body procedure is pointer to the object. We create a
4578 -- local variable of the proper type, duplicating what is done to
4579 -- define _object later on.
4583 Obj_Ptr : constant Entity_Id := Make_Defining_Identifier (Loc,
4585 New_Internal_Name ('T'));
4589 Make_Full_Type_Declaration (Loc,
4590 Defining_Identifier => Obj_Ptr,
4592 Make_Access_To_Object_Definition (Loc,
4593 Subtype_Indication =>
4595 (Corresponding_Record_Type (Scop), Loc))));
4597 Insert_Actions (N, Decls);
4598 Insert_Actions (N, Freeze_Entity (Obj_Ptr, Sloc (N)));
4601 Make_Explicit_Dereference (Loc,
4602 Unchecked_Convert_To (Obj_Ptr,
4603 New_Occurrence_Of (Param, Loc)));
4605 -- Analyze new actual. Other actuals in calls are already analyzed
4606 -- and the list of actuals is not reanalyzed after rewriting.
4608 Set_Parent (Rec, N);
4614 end Expand_Protected_Object_Reference;
4616 --------------------------------------
4617 -- Expand_Protected_Subprogram_Call --
4618 --------------------------------------
4620 procedure Expand_Protected_Subprogram_Call
4628 -- If the protected object is not an enclosing scope, this is
4629 -- an inter-object function call. Inter-object procedure
4630 -- calls are expanded by Exp_Ch9.Build_Simple_Entry_Call.
4631 -- The call is intra-object only if the subprogram being
4632 -- called is in the protected body being compiled, and if the
4633 -- protected object in the call is statically the enclosing type.
4634 -- The object may be an component of some other data structure,
4635 -- in which case this must be handled as an inter-object call.
4637 if not In_Open_Scopes (Scop)
4638 or else not Is_Entity_Name (Name (N))
4640 if Nkind (Name (N)) = N_Selected_Component then
4641 Rec := Prefix (Name (N));
4644 pragma Assert (Nkind (Name (N)) = N_Indexed_Component);
4645 Rec := Prefix (Prefix (Name (N)));
4648 Build_Protected_Subprogram_Call (N,
4649 Name => New_Occurrence_Of (Subp, Sloc (N)),
4650 Rec => Convert_Concurrent (Rec, Etype (Rec)),
4654 Rec := Expand_Protected_Object_Reference (N, Scop);
4660 Build_Protected_Subprogram_Call (N,
4667 -- If it is a function call it can appear in elaboration code and
4668 -- the called entity must be frozen here.
4670 if Ekind (Subp) = E_Function then
4671 Freeze_Expression (Name (N));
4674 -- Analyze and resolve the new call. The actuals have already been
4675 -- resolved, but expansion of a function call will add extra actuals
4676 -- if needed. Analysis of a procedure call already includes resolution.
4680 if Ekind (Subp) = E_Function then
4681 Resolve (N, Etype (Subp));
4683 end Expand_Protected_Subprogram_Call;
4685 --------------------------------
4686 -- Is_Build_In_Place_Function --
4687 --------------------------------
4689 function Is_Build_In_Place_Function (E : Entity_Id) return Boolean is
4691 -- For now we test whether E denotes a function or access-to-function
4692 -- type whose result subtype is inherently limited. Later this test may
4693 -- be revised to allow composite nonlimited types. Functions with a
4694 -- foreign convention or whose result type has a foreign convention
4697 if Ekind (E) = E_Function
4698 or else Ekind (E) = E_Generic_Function
4699 or else (Ekind (E) = E_Subprogram_Type
4700 and then Etype (E) /= Standard_Void_Type)
4702 -- Note: If you have Convention (C) on an inherently limited type,
4703 -- you're on your own. That is, the C code will have to be carefully
4704 -- written to know about the Ada conventions.
4706 if Has_Foreign_Convention (E)
4707 or else Has_Foreign_Convention (Etype (E))
4711 -- In Ada 2005 all functions with an inherently limited return type
4712 -- must be handled using a build-in-place profile, including the case
4713 -- of a function with a limited interface result, where the function
4714 -- may return objects of nonlimited descendants.
4717 return Is_Inherently_Limited_Type (Etype (E))
4718 and then Ada_Version >= Ada_05
4719 and then not Debug_Flag_Dot_L;
4725 end Is_Build_In_Place_Function;
4727 -------------------------------------
4728 -- Is_Build_In_Place_Function_Call --
4729 -------------------------------------
4731 function Is_Build_In_Place_Function_Call (N : Node_Id) return Boolean is
4732 Exp_Node : Node_Id := N;
4733 Function_Id : Entity_Id;
4736 -- Step past qualification or unchecked conversion (the latter can occur
4737 -- in cases of calls to 'Input).
4740 (Exp_Node, N_Qualified_Expression, N_Unchecked_Type_Conversion)
4742 Exp_Node := Expression (N);
4745 if Nkind (Exp_Node) /= N_Function_Call then
4749 if Is_Entity_Name (Name (Exp_Node)) then
4750 Function_Id := Entity (Name (Exp_Node));
4752 elsif Nkind (Name (Exp_Node)) = N_Explicit_Dereference then
4753 Function_Id := Etype (Name (Exp_Node));
4756 return Is_Build_In_Place_Function (Function_Id);
4758 end Is_Build_In_Place_Function_Call;
4760 -----------------------
4761 -- Freeze_Subprogram --
4762 -----------------------
4764 procedure Freeze_Subprogram (N : Node_Id) is
4765 Loc : constant Source_Ptr := Sloc (N);
4767 procedure Register_Predefined_DT_Entry (Prim : Entity_Id);
4768 -- (Ada 2005): Register a predefined primitive in all the secondary
4769 -- dispatch tables of its primitive type.
4771 ----------------------------------
4772 -- Register_Predefined_DT_Entry --
4773 ----------------------------------
4775 procedure Register_Predefined_DT_Entry (Prim : Entity_Id) is
4776 Iface_DT_Ptr : Elmt_Id;
4777 Tagged_Typ : Entity_Id;
4778 Thunk_Id : Entity_Id;
4779 Thunk_Code : Node_Id;
4782 Tagged_Typ := Find_Dispatching_Type (Prim);
4784 if No (Access_Disp_Table (Tagged_Typ))
4785 or else not Has_Interfaces (Tagged_Typ)
4786 or else not RTE_Available (RE_Interface_Tag)
4787 or else Restriction_Active (No_Dispatching_Calls)
4792 -- Skip the first two access-to-dispatch-table pointers since they
4793 -- leads to the primary dispatch table (predefined DT and user
4794 -- defined DT). We are only concerned with the secondary dispatch
4795 -- table pointers. Note that the access-to- dispatch-table pointer
4796 -- corresponds to the first implemented interface retrieved below.
4799 Next_Elmt (Next_Elmt (First_Elmt (Access_Disp_Table (Tagged_Typ))));
4801 while Present (Iface_DT_Ptr)
4802 and then Ekind (Node (Iface_DT_Ptr)) = E_Constant
4804 pragma Assert (Has_Thunks (Node (Iface_DT_Ptr)));
4805 Expand_Interface_Thunk (Prim, Thunk_Id, Thunk_Code);
4807 if Present (Thunk_Code) then
4808 Insert_Actions_After (N, New_List (
4811 Build_Set_Predefined_Prim_Op_Address (Loc,
4813 New_Reference_To (Node (Next_Elmt (Iface_DT_Ptr)), Loc),
4814 Position => DT_Position (Prim),
4816 Unchecked_Convert_To (RTE (RE_Prim_Ptr),
4817 Make_Attribute_Reference (Loc,
4818 Prefix => New_Reference_To (Thunk_Id, Loc),
4819 Attribute_Name => Name_Unrestricted_Access))),
4821 Build_Set_Predefined_Prim_Op_Address (Loc,
4824 (Node (Next_Elmt (Next_Elmt (Next_Elmt (Iface_DT_Ptr)))),
4826 Position => DT_Position (Prim),
4828 Unchecked_Convert_To (RTE (RE_Prim_Ptr),
4829 Make_Attribute_Reference (Loc,
4830 Prefix => New_Reference_To (Prim, Loc),
4831 Attribute_Name => Name_Unrestricted_Access)))));
4834 -- Skip the tag of the predefined primitives dispatch table
4836 Next_Elmt (Iface_DT_Ptr);
4837 pragma Assert (Has_Thunks (Node (Iface_DT_Ptr)));
4839 -- Skip the tag of the no-thunks dispatch table
4841 Next_Elmt (Iface_DT_Ptr);
4842 pragma Assert (not Has_Thunks (Node (Iface_DT_Ptr)));
4844 -- Skip the tag of the predefined primitives no-thunks dispatch
4847 Next_Elmt (Iface_DT_Ptr);
4848 pragma Assert (not Has_Thunks (Node (Iface_DT_Ptr)));
4850 Next_Elmt (Iface_DT_Ptr);
4852 end Register_Predefined_DT_Entry;
4856 Subp : constant Entity_Id := Entity (N);
4858 -- Start of processing for Freeze_Subprogram
4861 -- We suppress the initialization of the dispatch table entry when
4862 -- VM_Target because the dispatching mechanism is handled internally
4865 if Is_Dispatching_Operation (Subp)
4866 and then not Is_Abstract_Subprogram (Subp)
4867 and then Present (DTC_Entity (Subp))
4868 and then Present (Scope (DTC_Entity (Subp)))
4869 and then Tagged_Type_Expansion
4870 and then not Restriction_Active (No_Dispatching_Calls)
4871 and then RTE_Available (RE_Tag)
4874 Typ : constant Entity_Id := Scope (DTC_Entity (Subp));
4877 -- Handle private overridden primitives
4879 if not Is_CPP_Class (Typ) then
4880 Check_Overriding_Operation (Subp);
4883 -- We assume that imported CPP primitives correspond with objects
4884 -- whose constructor is in the CPP side; therefore we don't need
4885 -- to generate code to register them in the dispatch table.
4887 if Is_CPP_Class (Typ) then
4890 -- Handle CPP primitives found in derivations of CPP_Class types.
4891 -- These primitives must have been inherited from some parent, and
4892 -- there is no need to register them in the dispatch table because
4893 -- Build_Inherit_Prims takes care of the initialization of these
4896 elsif Is_Imported (Subp)
4897 and then (Convention (Subp) = Convention_CPP
4898 or else Convention (Subp) = Convention_C)
4902 -- Generate code to register the primitive in non statically
4903 -- allocated dispatch tables
4905 elsif not Static_Dispatch_Tables
4907 Is_Library_Level_Tagged_Type (Scope (DTC_Entity (Subp)))
4909 -- When a primitive is frozen, enter its name in its dispatch
4912 if not Is_Interface (Typ)
4913 or else Present (Interface_Alias (Subp))
4915 if Is_Predefined_Dispatching_Operation (Subp) then
4916 Register_Predefined_DT_Entry (Subp);
4919 Insert_Actions_After (N,
4920 Register_Primitive (Loc, Prim => Subp));
4926 -- Mark functions that return by reference. Note that it cannot be part
4927 -- of the normal semantic analysis of the spec since the underlying
4928 -- returned type may not be known yet (for private types).
4931 Typ : constant Entity_Id := Etype (Subp);
4932 Utyp : constant Entity_Id := Underlying_Type (Typ);
4934 if Is_Inherently_Limited_Type (Typ) then
4935 Set_Returns_By_Ref (Subp);
4936 elsif Present (Utyp) and then CW_Or_Has_Controlled_Part (Utyp) then
4937 Set_Returns_By_Ref (Subp);
4940 end Freeze_Subprogram;
4942 -----------------------
4943 -- Is_Null_Procedure --
4944 -----------------------
4946 function Is_Null_Procedure (Subp : Entity_Id) return Boolean is
4947 Decl : constant Node_Id := Unit_Declaration_Node (Subp);
4950 if Ekind (Subp) /= E_Procedure then
4953 -- Check if this is a declared null procedure
4955 elsif Nkind (Decl) = N_Subprogram_Declaration then
4956 if not Null_Present (Specification (Decl)) then
4959 elsif No (Body_To_Inline (Decl)) then
4962 -- Check if the body contains only a null statement, followed by
4963 -- the return statement added during expansion.
4967 Orig_Bod : constant Node_Id := Body_To_Inline (Decl);
4973 if Nkind (Orig_Bod) /= N_Subprogram_Body then
4976 -- We must skip SCIL nodes because they are currently
4977 -- implemented as special N_Null_Statement nodes.
4981 (Statements (Handled_Statement_Sequence (Orig_Bod)));
4982 Stat2 := Next_Non_SCIL_Node (Stat);
4985 Is_Empty_List (Declarations (Orig_Bod))
4986 and then Nkind (Stat) = N_Null_Statement
4990 (Nkind (Stat2) = N_Simple_Return_Statement
4991 and then No (Next (Stat2))));
4999 end Is_Null_Procedure;
5001 -------------------------------------------
5002 -- Make_Build_In_Place_Call_In_Allocator --
5003 -------------------------------------------
5005 procedure Make_Build_In_Place_Call_In_Allocator
5006 (Allocator : Node_Id;
5007 Function_Call : Node_Id)
5010 Func_Call : Node_Id := Function_Call;
5011 Function_Id : Entity_Id;
5012 Result_Subt : Entity_Id;
5013 Acc_Type : constant Entity_Id := Etype (Allocator);
5014 New_Allocator : Node_Id;
5015 Return_Obj_Access : Entity_Id;
5018 -- Step past qualification or unchecked conversion (the latter can occur
5019 -- in cases of calls to 'Input).
5021 if Nkind_In (Func_Call,
5022 N_Qualified_Expression,
5023 N_Unchecked_Type_Conversion)
5025 Func_Call := Expression (Func_Call);
5028 -- If the call has already been processed to add build-in-place actuals
5029 -- then return. This should not normally occur in an allocator context,
5030 -- but we add the protection as a defensive measure.
5032 if Is_Expanded_Build_In_Place_Call (Func_Call) then
5036 -- Mark the call as processed as a build-in-place call
5038 Set_Is_Expanded_Build_In_Place_Call (Func_Call);
5040 Loc := Sloc (Function_Call);
5042 if Is_Entity_Name (Name (Func_Call)) then
5043 Function_Id := Entity (Name (Func_Call));
5045 elsif Nkind (Name (Func_Call)) = N_Explicit_Dereference then
5046 Function_Id := Etype (Name (Func_Call));
5049 raise Program_Error;
5052 Result_Subt := Etype (Function_Id);
5054 -- When the result subtype is constrained, the return object must be
5055 -- allocated on the caller side, and access to it is passed to the
5058 -- Here and in related routines, we must examine the full view of the
5059 -- type, because the view at the point of call may differ from that
5060 -- that in the function body, and the expansion mechanism depends on
5061 -- the characteristics of the full view.
5063 if Is_Constrained (Underlying_Type (Result_Subt)) then
5065 -- Replace the initialized allocator of form "new T'(Func (...))"
5066 -- with an uninitialized allocator of form "new T", where T is the
5067 -- result subtype of the called function. The call to the function
5068 -- is handled separately further below.
5071 Make_Allocator (Loc,
5072 Expression => New_Reference_To (Result_Subt, Loc));
5073 Set_No_Initialization (New_Allocator);
5075 -- Copy attributes to new allocator. Note that the new allocator
5076 -- logically comes from source if the original one did, so copy the
5077 -- relevant flag. This ensures proper treatment of the restriction
5078 -- No_Implicit_Heap_Allocations in this case.
5080 Set_Storage_Pool (New_Allocator, Storage_Pool (Allocator));
5081 Set_Procedure_To_Call (New_Allocator, Procedure_To_Call (Allocator));
5082 Set_Comes_From_Source (New_Allocator, Comes_From_Source (Allocator));
5084 Rewrite (Allocator, New_Allocator);
5086 -- Create a new access object and initialize it to the result of the
5087 -- new uninitialized allocator.
5089 Return_Obj_Access :=
5090 Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
5091 Set_Etype (Return_Obj_Access, Acc_Type);
5093 Insert_Action (Allocator,
5094 Make_Object_Declaration (Loc,
5095 Defining_Identifier => Return_Obj_Access,
5096 Object_Definition => New_Reference_To (Acc_Type, Loc),
5097 Expression => Relocate_Node (Allocator)));
5099 -- When the function has a controlling result, an allocation-form
5100 -- parameter must be passed indicating that the caller is allocating
5101 -- the result object. This is needed because such a function can be
5102 -- called as a dispatching operation and must be treated similarly
5103 -- to functions with unconstrained result subtypes.
5105 Add_Alloc_Form_Actual_To_Build_In_Place_Call
5106 (Func_Call, Function_Id, Alloc_Form => Caller_Allocation);
5108 Add_Final_List_Actual_To_Build_In_Place_Call
5109 (Func_Call, Function_Id, Acc_Type);
5111 Add_Task_Actuals_To_Build_In_Place_Call
5112 (Func_Call, Function_Id, Master_Actual => Master_Id (Acc_Type));
5114 -- Add an implicit actual to the function call that provides access
5115 -- to the allocated object. An unchecked conversion to the (specific)
5116 -- result subtype of the function is inserted to handle cases where
5117 -- the access type of the allocator has a class-wide designated type.
5119 Add_Access_Actual_To_Build_In_Place_Call
5122 Make_Unchecked_Type_Conversion (Loc,
5123 Subtype_Mark => New_Reference_To (Result_Subt, Loc),
5125 Make_Explicit_Dereference (Loc,
5126 Prefix => New_Reference_To (Return_Obj_Access, Loc))));
5128 -- When the result subtype is unconstrained, the function itself must
5129 -- perform the allocation of the return object, so we pass parameters
5130 -- indicating that. We don't yet handle the case where the allocation
5131 -- must be done in a user-defined storage pool, which will require
5132 -- passing another actual or two to provide allocation/deallocation
5137 -- Pass an allocation parameter indicating that the function should
5138 -- allocate its result on the heap.
5140 Add_Alloc_Form_Actual_To_Build_In_Place_Call
5141 (Func_Call, Function_Id, Alloc_Form => Global_Heap);
5143 Add_Final_List_Actual_To_Build_In_Place_Call
5144 (Func_Call, Function_Id, Acc_Type);
5146 Add_Task_Actuals_To_Build_In_Place_Call
5147 (Func_Call, Function_Id, Master_Actual => Master_Id (Acc_Type));
5149 -- The caller does not provide the return object in this case, so we
5150 -- have to pass null for the object access actual.
5152 Add_Access_Actual_To_Build_In_Place_Call
5153 (Func_Call, Function_Id, Return_Object => Empty);
5156 -- Finally, replace the allocator node with a reference to the result
5157 -- of the function call itself (which will effectively be an access
5158 -- to the object created by the allocator).
5160 Rewrite (Allocator, Make_Reference (Loc, Relocate_Node (Function_Call)));
5161 Analyze_And_Resolve (Allocator, Acc_Type);
5162 end Make_Build_In_Place_Call_In_Allocator;
5164 ---------------------------------------------------
5165 -- Make_Build_In_Place_Call_In_Anonymous_Context --
5166 ---------------------------------------------------
5168 procedure Make_Build_In_Place_Call_In_Anonymous_Context
5169 (Function_Call : Node_Id)
5172 Func_Call : Node_Id := Function_Call;
5173 Function_Id : Entity_Id;
5174 Result_Subt : Entity_Id;
5175 Return_Obj_Id : Entity_Id;
5176 Return_Obj_Decl : Entity_Id;
5179 -- Step past qualification or unchecked conversion (the latter can occur
5180 -- in cases of calls to 'Input).
5182 if Nkind_In (Func_Call, N_Qualified_Expression,
5183 N_Unchecked_Type_Conversion)
5185 Func_Call := Expression (Func_Call);
5188 -- If the call has already been processed to add build-in-place actuals
5189 -- then return. One place this can occur is for calls to build-in-place
5190 -- functions that occur within a call to a protected operation, where
5191 -- due to rewriting and expansion of the protected call there can be
5192 -- more than one call to Expand_Actuals for the same set of actuals.
5194 if Is_Expanded_Build_In_Place_Call (Func_Call) then
5198 -- Mark the call as processed as a build-in-place call
5200 Set_Is_Expanded_Build_In_Place_Call (Func_Call);
5202 Loc := Sloc (Function_Call);
5204 if Is_Entity_Name (Name (Func_Call)) then
5205 Function_Id := Entity (Name (Func_Call));
5207 elsif Nkind (Name (Func_Call)) = N_Explicit_Dereference then
5208 Function_Id := Etype (Name (Func_Call));
5211 raise Program_Error;
5214 Result_Subt := Etype (Function_Id);
5216 -- When the result subtype is constrained, an object of the subtype is
5217 -- declared and an access value designating it is passed as an actual.
5219 if Is_Constrained (Underlying_Type (Result_Subt)) then
5221 -- Create a temporary object to hold the function result
5224 Make_Defining_Identifier (Loc,
5225 Chars => New_Internal_Name ('R'));
5226 Set_Etype (Return_Obj_Id, Result_Subt);
5229 Make_Object_Declaration (Loc,
5230 Defining_Identifier => Return_Obj_Id,
5231 Aliased_Present => True,
5232 Object_Definition => New_Reference_To (Result_Subt, Loc));
5234 Set_No_Initialization (Return_Obj_Decl);
5236 Insert_Action (Func_Call, Return_Obj_Decl);
5238 -- When the function has a controlling result, an allocation-form
5239 -- parameter must be passed indicating that the caller is allocating
5240 -- the result object. This is needed because such a function can be
5241 -- called as a dispatching operation and must be treated similarly
5242 -- to functions with unconstrained result subtypes.
5244 Add_Alloc_Form_Actual_To_Build_In_Place_Call
5245 (Func_Call, Function_Id, Alloc_Form => Caller_Allocation);
5247 Add_Final_List_Actual_To_Build_In_Place_Call
5248 (Func_Call, Function_Id, Acc_Type => Empty);
5250 Add_Task_Actuals_To_Build_In_Place_Call
5251 (Func_Call, Function_Id, Make_Identifier (Loc, Name_uMaster));
5253 -- Add an implicit actual to the function call that provides access
5254 -- to the caller's return object.
5256 Add_Access_Actual_To_Build_In_Place_Call
5257 (Func_Call, Function_Id, New_Reference_To (Return_Obj_Id, Loc));
5259 -- When the result subtype is unconstrained, the function must allocate
5260 -- the return object in the secondary stack, so appropriate implicit
5261 -- parameters are added to the call to indicate that. A transient
5262 -- scope is established to ensure eventual cleanup of the result.
5266 -- Pass an allocation parameter indicating that the function should
5267 -- allocate its result on the secondary stack.
5269 Add_Alloc_Form_Actual_To_Build_In_Place_Call
5270 (Func_Call, Function_Id, Alloc_Form => Secondary_Stack);
5272 Add_Final_List_Actual_To_Build_In_Place_Call
5273 (Func_Call, Function_Id, Acc_Type => Empty);
5275 Add_Task_Actuals_To_Build_In_Place_Call
5276 (Func_Call, Function_Id, Make_Identifier (Loc, Name_uMaster));
5278 -- Pass a null value to the function since no return object is
5279 -- available on the caller side.
5281 Add_Access_Actual_To_Build_In_Place_Call
5282 (Func_Call, Function_Id, Empty);
5284 Establish_Transient_Scope (Func_Call, Sec_Stack => True);
5286 end Make_Build_In_Place_Call_In_Anonymous_Context;
5288 --------------------------------------------
5289 -- Make_Build_In_Place_Call_In_Assignment --
5290 --------------------------------------------
5292 procedure Make_Build_In_Place_Call_In_Assignment
5294 Function_Call : Node_Id)
5296 Lhs : constant Node_Id := Name (Assign);
5297 Func_Call : Node_Id := Function_Call;
5298 Func_Id : Entity_Id;
5302 Ptr_Typ : Entity_Id;
5303 Ptr_Typ_Decl : Node_Id;
5304 Result_Subt : Entity_Id;
5308 -- Step past qualification or unchecked conversion (the latter can occur
5309 -- in cases of calls to 'Input).
5311 if Nkind_In (Func_Call, N_Qualified_Expression,
5312 N_Unchecked_Type_Conversion)
5314 Func_Call := Expression (Func_Call);
5317 -- If the call has already been processed to add build-in-place actuals
5318 -- then return. This should not normally occur in an assignment context,
5319 -- but we add the protection as a defensive measure.
5321 if Is_Expanded_Build_In_Place_Call (Func_Call) then
5325 -- Mark the call as processed as a build-in-place call
5327 Set_Is_Expanded_Build_In_Place_Call (Func_Call);
5329 Loc := Sloc (Function_Call);
5331 if Is_Entity_Name (Name (Func_Call)) then
5332 Func_Id := Entity (Name (Func_Call));
5334 elsif Nkind (Name (Func_Call)) = N_Explicit_Dereference then
5335 Func_Id := Etype (Name (Func_Call));
5338 raise Program_Error;
5341 Result_Subt := Etype (Func_Id);
5343 -- When the result subtype is unconstrained, an additional actual must
5344 -- be passed to indicate that the caller is providing the return object.
5345 -- This parameter must also be passed when the called function has a
5346 -- controlling result, because dispatching calls to the function needs
5347 -- to be treated effectively the same as calls to class-wide functions.
5349 Add_Alloc_Form_Actual_To_Build_In_Place_Call
5350 (Func_Call, Func_Id, Alloc_Form => Caller_Allocation);
5352 -- If Lhs is a selected component, then pass it along so that its prefix
5353 -- object will be used as the source of the finalization list.
5355 if Nkind (Lhs) = N_Selected_Component then
5356 Add_Final_List_Actual_To_Build_In_Place_Call
5357 (Func_Call, Func_Id, Acc_Type => Empty, Sel_Comp => Lhs);
5359 Add_Final_List_Actual_To_Build_In_Place_Call
5360 (Func_Call, Func_Id, Acc_Type => Empty);
5363 Add_Task_Actuals_To_Build_In_Place_Call
5364 (Func_Call, Func_Id, Make_Identifier (Loc, Name_uMaster));
5366 -- Add an implicit actual to the function call that provides access to
5367 -- the caller's return object.
5369 Add_Access_Actual_To_Build_In_Place_Call
5372 Make_Unchecked_Type_Conversion (Loc,
5373 Subtype_Mark => New_Reference_To (Result_Subt, Loc),
5374 Expression => Relocate_Node (Lhs)));
5376 -- Create an access type designating the function's result subtype
5379 Make_Defining_Identifier (Loc, New_Internal_Name ('A'));
5382 Make_Full_Type_Declaration (Loc,
5383 Defining_Identifier => Ptr_Typ,
5385 Make_Access_To_Object_Definition (Loc,
5386 All_Present => True,
5387 Subtype_Indication =>
5388 New_Reference_To (Result_Subt, Loc)));
5389 Insert_After_And_Analyze (Assign, Ptr_Typ_Decl);
5391 -- Finally, create an access object initialized to a reference to the
5394 Obj_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
5395 Set_Etype (Obj_Id, Ptr_Typ);
5398 Make_Object_Declaration (Loc,
5399 Defining_Identifier => Obj_Id,
5400 Object_Definition =>
5401 New_Reference_To (Ptr_Typ, Loc),
5403 Make_Reference (Loc,
5404 Prefix => Relocate_Node (Func_Call)));
5405 Insert_After_And_Analyze (Ptr_Typ_Decl, Obj_Decl);
5407 Rewrite (Assign, Make_Null_Statement (Loc));
5409 -- Retrieve the target of the assignment
5411 if Nkind (Lhs) = N_Selected_Component then
5412 Target := Selector_Name (Lhs);
5413 elsif Nkind (Lhs) = N_Type_Conversion then
5414 Target := Expression (Lhs);
5419 -- If we are assigning to a return object or this is an expression of
5420 -- an extension aggregate, the target should either be an identifier
5421 -- or a simple expression. All other cases imply a different scenario.
5423 if Nkind (Target) in N_Has_Entity then
5424 Target := Entity (Target);
5429 -- When the target of the assignment is a return object of an enclosing
5430 -- build-in-place function and also requires finalization, the list
5431 -- generated for the assignment must be moved to that of the enclosing
5434 -- function Enclosing_BIP_Function return Ctrl_Typ is
5436 -- return (Ctrl_Parent_Part => BIP_Function with ...);
5437 -- end Enclosing_BIP_Function;
5439 if Is_Return_Object (Target)
5440 and then Needs_Finalization (Etype (Target))
5441 and then Needs_Finalization (Result_Subt)
5444 Obj_List : constant Node_Id := Find_Final_List (Obj_Id);
5445 Encl_List : Node_Id;
5446 Encl_Scop : Entity_Id;
5449 Encl_Scop := Scope (Target);
5451 -- Locate the scope of the extended return statement
5453 while Present (Encl_Scop)
5454 and then Ekind (Encl_Scop) /= E_Return_Statement
5456 Encl_Scop := Scope (Encl_Scop);
5459 -- A return object should always be enclosed by a return statement
5460 -- scope at some level.
5462 pragma Assert (Present (Encl_Scop));
5465 Make_Attribute_Reference (Loc,
5468 Finalization_Chain_Entity (Encl_Scop), Loc),
5469 Attribute_Name => Name_Unrestricted_Access);
5471 -- Generate a call to move final list
5473 Insert_After_And_Analyze (Obj_Decl,
5474 Make_Procedure_Call_Statement (Loc,
5476 New_Reference_To (RTE (RE_Move_Final_List), Loc),
5477 Parameter_Associations => New_List (Obj_List, Encl_List)));
5480 end Make_Build_In_Place_Call_In_Assignment;
5482 ----------------------------------------------------
5483 -- Make_Build_In_Place_Call_In_Object_Declaration --
5484 ----------------------------------------------------
5486 procedure Make_Build_In_Place_Call_In_Object_Declaration
5487 (Object_Decl : Node_Id;
5488 Function_Call : Node_Id)
5491 Obj_Def_Id : constant Entity_Id :=
5492 Defining_Identifier (Object_Decl);
5494 Func_Call : Node_Id := Function_Call;
5495 Function_Id : Entity_Id;
5496 Result_Subt : Entity_Id;
5497 Caller_Object : Node_Id;
5498 Call_Deref : Node_Id;
5499 Ref_Type : Entity_Id;
5500 Ptr_Typ_Decl : Node_Id;
5503 Enclosing_Func : Entity_Id;
5504 Pass_Caller_Acc : Boolean := False;
5507 -- Step past qualification or unchecked conversion (the latter can occur
5508 -- in cases of calls to 'Input).
5510 if Nkind_In (Func_Call, N_Qualified_Expression,
5511 N_Unchecked_Type_Conversion)
5513 Func_Call := Expression (Func_Call);
5516 -- If the call has already been processed to add build-in-place actuals
5517 -- then return. This should not normally occur in an object declaration,
5518 -- but we add the protection as a defensive measure.
5520 if Is_Expanded_Build_In_Place_Call (Func_Call) then
5524 -- Mark the call as processed as a build-in-place call
5526 Set_Is_Expanded_Build_In_Place_Call (Func_Call);
5528 Loc := Sloc (Function_Call);
5530 if Is_Entity_Name (Name (Func_Call)) then
5531 Function_Id := Entity (Name (Func_Call));
5533 elsif Nkind (Name (Func_Call)) = N_Explicit_Dereference then
5534 Function_Id := Etype (Name (Func_Call));
5537 raise Program_Error;
5540 Result_Subt := Etype (Function_Id);
5542 -- In the constrained case, add an implicit actual to the function call
5543 -- that provides access to the declared object. An unchecked conversion
5544 -- to the (specific) result type of the function is inserted to handle
5545 -- the case where the object is declared with a class-wide type.
5547 if Is_Constrained (Underlying_Type (Result_Subt)) then
5549 Make_Unchecked_Type_Conversion (Loc,
5550 Subtype_Mark => New_Reference_To (Result_Subt, Loc),
5551 Expression => New_Reference_To (Obj_Def_Id, Loc));
5553 -- When the function has a controlling result, an allocation-form
5554 -- parameter must be passed indicating that the caller is allocating
5555 -- the result object. This is needed because such a function can be
5556 -- called as a dispatching operation and must be treated similarly
5557 -- to functions with unconstrained result subtypes.
5559 Add_Alloc_Form_Actual_To_Build_In_Place_Call
5560 (Func_Call, Function_Id, Alloc_Form => Caller_Allocation);
5562 -- If the function's result subtype is unconstrained and the object is
5563 -- a return object of an enclosing build-in-place function, then the
5564 -- implicit build-in-place parameters of the enclosing function must be
5565 -- passed along to the called function. (Unfortunately, this won't cover
5566 -- the case of extension aggregates where the ancestor part is a build-
5567 -- in-place unconstrained function call that should be passed along the
5568 -- caller's parameters. Currently those get mishandled by reassigning
5569 -- the result of the call to the aggregate return object, when the call
5570 -- result should really be directly built in place in the aggregate and
5571 -- not built in a temporary. ???)
5573 elsif Is_Return_Object (Defining_Identifier (Object_Decl)) then
5574 Pass_Caller_Acc := True;
5576 Enclosing_Func := Enclosing_Subprogram (Obj_Def_Id);
5578 -- If the enclosing function has a constrained result type, then
5579 -- caller allocation will be used.
5581 if Is_Constrained (Etype (Enclosing_Func)) then
5582 Add_Alloc_Form_Actual_To_Build_In_Place_Call
5583 (Func_Call, Function_Id, Alloc_Form => Caller_Allocation);
5585 -- Otherwise, when the enclosing function has an unconstrained result
5586 -- type, the BIP_Alloc_Form formal of the enclosing function must be
5587 -- passed along to the callee.
5590 Add_Alloc_Form_Actual_To_Build_In_Place_Call
5595 (Build_In_Place_Formal (Enclosing_Func, BIP_Alloc_Form),
5599 -- Retrieve the BIPacc formal from the enclosing function and convert
5600 -- it to the access type of the callee's BIP_Object_Access formal.
5603 Make_Unchecked_Type_Conversion (Loc,
5607 (Build_In_Place_Formal (Function_Id, BIP_Object_Access)),
5611 (Build_In_Place_Formal (Enclosing_Func, BIP_Object_Access),
5614 -- In other unconstrained cases, pass an indication to do the allocation
5615 -- on the secondary stack and set Caller_Object to Empty so that a null
5616 -- value will be passed for the caller's object address. A transient
5617 -- scope is established to ensure eventual cleanup of the result.
5620 Add_Alloc_Form_Actual_To_Build_In_Place_Call
5623 Alloc_Form => Secondary_Stack);
5624 Caller_Object := Empty;
5626 Establish_Transient_Scope (Object_Decl, Sec_Stack => True);
5629 Add_Final_List_Actual_To_Build_In_Place_Call
5630 (Func_Call, Function_Id, Acc_Type => Empty);
5632 if Nkind (Parent (Object_Decl)) = N_Extended_Return_Statement
5633 and then Has_Task (Result_Subt)
5635 Enclosing_Func := Enclosing_Subprogram (Obj_Def_Id);
5637 -- Here we're passing along the master that was passed in to this
5640 Add_Task_Actuals_To_Build_In_Place_Call
5641 (Func_Call, Function_Id,
5644 (Build_In_Place_Formal (Enclosing_Func, BIP_Master), Loc));
5647 Add_Task_Actuals_To_Build_In_Place_Call
5648 (Func_Call, Function_Id, Make_Identifier (Loc, Name_uMaster));
5651 Add_Access_Actual_To_Build_In_Place_Call
5652 (Func_Call, Function_Id, Caller_Object, Is_Access => Pass_Caller_Acc);
5654 -- Create an access type designating the function's result subtype
5657 Make_Defining_Identifier (Loc, New_Internal_Name ('A'));
5660 Make_Full_Type_Declaration (Loc,
5661 Defining_Identifier => Ref_Type,
5663 Make_Access_To_Object_Definition (Loc,
5664 All_Present => True,
5665 Subtype_Indication =>
5666 New_Reference_To (Result_Subt, Loc)));
5668 -- The access type and its accompanying object must be inserted after
5669 -- the object declaration in the constrained case, so that the function
5670 -- call can be passed access to the object. In the unconstrained case,
5671 -- the access type and object must be inserted before the object, since
5672 -- the object declaration is rewritten to be a renaming of a dereference
5673 -- of the access object.
5675 if Is_Constrained (Underlying_Type (Result_Subt)) then
5676 Insert_After_And_Analyze (Object_Decl, Ptr_Typ_Decl);
5678 Insert_Action (Object_Decl, Ptr_Typ_Decl);
5681 -- Finally, create an access object initialized to a reference to the
5685 Make_Defining_Identifier (Loc,
5686 Chars => New_Internal_Name ('R'));
5687 Set_Etype (Def_Id, Ref_Type);
5690 Make_Reference (Loc,
5691 Prefix => Relocate_Node (Func_Call));
5693 Insert_After_And_Analyze (Ptr_Typ_Decl,
5694 Make_Object_Declaration (Loc,
5695 Defining_Identifier => Def_Id,
5696 Object_Definition => New_Reference_To (Ref_Type, Loc),
5697 Expression => New_Expr));
5699 if Is_Constrained (Underlying_Type (Result_Subt)) then
5700 Set_Expression (Object_Decl, Empty);
5701 Set_No_Initialization (Object_Decl);
5703 -- In case of an unconstrained result subtype, rewrite the object
5704 -- declaration as an object renaming where the renamed object is a
5705 -- dereference of <function_Call>'reference:
5707 -- Obj : Subt renames <function_call>'Ref.all;
5711 Make_Explicit_Dereference (Loc,
5712 Prefix => New_Reference_To (Def_Id, Loc));
5714 Rewrite (Object_Decl,
5715 Make_Object_Renaming_Declaration (Loc,
5716 Defining_Identifier => Make_Defining_Identifier (Loc,
5717 New_Internal_Name ('D')),
5718 Access_Definition => Empty,
5719 Subtype_Mark => New_Occurrence_Of (Result_Subt, Loc),
5720 Name => Call_Deref));
5722 Set_Renamed_Object (Defining_Identifier (Object_Decl), Call_Deref);
5724 Analyze (Object_Decl);
5726 -- Replace the internal identifier of the renaming declaration's
5727 -- entity with identifier of the original object entity. We also have
5728 -- to exchange the entities containing their defining identifiers to
5729 -- ensure the correct replacement of the object declaration by the
5730 -- object renaming declaration to avoid homograph conflicts (since
5731 -- the object declaration's defining identifier was already entered
5732 -- in current scope). The Next_Entity links of the two entities also
5733 -- have to be swapped since the entities are part of the return
5734 -- scope's entity list and the list structure would otherwise be
5735 -- corrupted. Finally, the homonym chain must be preserved as well.
5738 Renaming_Def_Id : constant Entity_Id :=
5739 Defining_Identifier (Object_Decl);
5740 Next_Entity_Temp : constant Entity_Id :=
5741 Next_Entity (Renaming_Def_Id);
5743 Set_Chars (Renaming_Def_Id, Chars (Obj_Def_Id));
5745 -- Swap next entity links in preparation for exchanging entities
5747 Set_Next_Entity (Renaming_Def_Id, Next_Entity (Obj_Def_Id));
5748 Set_Next_Entity (Obj_Def_Id, Next_Entity_Temp);
5749 Set_Homonym (Renaming_Def_Id, Homonym (Obj_Def_Id));
5751 Exchange_Entities (Renaming_Def_Id, Obj_Def_Id);
5755 -- If the object entity has a class-wide Etype, then we need to change
5756 -- it to the result subtype of the function call, because otherwise the
5757 -- object will be class-wide without an explicit initialization and
5758 -- won't be allocated properly by the back end. It seems unclean to make
5759 -- such a revision to the type at this point, and we should try to
5760 -- improve this treatment when build-in-place functions with class-wide
5761 -- results are implemented. ???
5763 if Is_Class_Wide_Type (Etype (Defining_Identifier (Object_Decl))) then
5764 Set_Etype (Defining_Identifier (Object_Decl), Result_Subt);
5766 end Make_Build_In_Place_Call_In_Object_Declaration;
5768 --------------------------
5769 -- Needs_BIP_Final_List --
5770 --------------------------
5772 function Needs_BIP_Final_List (E : Entity_Id) return Boolean is
5773 pragma Assert (Is_Build_In_Place_Function (E));
5774 Result_Subt : constant Entity_Id := Underlying_Type (Etype (E));
5777 -- We need the BIP_Final_List if the result type needs finalization. We
5778 -- also need it for tagged types, even if not class-wide, because some
5779 -- type extension might need finalization, and all overriding functions
5780 -- must have the same calling conventions. However, if there is a
5781 -- pragma Restrictions (No_Finalization), we never need this parameter.
5783 return (Needs_Finalization (Result_Subt)
5784 or else Is_Tagged_Type (Underlying_Type (Result_Subt)))
5785 and then not Restriction_Active (No_Finalization);
5786 end Needs_BIP_Final_List;