1 -----------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2008, 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 Fname; use Fname;
45 with Freeze; use Freeze;
46 with Inline; use Inline;
48 with Namet; use Namet;
49 with Nlists; use Nlists;
50 with Nmake; use Nmake;
52 with Restrict; use Restrict;
53 with Rident; use Rident;
54 with Rtsfind; use Rtsfind;
56 with Sem_Ch6; use Sem_Ch6;
57 with Sem_Ch8; use Sem_Ch8;
58 with Sem_Ch12; use Sem_Ch12;
59 with Sem_Ch13; use Sem_Ch13;
60 with Sem_Eval; use Sem_Eval;
61 with Sem_Disp; use Sem_Disp;
62 with Sem_Dist; use Sem_Dist;
63 with Sem_Mech; use Sem_Mech;
64 with Sem_Res; use Sem_Res;
65 with Sem_Util; use Sem_Util;
66 with Sinfo; use Sinfo;
67 with Snames; use Snames;
68 with Stand; use Stand;
69 with Targparm; use Targparm;
70 with Tbuild; use Tbuild;
71 with Uintp; use Uintp;
72 with Validsw; use Validsw;
74 package body Exp_Ch6 is
76 -----------------------
77 -- Local Subprograms --
78 -----------------------
80 procedure Add_Access_Actual_To_Build_In_Place_Call
81 (Function_Call : Node_Id;
82 Function_Id : Entity_Id;
83 Return_Object : Node_Id;
84 Is_Access : Boolean := False);
85 -- Ada 2005 (AI-318-02): Apply the Unrestricted_Access attribute to the
86 -- object name given by Return_Object and add the attribute to the end of
87 -- the actual parameter list associated with the build-in-place function
88 -- call denoted by Function_Call. However, if Is_Access is True, then
89 -- Return_Object is already an access expression, in which case it's passed
90 -- along directly to the build-in-place function. Finally, if Return_Object
91 -- is empty, then pass a null literal as the actual.
93 procedure Add_Alloc_Form_Actual_To_Build_In_Place_Call
94 (Function_Call : Node_Id;
95 Function_Id : Entity_Id;
96 Alloc_Form : BIP_Allocation_Form := Unspecified;
97 Alloc_Form_Exp : Node_Id := Empty);
98 -- Ada 2005 (AI-318-02): Add an actual indicating the form of allocation,
99 -- if any, to be done by a build-in-place function. If Alloc_Form_Exp is
100 -- present, then use it, otherwise pass a literal corresponding to the
101 -- Alloc_Form parameter (which must not be Unspecified in that case).
103 procedure Add_Extra_Actual_To_Call
104 (Subprogram_Call : Node_Id;
105 Extra_Formal : Entity_Id;
106 Extra_Actual : Node_Id);
107 -- Adds Extra_Actual as a named parameter association for the formal
108 -- Extra_Formal in Subprogram_Call.
110 procedure Add_Final_List_Actual_To_Build_In_Place_Call
111 (Function_Call : Node_Id;
112 Function_Id : Entity_Id;
113 Acc_Type : Entity_Id;
114 Sel_Comp : Node_Id := Empty);
115 -- Ada 2005 (AI-318-02): For a build-in-place call, if the result type has
116 -- controlled parts, add an actual parameter that is a pointer to
117 -- appropriate finalization list. The finalization list is that of the
118 -- current scope, except for "new Acc'(F(...))" in which case it's the
119 -- finalization list of the access type returned by the allocator. Acc_Type
120 -- is that type in the allocator case; Empty otherwise. If Sel_Comp is
121 -- not Empty, then it denotes a selected component and the finalization
122 -- list is obtained from the _controller list of the prefix object.
124 procedure Add_Task_Actuals_To_Build_In_Place_Call
125 (Function_Call : Node_Id;
126 Function_Id : Entity_Id;
127 Master_Actual : Node_Id);
128 -- Ada 2005 (AI-318-02): For a build-in-place call, if the result type
129 -- contains tasks, add two actual parameters: the master, and a pointer to
130 -- the caller's activation chain. Master_Actual is the actual parameter
131 -- expression to pass for the master. In most cases, this is the current
132 -- master (_master). The two exceptions are: If the function call is the
133 -- initialization expression for an allocator, we pass the master of the
134 -- access type. If the function call is the initialization expression for
135 -- a return object, we pass along the master passed in by the caller. The
136 -- activation chain to pass is always the local one.
138 procedure Check_Overriding_Operation (Subp : Entity_Id);
139 -- Subp is a dispatching operation. Check whether it may override an
140 -- inherited private operation, in which case its DT entry is that of
141 -- the hidden operation, not the one it may have received earlier.
142 -- This must be done before emitting the code to set the corresponding
143 -- DT to the address of the subprogram. The actual placement of Subp in
144 -- the proper place in the list of primitive operations is done in
145 -- Declare_Inherited_Private_Subprograms, which also has to deal with
146 -- implicit operations. This duplication is unavoidable for now???
148 procedure Detect_Infinite_Recursion (N : Node_Id; Spec : Entity_Id);
149 -- This procedure is called only if the subprogram body N, whose spec
150 -- has the given entity Spec, contains a parameterless recursive call.
151 -- It attempts to generate runtime code to detect if this a case of
152 -- infinite recursion.
154 -- The body is scanned to determine dependencies. If the only external
155 -- dependencies are on a small set of scalar variables, then the values
156 -- of these variables are captured on entry to the subprogram, and if
157 -- the values are not changed for the call, we know immediately that
158 -- we have an infinite recursion.
160 procedure Expand_Actuals (N : Node_Id; Subp : Entity_Id);
161 -- For each actual of an in-out or out parameter which is a numeric
162 -- (view) conversion of the form T (A), where A denotes a variable,
163 -- we insert the declaration:
165 -- Temp : T[ := T (A)];
167 -- prior to the call. Then we replace the actual with a reference to Temp,
168 -- and append the assignment:
170 -- A := TypeA (Temp);
172 -- after the call. Here TypeA is the actual type of variable A.
173 -- For out parameters, the initial declaration has no expression.
174 -- If A is not an entity name, we generate instead:
176 -- Var : TypeA renames A;
177 -- Temp : T := Var; -- omitting expression for out parameter.
179 -- Var := TypeA (Temp);
181 -- For other in-out parameters, we emit the required constraint checks
182 -- before and/or after the call.
184 -- For all parameter modes, actuals that denote components and slices
185 -- of packed arrays are expanded into suitable temporaries.
187 -- For non-scalar objects that are possibly unaligned, add call by copy
188 -- code (copy in for IN and IN OUT, copy out for OUT and IN OUT).
190 procedure Expand_Inlined_Call
193 Orig_Subp : Entity_Id);
194 -- If called subprogram can be inlined by the front-end, retrieve the
195 -- analyzed body, replace formals with actuals and expand call in place.
196 -- Generate thunks for actuals that are expressions, and insert the
197 -- corresponding constant declarations before the call. If the original
198 -- call is to a derived operation, the return type is the one of the
199 -- derived operation, but the body is that of the original, so return
200 -- expressions in the body must be converted to the desired type (which
201 -- is simply not noted in the tree without inline expansion).
203 function Expand_Protected_Object_Reference
205 Scop : Entity_Id) return Node_Id;
207 procedure Expand_Protected_Subprogram_Call
211 -- A call to a protected subprogram within the protected object may appear
212 -- as a regular call. The list of actuals must be expanded to contain a
213 -- reference to the object itself, and the call becomes a call to the
214 -- corresponding protected subprogram.
216 ----------------------------------------------
217 -- Add_Access_Actual_To_Build_In_Place_Call --
218 ----------------------------------------------
220 procedure Add_Access_Actual_To_Build_In_Place_Call
221 (Function_Call : Node_Id;
222 Function_Id : Entity_Id;
223 Return_Object : Node_Id;
224 Is_Access : Boolean := False)
226 Loc : constant Source_Ptr := Sloc (Function_Call);
227 Obj_Address : Node_Id;
228 Obj_Acc_Formal : Entity_Id;
231 -- Locate the implicit access parameter in the called function
233 Obj_Acc_Formal := Build_In_Place_Formal (Function_Id, BIP_Object_Access);
235 -- If no return object is provided, then pass null
237 if not Present (Return_Object) then
238 Obj_Address := Make_Null (Loc);
239 Set_Parent (Obj_Address, Function_Call);
241 -- If Return_Object is already an expression of an access type, then use
242 -- it directly, since it must be an access value denoting the return
243 -- object, and couldn't possibly be the return object itself.
246 Obj_Address := Return_Object;
247 Set_Parent (Obj_Address, Function_Call);
249 -- Apply Unrestricted_Access to caller's return object
253 Make_Attribute_Reference (Loc,
254 Prefix => Return_Object,
255 Attribute_Name => Name_Unrestricted_Access);
257 Set_Parent (Return_Object, Obj_Address);
258 Set_Parent (Obj_Address, Function_Call);
261 Analyze_And_Resolve (Obj_Address, Etype (Obj_Acc_Formal));
263 -- Build the parameter association for the new actual and add it to the
264 -- end of the function's actuals.
266 Add_Extra_Actual_To_Call (Function_Call, Obj_Acc_Formal, Obj_Address);
267 end Add_Access_Actual_To_Build_In_Place_Call;
269 --------------------------------------------------
270 -- Add_Alloc_Form_Actual_To_Build_In_Place_Call --
271 --------------------------------------------------
273 procedure Add_Alloc_Form_Actual_To_Build_In_Place_Call
274 (Function_Call : Node_Id;
275 Function_Id : Entity_Id;
276 Alloc_Form : BIP_Allocation_Form := Unspecified;
277 Alloc_Form_Exp : Node_Id := Empty)
279 Loc : constant Source_Ptr := Sloc (Function_Call);
280 Alloc_Form_Actual : Node_Id;
281 Alloc_Form_Formal : Node_Id;
284 -- The allocation form generally doesn't need to be passed in the case
285 -- of a constrained result subtype, since normally the caller performs
286 -- the allocation in that case. However this formal is still needed in
287 -- the case where the function has a tagged result, because generally
288 -- such functions can be called in a dispatching context and such calls
289 -- must be handled like calls to class-wide functions.
291 if Is_Constrained (Underlying_Type (Etype (Function_Id)))
292 and then not Is_Tagged_Type (Underlying_Type (Etype (Function_Id)))
297 -- Locate the implicit allocation form parameter in the called function.
298 -- Maybe it would be better for each implicit formal of a build-in-place
299 -- function to have a flag or a Uint attribute to identify it. ???
301 Alloc_Form_Formal := Build_In_Place_Formal (Function_Id, BIP_Alloc_Form);
303 if Present (Alloc_Form_Exp) then
304 pragma Assert (Alloc_Form = Unspecified);
306 Alloc_Form_Actual := Alloc_Form_Exp;
309 pragma Assert (Alloc_Form /= Unspecified);
312 Make_Integer_Literal (Loc,
313 Intval => UI_From_Int (BIP_Allocation_Form'Pos (Alloc_Form)));
316 Analyze_And_Resolve (Alloc_Form_Actual, Etype (Alloc_Form_Formal));
318 -- Build the parameter association for the new actual and add it to the
319 -- end of the function's actuals.
321 Add_Extra_Actual_To_Call
322 (Function_Call, Alloc_Form_Formal, Alloc_Form_Actual);
323 end Add_Alloc_Form_Actual_To_Build_In_Place_Call;
325 ------------------------------
326 -- Add_Extra_Actual_To_Call --
327 ------------------------------
329 procedure Add_Extra_Actual_To_Call
330 (Subprogram_Call : Node_Id;
331 Extra_Formal : Entity_Id;
332 Extra_Actual : Node_Id)
334 Loc : constant Source_Ptr := Sloc (Subprogram_Call);
335 Param_Assoc : Node_Id;
339 Make_Parameter_Association (Loc,
340 Selector_Name => New_Occurrence_Of (Extra_Formal, Loc),
341 Explicit_Actual_Parameter => Extra_Actual);
343 Set_Parent (Param_Assoc, Subprogram_Call);
344 Set_Parent (Extra_Actual, Param_Assoc);
346 if Present (Parameter_Associations (Subprogram_Call)) then
347 if Nkind (Last (Parameter_Associations (Subprogram_Call))) =
348 N_Parameter_Association
351 -- Find last named actual, and append
356 L := First_Actual (Subprogram_Call);
357 while Present (L) loop
358 if No (Next_Actual (L)) then
359 Set_Next_Named_Actual (Parent (L), Extra_Actual);
367 Set_First_Named_Actual (Subprogram_Call, Extra_Actual);
370 Append (Param_Assoc, To => Parameter_Associations (Subprogram_Call));
373 Set_Parameter_Associations (Subprogram_Call, New_List (Param_Assoc));
374 Set_First_Named_Actual (Subprogram_Call, Extra_Actual);
376 end Add_Extra_Actual_To_Call;
378 --------------------------------------------------
379 -- Add_Final_List_Actual_To_Build_In_Place_Call --
380 --------------------------------------------------
382 procedure Add_Final_List_Actual_To_Build_In_Place_Call
383 (Function_Call : Node_Id;
384 Function_Id : Entity_Id;
385 Acc_Type : Entity_Id;
386 Sel_Comp : Node_Id := Empty)
388 Loc : constant Source_Ptr := Sloc (Function_Call);
389 Final_List : Node_Id;
390 Final_List_Actual : Node_Id;
391 Final_List_Formal : Node_Id;
392 Is_Ctrl_Result : constant Boolean :=
394 (Underlying_Type (Etype (Function_Id)));
397 -- No such extra parameter is needed if there are no controlled parts.
398 -- The test for Controlled_Type accounts for class-wide results (which
399 -- potentially have controlled parts, even if the root type doesn't),
400 -- and the test for a tagged result type is needed because calls to
401 -- such a function can in general occur in dispatching contexts, which
402 -- must be treated the same as a call to class-wide functions. Both of
403 -- these situations require that a finalization list be passed.
405 if not Is_Ctrl_Result
406 and then not Is_Tagged_Type (Underlying_Type (Etype (Function_Id)))
411 -- Locate implicit finalization list parameter in the called function
413 Final_List_Formal := Build_In_Place_Formal (Function_Id, BIP_Final_List);
415 -- Create the actual which is a pointer to the appropriate finalization
416 -- list. Acc_Type is present if and only if this call is the
417 -- initialization of an allocator. Use the Current_Scope or the Acc_Type
420 if Present (Acc_Type)
421 and then (Ekind (Acc_Type) = E_Anonymous_Access_Type
423 Present (Associated_Final_Chain (Base_Type (Acc_Type))))
425 Final_List := Find_Final_List (Acc_Type);
427 -- If Sel_Comp is present and the function result is controlled, then
428 -- the finalization list will be obtained from the _controller list of
429 -- the selected component's prefix object.
431 elsif Present (Sel_Comp) and then Is_Ctrl_Result then
432 Final_List := Find_Final_List (Current_Scope, Sel_Comp);
435 Final_List := Find_Final_List (Current_Scope);
439 Make_Attribute_Reference (Loc,
440 Prefix => Final_List,
441 Attribute_Name => Name_Unrestricted_Access);
443 Analyze_And_Resolve (Final_List_Actual, Etype (Final_List_Formal));
445 -- Build the parameter association for the new actual and add it to the
446 -- end of the function's actuals.
448 Add_Extra_Actual_To_Call
449 (Function_Call, Final_List_Formal, Final_List_Actual);
450 end Add_Final_List_Actual_To_Build_In_Place_Call;
452 ---------------------------------------------
453 -- Add_Task_Actuals_To_Build_In_Place_Call --
454 ---------------------------------------------
456 procedure Add_Task_Actuals_To_Build_In_Place_Call
457 (Function_Call : Node_Id;
458 Function_Id : Entity_Id;
459 Master_Actual : Node_Id)
460 -- Note: Master_Actual can be Empty, but only if there are no tasks
462 Loc : constant Source_Ptr := Sloc (Function_Call);
465 -- No such extra parameters are needed if there are no tasks
467 if not Has_Task (Etype (Function_Id)) then
474 Master_Formal : Node_Id;
476 -- Locate implicit master parameter in the called function
478 Master_Formal := Build_In_Place_Formal (Function_Id, BIP_Master);
480 Analyze_And_Resolve (Master_Actual, Etype (Master_Formal));
482 -- Build the parameter association for the new actual and add it to
483 -- the end of the function's actuals.
485 Add_Extra_Actual_To_Call
486 (Function_Call, Master_Formal, Master_Actual);
489 -- The activation chain
492 Activation_Chain_Actual : Node_Id;
493 Activation_Chain_Formal : Node_Id;
495 -- Locate implicit activation chain parameter in the called function
497 Activation_Chain_Formal := Build_In_Place_Formal
498 (Function_Id, BIP_Activation_Chain);
500 -- Create the actual which is a pointer to the current activation
503 Activation_Chain_Actual :=
504 Make_Attribute_Reference (Loc,
505 Prefix => Make_Identifier (Loc, Name_uChain),
506 Attribute_Name => Name_Unrestricted_Access);
509 (Activation_Chain_Actual, Etype (Activation_Chain_Formal));
511 -- Build the parameter association for the new actual and add it to
512 -- the end of the function's actuals.
514 Add_Extra_Actual_To_Call
515 (Function_Call, Activation_Chain_Formal, Activation_Chain_Actual);
517 end Add_Task_Actuals_To_Build_In_Place_Call;
519 -----------------------
520 -- BIP_Formal_Suffix --
521 -----------------------
523 function BIP_Formal_Suffix (Kind : BIP_Formal_Kind) return String is
526 when BIP_Alloc_Form =>
528 when BIP_Final_List =>
529 return "BIPfinallist";
532 when BIP_Activation_Chain =>
533 return "BIPactivationchain";
534 when BIP_Object_Access =>
537 end BIP_Formal_Suffix;
539 ---------------------------
540 -- Build_In_Place_Formal --
541 ---------------------------
543 function Build_In_Place_Formal
545 Kind : BIP_Formal_Kind) return Entity_Id
547 Extra_Formal : Entity_Id := Extra_Formals (Func);
550 -- Maybe it would be better for each implicit formal of a build-in-place
551 -- function to have a flag or a Uint attribute to identify it. ???
554 pragma Assert (Present (Extra_Formal));
556 Chars (Extra_Formal) =
557 New_External_Name (Chars (Func), BIP_Formal_Suffix (Kind));
558 Next_Formal_With_Extras (Extra_Formal);
562 end Build_In_Place_Formal;
564 --------------------------------
565 -- Check_Overriding_Operation --
566 --------------------------------
568 procedure Check_Overriding_Operation (Subp : Entity_Id) is
569 Typ : constant Entity_Id := Find_Dispatching_Type (Subp);
570 Op_List : constant Elist_Id := Primitive_Operations (Typ);
576 if Is_Derived_Type (Typ)
577 and then not Is_Private_Type (Typ)
578 and then In_Open_Scopes (Scope (Etype (Typ)))
579 and then Typ = Base_Type (Typ)
581 -- Subp overrides an inherited private operation if there is an
582 -- inherited operation with a different name than Subp (see
583 -- Derive_Subprogram) whose Alias is a hidden subprogram with the
584 -- same name as Subp.
586 Op_Elmt := First_Elmt (Op_List);
587 while Present (Op_Elmt) loop
588 Prim_Op := Node (Op_Elmt);
589 Par_Op := Alias (Prim_Op);
592 and then not Comes_From_Source (Prim_Op)
593 and then Chars (Prim_Op) /= Chars (Par_Op)
594 and then Chars (Par_Op) = Chars (Subp)
595 and then Is_Hidden (Par_Op)
596 and then Type_Conformant (Prim_Op, Subp)
598 Set_DT_Position (Subp, DT_Position (Prim_Op));
604 end Check_Overriding_Operation;
606 -------------------------------
607 -- Detect_Infinite_Recursion --
608 -------------------------------
610 procedure Detect_Infinite_Recursion (N : Node_Id; Spec : Entity_Id) is
611 Loc : constant Source_Ptr := Sloc (N);
613 Var_List : constant Elist_Id := New_Elmt_List;
614 -- List of globals referenced by body of procedure
616 Call_List : constant Elist_Id := New_Elmt_List;
617 -- List of recursive calls in body of procedure
619 Shad_List : constant Elist_Id := New_Elmt_List;
620 -- List of entity id's for entities created to capture the value of
621 -- referenced globals on entry to the procedure.
623 Scop : constant Uint := Scope_Depth (Spec);
624 -- This is used to record the scope depth of the current procedure, so
625 -- that we can identify global references.
627 Max_Vars : constant := 4;
628 -- Do not test more than four global variables
630 Count_Vars : Natural := 0;
631 -- Count variables found so far
643 function Process (Nod : Node_Id) return Traverse_Result;
644 -- Function to traverse the subprogram body (using Traverse_Func)
650 function Process (Nod : Node_Id) return Traverse_Result is
654 if Nkind (Nod) = N_Procedure_Call_Statement then
656 -- Case of one of the detected recursive calls
658 if Is_Entity_Name (Name (Nod))
659 and then Has_Recursive_Call (Entity (Name (Nod)))
660 and then Entity (Name (Nod)) = Spec
662 Append_Elmt (Nod, Call_List);
665 -- Any other procedure call may have side effects
671 -- A call to a pure function can always be ignored
673 elsif Nkind (Nod) = N_Function_Call
674 and then Is_Entity_Name (Name (Nod))
675 and then Is_Pure (Entity (Name (Nod)))
679 -- Case of an identifier reference
681 elsif Nkind (Nod) = N_Identifier then
684 -- If no entity, then ignore the reference
686 -- Not clear why this can happen. To investigate, remove this
687 -- test and look at the crash that occurs here in 3401-004 ???
692 -- Ignore entities with no Scope, again not clear how this
693 -- can happen, to investigate, look at 4108-008 ???
695 elsif No (Scope (Ent)) then
698 -- Ignore the reference if not to a more global object
700 elsif Scope_Depth (Scope (Ent)) >= Scop then
703 -- References to types, exceptions and constants are always OK
706 or else Ekind (Ent) = E_Exception
707 or else Ekind (Ent) = E_Constant
711 -- If other than a non-volatile scalar variable, we have some
712 -- kind of global reference (e.g. to a function) that we cannot
713 -- deal with so we forget the attempt.
715 elsif Ekind (Ent) /= E_Variable
716 or else not Is_Scalar_Type (Etype (Ent))
717 or else Treat_As_Volatile (Ent)
721 -- Otherwise we have a reference to a global scalar
724 -- Loop through global entities already detected
726 Elm := First_Elmt (Var_List);
728 -- If not detected before, record this new global reference
731 Count_Vars := Count_Vars + 1;
733 if Count_Vars <= Max_Vars then
734 Append_Elmt (Entity (Nod), Var_List);
741 -- If recorded before, ignore
743 elsif Node (Elm) = Entity (Nod) then
746 -- Otherwise keep looking
756 -- For all other node kinds, recursively visit syntactic children
763 function Traverse_Body is new Traverse_Func (Process);
765 -- Start of processing for Detect_Infinite_Recursion
768 -- Do not attempt detection in No_Implicit_Conditional mode, since we
769 -- won't be able to generate the code to handle the recursion in any
772 if Restriction_Active (No_Implicit_Conditionals) then
776 -- Otherwise do traversal and quit if we get abandon signal
778 if Traverse_Body (N) = Abandon then
781 -- We must have a call, since Has_Recursive_Call was set. If not just
782 -- ignore (this is only an error check, so if we have a funny situation,
783 -- due to bugs or errors, we do not want to bomb!)
785 elsif Is_Empty_Elmt_List (Call_List) then
789 -- Here is the case where we detect recursion at compile time
791 -- Push our current scope for analyzing the declarations and code that
792 -- we will insert for the checking.
796 -- This loop builds temporary variables for each of the referenced
797 -- globals, so that at the end of the loop the list Shad_List contains
798 -- these temporaries in one-to-one correspondence with the elements in
802 Elm := First_Elmt (Var_List);
803 while Present (Elm) loop
806 Make_Defining_Identifier (Loc,
807 Chars => New_Internal_Name ('S'));
808 Append_Elmt (Ent, Shad_List);
810 -- Insert a declaration for this temporary at the start of the
811 -- declarations for the procedure. The temporaries are declared as
812 -- constant objects initialized to the current values of the
813 -- corresponding temporaries.
816 Make_Object_Declaration (Loc,
817 Defining_Identifier => Ent,
818 Object_Definition => New_Occurrence_Of (Etype (Var), Loc),
819 Constant_Present => True,
820 Expression => New_Occurrence_Of (Var, Loc));
823 Prepend (Decl, Declarations (N));
825 Insert_After (Last, Decl);
833 -- Loop through calls
835 Call := First_Elmt (Call_List);
836 while Present (Call) loop
838 -- Build a predicate expression of the form
841 -- and then global1 = temp1
842 -- and then global2 = temp2
845 -- This predicate determines if any of the global values
846 -- referenced by the procedure have changed since the
847 -- current call, if not an infinite recursion is assured.
849 Test := New_Occurrence_Of (Standard_True, Loc);
851 Elm1 := First_Elmt (Var_List);
852 Elm2 := First_Elmt (Shad_List);
853 while Present (Elm1) loop
859 Left_Opnd => New_Occurrence_Of (Node (Elm1), Loc),
860 Right_Opnd => New_Occurrence_Of (Node (Elm2), Loc)));
866 -- Now we replace the call with the sequence
868 -- if no-changes (see above) then
869 -- raise Storage_Error;
874 Rewrite (Node (Call),
875 Make_If_Statement (Loc,
877 Then_Statements => New_List (
878 Make_Raise_Storage_Error (Loc,
879 Reason => SE_Infinite_Recursion)),
881 Else_Statements => New_List (
882 Relocate_Node (Node (Call)))));
884 Analyze (Node (Call));
889 -- Remove temporary scope stack entry used for analysis
892 end Detect_Infinite_Recursion;
898 procedure Expand_Actuals (N : Node_Id; Subp : Entity_Id) is
899 Loc : constant Source_Ptr := Sloc (N);
904 E_Formal : Entity_Id;
906 procedure Add_Call_By_Copy_Code;
907 -- For cases where the parameter must be passed by copy, this routine
908 -- generates a temporary variable into which the actual is copied and
909 -- then passes this as the parameter. For an OUT or IN OUT parameter,
910 -- an assignment is also generated to copy the result back. The call
911 -- also takes care of any constraint checks required for the type
912 -- conversion case (on both the way in and the way out).
914 procedure Add_Simple_Call_By_Copy_Code;
915 -- This is similar to the above, but is used in cases where we know
916 -- that all that is needed is to simply create a temporary and copy
917 -- the value in and out of the temporary.
919 procedure Check_Fortran_Logical;
920 -- A value of type Logical that is passed through a formal parameter
921 -- must be normalized because .TRUE. usually does not have the same
922 -- representation as True. We assume that .FALSE. = False = 0.
923 -- What about functions that return a logical type ???
925 function Is_Legal_Copy return Boolean;
926 -- Check that an actual can be copied before generating the temporary
927 -- to be used in the call. If the actual is of a by_reference type then
928 -- the program is illegal (this can only happen in the presence of
929 -- rep. clauses that force an incorrect alignment). If the formal is
930 -- a by_reference parameter imposed by a DEC pragma, emit a warning to
931 -- the effect that this might lead to unaligned arguments.
933 function Make_Var (Actual : Node_Id) return Entity_Id;
934 -- Returns an entity that refers to the given actual parameter,
935 -- Actual (not including any type conversion). If Actual is an
936 -- entity name, then this entity is returned unchanged, otherwise
937 -- a renaming is created to provide an entity for the actual.
939 procedure Reset_Packed_Prefix;
940 -- The expansion of a packed array component reference is delayed in
941 -- the context of a call. Now we need to complete the expansion, so we
942 -- unmark the analyzed bits in all prefixes.
944 ---------------------------
945 -- Add_Call_By_Copy_Code --
946 ---------------------------
948 procedure Add_Call_By_Copy_Code is
954 F_Typ : constant Entity_Id := Etype (Formal);
959 if not Is_Legal_Copy then
964 Make_Defining_Identifier (Loc,
965 Chars => New_Internal_Name ('T'));
967 -- Use formal type for temp, unless formal type is an unconstrained
968 -- array, in which case we don't have to worry about bounds checks,
969 -- and we use the actual type, since that has appropriate bounds.
971 if Is_Array_Type (F_Typ) and then not Is_Constrained (F_Typ) then
972 Indic := New_Occurrence_Of (Etype (Actual), Loc);
974 Indic := New_Occurrence_Of (Etype (Formal), Loc);
977 if Nkind (Actual) = N_Type_Conversion then
978 V_Typ := Etype (Expression (Actual));
980 -- If the formal is an (in-)out parameter, capture the name
981 -- of the variable in order to build the post-call assignment.
983 Var := Make_Var (Expression (Actual));
985 Crep := not Same_Representation
986 (F_Typ, Etype (Expression (Actual)));
989 V_Typ := Etype (Actual);
990 Var := Make_Var (Actual);
994 -- Setup initialization for case of in out parameter, or an out
995 -- parameter where the formal is an unconstrained array (in the
996 -- latter case, we have to pass in an object with bounds).
998 -- If this is an out parameter, the initial copy is wasteful, so as
999 -- an optimization for the one-dimensional case we extract the
1000 -- bounds of the actual and build an uninitialized temporary of the
1003 if Ekind (Formal) = E_In_Out_Parameter
1004 or else (Is_Array_Type (F_Typ) and then not Is_Constrained (F_Typ))
1006 if Nkind (Actual) = N_Type_Conversion then
1007 if Conversion_OK (Actual) then
1008 Init := OK_Convert_To (F_Typ, New_Occurrence_Of (Var, Loc));
1010 Init := Convert_To (F_Typ, New_Occurrence_Of (Var, Loc));
1013 elsif Ekind (Formal) = E_Out_Parameter
1014 and then Is_Array_Type (F_Typ)
1015 and then Number_Dimensions (F_Typ) = 1
1016 and then not Has_Non_Null_Base_Init_Proc (F_Typ)
1018 -- Actual is a one-dimensional array or slice, and the type
1019 -- requires no initialization. Create a temporary of the
1020 -- right size, but do not copy actual into it (optimization).
1024 Make_Subtype_Indication (Loc,
1026 New_Occurrence_Of (F_Typ, Loc),
1028 Make_Index_Or_Discriminant_Constraint (Loc,
1029 Constraints => New_List (
1032 Make_Attribute_Reference (Loc,
1033 Prefix => New_Occurrence_Of (Var, Loc),
1034 Attribute_Name => Name_First),
1036 Make_Attribute_Reference (Loc,
1037 Prefix => New_Occurrence_Of (Var, Loc),
1038 Attribute_Name => Name_Last)))));
1041 Init := New_Occurrence_Of (Var, Loc);
1044 -- An initialization is created for packed conversions as
1045 -- actuals for out parameters to enable Make_Object_Declaration
1046 -- to determine the proper subtype for N_Node. Note that this
1047 -- is wasteful because the extra copying on the call side is
1048 -- not required for such out parameters. ???
1050 elsif Ekind (Formal) = E_Out_Parameter
1051 and then Nkind (Actual) = N_Type_Conversion
1052 and then (Is_Bit_Packed_Array (F_Typ)
1054 Is_Bit_Packed_Array (Etype (Expression (Actual))))
1056 if Conversion_OK (Actual) then
1057 Init := OK_Convert_To (F_Typ, New_Occurrence_Of (Var, Loc));
1059 Init := Convert_To (F_Typ, New_Occurrence_Of (Var, Loc));
1062 elsif Ekind (Formal) = E_In_Parameter then
1064 -- Handle the case in which the actual is a type conversion
1066 if Nkind (Actual) = N_Type_Conversion then
1067 if Conversion_OK (Actual) then
1068 Init := OK_Convert_To (F_Typ, New_Occurrence_Of (Var, Loc));
1070 Init := Convert_To (F_Typ, New_Occurrence_Of (Var, Loc));
1073 Init := New_Occurrence_Of (Var, Loc);
1081 Make_Object_Declaration (Loc,
1082 Defining_Identifier => Temp,
1083 Object_Definition => Indic,
1084 Expression => Init);
1085 Set_Assignment_OK (N_Node);
1086 Insert_Action (N, N_Node);
1088 -- Now, normally the deal here is that we use the defining
1089 -- identifier created by that object declaration. There is
1090 -- one exception to this. In the change of representation case
1091 -- the above declaration will end up looking like:
1093 -- temp : type := identifier;
1095 -- And in this case we might as well use the identifier directly
1096 -- and eliminate the temporary. Note that the analysis of the
1097 -- declaration was not a waste of time in that case, since it is
1098 -- what generated the necessary change of representation code. If
1099 -- the change of representation introduced additional code, as in
1100 -- a fixed-integer conversion, the expression is not an identifier
1101 -- and must be kept.
1104 and then Present (Expression (N_Node))
1105 and then Is_Entity_Name (Expression (N_Node))
1107 Temp := Entity (Expression (N_Node));
1108 Rewrite (N_Node, Make_Null_Statement (Loc));
1111 -- For IN parameter, all we do is to replace the actual
1113 if Ekind (Formal) = E_In_Parameter then
1114 Rewrite (Actual, New_Reference_To (Temp, Loc));
1117 -- Processing for OUT or IN OUT parameter
1120 -- Kill current value indications for the temporary variable we
1121 -- created, since we just passed it as an OUT parameter.
1123 Kill_Current_Values (Temp);
1125 -- If type conversion, use reverse conversion on exit
1127 if Nkind (Actual) = N_Type_Conversion then
1128 if Conversion_OK (Actual) then
1129 Expr := OK_Convert_To (V_Typ, New_Occurrence_Of (Temp, Loc));
1131 Expr := Convert_To (V_Typ, New_Occurrence_Of (Temp, Loc));
1134 Expr := New_Occurrence_Of (Temp, Loc);
1137 Rewrite (Actual, New_Reference_To (Temp, Loc));
1140 -- If the actual is a conversion of a packed reference, it may
1141 -- already have been expanded by Remove_Side_Effects, and the
1142 -- resulting variable is a temporary which does not designate
1143 -- the proper out-parameter, which may not be addressable. In
1144 -- that case, generate an assignment to the original expression
1145 -- (before expansion of the packed reference) so that the proper
1146 -- expansion of assignment to a packed component can take place.
1153 if Is_Renaming_Of_Object (Var)
1154 and then Nkind (Renamed_Object (Var)) = N_Selected_Component
1155 and then Is_Entity_Name (Prefix (Renamed_Object (Var)))
1156 and then Nkind (Original_Node (Prefix (Renamed_Object (Var))))
1157 = N_Indexed_Component
1159 Has_Non_Standard_Rep (Etype (Prefix (Renamed_Object (Var))))
1161 Obj := Renamed_Object (Var);
1163 Make_Selected_Component (Loc,
1165 New_Copy_Tree (Original_Node (Prefix (Obj))),
1166 Selector_Name => New_Copy (Selector_Name (Obj)));
1167 Reset_Analyzed_Flags (Lhs);
1170 Lhs := New_Occurrence_Of (Var, Loc);
1173 Set_Assignment_OK (Lhs);
1175 Append_To (Post_Call,
1176 Make_Assignment_Statement (Loc,
1178 Expression => Expr));
1182 end Add_Call_By_Copy_Code;
1184 ----------------------------------
1185 -- Add_Simple_Call_By_Copy_Code --
1186 ----------------------------------
1188 procedure Add_Simple_Call_By_Copy_Code is
1196 F_Typ : constant Entity_Id := Etype (Formal);
1199 if not Is_Legal_Copy then
1203 -- Use formal type for temp, unless formal type is an unconstrained
1204 -- array, in which case we don't have to worry about bounds checks,
1205 -- and we use the actual type, since that has appropriate bounds.
1207 if Is_Array_Type (F_Typ) and then not Is_Constrained (F_Typ) then
1208 Indic := New_Occurrence_Of (Etype (Actual), Loc);
1210 Indic := New_Occurrence_Of (Etype (Formal), Loc);
1213 -- Prepare to generate code
1215 Reset_Packed_Prefix;
1218 Make_Defining_Identifier (Loc,
1219 Chars => New_Internal_Name ('T'));
1220 Incod := Relocate_Node (Actual);
1221 Outcod := New_Copy_Tree (Incod);
1223 -- Generate declaration of temporary variable, initializing it
1224 -- with the input parameter unless we have an OUT formal or
1225 -- this is an initialization call.
1227 -- If the formal is an out parameter with discriminants, the
1228 -- discriminants must be captured even if the rest of the object
1229 -- is in principle uninitialized, because the discriminants may
1230 -- be read by the called subprogram.
1232 if Ekind (Formal) = E_Out_Parameter then
1235 if Has_Discriminants (Etype (Formal)) then
1236 Indic := New_Occurrence_Of (Etype (Actual), Loc);
1239 elsif Inside_Init_Proc then
1241 -- Could use a comment here to match comment below ???
1243 if Nkind (Actual) /= N_Selected_Component
1245 not Has_Discriminant_Dependent_Constraint
1246 (Entity (Selector_Name (Actual)))
1250 -- Otherwise, keep the component in order to generate the proper
1251 -- actual subtype, that depends on enclosing discriminants.
1259 Make_Object_Declaration (Loc,
1260 Defining_Identifier => Temp,
1261 Object_Definition => Indic,
1262 Expression => Incod);
1267 -- If the call is to initialize a component of a composite type,
1268 -- and the component does not depend on discriminants, use the
1269 -- actual type of the component. This is required in case the
1270 -- component is constrained, because in general the formal of the
1271 -- initialization procedure will be unconstrained. Note that if
1272 -- the component being initialized is constrained by an enclosing
1273 -- discriminant, the presence of the initialization in the
1274 -- declaration will generate an expression for the actual subtype.
1276 Set_No_Initialization (Decl);
1277 Set_Object_Definition (Decl,
1278 New_Occurrence_Of (Etype (Actual), Loc));
1281 Insert_Action (N, Decl);
1283 -- The actual is simply a reference to the temporary
1285 Rewrite (Actual, New_Occurrence_Of (Temp, Loc));
1287 -- Generate copy out if OUT or IN OUT parameter
1289 if Ekind (Formal) /= E_In_Parameter then
1291 Rhs := New_Occurrence_Of (Temp, Loc);
1293 -- Deal with conversion
1295 if Nkind (Lhs) = N_Type_Conversion then
1296 Lhs := Expression (Lhs);
1297 Rhs := Convert_To (Etype (Actual), Rhs);
1300 Append_To (Post_Call,
1301 Make_Assignment_Statement (Loc,
1303 Expression => Rhs));
1304 Set_Assignment_OK (Name (Last (Post_Call)));
1306 end Add_Simple_Call_By_Copy_Code;
1308 ---------------------------
1309 -- Check_Fortran_Logical --
1310 ---------------------------
1312 procedure Check_Fortran_Logical is
1313 Logical : constant Entity_Id := Etype (Formal);
1316 -- Note: this is very incomplete, e.g. it does not handle arrays
1317 -- of logical values. This is really not the right approach at all???)
1320 if Convention (Subp) = Convention_Fortran
1321 and then Root_Type (Etype (Formal)) = Standard_Boolean
1322 and then Ekind (Formal) /= E_In_Parameter
1324 Var := Make_Var (Actual);
1325 Append_To (Post_Call,
1326 Make_Assignment_Statement (Loc,
1327 Name => New_Occurrence_Of (Var, Loc),
1329 Unchecked_Convert_To (
1332 Left_Opnd => New_Occurrence_Of (Var, Loc),
1334 Unchecked_Convert_To (
1336 New_Occurrence_Of (Standard_False, Loc))))));
1338 end Check_Fortran_Logical;
1344 function Is_Legal_Copy return Boolean is
1346 -- An attempt to copy a value of such a type can only occur if
1347 -- representation clauses give the actual a misaligned address.
1349 if Is_By_Reference_Type (Etype (Formal)) then
1351 ("misaligned actual cannot be passed by reference", Actual);
1354 -- For users of Starlet, we assume that the specification of by-
1355 -- reference mechanism is mandatory. This may lead to unaligned
1356 -- objects but at least for DEC legacy code it is known to work.
1357 -- The warning will alert users of this code that a problem may
1360 elsif Mechanism (Formal) = By_Reference
1361 and then Is_Valued_Procedure (Scope (Formal))
1364 ("by_reference actual may be misaligned?", Actual);
1376 function Make_Var (Actual : Node_Id) return Entity_Id is
1380 if Is_Entity_Name (Actual) then
1381 return Entity (Actual);
1385 Make_Defining_Identifier (Loc,
1386 Chars => New_Internal_Name ('T'));
1389 Make_Object_Renaming_Declaration (Loc,
1390 Defining_Identifier => Var,
1392 New_Occurrence_Of (Etype (Actual), Loc),
1393 Name => Relocate_Node (Actual));
1395 Insert_Action (N, N_Node);
1400 -------------------------
1401 -- Reset_Packed_Prefix --
1402 -------------------------
1404 procedure Reset_Packed_Prefix is
1405 Pfx : Node_Id := Actual;
1408 Set_Analyzed (Pfx, False);
1410 not Nkind_In (Pfx, N_Selected_Component, N_Indexed_Component);
1411 Pfx := Prefix (Pfx);
1413 end Reset_Packed_Prefix;
1415 -- Start of processing for Expand_Actuals
1418 Post_Call := New_List;
1420 Formal := First_Formal (Subp);
1421 Actual := First_Actual (N);
1422 while Present (Formal) loop
1423 E_Formal := Etype (Formal);
1425 if Is_Scalar_Type (E_Formal)
1426 or else Nkind (Actual) = N_Slice
1428 Check_Fortran_Logical;
1432 elsif Ekind (Formal) /= E_Out_Parameter then
1434 -- The unusual case of the current instance of a protected type
1435 -- requires special handling. This can only occur in the context
1436 -- of a call within the body of a protected operation.
1438 if Is_Entity_Name (Actual)
1439 and then Ekind (Entity (Actual)) = E_Protected_Type
1440 and then In_Open_Scopes (Entity (Actual))
1442 if Scope (Subp) /= Entity (Actual) then
1443 Error_Msg_N ("operation outside protected type may not "
1444 & "call back its protected operations?", Actual);
1448 Expand_Protected_Object_Reference (N, Entity (Actual)));
1451 -- Ada 2005 (AI-318-02): If the actual parameter is a call to a
1452 -- build-in-place function, then a temporary return object needs
1453 -- to be created and access to it must be passed to the function.
1454 -- Currently we limit such functions to those with inherently
1455 -- limited result subtypes, but eventually we plan to expand the
1456 -- functions that are treated as build-in-place to include other
1457 -- composite result types.
1459 if Ada_Version >= Ada_05
1460 and then Is_Build_In_Place_Function_Call (Actual)
1462 Make_Build_In_Place_Call_In_Anonymous_Context (Actual);
1465 Apply_Constraint_Check (Actual, E_Formal);
1467 -- Out parameter case. No constraint checks on access type
1470 elsif Is_Access_Type (E_Formal) then
1475 elsif Has_Discriminants (Base_Type (E_Formal))
1476 or else Has_Non_Null_Base_Init_Proc (E_Formal)
1478 Apply_Constraint_Check (Actual, E_Formal);
1483 Apply_Constraint_Check (Actual, Base_Type (E_Formal));
1486 -- Processing for IN-OUT and OUT parameters
1488 if Ekind (Formal) /= E_In_Parameter then
1490 -- For type conversions of arrays, apply length/range checks
1492 if Is_Array_Type (E_Formal)
1493 and then Nkind (Actual) = N_Type_Conversion
1495 if Is_Constrained (E_Formal) then
1496 Apply_Length_Check (Expression (Actual), E_Formal);
1498 Apply_Range_Check (Expression (Actual), E_Formal);
1502 -- If argument is a type conversion for a type that is passed
1503 -- by copy, then we must pass the parameter by copy.
1505 if Nkind (Actual) = N_Type_Conversion
1507 (Is_Numeric_Type (E_Formal)
1508 or else Is_Access_Type (E_Formal)
1509 or else Is_Enumeration_Type (E_Formal)
1510 or else Is_Bit_Packed_Array (Etype (Formal))
1511 or else Is_Bit_Packed_Array (Etype (Expression (Actual)))
1513 -- Also pass by copy if change of representation
1515 or else not Same_Representation
1517 Etype (Expression (Actual))))
1519 Add_Call_By_Copy_Code;
1521 -- References to components of bit packed arrays are expanded
1522 -- at this point, rather than at the point of analysis of the
1523 -- actuals, to handle the expansion of the assignment to
1524 -- [in] out parameters.
1526 elsif Is_Ref_To_Bit_Packed_Array (Actual) then
1527 Add_Simple_Call_By_Copy_Code;
1529 -- If a non-scalar actual is possibly bit-aligned, we need a copy
1530 -- because the back-end cannot cope with such objects. In other
1531 -- cases where alignment forces a copy, the back-end generates
1532 -- it properly. It should not be generated unconditionally in the
1533 -- front-end because it does not know precisely the alignment
1534 -- requirements of the target, and makes too conservative an
1535 -- estimate, leading to superfluous copies or spurious errors
1536 -- on by-reference parameters.
1538 elsif Nkind (Actual) = N_Selected_Component
1540 Component_May_Be_Bit_Aligned (Entity (Selector_Name (Actual)))
1541 and then not Represented_As_Scalar (Etype (Formal))
1543 Add_Simple_Call_By_Copy_Code;
1545 -- References to slices of bit packed arrays are expanded
1547 elsif Is_Ref_To_Bit_Packed_Slice (Actual) then
1548 Add_Call_By_Copy_Code;
1550 -- References to possibly unaligned slices of arrays are expanded
1552 elsif Is_Possibly_Unaligned_Slice (Actual) then
1553 Add_Call_By_Copy_Code;
1555 -- Deal with access types where the actual subtype and the
1556 -- formal subtype are not the same, requiring a check.
1558 -- It is necessary to exclude tagged types because of "downward
1559 -- conversion" errors.
1561 elsif Is_Access_Type (E_Formal)
1562 and then not Same_Type (E_Formal, Etype (Actual))
1563 and then not Is_Tagged_Type (Designated_Type (E_Formal))
1565 Add_Call_By_Copy_Code;
1567 -- If the actual is not a scalar and is marked for volatile
1568 -- treatment, whereas the formal is not volatile, then pass
1569 -- by copy unless it is a by-reference type.
1571 elsif Is_Entity_Name (Actual)
1572 and then Treat_As_Volatile (Entity (Actual))
1573 and then not Is_By_Reference_Type (Etype (Actual))
1574 and then not Is_Scalar_Type (Etype (Entity (Actual)))
1575 and then not Treat_As_Volatile (E_Formal)
1577 Add_Call_By_Copy_Code;
1579 elsif Nkind (Actual) = N_Indexed_Component
1580 and then Is_Entity_Name (Prefix (Actual))
1581 and then Has_Volatile_Components (Entity (Prefix (Actual)))
1583 Add_Call_By_Copy_Code;
1586 -- Processing for IN parameters
1589 -- For IN parameters is in the packed array case, we expand an
1590 -- indexed component (the circuit in Exp_Ch4 deliberately left
1591 -- indexed components appearing as actuals untouched, so that
1592 -- the special processing above for the OUT and IN OUT cases
1593 -- could be performed. We could make the test in Exp_Ch4 more
1594 -- complex and have it detect the parameter mode, but it is
1595 -- easier simply to handle all cases here.)
1597 if Nkind (Actual) = N_Indexed_Component
1598 and then Is_Packed (Etype (Prefix (Actual)))
1600 Reset_Packed_Prefix;
1601 Expand_Packed_Element_Reference (Actual);
1603 -- If we have a reference to a bit packed array, we copy it,
1604 -- since the actual must be byte aligned.
1606 -- Is this really necessary in all cases???
1608 elsif Is_Ref_To_Bit_Packed_Array (Actual) then
1609 Add_Simple_Call_By_Copy_Code;
1611 -- If a non-scalar actual is possibly unaligned, we need a copy
1613 elsif Is_Possibly_Unaligned_Object (Actual)
1614 and then not Represented_As_Scalar (Etype (Formal))
1616 Add_Simple_Call_By_Copy_Code;
1618 -- Similarly, we have to expand slices of packed arrays here
1619 -- because the result must be byte aligned.
1621 elsif Is_Ref_To_Bit_Packed_Slice (Actual) then
1622 Add_Call_By_Copy_Code;
1624 -- Only processing remaining is to pass by copy if this is a
1625 -- reference to a possibly unaligned slice, since the caller
1626 -- expects an appropriately aligned argument.
1628 elsif Is_Possibly_Unaligned_Slice (Actual) then
1629 Add_Call_By_Copy_Code;
1633 Next_Formal (Formal);
1634 Next_Actual (Actual);
1637 -- Find right place to put post call stuff if it is present
1639 if not Is_Empty_List (Post_Call) then
1641 -- If call is not a list member, it must be the triggering statement
1642 -- of a triggering alternative or an entry call alternative, and we
1643 -- can add the post call stuff to the corresponding statement list.
1645 if not Is_List_Member (N) then
1647 P : constant Node_Id := Parent (N);
1650 pragma Assert (Nkind_In (P, N_Triggering_Alternative,
1651 N_Entry_Call_Alternative));
1653 if Is_Non_Empty_List (Statements (P)) then
1654 Insert_List_Before_And_Analyze
1655 (First (Statements (P)), Post_Call);
1657 Set_Statements (P, Post_Call);
1661 -- Otherwise, normal case where N is in a statement sequence,
1662 -- just put the post-call stuff after the call statement.
1665 Insert_Actions_After (N, Post_Call);
1669 -- The call node itself is re-analyzed in Expand_Call
1677 -- This procedure handles expansion of function calls and procedure call
1678 -- statements (i.e. it serves as the body for Expand_N_Function_Call and
1679 -- Expand_N_Procedure_Call_Statement). Processing for calls includes:
1681 -- Replace call to Raise_Exception by Raise_Exception_Always if possible
1682 -- Provide values of actuals for all formals in Extra_Formals list
1683 -- Replace "call" to enumeration literal function by literal itself
1684 -- Rewrite call to predefined operator as operator
1685 -- Replace actuals to in-out parameters that are numeric conversions,
1686 -- with explicit assignment to temporaries before and after the call.
1687 -- Remove optional actuals if First_Optional_Parameter specified.
1689 -- Note that the list of actuals has been filled with default expressions
1690 -- during semantic analysis of the call. Only the extra actuals required
1691 -- for the 'Constrained attribute and for accessibility checks are added
1694 procedure Expand_Call (N : Node_Id) is
1695 Loc : constant Source_Ptr := Sloc (N);
1696 Extra_Actuals : List_Id := No_List;
1697 Prev : Node_Id := Empty;
1699 procedure Add_Actual_Parameter (Insert_Param : Node_Id);
1700 -- Adds one entry to the end of the actual parameter list. Used for
1701 -- default parameters and for extra actuals (for Extra_Formals). The
1702 -- argument is an N_Parameter_Association node.
1704 procedure Add_Extra_Actual (Expr : Node_Id; EF : Entity_Id);
1705 -- Adds an extra actual to the list of extra actuals. Expr is the
1706 -- expression for the value of the actual, EF is the entity for the
1709 function Inherited_From_Formal (S : Entity_Id) return Entity_Id;
1710 -- Within an instance, a type derived from a non-tagged formal derived
1711 -- type inherits from the original parent, not from the actual. The
1712 -- current derivation mechanism has the derived type inherit from the
1713 -- actual, which is only correct outside of the instance. If the
1714 -- subprogram is inherited, we test for this particular case through a
1715 -- convoluted tree traversal before setting the proper subprogram to be
1718 --------------------------
1719 -- Add_Actual_Parameter --
1720 --------------------------
1722 procedure Add_Actual_Parameter (Insert_Param : Node_Id) is
1723 Actual_Expr : constant Node_Id :=
1724 Explicit_Actual_Parameter (Insert_Param);
1727 -- Case of insertion is first named actual
1729 if No (Prev) or else
1730 Nkind (Parent (Prev)) /= N_Parameter_Association
1732 Set_Next_Named_Actual (Insert_Param, First_Named_Actual (N));
1733 Set_First_Named_Actual (N, Actual_Expr);
1736 if No (Parameter_Associations (N)) then
1737 Set_Parameter_Associations (N, New_List);
1738 Append (Insert_Param, Parameter_Associations (N));
1741 Insert_After (Prev, Insert_Param);
1744 -- Case of insertion is not first named actual
1747 Set_Next_Named_Actual
1748 (Insert_Param, Next_Named_Actual (Parent (Prev)));
1749 Set_Next_Named_Actual (Parent (Prev), Actual_Expr);
1750 Append (Insert_Param, Parameter_Associations (N));
1753 Prev := Actual_Expr;
1754 end Add_Actual_Parameter;
1756 ----------------------
1757 -- Add_Extra_Actual --
1758 ----------------------
1760 procedure Add_Extra_Actual (Expr : Node_Id; EF : Entity_Id) is
1761 Loc : constant Source_Ptr := Sloc (Expr);
1764 if Extra_Actuals = No_List then
1765 Extra_Actuals := New_List;
1766 Set_Parent (Extra_Actuals, N);
1769 Append_To (Extra_Actuals,
1770 Make_Parameter_Association (Loc,
1771 Explicit_Actual_Parameter => Expr,
1773 Make_Identifier (Loc, Chars (EF))));
1775 Analyze_And_Resolve (Expr, Etype (EF));
1776 end Add_Extra_Actual;
1778 ---------------------------
1779 -- Inherited_From_Formal --
1780 ---------------------------
1782 function Inherited_From_Formal (S : Entity_Id) return Entity_Id is
1784 Gen_Par : Entity_Id;
1785 Gen_Prim : Elist_Id;
1790 -- If the operation is inherited, it is attached to the corresponding
1791 -- type derivation. If the parent in the derivation is a generic
1792 -- actual, it is a subtype of the actual, and we have to recover the
1793 -- original derived type declaration to find the proper parent.
1795 if Nkind (Parent (S)) /= N_Full_Type_Declaration
1796 or else not Is_Derived_Type (Defining_Identifier (Parent (S)))
1797 or else Nkind (Type_Definition (Original_Node (Parent (S)))) /=
1798 N_Derived_Type_Definition
1799 or else not In_Instance
1806 (Type_Definition (Original_Node (Parent (S)))));
1808 if Nkind (Indic) = N_Subtype_Indication then
1809 Par := Entity (Subtype_Mark (Indic));
1811 Par := Entity (Indic);
1815 if not Is_Generic_Actual_Type (Par)
1816 or else Is_Tagged_Type (Par)
1817 or else Nkind (Parent (Par)) /= N_Subtype_Declaration
1818 or else not In_Open_Scopes (Scope (Par))
1823 Gen_Par := Generic_Parent_Type (Parent (Par));
1826 -- If the actual has no generic parent type, the formal is not
1827 -- a formal derived type, so nothing to inherit.
1829 if No (Gen_Par) then
1833 -- If the generic parent type is still the generic type, this is a
1834 -- private formal, not a derived formal, and there are no operations
1835 -- inherited from the formal.
1837 if Nkind (Parent (Gen_Par)) = N_Formal_Type_Declaration then
1841 Gen_Prim := Collect_Primitive_Operations (Gen_Par);
1843 Elmt := First_Elmt (Gen_Prim);
1844 while Present (Elmt) loop
1845 if Chars (Node (Elmt)) = Chars (S) then
1851 F1 := First_Formal (S);
1852 F2 := First_Formal (Node (Elmt));
1854 and then Present (F2)
1856 if Etype (F1) = Etype (F2)
1857 or else Etype (F2) = Gen_Par
1863 exit; -- not the right subprogram
1875 raise Program_Error;
1876 end Inherited_From_Formal;
1880 Remote : constant Boolean := Is_Remote_Call (N);
1883 Orig_Subp : Entity_Id := Empty;
1884 Param_Count : Natural := 0;
1885 Parent_Formal : Entity_Id;
1886 Parent_Subp : Entity_Id;
1890 Prev_Orig : Node_Id;
1891 -- Original node for an actual, which may have been rewritten. If the
1892 -- actual is a function call that has been transformed from a selected
1893 -- component, the original node is unanalyzed. Otherwise, it carries
1894 -- semantic information used to generate additional actuals.
1896 CW_Interface_Formals_Present : Boolean := False;
1898 -- Start of processing for Expand_Call
1901 -- Ignore if previous error
1903 if Nkind (N) in N_Has_Etype and then Etype (N) = Any_Type then
1907 -- Call using access to subprogram with explicit dereference
1909 if Nkind (Name (N)) = N_Explicit_Dereference then
1910 Subp := Etype (Name (N));
1911 Parent_Subp := Empty;
1913 -- Case of call to simple entry, where the Name is a selected component
1914 -- whose prefix is the task, and whose selector name is the entry name
1916 elsif Nkind (Name (N)) = N_Selected_Component then
1917 Subp := Entity (Selector_Name (Name (N)));
1918 Parent_Subp := Empty;
1920 -- Case of call to member of entry family, where Name is an indexed
1921 -- component, with the prefix being a selected component giving the
1922 -- task and entry family name, and the index being the entry index.
1924 elsif Nkind (Name (N)) = N_Indexed_Component then
1925 Subp := Entity (Selector_Name (Prefix (Name (N))));
1926 Parent_Subp := Empty;
1931 Subp := Entity (Name (N));
1932 Parent_Subp := Alias (Subp);
1934 -- Replace call to Raise_Exception by call to Raise_Exception_Always
1935 -- if we can tell that the first parameter cannot possibly be null.
1936 -- This improves efficiency by avoiding a run-time test.
1938 -- We do not do this if Raise_Exception_Always does not exist, which
1939 -- can happen in configurable run time profiles which provide only a
1942 if Is_RTE (Subp, RE_Raise_Exception)
1943 and then RTE_Available (RE_Raise_Exception_Always)
1946 FA : constant Node_Id := Original_Node (First_Actual (N));
1949 -- The case we catch is where the first argument is obtained
1950 -- using the Identity attribute (which must always be
1953 if Nkind (FA) = N_Attribute_Reference
1954 and then Attribute_Name (FA) = Name_Identity
1956 Subp := RTE (RE_Raise_Exception_Always);
1957 Set_Name (N, New_Occurrence_Of (Subp, Loc));
1962 if Ekind (Subp) = E_Entry then
1963 Parent_Subp := Empty;
1967 -- Ada 2005 (AI-345): We have a procedure call as a triggering
1968 -- alternative in an asynchronous select or as an entry call in
1969 -- a conditional or timed select. Check whether the procedure call
1970 -- is a renaming of an entry and rewrite it as an entry call.
1972 if Ada_Version >= Ada_05
1973 and then Nkind (N) = N_Procedure_Call_Statement
1975 ((Nkind (Parent (N)) = N_Triggering_Alternative
1976 and then Triggering_Statement (Parent (N)) = N)
1978 (Nkind (Parent (N)) = N_Entry_Call_Alternative
1979 and then Entry_Call_Statement (Parent (N)) = N))
1983 Ren_Root : Entity_Id := Subp;
1986 -- This may be a chain of renamings, find the root
1988 if Present (Alias (Ren_Root)) then
1989 Ren_Root := Alias (Ren_Root);
1992 if Present (Original_Node (Parent (Parent (Ren_Root)))) then
1993 Ren_Decl := Original_Node (Parent (Parent (Ren_Root)));
1995 if Nkind (Ren_Decl) = N_Subprogram_Renaming_Declaration then
1997 Make_Entry_Call_Statement (Loc,
1999 New_Copy_Tree (Name (Ren_Decl)),
2000 Parameter_Associations =>
2001 New_Copy_List_Tree (Parameter_Associations (N))));
2009 -- First step, compute extra actuals, corresponding to any
2010 -- Extra_Formals present. Note that we do not access Extra_Formals
2011 -- directly, instead we simply note the presence of the extra
2012 -- formals as we process the regular formals and collect the
2013 -- corresponding actuals in Extra_Actuals.
2015 -- We also generate any required range checks for actuals as we go
2016 -- through the loop, since this is a convenient place to do this.
2018 Formal := First_Formal (Subp);
2019 Actual := First_Actual (N);
2021 while Present (Formal) loop
2023 -- Generate range check if required (not activated yet ???)
2025 -- if Do_Range_Check (Actual) then
2026 -- Set_Do_Range_Check (Actual, False);
2027 -- Generate_Range_Check
2028 -- (Actual, Etype (Formal), CE_Range_Check_Failed);
2031 -- Prepare to examine current entry
2034 Prev_Orig := Original_Node (Prev);
2036 -- The original actual may have been a call written in prefix
2037 -- form, and rewritten before analysis.
2039 if not Analyzed (Prev_Orig)
2040 and then Nkind_In (Actual, N_Function_Call, N_Identifier)
2045 -- Ada 2005 (AI-251): Check if any formal is a class-wide interface
2046 -- to expand it in a further round.
2048 CW_Interface_Formals_Present :=
2049 CW_Interface_Formals_Present
2051 (Ekind (Etype (Formal)) = E_Class_Wide_Type
2052 and then Is_Interface (Etype (Etype (Formal))))
2054 (Ekind (Etype (Formal)) = E_Anonymous_Access_Type
2055 and then Is_Interface (Directly_Designated_Type
2056 (Etype (Etype (Formal)))));
2058 -- Create possible extra actual for constrained case. Usually, the
2059 -- extra actual is of the form actual'constrained, but since this
2060 -- attribute is only available for unconstrained records, TRUE is
2061 -- expanded if the type of the formal happens to be constrained (for
2062 -- instance when this procedure is inherited from an unconstrained
2063 -- record to a constrained one) or if the actual has no discriminant
2064 -- (its type is constrained). An exception to this is the case of a
2065 -- private type without discriminants. In this case we pass FALSE
2066 -- because the object has underlying discriminants with defaults.
2068 if Present (Extra_Constrained (Formal)) then
2069 if Ekind (Etype (Prev)) in Private_Kind
2070 and then not Has_Discriminants (Base_Type (Etype (Prev)))
2073 New_Occurrence_Of (Standard_False, Loc),
2074 Extra_Constrained (Formal));
2076 elsif Is_Constrained (Etype (Formal))
2077 or else not Has_Discriminants (Etype (Prev))
2080 New_Occurrence_Of (Standard_True, Loc),
2081 Extra_Constrained (Formal));
2083 -- Do not produce extra actuals for Unchecked_Union parameters.
2084 -- Jump directly to the end of the loop.
2086 elsif Is_Unchecked_Union (Base_Type (Etype (Actual))) then
2087 goto Skip_Extra_Actual_Generation;
2090 -- If the actual is a type conversion, then the constrained
2091 -- test applies to the actual, not the target type.
2097 -- Test for unchecked conversions as well, which can occur
2098 -- as out parameter actuals on calls to stream procedures.
2101 while Nkind_In (Act_Prev, N_Type_Conversion,
2102 N_Unchecked_Type_Conversion)
2104 Act_Prev := Expression (Act_Prev);
2107 -- If the expression is a conversion of a dereference,
2108 -- this is internally generated code that manipulates
2109 -- addresses, e.g. when building interface tables. No
2110 -- check should occur in this case, and the discriminated
2111 -- object is not directly a hand.
2113 if not Comes_From_Source (Actual)
2114 and then Nkind (Actual) = N_Unchecked_Type_Conversion
2115 and then Nkind (Act_Prev) = N_Explicit_Dereference
2118 (New_Occurrence_Of (Standard_False, Loc),
2119 Extra_Constrained (Formal));
2123 (Make_Attribute_Reference (Sloc (Prev),
2125 Duplicate_Subexpr_No_Checks
2126 (Act_Prev, Name_Req => True),
2127 Attribute_Name => Name_Constrained),
2128 Extra_Constrained (Formal));
2134 -- Create possible extra actual for accessibility level
2136 if Present (Extra_Accessibility (Formal)) then
2138 -- Ada 2005 (AI-252): If the actual was rewritten as an Access
2139 -- attribute, then the original actual may be an aliased object
2140 -- occurring as the prefix in a call using "Object.Operation"
2141 -- notation. In that case we must pass the level of the object,
2142 -- so Prev_Orig is reset to Prev and the attribute will be
2143 -- processed by the code for Access attributes further below.
2145 if Prev_Orig /= Prev
2146 and then Nkind (Prev) = N_Attribute_Reference
2148 Get_Attribute_Id (Attribute_Name (Prev)) = Attribute_Access
2149 and then Is_Aliased_View (Prev_Orig)
2154 -- Ada 2005 (AI-251): Thunks must propagate the extra actuals
2155 -- of accessibility levels.
2157 if Ekind (Current_Scope) in Subprogram_Kind
2158 and then Is_Thunk (Current_Scope)
2161 Parm_Ent : Entity_Id;
2164 if Is_Controlling_Actual (Actual) then
2166 -- Find the corresponding actual of the thunk
2168 Parm_Ent := First_Entity (Current_Scope);
2169 for J in 2 .. Param_Count loop
2170 Next_Entity (Parm_Ent);
2173 else pragma Assert (Is_Entity_Name (Actual));
2174 Parm_Ent := Entity (Actual);
2178 (New_Occurrence_Of (Extra_Accessibility (Parm_Ent), Loc),
2179 Extra_Accessibility (Formal));
2182 elsif Is_Entity_Name (Prev_Orig) then
2184 -- When passing an access parameter, or a renaming of an access
2185 -- parameter, as the actual to another access parameter we need
2186 -- to pass along the actual's own access level parameter. This
2187 -- is done if we are within the scope of the formal access
2188 -- parameter (if this is an inlined body the extra formal is
2191 if (Is_Formal (Entity (Prev_Orig))
2193 (Present (Renamed_Object (Entity (Prev_Orig)))
2195 Is_Entity_Name (Renamed_Object (Entity (Prev_Orig)))
2198 (Entity (Renamed_Object (Entity (Prev_Orig))))))
2199 and then Ekind (Etype (Prev_Orig)) = E_Anonymous_Access_Type
2200 and then In_Open_Scopes (Scope (Entity (Prev_Orig)))
2203 Parm_Ent : constant Entity_Id := Param_Entity (Prev_Orig);
2206 pragma Assert (Present (Parm_Ent));
2208 if Present (Extra_Accessibility (Parm_Ent)) then
2211 (Extra_Accessibility (Parm_Ent), Loc),
2212 Extra_Accessibility (Formal));
2214 -- If the actual access parameter does not have an
2215 -- associated extra formal providing its scope level,
2216 -- then treat the actual as having library-level
2221 (Make_Integer_Literal (Loc,
2222 Intval => Scope_Depth (Standard_Standard)),
2223 Extra_Accessibility (Formal));
2227 -- The actual is a normal access value, so just pass the level
2228 -- of the actual's access type.
2232 (Make_Integer_Literal (Loc,
2233 Intval => Type_Access_Level (Etype (Prev_Orig))),
2234 Extra_Accessibility (Formal));
2237 -- All cases other than thunks
2240 case Nkind (Prev_Orig) is
2242 when N_Attribute_Reference =>
2243 case Get_Attribute_Id (Attribute_Name (Prev_Orig)) is
2245 -- For X'Access, pass on the level of the prefix X
2247 when Attribute_Access =>
2249 Make_Integer_Literal (Loc,
2251 Object_Access_Level (Prefix (Prev_Orig))),
2252 Extra_Accessibility (Formal));
2254 -- Treat the unchecked attributes as library-level
2256 when Attribute_Unchecked_Access |
2257 Attribute_Unrestricted_Access =>
2259 Make_Integer_Literal (Loc,
2260 Intval => Scope_Depth (Standard_Standard)),
2261 Extra_Accessibility (Formal));
2263 -- No other cases of attributes returning access
2264 -- values that can be passed to access parameters
2267 raise Program_Error;
2271 -- For allocators we pass the level of the execution of
2272 -- the called subprogram, which is one greater than the
2273 -- current scope level.
2277 Make_Integer_Literal (Loc,
2278 Scope_Depth (Current_Scope) + 1),
2279 Extra_Accessibility (Formal));
2281 -- For other cases we simply pass the level of the
2282 -- actual's access type.
2286 Make_Integer_Literal (Loc,
2287 Intval => Type_Access_Level (Etype (Prev_Orig))),
2288 Extra_Accessibility (Formal));
2294 -- Perform the check of 4.6(49) that prevents a null value from being
2295 -- passed as an actual to an access parameter. Note that the check is
2296 -- elided in the common cases of passing an access attribute or
2297 -- access parameter as an actual. Also, we currently don't enforce
2298 -- this check for expander-generated actuals and when -gnatdj is set.
2300 if Ada_Version >= Ada_05 then
2302 -- Ada 2005 (AI-231): Check null-excluding access types
2304 if Is_Access_Type (Etype (Formal))
2305 and then Can_Never_Be_Null (Etype (Formal))
2306 and then Nkind (Prev) /= N_Raise_Constraint_Error
2307 and then (Known_Null (Prev)
2308 or else not Can_Never_Be_Null (Etype (Prev)))
2310 Install_Null_Excluding_Check (Prev);
2313 -- Ada_Version < Ada_05
2316 if Ekind (Etype (Formal)) /= E_Anonymous_Access_Type
2317 or else Access_Checks_Suppressed (Subp)
2321 elsif Debug_Flag_J then
2324 elsif not Comes_From_Source (Prev) then
2327 elsif Is_Entity_Name (Prev)
2328 and then Ekind (Etype (Prev)) = E_Anonymous_Access_Type
2332 elsif Nkind_In (Prev, N_Allocator, N_Attribute_Reference) then
2335 -- Suppress null checks when passing to access parameters of Java
2336 -- and CIL subprograms. (Should this be done for other foreign
2337 -- conventions as well ???)
2339 elsif Convention (Subp) = Convention_Java
2340 or else Convention (Subp) = Convention_CIL
2345 Install_Null_Excluding_Check (Prev);
2349 -- Perform appropriate validity checks on parameters that
2352 if Validity_Checks_On then
2353 if (Ekind (Formal) = E_In_Parameter
2354 and then Validity_Check_In_Params)
2356 (Ekind (Formal) = E_In_Out_Parameter
2357 and then Validity_Check_In_Out_Params)
2359 -- If the actual is an indexed component of a packed type (or
2360 -- is an indexed or selected component whose prefix recursively
2361 -- meets this condition), it has not been expanded yet. It will
2362 -- be copied in the validity code that follows, and has to be
2363 -- expanded appropriately, so reanalyze it.
2365 -- What we do is just to unset analyzed bits on prefixes till
2366 -- we reach something that does not have a prefix.
2373 while Nkind_In (Nod, N_Indexed_Component,
2374 N_Selected_Component)
2376 Set_Analyzed (Nod, False);
2377 Nod := Prefix (Nod);
2381 Ensure_Valid (Actual);
2385 -- For IN OUT and OUT parameters, ensure that subscripts are valid
2386 -- since this is a left side reference. We only do this for calls
2387 -- from the source program since we assume that compiler generated
2388 -- calls explicitly generate any required checks. We also need it
2389 -- only if we are doing standard validity checks, since clearly it
2390 -- is not needed if validity checks are off, and in subscript
2391 -- validity checking mode, all indexed components are checked with
2392 -- a call directly from Expand_N_Indexed_Component.
2394 if Comes_From_Source (N)
2395 and then Ekind (Formal) /= E_In_Parameter
2396 and then Validity_Checks_On
2397 and then Validity_Check_Default
2398 and then not Validity_Check_Subscripts
2400 Check_Valid_Lvalue_Subscripts (Actual);
2403 -- Mark any scalar OUT parameter that is a simple variable as no
2404 -- longer known to be valid (unless the type is always valid). This
2405 -- reflects the fact that if an OUT parameter is never set in a
2406 -- procedure, then it can become invalid on the procedure return.
2408 if Ekind (Formal) = E_Out_Parameter
2409 and then Is_Entity_Name (Actual)
2410 and then Ekind (Entity (Actual)) = E_Variable
2411 and then not Is_Known_Valid (Etype (Actual))
2413 Set_Is_Known_Valid (Entity (Actual), False);
2416 -- For an OUT or IN OUT parameter, if the actual is an entity, then
2417 -- clear current values, since they can be clobbered. We are probably
2418 -- doing this in more places than we need to, but better safe than
2419 -- sorry when it comes to retaining bad current values!
2421 if Ekind (Formal) /= E_In_Parameter
2422 and then Is_Entity_Name (Actual)
2423 and then Present (Entity (Actual))
2426 Ent : constant Entity_Id := Entity (Actual);
2430 -- For an OUT or IN OUT parameter that is an assignable entity,
2431 -- we do not want to clobber the Last_Assignment field, since
2432 -- if it is set, it was precisely because it is indeed an OUT
2433 -- or IN OUT parameter!
2435 if (Ekind (Formal) = E_Out_Parameter
2437 Ekind (Formal) = E_In_Out_Parameter)
2438 and then Is_Assignable (Ent)
2440 Sav := Last_Assignment (Ent);
2441 Kill_Current_Values (Ent);
2442 Set_Last_Assignment (Ent, Sav);
2444 -- For all other cases, just kill the current values
2447 Kill_Current_Values (Ent);
2452 -- If the formal is class wide and the actual is an aggregate, force
2453 -- evaluation so that the back end who does not know about class-wide
2454 -- type, does not generate a temporary of the wrong size.
2456 if not Is_Class_Wide_Type (Etype (Formal)) then
2459 elsif Nkind (Actual) = N_Aggregate
2460 or else (Nkind (Actual) = N_Qualified_Expression
2461 and then Nkind (Expression (Actual)) = N_Aggregate)
2463 Force_Evaluation (Actual);
2466 -- In a remote call, if the formal is of a class-wide type, check
2467 -- that the actual meets the requirements described in E.4(18).
2469 if Remote and then Is_Class_Wide_Type (Etype (Formal)) then
2470 Insert_Action (Actual,
2471 Make_Transportable_Check (Loc,
2472 Duplicate_Subexpr_Move_Checks (Actual)));
2475 -- This label is required when skipping extra actual generation for
2476 -- Unchecked_Union parameters.
2478 <<Skip_Extra_Actual_Generation>>
2480 Param_Count := Param_Count + 1;
2481 Next_Actual (Actual);
2482 Next_Formal (Formal);
2485 -- If we are expanding a rhs of an assignment we need to check if tag
2486 -- propagation is needed. You might expect this processing to be in
2487 -- Analyze_Assignment but has to be done earlier (bottom-up) because the
2488 -- assignment might be transformed to a declaration for an unconstrained
2489 -- value if the expression is classwide.
2491 if Nkind (N) = N_Function_Call
2492 and then Is_Tag_Indeterminate (N)
2493 and then Is_Entity_Name (Name (N))
2496 Ass : Node_Id := Empty;
2499 if Nkind (Parent (N)) = N_Assignment_Statement then
2502 elsif Nkind (Parent (N)) = N_Qualified_Expression
2503 and then Nkind (Parent (Parent (N))) = N_Assignment_Statement
2505 Ass := Parent (Parent (N));
2507 elsif Nkind (Parent (N)) = N_Explicit_Dereference
2508 and then Nkind (Parent (Parent (N))) = N_Assignment_Statement
2510 Ass := Parent (Parent (N));
2514 and then Is_Class_Wide_Type (Etype (Name (Ass)))
2516 if Is_Access_Type (Etype (N)) then
2517 if Designated_Type (Etype (N)) /=
2518 Root_Type (Etype (Name (Ass)))
2521 ("tag-indeterminate expression "
2522 & " must have designated type& (RM 5.2 (6))",
2523 N, Root_Type (Etype (Name (Ass))));
2525 Propagate_Tag (Name (Ass), N);
2528 elsif Etype (N) /= Root_Type (Etype (Name (Ass))) then
2530 ("tag-indeterminate expression must have type&"
2531 & "(RM 5.2 (6))", N, Root_Type (Etype (Name (Ass))));
2534 Propagate_Tag (Name (Ass), N);
2537 -- The call will be rewritten as a dispatching call, and
2538 -- expanded as such.
2545 -- Ada 2005 (AI-251): If some formal is a class-wide interface, expand
2546 -- it to point to the correct secondary virtual table
2548 if Nkind_In (N, N_Function_Call, N_Procedure_Call_Statement)
2549 and then CW_Interface_Formals_Present
2551 Expand_Interface_Actuals (N);
2554 -- Deals with Dispatch_Call if we still have a call, before expanding
2555 -- extra actuals since this will be done on the re-analysis of the
2556 -- dispatching call. Note that we do not try to shorten the actual
2557 -- list for a dispatching call, it would not make sense to do so.
2558 -- Expansion of dispatching calls is suppressed when VM_Target, because
2559 -- the VM back-ends directly handle the generation of dispatching
2560 -- calls and would have to undo any expansion to an indirect call.
2562 if Nkind_In (N, N_Function_Call, N_Procedure_Call_Statement)
2563 and then Present (Controlling_Argument (N))
2565 if VM_Target = No_VM then
2566 Expand_Dispatching_Call (N);
2568 -- The following return is worrisome. Is it really OK to
2569 -- skip all remaining processing in this procedure ???
2573 -- Expansion of a dispatching call results in an indirect call, which
2574 -- in turn causes current values to be killed (see Resolve_Call), so
2575 -- on VM targets we do the call here to ensure consistent warnings
2576 -- between VM and non-VM targets.
2579 Kill_Current_Values;
2583 -- Similarly, expand calls to RCI subprograms on which pragma
2584 -- All_Calls_Remote applies. The rewriting will be reanalyzed
2585 -- later. Do this only when the call comes from source since we do
2586 -- not want such a rewriting to occur in expanded code.
2588 if Is_All_Remote_Call (N) then
2589 Expand_All_Calls_Remote_Subprogram_Call (N);
2591 -- Similarly, do not add extra actuals for an entry call whose entity
2592 -- is a protected procedure, or for an internal protected subprogram
2593 -- call, because it will be rewritten as a protected subprogram call
2594 -- and reanalyzed (see Expand_Protected_Subprogram_Call).
2596 elsif Is_Protected_Type (Scope (Subp))
2597 and then (Ekind (Subp) = E_Procedure
2598 or else Ekind (Subp) = E_Function)
2602 -- During that loop we gathered the extra actuals (the ones that
2603 -- correspond to Extra_Formals), so now they can be appended.
2606 while Is_Non_Empty_List (Extra_Actuals) loop
2607 Add_Actual_Parameter (Remove_Head (Extra_Actuals));
2611 -- At this point we have all the actuals, so this is the point at
2612 -- which the various expansion activities for actuals is carried out.
2614 Expand_Actuals (N, Subp);
2616 -- If the subprogram is a renaming, or if it is inherited, replace it
2617 -- in the call with the name of the actual subprogram being called.
2618 -- If this is a dispatching call, the run-time decides what to call.
2619 -- The Alias attribute does not apply to entries.
2621 if Nkind (N) /= N_Entry_Call_Statement
2622 and then No (Controlling_Argument (N))
2623 and then Present (Parent_Subp)
2625 if Present (Inherited_From_Formal (Subp)) then
2626 Parent_Subp := Inherited_From_Formal (Subp);
2628 while Present (Alias (Parent_Subp)) loop
2629 Parent_Subp := Alias (Parent_Subp);
2633 -- The below setting of Entity is suspect, see F109-018 discussion???
2635 Set_Entity (Name (N), Parent_Subp);
2637 if Is_Abstract_Subprogram (Parent_Subp)
2638 and then not In_Instance
2641 ("cannot call abstract subprogram &!", Name (N), Parent_Subp);
2644 -- Inspect all formals of derived subprogram Subp. Compare parameter
2645 -- types with the parent subprogram and check whether an actual may
2646 -- need a type conversion to the corresponding formal of the parent
2649 -- Not clear whether intrinsic subprograms need such conversions. ???
2651 if not Is_Intrinsic_Subprogram (Parent_Subp)
2652 or else Is_Generic_Instance (Parent_Subp)
2655 procedure Convert (Act : Node_Id; Typ : Entity_Id);
2656 -- Rewrite node Act as a type conversion of Act to Typ. Analyze
2657 -- and resolve the newly generated construct.
2663 procedure Convert (Act : Node_Id; Typ : Entity_Id) is
2665 Rewrite (Act, OK_Convert_To (Typ, Relocate_Node (Act)));
2672 Actual_Typ : Entity_Id;
2673 Formal_Typ : Entity_Id;
2674 Parent_Typ : Entity_Id;
2677 Actual := First_Actual (N);
2678 Formal := First_Formal (Subp);
2679 Parent_Formal := First_Formal (Parent_Subp);
2680 while Present (Formal) loop
2681 Actual_Typ := Etype (Actual);
2682 Formal_Typ := Etype (Formal);
2683 Parent_Typ := Etype (Parent_Formal);
2685 -- For an IN parameter of a scalar type, the parent formal
2686 -- type and derived formal type differ or the parent formal
2687 -- type and actual type do not match statically.
2689 if Is_Scalar_Type (Formal_Typ)
2690 and then Ekind (Formal) = E_In_Parameter
2691 and then Formal_Typ /= Parent_Typ
2693 not Subtypes_Statically_Match (Parent_Typ, Actual_Typ)
2694 and then not Raises_Constraint_Error (Actual)
2696 Convert (Actual, Parent_Typ);
2697 Enable_Range_Check (Actual);
2699 -- For access types, the parent formal type and actual type
2702 elsif Is_Access_Type (Formal_Typ)
2703 and then Base_Type (Parent_Typ) /= Base_Type (Actual_Typ)
2705 if Ekind (Formal) /= E_In_Parameter then
2706 Convert (Actual, Parent_Typ);
2708 elsif Ekind (Parent_Typ) = E_Anonymous_Access_Type
2709 and then Designated_Type (Parent_Typ) /=
2710 Designated_Type (Actual_Typ)
2711 and then not Is_Controlling_Formal (Formal)
2713 -- This unchecked conversion is not necessary unless
2714 -- inlining is enabled, because in that case the type
2715 -- mismatch may become visible in the body about to be
2719 Unchecked_Convert_To (Parent_Typ,
2720 Relocate_Node (Actual)));
2723 Resolve (Actual, Parent_Typ);
2726 -- For array and record types, the parent formal type and
2727 -- derived formal type have different sizes or pragma Pack
2730 elsif ((Is_Array_Type (Formal_Typ)
2731 and then Is_Array_Type (Parent_Typ))
2733 (Is_Record_Type (Formal_Typ)
2734 and then Is_Record_Type (Parent_Typ)))
2736 (Esize (Formal_Typ) /= Esize (Parent_Typ)
2737 or else Has_Pragma_Pack (Formal_Typ) /=
2738 Has_Pragma_Pack (Parent_Typ))
2740 Convert (Actual, Parent_Typ);
2743 Next_Actual (Actual);
2744 Next_Formal (Formal);
2745 Next_Formal (Parent_Formal);
2751 Subp := Parent_Subp;
2754 -- Check for violation of No_Abort_Statements
2756 if Is_RTE (Subp, RE_Abort_Task) then
2757 Check_Restriction (No_Abort_Statements, N);
2759 -- Check for violation of No_Dynamic_Attachment
2761 elsif RTU_Loaded (Ada_Interrupts)
2762 and then (Is_RTE (Subp, RE_Is_Reserved) or else
2763 Is_RTE (Subp, RE_Is_Attached) or else
2764 Is_RTE (Subp, RE_Current_Handler) or else
2765 Is_RTE (Subp, RE_Attach_Handler) or else
2766 Is_RTE (Subp, RE_Exchange_Handler) or else
2767 Is_RTE (Subp, RE_Detach_Handler) or else
2768 Is_RTE (Subp, RE_Reference))
2770 Check_Restriction (No_Dynamic_Attachment, N);
2773 -- Deal with case where call is an explicit dereference
2775 if Nkind (Name (N)) = N_Explicit_Dereference then
2777 -- Handle case of access to protected subprogram type
2779 if Is_Access_Protected_Subprogram_Type
2780 (Base_Type (Etype (Prefix (Name (N)))))
2782 -- If this is a call through an access to protected operation,
2783 -- the prefix has the form (object'address, operation'access).
2784 -- Rewrite as a for other protected calls: the object is the
2785 -- first parameter of the list of actuals.
2792 Ptr : constant Node_Id := Prefix (Name (N));
2794 T : constant Entity_Id :=
2795 Equivalent_Type (Base_Type (Etype (Ptr)));
2797 D_T : constant Entity_Id :=
2798 Designated_Type (Base_Type (Etype (Ptr)));
2802 Make_Selected_Component (Loc,
2803 Prefix => Unchecked_Convert_To (T, Ptr),
2805 New_Occurrence_Of (First_Entity (T), Loc));
2808 Make_Selected_Component (Loc,
2809 Prefix => Unchecked_Convert_To (T, Ptr),
2811 New_Occurrence_Of (Next_Entity (First_Entity (T)), Loc));
2814 Make_Explicit_Dereference (Loc,
2817 if Present (Parameter_Associations (N)) then
2818 Parm := Parameter_Associations (N);
2823 Prepend (Obj, Parm);
2825 if Etype (D_T) = Standard_Void_Type then
2827 Make_Procedure_Call_Statement (Loc,
2829 Parameter_Associations => Parm);
2832 Make_Function_Call (Loc,
2834 Parameter_Associations => Parm);
2837 Set_First_Named_Actual (Call, First_Named_Actual (N));
2838 Set_Etype (Call, Etype (D_T));
2840 -- We do not re-analyze the call to avoid infinite recursion.
2841 -- We analyze separately the prefix and the object, and set
2842 -- the checks on the prefix that would otherwise be emitted
2843 -- when resolving a call.
2847 Apply_Access_Check (Nam);
2854 -- If this is a call to an intrinsic subprogram, then perform the
2855 -- appropriate expansion to the corresponding tree node and we
2856 -- are all done (since after that the call is gone!)
2858 -- In the case where the intrinsic is to be processed by the back end,
2859 -- the call to Expand_Intrinsic_Call will do nothing, which is fine,
2860 -- since the idea in this case is to pass the call unchanged.
2861 -- If the intrinsic is an inherited unchecked conversion, and the
2862 -- derived type is the target type of the conversion, we must retain
2863 -- it as the return type of the expression. Otherwise the expansion
2864 -- below, which uses the parent operation, will yield the wrong type.
2866 if Is_Intrinsic_Subprogram (Subp) then
2867 Expand_Intrinsic_Call (N, Subp);
2869 if Nkind (N) = N_Unchecked_Type_Conversion
2870 and then Parent_Subp /= Orig_Subp
2871 and then Etype (Parent_Subp) /= Etype (Orig_Subp)
2873 Set_Etype (N, Etype (Orig_Subp));
2879 if Ekind (Subp) = E_Function
2880 or else Ekind (Subp) = E_Procedure
2882 if Is_Inlined (Subp) then
2884 Inlined_Subprogram : declare
2886 Must_Inline : Boolean := False;
2887 Spec : constant Node_Id := Unit_Declaration_Node (Subp);
2888 Scop : constant Entity_Id := Scope (Subp);
2890 function In_Unfrozen_Instance return Boolean;
2891 -- If the subprogram comes from an instance in the same
2892 -- unit, and the instance is not yet frozen, inlining might
2893 -- trigger order-of-elaboration problems in gigi.
2895 --------------------------
2896 -- In_Unfrozen_Instance --
2897 --------------------------
2899 function In_Unfrozen_Instance return Boolean is
2905 and then S /= Standard_Standard
2907 if Is_Generic_Instance (S)
2908 and then Present (Freeze_Node (S))
2909 and then not Analyzed (Freeze_Node (S))
2918 end In_Unfrozen_Instance;
2920 -- Start of processing for Inlined_Subprogram
2923 -- Verify that the body to inline has already been seen, and
2924 -- that if the body is in the current unit the inlining does
2925 -- not occur earlier. This avoids order-of-elaboration problems
2928 -- This should be documented in sinfo/einfo ???
2931 or else Nkind (Spec) /= N_Subprogram_Declaration
2932 or else No (Body_To_Inline (Spec))
2934 Must_Inline := False;
2936 -- If this an inherited function that returns a private
2937 -- type, do not inline if the full view is an unconstrained
2938 -- array, because such calls cannot be inlined.
2940 elsif Present (Orig_Subp)
2941 and then Is_Array_Type (Etype (Orig_Subp))
2942 and then not Is_Constrained (Etype (Orig_Subp))
2944 Must_Inline := False;
2946 elsif In_Unfrozen_Instance then
2947 Must_Inline := False;
2950 Bod := Body_To_Inline (Spec);
2952 if (In_Extended_Main_Code_Unit (N)
2953 or else In_Extended_Main_Code_Unit (Parent (N))
2954 or else Has_Pragma_Inline_Always (Subp))
2955 and then (not In_Same_Extended_Unit (Sloc (Bod), Loc)
2957 Earlier_In_Extended_Unit (Sloc (Bod), Loc))
2959 Must_Inline := True;
2961 -- If we are compiling a package body that is not the main
2962 -- unit, it must be for inlining/instantiation purposes,
2963 -- in which case we inline the call to insure that the same
2964 -- temporaries are generated when compiling the body by
2965 -- itself. Otherwise link errors can occur.
2967 -- If the function being called is itself in the main unit,
2968 -- we cannot inline, because there is a risk of double
2969 -- elaboration and/or circularity: the inlining can make
2970 -- visible a private entity in the body of the main unit,
2971 -- that gigi will see before its sees its proper definition.
2973 elsif not (In_Extended_Main_Code_Unit (N))
2974 and then In_Package_Body
2976 Must_Inline := not In_Extended_Main_Source_Unit (Subp);
2981 Expand_Inlined_Call (N, Subp, Orig_Subp);
2984 -- Let the back end handle it
2986 Add_Inlined_Body (Subp);
2988 if Front_End_Inlining
2989 and then Nkind (Spec) = N_Subprogram_Declaration
2990 and then (In_Extended_Main_Code_Unit (N))
2991 and then No (Body_To_Inline (Spec))
2992 and then not Has_Completion (Subp)
2993 and then In_Same_Extended_Unit (Sloc (Spec), Loc)
2996 ("cannot inline& (body not seen yet)?",
3000 end Inlined_Subprogram;
3004 -- Check for a protected subprogram. This is either an intra-object
3005 -- call, or a protected function call. Protected procedure calls are
3006 -- rewritten as entry calls and handled accordingly.
3008 -- In Ada 2005, this may be an indirect call to an access parameter
3009 -- that is an access_to_subprogram. In that case the anonymous type
3010 -- has a scope that is a protected operation, but the call is a
3013 Scop := Scope (Subp);
3015 if Nkind (N) /= N_Entry_Call_Statement
3016 and then Is_Protected_Type (Scop)
3017 and then Ekind (Subp) /= E_Subprogram_Type
3019 -- If the call is an internal one, it is rewritten as a call to
3020 -- to the corresponding unprotected subprogram.
3022 Expand_Protected_Subprogram_Call (N, Subp, Scop);
3025 -- Functions returning controlled objects need special attention
3026 -- If the return type is limited the context is an initialization
3027 -- and different processing applies.
3029 if Controlled_Type (Etype (Subp))
3030 and then not Is_Inherently_Limited_Type (Etype (Subp))
3031 and then not Is_Limited_Interface (Etype (Subp))
3033 Expand_Ctrl_Function_Call (N);
3036 -- Test for First_Optional_Parameter, and if so, truncate parameter
3037 -- list if there are optional parameters at the trailing end.
3038 -- Note we never delete procedures for call via a pointer.
3040 if (Ekind (Subp) = E_Procedure or else Ekind (Subp) = E_Function)
3041 and then Present (First_Optional_Parameter (Subp))
3044 Last_Keep_Arg : Node_Id;
3047 -- Last_Keep_Arg will hold the last actual that should be
3048 -- retained. If it remains empty at the end, it means that
3049 -- all parameters are optional.
3051 Last_Keep_Arg := Empty;
3053 -- Find first optional parameter, must be present since we
3054 -- checked the validity of the parameter before setting it.
3056 Formal := First_Formal (Subp);
3057 Actual := First_Actual (N);
3058 while Formal /= First_Optional_Parameter (Subp) loop
3059 Last_Keep_Arg := Actual;
3060 Next_Formal (Formal);
3061 Next_Actual (Actual);
3064 -- We have Formal and Actual pointing to the first potentially
3065 -- droppable argument. We can drop all the trailing arguments
3066 -- whose actual matches the default. Note that we know that all
3067 -- remaining formals have defaults, because we checked that this
3068 -- requirement was met before setting First_Optional_Parameter.
3070 -- We use Fully_Conformant_Expressions to check for identity
3071 -- between formals and actuals, which may miss some cases, but
3072 -- on the other hand, this is only an optimization (if we fail
3073 -- to truncate a parameter it does not affect functionality).
3074 -- So if the default is 3 and the actual is 1+2, we consider
3075 -- them unequal, which hardly seems worrisome.
3077 while Present (Formal) loop
3078 if not Fully_Conformant_Expressions
3079 (Actual, Default_Value (Formal))
3081 Last_Keep_Arg := Actual;
3084 Next_Formal (Formal);
3085 Next_Actual (Actual);
3088 -- If no arguments, delete entire list, this is the easy case
3090 if No (Last_Keep_Arg) then
3091 Set_Parameter_Associations (N, No_List);
3092 Set_First_Named_Actual (N, Empty);
3094 -- Case where at the last retained argument is positional. This
3095 -- is also an easy case, since the retained arguments are already
3096 -- in the right form, and we don't need to worry about the order
3097 -- of arguments that get eliminated.
3099 elsif Is_List_Member (Last_Keep_Arg) then
3100 while Present (Next (Last_Keep_Arg)) loop
3101 Discard_Node (Remove_Next (Last_Keep_Arg));
3104 Set_First_Named_Actual (N, Empty);
3106 -- This is the annoying case where the last retained argument
3107 -- is a named parameter. Since the original arguments are not
3108 -- in declaration order, we may have to delete some fairly
3109 -- random collection of arguments.
3117 -- First step, remove all the named parameters from the
3118 -- list (they are still chained using First_Named_Actual
3119 -- and Next_Named_Actual, so we have not lost them!)
3121 Temp := First (Parameter_Associations (N));
3123 -- Case of all parameters named, remove them all
3125 if Nkind (Temp) = N_Parameter_Association then
3126 while Is_Non_Empty_List (Parameter_Associations (N)) loop
3127 Temp := Remove_Head (Parameter_Associations (N));
3130 -- Case of mixed positional/named, remove named parameters
3133 while Nkind (Next (Temp)) /= N_Parameter_Association loop
3137 while Present (Next (Temp)) loop
3138 Remove (Next (Temp));
3142 -- Now we loop through the named parameters, till we get
3143 -- to the last one to be retained, adding them to the list.
3144 -- Note that the Next_Named_Actual list does not need to be
3145 -- touched since we are only reordering them on the actual
3146 -- parameter association list.
3148 Passoc := Parent (First_Named_Actual (N));
3150 Temp := Relocate_Node (Passoc);
3152 (Parameter_Associations (N), Temp);
3154 Last_Keep_Arg = Explicit_Actual_Parameter (Passoc);
3155 Passoc := Parent (Next_Named_Actual (Passoc));
3158 Set_Next_Named_Actual (Temp, Empty);
3161 Temp := Next_Named_Actual (Passoc);
3162 exit when No (Temp);
3163 Set_Next_Named_Actual
3164 (Passoc, Next_Named_Actual (Parent (Temp)));
3172 --------------------------
3173 -- Expand_Inlined_Call --
3174 --------------------------
3176 procedure Expand_Inlined_Call
3179 Orig_Subp : Entity_Id)
3181 Loc : constant Source_Ptr := Sloc (N);
3182 Is_Predef : constant Boolean :=
3183 Is_Predefined_File_Name
3184 (Unit_File_Name (Get_Source_Unit (Subp)));
3185 Orig_Bod : constant Node_Id :=
3186 Body_To_Inline (Unit_Declaration_Node (Subp));
3191 Decls : constant List_Id := New_List;
3192 Exit_Lab : Entity_Id := Empty;
3199 Ret_Type : Entity_Id;
3203 Temp_Typ : Entity_Id;
3205 Is_Unc : constant Boolean :=
3206 Is_Array_Type (Etype (Subp))
3207 and then not Is_Constrained (Etype (Subp));
3208 -- If the type returned by the function is unconstrained and the
3209 -- call can be inlined, special processing is required.
3211 function Is_Null_Procedure return Boolean;
3212 -- Predicate to recognize stubbed procedures and null procedures, for
3213 -- which there is no need for the full inlining mechanism.
3215 procedure Make_Exit_Label;
3216 -- Build declaration for exit label to be used in Return statements
3218 function Process_Formals (N : Node_Id) return Traverse_Result;
3219 -- Replace occurrence of a formal with the corresponding actual, or
3220 -- the thunk generated for it.
3222 function Process_Sloc (Nod : Node_Id) return Traverse_Result;
3223 -- If the call being expanded is that of an internal subprogram,
3224 -- set the sloc of the generated block to that of the call itself,
3225 -- so that the expansion is skipped by the -next- command in gdb.
3226 -- Same processing for a subprogram in a predefined file, e.g.
3227 -- Ada.Tags. If Debug_Generated_Code is true, suppress this change
3228 -- to simplify our own development.
3230 procedure Rewrite_Function_Call (N : Node_Id; Blk : Node_Id);
3231 -- If the function body is a single expression, replace call with
3232 -- expression, else insert block appropriately.
3234 procedure Rewrite_Procedure_Call (N : Node_Id; Blk : Node_Id);
3235 -- If procedure body has no local variables, inline body without
3236 -- creating block, otherwise rewrite call with block.
3238 function Formal_Is_Used_Once (Formal : Entity_Id) return Boolean;
3239 -- Determine whether a formal parameter is used only once in Orig_Bod
3241 -----------------------
3242 -- Is_Null_Procedure --
3243 -----------------------
3245 function Is_Null_Procedure return Boolean is
3246 Decl : constant Node_Id := Unit_Declaration_Node (Subp);
3249 if Ekind (Subp) /= E_Procedure then
3252 elsif Nkind (Orig_Bod) /= N_Subprogram_Body then
3255 -- Check if this is an Ada 2005 null procedure
3257 elsif Nkind (Decl) = N_Subprogram_Declaration
3258 and then Null_Present (Specification (Decl))
3262 -- Check if the body contains only a null statement, followed by the
3263 -- return statement added during expansion.
3267 Stat : constant Node_Id :=
3269 (Statements (Handled_Statement_Sequence (Orig_Bod)));
3271 Stat2 : constant Node_Id := Next (Stat);
3275 Nkind (Stat) = N_Null_Statement
3279 (Nkind (Stat2) = N_Simple_Return_Statement
3280 and then No (Next (Stat2))));
3283 end Is_Null_Procedure;
3285 ---------------------
3286 -- Make_Exit_Label --
3287 ---------------------
3289 procedure Make_Exit_Label is
3291 -- Create exit label for subprogram if one does not exist yet
3293 if No (Exit_Lab) then
3295 Make_Identifier (Loc,
3296 Chars => New_Internal_Name ('L'));
3298 Make_Defining_Identifier (Loc, Chars (Lab_Id)));
3299 Exit_Lab := Make_Label (Loc, Lab_Id);
3302 Make_Implicit_Label_Declaration (Loc,
3303 Defining_Identifier => Entity (Lab_Id),
3304 Label_Construct => Exit_Lab);
3306 end Make_Exit_Label;
3308 ---------------------
3309 -- Process_Formals --
3310 ---------------------
3312 function Process_Formals (N : Node_Id) return Traverse_Result is
3318 if Is_Entity_Name (N)
3319 and then Present (Entity (N))
3324 and then Scope (E) = Subp
3326 A := Renamed_Object (E);
3328 -- Rewrite the occurrence of the formal into an occurrence of
3329 -- the actual. Also establish visibility on the proper view of
3330 -- the actual's subtype for the body's context (if the actual's
3331 -- subtype is private at the call point but its full view is
3332 -- visible to the body, then the inlined tree here must be
3333 -- analyzed with the full view).
3335 if Is_Entity_Name (A) then
3336 Rewrite (N, New_Occurrence_Of (Entity (A), Loc));
3337 Check_Private_View (N);
3339 elsif Nkind (A) = N_Defining_Identifier then
3340 Rewrite (N, New_Occurrence_Of (A, Loc));
3341 Check_Private_View (N);
3346 Rewrite (N, New_Copy (A));
3352 elsif Nkind (N) = N_Simple_Return_Statement then
3353 if No (Expression (N)) then
3356 Make_Goto_Statement (Loc,
3357 Name => New_Copy (Lab_Id)));
3360 if Nkind (Parent (N)) = N_Handled_Sequence_Of_Statements
3361 and then Nkind (Parent (Parent (N))) = N_Subprogram_Body
3363 -- Function body is a single expression. No need for
3369 Num_Ret := Num_Ret + 1;
3373 -- Because of the presence of private types, the views of the
3374 -- expression and the context may be different, so place an
3375 -- unchecked conversion to the context type to avoid spurious
3376 -- errors, e.g. when the expression is a numeric literal and
3377 -- the context is private. If the expression is an aggregate,
3378 -- use a qualified expression, because an aggregate is not a
3379 -- legal argument of a conversion.
3381 if Nkind_In (Expression (N), N_Aggregate, N_Null) then
3383 Make_Qualified_Expression (Sloc (N),
3384 Subtype_Mark => New_Occurrence_Of (Ret_Type, Sloc (N)),
3385 Expression => Relocate_Node (Expression (N)));
3388 Unchecked_Convert_To
3389 (Ret_Type, Relocate_Node (Expression (N)));
3392 if Nkind (Targ) = N_Defining_Identifier then
3394 Make_Assignment_Statement (Loc,
3395 Name => New_Occurrence_Of (Targ, Loc),
3396 Expression => Ret));
3399 Make_Assignment_Statement (Loc,
3400 Name => New_Copy (Targ),
3401 Expression => Ret));
3404 Set_Assignment_OK (Name (N));
3406 if Present (Exit_Lab) then
3408 Make_Goto_Statement (Loc,
3409 Name => New_Copy (Lab_Id)));
3415 -- Remove pragma Unreferenced since it may refer to formals that
3416 -- are not visible in the inlined body, and in any case we will
3417 -- not be posting warnings on the inlined body so it is unneeded.
3419 elsif Nkind (N) = N_Pragma
3420 and then Pragma_Name (N) = Name_Unreferenced
3422 Rewrite (N, Make_Null_Statement (Sloc (N)));
3428 end Process_Formals;
3430 procedure Replace_Formals is new Traverse_Proc (Process_Formals);
3436 function Process_Sloc (Nod : Node_Id) return Traverse_Result is
3438 if not Debug_Generated_Code then
3439 Set_Sloc (Nod, Sloc (N));
3440 Set_Comes_From_Source (Nod, False);
3446 procedure Reset_Slocs is new Traverse_Proc (Process_Sloc);
3448 ---------------------------
3449 -- Rewrite_Function_Call --
3450 ---------------------------
3452 procedure Rewrite_Function_Call (N : Node_Id; Blk : Node_Id) is
3453 HSS : constant Node_Id := Handled_Statement_Sequence (Blk);
3454 Fst : constant Node_Id := First (Statements (HSS));
3457 -- Optimize simple case: function body is a single return statement,
3458 -- which has been expanded into an assignment.
3460 if Is_Empty_List (Declarations (Blk))
3461 and then Nkind (Fst) = N_Assignment_Statement
3462 and then No (Next (Fst))
3465 -- The function call may have been rewritten as the temporary
3466 -- that holds the result of the call, in which case remove the
3467 -- now useless declaration.
3469 if Nkind (N) = N_Identifier
3470 and then Nkind (Parent (Entity (N))) = N_Object_Declaration
3472 Rewrite (Parent (Entity (N)), Make_Null_Statement (Loc));
3475 Rewrite (N, Expression (Fst));
3477 elsif Nkind (N) = N_Identifier
3478 and then Nkind (Parent (Entity (N))) = N_Object_Declaration
3480 -- The block assigns the result of the call to the temporary
3482 Insert_After (Parent (Entity (N)), Blk);
3484 elsif Nkind (Parent (N)) = N_Assignment_Statement
3486 (Is_Entity_Name (Name (Parent (N)))
3488 (Nkind (Name (Parent (N))) = N_Explicit_Dereference
3489 and then Is_Entity_Name (Prefix (Name (Parent (N))))))
3491 -- Replace assignment with the block
3494 Original_Assignment : constant Node_Id := Parent (N);
3497 -- Preserve the original assignment node to keep the complete
3498 -- assignment subtree consistent enough for Analyze_Assignment
3499 -- to proceed (specifically, the original Lhs node must still
3500 -- have an assignment statement as its parent).
3502 -- We cannot rely on Original_Node to go back from the block
3503 -- node to the assignment node, because the assignment might
3504 -- already be a rewrite substitution.
3506 Discard_Node (Relocate_Node (Original_Assignment));
3507 Rewrite (Original_Assignment, Blk);
3510 elsif Nkind (Parent (N)) = N_Object_Declaration then
3511 Set_Expression (Parent (N), Empty);
3512 Insert_After (Parent (N), Blk);
3515 Insert_Before (Parent (N), Blk);
3517 end Rewrite_Function_Call;
3519 ----------------------------
3520 -- Rewrite_Procedure_Call --
3521 ----------------------------
3523 procedure Rewrite_Procedure_Call (N : Node_Id; Blk : Node_Id) is
3524 HSS : constant Node_Id := Handled_Statement_Sequence (Blk);
3526 -- If there is a transient scope for N, this will be the scope of the
3527 -- actions for N, and the statements in Blk need to be within this
3528 -- scope. For example, they need to have visibility on the constant
3529 -- declarations created for the formals.
3531 -- If N needs no transient scope, and if there are no declarations in
3532 -- the inlined body, we can do a little optimization and insert the
3533 -- statements for the body directly after N, and rewrite N to a
3534 -- null statement, instead of rewriting N into a full-blown block
3537 if not Scope_Is_Transient
3538 and then Is_Empty_List (Declarations (Blk))
3540 Insert_List_After (N, Statements (HSS));
3541 Rewrite (N, Make_Null_Statement (Loc));
3545 end Rewrite_Procedure_Call;
3547 -------------------------
3548 -- Formal_Is_Used_Once --
3549 -------------------------
3551 function Formal_Is_Used_Once (Formal : Entity_Id) return Boolean is
3552 Use_Counter : Int := 0;
3554 function Count_Uses (N : Node_Id) return Traverse_Result;
3555 -- Traverse the tree and count the uses of the formal parameter.
3556 -- In this case, for optimization purposes, we do not need to
3557 -- continue the traversal once more than one use is encountered.
3563 function Count_Uses (N : Node_Id) return Traverse_Result is
3565 -- The original node is an identifier
3567 if Nkind (N) = N_Identifier
3568 and then Present (Entity (N))
3570 -- Original node's entity points to the one in the copied body
3572 and then Nkind (Entity (N)) = N_Identifier
3573 and then Present (Entity (Entity (N)))
3575 -- The entity of the copied node is the formal parameter
3577 and then Entity (Entity (N)) = Formal
3579 Use_Counter := Use_Counter + 1;
3581 if Use_Counter > 1 then
3583 -- Denote more than one use and abandon the traversal
3594 procedure Count_Formal_Uses is new Traverse_Proc (Count_Uses);
3596 -- Start of processing for Formal_Is_Used_Once
3599 Count_Formal_Uses (Orig_Bod);
3600 return Use_Counter = 1;
3601 end Formal_Is_Used_Once;
3603 -- Start of processing for Expand_Inlined_Call
3606 -- Check for special case of To_Address call, and if so, just do an
3607 -- unchecked conversion instead of expanding the call. Not only is this
3608 -- more efficient, but it also avoids problem with order of elaboration
3609 -- when address clauses are inlined (address expression elaborated at
3612 if Subp = RTE (RE_To_Address) then
3614 Unchecked_Convert_To
3616 Relocate_Node (First_Actual (N))));
3619 elsif Is_Null_Procedure then
3620 Rewrite (N, Make_Null_Statement (Loc));
3624 -- Check for an illegal attempt to inline a recursive procedure. If the
3625 -- subprogram has parameters this is detected when trying to supply a
3626 -- binding for parameters that already have one. For parameterless
3627 -- subprograms this must be done explicitly.
3629 if In_Open_Scopes (Subp) then
3630 Error_Msg_N ("call to recursive subprogram cannot be inlined?", N);
3631 Set_Is_Inlined (Subp, False);
3635 if Nkind (Orig_Bod) = N_Defining_Identifier
3636 or else Nkind (Orig_Bod) = N_Defining_Operator_Symbol
3638 -- Subprogram is a renaming_as_body. Calls appearing after the
3639 -- renaming can be replaced with calls to the renamed entity
3640 -- directly, because the subprograms are subtype conformant. If
3641 -- the renamed subprogram is an inherited operation, we must redo
3642 -- the expansion because implicit conversions may be needed.
3644 Set_Name (N, New_Occurrence_Of (Orig_Bod, Loc));
3646 if Present (Alias (Orig_Bod)) then
3653 -- Use generic machinery to copy body of inlined subprogram, as if it
3654 -- were an instantiation, resetting source locations appropriately, so
3655 -- that nested inlined calls appear in the main unit.
3657 Save_Env (Subp, Empty);
3658 Set_Copied_Sloc_For_Inlined_Body (N, Defining_Entity (Orig_Bod));
3660 Bod := Copy_Generic_Node (Orig_Bod, Empty, Instantiating => True);
3662 Make_Block_Statement (Loc,
3663 Declarations => Declarations (Bod),
3664 Handled_Statement_Sequence => Handled_Statement_Sequence (Bod));
3666 if No (Declarations (Bod)) then
3667 Set_Declarations (Blk, New_List);
3670 -- For the unconstrained case, capture the name of the local
3671 -- variable that holds the result. This must be the first declaration
3672 -- in the block, because its bounds cannot depend on local variables.
3673 -- Otherwise there is no way to declare the result outside of the
3674 -- block. Needless to say, in general the bounds will depend on the
3675 -- actuals in the call.
3678 Targ1 := Defining_Identifier (First (Declarations (Blk)));
3681 -- If this is a derived function, establish the proper return type
3683 if Present (Orig_Subp)
3684 and then Orig_Subp /= Subp
3686 Ret_Type := Etype (Orig_Subp);
3688 Ret_Type := Etype (Subp);
3691 -- Create temporaries for the actuals that are expressions, or that
3692 -- are scalars and require copying to preserve semantics.
3694 F := First_Formal (Subp);
3695 A := First_Actual (N);
3696 while Present (F) loop
3697 if Present (Renamed_Object (F)) then
3698 Error_Msg_N ("cannot inline call to recursive subprogram", N);
3702 -- If the argument may be a controlling argument in a call within
3703 -- the inlined body, we must preserve its classwide nature to insure
3704 -- that dynamic dispatching take place subsequently. If the formal
3705 -- has a constraint it must be preserved to retain the semantics of
3708 if Is_Class_Wide_Type (Etype (F))
3709 or else (Is_Access_Type (Etype (F))
3711 Is_Class_Wide_Type (Designated_Type (Etype (F))))
3713 Temp_Typ := Etype (F);
3715 elsif Base_Type (Etype (F)) = Base_Type (Etype (A))
3716 and then Etype (F) /= Base_Type (Etype (F))
3718 Temp_Typ := Etype (F);
3721 Temp_Typ := Etype (A);
3724 -- If the actual is a simple name or a literal, no need to
3725 -- create a temporary, object can be used directly.
3727 -- If the actual is a literal and the formal has its address taken,
3728 -- we cannot pass the literal itself as an argument, so its value
3729 -- must be captured in a temporary.
3731 if (Is_Entity_Name (A)
3733 (not Is_Scalar_Type (Etype (A))
3734 or else Ekind (Entity (A)) = E_Enumeration_Literal))
3736 -- When the actual is an identifier and the corresponding formal
3737 -- is used only once in the original body, the formal can be
3738 -- substituted directly with the actual parameter.
3740 or else (Nkind (A) = N_Identifier
3741 and then Formal_Is_Used_Once (F))
3744 (Nkind_In (A, N_Real_Literal,
3746 N_Character_Literal)
3747 and then not Address_Taken (F))
3749 if Etype (F) /= Etype (A) then
3751 (F, Unchecked_Convert_To (Etype (F), Relocate_Node (A)));
3753 Set_Renamed_Object (F, A);
3758 Make_Defining_Identifier (Loc,
3759 Chars => New_Internal_Name ('C'));
3761 -- If the actual for an in/in-out parameter is a view conversion,
3762 -- make it into an unchecked conversion, given that an untagged
3763 -- type conversion is not a proper object for a renaming.
3765 -- In-out conversions that involve real conversions have already
3766 -- been transformed in Expand_Actuals.
3768 if Nkind (A) = N_Type_Conversion
3769 and then Ekind (F) /= E_In_Parameter
3772 Make_Unchecked_Type_Conversion (Loc,
3773 Subtype_Mark => New_Occurrence_Of (Etype (F), Loc),
3774 Expression => Relocate_Node (Expression (A)));
3776 elsif Etype (F) /= Etype (A) then
3777 New_A := Unchecked_Convert_To (Etype (F), Relocate_Node (A));
3778 Temp_Typ := Etype (F);
3781 New_A := Relocate_Node (A);
3784 Set_Sloc (New_A, Sloc (N));
3786 -- If the actual has a by-reference type, it cannot be copied, so
3787 -- its value is captured in a renaming declaration. Otherwise
3788 -- declare a local constant initialized with the actual.
3790 if Ekind (F) = E_In_Parameter
3791 and then not Is_Limited_Type (Etype (A))
3792 and then not Is_Tagged_Type (Etype (A))
3795 Make_Object_Declaration (Loc,
3796 Defining_Identifier => Temp,
3797 Constant_Present => True,
3798 Object_Definition => New_Occurrence_Of (Temp_Typ, Loc),
3799 Expression => New_A);
3802 Make_Object_Renaming_Declaration (Loc,
3803 Defining_Identifier => Temp,
3804 Subtype_Mark => New_Occurrence_Of (Temp_Typ, Loc),
3808 Append (Decl, Decls);
3809 Set_Renamed_Object (F, Temp);
3816 -- Establish target of function call. If context is not assignment or
3817 -- declaration, create a temporary as a target. The declaration for
3818 -- the temporary may be subsequently optimized away if the body is a
3819 -- single expression, or if the left-hand side of the assignment is
3820 -- simple enough, i.e. an entity or an explicit dereference of one.
3822 if Ekind (Subp) = E_Function then
3823 if Nkind (Parent (N)) = N_Assignment_Statement
3824 and then Is_Entity_Name (Name (Parent (N)))
3826 Targ := Name (Parent (N));
3828 elsif Nkind (Parent (N)) = N_Assignment_Statement
3829 and then Nkind (Name (Parent (N))) = N_Explicit_Dereference
3830 and then Is_Entity_Name (Prefix (Name (Parent (N))))
3832 Targ := Name (Parent (N));
3835 -- Replace call with temporary and create its declaration
3838 Make_Defining_Identifier (Loc, New_Internal_Name ('C'));
3839 Set_Is_Internal (Temp);
3841 -- For the unconstrained case. the generated temporary has the
3842 -- same constrained declaration as the result variable.
3843 -- It may eventually be possible to remove that temporary and
3844 -- use the result variable directly.
3848 Make_Object_Declaration (Loc,
3849 Defining_Identifier => Temp,
3850 Object_Definition =>
3851 New_Copy_Tree (Object_Definition (Parent (Targ1))));
3853 Replace_Formals (Decl);
3857 Make_Object_Declaration (Loc,
3858 Defining_Identifier => Temp,
3859 Object_Definition =>
3860 New_Occurrence_Of (Ret_Type, Loc));
3862 Set_Etype (Temp, Ret_Type);
3865 Set_No_Initialization (Decl);
3866 Append (Decl, Decls);
3867 Rewrite (N, New_Occurrence_Of (Temp, Loc));
3872 Insert_Actions (N, Decls);
3874 -- Traverse the tree and replace formals with actuals or their thunks.
3875 -- Attach block to tree before analysis and rewriting.
3877 Replace_Formals (Blk);
3878 Set_Parent (Blk, N);
3880 if not Comes_From_Source (Subp)
3886 if Present (Exit_Lab) then
3888 -- If the body was a single expression, the single return statement
3889 -- and the corresponding label are useless.
3893 Nkind (Last (Statements (Handled_Statement_Sequence (Blk)))) =
3896 Remove (Last (Statements (Handled_Statement_Sequence (Blk))));
3898 Append (Lab_Decl, (Declarations (Blk)));
3899 Append (Exit_Lab, Statements (Handled_Statement_Sequence (Blk)));
3903 -- Analyze Blk with In_Inlined_Body set, to avoid spurious errors on
3904 -- conflicting private views that Gigi would ignore. If this is
3905 -- predefined unit, analyze with checks off, as is done in the non-
3906 -- inlined run-time units.
3909 I_Flag : constant Boolean := In_Inlined_Body;
3912 In_Inlined_Body := True;
3916 Style : constant Boolean := Style_Check;
3918 Style_Check := False;
3919 Analyze (Blk, Suppress => All_Checks);
3920 Style_Check := Style;
3927 In_Inlined_Body := I_Flag;
3930 if Ekind (Subp) = E_Procedure then
3931 Rewrite_Procedure_Call (N, Blk);
3933 Rewrite_Function_Call (N, Blk);
3935 -- For the unconstrained case, the replacement of the call has been
3936 -- made prior to the complete analysis of the generated declarations.
3937 -- Propagate the proper type now.
3940 if Nkind (N) = N_Identifier then
3941 Set_Etype (N, Etype (Entity (N)));
3943 Set_Etype (N, Etype (Targ1));
3950 -- Cleanup mapping between formals and actuals for other expansions
3952 F := First_Formal (Subp);
3953 while Present (F) loop
3954 Set_Renamed_Object (F, Empty);
3957 end Expand_Inlined_Call;
3959 ----------------------------
3960 -- Expand_N_Function_Call --
3961 ----------------------------
3963 procedure Expand_N_Function_Call (N : Node_Id) is
3966 end Expand_N_Function_Call;
3968 ---------------------------------------
3969 -- Expand_N_Procedure_Call_Statement --
3970 ---------------------------------------
3972 procedure Expand_N_Procedure_Call_Statement (N : Node_Id) is
3975 end Expand_N_Procedure_Call_Statement;
3977 ------------------------------
3978 -- Expand_N_Subprogram_Body --
3979 ------------------------------
3981 -- Add poll call if ATC polling is enabled, unless the body will be
3982 -- inlined by the back-end.
3984 -- Add dummy push/pop label nodes at start and end to clear any local
3985 -- exception indications if local-exception-to-goto optimization active.
3987 -- Add return statement if last statement in body is not a return statement
3988 -- (this makes things easier on Gigi which does not want to have to handle
3989 -- a missing return).
3991 -- Add call to Activate_Tasks if body is a task activator
3993 -- Deal with possible detection of infinite recursion
3995 -- Eliminate body completely if convention stubbed
3997 -- Encode entity names within body, since we will not need to reference
3998 -- these entities any longer in the front end.
4000 -- Initialize scalar out parameters if Initialize/Normalize_Scalars
4002 -- Reset Pure indication if any parameter has root type System.Address
4006 procedure Expand_N_Subprogram_Body (N : Node_Id) is
4007 Loc : constant Source_Ptr := Sloc (N);
4008 H : constant Node_Id := Handled_Statement_Sequence (N);
4009 Body_Id : Entity_Id;
4012 Spec_Id : Entity_Id;
4014 procedure Add_Return (S : List_Id);
4015 -- Append a return statement to the statement sequence S if the last
4016 -- statement is not already a return or a goto statement. Note that
4017 -- the latter test is not critical, it does not matter if we add a
4018 -- few extra returns, since they get eliminated anyway later on.
4024 procedure Add_Return (S : List_Id) is
4029 -- Get last statement, ignoring any Pop_xxx_Label nodes, which are
4030 -- not relevant in this context since they are not executable.
4032 Last_Stm := Last (S);
4033 while Nkind (Last_Stm) in N_Pop_xxx_Label loop
4037 -- Now insert return unless last statement is a transfer
4039 if not Is_Transfer (Last_Stm) then
4041 -- The source location for the return is the end label of the
4042 -- procedure if present. Otherwise use the sloc of the last
4043 -- statement in the list. If the list comes from a generated
4044 -- exception handler and we are not debugging generated code,
4045 -- all the statements within the handler are made invisible
4048 if Nkind (Parent (S)) = N_Exception_Handler
4049 and then not Comes_From_Source (Parent (S))
4051 Loc := Sloc (Last_Stm);
4053 elsif Present (End_Label (H)) then
4054 Loc := Sloc (End_Label (H));
4057 Loc := Sloc (Last_Stm);
4060 Append_To (S, Make_Simple_Return_Statement (Loc));
4064 -- Start of processing for Expand_N_Subprogram_Body
4067 -- Set L to either the list of declarations if present, or
4068 -- to the list of statements if no declarations are present.
4069 -- This is used to insert new stuff at the start.
4071 if Is_Non_Empty_List (Declarations (N)) then
4072 L := Declarations (N);
4074 L := Statements (H);
4077 -- If local-exception-to-goto optimization active, insert dummy push
4078 -- statements at start, and dummy pop statements at end.
4080 if (Debug_Flag_Dot_G
4081 or else Restriction_Active (No_Exception_Propagation))
4082 and then Is_Non_Empty_List (L)
4085 FS : constant Node_Id := First (L);
4086 FL : constant Source_Ptr := Sloc (FS);
4091 -- LS points to either last statement, if statements are present
4092 -- or to the last declaration if there are no statements present.
4093 -- It is the node after which the pop's are generated.
4095 if Is_Non_Empty_List (Statements (H)) then
4096 LS := Last (Statements (H));
4103 Insert_List_Before_And_Analyze (FS, New_List (
4104 Make_Push_Constraint_Error_Label (FL),
4105 Make_Push_Program_Error_Label (FL),
4106 Make_Push_Storage_Error_Label (FL)));
4108 Insert_List_After_And_Analyze (LS, New_List (
4109 Make_Pop_Constraint_Error_Label (LL),
4110 Make_Pop_Program_Error_Label (LL),
4111 Make_Pop_Storage_Error_Label (LL)));
4115 -- Find entity for subprogram
4117 Body_Id := Defining_Entity (N);
4119 if Present (Corresponding_Spec (N)) then
4120 Spec_Id := Corresponding_Spec (N);
4125 -- Need poll on entry to subprogram if polling enabled. We only do this
4126 -- for non-empty subprograms, since it does not seem necessary to poll
4127 -- for a dummy null subprogram. Do not add polling point if calls to
4128 -- this subprogram will be inlined by the back-end, to avoid repeated
4129 -- polling points in nested inlinings.
4131 if Is_Non_Empty_List (L) then
4132 if Is_Inlined (Spec_Id)
4133 and then Front_End_Inlining
4134 and then Optimization_Level > 1
4138 Generate_Poll_Call (First (L));
4142 -- If this is a Pure function which has any parameters whose root
4143 -- type is System.Address, reset the Pure indication, since it will
4144 -- likely cause incorrect code to be generated as the parameter is
4145 -- probably a pointer, and the fact that the same pointer is passed
4146 -- does not mean that the same value is being referenced.
4148 -- Note that if the programmer gave an explicit Pure_Function pragma,
4149 -- then we believe the programmer, and leave the subprogram Pure.
4151 -- This code should probably be at the freeze point, so that it
4152 -- happens even on a -gnatc (or more importantly -gnatt) compile
4153 -- so that the semantic tree has Is_Pure set properly ???
4155 if Is_Pure (Spec_Id)
4156 and then Is_Subprogram (Spec_Id)
4157 and then not Has_Pragma_Pure_Function (Spec_Id)
4163 F := First_Formal (Spec_Id);
4164 while Present (F) loop
4165 if Is_Descendent_Of_Address (Etype (F)) then
4166 Set_Is_Pure (Spec_Id, False);
4168 if Spec_Id /= Body_Id then
4169 Set_Is_Pure (Body_Id, False);
4180 -- Initialize any scalar OUT args if Initialize/Normalize_Scalars
4182 if Init_Or_Norm_Scalars and then Is_Subprogram (Spec_Id) then
4187 -- Loop through formals
4189 F := First_Formal (Spec_Id);
4190 while Present (F) loop
4191 if Is_Scalar_Type (Etype (F))
4192 and then Ekind (F) = E_Out_Parameter
4194 Check_Restriction (No_Default_Initialization, F);
4196 -- Insert the initialization. We turn off validity checks
4197 -- for this assignment, since we do not want any check on
4198 -- the initial value itself (which may well be invalid).
4200 Insert_Before_And_Analyze (First (L),
4201 Make_Assignment_Statement (Loc,
4202 Name => New_Occurrence_Of (F, Loc),
4203 Expression => Get_Simple_Init_Val (Etype (F), N)),
4204 Suppress => Validity_Check);
4212 -- Clear out statement list for stubbed procedure
4214 if Present (Corresponding_Spec (N)) then
4215 Set_Elaboration_Flag (N, Spec_Id);
4217 if Convention (Spec_Id) = Convention_Stubbed
4218 or else Is_Eliminated (Spec_Id)
4220 Set_Declarations (N, Empty_List);
4221 Set_Handled_Statement_Sequence (N,
4222 Make_Handled_Sequence_Of_Statements (Loc,
4223 Statements => New_List (
4224 Make_Null_Statement (Loc))));
4229 -- Create a set of discriminals for the next protected subprogram body
4231 if Is_List_Member (N)
4232 and then Present (Parent (List_Containing (N)))
4233 and then Nkind (Parent (List_Containing (N))) = N_Protected_Body
4234 and then Present (Next_Protected_Operation (N))
4236 Set_Discriminals (Parent (Base_Type (Scope (Spec_Id))));
4239 -- Returns_By_Ref flag is normally set when the subprogram is frozen
4240 -- but subprograms with no specs are not frozen.
4243 Typ : constant Entity_Id := Etype (Spec_Id);
4244 Utyp : constant Entity_Id := Underlying_Type (Typ);
4247 if not Acts_As_Spec (N)
4248 and then Nkind (Parent (Parent (Spec_Id))) /=
4249 N_Subprogram_Body_Stub
4253 elsif Is_Inherently_Limited_Type (Typ) then
4254 Set_Returns_By_Ref (Spec_Id);
4256 elsif Present (Utyp) and then CW_Or_Controlled_Type (Utyp) then
4257 Set_Returns_By_Ref (Spec_Id);
4261 -- For a procedure, we add a return for all possible syntactic ends
4262 -- of the subprogram. Note that reanalysis is not necessary in this
4263 -- case since it would require a lot of work and accomplish nothing.
4265 if Ekind (Spec_Id) = E_Procedure
4266 or else Ekind (Spec_Id) = E_Generic_Procedure
4268 Add_Return (Statements (H));
4270 if Present (Exception_Handlers (H)) then
4271 Except_H := First_Non_Pragma (Exception_Handlers (H));
4272 while Present (Except_H) loop
4273 Add_Return (Statements (Except_H));
4274 Next_Non_Pragma (Except_H);
4278 -- For a function, we must deal with the case where there is at least
4279 -- one missing return. What we do is to wrap the entire body of the
4280 -- function in a block:
4293 -- raise Program_Error;
4296 -- This approach is necessary because the raise must be signalled
4297 -- to the caller, not handled by any local handler (RM 6.4(11)).
4299 -- Note: we do not need to analyze the constructed sequence here,
4300 -- since it has no handler, and an attempt to analyze the handled
4301 -- statement sequence twice is risky in various ways (e.g. the
4302 -- issue of expanding cleanup actions twice).
4304 elsif Has_Missing_Return (Spec_Id) then
4306 Hloc : constant Source_Ptr := Sloc (H);
4307 Blok : constant Node_Id :=
4308 Make_Block_Statement (Hloc,
4309 Handled_Statement_Sequence => H);
4310 Rais : constant Node_Id :=
4311 Make_Raise_Program_Error (Hloc,
4312 Reason => PE_Missing_Return);
4315 Set_Handled_Statement_Sequence (N,
4316 Make_Handled_Sequence_Of_Statements (Hloc,
4317 Statements => New_List (Blok, Rais)));
4319 Push_Scope (Spec_Id);
4326 -- If subprogram contains a parameterless recursive call, then we may
4327 -- have an infinite recursion, so see if we can generate code to check
4328 -- for this possibility if storage checks are not suppressed.
4330 if Ekind (Spec_Id) = E_Procedure
4331 and then Has_Recursive_Call (Spec_Id)
4332 and then not Storage_Checks_Suppressed (Spec_Id)
4334 Detect_Infinite_Recursion (N, Spec_Id);
4337 -- Set to encode entity names in package body before gigi is called
4339 Qualify_Entity_Names (N);
4340 end Expand_N_Subprogram_Body;
4342 -----------------------------------
4343 -- Expand_N_Subprogram_Body_Stub --
4344 -----------------------------------
4346 procedure Expand_N_Subprogram_Body_Stub (N : Node_Id) is
4348 if Present (Corresponding_Body (N)) then
4349 Expand_N_Subprogram_Body (
4350 Unit_Declaration_Node (Corresponding_Body (N)));
4352 end Expand_N_Subprogram_Body_Stub;
4354 -------------------------------------
4355 -- Expand_N_Subprogram_Declaration --
4356 -------------------------------------
4358 -- If the declaration appears within a protected body, it is a private
4359 -- operation of the protected type. We must create the corresponding
4360 -- protected subprogram an associated formals. For a normal protected
4361 -- operation, this is done when expanding the protected type declaration.
4363 -- If the declaration is for a null procedure, emit null body
4365 procedure Expand_N_Subprogram_Declaration (N : Node_Id) is
4366 Loc : constant Source_Ptr := Sloc (N);
4367 Subp : constant Entity_Id := Defining_Entity (N);
4368 Scop : constant Entity_Id := Scope (Subp);
4369 Prot_Decl : Node_Id;
4371 Prot_Id : Entity_Id;
4374 -- Deal with case of protected subprogram. Do not generate protected
4375 -- operation if operation is flagged as eliminated.
4377 if Is_List_Member (N)
4378 and then Present (Parent (List_Containing (N)))
4379 and then Nkind (Parent (List_Containing (N))) = N_Protected_Body
4380 and then Is_Protected_Type (Scop)
4382 if No (Protected_Body_Subprogram (Subp))
4383 and then not Is_Eliminated (Subp)
4386 Make_Subprogram_Declaration (Loc,
4388 Build_Protected_Sub_Specification
4389 (N, Scop, Unprotected_Mode));
4391 -- The protected subprogram is declared outside of the protected
4392 -- body. Given that the body has frozen all entities so far, we
4393 -- analyze the subprogram and perform freezing actions explicitly.
4394 -- including the generation of an explicit freeze node, to ensure
4395 -- that gigi has the proper order of elaboration.
4396 -- If the body is a subunit, the insertion point is before the
4397 -- stub in the parent.
4399 Prot_Bod := Parent (List_Containing (N));
4401 if Nkind (Parent (Prot_Bod)) = N_Subunit then
4402 Prot_Bod := Corresponding_Stub (Parent (Prot_Bod));
4405 Insert_Before (Prot_Bod, Prot_Decl);
4406 Prot_Id := Defining_Unit_Name (Specification (Prot_Decl));
4407 Set_Has_Delayed_Freeze (Prot_Id);
4409 Push_Scope (Scope (Scop));
4410 Analyze (Prot_Decl);
4411 Insert_Actions (N, Freeze_Entity (Prot_Id, Loc));
4412 Set_Protected_Body_Subprogram (Subp, Prot_Id);
4416 -- Ada 2005 (AI-348): Generation of the null body
4418 elsif Nkind (Specification (N)) = N_Procedure_Specification
4419 and then Null_Present (Specification (N))
4422 Bod : constant Node_Id :=
4423 Make_Subprogram_Body (Loc,
4425 New_Copy_Tree (Specification (N)),
4426 Declarations => New_List,
4427 Handled_Statement_Sequence =>
4428 Make_Handled_Sequence_Of_Statements (Loc,
4429 Statements => New_List (Make_Null_Statement (Loc))));
4431 Set_Body_To_Inline (N, Bod);
4432 Insert_After (N, Bod);
4435 -- Corresponding_Spec isn't being set by Analyze_Subprogram_Body,
4436 -- evidently because Set_Has_Completion is called earlier for null
4437 -- procedures in Analyze_Subprogram_Declaration, so we force its
4438 -- setting here. If the setting of Has_Completion is not set
4439 -- earlier, then it can result in missing body errors if other
4440 -- errors were already reported (since expansion is turned off).
4442 -- Should creation of the empty body be moved to the analyzer???
4444 Set_Corresponding_Spec (Bod, Defining_Entity (Specification (N)));
4447 end Expand_N_Subprogram_Declaration;
4449 ---------------------------------------
4450 -- Expand_Protected_Object_Reference --
4451 ---------------------------------------
4453 function Expand_Protected_Object_Reference
4455 Scop : Entity_Id) return Node_Id
4457 Loc : constant Source_Ptr := Sloc (N);
4465 Make_Identifier (Loc,
4466 Chars => Name_uObject);
4467 Set_Etype (Rec, Corresponding_Record_Type (Scop));
4469 -- Find enclosing protected operation, and retrieve its first parameter,
4470 -- which denotes the enclosing protected object. If the enclosing
4471 -- operation is an entry, we are immediately within the protected body,
4472 -- and we can retrieve the object from the service entries procedure. A
4473 -- barrier function has has the same signature as an entry. A barrier
4474 -- function is compiled within the protected object, but unlike
4475 -- protected operations its never needs locks, so that its protected
4476 -- body subprogram points to itself.
4478 Proc := Current_Scope;
4479 while Present (Proc)
4480 and then Scope (Proc) /= Scop
4482 Proc := Scope (Proc);
4485 Corr := Protected_Body_Subprogram (Proc);
4489 -- Previous error left expansion incomplete.
4490 -- Nothing to do on this call.
4497 (First (Parameter_Specifications (Parent (Corr))));
4499 if Is_Subprogram (Proc)
4500 and then Proc /= Corr
4502 -- Protected function or procedure
4504 Set_Entity (Rec, Param);
4506 -- Rec is a reference to an entity which will not be in scope when
4507 -- the call is reanalyzed, and needs no further analysis.
4512 -- Entry or barrier function for entry body. The first parameter of
4513 -- the entry body procedure is pointer to the object. We create a
4514 -- local variable of the proper type, duplicating what is done to
4515 -- define _object later on.
4519 Obj_Ptr : constant Entity_Id := Make_Defining_Identifier (Loc,
4521 New_Internal_Name ('T'));
4525 Make_Full_Type_Declaration (Loc,
4526 Defining_Identifier => Obj_Ptr,
4528 Make_Access_To_Object_Definition (Loc,
4529 Subtype_Indication =>
4531 (Corresponding_Record_Type (Scop), Loc))));
4533 Insert_Actions (N, Decls);
4534 Insert_Actions (N, Freeze_Entity (Obj_Ptr, Sloc (N)));
4537 Make_Explicit_Dereference (Loc,
4538 Unchecked_Convert_To (Obj_Ptr,
4539 New_Occurrence_Of (Param, Loc)));
4541 -- Analyze new actual. Other actuals in calls are already analyzed
4542 -- and the list of actuals is not reanalyzed after rewriting.
4544 Set_Parent (Rec, N);
4550 end Expand_Protected_Object_Reference;
4552 --------------------------------------
4553 -- Expand_Protected_Subprogram_Call --
4554 --------------------------------------
4556 procedure Expand_Protected_Subprogram_Call
4564 -- If the protected object is not an enclosing scope, this is
4565 -- an inter-object function call. Inter-object procedure
4566 -- calls are expanded by Exp_Ch9.Build_Simple_Entry_Call.
4567 -- The call is intra-object only if the subprogram being
4568 -- called is in the protected body being compiled, and if the
4569 -- protected object in the call is statically the enclosing type.
4570 -- The object may be an component of some other data structure,
4571 -- in which case this must be handled as an inter-object call.
4573 if not In_Open_Scopes (Scop)
4574 or else not Is_Entity_Name (Name (N))
4576 if Nkind (Name (N)) = N_Selected_Component then
4577 Rec := Prefix (Name (N));
4580 pragma Assert (Nkind (Name (N)) = N_Indexed_Component);
4581 Rec := Prefix (Prefix (Name (N)));
4584 Build_Protected_Subprogram_Call (N,
4585 Name => New_Occurrence_Of (Subp, Sloc (N)),
4586 Rec => Convert_Concurrent (Rec, Etype (Rec)),
4590 Rec := Expand_Protected_Object_Reference (N, Scop);
4596 Build_Protected_Subprogram_Call (N,
4605 -- If it is a function call it can appear in elaboration code and
4606 -- the called entity must be frozen here.
4608 if Ekind (Subp) = E_Function then
4609 Freeze_Expression (Name (N));
4611 end Expand_Protected_Subprogram_Call;
4613 --------------------------------
4614 -- Is_Build_In_Place_Function --
4615 --------------------------------
4617 function Is_Build_In_Place_Function (E : Entity_Id) return Boolean is
4619 -- For now we test whether E denotes a function or access-to-function
4620 -- type whose result subtype is inherently limited. Later this test may
4621 -- be revised to allow composite nonlimited types. Functions with a
4622 -- foreign convention or whose result type has a foreign convention
4625 if Ekind (E) = E_Function
4626 or else Ekind (E) = E_Generic_Function
4627 or else (Ekind (E) = E_Subprogram_Type
4628 and then Etype (E) /= Standard_Void_Type)
4630 -- Note: If you have Convention (C) on an inherently limited type,
4631 -- you're on your own. That is, the C code will have to be carefully
4632 -- written to know about the Ada conventions.
4634 if Has_Foreign_Convention (E)
4635 or else Has_Foreign_Convention (Etype (E))
4639 -- If the return type is a limited interface it has to be treated
4640 -- as a return in place, even if the actual object is some non-
4641 -- limited descendant.
4643 elsif Is_Limited_Interface (Etype (E)) then
4647 return Is_Inherently_Limited_Type (Etype (E))
4648 and then Ada_Version >= Ada_05
4649 and then not Debug_Flag_Dot_L;
4655 end Is_Build_In_Place_Function;
4657 -------------------------------------
4658 -- Is_Build_In_Place_Function_Call --
4659 -------------------------------------
4661 function Is_Build_In_Place_Function_Call (N : Node_Id) return Boolean is
4662 Exp_Node : Node_Id := N;
4663 Function_Id : Entity_Id;
4666 -- Step past qualification or unchecked conversion (the latter can occur
4667 -- in cases of calls to 'Input).
4670 (Exp_Node, N_Qualified_Expression, N_Unchecked_Type_Conversion)
4672 Exp_Node := Expression (N);
4675 if Nkind (Exp_Node) /= N_Function_Call then
4679 if Is_Entity_Name (Name (Exp_Node)) then
4680 Function_Id := Entity (Name (Exp_Node));
4682 elsif Nkind (Name (Exp_Node)) = N_Explicit_Dereference then
4683 Function_Id := Etype (Name (Exp_Node));
4686 return Is_Build_In_Place_Function (Function_Id);
4688 end Is_Build_In_Place_Function_Call;
4690 ---------------------------------------
4691 -- Is_Build_In_Place_Function_Return --
4692 ---------------------------------------
4694 function Is_Build_In_Place_Function_Return (N : Node_Id) return Boolean is
4696 if Nkind_In (N, N_Simple_Return_Statement,
4697 N_Extended_Return_Statement)
4699 return Is_Build_In_Place_Function
4700 (Return_Applies_To (Return_Statement_Entity (N)));
4704 end Is_Build_In_Place_Function_Return;
4706 -----------------------
4707 -- Freeze_Subprogram --
4708 -----------------------
4710 procedure Freeze_Subprogram (N : Node_Id) is
4711 Loc : constant Source_Ptr := Sloc (N);
4713 procedure Register_Predefined_DT_Entry (Prim : Entity_Id);
4714 -- (Ada 2005): Register a predefined primitive in all the secondary
4715 -- dispatch tables of its primitive type.
4717 ----------------------------------
4718 -- Register_Predefined_DT_Entry --
4719 ----------------------------------
4721 procedure Register_Predefined_DT_Entry (Prim : Entity_Id) is
4722 Iface_DT_Ptr : Elmt_Id;
4723 Tagged_Typ : Entity_Id;
4724 Thunk_Id : Entity_Id;
4725 Thunk_Code : Node_Id;
4728 Tagged_Typ := Find_Dispatching_Type (Prim);
4730 if No (Access_Disp_Table (Tagged_Typ))
4731 or else not Has_Interfaces (Tagged_Typ)
4732 or else not RTE_Available (RE_Interface_Tag)
4733 or else Restriction_Active (No_Dispatching_Calls)
4738 -- Skip the first two access-to-dispatch-table pointers since they
4739 -- leads to the primary dispatch table (predefined DT and user
4740 -- defined DT). We are only concerned with the secondary dispatch
4741 -- table pointers. Note that the access-to- dispatch-table pointer
4742 -- corresponds to the first implemented interface retrieved below.
4745 Next_Elmt (Next_Elmt (First_Elmt (Access_Disp_Table (Tagged_Typ))));
4747 while Present (Iface_DT_Ptr)
4748 and then Ekind (Node (Iface_DT_Ptr)) = E_Constant
4750 pragma Assert (Has_Thunks (Node (Iface_DT_Ptr)));
4751 Expand_Interface_Thunk (Prim, Thunk_Id, Thunk_Code);
4753 if Present (Thunk_Code) then
4754 Insert_Actions_After (N, New_List (
4757 Build_Set_Predefined_Prim_Op_Address (Loc,
4759 New_Reference_To (Node (Next_Elmt (Iface_DT_Ptr)), Loc),
4760 Position => DT_Position (Prim),
4762 Unchecked_Convert_To (RTE (RE_Prim_Ptr),
4763 Make_Attribute_Reference (Loc,
4764 Prefix => New_Reference_To (Thunk_Id, Loc),
4765 Attribute_Name => Name_Unrestricted_Access))),
4767 Build_Set_Predefined_Prim_Op_Address (Loc,
4770 (Node (Next_Elmt (Next_Elmt (Next_Elmt (Iface_DT_Ptr)))),
4772 Position => DT_Position (Prim),
4774 Unchecked_Convert_To (RTE (RE_Prim_Ptr),
4775 Make_Attribute_Reference (Loc,
4776 Prefix => New_Reference_To (Prim, Loc),
4777 Attribute_Name => Name_Unrestricted_Access)))));
4780 -- Skip the tag of the predefined primitives dispatch table
4782 Next_Elmt (Iface_DT_Ptr);
4783 pragma Assert (Has_Thunks (Node (Iface_DT_Ptr)));
4785 -- Skip the tag of the no-thunks dispatch table
4787 Next_Elmt (Iface_DT_Ptr);
4788 pragma Assert (not Has_Thunks (Node (Iface_DT_Ptr)));
4790 -- Skip the tag of the predefined primitives no-thunks dispatch
4793 Next_Elmt (Iface_DT_Ptr);
4794 pragma Assert (not Has_Thunks (Node (Iface_DT_Ptr)));
4796 Next_Elmt (Iface_DT_Ptr);
4798 end Register_Predefined_DT_Entry;
4802 Subp : constant Entity_Id := Entity (N);
4804 -- Start of processing for Freeze_Subprogram
4807 -- We suppress the initialization of the dispatch table entry when
4808 -- VM_Target because the dispatching mechanism is handled internally
4811 if Is_Dispatching_Operation (Subp)
4812 and then not Is_Abstract_Subprogram (Subp)
4813 and then Present (DTC_Entity (Subp))
4814 and then Present (Scope (DTC_Entity (Subp)))
4815 and then VM_Target = No_VM
4816 and then not Restriction_Active (No_Dispatching_Calls)
4817 and then RTE_Available (RE_Tag)
4820 Typ : constant Entity_Id := Scope (DTC_Entity (Subp));
4823 -- Handle private overridden primitives
4825 if not Is_CPP_Class (Typ) then
4826 Check_Overriding_Operation (Subp);
4829 -- We assume that imported CPP primitives correspond with objects
4830 -- whose constructor is in the CPP side; therefore we don't need
4831 -- to generate code to register them in the dispatch table.
4833 if Is_CPP_Class (Typ) then
4836 -- Handle CPP primitives found in derivations of CPP_Class types.
4837 -- These primitives must have been inherited from some parent, and
4838 -- there is no need to register them in the dispatch table because
4839 -- Build_Inherit_Prims takes care of the initialization of these
4842 elsif Is_Imported (Subp)
4843 and then (Convention (Subp) = Convention_CPP
4844 or else Convention (Subp) = Convention_C)
4848 -- Generate code to register the primitive in non statically
4849 -- allocated dispatch tables
4851 elsif not Static_Dispatch_Tables
4853 Is_Library_Level_Tagged_Type (Scope (DTC_Entity (Subp)))
4855 -- When a primitive is frozen, enter its name in its dispatch
4858 if not Is_Interface (Typ)
4859 or else Present (Interface_Alias (Subp))
4861 if Is_Predefined_Dispatching_Operation (Subp) then
4862 Register_Predefined_DT_Entry (Subp);
4865 Register_Primitive (Loc,
4873 -- Mark functions that return by reference. Note that it cannot be part
4874 -- of the normal semantic analysis of the spec since the underlying
4875 -- returned type may not be known yet (for private types).
4878 Typ : constant Entity_Id := Etype (Subp);
4879 Utyp : constant Entity_Id := Underlying_Type (Typ);
4881 if Is_Inherently_Limited_Type (Typ) then
4882 Set_Returns_By_Ref (Subp);
4883 elsif Present (Utyp) and then CW_Or_Controlled_Type (Utyp) then
4884 Set_Returns_By_Ref (Subp);
4887 end Freeze_Subprogram;
4889 -------------------------------------------
4890 -- Make_Build_In_Place_Call_In_Allocator --
4891 -------------------------------------------
4893 procedure Make_Build_In_Place_Call_In_Allocator
4894 (Allocator : Node_Id;
4895 Function_Call : Node_Id)
4898 Func_Call : Node_Id := Function_Call;
4899 Function_Id : Entity_Id;
4900 Result_Subt : Entity_Id;
4901 Acc_Type : constant Entity_Id := Etype (Allocator);
4902 New_Allocator : Node_Id;
4903 Return_Obj_Access : Entity_Id;
4906 -- Step past qualification or unchecked conversion (the latter can occur
4907 -- in cases of calls to 'Input).
4909 if Nkind_In (Func_Call,
4910 N_Qualified_Expression,
4911 N_Unchecked_Type_Conversion)
4913 Func_Call := Expression (Func_Call);
4916 -- If the call has already been processed to add build-in-place actuals
4917 -- then return. This should not normally occur in an allocator context,
4918 -- but we add the protection as a defensive measure.
4920 if Is_Expanded_Build_In_Place_Call (Func_Call) then
4924 -- Mark the call as processed as a build-in-place call
4926 Set_Is_Expanded_Build_In_Place_Call (Func_Call);
4928 Loc := Sloc (Function_Call);
4930 if Is_Entity_Name (Name (Func_Call)) then
4931 Function_Id := Entity (Name (Func_Call));
4933 elsif Nkind (Name (Func_Call)) = N_Explicit_Dereference then
4934 Function_Id := Etype (Name (Func_Call));
4937 raise Program_Error;
4940 Result_Subt := Etype (Function_Id);
4942 -- When the result subtype is constrained, the return object must be
4943 -- allocated on the caller side, and access to it is passed to the
4946 -- Here and in related routines, we must examine the full view of the
4947 -- type, because the view at the point of call may differ from that
4948 -- that in the function body, and the expansion mechanism depends on
4949 -- the characteristics of the full view.
4951 if Is_Constrained (Underlying_Type (Result_Subt)) then
4953 -- Replace the initialized allocator of form "new T'(Func (...))"
4954 -- with an uninitialized allocator of form "new T", where T is the
4955 -- result subtype of the called function. The call to the function
4956 -- is handled separately further below.
4959 Make_Allocator (Loc, New_Reference_To (Result_Subt, Loc));
4961 Set_Storage_Pool (New_Allocator, Storage_Pool (Allocator));
4962 Set_Procedure_To_Call (New_Allocator, Procedure_To_Call (Allocator));
4963 Set_No_Initialization (New_Allocator);
4965 Rewrite (Allocator, New_Allocator);
4967 -- Create a new access object and initialize it to the result of the
4968 -- new uninitialized allocator.
4970 Return_Obj_Access :=
4971 Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
4972 Set_Etype (Return_Obj_Access, Acc_Type);
4974 Insert_Action (Allocator,
4975 Make_Object_Declaration (Loc,
4976 Defining_Identifier => Return_Obj_Access,
4977 Object_Definition => New_Reference_To (Acc_Type, Loc),
4978 Expression => Relocate_Node (Allocator)));
4980 -- When the function has a controlling result, an allocation-form
4981 -- parameter must be passed indicating that the caller is allocating
4982 -- the result object. This is needed because such a function can be
4983 -- called as a dispatching operation and must be treated similarly
4984 -- to functions with unconstrained result subtypes.
4986 Add_Alloc_Form_Actual_To_Build_In_Place_Call
4987 (Func_Call, Function_Id, Alloc_Form => Caller_Allocation);
4989 Add_Final_List_Actual_To_Build_In_Place_Call
4990 (Func_Call, Function_Id, Acc_Type);
4992 Add_Task_Actuals_To_Build_In_Place_Call
4993 (Func_Call, Function_Id, Master_Actual => Master_Id (Acc_Type));
4995 -- Add an implicit actual to the function call that provides access
4996 -- to the allocated object. An unchecked conversion to the (specific)
4997 -- result subtype of the function is inserted to handle cases where
4998 -- the access type of the allocator has a class-wide designated type.
5000 Add_Access_Actual_To_Build_In_Place_Call
5003 Make_Unchecked_Type_Conversion (Loc,
5004 Subtype_Mark => New_Reference_To (Result_Subt, Loc),
5006 Make_Explicit_Dereference (Loc,
5007 Prefix => New_Reference_To (Return_Obj_Access, Loc))));
5009 -- When the result subtype is unconstrained, the function itself must
5010 -- perform the allocation of the return object, so we pass parameters
5011 -- indicating that. We don't yet handle the case where the allocation
5012 -- must be done in a user-defined storage pool, which will require
5013 -- passing another actual or two to provide allocation/deallocation
5018 -- Pass an allocation parameter indicating that the function should
5019 -- allocate its result on the heap.
5021 Add_Alloc_Form_Actual_To_Build_In_Place_Call
5022 (Func_Call, Function_Id, Alloc_Form => Global_Heap);
5024 Add_Final_List_Actual_To_Build_In_Place_Call
5025 (Func_Call, Function_Id, Acc_Type);
5027 Add_Task_Actuals_To_Build_In_Place_Call
5028 (Func_Call, Function_Id, Master_Actual => Master_Id (Acc_Type));
5030 -- The caller does not provide the return object in this case, so we
5031 -- have to pass null for the object access actual.
5033 Add_Access_Actual_To_Build_In_Place_Call
5034 (Func_Call, Function_Id, Return_Object => Empty);
5037 -- Finally, replace the allocator node with a reference to the result
5038 -- of the function call itself (which will effectively be an access
5039 -- to the object created by the allocator).
5041 Rewrite (Allocator, Make_Reference (Loc, Relocate_Node (Function_Call)));
5042 Analyze_And_Resolve (Allocator, Acc_Type);
5043 end Make_Build_In_Place_Call_In_Allocator;
5045 ---------------------------------------------------
5046 -- Make_Build_In_Place_Call_In_Anonymous_Context --
5047 ---------------------------------------------------
5049 procedure Make_Build_In_Place_Call_In_Anonymous_Context
5050 (Function_Call : Node_Id)
5053 Func_Call : Node_Id := Function_Call;
5054 Function_Id : Entity_Id;
5055 Result_Subt : Entity_Id;
5056 Return_Obj_Id : Entity_Id;
5057 Return_Obj_Decl : Entity_Id;
5060 -- Step past qualification or unchecked conversion (the latter can occur
5061 -- in cases of calls to 'Input).
5063 if Nkind_In (Func_Call, N_Qualified_Expression,
5064 N_Unchecked_Type_Conversion)
5066 Func_Call := Expression (Func_Call);
5069 -- If the call has already been processed to add build-in-place actuals
5070 -- then return. One place this can occur is for calls to build-in-place
5071 -- functions that occur within a call to a protected operation, where
5072 -- due to rewriting and expansion of the protected call there can be
5073 -- more than one call to Expand_Actuals for the same set of actuals.
5075 if Is_Expanded_Build_In_Place_Call (Func_Call) then
5079 -- Mark the call as processed as a build-in-place call
5081 Set_Is_Expanded_Build_In_Place_Call (Func_Call);
5083 Loc := Sloc (Function_Call);
5085 if Is_Entity_Name (Name (Func_Call)) then
5086 Function_Id := Entity (Name (Func_Call));
5088 elsif Nkind (Name (Func_Call)) = N_Explicit_Dereference then
5089 Function_Id := Etype (Name (Func_Call));
5092 raise Program_Error;
5095 Result_Subt := Etype (Function_Id);
5097 -- When the result subtype is constrained, an object of the subtype is
5098 -- declared and an access value designating it is passed as an actual.
5100 if Is_Constrained (Underlying_Type (Result_Subt)) then
5102 -- Create a temporary object to hold the function result
5105 Make_Defining_Identifier (Loc,
5106 Chars => New_Internal_Name ('R'));
5107 Set_Etype (Return_Obj_Id, Result_Subt);
5110 Make_Object_Declaration (Loc,
5111 Defining_Identifier => Return_Obj_Id,
5112 Aliased_Present => True,
5113 Object_Definition => New_Reference_To (Result_Subt, Loc));
5115 Set_No_Initialization (Return_Obj_Decl);
5117 Insert_Action (Func_Call, Return_Obj_Decl);
5119 -- When the function has a controlling result, an allocation-form
5120 -- parameter must be passed indicating that the caller is allocating
5121 -- the result object. This is needed because such a function can be
5122 -- called as a dispatching operation and must be treated similarly
5123 -- to functions with unconstrained result subtypes.
5125 Add_Alloc_Form_Actual_To_Build_In_Place_Call
5126 (Func_Call, Function_Id, Alloc_Form => Caller_Allocation);
5128 Add_Final_List_Actual_To_Build_In_Place_Call
5129 (Func_Call, Function_Id, Acc_Type => Empty);
5131 Add_Task_Actuals_To_Build_In_Place_Call
5132 (Func_Call, Function_Id, Make_Identifier (Loc, Name_uMaster));
5134 -- Add an implicit actual to the function call that provides access
5135 -- to the caller's return object.
5137 Add_Access_Actual_To_Build_In_Place_Call
5138 (Func_Call, Function_Id, New_Reference_To (Return_Obj_Id, Loc));
5140 -- When the result subtype is unconstrained, the function must allocate
5141 -- the return object in the secondary stack, so appropriate implicit
5142 -- parameters are added to the call to indicate that. A transient
5143 -- scope is established to ensure eventual cleanup of the result.
5147 -- Pass an allocation parameter indicating that the function should
5148 -- allocate its result on the secondary stack.
5150 Add_Alloc_Form_Actual_To_Build_In_Place_Call
5151 (Func_Call, Function_Id, Alloc_Form => Secondary_Stack);
5153 Add_Final_List_Actual_To_Build_In_Place_Call
5154 (Func_Call, Function_Id, Acc_Type => Empty);
5156 Add_Task_Actuals_To_Build_In_Place_Call
5157 (Func_Call, Function_Id, Make_Identifier (Loc, Name_uMaster));
5159 -- Pass a null value to the function since no return object is
5160 -- available on the caller side.
5162 Add_Access_Actual_To_Build_In_Place_Call
5163 (Func_Call, Function_Id, Empty);
5165 Establish_Transient_Scope (Func_Call, Sec_Stack => True);
5167 end Make_Build_In_Place_Call_In_Anonymous_Context;
5169 ---------------------------------------------------
5170 -- Make_Build_In_Place_Call_In_Assignment --
5171 ---------------------------------------------------
5173 procedure Make_Build_In_Place_Call_In_Assignment
5175 Function_Call : Node_Id)
5177 Lhs : constant Node_Id := Name (Assign);
5179 Func_Call : Node_Id := Function_Call;
5180 Function_Id : Entity_Id;
5181 Result_Subt : Entity_Id;
5182 Ref_Type : Entity_Id;
5183 Ptr_Typ_Decl : Node_Id;
5188 -- Step past qualification or unchecked conversion (the latter can occur
5189 -- in cases of calls to 'Input).
5191 if Nkind_In (Func_Call, N_Qualified_Expression,
5192 N_Unchecked_Type_Conversion)
5194 Func_Call := Expression (Func_Call);
5197 -- If the call has already been processed to add build-in-place actuals
5198 -- then return. This should not normally occur in an assignment context,
5199 -- but we add the protection as a defensive measure.
5201 if Is_Expanded_Build_In_Place_Call (Func_Call) then
5205 -- Mark the call as processed as a build-in-place call
5207 Set_Is_Expanded_Build_In_Place_Call (Func_Call);
5209 Loc := Sloc (Function_Call);
5211 if Is_Entity_Name (Name (Func_Call)) then
5212 Function_Id := Entity (Name (Func_Call));
5214 elsif Nkind (Name (Func_Call)) = N_Explicit_Dereference then
5215 Function_Id := Etype (Name (Func_Call));
5218 raise Program_Error;
5221 Result_Subt := Etype (Function_Id);
5223 -- When the result subtype is unconstrained, an additional actual must
5224 -- be passed to indicate that the caller is providing the return object.
5225 -- This parameter must also be passed when the called function has a
5226 -- controlling result, because dispatching calls to the function needs
5227 -- to be treated effectively the same as calls to class-wide functions.
5229 Add_Alloc_Form_Actual_To_Build_In_Place_Call
5230 (Func_Call, Function_Id, Alloc_Form => Caller_Allocation);
5232 -- If Lhs is a selected component, then pass it along so that its prefix
5233 -- object will be used as the source of the finalization list.
5235 if Nkind (Lhs) = N_Selected_Component then
5236 Add_Final_List_Actual_To_Build_In_Place_Call
5237 (Func_Call, Function_Id, Acc_Type => Empty, Sel_Comp => Lhs);
5239 Add_Final_List_Actual_To_Build_In_Place_Call
5240 (Func_Call, Function_Id, Acc_Type => Empty);
5243 Add_Task_Actuals_To_Build_In_Place_Call
5244 (Func_Call, Function_Id, Make_Identifier (Loc, Name_uMaster));
5246 -- Add an implicit actual to the function call that provides access to
5247 -- the caller's return object.
5249 Add_Access_Actual_To_Build_In_Place_Call
5252 Make_Unchecked_Type_Conversion (Loc,
5253 Subtype_Mark => New_Reference_To (Result_Subt, Loc),
5254 Expression => Relocate_Node (Lhs)));
5256 -- Create an access type designating the function's result subtype
5259 Make_Defining_Identifier (Loc, New_Internal_Name ('A'));
5262 Make_Full_Type_Declaration (Loc,
5263 Defining_Identifier => Ref_Type,
5265 Make_Access_To_Object_Definition (Loc,
5266 All_Present => True,
5267 Subtype_Indication =>
5268 New_Reference_To (Result_Subt, Loc)));
5270 Insert_After_And_Analyze (Assign, Ptr_Typ_Decl);
5272 -- Finally, create an access object initialized to a reference to the
5276 Make_Defining_Identifier (Loc,
5277 Chars => New_Internal_Name ('R'));
5278 Set_Etype (Def_Id, Ref_Type);
5281 Make_Reference (Loc,
5282 Prefix => Relocate_Node (Func_Call));
5284 Insert_After_And_Analyze (Ptr_Typ_Decl,
5285 Make_Object_Declaration (Loc,
5286 Defining_Identifier => Def_Id,
5287 Object_Definition => New_Reference_To (Ref_Type, Loc),
5288 Expression => New_Expr));
5290 Rewrite (Assign, Make_Null_Statement (Loc));
5291 end Make_Build_In_Place_Call_In_Assignment;
5293 ----------------------------------------------------
5294 -- Make_Build_In_Place_Call_In_Object_Declaration --
5295 ----------------------------------------------------
5297 procedure Make_Build_In_Place_Call_In_Object_Declaration
5298 (Object_Decl : Node_Id;
5299 Function_Call : Node_Id)
5302 Obj_Def_Id : constant Entity_Id :=
5303 Defining_Identifier (Object_Decl);
5305 Func_Call : Node_Id := Function_Call;
5306 Function_Id : Entity_Id;
5307 Result_Subt : Entity_Id;
5308 Caller_Object : Node_Id;
5309 Call_Deref : Node_Id;
5310 Ref_Type : Entity_Id;
5311 Ptr_Typ_Decl : Node_Id;
5314 Enclosing_Func : Entity_Id;
5315 Pass_Caller_Acc : Boolean := False;
5318 -- Step past qualification or unchecked conversion (the latter can occur
5319 -- in cases of calls to 'Input).
5321 if Nkind_In (Func_Call, N_Qualified_Expression,
5322 N_Unchecked_Type_Conversion)
5324 Func_Call := Expression (Func_Call);
5327 -- If the call has already been processed to add build-in-place actuals
5328 -- then return. This should not normally occur in an object declaration,
5329 -- but we add the protection as a defensive measure.
5331 if Is_Expanded_Build_In_Place_Call (Func_Call) then
5335 -- Mark the call as processed as a build-in-place call
5337 Set_Is_Expanded_Build_In_Place_Call (Func_Call);
5339 Loc := Sloc (Function_Call);
5341 if Is_Entity_Name (Name (Func_Call)) then
5342 Function_Id := Entity (Name (Func_Call));
5344 elsif Nkind (Name (Func_Call)) = N_Explicit_Dereference then
5345 Function_Id := Etype (Name (Func_Call));
5348 raise Program_Error;
5351 Result_Subt := Etype (Function_Id);
5353 -- In the constrained case, add an implicit actual to the function call
5354 -- that provides access to the declared object. An unchecked conversion
5355 -- to the (specific) result type of the function is inserted to handle
5356 -- the case where the object is declared with a class-wide type.
5358 if Is_Constrained (Underlying_Type (Result_Subt)) then
5360 Make_Unchecked_Type_Conversion (Loc,
5361 Subtype_Mark => New_Reference_To (Result_Subt, Loc),
5362 Expression => New_Reference_To (Obj_Def_Id, Loc));
5364 -- When the function has a controlling result, an allocation-form
5365 -- parameter must be passed indicating that the caller is allocating
5366 -- the result object. This is needed because such a function can be
5367 -- called as a dispatching operation and must be treated similarly
5368 -- to functions with unconstrained result subtypes.
5370 Add_Alloc_Form_Actual_To_Build_In_Place_Call
5371 (Func_Call, Function_Id, Alloc_Form => Caller_Allocation);
5373 -- If the function's result subtype is unconstrained and the object is
5374 -- a return object of an enclosing build-in-place function, then the
5375 -- implicit build-in-place parameters of the enclosing function must be
5376 -- passed along to the called function.
5378 elsif Nkind (Parent (Object_Decl)) = N_Extended_Return_Statement then
5379 Pass_Caller_Acc := True;
5381 Enclosing_Func := Enclosing_Subprogram (Obj_Def_Id);
5383 -- If the enclosing function has a constrained result type, then
5384 -- caller allocation will be used.
5386 if Is_Constrained (Etype (Enclosing_Func)) then
5387 Add_Alloc_Form_Actual_To_Build_In_Place_Call
5388 (Func_Call, Function_Id, Alloc_Form => Caller_Allocation);
5390 -- Otherwise, when the enclosing function has an unconstrained result
5391 -- type, the BIP_Alloc_Form formal of the enclosing function must be
5392 -- passed along to the callee.
5395 Add_Alloc_Form_Actual_To_Build_In_Place_Call
5400 (Build_In_Place_Formal (Enclosing_Func, BIP_Alloc_Form),
5404 -- Retrieve the BIPacc formal from the enclosing function and convert
5405 -- it to the access type of the callee's BIP_Object_Access formal.
5408 Make_Unchecked_Type_Conversion (Loc,
5412 (Build_In_Place_Formal (Function_Id, BIP_Object_Access)),
5416 (Build_In_Place_Formal (Enclosing_Func, BIP_Object_Access),
5419 -- In other unconstrained cases, pass an indication to do the allocation
5420 -- on the secondary stack and set Caller_Object to Empty so that a null
5421 -- value will be passed for the caller's object address. A transient
5422 -- scope is established to ensure eventual cleanup of the result.
5425 Add_Alloc_Form_Actual_To_Build_In_Place_Call
5428 Alloc_Form => Secondary_Stack);
5429 Caller_Object := Empty;
5431 Establish_Transient_Scope (Object_Decl, Sec_Stack => True);
5434 Add_Final_List_Actual_To_Build_In_Place_Call
5435 (Func_Call, Function_Id, Acc_Type => Empty);
5437 if Nkind (Parent (Object_Decl)) = N_Extended_Return_Statement
5438 and then Has_Task (Result_Subt)
5440 Enclosing_Func := Enclosing_Subprogram (Obj_Def_Id);
5442 -- Here we're passing along the master that was passed in to this
5445 Add_Task_Actuals_To_Build_In_Place_Call
5446 (Func_Call, Function_Id,
5449 (Build_In_Place_Formal (Enclosing_Func, BIP_Master), Loc));
5452 Add_Task_Actuals_To_Build_In_Place_Call
5453 (Func_Call, Function_Id, Make_Identifier (Loc, Name_uMaster));
5456 Add_Access_Actual_To_Build_In_Place_Call
5457 (Func_Call, Function_Id, Caller_Object, Is_Access => Pass_Caller_Acc);
5459 -- Create an access type designating the function's result subtype
5462 Make_Defining_Identifier (Loc, New_Internal_Name ('A'));
5465 Make_Full_Type_Declaration (Loc,
5466 Defining_Identifier => Ref_Type,
5468 Make_Access_To_Object_Definition (Loc,
5469 All_Present => True,
5470 Subtype_Indication =>
5471 New_Reference_To (Result_Subt, Loc)));
5473 -- The access type and its accompanying object must be inserted after
5474 -- the object declaration in the constrained case, so that the function
5475 -- call can be passed access to the object. In the unconstrained case,
5476 -- the access type and object must be inserted before the object, since
5477 -- the object declaration is rewritten to be a renaming of a dereference
5478 -- of the access object.
5480 if Is_Constrained (Underlying_Type (Result_Subt)) then
5481 Insert_After_And_Analyze (Object_Decl, Ptr_Typ_Decl);
5483 Insert_Before_And_Analyze (Object_Decl, Ptr_Typ_Decl);
5486 -- Finally, create an access object initialized to a reference to the
5490 Make_Defining_Identifier (Loc,
5491 Chars => New_Internal_Name ('R'));
5492 Set_Etype (Def_Id, Ref_Type);
5495 Make_Reference (Loc,
5496 Prefix => Relocate_Node (Func_Call));
5498 Insert_After_And_Analyze (Ptr_Typ_Decl,
5499 Make_Object_Declaration (Loc,
5500 Defining_Identifier => Def_Id,
5501 Object_Definition => New_Reference_To (Ref_Type, Loc),
5502 Expression => New_Expr));
5504 if Is_Constrained (Underlying_Type (Result_Subt)) then
5505 Set_Expression (Object_Decl, Empty);
5506 Set_No_Initialization (Object_Decl);
5508 -- In case of an unconstrained result subtype, rewrite the object
5509 -- declaration as an object renaming where the renamed object is a
5510 -- dereference of <function_Call>'reference:
5512 -- Obj : Subt renames <function_call>'Ref.all;
5516 Make_Explicit_Dereference (Loc,
5517 Prefix => New_Reference_To (Def_Id, Loc));
5519 Rewrite (Object_Decl,
5520 Make_Object_Renaming_Declaration (Loc,
5521 Defining_Identifier => Make_Defining_Identifier (Loc,
5522 New_Internal_Name ('D')),
5523 Access_Definition => Empty,
5524 Subtype_Mark => New_Occurrence_Of (Result_Subt, Loc),
5525 Name => Call_Deref));
5527 Set_Renamed_Object (Defining_Identifier (Object_Decl), Call_Deref);
5529 Analyze (Object_Decl);
5531 -- Replace the internal identifier of the renaming declaration's
5532 -- entity with identifier of the original object entity. We also have
5533 -- to exchange the entities containing their defining identifiers to
5534 -- ensure the correct replacement of the object declaration by the
5535 -- object renaming declaration to avoid homograph conflicts (since
5536 -- the object declaration's defining identifier was already entered
5537 -- in current scope). The Next_Entity links of the two entities also
5538 -- have to be swapped since the entities are part of the return
5539 -- scope's entity list and the list structure would otherwise be
5543 Renaming_Def_Id : constant Entity_Id :=
5544 Defining_Identifier (Object_Decl);
5545 Next_Entity_Temp : constant Entity_Id :=
5546 Next_Entity (Renaming_Def_Id);
5548 Set_Chars (Renaming_Def_Id, Chars (Obj_Def_Id));
5550 -- Swap next entity links in preparation for exchanging entities
5552 Set_Next_Entity (Renaming_Def_Id, Next_Entity (Obj_Def_Id));
5553 Set_Next_Entity (Obj_Def_Id, Next_Entity_Temp);
5555 Exchange_Entities (Renaming_Def_Id, Obj_Def_Id);
5559 -- If the object entity has a class-wide Etype, then we need to change
5560 -- it to the result subtype of the function call, because otherwise the
5561 -- object will be class-wide without an explicit initialization and
5562 -- won't be allocated properly by the back end. It seems unclean to make
5563 -- such a revision to the type at this point, and we should try to
5564 -- improve this treatment when build-in-place functions with class-wide
5565 -- results are implemented. ???
5567 if Is_Class_Wide_Type (Etype (Defining_Identifier (Object_Decl))) then
5568 Set_Etype (Defining_Identifier (Object_Decl), Result_Subt);
5570 end Make_Build_In_Place_Call_In_Object_Declaration;