1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2008, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 with Atree
; use Atree
;
27 with Checks
; use Checks
;
28 with Debug
; use Debug
;
29 with Einfo
; use Einfo
;
30 with Errout
; use Errout
;
31 with Elists
; use Elists
;
32 with Exp_Atag
; use Exp_Atag
;
33 with Exp_Ch2
; use Exp_Ch2
;
34 with Exp_Ch3
; use Exp_Ch3
;
35 with Exp_Ch7
; use Exp_Ch7
;
36 with Exp_Ch9
; use Exp_Ch9
;
37 with Exp_Dbug
; use Exp_Dbug
;
38 with Exp_Disp
; use Exp_Disp
;
39 with Exp_Dist
; use Exp_Dist
;
40 with Exp_Intr
; use Exp_Intr
;
41 with Exp_Pakd
; use Exp_Pakd
;
42 with Exp_Tss
; use Exp_Tss
;
43 with Exp_Util
; use Exp_Util
;
44 with 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_Ch6
; use Sem_Ch6
;
58 with Sem_Ch8
; use Sem_Ch8
;
59 with Sem_Ch12
; use Sem_Ch12
;
60 with Sem_Ch13
; use Sem_Ch13
;
61 with Sem_Eval
; use Sem_Eval
;
62 with Sem_Disp
; use Sem_Disp
;
63 with Sem_Dist
; use Sem_Dist
;
64 with Sem_Mech
; use Sem_Mech
;
65 with Sem_Res
; use Sem_Res
;
66 with Sem_Util
; use Sem_Util
;
67 with Sinfo
; use Sinfo
;
68 with Snames
; use Snames
;
69 with Stand
; use Stand
;
70 with Targparm
; use Targparm
;
71 with Tbuild
; use Tbuild
;
72 with Uintp
; use Uintp
;
73 with Validsw
; use Validsw
;
75 package body Exp_Ch6
is
77 -----------------------
78 -- Local Subprograms --
79 -----------------------
81 procedure Add_Access_Actual_To_Build_In_Place_Call
82 (Function_Call
: Node_Id
;
83 Function_Id
: Entity_Id
;
84 Return_Object
: Node_Id
;
85 Is_Access
: Boolean := False);
86 -- Ada 2005 (AI-318-02): Apply the Unrestricted_Access attribute to the
87 -- object name given by Return_Object and add the attribute to the end of
88 -- the actual parameter list associated with the build-in-place function
89 -- call denoted by Function_Call. However, if Is_Access is True, then
90 -- Return_Object is already an access expression, in which case it's passed
91 -- along directly to the build-in-place function. Finally, if Return_Object
92 -- is empty, then pass a null literal as the actual.
94 procedure Add_Alloc_Form_Actual_To_Build_In_Place_Call
95 (Function_Call
: Node_Id
;
96 Function_Id
: Entity_Id
;
97 Alloc_Form
: BIP_Allocation_Form
:= Unspecified
;
98 Alloc_Form_Exp
: Node_Id
:= Empty
);
99 -- Ada 2005 (AI-318-02): Add an actual indicating the form of allocation,
100 -- if any, to be done by a build-in-place function. If Alloc_Form_Exp is
101 -- present, then use it, otherwise pass a literal corresponding to the
102 -- Alloc_Form parameter (which must not be Unspecified in that case).
104 procedure Add_Extra_Actual_To_Call
105 (Subprogram_Call
: Node_Id
;
106 Extra_Formal
: Entity_Id
;
107 Extra_Actual
: Node_Id
);
108 -- Adds Extra_Actual as a named parameter association for the formal
109 -- Extra_Formal in Subprogram_Call.
111 procedure Add_Final_List_Actual_To_Build_In_Place_Call
112 (Function_Call
: Node_Id
;
113 Function_Id
: Entity_Id
;
114 Acc_Type
: Entity_Id
;
115 Sel_Comp
: Node_Id
:= Empty
);
116 -- Ada 2005 (AI-318-02): For a build-in-place call, if the result type has
117 -- controlled parts, add an actual parameter that is a pointer to
118 -- appropriate finalization list. The finalization list is that of the
119 -- current scope, except for "new Acc'(F(...))" in which case it's the
120 -- finalization list of the access type returned by the allocator. Acc_Type
121 -- is that type in the allocator case; Empty otherwise. If Sel_Comp is
122 -- not Empty, then it denotes a selected component and the finalization
123 -- list is obtained from the _controller list of the prefix object.
125 procedure Add_Task_Actuals_To_Build_In_Place_Call
126 (Function_Call
: Node_Id
;
127 Function_Id
: Entity_Id
;
128 Master_Actual
: Node_Id
);
129 -- Ada 2005 (AI-318-02): For a build-in-place call, if the result type
130 -- contains tasks, add two actual parameters: the master, and a pointer to
131 -- the caller's activation chain. Master_Actual is the actual parameter
132 -- expression to pass for the master. In most cases, this is the current
133 -- master (_master). The two exceptions are: If the function call is the
134 -- initialization expression for an allocator, we pass the master of the
135 -- access type. If the function call is the initialization expression for
136 -- a return object, we pass along the master passed in by the caller. The
137 -- activation chain to pass is always the local one.
139 procedure Check_Overriding_Operation
(Subp
: Entity_Id
);
140 -- Subp is a dispatching operation. Check whether it may override an
141 -- inherited private operation, in which case its DT entry is that of
142 -- the hidden operation, not the one it may have received earlier.
143 -- This must be done before emitting the code to set the corresponding
144 -- DT to the address of the subprogram. The actual placement of Subp in
145 -- the proper place in the list of primitive operations is done in
146 -- Declare_Inherited_Private_Subprograms, which also has to deal with
147 -- implicit operations. This duplication is unavoidable for now???
149 procedure Detect_Infinite_Recursion
(N
: Node_Id
; Spec
: Entity_Id
);
150 -- This procedure is called only if the subprogram body N, whose spec
151 -- has the given entity Spec, contains a parameterless recursive call.
152 -- It attempts to generate runtime code to detect if this a case of
153 -- infinite recursion.
155 -- The body is scanned to determine dependencies. If the only external
156 -- dependencies are on a small set of scalar variables, then the values
157 -- of these variables are captured on entry to the subprogram, and if
158 -- the values are not changed for the call, we know immediately that
159 -- we have an infinite recursion.
161 procedure Expand_Actuals
(N
: Node_Id
; Subp
: Entity_Id
);
162 -- For each actual of an in-out or out parameter which is a numeric
163 -- (view) conversion of the form T (A), where A denotes a variable,
164 -- we insert the declaration:
166 -- Temp : T[ := T (A)];
168 -- prior to the call. Then we replace the actual with a reference to Temp,
169 -- and append the assignment:
171 -- A := TypeA (Temp);
173 -- after the call. Here TypeA is the actual type of variable A.
174 -- For out parameters, the initial declaration has no expression.
175 -- If A is not an entity name, we generate instead:
177 -- Var : TypeA renames A;
178 -- Temp : T := Var; -- omitting expression for out parameter.
180 -- Var := TypeA (Temp);
182 -- For other in-out parameters, we emit the required constraint checks
183 -- before and/or after the call.
185 -- For all parameter modes, actuals that denote components and slices
186 -- of packed arrays are expanded into suitable temporaries.
188 -- For non-scalar objects that are possibly unaligned, add call by copy
189 -- code (copy in for IN and IN OUT, copy out for OUT and IN OUT).
191 procedure Expand_Inlined_Call
194 Orig_Subp
: Entity_Id
);
195 -- If called subprogram can be inlined by the front-end, retrieve the
196 -- analyzed body, replace formals with actuals and expand call in place.
197 -- Generate thunks for actuals that are expressions, and insert the
198 -- corresponding constant declarations before the call. If the original
199 -- call is to a derived operation, the return type is the one of the
200 -- derived operation, but the body is that of the original, so return
201 -- expressions in the body must be converted to the desired type (which
202 -- is simply not noted in the tree without inline expansion).
204 function Expand_Protected_Object_Reference
206 Scop
: Entity_Id
) return Node_Id
;
208 procedure Expand_Protected_Subprogram_Call
212 -- A call to a protected subprogram within the protected object may appear
213 -- as a regular call. The list of actuals must be expanded to contain a
214 -- reference to the object itself, and the call becomes a call to the
215 -- corresponding protected subprogram.
217 ----------------------------------------------
218 -- Add_Access_Actual_To_Build_In_Place_Call --
219 ----------------------------------------------
221 procedure Add_Access_Actual_To_Build_In_Place_Call
222 (Function_Call
: Node_Id
;
223 Function_Id
: Entity_Id
;
224 Return_Object
: Node_Id
;
225 Is_Access
: Boolean := False)
227 Loc
: constant Source_Ptr
:= Sloc
(Function_Call
);
228 Obj_Address
: Node_Id
;
229 Obj_Acc_Formal
: Entity_Id
;
232 -- Locate the implicit access parameter in the called function
234 Obj_Acc_Formal
:= Build_In_Place_Formal
(Function_Id
, BIP_Object_Access
);
236 -- If no return object is provided, then pass null
238 if not Present
(Return_Object
) then
239 Obj_Address
:= Make_Null
(Loc
);
240 Set_Parent
(Obj_Address
, Function_Call
);
242 -- If Return_Object is already an expression of an access type, then use
243 -- it directly, since it must be an access value denoting the return
244 -- object, and couldn't possibly be the return object itself.
247 Obj_Address
:= Return_Object
;
248 Set_Parent
(Obj_Address
, Function_Call
);
250 -- Apply Unrestricted_Access to caller's return object
254 Make_Attribute_Reference
(Loc
,
255 Prefix
=> Return_Object
,
256 Attribute_Name
=> Name_Unrestricted_Access
);
258 Set_Parent
(Return_Object
, Obj_Address
);
259 Set_Parent
(Obj_Address
, Function_Call
);
262 Analyze_And_Resolve
(Obj_Address
, Etype
(Obj_Acc_Formal
));
264 -- Build the parameter association for the new actual and add it to the
265 -- end of the function's actuals.
267 Add_Extra_Actual_To_Call
(Function_Call
, Obj_Acc_Formal
, Obj_Address
);
268 end Add_Access_Actual_To_Build_In_Place_Call
;
270 --------------------------------------------------
271 -- Add_Alloc_Form_Actual_To_Build_In_Place_Call --
272 --------------------------------------------------
274 procedure Add_Alloc_Form_Actual_To_Build_In_Place_Call
275 (Function_Call
: Node_Id
;
276 Function_Id
: Entity_Id
;
277 Alloc_Form
: BIP_Allocation_Form
:= Unspecified
;
278 Alloc_Form_Exp
: Node_Id
:= Empty
)
280 Loc
: constant Source_Ptr
:= Sloc
(Function_Call
);
281 Alloc_Form_Actual
: Node_Id
;
282 Alloc_Form_Formal
: Node_Id
;
285 -- The allocation form generally doesn't need to be passed in the case
286 -- of a constrained result subtype, since normally the caller performs
287 -- the allocation in that case. However this formal is still needed in
288 -- the case where the function has a tagged result, because generally
289 -- such functions can be called in a dispatching context and such calls
290 -- must be handled like calls to class-wide functions.
292 if Is_Constrained
(Underlying_Type
(Etype
(Function_Id
)))
293 and then not Is_Tagged_Type
(Underlying_Type
(Etype
(Function_Id
)))
298 -- Locate the implicit allocation form parameter in the called function.
299 -- Maybe it would be better for each implicit formal of a build-in-place
300 -- function to have a flag or a Uint attribute to identify it. ???
302 Alloc_Form_Formal
:= Build_In_Place_Formal
(Function_Id
, BIP_Alloc_Form
);
304 if Present
(Alloc_Form_Exp
) then
305 pragma Assert
(Alloc_Form
= Unspecified
);
307 Alloc_Form_Actual
:= Alloc_Form_Exp
;
310 pragma Assert
(Alloc_Form
/= Unspecified
);
313 Make_Integer_Literal
(Loc
,
314 Intval
=> UI_From_Int
(BIP_Allocation_Form
'Pos (Alloc_Form
)));
317 Analyze_And_Resolve
(Alloc_Form_Actual
, Etype
(Alloc_Form_Formal
));
319 -- Build the parameter association for the new actual and add it to the
320 -- end of the function's actuals.
322 Add_Extra_Actual_To_Call
323 (Function_Call
, Alloc_Form_Formal
, Alloc_Form_Actual
);
324 end Add_Alloc_Form_Actual_To_Build_In_Place_Call
;
326 ------------------------------
327 -- Add_Extra_Actual_To_Call --
328 ------------------------------
330 procedure Add_Extra_Actual_To_Call
331 (Subprogram_Call
: Node_Id
;
332 Extra_Formal
: Entity_Id
;
333 Extra_Actual
: Node_Id
)
335 Loc
: constant Source_Ptr
:= Sloc
(Subprogram_Call
);
336 Param_Assoc
: Node_Id
;
340 Make_Parameter_Association
(Loc
,
341 Selector_Name
=> New_Occurrence_Of
(Extra_Formal
, Loc
),
342 Explicit_Actual_Parameter
=> Extra_Actual
);
344 Set_Parent
(Param_Assoc
, Subprogram_Call
);
345 Set_Parent
(Extra_Actual
, Param_Assoc
);
347 if Present
(Parameter_Associations
(Subprogram_Call
)) then
348 if Nkind
(Last
(Parameter_Associations
(Subprogram_Call
))) =
349 N_Parameter_Association
352 -- Find last named actual, and append
357 L
:= First_Actual
(Subprogram_Call
);
358 while Present
(L
) loop
359 if No
(Next_Actual
(L
)) then
360 Set_Next_Named_Actual
(Parent
(L
), Extra_Actual
);
368 Set_First_Named_Actual
(Subprogram_Call
, Extra_Actual
);
371 Append
(Param_Assoc
, To
=> Parameter_Associations
(Subprogram_Call
));
374 Set_Parameter_Associations
(Subprogram_Call
, New_List
(Param_Assoc
));
375 Set_First_Named_Actual
(Subprogram_Call
, Extra_Actual
);
377 end Add_Extra_Actual_To_Call
;
379 --------------------------------------------------
380 -- Add_Final_List_Actual_To_Build_In_Place_Call --
381 --------------------------------------------------
383 procedure Add_Final_List_Actual_To_Build_In_Place_Call
384 (Function_Call
: Node_Id
;
385 Function_Id
: Entity_Id
;
386 Acc_Type
: Entity_Id
;
387 Sel_Comp
: Node_Id
:= Empty
)
389 Loc
: constant Source_Ptr
:= Sloc
(Function_Call
);
390 Final_List
: Node_Id
;
391 Final_List_Actual
: Node_Id
;
392 Final_List_Formal
: Node_Id
;
393 Is_Ctrl_Result
: constant Boolean :=
395 (Underlying_Type
(Etype
(Function_Id
)));
398 -- No such extra parameter is needed if there are no controlled parts.
399 -- The test for Needs_Finalization accounts for class-wide results
400 -- (which potentially have controlled parts, even if the root type
401 -- doesn't), and the test for a tagged result type is needed because
402 -- calls to such a function can in general occur in dispatching
403 -- contexts, which must be treated the same as a call to class-wide
404 -- functions. Both of these situations require that a finalization list
407 if not Needs_BIP_Final_List
(Function_Id
) then
411 -- Locate implicit finalization list parameter in the called function
413 Final_List_Formal
:= Build_In_Place_Formal
(Function_Id
, BIP_Final_List
);
415 -- Create the actual which is a pointer to the appropriate finalization
416 -- list. Acc_Type is present if and only if this call is the
417 -- initialization of an allocator. Use the Current_Scope or the Acc_Type
420 if Present
(Acc_Type
)
421 and then (Ekind
(Acc_Type
) = E_Anonymous_Access_Type
423 Present
(Associated_Final_Chain
(Base_Type
(Acc_Type
))))
425 Final_List
:= Find_Final_List
(Acc_Type
);
427 -- If Sel_Comp is present and the function result is controlled, then
428 -- the finalization list will be obtained from the _controller list of
429 -- the selected component's prefix object.
431 elsif Present
(Sel_Comp
) and then Is_Ctrl_Result
then
432 Final_List
:= Find_Final_List
(Current_Scope
, Sel_Comp
);
435 Final_List
:= Find_Final_List
(Current_Scope
);
439 Make_Attribute_Reference
(Loc
,
440 Prefix
=> Final_List
,
441 Attribute_Name
=> Name_Unrestricted_Access
);
443 Analyze_And_Resolve
(Final_List_Actual
, Etype
(Final_List_Formal
));
445 -- Build the parameter association for the new actual and add it to the
446 -- end of the function's actuals.
448 Add_Extra_Actual_To_Call
449 (Function_Call
, Final_List_Formal
, Final_List_Actual
);
450 end Add_Final_List_Actual_To_Build_In_Place_Call
;
452 ---------------------------------------------
453 -- Add_Task_Actuals_To_Build_In_Place_Call --
454 ---------------------------------------------
456 procedure Add_Task_Actuals_To_Build_In_Place_Call
457 (Function_Call
: Node_Id
;
458 Function_Id
: Entity_Id
;
459 Master_Actual
: Node_Id
)
460 -- Note: Master_Actual can be Empty, but only if there are no tasks
462 Loc
: constant Source_Ptr
:= Sloc
(Function_Call
);
465 -- No such extra parameters are needed if there are no tasks
467 if not Has_Task
(Etype
(Function_Id
)) then
474 Master_Formal
: Node_Id
;
476 -- Locate implicit master parameter in the called function
478 Master_Formal
:= Build_In_Place_Formal
(Function_Id
, BIP_Master
);
480 Analyze_And_Resolve
(Master_Actual
, Etype
(Master_Formal
));
482 -- Build the parameter association for the new actual and add it to
483 -- the end of the function's actuals.
485 Add_Extra_Actual_To_Call
486 (Function_Call
, Master_Formal
, Master_Actual
);
489 -- The activation chain
492 Activation_Chain_Actual
: Node_Id
;
493 Activation_Chain_Formal
: Node_Id
;
495 -- Locate implicit activation chain parameter in the called function
497 Activation_Chain_Formal
:= Build_In_Place_Formal
498 (Function_Id
, BIP_Activation_Chain
);
500 -- Create the actual which is a pointer to the current activation
503 Activation_Chain_Actual
:=
504 Make_Attribute_Reference
(Loc
,
505 Prefix
=> Make_Identifier
(Loc
, Name_uChain
),
506 Attribute_Name
=> Name_Unrestricted_Access
);
509 (Activation_Chain_Actual
, Etype
(Activation_Chain_Formal
));
511 -- Build the parameter association for the new actual and add it to
512 -- the end of the function's actuals.
514 Add_Extra_Actual_To_Call
515 (Function_Call
, Activation_Chain_Formal
, Activation_Chain_Actual
);
517 end Add_Task_Actuals_To_Build_In_Place_Call
;
519 -----------------------
520 -- BIP_Formal_Suffix --
521 -----------------------
523 function BIP_Formal_Suffix
(Kind
: BIP_Formal_Kind
) return String is
526 when BIP_Alloc_Form
=>
528 when BIP_Final_List
=>
529 return "BIPfinallist";
532 when BIP_Activation_Chain
=>
533 return "BIPactivationchain";
534 when BIP_Object_Access
=>
537 end BIP_Formal_Suffix
;
539 ---------------------------
540 -- Build_In_Place_Formal --
541 ---------------------------
543 function Build_In_Place_Formal
545 Kind
: BIP_Formal_Kind
) return Entity_Id
547 Extra_Formal
: Entity_Id
:= Extra_Formals
(Func
);
550 -- Maybe it would be better for each implicit formal of a build-in-place
551 -- function to have a flag or a Uint attribute to identify it. ???
554 pragma Assert
(Present
(Extra_Formal
));
556 Chars
(Extra_Formal
) =
557 New_External_Name
(Chars
(Func
), BIP_Formal_Suffix
(Kind
));
558 Next_Formal_With_Extras
(Extra_Formal
);
562 end Build_In_Place_Formal
;
564 --------------------------------
565 -- Check_Overriding_Operation --
566 --------------------------------
568 procedure Check_Overriding_Operation
(Subp
: Entity_Id
) is
569 Typ
: constant Entity_Id
:= Find_Dispatching_Type
(Subp
);
570 Op_List
: constant Elist_Id
:= Primitive_Operations
(Typ
);
576 if Is_Derived_Type
(Typ
)
577 and then not Is_Private_Type
(Typ
)
578 and then In_Open_Scopes
(Scope
(Etype
(Typ
)))
579 and then Typ
= Base_Type
(Typ
)
581 -- Subp overrides an inherited private operation if there is an
582 -- inherited operation with a different name than Subp (see
583 -- Derive_Subprogram) whose Alias is a hidden subprogram with the
584 -- same name as Subp.
586 Op_Elmt
:= First_Elmt
(Op_List
);
587 while Present
(Op_Elmt
) loop
588 Prim_Op
:= Node
(Op_Elmt
);
589 Par_Op
:= Alias
(Prim_Op
);
592 and then not Comes_From_Source
(Prim_Op
)
593 and then Chars
(Prim_Op
) /= Chars
(Par_Op
)
594 and then Chars
(Par_Op
) = Chars
(Subp
)
595 and then Is_Hidden
(Par_Op
)
596 and then Type_Conformant
(Prim_Op
, Subp
)
598 Set_DT_Position
(Subp
, DT_Position
(Prim_Op
));
604 end Check_Overriding_Operation
;
606 -------------------------------
607 -- Detect_Infinite_Recursion --
608 -------------------------------
610 procedure Detect_Infinite_Recursion
(N
: Node_Id
; Spec
: Entity_Id
) is
611 Loc
: constant Source_Ptr
:= Sloc
(N
);
613 Var_List
: constant Elist_Id
:= New_Elmt_List
;
614 -- List of globals referenced by body of procedure
616 Call_List
: constant Elist_Id
:= New_Elmt_List
;
617 -- List of recursive calls in body of procedure
619 Shad_List
: constant Elist_Id
:= New_Elmt_List
;
620 -- List of entity id's for entities created to capture the value of
621 -- referenced globals on entry to the procedure.
623 Scop
: constant Uint
:= Scope_Depth
(Spec
);
624 -- This is used to record the scope depth of the current procedure, so
625 -- that we can identify global references.
627 Max_Vars
: constant := 4;
628 -- Do not test more than four global variables
630 Count_Vars
: Natural := 0;
631 -- Count variables found so far
643 function Process
(Nod
: Node_Id
) return Traverse_Result
;
644 -- Function to traverse the subprogram body (using Traverse_Func)
650 function Process
(Nod
: Node_Id
) return Traverse_Result
is
654 if Nkind
(Nod
) = N_Procedure_Call_Statement
then
656 -- Case of one of the detected recursive calls
658 if Is_Entity_Name
(Name
(Nod
))
659 and then Has_Recursive_Call
(Entity
(Name
(Nod
)))
660 and then Entity
(Name
(Nod
)) = Spec
662 Append_Elmt
(Nod
, Call_List
);
665 -- Any other procedure call may have side effects
671 -- A call to a pure function can always be ignored
673 elsif Nkind
(Nod
) = N_Function_Call
674 and then Is_Entity_Name
(Name
(Nod
))
675 and then Is_Pure
(Entity
(Name
(Nod
)))
679 -- Case of an identifier reference
681 elsif Nkind
(Nod
) = N_Identifier
then
684 -- If no entity, then ignore the reference
686 -- Not clear why this can happen. To investigate, remove this
687 -- test and look at the crash that occurs here in 3401-004 ???
692 -- Ignore entities with no Scope, again not clear how this
693 -- can happen, to investigate, look at 4108-008 ???
695 elsif No
(Scope
(Ent
)) then
698 -- Ignore the reference if not to a more global object
700 elsif Scope_Depth
(Scope
(Ent
)) >= Scop
then
703 -- References to types, exceptions and constants are always OK
706 or else Ekind
(Ent
) = E_Exception
707 or else Ekind
(Ent
) = E_Constant
711 -- If other than a non-volatile scalar variable, we have some
712 -- kind of global reference (e.g. to a function) that we cannot
713 -- deal with so we forget the attempt.
715 elsif Ekind
(Ent
) /= E_Variable
716 or else not Is_Scalar_Type
(Etype
(Ent
))
717 or else Treat_As_Volatile
(Ent
)
721 -- Otherwise we have a reference to a global scalar
724 -- Loop through global entities already detected
726 Elm
:= First_Elmt
(Var_List
);
728 -- If not detected before, record this new global reference
731 Count_Vars
:= Count_Vars
+ 1;
733 if Count_Vars
<= Max_Vars
then
734 Append_Elmt
(Entity
(Nod
), Var_List
);
741 -- If recorded before, ignore
743 elsif Node
(Elm
) = Entity
(Nod
) then
746 -- Otherwise keep looking
756 -- For all other node kinds, recursively visit syntactic children
763 function Traverse_Body
is new Traverse_Func
(Process
);
765 -- Start of processing for Detect_Infinite_Recursion
768 -- Do not attempt detection in No_Implicit_Conditional mode, since we
769 -- won't be able to generate the code to handle the recursion in any
772 if Restriction_Active
(No_Implicit_Conditionals
) then
776 -- Otherwise do traversal and quit if we get abandon signal
778 if Traverse_Body
(N
) = Abandon
then
781 -- We must have a call, since Has_Recursive_Call was set. If not just
782 -- ignore (this is only an error check, so if we have a funny situation,
783 -- due to bugs or errors, we do not want to bomb!)
785 elsif Is_Empty_Elmt_List
(Call_List
) then
789 -- Here is the case where we detect recursion at compile time
791 -- Push our current scope for analyzing the declarations and code that
792 -- we will insert for the checking.
796 -- This loop builds temporary variables for each of the referenced
797 -- globals, so that at the end of the loop the list Shad_List contains
798 -- these temporaries in one-to-one correspondence with the elements in
802 Elm
:= First_Elmt
(Var_List
);
803 while Present
(Elm
) loop
806 Make_Defining_Identifier
(Loc
,
807 Chars
=> New_Internal_Name
('S'));
808 Append_Elmt
(Ent
, Shad_List
);
810 -- Insert a declaration for this temporary at the start of the
811 -- declarations for the procedure. The temporaries are declared as
812 -- constant objects initialized to the current values of the
813 -- corresponding temporaries.
816 Make_Object_Declaration
(Loc
,
817 Defining_Identifier
=> Ent
,
818 Object_Definition
=> New_Occurrence_Of
(Etype
(Var
), Loc
),
819 Constant_Present
=> True,
820 Expression
=> New_Occurrence_Of
(Var
, Loc
));
823 Prepend
(Decl
, Declarations
(N
));
825 Insert_After
(Last
, Decl
);
833 -- Loop through calls
835 Call
:= First_Elmt
(Call_List
);
836 while Present
(Call
) loop
838 -- Build a predicate expression of the form
841 -- and then global1 = temp1
842 -- and then global2 = temp2
845 -- This predicate determines if any of the global values
846 -- referenced by the procedure have changed since the
847 -- current call, if not an infinite recursion is assured.
849 Test
:= New_Occurrence_Of
(Standard_True
, Loc
);
851 Elm1
:= First_Elmt
(Var_List
);
852 Elm2
:= First_Elmt
(Shad_List
);
853 while Present
(Elm1
) loop
859 Left_Opnd
=> New_Occurrence_Of
(Node
(Elm1
), Loc
),
860 Right_Opnd
=> New_Occurrence_Of
(Node
(Elm2
), Loc
)));
866 -- Now we replace the call with the sequence
868 -- if no-changes (see above) then
869 -- raise Storage_Error;
874 Rewrite
(Node
(Call
),
875 Make_If_Statement
(Loc
,
877 Then_Statements
=> New_List
(
878 Make_Raise_Storage_Error
(Loc
,
879 Reason
=> SE_Infinite_Recursion
)),
881 Else_Statements
=> New_List
(
882 Relocate_Node
(Node
(Call
)))));
884 Analyze
(Node
(Call
));
889 -- Remove temporary scope stack entry used for analysis
892 end Detect_Infinite_Recursion
;
898 procedure Expand_Actuals
(N
: Node_Id
; Subp
: Entity_Id
) is
899 Loc
: constant Source_Ptr
:= Sloc
(N
);
904 E_Formal
: Entity_Id
;
906 procedure Add_Call_By_Copy_Code
;
907 -- For cases where the parameter must be passed by copy, this routine
908 -- generates a temporary variable into which the actual is copied and
909 -- then passes this as the parameter. For an OUT or IN OUT parameter,
910 -- an assignment is also generated to copy the result back. The call
911 -- also takes care of any constraint checks required for the type
912 -- conversion case (on both the way in and the way out).
914 procedure Add_Simple_Call_By_Copy_Code
;
915 -- This is similar to the above, but is used in cases where we know
916 -- that all that is needed is to simply create a temporary and copy
917 -- the value in and out of the temporary.
919 procedure Check_Fortran_Logical
;
920 -- A value of type Logical that is passed through a formal parameter
921 -- must be normalized because .TRUE. usually does not have the same
922 -- representation as True. We assume that .FALSE. = False = 0.
923 -- What about functions that return a logical type ???
925 function Is_Legal_Copy
return Boolean;
926 -- Check that an actual can be copied before generating the temporary
927 -- to be used in the call. If the actual is of a by_reference type then
928 -- the program is illegal (this can only happen in the presence of
929 -- rep. clauses that force an incorrect alignment). If the formal is
930 -- a by_reference parameter imposed by a DEC pragma, emit a warning to
931 -- the effect that this might lead to unaligned arguments.
933 function Make_Var
(Actual
: Node_Id
) return Entity_Id
;
934 -- Returns an entity that refers to the given actual parameter,
935 -- Actual (not including any type conversion). If Actual is an
936 -- entity name, then this entity is returned unchanged, otherwise
937 -- a renaming is created to provide an entity for the actual.
939 procedure Reset_Packed_Prefix
;
940 -- The expansion of a packed array component reference is delayed in
941 -- the context of a call. Now we need to complete the expansion, so we
942 -- unmark the analyzed bits in all prefixes.
944 ---------------------------
945 -- Add_Call_By_Copy_Code --
946 ---------------------------
948 procedure Add_Call_By_Copy_Code
is
954 F_Typ
: constant Entity_Id
:= Etype
(Formal
);
959 if not Is_Legal_Copy
then
964 Make_Defining_Identifier
(Loc
,
965 Chars
=> New_Internal_Name
('T'));
967 -- Use formal type for temp, unless formal type is an unconstrained
968 -- array, in which case we don't have to worry about bounds checks,
969 -- and we use the actual type, since that has appropriate bounds.
971 if Is_Array_Type
(F_Typ
) and then not Is_Constrained
(F_Typ
) then
972 Indic
:= New_Occurrence_Of
(Etype
(Actual
), Loc
);
974 Indic
:= New_Occurrence_Of
(Etype
(Formal
), Loc
);
977 if Nkind
(Actual
) = N_Type_Conversion
then
978 V_Typ
:= Etype
(Expression
(Actual
));
980 -- If the formal is an (in-)out parameter, capture the name
981 -- of the variable in order to build the post-call assignment.
983 Var
:= Make_Var
(Expression
(Actual
));
985 Crep
:= not Same_Representation
986 (F_Typ
, Etype
(Expression
(Actual
)));
989 V_Typ
:= Etype
(Actual
);
990 Var
:= Make_Var
(Actual
);
994 -- Setup initialization for case of in out parameter, or an out
995 -- parameter where the formal is an unconstrained array (in the
996 -- latter case, we have to pass in an object with bounds).
998 -- If this is an out parameter, the initial copy is wasteful, so as
999 -- an optimization for the one-dimensional case we extract the
1000 -- bounds of the actual and build an uninitialized temporary of the
1003 if Ekind
(Formal
) = E_In_Out_Parameter
1004 or else (Is_Array_Type
(F_Typ
) and then not Is_Constrained
(F_Typ
))
1006 if Nkind
(Actual
) = N_Type_Conversion
then
1007 if Conversion_OK
(Actual
) then
1008 Init
:= OK_Convert_To
(F_Typ
, New_Occurrence_Of
(Var
, Loc
));
1010 Init
:= Convert_To
(F_Typ
, New_Occurrence_Of
(Var
, Loc
));
1013 elsif Ekind
(Formal
) = E_Out_Parameter
1014 and then Is_Array_Type
(F_Typ
)
1015 and then Number_Dimensions
(F_Typ
) = 1
1016 and then not Has_Non_Null_Base_Init_Proc
(F_Typ
)
1018 -- Actual is a one-dimensional array or slice, and the type
1019 -- requires no initialization. Create a temporary of the
1020 -- right size, but do not copy actual into it (optimization).
1024 Make_Subtype_Indication
(Loc
,
1026 New_Occurrence_Of
(F_Typ
, Loc
),
1028 Make_Index_Or_Discriminant_Constraint
(Loc
,
1029 Constraints
=> New_List
(
1032 Make_Attribute_Reference
(Loc
,
1033 Prefix
=> New_Occurrence_Of
(Var
, Loc
),
1034 Attribute_Name
=> Name_First
),
1036 Make_Attribute_Reference
(Loc
,
1037 Prefix
=> New_Occurrence_Of
(Var
, Loc
),
1038 Attribute_Name
=> Name_Last
)))));
1041 Init
:= New_Occurrence_Of
(Var
, Loc
);
1044 -- An initialization is created for packed conversions as
1045 -- actuals for out parameters to enable Make_Object_Declaration
1046 -- to determine the proper subtype for N_Node. Note that this
1047 -- is wasteful because the extra copying on the call side is
1048 -- not required for such out parameters. ???
1050 elsif Ekind
(Formal
) = E_Out_Parameter
1051 and then Nkind
(Actual
) = N_Type_Conversion
1052 and then (Is_Bit_Packed_Array
(F_Typ
)
1054 Is_Bit_Packed_Array
(Etype
(Expression
(Actual
))))
1056 if Conversion_OK
(Actual
) then
1057 Init
:= OK_Convert_To
(F_Typ
, New_Occurrence_Of
(Var
, Loc
));
1059 Init
:= Convert_To
(F_Typ
, New_Occurrence_Of
(Var
, Loc
));
1062 elsif Ekind
(Formal
) = E_In_Parameter
then
1064 -- Handle the case in which the actual is a type conversion
1066 if Nkind
(Actual
) = N_Type_Conversion
then
1067 if Conversion_OK
(Actual
) then
1068 Init
:= OK_Convert_To
(F_Typ
, New_Occurrence_Of
(Var
, Loc
));
1070 Init
:= Convert_To
(F_Typ
, New_Occurrence_Of
(Var
, Loc
));
1073 Init
:= New_Occurrence_Of
(Var
, Loc
);
1081 Make_Object_Declaration
(Loc
,
1082 Defining_Identifier
=> Temp
,
1083 Object_Definition
=> Indic
,
1084 Expression
=> Init
);
1085 Set_Assignment_OK
(N_Node
);
1086 Insert_Action
(N
, N_Node
);
1088 -- Now, normally the deal here is that we use the defining
1089 -- identifier created by that object declaration. There is
1090 -- one exception to this. In the change of representation case
1091 -- the above declaration will end up looking like:
1093 -- temp : type := identifier;
1095 -- And in this case we might as well use the identifier directly
1096 -- and eliminate the temporary. Note that the analysis of the
1097 -- declaration was not a waste of time in that case, since it is
1098 -- what generated the necessary change of representation code. If
1099 -- the change of representation introduced additional code, as in
1100 -- a fixed-integer conversion, the expression is not an identifier
1101 -- and must be kept.
1104 and then Present
(Expression
(N_Node
))
1105 and then Is_Entity_Name
(Expression
(N_Node
))
1107 Temp
:= Entity
(Expression
(N_Node
));
1108 Rewrite
(N_Node
, Make_Null_Statement
(Loc
));
1111 -- For IN parameter, all we do is to replace the actual
1113 if Ekind
(Formal
) = E_In_Parameter
then
1114 Rewrite
(Actual
, New_Reference_To
(Temp
, Loc
));
1117 -- Processing for OUT or IN OUT parameter
1120 -- Kill current value indications for the temporary variable we
1121 -- created, since we just passed it as an OUT parameter.
1123 Kill_Current_Values
(Temp
);
1125 -- If type conversion, use reverse conversion on exit
1127 if Nkind
(Actual
) = N_Type_Conversion
then
1128 if Conversion_OK
(Actual
) then
1129 Expr
:= OK_Convert_To
(V_Typ
, New_Occurrence_Of
(Temp
, Loc
));
1131 Expr
:= Convert_To
(V_Typ
, New_Occurrence_Of
(Temp
, Loc
));
1134 Expr
:= New_Occurrence_Of
(Temp
, Loc
);
1137 Rewrite
(Actual
, New_Reference_To
(Temp
, Loc
));
1140 -- If the actual is a conversion of a packed reference, it may
1141 -- already have been expanded by Remove_Side_Effects, and the
1142 -- resulting variable is a temporary which does not designate
1143 -- the proper out-parameter, which may not be addressable. In
1144 -- that case, generate an assignment to the original expression
1145 -- (before expansion of the packed reference) so that the proper
1146 -- expansion of assignment to a packed component can take place.
1153 if Is_Renaming_Of_Object
(Var
)
1154 and then Nkind
(Renamed_Object
(Var
)) = N_Selected_Component
1155 and then Is_Entity_Name
(Prefix
(Renamed_Object
(Var
)))
1156 and then Nkind
(Original_Node
(Prefix
(Renamed_Object
(Var
))))
1157 = N_Indexed_Component
1159 Has_Non_Standard_Rep
(Etype
(Prefix
(Renamed_Object
(Var
))))
1161 Obj
:= Renamed_Object
(Var
);
1163 Make_Selected_Component
(Loc
,
1165 New_Copy_Tree
(Original_Node
(Prefix
(Obj
))),
1166 Selector_Name
=> New_Copy
(Selector_Name
(Obj
)));
1167 Reset_Analyzed_Flags
(Lhs
);
1170 Lhs
:= New_Occurrence_Of
(Var
, Loc
);
1173 Set_Assignment_OK
(Lhs
);
1175 Append_To
(Post_Call
,
1176 Make_Assignment_Statement
(Loc
,
1178 Expression
=> Expr
));
1182 end Add_Call_By_Copy_Code
;
1184 ----------------------------------
1185 -- Add_Simple_Call_By_Copy_Code --
1186 ----------------------------------
1188 procedure Add_Simple_Call_By_Copy_Code
is
1196 F_Typ
: constant Entity_Id
:= Etype
(Formal
);
1199 if not Is_Legal_Copy
then
1203 -- Use formal type for temp, unless formal type is an unconstrained
1204 -- array, in which case we don't have to worry about bounds checks,
1205 -- and we use the actual type, since that has appropriate bounds.
1207 if Is_Array_Type
(F_Typ
) and then not Is_Constrained
(F_Typ
) then
1208 Indic
:= New_Occurrence_Of
(Etype
(Actual
), Loc
);
1210 Indic
:= New_Occurrence_Of
(Etype
(Formal
), Loc
);
1213 -- Prepare to generate code
1215 Reset_Packed_Prefix
;
1218 Make_Defining_Identifier
(Loc
,
1219 Chars
=> New_Internal_Name
('T'));
1220 Incod
:= Relocate_Node
(Actual
);
1221 Outcod
:= New_Copy_Tree
(Incod
);
1223 -- Generate declaration of temporary variable, initializing it
1224 -- with the input parameter unless we have an OUT formal or
1225 -- this is an initialization call.
1227 -- If the formal is an out parameter with discriminants, the
1228 -- discriminants must be captured even if the rest of the object
1229 -- is in principle uninitialized, because the discriminants may
1230 -- be read by the called subprogram.
1232 if Ekind
(Formal
) = E_Out_Parameter
then
1235 if Has_Discriminants
(Etype
(Formal
)) then
1236 Indic
:= New_Occurrence_Of
(Etype
(Actual
), Loc
);
1239 elsif Inside_Init_Proc
then
1241 -- Could use a comment here to match comment below ???
1243 if Nkind
(Actual
) /= N_Selected_Component
1245 not Has_Discriminant_Dependent_Constraint
1246 (Entity
(Selector_Name
(Actual
)))
1250 -- Otherwise, keep the component in order to generate the proper
1251 -- actual subtype, that depends on enclosing discriminants.
1259 Make_Object_Declaration
(Loc
,
1260 Defining_Identifier
=> Temp
,
1261 Object_Definition
=> Indic
,
1262 Expression
=> Incod
);
1267 -- If the call is to initialize a component of a composite type,
1268 -- and the component does not depend on discriminants, use the
1269 -- actual type of the component. This is required in case the
1270 -- component is constrained, because in general the formal of the
1271 -- initialization procedure will be unconstrained. Note that if
1272 -- the component being initialized is constrained by an enclosing
1273 -- discriminant, the presence of the initialization in the
1274 -- declaration will generate an expression for the actual subtype.
1276 Set_No_Initialization
(Decl
);
1277 Set_Object_Definition
(Decl
,
1278 New_Occurrence_Of
(Etype
(Actual
), Loc
));
1281 Insert_Action
(N
, Decl
);
1283 -- The actual is simply a reference to the temporary
1285 Rewrite
(Actual
, New_Occurrence_Of
(Temp
, Loc
));
1287 -- Generate copy out if OUT or IN OUT parameter
1289 if Ekind
(Formal
) /= E_In_Parameter
then
1291 Rhs
:= New_Occurrence_Of
(Temp
, Loc
);
1293 -- Deal with conversion
1295 if Nkind
(Lhs
) = N_Type_Conversion
then
1296 Lhs
:= Expression
(Lhs
);
1297 Rhs
:= Convert_To
(Etype
(Actual
), Rhs
);
1300 Append_To
(Post_Call
,
1301 Make_Assignment_Statement
(Loc
,
1303 Expression
=> Rhs
));
1304 Set_Assignment_OK
(Name
(Last
(Post_Call
)));
1306 end Add_Simple_Call_By_Copy_Code
;
1308 ---------------------------
1309 -- Check_Fortran_Logical --
1310 ---------------------------
1312 procedure Check_Fortran_Logical
is
1313 Logical
: constant Entity_Id
:= Etype
(Formal
);
1316 -- Note: this is very incomplete, e.g. it does not handle arrays
1317 -- of logical values. This is really not the right approach at all???)
1320 if Convention
(Subp
) = Convention_Fortran
1321 and then Root_Type
(Etype
(Formal
)) = Standard_Boolean
1322 and then Ekind
(Formal
) /= E_In_Parameter
1324 Var
:= Make_Var
(Actual
);
1325 Append_To
(Post_Call
,
1326 Make_Assignment_Statement
(Loc
,
1327 Name
=> New_Occurrence_Of
(Var
, Loc
),
1329 Unchecked_Convert_To
(
1332 Left_Opnd
=> New_Occurrence_Of
(Var
, Loc
),
1334 Unchecked_Convert_To
(
1336 New_Occurrence_Of
(Standard_False
, Loc
))))));
1338 end Check_Fortran_Logical
;
1344 function Is_Legal_Copy
return Boolean is
1346 -- An attempt to copy a value of such a type can only occur if
1347 -- representation clauses give the actual a misaligned address.
1349 if Is_By_Reference_Type
(Etype
(Formal
)) then
1351 ("misaligned actual cannot be passed by reference", Actual
);
1354 -- For users of Starlet, we assume that the specification of by-
1355 -- reference mechanism is mandatory. This may lead to unaligned
1356 -- objects but at least for DEC legacy code it is known to work.
1357 -- The warning will alert users of this code that a problem may
1360 elsif Mechanism
(Formal
) = By_Reference
1361 and then Is_Valued_Procedure
(Scope
(Formal
))
1364 ("by_reference actual may be misaligned?", Actual
);
1376 function Make_Var
(Actual
: Node_Id
) return Entity_Id
is
1380 if Is_Entity_Name
(Actual
) then
1381 return Entity
(Actual
);
1385 Make_Defining_Identifier
(Loc
,
1386 Chars
=> New_Internal_Name
('T'));
1389 Make_Object_Renaming_Declaration
(Loc
,
1390 Defining_Identifier
=> Var
,
1392 New_Occurrence_Of
(Etype
(Actual
), Loc
),
1393 Name
=> Relocate_Node
(Actual
));
1395 Insert_Action
(N
, N_Node
);
1400 -------------------------
1401 -- Reset_Packed_Prefix --
1402 -------------------------
1404 procedure Reset_Packed_Prefix
is
1405 Pfx
: Node_Id
:= Actual
;
1408 Set_Analyzed
(Pfx
, False);
1410 not Nkind_In
(Pfx
, N_Selected_Component
, N_Indexed_Component
);
1411 Pfx
:= Prefix
(Pfx
);
1413 end Reset_Packed_Prefix
;
1415 -- Start of processing for Expand_Actuals
1418 Post_Call
:= New_List
;
1420 Formal
:= First_Formal
(Subp
);
1421 Actual
:= First_Actual
(N
);
1422 while Present
(Formal
) loop
1423 E_Formal
:= Etype
(Formal
);
1425 if Is_Scalar_Type
(E_Formal
)
1426 or else Nkind
(Actual
) = N_Slice
1428 Check_Fortran_Logical
;
1432 elsif Ekind
(Formal
) /= E_Out_Parameter
then
1434 -- The unusual case of the current instance of a protected type
1435 -- requires special handling. This can only occur in the context
1436 -- of a call within the body of a protected operation.
1438 if Is_Entity_Name
(Actual
)
1439 and then Ekind
(Entity
(Actual
)) = E_Protected_Type
1440 and then In_Open_Scopes
(Entity
(Actual
))
1442 if Scope
(Subp
) /= Entity
(Actual
) then
1443 Error_Msg_N
("operation outside protected type may not "
1444 & "call back its protected operations?", Actual
);
1448 Expand_Protected_Object_Reference
(N
, Entity
(Actual
)));
1451 -- Ada 2005 (AI-318-02): If the actual parameter is a call to a
1452 -- build-in-place function, then a temporary return object needs
1453 -- to be created and access to it must be passed to the function.
1454 -- Currently we limit such functions to those with inherently
1455 -- limited result subtypes, but eventually we plan to expand the
1456 -- functions that are treated as build-in-place to include other
1457 -- composite result types.
1459 if Ada_Version
>= Ada_05
1460 and then Is_Build_In_Place_Function_Call
(Actual
)
1462 Make_Build_In_Place_Call_In_Anonymous_Context
(Actual
);
1465 Apply_Constraint_Check
(Actual
, E_Formal
);
1467 -- Out parameter case. No constraint checks on access type
1470 elsif Is_Access_Type
(E_Formal
) then
1475 elsif Has_Discriminants
(Base_Type
(E_Formal
))
1476 or else Has_Non_Null_Base_Init_Proc
(E_Formal
)
1478 Apply_Constraint_Check
(Actual
, E_Formal
);
1483 Apply_Constraint_Check
(Actual
, Base_Type
(E_Formal
));
1486 -- Processing for IN-OUT and OUT parameters
1488 if Ekind
(Formal
) /= E_In_Parameter
then
1490 -- For type conversions of arrays, apply length/range checks
1492 if Is_Array_Type
(E_Formal
)
1493 and then Nkind
(Actual
) = N_Type_Conversion
1495 if Is_Constrained
(E_Formal
) then
1496 Apply_Length_Check
(Expression
(Actual
), E_Formal
);
1498 Apply_Range_Check
(Expression
(Actual
), E_Formal
);
1502 -- If argument is a type conversion for a type that is passed
1503 -- by copy, then we must pass the parameter by copy.
1505 if Nkind
(Actual
) = N_Type_Conversion
1507 (Is_Numeric_Type
(E_Formal
)
1508 or else Is_Access_Type
(E_Formal
)
1509 or else Is_Enumeration_Type
(E_Formal
)
1510 or else Is_Bit_Packed_Array
(Etype
(Formal
))
1511 or else Is_Bit_Packed_Array
(Etype
(Expression
(Actual
)))
1513 -- Also pass by copy if change of representation
1515 or else not Same_Representation
1517 Etype
(Expression
(Actual
))))
1519 Add_Call_By_Copy_Code
;
1521 -- References to components of bit packed arrays are expanded
1522 -- at this point, rather than at the point of analysis of the
1523 -- actuals, to handle the expansion of the assignment to
1524 -- [in] out parameters.
1526 elsif Is_Ref_To_Bit_Packed_Array
(Actual
) then
1527 Add_Simple_Call_By_Copy_Code
;
1529 -- If a non-scalar actual is possibly bit-aligned, we need a copy
1530 -- because the back-end cannot cope with such objects. In other
1531 -- cases where alignment forces a copy, the back-end generates
1532 -- it properly. It should not be generated unconditionally in the
1533 -- front-end because it does not know precisely the alignment
1534 -- requirements of the target, and makes too conservative an
1535 -- estimate, leading to superfluous copies or spurious errors
1536 -- on by-reference parameters.
1538 elsif Nkind
(Actual
) = N_Selected_Component
1540 Component_May_Be_Bit_Aligned
(Entity
(Selector_Name
(Actual
)))
1541 and then not Represented_As_Scalar
(Etype
(Formal
))
1543 Add_Simple_Call_By_Copy_Code
;
1545 -- References to slices of bit packed arrays are expanded
1547 elsif Is_Ref_To_Bit_Packed_Slice
(Actual
) then
1548 Add_Call_By_Copy_Code
;
1550 -- References to possibly unaligned slices of arrays are expanded
1552 elsif Is_Possibly_Unaligned_Slice
(Actual
) then
1553 Add_Call_By_Copy_Code
;
1555 -- Deal with access types where the actual subtype and the
1556 -- formal subtype are not the same, requiring a check.
1558 -- It is necessary to exclude tagged types because of "downward
1559 -- conversion" errors.
1561 elsif Is_Access_Type
(E_Formal
)
1562 and then not Same_Type
(E_Formal
, Etype
(Actual
))
1563 and then not Is_Tagged_Type
(Designated_Type
(E_Formal
))
1565 Add_Call_By_Copy_Code
;
1567 -- If the actual is not a scalar and is marked for volatile
1568 -- treatment, whereas the formal is not volatile, then pass
1569 -- by copy unless it is a by-reference type.
1571 elsif Is_Entity_Name
(Actual
)
1572 and then Treat_As_Volatile
(Entity
(Actual
))
1573 and then not Is_By_Reference_Type
(Etype
(Actual
))
1574 and then not Is_Scalar_Type
(Etype
(Entity
(Actual
)))
1575 and then not Treat_As_Volatile
(E_Formal
)
1577 Add_Call_By_Copy_Code
;
1579 elsif Nkind
(Actual
) = N_Indexed_Component
1580 and then Is_Entity_Name
(Prefix
(Actual
))
1581 and then Has_Volatile_Components
(Entity
(Prefix
(Actual
)))
1583 Add_Call_By_Copy_Code
;
1586 -- Processing for IN parameters
1589 -- For IN parameters is in the packed array case, we expand an
1590 -- indexed component (the circuit in Exp_Ch4 deliberately left
1591 -- indexed components appearing as actuals untouched, so that
1592 -- the special processing above for the OUT and IN OUT cases
1593 -- could be performed. We could make the test in Exp_Ch4 more
1594 -- complex and have it detect the parameter mode, but it is
1595 -- easier simply to handle all cases here.)
1597 if Nkind
(Actual
) = N_Indexed_Component
1598 and then Is_Packed
(Etype
(Prefix
(Actual
)))
1600 Reset_Packed_Prefix
;
1601 Expand_Packed_Element_Reference
(Actual
);
1603 -- If we have a reference to a bit packed array, we copy it,
1604 -- since the actual must be byte aligned.
1606 -- Is this really necessary in all cases???
1608 elsif Is_Ref_To_Bit_Packed_Array
(Actual
) then
1609 Add_Simple_Call_By_Copy_Code
;
1611 -- If a non-scalar actual is possibly unaligned, we need a copy
1613 elsif Is_Possibly_Unaligned_Object
(Actual
)
1614 and then not Represented_As_Scalar
(Etype
(Formal
))
1616 Add_Simple_Call_By_Copy_Code
;
1618 -- Similarly, we have to expand slices of packed arrays here
1619 -- because the result must be byte aligned.
1621 elsif Is_Ref_To_Bit_Packed_Slice
(Actual
) then
1622 Add_Call_By_Copy_Code
;
1624 -- Only processing remaining is to pass by copy if this is a
1625 -- reference to a possibly unaligned slice, since the caller
1626 -- expects an appropriately aligned argument.
1628 elsif Is_Possibly_Unaligned_Slice
(Actual
) then
1629 Add_Call_By_Copy_Code
;
1633 Next_Formal
(Formal
);
1634 Next_Actual
(Actual
);
1637 -- Find right place to put post call stuff if it is present
1639 if not Is_Empty_List
(Post_Call
) then
1641 -- If call is not a list member, it must be the triggering statement
1642 -- of a triggering alternative or an entry call alternative, and we
1643 -- can add the post call stuff to the corresponding statement list.
1645 if not Is_List_Member
(N
) then
1647 P
: constant Node_Id
:= Parent
(N
);
1650 pragma Assert
(Nkind_In
(P
, N_Triggering_Alternative
,
1651 N_Entry_Call_Alternative
));
1653 if Is_Non_Empty_List
(Statements
(P
)) then
1654 Insert_List_Before_And_Analyze
1655 (First
(Statements
(P
)), Post_Call
);
1657 Set_Statements
(P
, Post_Call
);
1661 -- Otherwise, normal case where N is in a statement sequence,
1662 -- just put the post-call stuff after the call statement.
1665 Insert_Actions_After
(N
, Post_Call
);
1669 -- The call node itself is re-analyzed in Expand_Call
1677 -- This procedure handles expansion of function calls and procedure call
1678 -- statements (i.e. it serves as the body for Expand_N_Function_Call and
1679 -- Expand_N_Procedure_Call_Statement). Processing for calls includes:
1681 -- Replace call to Raise_Exception by Raise_Exception_Always if possible
1682 -- Provide values of actuals for all formals in Extra_Formals list
1683 -- Replace "call" to enumeration literal function by literal itself
1684 -- Rewrite call to predefined operator as operator
1685 -- Replace actuals to in-out parameters that are numeric conversions,
1686 -- with explicit assignment to temporaries before and after the call.
1687 -- Remove optional actuals if First_Optional_Parameter specified.
1689 -- Note that the list of actuals has been filled with default expressions
1690 -- during semantic analysis of the call. Only the extra actuals required
1691 -- for the 'Constrained attribute and for accessibility checks are added
1694 procedure Expand_Call
(N
: Node_Id
) is
1695 Loc
: constant Source_Ptr
:= Sloc
(N
);
1696 Extra_Actuals
: List_Id
:= No_List
;
1697 Prev
: Node_Id
:= Empty
;
1699 procedure Add_Actual_Parameter
(Insert_Param
: Node_Id
);
1700 -- Adds one entry to the end of the actual parameter list. Used for
1701 -- default parameters and for extra actuals (for Extra_Formals). The
1702 -- argument is an N_Parameter_Association node.
1704 procedure Add_Extra_Actual
(Expr
: Node_Id
; EF
: Entity_Id
);
1705 -- Adds an extra actual to the list of extra actuals. Expr is the
1706 -- expression for the value of the actual, EF is the entity for the
1709 function Inherited_From_Formal
(S
: Entity_Id
) return Entity_Id
;
1710 -- Within an instance, a type derived from a non-tagged formal derived
1711 -- type inherits from the original parent, not from the actual. The
1712 -- current derivation mechanism has the derived type inherit from the
1713 -- actual, which is only correct outside of the instance. If the
1714 -- subprogram is inherited, we test for this particular case through a
1715 -- convoluted tree traversal before setting the proper subprogram to be
1718 --------------------------
1719 -- Add_Actual_Parameter --
1720 --------------------------
1722 procedure Add_Actual_Parameter
(Insert_Param
: Node_Id
) is
1723 Actual_Expr
: constant Node_Id
:=
1724 Explicit_Actual_Parameter
(Insert_Param
);
1727 -- Case of insertion is first named actual
1729 if No
(Prev
) or else
1730 Nkind
(Parent
(Prev
)) /= N_Parameter_Association
1732 Set_Next_Named_Actual
(Insert_Param
, First_Named_Actual
(N
));
1733 Set_First_Named_Actual
(N
, Actual_Expr
);
1736 if No
(Parameter_Associations
(N
)) then
1737 Set_Parameter_Associations
(N
, New_List
);
1738 Append
(Insert_Param
, Parameter_Associations
(N
));
1741 Insert_After
(Prev
, Insert_Param
);
1744 -- Case of insertion is not first named actual
1747 Set_Next_Named_Actual
1748 (Insert_Param
, Next_Named_Actual
(Parent
(Prev
)));
1749 Set_Next_Named_Actual
(Parent
(Prev
), Actual_Expr
);
1750 Append
(Insert_Param
, Parameter_Associations
(N
));
1753 Prev
:= Actual_Expr
;
1754 end Add_Actual_Parameter
;
1756 ----------------------
1757 -- Add_Extra_Actual --
1758 ----------------------
1760 procedure Add_Extra_Actual
(Expr
: Node_Id
; EF
: Entity_Id
) is
1761 Loc
: constant Source_Ptr
:= Sloc
(Expr
);
1764 if Extra_Actuals
= No_List
then
1765 Extra_Actuals
:= New_List
;
1766 Set_Parent
(Extra_Actuals
, N
);
1769 Append_To
(Extra_Actuals
,
1770 Make_Parameter_Association
(Loc
,
1771 Explicit_Actual_Parameter
=> Expr
,
1773 Make_Identifier
(Loc
, Chars
(EF
))));
1775 Analyze_And_Resolve
(Expr
, Etype
(EF
));
1776 end Add_Extra_Actual
;
1778 ---------------------------
1779 -- Inherited_From_Formal --
1780 ---------------------------
1782 function Inherited_From_Formal
(S
: Entity_Id
) return Entity_Id
is
1784 Gen_Par
: Entity_Id
;
1785 Gen_Prim
: Elist_Id
;
1790 -- If the operation is inherited, it is attached to the corresponding
1791 -- type derivation. If the parent in the derivation is a generic
1792 -- actual, it is a subtype of the actual, and we have to recover the
1793 -- original derived type declaration to find the proper parent.
1795 if Nkind
(Parent
(S
)) /= N_Full_Type_Declaration
1796 or else not Is_Derived_Type
(Defining_Identifier
(Parent
(S
)))
1797 or else Nkind
(Type_Definition
(Original_Node
(Parent
(S
)))) /=
1798 N_Derived_Type_Definition
1799 or else not In_Instance
1806 (Type_Definition
(Original_Node
(Parent
(S
)))));
1808 if Nkind
(Indic
) = N_Subtype_Indication
then
1809 Par
:= Entity
(Subtype_Mark
(Indic
));
1811 Par
:= Entity
(Indic
);
1815 if not Is_Generic_Actual_Type
(Par
)
1816 or else Is_Tagged_Type
(Par
)
1817 or else Nkind
(Parent
(Par
)) /= N_Subtype_Declaration
1818 or else not In_Open_Scopes
(Scope
(Par
))
1823 Gen_Par
:= Generic_Parent_Type
(Parent
(Par
));
1826 -- If the actual has no generic parent type, the formal is not
1827 -- a formal derived type, so nothing to inherit.
1829 if No
(Gen_Par
) then
1833 -- If the generic parent type is still the generic type, this is a
1834 -- private formal, not a derived formal, and there are no operations
1835 -- inherited from the formal.
1837 if Nkind
(Parent
(Gen_Par
)) = N_Formal_Type_Declaration
then
1841 Gen_Prim
:= Collect_Primitive_Operations
(Gen_Par
);
1843 Elmt
:= First_Elmt
(Gen_Prim
);
1844 while Present
(Elmt
) loop
1845 if Chars
(Node
(Elmt
)) = Chars
(S
) then
1851 F1
:= First_Formal
(S
);
1852 F2
:= First_Formal
(Node
(Elmt
));
1854 and then Present
(F2
)
1856 if Etype
(F1
) = Etype
(F2
)
1857 or else Etype
(F2
) = Gen_Par
1863 exit; -- not the right subprogram
1875 raise Program_Error
;
1876 end Inherited_From_Formal
;
1880 Remote
: constant Boolean := Is_Remote_Call
(N
);
1883 Orig_Subp
: Entity_Id
:= Empty
;
1884 Param_Count
: Natural := 0;
1885 Parent_Formal
: Entity_Id
;
1886 Parent_Subp
: Entity_Id
;
1890 Prev_Orig
: Node_Id
;
1891 -- Original node for an actual, which may have been rewritten. If the
1892 -- actual is a function call that has been transformed from a selected
1893 -- component, the original node is unanalyzed. Otherwise, it carries
1894 -- semantic information used to generate additional actuals.
1896 CW_Interface_Formals_Present
: Boolean := False;
1898 -- Start of processing for Expand_Call
1901 -- Ignore if previous error
1903 if Nkind
(N
) in N_Has_Etype
and then Etype
(N
) = Any_Type
then
1907 -- Call using access to subprogram with explicit dereference
1909 if Nkind
(Name
(N
)) = N_Explicit_Dereference
then
1910 Subp
:= Etype
(Name
(N
));
1911 Parent_Subp
:= Empty
;
1913 -- Case of call to simple entry, where the Name is a selected component
1914 -- whose prefix is the task, and whose selector name is the entry name
1916 elsif Nkind
(Name
(N
)) = N_Selected_Component
then
1917 Subp
:= Entity
(Selector_Name
(Name
(N
)));
1918 Parent_Subp
:= Empty
;
1920 -- Case of call to member of entry family, where Name is an indexed
1921 -- component, with the prefix being a selected component giving the
1922 -- task and entry family name, and the index being the entry index.
1924 elsif Nkind
(Name
(N
)) = N_Indexed_Component
then
1925 Subp
:= Entity
(Selector_Name
(Prefix
(Name
(N
))));
1926 Parent_Subp
:= Empty
;
1931 Subp
:= Entity
(Name
(N
));
1932 Parent_Subp
:= Alias
(Subp
);
1934 -- Replace call to Raise_Exception by call to Raise_Exception_Always
1935 -- if we can tell that the first parameter cannot possibly be null.
1936 -- This improves efficiency by avoiding a run-time test.
1938 -- We do not do this if Raise_Exception_Always does not exist, which
1939 -- can happen in configurable run time profiles which provide only a
1942 if Is_RTE
(Subp
, RE_Raise_Exception
)
1943 and then RTE_Available
(RE_Raise_Exception_Always
)
1946 FA
: constant Node_Id
:= Original_Node
(First_Actual
(N
));
1949 -- The case we catch is where the first argument is obtained
1950 -- using the Identity attribute (which must always be
1953 if Nkind
(FA
) = N_Attribute_Reference
1954 and then Attribute_Name
(FA
) = Name_Identity
1956 Subp
:= RTE
(RE_Raise_Exception_Always
);
1957 Set_Name
(N
, New_Occurrence_Of
(Subp
, Loc
));
1962 if Ekind
(Subp
) = E_Entry
then
1963 Parent_Subp
:= Empty
;
1967 -- Ada 2005 (AI-345): We have a procedure call as a triggering
1968 -- alternative in an asynchronous select or as an entry call in
1969 -- a conditional or timed select. Check whether the procedure call
1970 -- is a renaming of an entry and rewrite it as an entry call.
1972 if Ada_Version
>= Ada_05
1973 and then Nkind
(N
) = N_Procedure_Call_Statement
1975 ((Nkind
(Parent
(N
)) = N_Triggering_Alternative
1976 and then Triggering_Statement
(Parent
(N
)) = N
)
1978 (Nkind
(Parent
(N
)) = N_Entry_Call_Alternative
1979 and then Entry_Call_Statement
(Parent
(N
)) = N
))
1983 Ren_Root
: Entity_Id
:= Subp
;
1986 -- This may be a chain of renamings, find the root
1988 if Present
(Alias
(Ren_Root
)) then
1989 Ren_Root
:= Alias
(Ren_Root
);
1992 if Present
(Original_Node
(Parent
(Parent
(Ren_Root
)))) then
1993 Ren_Decl
:= Original_Node
(Parent
(Parent
(Ren_Root
)));
1995 if Nkind
(Ren_Decl
) = N_Subprogram_Renaming_Declaration
then
1997 Make_Entry_Call_Statement
(Loc
,
1999 New_Copy_Tree
(Name
(Ren_Decl
)),
2000 Parameter_Associations
=>
2001 New_Copy_List_Tree
(Parameter_Associations
(N
))));
2009 -- First step, compute extra actuals, corresponding to any
2010 -- Extra_Formals present. Note that we do not access Extra_Formals
2011 -- directly, instead we simply note the presence of the extra
2012 -- formals as we process the regular formals and collect the
2013 -- corresponding actuals in Extra_Actuals.
2015 -- We also generate any required range checks for actuals as we go
2016 -- through the loop, since this is a convenient place to do this.
2018 Formal
:= First_Formal
(Subp
);
2019 Actual
:= First_Actual
(N
);
2021 while Present
(Formal
) loop
2023 -- Generate range check if required (not activated yet ???)
2025 -- if Do_Range_Check (Actual) then
2026 -- Set_Do_Range_Check (Actual, False);
2027 -- Generate_Range_Check
2028 -- (Actual, Etype (Formal), CE_Range_Check_Failed);
2031 -- Prepare to examine current entry
2034 Prev_Orig
:= Original_Node
(Prev
);
2036 -- Ada 2005 (AI-251): Check if any formal is a class-wide interface
2037 -- to expand it in a further round.
2039 CW_Interface_Formals_Present
:=
2040 CW_Interface_Formals_Present
2042 (Ekind
(Etype
(Formal
)) = E_Class_Wide_Type
2043 and then Is_Interface
(Etype
(Etype
(Formal
))))
2045 (Ekind
(Etype
(Formal
)) = E_Anonymous_Access_Type
2046 and then Is_Interface
(Directly_Designated_Type
2047 (Etype
(Etype
(Formal
)))));
2049 -- Create possible extra actual for constrained case. Usually, the
2050 -- extra actual is of the form actual'constrained, but since this
2051 -- attribute is only available for unconstrained records, TRUE is
2052 -- expanded if the type of the formal happens to be constrained (for
2053 -- instance when this procedure is inherited from an unconstrained
2054 -- record to a constrained one) or if the actual has no discriminant
2055 -- (its type is constrained). An exception to this is the case of a
2056 -- private type without discriminants. In this case we pass FALSE
2057 -- because the object has underlying discriminants with defaults.
2059 if Present
(Extra_Constrained
(Formal
)) then
2060 if Ekind
(Etype
(Prev
)) in Private_Kind
2061 and then not Has_Discriminants
(Base_Type
(Etype
(Prev
)))
2064 (New_Occurrence_Of
(Standard_False
, Loc
),
2065 Extra_Constrained
(Formal
));
2067 elsif Is_Constrained
(Etype
(Formal
))
2068 or else not Has_Discriminants
(Etype
(Prev
))
2071 (New_Occurrence_Of
(Standard_True
, Loc
),
2072 Extra_Constrained
(Formal
));
2074 -- Do not produce extra actuals for Unchecked_Union parameters.
2075 -- Jump directly to the end of the loop.
2077 elsif Is_Unchecked_Union
(Base_Type
(Etype
(Actual
))) then
2078 goto Skip_Extra_Actual_Generation
;
2081 -- If the actual is a type conversion, then the constrained
2082 -- test applies to the actual, not the target type.
2088 -- Test for unchecked conversions as well, which can occur
2089 -- as out parameter actuals on calls to stream procedures.
2092 while Nkind_In
(Act_Prev
, N_Type_Conversion
,
2093 N_Unchecked_Type_Conversion
)
2095 Act_Prev
:= Expression
(Act_Prev
);
2098 -- If the expression is a conversion of a dereference,
2099 -- this is internally generated code that manipulates
2100 -- addresses, e.g. when building interface tables. No
2101 -- check should occur in this case, and the discriminated
2102 -- object is not directly a hand.
2104 if not Comes_From_Source
(Actual
)
2105 and then Nkind
(Actual
) = N_Unchecked_Type_Conversion
2106 and then Nkind
(Act_Prev
) = N_Explicit_Dereference
2109 (New_Occurrence_Of
(Standard_False
, Loc
),
2110 Extra_Constrained
(Formal
));
2114 (Make_Attribute_Reference
(Sloc
(Prev
),
2116 Duplicate_Subexpr_No_Checks
2117 (Act_Prev
, Name_Req
=> True),
2118 Attribute_Name
=> Name_Constrained
),
2119 Extra_Constrained
(Formal
));
2125 -- Create possible extra actual for accessibility level
2127 if Present
(Extra_Accessibility
(Formal
)) then
2129 -- Ada 2005 (AI-252): If the actual was rewritten as an Access
2130 -- attribute, then the original actual may be an aliased object
2131 -- occurring as the prefix in a call using "Object.Operation"
2132 -- notation. In that case we must pass the level of the object,
2133 -- so Prev_Orig is reset to Prev and the attribute will be
2134 -- processed by the code for Access attributes further below.
2136 if Prev_Orig
/= Prev
2137 and then Nkind
(Prev
) = N_Attribute_Reference
2139 Get_Attribute_Id
(Attribute_Name
(Prev
)) = Attribute_Access
2140 and then Is_Aliased_View
(Prev_Orig
)
2145 -- Ada 2005 (AI-251): Thunks must propagate the extra actuals
2146 -- of accessibility levels.
2148 if Ekind
(Current_Scope
) in Subprogram_Kind
2149 and then Is_Thunk
(Current_Scope
)
2152 Parm_Ent
: Entity_Id
;
2155 if Is_Controlling_Actual
(Actual
) then
2157 -- Find the corresponding actual of the thunk
2159 Parm_Ent
:= First_Entity
(Current_Scope
);
2160 for J
in 2 .. Param_Count
loop
2161 Next_Entity
(Parm_Ent
);
2164 else pragma Assert
(Is_Entity_Name
(Actual
));
2165 Parm_Ent
:= Entity
(Actual
);
2169 (New_Occurrence_Of
(Extra_Accessibility
(Parm_Ent
), Loc
),
2170 Extra_Accessibility
(Formal
));
2173 elsif Is_Entity_Name
(Prev_Orig
) then
2175 -- When passing an access parameter, or a renaming of an access
2176 -- parameter, as the actual to another access parameter we need
2177 -- to pass along the actual's own access level parameter. This
2178 -- is done if we are within the scope of the formal access
2179 -- parameter (if this is an inlined body the extra formal is
2182 if (Is_Formal
(Entity
(Prev_Orig
))
2184 (Present
(Renamed_Object
(Entity
(Prev_Orig
)))
2186 Is_Entity_Name
(Renamed_Object
(Entity
(Prev_Orig
)))
2189 (Entity
(Renamed_Object
(Entity
(Prev_Orig
))))))
2190 and then Ekind
(Etype
(Prev_Orig
)) = E_Anonymous_Access_Type
2191 and then In_Open_Scopes
(Scope
(Entity
(Prev_Orig
)))
2194 Parm_Ent
: constant Entity_Id
:= Param_Entity
(Prev_Orig
);
2197 pragma Assert
(Present
(Parm_Ent
));
2199 if Present
(Extra_Accessibility
(Parm_Ent
)) then
2202 (Extra_Accessibility
(Parm_Ent
), Loc
),
2203 Extra_Accessibility
(Formal
));
2205 -- If the actual access parameter does not have an
2206 -- associated extra formal providing its scope level,
2207 -- then treat the actual as having library-level
2212 (Make_Integer_Literal
(Loc
,
2213 Intval
=> Scope_Depth
(Standard_Standard
)),
2214 Extra_Accessibility
(Formal
));
2218 -- The actual is a normal access value, so just pass the level
2219 -- of the actual's access type.
2223 (Make_Integer_Literal
(Loc
,
2224 Intval
=> Type_Access_Level
(Etype
(Prev_Orig
))),
2225 Extra_Accessibility
(Formal
));
2228 -- If the actual is an access discriminant, then pass the level
2229 -- of the enclosing object (RM05-3.10.2(12.4/2)).
2231 elsif Nkind
(Prev_Orig
) = N_Selected_Component
2232 and then Ekind
(Entity
(Selector_Name
(Prev_Orig
))) =
2234 and then Ekind
(Etype
(Entity
(Selector_Name
(Prev_Orig
)))) =
2235 E_Anonymous_Access_Type
2238 (Make_Integer_Literal
(Loc
,
2239 Intval
=> Object_Access_Level
(Prefix
(Prev_Orig
))),
2240 Extra_Accessibility
(Formal
));
2245 case Nkind
(Prev_Orig
) is
2247 when N_Attribute_Reference
=>
2248 case Get_Attribute_Id
(Attribute_Name
(Prev_Orig
)) is
2250 -- For X'Access, pass on the level of the prefix X
2252 when Attribute_Access
=>
2254 (Make_Integer_Literal
(Loc
,
2256 Object_Access_Level
(Prefix
(Prev_Orig
))),
2257 Extra_Accessibility
(Formal
));
2259 -- Treat the unchecked attributes as library-level
2261 when Attribute_Unchecked_Access |
2262 Attribute_Unrestricted_Access
=>
2264 (Make_Integer_Literal
(Loc
,
2265 Intval
=> Scope_Depth
(Standard_Standard
)),
2266 Extra_Accessibility
(Formal
));
2268 -- No other cases of attributes returning access
2269 -- values that can be passed to access parameters
2272 raise Program_Error
;
2276 -- For allocators we pass the level of the execution of
2277 -- the called subprogram, which is one greater than the
2278 -- current scope level.
2282 (Make_Integer_Literal
(Loc
,
2283 Intval
=> Scope_Depth
(Current_Scope
) + 1),
2284 Extra_Accessibility
(Formal
));
2286 -- For other cases we simply pass the level of the actual's
2287 -- access type. The type is retrieved from Prev rather than
2288 -- Prev_Orig, because in some cases Prev_Orig denotes an
2289 -- original expression that has not been analyzed.
2293 (Make_Integer_Literal
(Loc
,
2294 Intval
=> Type_Access_Level
(Etype
(Prev
))),
2295 Extra_Accessibility
(Formal
));
2301 -- Perform the check of 4.6(49) that prevents a null value from being
2302 -- passed as an actual to an access parameter. Note that the check is
2303 -- elided in the common cases of passing an access attribute or
2304 -- access parameter as an actual. Also, we currently don't enforce
2305 -- this check for expander-generated actuals and when -gnatdj is set.
2307 if Ada_Version
>= Ada_05
then
2309 -- Ada 2005 (AI-231): Check null-excluding access types
2311 if Is_Access_Type
(Etype
(Formal
))
2312 and then Can_Never_Be_Null
(Etype
(Formal
))
2313 and then Nkind
(Prev
) /= N_Raise_Constraint_Error
2314 and then (Known_Null
(Prev
)
2315 or else not Can_Never_Be_Null
(Etype
(Prev
)))
2317 Install_Null_Excluding_Check
(Prev
);
2320 -- Ada_Version < Ada_05
2323 if Ekind
(Etype
(Formal
)) /= E_Anonymous_Access_Type
2324 or else Access_Checks_Suppressed
(Subp
)
2328 elsif Debug_Flag_J
then
2331 elsif not Comes_From_Source
(Prev
) then
2334 elsif Is_Entity_Name
(Prev
)
2335 and then Ekind
(Etype
(Prev
)) = E_Anonymous_Access_Type
2339 elsif Nkind_In
(Prev
, N_Allocator
, N_Attribute_Reference
) then
2342 -- Suppress null checks when passing to access parameters of Java
2343 -- and CIL subprograms. (Should this be done for other foreign
2344 -- conventions as well ???)
2346 elsif Convention
(Subp
) = Convention_Java
2347 or else Convention
(Subp
) = Convention_CIL
2352 Install_Null_Excluding_Check
(Prev
);
2356 -- Perform appropriate validity checks on parameters that
2359 if Validity_Checks_On
then
2360 if (Ekind
(Formal
) = E_In_Parameter
2361 and then Validity_Check_In_Params
)
2363 (Ekind
(Formal
) = E_In_Out_Parameter
2364 and then Validity_Check_In_Out_Params
)
2366 -- If the actual is an indexed component of a packed type (or
2367 -- is an indexed or selected component whose prefix recursively
2368 -- meets this condition), it has not been expanded yet. It will
2369 -- be copied in the validity code that follows, and has to be
2370 -- expanded appropriately, so reanalyze it.
2372 -- What we do is just to unset analyzed bits on prefixes till
2373 -- we reach something that does not have a prefix.
2380 while Nkind_In
(Nod
, N_Indexed_Component
,
2381 N_Selected_Component
)
2383 Set_Analyzed
(Nod
, False);
2384 Nod
:= Prefix
(Nod
);
2388 Ensure_Valid
(Actual
);
2392 -- For IN OUT and OUT parameters, ensure that subscripts are valid
2393 -- since this is a left side reference. We only do this for calls
2394 -- from the source program since we assume that compiler generated
2395 -- calls explicitly generate any required checks. We also need it
2396 -- only if we are doing standard validity checks, since clearly it
2397 -- is not needed if validity checks are off, and in subscript
2398 -- validity checking mode, all indexed components are checked with
2399 -- a call directly from Expand_N_Indexed_Component.
2401 if Comes_From_Source
(N
)
2402 and then Ekind
(Formal
) /= E_In_Parameter
2403 and then Validity_Checks_On
2404 and then Validity_Check_Default
2405 and then not Validity_Check_Subscripts
2407 Check_Valid_Lvalue_Subscripts
(Actual
);
2410 -- Mark any scalar OUT parameter that is a simple variable as no
2411 -- longer known to be valid (unless the type is always valid). This
2412 -- reflects the fact that if an OUT parameter is never set in a
2413 -- procedure, then it can become invalid on the procedure return.
2415 if Ekind
(Formal
) = E_Out_Parameter
2416 and then Is_Entity_Name
(Actual
)
2417 and then Ekind
(Entity
(Actual
)) = E_Variable
2418 and then not Is_Known_Valid
(Etype
(Actual
))
2420 Set_Is_Known_Valid
(Entity
(Actual
), False);
2423 -- For an OUT or IN OUT parameter, if the actual is an entity, then
2424 -- clear current values, since they can be clobbered. We are probably
2425 -- doing this in more places than we need to, but better safe than
2426 -- sorry when it comes to retaining bad current values!
2428 if Ekind
(Formal
) /= E_In_Parameter
2429 and then Is_Entity_Name
(Actual
)
2430 and then Present
(Entity
(Actual
))
2433 Ent
: constant Entity_Id
:= Entity
(Actual
);
2437 -- For an OUT or IN OUT parameter that is an assignable entity,
2438 -- we do not want to clobber the Last_Assignment field, since
2439 -- if it is set, it was precisely because it is indeed an OUT
2440 -- or IN OUT parameter!
2442 if (Ekind
(Formal
) = E_Out_Parameter
2444 Ekind
(Formal
) = E_In_Out_Parameter
)
2445 and then Is_Assignable
(Ent
)
2447 Sav
:= Last_Assignment
(Ent
);
2448 Kill_Current_Values
(Ent
);
2449 Set_Last_Assignment
(Ent
, Sav
);
2451 -- For all other cases, just kill the current values
2454 Kill_Current_Values
(Ent
);
2459 -- If the formal is class wide and the actual is an aggregate, force
2460 -- evaluation so that the back end who does not know about class-wide
2461 -- type, does not generate a temporary of the wrong size.
2463 if not Is_Class_Wide_Type
(Etype
(Formal
)) then
2466 elsif Nkind
(Actual
) = N_Aggregate
2467 or else (Nkind
(Actual
) = N_Qualified_Expression
2468 and then Nkind
(Expression
(Actual
)) = N_Aggregate
)
2470 Force_Evaluation
(Actual
);
2473 -- In a remote call, if the formal is of a class-wide type, check
2474 -- that the actual meets the requirements described in E.4(18).
2476 if Remote
and then Is_Class_Wide_Type
(Etype
(Formal
)) then
2477 Insert_Action
(Actual
,
2478 Make_Transportable_Check
(Loc
,
2479 Duplicate_Subexpr_Move_Checks
(Actual
)));
2482 -- This label is required when skipping extra actual generation for
2483 -- Unchecked_Union parameters.
2485 <<Skip_Extra_Actual_Generation
>>
2487 Param_Count
:= Param_Count
+ 1;
2488 Next_Actual
(Actual
);
2489 Next_Formal
(Formal
);
2492 -- If we are expanding a rhs of an assignment we need to check if tag
2493 -- propagation is needed. You might expect this processing to be in
2494 -- Analyze_Assignment but has to be done earlier (bottom-up) because the
2495 -- assignment might be transformed to a declaration for an unconstrained
2496 -- value if the expression is classwide.
2498 if Nkind
(N
) = N_Function_Call
2499 and then Is_Tag_Indeterminate
(N
)
2500 and then Is_Entity_Name
(Name
(N
))
2503 Ass
: Node_Id
:= Empty
;
2506 if Nkind
(Parent
(N
)) = N_Assignment_Statement
then
2509 elsif Nkind
(Parent
(N
)) = N_Qualified_Expression
2510 and then Nkind
(Parent
(Parent
(N
))) = N_Assignment_Statement
2512 Ass
:= Parent
(Parent
(N
));
2514 elsif Nkind
(Parent
(N
)) = N_Explicit_Dereference
2515 and then Nkind
(Parent
(Parent
(N
))) = N_Assignment_Statement
2517 Ass
:= Parent
(Parent
(N
));
2521 and then Is_Class_Wide_Type
(Etype
(Name
(Ass
)))
2523 if Is_Access_Type
(Etype
(N
)) then
2524 if Designated_Type
(Etype
(N
)) /=
2525 Root_Type
(Etype
(Name
(Ass
)))
2528 ("tag-indeterminate expression "
2529 & " must have designated type& (RM 5.2 (6))",
2530 N
, Root_Type
(Etype
(Name
(Ass
))));
2532 Propagate_Tag
(Name
(Ass
), N
);
2535 elsif Etype
(N
) /= Root_Type
(Etype
(Name
(Ass
))) then
2537 ("tag-indeterminate expression must have type&"
2538 & "(RM 5.2 (6))", N
, Root_Type
(Etype
(Name
(Ass
))));
2541 Propagate_Tag
(Name
(Ass
), N
);
2544 -- The call will be rewritten as a dispatching call, and
2545 -- expanded as such.
2552 -- Ada 2005 (AI-251): If some formal is a class-wide interface, expand
2553 -- it to point to the correct secondary virtual table
2555 if Nkind_In
(N
, N_Function_Call
, N_Procedure_Call_Statement
)
2556 and then CW_Interface_Formals_Present
2558 Expand_Interface_Actuals
(N
);
2561 -- Deals with Dispatch_Call if we still have a call, before expanding
2562 -- extra actuals since this will be done on the re-analysis of the
2563 -- dispatching call. Note that we do not try to shorten the actual
2564 -- list for a dispatching call, it would not make sense to do so.
2565 -- Expansion of dispatching calls is suppressed when VM_Target, because
2566 -- the VM back-ends directly handle the generation of dispatching
2567 -- calls and would have to undo any expansion to an indirect call.
2569 if Nkind_In
(N
, N_Function_Call
, N_Procedure_Call_Statement
)
2570 and then Present
(Controlling_Argument
(N
))
2572 if VM_Target
= No_VM
then
2573 Expand_Dispatching_Call
(N
);
2575 -- The following return is worrisome. Is it really OK to
2576 -- skip all remaining processing in this procedure ???
2580 -- Expansion of a dispatching call results in an indirect call, which
2581 -- in turn causes current values to be killed (see Resolve_Call), so
2582 -- on VM targets we do the call here to ensure consistent warnings
2583 -- between VM and non-VM targets.
2586 Kill_Current_Values
;
2590 -- Similarly, expand calls to RCI subprograms on which pragma
2591 -- All_Calls_Remote applies. The rewriting will be reanalyzed
2592 -- later. Do this only when the call comes from source since we do
2593 -- not want such a rewriting to occur in expanded code.
2595 if Is_All_Remote_Call
(N
) then
2596 Expand_All_Calls_Remote_Subprogram_Call
(N
);
2598 -- Similarly, do not add extra actuals for an entry call whose entity
2599 -- is a protected procedure, or for an internal protected subprogram
2600 -- call, because it will be rewritten as a protected subprogram call
2601 -- and reanalyzed (see Expand_Protected_Subprogram_Call).
2603 elsif Is_Protected_Type
(Scope
(Subp
))
2604 and then (Ekind
(Subp
) = E_Procedure
2605 or else Ekind
(Subp
) = E_Function
)
2609 -- During that loop we gathered the extra actuals (the ones that
2610 -- correspond to Extra_Formals), so now they can be appended.
2613 while Is_Non_Empty_List
(Extra_Actuals
) loop
2614 Add_Actual_Parameter
(Remove_Head
(Extra_Actuals
));
2618 -- At this point we have all the actuals, so this is the point at
2619 -- which the various expansion activities for actuals is carried out.
2621 Expand_Actuals
(N
, Subp
);
2623 -- If the subprogram is a renaming, or if it is inherited, replace it
2624 -- in the call with the name of the actual subprogram being called.
2625 -- If this is a dispatching call, the run-time decides what to call.
2626 -- The Alias attribute does not apply to entries.
2628 if Nkind
(N
) /= N_Entry_Call_Statement
2629 and then No
(Controlling_Argument
(N
))
2630 and then Present
(Parent_Subp
)
2632 if Present
(Inherited_From_Formal
(Subp
)) then
2633 Parent_Subp
:= Inherited_From_Formal
(Subp
);
2635 while Present
(Alias
(Parent_Subp
)) loop
2636 Parent_Subp
:= Alias
(Parent_Subp
);
2640 -- The below setting of Entity is suspect, see F109-018 discussion???
2642 Set_Entity
(Name
(N
), Parent_Subp
);
2644 if Is_Abstract_Subprogram
(Parent_Subp
)
2645 and then not In_Instance
2648 ("cannot call abstract subprogram &!", Name
(N
), Parent_Subp
);
2651 -- Inspect all formals of derived subprogram Subp. Compare parameter
2652 -- types with the parent subprogram and check whether an actual may
2653 -- need a type conversion to the corresponding formal of the parent
2656 -- Not clear whether intrinsic subprograms need such conversions. ???
2658 if not Is_Intrinsic_Subprogram
(Parent_Subp
)
2659 or else Is_Generic_Instance
(Parent_Subp
)
2662 procedure Convert
(Act
: Node_Id
; Typ
: Entity_Id
);
2663 -- Rewrite node Act as a type conversion of Act to Typ. Analyze
2664 -- and resolve the newly generated construct.
2670 procedure Convert
(Act
: Node_Id
; Typ
: Entity_Id
) is
2672 Rewrite
(Act
, OK_Convert_To
(Typ
, Relocate_Node
(Act
)));
2679 Actual_Typ
: Entity_Id
;
2680 Formal_Typ
: Entity_Id
;
2681 Parent_Typ
: Entity_Id
;
2684 Actual
:= First_Actual
(N
);
2685 Formal
:= First_Formal
(Subp
);
2686 Parent_Formal
:= First_Formal
(Parent_Subp
);
2687 while Present
(Formal
) loop
2688 Actual_Typ
:= Etype
(Actual
);
2689 Formal_Typ
:= Etype
(Formal
);
2690 Parent_Typ
:= Etype
(Parent_Formal
);
2692 -- For an IN parameter of a scalar type, the parent formal
2693 -- type and derived formal type differ or the parent formal
2694 -- type and actual type do not match statically.
2696 if Is_Scalar_Type
(Formal_Typ
)
2697 and then Ekind
(Formal
) = E_In_Parameter
2698 and then Formal_Typ
/= Parent_Typ
2700 not Subtypes_Statically_Match
(Parent_Typ
, Actual_Typ
)
2701 and then not Raises_Constraint_Error
(Actual
)
2703 Convert
(Actual
, Parent_Typ
);
2704 Enable_Range_Check
(Actual
);
2706 -- For access types, the parent formal type and actual type
2709 elsif Is_Access_Type
(Formal_Typ
)
2710 and then Base_Type
(Parent_Typ
) /= Base_Type
(Actual_Typ
)
2712 if Ekind
(Formal
) /= E_In_Parameter
then
2713 Convert
(Actual
, Parent_Typ
);
2715 elsif Ekind
(Parent_Typ
) = E_Anonymous_Access_Type
2716 and then Designated_Type
(Parent_Typ
) /=
2717 Designated_Type
(Actual_Typ
)
2718 and then not Is_Controlling_Formal
(Formal
)
2720 -- This unchecked conversion is not necessary unless
2721 -- inlining is enabled, because in that case the type
2722 -- mismatch may become visible in the body about to be
2726 Unchecked_Convert_To
(Parent_Typ
,
2727 Relocate_Node
(Actual
)));
2730 Resolve
(Actual
, Parent_Typ
);
2733 -- For array and record types, the parent formal type and
2734 -- derived formal type have different sizes or pragma Pack
2737 elsif ((Is_Array_Type
(Formal_Typ
)
2738 and then Is_Array_Type
(Parent_Typ
))
2740 (Is_Record_Type
(Formal_Typ
)
2741 and then Is_Record_Type
(Parent_Typ
)))
2743 (Esize
(Formal_Typ
) /= Esize
(Parent_Typ
)
2744 or else Has_Pragma_Pack
(Formal_Typ
) /=
2745 Has_Pragma_Pack
(Parent_Typ
))
2747 Convert
(Actual
, Parent_Typ
);
2750 Next_Actual
(Actual
);
2751 Next_Formal
(Formal
);
2752 Next_Formal
(Parent_Formal
);
2758 Subp
:= Parent_Subp
;
2761 -- Check for violation of No_Abort_Statements
2763 if Is_RTE
(Subp
, RE_Abort_Task
) then
2764 Check_Restriction
(No_Abort_Statements
, N
);
2766 -- Check for violation of No_Dynamic_Attachment
2768 elsif RTU_Loaded
(Ada_Interrupts
)
2769 and then (Is_RTE
(Subp
, RE_Is_Reserved
) or else
2770 Is_RTE
(Subp
, RE_Is_Attached
) or else
2771 Is_RTE
(Subp
, RE_Current_Handler
) or else
2772 Is_RTE
(Subp
, RE_Attach_Handler
) or else
2773 Is_RTE
(Subp
, RE_Exchange_Handler
) or else
2774 Is_RTE
(Subp
, RE_Detach_Handler
) or else
2775 Is_RTE
(Subp
, RE_Reference
))
2777 Check_Restriction
(No_Dynamic_Attachment
, N
);
2780 -- Deal with case where call is an explicit dereference
2782 if Nkind
(Name
(N
)) = N_Explicit_Dereference
then
2784 -- Handle case of access to protected subprogram type
2786 if Is_Access_Protected_Subprogram_Type
2787 (Base_Type
(Etype
(Prefix
(Name
(N
)))))
2789 -- If this is a call through an access to protected operation,
2790 -- the prefix has the form (object'address, operation'access).
2791 -- Rewrite as a for other protected calls: the object is the
2792 -- first parameter of the list of actuals.
2799 Ptr
: constant Node_Id
:= Prefix
(Name
(N
));
2801 T
: constant Entity_Id
:=
2802 Equivalent_Type
(Base_Type
(Etype
(Ptr
)));
2804 D_T
: constant Entity_Id
:=
2805 Designated_Type
(Base_Type
(Etype
(Ptr
)));
2809 Make_Selected_Component
(Loc
,
2810 Prefix
=> Unchecked_Convert_To
(T
, Ptr
),
2812 New_Occurrence_Of
(First_Entity
(T
), Loc
));
2815 Make_Selected_Component
(Loc
,
2816 Prefix
=> Unchecked_Convert_To
(T
, Ptr
),
2818 New_Occurrence_Of
(Next_Entity
(First_Entity
(T
)), Loc
));
2821 Make_Explicit_Dereference
(Loc
,
2824 if Present
(Parameter_Associations
(N
)) then
2825 Parm
:= Parameter_Associations
(N
);
2830 Prepend
(Obj
, Parm
);
2832 if Etype
(D_T
) = Standard_Void_Type
then
2834 Make_Procedure_Call_Statement
(Loc
,
2836 Parameter_Associations
=> Parm
);
2839 Make_Function_Call
(Loc
,
2841 Parameter_Associations
=> Parm
);
2844 Set_First_Named_Actual
(Call
, First_Named_Actual
(N
));
2845 Set_Etype
(Call
, Etype
(D_T
));
2847 -- We do not re-analyze the call to avoid infinite recursion.
2848 -- We analyze separately the prefix and the object, and set
2849 -- the checks on the prefix that would otherwise be emitted
2850 -- when resolving a call.
2854 Apply_Access_Check
(Nam
);
2861 -- If this is a call to an intrinsic subprogram, then perform the
2862 -- appropriate expansion to the corresponding tree node and we
2863 -- are all done (since after that the call is gone!)
2865 -- In the case where the intrinsic is to be processed by the back end,
2866 -- the call to Expand_Intrinsic_Call will do nothing, which is fine,
2867 -- since the idea in this case is to pass the call unchanged.
2868 -- If the intrinsic is an inherited unchecked conversion, and the
2869 -- derived type is the target type of the conversion, we must retain
2870 -- it as the return type of the expression. Otherwise the expansion
2871 -- below, which uses the parent operation, will yield the wrong type.
2873 if Is_Intrinsic_Subprogram
(Subp
) then
2874 Expand_Intrinsic_Call
(N
, Subp
);
2876 if Nkind
(N
) = N_Unchecked_Type_Conversion
2877 and then Parent_Subp
/= Orig_Subp
2878 and then Etype
(Parent_Subp
) /= Etype
(Orig_Subp
)
2880 Set_Etype
(N
, Etype
(Orig_Subp
));
2886 if Ekind
(Subp
) = E_Function
2887 or else Ekind
(Subp
) = E_Procedure
2889 if Is_Inlined
(Subp
) then
2891 Inlined_Subprogram
: declare
2893 Must_Inline
: Boolean := False;
2894 Spec
: constant Node_Id
:= Unit_Declaration_Node
(Subp
);
2895 Scop
: constant Entity_Id
:= Scope
(Subp
);
2897 function In_Unfrozen_Instance
return Boolean;
2898 -- If the subprogram comes from an instance in the same
2899 -- unit, and the instance is not yet frozen, inlining might
2900 -- trigger order-of-elaboration problems in gigi.
2902 --------------------------
2903 -- In_Unfrozen_Instance --
2904 --------------------------
2906 function In_Unfrozen_Instance
return Boolean is
2912 and then S
/= Standard_Standard
2914 if Is_Generic_Instance
(S
)
2915 and then Present
(Freeze_Node
(S
))
2916 and then not Analyzed
(Freeze_Node
(S
))
2925 end In_Unfrozen_Instance
;
2927 -- Start of processing for Inlined_Subprogram
2930 -- Verify that the body to inline has already been seen, and
2931 -- that if the body is in the current unit the inlining does
2932 -- not occur earlier. This avoids order-of-elaboration problems
2935 -- This should be documented in sinfo/einfo ???
2938 or else Nkind
(Spec
) /= N_Subprogram_Declaration
2939 or else No
(Body_To_Inline
(Spec
))
2941 Must_Inline
:= False;
2943 -- If this an inherited function that returns a private
2944 -- type, do not inline if the full view is an unconstrained
2945 -- array, because such calls cannot be inlined.
2947 elsif Present
(Orig_Subp
)
2948 and then Is_Array_Type
(Etype
(Orig_Subp
))
2949 and then not Is_Constrained
(Etype
(Orig_Subp
))
2951 Must_Inline
:= False;
2953 elsif In_Unfrozen_Instance
then
2954 Must_Inline
:= False;
2957 Bod
:= Body_To_Inline
(Spec
);
2959 if (In_Extended_Main_Code_Unit
(N
)
2960 or else In_Extended_Main_Code_Unit
(Parent
(N
))
2961 or else Has_Pragma_Inline_Always
(Subp
))
2962 and then (not In_Same_Extended_Unit
(Sloc
(Bod
), Loc
)
2964 Earlier_In_Extended_Unit
(Sloc
(Bod
), Loc
))
2966 Must_Inline
:= True;
2968 -- If we are compiling a package body that is not the main
2969 -- unit, it must be for inlining/instantiation purposes,
2970 -- in which case we inline the call to insure that the same
2971 -- temporaries are generated when compiling the body by
2972 -- itself. Otherwise link errors can occur.
2974 -- If the function being called is itself in the main unit,
2975 -- we cannot inline, because there is a risk of double
2976 -- elaboration and/or circularity: the inlining can make
2977 -- visible a private entity in the body of the main unit,
2978 -- that gigi will see before its sees its proper definition.
2980 elsif not (In_Extended_Main_Code_Unit
(N
))
2981 and then In_Package_Body
2983 Must_Inline
:= not In_Extended_Main_Source_Unit
(Subp
);
2988 Expand_Inlined_Call
(N
, Subp
, Orig_Subp
);
2991 -- Let the back end handle it
2993 Add_Inlined_Body
(Subp
);
2995 if Front_End_Inlining
2996 and then Nkind
(Spec
) = N_Subprogram_Declaration
2997 and then (In_Extended_Main_Code_Unit
(N
))
2998 and then No
(Body_To_Inline
(Spec
))
2999 and then not Has_Completion
(Subp
)
3000 and then In_Same_Extended_Unit
(Sloc
(Spec
), Loc
)
3003 ("cannot inline& (body not seen yet)?",
3007 end Inlined_Subprogram
;
3011 -- Check for a protected subprogram. This is either an intra-object
3012 -- call, or a protected function call. Protected procedure calls are
3013 -- rewritten as entry calls and handled accordingly.
3015 -- In Ada 2005, this may be an indirect call to an access parameter
3016 -- that is an access_to_subprogram. In that case the anonymous type
3017 -- has a scope that is a protected operation, but the call is a
3020 Scop
:= Scope
(Subp
);
3022 if Nkind
(N
) /= N_Entry_Call_Statement
3023 and then Is_Protected_Type
(Scop
)
3024 and then Ekind
(Subp
) /= E_Subprogram_Type
3026 -- If the call is an internal one, it is rewritten as a call to
3027 -- to the corresponding unprotected subprogram.
3029 Expand_Protected_Subprogram_Call
(N
, Subp
, Scop
);
3032 -- Functions returning controlled objects need special attention
3033 -- If the return type is limited the context is an initialization
3034 -- and different processing applies.
3036 if Needs_Finalization
(Etype
(Subp
))
3037 and then not Is_Inherently_Limited_Type
(Etype
(Subp
))
3038 and then not Is_Limited_Interface
(Etype
(Subp
))
3040 Expand_Ctrl_Function_Call
(N
);
3043 -- Test for First_Optional_Parameter, and if so, truncate parameter
3044 -- list if there are optional parameters at the trailing end.
3045 -- Note we never delete procedures for call via a pointer.
3047 if (Ekind
(Subp
) = E_Procedure
or else Ekind
(Subp
) = E_Function
)
3048 and then Present
(First_Optional_Parameter
(Subp
))
3051 Last_Keep_Arg
: Node_Id
;
3054 -- Last_Keep_Arg will hold the last actual that should be
3055 -- retained. If it remains empty at the end, it means that
3056 -- all parameters are optional.
3058 Last_Keep_Arg
:= Empty
;
3060 -- Find first optional parameter, must be present since we
3061 -- checked the validity of the parameter before setting it.
3063 Formal
:= First_Formal
(Subp
);
3064 Actual
:= First_Actual
(N
);
3065 while Formal
/= First_Optional_Parameter
(Subp
) loop
3066 Last_Keep_Arg
:= Actual
;
3067 Next_Formal
(Formal
);
3068 Next_Actual
(Actual
);
3071 -- We have Formal and Actual pointing to the first potentially
3072 -- droppable argument. We can drop all the trailing arguments
3073 -- whose actual matches the default. Note that we know that all
3074 -- remaining formals have defaults, because we checked that this
3075 -- requirement was met before setting First_Optional_Parameter.
3077 -- We use Fully_Conformant_Expressions to check for identity
3078 -- between formals and actuals, which may miss some cases, but
3079 -- on the other hand, this is only an optimization (if we fail
3080 -- to truncate a parameter it does not affect functionality).
3081 -- So if the default is 3 and the actual is 1+2, we consider
3082 -- them unequal, which hardly seems worrisome.
3084 while Present
(Formal
) loop
3085 if not Fully_Conformant_Expressions
3086 (Actual
, Default_Value
(Formal
))
3088 Last_Keep_Arg
:= Actual
;
3091 Next_Formal
(Formal
);
3092 Next_Actual
(Actual
);
3095 -- If no arguments, delete entire list, this is the easy case
3097 if No
(Last_Keep_Arg
) then
3098 Set_Parameter_Associations
(N
, No_List
);
3099 Set_First_Named_Actual
(N
, Empty
);
3101 -- Case where at the last retained argument is positional. This
3102 -- is also an easy case, since the retained arguments are already
3103 -- in the right form, and we don't need to worry about the order
3104 -- of arguments that get eliminated.
3106 elsif Is_List_Member
(Last_Keep_Arg
) then
3107 while Present
(Next
(Last_Keep_Arg
)) loop
3108 Discard_Node
(Remove_Next
(Last_Keep_Arg
));
3111 Set_First_Named_Actual
(N
, Empty
);
3113 -- This is the annoying case where the last retained argument
3114 -- is a named parameter. Since the original arguments are not
3115 -- in declaration order, we may have to delete some fairly
3116 -- random collection of arguments.
3124 -- First step, remove all the named parameters from the
3125 -- list (they are still chained using First_Named_Actual
3126 -- and Next_Named_Actual, so we have not lost them!)
3128 Temp
:= First
(Parameter_Associations
(N
));
3130 -- Case of all parameters named, remove them all
3132 if Nkind
(Temp
) = N_Parameter_Association
then
3133 while Is_Non_Empty_List
(Parameter_Associations
(N
)) loop
3134 Temp
:= Remove_Head
(Parameter_Associations
(N
));
3137 -- Case of mixed positional/named, remove named parameters
3140 while Nkind
(Next
(Temp
)) /= N_Parameter_Association
loop
3144 while Present
(Next
(Temp
)) loop
3145 Remove
(Next
(Temp
));
3149 -- Now we loop through the named parameters, till we get
3150 -- to the last one to be retained, adding them to the list.
3151 -- Note that the Next_Named_Actual list does not need to be
3152 -- touched since we are only reordering them on the actual
3153 -- parameter association list.
3155 Passoc
:= Parent
(First_Named_Actual
(N
));
3157 Temp
:= Relocate_Node
(Passoc
);
3159 (Parameter_Associations
(N
), Temp
);
3161 Last_Keep_Arg
= Explicit_Actual_Parameter
(Passoc
);
3162 Passoc
:= Parent
(Next_Named_Actual
(Passoc
));
3165 Set_Next_Named_Actual
(Temp
, Empty
);
3168 Temp
:= Next_Named_Actual
(Passoc
);
3169 exit when No
(Temp
);
3170 Set_Next_Named_Actual
3171 (Passoc
, Next_Named_Actual
(Parent
(Temp
)));
3179 --------------------------
3180 -- Expand_Inlined_Call --
3181 --------------------------
3183 procedure Expand_Inlined_Call
3186 Orig_Subp
: Entity_Id
)
3188 Loc
: constant Source_Ptr
:= Sloc
(N
);
3189 Is_Predef
: constant Boolean :=
3190 Is_Predefined_File_Name
3191 (Unit_File_Name
(Get_Source_Unit
(Subp
)));
3192 Orig_Bod
: constant Node_Id
:=
3193 Body_To_Inline
(Unit_Declaration_Node
(Subp
));
3198 Decls
: constant List_Id
:= New_List
;
3199 Exit_Lab
: Entity_Id
:= Empty
;
3206 Ret_Type
: Entity_Id
;
3210 Temp_Typ
: Entity_Id
;
3212 Is_Unc
: constant Boolean :=
3213 Is_Array_Type
(Etype
(Subp
))
3214 and then not Is_Constrained
(Etype
(Subp
));
3215 -- If the type returned by the function is unconstrained and the
3216 -- call can be inlined, special processing is required.
3218 function Is_Null_Procedure
return Boolean;
3219 -- Predicate to recognize stubbed procedures and null procedures, for
3220 -- which there is no need for the full inlining mechanism.
3222 procedure Make_Exit_Label
;
3223 -- Build declaration for exit label to be used in Return statements
3225 function Process_Formals
(N
: Node_Id
) return Traverse_Result
;
3226 -- Replace occurrence of a formal with the corresponding actual, or
3227 -- the thunk generated for it.
3229 function Process_Sloc
(Nod
: Node_Id
) return Traverse_Result
;
3230 -- If the call being expanded is that of an internal subprogram,
3231 -- set the sloc of the generated block to that of the call itself,
3232 -- so that the expansion is skipped by the -next- command in gdb.
3233 -- Same processing for a subprogram in a predefined file, e.g.
3234 -- Ada.Tags. If Debug_Generated_Code is true, suppress this change
3235 -- to simplify our own development.
3237 procedure Rewrite_Function_Call
(N
: Node_Id
; Blk
: Node_Id
);
3238 -- If the function body is a single expression, replace call with
3239 -- expression, else insert block appropriately.
3241 procedure Rewrite_Procedure_Call
(N
: Node_Id
; Blk
: Node_Id
);
3242 -- If procedure body has no local variables, inline body without
3243 -- creating block, otherwise rewrite call with block.
3245 function Formal_Is_Used_Once
(Formal
: Entity_Id
) return Boolean;
3246 -- Determine whether a formal parameter is used only once in Orig_Bod
3248 -----------------------
3249 -- Is_Null_Procedure --
3250 -----------------------
3252 function Is_Null_Procedure
return Boolean is
3253 Decl
: constant Node_Id
:= Unit_Declaration_Node
(Subp
);
3256 if Ekind
(Subp
) /= E_Procedure
then
3259 elsif Nkind
(Orig_Bod
) /= N_Subprogram_Body
then
3262 -- Check if this is an Ada 2005 null procedure
3264 elsif Nkind
(Decl
) = N_Subprogram_Declaration
3265 and then Null_Present
(Specification
(Decl
))
3269 -- Check if the body contains only a null statement, followed by the
3270 -- return statement added during expansion.
3274 Stat
: constant Node_Id
:=
3276 (Statements
(Handled_Statement_Sequence
(Orig_Bod
)));
3278 Stat2
: constant Node_Id
:= Next
(Stat
);
3282 Nkind
(Stat
) = N_Null_Statement
3286 (Nkind
(Stat2
) = N_Simple_Return_Statement
3287 and then No
(Next
(Stat2
))));
3290 end Is_Null_Procedure
;
3292 ---------------------
3293 -- Make_Exit_Label --
3294 ---------------------
3296 procedure Make_Exit_Label
is
3298 -- Create exit label for subprogram if one does not exist yet
3300 if No
(Exit_Lab
) then
3302 Make_Identifier
(Loc
,
3303 Chars
=> New_Internal_Name
('L'));
3305 Make_Defining_Identifier
(Loc
, Chars
(Lab_Id
)));
3306 Exit_Lab
:= Make_Label
(Loc
, Lab_Id
);
3309 Make_Implicit_Label_Declaration
(Loc
,
3310 Defining_Identifier
=> Entity
(Lab_Id
),
3311 Label_Construct
=> Exit_Lab
);
3313 end Make_Exit_Label
;
3315 ---------------------
3316 -- Process_Formals --
3317 ---------------------
3319 function Process_Formals
(N
: Node_Id
) return Traverse_Result
is
3325 if Is_Entity_Name
(N
)
3326 and then Present
(Entity
(N
))
3331 and then Scope
(E
) = Subp
3333 A
:= Renamed_Object
(E
);
3335 -- Rewrite the occurrence of the formal into an occurrence of
3336 -- the actual. Also establish visibility on the proper view of
3337 -- the actual's subtype for the body's context (if the actual's
3338 -- subtype is private at the call point but its full view is
3339 -- visible to the body, then the inlined tree here must be
3340 -- analyzed with the full view).
3342 if Is_Entity_Name
(A
) then
3343 Rewrite
(N
, New_Occurrence_Of
(Entity
(A
), Loc
));
3344 Check_Private_View
(N
);
3346 elsif Nkind
(A
) = N_Defining_Identifier
then
3347 Rewrite
(N
, New_Occurrence_Of
(A
, Loc
));
3348 Check_Private_View
(N
);
3353 Rewrite
(N
, New_Copy
(A
));
3359 elsif Nkind
(N
) = N_Simple_Return_Statement
then
3360 if No
(Expression
(N
)) then
3363 Make_Goto_Statement
(Loc
,
3364 Name
=> New_Copy
(Lab_Id
)));
3367 if Nkind
(Parent
(N
)) = N_Handled_Sequence_Of_Statements
3368 and then Nkind
(Parent
(Parent
(N
))) = N_Subprogram_Body
3370 -- Function body is a single expression. No need for
3376 Num_Ret
:= Num_Ret
+ 1;
3380 -- Because of the presence of private types, the views of the
3381 -- expression and the context may be different, so place an
3382 -- unchecked conversion to the context type to avoid spurious
3383 -- errors, e.g. when the expression is a numeric literal and
3384 -- the context is private. If the expression is an aggregate,
3385 -- use a qualified expression, because an aggregate is not a
3386 -- legal argument of a conversion.
3388 if Nkind_In
(Expression
(N
), N_Aggregate
, N_Null
) then
3390 Make_Qualified_Expression
(Sloc
(N
),
3391 Subtype_Mark
=> New_Occurrence_Of
(Ret_Type
, Sloc
(N
)),
3392 Expression
=> Relocate_Node
(Expression
(N
)));
3395 Unchecked_Convert_To
3396 (Ret_Type
, Relocate_Node
(Expression
(N
)));
3399 if Nkind
(Targ
) = N_Defining_Identifier
then
3401 Make_Assignment_Statement
(Loc
,
3402 Name
=> New_Occurrence_Of
(Targ
, Loc
),
3403 Expression
=> Ret
));
3406 Make_Assignment_Statement
(Loc
,
3407 Name
=> New_Copy
(Targ
),
3408 Expression
=> Ret
));
3411 Set_Assignment_OK
(Name
(N
));
3413 if Present
(Exit_Lab
) then
3415 Make_Goto_Statement
(Loc
,
3416 Name
=> New_Copy
(Lab_Id
)));
3422 -- Remove pragma Unreferenced since it may refer to formals that
3423 -- are not visible in the inlined body, and in any case we will
3424 -- not be posting warnings on the inlined body so it is unneeded.
3426 elsif Nkind
(N
) = N_Pragma
3427 and then Pragma_Name
(N
) = Name_Unreferenced
3429 Rewrite
(N
, Make_Null_Statement
(Sloc
(N
)));
3435 end Process_Formals
;
3437 procedure Replace_Formals
is new Traverse_Proc
(Process_Formals
);
3443 function Process_Sloc
(Nod
: Node_Id
) return Traverse_Result
is
3445 if not Debug_Generated_Code
then
3446 Set_Sloc
(Nod
, Sloc
(N
));
3447 Set_Comes_From_Source
(Nod
, False);
3453 procedure Reset_Slocs
is new Traverse_Proc
(Process_Sloc
);
3455 ---------------------------
3456 -- Rewrite_Function_Call --
3457 ---------------------------
3459 procedure Rewrite_Function_Call
(N
: Node_Id
; Blk
: Node_Id
) is
3460 HSS
: constant Node_Id
:= Handled_Statement_Sequence
(Blk
);
3461 Fst
: constant Node_Id
:= First
(Statements
(HSS
));
3464 -- Optimize simple case: function body is a single return statement,
3465 -- which has been expanded into an assignment.
3467 if Is_Empty_List
(Declarations
(Blk
))
3468 and then Nkind
(Fst
) = N_Assignment_Statement
3469 and then No
(Next
(Fst
))
3472 -- The function call may have been rewritten as the temporary
3473 -- that holds the result of the call, in which case remove the
3474 -- now useless declaration.
3476 if Nkind
(N
) = N_Identifier
3477 and then Nkind
(Parent
(Entity
(N
))) = N_Object_Declaration
3479 Rewrite
(Parent
(Entity
(N
)), Make_Null_Statement
(Loc
));
3482 Rewrite
(N
, Expression
(Fst
));
3484 elsif Nkind
(N
) = N_Identifier
3485 and then Nkind
(Parent
(Entity
(N
))) = N_Object_Declaration
3487 -- The block assigns the result of the call to the temporary
3489 Insert_After
(Parent
(Entity
(N
)), Blk
);
3491 elsif Nkind
(Parent
(N
)) = N_Assignment_Statement
3493 (Is_Entity_Name
(Name
(Parent
(N
)))
3495 (Nkind
(Name
(Parent
(N
))) = N_Explicit_Dereference
3496 and then Is_Entity_Name
(Prefix
(Name
(Parent
(N
))))))
3498 -- Replace assignment with the block
3501 Original_Assignment
: constant Node_Id
:= Parent
(N
);
3504 -- Preserve the original assignment node to keep the complete
3505 -- assignment subtree consistent enough for Analyze_Assignment
3506 -- to proceed (specifically, the original Lhs node must still
3507 -- have an assignment statement as its parent).
3509 -- We cannot rely on Original_Node to go back from the block
3510 -- node to the assignment node, because the assignment might
3511 -- already be a rewrite substitution.
3513 Discard_Node
(Relocate_Node
(Original_Assignment
));
3514 Rewrite
(Original_Assignment
, Blk
);
3517 elsif Nkind
(Parent
(N
)) = N_Object_Declaration
then
3518 Set_Expression
(Parent
(N
), Empty
);
3519 Insert_After
(Parent
(N
), Blk
);
3522 Insert_Before
(Parent
(N
), Blk
);
3524 end Rewrite_Function_Call
;
3526 ----------------------------
3527 -- Rewrite_Procedure_Call --
3528 ----------------------------
3530 procedure Rewrite_Procedure_Call
(N
: Node_Id
; Blk
: Node_Id
) is
3531 HSS
: constant Node_Id
:= Handled_Statement_Sequence
(Blk
);
3533 -- If there is a transient scope for N, this will be the scope of the
3534 -- actions for N, and the statements in Blk need to be within this
3535 -- scope. For example, they need to have visibility on the constant
3536 -- declarations created for the formals.
3538 -- If N needs no transient scope, and if there are no declarations in
3539 -- the inlined body, we can do a little optimization and insert the
3540 -- statements for the body directly after N, and rewrite N to a
3541 -- null statement, instead of rewriting N into a full-blown block
3544 if not Scope_Is_Transient
3545 and then Is_Empty_List
(Declarations
(Blk
))
3547 Insert_List_After
(N
, Statements
(HSS
));
3548 Rewrite
(N
, Make_Null_Statement
(Loc
));
3552 end Rewrite_Procedure_Call
;
3554 -------------------------
3555 -- Formal_Is_Used_Once --
3556 -------------------------
3558 function Formal_Is_Used_Once
(Formal
: Entity_Id
) return Boolean is
3559 Use_Counter
: Int
:= 0;
3561 function Count_Uses
(N
: Node_Id
) return Traverse_Result
;
3562 -- Traverse the tree and count the uses of the formal parameter.
3563 -- In this case, for optimization purposes, we do not need to
3564 -- continue the traversal once more than one use is encountered.
3570 function Count_Uses
(N
: Node_Id
) return Traverse_Result
is
3572 -- The original node is an identifier
3574 if Nkind
(N
) = N_Identifier
3575 and then Present
(Entity
(N
))
3577 -- Original node's entity points to the one in the copied body
3579 and then Nkind
(Entity
(N
)) = N_Identifier
3580 and then Present
(Entity
(Entity
(N
)))
3582 -- The entity of the copied node is the formal parameter
3584 and then Entity
(Entity
(N
)) = Formal
3586 Use_Counter
:= Use_Counter
+ 1;
3588 if Use_Counter
> 1 then
3590 -- Denote more than one use and abandon the traversal
3601 procedure Count_Formal_Uses
is new Traverse_Proc
(Count_Uses
);
3603 -- Start of processing for Formal_Is_Used_Once
3606 Count_Formal_Uses
(Orig_Bod
);
3607 return Use_Counter
= 1;
3608 end Formal_Is_Used_Once
;
3610 -- Start of processing for Expand_Inlined_Call
3613 -- Check for special case of To_Address call, and if so, just do an
3614 -- unchecked conversion instead of expanding the call. Not only is this
3615 -- more efficient, but it also avoids problem with order of elaboration
3616 -- when address clauses are inlined (address expression elaborated at
3619 if Subp
= RTE
(RE_To_Address
) then
3621 Unchecked_Convert_To
3623 Relocate_Node
(First_Actual
(N
))));
3626 elsif Is_Null_Procedure
then
3627 Rewrite
(N
, Make_Null_Statement
(Loc
));
3631 -- Check for an illegal attempt to inline a recursive procedure. If the
3632 -- subprogram has parameters this is detected when trying to supply a
3633 -- binding for parameters that already have one. For parameterless
3634 -- subprograms this must be done explicitly.
3636 if In_Open_Scopes
(Subp
) then
3637 Error_Msg_N
("call to recursive subprogram cannot be inlined?", N
);
3638 Set_Is_Inlined
(Subp
, False);
3642 if Nkind
(Orig_Bod
) = N_Defining_Identifier
3643 or else Nkind
(Orig_Bod
) = N_Defining_Operator_Symbol
3645 -- Subprogram is a renaming_as_body. Calls appearing after the
3646 -- renaming can be replaced with calls to the renamed entity
3647 -- directly, because the subprograms are subtype conformant. If
3648 -- the renamed subprogram is an inherited operation, we must redo
3649 -- the expansion because implicit conversions may be needed.
3651 Set_Name
(N
, New_Occurrence_Of
(Orig_Bod
, Loc
));
3653 if Present
(Alias
(Orig_Bod
)) then
3660 -- Use generic machinery to copy body of inlined subprogram, as if it
3661 -- were an instantiation, resetting source locations appropriately, so
3662 -- that nested inlined calls appear in the main unit.
3664 Save_Env
(Subp
, Empty
);
3665 Set_Copied_Sloc_For_Inlined_Body
(N
, Defining_Entity
(Orig_Bod
));
3667 Bod
:= Copy_Generic_Node
(Orig_Bod
, Empty
, Instantiating
=> True);
3669 Make_Block_Statement
(Loc
,
3670 Declarations
=> Declarations
(Bod
),
3671 Handled_Statement_Sequence
=> Handled_Statement_Sequence
(Bod
));
3673 if No
(Declarations
(Bod
)) then
3674 Set_Declarations
(Blk
, New_List
);
3677 -- For the unconstrained case, capture the name of the local
3678 -- variable that holds the result. This must be the first declaration
3679 -- in the block, because its bounds cannot depend on local variables.
3680 -- Otherwise there is no way to declare the result outside of the
3681 -- block. Needless to say, in general the bounds will depend on the
3682 -- actuals in the call.
3685 Targ1
:= Defining_Identifier
(First
(Declarations
(Blk
)));
3688 -- If this is a derived function, establish the proper return type
3690 if Present
(Orig_Subp
)
3691 and then Orig_Subp
/= Subp
3693 Ret_Type
:= Etype
(Orig_Subp
);
3695 Ret_Type
:= Etype
(Subp
);
3698 -- Create temporaries for the actuals that are expressions, or that
3699 -- are scalars and require copying to preserve semantics.
3701 F
:= First_Formal
(Subp
);
3702 A
:= First_Actual
(N
);
3703 while Present
(F
) loop
3704 if Present
(Renamed_Object
(F
)) then
3705 Error_Msg_N
("cannot inline call to recursive subprogram", N
);
3709 -- If the argument may be a controlling argument in a call within
3710 -- the inlined body, we must preserve its classwide nature to insure
3711 -- that dynamic dispatching take place subsequently. If the formal
3712 -- has a constraint it must be preserved to retain the semantics of
3715 if Is_Class_Wide_Type
(Etype
(F
))
3716 or else (Is_Access_Type
(Etype
(F
))
3718 Is_Class_Wide_Type
(Designated_Type
(Etype
(F
))))
3720 Temp_Typ
:= Etype
(F
);
3722 elsif Base_Type
(Etype
(F
)) = Base_Type
(Etype
(A
))
3723 and then Etype
(F
) /= Base_Type
(Etype
(F
))
3725 Temp_Typ
:= Etype
(F
);
3728 Temp_Typ
:= Etype
(A
);
3731 -- If the actual is a simple name or a literal, no need to
3732 -- create a temporary, object can be used directly.
3734 -- If the actual is a literal and the formal has its address taken,
3735 -- we cannot pass the literal itself as an argument, so its value
3736 -- must be captured in a temporary.
3738 if (Is_Entity_Name
(A
)
3740 (not Is_Scalar_Type
(Etype
(A
))
3741 or else Ekind
(Entity
(A
)) = E_Enumeration_Literal
))
3743 -- When the actual is an identifier and the corresponding formal
3744 -- is used only once in the original body, the formal can be
3745 -- substituted directly with the actual parameter.
3747 or else (Nkind
(A
) = N_Identifier
3748 and then Formal_Is_Used_Once
(F
))
3751 (Nkind_In
(A
, N_Real_Literal
,
3753 N_Character_Literal
)
3754 and then not Address_Taken
(F
))
3756 if Etype
(F
) /= Etype
(A
) then
3758 (F
, Unchecked_Convert_To
(Etype
(F
), Relocate_Node
(A
)));
3760 Set_Renamed_Object
(F
, A
);
3765 Make_Defining_Identifier
(Loc
,
3766 Chars
=> New_Internal_Name
('C'));
3768 -- If the actual for an in/in-out parameter is a view conversion,
3769 -- make it into an unchecked conversion, given that an untagged
3770 -- type conversion is not a proper object for a renaming.
3772 -- In-out conversions that involve real conversions have already
3773 -- been transformed in Expand_Actuals.
3775 if Nkind
(A
) = N_Type_Conversion
3776 and then Ekind
(F
) /= E_In_Parameter
3779 Make_Unchecked_Type_Conversion
(Loc
,
3780 Subtype_Mark
=> New_Occurrence_Of
(Etype
(F
), Loc
),
3781 Expression
=> Relocate_Node
(Expression
(A
)));
3783 elsif Etype
(F
) /= Etype
(A
) then
3784 New_A
:= Unchecked_Convert_To
(Etype
(F
), Relocate_Node
(A
));
3785 Temp_Typ
:= Etype
(F
);
3788 New_A
:= Relocate_Node
(A
);
3791 Set_Sloc
(New_A
, Sloc
(N
));
3793 -- If the actual has a by-reference type, it cannot be copied, so
3794 -- its value is captured in a renaming declaration. Otherwise
3795 -- declare a local constant initialized with the actual.
3797 if Ekind
(F
) = E_In_Parameter
3798 and then not Is_Limited_Type
(Etype
(A
))
3799 and then not Is_Tagged_Type
(Etype
(A
))
3802 Make_Object_Declaration
(Loc
,
3803 Defining_Identifier
=> Temp
,
3804 Constant_Present
=> True,
3805 Object_Definition
=> New_Occurrence_Of
(Temp_Typ
, Loc
),
3806 Expression
=> New_A
);
3809 Make_Object_Renaming_Declaration
(Loc
,
3810 Defining_Identifier
=> Temp
,
3811 Subtype_Mark
=> New_Occurrence_Of
(Temp_Typ
, Loc
),
3815 Append
(Decl
, Decls
);
3816 Set_Renamed_Object
(F
, Temp
);
3823 -- Establish target of function call. If context is not assignment or
3824 -- declaration, create a temporary as a target. The declaration for
3825 -- the temporary may be subsequently optimized away if the body is a
3826 -- single expression, or if the left-hand side of the assignment is
3827 -- simple enough, i.e. an entity or an explicit dereference of one.
3829 if Ekind
(Subp
) = E_Function
then
3830 if Nkind
(Parent
(N
)) = N_Assignment_Statement
3831 and then Is_Entity_Name
(Name
(Parent
(N
)))
3833 Targ
:= Name
(Parent
(N
));
3835 elsif Nkind
(Parent
(N
)) = N_Assignment_Statement
3836 and then Nkind
(Name
(Parent
(N
))) = N_Explicit_Dereference
3837 and then Is_Entity_Name
(Prefix
(Name
(Parent
(N
))))
3839 Targ
:= Name
(Parent
(N
));
3842 -- Replace call with temporary and create its declaration
3845 Make_Defining_Identifier
(Loc
, New_Internal_Name
('C'));
3846 Set_Is_Internal
(Temp
);
3848 -- For the unconstrained case, the generated temporary has the
3849 -- same constrained declaration as the result variable.
3850 -- It may eventually be possible to remove that temporary and
3851 -- use the result variable directly.
3855 Make_Object_Declaration
(Loc
,
3856 Defining_Identifier
=> Temp
,
3857 Object_Definition
=>
3858 New_Copy_Tree
(Object_Definition
(Parent
(Targ1
))));
3860 Replace_Formals
(Decl
);
3864 Make_Object_Declaration
(Loc
,
3865 Defining_Identifier
=> Temp
,
3866 Object_Definition
=>
3867 New_Occurrence_Of
(Ret_Type
, Loc
));
3869 Set_Etype
(Temp
, Ret_Type
);
3872 Set_No_Initialization
(Decl
);
3873 Append
(Decl
, Decls
);
3874 Rewrite
(N
, New_Occurrence_Of
(Temp
, Loc
));
3879 Insert_Actions
(N
, Decls
);
3881 -- Traverse the tree and replace formals with actuals or their thunks.
3882 -- Attach block to tree before analysis and rewriting.
3884 Replace_Formals
(Blk
);
3885 Set_Parent
(Blk
, N
);
3887 if not Comes_From_Source
(Subp
)
3893 if Present
(Exit_Lab
) then
3895 -- If the body was a single expression, the single return statement
3896 -- and the corresponding label are useless.
3900 Nkind
(Last
(Statements
(Handled_Statement_Sequence
(Blk
)))) =
3903 Remove
(Last
(Statements
(Handled_Statement_Sequence
(Blk
))));
3905 Append
(Lab_Decl
, (Declarations
(Blk
)));
3906 Append
(Exit_Lab
, Statements
(Handled_Statement_Sequence
(Blk
)));
3910 -- Analyze Blk with In_Inlined_Body set, to avoid spurious errors on
3911 -- conflicting private views that Gigi would ignore. If this is
3912 -- predefined unit, analyze with checks off, as is done in the non-
3913 -- inlined run-time units.
3916 I_Flag
: constant Boolean := In_Inlined_Body
;
3919 In_Inlined_Body
:= True;
3923 Style
: constant Boolean := Style_Check
;
3925 Style_Check
:= False;
3926 Analyze
(Blk
, Suppress
=> All_Checks
);
3927 Style_Check
:= Style
;
3934 In_Inlined_Body
:= I_Flag
;
3937 if Ekind
(Subp
) = E_Procedure
then
3938 Rewrite_Procedure_Call
(N
, Blk
);
3940 Rewrite_Function_Call
(N
, Blk
);
3942 -- For the unconstrained case, the replacement of the call has been
3943 -- made prior to the complete analysis of the generated declarations.
3944 -- Propagate the proper type now.
3947 if Nkind
(N
) = N_Identifier
then
3948 Set_Etype
(N
, Etype
(Entity
(N
)));
3950 Set_Etype
(N
, Etype
(Targ1
));
3957 -- Cleanup mapping between formals and actuals for other expansions
3959 F
:= First_Formal
(Subp
);
3960 while Present
(F
) loop
3961 Set_Renamed_Object
(F
, Empty
);
3964 end Expand_Inlined_Call
;
3966 ----------------------------
3967 -- Expand_N_Function_Call --
3968 ----------------------------
3970 procedure Expand_N_Function_Call
(N
: Node_Id
) is
3974 -- If the return value of a foreign compiled function is
3975 -- VAX Float then expand the return (adjusts the location
3976 -- of the return value on Alpha/VMS, noop everywhere else).
3977 -- Comes_From_Source intercepts recursive expansion.
3979 if Vax_Float
(Etype
(N
))
3980 and then Nkind
(N
) = N_Function_Call
3981 and then Present
(Name
(N
))
3982 and then Present
(Entity
(Name
(N
)))
3983 and then Has_Foreign_Convention
(Entity
(Name
(N
)))
3984 and then Comes_From_Source
(Parent
(N
))
3986 Expand_Vax_Foreign_Return
(N
);
3988 end Expand_N_Function_Call
;
3990 ---------------------------------------
3991 -- Expand_N_Procedure_Call_Statement --
3992 ---------------------------------------
3994 procedure Expand_N_Procedure_Call_Statement
(N
: Node_Id
) is
3997 end Expand_N_Procedure_Call_Statement
;
3999 ------------------------------
4000 -- Expand_N_Subprogram_Body --
4001 ------------------------------
4003 -- Add poll call if ATC polling is enabled, unless the body will be
4004 -- inlined by the back-end.
4006 -- Add dummy push/pop label nodes at start and end to clear any local
4007 -- exception indications if local-exception-to-goto optimization active.
4009 -- Add return statement if last statement in body is not a return statement
4010 -- (this makes things easier on Gigi which does not want to have to handle
4011 -- a missing return).
4013 -- Add call to Activate_Tasks if body is a task activator
4015 -- Deal with possible detection of infinite recursion
4017 -- Eliminate body completely if convention stubbed
4019 -- Encode entity names within body, since we will not need to reference
4020 -- these entities any longer in the front end.
4022 -- Initialize scalar out parameters if Initialize/Normalize_Scalars
4024 -- Reset Pure indication if any parameter has root type System.Address
4028 procedure Expand_N_Subprogram_Body
(N
: Node_Id
) is
4029 Loc
: constant Source_Ptr
:= Sloc
(N
);
4030 H
: constant Node_Id
:= Handled_Statement_Sequence
(N
);
4031 Body_Id
: Entity_Id
;
4034 Spec_Id
: Entity_Id
;
4036 procedure Add_Return
(S
: List_Id
);
4037 -- Append a return statement to the statement sequence S if the last
4038 -- statement is not already a return or a goto statement. Note that
4039 -- the latter test is not critical, it does not matter if we add a
4040 -- few extra returns, since they get eliminated anyway later on.
4046 procedure Add_Return
(S
: List_Id
) is
4051 -- Get last statement, ignoring any Pop_xxx_Label nodes, which are
4052 -- not relevant in this context since they are not executable.
4054 Last_Stm
:= Last
(S
);
4055 while Nkind
(Last_Stm
) in N_Pop_xxx_Label
loop
4059 -- Now insert return unless last statement is a transfer
4061 if not Is_Transfer
(Last_Stm
) then
4063 -- The source location for the return is the end label of the
4064 -- procedure if present. Otherwise use the sloc of the last
4065 -- statement in the list. If the list comes from a generated
4066 -- exception handler and we are not debugging generated code,
4067 -- all the statements within the handler are made invisible
4070 if Nkind
(Parent
(S
)) = N_Exception_Handler
4071 and then not Comes_From_Source
(Parent
(S
))
4073 Loc
:= Sloc
(Last_Stm
);
4075 elsif Present
(End_Label
(H
)) then
4076 Loc
:= Sloc
(End_Label
(H
));
4079 Loc
:= Sloc
(Last_Stm
);
4082 Append_To
(S
, Make_Simple_Return_Statement
(Loc
));
4086 -- Start of processing for Expand_N_Subprogram_Body
4089 -- Set L to either the list of declarations if present, or
4090 -- to the list of statements if no declarations are present.
4091 -- This is used to insert new stuff at the start.
4093 if Is_Non_Empty_List
(Declarations
(N
)) then
4094 L
:= Declarations
(N
);
4096 L
:= Statements
(H
);
4099 -- If local-exception-to-goto optimization active, insert dummy push
4100 -- statements at start, and dummy pop statements at end.
4102 if (Debug_Flag_Dot_G
4103 or else Restriction_Active
(No_Exception_Propagation
))
4104 and then Is_Non_Empty_List
(L
)
4107 FS
: constant Node_Id
:= First
(L
);
4108 FL
: constant Source_Ptr
:= Sloc
(FS
);
4113 -- LS points to either last statement, if statements are present
4114 -- or to the last declaration if there are no statements present.
4115 -- It is the node after which the pop's are generated.
4117 if Is_Non_Empty_List
(Statements
(H
)) then
4118 LS
:= Last
(Statements
(H
));
4125 Insert_List_Before_And_Analyze
(FS
, New_List
(
4126 Make_Push_Constraint_Error_Label
(FL
),
4127 Make_Push_Program_Error_Label
(FL
),
4128 Make_Push_Storage_Error_Label
(FL
)));
4130 Insert_List_After_And_Analyze
(LS
, New_List
(
4131 Make_Pop_Constraint_Error_Label
(LL
),
4132 Make_Pop_Program_Error_Label
(LL
),
4133 Make_Pop_Storage_Error_Label
(LL
)));
4137 -- Find entity for subprogram
4139 Body_Id
:= Defining_Entity
(N
);
4141 if Present
(Corresponding_Spec
(N
)) then
4142 Spec_Id
:= Corresponding_Spec
(N
);
4147 -- Need poll on entry to subprogram if polling enabled. We only do this
4148 -- for non-empty subprograms, since it does not seem necessary to poll
4149 -- for a dummy null subprogram. Do not add polling point if calls to
4150 -- this subprogram will be inlined by the back-end, to avoid repeated
4151 -- polling points in nested inlinings.
4153 if Is_Non_Empty_List
(L
) then
4154 if Is_Inlined
(Spec_Id
)
4155 and then Front_End_Inlining
4156 and then Optimization_Level
> 1
4160 Generate_Poll_Call
(First
(L
));
4164 -- If this is a Pure function which has any parameters whose root
4165 -- type is System.Address, reset the Pure indication, since it will
4166 -- likely cause incorrect code to be generated as the parameter is
4167 -- probably a pointer, and the fact that the same pointer is passed
4168 -- does not mean that the same value is being referenced.
4170 -- Note that if the programmer gave an explicit Pure_Function pragma,
4171 -- then we believe the programmer, and leave the subprogram Pure.
4173 -- This code should probably be at the freeze point, so that it
4174 -- happens even on a -gnatc (or more importantly -gnatt) compile
4175 -- so that the semantic tree has Is_Pure set properly ???
4177 if Is_Pure
(Spec_Id
)
4178 and then Is_Subprogram
(Spec_Id
)
4179 and then not Has_Pragma_Pure_Function
(Spec_Id
)
4185 F
:= First_Formal
(Spec_Id
);
4186 while Present
(F
) loop
4187 if Is_Descendent_Of_Address
(Etype
(F
)) then
4188 Set_Is_Pure
(Spec_Id
, False);
4190 if Spec_Id
/= Body_Id
then
4191 Set_Is_Pure
(Body_Id
, False);
4202 -- Initialize any scalar OUT args if Initialize/Normalize_Scalars
4204 if Init_Or_Norm_Scalars
and then Is_Subprogram
(Spec_Id
) then
4209 -- Loop through formals
4211 F
:= First_Formal
(Spec_Id
);
4212 while Present
(F
) loop
4213 if Is_Scalar_Type
(Etype
(F
))
4214 and then Ekind
(F
) = E_Out_Parameter
4216 Check_Restriction
(No_Default_Initialization
, F
);
4218 -- Insert the initialization. We turn off validity checks
4219 -- for this assignment, since we do not want any check on
4220 -- the initial value itself (which may well be invalid).
4222 Insert_Before_And_Analyze
(First
(L
),
4223 Make_Assignment_Statement
(Loc
,
4224 Name
=> New_Occurrence_Of
(F
, Loc
),
4225 Expression
=> Get_Simple_Init_Val
(Etype
(F
), N
)),
4226 Suppress
=> Validity_Check
);
4234 -- Clear out statement list for stubbed procedure
4236 if Present
(Corresponding_Spec
(N
)) then
4237 Set_Elaboration_Flag
(N
, Spec_Id
);
4239 if Convention
(Spec_Id
) = Convention_Stubbed
4240 or else Is_Eliminated
(Spec_Id
)
4242 Set_Declarations
(N
, Empty_List
);
4243 Set_Handled_Statement_Sequence
(N
,
4244 Make_Handled_Sequence_Of_Statements
(Loc
,
4245 Statements
=> New_List
(
4246 Make_Null_Statement
(Loc
))));
4251 -- Create a set of discriminals for the next protected subprogram body
4253 if Is_List_Member
(N
)
4254 and then Present
(Parent
(List_Containing
(N
)))
4255 and then Nkind
(Parent
(List_Containing
(N
))) = N_Protected_Body
4256 and then Present
(Next_Protected_Operation
(N
))
4258 Set_Discriminals
(Parent
(Base_Type
(Scope
(Spec_Id
))));
4261 -- Returns_By_Ref flag is normally set when the subprogram is frozen
4262 -- but subprograms with no specs are not frozen.
4265 Typ
: constant Entity_Id
:= Etype
(Spec_Id
);
4266 Utyp
: constant Entity_Id
:= Underlying_Type
(Typ
);
4269 if not Acts_As_Spec
(N
)
4270 and then Nkind
(Parent
(Parent
(Spec_Id
))) /=
4271 N_Subprogram_Body_Stub
4275 elsif Is_Inherently_Limited_Type
(Typ
) then
4276 Set_Returns_By_Ref
(Spec_Id
);
4278 elsif Present
(Utyp
) and then CW_Or_Has_Controlled_Part
(Utyp
) then
4279 Set_Returns_By_Ref
(Spec_Id
);
4283 -- For a procedure, we add a return for all possible syntactic ends
4284 -- of the subprogram. Note that reanalysis is not necessary in this
4285 -- case since it would require a lot of work and accomplish nothing.
4287 if Ekind
(Spec_Id
) = E_Procedure
4288 or else Ekind
(Spec_Id
) = E_Generic_Procedure
4290 Add_Return
(Statements
(H
));
4292 if Present
(Exception_Handlers
(H
)) then
4293 Except_H
:= First_Non_Pragma
(Exception_Handlers
(H
));
4294 while Present
(Except_H
) loop
4295 Add_Return
(Statements
(Except_H
));
4296 Next_Non_Pragma
(Except_H
);
4300 -- For a function, we must deal with the case where there is at least
4301 -- one missing return. What we do is to wrap the entire body of the
4302 -- function in a block:
4315 -- raise Program_Error;
4318 -- This approach is necessary because the raise must be signalled
4319 -- to the caller, not handled by any local handler (RM 6.4(11)).
4321 -- Note: we do not need to analyze the constructed sequence here,
4322 -- since it has no handler, and an attempt to analyze the handled
4323 -- statement sequence twice is risky in various ways (e.g. the
4324 -- issue of expanding cleanup actions twice).
4326 elsif Has_Missing_Return
(Spec_Id
) then
4328 Hloc
: constant Source_Ptr
:= Sloc
(H
);
4329 Blok
: constant Node_Id
:=
4330 Make_Block_Statement
(Hloc
,
4331 Handled_Statement_Sequence
=> H
);
4332 Rais
: constant Node_Id
:=
4333 Make_Raise_Program_Error
(Hloc
,
4334 Reason
=> PE_Missing_Return
);
4337 Set_Handled_Statement_Sequence
(N
,
4338 Make_Handled_Sequence_Of_Statements
(Hloc
,
4339 Statements
=> New_List
(Blok
, Rais
)));
4341 Push_Scope
(Spec_Id
);
4348 -- If subprogram contains a parameterless recursive call, then we may
4349 -- have an infinite recursion, so see if we can generate code to check
4350 -- for this possibility if storage checks are not suppressed.
4352 if Ekind
(Spec_Id
) = E_Procedure
4353 and then Has_Recursive_Call
(Spec_Id
)
4354 and then not Storage_Checks_Suppressed
(Spec_Id
)
4356 Detect_Infinite_Recursion
(N
, Spec_Id
);
4359 -- Set to encode entity names in package body before gigi is called
4361 Qualify_Entity_Names
(N
);
4362 end Expand_N_Subprogram_Body
;
4364 -----------------------------------
4365 -- Expand_N_Subprogram_Body_Stub --
4366 -----------------------------------
4368 procedure Expand_N_Subprogram_Body_Stub
(N
: Node_Id
) is
4370 if Present
(Corresponding_Body
(N
)) then
4371 Expand_N_Subprogram_Body
(
4372 Unit_Declaration_Node
(Corresponding_Body
(N
)));
4374 end Expand_N_Subprogram_Body_Stub
;
4376 -------------------------------------
4377 -- Expand_N_Subprogram_Declaration --
4378 -------------------------------------
4380 -- If the declaration appears within a protected body, it is a private
4381 -- operation of the protected type. We must create the corresponding
4382 -- protected subprogram an associated formals. For a normal protected
4383 -- operation, this is done when expanding the protected type declaration.
4385 -- If the declaration is for a null procedure, emit null body
4387 procedure Expand_N_Subprogram_Declaration
(N
: Node_Id
) is
4388 Loc
: constant Source_Ptr
:= Sloc
(N
);
4389 Subp
: constant Entity_Id
:= Defining_Entity
(N
);
4390 Scop
: constant Entity_Id
:= Scope
(Subp
);
4391 Prot_Decl
: Node_Id
;
4393 Prot_Id
: Entity_Id
;
4396 -- Deal with case of protected subprogram. Do not generate protected
4397 -- operation if operation is flagged as eliminated.
4399 if Is_List_Member
(N
)
4400 and then Present
(Parent
(List_Containing
(N
)))
4401 and then Nkind
(Parent
(List_Containing
(N
))) = N_Protected_Body
4402 and then Is_Protected_Type
(Scop
)
4404 if No
(Protected_Body_Subprogram
(Subp
))
4405 and then not Is_Eliminated
(Subp
)
4408 Make_Subprogram_Declaration
(Loc
,
4410 Build_Protected_Sub_Specification
4411 (N
, Scop
, Unprotected_Mode
));
4413 -- The protected subprogram is declared outside of the protected
4414 -- body. Given that the body has frozen all entities so far, we
4415 -- analyze the subprogram and perform freezing actions explicitly.
4416 -- including the generation of an explicit freeze node, to ensure
4417 -- that gigi has the proper order of elaboration.
4418 -- If the body is a subunit, the insertion point is before the
4419 -- stub in the parent.
4421 Prot_Bod
:= Parent
(List_Containing
(N
));
4423 if Nkind
(Parent
(Prot_Bod
)) = N_Subunit
then
4424 Prot_Bod
:= Corresponding_Stub
(Parent
(Prot_Bod
));
4427 Insert_Before
(Prot_Bod
, Prot_Decl
);
4428 Prot_Id
:= Defining_Unit_Name
(Specification
(Prot_Decl
));
4429 Set_Has_Delayed_Freeze
(Prot_Id
);
4431 Push_Scope
(Scope
(Scop
));
4432 Analyze
(Prot_Decl
);
4433 Insert_Actions
(N
, Freeze_Entity
(Prot_Id
, Loc
));
4434 Set_Protected_Body_Subprogram
(Subp
, Prot_Id
);
4438 -- Ada 2005 (AI-348): Generation of the null body
4440 elsif Nkind
(Specification
(N
)) = N_Procedure_Specification
4441 and then Null_Present
(Specification
(N
))
4444 Bod
: constant Node_Id
:=
4445 Make_Subprogram_Body
(Loc
,
4447 New_Copy_Tree
(Specification
(N
)),
4448 Declarations
=> New_List
,
4449 Handled_Statement_Sequence
=>
4450 Make_Handled_Sequence_Of_Statements
(Loc
,
4451 Statements
=> New_List
(Make_Null_Statement
(Loc
))));
4453 Set_Body_To_Inline
(N
, Bod
);
4454 Insert_After
(N
, Bod
);
4457 -- Corresponding_Spec isn't being set by Analyze_Subprogram_Body,
4458 -- evidently because Set_Has_Completion is called earlier for null
4459 -- procedures in Analyze_Subprogram_Declaration, so we force its
4460 -- setting here. If the setting of Has_Completion is not set
4461 -- earlier, then it can result in missing body errors if other
4462 -- errors were already reported (since expansion is turned off).
4464 -- Should creation of the empty body be moved to the analyzer???
4466 Set_Corresponding_Spec
(Bod
, Defining_Entity
(Specification
(N
)));
4469 end Expand_N_Subprogram_Declaration
;
4471 ---------------------------------------
4472 -- Expand_Protected_Object_Reference --
4473 ---------------------------------------
4475 function Expand_Protected_Object_Reference
4477 Scop
: Entity_Id
) return Node_Id
4479 Loc
: constant Source_Ptr
:= Sloc
(N
);
4487 Make_Identifier
(Loc
,
4488 Chars
=> Name_uObject
);
4489 Set_Etype
(Rec
, Corresponding_Record_Type
(Scop
));
4491 -- Find enclosing protected operation, and retrieve its first parameter,
4492 -- which denotes the enclosing protected object. If the enclosing
4493 -- operation is an entry, we are immediately within the protected body,
4494 -- and we can retrieve the object from the service entries procedure. A
4495 -- barrier function has has the same signature as an entry. A barrier
4496 -- function is compiled within the protected object, but unlike
4497 -- protected operations its never needs locks, so that its protected
4498 -- body subprogram points to itself.
4500 Proc
:= Current_Scope
;
4501 while Present
(Proc
)
4502 and then Scope
(Proc
) /= Scop
4504 Proc
:= Scope
(Proc
);
4507 Corr
:= Protected_Body_Subprogram
(Proc
);
4511 -- Previous error left expansion incomplete.
4512 -- Nothing to do on this call.
4519 (First
(Parameter_Specifications
(Parent
(Corr
))));
4521 if Is_Subprogram
(Proc
)
4522 and then Proc
/= Corr
4524 -- Protected function or procedure
4526 Set_Entity
(Rec
, Param
);
4528 -- Rec is a reference to an entity which will not be in scope when
4529 -- the call is reanalyzed, and needs no further analysis.
4534 -- Entry or barrier function for entry body. The first parameter of
4535 -- the entry body procedure is pointer to the object. We create a
4536 -- local variable of the proper type, duplicating what is done to
4537 -- define _object later on.
4541 Obj_Ptr
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
,
4543 New_Internal_Name
('T'));
4547 Make_Full_Type_Declaration
(Loc
,
4548 Defining_Identifier
=> Obj_Ptr
,
4550 Make_Access_To_Object_Definition
(Loc
,
4551 Subtype_Indication
=>
4553 (Corresponding_Record_Type
(Scop
), Loc
))));
4555 Insert_Actions
(N
, Decls
);
4556 Insert_Actions
(N
, Freeze_Entity
(Obj_Ptr
, Sloc
(N
)));
4559 Make_Explicit_Dereference
(Loc
,
4560 Unchecked_Convert_To
(Obj_Ptr
,
4561 New_Occurrence_Of
(Param
, Loc
)));
4563 -- Analyze new actual. Other actuals in calls are already analyzed
4564 -- and the list of actuals is not reanalyzed after rewriting.
4566 Set_Parent
(Rec
, N
);
4572 end Expand_Protected_Object_Reference
;
4574 --------------------------------------
4575 -- Expand_Protected_Subprogram_Call --
4576 --------------------------------------
4578 procedure Expand_Protected_Subprogram_Call
4586 -- If the protected object is not an enclosing scope, this is
4587 -- an inter-object function call. Inter-object procedure
4588 -- calls are expanded by Exp_Ch9.Build_Simple_Entry_Call.
4589 -- The call is intra-object only if the subprogram being
4590 -- called is in the protected body being compiled, and if the
4591 -- protected object in the call is statically the enclosing type.
4592 -- The object may be an component of some other data structure,
4593 -- in which case this must be handled as an inter-object call.
4595 if not In_Open_Scopes
(Scop
)
4596 or else not Is_Entity_Name
(Name
(N
))
4598 if Nkind
(Name
(N
)) = N_Selected_Component
then
4599 Rec
:= Prefix
(Name
(N
));
4602 pragma Assert
(Nkind
(Name
(N
)) = N_Indexed_Component
);
4603 Rec
:= Prefix
(Prefix
(Name
(N
)));
4606 Build_Protected_Subprogram_Call
(N
,
4607 Name
=> New_Occurrence_Of
(Subp
, Sloc
(N
)),
4608 Rec
=> Convert_Concurrent
(Rec
, Etype
(Rec
)),
4612 Rec
:= Expand_Protected_Object_Reference
(N
, Scop
);
4618 Build_Protected_Subprogram_Call
(N
,
4627 -- If it is a function call it can appear in elaboration code and
4628 -- the called entity must be frozen here.
4630 if Ekind
(Subp
) = E_Function
then
4631 Freeze_Expression
(Name
(N
));
4633 end Expand_Protected_Subprogram_Call
;
4635 --------------------------------
4636 -- Is_Build_In_Place_Function --
4637 --------------------------------
4639 function Is_Build_In_Place_Function
(E
: Entity_Id
) return Boolean is
4641 -- For now we test whether E denotes a function or access-to-function
4642 -- type whose result subtype is inherently limited. Later this test may
4643 -- be revised to allow composite nonlimited types. Functions with a
4644 -- foreign convention or whose result type has a foreign convention
4647 if Ekind
(E
) = E_Function
4648 or else Ekind
(E
) = E_Generic_Function
4649 or else (Ekind
(E
) = E_Subprogram_Type
4650 and then Etype
(E
) /= Standard_Void_Type
)
4652 -- Note: If you have Convention (C) on an inherently limited type,
4653 -- you're on your own. That is, the C code will have to be carefully
4654 -- written to know about the Ada conventions.
4656 if Has_Foreign_Convention
(E
)
4657 or else Has_Foreign_Convention
(Etype
(E
))
4661 -- If the return type is a limited interface it has to be treated
4662 -- as a return in place, even if the actual object is some non-
4663 -- limited descendant.
4665 elsif Is_Limited_Interface
(Etype
(E
)) then
4669 return Is_Inherently_Limited_Type
(Etype
(E
))
4670 and then Ada_Version
>= Ada_05
4671 and then not Debug_Flag_Dot_L
;
4677 end Is_Build_In_Place_Function
;
4679 -------------------------------------
4680 -- Is_Build_In_Place_Function_Call --
4681 -------------------------------------
4683 function Is_Build_In_Place_Function_Call
(N
: Node_Id
) return Boolean is
4684 Exp_Node
: Node_Id
:= N
;
4685 Function_Id
: Entity_Id
;
4688 -- Step past qualification or unchecked conversion (the latter can occur
4689 -- in cases of calls to 'Input).
4692 (Exp_Node
, N_Qualified_Expression
, N_Unchecked_Type_Conversion
)
4694 Exp_Node
:= Expression
(N
);
4697 if Nkind
(Exp_Node
) /= N_Function_Call
then
4701 if Is_Entity_Name
(Name
(Exp_Node
)) then
4702 Function_Id
:= Entity
(Name
(Exp_Node
));
4704 elsif Nkind
(Name
(Exp_Node
)) = N_Explicit_Dereference
then
4705 Function_Id
:= Etype
(Name
(Exp_Node
));
4708 return Is_Build_In_Place_Function
(Function_Id
);
4710 end Is_Build_In_Place_Function_Call
;
4712 ---------------------------------------
4713 -- Is_Build_In_Place_Function_Return --
4714 ---------------------------------------
4716 function Is_Build_In_Place_Function_Return
(N
: Node_Id
) return Boolean is
4718 if Nkind_In
(N
, N_Simple_Return_Statement
,
4719 N_Extended_Return_Statement
)
4721 return Is_Build_In_Place_Function
4722 (Return_Applies_To
(Return_Statement_Entity
(N
)));
4726 end Is_Build_In_Place_Function_Return
;
4728 -----------------------
4729 -- Freeze_Subprogram --
4730 -----------------------
4732 procedure Freeze_Subprogram
(N
: Node_Id
) is
4733 Loc
: constant Source_Ptr
:= Sloc
(N
);
4735 procedure Register_Predefined_DT_Entry
(Prim
: Entity_Id
);
4736 -- (Ada 2005): Register a predefined primitive in all the secondary
4737 -- dispatch tables of its primitive type.
4739 ----------------------------------
4740 -- Register_Predefined_DT_Entry --
4741 ----------------------------------
4743 procedure Register_Predefined_DT_Entry
(Prim
: Entity_Id
) is
4744 Iface_DT_Ptr
: Elmt_Id
;
4745 Tagged_Typ
: Entity_Id
;
4746 Thunk_Id
: Entity_Id
;
4747 Thunk_Code
: Node_Id
;
4750 Tagged_Typ
:= Find_Dispatching_Type
(Prim
);
4752 if No
(Access_Disp_Table
(Tagged_Typ
))
4753 or else not Has_Interfaces
(Tagged_Typ
)
4754 or else not RTE_Available
(RE_Interface_Tag
)
4755 or else Restriction_Active
(No_Dispatching_Calls
)
4760 -- Skip the first two access-to-dispatch-table pointers since they
4761 -- leads to the primary dispatch table (predefined DT and user
4762 -- defined DT). We are only concerned with the secondary dispatch
4763 -- table pointers. Note that the access-to- dispatch-table pointer
4764 -- corresponds to the first implemented interface retrieved below.
4767 Next_Elmt
(Next_Elmt
(First_Elmt
(Access_Disp_Table
(Tagged_Typ
))));
4769 while Present
(Iface_DT_Ptr
)
4770 and then Ekind
(Node
(Iface_DT_Ptr
)) = E_Constant
4772 pragma Assert
(Has_Thunks
(Node
(Iface_DT_Ptr
)));
4773 Expand_Interface_Thunk
(Prim
, Thunk_Id
, Thunk_Code
);
4775 if Present
(Thunk_Code
) then
4776 Insert_Actions_After
(N
, New_List
(
4779 Build_Set_Predefined_Prim_Op_Address
(Loc
,
4781 New_Reference_To
(Node
(Next_Elmt
(Iface_DT_Ptr
)), Loc
),
4782 Position
=> DT_Position
(Prim
),
4784 Unchecked_Convert_To
(RTE
(RE_Prim_Ptr
),
4785 Make_Attribute_Reference
(Loc
,
4786 Prefix
=> New_Reference_To
(Thunk_Id
, Loc
),
4787 Attribute_Name
=> Name_Unrestricted_Access
))),
4789 Build_Set_Predefined_Prim_Op_Address
(Loc
,
4792 (Node
(Next_Elmt
(Next_Elmt
(Next_Elmt
(Iface_DT_Ptr
)))),
4794 Position
=> DT_Position
(Prim
),
4796 Unchecked_Convert_To
(RTE
(RE_Prim_Ptr
),
4797 Make_Attribute_Reference
(Loc
,
4798 Prefix
=> New_Reference_To
(Prim
, Loc
),
4799 Attribute_Name
=> Name_Unrestricted_Access
)))));
4802 -- Skip the tag of the predefined primitives dispatch table
4804 Next_Elmt
(Iface_DT_Ptr
);
4805 pragma Assert
(Has_Thunks
(Node
(Iface_DT_Ptr
)));
4807 -- Skip the tag of the no-thunks dispatch table
4809 Next_Elmt
(Iface_DT_Ptr
);
4810 pragma Assert
(not Has_Thunks
(Node
(Iface_DT_Ptr
)));
4812 -- Skip the tag of the predefined primitives no-thunks dispatch
4815 Next_Elmt
(Iface_DT_Ptr
);
4816 pragma Assert
(not Has_Thunks
(Node
(Iface_DT_Ptr
)));
4818 Next_Elmt
(Iface_DT_Ptr
);
4820 end Register_Predefined_DT_Entry
;
4824 Subp
: constant Entity_Id
:= Entity
(N
);
4826 -- Start of processing for Freeze_Subprogram
4829 -- We suppress the initialization of the dispatch table entry when
4830 -- VM_Target because the dispatching mechanism is handled internally
4833 if Is_Dispatching_Operation
(Subp
)
4834 and then not Is_Abstract_Subprogram
(Subp
)
4835 and then Present
(DTC_Entity
(Subp
))
4836 and then Present
(Scope
(DTC_Entity
(Subp
)))
4837 and then VM_Target
= No_VM
4838 and then not Restriction_Active
(No_Dispatching_Calls
)
4839 and then RTE_Available
(RE_Tag
)
4842 Typ
: constant Entity_Id
:= Scope
(DTC_Entity
(Subp
));
4845 -- Handle private overridden primitives
4847 if not Is_CPP_Class
(Typ
) then
4848 Check_Overriding_Operation
(Subp
);
4851 -- We assume that imported CPP primitives correspond with objects
4852 -- whose constructor is in the CPP side; therefore we don't need
4853 -- to generate code to register them in the dispatch table.
4855 if Is_CPP_Class
(Typ
) then
4858 -- Handle CPP primitives found in derivations of CPP_Class types.
4859 -- These primitives must have been inherited from some parent, and
4860 -- there is no need to register them in the dispatch table because
4861 -- Build_Inherit_Prims takes care of the initialization of these
4864 elsif Is_Imported
(Subp
)
4865 and then (Convention
(Subp
) = Convention_CPP
4866 or else Convention
(Subp
) = Convention_C
)
4870 -- Generate code to register the primitive in non statically
4871 -- allocated dispatch tables
4873 elsif not Static_Dispatch_Tables
4875 Is_Library_Level_Tagged_Type
(Scope
(DTC_Entity
(Subp
)))
4877 -- When a primitive is frozen, enter its name in its dispatch
4880 if not Is_Interface
(Typ
)
4881 or else Present
(Interface_Alias
(Subp
))
4883 if Is_Predefined_Dispatching_Operation
(Subp
) then
4884 Register_Predefined_DT_Entry
(Subp
);
4887 Register_Primitive
(Loc
,
4895 -- Mark functions that return by reference. Note that it cannot be part
4896 -- of the normal semantic analysis of the spec since the underlying
4897 -- returned type may not be known yet (for private types).
4900 Typ
: constant Entity_Id
:= Etype
(Subp
);
4901 Utyp
: constant Entity_Id
:= Underlying_Type
(Typ
);
4903 if Is_Inherently_Limited_Type
(Typ
) then
4904 Set_Returns_By_Ref
(Subp
);
4905 elsif Present
(Utyp
) and then CW_Or_Has_Controlled_Part
(Utyp
) then
4906 Set_Returns_By_Ref
(Subp
);
4909 end Freeze_Subprogram
;
4911 -------------------------------------------
4912 -- Make_Build_In_Place_Call_In_Allocator --
4913 -------------------------------------------
4915 procedure Make_Build_In_Place_Call_In_Allocator
4916 (Allocator
: Node_Id
;
4917 Function_Call
: Node_Id
)
4920 Func_Call
: Node_Id
:= Function_Call
;
4921 Function_Id
: Entity_Id
;
4922 Result_Subt
: Entity_Id
;
4923 Acc_Type
: constant Entity_Id
:= Etype
(Allocator
);
4924 New_Allocator
: Node_Id
;
4925 Return_Obj_Access
: Entity_Id
;
4928 -- Step past qualification or unchecked conversion (the latter can occur
4929 -- in cases of calls to 'Input).
4931 if Nkind_In
(Func_Call
,
4932 N_Qualified_Expression
,
4933 N_Unchecked_Type_Conversion
)
4935 Func_Call
:= Expression
(Func_Call
);
4938 -- If the call has already been processed to add build-in-place actuals
4939 -- then return. This should not normally occur in an allocator context,
4940 -- but we add the protection as a defensive measure.
4942 if Is_Expanded_Build_In_Place_Call
(Func_Call
) then
4946 -- Mark the call as processed as a build-in-place call
4948 Set_Is_Expanded_Build_In_Place_Call
(Func_Call
);
4950 Loc
:= Sloc
(Function_Call
);
4952 if Is_Entity_Name
(Name
(Func_Call
)) then
4953 Function_Id
:= Entity
(Name
(Func_Call
));
4955 elsif Nkind
(Name
(Func_Call
)) = N_Explicit_Dereference
then
4956 Function_Id
:= Etype
(Name
(Func_Call
));
4959 raise Program_Error
;
4962 Result_Subt
:= Etype
(Function_Id
);
4964 -- When the result subtype is constrained, the return object must be
4965 -- allocated on the caller side, and access to it is passed to the
4968 -- Here and in related routines, we must examine the full view of the
4969 -- type, because the view at the point of call may differ from that
4970 -- that in the function body, and the expansion mechanism depends on
4971 -- the characteristics of the full view.
4973 if Is_Constrained
(Underlying_Type
(Result_Subt
)) then
4975 -- Replace the initialized allocator of form "new T'(Func (...))"
4976 -- with an uninitialized allocator of form "new T", where T is the
4977 -- result subtype of the called function. The call to the function
4978 -- is handled separately further below.
4981 Make_Allocator
(Loc
, New_Reference_To
(Result_Subt
, Loc
));
4983 Set_Storage_Pool
(New_Allocator
, Storage_Pool
(Allocator
));
4984 Set_Procedure_To_Call
(New_Allocator
, Procedure_To_Call
(Allocator
));
4985 Set_No_Initialization
(New_Allocator
);
4987 Rewrite
(Allocator
, New_Allocator
);
4989 -- Create a new access object and initialize it to the result of the
4990 -- new uninitialized allocator.
4992 Return_Obj_Access
:=
4993 Make_Defining_Identifier
(Loc
, New_Internal_Name
('R'));
4994 Set_Etype
(Return_Obj_Access
, Acc_Type
);
4996 Insert_Action
(Allocator
,
4997 Make_Object_Declaration
(Loc
,
4998 Defining_Identifier
=> Return_Obj_Access
,
4999 Object_Definition
=> New_Reference_To
(Acc_Type
, Loc
),
5000 Expression
=> Relocate_Node
(Allocator
)));
5002 -- When the function has a controlling result, an allocation-form
5003 -- parameter must be passed indicating that the caller is allocating
5004 -- the result object. This is needed because such a function can be
5005 -- called as a dispatching operation and must be treated similarly
5006 -- to functions with unconstrained result subtypes.
5008 Add_Alloc_Form_Actual_To_Build_In_Place_Call
5009 (Func_Call
, Function_Id
, Alloc_Form
=> Caller_Allocation
);
5011 Add_Final_List_Actual_To_Build_In_Place_Call
5012 (Func_Call
, Function_Id
, Acc_Type
);
5014 Add_Task_Actuals_To_Build_In_Place_Call
5015 (Func_Call
, Function_Id
, Master_Actual
=> Master_Id
(Acc_Type
));
5017 -- Add an implicit actual to the function call that provides access
5018 -- to the allocated object. An unchecked conversion to the (specific)
5019 -- result subtype of the function is inserted to handle cases where
5020 -- the access type of the allocator has a class-wide designated type.
5022 Add_Access_Actual_To_Build_In_Place_Call
5025 Make_Unchecked_Type_Conversion
(Loc
,
5026 Subtype_Mark
=> New_Reference_To
(Result_Subt
, Loc
),
5028 Make_Explicit_Dereference
(Loc
,
5029 Prefix
=> New_Reference_To
(Return_Obj_Access
, Loc
))));
5031 -- When the result subtype is unconstrained, the function itself must
5032 -- perform the allocation of the return object, so we pass parameters
5033 -- indicating that. We don't yet handle the case where the allocation
5034 -- must be done in a user-defined storage pool, which will require
5035 -- passing another actual or two to provide allocation/deallocation
5040 -- Pass an allocation parameter indicating that the function should
5041 -- allocate its result on the heap.
5043 Add_Alloc_Form_Actual_To_Build_In_Place_Call
5044 (Func_Call
, Function_Id
, Alloc_Form
=> Global_Heap
);
5046 Add_Final_List_Actual_To_Build_In_Place_Call
5047 (Func_Call
, Function_Id
, Acc_Type
);
5049 Add_Task_Actuals_To_Build_In_Place_Call
5050 (Func_Call
, Function_Id
, Master_Actual
=> Master_Id
(Acc_Type
));
5052 -- The caller does not provide the return object in this case, so we
5053 -- have to pass null for the object access actual.
5055 Add_Access_Actual_To_Build_In_Place_Call
5056 (Func_Call
, Function_Id
, Return_Object
=> Empty
);
5059 -- Finally, replace the allocator node with a reference to the result
5060 -- of the function call itself (which will effectively be an access
5061 -- to the object created by the allocator).
5063 Rewrite
(Allocator
, Make_Reference
(Loc
, Relocate_Node
(Function_Call
)));
5064 Analyze_And_Resolve
(Allocator
, Acc_Type
);
5065 end Make_Build_In_Place_Call_In_Allocator
;
5067 ---------------------------------------------------
5068 -- Make_Build_In_Place_Call_In_Anonymous_Context --
5069 ---------------------------------------------------
5071 procedure Make_Build_In_Place_Call_In_Anonymous_Context
5072 (Function_Call
: Node_Id
)
5075 Func_Call
: Node_Id
:= Function_Call
;
5076 Function_Id
: Entity_Id
;
5077 Result_Subt
: Entity_Id
;
5078 Return_Obj_Id
: Entity_Id
;
5079 Return_Obj_Decl
: Entity_Id
;
5082 -- Step past qualification or unchecked conversion (the latter can occur
5083 -- in cases of calls to 'Input).
5085 if Nkind_In
(Func_Call
, N_Qualified_Expression
,
5086 N_Unchecked_Type_Conversion
)
5088 Func_Call
:= Expression
(Func_Call
);
5091 -- If the call has already been processed to add build-in-place actuals
5092 -- then return. One place this can occur is for calls to build-in-place
5093 -- functions that occur within a call to a protected operation, where
5094 -- due to rewriting and expansion of the protected call there can be
5095 -- more than one call to Expand_Actuals for the same set of actuals.
5097 if Is_Expanded_Build_In_Place_Call
(Func_Call
) then
5101 -- Mark the call as processed as a build-in-place call
5103 Set_Is_Expanded_Build_In_Place_Call
(Func_Call
);
5105 Loc
:= Sloc
(Function_Call
);
5107 if Is_Entity_Name
(Name
(Func_Call
)) then
5108 Function_Id
:= Entity
(Name
(Func_Call
));
5110 elsif Nkind
(Name
(Func_Call
)) = N_Explicit_Dereference
then
5111 Function_Id
:= Etype
(Name
(Func_Call
));
5114 raise Program_Error
;
5117 Result_Subt
:= Etype
(Function_Id
);
5119 -- When the result subtype is constrained, an object of the subtype is
5120 -- declared and an access value designating it is passed as an actual.
5122 if Is_Constrained
(Underlying_Type
(Result_Subt
)) then
5124 -- Create a temporary object to hold the function result
5127 Make_Defining_Identifier
(Loc
,
5128 Chars
=> New_Internal_Name
('R'));
5129 Set_Etype
(Return_Obj_Id
, Result_Subt
);
5132 Make_Object_Declaration
(Loc
,
5133 Defining_Identifier
=> Return_Obj_Id
,
5134 Aliased_Present
=> True,
5135 Object_Definition
=> New_Reference_To
(Result_Subt
, Loc
));
5137 Set_No_Initialization
(Return_Obj_Decl
);
5139 Insert_Action
(Func_Call
, Return_Obj_Decl
);
5141 -- When the function has a controlling result, an allocation-form
5142 -- parameter must be passed indicating that the caller is allocating
5143 -- the result object. This is needed because such a function can be
5144 -- called as a dispatching operation and must be treated similarly
5145 -- to functions with unconstrained result subtypes.
5147 Add_Alloc_Form_Actual_To_Build_In_Place_Call
5148 (Func_Call
, Function_Id
, Alloc_Form
=> Caller_Allocation
);
5150 Add_Final_List_Actual_To_Build_In_Place_Call
5151 (Func_Call
, Function_Id
, Acc_Type
=> Empty
);
5153 Add_Task_Actuals_To_Build_In_Place_Call
5154 (Func_Call
, Function_Id
, Make_Identifier
(Loc
, Name_uMaster
));
5156 -- Add an implicit actual to the function call that provides access
5157 -- to the caller's return object.
5159 Add_Access_Actual_To_Build_In_Place_Call
5160 (Func_Call
, Function_Id
, New_Reference_To
(Return_Obj_Id
, Loc
));
5162 -- When the result subtype is unconstrained, the function must allocate
5163 -- the return object in the secondary stack, so appropriate implicit
5164 -- parameters are added to the call to indicate that. A transient
5165 -- scope is established to ensure eventual cleanup of the result.
5169 -- Pass an allocation parameter indicating that the function should
5170 -- allocate its result on the secondary stack.
5172 Add_Alloc_Form_Actual_To_Build_In_Place_Call
5173 (Func_Call
, Function_Id
, Alloc_Form
=> Secondary_Stack
);
5175 Add_Final_List_Actual_To_Build_In_Place_Call
5176 (Func_Call
, Function_Id
, Acc_Type
=> Empty
);
5178 Add_Task_Actuals_To_Build_In_Place_Call
5179 (Func_Call
, Function_Id
, Make_Identifier
(Loc
, Name_uMaster
));
5181 -- Pass a null value to the function since no return object is
5182 -- available on the caller side.
5184 Add_Access_Actual_To_Build_In_Place_Call
5185 (Func_Call
, Function_Id
, Empty
);
5187 Establish_Transient_Scope
(Func_Call
, Sec_Stack
=> True);
5189 end Make_Build_In_Place_Call_In_Anonymous_Context
;
5191 --------------------------------------------
5192 -- Make_Build_In_Place_Call_In_Assignment --
5193 --------------------------------------------
5195 procedure Make_Build_In_Place_Call_In_Assignment
5197 Function_Call
: Node_Id
)
5199 Lhs
: constant Node_Id
:= Name
(Assign
);
5201 Func_Call
: Node_Id
:= Function_Call
;
5202 Function_Id
: Entity_Id
;
5203 Result_Subt
: Entity_Id
;
5204 Ref_Type
: Entity_Id
;
5205 Ptr_Typ_Decl
: Node_Id
;
5210 -- Step past qualification or unchecked conversion (the latter can occur
5211 -- in cases of calls to 'Input).
5213 if Nkind_In
(Func_Call
, N_Qualified_Expression
,
5214 N_Unchecked_Type_Conversion
)
5216 Func_Call
:= Expression
(Func_Call
);
5219 -- If the call has already been processed to add build-in-place actuals
5220 -- then return. This should not normally occur in an assignment context,
5221 -- but we add the protection as a defensive measure.
5223 if Is_Expanded_Build_In_Place_Call
(Func_Call
) then
5227 -- Mark the call as processed as a build-in-place call
5229 Set_Is_Expanded_Build_In_Place_Call
(Func_Call
);
5231 Loc
:= Sloc
(Function_Call
);
5233 if Is_Entity_Name
(Name
(Func_Call
)) then
5234 Function_Id
:= Entity
(Name
(Func_Call
));
5236 elsif Nkind
(Name
(Func_Call
)) = N_Explicit_Dereference
then
5237 Function_Id
:= Etype
(Name
(Func_Call
));
5240 raise Program_Error
;
5243 Result_Subt
:= Etype
(Function_Id
);
5245 -- When the result subtype is unconstrained, an additional actual must
5246 -- be passed to indicate that the caller is providing the return object.
5247 -- This parameter must also be passed when the called function has a
5248 -- controlling result, because dispatching calls to the function needs
5249 -- to be treated effectively the same as calls to class-wide functions.
5251 Add_Alloc_Form_Actual_To_Build_In_Place_Call
5252 (Func_Call
, Function_Id
, Alloc_Form
=> Caller_Allocation
);
5254 -- If Lhs is a selected component, then pass it along so that its prefix
5255 -- object will be used as the source of the finalization list.
5257 if Nkind
(Lhs
) = N_Selected_Component
then
5258 Add_Final_List_Actual_To_Build_In_Place_Call
5259 (Func_Call
, Function_Id
, Acc_Type
=> Empty
, Sel_Comp
=> Lhs
);
5261 Add_Final_List_Actual_To_Build_In_Place_Call
5262 (Func_Call
, Function_Id
, Acc_Type
=> Empty
);
5265 Add_Task_Actuals_To_Build_In_Place_Call
5266 (Func_Call
, Function_Id
, Make_Identifier
(Loc
, Name_uMaster
));
5268 -- Add an implicit actual to the function call that provides access to
5269 -- the caller's return object.
5271 Add_Access_Actual_To_Build_In_Place_Call
5274 Make_Unchecked_Type_Conversion
(Loc
,
5275 Subtype_Mark
=> New_Reference_To
(Result_Subt
, Loc
),
5276 Expression
=> Relocate_Node
(Lhs
)));
5278 -- Create an access type designating the function's result subtype
5281 Make_Defining_Identifier
(Loc
, New_Internal_Name
('A'));
5284 Make_Full_Type_Declaration
(Loc
,
5285 Defining_Identifier
=> Ref_Type
,
5287 Make_Access_To_Object_Definition
(Loc
,
5288 All_Present
=> True,
5289 Subtype_Indication
=>
5290 New_Reference_To
(Result_Subt
, Loc
)));
5292 Insert_After_And_Analyze
(Assign
, Ptr_Typ_Decl
);
5294 -- Finally, create an access object initialized to a reference to the
5298 Make_Defining_Identifier
(Loc
,
5299 Chars
=> New_Internal_Name
('R'));
5300 Set_Etype
(Def_Id
, Ref_Type
);
5303 Make_Reference
(Loc
,
5304 Prefix
=> Relocate_Node
(Func_Call
));
5306 Insert_After_And_Analyze
(Ptr_Typ_Decl
,
5307 Make_Object_Declaration
(Loc
,
5308 Defining_Identifier
=> Def_Id
,
5309 Object_Definition
=> New_Reference_To
(Ref_Type
, Loc
),
5310 Expression
=> New_Expr
));
5312 Rewrite
(Assign
, Make_Null_Statement
(Loc
));
5313 end Make_Build_In_Place_Call_In_Assignment
;
5315 ----------------------------------------------------
5316 -- Make_Build_In_Place_Call_In_Object_Declaration --
5317 ----------------------------------------------------
5319 procedure Make_Build_In_Place_Call_In_Object_Declaration
5320 (Object_Decl
: Node_Id
;
5321 Function_Call
: Node_Id
)
5324 Obj_Def_Id
: constant Entity_Id
:=
5325 Defining_Identifier
(Object_Decl
);
5327 Func_Call
: Node_Id
:= Function_Call
;
5328 Function_Id
: Entity_Id
;
5329 Result_Subt
: Entity_Id
;
5330 Caller_Object
: Node_Id
;
5331 Call_Deref
: Node_Id
;
5332 Ref_Type
: Entity_Id
;
5333 Ptr_Typ_Decl
: Node_Id
;
5336 Enclosing_Func
: Entity_Id
;
5337 Pass_Caller_Acc
: Boolean := False;
5340 -- Step past qualification or unchecked conversion (the latter can occur
5341 -- in cases of calls to 'Input).
5343 if Nkind_In
(Func_Call
, N_Qualified_Expression
,
5344 N_Unchecked_Type_Conversion
)
5346 Func_Call
:= Expression
(Func_Call
);
5349 -- If the call has already been processed to add build-in-place actuals
5350 -- then return. This should not normally occur in an object declaration,
5351 -- but we add the protection as a defensive measure.
5353 if Is_Expanded_Build_In_Place_Call
(Func_Call
) then
5357 -- Mark the call as processed as a build-in-place call
5359 Set_Is_Expanded_Build_In_Place_Call
(Func_Call
);
5361 Loc
:= Sloc
(Function_Call
);
5363 if Is_Entity_Name
(Name
(Func_Call
)) then
5364 Function_Id
:= Entity
(Name
(Func_Call
));
5366 elsif Nkind
(Name
(Func_Call
)) = N_Explicit_Dereference
then
5367 Function_Id
:= Etype
(Name
(Func_Call
));
5370 raise Program_Error
;
5373 Result_Subt
:= Etype
(Function_Id
);
5375 -- In the constrained case, add an implicit actual to the function call
5376 -- that provides access to the declared object. An unchecked conversion
5377 -- to the (specific) result type of the function is inserted to handle
5378 -- the case where the object is declared with a class-wide type.
5380 if Is_Constrained
(Underlying_Type
(Result_Subt
)) then
5382 Make_Unchecked_Type_Conversion
(Loc
,
5383 Subtype_Mark
=> New_Reference_To
(Result_Subt
, Loc
),
5384 Expression
=> New_Reference_To
(Obj_Def_Id
, Loc
));
5386 -- When the function has a controlling result, an allocation-form
5387 -- parameter must be passed indicating that the caller is allocating
5388 -- the result object. This is needed because such a function can be
5389 -- called as a dispatching operation and must be treated similarly
5390 -- to functions with unconstrained result subtypes.
5392 Add_Alloc_Form_Actual_To_Build_In_Place_Call
5393 (Func_Call
, Function_Id
, Alloc_Form
=> Caller_Allocation
);
5395 -- If the function's result subtype is unconstrained and the object is
5396 -- a return object of an enclosing build-in-place function, then the
5397 -- implicit build-in-place parameters of the enclosing function must be
5398 -- passed along to the called function.
5400 elsif Nkind
(Parent
(Object_Decl
)) = N_Extended_Return_Statement
then
5401 Pass_Caller_Acc
:= True;
5403 Enclosing_Func
:= Enclosing_Subprogram
(Obj_Def_Id
);
5405 -- If the enclosing function has a constrained result type, then
5406 -- caller allocation will be used.
5408 if Is_Constrained
(Etype
(Enclosing_Func
)) then
5409 Add_Alloc_Form_Actual_To_Build_In_Place_Call
5410 (Func_Call
, Function_Id
, Alloc_Form
=> Caller_Allocation
);
5412 -- Otherwise, when the enclosing function has an unconstrained result
5413 -- type, the BIP_Alloc_Form formal of the enclosing function must be
5414 -- passed along to the callee.
5417 Add_Alloc_Form_Actual_To_Build_In_Place_Call
5422 (Build_In_Place_Formal
(Enclosing_Func
, BIP_Alloc_Form
),
5426 -- Retrieve the BIPacc formal from the enclosing function and convert
5427 -- it to the access type of the callee's BIP_Object_Access formal.
5430 Make_Unchecked_Type_Conversion
(Loc
,
5434 (Build_In_Place_Formal
(Function_Id
, BIP_Object_Access
)),
5438 (Build_In_Place_Formal
(Enclosing_Func
, BIP_Object_Access
),
5441 -- In other unconstrained cases, pass an indication to do the allocation
5442 -- on the secondary stack and set Caller_Object to Empty so that a null
5443 -- value will be passed for the caller's object address. A transient
5444 -- scope is established to ensure eventual cleanup of the result.
5447 Add_Alloc_Form_Actual_To_Build_In_Place_Call
5450 Alloc_Form
=> Secondary_Stack
);
5451 Caller_Object
:= Empty
;
5453 Establish_Transient_Scope
(Object_Decl
, Sec_Stack
=> True);
5456 Add_Final_List_Actual_To_Build_In_Place_Call
5457 (Func_Call
, Function_Id
, Acc_Type
=> Empty
);
5459 if Nkind
(Parent
(Object_Decl
)) = N_Extended_Return_Statement
5460 and then Has_Task
(Result_Subt
)
5462 Enclosing_Func
:= Enclosing_Subprogram
(Obj_Def_Id
);
5464 -- Here we're passing along the master that was passed in to this
5467 Add_Task_Actuals_To_Build_In_Place_Call
5468 (Func_Call
, Function_Id
,
5471 (Build_In_Place_Formal
(Enclosing_Func
, BIP_Master
), Loc
));
5474 Add_Task_Actuals_To_Build_In_Place_Call
5475 (Func_Call
, Function_Id
, Make_Identifier
(Loc
, Name_uMaster
));
5478 Add_Access_Actual_To_Build_In_Place_Call
5479 (Func_Call
, Function_Id
, Caller_Object
, Is_Access
=> Pass_Caller_Acc
);
5481 -- Create an access type designating the function's result subtype
5484 Make_Defining_Identifier
(Loc
, New_Internal_Name
('A'));
5487 Make_Full_Type_Declaration
(Loc
,
5488 Defining_Identifier
=> Ref_Type
,
5490 Make_Access_To_Object_Definition
(Loc
,
5491 All_Present
=> True,
5492 Subtype_Indication
=>
5493 New_Reference_To
(Result_Subt
, Loc
)));
5495 -- The access type and its accompanying object must be inserted after
5496 -- the object declaration in the constrained case, so that the function
5497 -- call can be passed access to the object. In the unconstrained case,
5498 -- the access type and object must be inserted before the object, since
5499 -- the object declaration is rewritten to be a renaming of a dereference
5500 -- of the access object.
5502 if Is_Constrained
(Underlying_Type
(Result_Subt
)) then
5503 Insert_After_And_Analyze
(Object_Decl
, Ptr_Typ_Decl
);
5505 Insert_Action
(Object_Decl
, Ptr_Typ_Decl
);
5508 -- Finally, create an access object initialized to a reference to the
5512 Make_Defining_Identifier
(Loc
,
5513 Chars
=> New_Internal_Name
('R'));
5514 Set_Etype
(Def_Id
, Ref_Type
);
5517 Make_Reference
(Loc
,
5518 Prefix
=> Relocate_Node
(Func_Call
));
5520 Insert_After_And_Analyze
(Ptr_Typ_Decl
,
5521 Make_Object_Declaration
(Loc
,
5522 Defining_Identifier
=> Def_Id
,
5523 Object_Definition
=> New_Reference_To
(Ref_Type
, Loc
),
5524 Expression
=> New_Expr
));
5526 if Is_Constrained
(Underlying_Type
(Result_Subt
)) then
5527 Set_Expression
(Object_Decl
, Empty
);
5528 Set_No_Initialization
(Object_Decl
);
5530 -- In case of an unconstrained result subtype, rewrite the object
5531 -- declaration as an object renaming where the renamed object is a
5532 -- dereference of <function_Call>'reference:
5534 -- Obj : Subt renames <function_call>'Ref.all;
5538 Make_Explicit_Dereference
(Loc
,
5539 Prefix
=> New_Reference_To
(Def_Id
, Loc
));
5541 Rewrite
(Object_Decl
,
5542 Make_Object_Renaming_Declaration
(Loc
,
5543 Defining_Identifier
=> Make_Defining_Identifier
(Loc
,
5544 New_Internal_Name
('D')),
5545 Access_Definition
=> Empty
,
5546 Subtype_Mark
=> New_Occurrence_Of
(Result_Subt
, Loc
),
5547 Name
=> Call_Deref
));
5549 Set_Renamed_Object
(Defining_Identifier
(Object_Decl
), Call_Deref
);
5551 Analyze
(Object_Decl
);
5553 -- Replace the internal identifier of the renaming declaration's
5554 -- entity with identifier of the original object entity. We also have
5555 -- to exchange the entities containing their defining identifiers to
5556 -- ensure the correct replacement of the object declaration by the
5557 -- object renaming declaration to avoid homograph conflicts (since
5558 -- the object declaration's defining identifier was already entered
5559 -- in current scope). The Next_Entity links of the two entities also
5560 -- have to be swapped since the entities are part of the return
5561 -- scope's entity list and the list structure would otherwise be
5565 Renaming_Def_Id
: constant Entity_Id
:=
5566 Defining_Identifier
(Object_Decl
);
5567 Next_Entity_Temp
: constant Entity_Id
:=
5568 Next_Entity
(Renaming_Def_Id
);
5570 Set_Chars
(Renaming_Def_Id
, Chars
(Obj_Def_Id
));
5572 -- Swap next entity links in preparation for exchanging entities
5574 Set_Next_Entity
(Renaming_Def_Id
, Next_Entity
(Obj_Def_Id
));
5575 Set_Next_Entity
(Obj_Def_Id
, Next_Entity_Temp
);
5577 Exchange_Entities
(Renaming_Def_Id
, Obj_Def_Id
);
5581 -- If the object entity has a class-wide Etype, then we need to change
5582 -- it to the result subtype of the function call, because otherwise the
5583 -- object will be class-wide without an explicit initialization and
5584 -- won't be allocated properly by the back end. It seems unclean to make
5585 -- such a revision to the type at this point, and we should try to
5586 -- improve this treatment when build-in-place functions with class-wide
5587 -- results are implemented. ???
5589 if Is_Class_Wide_Type
(Etype
(Defining_Identifier
(Object_Decl
))) then
5590 Set_Etype
(Defining_Identifier
(Object_Decl
), Result_Subt
);
5592 end Make_Build_In_Place_Call_In_Object_Declaration
;
5594 --------------------------
5595 -- Needs_BIP_Final_List --
5596 --------------------------
5598 function Needs_BIP_Final_List
(E
: Entity_Id
) return Boolean is
5599 pragma Assert
(Is_Build_In_Place_Function
(E
));
5600 Result_Subt
: constant Entity_Id
:= Underlying_Type
(Etype
(E
));
5603 -- We need the BIP_Final_List if the result type needs finalization. We
5604 -- also need it for tagged types, even if not class-wide, because some
5605 -- type extension might need finalization, and all overriding functions
5606 -- must have the same calling conventions. However, if there is a
5607 -- pragma Restrictions (No_Finalization), we never need this parameter.
5609 return (Needs_Finalization
(Result_Subt
)
5610 or else Is_Tagged_Type
(Underlying_Type
(Result_Subt
)))
5611 and then not Restriction_Active
(No_Finalization
);
5612 end Needs_BIP_Final_List
;