1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 with Atree
; use Atree
;
27 with Checks
; use Checks
;
28 with Debug
; use Debug
;
29 with Einfo
; use Einfo
;
30 with Errout
; use Errout
;
31 with Elists
; use Elists
;
32 with Exp_Atag
; use Exp_Atag
;
33 with Exp_Ch2
; use Exp_Ch2
;
34 with Exp_Ch3
; use Exp_Ch3
;
35 with Exp_Ch7
; use Exp_Ch7
;
36 with Exp_Ch9
; use Exp_Ch9
;
37 with Exp_Dbug
; use Exp_Dbug
;
38 with Exp_Disp
; use Exp_Disp
;
39 with Exp_Dist
; use Exp_Dist
;
40 with Exp_Intr
; use Exp_Intr
;
41 with Exp_Pakd
; use Exp_Pakd
;
42 with Exp_Tss
; use Exp_Tss
;
43 with Exp_Util
; use Exp_Util
;
44 with Exp_VFpt
; use Exp_VFpt
;
45 with Fname
; use Fname
;
46 with Freeze
; use Freeze
;
47 with Inline
; use Inline
;
49 with Namet
; use Namet
;
50 with Nlists
; use Nlists
;
51 with Nmake
; use Nmake
;
53 with Restrict
; use Restrict
;
54 with Rident
; use Rident
;
55 with Rtsfind
; use Rtsfind
;
57 with Sem_Aux
; use Sem_Aux
;
58 with Sem_Ch6
; use Sem_Ch6
;
59 with Sem_Ch8
; use Sem_Ch8
;
60 with Sem_Ch12
; use Sem_Ch12
;
61 with Sem_Ch13
; use Sem_Ch13
;
62 with Sem_Eval
; use Sem_Eval
;
63 with Sem_Disp
; use Sem_Disp
;
64 with Sem_Dist
; use Sem_Dist
;
65 with Sem_Mech
; use Sem_Mech
;
66 with Sem_Res
; use Sem_Res
;
67 with Sem_SCIL
; use Sem_SCIL
;
68 with Sem_Util
; use Sem_Util
;
69 with Sinfo
; use Sinfo
;
70 with Snames
; use Snames
;
71 with Stand
; use Stand
;
72 with Tbuild
; use Tbuild
;
73 with Uintp
; use Uintp
;
74 with Validsw
; use Validsw
;
76 package body Exp_Ch6
is
78 -----------------------
79 -- Local Subprograms --
80 -----------------------
82 procedure Add_Access_Actual_To_Build_In_Place_Call
83 (Function_Call
: Node_Id
;
84 Function_Id
: Entity_Id
;
85 Return_Object
: Node_Id
;
86 Is_Access
: Boolean := False);
87 -- Ada 2005 (AI-318-02): Apply the Unrestricted_Access attribute to the
88 -- object name given by Return_Object and add the attribute to the end of
89 -- the actual parameter list associated with the build-in-place function
90 -- call denoted by Function_Call. However, if Is_Access is True, then
91 -- Return_Object is already an access expression, in which case it's passed
92 -- along directly to the build-in-place function. Finally, if Return_Object
93 -- is empty, then pass a null literal as the actual.
95 procedure Add_Alloc_Form_Actual_To_Build_In_Place_Call
96 (Function_Call
: Node_Id
;
97 Function_Id
: Entity_Id
;
98 Alloc_Form
: BIP_Allocation_Form
:= Unspecified
;
99 Alloc_Form_Exp
: Node_Id
:= Empty
);
100 -- Ada 2005 (AI-318-02): Add an actual indicating the form of allocation,
101 -- if any, to be done by a build-in-place function. If Alloc_Form_Exp is
102 -- present, then use it, otherwise pass a literal corresponding to the
103 -- Alloc_Form parameter (which must not be Unspecified in that case).
105 procedure Add_Extra_Actual_To_Call
106 (Subprogram_Call
: Node_Id
;
107 Extra_Formal
: Entity_Id
;
108 Extra_Actual
: Node_Id
);
109 -- Adds Extra_Actual as a named parameter association for the formal
110 -- Extra_Formal in Subprogram_Call.
112 procedure Add_Final_List_Actual_To_Build_In_Place_Call
113 (Function_Call
: Node_Id
;
114 Function_Id
: Entity_Id
;
115 Acc_Type
: Entity_Id
;
116 Sel_Comp
: Node_Id
:= Empty
);
117 -- Ada 2005 (AI-318-02): For a build-in-place call, if the result type has
118 -- controlled parts, add an actual parameter that is a pointer to
119 -- appropriate finalization list. The finalization list is that of the
120 -- current scope, except for "new Acc'(F(...))" in which case it's the
121 -- finalization list of the access type returned by the allocator. Acc_Type
122 -- is that type in the allocator case; Empty otherwise. If Sel_Comp is
123 -- not Empty, then it denotes a selected component and the finalization
124 -- list is obtained from the _controller list of the prefix object.
126 procedure Add_Task_Actuals_To_Build_In_Place_Call
127 (Function_Call
: Node_Id
;
128 Function_Id
: Entity_Id
;
129 Master_Actual
: Node_Id
);
130 -- Ada 2005 (AI-318-02): For a build-in-place call, if the result type
131 -- contains tasks, add two actual parameters: the master, and a pointer to
132 -- the caller's activation chain. Master_Actual is the actual parameter
133 -- expression to pass for the master. In most cases, this is the current
134 -- master (_master). The two exceptions are: If the function call is the
135 -- initialization expression for an allocator, we pass the master of the
136 -- access type. If the function call is the initialization expression for
137 -- a return object, we pass along the master passed in by the caller. The
138 -- activation chain to pass is always the local one.
140 procedure Check_Overriding_Operation
(Subp
: Entity_Id
);
141 -- Subp is a dispatching operation. Check whether it may override an
142 -- inherited private operation, in which case its DT entry is that of
143 -- the hidden operation, not the one it may have received earlier.
144 -- This must be done before emitting the code to set the corresponding
145 -- DT to the address of the subprogram. The actual placement of Subp in
146 -- the proper place in the list of primitive operations is done in
147 -- Declare_Inherited_Private_Subprograms, which also has to deal with
148 -- implicit operations. This duplication is unavoidable for now???
150 procedure Detect_Infinite_Recursion
(N
: Node_Id
; Spec
: Entity_Id
);
151 -- This procedure is called only if the subprogram body N, whose spec
152 -- has the given entity Spec, contains a parameterless recursive call.
153 -- It attempts to generate runtime code to detect if this a case of
154 -- infinite recursion.
156 -- The body is scanned to determine dependencies. If the only external
157 -- dependencies are on a small set of scalar variables, then the values
158 -- of these variables are captured on entry to the subprogram, and if
159 -- the values are not changed for the call, we know immediately that
160 -- we have an infinite recursion.
162 procedure Expand_Actuals
(N
: Node_Id
; Subp
: Entity_Id
);
163 -- For each actual of an in-out or out parameter which is a numeric
164 -- (view) conversion of the form T (A), where A denotes a variable,
165 -- we insert the declaration:
167 -- Temp : T[ := T (A)];
169 -- prior to the call. Then we replace the actual with a reference to Temp,
170 -- and append the assignment:
172 -- A := TypeA (Temp);
174 -- after the call. Here TypeA is the actual type of variable A. For out
175 -- parameters, the initial declaration has no expression. If A is not an
176 -- entity name, we generate instead:
178 -- Var : TypeA renames A;
179 -- Temp : T := Var; -- omitting expression for out parameter.
181 -- Var := TypeA (Temp);
183 -- For other in-out parameters, we emit the required constraint checks
184 -- before and/or after the call.
186 -- For all parameter modes, actuals that denote components and slices of
187 -- packed arrays are expanded into suitable temporaries.
189 -- For non-scalar objects that are possibly unaligned, add call by copy
190 -- code (copy in for IN and IN OUT, copy out for OUT and IN OUT).
192 procedure Expand_Inlined_Call
195 Orig_Subp
: Entity_Id
);
196 -- If called subprogram can be inlined by the front-end, retrieve the
197 -- analyzed body, replace formals with actuals and expand call in place.
198 -- Generate thunks for actuals that are expressions, and insert the
199 -- corresponding constant declarations before the call. If the original
200 -- call is to a derived operation, the return type is the one of the
201 -- derived operation, but the body is that of the original, so return
202 -- expressions in the body must be converted to the desired type (which
203 -- is simply not noted in the tree without inline expansion).
205 function Expand_Protected_Object_Reference
207 Scop
: Entity_Id
) return Node_Id
;
209 procedure Expand_Protected_Subprogram_Call
213 -- A call to a protected subprogram within the protected object may appear
214 -- as a regular call. The list of actuals must be expanded to contain a
215 -- reference to the object itself, and the call becomes a call to the
216 -- corresponding protected subprogram.
218 function Is_Null_Procedure
(Subp
: Entity_Id
) return Boolean;
219 -- Predicate to recognize stubbed procedures and null procedures, which
220 -- can be inlined unconditionally in all cases.
222 ----------------------------------------------
223 -- Add_Access_Actual_To_Build_In_Place_Call --
224 ----------------------------------------------
226 procedure Add_Access_Actual_To_Build_In_Place_Call
227 (Function_Call
: Node_Id
;
228 Function_Id
: Entity_Id
;
229 Return_Object
: Node_Id
;
230 Is_Access
: Boolean := False)
232 Loc
: constant Source_Ptr
:= Sloc
(Function_Call
);
233 Obj_Address
: Node_Id
;
234 Obj_Acc_Formal
: Entity_Id
;
237 -- Locate the implicit access parameter in the called function
239 Obj_Acc_Formal
:= Build_In_Place_Formal
(Function_Id
, BIP_Object_Access
);
241 -- If no return object is provided, then pass null
243 if not Present
(Return_Object
) then
244 Obj_Address
:= Make_Null
(Loc
);
245 Set_Parent
(Obj_Address
, Function_Call
);
247 -- If Return_Object is already an expression of an access type, then use
248 -- it directly, since it must be an access value denoting the return
249 -- object, and couldn't possibly be the return object itself.
252 Obj_Address
:= Return_Object
;
253 Set_Parent
(Obj_Address
, Function_Call
);
255 -- Apply Unrestricted_Access to caller's return object
259 Make_Attribute_Reference
(Loc
,
260 Prefix
=> Return_Object
,
261 Attribute_Name
=> Name_Unrestricted_Access
);
263 Set_Parent
(Return_Object
, Obj_Address
);
264 Set_Parent
(Obj_Address
, Function_Call
);
267 Analyze_And_Resolve
(Obj_Address
, Etype
(Obj_Acc_Formal
));
269 -- Build the parameter association for the new actual and add it to the
270 -- end of the function's actuals.
272 Add_Extra_Actual_To_Call
(Function_Call
, Obj_Acc_Formal
, Obj_Address
);
273 end Add_Access_Actual_To_Build_In_Place_Call
;
275 --------------------------------------------------
276 -- Add_Alloc_Form_Actual_To_Build_In_Place_Call --
277 --------------------------------------------------
279 procedure Add_Alloc_Form_Actual_To_Build_In_Place_Call
280 (Function_Call
: Node_Id
;
281 Function_Id
: Entity_Id
;
282 Alloc_Form
: BIP_Allocation_Form
:= Unspecified
;
283 Alloc_Form_Exp
: Node_Id
:= Empty
)
285 Loc
: constant Source_Ptr
:= Sloc
(Function_Call
);
286 Alloc_Form_Actual
: Node_Id
;
287 Alloc_Form_Formal
: Node_Id
;
290 -- The allocation form generally doesn't need to be passed in the case
291 -- of a constrained result subtype, since normally the caller performs
292 -- the allocation in that case. However this formal is still needed in
293 -- the case where the function has a tagged result, because generally
294 -- such functions can be called in a dispatching context and such calls
295 -- must be handled like calls to class-wide functions.
297 if Is_Constrained
(Underlying_Type
(Etype
(Function_Id
)))
298 and then not Is_Tagged_Type
(Underlying_Type
(Etype
(Function_Id
)))
303 -- Locate the implicit allocation form parameter in the called function.
304 -- Maybe it would be better for each implicit formal of a build-in-place
305 -- function to have a flag or a Uint attribute to identify it. ???
307 Alloc_Form_Formal
:= Build_In_Place_Formal
(Function_Id
, BIP_Alloc_Form
);
309 if Present
(Alloc_Form_Exp
) then
310 pragma Assert
(Alloc_Form
= Unspecified
);
312 Alloc_Form_Actual
:= Alloc_Form_Exp
;
315 pragma Assert
(Alloc_Form
/= Unspecified
);
318 Make_Integer_Literal
(Loc
,
319 Intval
=> UI_From_Int
(BIP_Allocation_Form
'Pos (Alloc_Form
)));
322 Analyze_And_Resolve
(Alloc_Form_Actual
, Etype
(Alloc_Form_Formal
));
324 -- Build the parameter association for the new actual and add it to the
325 -- end of the function's actuals.
327 Add_Extra_Actual_To_Call
328 (Function_Call
, Alloc_Form_Formal
, Alloc_Form_Actual
);
329 end Add_Alloc_Form_Actual_To_Build_In_Place_Call
;
331 ------------------------------
332 -- Add_Extra_Actual_To_Call --
333 ------------------------------
335 procedure Add_Extra_Actual_To_Call
336 (Subprogram_Call
: Node_Id
;
337 Extra_Formal
: Entity_Id
;
338 Extra_Actual
: Node_Id
)
340 Loc
: constant Source_Ptr
:= Sloc
(Subprogram_Call
);
341 Param_Assoc
: Node_Id
;
345 Make_Parameter_Association
(Loc
,
346 Selector_Name
=> New_Occurrence_Of
(Extra_Formal
, Loc
),
347 Explicit_Actual_Parameter
=> Extra_Actual
);
349 Set_Parent
(Param_Assoc
, Subprogram_Call
);
350 Set_Parent
(Extra_Actual
, Param_Assoc
);
352 if Present
(Parameter_Associations
(Subprogram_Call
)) then
353 if Nkind
(Last
(Parameter_Associations
(Subprogram_Call
))) =
354 N_Parameter_Association
357 -- Find last named actual, and append
362 L
:= First_Actual
(Subprogram_Call
);
363 while Present
(L
) loop
364 if No
(Next_Actual
(L
)) then
365 Set_Next_Named_Actual
(Parent
(L
), Extra_Actual
);
373 Set_First_Named_Actual
(Subprogram_Call
, Extra_Actual
);
376 Append
(Param_Assoc
, To
=> Parameter_Associations
(Subprogram_Call
));
379 Set_Parameter_Associations
(Subprogram_Call
, New_List
(Param_Assoc
));
380 Set_First_Named_Actual
(Subprogram_Call
, Extra_Actual
);
382 end Add_Extra_Actual_To_Call
;
384 --------------------------------------------------
385 -- Add_Final_List_Actual_To_Build_In_Place_Call --
386 --------------------------------------------------
388 procedure Add_Final_List_Actual_To_Build_In_Place_Call
389 (Function_Call
: Node_Id
;
390 Function_Id
: Entity_Id
;
391 Acc_Type
: Entity_Id
;
392 Sel_Comp
: Node_Id
:= Empty
)
394 Loc
: constant Source_Ptr
:= Sloc
(Function_Call
);
395 Final_List
: Node_Id
;
396 Final_List_Actual
: Node_Id
;
397 Final_List_Formal
: Node_Id
;
398 Is_Ctrl_Result
: constant Boolean :=
400 (Underlying_Type
(Etype
(Function_Id
)));
403 -- No such extra parameter is needed if there are no controlled parts.
404 -- The test for Needs_Finalization accounts for class-wide results
405 -- (which potentially have controlled parts, even if the root type
406 -- doesn't), and the test for a tagged result type is needed because
407 -- calls to such a function can in general occur in dispatching
408 -- contexts, which must be treated the same as a call to class-wide
409 -- functions. Both of these situations require that a finalization list
412 if not Needs_BIP_Final_List
(Function_Id
) then
416 -- Locate implicit finalization list parameter in the called function
418 Final_List_Formal
:= Build_In_Place_Formal
(Function_Id
, BIP_Final_List
);
420 -- Create the actual which is a pointer to the appropriate finalization
421 -- list. Acc_Type is present if and only if this call is the
422 -- initialization of an allocator. Use the Current_Scope or the
423 -- Acc_Type as appropriate.
425 if Present
(Acc_Type
)
426 and then (Ekind
(Acc_Type
) = E_Anonymous_Access_Type
428 Present
(Associated_Final_Chain
(Base_Type
(Acc_Type
))))
430 Final_List
:= Find_Final_List
(Acc_Type
);
432 -- If Sel_Comp is present and the function result is controlled, then
433 -- the finalization list will be obtained from the _controller list of
434 -- the selected component's prefix object.
436 elsif Present
(Sel_Comp
) and then Is_Ctrl_Result
then
437 Final_List
:= Find_Final_List
(Current_Scope
, Sel_Comp
);
440 Final_List
:= Find_Final_List
(Current_Scope
);
444 Make_Attribute_Reference
(Loc
,
445 Prefix
=> Final_List
,
446 Attribute_Name
=> Name_Unrestricted_Access
);
448 Analyze_And_Resolve
(Final_List_Actual
, Etype
(Final_List_Formal
));
450 -- Build the parameter association for the new actual and add it to the
451 -- end of the function's actuals.
453 Add_Extra_Actual_To_Call
454 (Function_Call
, Final_List_Formal
, Final_List_Actual
);
455 end Add_Final_List_Actual_To_Build_In_Place_Call
;
457 ---------------------------------------------
458 -- Add_Task_Actuals_To_Build_In_Place_Call --
459 ---------------------------------------------
461 procedure Add_Task_Actuals_To_Build_In_Place_Call
462 (Function_Call
: Node_Id
;
463 Function_Id
: Entity_Id
;
464 Master_Actual
: Node_Id
)
465 -- Note: Master_Actual can be Empty, but only if there are no tasks
467 Loc
: constant Source_Ptr
:= Sloc
(Function_Call
);
470 -- No such extra parameters are needed if there are no tasks
472 if not Has_Task
(Etype
(Function_Id
)) then
479 Master_Formal
: Node_Id
;
481 -- Locate implicit master parameter in the called function
483 Master_Formal
:= Build_In_Place_Formal
(Function_Id
, BIP_Master
);
485 Analyze_And_Resolve
(Master_Actual
, Etype
(Master_Formal
));
487 -- Build the parameter association for the new actual and add it to
488 -- the end of the function's actuals.
490 Add_Extra_Actual_To_Call
491 (Function_Call
, Master_Formal
, Master_Actual
);
494 -- The activation chain
497 Activation_Chain_Actual
: Node_Id
;
498 Activation_Chain_Formal
: Node_Id
;
501 -- Locate implicit activation chain parameter in the called function
503 Activation_Chain_Formal
:= Build_In_Place_Formal
504 (Function_Id
, BIP_Activation_Chain
);
506 -- Create the actual which is a pointer to the current activation
509 Activation_Chain_Actual
:=
510 Make_Attribute_Reference
(Loc
,
511 Prefix
=> Make_Identifier
(Loc
, Name_uChain
),
512 Attribute_Name
=> Name_Unrestricted_Access
);
515 (Activation_Chain_Actual
, Etype
(Activation_Chain_Formal
));
517 -- Build the parameter association for the new actual and add it to
518 -- the end of the function's actuals.
520 Add_Extra_Actual_To_Call
521 (Function_Call
, Activation_Chain_Formal
, Activation_Chain_Actual
);
523 end Add_Task_Actuals_To_Build_In_Place_Call
;
525 -----------------------
526 -- BIP_Formal_Suffix --
527 -----------------------
529 function BIP_Formal_Suffix
(Kind
: BIP_Formal_Kind
) return String is
532 when BIP_Alloc_Form
=>
534 when BIP_Final_List
=>
535 return "BIPfinallist";
538 when BIP_Activation_Chain
=>
539 return "BIPactivationchain";
540 when BIP_Object_Access
=>
543 end BIP_Formal_Suffix
;
545 ---------------------------
546 -- Build_In_Place_Formal --
547 ---------------------------
549 function Build_In_Place_Formal
551 Kind
: BIP_Formal_Kind
) return Entity_Id
553 Extra_Formal
: Entity_Id
:= Extra_Formals
(Func
);
556 -- Maybe it would be better for each implicit formal of a build-in-place
557 -- function to have a flag or a Uint attribute to identify it. ???
560 pragma Assert
(Present
(Extra_Formal
));
562 Chars
(Extra_Formal
) =
563 New_External_Name
(Chars
(Func
), BIP_Formal_Suffix
(Kind
));
564 Next_Formal_With_Extras
(Extra_Formal
);
568 end Build_In_Place_Formal
;
570 --------------------------------
571 -- Check_Overriding_Operation --
572 --------------------------------
574 procedure Check_Overriding_Operation
(Subp
: Entity_Id
) is
575 Typ
: constant Entity_Id
:= Find_Dispatching_Type
(Subp
);
576 Op_List
: constant Elist_Id
:= Primitive_Operations
(Typ
);
582 if Is_Derived_Type
(Typ
)
583 and then not Is_Private_Type
(Typ
)
584 and then In_Open_Scopes
(Scope
(Etype
(Typ
)))
585 and then Typ
= Base_Type
(Typ
)
587 -- Subp overrides an inherited private operation if there is an
588 -- inherited operation with a different name than Subp (see
589 -- Derive_Subprogram) whose Alias is a hidden subprogram with the
590 -- same name as Subp.
592 Op_Elmt
:= First_Elmt
(Op_List
);
593 while Present
(Op_Elmt
) loop
594 Prim_Op
:= Node
(Op_Elmt
);
595 Par_Op
:= Alias
(Prim_Op
);
598 and then not Comes_From_Source
(Prim_Op
)
599 and then Chars
(Prim_Op
) /= Chars
(Par_Op
)
600 and then Chars
(Par_Op
) = Chars
(Subp
)
601 and then Is_Hidden
(Par_Op
)
602 and then Type_Conformant
(Prim_Op
, Subp
)
604 Set_DT_Position
(Subp
, DT_Position
(Prim_Op
));
610 end Check_Overriding_Operation
;
612 -------------------------------
613 -- Detect_Infinite_Recursion --
614 -------------------------------
616 procedure Detect_Infinite_Recursion
(N
: Node_Id
; Spec
: Entity_Id
) is
617 Loc
: constant Source_Ptr
:= Sloc
(N
);
619 Var_List
: constant Elist_Id
:= New_Elmt_List
;
620 -- List of globals referenced by body of procedure
622 Call_List
: constant Elist_Id
:= New_Elmt_List
;
623 -- List of recursive calls in body of procedure
625 Shad_List
: constant Elist_Id
:= New_Elmt_List
;
626 -- List of entity id's for entities created to capture the value of
627 -- referenced globals on entry to the procedure.
629 Scop
: constant Uint
:= Scope_Depth
(Spec
);
630 -- This is used to record the scope depth of the current procedure, so
631 -- that we can identify global references.
633 Max_Vars
: constant := 4;
634 -- Do not test more than four global variables
636 Count_Vars
: Natural := 0;
637 -- Count variables found so far
649 function Process
(Nod
: Node_Id
) return Traverse_Result
;
650 -- Function to traverse the subprogram body (using Traverse_Func)
656 function Process
(Nod
: Node_Id
) return Traverse_Result
is
660 if Nkind
(Nod
) = N_Procedure_Call_Statement
then
662 -- Case of one of the detected recursive calls
664 if Is_Entity_Name
(Name
(Nod
))
665 and then Has_Recursive_Call
(Entity
(Name
(Nod
)))
666 and then Entity
(Name
(Nod
)) = Spec
668 Append_Elmt
(Nod
, Call_List
);
671 -- Any other procedure call may have side effects
677 -- A call to a pure function can always be ignored
679 elsif Nkind
(Nod
) = N_Function_Call
680 and then Is_Entity_Name
(Name
(Nod
))
681 and then Is_Pure
(Entity
(Name
(Nod
)))
685 -- Case of an identifier reference
687 elsif Nkind
(Nod
) = N_Identifier
then
690 -- If no entity, then ignore the reference
692 -- Not clear why this can happen. To investigate, remove this
693 -- test and look at the crash that occurs here in 3401-004 ???
698 -- Ignore entities with no Scope, again not clear how this
699 -- can happen, to investigate, look at 4108-008 ???
701 elsif No
(Scope
(Ent
)) then
704 -- Ignore the reference if not to a more global object
706 elsif Scope_Depth
(Scope
(Ent
)) >= Scop
then
709 -- References to types, exceptions and constants are always OK
712 or else Ekind
(Ent
) = E_Exception
713 or else Ekind
(Ent
) = E_Constant
717 -- If other than a non-volatile scalar variable, we have some
718 -- kind of global reference (e.g. to a function) that we cannot
719 -- deal with so we forget the attempt.
721 elsif Ekind
(Ent
) /= E_Variable
722 or else not Is_Scalar_Type
(Etype
(Ent
))
723 or else Treat_As_Volatile
(Ent
)
727 -- Otherwise we have a reference to a global scalar
730 -- Loop through global entities already detected
732 Elm
:= First_Elmt
(Var_List
);
734 -- If not detected before, record this new global reference
737 Count_Vars
:= Count_Vars
+ 1;
739 if Count_Vars
<= Max_Vars
then
740 Append_Elmt
(Entity
(Nod
), Var_List
);
747 -- If recorded before, ignore
749 elsif Node
(Elm
) = Entity
(Nod
) then
752 -- Otherwise keep looking
762 -- For all other node kinds, recursively visit syntactic children
769 function Traverse_Body
is new Traverse_Func
(Process
);
771 -- Start of processing for Detect_Infinite_Recursion
774 -- Do not attempt detection in No_Implicit_Conditional mode, since we
775 -- won't be able to generate the code to handle the recursion in any
778 if Restriction_Active
(No_Implicit_Conditionals
) then
782 -- Otherwise do traversal and quit if we get abandon signal
784 if Traverse_Body
(N
) = Abandon
then
787 -- We must have a call, since Has_Recursive_Call was set. If not just
788 -- ignore (this is only an error check, so if we have a funny situation,
789 -- due to bugs or errors, we do not want to bomb!)
791 elsif Is_Empty_Elmt_List
(Call_List
) then
795 -- Here is the case where we detect recursion at compile time
797 -- Push our current scope for analyzing the declarations and code that
798 -- we will insert for the checking.
802 -- This loop builds temporary variables for each of the referenced
803 -- globals, so that at the end of the loop the list Shad_List contains
804 -- these temporaries in one-to-one correspondence with the elements in
808 Elm
:= First_Elmt
(Var_List
);
809 while Present
(Elm
) loop
812 Make_Defining_Identifier
(Loc
,
813 Chars
=> New_Internal_Name
('S'));
814 Append_Elmt
(Ent
, Shad_List
);
816 -- Insert a declaration for this temporary at the start of the
817 -- declarations for the procedure. The temporaries are declared as
818 -- constant objects initialized to the current values of the
819 -- corresponding temporaries.
822 Make_Object_Declaration
(Loc
,
823 Defining_Identifier
=> Ent
,
824 Object_Definition
=> New_Occurrence_Of
(Etype
(Var
), Loc
),
825 Constant_Present
=> True,
826 Expression
=> New_Occurrence_Of
(Var
, Loc
));
829 Prepend
(Decl
, Declarations
(N
));
831 Insert_After
(Last
, Decl
);
839 -- Loop through calls
841 Call
:= First_Elmt
(Call_List
);
842 while Present
(Call
) loop
844 -- Build a predicate expression of the form
847 -- and then global1 = temp1
848 -- and then global2 = temp2
851 -- This predicate determines if any of the global values
852 -- referenced by the procedure have changed since the
853 -- current call, if not an infinite recursion is assured.
855 Test
:= New_Occurrence_Of
(Standard_True
, Loc
);
857 Elm1
:= First_Elmt
(Var_List
);
858 Elm2
:= First_Elmt
(Shad_List
);
859 while Present
(Elm1
) loop
865 Left_Opnd
=> New_Occurrence_Of
(Node
(Elm1
), Loc
),
866 Right_Opnd
=> New_Occurrence_Of
(Node
(Elm2
), Loc
)));
872 -- Now we replace the call with the sequence
874 -- if no-changes (see above) then
875 -- raise Storage_Error;
880 Rewrite
(Node
(Call
),
881 Make_If_Statement
(Loc
,
883 Then_Statements
=> New_List
(
884 Make_Raise_Storage_Error
(Loc
,
885 Reason
=> SE_Infinite_Recursion
)),
887 Else_Statements
=> New_List
(
888 Relocate_Node
(Node
(Call
)))));
890 Analyze
(Node
(Call
));
895 -- Remove temporary scope stack entry used for analysis
898 end Detect_Infinite_Recursion
;
904 procedure Expand_Actuals
(N
: Node_Id
; Subp
: Entity_Id
) is
905 Loc
: constant Source_Ptr
:= Sloc
(N
);
910 E_Formal
: Entity_Id
;
912 procedure Add_Call_By_Copy_Code
;
913 -- For cases where the parameter must be passed by copy, this routine
914 -- generates a temporary variable into which the actual is copied and
915 -- then passes this as the parameter. For an OUT or IN OUT parameter,
916 -- an assignment is also generated to copy the result back. The call
917 -- also takes care of any constraint checks required for the type
918 -- conversion case (on both the way in and the way out).
920 procedure Add_Simple_Call_By_Copy_Code
;
921 -- This is similar to the above, but is used in cases where we know
922 -- that all that is needed is to simply create a temporary and copy
923 -- the value in and out of the temporary.
925 procedure Check_Fortran_Logical
;
926 -- A value of type Logical that is passed through a formal parameter
927 -- must be normalized because .TRUE. usually does not have the same
928 -- representation as True. We assume that .FALSE. = False = 0.
929 -- What about functions that return a logical type ???
931 function Is_Legal_Copy
return Boolean;
932 -- Check that an actual can be copied before generating the temporary
933 -- to be used in the call. If the actual is of a by_reference type then
934 -- the program is illegal (this can only happen in the presence of
935 -- rep. clauses that force an incorrect alignment). If the formal is
936 -- a by_reference parameter imposed by a DEC pragma, emit a warning to
937 -- the effect that this might lead to unaligned arguments.
939 function Make_Var
(Actual
: Node_Id
) return Entity_Id
;
940 -- Returns an entity that refers to the given actual parameter,
941 -- Actual (not including any type conversion). If Actual is an
942 -- entity name, then this entity is returned unchanged, otherwise
943 -- a renaming is created to provide an entity for the actual.
945 procedure Reset_Packed_Prefix
;
946 -- The expansion of a packed array component reference is delayed in
947 -- the context of a call. Now we need to complete the expansion, so we
948 -- unmark the analyzed bits in all prefixes.
950 ---------------------------
951 -- Add_Call_By_Copy_Code --
952 ---------------------------
954 procedure Add_Call_By_Copy_Code
is
960 F_Typ
: constant Entity_Id
:= Etype
(Formal
);
965 if not Is_Legal_Copy
then
970 Make_Defining_Identifier
(Loc
,
971 Chars
=> New_Internal_Name
('T'));
973 -- Use formal type for temp, unless formal type is an unconstrained
974 -- array, in which case we don't have to worry about bounds checks,
975 -- and we use the actual type, since that has appropriate bounds.
977 if Is_Array_Type
(F_Typ
) and then not Is_Constrained
(F_Typ
) then
978 Indic
:= New_Occurrence_Of
(Etype
(Actual
), Loc
);
980 Indic
:= New_Occurrence_Of
(Etype
(Formal
), Loc
);
983 if Nkind
(Actual
) = N_Type_Conversion
then
984 V_Typ
:= Etype
(Expression
(Actual
));
986 -- If the formal is an (in-)out parameter, capture the name
987 -- of the variable in order to build the post-call assignment.
989 Var
:= Make_Var
(Expression
(Actual
));
991 Crep
:= not Same_Representation
992 (F_Typ
, Etype
(Expression
(Actual
)));
995 V_Typ
:= Etype
(Actual
);
996 Var
:= Make_Var
(Actual
);
1000 -- Setup initialization for case of in out parameter, or an out
1001 -- parameter where the formal is an unconstrained array (in the
1002 -- latter case, we have to pass in an object with bounds).
1004 -- If this is an out parameter, the initial copy is wasteful, so as
1005 -- an optimization for the one-dimensional case we extract the
1006 -- bounds of the actual and build an uninitialized temporary of the
1009 if Ekind
(Formal
) = E_In_Out_Parameter
1010 or else (Is_Array_Type
(F_Typ
) and then not Is_Constrained
(F_Typ
))
1012 if Nkind
(Actual
) = N_Type_Conversion
then
1013 if Conversion_OK
(Actual
) then
1014 Init
:= OK_Convert_To
(F_Typ
, New_Occurrence_Of
(Var
, Loc
));
1016 Init
:= Convert_To
(F_Typ
, New_Occurrence_Of
(Var
, Loc
));
1019 elsif Ekind
(Formal
) = E_Out_Parameter
1020 and then Is_Array_Type
(F_Typ
)
1021 and then Number_Dimensions
(F_Typ
) = 1
1022 and then not Has_Non_Null_Base_Init_Proc
(F_Typ
)
1024 -- Actual is a one-dimensional array or slice, and the type
1025 -- requires no initialization. Create a temporary of the
1026 -- right size, but do not copy actual into it (optimization).
1030 Make_Subtype_Indication
(Loc
,
1032 New_Occurrence_Of
(F_Typ
, Loc
),
1034 Make_Index_Or_Discriminant_Constraint
(Loc
,
1035 Constraints
=> New_List
(
1038 Make_Attribute_Reference
(Loc
,
1039 Prefix
=> New_Occurrence_Of
(Var
, Loc
),
1040 Attribute_Name
=> Name_First
),
1042 Make_Attribute_Reference
(Loc
,
1043 Prefix
=> New_Occurrence_Of
(Var
, Loc
),
1044 Attribute_Name
=> Name_Last
)))));
1047 Init
:= New_Occurrence_Of
(Var
, Loc
);
1050 -- An initialization is created for packed conversions as
1051 -- actuals for out parameters to enable Make_Object_Declaration
1052 -- to determine the proper subtype for N_Node. Note that this
1053 -- is wasteful because the extra copying on the call side is
1054 -- not required for such out parameters. ???
1056 elsif Ekind
(Formal
) = E_Out_Parameter
1057 and then Nkind
(Actual
) = N_Type_Conversion
1058 and then (Is_Bit_Packed_Array
(F_Typ
)
1060 Is_Bit_Packed_Array
(Etype
(Expression
(Actual
))))
1062 if Conversion_OK
(Actual
) then
1063 Init
:= OK_Convert_To
(F_Typ
, New_Occurrence_Of
(Var
, Loc
));
1065 Init
:= Convert_To
(F_Typ
, New_Occurrence_Of
(Var
, Loc
));
1068 elsif Ekind
(Formal
) = E_In_Parameter
then
1070 -- Handle the case in which the actual is a type conversion
1072 if Nkind
(Actual
) = N_Type_Conversion
then
1073 if Conversion_OK
(Actual
) then
1074 Init
:= OK_Convert_To
(F_Typ
, New_Occurrence_Of
(Var
, Loc
));
1076 Init
:= Convert_To
(F_Typ
, New_Occurrence_Of
(Var
, Loc
));
1079 Init
:= New_Occurrence_Of
(Var
, Loc
);
1087 Make_Object_Declaration
(Loc
,
1088 Defining_Identifier
=> Temp
,
1089 Object_Definition
=> Indic
,
1090 Expression
=> Init
);
1091 Set_Assignment_OK
(N_Node
);
1092 Insert_Action
(N
, N_Node
);
1094 -- Now, normally the deal here is that we use the defining
1095 -- identifier created by that object declaration. There is
1096 -- one exception to this. In the change of representation case
1097 -- the above declaration will end up looking like:
1099 -- temp : type := identifier;
1101 -- And in this case we might as well use the identifier directly
1102 -- and eliminate the temporary. Note that the analysis of the
1103 -- declaration was not a waste of time in that case, since it is
1104 -- what generated the necessary change of representation code. If
1105 -- the change of representation introduced additional code, as in
1106 -- a fixed-integer conversion, the expression is not an identifier
1107 -- and must be kept.
1110 and then Present
(Expression
(N_Node
))
1111 and then Is_Entity_Name
(Expression
(N_Node
))
1113 Temp
:= Entity
(Expression
(N_Node
));
1114 Rewrite
(N_Node
, Make_Null_Statement
(Loc
));
1117 -- For IN parameter, all we do is to replace the actual
1119 if Ekind
(Formal
) = E_In_Parameter
then
1120 Rewrite
(Actual
, New_Reference_To
(Temp
, Loc
));
1123 -- Processing for OUT or IN OUT parameter
1126 -- Kill current value indications for the temporary variable we
1127 -- created, since we just passed it as an OUT parameter.
1129 Kill_Current_Values
(Temp
);
1130 Set_Is_Known_Valid
(Temp
, False);
1132 -- If type conversion, use reverse conversion on exit
1134 if Nkind
(Actual
) = N_Type_Conversion
then
1135 if Conversion_OK
(Actual
) then
1136 Expr
:= OK_Convert_To
(V_Typ
, New_Occurrence_Of
(Temp
, Loc
));
1138 Expr
:= Convert_To
(V_Typ
, New_Occurrence_Of
(Temp
, Loc
));
1141 Expr
:= New_Occurrence_Of
(Temp
, Loc
);
1144 Rewrite
(Actual
, New_Reference_To
(Temp
, Loc
));
1147 -- If the actual is a conversion of a packed reference, it may
1148 -- already have been expanded by Remove_Side_Effects, and the
1149 -- resulting variable is a temporary which does not designate
1150 -- the proper out-parameter, which may not be addressable. In
1151 -- that case, generate an assignment to the original expression
1152 -- (before expansion of the packed reference) so that the proper
1153 -- expansion of assignment to a packed component can take place.
1160 if Is_Renaming_Of_Object
(Var
)
1161 and then Nkind
(Renamed_Object
(Var
)) = N_Selected_Component
1162 and then Is_Entity_Name
(Prefix
(Renamed_Object
(Var
)))
1163 and then Nkind
(Original_Node
(Prefix
(Renamed_Object
(Var
))))
1164 = N_Indexed_Component
1166 Has_Non_Standard_Rep
(Etype
(Prefix
(Renamed_Object
(Var
))))
1168 Obj
:= Renamed_Object
(Var
);
1170 Make_Selected_Component
(Loc
,
1172 New_Copy_Tree
(Original_Node
(Prefix
(Obj
))),
1173 Selector_Name
=> New_Copy
(Selector_Name
(Obj
)));
1174 Reset_Analyzed_Flags
(Lhs
);
1177 Lhs
:= New_Occurrence_Of
(Var
, Loc
);
1180 Set_Assignment_OK
(Lhs
);
1182 Append_To
(Post_Call
,
1183 Make_Assignment_Statement
(Loc
,
1185 Expression
=> Expr
));
1188 end Add_Call_By_Copy_Code
;
1190 ----------------------------------
1191 -- Add_Simple_Call_By_Copy_Code --
1192 ----------------------------------
1194 procedure Add_Simple_Call_By_Copy_Code
is
1202 F_Typ
: constant Entity_Id
:= Etype
(Formal
);
1205 if not Is_Legal_Copy
then
1209 -- Use formal type for temp, unless formal type is an unconstrained
1210 -- array, in which case we don't have to worry about bounds checks,
1211 -- and we use the actual type, since that has appropriate bounds.
1213 if Is_Array_Type
(F_Typ
) and then not Is_Constrained
(F_Typ
) then
1214 Indic
:= New_Occurrence_Of
(Etype
(Actual
), Loc
);
1216 Indic
:= New_Occurrence_Of
(Etype
(Formal
), Loc
);
1219 -- Prepare to generate code
1221 Reset_Packed_Prefix
;
1224 Make_Defining_Identifier
(Loc
,
1225 Chars
=> New_Internal_Name
('T'));
1226 Incod
:= Relocate_Node
(Actual
);
1227 Outcod
:= New_Copy_Tree
(Incod
);
1229 -- Generate declaration of temporary variable, initializing it
1230 -- with the input parameter unless we have an OUT formal or
1231 -- this is an initialization call.
1233 -- If the formal is an out parameter with discriminants, the
1234 -- discriminants must be captured even if the rest of the object
1235 -- is in principle uninitialized, because the discriminants may
1236 -- be read by the called subprogram.
1238 if Ekind
(Formal
) = E_Out_Parameter
then
1241 if Has_Discriminants
(Etype
(Formal
)) then
1242 Indic
:= New_Occurrence_Of
(Etype
(Actual
), Loc
);
1245 elsif Inside_Init_Proc
then
1247 -- Could use a comment here to match comment below ???
1249 if Nkind
(Actual
) /= N_Selected_Component
1251 not Has_Discriminant_Dependent_Constraint
1252 (Entity
(Selector_Name
(Actual
)))
1256 -- Otherwise, keep the component in order to generate the proper
1257 -- actual subtype, that depends on enclosing discriminants.
1265 Make_Object_Declaration
(Loc
,
1266 Defining_Identifier
=> Temp
,
1267 Object_Definition
=> Indic
,
1268 Expression
=> Incod
);
1273 -- If the call is to initialize a component of a composite type,
1274 -- and the component does not depend on discriminants, use the
1275 -- actual type of the component. This is required in case the
1276 -- component is constrained, because in general the formal of the
1277 -- initialization procedure will be unconstrained. Note that if
1278 -- the component being initialized is constrained by an enclosing
1279 -- discriminant, the presence of the initialization in the
1280 -- declaration will generate an expression for the actual subtype.
1282 Set_No_Initialization
(Decl
);
1283 Set_Object_Definition
(Decl
,
1284 New_Occurrence_Of
(Etype
(Actual
), Loc
));
1287 Insert_Action
(N
, Decl
);
1289 -- The actual is simply a reference to the temporary
1291 Rewrite
(Actual
, New_Occurrence_Of
(Temp
, Loc
));
1293 -- Generate copy out if OUT or IN OUT parameter
1295 if Ekind
(Formal
) /= E_In_Parameter
then
1297 Rhs
:= New_Occurrence_Of
(Temp
, Loc
);
1299 -- Deal with conversion
1301 if Nkind
(Lhs
) = N_Type_Conversion
then
1302 Lhs
:= Expression
(Lhs
);
1303 Rhs
:= Convert_To
(Etype
(Actual
), Rhs
);
1306 Append_To
(Post_Call
,
1307 Make_Assignment_Statement
(Loc
,
1309 Expression
=> Rhs
));
1310 Set_Assignment_OK
(Name
(Last
(Post_Call
)));
1312 end Add_Simple_Call_By_Copy_Code
;
1314 ---------------------------
1315 -- Check_Fortran_Logical --
1316 ---------------------------
1318 procedure Check_Fortran_Logical
is
1319 Logical
: constant Entity_Id
:= Etype
(Formal
);
1322 -- Note: this is very incomplete, e.g. it does not handle arrays
1323 -- of logical values. This is really not the right approach at all???)
1326 if Convention
(Subp
) = Convention_Fortran
1327 and then Root_Type
(Etype
(Formal
)) = Standard_Boolean
1328 and then Ekind
(Formal
) /= E_In_Parameter
1330 Var
:= Make_Var
(Actual
);
1331 Append_To
(Post_Call
,
1332 Make_Assignment_Statement
(Loc
,
1333 Name
=> New_Occurrence_Of
(Var
, Loc
),
1335 Unchecked_Convert_To
(
1338 Left_Opnd
=> New_Occurrence_Of
(Var
, Loc
),
1340 Unchecked_Convert_To
(
1342 New_Occurrence_Of
(Standard_False
, Loc
))))));
1344 end Check_Fortran_Logical
;
1350 function Is_Legal_Copy
return Boolean is
1352 -- An attempt to copy a value of such a type can only occur if
1353 -- representation clauses give the actual a misaligned address.
1355 if Is_By_Reference_Type
(Etype
(Formal
)) then
1357 ("misaligned actual cannot be passed by reference", Actual
);
1360 -- For users of Starlet, we assume that the specification of by-
1361 -- reference mechanism is mandatory. This may lead to unaligned
1362 -- objects but at least for DEC legacy code it is known to work.
1363 -- The warning will alert users of this code that a problem may
1366 elsif Mechanism
(Formal
) = By_Reference
1367 and then Is_Valued_Procedure
(Scope
(Formal
))
1370 ("by_reference actual may be misaligned?", Actual
);
1382 function Make_Var
(Actual
: Node_Id
) return Entity_Id
is
1386 if Is_Entity_Name
(Actual
) then
1387 return Entity
(Actual
);
1391 Make_Defining_Identifier
(Loc
,
1392 Chars
=> New_Internal_Name
('T'));
1395 Make_Object_Renaming_Declaration
(Loc
,
1396 Defining_Identifier
=> Var
,
1398 New_Occurrence_Of
(Etype
(Actual
), Loc
),
1399 Name
=> Relocate_Node
(Actual
));
1401 Insert_Action
(N
, N_Node
);
1406 -------------------------
1407 -- Reset_Packed_Prefix --
1408 -------------------------
1410 procedure Reset_Packed_Prefix
is
1411 Pfx
: Node_Id
:= Actual
;
1414 Set_Analyzed
(Pfx
, False);
1416 not Nkind_In
(Pfx
, N_Selected_Component
, N_Indexed_Component
);
1417 Pfx
:= Prefix
(Pfx
);
1419 end Reset_Packed_Prefix
;
1421 -- Start of processing for Expand_Actuals
1424 Post_Call
:= New_List
;
1426 Formal
:= First_Formal
(Subp
);
1427 Actual
:= First_Actual
(N
);
1428 while Present
(Formal
) loop
1429 E_Formal
:= Etype
(Formal
);
1431 if Is_Scalar_Type
(E_Formal
)
1432 or else Nkind
(Actual
) = N_Slice
1434 Check_Fortran_Logical
;
1438 elsif Ekind
(Formal
) /= E_Out_Parameter
then
1440 -- The unusual case of the current instance of a protected type
1441 -- requires special handling. This can only occur in the context
1442 -- of a call within the body of a protected operation.
1444 if Is_Entity_Name
(Actual
)
1445 and then Ekind
(Entity
(Actual
)) = E_Protected_Type
1446 and then In_Open_Scopes
(Entity
(Actual
))
1448 if Scope
(Subp
) /= Entity
(Actual
) then
1449 Error_Msg_N
("operation outside protected type may not "
1450 & "call back its protected operations?", Actual
);
1454 Expand_Protected_Object_Reference
(N
, Entity
(Actual
)));
1457 -- Ada 2005 (AI-318-02): If the actual parameter is a call to a
1458 -- build-in-place function, then a temporary return object needs
1459 -- to be created and access to it must be passed to the function.
1460 -- Currently we limit such functions to those with inherently
1461 -- limited result subtypes, but eventually we plan to expand the
1462 -- functions that are treated as build-in-place to include other
1463 -- composite result types.
1465 if Ada_Version
>= Ada_05
1466 and then Is_Build_In_Place_Function_Call
(Actual
)
1468 Make_Build_In_Place_Call_In_Anonymous_Context
(Actual
);
1471 Apply_Constraint_Check
(Actual
, E_Formal
);
1473 -- Out parameter case. No constraint checks on access type
1476 elsif Is_Access_Type
(E_Formal
) then
1481 elsif Has_Discriminants
(Base_Type
(E_Formal
))
1482 or else Has_Non_Null_Base_Init_Proc
(E_Formal
)
1484 Apply_Constraint_Check
(Actual
, E_Formal
);
1489 Apply_Constraint_Check
(Actual
, Base_Type
(E_Formal
));
1492 -- Processing for IN-OUT and OUT parameters
1494 if Ekind
(Formal
) /= E_In_Parameter
then
1496 -- For type conversions of arrays, apply length/range checks
1498 if Is_Array_Type
(E_Formal
)
1499 and then Nkind
(Actual
) = N_Type_Conversion
1501 if Is_Constrained
(E_Formal
) then
1502 Apply_Length_Check
(Expression
(Actual
), E_Formal
);
1504 Apply_Range_Check
(Expression
(Actual
), E_Formal
);
1508 -- If argument is a type conversion for a type that is passed
1509 -- by copy, then we must pass the parameter by copy.
1511 if Nkind
(Actual
) = N_Type_Conversion
1513 (Is_Numeric_Type
(E_Formal
)
1514 or else Is_Access_Type
(E_Formal
)
1515 or else Is_Enumeration_Type
(E_Formal
)
1516 or else Is_Bit_Packed_Array
(Etype
(Formal
))
1517 or else Is_Bit_Packed_Array
(Etype
(Expression
(Actual
)))
1519 -- Also pass by copy if change of representation
1521 or else not Same_Representation
1523 Etype
(Expression
(Actual
))))
1525 Add_Call_By_Copy_Code
;
1527 -- References to components of bit packed arrays are expanded
1528 -- at this point, rather than at the point of analysis of the
1529 -- actuals, to handle the expansion of the assignment to
1530 -- [in] out parameters.
1532 elsif Is_Ref_To_Bit_Packed_Array
(Actual
) then
1533 Add_Simple_Call_By_Copy_Code
;
1535 -- If a non-scalar actual is possibly bit-aligned, we need a copy
1536 -- because the back-end cannot cope with such objects. In other
1537 -- cases where alignment forces a copy, the back-end generates
1538 -- it properly. It should not be generated unconditionally in the
1539 -- front-end because it does not know precisely the alignment
1540 -- requirements of the target, and makes too conservative an
1541 -- estimate, leading to superfluous copies or spurious errors
1542 -- on by-reference parameters.
1544 elsif Nkind
(Actual
) = N_Selected_Component
1546 Component_May_Be_Bit_Aligned
(Entity
(Selector_Name
(Actual
)))
1547 and then not Represented_As_Scalar
(Etype
(Formal
))
1549 Add_Simple_Call_By_Copy_Code
;
1551 -- References to slices of bit packed arrays are expanded
1553 elsif Is_Ref_To_Bit_Packed_Slice
(Actual
) then
1554 Add_Call_By_Copy_Code
;
1556 -- References to possibly unaligned slices of arrays are expanded
1558 elsif Is_Possibly_Unaligned_Slice
(Actual
) then
1559 Add_Call_By_Copy_Code
;
1561 -- Deal with access types where the actual subtype and the
1562 -- formal subtype are not the same, requiring a check.
1564 -- It is necessary to exclude tagged types because of "downward
1565 -- conversion" errors.
1567 elsif Is_Access_Type
(E_Formal
)
1568 and then not Same_Type
(E_Formal
, Etype
(Actual
))
1569 and then not Is_Tagged_Type
(Designated_Type
(E_Formal
))
1571 Add_Call_By_Copy_Code
;
1573 -- If the actual is not a scalar and is marked for volatile
1574 -- treatment, whereas the formal is not volatile, then pass
1575 -- by copy unless it is a by-reference type.
1577 -- Note: we use Is_Volatile here rather than Treat_As_Volatile,
1578 -- because this is the enforcement of a language rule that applies
1579 -- only to "real" volatile variables, not e.g. to the address
1580 -- clause overlay case.
1582 elsif Is_Entity_Name
(Actual
)
1583 and then Is_Volatile
(Entity
(Actual
))
1584 and then not Is_By_Reference_Type
(Etype
(Actual
))
1585 and then not Is_Scalar_Type
(Etype
(Entity
(Actual
)))
1586 and then not Is_Volatile
(E_Formal
)
1588 Add_Call_By_Copy_Code
;
1590 elsif Nkind
(Actual
) = N_Indexed_Component
1591 and then Is_Entity_Name
(Prefix
(Actual
))
1592 and then Has_Volatile_Components
(Entity
(Prefix
(Actual
)))
1594 Add_Call_By_Copy_Code
;
1596 -- Add call-by-copy code for the case of scalar out parameters
1597 -- when it is not known at compile time that the subtype of the
1598 -- formal is a subrange of the subtype of the actual (or vice
1599 -- versa for in out parameters), in order to get range checks
1600 -- on such actuals. (Maybe this case should be handled earlier
1601 -- in the if statement???)
1603 elsif Is_Scalar_Type
(E_Formal
)
1605 (not In_Subrange_Of
(E_Formal
, Etype
(Actual
))
1607 (Ekind
(Formal
) = E_In_Out_Parameter
1608 and then not In_Subrange_Of
(Etype
(Actual
), E_Formal
)))
1610 -- Perhaps the setting back to False should be done within
1611 -- Add_Call_By_Copy_Code, since it could get set on other
1612 -- cases occurring above???
1614 if Do_Range_Check
(Actual
) then
1615 Set_Do_Range_Check
(Actual
, False);
1618 Add_Call_By_Copy_Code
;
1621 -- Processing for IN parameters
1624 -- For IN parameters is in the packed array case, we expand an
1625 -- indexed component (the circuit in Exp_Ch4 deliberately left
1626 -- indexed components appearing as actuals untouched, so that
1627 -- the special processing above for the OUT and IN OUT cases
1628 -- could be performed. We could make the test in Exp_Ch4 more
1629 -- complex and have it detect the parameter mode, but it is
1630 -- easier simply to handle all cases here.)
1632 if Nkind
(Actual
) = N_Indexed_Component
1633 and then Is_Packed
(Etype
(Prefix
(Actual
)))
1635 Reset_Packed_Prefix
;
1636 Expand_Packed_Element_Reference
(Actual
);
1638 -- If we have a reference to a bit packed array, we copy it, since
1639 -- the actual must be byte aligned.
1641 -- Is this really necessary in all cases???
1643 elsif Is_Ref_To_Bit_Packed_Array
(Actual
) then
1644 Add_Simple_Call_By_Copy_Code
;
1646 -- If a non-scalar actual is possibly unaligned, we need a copy
1648 elsif Is_Possibly_Unaligned_Object
(Actual
)
1649 and then not Represented_As_Scalar
(Etype
(Formal
))
1651 Add_Simple_Call_By_Copy_Code
;
1653 -- Similarly, we have to expand slices of packed arrays here
1654 -- because the result must be byte aligned.
1656 elsif Is_Ref_To_Bit_Packed_Slice
(Actual
) then
1657 Add_Call_By_Copy_Code
;
1659 -- Only processing remaining is to pass by copy if this is a
1660 -- reference to a possibly unaligned slice, since the caller
1661 -- expects an appropriately aligned argument.
1663 elsif Is_Possibly_Unaligned_Slice
(Actual
) then
1664 Add_Call_By_Copy_Code
;
1668 Next_Formal
(Formal
);
1669 Next_Actual
(Actual
);
1672 -- Find right place to put post call stuff if it is present
1674 if not Is_Empty_List
(Post_Call
) then
1676 -- If call is not a list member, it must be the triggering statement
1677 -- of a triggering alternative or an entry call alternative, and we
1678 -- can add the post call stuff to the corresponding statement list.
1680 if not Is_List_Member
(N
) then
1682 P
: constant Node_Id
:= Parent
(N
);
1685 pragma Assert
(Nkind_In
(P
, N_Triggering_Alternative
,
1686 N_Entry_Call_Alternative
));
1688 if Is_Non_Empty_List
(Statements
(P
)) then
1689 Insert_List_Before_And_Analyze
1690 (First
(Statements
(P
)), Post_Call
);
1692 Set_Statements
(P
, Post_Call
);
1696 -- Otherwise, normal case where N is in a statement sequence,
1697 -- just put the post-call stuff after the call statement.
1700 Insert_Actions_After
(N
, Post_Call
);
1704 -- The call node itself is re-analyzed in Expand_Call
1712 -- This procedure handles expansion of function calls and procedure call
1713 -- statements (i.e. it serves as the body for Expand_N_Function_Call and
1714 -- Expand_N_Procedure_Call_Statement). Processing for calls includes:
1716 -- Replace call to Raise_Exception by Raise_Exception_Always if possible
1717 -- Provide values of actuals for all formals in Extra_Formals list
1718 -- Replace "call" to enumeration literal function by literal itself
1719 -- Rewrite call to predefined operator as operator
1720 -- Replace actuals to in-out parameters that are numeric conversions,
1721 -- with explicit assignment to temporaries before and after the call.
1722 -- Remove optional actuals if First_Optional_Parameter specified.
1724 -- Note that the list of actuals has been filled with default expressions
1725 -- during semantic analysis of the call. Only the extra actuals required
1726 -- for the 'Constrained attribute and for accessibility checks are added
1729 procedure Expand_Call
(N
: Node_Id
) is
1730 Loc
: constant Source_Ptr
:= Sloc
(N
);
1731 Extra_Actuals
: List_Id
:= No_List
;
1732 Prev
: Node_Id
:= Empty
;
1734 procedure Add_Actual_Parameter
(Insert_Param
: Node_Id
);
1735 -- Adds one entry to the end of the actual parameter list. Used for
1736 -- default parameters and for extra actuals (for Extra_Formals). The
1737 -- argument is an N_Parameter_Association node.
1739 procedure Add_Extra_Actual
(Expr
: Node_Id
; EF
: Entity_Id
);
1740 -- Adds an extra actual to the list of extra actuals. Expr is the
1741 -- expression for the value of the actual, EF is the entity for the
1744 function Inherited_From_Formal
(S
: Entity_Id
) return Entity_Id
;
1745 -- Within an instance, a type derived from a non-tagged formal derived
1746 -- type inherits from the original parent, not from the actual. The
1747 -- current derivation mechanism has the derived type inherit from the
1748 -- actual, which is only correct outside of the instance. If the
1749 -- subprogram is inherited, we test for this particular case through a
1750 -- convoluted tree traversal before setting the proper subprogram to be
1753 --------------------------
1754 -- Add_Actual_Parameter --
1755 --------------------------
1757 procedure Add_Actual_Parameter
(Insert_Param
: Node_Id
) is
1758 Actual_Expr
: constant Node_Id
:=
1759 Explicit_Actual_Parameter
(Insert_Param
);
1762 -- Case of insertion is first named actual
1764 if No
(Prev
) or else
1765 Nkind
(Parent
(Prev
)) /= N_Parameter_Association
1767 Set_Next_Named_Actual
(Insert_Param
, First_Named_Actual
(N
));
1768 Set_First_Named_Actual
(N
, Actual_Expr
);
1771 if No
(Parameter_Associations
(N
)) then
1772 Set_Parameter_Associations
(N
, New_List
);
1773 Append
(Insert_Param
, Parameter_Associations
(N
));
1776 Insert_After
(Prev
, Insert_Param
);
1779 -- Case of insertion is not first named actual
1782 Set_Next_Named_Actual
1783 (Insert_Param
, Next_Named_Actual
(Parent
(Prev
)));
1784 Set_Next_Named_Actual
(Parent
(Prev
), Actual_Expr
);
1785 Append
(Insert_Param
, Parameter_Associations
(N
));
1788 Prev
:= Actual_Expr
;
1789 end Add_Actual_Parameter
;
1791 ----------------------
1792 -- Add_Extra_Actual --
1793 ----------------------
1795 procedure Add_Extra_Actual
(Expr
: Node_Id
; EF
: Entity_Id
) is
1796 Loc
: constant Source_Ptr
:= Sloc
(Expr
);
1799 if Extra_Actuals
= No_List
then
1800 Extra_Actuals
:= New_List
;
1801 Set_Parent
(Extra_Actuals
, N
);
1804 Append_To
(Extra_Actuals
,
1805 Make_Parameter_Association
(Loc
,
1806 Explicit_Actual_Parameter
=> Expr
,
1808 Make_Identifier
(Loc
, Chars
(EF
))));
1810 Analyze_And_Resolve
(Expr
, Etype
(EF
));
1812 if Nkind
(N
) = N_Function_Call
then
1813 Set_Is_Accessibility_Actual
(Parent
(Expr
));
1815 end Add_Extra_Actual
;
1817 ---------------------------
1818 -- Inherited_From_Formal --
1819 ---------------------------
1821 function Inherited_From_Formal
(S
: Entity_Id
) return Entity_Id
is
1823 Gen_Par
: Entity_Id
;
1824 Gen_Prim
: Elist_Id
;
1829 -- If the operation is inherited, it is attached to the corresponding
1830 -- type derivation. If the parent in the derivation is a generic
1831 -- actual, it is a subtype of the actual, and we have to recover the
1832 -- original derived type declaration to find the proper parent.
1834 if Nkind
(Parent
(S
)) /= N_Full_Type_Declaration
1835 or else not Is_Derived_Type
(Defining_Identifier
(Parent
(S
)))
1836 or else Nkind
(Type_Definition
(Original_Node
(Parent
(S
)))) /=
1837 N_Derived_Type_Definition
1838 or else not In_Instance
1845 (Type_Definition
(Original_Node
(Parent
(S
))));
1847 if Nkind
(Indic
) = N_Subtype_Indication
then
1848 Par
:= Entity
(Subtype_Mark
(Indic
));
1850 Par
:= Entity
(Indic
);
1854 if not Is_Generic_Actual_Type
(Par
)
1855 or else Is_Tagged_Type
(Par
)
1856 or else Nkind
(Parent
(Par
)) /= N_Subtype_Declaration
1857 or else not In_Open_Scopes
(Scope
(Par
))
1861 Gen_Par
:= Generic_Parent_Type
(Parent
(Par
));
1864 -- If the actual has no generic parent type, the formal is not
1865 -- a formal derived type, so nothing to inherit.
1867 if No
(Gen_Par
) then
1871 -- If the generic parent type is still the generic type, this is a
1872 -- private formal, not a derived formal, and there are no operations
1873 -- inherited from the formal.
1875 if Nkind
(Parent
(Gen_Par
)) = N_Formal_Type_Declaration
then
1879 Gen_Prim
:= Collect_Primitive_Operations
(Gen_Par
);
1881 Elmt
:= First_Elmt
(Gen_Prim
);
1882 while Present
(Elmt
) loop
1883 if Chars
(Node
(Elmt
)) = Chars
(S
) then
1889 F1
:= First_Formal
(S
);
1890 F2
:= First_Formal
(Node
(Elmt
));
1892 and then Present
(F2
)
1894 if Etype
(F1
) = Etype
(F2
)
1895 or else Etype
(F2
) = Gen_Par
1901 exit; -- not the right subprogram
1913 raise Program_Error
;
1914 end Inherited_From_Formal
;
1918 Remote
: constant Boolean := Is_Remote_Call
(N
);
1921 Orig_Subp
: Entity_Id
:= Empty
;
1922 Param_Count
: Natural := 0;
1923 Parent_Formal
: Entity_Id
;
1924 Parent_Subp
: Entity_Id
;
1928 Prev_Orig
: Node_Id
;
1929 -- Original node for an actual, which may have been rewritten. If the
1930 -- actual is a function call that has been transformed from a selected
1931 -- component, the original node is unanalyzed. Otherwise, it carries
1932 -- semantic information used to generate additional actuals.
1934 CW_Interface_Formals_Present
: Boolean := False;
1936 -- Start of processing for Expand_Call
1939 -- Ignore if previous error
1941 if Nkind
(N
) in N_Has_Etype
and then Etype
(N
) = Any_Type
then
1945 -- Call using access to subprogram with explicit dereference
1947 if Nkind
(Name
(N
)) = N_Explicit_Dereference
then
1948 Subp
:= Etype
(Name
(N
));
1949 Parent_Subp
:= Empty
;
1951 -- Case of call to simple entry, where the Name is a selected component
1952 -- whose prefix is the task, and whose selector name is the entry name
1954 elsif Nkind
(Name
(N
)) = N_Selected_Component
then
1955 Subp
:= Entity
(Selector_Name
(Name
(N
)));
1956 Parent_Subp
:= Empty
;
1958 -- Case of call to member of entry family, where Name is an indexed
1959 -- component, with the prefix being a selected component giving the
1960 -- task and entry family name, and the index being the entry index.
1962 elsif Nkind
(Name
(N
)) = N_Indexed_Component
then
1963 Subp
:= Entity
(Selector_Name
(Prefix
(Name
(N
))));
1964 Parent_Subp
:= Empty
;
1969 Subp
:= Entity
(Name
(N
));
1970 Parent_Subp
:= Alias
(Subp
);
1972 -- Replace call to Raise_Exception by call to Raise_Exception_Always
1973 -- if we can tell that the first parameter cannot possibly be null.
1974 -- This improves efficiency by avoiding a run-time test.
1976 -- We do not do this if Raise_Exception_Always does not exist, which
1977 -- can happen in configurable run time profiles which provide only a
1980 if Is_RTE
(Subp
, RE_Raise_Exception
)
1981 and then RTE_Available
(RE_Raise_Exception_Always
)
1984 FA
: constant Node_Id
:= Original_Node
(First_Actual
(N
));
1987 -- The case we catch is where the first argument is obtained
1988 -- using the Identity attribute (which must always be
1991 if Nkind
(FA
) = N_Attribute_Reference
1992 and then Attribute_Name
(FA
) = Name_Identity
1994 Subp
:= RTE
(RE_Raise_Exception_Always
);
1995 Set_Name
(N
, New_Occurrence_Of
(Subp
, Loc
));
2000 if Ekind
(Subp
) = E_Entry
then
2001 Parent_Subp
:= Empty
;
2005 -- Ada 2005 (AI-345): We have a procedure call as a triggering
2006 -- alternative in an asynchronous select or as an entry call in
2007 -- a conditional or timed select. Check whether the procedure call
2008 -- is a renaming of an entry and rewrite it as an entry call.
2010 if Ada_Version
>= Ada_05
2011 and then Nkind
(N
) = N_Procedure_Call_Statement
2013 ((Nkind
(Parent
(N
)) = N_Triggering_Alternative
2014 and then Triggering_Statement
(Parent
(N
)) = N
)
2016 (Nkind
(Parent
(N
)) = N_Entry_Call_Alternative
2017 and then Entry_Call_Statement
(Parent
(N
)) = N
))
2021 Ren_Root
: Entity_Id
:= Subp
;
2024 -- This may be a chain of renamings, find the root
2026 if Present
(Alias
(Ren_Root
)) then
2027 Ren_Root
:= Alias
(Ren_Root
);
2030 if Present
(Original_Node
(Parent
(Parent
(Ren_Root
)))) then
2031 Ren_Decl
:= Original_Node
(Parent
(Parent
(Ren_Root
)));
2033 if Nkind
(Ren_Decl
) = N_Subprogram_Renaming_Declaration
then
2035 Make_Entry_Call_Statement
(Loc
,
2037 New_Copy_Tree
(Name
(Ren_Decl
)),
2038 Parameter_Associations
=>
2039 New_Copy_List_Tree
(Parameter_Associations
(N
))));
2047 -- First step, compute extra actuals, corresponding to any Extra_Formals
2048 -- present. Note that we do not access Extra_Formals directly, instead
2049 -- we simply note the presence of the extra formals as we process the
2050 -- regular formals collecting corresponding actuals in Extra_Actuals.
2052 -- We also generate any required range checks for actuals for in formals
2053 -- as we go through the loop, since this is a convenient place to do it.
2054 -- (Though it seems that this would be better done in Expand_Actuals???)
2056 Formal
:= First_Formal
(Subp
);
2057 Actual
:= First_Actual
(N
);
2059 while Present
(Formal
) loop
2061 -- Generate range check if required
2063 if Do_Range_Check
(Actual
)
2064 and then Ekind
(Formal
) = E_In_Parameter
2066 Set_Do_Range_Check
(Actual
, False);
2067 Generate_Range_Check
2068 (Actual
, Etype
(Formal
), CE_Range_Check_Failed
);
2071 -- Prepare to examine current entry
2074 Prev_Orig
:= Original_Node
(Prev
);
2076 -- Ada 2005 (AI-251): Check if any formal is a class-wide interface
2077 -- to expand it in a further round.
2079 CW_Interface_Formals_Present
:=
2080 CW_Interface_Formals_Present
2082 (Ekind
(Etype
(Formal
)) = E_Class_Wide_Type
2083 and then Is_Interface
(Etype
(Etype
(Formal
))))
2085 (Ekind
(Etype
(Formal
)) = E_Anonymous_Access_Type
2086 and then Is_Interface
(Directly_Designated_Type
2087 (Etype
(Etype
(Formal
)))));
2089 -- Create possible extra actual for constrained case. Usually, the
2090 -- extra actual is of the form actual'constrained, but since this
2091 -- attribute is only available for unconstrained records, TRUE is
2092 -- expanded if the type of the formal happens to be constrained (for
2093 -- instance when this procedure is inherited from an unconstrained
2094 -- record to a constrained one) or if the actual has no discriminant
2095 -- (its type is constrained). An exception to this is the case of a
2096 -- private type without discriminants. In this case we pass FALSE
2097 -- because the object has underlying discriminants with defaults.
2099 if Present
(Extra_Constrained
(Formal
)) then
2100 if Ekind
(Etype
(Prev
)) in Private_Kind
2101 and then not Has_Discriminants
(Base_Type
(Etype
(Prev
)))
2104 (New_Occurrence_Of
(Standard_False
, Loc
),
2105 Extra_Constrained
(Formal
));
2107 elsif Is_Constrained
(Etype
(Formal
))
2108 or else not Has_Discriminants
(Etype
(Prev
))
2111 (New_Occurrence_Of
(Standard_True
, Loc
),
2112 Extra_Constrained
(Formal
));
2114 -- Do not produce extra actuals for Unchecked_Union parameters.
2115 -- Jump directly to the end of the loop.
2117 elsif Is_Unchecked_Union
(Base_Type
(Etype
(Actual
))) then
2118 goto Skip_Extra_Actual_Generation
;
2121 -- If the actual is a type conversion, then the constrained
2122 -- test applies to the actual, not the target type.
2128 -- Test for unchecked conversions as well, which can occur
2129 -- as out parameter actuals on calls to stream procedures.
2132 while Nkind_In
(Act_Prev
, N_Type_Conversion
,
2133 N_Unchecked_Type_Conversion
)
2135 Act_Prev
:= Expression
(Act_Prev
);
2138 -- If the expression is a conversion of a dereference, this
2139 -- is internally generated code that manipulates addresses,
2140 -- e.g. when building interface tables. No check should
2141 -- occur in this case, and the discriminated object is not
2144 if not Comes_From_Source
(Actual
)
2145 and then Nkind
(Actual
) = N_Unchecked_Type_Conversion
2146 and then Nkind
(Act_Prev
) = N_Explicit_Dereference
2149 (New_Occurrence_Of
(Standard_False
, Loc
),
2150 Extra_Constrained
(Formal
));
2154 (Make_Attribute_Reference
(Sloc
(Prev
),
2156 Duplicate_Subexpr_No_Checks
2157 (Act_Prev
, Name_Req
=> True),
2158 Attribute_Name
=> Name_Constrained
),
2159 Extra_Constrained
(Formal
));
2165 -- Create possible extra actual for accessibility level
2167 if Present
(Extra_Accessibility
(Formal
)) then
2169 -- Ada 2005 (AI-252): If the actual was rewritten as an Access
2170 -- attribute, then the original actual may be an aliased object
2171 -- occurring as the prefix in a call using "Object.Operation"
2172 -- notation. In that case we must pass the level of the object,
2173 -- so Prev_Orig is reset to Prev and the attribute will be
2174 -- processed by the code for Access attributes further below.
2176 if Prev_Orig
/= Prev
2177 and then Nkind
(Prev
) = N_Attribute_Reference
2179 Get_Attribute_Id
(Attribute_Name
(Prev
)) = Attribute_Access
2180 and then Is_Aliased_View
(Prev_Orig
)
2185 -- Ada 2005 (AI-251): Thunks must propagate the extra actuals
2186 -- of accessibility levels.
2188 if Ekind
(Current_Scope
) in Subprogram_Kind
2189 and then Is_Thunk
(Current_Scope
)
2192 Parm_Ent
: Entity_Id
;
2195 if Is_Controlling_Actual
(Actual
) then
2197 -- Find the corresponding actual of the thunk
2199 Parm_Ent
:= First_Entity
(Current_Scope
);
2200 for J
in 2 .. Param_Count
loop
2201 Next_Entity
(Parm_Ent
);
2204 else pragma Assert
(Is_Entity_Name
(Actual
));
2205 Parm_Ent
:= Entity
(Actual
);
2209 (New_Occurrence_Of
(Extra_Accessibility
(Parm_Ent
), Loc
),
2210 Extra_Accessibility
(Formal
));
2213 elsif Is_Entity_Name
(Prev_Orig
) then
2215 -- When passing an access parameter, or a renaming of an access
2216 -- parameter, as the actual to another access parameter we need
2217 -- to pass along the actual's own access level parameter. This
2218 -- is done if we are within the scope of the formal access
2219 -- parameter (if this is an inlined body the extra formal is
2222 if (Is_Formal
(Entity
(Prev_Orig
))
2224 (Present
(Renamed_Object
(Entity
(Prev_Orig
)))
2226 Is_Entity_Name
(Renamed_Object
(Entity
(Prev_Orig
)))
2229 (Entity
(Renamed_Object
(Entity
(Prev_Orig
))))))
2230 and then Ekind
(Etype
(Prev_Orig
)) = E_Anonymous_Access_Type
2231 and then In_Open_Scopes
(Scope
(Entity
(Prev_Orig
)))
2234 Parm_Ent
: constant Entity_Id
:= Param_Entity
(Prev_Orig
);
2237 pragma Assert
(Present
(Parm_Ent
));
2239 if Present
(Extra_Accessibility
(Parm_Ent
)) then
2242 (Extra_Accessibility
(Parm_Ent
), Loc
),
2243 Extra_Accessibility
(Formal
));
2245 -- If the actual access parameter does not have an
2246 -- associated extra formal providing its scope level,
2247 -- then treat the actual as having library-level
2252 (Make_Integer_Literal
(Loc
,
2253 Intval
=> Scope_Depth
(Standard_Standard
)),
2254 Extra_Accessibility
(Formal
));
2258 -- The actual is a normal access value, so just pass the level
2259 -- of the actual's access type.
2263 (Make_Integer_Literal
(Loc
,
2264 Intval
=> Type_Access_Level
(Etype
(Prev_Orig
))),
2265 Extra_Accessibility
(Formal
));
2268 -- If the actual is an access discriminant, then pass the level
2269 -- of the enclosing object (RM05-3.10.2(12.4/2)).
2271 elsif Nkind
(Prev_Orig
) = N_Selected_Component
2272 and then Ekind
(Entity
(Selector_Name
(Prev_Orig
))) =
2274 and then Ekind
(Etype
(Entity
(Selector_Name
(Prev_Orig
)))) =
2275 E_Anonymous_Access_Type
2278 (Make_Integer_Literal
(Loc
,
2279 Intval
=> Object_Access_Level
(Prefix
(Prev_Orig
))),
2280 Extra_Accessibility
(Formal
));
2285 case Nkind
(Prev_Orig
) is
2287 when N_Attribute_Reference
=>
2288 case Get_Attribute_Id
(Attribute_Name
(Prev_Orig
)) is
2290 -- For X'Access, pass on the level of the prefix X
2292 when Attribute_Access
=>
2294 (Make_Integer_Literal
(Loc
,
2297 (Prefix
(Prev_Orig
))),
2298 Extra_Accessibility
(Formal
));
2300 -- Treat the unchecked attributes as library-level
2302 when Attribute_Unchecked_Access |
2303 Attribute_Unrestricted_Access
=>
2305 (Make_Integer_Literal
(Loc
,
2306 Intval
=> Scope_Depth
(Standard_Standard
)),
2307 Extra_Accessibility
(Formal
));
2309 -- No other cases of attributes returning access
2310 -- values that can be passed to access parameters
2313 raise Program_Error
;
2317 -- For allocators we pass the level of the execution of the
2318 -- called subprogram, which is one greater than the current
2323 (Make_Integer_Literal
(Loc
,
2324 Intval
=> Scope_Depth
(Current_Scope
) + 1),
2325 Extra_Accessibility
(Formal
));
2327 -- For other cases we simply pass the level of the actual's
2328 -- access type. The type is retrieved from Prev rather than
2329 -- Prev_Orig, because in some cases Prev_Orig denotes an
2330 -- original expression that has not been analyzed.
2334 (Make_Integer_Literal
(Loc
,
2335 Intval
=> Type_Access_Level
(Etype
(Prev
))),
2336 Extra_Accessibility
(Formal
));
2341 -- Perform the check of 4.6(49) that prevents a null value from being
2342 -- passed as an actual to an access parameter. Note that the check is
2343 -- elided in the common cases of passing an access attribute or
2344 -- access parameter as an actual. Also, we currently don't enforce
2345 -- this check for expander-generated actuals and when -gnatdj is set.
2347 if Ada_Version
>= Ada_05
then
2349 -- Ada 2005 (AI-231): Check null-excluding access types
2351 if Is_Access_Type
(Etype
(Formal
))
2352 and then Can_Never_Be_Null
(Etype
(Formal
))
2353 and then Nkind
(Prev
) /= N_Raise_Constraint_Error
2354 and then (Known_Null
(Prev
)
2355 or else not Can_Never_Be_Null
(Etype
(Prev
)))
2357 Install_Null_Excluding_Check
(Prev
);
2360 -- Ada_Version < Ada_05
2363 if Ekind
(Etype
(Formal
)) /= E_Anonymous_Access_Type
2364 or else Access_Checks_Suppressed
(Subp
)
2368 elsif Debug_Flag_J
then
2371 elsif not Comes_From_Source
(Prev
) then
2374 elsif Is_Entity_Name
(Prev
)
2375 and then Ekind
(Etype
(Prev
)) = E_Anonymous_Access_Type
2379 elsif Nkind_In
(Prev
, N_Allocator
, N_Attribute_Reference
) then
2382 -- Suppress null checks when passing to access parameters of Java
2383 -- and CIL subprograms. (Should this be done for other foreign
2384 -- conventions as well ???)
2386 elsif Convention
(Subp
) = Convention_Java
2387 or else Convention
(Subp
) = Convention_CIL
2392 Install_Null_Excluding_Check
(Prev
);
2396 -- Perform appropriate validity checks on parameters that
2399 if Validity_Checks_On
then
2400 if (Ekind
(Formal
) = E_In_Parameter
2401 and then Validity_Check_In_Params
)
2403 (Ekind
(Formal
) = E_In_Out_Parameter
2404 and then Validity_Check_In_Out_Params
)
2406 -- If the actual is an indexed component of a packed type (or
2407 -- is an indexed or selected component whose prefix recursively
2408 -- meets this condition), it has not been expanded yet. It will
2409 -- be copied in the validity code that follows, and has to be
2410 -- expanded appropriately, so reanalyze it.
2412 -- What we do is just to unset analyzed bits on prefixes till
2413 -- we reach something that does not have a prefix.
2420 while Nkind_In
(Nod
, N_Indexed_Component
,
2421 N_Selected_Component
)
2423 Set_Analyzed
(Nod
, False);
2424 Nod
:= Prefix
(Nod
);
2428 Ensure_Valid
(Actual
);
2432 -- For IN OUT and OUT parameters, ensure that subscripts are valid
2433 -- since this is a left side reference. We only do this for calls
2434 -- from the source program since we assume that compiler generated
2435 -- calls explicitly generate any required checks. We also need it
2436 -- only if we are doing standard validity checks, since clearly it
2437 -- is not needed if validity checks are off, and in subscript
2438 -- validity checking mode, all indexed components are checked with
2439 -- a call directly from Expand_N_Indexed_Component.
2441 if Comes_From_Source
(N
)
2442 and then Ekind
(Formal
) /= E_In_Parameter
2443 and then Validity_Checks_On
2444 and then Validity_Check_Default
2445 and then not Validity_Check_Subscripts
2447 Check_Valid_Lvalue_Subscripts
(Actual
);
2450 -- Mark any scalar OUT parameter that is a simple variable as no
2451 -- longer known to be valid (unless the type is always valid). This
2452 -- reflects the fact that if an OUT parameter is never set in a
2453 -- procedure, then it can become invalid on the procedure return.
2455 if Ekind
(Formal
) = E_Out_Parameter
2456 and then Is_Entity_Name
(Actual
)
2457 and then Ekind
(Entity
(Actual
)) = E_Variable
2458 and then not Is_Known_Valid
(Etype
(Actual
))
2460 Set_Is_Known_Valid
(Entity
(Actual
), False);
2463 -- For an OUT or IN OUT parameter, if the actual is an entity, then
2464 -- clear current values, since they can be clobbered. We are probably
2465 -- doing this in more places than we need to, but better safe than
2466 -- sorry when it comes to retaining bad current values!
2468 if Ekind
(Formal
) /= E_In_Parameter
2469 and then Is_Entity_Name
(Actual
)
2470 and then Present
(Entity
(Actual
))
2473 Ent
: constant Entity_Id
:= Entity
(Actual
);
2477 -- For an OUT or IN OUT parameter that is an assignable entity,
2478 -- we do not want to clobber the Last_Assignment field, since
2479 -- if it is set, it was precisely because it is indeed an OUT
2480 -- or IN OUT parameter! We do reset the Is_Known_Valid flag
2481 -- since the subprogram could have returned in invalid value.
2483 if (Ekind
(Formal
) = E_Out_Parameter
2485 Ekind
(Formal
) = E_In_Out_Parameter
)
2486 and then Is_Assignable
(Ent
)
2488 Sav
:= Last_Assignment
(Ent
);
2489 Kill_Current_Values
(Ent
);
2490 Set_Last_Assignment
(Ent
, Sav
);
2491 Set_Is_Known_Valid
(Ent
, False);
2493 -- For all other cases, just kill the current values
2496 Kill_Current_Values
(Ent
);
2501 -- If the formal is class wide and the actual is an aggregate, force
2502 -- evaluation so that the back end who does not know about class-wide
2503 -- type, does not generate a temporary of the wrong size.
2505 if not Is_Class_Wide_Type
(Etype
(Formal
)) then
2508 elsif Nkind
(Actual
) = N_Aggregate
2509 or else (Nkind
(Actual
) = N_Qualified_Expression
2510 and then Nkind
(Expression
(Actual
)) = N_Aggregate
)
2512 Force_Evaluation
(Actual
);
2515 -- In a remote call, if the formal is of a class-wide type, check
2516 -- that the actual meets the requirements described in E.4(18).
2518 if Remote
and then Is_Class_Wide_Type
(Etype
(Formal
)) then
2519 Insert_Action
(Actual
,
2520 Make_Transportable_Check
(Loc
,
2521 Duplicate_Subexpr_Move_Checks
(Actual
)));
2524 -- This label is required when skipping extra actual generation for
2525 -- Unchecked_Union parameters.
2527 <<Skip_Extra_Actual_Generation
>>
2529 Param_Count
:= Param_Count
+ 1;
2530 Next_Actual
(Actual
);
2531 Next_Formal
(Formal
);
2534 -- If we are expanding a rhs of an assignment we need to check if tag
2535 -- propagation is needed. You might expect this processing to be in
2536 -- Analyze_Assignment but has to be done earlier (bottom-up) because the
2537 -- assignment might be transformed to a declaration for an unconstrained
2538 -- value if the expression is classwide.
2540 if Nkind
(N
) = N_Function_Call
2541 and then Is_Tag_Indeterminate
(N
)
2542 and then Is_Entity_Name
(Name
(N
))
2545 Ass
: Node_Id
:= Empty
;
2548 if Nkind
(Parent
(N
)) = N_Assignment_Statement
then
2551 elsif Nkind
(Parent
(N
)) = N_Qualified_Expression
2552 and then Nkind
(Parent
(Parent
(N
))) = N_Assignment_Statement
2554 Ass
:= Parent
(Parent
(N
));
2556 elsif Nkind
(Parent
(N
)) = N_Explicit_Dereference
2557 and then Nkind
(Parent
(Parent
(N
))) = N_Assignment_Statement
2559 Ass
:= Parent
(Parent
(N
));
2563 and then Is_Class_Wide_Type
(Etype
(Name
(Ass
)))
2565 if Is_Access_Type
(Etype
(N
)) then
2566 if Designated_Type
(Etype
(N
)) /=
2567 Root_Type
(Etype
(Name
(Ass
)))
2570 ("tag-indeterminate expression "
2571 & " must have designated type& (RM 5.2 (6))",
2572 N
, Root_Type
(Etype
(Name
(Ass
))));
2574 Propagate_Tag
(Name
(Ass
), N
);
2577 elsif Etype
(N
) /= Root_Type
(Etype
(Name
(Ass
))) then
2579 ("tag-indeterminate expression must have type&"
2580 & "(RM 5.2 (6))", N
, Root_Type
(Etype
(Name
(Ass
))));
2583 Propagate_Tag
(Name
(Ass
), N
);
2586 -- The call will be rewritten as a dispatching call, and
2587 -- expanded as such.
2594 -- Ada 2005 (AI-251): If some formal is a class-wide interface, expand
2595 -- it to point to the correct secondary virtual table
2597 if Nkind_In
(N
, N_Function_Call
, N_Procedure_Call_Statement
)
2598 and then CW_Interface_Formals_Present
2600 Expand_Interface_Actuals
(N
);
2603 -- Deals with Dispatch_Call if we still have a call, before expanding
2604 -- extra actuals since this will be done on the re-analysis of the
2605 -- dispatching call. Note that we do not try to shorten the actual
2606 -- list for a dispatching call, it would not make sense to do so.
2607 -- Expansion of dispatching calls is suppressed when VM_Target, because
2608 -- the VM back-ends directly handle the generation of dispatching
2609 -- calls and would have to undo any expansion to an indirect call.
2611 if Nkind_In
(N
, N_Function_Call
, N_Procedure_Call_Statement
)
2612 and then Present
(Controlling_Argument
(N
))
2614 if Tagged_Type_Expansion
then
2615 Expand_Dispatching_Call
(N
);
2617 -- The following return is worrisome. Is it really OK to
2618 -- skip all remaining processing in this procedure ???
2623 Apply_Tag_Checks
(N
);
2625 -- Expansion of a dispatching call results in an indirect call,
2626 -- which in turn causes current values to be killed (see
2627 -- Resolve_Call), so on VM targets we do the call here to ensure
2628 -- consistent warnings between VM and non-VM targets.
2630 Kill_Current_Values
;
2634 -- Similarly, expand calls to RCI subprograms on which pragma
2635 -- All_Calls_Remote applies. The rewriting will be reanalyzed
2636 -- later. Do this only when the call comes from source since we do
2637 -- not want such a rewriting to occur in expanded code.
2639 if Is_All_Remote_Call
(N
) then
2640 Expand_All_Calls_Remote_Subprogram_Call
(N
);
2642 -- Similarly, do not add extra actuals for an entry call whose entity
2643 -- is a protected procedure, or for an internal protected subprogram
2644 -- call, because it will be rewritten as a protected subprogram call
2645 -- and reanalyzed (see Expand_Protected_Subprogram_Call).
2647 elsif Is_Protected_Type
(Scope
(Subp
))
2648 and then (Ekind
(Subp
) = E_Procedure
2649 or else Ekind
(Subp
) = E_Function
)
2653 -- During that loop we gathered the extra actuals (the ones that
2654 -- correspond to Extra_Formals), so now they can be appended.
2657 while Is_Non_Empty_List
(Extra_Actuals
) loop
2658 Add_Actual_Parameter
(Remove_Head
(Extra_Actuals
));
2662 -- At this point we have all the actuals, so this is the point at
2663 -- which the various expansion activities for actuals is carried out.
2665 Expand_Actuals
(N
, Subp
);
2667 -- If the subprogram is a renaming, or if it is inherited, replace it
2668 -- in the call with the name of the actual subprogram being called.
2669 -- If this is a dispatching call, the run-time decides what to call.
2670 -- The Alias attribute does not apply to entries.
2672 if Nkind
(N
) /= N_Entry_Call_Statement
2673 and then No
(Controlling_Argument
(N
))
2674 and then Present
(Parent_Subp
)
2676 if Present
(Inherited_From_Formal
(Subp
)) then
2677 Parent_Subp
:= Inherited_From_Formal
(Subp
);
2679 while Present
(Alias
(Parent_Subp
)) loop
2680 Parent_Subp
:= Alias
(Parent_Subp
);
2684 -- The below setting of Entity is suspect, see F109-018 discussion???
2686 Set_Entity
(Name
(N
), Parent_Subp
);
2688 if Is_Abstract_Subprogram
(Parent_Subp
)
2689 and then not In_Instance
2692 ("cannot call abstract subprogram &!", Name
(N
), Parent_Subp
);
2695 -- Inspect all formals of derived subprogram Subp. Compare parameter
2696 -- types with the parent subprogram and check whether an actual may
2697 -- need a type conversion to the corresponding formal of the parent
2700 -- Not clear whether intrinsic subprograms need such conversions. ???
2702 if not Is_Intrinsic_Subprogram
(Parent_Subp
)
2703 or else Is_Generic_Instance
(Parent_Subp
)
2706 procedure Convert
(Act
: Node_Id
; Typ
: Entity_Id
);
2707 -- Rewrite node Act as a type conversion of Act to Typ. Analyze
2708 -- and resolve the newly generated construct.
2714 procedure Convert
(Act
: Node_Id
; Typ
: Entity_Id
) is
2716 Rewrite
(Act
, OK_Convert_To
(Typ
, Relocate_Node
(Act
)));
2723 Actual_Typ
: Entity_Id
;
2724 Formal_Typ
: Entity_Id
;
2725 Parent_Typ
: Entity_Id
;
2728 Actual
:= First_Actual
(N
);
2729 Formal
:= First_Formal
(Subp
);
2730 Parent_Formal
:= First_Formal
(Parent_Subp
);
2731 while Present
(Formal
) loop
2732 Actual_Typ
:= Etype
(Actual
);
2733 Formal_Typ
:= Etype
(Formal
);
2734 Parent_Typ
:= Etype
(Parent_Formal
);
2736 -- For an IN parameter of a scalar type, the parent formal
2737 -- type and derived formal type differ or the parent formal
2738 -- type and actual type do not match statically.
2740 if Is_Scalar_Type
(Formal_Typ
)
2741 and then Ekind
(Formal
) = E_In_Parameter
2742 and then Formal_Typ
/= Parent_Typ
2744 not Subtypes_Statically_Match
(Parent_Typ
, Actual_Typ
)
2745 and then not Raises_Constraint_Error
(Actual
)
2747 Convert
(Actual
, Parent_Typ
);
2748 Enable_Range_Check
(Actual
);
2750 -- If the actual has been marked as requiring a range
2751 -- check, then generate it here.
2753 if Do_Range_Check
(Actual
) then
2754 Set_Do_Range_Check
(Actual
, False);
2755 Generate_Range_Check
2756 (Actual
, Etype
(Formal
), CE_Range_Check_Failed
);
2759 -- For access types, the parent formal type and actual type
2762 elsif Is_Access_Type
(Formal_Typ
)
2763 and then Base_Type
(Parent_Typ
) /= Base_Type
(Actual_Typ
)
2765 if Ekind
(Formal
) /= E_In_Parameter
then
2766 Convert
(Actual
, Parent_Typ
);
2768 elsif Ekind
(Parent_Typ
) = E_Anonymous_Access_Type
2769 and then Designated_Type
(Parent_Typ
) /=
2770 Designated_Type
(Actual_Typ
)
2771 and then not Is_Controlling_Formal
(Formal
)
2773 -- This unchecked conversion is not necessary unless
2774 -- inlining is enabled, because in that case the type
2775 -- mismatch may become visible in the body about to be
2779 Unchecked_Convert_To
(Parent_Typ
,
2780 Relocate_Node
(Actual
)));
2782 -- If the relocated node is a function call then it
2783 -- can be part of the expansion of the predefined
2784 -- equality operator of a tagged type and we may
2785 -- need to adjust its SCIL dispatching node.
2788 and then Nkind
(Actual
) /= N_Null
2789 and then Nkind
(Expression
(Actual
))
2792 Adjust_SCIL_Node
(Actual
, Expression
(Actual
));
2796 Resolve
(Actual
, Parent_Typ
);
2799 -- For array and record types, the parent formal type and
2800 -- derived formal type have different sizes or pragma Pack
2803 elsif ((Is_Array_Type
(Formal_Typ
)
2804 and then Is_Array_Type
(Parent_Typ
))
2806 (Is_Record_Type
(Formal_Typ
)
2807 and then Is_Record_Type
(Parent_Typ
)))
2809 (Esize
(Formal_Typ
) /= Esize
(Parent_Typ
)
2810 or else Has_Pragma_Pack
(Formal_Typ
) /=
2811 Has_Pragma_Pack
(Parent_Typ
))
2813 Convert
(Actual
, Parent_Typ
);
2816 Next_Actual
(Actual
);
2817 Next_Formal
(Formal
);
2818 Next_Formal
(Parent_Formal
);
2824 Subp
:= Parent_Subp
;
2827 -- Check for violation of No_Abort_Statements
2829 if Is_RTE
(Subp
, RE_Abort_Task
) then
2830 Check_Restriction
(No_Abort_Statements
, N
);
2832 -- Check for violation of No_Dynamic_Attachment
2834 elsif RTU_Loaded
(Ada_Interrupts
)
2835 and then (Is_RTE
(Subp
, RE_Is_Reserved
) or else
2836 Is_RTE
(Subp
, RE_Is_Attached
) or else
2837 Is_RTE
(Subp
, RE_Current_Handler
) or else
2838 Is_RTE
(Subp
, RE_Attach_Handler
) or else
2839 Is_RTE
(Subp
, RE_Exchange_Handler
) or else
2840 Is_RTE
(Subp
, RE_Detach_Handler
) or else
2841 Is_RTE
(Subp
, RE_Reference
))
2843 Check_Restriction
(No_Dynamic_Attachment
, N
);
2846 -- Deal with case where call is an explicit dereference
2848 if Nkind
(Name
(N
)) = N_Explicit_Dereference
then
2850 -- Handle case of access to protected subprogram type
2852 if Is_Access_Protected_Subprogram_Type
2853 (Base_Type
(Etype
(Prefix
(Name
(N
)))))
2855 -- If this is a call through an access to protected operation,
2856 -- the prefix has the form (object'address, operation'access).
2857 -- Rewrite as a for other protected calls: the object is the
2858 -- first parameter of the list of actuals.
2865 Ptr
: constant Node_Id
:= Prefix
(Name
(N
));
2867 T
: constant Entity_Id
:=
2868 Equivalent_Type
(Base_Type
(Etype
(Ptr
)));
2870 D_T
: constant Entity_Id
:=
2871 Designated_Type
(Base_Type
(Etype
(Ptr
)));
2875 Make_Selected_Component
(Loc
,
2876 Prefix
=> Unchecked_Convert_To
(T
, Ptr
),
2878 New_Occurrence_Of
(First_Entity
(T
), Loc
));
2881 Make_Selected_Component
(Loc
,
2882 Prefix
=> Unchecked_Convert_To
(T
, Ptr
),
2884 New_Occurrence_Of
(Next_Entity
(First_Entity
(T
)), Loc
));
2887 Make_Explicit_Dereference
(Loc
,
2890 if Present
(Parameter_Associations
(N
)) then
2891 Parm
:= Parameter_Associations
(N
);
2896 Prepend
(Obj
, Parm
);
2898 if Etype
(D_T
) = Standard_Void_Type
then
2900 Make_Procedure_Call_Statement
(Loc
,
2902 Parameter_Associations
=> Parm
);
2905 Make_Function_Call
(Loc
,
2907 Parameter_Associations
=> Parm
);
2910 Set_First_Named_Actual
(Call
, First_Named_Actual
(N
));
2911 Set_Etype
(Call
, Etype
(D_T
));
2913 -- We do not re-analyze the call to avoid infinite recursion.
2914 -- We analyze separately the prefix and the object, and set
2915 -- the checks on the prefix that would otherwise be emitted
2916 -- when resolving a call.
2920 Apply_Access_Check
(Nam
);
2927 -- If this is a call to an intrinsic subprogram, then perform the
2928 -- appropriate expansion to the corresponding tree node and we
2929 -- are all done (since after that the call is gone!)
2931 -- In the case where the intrinsic is to be processed by the back end,
2932 -- the call to Expand_Intrinsic_Call will do nothing, which is fine,
2933 -- since the idea in this case is to pass the call unchanged.
2934 -- If the intrinsic is an inherited unchecked conversion, and the
2935 -- derived type is the target type of the conversion, we must retain
2936 -- it as the return type of the expression. Otherwise the expansion
2937 -- below, which uses the parent operation, will yield the wrong type.
2939 if Is_Intrinsic_Subprogram
(Subp
) then
2940 Expand_Intrinsic_Call
(N
, Subp
);
2942 if Nkind
(N
) = N_Unchecked_Type_Conversion
2943 and then Parent_Subp
/= Orig_Subp
2944 and then Etype
(Parent_Subp
) /= Etype
(Orig_Subp
)
2946 Set_Etype
(N
, Etype
(Orig_Subp
));
2952 if Ekind
(Subp
) = E_Function
2953 or else Ekind
(Subp
) = E_Procedure
2955 -- We perform two simple optimization on calls:
2957 -- a) replace calls to null procedures unconditionally;
2959 -- b) for To_Address, just do an unchecked conversion. Not only is
2960 -- this efficient, but it also avoids order of elaboration problems
2961 -- when address clauses are inlined (address expression elaborated
2962 -- at the wrong point).
2964 -- We perform these optimization regardless of whether we are in the
2965 -- main unit or in a unit in the context of the main unit, to ensure
2966 -- that tree generated is the same in both cases, for Inspector use.
2968 if Is_RTE
(Subp
, RE_To_Address
) then
2970 Unchecked_Convert_To
2971 (RTE
(RE_Address
), Relocate_Node
(First_Actual
(N
))));
2974 elsif Is_Null_Procedure
(Subp
) then
2975 Rewrite
(N
, Make_Null_Statement
(Loc
));
2979 if Is_Inlined
(Subp
) then
2981 Inlined_Subprogram
: declare
2983 Must_Inline
: Boolean := False;
2984 Spec
: constant Node_Id
:= Unit_Declaration_Node
(Subp
);
2985 Scop
: constant Entity_Id
:= Scope
(Subp
);
2987 function In_Unfrozen_Instance
return Boolean;
2988 -- If the subprogram comes from an instance in the same unit,
2989 -- and the instance is not yet frozen, inlining might trigger
2990 -- order-of-elaboration problems in gigi.
2992 --------------------------
2993 -- In_Unfrozen_Instance --
2994 --------------------------
2996 function In_Unfrozen_Instance
return Boolean is
3002 and then S
/= Standard_Standard
3004 if Is_Generic_Instance
(S
)
3005 and then Present
(Freeze_Node
(S
))
3006 and then not Analyzed
(Freeze_Node
(S
))
3015 end In_Unfrozen_Instance
;
3017 -- Start of processing for Inlined_Subprogram
3020 -- Verify that the body to inline has already been seen, and
3021 -- that if the body is in the current unit the inlining does
3022 -- not occur earlier. This avoids order-of-elaboration problems
3025 -- This should be documented in sinfo/einfo ???
3028 or else Nkind
(Spec
) /= N_Subprogram_Declaration
3029 or else No
(Body_To_Inline
(Spec
))
3031 Must_Inline
:= False;
3033 -- If this an inherited function that returns a private type,
3034 -- do not inline if the full view is an unconstrained array,
3035 -- because such calls cannot be inlined.
3037 elsif Present
(Orig_Subp
)
3038 and then Is_Array_Type
(Etype
(Orig_Subp
))
3039 and then not Is_Constrained
(Etype
(Orig_Subp
))
3041 Must_Inline
:= False;
3043 elsif In_Unfrozen_Instance
then
3044 Must_Inline
:= False;
3047 Bod
:= Body_To_Inline
(Spec
);
3049 if (In_Extended_Main_Code_Unit
(N
)
3050 or else In_Extended_Main_Code_Unit
(Parent
(N
))
3051 or else Has_Pragma_Inline_Always
(Subp
))
3052 and then (not In_Same_Extended_Unit
(Sloc
(Bod
), Loc
)
3054 Earlier_In_Extended_Unit
(Sloc
(Bod
), Loc
))
3056 Must_Inline
:= True;
3058 -- If we are compiling a package body that is not the main
3059 -- unit, it must be for inlining/instantiation purposes,
3060 -- in which case we inline the call to insure that the same
3061 -- temporaries are generated when compiling the body by
3062 -- itself. Otherwise link errors can occur.
3064 -- If the function being called is itself in the main unit,
3065 -- we cannot inline, because there is a risk of double
3066 -- elaboration and/or circularity: the inlining can make
3067 -- visible a private entity in the body of the main unit,
3068 -- that gigi will see before its sees its proper definition.
3070 elsif not (In_Extended_Main_Code_Unit
(N
))
3071 and then In_Package_Body
3073 Must_Inline
:= not In_Extended_Main_Source_Unit
(Subp
);
3078 Expand_Inlined_Call
(N
, Subp
, Orig_Subp
);
3081 -- Let the back end handle it
3083 Add_Inlined_Body
(Subp
);
3085 if Front_End_Inlining
3086 and then Nkind
(Spec
) = N_Subprogram_Declaration
3087 and then (In_Extended_Main_Code_Unit
(N
))
3088 and then No
(Body_To_Inline
(Spec
))
3089 and then not Has_Completion
(Subp
)
3090 and then In_Same_Extended_Unit
(Sloc
(Spec
), Loc
)
3093 ("cannot inline& (body not seen yet)?", N
, Subp
);
3096 end Inlined_Subprogram
;
3100 -- Check for protected subprogram. This is either an intra-object call,
3101 -- or a protected function call. Protected procedure calls are rewritten
3102 -- as entry calls and handled accordingly.
3104 -- In Ada 2005, this may be an indirect call to an access parameter that
3105 -- is an access_to_subprogram. In that case the anonymous type has a
3106 -- scope that is a protected operation, but the call is a regular one.
3108 Scop
:= Scope
(Subp
);
3110 if Nkind
(N
) /= N_Entry_Call_Statement
3111 and then Is_Protected_Type
(Scop
)
3112 and then Ekind
(Subp
) /= E_Subprogram_Type
3114 -- If the call is an internal one, it is rewritten as a call to the
3115 -- corresponding unprotected subprogram.
3117 Expand_Protected_Subprogram_Call
(N
, Subp
, Scop
);
3120 -- Functions returning controlled objects need special attention:
3121 -- if the return type is limited, the context is an initialization
3122 -- and different processing applies. If the call is to a protected
3123 -- function, the expansion above will call Expand_Call recusively.
3124 -- To prevent a double attachment, check that the current call is
3125 -- not a rewriting of a protected function call.
3127 if Needs_Finalization
(Etype
(Subp
))
3128 and then not Is_Inherently_Limited_Type
(Etype
(Subp
))
3130 (No
(First_Formal
(Subp
))
3132 not Is_Concurrent_Record_Type
(Etype
(First_Formal
(Subp
))))
3134 Expand_Ctrl_Function_Call
(N
);
3137 -- Test for First_Optional_Parameter, and if so, truncate parameter list
3138 -- if there are optional parameters at the trailing end.
3139 -- Note: we never delete procedures for call via a pointer.
3141 if (Ekind
(Subp
) = E_Procedure
or else Ekind
(Subp
) = E_Function
)
3142 and then Present
(First_Optional_Parameter
(Subp
))
3145 Last_Keep_Arg
: Node_Id
;
3148 -- Last_Keep_Arg will hold the last actual that should be kept.
3149 -- If it remains empty at the end, it means that all parameters
3152 Last_Keep_Arg
:= Empty
;
3154 -- Find first optional parameter, must be present since we checked
3155 -- the validity of the parameter before setting it.
3157 Formal
:= First_Formal
(Subp
);
3158 Actual
:= First_Actual
(N
);
3159 while Formal
/= First_Optional_Parameter
(Subp
) loop
3160 Last_Keep_Arg
:= Actual
;
3161 Next_Formal
(Formal
);
3162 Next_Actual
(Actual
);
3165 -- We have Formal and Actual pointing to the first potentially
3166 -- droppable argument. We can drop all the trailing arguments
3167 -- whose actual matches the default. Note that we know that all
3168 -- remaining formals have defaults, because we checked that this
3169 -- requirement was met before setting First_Optional_Parameter.
3171 -- We use Fully_Conformant_Expressions to check for identity
3172 -- between formals and actuals, which may miss some cases, but
3173 -- on the other hand, this is only an optimization (if we fail
3174 -- to truncate a parameter it does not affect functionality).
3175 -- So if the default is 3 and the actual is 1+2, we consider
3176 -- them unequal, which hardly seems worrisome.
3178 while Present
(Formal
) loop
3179 if not Fully_Conformant_Expressions
3180 (Actual
, Default_Value
(Formal
))
3182 Last_Keep_Arg
:= Actual
;
3185 Next_Formal
(Formal
);
3186 Next_Actual
(Actual
);
3189 -- If no arguments, delete entire list, this is the easy case
3191 if No
(Last_Keep_Arg
) then
3192 Set_Parameter_Associations
(N
, No_List
);
3193 Set_First_Named_Actual
(N
, Empty
);
3195 -- Case where at the last retained argument is positional. This
3196 -- is also an easy case, since the retained arguments are already
3197 -- in the right form, and we don't need to worry about the order
3198 -- of arguments that get eliminated.
3200 elsif Is_List_Member
(Last_Keep_Arg
) then
3201 while Present
(Next
(Last_Keep_Arg
)) loop
3202 Discard_Node
(Remove_Next
(Last_Keep_Arg
));
3205 Set_First_Named_Actual
(N
, Empty
);
3207 -- This is the annoying case where the last retained argument
3208 -- is a named parameter. Since the original arguments are not
3209 -- in declaration order, we may have to delete some fairly
3210 -- random collection of arguments.
3218 -- First step, remove all the named parameters from the
3219 -- list (they are still chained using First_Named_Actual
3220 -- and Next_Named_Actual, so we have not lost them!)
3222 Temp
:= First
(Parameter_Associations
(N
));
3224 -- Case of all parameters named, remove them all
3226 if Nkind
(Temp
) = N_Parameter_Association
then
3227 while Is_Non_Empty_List
(Parameter_Associations
(N
)) loop
3228 Temp
:= Remove_Head
(Parameter_Associations
(N
));
3231 -- Case of mixed positional/named, remove named parameters
3234 while Nkind
(Next
(Temp
)) /= N_Parameter_Association
loop
3238 while Present
(Next
(Temp
)) loop
3239 Remove
(Next
(Temp
));
3243 -- Now we loop through the named parameters, till we get
3244 -- to the last one to be retained, adding them to the list.
3245 -- Note that the Next_Named_Actual list does not need to be
3246 -- touched since we are only reordering them on the actual
3247 -- parameter association list.
3249 Passoc
:= Parent
(First_Named_Actual
(N
));
3251 Temp
:= Relocate_Node
(Passoc
);
3253 (Parameter_Associations
(N
), Temp
);
3255 Last_Keep_Arg
= Explicit_Actual_Parameter
(Passoc
);
3256 Passoc
:= Parent
(Next_Named_Actual
(Passoc
));
3259 Set_Next_Named_Actual
(Temp
, Empty
);
3262 Temp
:= Next_Named_Actual
(Passoc
);
3263 exit when No
(Temp
);
3264 Set_Next_Named_Actual
3265 (Passoc
, Next_Named_Actual
(Parent
(Temp
)));
3274 --------------------------
3275 -- Expand_Inlined_Call --
3276 --------------------------
3278 procedure Expand_Inlined_Call
3281 Orig_Subp
: Entity_Id
)
3283 Loc
: constant Source_Ptr
:= Sloc
(N
);
3284 Is_Predef
: constant Boolean :=
3285 Is_Predefined_File_Name
3286 (Unit_File_Name
(Get_Source_Unit
(Subp
)));
3287 Orig_Bod
: constant Node_Id
:=
3288 Body_To_Inline
(Unit_Declaration_Node
(Subp
));
3293 Decls
: constant List_Id
:= New_List
;
3294 Exit_Lab
: Entity_Id
:= Empty
;
3301 Ret_Type
: Entity_Id
;
3305 Temp_Typ
: Entity_Id
;
3307 Is_Unc
: constant Boolean :=
3308 Is_Array_Type
(Etype
(Subp
))
3309 and then not Is_Constrained
(Etype
(Subp
));
3310 -- If the type returned by the function is unconstrained and the call
3311 -- can be inlined, special processing is required.
3313 procedure Make_Exit_Label
;
3314 -- Build declaration for exit label to be used in Return statements,
3315 -- sets Exit_Lab (the label node) and Lab_Decl (corresponding implcit
3318 function Process_Formals
(N
: Node_Id
) return Traverse_Result
;
3319 -- Replace occurrence of a formal with the corresponding actual, or the
3320 -- thunk generated for it.
3322 function Process_Sloc
(Nod
: Node_Id
) return Traverse_Result
;
3323 -- If the call being expanded is that of an internal subprogram, set the
3324 -- sloc of the generated block to that of the call itself, so that the
3325 -- expansion is skipped by the "next" command in gdb.
3326 -- Same processing for a subprogram in a predefined file, e.g.
3327 -- Ada.Tags. If Debug_Generated_Code is true, suppress this change to
3328 -- simplify our own development.
3330 procedure Rewrite_Function_Call
(N
: Node_Id
; Blk
: Node_Id
);
3331 -- If the function body is a single expression, replace call with
3332 -- expression, else insert block appropriately.
3334 procedure Rewrite_Procedure_Call
(N
: Node_Id
; Blk
: Node_Id
);
3335 -- If procedure body has no local variables, inline body without
3336 -- creating block, otherwise rewrite call with block.
3338 function Formal_Is_Used_Once
(Formal
: Entity_Id
) return Boolean;
3339 -- Determine whether a formal parameter is used only once in Orig_Bod
3341 ---------------------
3342 -- Make_Exit_Label --
3343 ---------------------
3345 procedure Make_Exit_Label
is
3347 -- Create exit label for subprogram if one does not exist yet
3349 if No
(Exit_Lab
) then
3351 Make_Identifier
(Loc
,
3352 Chars
=> New_Internal_Name
('L'));
3354 Make_Defining_Identifier
(Loc
, Chars
(Lab_Id
)));
3355 Exit_Lab
:= Make_Label
(Loc
, Lab_Id
);
3358 Make_Implicit_Label_Declaration
(Loc
,
3359 Defining_Identifier
=> Entity
(Lab_Id
),
3360 Label_Construct
=> Exit_Lab
);
3362 end Make_Exit_Label
;
3364 ---------------------
3365 -- Process_Formals --
3366 ---------------------
3368 function Process_Formals
(N
: Node_Id
) return Traverse_Result
is
3374 if Is_Entity_Name
(N
)
3375 and then Present
(Entity
(N
))
3380 and then Scope
(E
) = Subp
3382 A
:= Renamed_Object
(E
);
3384 -- Rewrite the occurrence of the formal into an occurrence of
3385 -- the actual. Also establish visibility on the proper view of
3386 -- the actual's subtype for the body's context (if the actual's
3387 -- subtype is private at the call point but its full view is
3388 -- visible to the body, then the inlined tree here must be
3389 -- analyzed with the full view).
3391 if Is_Entity_Name
(A
) then
3392 Rewrite
(N
, New_Occurrence_Of
(Entity
(A
), Loc
));
3393 Check_Private_View
(N
);
3395 elsif Nkind
(A
) = N_Defining_Identifier
then
3396 Rewrite
(N
, New_Occurrence_Of
(A
, Loc
));
3397 Check_Private_View
(N
);
3402 Rewrite
(N
, New_Copy
(A
));
3408 elsif Nkind
(N
) = N_Simple_Return_Statement
then
3409 if No
(Expression
(N
)) then
3412 Make_Goto_Statement
(Loc
,
3413 Name
=> New_Copy
(Lab_Id
)));
3416 if Nkind
(Parent
(N
)) = N_Handled_Sequence_Of_Statements
3417 and then Nkind
(Parent
(Parent
(N
))) = N_Subprogram_Body
3419 -- Function body is a single expression. No need for
3425 Num_Ret
:= Num_Ret
+ 1;
3429 -- Because of the presence of private types, the views of the
3430 -- expression and the context may be different, so place an
3431 -- unchecked conversion to the context type to avoid spurious
3432 -- errors, e.g. when the expression is a numeric literal and
3433 -- the context is private. If the expression is an aggregate,
3434 -- use a qualified expression, because an aggregate is not a
3435 -- legal argument of a conversion.
3437 if Nkind_In
(Expression
(N
), N_Aggregate
, N_Null
) then
3439 Make_Qualified_Expression
(Sloc
(N
),
3440 Subtype_Mark
=> New_Occurrence_Of
(Ret_Type
, Sloc
(N
)),
3441 Expression
=> Relocate_Node
(Expression
(N
)));
3444 Unchecked_Convert_To
3445 (Ret_Type
, Relocate_Node
(Expression
(N
)));
3448 if Nkind
(Targ
) = N_Defining_Identifier
then
3450 Make_Assignment_Statement
(Loc
,
3451 Name
=> New_Occurrence_Of
(Targ
, Loc
),
3452 Expression
=> Ret
));
3455 Make_Assignment_Statement
(Loc
,
3456 Name
=> New_Copy
(Targ
),
3457 Expression
=> Ret
));
3460 Set_Assignment_OK
(Name
(N
));
3462 if Present
(Exit_Lab
) then
3464 Make_Goto_Statement
(Loc
,
3465 Name
=> New_Copy
(Lab_Id
)));
3471 -- Remove pragma Unreferenced since it may refer to formals that
3472 -- are not visible in the inlined body, and in any case we will
3473 -- not be posting warnings on the inlined body so it is unneeded.
3475 elsif Nkind
(N
) = N_Pragma
3476 and then Pragma_Name
(N
) = Name_Unreferenced
3478 Rewrite
(N
, Make_Null_Statement
(Sloc
(N
)));
3484 end Process_Formals
;
3486 procedure Replace_Formals
is new Traverse_Proc
(Process_Formals
);
3492 function Process_Sloc
(Nod
: Node_Id
) return Traverse_Result
is
3494 if not Debug_Generated_Code
then
3495 Set_Sloc
(Nod
, Sloc
(N
));
3496 Set_Comes_From_Source
(Nod
, False);
3502 procedure Reset_Slocs
is new Traverse_Proc
(Process_Sloc
);
3504 ---------------------------
3505 -- Rewrite_Function_Call --
3506 ---------------------------
3508 procedure Rewrite_Function_Call
(N
: Node_Id
; Blk
: Node_Id
) is
3509 HSS
: constant Node_Id
:= Handled_Statement_Sequence
(Blk
);
3510 Fst
: constant Node_Id
:= First
(Statements
(HSS
));
3513 -- Optimize simple case: function body is a single return statement,
3514 -- which has been expanded into an assignment.
3516 if Is_Empty_List
(Declarations
(Blk
))
3517 and then Nkind
(Fst
) = N_Assignment_Statement
3518 and then No
(Next
(Fst
))
3521 -- The function call may have been rewritten as the temporary
3522 -- that holds the result of the call, in which case remove the
3523 -- now useless declaration.
3525 if Nkind
(N
) = N_Identifier
3526 and then Nkind
(Parent
(Entity
(N
))) = N_Object_Declaration
3528 Rewrite
(Parent
(Entity
(N
)), Make_Null_Statement
(Loc
));
3531 Rewrite
(N
, Expression
(Fst
));
3533 elsif Nkind
(N
) = N_Identifier
3534 and then Nkind
(Parent
(Entity
(N
))) = N_Object_Declaration
3536 -- The block assigns the result of the call to the temporary
3538 Insert_After
(Parent
(Entity
(N
)), Blk
);
3540 elsif Nkind
(Parent
(N
)) = N_Assignment_Statement
3542 (Is_Entity_Name
(Name
(Parent
(N
)))
3544 (Nkind
(Name
(Parent
(N
))) = N_Explicit_Dereference
3545 and then Is_Entity_Name
(Prefix
(Name
(Parent
(N
))))))
3547 -- Replace assignment with the block
3550 Original_Assignment
: constant Node_Id
:= Parent
(N
);
3553 -- Preserve the original assignment node to keep the complete
3554 -- assignment subtree consistent enough for Analyze_Assignment
3555 -- to proceed (specifically, the original Lhs node must still
3556 -- have an assignment statement as its parent).
3558 -- We cannot rely on Original_Node to go back from the block
3559 -- node to the assignment node, because the assignment might
3560 -- already be a rewrite substitution.
3562 Discard_Node
(Relocate_Node
(Original_Assignment
));
3563 Rewrite
(Original_Assignment
, Blk
);
3566 elsif Nkind
(Parent
(N
)) = N_Object_Declaration
then
3567 Set_Expression
(Parent
(N
), Empty
);
3568 Insert_After
(Parent
(N
), Blk
);
3571 Insert_Before
(Parent
(N
), Blk
);
3573 end Rewrite_Function_Call
;
3575 ----------------------------
3576 -- Rewrite_Procedure_Call --
3577 ----------------------------
3579 procedure Rewrite_Procedure_Call
(N
: Node_Id
; Blk
: Node_Id
) is
3580 HSS
: constant Node_Id
:= Handled_Statement_Sequence
(Blk
);
3582 -- If there is a transient scope for N, this will be the scope of the
3583 -- actions for N, and the statements in Blk need to be within this
3584 -- scope. For example, they need to have visibility on the constant
3585 -- declarations created for the formals.
3587 -- If N needs no transient scope, and if there are no declarations in
3588 -- the inlined body, we can do a little optimization and insert the
3589 -- statements for the body directly after N, and rewrite N to a
3590 -- null statement, instead of rewriting N into a full-blown block
3593 if not Scope_Is_Transient
3594 and then Is_Empty_List
(Declarations
(Blk
))
3596 Insert_List_After
(N
, Statements
(HSS
));
3597 Rewrite
(N
, Make_Null_Statement
(Loc
));
3601 end Rewrite_Procedure_Call
;
3603 -------------------------
3604 -- Formal_Is_Used_Once --
3605 -------------------------
3607 function Formal_Is_Used_Once
(Formal
: Entity_Id
) return Boolean is
3608 Use_Counter
: Int
:= 0;
3610 function Count_Uses
(N
: Node_Id
) return Traverse_Result
;
3611 -- Traverse the tree and count the uses of the formal parameter.
3612 -- In this case, for optimization purposes, we do not need to
3613 -- continue the traversal once more than one use is encountered.
3619 function Count_Uses
(N
: Node_Id
) return Traverse_Result
is
3621 -- The original node is an identifier
3623 if Nkind
(N
) = N_Identifier
3624 and then Present
(Entity
(N
))
3626 -- Original node's entity points to the one in the copied body
3628 and then Nkind
(Entity
(N
)) = N_Identifier
3629 and then Present
(Entity
(Entity
(N
)))
3631 -- The entity of the copied node is the formal parameter
3633 and then Entity
(Entity
(N
)) = Formal
3635 Use_Counter
:= Use_Counter
+ 1;
3637 if Use_Counter
> 1 then
3639 -- Denote more than one use and abandon the traversal
3650 procedure Count_Formal_Uses
is new Traverse_Proc
(Count_Uses
);
3652 -- Start of processing for Formal_Is_Used_Once
3655 Count_Formal_Uses
(Orig_Bod
);
3656 return Use_Counter
= 1;
3657 end Formal_Is_Used_Once
;
3659 -- Start of processing for Expand_Inlined_Call
3663 -- Check for an illegal attempt to inline a recursive procedure. If the
3664 -- subprogram has parameters this is detected when trying to supply a
3665 -- binding for parameters that already have one. For parameterless
3666 -- subprograms this must be done explicitly.
3668 if In_Open_Scopes
(Subp
) then
3669 Error_Msg_N
("call to recursive subprogram cannot be inlined?", N
);
3670 Set_Is_Inlined
(Subp
, False);
3674 if Nkind
(Orig_Bod
) = N_Defining_Identifier
3675 or else Nkind
(Orig_Bod
) = N_Defining_Operator_Symbol
3677 -- Subprogram is a renaming_as_body. Calls appearing after the
3678 -- renaming can be replaced with calls to the renamed entity
3679 -- directly, because the subprograms are subtype conformant. If
3680 -- the renamed subprogram is an inherited operation, we must redo
3681 -- the expansion because implicit conversions may be needed.
3683 Set_Name
(N
, New_Occurrence_Of
(Orig_Bod
, Loc
));
3685 if Present
(Alias
(Orig_Bod
)) then
3692 -- Use generic machinery to copy body of inlined subprogram, as if it
3693 -- were an instantiation, resetting source locations appropriately, so
3694 -- that nested inlined calls appear in the main unit.
3696 Save_Env
(Subp
, Empty
);
3697 Set_Copied_Sloc_For_Inlined_Body
(N
, Defining_Entity
(Orig_Bod
));
3699 Bod
:= Copy_Generic_Node
(Orig_Bod
, Empty
, Instantiating
=> True);
3701 Make_Block_Statement
(Loc
,
3702 Declarations
=> Declarations
(Bod
),
3703 Handled_Statement_Sequence
=> Handled_Statement_Sequence
(Bod
));
3705 if No
(Declarations
(Bod
)) then
3706 Set_Declarations
(Blk
, New_List
);
3709 -- For the unconstrained case, capture the name of the local
3710 -- variable that holds the result. This must be the first declaration
3711 -- in the block, because its bounds cannot depend on local variables.
3712 -- Otherwise there is no way to declare the result outside of the
3713 -- block. Needless to say, in general the bounds will depend on the
3714 -- actuals in the call.
3717 Targ1
:= Defining_Identifier
(First
(Declarations
(Blk
)));
3720 -- If this is a derived function, establish the proper return type
3722 if Present
(Orig_Subp
)
3723 and then Orig_Subp
/= Subp
3725 Ret_Type
:= Etype
(Orig_Subp
);
3727 Ret_Type
:= Etype
(Subp
);
3730 -- Create temporaries for the actuals that are expressions, or that
3731 -- are scalars and require copying to preserve semantics.
3733 F
:= First_Formal
(Subp
);
3734 A
:= First_Actual
(N
);
3735 while Present
(F
) loop
3736 if Present
(Renamed_Object
(F
)) then
3737 Error_Msg_N
("cannot inline call to recursive subprogram", N
);
3741 -- If the argument may be a controlling argument in a call within
3742 -- the inlined body, we must preserve its classwide nature to insure
3743 -- that dynamic dispatching take place subsequently. If the formal
3744 -- has a constraint it must be preserved to retain the semantics of
3747 if Is_Class_Wide_Type
(Etype
(F
))
3748 or else (Is_Access_Type
(Etype
(F
))
3750 Is_Class_Wide_Type
(Designated_Type
(Etype
(F
))))
3752 Temp_Typ
:= Etype
(F
);
3754 elsif Base_Type
(Etype
(F
)) = Base_Type
(Etype
(A
))
3755 and then Etype
(F
) /= Base_Type
(Etype
(F
))
3757 Temp_Typ
:= Etype
(F
);
3760 Temp_Typ
:= Etype
(A
);
3763 -- If the actual is a simple name or a literal, no need to
3764 -- create a temporary, object can be used directly.
3766 -- If the actual is a literal and the formal has its address taken,
3767 -- we cannot pass the literal itself as an argument, so its value
3768 -- must be captured in a temporary.
3770 if (Is_Entity_Name
(A
)
3772 (not Is_Scalar_Type
(Etype
(A
))
3773 or else Ekind
(Entity
(A
)) = E_Enumeration_Literal
))
3775 -- When the actual is an identifier and the corresponding formal
3776 -- is used only once in the original body, the formal can be
3777 -- substituted directly with the actual parameter.
3779 or else (Nkind
(A
) = N_Identifier
3780 and then Formal_Is_Used_Once
(F
))
3783 (Nkind_In
(A
, N_Real_Literal
,
3785 N_Character_Literal
)
3786 and then not Address_Taken
(F
))
3788 if Etype
(F
) /= Etype
(A
) then
3790 (F
, Unchecked_Convert_To
(Etype
(F
), Relocate_Node
(A
)));
3792 Set_Renamed_Object
(F
, A
);
3797 Make_Defining_Identifier
(Loc
,
3798 Chars
=> New_Internal_Name
('C'));
3800 -- If the actual for an in/in-out parameter is a view conversion,
3801 -- make it into an unchecked conversion, given that an untagged
3802 -- type conversion is not a proper object for a renaming.
3804 -- In-out conversions that involve real conversions have already
3805 -- been transformed in Expand_Actuals.
3807 if Nkind
(A
) = N_Type_Conversion
3808 and then Ekind
(F
) /= E_In_Parameter
3811 Make_Unchecked_Type_Conversion
(Loc
,
3812 Subtype_Mark
=> New_Occurrence_Of
(Etype
(F
), Loc
),
3813 Expression
=> Relocate_Node
(Expression
(A
)));
3815 elsif Etype
(F
) /= Etype
(A
) then
3816 New_A
:= Unchecked_Convert_To
(Etype
(F
), Relocate_Node
(A
));
3817 Temp_Typ
:= Etype
(F
);
3820 New_A
:= Relocate_Node
(A
);
3823 Set_Sloc
(New_A
, Sloc
(N
));
3825 -- If the actual has a by-reference type, it cannot be copied, so
3826 -- its value is captured in a renaming declaration. Otherwise
3827 -- declare a local constant initialized with the actual.
3829 -- We also use a renaming declaration for expressions of an array
3830 -- type that is not bit-packed, both for efficiency reasons and to
3831 -- respect the semantics of the call: in most cases the original
3832 -- call will pass the parameter by reference, and thus the inlined
3833 -- code will have the same semantics.
3835 if Ekind
(F
) = E_In_Parameter
3836 and then not Is_Limited_Type
(Etype
(A
))
3837 and then not Is_Tagged_Type
(Etype
(A
))
3839 (not Is_Array_Type
(Etype
(A
))
3840 or else not Is_Object_Reference
(A
)
3841 or else Is_Bit_Packed_Array
(Etype
(A
)))
3844 Make_Object_Declaration
(Loc
,
3845 Defining_Identifier
=> Temp
,
3846 Constant_Present
=> True,
3847 Object_Definition
=> New_Occurrence_Of
(Temp_Typ
, Loc
),
3848 Expression
=> New_A
);
3851 Make_Object_Renaming_Declaration
(Loc
,
3852 Defining_Identifier
=> Temp
,
3853 Subtype_Mark
=> New_Occurrence_Of
(Temp_Typ
, Loc
),
3857 Append
(Decl
, Decls
);
3858 Set_Renamed_Object
(F
, Temp
);
3865 -- Establish target of function call. If context is not assignment or
3866 -- declaration, create a temporary as a target. The declaration for
3867 -- the temporary may be subsequently optimized away if the body is a
3868 -- single expression, or if the left-hand side of the assignment is
3869 -- simple enough, i.e. an entity or an explicit dereference of one.
3871 if Ekind
(Subp
) = E_Function
then
3872 if Nkind
(Parent
(N
)) = N_Assignment_Statement
3873 and then Is_Entity_Name
(Name
(Parent
(N
)))
3875 Targ
:= Name
(Parent
(N
));
3877 elsif Nkind
(Parent
(N
)) = N_Assignment_Statement
3878 and then Nkind
(Name
(Parent
(N
))) = N_Explicit_Dereference
3879 and then Is_Entity_Name
(Prefix
(Name
(Parent
(N
))))
3881 Targ
:= Name
(Parent
(N
));
3884 -- Replace call with temporary and create its declaration
3887 Make_Defining_Identifier
(Loc
, New_Internal_Name
('C'));
3888 Set_Is_Internal
(Temp
);
3890 -- For the unconstrained case, the generated temporary has the
3891 -- same constrained declaration as the result variable. It may
3892 -- eventually be possible to remove that temporary and use the
3893 -- result variable directly.
3897 Make_Object_Declaration
(Loc
,
3898 Defining_Identifier
=> Temp
,
3899 Object_Definition
=>
3900 New_Copy_Tree
(Object_Definition
(Parent
(Targ1
))));
3902 Replace_Formals
(Decl
);
3906 Make_Object_Declaration
(Loc
,
3907 Defining_Identifier
=> Temp
,
3908 Object_Definition
=>
3909 New_Occurrence_Of
(Ret_Type
, Loc
));
3911 Set_Etype
(Temp
, Ret_Type
);
3914 Set_No_Initialization
(Decl
);
3915 Append
(Decl
, Decls
);
3916 Rewrite
(N
, New_Occurrence_Of
(Temp
, Loc
));
3921 Insert_Actions
(N
, Decls
);
3923 -- Traverse the tree and replace formals with actuals or their thunks.
3924 -- Attach block to tree before analysis and rewriting.
3926 Replace_Formals
(Blk
);
3927 Set_Parent
(Blk
, N
);
3929 if not Comes_From_Source
(Subp
)
3935 if Present
(Exit_Lab
) then
3937 -- If the body was a single expression, the single return statement
3938 -- and the corresponding label are useless.
3942 Nkind
(Last
(Statements
(Handled_Statement_Sequence
(Blk
)))) =
3945 Remove
(Last
(Statements
(Handled_Statement_Sequence
(Blk
))));
3947 Append
(Lab_Decl
, (Declarations
(Blk
)));
3948 Append
(Exit_Lab
, Statements
(Handled_Statement_Sequence
(Blk
)));
3952 -- Analyze Blk with In_Inlined_Body set, to avoid spurious errors on
3953 -- conflicting private views that Gigi would ignore. If this is a
3954 -- predefined unit, analyze with checks off, as is done in the non-
3955 -- inlined run-time units.
3958 I_Flag
: constant Boolean := In_Inlined_Body
;
3961 In_Inlined_Body
:= True;
3965 Style
: constant Boolean := Style_Check
;
3967 Style_Check
:= False;
3968 Analyze
(Blk
, Suppress
=> All_Checks
);
3969 Style_Check
:= Style
;
3976 In_Inlined_Body
:= I_Flag
;
3979 if Ekind
(Subp
) = E_Procedure
then
3980 Rewrite_Procedure_Call
(N
, Blk
);
3982 Rewrite_Function_Call
(N
, Blk
);
3984 -- For the unconstrained case, the replacement of the call has been
3985 -- made prior to the complete analysis of the generated declarations.
3986 -- Propagate the proper type now.
3989 if Nkind
(N
) = N_Identifier
then
3990 Set_Etype
(N
, Etype
(Entity
(N
)));
3992 Set_Etype
(N
, Etype
(Targ1
));
3999 -- Cleanup mapping between formals and actuals for other expansions
4001 F
:= First_Formal
(Subp
);
4002 while Present
(F
) loop
4003 Set_Renamed_Object
(F
, Empty
);
4006 end Expand_Inlined_Call
;
4008 ----------------------------
4009 -- Expand_N_Function_Call --
4010 ----------------------------
4012 procedure Expand_N_Function_Call
(N
: Node_Id
) is
4016 -- If the return value of a foreign compiled function is VAX Float, then
4017 -- expand the return (adjusts the location of the return value on
4018 -- Alpha/VMS, no-op everywhere else).
4019 -- Comes_From_Source intercepts recursive expansion.
4021 if Vax_Float
(Etype
(N
))
4022 and then Nkind
(N
) = N_Function_Call
4023 and then Present
(Name
(N
))
4024 and then Present
(Entity
(Name
(N
)))
4025 and then Has_Foreign_Convention
(Entity
(Name
(N
)))
4026 and then Comes_From_Source
(Parent
(N
))
4028 Expand_Vax_Foreign_Return
(N
);
4030 end Expand_N_Function_Call
;
4032 ---------------------------------------
4033 -- Expand_N_Procedure_Call_Statement --
4034 ---------------------------------------
4036 procedure Expand_N_Procedure_Call_Statement
(N
: Node_Id
) is
4039 end Expand_N_Procedure_Call_Statement
;
4041 ------------------------------
4042 -- Expand_N_Subprogram_Body --
4043 ------------------------------
4045 -- Add poll call if ATC polling is enabled, unless the body will be inlined
4048 -- Add dummy push/pop label nodes at start and end to clear any local
4049 -- exception indications if local-exception-to-goto optimization is active.
4051 -- Add return statement if last statement in body is not a return statement
4052 -- (this makes things easier on Gigi which does not want to have to handle
4053 -- a missing return).
4055 -- Add call to Activate_Tasks if body is a task activator
4057 -- Deal with possible detection of infinite recursion
4059 -- Eliminate body completely if convention stubbed
4061 -- Encode entity names within body, since we will not need to reference
4062 -- these entities any longer in the front end.
4064 -- Initialize scalar out parameters if Initialize/Normalize_Scalars
4066 -- Reset Pure indication if any parameter has root type System.Address
4070 procedure Expand_N_Subprogram_Body
(N
: Node_Id
) is
4071 Loc
: constant Source_Ptr
:= Sloc
(N
);
4072 H
: constant Node_Id
:= Handled_Statement_Sequence
(N
);
4073 Body_Id
: Entity_Id
;
4076 Spec_Id
: Entity_Id
;
4078 procedure Add_Return
(S
: List_Id
);
4079 -- Append a return statement to the statement sequence S if the last
4080 -- statement is not already a return or a goto statement. Note that
4081 -- the latter test is not critical, it does not matter if we add a few
4082 -- extra returns, since they get eliminated anyway later on.
4088 procedure Add_Return
(S
: List_Id
) is
4093 -- Get last statement, ignoring any Pop_xxx_Label nodes, which are
4094 -- not relevant in this context since they are not executable.
4096 Last_Stm
:= Last
(S
);
4097 while Nkind
(Last_Stm
) in N_Pop_xxx_Label
loop
4101 -- Now insert return unless last statement is a transfer
4103 if not Is_Transfer
(Last_Stm
) then
4105 -- The source location for the return is the end label of the
4106 -- procedure if present. Otherwise use the sloc of the last
4107 -- statement in the list. If the list comes from a generated
4108 -- exception handler and we are not debugging generated code,
4109 -- all the statements within the handler are made invisible
4112 if Nkind
(Parent
(S
)) = N_Exception_Handler
4113 and then not Comes_From_Source
(Parent
(S
))
4115 Loc
:= Sloc
(Last_Stm
);
4117 elsif Present
(End_Label
(H
)) then
4118 Loc
:= Sloc
(End_Label
(H
));
4121 Loc
:= Sloc
(Last_Stm
);
4125 Rtn
: constant Node_Id
:= Make_Simple_Return_Statement
(Loc
);
4128 -- Append return statement, and set analyzed manually. We can't
4129 -- call Analyze on this return since the scope is wrong.
4131 -- Note: it almost works to push the scope and then do the
4132 -- Analyze call, but something goes wrong in some weird cases
4133 -- and it is not worth worrying about ???
4138 -- Call _Postconditions procedure if appropriate. We need to
4139 -- do this explicitly because we did not analyze the generated
4140 -- return statement above, so the call did not get inserted.
4142 if Ekind
(Spec_Id
) = E_Procedure
4143 and then Has_Postconditions
(Spec_Id
)
4145 pragma Assert
(Present
(Postcondition_Proc
(Spec_Id
)));
4147 Make_Procedure_Call_Statement
(Loc
,
4149 New_Reference_To
(Postcondition_Proc
(Spec_Id
), Loc
)));
4155 -- Start of processing for Expand_N_Subprogram_Body
4158 -- Set L to either the list of declarations if present, or to the list
4159 -- of statements if no declarations are present. This is used to insert
4160 -- new stuff at the start.
4162 if Is_Non_Empty_List
(Declarations
(N
)) then
4163 L
:= Declarations
(N
);
4165 L
:= Statements
(H
);
4168 -- If local-exception-to-goto optimization active, insert dummy push
4169 -- statements at start, and dummy pop statements at end.
4171 if (Debug_Flag_Dot_G
4172 or else Restriction_Active
(No_Exception_Propagation
))
4173 and then Is_Non_Empty_List
(L
)
4176 FS
: constant Node_Id
:= First
(L
);
4177 FL
: constant Source_Ptr
:= Sloc
(FS
);
4182 -- LS points to either last statement, if statements are present
4183 -- or to the last declaration if there are no statements present.
4184 -- It is the node after which the pop's are generated.
4186 if Is_Non_Empty_List
(Statements
(H
)) then
4187 LS
:= Last
(Statements
(H
));
4194 Insert_List_Before_And_Analyze
(FS
, New_List
(
4195 Make_Push_Constraint_Error_Label
(FL
),
4196 Make_Push_Program_Error_Label
(FL
),
4197 Make_Push_Storage_Error_Label
(FL
)));
4199 Insert_List_After_And_Analyze
(LS
, New_List
(
4200 Make_Pop_Constraint_Error_Label
(LL
),
4201 Make_Pop_Program_Error_Label
(LL
),
4202 Make_Pop_Storage_Error_Label
(LL
)));
4206 -- Find entity for subprogram
4208 Body_Id
:= Defining_Entity
(N
);
4210 if Present
(Corresponding_Spec
(N
)) then
4211 Spec_Id
:= Corresponding_Spec
(N
);
4216 -- Need poll on entry to subprogram if polling enabled. We only do this
4217 -- for non-empty subprograms, since it does not seem necessary to poll
4218 -- for a dummy null subprogram.
4220 if Is_Non_Empty_List
(L
) then
4222 -- Do not add a polling call if the subprogram is to be inlined by
4223 -- the back-end, to avoid repeated calls with multiple inlinings.
4225 if Is_Inlined
(Spec_Id
)
4226 and then Front_End_Inlining
4227 and then Optimization_Level
> 1
4231 Generate_Poll_Call
(First
(L
));
4235 -- If this is a Pure function which has any parameters whose root type
4236 -- is System.Address, reset the Pure indication, since it will likely
4237 -- cause incorrect code to be generated as the parameter is probably
4238 -- a pointer, and the fact that the same pointer is passed does not mean
4239 -- that the same value is being referenced.
4241 -- Note that if the programmer gave an explicit Pure_Function pragma,
4242 -- then we believe the programmer, and leave the subprogram Pure.
4244 -- This code should probably be at the freeze point, so that it happens
4245 -- even on a -gnatc (or more importantly -gnatt) compile, so that the
4246 -- semantic tree has Is_Pure set properly ???
4248 if Is_Pure
(Spec_Id
)
4249 and then Is_Subprogram
(Spec_Id
)
4250 and then not Has_Pragma_Pure_Function
(Spec_Id
)
4256 F
:= First_Formal
(Spec_Id
);
4257 while Present
(F
) loop
4258 if Is_Descendent_Of_Address
(Etype
(F
)) then
4259 Set_Is_Pure
(Spec_Id
, False);
4261 if Spec_Id
/= Body_Id
then
4262 Set_Is_Pure
(Body_Id
, False);
4273 -- Initialize any scalar OUT args if Initialize/Normalize_Scalars
4275 if Init_Or_Norm_Scalars
and then Is_Subprogram
(Spec_Id
) then
4280 -- Loop through formals
4282 F
:= First_Formal
(Spec_Id
);
4283 while Present
(F
) loop
4284 if Is_Scalar_Type
(Etype
(F
))
4285 and then Ekind
(F
) = E_Out_Parameter
4287 Check_Restriction
(No_Default_Initialization
, F
);
4289 -- Insert the initialization. We turn off validity checks
4290 -- for this assignment, since we do not want any check on
4291 -- the initial value itself (which may well be invalid).
4293 Insert_Before_And_Analyze
(First
(L
),
4294 Make_Assignment_Statement
(Loc
,
4295 Name
=> New_Occurrence_Of
(F
, Loc
),
4296 Expression
=> Get_Simple_Init_Val
(Etype
(F
), N
)),
4297 Suppress
=> Validity_Check
);
4305 -- Clear out statement list for stubbed procedure
4307 if Present
(Corresponding_Spec
(N
)) then
4308 Set_Elaboration_Flag
(N
, Spec_Id
);
4310 if Convention
(Spec_Id
) = Convention_Stubbed
4311 or else Is_Eliminated
(Spec_Id
)
4313 Set_Declarations
(N
, Empty_List
);
4314 Set_Handled_Statement_Sequence
(N
,
4315 Make_Handled_Sequence_Of_Statements
(Loc
,
4316 Statements
=> New_List
(
4317 Make_Null_Statement
(Loc
))));
4322 -- Create a set of discriminals for the next protected subprogram body
4324 if Is_List_Member
(N
)
4325 and then Present
(Parent
(List_Containing
(N
)))
4326 and then Nkind
(Parent
(List_Containing
(N
))) = N_Protected_Body
4327 and then Present
(Next_Protected_Operation
(N
))
4329 Set_Discriminals
(Parent
(Base_Type
(Scope
(Spec_Id
))));
4332 -- Returns_By_Ref flag is normally set when the subprogram is frozen but
4333 -- subprograms with no specs are not frozen.
4336 Typ
: constant Entity_Id
:= Etype
(Spec_Id
);
4337 Utyp
: constant Entity_Id
:= Underlying_Type
(Typ
);
4340 if not Acts_As_Spec
(N
)
4341 and then Nkind
(Parent
(Parent
(Spec_Id
))) /=
4342 N_Subprogram_Body_Stub
4346 elsif Is_Inherently_Limited_Type
(Typ
) then
4347 Set_Returns_By_Ref
(Spec_Id
);
4349 elsif Present
(Utyp
) and then CW_Or_Has_Controlled_Part
(Utyp
) then
4350 Set_Returns_By_Ref
(Spec_Id
);
4354 -- For a procedure, we add a return for all possible syntactic ends of
4357 if Ekind
(Spec_Id
) = E_Procedure
4358 or else Ekind
(Spec_Id
) = E_Generic_Procedure
4360 Add_Return
(Statements
(H
));
4362 if Present
(Exception_Handlers
(H
)) then
4363 Except_H
:= First_Non_Pragma
(Exception_Handlers
(H
));
4364 while Present
(Except_H
) loop
4365 Add_Return
(Statements
(Except_H
));
4366 Next_Non_Pragma
(Except_H
);
4370 -- For a function, we must deal with the case where there is at least
4371 -- one missing return. What we do is to wrap the entire body of the
4372 -- function in a block:
4385 -- raise Program_Error;
4388 -- This approach is necessary because the raise must be signalled to the
4389 -- caller, not handled by any local handler (RM 6.4(11)).
4391 -- Note: we do not need to analyze the constructed sequence here, since
4392 -- it has no handler, and an attempt to analyze the handled statement
4393 -- sequence twice is risky in various ways (e.g. the issue of expanding
4394 -- cleanup actions twice).
4396 elsif Has_Missing_Return
(Spec_Id
) then
4398 Hloc
: constant Source_Ptr
:= Sloc
(H
);
4399 Blok
: constant Node_Id
:=
4400 Make_Block_Statement
(Hloc
,
4401 Handled_Statement_Sequence
=> H
);
4402 Rais
: constant Node_Id
:=
4403 Make_Raise_Program_Error
(Hloc
,
4404 Reason
=> PE_Missing_Return
);
4407 Set_Handled_Statement_Sequence
(N
,
4408 Make_Handled_Sequence_Of_Statements
(Hloc
,
4409 Statements
=> New_List
(Blok
, Rais
)));
4411 Push_Scope
(Spec_Id
);
4418 -- If subprogram contains a parameterless recursive call, then we may
4419 -- have an infinite recursion, so see if we can generate code to check
4420 -- for this possibility if storage checks are not suppressed.
4422 if Ekind
(Spec_Id
) = E_Procedure
4423 and then Has_Recursive_Call
(Spec_Id
)
4424 and then not Storage_Checks_Suppressed
(Spec_Id
)
4426 Detect_Infinite_Recursion
(N
, Spec_Id
);
4429 -- Set to encode entity names in package body before gigi is called
4431 Qualify_Entity_Names
(N
);
4432 end Expand_N_Subprogram_Body
;
4434 -----------------------------------
4435 -- Expand_N_Subprogram_Body_Stub --
4436 -----------------------------------
4438 procedure Expand_N_Subprogram_Body_Stub
(N
: Node_Id
) is
4440 if Present
(Corresponding_Body
(N
)) then
4441 Expand_N_Subprogram_Body
(
4442 Unit_Declaration_Node
(Corresponding_Body
(N
)));
4444 end Expand_N_Subprogram_Body_Stub
;
4446 -------------------------------------
4447 -- Expand_N_Subprogram_Declaration --
4448 -------------------------------------
4450 -- If the declaration appears within a protected body, it is a private
4451 -- operation of the protected type. We must create the corresponding
4452 -- protected subprogram an associated formals. For a normal protected
4453 -- operation, this is done when expanding the protected type declaration.
4455 -- If the declaration is for a null procedure, emit null body
4457 procedure Expand_N_Subprogram_Declaration
(N
: Node_Id
) is
4458 Loc
: constant Source_Ptr
:= Sloc
(N
);
4459 Subp
: constant Entity_Id
:= Defining_Entity
(N
);
4460 Scop
: constant Entity_Id
:= Scope
(Subp
);
4461 Prot_Decl
: Node_Id
;
4463 Prot_Id
: Entity_Id
;
4466 -- Deal with case of protected subprogram. Do not generate protected
4467 -- operation if operation is flagged as eliminated.
4469 if Is_List_Member
(N
)
4470 and then Present
(Parent
(List_Containing
(N
)))
4471 and then Nkind
(Parent
(List_Containing
(N
))) = N_Protected_Body
4472 and then Is_Protected_Type
(Scop
)
4474 if No
(Protected_Body_Subprogram
(Subp
))
4475 and then not Is_Eliminated
(Subp
)
4478 Make_Subprogram_Declaration
(Loc
,
4480 Build_Protected_Sub_Specification
4481 (N
, Scop
, Unprotected_Mode
));
4483 -- The protected subprogram is declared outside of the protected
4484 -- body. Given that the body has frozen all entities so far, we
4485 -- analyze the subprogram and perform freezing actions explicitly.
4486 -- including the generation of an explicit freeze node, to ensure
4487 -- that gigi has the proper order of elaboration.
4488 -- If the body is a subunit, the insertion point is before the
4489 -- stub in the parent.
4491 Prot_Bod
:= Parent
(List_Containing
(N
));
4493 if Nkind
(Parent
(Prot_Bod
)) = N_Subunit
then
4494 Prot_Bod
:= Corresponding_Stub
(Parent
(Prot_Bod
));
4497 Insert_Before
(Prot_Bod
, Prot_Decl
);
4498 Prot_Id
:= Defining_Unit_Name
(Specification
(Prot_Decl
));
4499 Set_Has_Delayed_Freeze
(Prot_Id
);
4501 Push_Scope
(Scope
(Scop
));
4502 Analyze
(Prot_Decl
);
4503 Insert_Actions
(N
, Freeze_Entity
(Prot_Id
, Loc
));
4504 Set_Protected_Body_Subprogram
(Subp
, Prot_Id
);
4506 -- Create protected operation as well. Even though the operation
4507 -- is only accessible within the body, it is possible to make it
4508 -- available outside of the protected object by using 'Access to
4509 -- provide a callback, so build protected version in all cases.
4512 Make_Subprogram_Declaration
(Loc
,
4514 Build_Protected_Sub_Specification
(N
, Scop
, Protected_Mode
));
4515 Insert_Before
(Prot_Bod
, Prot_Decl
);
4516 Analyze
(Prot_Decl
);
4521 -- Ada 2005 (AI-348): Generate body for a null procedure.
4522 -- In most cases this is superfluous because calls to it
4523 -- will be automatically inlined, but we definitely need
4524 -- the body if preconditions for the procedure are present.
4526 elsif Nkind
(Specification
(N
)) = N_Procedure_Specification
4527 and then Null_Present
(Specification
(N
))
4530 Bod
: constant Node_Id
:= Body_To_Inline
(N
);
4533 Set_Has_Completion
(Subp
, False);
4534 Append_Freeze_Action
(Subp
, Bod
);
4536 -- The body now contains raise statements, so calls to it will
4539 Set_Is_Inlined
(Subp
, False);
4542 end Expand_N_Subprogram_Declaration
;
4544 ---------------------------------------
4545 -- Expand_Protected_Object_Reference --
4546 ---------------------------------------
4548 function Expand_Protected_Object_Reference
4550 Scop
: Entity_Id
) return Node_Id
4552 Loc
: constant Source_Ptr
:= Sloc
(N
);
4560 Make_Identifier
(Loc
,
4561 Chars
=> Name_uObject
);
4562 Set_Etype
(Rec
, Corresponding_Record_Type
(Scop
));
4564 -- Find enclosing protected operation, and retrieve its first parameter,
4565 -- which denotes the enclosing protected object. If the enclosing
4566 -- operation is an entry, we are immediately within the protected body,
4567 -- and we can retrieve the object from the service entries procedure. A
4568 -- barrier function has the same signature as an entry. A barrier
4569 -- function is compiled within the protected object, but unlike
4570 -- protected operations its never needs locks, so that its protected
4571 -- body subprogram points to itself.
4573 Proc
:= Current_Scope
;
4574 while Present
(Proc
)
4575 and then Scope
(Proc
) /= Scop
4577 Proc
:= Scope
(Proc
);
4580 Corr
:= Protected_Body_Subprogram
(Proc
);
4584 -- Previous error left expansion incomplete.
4585 -- Nothing to do on this call.
4592 (First
(Parameter_Specifications
(Parent
(Corr
))));
4594 if Is_Subprogram
(Proc
)
4595 and then Proc
/= Corr
4597 -- Protected function or procedure
4599 Set_Entity
(Rec
, Param
);
4601 -- Rec is a reference to an entity which will not be in scope when
4602 -- the call is reanalyzed, and needs no further analysis.
4607 -- Entry or barrier function for entry body. The first parameter of
4608 -- the entry body procedure is pointer to the object. We create a
4609 -- local variable of the proper type, duplicating what is done to
4610 -- define _object later on.
4614 Obj_Ptr
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
,
4616 New_Internal_Name
('T'));
4620 Make_Full_Type_Declaration
(Loc
,
4621 Defining_Identifier
=> Obj_Ptr
,
4623 Make_Access_To_Object_Definition
(Loc
,
4624 Subtype_Indication
=>
4626 (Corresponding_Record_Type
(Scop
), Loc
))));
4628 Insert_Actions
(N
, Decls
);
4629 Insert_Actions
(N
, Freeze_Entity
(Obj_Ptr
, Sloc
(N
)));
4632 Make_Explicit_Dereference
(Loc
,
4633 Unchecked_Convert_To
(Obj_Ptr
,
4634 New_Occurrence_Of
(Param
, Loc
)));
4636 -- Analyze new actual. Other actuals in calls are already analyzed
4637 -- and the list of actuals is not reanalyzed after rewriting.
4639 Set_Parent
(Rec
, N
);
4645 end Expand_Protected_Object_Reference
;
4647 --------------------------------------
4648 -- Expand_Protected_Subprogram_Call --
4649 --------------------------------------
4651 procedure Expand_Protected_Subprogram_Call
4659 -- If the protected object is not an enclosing scope, this is
4660 -- an inter-object function call. Inter-object procedure
4661 -- calls are expanded by Exp_Ch9.Build_Simple_Entry_Call.
4662 -- The call is intra-object only if the subprogram being
4663 -- called is in the protected body being compiled, and if the
4664 -- protected object in the call is statically the enclosing type.
4665 -- The object may be an component of some other data structure,
4666 -- in which case this must be handled as an inter-object call.
4668 if not In_Open_Scopes
(Scop
)
4669 or else not Is_Entity_Name
(Name
(N
))
4671 if Nkind
(Name
(N
)) = N_Selected_Component
then
4672 Rec
:= Prefix
(Name
(N
));
4675 pragma Assert
(Nkind
(Name
(N
)) = N_Indexed_Component
);
4676 Rec
:= Prefix
(Prefix
(Name
(N
)));
4679 Build_Protected_Subprogram_Call
(N
,
4680 Name
=> New_Occurrence_Of
(Subp
, Sloc
(N
)),
4681 Rec
=> Convert_Concurrent
(Rec
, Etype
(Rec
)),
4685 Rec
:= Expand_Protected_Object_Reference
(N
, Scop
);
4691 Build_Protected_Subprogram_Call
(N
,
4698 -- If it is a function call it can appear in elaboration code and
4699 -- the called entity must be frozen here.
4701 if Ekind
(Subp
) = E_Function
then
4702 Freeze_Expression
(Name
(N
));
4705 -- Analyze and resolve the new call. The actuals have already been
4706 -- resolved, but expansion of a function call will add extra actuals
4707 -- if needed. Analysis of a procedure call already includes resolution.
4711 if Ekind
(Subp
) = E_Function
then
4712 Resolve
(N
, Etype
(Subp
));
4714 end Expand_Protected_Subprogram_Call
;
4716 --------------------------------
4717 -- Is_Build_In_Place_Function --
4718 --------------------------------
4720 function Is_Build_In_Place_Function
(E
: Entity_Id
) return Boolean is
4722 -- For now we test whether E denotes a function or access-to-function
4723 -- type whose result subtype is inherently limited. Later this test may
4724 -- be revised to allow composite nonlimited types. Functions with a
4725 -- foreign convention or whose result type has a foreign convention
4728 if Ekind
(E
) = E_Function
4729 or else Ekind
(E
) = E_Generic_Function
4730 or else (Ekind
(E
) = E_Subprogram_Type
4731 and then Etype
(E
) /= Standard_Void_Type
)
4733 -- Note: If you have Convention (C) on an inherently limited type,
4734 -- you're on your own. That is, the C code will have to be carefully
4735 -- written to know about the Ada conventions.
4737 if Has_Foreign_Convention
(E
)
4738 or else Has_Foreign_Convention
(Etype
(E
))
4742 -- In Ada 2005 all functions with an inherently limited return type
4743 -- must be handled using a build-in-place profile, including the case
4744 -- of a function with a limited interface result, where the function
4745 -- may return objects of nonlimited descendants.
4748 return Is_Inherently_Limited_Type
(Etype
(E
))
4749 and then Ada_Version
>= Ada_05
4750 and then not Debug_Flag_Dot_L
;
4756 end Is_Build_In_Place_Function
;
4758 -------------------------------------
4759 -- Is_Build_In_Place_Function_Call --
4760 -------------------------------------
4762 function Is_Build_In_Place_Function_Call
(N
: Node_Id
) return Boolean is
4763 Exp_Node
: Node_Id
:= N
;
4764 Function_Id
: Entity_Id
;
4767 -- Step past qualification or unchecked conversion (the latter can occur
4768 -- in cases of calls to 'Input).
4771 (Exp_Node
, N_Qualified_Expression
, N_Unchecked_Type_Conversion
)
4773 Exp_Node
:= Expression
(N
);
4776 if Nkind
(Exp_Node
) /= N_Function_Call
then
4780 if Is_Entity_Name
(Name
(Exp_Node
)) then
4781 Function_Id
:= Entity
(Name
(Exp_Node
));
4783 elsif Nkind
(Name
(Exp_Node
)) = N_Explicit_Dereference
then
4784 Function_Id
:= Etype
(Name
(Exp_Node
));
4787 return Is_Build_In_Place_Function
(Function_Id
);
4789 end Is_Build_In_Place_Function_Call
;
4791 -----------------------
4792 -- Freeze_Subprogram --
4793 -----------------------
4795 procedure Freeze_Subprogram
(N
: Node_Id
) is
4796 Loc
: constant Source_Ptr
:= Sloc
(N
);
4798 procedure Register_Predefined_DT_Entry
(Prim
: Entity_Id
);
4799 -- (Ada 2005): Register a predefined primitive in all the secondary
4800 -- dispatch tables of its primitive type.
4802 ----------------------------------
4803 -- Register_Predefined_DT_Entry --
4804 ----------------------------------
4806 procedure Register_Predefined_DT_Entry
(Prim
: Entity_Id
) is
4807 Iface_DT_Ptr
: Elmt_Id
;
4808 Tagged_Typ
: Entity_Id
;
4809 Thunk_Id
: Entity_Id
;
4810 Thunk_Code
: Node_Id
;
4813 Tagged_Typ
:= Find_Dispatching_Type
(Prim
);
4815 if No
(Access_Disp_Table
(Tagged_Typ
))
4816 or else not Has_Interfaces
(Tagged_Typ
)
4817 or else not RTE_Available
(RE_Interface_Tag
)
4818 or else Restriction_Active
(No_Dispatching_Calls
)
4823 -- Skip the first two access-to-dispatch-table pointers since they
4824 -- leads to the primary dispatch table (predefined DT and user
4825 -- defined DT). We are only concerned with the secondary dispatch
4826 -- table pointers. Note that the access-to- dispatch-table pointer
4827 -- corresponds to the first implemented interface retrieved below.
4830 Next_Elmt
(Next_Elmt
(First_Elmt
(Access_Disp_Table
(Tagged_Typ
))));
4832 while Present
(Iface_DT_Ptr
)
4833 and then Ekind
(Node
(Iface_DT_Ptr
)) = E_Constant
4835 pragma Assert
(Has_Thunks
(Node
(Iface_DT_Ptr
)));
4836 Expand_Interface_Thunk
(Prim
, Thunk_Id
, Thunk_Code
);
4838 if Present
(Thunk_Code
) then
4839 Insert_Actions_After
(N
, New_List
(
4842 Build_Set_Predefined_Prim_Op_Address
(Loc
,
4844 New_Reference_To
(Node
(Next_Elmt
(Iface_DT_Ptr
)), Loc
),
4845 Position
=> DT_Position
(Prim
),
4847 Unchecked_Convert_To
(RTE
(RE_Prim_Ptr
),
4848 Make_Attribute_Reference
(Loc
,
4849 Prefix
=> New_Reference_To
(Thunk_Id
, Loc
),
4850 Attribute_Name
=> Name_Unrestricted_Access
))),
4852 Build_Set_Predefined_Prim_Op_Address
(Loc
,
4855 (Node
(Next_Elmt
(Next_Elmt
(Next_Elmt
(Iface_DT_Ptr
)))),
4857 Position
=> DT_Position
(Prim
),
4859 Unchecked_Convert_To
(RTE
(RE_Prim_Ptr
),
4860 Make_Attribute_Reference
(Loc
,
4861 Prefix
=> New_Reference_To
(Prim
, Loc
),
4862 Attribute_Name
=> Name_Unrestricted_Access
)))));
4865 -- Skip the tag of the predefined primitives dispatch table
4867 Next_Elmt
(Iface_DT_Ptr
);
4868 pragma Assert
(Has_Thunks
(Node
(Iface_DT_Ptr
)));
4870 -- Skip the tag of the no-thunks dispatch table
4872 Next_Elmt
(Iface_DT_Ptr
);
4873 pragma Assert
(not Has_Thunks
(Node
(Iface_DT_Ptr
)));
4875 -- Skip the tag of the predefined primitives no-thunks dispatch
4878 Next_Elmt
(Iface_DT_Ptr
);
4879 pragma Assert
(not Has_Thunks
(Node
(Iface_DT_Ptr
)));
4881 Next_Elmt
(Iface_DT_Ptr
);
4883 end Register_Predefined_DT_Entry
;
4887 Subp
: constant Entity_Id
:= Entity
(N
);
4889 -- Start of processing for Freeze_Subprogram
4892 -- We suppress the initialization of the dispatch table entry when
4893 -- VM_Target because the dispatching mechanism is handled internally
4896 if Is_Dispatching_Operation
(Subp
)
4897 and then not Is_Abstract_Subprogram
(Subp
)
4898 and then Present
(DTC_Entity
(Subp
))
4899 and then Present
(Scope
(DTC_Entity
(Subp
)))
4900 and then Tagged_Type_Expansion
4901 and then not Restriction_Active
(No_Dispatching_Calls
)
4902 and then RTE_Available
(RE_Tag
)
4905 Typ
: constant Entity_Id
:= Scope
(DTC_Entity
(Subp
));
4908 -- Handle private overridden primitives
4910 if not Is_CPP_Class
(Typ
) then
4911 Check_Overriding_Operation
(Subp
);
4914 -- We assume that imported CPP primitives correspond with objects
4915 -- whose constructor is in the CPP side; therefore we don't need
4916 -- to generate code to register them in the dispatch table.
4918 if Is_CPP_Class
(Typ
) then
4921 -- Handle CPP primitives found in derivations of CPP_Class types.
4922 -- These primitives must have been inherited from some parent, and
4923 -- there is no need to register them in the dispatch table because
4924 -- Build_Inherit_Prims takes care of the initialization of these
4927 elsif Is_Imported
(Subp
)
4928 and then (Convention
(Subp
) = Convention_CPP
4929 or else Convention
(Subp
) = Convention_C
)
4933 -- Generate code to register the primitive in non statically
4934 -- allocated dispatch tables
4936 elsif not Static_Dispatch_Tables
4938 Is_Library_Level_Tagged_Type
(Scope
(DTC_Entity
(Subp
)))
4940 -- When a primitive is frozen, enter its name in its dispatch
4943 if not Is_Interface
(Typ
)
4944 or else Present
(Interface_Alias
(Subp
))
4946 if Is_Predefined_Dispatching_Operation
(Subp
) then
4947 Register_Predefined_DT_Entry
(Subp
);
4950 Insert_Actions_After
(N
,
4951 Register_Primitive
(Loc
, Prim
=> Subp
));
4957 -- Mark functions that return by reference. Note that it cannot be part
4958 -- of the normal semantic analysis of the spec since the underlying
4959 -- returned type may not be known yet (for private types).
4962 Typ
: constant Entity_Id
:= Etype
(Subp
);
4963 Utyp
: constant Entity_Id
:= Underlying_Type
(Typ
);
4965 if Is_Inherently_Limited_Type
(Typ
) then
4966 Set_Returns_By_Ref
(Subp
);
4967 elsif Present
(Utyp
) and then CW_Or_Has_Controlled_Part
(Utyp
) then
4968 Set_Returns_By_Ref
(Subp
);
4971 end Freeze_Subprogram
;
4973 -----------------------
4974 -- Is_Null_Procedure --
4975 -----------------------
4977 function Is_Null_Procedure
(Subp
: Entity_Id
) return Boolean is
4978 Decl
: constant Node_Id
:= Unit_Declaration_Node
(Subp
);
4981 if Ekind
(Subp
) /= E_Procedure
then
4984 -- Check if this is a declared null procedure
4986 elsif Nkind
(Decl
) = N_Subprogram_Declaration
then
4987 if not Null_Present
(Specification
(Decl
)) then
4990 elsif No
(Body_To_Inline
(Decl
)) then
4993 -- Check if the body contains only a null statement, followed by
4994 -- the return statement added during expansion.
4998 Orig_Bod
: constant Node_Id
:= Body_To_Inline
(Decl
);
5004 if Nkind
(Orig_Bod
) /= N_Subprogram_Body
then
5007 -- We must skip SCIL nodes because they are currently
5008 -- implemented as special N_Null_Statement nodes.
5012 (Statements
(Handled_Statement_Sequence
(Orig_Bod
)));
5013 Stat2
:= Next_Non_SCIL_Node
(Stat
);
5016 Is_Empty_List
(Declarations
(Orig_Bod
))
5017 and then Nkind
(Stat
) = N_Null_Statement
5021 (Nkind
(Stat2
) = N_Simple_Return_Statement
5022 and then No
(Next
(Stat2
))));
5030 end Is_Null_Procedure
;
5032 -------------------------------------------
5033 -- Make_Build_In_Place_Call_In_Allocator --
5034 -------------------------------------------
5036 procedure Make_Build_In_Place_Call_In_Allocator
5037 (Allocator
: Node_Id
;
5038 Function_Call
: Node_Id
)
5041 Func_Call
: Node_Id
:= Function_Call
;
5042 Function_Id
: Entity_Id
;
5043 Result_Subt
: Entity_Id
;
5044 Acc_Type
: constant Entity_Id
:= Etype
(Allocator
);
5045 New_Allocator
: Node_Id
;
5046 Return_Obj_Access
: Entity_Id
;
5049 -- Step past qualification or unchecked conversion (the latter can occur
5050 -- in cases of calls to 'Input).
5052 if Nkind_In
(Func_Call
,
5053 N_Qualified_Expression
,
5054 N_Unchecked_Type_Conversion
)
5056 Func_Call
:= Expression
(Func_Call
);
5059 -- If the call has already been processed to add build-in-place actuals
5060 -- then return. This should not normally occur in an allocator context,
5061 -- but we add the protection as a defensive measure.
5063 if Is_Expanded_Build_In_Place_Call
(Func_Call
) then
5067 -- Mark the call as processed as a build-in-place call
5069 Set_Is_Expanded_Build_In_Place_Call
(Func_Call
);
5071 Loc
:= Sloc
(Function_Call
);
5073 if Is_Entity_Name
(Name
(Func_Call
)) then
5074 Function_Id
:= Entity
(Name
(Func_Call
));
5076 elsif Nkind
(Name
(Func_Call
)) = N_Explicit_Dereference
then
5077 Function_Id
:= Etype
(Name
(Func_Call
));
5080 raise Program_Error
;
5083 Result_Subt
:= Etype
(Function_Id
);
5085 -- When the result subtype is constrained, the return object must be
5086 -- allocated on the caller side, and access to it is passed to the
5089 -- Here and in related routines, we must examine the full view of the
5090 -- type, because the view at the point of call may differ from that
5091 -- that in the function body, and the expansion mechanism depends on
5092 -- the characteristics of the full view.
5094 if Is_Constrained
(Underlying_Type
(Result_Subt
)) then
5096 -- Replace the initialized allocator of form "new T'(Func (...))"
5097 -- with an uninitialized allocator of form "new T", where T is the
5098 -- result subtype of the called function. The call to the function
5099 -- is handled separately further below.
5102 Make_Allocator
(Loc
,
5103 Expression
=> New_Reference_To
(Result_Subt
, Loc
));
5104 Set_No_Initialization
(New_Allocator
);
5106 -- Copy attributes to new allocator. Note that the new allocator
5107 -- logically comes from source if the original one did, so copy the
5108 -- relevant flag. This ensures proper treatment of the restriction
5109 -- No_Implicit_Heap_Allocations in this case.
5111 Set_Storage_Pool
(New_Allocator
, Storage_Pool
(Allocator
));
5112 Set_Procedure_To_Call
(New_Allocator
, Procedure_To_Call
(Allocator
));
5113 Set_Comes_From_Source
(New_Allocator
, Comes_From_Source
(Allocator
));
5115 Rewrite
(Allocator
, New_Allocator
);
5117 -- Create a new access object and initialize it to the result of the
5118 -- new uninitialized allocator.
5120 Return_Obj_Access
:=
5121 Make_Defining_Identifier
(Loc
, New_Internal_Name
('R'));
5122 Set_Etype
(Return_Obj_Access
, Acc_Type
);
5124 Insert_Action
(Allocator
,
5125 Make_Object_Declaration
(Loc
,
5126 Defining_Identifier
=> Return_Obj_Access
,
5127 Object_Definition
=> New_Reference_To
(Acc_Type
, Loc
),
5128 Expression
=> Relocate_Node
(Allocator
)));
5130 -- When the function has a controlling result, an allocation-form
5131 -- parameter must be passed indicating that the caller is allocating
5132 -- the result object. This is needed because such a function can be
5133 -- called as a dispatching operation and must be treated similarly
5134 -- to functions with unconstrained result subtypes.
5136 Add_Alloc_Form_Actual_To_Build_In_Place_Call
5137 (Func_Call
, Function_Id
, Alloc_Form
=> Caller_Allocation
);
5139 Add_Final_List_Actual_To_Build_In_Place_Call
5140 (Func_Call
, Function_Id
, Acc_Type
);
5142 Add_Task_Actuals_To_Build_In_Place_Call
5143 (Func_Call
, Function_Id
, Master_Actual
=> Master_Id
(Acc_Type
));
5145 -- Add an implicit actual to the function call that provides access
5146 -- to the allocated object. An unchecked conversion to the (specific)
5147 -- result subtype of the function is inserted to handle cases where
5148 -- the access type of the allocator has a class-wide designated type.
5150 Add_Access_Actual_To_Build_In_Place_Call
5153 Make_Unchecked_Type_Conversion
(Loc
,
5154 Subtype_Mark
=> New_Reference_To
(Result_Subt
, Loc
),
5156 Make_Explicit_Dereference
(Loc
,
5157 Prefix
=> New_Reference_To
(Return_Obj_Access
, Loc
))));
5159 -- When the result subtype is unconstrained, the function itself must
5160 -- perform the allocation of the return object, so we pass parameters
5161 -- indicating that. We don't yet handle the case where the allocation
5162 -- must be done in a user-defined storage pool, which will require
5163 -- passing another actual or two to provide allocation/deallocation
5168 -- Pass an allocation parameter indicating that the function should
5169 -- allocate its result on the heap.
5171 Add_Alloc_Form_Actual_To_Build_In_Place_Call
5172 (Func_Call
, Function_Id
, Alloc_Form
=> Global_Heap
);
5174 Add_Final_List_Actual_To_Build_In_Place_Call
5175 (Func_Call
, Function_Id
, Acc_Type
);
5177 Add_Task_Actuals_To_Build_In_Place_Call
5178 (Func_Call
, Function_Id
, Master_Actual
=> Master_Id
(Acc_Type
));
5180 -- The caller does not provide the return object in this case, so we
5181 -- have to pass null for the object access actual.
5183 Add_Access_Actual_To_Build_In_Place_Call
5184 (Func_Call
, Function_Id
, Return_Object
=> Empty
);
5187 -- Finally, replace the allocator node with a reference to the result
5188 -- of the function call itself (which will effectively be an access
5189 -- to the object created by the allocator).
5191 Rewrite
(Allocator
, Make_Reference
(Loc
, Relocate_Node
(Function_Call
)));
5192 Analyze_And_Resolve
(Allocator
, Acc_Type
);
5193 end Make_Build_In_Place_Call_In_Allocator
;
5195 ---------------------------------------------------
5196 -- Make_Build_In_Place_Call_In_Anonymous_Context --
5197 ---------------------------------------------------
5199 procedure Make_Build_In_Place_Call_In_Anonymous_Context
5200 (Function_Call
: Node_Id
)
5203 Func_Call
: Node_Id
:= Function_Call
;
5204 Function_Id
: Entity_Id
;
5205 Result_Subt
: Entity_Id
;
5206 Return_Obj_Id
: Entity_Id
;
5207 Return_Obj_Decl
: Entity_Id
;
5210 -- Step past qualification or unchecked conversion (the latter can occur
5211 -- in cases of calls to 'Input).
5213 if Nkind_In
(Func_Call
, N_Qualified_Expression
,
5214 N_Unchecked_Type_Conversion
)
5216 Func_Call
:= Expression
(Func_Call
);
5219 -- If the call has already been processed to add build-in-place actuals
5220 -- then return. One place this can occur is for calls to build-in-place
5221 -- functions that occur within a call to a protected operation, where
5222 -- due to rewriting and expansion of the protected call there can be
5223 -- more than one call to Expand_Actuals for the same set of actuals.
5225 if Is_Expanded_Build_In_Place_Call
(Func_Call
) then
5229 -- Mark the call as processed as a build-in-place call
5231 Set_Is_Expanded_Build_In_Place_Call
(Func_Call
);
5233 Loc
:= Sloc
(Function_Call
);
5235 if Is_Entity_Name
(Name
(Func_Call
)) then
5236 Function_Id
:= Entity
(Name
(Func_Call
));
5238 elsif Nkind
(Name
(Func_Call
)) = N_Explicit_Dereference
then
5239 Function_Id
:= Etype
(Name
(Func_Call
));
5242 raise Program_Error
;
5245 Result_Subt
:= Etype
(Function_Id
);
5247 -- When the result subtype is constrained, an object of the subtype is
5248 -- declared and an access value designating it is passed as an actual.
5250 if Is_Constrained
(Underlying_Type
(Result_Subt
)) then
5252 -- Create a temporary object to hold the function result
5255 Make_Defining_Identifier
(Loc
,
5256 Chars
=> New_Internal_Name
('R'));
5257 Set_Etype
(Return_Obj_Id
, Result_Subt
);
5260 Make_Object_Declaration
(Loc
,
5261 Defining_Identifier
=> Return_Obj_Id
,
5262 Aliased_Present
=> True,
5263 Object_Definition
=> New_Reference_To
(Result_Subt
, Loc
));
5265 Set_No_Initialization
(Return_Obj_Decl
);
5267 Insert_Action
(Func_Call
, Return_Obj_Decl
);
5269 -- When the function has a controlling result, an allocation-form
5270 -- parameter must be passed indicating that the caller is allocating
5271 -- the result object. This is needed because such a function can be
5272 -- called as a dispatching operation and must be treated similarly
5273 -- to functions with unconstrained result subtypes.
5275 Add_Alloc_Form_Actual_To_Build_In_Place_Call
5276 (Func_Call
, Function_Id
, Alloc_Form
=> Caller_Allocation
);
5278 Add_Final_List_Actual_To_Build_In_Place_Call
5279 (Func_Call
, Function_Id
, Acc_Type
=> Empty
);
5281 Add_Task_Actuals_To_Build_In_Place_Call
5282 (Func_Call
, Function_Id
, Make_Identifier
(Loc
, Name_uMaster
));
5284 -- Add an implicit actual to the function call that provides access
5285 -- to the caller's return object.
5287 Add_Access_Actual_To_Build_In_Place_Call
5288 (Func_Call
, Function_Id
, New_Reference_To
(Return_Obj_Id
, Loc
));
5290 -- When the result subtype is unconstrained, the function must allocate
5291 -- the return object in the secondary stack, so appropriate implicit
5292 -- parameters are added to the call to indicate that. A transient
5293 -- scope is established to ensure eventual cleanup of the result.
5297 -- Pass an allocation parameter indicating that the function should
5298 -- allocate its result on the secondary stack.
5300 Add_Alloc_Form_Actual_To_Build_In_Place_Call
5301 (Func_Call
, Function_Id
, Alloc_Form
=> Secondary_Stack
);
5303 Add_Final_List_Actual_To_Build_In_Place_Call
5304 (Func_Call
, Function_Id
, Acc_Type
=> Empty
);
5306 Add_Task_Actuals_To_Build_In_Place_Call
5307 (Func_Call
, Function_Id
, Make_Identifier
(Loc
, Name_uMaster
));
5309 -- Pass a null value to the function since no return object is
5310 -- available on the caller side.
5312 Add_Access_Actual_To_Build_In_Place_Call
5313 (Func_Call
, Function_Id
, Empty
);
5315 Establish_Transient_Scope
(Func_Call
, Sec_Stack
=> True);
5317 end Make_Build_In_Place_Call_In_Anonymous_Context
;
5319 --------------------------------------------
5320 -- Make_Build_In_Place_Call_In_Assignment --
5321 --------------------------------------------
5323 procedure Make_Build_In_Place_Call_In_Assignment
5325 Function_Call
: Node_Id
)
5327 Lhs
: constant Node_Id
:= Name
(Assign
);
5328 Func_Call
: Node_Id
:= Function_Call
;
5329 Func_Id
: Entity_Id
;
5333 Ptr_Typ
: Entity_Id
;
5334 Ptr_Typ_Decl
: Node_Id
;
5335 Result_Subt
: Entity_Id
;
5339 -- Step past qualification or unchecked conversion (the latter can occur
5340 -- in cases of calls to 'Input).
5342 if Nkind_In
(Func_Call
, N_Qualified_Expression
,
5343 N_Unchecked_Type_Conversion
)
5345 Func_Call
:= Expression
(Func_Call
);
5348 -- If the call has already been processed to add build-in-place actuals
5349 -- then return. This should not normally occur in an assignment context,
5350 -- but we add the protection as a defensive measure.
5352 if Is_Expanded_Build_In_Place_Call
(Func_Call
) then
5356 -- Mark the call as processed as a build-in-place call
5358 Set_Is_Expanded_Build_In_Place_Call
(Func_Call
);
5360 Loc
:= Sloc
(Function_Call
);
5362 if Is_Entity_Name
(Name
(Func_Call
)) then
5363 Func_Id
:= Entity
(Name
(Func_Call
));
5365 elsif Nkind
(Name
(Func_Call
)) = N_Explicit_Dereference
then
5366 Func_Id
:= Etype
(Name
(Func_Call
));
5369 raise Program_Error
;
5372 Result_Subt
:= Etype
(Func_Id
);
5374 -- When the result subtype is unconstrained, an additional actual must
5375 -- be passed to indicate that the caller is providing the return object.
5376 -- This parameter must also be passed when the called function has a
5377 -- controlling result, because dispatching calls to the function needs
5378 -- to be treated effectively the same as calls to class-wide functions.
5380 Add_Alloc_Form_Actual_To_Build_In_Place_Call
5381 (Func_Call
, Func_Id
, Alloc_Form
=> Caller_Allocation
);
5383 -- If Lhs is a selected component, then pass it along so that its prefix
5384 -- object will be used as the source of the finalization list.
5386 if Nkind
(Lhs
) = N_Selected_Component
then
5387 Add_Final_List_Actual_To_Build_In_Place_Call
5388 (Func_Call
, Func_Id
, Acc_Type
=> Empty
, Sel_Comp
=> Lhs
);
5390 Add_Final_List_Actual_To_Build_In_Place_Call
5391 (Func_Call
, Func_Id
, Acc_Type
=> Empty
);
5394 Add_Task_Actuals_To_Build_In_Place_Call
5395 (Func_Call
, Func_Id
, Make_Identifier
(Loc
, Name_uMaster
));
5397 -- Add an implicit actual to the function call that provides access to
5398 -- the caller's return object.
5400 Add_Access_Actual_To_Build_In_Place_Call
5403 Make_Unchecked_Type_Conversion
(Loc
,
5404 Subtype_Mark
=> New_Reference_To
(Result_Subt
, Loc
),
5405 Expression
=> Relocate_Node
(Lhs
)));
5407 -- Create an access type designating the function's result subtype
5410 Make_Defining_Identifier
(Loc
, New_Internal_Name
('A'));
5413 Make_Full_Type_Declaration
(Loc
,
5414 Defining_Identifier
=> Ptr_Typ
,
5416 Make_Access_To_Object_Definition
(Loc
,
5417 All_Present
=> True,
5418 Subtype_Indication
=>
5419 New_Reference_To
(Result_Subt
, Loc
)));
5420 Insert_After_And_Analyze
(Assign
, Ptr_Typ_Decl
);
5422 -- Finally, create an access object initialized to a reference to the
5425 Obj_Id
:= Make_Defining_Identifier
(Loc
, New_Internal_Name
('R'));
5426 Set_Etype
(Obj_Id
, Ptr_Typ
);
5429 Make_Object_Declaration
(Loc
,
5430 Defining_Identifier
=> Obj_Id
,
5431 Object_Definition
=>
5432 New_Reference_To
(Ptr_Typ
, Loc
),
5434 Make_Reference
(Loc
,
5435 Prefix
=> Relocate_Node
(Func_Call
)));
5436 Insert_After_And_Analyze
(Ptr_Typ_Decl
, Obj_Decl
);
5438 Rewrite
(Assign
, Make_Null_Statement
(Loc
));
5440 -- Retrieve the target of the assignment
5442 if Nkind
(Lhs
) = N_Selected_Component
then
5443 Target
:= Selector_Name
(Lhs
);
5444 elsif Nkind
(Lhs
) = N_Type_Conversion
then
5445 Target
:= Expression
(Lhs
);
5450 -- If we are assigning to a return object or this is an expression of
5451 -- an extension aggregate, the target should either be an identifier
5452 -- or a simple expression. All other cases imply a different scenario.
5454 if Nkind
(Target
) in N_Has_Entity
then
5455 Target
:= Entity
(Target
);
5460 -- When the target of the assignment is a return object of an enclosing
5461 -- build-in-place function and also requires finalization, the list
5462 -- generated for the assignment must be moved to that of the enclosing
5465 -- function Enclosing_BIP_Function return Ctrl_Typ is
5467 -- return (Ctrl_Parent_Part => BIP_Function with ...);
5468 -- end Enclosing_BIP_Function;
5470 if Is_Return_Object
(Target
)
5471 and then Needs_Finalization
(Etype
(Target
))
5472 and then Needs_Finalization
(Result_Subt
)
5475 Obj_List
: constant Node_Id
:= Find_Final_List
(Obj_Id
);
5476 Encl_List
: Node_Id
;
5477 Encl_Scop
: Entity_Id
;
5480 Encl_Scop
:= Scope
(Target
);
5482 -- Locate the scope of the extended return statement
5484 while Present
(Encl_Scop
)
5485 and then Ekind
(Encl_Scop
) /= E_Return_Statement
5487 Encl_Scop
:= Scope
(Encl_Scop
);
5490 -- A return object should always be enclosed by a return statement
5491 -- scope at some level.
5493 pragma Assert
(Present
(Encl_Scop
));
5496 Make_Attribute_Reference
(Loc
,
5499 Finalization_Chain_Entity
(Encl_Scop
), Loc
),
5500 Attribute_Name
=> Name_Unrestricted_Access
);
5502 -- Generate a call to move final list
5504 Insert_After_And_Analyze
(Obj_Decl
,
5505 Make_Procedure_Call_Statement
(Loc
,
5507 New_Reference_To
(RTE
(RE_Move_Final_List
), Loc
),
5508 Parameter_Associations
=> New_List
(Obj_List
, Encl_List
)));
5511 end Make_Build_In_Place_Call_In_Assignment
;
5513 ----------------------------------------------------
5514 -- Make_Build_In_Place_Call_In_Object_Declaration --
5515 ----------------------------------------------------
5517 procedure Make_Build_In_Place_Call_In_Object_Declaration
5518 (Object_Decl
: Node_Id
;
5519 Function_Call
: Node_Id
)
5522 Obj_Def_Id
: constant Entity_Id
:=
5523 Defining_Identifier
(Object_Decl
);
5525 Func_Call
: Node_Id
:= Function_Call
;
5526 Function_Id
: Entity_Id
;
5527 Result_Subt
: Entity_Id
;
5528 Caller_Object
: Node_Id
;
5529 Call_Deref
: Node_Id
;
5530 Ref_Type
: Entity_Id
;
5531 Ptr_Typ_Decl
: Node_Id
;
5534 Enclosing_Func
: Entity_Id
;
5535 Pass_Caller_Acc
: Boolean := False;
5538 -- Step past qualification or unchecked conversion (the latter can occur
5539 -- in cases of calls to 'Input).
5541 if Nkind_In
(Func_Call
, N_Qualified_Expression
,
5542 N_Unchecked_Type_Conversion
)
5544 Func_Call
:= Expression
(Func_Call
);
5547 -- If the call has already been processed to add build-in-place actuals
5548 -- then return. This should not normally occur in an object declaration,
5549 -- but we add the protection as a defensive measure.
5551 if Is_Expanded_Build_In_Place_Call
(Func_Call
) then
5555 -- Mark the call as processed as a build-in-place call
5557 Set_Is_Expanded_Build_In_Place_Call
(Func_Call
);
5559 Loc
:= Sloc
(Function_Call
);
5561 if Is_Entity_Name
(Name
(Func_Call
)) then
5562 Function_Id
:= Entity
(Name
(Func_Call
));
5564 elsif Nkind
(Name
(Func_Call
)) = N_Explicit_Dereference
then
5565 Function_Id
:= Etype
(Name
(Func_Call
));
5568 raise Program_Error
;
5571 Result_Subt
:= Etype
(Function_Id
);
5573 -- In the constrained case, add an implicit actual to the function call
5574 -- that provides access to the declared object. An unchecked conversion
5575 -- to the (specific) result type of the function is inserted to handle
5576 -- the case where the object is declared with a class-wide type.
5578 if Is_Constrained
(Underlying_Type
(Result_Subt
)) then
5580 Make_Unchecked_Type_Conversion
(Loc
,
5581 Subtype_Mark
=> New_Reference_To
(Result_Subt
, Loc
),
5582 Expression
=> New_Reference_To
(Obj_Def_Id
, Loc
));
5584 -- When the function has a controlling result, an allocation-form
5585 -- parameter must be passed indicating that the caller is allocating
5586 -- the result object. This is needed because such a function can be
5587 -- called as a dispatching operation and must be treated similarly
5588 -- to functions with unconstrained result subtypes.
5590 Add_Alloc_Form_Actual_To_Build_In_Place_Call
5591 (Func_Call
, Function_Id
, Alloc_Form
=> Caller_Allocation
);
5593 -- If the function's result subtype is unconstrained and the object is
5594 -- a return object of an enclosing build-in-place function, then the
5595 -- implicit build-in-place parameters of the enclosing function must be
5596 -- passed along to the called function. (Unfortunately, this won't cover
5597 -- the case of extension aggregates where the ancestor part is a build-
5598 -- in-place unconstrained function call that should be passed along the
5599 -- caller's parameters. Currently those get mishandled by reassigning
5600 -- the result of the call to the aggregate return object, when the call
5601 -- result should really be directly built in place in the aggregate and
5602 -- not built in a temporary. ???)
5604 elsif Is_Return_Object
(Defining_Identifier
(Object_Decl
)) then
5605 Pass_Caller_Acc
:= True;
5607 Enclosing_Func
:= Enclosing_Subprogram
(Obj_Def_Id
);
5609 -- If the enclosing function has a constrained result type, then
5610 -- caller allocation will be used.
5612 if Is_Constrained
(Etype
(Enclosing_Func
)) then
5613 Add_Alloc_Form_Actual_To_Build_In_Place_Call
5614 (Func_Call
, Function_Id
, Alloc_Form
=> Caller_Allocation
);
5616 -- Otherwise, when the enclosing function has an unconstrained result
5617 -- type, the BIP_Alloc_Form formal of the enclosing function must be
5618 -- passed along to the callee.
5621 Add_Alloc_Form_Actual_To_Build_In_Place_Call
5626 (Build_In_Place_Formal
(Enclosing_Func
, BIP_Alloc_Form
),
5630 -- Retrieve the BIPacc formal from the enclosing function and convert
5631 -- it to the access type of the callee's BIP_Object_Access formal.
5634 Make_Unchecked_Type_Conversion
(Loc
,
5638 (Build_In_Place_Formal
(Function_Id
, BIP_Object_Access
)),
5642 (Build_In_Place_Formal
(Enclosing_Func
, BIP_Object_Access
),
5645 -- In other unconstrained cases, pass an indication to do the allocation
5646 -- on the secondary stack and set Caller_Object to Empty so that a null
5647 -- value will be passed for the caller's object address. A transient
5648 -- scope is established to ensure eventual cleanup of the result.
5651 Add_Alloc_Form_Actual_To_Build_In_Place_Call
5654 Alloc_Form
=> Secondary_Stack
);
5655 Caller_Object
:= Empty
;
5657 Establish_Transient_Scope
(Object_Decl
, Sec_Stack
=> True);
5660 Add_Final_List_Actual_To_Build_In_Place_Call
5661 (Func_Call
, Function_Id
, Acc_Type
=> Empty
);
5663 if Nkind
(Parent
(Object_Decl
)) = N_Extended_Return_Statement
5664 and then Has_Task
(Result_Subt
)
5666 Enclosing_Func
:= Enclosing_Subprogram
(Obj_Def_Id
);
5668 -- Here we're passing along the master that was passed in to this
5671 Add_Task_Actuals_To_Build_In_Place_Call
5672 (Func_Call
, Function_Id
,
5675 (Build_In_Place_Formal
(Enclosing_Func
, BIP_Master
), Loc
));
5678 Add_Task_Actuals_To_Build_In_Place_Call
5679 (Func_Call
, Function_Id
, Make_Identifier
(Loc
, Name_uMaster
));
5682 Add_Access_Actual_To_Build_In_Place_Call
5683 (Func_Call
, Function_Id
, Caller_Object
, Is_Access
=> Pass_Caller_Acc
);
5685 -- Create an access type designating the function's result subtype
5688 Make_Defining_Identifier
(Loc
, New_Internal_Name
('A'));
5691 Make_Full_Type_Declaration
(Loc
,
5692 Defining_Identifier
=> Ref_Type
,
5694 Make_Access_To_Object_Definition
(Loc
,
5695 All_Present
=> True,
5696 Subtype_Indication
=>
5697 New_Reference_To
(Result_Subt
, Loc
)));
5699 -- The access type and its accompanying object must be inserted after
5700 -- the object declaration in the constrained case, so that the function
5701 -- call can be passed access to the object. In the unconstrained case,
5702 -- the access type and object must be inserted before the object, since
5703 -- the object declaration is rewritten to be a renaming of a dereference
5704 -- of the access object.
5706 if Is_Constrained
(Underlying_Type
(Result_Subt
)) then
5707 Insert_After_And_Analyze
(Object_Decl
, Ptr_Typ_Decl
);
5709 Insert_Action
(Object_Decl
, Ptr_Typ_Decl
);
5712 -- Finally, create an access object initialized to a reference to the
5716 Make_Defining_Identifier
(Loc
,
5717 Chars
=> New_Internal_Name
('R'));
5718 Set_Etype
(Def_Id
, Ref_Type
);
5721 Make_Reference
(Loc
,
5722 Prefix
=> Relocate_Node
(Func_Call
));
5724 Insert_After_And_Analyze
(Ptr_Typ_Decl
,
5725 Make_Object_Declaration
(Loc
,
5726 Defining_Identifier
=> Def_Id
,
5727 Object_Definition
=> New_Reference_To
(Ref_Type
, Loc
),
5728 Expression
=> New_Expr
));
5730 if Is_Constrained
(Underlying_Type
(Result_Subt
)) then
5731 Set_Expression
(Object_Decl
, Empty
);
5732 Set_No_Initialization
(Object_Decl
);
5734 -- In case of an unconstrained result subtype, rewrite the object
5735 -- declaration as an object renaming where the renamed object is a
5736 -- dereference of <function_Call>'reference:
5738 -- Obj : Subt renames <function_call>'Ref.all;
5742 Make_Explicit_Dereference
(Loc
,
5743 Prefix
=> New_Reference_To
(Def_Id
, Loc
));
5745 Rewrite
(Object_Decl
,
5746 Make_Object_Renaming_Declaration
(Loc
,
5747 Defining_Identifier
=> Make_Defining_Identifier
(Loc
,
5748 New_Internal_Name
('D')),
5749 Access_Definition
=> Empty
,
5750 Subtype_Mark
=> New_Occurrence_Of
(Result_Subt
, Loc
),
5751 Name
=> Call_Deref
));
5753 Set_Renamed_Object
(Defining_Identifier
(Object_Decl
), Call_Deref
);
5755 Analyze
(Object_Decl
);
5757 -- Replace the internal identifier of the renaming declaration's
5758 -- entity with identifier of the original object entity. We also have
5759 -- to exchange the entities containing their defining identifiers to
5760 -- ensure the correct replacement of the object declaration by the
5761 -- object renaming declaration to avoid homograph conflicts (since
5762 -- the object declaration's defining identifier was already entered
5763 -- in current scope). The Next_Entity links of the two entities also
5764 -- have to be swapped since the entities are part of the return
5765 -- scope's entity list and the list structure would otherwise be
5766 -- corrupted. Finally, the homonym chain must be preserved as well.
5769 Renaming_Def_Id
: constant Entity_Id
:=
5770 Defining_Identifier
(Object_Decl
);
5771 Next_Entity_Temp
: constant Entity_Id
:=
5772 Next_Entity
(Renaming_Def_Id
);
5774 Set_Chars
(Renaming_Def_Id
, Chars
(Obj_Def_Id
));
5776 -- Swap next entity links in preparation for exchanging entities
5778 Set_Next_Entity
(Renaming_Def_Id
, Next_Entity
(Obj_Def_Id
));
5779 Set_Next_Entity
(Obj_Def_Id
, Next_Entity_Temp
);
5780 Set_Homonym
(Renaming_Def_Id
, Homonym
(Obj_Def_Id
));
5782 Exchange_Entities
(Renaming_Def_Id
, Obj_Def_Id
);
5786 -- If the object entity has a class-wide Etype, then we need to change
5787 -- it to the result subtype of the function call, because otherwise the
5788 -- object will be class-wide without an explicit initialization and
5789 -- won't be allocated properly by the back end. It seems unclean to make
5790 -- such a revision to the type at this point, and we should try to
5791 -- improve this treatment when build-in-place functions with class-wide
5792 -- results are implemented. ???
5794 if Is_Class_Wide_Type
(Etype
(Defining_Identifier
(Object_Decl
))) then
5795 Set_Etype
(Defining_Identifier
(Object_Decl
), Result_Subt
);
5797 end Make_Build_In_Place_Call_In_Object_Declaration
;
5799 --------------------------
5800 -- Needs_BIP_Final_List --
5801 --------------------------
5803 function Needs_BIP_Final_List
(E
: Entity_Id
) return Boolean is
5804 pragma Assert
(Is_Build_In_Place_Function
(E
));
5805 Result_Subt
: constant Entity_Id
:= Underlying_Type
(Etype
(E
));
5808 -- We need the BIP_Final_List if the result type needs finalization. We
5809 -- also need it for tagged types, even if not class-wide, because some
5810 -- type extension might need finalization, and all overriding functions
5811 -- must have the same calling conventions. However, if there is a
5812 -- pragma Restrictions (No_Finalization), we never need this parameter.
5814 return (Needs_Finalization
(Result_Subt
)
5815 or else Is_Tagged_Type
(Underlying_Type
(Result_Subt
)))
5816 and then not Restriction_Active
(No_Finalization
);
5817 end Needs_BIP_Final_List
;