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
2318 -- the called subprogram, which is one greater than the
2319 -- current scope level.
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
)));
2783 Resolve
(Actual
, Parent_Typ
);
2786 -- For array and record types, the parent formal type and
2787 -- derived formal type have different sizes or pragma Pack
2790 elsif ((Is_Array_Type
(Formal_Typ
)
2791 and then Is_Array_Type
(Parent_Typ
))
2793 (Is_Record_Type
(Formal_Typ
)
2794 and then Is_Record_Type
(Parent_Typ
)))
2796 (Esize
(Formal_Typ
) /= Esize
(Parent_Typ
)
2797 or else Has_Pragma_Pack
(Formal_Typ
) /=
2798 Has_Pragma_Pack
(Parent_Typ
))
2800 Convert
(Actual
, Parent_Typ
);
2803 Next_Actual
(Actual
);
2804 Next_Formal
(Formal
);
2805 Next_Formal
(Parent_Formal
);
2811 Subp
:= Parent_Subp
;
2814 -- Check for violation of No_Abort_Statements
2816 if Is_RTE
(Subp
, RE_Abort_Task
) then
2817 Check_Restriction
(No_Abort_Statements
, N
);
2819 -- Check for violation of No_Dynamic_Attachment
2821 elsif RTU_Loaded
(Ada_Interrupts
)
2822 and then (Is_RTE
(Subp
, RE_Is_Reserved
) or else
2823 Is_RTE
(Subp
, RE_Is_Attached
) or else
2824 Is_RTE
(Subp
, RE_Current_Handler
) or else
2825 Is_RTE
(Subp
, RE_Attach_Handler
) or else
2826 Is_RTE
(Subp
, RE_Exchange_Handler
) or else
2827 Is_RTE
(Subp
, RE_Detach_Handler
) or else
2828 Is_RTE
(Subp
, RE_Reference
))
2830 Check_Restriction
(No_Dynamic_Attachment
, N
);
2833 -- Deal with case where call is an explicit dereference
2835 if Nkind
(Name
(N
)) = N_Explicit_Dereference
then
2837 -- Handle case of access to protected subprogram type
2839 if Is_Access_Protected_Subprogram_Type
2840 (Base_Type
(Etype
(Prefix
(Name
(N
)))))
2842 -- If this is a call through an access to protected operation,
2843 -- the prefix has the form (object'address, operation'access).
2844 -- Rewrite as a for other protected calls: the object is the
2845 -- first parameter of the list of actuals.
2852 Ptr
: constant Node_Id
:= Prefix
(Name
(N
));
2854 T
: constant Entity_Id
:=
2855 Equivalent_Type
(Base_Type
(Etype
(Ptr
)));
2857 D_T
: constant Entity_Id
:=
2858 Designated_Type
(Base_Type
(Etype
(Ptr
)));
2862 Make_Selected_Component
(Loc
,
2863 Prefix
=> Unchecked_Convert_To
(T
, Ptr
),
2865 New_Occurrence_Of
(First_Entity
(T
), Loc
));
2868 Make_Selected_Component
(Loc
,
2869 Prefix
=> Unchecked_Convert_To
(T
, Ptr
),
2871 New_Occurrence_Of
(Next_Entity
(First_Entity
(T
)), Loc
));
2874 Make_Explicit_Dereference
(Loc
,
2877 if Present
(Parameter_Associations
(N
)) then
2878 Parm
:= Parameter_Associations
(N
);
2883 Prepend
(Obj
, Parm
);
2885 if Etype
(D_T
) = Standard_Void_Type
then
2887 Make_Procedure_Call_Statement
(Loc
,
2889 Parameter_Associations
=> Parm
);
2892 Make_Function_Call
(Loc
,
2894 Parameter_Associations
=> Parm
);
2897 Set_First_Named_Actual
(Call
, First_Named_Actual
(N
));
2898 Set_Etype
(Call
, Etype
(D_T
));
2900 -- We do not re-analyze the call to avoid infinite recursion.
2901 -- We analyze separately the prefix and the object, and set
2902 -- the checks on the prefix that would otherwise be emitted
2903 -- when resolving a call.
2907 Apply_Access_Check
(Nam
);
2914 -- If this is a call to an intrinsic subprogram, then perform the
2915 -- appropriate expansion to the corresponding tree node and we
2916 -- are all done (since after that the call is gone!)
2918 -- In the case where the intrinsic is to be processed by the back end,
2919 -- the call to Expand_Intrinsic_Call will do nothing, which is fine,
2920 -- since the idea in this case is to pass the call unchanged.
2921 -- If the intrinsic is an inherited unchecked conversion, and the
2922 -- derived type is the target type of the conversion, we must retain
2923 -- it as the return type of the expression. Otherwise the expansion
2924 -- below, which uses the parent operation, will yield the wrong type.
2926 if Is_Intrinsic_Subprogram
(Subp
) then
2927 Expand_Intrinsic_Call
(N
, Subp
);
2929 if Nkind
(N
) = N_Unchecked_Type_Conversion
2930 and then Parent_Subp
/= Orig_Subp
2931 and then Etype
(Parent_Subp
) /= Etype
(Orig_Subp
)
2933 Set_Etype
(N
, Etype
(Orig_Subp
));
2939 if Ekind
(Subp
) = E_Function
2940 or else Ekind
(Subp
) = E_Procedure
2942 -- We perform two simple optimization on calls:
2944 -- a) replace calls to null procedures unconditionally;
2946 -- b) for To_Address, just do an unchecked conversion. Not only is
2947 -- this efficient, but it also avoids order of elaboration problems
2948 -- when address clauses are inlined (address expression elaborated
2949 -- at the wrong point).
2951 -- We perform these optimization regardless of whether we are in the
2952 -- main unit or in a unit in the context of the main unit, to ensure
2953 -- that tree generated is the same in both cases, for Inspector use.
2955 if Is_RTE
(Subp
, RE_To_Address
) then
2957 Unchecked_Convert_To
2958 (RTE
(RE_Address
), Relocate_Node
(First_Actual
(N
))));
2961 elsif Is_Null_Procedure
(Subp
) then
2962 Rewrite
(N
, Make_Null_Statement
(Loc
));
2966 if Is_Inlined
(Subp
) then
2968 Inlined_Subprogram
: declare
2970 Must_Inline
: Boolean := False;
2971 Spec
: constant Node_Id
:= Unit_Declaration_Node
(Subp
);
2972 Scop
: constant Entity_Id
:= Scope
(Subp
);
2974 function In_Unfrozen_Instance
return Boolean;
2975 -- If the subprogram comes from an instance in the same unit,
2976 -- and the instance is not yet frozen, inlining might trigger
2977 -- order-of-elaboration problems in gigi.
2979 --------------------------
2980 -- In_Unfrozen_Instance --
2981 --------------------------
2983 function In_Unfrozen_Instance
return Boolean is
2989 and then S
/= Standard_Standard
2991 if Is_Generic_Instance
(S
)
2992 and then Present
(Freeze_Node
(S
))
2993 and then not Analyzed
(Freeze_Node
(S
))
3002 end In_Unfrozen_Instance
;
3004 -- Start of processing for Inlined_Subprogram
3007 -- Verify that the body to inline has already been seen, and
3008 -- that if the body is in the current unit the inlining does
3009 -- not occur earlier. This avoids order-of-elaboration problems
3012 -- This should be documented in sinfo/einfo ???
3015 or else Nkind
(Spec
) /= N_Subprogram_Declaration
3016 or else No
(Body_To_Inline
(Spec
))
3018 Must_Inline
:= False;
3020 -- If this an inherited function that returns a private type,
3021 -- do not inline if the full view is an unconstrained array,
3022 -- because such calls cannot be inlined.
3024 elsif Present
(Orig_Subp
)
3025 and then Is_Array_Type
(Etype
(Orig_Subp
))
3026 and then not Is_Constrained
(Etype
(Orig_Subp
))
3028 Must_Inline
:= False;
3030 elsif In_Unfrozen_Instance
then
3031 Must_Inline
:= False;
3034 Bod
:= Body_To_Inline
(Spec
);
3036 if (In_Extended_Main_Code_Unit
(N
)
3037 or else In_Extended_Main_Code_Unit
(Parent
(N
))
3038 or else Has_Pragma_Inline_Always
(Subp
))
3039 and then (not In_Same_Extended_Unit
(Sloc
(Bod
), Loc
)
3041 Earlier_In_Extended_Unit
(Sloc
(Bod
), Loc
))
3043 Must_Inline
:= True;
3045 -- If we are compiling a package body that is not the main
3046 -- unit, it must be for inlining/instantiation purposes,
3047 -- in which case we inline the call to insure that the same
3048 -- temporaries are generated when compiling the body by
3049 -- itself. Otherwise link errors can occur.
3051 -- If the function being called is itself in the main unit,
3052 -- we cannot inline, because there is a risk of double
3053 -- elaboration and/or circularity: the inlining can make
3054 -- visible a private entity in the body of the main unit,
3055 -- that gigi will see before its sees its proper definition.
3057 elsif not (In_Extended_Main_Code_Unit
(N
))
3058 and then In_Package_Body
3060 Must_Inline
:= not In_Extended_Main_Source_Unit
(Subp
);
3065 Expand_Inlined_Call
(N
, Subp
, Orig_Subp
);
3068 -- Let the back end handle it
3070 Add_Inlined_Body
(Subp
);
3072 if Front_End_Inlining
3073 and then Nkind
(Spec
) = N_Subprogram_Declaration
3074 and then (In_Extended_Main_Code_Unit
(N
))
3075 and then No
(Body_To_Inline
(Spec
))
3076 and then not Has_Completion
(Subp
)
3077 and then In_Same_Extended_Unit
(Sloc
(Spec
), Loc
)
3080 ("cannot inline& (body not seen yet)?", N
, Subp
);
3083 end Inlined_Subprogram
;
3087 -- Check for protected subprogram. This is either an intra-object call,
3088 -- or a protected function call. Protected procedure calls are rewritten
3089 -- as entry calls and handled accordingly.
3091 -- In Ada 2005, this may be an indirect call to an access parameter that
3092 -- is an access_to_subprogram. In that case the anonymous type has a
3093 -- scope that is a protected operation, but the call is a regular one.
3095 Scop
:= Scope
(Subp
);
3097 if Nkind
(N
) /= N_Entry_Call_Statement
3098 and then Is_Protected_Type
(Scop
)
3099 and then Ekind
(Subp
) /= E_Subprogram_Type
3101 -- If the call is an internal one, it is rewritten as a call to the
3102 -- corresponding unprotected subprogram.
3104 Expand_Protected_Subprogram_Call
(N
, Subp
, Scop
);
3107 -- Functions returning controlled objects need special attention:
3108 -- if the return type is limited, the context is an initialization
3109 -- and different processing applies. If the call is to a protected
3110 -- function, the expansion above will call Expand_Call recusively.
3111 -- To prevent a double attachment, check that the current call is
3112 -- not a rewriting of a protected function call.
3114 if Needs_Finalization
(Etype
(Subp
))
3115 and then not Is_Inherently_Limited_Type
(Etype
(Subp
))
3117 (No
(First_Formal
(Subp
))
3119 not Is_Concurrent_Record_Type
(Etype
(First_Formal
(Subp
))))
3121 Expand_Ctrl_Function_Call
(N
);
3124 -- Test for First_Optional_Parameter, and if so, truncate parameter list
3125 -- if there are optional parameters at the trailing end.
3126 -- Note: we never delete procedures for call via a pointer.
3128 if (Ekind
(Subp
) = E_Procedure
or else Ekind
(Subp
) = E_Function
)
3129 and then Present
(First_Optional_Parameter
(Subp
))
3132 Last_Keep_Arg
: Node_Id
;
3135 -- Last_Keep_Arg will hold the last actual that should be kept.
3136 -- If it remains empty at the end, it means that all parameters
3139 Last_Keep_Arg
:= Empty
;
3141 -- Find first optional parameter, must be present since we checked
3142 -- the validity of the parameter before setting it.
3144 Formal
:= First_Formal
(Subp
);
3145 Actual
:= First_Actual
(N
);
3146 while Formal
/= First_Optional_Parameter
(Subp
) loop
3147 Last_Keep_Arg
:= Actual
;
3148 Next_Formal
(Formal
);
3149 Next_Actual
(Actual
);
3152 -- We have Formal and Actual pointing to the first potentially
3153 -- droppable argument. We can drop all the trailing arguments
3154 -- whose actual matches the default. Note that we know that all
3155 -- remaining formals have defaults, because we checked that this
3156 -- requirement was met before setting First_Optional_Parameter.
3158 -- We use Fully_Conformant_Expressions to check for identity
3159 -- between formals and actuals, which may miss some cases, but
3160 -- on the other hand, this is only an optimization (if we fail
3161 -- to truncate a parameter it does not affect functionality).
3162 -- So if the default is 3 and the actual is 1+2, we consider
3163 -- them unequal, which hardly seems worrisome.
3165 while Present
(Formal
) loop
3166 if not Fully_Conformant_Expressions
3167 (Actual
, Default_Value
(Formal
))
3169 Last_Keep_Arg
:= Actual
;
3172 Next_Formal
(Formal
);
3173 Next_Actual
(Actual
);
3176 -- If no arguments, delete entire list, this is the easy case
3178 if No
(Last_Keep_Arg
) then
3179 Set_Parameter_Associations
(N
, No_List
);
3180 Set_First_Named_Actual
(N
, Empty
);
3182 -- Case where at the last retained argument is positional. This
3183 -- is also an easy case, since the retained arguments are already
3184 -- in the right form, and we don't need to worry about the order
3185 -- of arguments that get eliminated.
3187 elsif Is_List_Member
(Last_Keep_Arg
) then
3188 while Present
(Next
(Last_Keep_Arg
)) loop
3189 Discard_Node
(Remove_Next
(Last_Keep_Arg
));
3192 Set_First_Named_Actual
(N
, Empty
);
3194 -- This is the annoying case where the last retained argument
3195 -- is a named parameter. Since the original arguments are not
3196 -- in declaration order, we may have to delete some fairly
3197 -- random collection of arguments.
3205 -- First step, remove all the named parameters from the
3206 -- list (they are still chained using First_Named_Actual
3207 -- and Next_Named_Actual, so we have not lost them!)
3209 Temp
:= First
(Parameter_Associations
(N
));
3211 -- Case of all parameters named, remove them all
3213 if Nkind
(Temp
) = N_Parameter_Association
then
3214 while Is_Non_Empty_List
(Parameter_Associations
(N
)) loop
3215 Temp
:= Remove_Head
(Parameter_Associations
(N
));
3218 -- Case of mixed positional/named, remove named parameters
3221 while Nkind
(Next
(Temp
)) /= N_Parameter_Association
loop
3225 while Present
(Next
(Temp
)) loop
3226 Remove
(Next
(Temp
));
3230 -- Now we loop through the named parameters, till we get
3231 -- to the last one to be retained, adding them to the list.
3232 -- Note that the Next_Named_Actual list does not need to be
3233 -- touched since we are only reordering them on the actual
3234 -- parameter association list.
3236 Passoc
:= Parent
(First_Named_Actual
(N
));
3238 Temp
:= Relocate_Node
(Passoc
);
3240 (Parameter_Associations
(N
), Temp
);
3242 Last_Keep_Arg
= Explicit_Actual_Parameter
(Passoc
);
3243 Passoc
:= Parent
(Next_Named_Actual
(Passoc
));
3246 Set_Next_Named_Actual
(Temp
, Empty
);
3249 Temp
:= Next_Named_Actual
(Passoc
);
3250 exit when No
(Temp
);
3251 Set_Next_Named_Actual
3252 (Passoc
, Next_Named_Actual
(Parent
(Temp
)));
3261 --------------------------
3262 -- Expand_Inlined_Call --
3263 --------------------------
3265 procedure Expand_Inlined_Call
3268 Orig_Subp
: Entity_Id
)
3270 Loc
: constant Source_Ptr
:= Sloc
(N
);
3271 Is_Predef
: constant Boolean :=
3272 Is_Predefined_File_Name
3273 (Unit_File_Name
(Get_Source_Unit
(Subp
)));
3274 Orig_Bod
: constant Node_Id
:=
3275 Body_To_Inline
(Unit_Declaration_Node
(Subp
));
3280 Decls
: constant List_Id
:= New_List
;
3281 Exit_Lab
: Entity_Id
:= Empty
;
3288 Ret_Type
: Entity_Id
;
3292 Temp_Typ
: Entity_Id
;
3294 Is_Unc
: constant Boolean :=
3295 Is_Array_Type
(Etype
(Subp
))
3296 and then not Is_Constrained
(Etype
(Subp
));
3297 -- If the type returned by the function is unconstrained and the call
3298 -- can be inlined, special processing is required.
3300 procedure Make_Exit_Label
;
3301 -- Build declaration for exit label to be used in Return statements,
3302 -- sets Exit_Lab (the label node) and Lab_Decl (corresponding implcit
3305 function Process_Formals
(N
: Node_Id
) return Traverse_Result
;
3306 -- Replace occurrence of a formal with the corresponding actual, or the
3307 -- thunk generated for it.
3309 function Process_Sloc
(Nod
: Node_Id
) return Traverse_Result
;
3310 -- If the call being expanded is that of an internal subprogram, set the
3311 -- sloc of the generated block to that of the call itself, so that the
3312 -- expansion is skipped by the "next" command in gdb.
3313 -- Same processing for a subprogram in a predefined file, e.g.
3314 -- Ada.Tags. If Debug_Generated_Code is true, suppress this change to
3315 -- simplify our own development.
3317 procedure Rewrite_Function_Call
(N
: Node_Id
; Blk
: Node_Id
);
3318 -- If the function body is a single expression, replace call with
3319 -- expression, else insert block appropriately.
3321 procedure Rewrite_Procedure_Call
(N
: Node_Id
; Blk
: Node_Id
);
3322 -- If procedure body has no local variables, inline body without
3323 -- creating block, otherwise rewrite call with block.
3325 function Formal_Is_Used_Once
(Formal
: Entity_Id
) return Boolean;
3326 -- Determine whether a formal parameter is used only once in Orig_Bod
3328 ---------------------
3329 -- Make_Exit_Label --
3330 ---------------------
3332 procedure Make_Exit_Label
is
3334 -- Create exit label for subprogram if one does not exist yet
3336 if No
(Exit_Lab
) then
3338 Make_Identifier
(Loc
,
3339 Chars
=> New_Internal_Name
('L'));
3341 Make_Defining_Identifier
(Loc
, Chars
(Lab_Id
)));
3342 Exit_Lab
:= Make_Label
(Loc
, Lab_Id
);
3345 Make_Implicit_Label_Declaration
(Loc
,
3346 Defining_Identifier
=> Entity
(Lab_Id
),
3347 Label_Construct
=> Exit_Lab
);
3349 end Make_Exit_Label
;
3351 ---------------------
3352 -- Process_Formals --
3353 ---------------------
3355 function Process_Formals
(N
: Node_Id
) return Traverse_Result
is
3361 if Is_Entity_Name
(N
)
3362 and then Present
(Entity
(N
))
3367 and then Scope
(E
) = Subp
3369 A
:= Renamed_Object
(E
);
3371 -- Rewrite the occurrence of the formal into an occurrence of
3372 -- the actual. Also establish visibility on the proper view of
3373 -- the actual's subtype for the body's context (if the actual's
3374 -- subtype is private at the call point but its full view is
3375 -- visible to the body, then the inlined tree here must be
3376 -- analyzed with the full view).
3378 if Is_Entity_Name
(A
) then
3379 Rewrite
(N
, New_Occurrence_Of
(Entity
(A
), Loc
));
3380 Check_Private_View
(N
);
3382 elsif Nkind
(A
) = N_Defining_Identifier
then
3383 Rewrite
(N
, New_Occurrence_Of
(A
, Loc
));
3384 Check_Private_View
(N
);
3389 Rewrite
(N
, New_Copy
(A
));
3395 elsif Nkind
(N
) = N_Simple_Return_Statement
then
3396 if No
(Expression
(N
)) then
3399 Make_Goto_Statement
(Loc
,
3400 Name
=> New_Copy
(Lab_Id
)));
3403 if Nkind
(Parent
(N
)) = N_Handled_Sequence_Of_Statements
3404 and then Nkind
(Parent
(Parent
(N
))) = N_Subprogram_Body
3406 -- Function body is a single expression. No need for
3412 Num_Ret
:= Num_Ret
+ 1;
3416 -- Because of the presence of private types, the views of the
3417 -- expression and the context may be different, so place an
3418 -- unchecked conversion to the context type to avoid spurious
3419 -- errors, e.g. when the expression is a numeric literal and
3420 -- the context is private. If the expression is an aggregate,
3421 -- use a qualified expression, because an aggregate is not a
3422 -- legal argument of a conversion.
3424 if Nkind_In
(Expression
(N
), N_Aggregate
, N_Null
) then
3426 Make_Qualified_Expression
(Sloc
(N
),
3427 Subtype_Mark
=> New_Occurrence_Of
(Ret_Type
, Sloc
(N
)),
3428 Expression
=> Relocate_Node
(Expression
(N
)));
3431 Unchecked_Convert_To
3432 (Ret_Type
, Relocate_Node
(Expression
(N
)));
3435 if Nkind
(Targ
) = N_Defining_Identifier
then
3437 Make_Assignment_Statement
(Loc
,
3438 Name
=> New_Occurrence_Of
(Targ
, Loc
),
3439 Expression
=> Ret
));
3442 Make_Assignment_Statement
(Loc
,
3443 Name
=> New_Copy
(Targ
),
3444 Expression
=> Ret
));
3447 Set_Assignment_OK
(Name
(N
));
3449 if Present
(Exit_Lab
) then
3451 Make_Goto_Statement
(Loc
,
3452 Name
=> New_Copy
(Lab_Id
)));
3458 -- Remove pragma Unreferenced since it may refer to formals that
3459 -- are not visible in the inlined body, and in any case we will
3460 -- not be posting warnings on the inlined body so it is unneeded.
3462 elsif Nkind
(N
) = N_Pragma
3463 and then Pragma_Name
(N
) = Name_Unreferenced
3465 Rewrite
(N
, Make_Null_Statement
(Sloc
(N
)));
3471 end Process_Formals
;
3473 procedure Replace_Formals
is new Traverse_Proc
(Process_Formals
);
3479 function Process_Sloc
(Nod
: Node_Id
) return Traverse_Result
is
3481 if not Debug_Generated_Code
then
3482 Set_Sloc
(Nod
, Sloc
(N
));
3483 Set_Comes_From_Source
(Nod
, False);
3489 procedure Reset_Slocs
is new Traverse_Proc
(Process_Sloc
);
3491 ---------------------------
3492 -- Rewrite_Function_Call --
3493 ---------------------------
3495 procedure Rewrite_Function_Call
(N
: Node_Id
; Blk
: Node_Id
) is
3496 HSS
: constant Node_Id
:= Handled_Statement_Sequence
(Blk
);
3497 Fst
: constant Node_Id
:= First
(Statements
(HSS
));
3500 -- Optimize simple case: function body is a single return statement,
3501 -- which has been expanded into an assignment.
3503 if Is_Empty_List
(Declarations
(Blk
))
3504 and then Nkind
(Fst
) = N_Assignment_Statement
3505 and then No
(Next
(Fst
))
3508 -- The function call may have been rewritten as the temporary
3509 -- that holds the result of the call, in which case remove the
3510 -- now useless declaration.
3512 if Nkind
(N
) = N_Identifier
3513 and then Nkind
(Parent
(Entity
(N
))) = N_Object_Declaration
3515 Rewrite
(Parent
(Entity
(N
)), Make_Null_Statement
(Loc
));
3518 Rewrite
(N
, Expression
(Fst
));
3520 elsif Nkind
(N
) = N_Identifier
3521 and then Nkind
(Parent
(Entity
(N
))) = N_Object_Declaration
3523 -- The block assigns the result of the call to the temporary
3525 Insert_After
(Parent
(Entity
(N
)), Blk
);
3527 elsif Nkind
(Parent
(N
)) = N_Assignment_Statement
3529 (Is_Entity_Name
(Name
(Parent
(N
)))
3531 (Nkind
(Name
(Parent
(N
))) = N_Explicit_Dereference
3532 and then Is_Entity_Name
(Prefix
(Name
(Parent
(N
))))))
3534 -- Replace assignment with the block
3537 Original_Assignment
: constant Node_Id
:= Parent
(N
);
3540 -- Preserve the original assignment node to keep the complete
3541 -- assignment subtree consistent enough for Analyze_Assignment
3542 -- to proceed (specifically, the original Lhs node must still
3543 -- have an assignment statement as its parent).
3545 -- We cannot rely on Original_Node to go back from the block
3546 -- node to the assignment node, because the assignment might
3547 -- already be a rewrite substitution.
3549 Discard_Node
(Relocate_Node
(Original_Assignment
));
3550 Rewrite
(Original_Assignment
, Blk
);
3553 elsif Nkind
(Parent
(N
)) = N_Object_Declaration
then
3554 Set_Expression
(Parent
(N
), Empty
);
3555 Insert_After
(Parent
(N
), Blk
);
3558 Insert_Before
(Parent
(N
), Blk
);
3560 end Rewrite_Function_Call
;
3562 ----------------------------
3563 -- Rewrite_Procedure_Call --
3564 ----------------------------
3566 procedure Rewrite_Procedure_Call
(N
: Node_Id
; Blk
: Node_Id
) is
3567 HSS
: constant Node_Id
:= Handled_Statement_Sequence
(Blk
);
3569 -- If there is a transient scope for N, this will be the scope of the
3570 -- actions for N, and the statements in Blk need to be within this
3571 -- scope. For example, they need to have visibility on the constant
3572 -- declarations created for the formals.
3574 -- If N needs no transient scope, and if there are no declarations in
3575 -- the inlined body, we can do a little optimization and insert the
3576 -- statements for the body directly after N, and rewrite N to a
3577 -- null statement, instead of rewriting N into a full-blown block
3580 if not Scope_Is_Transient
3581 and then Is_Empty_List
(Declarations
(Blk
))
3583 Insert_List_After
(N
, Statements
(HSS
));
3584 Rewrite
(N
, Make_Null_Statement
(Loc
));
3588 end Rewrite_Procedure_Call
;
3590 -------------------------
3591 -- Formal_Is_Used_Once --
3592 -------------------------
3594 function Formal_Is_Used_Once
(Formal
: Entity_Id
) return Boolean is
3595 Use_Counter
: Int
:= 0;
3597 function Count_Uses
(N
: Node_Id
) return Traverse_Result
;
3598 -- Traverse the tree and count the uses of the formal parameter.
3599 -- In this case, for optimization purposes, we do not need to
3600 -- continue the traversal once more than one use is encountered.
3606 function Count_Uses
(N
: Node_Id
) return Traverse_Result
is
3608 -- The original node is an identifier
3610 if Nkind
(N
) = N_Identifier
3611 and then Present
(Entity
(N
))
3613 -- Original node's entity points to the one in the copied body
3615 and then Nkind
(Entity
(N
)) = N_Identifier
3616 and then Present
(Entity
(Entity
(N
)))
3618 -- The entity of the copied node is the formal parameter
3620 and then Entity
(Entity
(N
)) = Formal
3622 Use_Counter
:= Use_Counter
+ 1;
3624 if Use_Counter
> 1 then
3626 -- Denote more than one use and abandon the traversal
3637 procedure Count_Formal_Uses
is new Traverse_Proc
(Count_Uses
);
3639 -- Start of processing for Formal_Is_Used_Once
3642 Count_Formal_Uses
(Orig_Bod
);
3643 return Use_Counter
= 1;
3644 end Formal_Is_Used_Once
;
3646 -- Start of processing for Expand_Inlined_Call
3650 -- Check for an illegal attempt to inline a recursive procedure. If the
3651 -- subprogram has parameters this is detected when trying to supply a
3652 -- binding for parameters that already have one. For parameterless
3653 -- subprograms this must be done explicitly.
3655 if In_Open_Scopes
(Subp
) then
3656 Error_Msg_N
("call to recursive subprogram cannot be inlined?", N
);
3657 Set_Is_Inlined
(Subp
, False);
3661 if Nkind
(Orig_Bod
) = N_Defining_Identifier
3662 or else Nkind
(Orig_Bod
) = N_Defining_Operator_Symbol
3664 -- Subprogram is a renaming_as_body. Calls appearing after the
3665 -- renaming can be replaced with calls to the renamed entity
3666 -- directly, because the subprograms are subtype conformant. If
3667 -- the renamed subprogram is an inherited operation, we must redo
3668 -- the expansion because implicit conversions may be needed.
3670 Set_Name
(N
, New_Occurrence_Of
(Orig_Bod
, Loc
));
3672 if Present
(Alias
(Orig_Bod
)) then
3679 -- Use generic machinery to copy body of inlined subprogram, as if it
3680 -- were an instantiation, resetting source locations appropriately, so
3681 -- that nested inlined calls appear in the main unit.
3683 Save_Env
(Subp
, Empty
);
3684 Set_Copied_Sloc_For_Inlined_Body
(N
, Defining_Entity
(Orig_Bod
));
3686 Bod
:= Copy_Generic_Node
(Orig_Bod
, Empty
, Instantiating
=> True);
3688 Make_Block_Statement
(Loc
,
3689 Declarations
=> Declarations
(Bod
),
3690 Handled_Statement_Sequence
=> Handled_Statement_Sequence
(Bod
));
3692 if No
(Declarations
(Bod
)) then
3693 Set_Declarations
(Blk
, New_List
);
3696 -- For the unconstrained case, capture the name of the local
3697 -- variable that holds the result. This must be the first declaration
3698 -- in the block, because its bounds cannot depend on local variables.
3699 -- Otherwise there is no way to declare the result outside of the
3700 -- block. Needless to say, in general the bounds will depend on the
3701 -- actuals in the call.
3704 Targ1
:= Defining_Identifier
(First
(Declarations
(Blk
)));
3707 -- If this is a derived function, establish the proper return type
3709 if Present
(Orig_Subp
)
3710 and then Orig_Subp
/= Subp
3712 Ret_Type
:= Etype
(Orig_Subp
);
3714 Ret_Type
:= Etype
(Subp
);
3717 -- Create temporaries for the actuals that are expressions, or that
3718 -- are scalars and require copying to preserve semantics.
3720 F
:= First_Formal
(Subp
);
3721 A
:= First_Actual
(N
);
3722 while Present
(F
) loop
3723 if Present
(Renamed_Object
(F
)) then
3724 Error_Msg_N
("cannot inline call to recursive subprogram", N
);
3728 -- If the argument may be a controlling argument in a call within
3729 -- the inlined body, we must preserve its classwide nature to insure
3730 -- that dynamic dispatching take place subsequently. If the formal
3731 -- has a constraint it must be preserved to retain the semantics of
3734 if Is_Class_Wide_Type
(Etype
(F
))
3735 or else (Is_Access_Type
(Etype
(F
))
3737 Is_Class_Wide_Type
(Designated_Type
(Etype
(F
))))
3739 Temp_Typ
:= Etype
(F
);
3741 elsif Base_Type
(Etype
(F
)) = Base_Type
(Etype
(A
))
3742 and then Etype
(F
) /= Base_Type
(Etype
(F
))
3744 Temp_Typ
:= Etype
(F
);
3747 Temp_Typ
:= Etype
(A
);
3750 -- If the actual is a simple name or a literal, no need to
3751 -- create a temporary, object can be used directly.
3753 -- If the actual is a literal and the formal has its address taken,
3754 -- we cannot pass the literal itself as an argument, so its value
3755 -- must be captured in a temporary.
3757 if (Is_Entity_Name
(A
)
3759 (not Is_Scalar_Type
(Etype
(A
))
3760 or else Ekind
(Entity
(A
)) = E_Enumeration_Literal
))
3762 -- When the actual is an identifier and the corresponding formal
3763 -- is used only once in the original body, the formal can be
3764 -- substituted directly with the actual parameter.
3766 or else (Nkind
(A
) = N_Identifier
3767 and then Formal_Is_Used_Once
(F
))
3770 (Nkind_In
(A
, N_Real_Literal
,
3772 N_Character_Literal
)
3773 and then not Address_Taken
(F
))
3775 if Etype
(F
) /= Etype
(A
) then
3777 (F
, Unchecked_Convert_To
(Etype
(F
), Relocate_Node
(A
)));
3779 Set_Renamed_Object
(F
, A
);
3784 Make_Defining_Identifier
(Loc
,
3785 Chars
=> New_Internal_Name
('C'));
3787 -- If the actual for an in/in-out parameter is a view conversion,
3788 -- make it into an unchecked conversion, given that an untagged
3789 -- type conversion is not a proper object for a renaming.
3791 -- In-out conversions that involve real conversions have already
3792 -- been transformed in Expand_Actuals.
3794 if Nkind
(A
) = N_Type_Conversion
3795 and then Ekind
(F
) /= E_In_Parameter
3798 Make_Unchecked_Type_Conversion
(Loc
,
3799 Subtype_Mark
=> New_Occurrence_Of
(Etype
(F
), Loc
),
3800 Expression
=> Relocate_Node
(Expression
(A
)));
3802 elsif Etype
(F
) /= Etype
(A
) then
3803 New_A
:= Unchecked_Convert_To
(Etype
(F
), Relocate_Node
(A
));
3804 Temp_Typ
:= Etype
(F
);
3807 New_A
:= Relocate_Node
(A
);
3810 Set_Sloc
(New_A
, Sloc
(N
));
3812 -- If the actual has a by-reference type, it cannot be copied, so
3813 -- its value is captured in a renaming declaration. Otherwise
3814 -- declare a local constant initialized with the actual.
3816 -- We also use a renaming declaration for expressions of an array
3817 -- type that is not bit-packed, both for efficiency reasons and to
3818 -- respect the semantics of the call: in most cases the original
3819 -- call will pass the parameter by reference, and thus the inlined
3820 -- code will have the same semantics.
3822 if Ekind
(F
) = E_In_Parameter
3823 and then not Is_Limited_Type
(Etype
(A
))
3824 and then not Is_Tagged_Type
(Etype
(A
))
3826 (not Is_Array_Type
(Etype
(A
))
3827 or else not Is_Object_Reference
(A
)
3828 or else Is_Bit_Packed_Array
(Etype
(A
)))
3831 Make_Object_Declaration
(Loc
,
3832 Defining_Identifier
=> Temp
,
3833 Constant_Present
=> True,
3834 Object_Definition
=> New_Occurrence_Of
(Temp_Typ
, Loc
),
3835 Expression
=> New_A
);
3838 Make_Object_Renaming_Declaration
(Loc
,
3839 Defining_Identifier
=> Temp
,
3840 Subtype_Mark
=> New_Occurrence_Of
(Temp_Typ
, Loc
),
3844 Append
(Decl
, Decls
);
3845 Set_Renamed_Object
(F
, Temp
);
3852 -- Establish target of function call. If context is not assignment or
3853 -- declaration, create a temporary as a target. The declaration for
3854 -- the temporary may be subsequently optimized away if the body is a
3855 -- single expression, or if the left-hand side of the assignment is
3856 -- simple enough, i.e. an entity or an explicit dereference of one.
3858 if Ekind
(Subp
) = E_Function
then
3859 if Nkind
(Parent
(N
)) = N_Assignment_Statement
3860 and then Is_Entity_Name
(Name
(Parent
(N
)))
3862 Targ
:= Name
(Parent
(N
));
3864 elsif Nkind
(Parent
(N
)) = N_Assignment_Statement
3865 and then Nkind
(Name
(Parent
(N
))) = N_Explicit_Dereference
3866 and then Is_Entity_Name
(Prefix
(Name
(Parent
(N
))))
3868 Targ
:= Name
(Parent
(N
));
3871 -- Replace call with temporary and create its declaration
3874 Make_Defining_Identifier
(Loc
, New_Internal_Name
('C'));
3875 Set_Is_Internal
(Temp
);
3877 -- For the unconstrained case, the generated temporary has the
3878 -- same constrained declaration as the result variable. It may
3879 -- eventually be possible to remove that temporary and use the
3880 -- result variable directly.
3884 Make_Object_Declaration
(Loc
,
3885 Defining_Identifier
=> Temp
,
3886 Object_Definition
=>
3887 New_Copy_Tree
(Object_Definition
(Parent
(Targ1
))));
3889 Replace_Formals
(Decl
);
3893 Make_Object_Declaration
(Loc
,
3894 Defining_Identifier
=> Temp
,
3895 Object_Definition
=>
3896 New_Occurrence_Of
(Ret_Type
, Loc
));
3898 Set_Etype
(Temp
, Ret_Type
);
3901 Set_No_Initialization
(Decl
);
3902 Append
(Decl
, Decls
);
3903 Rewrite
(N
, New_Occurrence_Of
(Temp
, Loc
));
3908 Insert_Actions
(N
, Decls
);
3910 -- Traverse the tree and replace formals with actuals or their thunks.
3911 -- Attach block to tree before analysis and rewriting.
3913 Replace_Formals
(Blk
);
3914 Set_Parent
(Blk
, N
);
3916 if not Comes_From_Source
(Subp
)
3922 if Present
(Exit_Lab
) then
3924 -- If the body was a single expression, the single return statement
3925 -- and the corresponding label are useless.
3929 Nkind
(Last
(Statements
(Handled_Statement_Sequence
(Blk
)))) =
3932 Remove
(Last
(Statements
(Handled_Statement_Sequence
(Blk
))));
3934 Append
(Lab_Decl
, (Declarations
(Blk
)));
3935 Append
(Exit_Lab
, Statements
(Handled_Statement_Sequence
(Blk
)));
3939 -- Analyze Blk with In_Inlined_Body set, to avoid spurious errors on
3940 -- conflicting private views that Gigi would ignore. If this is a
3941 -- predefined unit, analyze with checks off, as is done in the non-
3942 -- inlined run-time units.
3945 I_Flag
: constant Boolean := In_Inlined_Body
;
3948 In_Inlined_Body
:= True;
3952 Style
: constant Boolean := Style_Check
;
3954 Style_Check
:= False;
3955 Analyze
(Blk
, Suppress
=> All_Checks
);
3956 Style_Check
:= Style
;
3963 In_Inlined_Body
:= I_Flag
;
3966 if Ekind
(Subp
) = E_Procedure
then
3967 Rewrite_Procedure_Call
(N
, Blk
);
3969 Rewrite_Function_Call
(N
, Blk
);
3971 -- For the unconstrained case, the replacement of the call has been
3972 -- made prior to the complete analysis of the generated declarations.
3973 -- Propagate the proper type now.
3976 if Nkind
(N
) = N_Identifier
then
3977 Set_Etype
(N
, Etype
(Entity
(N
)));
3979 Set_Etype
(N
, Etype
(Targ1
));
3986 -- Cleanup mapping between formals and actuals for other expansions
3988 F
:= First_Formal
(Subp
);
3989 while Present
(F
) loop
3990 Set_Renamed_Object
(F
, Empty
);
3993 end Expand_Inlined_Call
;
3995 ----------------------------
3996 -- Expand_N_Function_Call --
3997 ----------------------------
3999 procedure Expand_N_Function_Call
(N
: Node_Id
) is
4003 -- If the return value of a foreign compiled function is VAX Float, then
4004 -- expand the return (adjusts the location of the return value on
4005 -- Alpha/VMS, no-op everywhere else).
4006 -- Comes_From_Source intercepts recursive expansion.
4008 if Vax_Float
(Etype
(N
))
4009 and then Nkind
(N
) = N_Function_Call
4010 and then Present
(Name
(N
))
4011 and then Present
(Entity
(Name
(N
)))
4012 and then Has_Foreign_Convention
(Entity
(Name
(N
)))
4013 and then Comes_From_Source
(Parent
(N
))
4015 Expand_Vax_Foreign_Return
(N
);
4017 end Expand_N_Function_Call
;
4019 ---------------------------------------
4020 -- Expand_N_Procedure_Call_Statement --
4021 ---------------------------------------
4023 procedure Expand_N_Procedure_Call_Statement
(N
: Node_Id
) is
4026 end Expand_N_Procedure_Call_Statement
;
4028 ------------------------------
4029 -- Expand_N_Subprogram_Body --
4030 ------------------------------
4032 -- Add poll call if ATC polling is enabled, unless the body will be inlined
4035 -- Add dummy push/pop label nodes at start and end to clear any local
4036 -- exception indications if local-exception-to-goto optimization is active.
4038 -- Add return statement if last statement in body is not a return statement
4039 -- (this makes things easier on Gigi which does not want to have to handle
4040 -- a missing return).
4042 -- Add call to Activate_Tasks if body is a task activator
4044 -- Deal with possible detection of infinite recursion
4046 -- Eliminate body completely if convention stubbed
4048 -- Encode entity names within body, since we will not need to reference
4049 -- these entities any longer in the front end.
4051 -- Initialize scalar out parameters if Initialize/Normalize_Scalars
4053 -- Reset Pure indication if any parameter has root type System.Address
4057 procedure Expand_N_Subprogram_Body
(N
: Node_Id
) is
4058 Loc
: constant Source_Ptr
:= Sloc
(N
);
4059 H
: constant Node_Id
:= Handled_Statement_Sequence
(N
);
4060 Body_Id
: Entity_Id
;
4063 Spec_Id
: Entity_Id
;
4065 procedure Add_Return
(S
: List_Id
);
4066 -- Append a return statement to the statement sequence S if the last
4067 -- statement is not already a return or a goto statement. Note that
4068 -- the latter test is not critical, it does not matter if we add a few
4069 -- extra returns, since they get eliminated anyway later on.
4075 procedure Add_Return
(S
: List_Id
) is
4080 -- Get last statement, ignoring any Pop_xxx_Label nodes, which are
4081 -- not relevant in this context since they are not executable.
4083 Last_Stm
:= Last
(S
);
4084 while Nkind
(Last_Stm
) in N_Pop_xxx_Label
loop
4088 -- Now insert return unless last statement is a transfer
4090 if not Is_Transfer
(Last_Stm
) then
4092 -- The source location for the return is the end label of the
4093 -- procedure if present. Otherwise use the sloc of the last
4094 -- statement in the list. If the list comes from a generated
4095 -- exception handler and we are not debugging generated code,
4096 -- all the statements within the handler are made invisible
4099 if Nkind
(Parent
(S
)) = N_Exception_Handler
4100 and then not Comes_From_Source
(Parent
(S
))
4102 Loc
:= Sloc
(Last_Stm
);
4104 elsif Present
(End_Label
(H
)) then
4105 Loc
:= Sloc
(End_Label
(H
));
4108 Loc
:= Sloc
(Last_Stm
);
4112 Rtn
: constant Node_Id
:= Make_Simple_Return_Statement
(Loc
);
4115 -- Append return statement, and set analyzed manually. We can't
4116 -- call Analyze on this return since the scope is wrong.
4118 -- Note: it almost works to push the scope and then do the
4119 -- Analyze call, but something goes wrong in some weird cases
4120 -- and it is not worth worrying about ???
4125 -- Call _Postconditions procedure if appropriate. We need to
4126 -- do this explicitly because we did not analyze the generated
4127 -- return statement above, so the call did not get inserted.
4129 if Ekind
(Spec_Id
) = E_Procedure
4130 and then Has_Postconditions
(Spec_Id
)
4132 pragma Assert
(Present
(Postcondition_Proc
(Spec_Id
)));
4134 Make_Procedure_Call_Statement
(Loc
,
4136 New_Reference_To
(Postcondition_Proc
(Spec_Id
), Loc
)));
4142 -- Start of processing for Expand_N_Subprogram_Body
4145 -- Set L to either the list of declarations if present, or to the list
4146 -- of statements if no declarations are present. This is used to insert
4147 -- new stuff at the start.
4149 if Is_Non_Empty_List
(Declarations
(N
)) then
4150 L
:= Declarations
(N
);
4152 L
:= Statements
(H
);
4155 -- If local-exception-to-goto optimization active, insert dummy push
4156 -- statements at start, and dummy pop statements at end.
4158 if (Debug_Flag_Dot_G
4159 or else Restriction_Active
(No_Exception_Propagation
))
4160 and then Is_Non_Empty_List
(L
)
4163 FS
: constant Node_Id
:= First
(L
);
4164 FL
: constant Source_Ptr
:= Sloc
(FS
);
4169 -- LS points to either last statement, if statements are present
4170 -- or to the last declaration if there are no statements present.
4171 -- It is the node after which the pop's are generated.
4173 if Is_Non_Empty_List
(Statements
(H
)) then
4174 LS
:= Last
(Statements
(H
));
4181 Insert_List_Before_And_Analyze
(FS
, New_List
(
4182 Make_Push_Constraint_Error_Label
(FL
),
4183 Make_Push_Program_Error_Label
(FL
),
4184 Make_Push_Storage_Error_Label
(FL
)));
4186 Insert_List_After_And_Analyze
(LS
, New_List
(
4187 Make_Pop_Constraint_Error_Label
(LL
),
4188 Make_Pop_Program_Error_Label
(LL
),
4189 Make_Pop_Storage_Error_Label
(LL
)));
4193 -- Find entity for subprogram
4195 Body_Id
:= Defining_Entity
(N
);
4197 if Present
(Corresponding_Spec
(N
)) then
4198 Spec_Id
:= Corresponding_Spec
(N
);
4203 -- Need poll on entry to subprogram if polling enabled. We only do this
4204 -- for non-empty subprograms, since it does not seem necessary to poll
4205 -- for a dummy null subprogram.
4207 if Is_Non_Empty_List
(L
) then
4209 -- Do not add a polling call if the subprogram is to be inlined by
4210 -- the back-end, to avoid repeated calls with multiple inlinings.
4212 if Is_Inlined
(Spec_Id
)
4213 and then Front_End_Inlining
4214 and then Optimization_Level
> 1
4218 Generate_Poll_Call
(First
(L
));
4222 -- If this is a Pure function which has any parameters whose root type
4223 -- is System.Address, reset the Pure indication, since it will likely
4224 -- cause incorrect code to be generated as the parameter is probably
4225 -- a pointer, and the fact that the same pointer is passed does not mean
4226 -- that the same value is being referenced.
4228 -- Note that if the programmer gave an explicit Pure_Function pragma,
4229 -- then we believe the programmer, and leave the subprogram Pure.
4231 -- This code should probably be at the freeze point, so that it happens
4232 -- even on a -gnatc (or more importantly -gnatt) compile, so that the
4233 -- semantic tree has Is_Pure set properly ???
4235 if Is_Pure
(Spec_Id
)
4236 and then Is_Subprogram
(Spec_Id
)
4237 and then not Has_Pragma_Pure_Function
(Spec_Id
)
4243 F
:= First_Formal
(Spec_Id
);
4244 while Present
(F
) loop
4245 if Is_Descendent_Of_Address
(Etype
(F
)) then
4246 Set_Is_Pure
(Spec_Id
, False);
4248 if Spec_Id
/= Body_Id
then
4249 Set_Is_Pure
(Body_Id
, False);
4260 -- Initialize any scalar OUT args if Initialize/Normalize_Scalars
4262 if Init_Or_Norm_Scalars
and then Is_Subprogram
(Spec_Id
) then
4267 -- Loop through formals
4269 F
:= First_Formal
(Spec_Id
);
4270 while Present
(F
) loop
4271 if Is_Scalar_Type
(Etype
(F
))
4272 and then Ekind
(F
) = E_Out_Parameter
4274 Check_Restriction
(No_Default_Initialization
, F
);
4276 -- Insert the initialization. We turn off validity checks
4277 -- for this assignment, since we do not want any check on
4278 -- the initial value itself (which may well be invalid).
4280 Insert_Before_And_Analyze
(First
(L
),
4281 Make_Assignment_Statement
(Loc
,
4282 Name
=> New_Occurrence_Of
(F
, Loc
),
4283 Expression
=> Get_Simple_Init_Val
(Etype
(F
), N
)),
4284 Suppress
=> Validity_Check
);
4292 -- Clear out statement list for stubbed procedure
4294 if Present
(Corresponding_Spec
(N
)) then
4295 Set_Elaboration_Flag
(N
, Spec_Id
);
4297 if Convention
(Spec_Id
) = Convention_Stubbed
4298 or else Is_Eliminated
(Spec_Id
)
4300 Set_Declarations
(N
, Empty_List
);
4301 Set_Handled_Statement_Sequence
(N
,
4302 Make_Handled_Sequence_Of_Statements
(Loc
,
4303 Statements
=> New_List
(
4304 Make_Null_Statement
(Loc
))));
4309 -- Create a set of discriminals for the next protected subprogram body
4311 if Is_List_Member
(N
)
4312 and then Present
(Parent
(List_Containing
(N
)))
4313 and then Nkind
(Parent
(List_Containing
(N
))) = N_Protected_Body
4314 and then Present
(Next_Protected_Operation
(N
))
4316 Set_Discriminals
(Parent
(Base_Type
(Scope
(Spec_Id
))));
4319 -- Returns_By_Ref flag is normally set when the subprogram is frozen but
4320 -- subprograms with no specs are not frozen.
4323 Typ
: constant Entity_Id
:= Etype
(Spec_Id
);
4324 Utyp
: constant Entity_Id
:= Underlying_Type
(Typ
);
4327 if not Acts_As_Spec
(N
)
4328 and then Nkind
(Parent
(Parent
(Spec_Id
))) /=
4329 N_Subprogram_Body_Stub
4333 elsif Is_Inherently_Limited_Type
(Typ
) then
4334 Set_Returns_By_Ref
(Spec_Id
);
4336 elsif Present
(Utyp
) and then CW_Or_Has_Controlled_Part
(Utyp
) then
4337 Set_Returns_By_Ref
(Spec_Id
);
4341 -- For a procedure, we add a return for all possible syntactic ends of
4344 if Ekind
(Spec_Id
) = E_Procedure
4345 or else Ekind
(Spec_Id
) = E_Generic_Procedure
4347 Add_Return
(Statements
(H
));
4349 if Present
(Exception_Handlers
(H
)) then
4350 Except_H
:= First_Non_Pragma
(Exception_Handlers
(H
));
4351 while Present
(Except_H
) loop
4352 Add_Return
(Statements
(Except_H
));
4353 Next_Non_Pragma
(Except_H
);
4357 -- For a function, we must deal with the case where there is at least
4358 -- one missing return. What we do is to wrap the entire body of the
4359 -- function in a block:
4372 -- raise Program_Error;
4375 -- This approach is necessary because the raise must be signalled to the
4376 -- caller, not handled by any local handler (RM 6.4(11)).
4378 -- Note: we do not need to analyze the constructed sequence here, since
4379 -- it has no handler, and an attempt to analyze the handled statement
4380 -- sequence twice is risky in various ways (e.g. the issue of expanding
4381 -- cleanup actions twice).
4383 elsif Has_Missing_Return
(Spec_Id
) then
4385 Hloc
: constant Source_Ptr
:= Sloc
(H
);
4386 Blok
: constant Node_Id
:=
4387 Make_Block_Statement
(Hloc
,
4388 Handled_Statement_Sequence
=> H
);
4389 Rais
: constant Node_Id
:=
4390 Make_Raise_Program_Error
(Hloc
,
4391 Reason
=> PE_Missing_Return
);
4394 Set_Handled_Statement_Sequence
(N
,
4395 Make_Handled_Sequence_Of_Statements
(Hloc
,
4396 Statements
=> New_List
(Blok
, Rais
)));
4398 Push_Scope
(Spec_Id
);
4405 -- If subprogram contains a parameterless recursive call, then we may
4406 -- have an infinite recursion, so see if we can generate code to check
4407 -- for this possibility if storage checks are not suppressed.
4409 if Ekind
(Spec_Id
) = E_Procedure
4410 and then Has_Recursive_Call
(Spec_Id
)
4411 and then not Storage_Checks_Suppressed
(Spec_Id
)
4413 Detect_Infinite_Recursion
(N
, Spec_Id
);
4416 -- Set to encode entity names in package body before gigi is called
4418 Qualify_Entity_Names
(N
);
4419 end Expand_N_Subprogram_Body
;
4421 -----------------------------------
4422 -- Expand_N_Subprogram_Body_Stub --
4423 -----------------------------------
4425 procedure Expand_N_Subprogram_Body_Stub
(N
: Node_Id
) is
4427 if Present
(Corresponding_Body
(N
)) then
4428 Expand_N_Subprogram_Body
(
4429 Unit_Declaration_Node
(Corresponding_Body
(N
)));
4431 end Expand_N_Subprogram_Body_Stub
;
4433 -------------------------------------
4434 -- Expand_N_Subprogram_Declaration --
4435 -------------------------------------
4437 -- If the declaration appears within a protected body, it is a private
4438 -- operation of the protected type. We must create the corresponding
4439 -- protected subprogram an associated formals. For a normal protected
4440 -- operation, this is done when expanding the protected type declaration.
4442 -- If the declaration is for a null procedure, emit null body
4444 procedure Expand_N_Subprogram_Declaration
(N
: Node_Id
) is
4445 Loc
: constant Source_Ptr
:= Sloc
(N
);
4446 Subp
: constant Entity_Id
:= Defining_Entity
(N
);
4447 Scop
: constant Entity_Id
:= Scope
(Subp
);
4448 Prot_Decl
: Node_Id
;
4450 Prot_Id
: Entity_Id
;
4453 -- Deal with case of protected subprogram. Do not generate protected
4454 -- operation if operation is flagged as eliminated.
4456 if Is_List_Member
(N
)
4457 and then Present
(Parent
(List_Containing
(N
)))
4458 and then Nkind
(Parent
(List_Containing
(N
))) = N_Protected_Body
4459 and then Is_Protected_Type
(Scop
)
4461 if No
(Protected_Body_Subprogram
(Subp
))
4462 and then not Is_Eliminated
(Subp
)
4465 Make_Subprogram_Declaration
(Loc
,
4467 Build_Protected_Sub_Specification
4468 (N
, Scop
, Unprotected_Mode
));
4470 -- The protected subprogram is declared outside of the protected
4471 -- body. Given that the body has frozen all entities so far, we
4472 -- analyze the subprogram and perform freezing actions explicitly.
4473 -- including the generation of an explicit freeze node, to ensure
4474 -- that gigi has the proper order of elaboration.
4475 -- If the body is a subunit, the insertion point is before the
4476 -- stub in the parent.
4478 Prot_Bod
:= Parent
(List_Containing
(N
));
4480 if Nkind
(Parent
(Prot_Bod
)) = N_Subunit
then
4481 Prot_Bod
:= Corresponding_Stub
(Parent
(Prot_Bod
));
4484 Insert_Before
(Prot_Bod
, Prot_Decl
);
4485 Prot_Id
:= Defining_Unit_Name
(Specification
(Prot_Decl
));
4486 Set_Has_Delayed_Freeze
(Prot_Id
);
4488 Push_Scope
(Scope
(Scop
));
4489 Analyze
(Prot_Decl
);
4490 Insert_Actions
(N
, Freeze_Entity
(Prot_Id
, Loc
));
4491 Set_Protected_Body_Subprogram
(Subp
, Prot_Id
);
4495 -- Ada 2005 (AI-348): Generate body for a null procedure.
4496 -- In most cases this is superfluous because calls to it
4497 -- will be automatically inlined, but we definitely need
4498 -- the body if preconditions for the procedure are present.
4500 elsif Nkind
(Specification
(N
)) = N_Procedure_Specification
4501 and then Null_Present
(Specification
(N
))
4504 Bod
: constant Node_Id
:= Body_To_Inline
(N
);
4507 Set_Has_Completion
(Subp
, False);
4508 Append_Freeze_Action
(Subp
, Bod
);
4510 -- The body now contains raise statements, so calls to it will
4513 Set_Is_Inlined
(Subp
, False);
4516 end Expand_N_Subprogram_Declaration
;
4518 ---------------------------------------
4519 -- Expand_Protected_Object_Reference --
4520 ---------------------------------------
4522 function Expand_Protected_Object_Reference
4524 Scop
: Entity_Id
) return Node_Id
4526 Loc
: constant Source_Ptr
:= Sloc
(N
);
4534 Make_Identifier
(Loc
,
4535 Chars
=> Name_uObject
);
4536 Set_Etype
(Rec
, Corresponding_Record_Type
(Scop
));
4538 -- Find enclosing protected operation, and retrieve its first parameter,
4539 -- which denotes the enclosing protected object. If the enclosing
4540 -- operation is an entry, we are immediately within the protected body,
4541 -- and we can retrieve the object from the service entries procedure. A
4542 -- barrier function has the same signature as an entry. A barrier
4543 -- function is compiled within the protected object, but unlike
4544 -- protected operations its never needs locks, so that its protected
4545 -- body subprogram points to itself.
4547 Proc
:= Current_Scope
;
4548 while Present
(Proc
)
4549 and then Scope
(Proc
) /= Scop
4551 Proc
:= Scope
(Proc
);
4554 Corr
:= Protected_Body_Subprogram
(Proc
);
4558 -- Previous error left expansion incomplete.
4559 -- Nothing to do on this call.
4566 (First
(Parameter_Specifications
(Parent
(Corr
))));
4568 if Is_Subprogram
(Proc
)
4569 and then Proc
/= Corr
4571 -- Protected function or procedure
4573 Set_Entity
(Rec
, Param
);
4575 -- Rec is a reference to an entity which will not be in scope when
4576 -- the call is reanalyzed, and needs no further analysis.
4581 -- Entry or barrier function for entry body. The first parameter of
4582 -- the entry body procedure is pointer to the object. We create a
4583 -- local variable of the proper type, duplicating what is done to
4584 -- define _object later on.
4588 Obj_Ptr
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
,
4590 New_Internal_Name
('T'));
4594 Make_Full_Type_Declaration
(Loc
,
4595 Defining_Identifier
=> Obj_Ptr
,
4597 Make_Access_To_Object_Definition
(Loc
,
4598 Subtype_Indication
=>
4600 (Corresponding_Record_Type
(Scop
), Loc
))));
4602 Insert_Actions
(N
, Decls
);
4603 Insert_Actions
(N
, Freeze_Entity
(Obj_Ptr
, Sloc
(N
)));
4606 Make_Explicit_Dereference
(Loc
,
4607 Unchecked_Convert_To
(Obj_Ptr
,
4608 New_Occurrence_Of
(Param
, Loc
)));
4610 -- Analyze new actual. Other actuals in calls are already analyzed
4611 -- and the list of actuals is not reanalyzed after rewriting.
4613 Set_Parent
(Rec
, N
);
4619 end Expand_Protected_Object_Reference
;
4621 --------------------------------------
4622 -- Expand_Protected_Subprogram_Call --
4623 --------------------------------------
4625 procedure Expand_Protected_Subprogram_Call
4633 -- If the protected object is not an enclosing scope, this is
4634 -- an inter-object function call. Inter-object procedure
4635 -- calls are expanded by Exp_Ch9.Build_Simple_Entry_Call.
4636 -- The call is intra-object only if the subprogram being
4637 -- called is in the protected body being compiled, and if the
4638 -- protected object in the call is statically the enclosing type.
4639 -- The object may be an component of some other data structure,
4640 -- in which case this must be handled as an inter-object call.
4642 if not In_Open_Scopes
(Scop
)
4643 or else not Is_Entity_Name
(Name
(N
))
4645 if Nkind
(Name
(N
)) = N_Selected_Component
then
4646 Rec
:= Prefix
(Name
(N
));
4649 pragma Assert
(Nkind
(Name
(N
)) = N_Indexed_Component
);
4650 Rec
:= Prefix
(Prefix
(Name
(N
)));
4653 Build_Protected_Subprogram_Call
(N
,
4654 Name
=> New_Occurrence_Of
(Subp
, Sloc
(N
)),
4655 Rec
=> Convert_Concurrent
(Rec
, Etype
(Rec
)),
4659 Rec
:= Expand_Protected_Object_Reference
(N
, Scop
);
4665 Build_Protected_Subprogram_Call
(N
,
4672 -- If it is a function call it can appear in elaboration code and
4673 -- the called entity must be frozen here.
4675 if Ekind
(Subp
) = E_Function
then
4676 Freeze_Expression
(Name
(N
));
4679 -- Analyze and resolve the new call. The actuals have already been
4680 -- resolved, but expansion of a function call will add extra actuals
4681 -- if needed. Analysis of a procedure call already includes resolution.
4685 if Ekind
(Subp
) = E_Function
then
4686 Resolve
(N
, Etype
(Subp
));
4688 end Expand_Protected_Subprogram_Call
;
4690 --------------------------------
4691 -- Is_Build_In_Place_Function --
4692 --------------------------------
4694 function Is_Build_In_Place_Function
(E
: Entity_Id
) return Boolean is
4696 -- For now we test whether E denotes a function or access-to-function
4697 -- type whose result subtype is inherently limited. Later this test may
4698 -- be revised to allow composite nonlimited types. Functions with a
4699 -- foreign convention or whose result type has a foreign convention
4702 if Ekind
(E
) = E_Function
4703 or else Ekind
(E
) = E_Generic_Function
4704 or else (Ekind
(E
) = E_Subprogram_Type
4705 and then Etype
(E
) /= Standard_Void_Type
)
4707 -- Note: If you have Convention (C) on an inherently limited type,
4708 -- you're on your own. That is, the C code will have to be carefully
4709 -- written to know about the Ada conventions.
4711 if Has_Foreign_Convention
(E
)
4712 or else Has_Foreign_Convention
(Etype
(E
))
4716 -- In Ada 2005 all functions with an inherently limited return type
4717 -- must be handled using a build-in-place profile, including the case
4718 -- of a function with a limited interface result, where the function
4719 -- may return objects of nonlimited descendants.
4722 return Is_Inherently_Limited_Type
(Etype
(E
))
4723 and then Ada_Version
>= Ada_05
4724 and then not Debug_Flag_Dot_L
;
4730 end Is_Build_In_Place_Function
;
4732 -------------------------------------
4733 -- Is_Build_In_Place_Function_Call --
4734 -------------------------------------
4736 function Is_Build_In_Place_Function_Call
(N
: Node_Id
) return Boolean is
4737 Exp_Node
: Node_Id
:= N
;
4738 Function_Id
: Entity_Id
;
4741 -- Step past qualification or unchecked conversion (the latter can occur
4742 -- in cases of calls to 'Input).
4745 (Exp_Node
, N_Qualified_Expression
, N_Unchecked_Type_Conversion
)
4747 Exp_Node
:= Expression
(N
);
4750 if Nkind
(Exp_Node
) /= N_Function_Call
then
4754 if Is_Entity_Name
(Name
(Exp_Node
)) then
4755 Function_Id
:= Entity
(Name
(Exp_Node
));
4757 elsif Nkind
(Name
(Exp_Node
)) = N_Explicit_Dereference
then
4758 Function_Id
:= Etype
(Name
(Exp_Node
));
4761 return Is_Build_In_Place_Function
(Function_Id
);
4763 end Is_Build_In_Place_Function_Call
;
4765 -----------------------
4766 -- Freeze_Subprogram --
4767 -----------------------
4769 procedure Freeze_Subprogram
(N
: Node_Id
) is
4770 Loc
: constant Source_Ptr
:= Sloc
(N
);
4772 procedure Register_Predefined_DT_Entry
(Prim
: Entity_Id
);
4773 -- (Ada 2005): Register a predefined primitive in all the secondary
4774 -- dispatch tables of its primitive type.
4776 ----------------------------------
4777 -- Register_Predefined_DT_Entry --
4778 ----------------------------------
4780 procedure Register_Predefined_DT_Entry
(Prim
: Entity_Id
) is
4781 Iface_DT_Ptr
: Elmt_Id
;
4782 Tagged_Typ
: Entity_Id
;
4783 Thunk_Id
: Entity_Id
;
4784 Thunk_Code
: Node_Id
;
4787 Tagged_Typ
:= Find_Dispatching_Type
(Prim
);
4789 if No
(Access_Disp_Table
(Tagged_Typ
))
4790 or else not Has_Interfaces
(Tagged_Typ
)
4791 or else not RTE_Available
(RE_Interface_Tag
)
4792 or else Restriction_Active
(No_Dispatching_Calls
)
4797 -- Skip the first two access-to-dispatch-table pointers since they
4798 -- leads to the primary dispatch table (predefined DT and user
4799 -- defined DT). We are only concerned with the secondary dispatch
4800 -- table pointers. Note that the access-to- dispatch-table pointer
4801 -- corresponds to the first implemented interface retrieved below.
4804 Next_Elmt
(Next_Elmt
(First_Elmt
(Access_Disp_Table
(Tagged_Typ
))));
4806 while Present
(Iface_DT_Ptr
)
4807 and then Ekind
(Node
(Iface_DT_Ptr
)) = E_Constant
4809 pragma Assert
(Has_Thunks
(Node
(Iface_DT_Ptr
)));
4810 Expand_Interface_Thunk
(Prim
, Thunk_Id
, Thunk_Code
);
4812 if Present
(Thunk_Code
) then
4813 Insert_Actions_After
(N
, New_List
(
4816 Build_Set_Predefined_Prim_Op_Address
(Loc
,
4818 New_Reference_To
(Node
(Next_Elmt
(Iface_DT_Ptr
)), Loc
),
4819 Position
=> DT_Position
(Prim
),
4821 Unchecked_Convert_To
(RTE
(RE_Prim_Ptr
),
4822 Make_Attribute_Reference
(Loc
,
4823 Prefix
=> New_Reference_To
(Thunk_Id
, Loc
),
4824 Attribute_Name
=> Name_Unrestricted_Access
))),
4826 Build_Set_Predefined_Prim_Op_Address
(Loc
,
4829 (Node
(Next_Elmt
(Next_Elmt
(Next_Elmt
(Iface_DT_Ptr
)))),
4831 Position
=> DT_Position
(Prim
),
4833 Unchecked_Convert_To
(RTE
(RE_Prim_Ptr
),
4834 Make_Attribute_Reference
(Loc
,
4835 Prefix
=> New_Reference_To
(Prim
, Loc
),
4836 Attribute_Name
=> Name_Unrestricted_Access
)))));
4839 -- Skip the tag of the predefined primitives dispatch table
4841 Next_Elmt
(Iface_DT_Ptr
);
4842 pragma Assert
(Has_Thunks
(Node
(Iface_DT_Ptr
)));
4844 -- Skip the tag of the no-thunks dispatch table
4846 Next_Elmt
(Iface_DT_Ptr
);
4847 pragma Assert
(not Has_Thunks
(Node
(Iface_DT_Ptr
)));
4849 -- Skip the tag of the predefined primitives no-thunks dispatch
4852 Next_Elmt
(Iface_DT_Ptr
);
4853 pragma Assert
(not Has_Thunks
(Node
(Iface_DT_Ptr
)));
4855 Next_Elmt
(Iface_DT_Ptr
);
4857 end Register_Predefined_DT_Entry
;
4861 Subp
: constant Entity_Id
:= Entity
(N
);
4863 -- Start of processing for Freeze_Subprogram
4866 -- We suppress the initialization of the dispatch table entry when
4867 -- VM_Target because the dispatching mechanism is handled internally
4870 if Is_Dispatching_Operation
(Subp
)
4871 and then not Is_Abstract_Subprogram
(Subp
)
4872 and then Present
(DTC_Entity
(Subp
))
4873 and then Present
(Scope
(DTC_Entity
(Subp
)))
4874 and then Tagged_Type_Expansion
4875 and then not Restriction_Active
(No_Dispatching_Calls
)
4876 and then RTE_Available
(RE_Tag
)
4879 Typ
: constant Entity_Id
:= Scope
(DTC_Entity
(Subp
));
4882 -- Handle private overridden primitives
4884 if not Is_CPP_Class
(Typ
) then
4885 Check_Overriding_Operation
(Subp
);
4888 -- We assume that imported CPP primitives correspond with objects
4889 -- whose constructor is in the CPP side; therefore we don't need
4890 -- to generate code to register them in the dispatch table.
4892 if Is_CPP_Class
(Typ
) then
4895 -- Handle CPP primitives found in derivations of CPP_Class types.
4896 -- These primitives must have been inherited from some parent, and
4897 -- there is no need to register them in the dispatch table because
4898 -- Build_Inherit_Prims takes care of the initialization of these
4901 elsif Is_Imported
(Subp
)
4902 and then (Convention
(Subp
) = Convention_CPP
4903 or else Convention
(Subp
) = Convention_C
)
4907 -- Generate code to register the primitive in non statically
4908 -- allocated dispatch tables
4910 elsif not Static_Dispatch_Tables
4912 Is_Library_Level_Tagged_Type
(Scope
(DTC_Entity
(Subp
)))
4914 -- When a primitive is frozen, enter its name in its dispatch
4917 if not Is_Interface
(Typ
)
4918 or else Present
(Interface_Alias
(Subp
))
4920 if Is_Predefined_Dispatching_Operation
(Subp
) then
4921 Register_Predefined_DT_Entry
(Subp
);
4924 Insert_Actions_After
(N
,
4925 Register_Primitive
(Loc
, Prim
=> Subp
));
4931 -- Mark functions that return by reference. Note that it cannot be part
4932 -- of the normal semantic analysis of the spec since the underlying
4933 -- returned type may not be known yet (for private types).
4936 Typ
: constant Entity_Id
:= Etype
(Subp
);
4937 Utyp
: constant Entity_Id
:= Underlying_Type
(Typ
);
4939 if Is_Inherently_Limited_Type
(Typ
) then
4940 Set_Returns_By_Ref
(Subp
);
4941 elsif Present
(Utyp
) and then CW_Or_Has_Controlled_Part
(Utyp
) then
4942 Set_Returns_By_Ref
(Subp
);
4945 end Freeze_Subprogram
;
4947 -----------------------
4948 -- Is_Null_Procedure --
4949 -----------------------
4951 function Is_Null_Procedure
(Subp
: Entity_Id
) return Boolean is
4952 Decl
: constant Node_Id
:= Unit_Declaration_Node
(Subp
);
4955 if Ekind
(Subp
) /= E_Procedure
then
4958 -- Check if this is a declared null procedure
4960 elsif Nkind
(Decl
) = N_Subprogram_Declaration
then
4961 if not Null_Present
(Specification
(Decl
)) then
4964 elsif No
(Body_To_Inline
(Decl
)) then
4967 -- Check if the body contains only a null statement, followed by
4968 -- the return statement added during expansion.
4972 Orig_Bod
: constant Node_Id
:= Body_To_Inline
(Decl
);
4978 if Nkind
(Orig_Bod
) /= N_Subprogram_Body
then
4981 -- We must skip SCIL nodes because they are currently
4982 -- implemented as special N_Null_Statement nodes.
4986 (Statements
(Handled_Statement_Sequence
(Orig_Bod
)));
4987 Stat2
:= Next_Non_SCIL_Node
(Stat
);
4990 Is_Empty_List
(Declarations
(Orig_Bod
))
4991 and then Nkind
(Stat
) = N_Null_Statement
4995 (Nkind
(Stat2
) = N_Simple_Return_Statement
4996 and then No
(Next
(Stat2
))));
5004 end Is_Null_Procedure
;
5006 -------------------------------------------
5007 -- Make_Build_In_Place_Call_In_Allocator --
5008 -------------------------------------------
5010 procedure Make_Build_In_Place_Call_In_Allocator
5011 (Allocator
: Node_Id
;
5012 Function_Call
: Node_Id
)
5015 Func_Call
: Node_Id
:= Function_Call
;
5016 Function_Id
: Entity_Id
;
5017 Result_Subt
: Entity_Id
;
5018 Acc_Type
: constant Entity_Id
:= Etype
(Allocator
);
5019 New_Allocator
: Node_Id
;
5020 Return_Obj_Access
: Entity_Id
;
5023 -- Step past qualification or unchecked conversion (the latter can occur
5024 -- in cases of calls to 'Input).
5026 if Nkind_In
(Func_Call
,
5027 N_Qualified_Expression
,
5028 N_Unchecked_Type_Conversion
)
5030 Func_Call
:= Expression
(Func_Call
);
5033 -- If the call has already been processed to add build-in-place actuals
5034 -- then return. This should not normally occur in an allocator context,
5035 -- but we add the protection as a defensive measure.
5037 if Is_Expanded_Build_In_Place_Call
(Func_Call
) then
5041 -- Mark the call as processed as a build-in-place call
5043 Set_Is_Expanded_Build_In_Place_Call
(Func_Call
);
5045 Loc
:= Sloc
(Function_Call
);
5047 if Is_Entity_Name
(Name
(Func_Call
)) then
5048 Function_Id
:= Entity
(Name
(Func_Call
));
5050 elsif Nkind
(Name
(Func_Call
)) = N_Explicit_Dereference
then
5051 Function_Id
:= Etype
(Name
(Func_Call
));
5054 raise Program_Error
;
5057 Result_Subt
:= Etype
(Function_Id
);
5059 -- When the result subtype is constrained, the return object must be
5060 -- allocated on the caller side, and access to it is passed to the
5063 -- Here and in related routines, we must examine the full view of the
5064 -- type, because the view at the point of call may differ from that
5065 -- that in the function body, and the expansion mechanism depends on
5066 -- the characteristics of the full view.
5068 if Is_Constrained
(Underlying_Type
(Result_Subt
)) then
5070 -- Replace the initialized allocator of form "new T'(Func (...))"
5071 -- with an uninitialized allocator of form "new T", where T is the
5072 -- result subtype of the called function. The call to the function
5073 -- is handled separately further below.
5076 Make_Allocator
(Loc
,
5077 Expression
=> New_Reference_To
(Result_Subt
, Loc
));
5078 Set_No_Initialization
(New_Allocator
);
5080 -- Copy attributes to new allocator. Note that the new allocator
5081 -- logically comes from source if the original one did, so copy the
5082 -- relevant flag. This ensures proper treatment of the restriction
5083 -- No_Implicit_Heap_Allocations in this case.
5085 Set_Storage_Pool
(New_Allocator
, Storage_Pool
(Allocator
));
5086 Set_Procedure_To_Call
(New_Allocator
, Procedure_To_Call
(Allocator
));
5087 Set_Comes_From_Source
(New_Allocator
, Comes_From_Source
(Allocator
));
5089 Rewrite
(Allocator
, New_Allocator
);
5091 -- Create a new access object and initialize it to the result of the
5092 -- new uninitialized allocator.
5094 Return_Obj_Access
:=
5095 Make_Defining_Identifier
(Loc
, New_Internal_Name
('R'));
5096 Set_Etype
(Return_Obj_Access
, Acc_Type
);
5098 Insert_Action
(Allocator
,
5099 Make_Object_Declaration
(Loc
,
5100 Defining_Identifier
=> Return_Obj_Access
,
5101 Object_Definition
=> New_Reference_To
(Acc_Type
, Loc
),
5102 Expression
=> Relocate_Node
(Allocator
)));
5104 -- When the function has a controlling result, an allocation-form
5105 -- parameter must be passed indicating that the caller is allocating
5106 -- the result object. This is needed because such a function can be
5107 -- called as a dispatching operation and must be treated similarly
5108 -- to functions with unconstrained result subtypes.
5110 Add_Alloc_Form_Actual_To_Build_In_Place_Call
5111 (Func_Call
, Function_Id
, Alloc_Form
=> Caller_Allocation
);
5113 Add_Final_List_Actual_To_Build_In_Place_Call
5114 (Func_Call
, Function_Id
, Acc_Type
);
5116 Add_Task_Actuals_To_Build_In_Place_Call
5117 (Func_Call
, Function_Id
, Master_Actual
=> Master_Id
(Acc_Type
));
5119 -- Add an implicit actual to the function call that provides access
5120 -- to the allocated object. An unchecked conversion to the (specific)
5121 -- result subtype of the function is inserted to handle cases where
5122 -- the access type of the allocator has a class-wide designated type.
5124 Add_Access_Actual_To_Build_In_Place_Call
5127 Make_Unchecked_Type_Conversion
(Loc
,
5128 Subtype_Mark
=> New_Reference_To
(Result_Subt
, Loc
),
5130 Make_Explicit_Dereference
(Loc
,
5131 Prefix
=> New_Reference_To
(Return_Obj_Access
, Loc
))));
5133 -- When the result subtype is unconstrained, the function itself must
5134 -- perform the allocation of the return object, so we pass parameters
5135 -- indicating that. We don't yet handle the case where the allocation
5136 -- must be done in a user-defined storage pool, which will require
5137 -- passing another actual or two to provide allocation/deallocation
5142 -- Pass an allocation parameter indicating that the function should
5143 -- allocate its result on the heap.
5145 Add_Alloc_Form_Actual_To_Build_In_Place_Call
5146 (Func_Call
, Function_Id
, Alloc_Form
=> Global_Heap
);
5148 Add_Final_List_Actual_To_Build_In_Place_Call
5149 (Func_Call
, Function_Id
, Acc_Type
);
5151 Add_Task_Actuals_To_Build_In_Place_Call
5152 (Func_Call
, Function_Id
, Master_Actual
=> Master_Id
(Acc_Type
));
5154 -- The caller does not provide the return object in this case, so we
5155 -- have to pass null for the object access actual.
5157 Add_Access_Actual_To_Build_In_Place_Call
5158 (Func_Call
, Function_Id
, Return_Object
=> Empty
);
5161 -- Finally, replace the allocator node with a reference to the result
5162 -- of the function call itself (which will effectively be an access
5163 -- to the object created by the allocator).
5165 Rewrite
(Allocator
, Make_Reference
(Loc
, Relocate_Node
(Function_Call
)));
5166 Analyze_And_Resolve
(Allocator
, Acc_Type
);
5167 end Make_Build_In_Place_Call_In_Allocator
;
5169 ---------------------------------------------------
5170 -- Make_Build_In_Place_Call_In_Anonymous_Context --
5171 ---------------------------------------------------
5173 procedure Make_Build_In_Place_Call_In_Anonymous_Context
5174 (Function_Call
: Node_Id
)
5177 Func_Call
: Node_Id
:= Function_Call
;
5178 Function_Id
: Entity_Id
;
5179 Result_Subt
: Entity_Id
;
5180 Return_Obj_Id
: Entity_Id
;
5181 Return_Obj_Decl
: Entity_Id
;
5184 -- Step past qualification or unchecked conversion (the latter can occur
5185 -- in cases of calls to 'Input).
5187 if Nkind_In
(Func_Call
, N_Qualified_Expression
,
5188 N_Unchecked_Type_Conversion
)
5190 Func_Call
:= Expression
(Func_Call
);
5193 -- If the call has already been processed to add build-in-place actuals
5194 -- then return. One place this can occur is for calls to build-in-place
5195 -- functions that occur within a call to a protected operation, where
5196 -- due to rewriting and expansion of the protected call there can be
5197 -- more than one call to Expand_Actuals for the same set of actuals.
5199 if Is_Expanded_Build_In_Place_Call
(Func_Call
) then
5203 -- Mark the call as processed as a build-in-place call
5205 Set_Is_Expanded_Build_In_Place_Call
(Func_Call
);
5207 Loc
:= Sloc
(Function_Call
);
5209 if Is_Entity_Name
(Name
(Func_Call
)) then
5210 Function_Id
:= Entity
(Name
(Func_Call
));
5212 elsif Nkind
(Name
(Func_Call
)) = N_Explicit_Dereference
then
5213 Function_Id
:= Etype
(Name
(Func_Call
));
5216 raise Program_Error
;
5219 Result_Subt
:= Etype
(Function_Id
);
5221 -- When the result subtype is constrained, an object of the subtype is
5222 -- declared and an access value designating it is passed as an actual.
5224 if Is_Constrained
(Underlying_Type
(Result_Subt
)) then
5226 -- Create a temporary object to hold the function result
5229 Make_Defining_Identifier
(Loc
,
5230 Chars
=> New_Internal_Name
('R'));
5231 Set_Etype
(Return_Obj_Id
, Result_Subt
);
5234 Make_Object_Declaration
(Loc
,
5235 Defining_Identifier
=> Return_Obj_Id
,
5236 Aliased_Present
=> True,
5237 Object_Definition
=> New_Reference_To
(Result_Subt
, Loc
));
5239 Set_No_Initialization
(Return_Obj_Decl
);
5241 Insert_Action
(Func_Call
, Return_Obj_Decl
);
5243 -- When the function has a controlling result, an allocation-form
5244 -- parameter must be passed indicating that the caller is allocating
5245 -- the result object. This is needed because such a function can be
5246 -- called as a dispatching operation and must be treated similarly
5247 -- to functions with unconstrained result subtypes.
5249 Add_Alloc_Form_Actual_To_Build_In_Place_Call
5250 (Func_Call
, Function_Id
, Alloc_Form
=> Caller_Allocation
);
5252 Add_Final_List_Actual_To_Build_In_Place_Call
5253 (Func_Call
, Function_Id
, Acc_Type
=> Empty
);
5255 Add_Task_Actuals_To_Build_In_Place_Call
5256 (Func_Call
, Function_Id
, Make_Identifier
(Loc
, Name_uMaster
));
5258 -- Add an implicit actual to the function call that provides access
5259 -- to the caller's return object.
5261 Add_Access_Actual_To_Build_In_Place_Call
5262 (Func_Call
, Function_Id
, New_Reference_To
(Return_Obj_Id
, Loc
));
5264 -- When the result subtype is unconstrained, the function must allocate
5265 -- the return object in the secondary stack, so appropriate implicit
5266 -- parameters are added to the call to indicate that. A transient
5267 -- scope is established to ensure eventual cleanup of the result.
5271 -- Pass an allocation parameter indicating that the function should
5272 -- allocate its result on the secondary stack.
5274 Add_Alloc_Form_Actual_To_Build_In_Place_Call
5275 (Func_Call
, Function_Id
, Alloc_Form
=> Secondary_Stack
);
5277 Add_Final_List_Actual_To_Build_In_Place_Call
5278 (Func_Call
, Function_Id
, Acc_Type
=> Empty
);
5280 Add_Task_Actuals_To_Build_In_Place_Call
5281 (Func_Call
, Function_Id
, Make_Identifier
(Loc
, Name_uMaster
));
5283 -- Pass a null value to the function since no return object is
5284 -- available on the caller side.
5286 Add_Access_Actual_To_Build_In_Place_Call
5287 (Func_Call
, Function_Id
, Empty
);
5289 Establish_Transient_Scope
(Func_Call
, Sec_Stack
=> True);
5291 end Make_Build_In_Place_Call_In_Anonymous_Context
;
5293 --------------------------------------------
5294 -- Make_Build_In_Place_Call_In_Assignment --
5295 --------------------------------------------
5297 procedure Make_Build_In_Place_Call_In_Assignment
5299 Function_Call
: Node_Id
)
5301 Lhs
: constant Node_Id
:= Name
(Assign
);
5302 Func_Call
: Node_Id
:= Function_Call
;
5303 Func_Id
: Entity_Id
;
5307 Ptr_Typ
: Entity_Id
;
5308 Ptr_Typ_Decl
: Node_Id
;
5309 Result_Subt
: Entity_Id
;
5313 -- Step past qualification or unchecked conversion (the latter can occur
5314 -- in cases of calls to 'Input).
5316 if Nkind_In
(Func_Call
, N_Qualified_Expression
,
5317 N_Unchecked_Type_Conversion
)
5319 Func_Call
:= Expression
(Func_Call
);
5322 -- If the call has already been processed to add build-in-place actuals
5323 -- then return. This should not normally occur in an assignment context,
5324 -- but we add the protection as a defensive measure.
5326 if Is_Expanded_Build_In_Place_Call
(Func_Call
) then
5330 -- Mark the call as processed as a build-in-place call
5332 Set_Is_Expanded_Build_In_Place_Call
(Func_Call
);
5334 Loc
:= Sloc
(Function_Call
);
5336 if Is_Entity_Name
(Name
(Func_Call
)) then
5337 Func_Id
:= Entity
(Name
(Func_Call
));
5339 elsif Nkind
(Name
(Func_Call
)) = N_Explicit_Dereference
then
5340 Func_Id
:= Etype
(Name
(Func_Call
));
5343 raise Program_Error
;
5346 Result_Subt
:= Etype
(Func_Id
);
5348 -- When the result subtype is unconstrained, an additional actual must
5349 -- be passed to indicate that the caller is providing the return object.
5350 -- This parameter must also be passed when the called function has a
5351 -- controlling result, because dispatching calls to the function needs
5352 -- to be treated effectively the same as calls to class-wide functions.
5354 Add_Alloc_Form_Actual_To_Build_In_Place_Call
5355 (Func_Call
, Func_Id
, Alloc_Form
=> Caller_Allocation
);
5357 -- If Lhs is a selected component, then pass it along so that its prefix
5358 -- object will be used as the source of the finalization list.
5360 if Nkind
(Lhs
) = N_Selected_Component
then
5361 Add_Final_List_Actual_To_Build_In_Place_Call
5362 (Func_Call
, Func_Id
, Acc_Type
=> Empty
, Sel_Comp
=> Lhs
);
5364 Add_Final_List_Actual_To_Build_In_Place_Call
5365 (Func_Call
, Func_Id
, Acc_Type
=> Empty
);
5368 Add_Task_Actuals_To_Build_In_Place_Call
5369 (Func_Call
, Func_Id
, Make_Identifier
(Loc
, Name_uMaster
));
5371 -- Add an implicit actual to the function call that provides access to
5372 -- the caller's return object.
5374 Add_Access_Actual_To_Build_In_Place_Call
5377 Make_Unchecked_Type_Conversion
(Loc
,
5378 Subtype_Mark
=> New_Reference_To
(Result_Subt
, Loc
),
5379 Expression
=> Relocate_Node
(Lhs
)));
5381 -- Create an access type designating the function's result subtype
5384 Make_Defining_Identifier
(Loc
, New_Internal_Name
('A'));
5387 Make_Full_Type_Declaration
(Loc
,
5388 Defining_Identifier
=> Ptr_Typ
,
5390 Make_Access_To_Object_Definition
(Loc
,
5391 All_Present
=> True,
5392 Subtype_Indication
=>
5393 New_Reference_To
(Result_Subt
, Loc
)));
5394 Insert_After_And_Analyze
(Assign
, Ptr_Typ_Decl
);
5396 -- Finally, create an access object initialized to a reference to the
5399 Obj_Id
:= Make_Defining_Identifier
(Loc
, New_Internal_Name
('R'));
5400 Set_Etype
(Obj_Id
, Ptr_Typ
);
5403 Make_Object_Declaration
(Loc
,
5404 Defining_Identifier
=> Obj_Id
,
5405 Object_Definition
=>
5406 New_Reference_To
(Ptr_Typ
, Loc
),
5408 Make_Reference
(Loc
,
5409 Prefix
=> Relocate_Node
(Func_Call
)));
5410 Insert_After_And_Analyze
(Ptr_Typ_Decl
, Obj_Decl
);
5412 Rewrite
(Assign
, Make_Null_Statement
(Loc
));
5414 -- Retrieve the target of the assignment
5416 if Nkind
(Lhs
) = N_Selected_Component
then
5417 Target
:= Selector_Name
(Lhs
);
5418 elsif Nkind
(Lhs
) = N_Type_Conversion
then
5419 Target
:= Expression
(Lhs
);
5424 -- If we are assigning to a return object or this is an expression of
5425 -- an extension aggregate, the target should either be an identifier
5426 -- or a simple expression. All other cases imply a different scenario.
5428 if Nkind
(Target
) in N_Has_Entity
then
5429 Target
:= Entity
(Target
);
5434 -- When the target of the assignment is a return object of an enclosing
5435 -- build-in-place function and also requires finalization, the list
5436 -- generated for the assignment must be moved to that of the enclosing
5439 -- function Enclosing_BIP_Function return Ctrl_Typ is
5441 -- return (Ctrl_Parent_Part => BIP_Function with ...);
5442 -- end Enclosing_BIP_Function;
5444 if Is_Return_Object
(Target
)
5445 and then Needs_Finalization
(Etype
(Target
))
5446 and then Needs_Finalization
(Result_Subt
)
5449 Obj_List
: constant Node_Id
:= Find_Final_List
(Obj_Id
);
5450 Encl_List
: Node_Id
;
5451 Encl_Scop
: Entity_Id
;
5454 Encl_Scop
:= Scope
(Target
);
5456 -- Locate the scope of the extended return statement
5458 while Present
(Encl_Scop
)
5459 and then Ekind
(Encl_Scop
) /= E_Return_Statement
5461 Encl_Scop
:= Scope
(Encl_Scop
);
5464 -- A return object should always be enclosed by a return statement
5465 -- scope at some level.
5467 pragma Assert
(Present
(Encl_Scop
));
5470 Make_Attribute_Reference
(Loc
,
5473 Finalization_Chain_Entity
(Encl_Scop
), Loc
),
5474 Attribute_Name
=> Name_Unrestricted_Access
);
5476 -- Generate a call to move final list
5478 Insert_After_And_Analyze
(Obj_Decl
,
5479 Make_Procedure_Call_Statement
(Loc
,
5481 New_Reference_To
(RTE
(RE_Move_Final_List
), Loc
),
5482 Parameter_Associations
=> New_List
(Obj_List
, Encl_List
)));
5485 end Make_Build_In_Place_Call_In_Assignment
;
5487 ----------------------------------------------------
5488 -- Make_Build_In_Place_Call_In_Object_Declaration --
5489 ----------------------------------------------------
5491 procedure Make_Build_In_Place_Call_In_Object_Declaration
5492 (Object_Decl
: Node_Id
;
5493 Function_Call
: Node_Id
)
5496 Obj_Def_Id
: constant Entity_Id
:=
5497 Defining_Identifier
(Object_Decl
);
5499 Func_Call
: Node_Id
:= Function_Call
;
5500 Function_Id
: Entity_Id
;
5501 Result_Subt
: Entity_Id
;
5502 Caller_Object
: Node_Id
;
5503 Call_Deref
: Node_Id
;
5504 Ref_Type
: Entity_Id
;
5505 Ptr_Typ_Decl
: Node_Id
;
5508 Enclosing_Func
: Entity_Id
;
5509 Pass_Caller_Acc
: Boolean := False;
5512 -- Step past qualification or unchecked conversion (the latter can occur
5513 -- in cases of calls to 'Input).
5515 if Nkind_In
(Func_Call
, N_Qualified_Expression
,
5516 N_Unchecked_Type_Conversion
)
5518 Func_Call
:= Expression
(Func_Call
);
5521 -- If the call has already been processed to add build-in-place actuals
5522 -- then return. This should not normally occur in an object declaration,
5523 -- but we add the protection as a defensive measure.
5525 if Is_Expanded_Build_In_Place_Call
(Func_Call
) then
5529 -- Mark the call as processed as a build-in-place call
5531 Set_Is_Expanded_Build_In_Place_Call
(Func_Call
);
5533 Loc
:= Sloc
(Function_Call
);
5535 if Is_Entity_Name
(Name
(Func_Call
)) then
5536 Function_Id
:= Entity
(Name
(Func_Call
));
5538 elsif Nkind
(Name
(Func_Call
)) = N_Explicit_Dereference
then
5539 Function_Id
:= Etype
(Name
(Func_Call
));
5542 raise Program_Error
;
5545 Result_Subt
:= Etype
(Function_Id
);
5547 -- In the constrained case, add an implicit actual to the function call
5548 -- that provides access to the declared object. An unchecked conversion
5549 -- to the (specific) result type of the function is inserted to handle
5550 -- the case where the object is declared with a class-wide type.
5552 if Is_Constrained
(Underlying_Type
(Result_Subt
)) then
5554 Make_Unchecked_Type_Conversion
(Loc
,
5555 Subtype_Mark
=> New_Reference_To
(Result_Subt
, Loc
),
5556 Expression
=> New_Reference_To
(Obj_Def_Id
, Loc
));
5558 -- When the function has a controlling result, an allocation-form
5559 -- parameter must be passed indicating that the caller is allocating
5560 -- the result object. This is needed because such a function can be
5561 -- called as a dispatching operation and must be treated similarly
5562 -- to functions with unconstrained result subtypes.
5564 Add_Alloc_Form_Actual_To_Build_In_Place_Call
5565 (Func_Call
, Function_Id
, Alloc_Form
=> Caller_Allocation
);
5567 -- If the function's result subtype is unconstrained and the object is
5568 -- a return object of an enclosing build-in-place function, then the
5569 -- implicit build-in-place parameters of the enclosing function must be
5570 -- passed along to the called function. (Unfortunately, this won't cover
5571 -- the case of extension aggregates where the ancestor part is a build-
5572 -- in-place unconstrained function call that should be passed along the
5573 -- caller's parameters. Currently those get mishandled by reassigning
5574 -- the result of the call to the aggregate return object, when the call
5575 -- result should really be directly built in place in the aggregate and
5576 -- not built in a temporary. ???)
5578 elsif Is_Return_Object
(Defining_Identifier
(Object_Decl
)) then
5579 Pass_Caller_Acc
:= True;
5581 Enclosing_Func
:= Enclosing_Subprogram
(Obj_Def_Id
);
5583 -- If the enclosing function has a constrained result type, then
5584 -- caller allocation will be used.
5586 if Is_Constrained
(Etype
(Enclosing_Func
)) then
5587 Add_Alloc_Form_Actual_To_Build_In_Place_Call
5588 (Func_Call
, Function_Id
, Alloc_Form
=> Caller_Allocation
);
5590 -- Otherwise, when the enclosing function has an unconstrained result
5591 -- type, the BIP_Alloc_Form formal of the enclosing function must be
5592 -- passed along to the callee.
5595 Add_Alloc_Form_Actual_To_Build_In_Place_Call
5600 (Build_In_Place_Formal
(Enclosing_Func
, BIP_Alloc_Form
),
5604 -- Retrieve the BIPacc formal from the enclosing function and convert
5605 -- it to the access type of the callee's BIP_Object_Access formal.
5608 Make_Unchecked_Type_Conversion
(Loc
,
5612 (Build_In_Place_Formal
(Function_Id
, BIP_Object_Access
)),
5616 (Build_In_Place_Formal
(Enclosing_Func
, BIP_Object_Access
),
5619 -- In other unconstrained cases, pass an indication to do the allocation
5620 -- on the secondary stack and set Caller_Object to Empty so that a null
5621 -- value will be passed for the caller's object address. A transient
5622 -- scope is established to ensure eventual cleanup of the result.
5625 Add_Alloc_Form_Actual_To_Build_In_Place_Call
5628 Alloc_Form
=> Secondary_Stack
);
5629 Caller_Object
:= Empty
;
5631 Establish_Transient_Scope
(Object_Decl
, Sec_Stack
=> True);
5634 Add_Final_List_Actual_To_Build_In_Place_Call
5635 (Func_Call
, Function_Id
, Acc_Type
=> Empty
);
5637 if Nkind
(Parent
(Object_Decl
)) = N_Extended_Return_Statement
5638 and then Has_Task
(Result_Subt
)
5640 Enclosing_Func
:= Enclosing_Subprogram
(Obj_Def_Id
);
5642 -- Here we're passing along the master that was passed in to this
5645 Add_Task_Actuals_To_Build_In_Place_Call
5646 (Func_Call
, Function_Id
,
5649 (Build_In_Place_Formal
(Enclosing_Func
, BIP_Master
), Loc
));
5652 Add_Task_Actuals_To_Build_In_Place_Call
5653 (Func_Call
, Function_Id
, Make_Identifier
(Loc
, Name_uMaster
));
5656 Add_Access_Actual_To_Build_In_Place_Call
5657 (Func_Call
, Function_Id
, Caller_Object
, Is_Access
=> Pass_Caller_Acc
);
5659 -- Create an access type designating the function's result subtype
5662 Make_Defining_Identifier
(Loc
, New_Internal_Name
('A'));
5665 Make_Full_Type_Declaration
(Loc
,
5666 Defining_Identifier
=> Ref_Type
,
5668 Make_Access_To_Object_Definition
(Loc
,
5669 All_Present
=> True,
5670 Subtype_Indication
=>
5671 New_Reference_To
(Result_Subt
, Loc
)));
5673 -- The access type and its accompanying object must be inserted after
5674 -- the object declaration in the constrained case, so that the function
5675 -- call can be passed access to the object. In the unconstrained case,
5676 -- the access type and object must be inserted before the object, since
5677 -- the object declaration is rewritten to be a renaming of a dereference
5678 -- of the access object.
5680 if Is_Constrained
(Underlying_Type
(Result_Subt
)) then
5681 Insert_After_And_Analyze
(Object_Decl
, Ptr_Typ_Decl
);
5683 Insert_Action
(Object_Decl
, Ptr_Typ_Decl
);
5686 -- Finally, create an access object initialized to a reference to the
5690 Make_Defining_Identifier
(Loc
,
5691 Chars
=> New_Internal_Name
('R'));
5692 Set_Etype
(Def_Id
, Ref_Type
);
5695 Make_Reference
(Loc
,
5696 Prefix
=> Relocate_Node
(Func_Call
));
5698 Insert_After_And_Analyze
(Ptr_Typ_Decl
,
5699 Make_Object_Declaration
(Loc
,
5700 Defining_Identifier
=> Def_Id
,
5701 Object_Definition
=> New_Reference_To
(Ref_Type
, Loc
),
5702 Expression
=> New_Expr
));
5704 if Is_Constrained
(Underlying_Type
(Result_Subt
)) then
5705 Set_Expression
(Object_Decl
, Empty
);
5706 Set_No_Initialization
(Object_Decl
);
5708 -- In case of an unconstrained result subtype, rewrite the object
5709 -- declaration as an object renaming where the renamed object is a
5710 -- dereference of <function_Call>'reference:
5712 -- Obj : Subt renames <function_call>'Ref.all;
5716 Make_Explicit_Dereference
(Loc
,
5717 Prefix
=> New_Reference_To
(Def_Id
, Loc
));
5719 Rewrite
(Object_Decl
,
5720 Make_Object_Renaming_Declaration
(Loc
,
5721 Defining_Identifier
=> Make_Defining_Identifier
(Loc
,
5722 New_Internal_Name
('D')),
5723 Access_Definition
=> Empty
,
5724 Subtype_Mark
=> New_Occurrence_Of
(Result_Subt
, Loc
),
5725 Name
=> Call_Deref
));
5727 Set_Renamed_Object
(Defining_Identifier
(Object_Decl
), Call_Deref
);
5729 Analyze
(Object_Decl
);
5731 -- Replace the internal identifier of the renaming declaration's
5732 -- entity with identifier of the original object entity. We also have
5733 -- to exchange the entities containing their defining identifiers to
5734 -- ensure the correct replacement of the object declaration by the
5735 -- object renaming declaration to avoid homograph conflicts (since
5736 -- the object declaration's defining identifier was already entered
5737 -- in current scope). The Next_Entity links of the two entities also
5738 -- have to be swapped since the entities are part of the return
5739 -- scope's entity list and the list structure would otherwise be
5740 -- corrupted. Finally, the homonym chain must be preserved as well.
5743 Renaming_Def_Id
: constant Entity_Id
:=
5744 Defining_Identifier
(Object_Decl
);
5745 Next_Entity_Temp
: constant Entity_Id
:=
5746 Next_Entity
(Renaming_Def_Id
);
5748 Set_Chars
(Renaming_Def_Id
, Chars
(Obj_Def_Id
));
5750 -- Swap next entity links in preparation for exchanging entities
5752 Set_Next_Entity
(Renaming_Def_Id
, Next_Entity
(Obj_Def_Id
));
5753 Set_Next_Entity
(Obj_Def_Id
, Next_Entity_Temp
);
5754 Set_Homonym
(Renaming_Def_Id
, Homonym
(Obj_Def_Id
));
5756 Exchange_Entities
(Renaming_Def_Id
, Obj_Def_Id
);
5760 -- If the object entity has a class-wide Etype, then we need to change
5761 -- it to the result subtype of the function call, because otherwise the
5762 -- object will be class-wide without an explicit initialization and
5763 -- won't be allocated properly by the back end. It seems unclean to make
5764 -- such a revision to the type at this point, and we should try to
5765 -- improve this treatment when build-in-place functions with class-wide
5766 -- results are implemented. ???
5768 if Is_Class_Wide_Type
(Etype
(Defining_Identifier
(Object_Decl
))) then
5769 Set_Etype
(Defining_Identifier
(Object_Decl
), Result_Subt
);
5771 end Make_Build_In_Place_Call_In_Object_Declaration
;
5773 --------------------------
5774 -- Needs_BIP_Final_List --
5775 --------------------------
5777 function Needs_BIP_Final_List
(E
: Entity_Id
) return Boolean is
5778 pragma Assert
(Is_Build_In_Place_Function
(E
));
5779 Result_Subt
: constant Entity_Id
:= Underlying_Type
(Etype
(E
));
5782 -- We need the BIP_Final_List if the result type needs finalization. We
5783 -- also need it for tagged types, even if not class-wide, because some
5784 -- type extension might need finalization, and all overriding functions
5785 -- must have the same calling conventions. However, if there is a
5786 -- pragma Restrictions (No_Finalization), we never need this parameter.
5788 return (Needs_Finalization
(Result_Subt
)
5789 or else Is_Tagged_Type
(Underlying_Type
(Result_Subt
)))
5790 and then not Restriction_Active
(No_Finalization
);
5791 end Needs_BIP_Final_List
;