1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 with Atree
; use Atree
;
27 with Checks
; use Checks
;
28 with Debug
; use Debug
;
29 with Einfo
; use Einfo
;
30 with Errout
; use Errout
;
31 with Elists
; use Elists
;
32 with Exp_Atag
; use Exp_Atag
;
33 with Exp_Ch2
; use Exp_Ch2
;
34 with Exp_Ch3
; use Exp_Ch3
;
35 with Exp_Ch7
; use Exp_Ch7
;
36 with Exp_Ch9
; use Exp_Ch9
;
37 with Exp_Dbug
; use Exp_Dbug
;
38 with Exp_Disp
; use Exp_Disp
;
39 with Exp_Dist
; use Exp_Dist
;
40 with Exp_Intr
; use Exp_Intr
;
41 with Exp_Pakd
; use Exp_Pakd
;
42 with Exp_Tss
; use Exp_Tss
;
43 with Exp_Util
; use Exp_Util
;
44 with Fname
; use Fname
;
45 with Freeze
; use Freeze
;
46 with Inline
; use Inline
;
48 with Namet
; use Namet
;
49 with Nlists
; use Nlists
;
50 with Nmake
; use Nmake
;
52 with Restrict
; use Restrict
;
53 with Rident
; use Rident
;
54 with Rtsfind
; use Rtsfind
;
56 with Sem_Ch6
; use Sem_Ch6
;
57 with Sem_Ch8
; use Sem_Ch8
;
58 with Sem_Ch12
; use Sem_Ch12
;
59 with Sem_Ch13
; use Sem_Ch13
;
60 with Sem_Eval
; use Sem_Eval
;
61 with Sem_Disp
; use Sem_Disp
;
62 with Sem_Dist
; use Sem_Dist
;
63 with Sem_Mech
; use Sem_Mech
;
64 with Sem_Res
; use Sem_Res
;
65 with Sem_Util
; use Sem_Util
;
66 with Sinfo
; use Sinfo
;
67 with Snames
; use Snames
;
68 with Stand
; use Stand
;
69 with Targparm
; use Targparm
;
70 with Tbuild
; use Tbuild
;
71 with Uintp
; use Uintp
;
72 with Validsw
; use Validsw
;
74 package body Exp_Ch6
is
76 -----------------------
77 -- Local Subprograms --
78 -----------------------
80 procedure Add_Access_Actual_To_Build_In_Place_Call
81 (Function_Call
: Node_Id
;
82 Function_Id
: Entity_Id
;
83 Return_Object
: Node_Id
;
84 Is_Access
: Boolean := False);
85 -- Ada 2005 (AI-318-02): Apply the Unrestricted_Access attribute to the
86 -- object name given by Return_Object and add the attribute to the end of
87 -- the actual parameter list associated with the build-in-place function
88 -- call denoted by Function_Call. However, if Is_Access is True, then
89 -- Return_Object is already an access expression, in which case it's passed
90 -- along directly to the build-in-place function. Finally, if Return_Object
91 -- is empty, then pass a null literal as the actual.
93 procedure Add_Alloc_Form_Actual_To_Build_In_Place_Call
94 (Function_Call
: Node_Id
;
95 Function_Id
: Entity_Id
;
96 Alloc_Form
: BIP_Allocation_Form
:= Unspecified
;
97 Alloc_Form_Exp
: Node_Id
:= Empty
);
98 -- Ada 2005 (AI-318-02): Add an actual indicating the form of allocation,
99 -- if any, to be done by a build-in-place function. If Alloc_Form_Exp is
100 -- present, then use it, otherwise pass a literal corresponding to the
101 -- Alloc_Form parameter (which must not be Unspecified in that case).
103 procedure Add_Extra_Actual_To_Call
104 (Subprogram_Call
: Node_Id
;
105 Extra_Formal
: Entity_Id
;
106 Extra_Actual
: Node_Id
);
107 -- Adds Extra_Actual as a named parameter association for the formal
108 -- Extra_Formal in Subprogram_Call.
110 procedure Add_Final_List_Actual_To_Build_In_Place_Call
111 (Function_Call
: Node_Id
;
112 Function_Id
: Entity_Id
;
113 Acc_Type
: Entity_Id
);
114 -- Ada 2005 (AI-318-02): For a build-in-place call, if the result type has
115 -- controlled parts, add an actual parameter that is a pointer to
116 -- appropriate finalization list. The finalization list is that of the
117 -- current scope, except for "new Acc'(F(...))" in which case it's the
118 -- finalization list of the access type returned by the allocator. Acc_Type
119 -- is that type in the allocator case; Empty otherwise.
121 procedure Add_Task_Actuals_To_Build_In_Place_Call
122 (Function_Call
: Node_Id
;
123 Function_Id
: Entity_Id
;
124 Master_Actual
: Node_Id
);
125 -- Ada 2005 (AI-318-02): For a build-in-place call, if the result type
126 -- contains tasks, add two actual parameters: the master, and a pointer to
127 -- the caller's activation chain. Master_Actual is the actual parameter
128 -- expression to pass for the master. In most cases, this is the current
129 -- master (_master). The two exceptions are: If the function call is the
130 -- initialization expression for an allocator, we pass the master of the
131 -- access type. If the function call is the initialization expression for
132 -- a return object, we pass along the master passed in by the caller. The
133 -- activation chain to pass is always the local one.
135 procedure Check_Overriding_Operation
(Subp
: Entity_Id
);
136 -- Subp is a dispatching operation. Check whether it may override an
137 -- inherited private operation, in which case its DT entry is that of
138 -- the hidden operation, not the one it may have received earlier.
139 -- This must be done before emitting the code to set the corresponding
140 -- DT to the address of the subprogram. The actual placement of Subp in
141 -- the proper place in the list of primitive operations is done in
142 -- Declare_Inherited_Private_Subprograms, which also has to deal with
143 -- implicit operations. This duplication is unavoidable for now???
145 procedure Detect_Infinite_Recursion
(N
: Node_Id
; Spec
: Entity_Id
);
146 -- This procedure is called only if the subprogram body N, whose spec
147 -- has the given entity Spec, contains a parameterless recursive call.
148 -- It attempts to generate runtime code to detect if this a case of
149 -- infinite recursion.
151 -- The body is scanned to determine dependencies. If the only external
152 -- dependencies are on a small set of scalar variables, then the values
153 -- of these variables are captured on entry to the subprogram, and if
154 -- the values are not changed for the call, we know immediately that
155 -- we have an infinite recursion.
157 procedure Expand_Actuals
(N
: Node_Id
; Subp
: Entity_Id
);
158 -- For each actual of an in-out or out parameter which is a numeric
159 -- (view) conversion of the form T (A), where A denotes a variable,
160 -- we insert the declaration:
162 -- Temp : T[ := T (A)];
164 -- prior to the call. Then we replace the actual with a reference to Temp,
165 -- and append the assignment:
167 -- A := TypeA (Temp);
169 -- after the call. Here TypeA is the actual type of variable A.
170 -- For out parameters, the initial declaration has no expression.
171 -- If A is not an entity name, we generate instead:
173 -- Var : TypeA renames A;
174 -- Temp : T := Var; -- omitting expression for out parameter.
176 -- Var := TypeA (Temp);
178 -- For other in-out parameters, we emit the required constraint checks
179 -- before and/or after the call.
181 -- For all parameter modes, actuals that denote components and slices
182 -- of packed arrays are expanded into suitable temporaries.
184 -- For non-scalar objects that are possibly unaligned, add call by copy
185 -- code (copy in for IN and IN OUT, copy out for OUT and IN OUT).
187 procedure Expand_Inlined_Call
190 Orig_Subp
: Entity_Id
);
191 -- If called subprogram can be inlined by the front-end, retrieve the
192 -- analyzed body, replace formals with actuals and expand call in place.
193 -- Generate thunks for actuals that are expressions, and insert the
194 -- corresponding constant declarations before the call. If the original
195 -- call is to a derived operation, the return type is the one of the
196 -- derived operation, but the body is that of the original, so return
197 -- expressions in the body must be converted to the desired type (which
198 -- is simply not noted in the tree without inline expansion).
200 function Expand_Protected_Object_Reference
202 Scop
: Entity_Id
) return Node_Id
;
204 procedure Expand_Protected_Subprogram_Call
208 -- A call to a protected subprogram within the protected object may appear
209 -- as a regular call. The list of actuals must be expanded to contain a
210 -- reference to the object itself, and the call becomes a call to the
211 -- corresponding protected subprogram.
213 ----------------------------------------------
214 -- Add_Access_Actual_To_Build_In_Place_Call --
215 ----------------------------------------------
217 procedure Add_Access_Actual_To_Build_In_Place_Call
218 (Function_Call
: Node_Id
;
219 Function_Id
: Entity_Id
;
220 Return_Object
: Node_Id
;
221 Is_Access
: Boolean := False)
223 Loc
: constant Source_Ptr
:= Sloc
(Function_Call
);
224 Obj_Address
: Node_Id
;
225 Obj_Acc_Formal
: Entity_Id
;
228 -- Locate the implicit access parameter in the called function
230 Obj_Acc_Formal
:= Build_In_Place_Formal
(Function_Id
, BIP_Object_Access
);
232 -- If no return object is provided, then pass null
234 if not Present
(Return_Object
) then
235 Obj_Address
:= Make_Null
(Loc
);
236 Set_Parent
(Obj_Address
, Function_Call
);
238 -- If Return_Object is already an expression of an access type, then use
239 -- it directly, since it must be an access value denoting the return
240 -- object, and couldn't possibly be the return object itself.
243 Obj_Address
:= Return_Object
;
244 Set_Parent
(Obj_Address
, Function_Call
);
246 -- Apply Unrestricted_Access to caller's return object
250 Make_Attribute_Reference
(Loc
,
251 Prefix
=> Return_Object
,
252 Attribute_Name
=> Name_Unrestricted_Access
);
254 Set_Parent
(Return_Object
, Obj_Address
);
255 Set_Parent
(Obj_Address
, Function_Call
);
258 Analyze_And_Resolve
(Obj_Address
, Etype
(Obj_Acc_Formal
));
260 -- Build the parameter association for the new actual and add it to the
261 -- end of the function's actuals.
263 Add_Extra_Actual_To_Call
(Function_Call
, Obj_Acc_Formal
, Obj_Address
);
264 end Add_Access_Actual_To_Build_In_Place_Call
;
266 --------------------------------------------------
267 -- Add_Alloc_Form_Actual_To_Build_In_Place_Call --
268 --------------------------------------------------
270 procedure Add_Alloc_Form_Actual_To_Build_In_Place_Call
271 (Function_Call
: Node_Id
;
272 Function_Id
: Entity_Id
;
273 Alloc_Form
: BIP_Allocation_Form
:= Unspecified
;
274 Alloc_Form_Exp
: Node_Id
:= Empty
)
276 Loc
: constant Source_Ptr
:= Sloc
(Function_Call
);
277 Alloc_Form_Actual
: Node_Id
;
278 Alloc_Form_Formal
: Node_Id
;
281 -- The allocation form generally doesn't need to be passed in the case
282 -- of a constrained result subtype, since normally the caller performs
283 -- the allocation in that case. However this formal is still needed in
284 -- the case where the function has a tagged result, because generally
285 -- such functions can be called in a dispatching context and such calls
286 -- must be handled like calls to class-wide functions.
288 if Is_Constrained
(Underlying_Type
(Etype
(Function_Id
)))
289 and then not Is_Tagged_Type
(Underlying_Type
(Etype
(Function_Id
)))
294 -- Locate the implicit allocation form parameter in the called function.
295 -- Maybe it would be better for each implicit formal of a build-in-place
296 -- function to have a flag or a Uint attribute to identify it. ???
298 Alloc_Form_Formal
:= Build_In_Place_Formal
(Function_Id
, BIP_Alloc_Form
);
300 if Present
(Alloc_Form_Exp
) then
301 pragma Assert
(Alloc_Form
= Unspecified
);
303 Alloc_Form_Actual
:= Alloc_Form_Exp
;
306 pragma Assert
(Alloc_Form
/= Unspecified
);
309 Make_Integer_Literal
(Loc
,
310 Intval
=> UI_From_Int
(BIP_Allocation_Form
'Pos (Alloc_Form
)));
313 Analyze_And_Resolve
(Alloc_Form_Actual
, Etype
(Alloc_Form_Formal
));
315 -- Build the parameter association for the new actual and add it to the
316 -- end of the function's actuals.
318 Add_Extra_Actual_To_Call
319 (Function_Call
, Alloc_Form_Formal
, Alloc_Form_Actual
);
320 end Add_Alloc_Form_Actual_To_Build_In_Place_Call
;
322 ------------------------------
323 -- Add_Extra_Actual_To_Call --
324 ------------------------------
326 procedure Add_Extra_Actual_To_Call
327 (Subprogram_Call
: Node_Id
;
328 Extra_Formal
: Entity_Id
;
329 Extra_Actual
: Node_Id
)
331 Loc
: constant Source_Ptr
:= Sloc
(Subprogram_Call
);
332 Param_Assoc
: Node_Id
;
336 Make_Parameter_Association
(Loc
,
337 Selector_Name
=> New_Occurrence_Of
(Extra_Formal
, Loc
),
338 Explicit_Actual_Parameter
=> Extra_Actual
);
340 Set_Parent
(Param_Assoc
, Subprogram_Call
);
341 Set_Parent
(Extra_Actual
, Param_Assoc
);
343 if Present
(Parameter_Associations
(Subprogram_Call
)) then
344 if Nkind
(Last
(Parameter_Associations
(Subprogram_Call
))) =
345 N_Parameter_Association
348 -- Find last named actual, and append
353 L
:= First_Actual
(Subprogram_Call
);
354 while Present
(L
) loop
355 if No
(Next_Actual
(L
)) then
356 Set_Next_Named_Actual
(Parent
(L
), Extra_Actual
);
364 Set_First_Named_Actual
(Subprogram_Call
, Extra_Actual
);
367 Append
(Param_Assoc
, To
=> Parameter_Associations
(Subprogram_Call
));
370 Set_Parameter_Associations
(Subprogram_Call
, New_List
(Param_Assoc
));
371 Set_First_Named_Actual
(Subprogram_Call
, Extra_Actual
);
373 end Add_Extra_Actual_To_Call
;
375 --------------------------------------------------
376 -- Add_Final_List_Actual_To_Build_In_Place_Call --
377 --------------------------------------------------
379 procedure Add_Final_List_Actual_To_Build_In_Place_Call
380 (Function_Call
: Node_Id
;
381 Function_Id
: Entity_Id
;
382 Acc_Type
: Entity_Id
)
384 Loc
: constant Source_Ptr
:= Sloc
(Function_Call
);
385 Final_List
: Node_Id
;
386 Final_List_Actual
: Node_Id
;
387 Final_List_Formal
: Node_Id
;
390 -- No such extra parameter is needed if there are no controlled parts.
391 -- The test for Controlled_Type accounts for class-wide results (which
392 -- potentially have controlled parts, even if the root type doesn't),
393 -- and the test for a tagged result type is needed because calls to
394 -- such a function can in general occur in dispatching contexts, which
395 -- must be treated the same as a call to class-wide functions. Both of
396 -- these situations require that a finalization list be passed.
398 if not Controlled_Type
(Underlying_Type
(Etype
(Function_Id
)))
399 and then not Is_Tagged_Type
(Underlying_Type
(Etype
(Function_Id
)))
404 -- Locate implicit finalization list parameter in the called function
406 Final_List_Formal
:= Build_In_Place_Formal
(Function_Id
, BIP_Final_List
);
408 -- Create the actual which is a pointer to the appropriate finalization
409 -- list. Acc_Type is present if and only if this call is the
410 -- initialization of an allocator. Use the Current_Scope or the Acc_Type
413 if Present
(Acc_Type
)
414 and then (Ekind
(Acc_Type
) = E_Anonymous_Access_Type
416 Present
(Associated_Final_Chain
(Base_Type
(Acc_Type
))))
418 Final_List
:= Find_Final_List
(Acc_Type
);
420 Final_List
:= Find_Final_List
(Current_Scope
);
424 Make_Attribute_Reference
(Loc
,
425 Prefix
=> Final_List
,
426 Attribute_Name
=> Name_Unrestricted_Access
);
428 Analyze_And_Resolve
(Final_List_Actual
, Etype
(Final_List_Formal
));
430 -- Build the parameter association for the new actual and add it to the
431 -- end of the function's actuals.
433 Add_Extra_Actual_To_Call
434 (Function_Call
, Final_List_Formal
, Final_List_Actual
);
435 end Add_Final_List_Actual_To_Build_In_Place_Call
;
437 ---------------------------------------------
438 -- Add_Task_Actuals_To_Build_In_Place_Call --
439 ---------------------------------------------
441 procedure Add_Task_Actuals_To_Build_In_Place_Call
442 (Function_Call
: Node_Id
;
443 Function_Id
: Entity_Id
;
444 Master_Actual
: Node_Id
)
445 -- Note: Master_Actual can be Empty, but only if there are no tasks
447 Loc
: constant Source_Ptr
:= Sloc
(Function_Call
);
450 -- No such extra parameters are needed if there are no tasks
452 if not Has_Task
(Etype
(Function_Id
)) then
459 Master_Formal
: Node_Id
;
461 -- Locate implicit master parameter in the called function
463 Master_Formal
:= Build_In_Place_Formal
(Function_Id
, BIP_Master
);
465 Analyze_And_Resolve
(Master_Actual
, Etype
(Master_Formal
));
467 -- Build the parameter association for the new actual and add it to
468 -- the end of the function's actuals.
470 Add_Extra_Actual_To_Call
471 (Function_Call
, Master_Formal
, Master_Actual
);
474 -- The activation chain
477 Activation_Chain_Actual
: Node_Id
;
478 Activation_Chain_Formal
: Node_Id
;
480 -- Locate implicit activation chain parameter in the called function
482 Activation_Chain_Formal
:= Build_In_Place_Formal
483 (Function_Id
, BIP_Activation_Chain
);
485 -- Create the actual which is a pointer to the current activation
488 Activation_Chain_Actual
:=
489 Make_Attribute_Reference
(Loc
,
490 Prefix
=> Make_Identifier
(Loc
, Name_uChain
),
491 Attribute_Name
=> Name_Unrestricted_Access
);
494 (Activation_Chain_Actual
, Etype
(Activation_Chain_Formal
));
496 -- Build the parameter association for the new actual and add it to
497 -- the end of the function's actuals.
499 Add_Extra_Actual_To_Call
500 (Function_Call
, Activation_Chain_Formal
, Activation_Chain_Actual
);
502 end Add_Task_Actuals_To_Build_In_Place_Call
;
504 -----------------------
505 -- BIP_Formal_Suffix --
506 -----------------------
508 function BIP_Formal_Suffix
(Kind
: BIP_Formal_Kind
) return String is
511 when BIP_Alloc_Form
=>
513 when BIP_Final_List
=>
514 return "BIPfinallist";
517 when BIP_Activation_Chain
=>
518 return "BIPactivationchain";
519 when BIP_Object_Access
=>
522 end BIP_Formal_Suffix
;
524 ---------------------------
525 -- Build_In_Place_Formal --
526 ---------------------------
528 function Build_In_Place_Formal
530 Kind
: BIP_Formal_Kind
) return Entity_Id
532 Extra_Formal
: Entity_Id
:= Extra_Formals
(Func
);
535 -- Maybe it would be better for each implicit formal of a build-in-place
536 -- function to have a flag or a Uint attribute to identify it. ???
539 pragma Assert
(Present
(Extra_Formal
));
541 Chars
(Extra_Formal
) =
542 New_External_Name
(Chars
(Func
), BIP_Formal_Suffix
(Kind
));
543 Next_Formal_With_Extras
(Extra_Formal
);
547 end Build_In_Place_Formal
;
549 --------------------------------
550 -- Check_Overriding_Operation --
551 --------------------------------
553 procedure Check_Overriding_Operation
(Subp
: Entity_Id
) is
554 Typ
: constant Entity_Id
:= Find_Dispatching_Type
(Subp
);
555 Op_List
: constant Elist_Id
:= Primitive_Operations
(Typ
);
561 if Is_Derived_Type
(Typ
)
562 and then not Is_Private_Type
(Typ
)
563 and then In_Open_Scopes
(Scope
(Etype
(Typ
)))
564 and then Typ
= Base_Type
(Typ
)
566 -- Subp overrides an inherited private operation if there is an
567 -- inherited operation with a different name than Subp (see
568 -- Derive_Subprogram) whose Alias is a hidden subprogram with the
569 -- same name as Subp.
571 Op_Elmt
:= First_Elmt
(Op_List
);
572 while Present
(Op_Elmt
) loop
573 Prim_Op
:= Node
(Op_Elmt
);
574 Par_Op
:= Alias
(Prim_Op
);
577 and then not Comes_From_Source
(Prim_Op
)
578 and then Chars
(Prim_Op
) /= Chars
(Par_Op
)
579 and then Chars
(Par_Op
) = Chars
(Subp
)
580 and then Is_Hidden
(Par_Op
)
581 and then Type_Conformant
(Prim_Op
, Subp
)
583 Set_DT_Position
(Subp
, DT_Position
(Prim_Op
));
589 end Check_Overriding_Operation
;
591 -------------------------------
592 -- Detect_Infinite_Recursion --
593 -------------------------------
595 procedure Detect_Infinite_Recursion
(N
: Node_Id
; Spec
: Entity_Id
) is
596 Loc
: constant Source_Ptr
:= Sloc
(N
);
598 Var_List
: constant Elist_Id
:= New_Elmt_List
;
599 -- List of globals referenced by body of procedure
601 Call_List
: constant Elist_Id
:= New_Elmt_List
;
602 -- List of recursive calls in body of procedure
604 Shad_List
: constant Elist_Id
:= New_Elmt_List
;
605 -- List of entity id's for entities created to capture the value of
606 -- referenced globals on entry to the procedure.
608 Scop
: constant Uint
:= Scope_Depth
(Spec
);
609 -- This is used to record the scope depth of the current procedure, so
610 -- that we can identify global references.
612 Max_Vars
: constant := 4;
613 -- Do not test more than four global variables
615 Count_Vars
: Natural := 0;
616 -- Count variables found so far
628 function Process
(Nod
: Node_Id
) return Traverse_Result
;
629 -- Function to traverse the subprogram body (using Traverse_Func)
635 function Process
(Nod
: Node_Id
) return Traverse_Result
is
639 if Nkind
(Nod
) = N_Procedure_Call_Statement
then
641 -- Case of one of the detected recursive calls
643 if Is_Entity_Name
(Name
(Nod
))
644 and then Has_Recursive_Call
(Entity
(Name
(Nod
)))
645 and then Entity
(Name
(Nod
)) = Spec
647 Append_Elmt
(Nod
, Call_List
);
650 -- Any other procedure call may have side effects
656 -- A call to a pure function can always be ignored
658 elsif Nkind
(Nod
) = N_Function_Call
659 and then Is_Entity_Name
(Name
(Nod
))
660 and then Is_Pure
(Entity
(Name
(Nod
)))
664 -- Case of an identifier reference
666 elsif Nkind
(Nod
) = N_Identifier
then
669 -- If no entity, then ignore the reference
671 -- Not clear why this can happen. To investigate, remove this
672 -- test and look at the crash that occurs here in 3401-004 ???
677 -- Ignore entities with no Scope, again not clear how this
678 -- can happen, to investigate, look at 4108-008 ???
680 elsif No
(Scope
(Ent
)) then
683 -- Ignore the reference if not to a more global object
685 elsif Scope_Depth
(Scope
(Ent
)) >= Scop
then
688 -- References to types, exceptions and constants are always OK
691 or else Ekind
(Ent
) = E_Exception
692 or else Ekind
(Ent
) = E_Constant
696 -- If other than a non-volatile scalar variable, we have some
697 -- kind of global reference (e.g. to a function) that we cannot
698 -- deal with so we forget the attempt.
700 elsif Ekind
(Ent
) /= E_Variable
701 or else not Is_Scalar_Type
(Etype
(Ent
))
702 or else Treat_As_Volatile
(Ent
)
706 -- Otherwise we have a reference to a global scalar
709 -- Loop through global entities already detected
711 Elm
:= First_Elmt
(Var_List
);
713 -- If not detected before, record this new global reference
716 Count_Vars
:= Count_Vars
+ 1;
718 if Count_Vars
<= Max_Vars
then
719 Append_Elmt
(Entity
(Nod
), Var_List
);
726 -- If recorded before, ignore
728 elsif Node
(Elm
) = Entity
(Nod
) then
731 -- Otherwise keep looking
741 -- For all other node kinds, recursively visit syntactic children
748 function Traverse_Body
is new Traverse_Func
(Process
);
750 -- Start of processing for Detect_Infinite_Recursion
753 -- Do not attempt detection in No_Implicit_Conditional mode, since we
754 -- won't be able to generate the code to handle the recursion in any
757 if Restriction_Active
(No_Implicit_Conditionals
) then
761 -- Otherwise do traversal and quit if we get abandon signal
763 if Traverse_Body
(N
) = Abandon
then
766 -- We must have a call, since Has_Recursive_Call was set. If not just
767 -- ignore (this is only an error check, so if we have a funny situation,
768 -- due to bugs or errors, we do not want to bomb!)
770 elsif Is_Empty_Elmt_List
(Call_List
) then
774 -- Here is the case where we detect recursion at compile time
776 -- Push our current scope for analyzing the declarations and code that
777 -- we will insert for the checking.
781 -- This loop builds temporary variables for each of the referenced
782 -- globals, so that at the end of the loop the list Shad_List contains
783 -- these temporaries in one-to-one correspondence with the elements in
787 Elm
:= First_Elmt
(Var_List
);
788 while Present
(Elm
) loop
791 Make_Defining_Identifier
(Loc
,
792 Chars
=> New_Internal_Name
('S'));
793 Append_Elmt
(Ent
, Shad_List
);
795 -- Insert a declaration for this temporary at the start of the
796 -- declarations for the procedure. The temporaries are declared as
797 -- constant objects initialized to the current values of the
798 -- corresponding temporaries.
801 Make_Object_Declaration
(Loc
,
802 Defining_Identifier
=> Ent
,
803 Object_Definition
=> New_Occurrence_Of
(Etype
(Var
), Loc
),
804 Constant_Present
=> True,
805 Expression
=> New_Occurrence_Of
(Var
, Loc
));
808 Prepend
(Decl
, Declarations
(N
));
810 Insert_After
(Last
, Decl
);
818 -- Loop through calls
820 Call
:= First_Elmt
(Call_List
);
821 while Present
(Call
) loop
823 -- Build a predicate expression of the form
826 -- and then global1 = temp1
827 -- and then global2 = temp2
830 -- This predicate determines if any of the global values
831 -- referenced by the procedure have changed since the
832 -- current call, if not an infinite recursion is assured.
834 Test
:= New_Occurrence_Of
(Standard_True
, Loc
);
836 Elm1
:= First_Elmt
(Var_List
);
837 Elm2
:= First_Elmt
(Shad_List
);
838 while Present
(Elm1
) loop
844 Left_Opnd
=> New_Occurrence_Of
(Node
(Elm1
), Loc
),
845 Right_Opnd
=> New_Occurrence_Of
(Node
(Elm2
), Loc
)));
851 -- Now we replace the call with the sequence
853 -- if no-changes (see above) then
854 -- raise Storage_Error;
859 Rewrite
(Node
(Call
),
860 Make_If_Statement
(Loc
,
862 Then_Statements
=> New_List
(
863 Make_Raise_Storage_Error
(Loc
,
864 Reason
=> SE_Infinite_Recursion
)),
866 Else_Statements
=> New_List
(
867 Relocate_Node
(Node
(Call
)))));
869 Analyze
(Node
(Call
));
874 -- Remove temporary scope stack entry used for analysis
877 end Detect_Infinite_Recursion
;
883 procedure Expand_Actuals
(N
: Node_Id
; Subp
: Entity_Id
) is
884 Loc
: constant Source_Ptr
:= Sloc
(N
);
889 E_Formal
: Entity_Id
;
891 procedure Add_Call_By_Copy_Code
;
892 -- For cases where the parameter must be passed by copy, this routine
893 -- generates a temporary variable into which the actual is copied and
894 -- then passes this as the parameter. For an OUT or IN OUT parameter,
895 -- an assignment is also generated to copy the result back. The call
896 -- also takes care of any constraint checks required for the type
897 -- conversion case (on both the way in and the way out).
899 procedure Add_Simple_Call_By_Copy_Code
;
900 -- This is similar to the above, but is used in cases where we know
901 -- that all that is needed is to simply create a temporary and copy
902 -- the value in and out of the temporary.
904 procedure Check_Fortran_Logical
;
905 -- A value of type Logical that is passed through a formal parameter
906 -- must be normalized because .TRUE. usually does not have the same
907 -- representation as True. We assume that .FALSE. = False = 0.
908 -- What about functions that return a logical type ???
910 function Is_Legal_Copy
return Boolean;
911 -- Check that an actual can be copied before generating the temporary
912 -- to be used in the call. If the actual is of a by_reference type then
913 -- the program is illegal (this can only happen in the presence of
914 -- rep. clauses that force an incorrect alignment). If the formal is
915 -- a by_reference parameter imposed by a DEC pragma, emit a warning to
916 -- the effect that this might lead to unaligned arguments.
918 function Make_Var
(Actual
: Node_Id
) return Entity_Id
;
919 -- Returns an entity that refers to the given actual parameter,
920 -- Actual (not including any type conversion). If Actual is an
921 -- entity name, then this entity is returned unchanged, otherwise
922 -- a renaming is created to provide an entity for the actual.
924 procedure Reset_Packed_Prefix
;
925 -- The expansion of a packed array component reference is delayed in
926 -- the context of a call. Now we need to complete the expansion, so we
927 -- unmark the analyzed bits in all prefixes.
929 ---------------------------
930 -- Add_Call_By_Copy_Code --
931 ---------------------------
933 procedure Add_Call_By_Copy_Code
is
939 F_Typ
: constant Entity_Id
:= Etype
(Formal
);
944 if not Is_Legal_Copy
then
949 Make_Defining_Identifier
(Loc
,
950 Chars
=> New_Internal_Name
('T'));
952 -- Use formal type for temp, unless formal type is an unconstrained
953 -- array, in which case we don't have to worry about bounds checks,
954 -- and we use the actual type, since that has appropriate bounds.
956 if Is_Array_Type
(F_Typ
) and then not Is_Constrained
(F_Typ
) then
957 Indic
:= New_Occurrence_Of
(Etype
(Actual
), Loc
);
959 Indic
:= New_Occurrence_Of
(Etype
(Formal
), Loc
);
962 if Nkind
(Actual
) = N_Type_Conversion
then
963 V_Typ
:= Etype
(Expression
(Actual
));
965 -- If the formal is an (in-)out parameter, capture the name
966 -- of the variable in order to build the post-call assignment.
968 Var
:= Make_Var
(Expression
(Actual
));
970 Crep
:= not Same_Representation
971 (F_Typ
, Etype
(Expression
(Actual
)));
974 V_Typ
:= Etype
(Actual
);
975 Var
:= Make_Var
(Actual
);
979 -- Setup initialization for case of in out parameter, or an out
980 -- parameter where the formal is an unconstrained array (in the
981 -- latter case, we have to pass in an object with bounds).
983 -- If this is an out parameter, the initial copy is wasteful, so as
984 -- an optimization for the one-dimensional case we extract the
985 -- bounds of the actual and build an uninitialized temporary of the
988 if Ekind
(Formal
) = E_In_Out_Parameter
989 or else (Is_Array_Type
(F_Typ
) and then not Is_Constrained
(F_Typ
))
991 if Nkind
(Actual
) = N_Type_Conversion
then
992 if Conversion_OK
(Actual
) then
993 Init
:= OK_Convert_To
(F_Typ
, New_Occurrence_Of
(Var
, Loc
));
995 Init
:= Convert_To
(F_Typ
, New_Occurrence_Of
(Var
, Loc
));
998 elsif Ekind
(Formal
) = E_Out_Parameter
999 and then Is_Array_Type
(F_Typ
)
1000 and then Number_Dimensions
(F_Typ
) = 1
1001 and then not Has_Non_Null_Base_Init_Proc
(F_Typ
)
1003 -- Actual is a one-dimensional array or slice, and the type
1004 -- requires no initialization. Create a temporary of the
1005 -- right size, but do not copy actual into it (optimization).
1009 Make_Subtype_Indication
(Loc
,
1011 New_Occurrence_Of
(F_Typ
, Loc
),
1013 Make_Index_Or_Discriminant_Constraint
(Loc
,
1014 Constraints
=> New_List
(
1017 Make_Attribute_Reference
(Loc
,
1018 Prefix
=> New_Occurrence_Of
(Var
, Loc
),
1019 Attribute_name
=> Name_First
),
1021 Make_Attribute_Reference
(Loc
,
1022 Prefix
=> New_Occurrence_Of
(Var
, Loc
),
1023 Attribute_Name
=> Name_Last
)))));
1026 Init
:= New_Occurrence_Of
(Var
, Loc
);
1029 -- An initialization is created for packed conversions as
1030 -- actuals for out parameters to enable Make_Object_Declaration
1031 -- to determine the proper subtype for N_Node. Note that this
1032 -- is wasteful because the extra copying on the call side is
1033 -- not required for such out parameters. ???
1035 elsif Ekind
(Formal
) = E_Out_Parameter
1036 and then Nkind
(Actual
) = N_Type_Conversion
1037 and then (Is_Bit_Packed_Array
(F_Typ
)
1039 Is_Bit_Packed_Array
(Etype
(Expression
(Actual
))))
1041 if Conversion_OK
(Actual
) then
1042 Init
:= OK_Convert_To
(F_Typ
, New_Occurrence_Of
(Var
, Loc
));
1044 Init
:= Convert_To
(F_Typ
, New_Occurrence_Of
(Var
, Loc
));
1047 elsif Ekind
(Formal
) = E_In_Parameter
then
1049 -- Handle the case in which the actual is a type conversion
1051 if Nkind
(Actual
) = N_Type_Conversion
then
1052 if Conversion_OK
(Actual
) then
1053 Init
:= OK_Convert_To
(F_Typ
, New_Occurrence_Of
(Var
, Loc
));
1055 Init
:= Convert_To
(F_Typ
, New_Occurrence_Of
(Var
, Loc
));
1058 Init
:= New_Occurrence_Of
(Var
, Loc
);
1066 Make_Object_Declaration
(Loc
,
1067 Defining_Identifier
=> Temp
,
1068 Object_Definition
=> Indic
,
1069 Expression
=> Init
);
1070 Set_Assignment_OK
(N_Node
);
1071 Insert_Action
(N
, N_Node
);
1073 -- Now, normally the deal here is that we use the defining
1074 -- identifier created by that object declaration. There is
1075 -- one exception to this. In the change of representation case
1076 -- the above declaration will end up looking like:
1078 -- temp : type := identifier;
1080 -- And in this case we might as well use the identifier directly
1081 -- and eliminate the temporary. Note that the analysis of the
1082 -- declaration was not a waste of time in that case, since it is
1083 -- what generated the necessary change of representation code. If
1084 -- the change of representation introduced additional code, as in
1085 -- a fixed-integer conversion, the expression is not an identifier
1086 -- and must be kept.
1089 and then Present
(Expression
(N_Node
))
1090 and then Is_Entity_Name
(Expression
(N_Node
))
1092 Temp
:= Entity
(Expression
(N_Node
));
1093 Rewrite
(N_Node
, Make_Null_Statement
(Loc
));
1096 -- For IN parameter, all we do is to replace the actual
1098 if Ekind
(Formal
) = E_In_Parameter
then
1099 Rewrite
(Actual
, New_Reference_To
(Temp
, Loc
));
1102 -- Processing for OUT or IN OUT parameter
1105 -- Kill current value indications for the temporary variable we
1106 -- created, since we just passed it as an OUT parameter.
1108 Kill_Current_Values
(Temp
);
1110 -- If type conversion, use reverse conversion on exit
1112 if Nkind
(Actual
) = N_Type_Conversion
then
1113 if Conversion_OK
(Actual
) then
1114 Expr
:= OK_Convert_To
(V_Typ
, New_Occurrence_Of
(Temp
, Loc
));
1116 Expr
:= Convert_To
(V_Typ
, New_Occurrence_Of
(Temp
, Loc
));
1119 Expr
:= New_Occurrence_Of
(Temp
, Loc
);
1122 Rewrite
(Actual
, New_Reference_To
(Temp
, Loc
));
1125 -- If the actual is a conversion of a packed reference, it may
1126 -- already have been expanded by Remove_Side_Effects, and the
1127 -- resulting variable is a temporary which does not designate
1128 -- the proper out-parameter, which may not be addressable. In
1129 -- that case, generate an assignment to the original expression
1130 -- (before expansion of the packed reference) so that the proper
1131 -- expansion of assignment to a packed component can take place.
1138 if Is_Renaming_Of_Object
(Var
)
1139 and then Nkind
(Renamed_Object
(Var
)) = N_Selected_Component
1140 and then Is_Entity_Name
(Prefix
(Renamed_Object
(Var
)))
1141 and then Nkind
(Original_Node
(Prefix
(Renamed_Object
(Var
))))
1142 = N_Indexed_Component
1144 Has_Non_Standard_Rep
(Etype
(Prefix
(Renamed_Object
(Var
))))
1146 Obj
:= Renamed_Object
(Var
);
1148 Make_Selected_Component
(Loc
,
1150 New_Copy_Tree
(Original_Node
(Prefix
(Obj
))),
1151 Selector_Name
=> New_Copy
(Selector_Name
(Obj
)));
1152 Reset_Analyzed_Flags
(Lhs
);
1155 Lhs
:= New_Occurrence_Of
(Var
, Loc
);
1158 Set_Assignment_OK
(Lhs
);
1160 Append_To
(Post_Call
,
1161 Make_Assignment_Statement
(Loc
,
1163 Expression
=> Expr
));
1167 end Add_Call_By_Copy_Code
;
1169 ----------------------------------
1170 -- Add_Simple_Call_By_Copy_Code --
1171 ----------------------------------
1173 procedure Add_Simple_Call_By_Copy_Code
is
1181 F_Typ
: constant Entity_Id
:= Etype
(Formal
);
1184 if not Is_Legal_Copy
then
1188 -- Use formal type for temp, unless formal type is an unconstrained
1189 -- array, in which case we don't have to worry about bounds checks,
1190 -- and we use the actual type, since that has appropriate bounds.
1192 if Is_Array_Type
(F_Typ
) and then not Is_Constrained
(F_Typ
) then
1193 Indic
:= New_Occurrence_Of
(Etype
(Actual
), Loc
);
1195 Indic
:= New_Occurrence_Of
(Etype
(Formal
), Loc
);
1198 -- Prepare to generate code
1200 Reset_Packed_Prefix
;
1203 Make_Defining_Identifier
(Loc
,
1204 Chars
=> New_Internal_Name
('T'));
1205 Incod
:= Relocate_Node
(Actual
);
1206 Outcod
:= New_Copy_Tree
(Incod
);
1208 -- Generate declaration of temporary variable, initializing it
1209 -- with the input parameter unless we have an OUT formal or
1210 -- this is an initialization call.
1212 -- If the formal is an out parameter with discriminants, the
1213 -- discriminants must be captured even if the rest of the object
1214 -- is in principle uninitialized, because the discriminants may
1215 -- be read by the called subprogram.
1217 if Ekind
(Formal
) = E_Out_Parameter
then
1220 if Has_Discriminants
(Etype
(Formal
)) then
1221 Indic
:= New_Occurrence_Of
(Etype
(Actual
), Loc
);
1224 elsif Inside_Init_Proc
then
1226 -- Could use a comment here to match comment below ???
1228 if Nkind
(Actual
) /= N_Selected_Component
1230 not Has_Discriminant_Dependent_Constraint
1231 (Entity
(Selector_Name
(Actual
)))
1235 -- Otherwise, keep the component in order to generate the proper
1236 -- actual subtype, that depends on enclosing discriminants.
1244 Make_Object_Declaration
(Loc
,
1245 Defining_Identifier
=> Temp
,
1246 Object_Definition
=> Indic
,
1247 Expression
=> Incod
);
1252 -- If the call is to initialize a component of a composite type,
1253 -- and the component does not depend on discriminants, use the
1254 -- actual type of the component. This is required in case the
1255 -- component is constrained, because in general the formal of the
1256 -- initialization procedure will be unconstrained. Note that if
1257 -- the component being initialized is constrained by an enclosing
1258 -- discriminant, the presence of the initialization in the
1259 -- declaration will generate an expression for the actual subtype.
1261 Set_No_Initialization
(Decl
);
1262 Set_Object_Definition
(Decl
,
1263 New_Occurrence_Of
(Etype
(Actual
), Loc
));
1266 Insert_Action
(N
, Decl
);
1268 -- The actual is simply a reference to the temporary
1270 Rewrite
(Actual
, New_Occurrence_Of
(Temp
, Loc
));
1272 -- Generate copy out if OUT or IN OUT parameter
1274 if Ekind
(Formal
) /= E_In_Parameter
then
1276 Rhs
:= New_Occurrence_Of
(Temp
, Loc
);
1278 -- Deal with conversion
1280 if Nkind
(Lhs
) = N_Type_Conversion
then
1281 Lhs
:= Expression
(Lhs
);
1282 Rhs
:= Convert_To
(Etype
(Actual
), Rhs
);
1285 Append_To
(Post_Call
,
1286 Make_Assignment_Statement
(Loc
,
1288 Expression
=> Rhs
));
1289 Set_Assignment_OK
(Name
(Last
(Post_Call
)));
1291 end Add_Simple_Call_By_Copy_Code
;
1293 ---------------------------
1294 -- Check_Fortran_Logical --
1295 ---------------------------
1297 procedure Check_Fortran_Logical
is
1298 Logical
: constant Entity_Id
:= Etype
(Formal
);
1301 -- Note: this is very incomplete, e.g. it does not handle arrays
1302 -- of logical values. This is really not the right approach at all???)
1305 if Convention
(Subp
) = Convention_Fortran
1306 and then Root_Type
(Etype
(Formal
)) = Standard_Boolean
1307 and then Ekind
(Formal
) /= E_In_Parameter
1309 Var
:= Make_Var
(Actual
);
1310 Append_To
(Post_Call
,
1311 Make_Assignment_Statement
(Loc
,
1312 Name
=> New_Occurrence_Of
(Var
, Loc
),
1314 Unchecked_Convert_To
(
1317 Left_Opnd
=> New_Occurrence_Of
(Var
, Loc
),
1319 Unchecked_Convert_To
(
1321 New_Occurrence_Of
(Standard_False
, Loc
))))));
1323 end Check_Fortran_Logical
;
1329 function Is_Legal_Copy
return Boolean is
1331 -- An attempt to copy a value of such a type can only occur if
1332 -- representation clauses give the actual a misaligned address.
1334 if Is_By_Reference_Type
(Etype
(Formal
)) then
1336 ("misaligned actual cannot be passed by reference", Actual
);
1339 -- For users of Starlet, we assume that the specification of by-
1340 -- reference mechanism is mandatory. This may lead to unaligned
1341 -- objects but at least for DEC legacy code it is known to work.
1342 -- The warning will alert users of this code that a problem may
1345 elsif Mechanism
(Formal
) = By_Reference
1346 and then Is_Valued_Procedure
(Scope
(Formal
))
1349 ("by_reference actual may be misaligned?", Actual
);
1361 function Make_Var
(Actual
: Node_Id
) return Entity_Id
is
1365 if Is_Entity_Name
(Actual
) then
1366 return Entity
(Actual
);
1370 Make_Defining_Identifier
(Loc
,
1371 Chars
=> New_Internal_Name
('T'));
1374 Make_Object_Renaming_Declaration
(Loc
,
1375 Defining_Identifier
=> Var
,
1377 New_Occurrence_Of
(Etype
(Actual
), Loc
),
1378 Name
=> Relocate_Node
(Actual
));
1380 Insert_Action
(N
, N_Node
);
1385 -------------------------
1386 -- Reset_Packed_Prefix --
1387 -------------------------
1389 procedure Reset_Packed_Prefix
is
1390 Pfx
: Node_Id
:= Actual
;
1393 Set_Analyzed
(Pfx
, False);
1394 exit when Nkind
(Pfx
) /= N_Selected_Component
1395 and then Nkind
(Pfx
) /= N_Indexed_Component
;
1396 Pfx
:= Prefix
(Pfx
);
1398 end Reset_Packed_Prefix
;
1400 -- Start of processing for Expand_Actuals
1403 Post_Call
:= New_List
;
1405 Formal
:= First_Formal
(Subp
);
1406 Actual
:= First_Actual
(N
);
1407 while Present
(Formal
) loop
1408 E_Formal
:= Etype
(Formal
);
1410 if Is_Scalar_Type
(E_Formal
)
1411 or else Nkind
(Actual
) = N_Slice
1413 Check_Fortran_Logical
;
1417 elsif Ekind
(Formal
) /= E_Out_Parameter
then
1419 -- The unusual case of the current instance of a protected type
1420 -- requires special handling. This can only occur in the context
1421 -- of a call within the body of a protected operation.
1423 if Is_Entity_Name
(Actual
)
1424 and then Ekind
(Entity
(Actual
)) = E_Protected_Type
1425 and then In_Open_Scopes
(Entity
(Actual
))
1427 if Scope
(Subp
) /= Entity
(Actual
) then
1428 Error_Msg_N
("operation outside protected type may not "
1429 & "call back its protected operations?", Actual
);
1433 Expand_Protected_Object_Reference
(N
, Entity
(Actual
)));
1436 -- Ada 2005 (AI-318-02): If the actual parameter is a call to a
1437 -- build-in-place function, then a temporary return object needs
1438 -- to be created and access to it must be passed to the function.
1439 -- Currently we limit such functions to those with inherently
1440 -- limited result subtypes, but eventually we plan to expand the
1441 -- functions that are treated as build-in-place to include other
1442 -- composite result types.
1444 if Ada_Version
>= Ada_05
1445 and then Is_Build_In_Place_Function_Call
(Actual
)
1447 Make_Build_In_Place_Call_In_Anonymous_Context
(Actual
);
1450 Apply_Constraint_Check
(Actual
, E_Formal
);
1452 -- Out parameter case. No constraint checks on access type
1455 elsif Is_Access_Type
(E_Formal
) then
1460 elsif Has_Discriminants
(Base_Type
(E_Formal
))
1461 or else Has_Non_Null_Base_Init_Proc
(E_Formal
)
1463 Apply_Constraint_Check
(Actual
, E_Formal
);
1468 Apply_Constraint_Check
(Actual
, Base_Type
(E_Formal
));
1471 -- Processing for IN-OUT and OUT parameters
1473 if Ekind
(Formal
) /= E_In_Parameter
then
1475 -- For type conversions of arrays, apply length/range checks
1477 if Is_Array_Type
(E_Formal
)
1478 and then Nkind
(Actual
) = N_Type_Conversion
1480 if Is_Constrained
(E_Formal
) then
1481 Apply_Length_Check
(Expression
(Actual
), E_Formal
);
1483 Apply_Range_Check
(Expression
(Actual
), E_Formal
);
1487 -- If argument is a type conversion for a type that is passed
1488 -- by copy, then we must pass the parameter by copy.
1490 if Nkind
(Actual
) = N_Type_Conversion
1492 (Is_Numeric_Type
(E_Formal
)
1493 or else Is_Access_Type
(E_Formal
)
1494 or else Is_Enumeration_Type
(E_Formal
)
1495 or else Is_Bit_Packed_Array
(Etype
(Formal
))
1496 or else Is_Bit_Packed_Array
(Etype
(Expression
(Actual
)))
1498 -- Also pass by copy if change of representation
1500 or else not Same_Representation
1502 Etype
(Expression
(Actual
))))
1504 Add_Call_By_Copy_Code
;
1506 -- References to components of bit packed arrays are expanded
1507 -- at this point, rather than at the point of analysis of the
1508 -- actuals, to handle the expansion of the assignment to
1509 -- [in] out parameters.
1511 elsif Is_Ref_To_Bit_Packed_Array
(Actual
) then
1512 Add_Simple_Call_By_Copy_Code
;
1514 -- If a non-scalar actual is possibly bit-aligned, we need a copy
1515 -- because the back-end cannot cope with such objects. In other
1516 -- cases where alignment forces a copy, the back-end generates
1517 -- it properly. It should not be generated unconditionally in the
1518 -- front-end because it does not know precisely the alignment
1519 -- requirements of the target, and makes too conservative an
1520 -- estimate, leading to superfluous copies or spurious errors
1521 -- on by-reference parameters.
1523 elsif Nkind
(Actual
) = N_Selected_Component
1525 Component_May_Be_Bit_Aligned
(Entity
(Selector_Name
(Actual
)))
1526 and then not Represented_As_Scalar
(Etype
(Formal
))
1528 Add_Simple_Call_By_Copy_Code
;
1530 -- References to slices of bit packed arrays are expanded
1532 elsif Is_Ref_To_Bit_Packed_Slice
(Actual
) then
1533 Add_Call_By_Copy_Code
;
1535 -- References to possibly unaligned slices of arrays are expanded
1537 elsif Is_Possibly_Unaligned_Slice
(Actual
) then
1538 Add_Call_By_Copy_Code
;
1540 -- Deal with access types where the actual subtype and the
1541 -- formal subtype are not the same, requiring a check.
1543 -- It is necessary to exclude tagged types because of "downward
1544 -- conversion" errors and a strange assertion error in namet
1545 -- from gnatf in bug 1215-001 ???
1547 elsif Is_Access_Type
(E_Formal
)
1548 and then not Same_Type
(E_Formal
, Etype
(Actual
))
1549 and then not Is_Tagged_Type
(Designated_Type
(E_Formal
))
1551 Add_Call_By_Copy_Code
;
1553 -- If the actual is not a scalar and is marked for volatile
1554 -- treatment, whereas the formal is not volatile, then pass
1555 -- by copy unless it is a by-reference type.
1557 elsif Is_Entity_Name
(Actual
)
1558 and then Treat_As_Volatile
(Entity
(Actual
))
1559 and then not Is_By_Reference_Type
(Etype
(Actual
))
1560 and then not Is_Scalar_Type
(Etype
(Entity
(Actual
)))
1561 and then not Treat_As_Volatile
(E_Formal
)
1563 Add_Call_By_Copy_Code
;
1565 elsif Nkind
(Actual
) = N_Indexed_Component
1566 and then Is_Entity_Name
(Prefix
(Actual
))
1567 and then Has_Volatile_Components
(Entity
(Prefix
(Actual
)))
1569 Add_Call_By_Copy_Code
;
1572 -- Processing for IN parameters
1575 -- For IN parameters is in the packed array case, we expand an
1576 -- indexed component (the circuit in Exp_Ch4 deliberately left
1577 -- indexed components appearing as actuals untouched, so that
1578 -- the special processing above for the OUT and IN OUT cases
1579 -- could be performed. We could make the test in Exp_Ch4 more
1580 -- complex and have it detect the parameter mode, but it is
1581 -- easier simply to handle all cases here.)
1583 if Nkind
(Actual
) = N_Indexed_Component
1584 and then Is_Packed
(Etype
(Prefix
(Actual
)))
1586 Reset_Packed_Prefix
;
1587 Expand_Packed_Element_Reference
(Actual
);
1589 -- If we have a reference to a bit packed array, we copy it,
1590 -- since the actual must be byte aligned.
1592 -- Is this really necessary in all cases???
1594 elsif Is_Ref_To_Bit_Packed_Array
(Actual
) then
1595 Add_Simple_Call_By_Copy_Code
;
1597 -- If a non-scalar actual is possibly unaligned, we need a copy
1599 elsif Is_Possibly_Unaligned_Object
(Actual
)
1600 and then not Represented_As_Scalar
(Etype
(Formal
))
1602 Add_Simple_Call_By_Copy_Code
;
1604 -- Similarly, we have to expand slices of packed arrays here
1605 -- because the result must be byte aligned.
1607 elsif Is_Ref_To_Bit_Packed_Slice
(Actual
) then
1608 Add_Call_By_Copy_Code
;
1610 -- Only processing remaining is to pass by copy if this is a
1611 -- reference to a possibly unaligned slice, since the caller
1612 -- expects an appropriately aligned argument.
1614 elsif Is_Possibly_Unaligned_Slice
(Actual
) then
1615 Add_Call_By_Copy_Code
;
1619 Next_Formal
(Formal
);
1620 Next_Actual
(Actual
);
1623 -- Find right place to put post call stuff if it is present
1625 if not Is_Empty_List
(Post_Call
) then
1627 -- If call is not a list member, it must be the triggering statement
1628 -- of a triggering alternative or an entry call alternative, and we
1629 -- can add the post call stuff to the corresponding statement list.
1631 if not Is_List_Member
(N
) then
1633 P
: constant Node_Id
:= Parent
(N
);
1636 pragma Assert
(Nkind
(P
) = N_Triggering_Alternative
1637 or else Nkind
(P
) = N_Entry_Call_Alternative
);
1639 if Is_Non_Empty_List
(Statements
(P
)) then
1640 Insert_List_Before_And_Analyze
1641 (First
(Statements
(P
)), Post_Call
);
1643 Set_Statements
(P
, Post_Call
);
1647 -- Otherwise, normal case where N is in a statement sequence,
1648 -- just put the post-call stuff after the call statement.
1651 Insert_Actions_After
(N
, Post_Call
);
1655 -- The call node itself is re-analyzed in Expand_Call
1663 -- This procedure handles expansion of function calls and procedure call
1664 -- statements (i.e. it serves as the body for Expand_N_Function_Call and
1665 -- Expand_N_Procedure_Call_Statement. Processing for calls includes:
1667 -- Replace call to Raise_Exception by Raise_Exception always if possible
1668 -- Provide values of actuals for all formals in Extra_Formals list
1669 -- Replace "call" to enumeration literal function by literal itself
1670 -- Rewrite call to predefined operator as operator
1671 -- Replace actuals to in-out parameters that are numeric conversions,
1672 -- with explicit assignment to temporaries before and after the call.
1673 -- Remove optional actuals if First_Optional_Parameter specified.
1675 -- Note that the list of actuals has been filled with default expressions
1676 -- during semantic analysis of the call. Only the extra actuals required
1677 -- for the 'Constrained attribute and for accessibility checks are added
1680 procedure Expand_Call
(N
: Node_Id
) is
1681 Loc
: constant Source_Ptr
:= Sloc
(N
);
1682 Extra_Actuals
: List_Id
:= No_List
;
1683 Prev
: Node_Id
:= Empty
;
1685 procedure Add_Actual_Parameter
(Insert_Param
: Node_Id
);
1686 -- Adds one entry to the end of the actual parameter list. Used for
1687 -- default parameters and for extra actuals (for Extra_Formals). The
1688 -- argument is an N_Parameter_Association node.
1690 procedure Add_Extra_Actual
(Expr
: Node_Id
; EF
: Entity_Id
);
1691 -- Adds an extra actual to the list of extra actuals. Expr is the
1692 -- expression for the value of the actual, EF is the entity for the
1695 function Inherited_From_Formal
(S
: Entity_Id
) return Entity_Id
;
1696 -- Within an instance, a type derived from a non-tagged formal derived
1697 -- type inherits from the original parent, not from the actual. This is
1698 -- tested in 4723-003. The current derivation mechanism has the derived
1699 -- type inherit from the actual, which is only correct outside of the
1700 -- instance. If the subprogram is inherited, we test for this particular
1701 -- case through a convoluted tree traversal before setting the proper
1702 -- subprogram to be called.
1704 --------------------------
1705 -- Add_Actual_Parameter --
1706 --------------------------
1708 procedure Add_Actual_Parameter
(Insert_Param
: Node_Id
) is
1709 Actual_Expr
: constant Node_Id
:=
1710 Explicit_Actual_Parameter
(Insert_Param
);
1713 -- Case of insertion is first named actual
1715 if No
(Prev
) or else
1716 Nkind
(Parent
(Prev
)) /= N_Parameter_Association
1718 Set_Next_Named_Actual
(Insert_Param
, First_Named_Actual
(N
));
1719 Set_First_Named_Actual
(N
, Actual_Expr
);
1722 if No
(Parameter_Associations
(N
)) then
1723 Set_Parameter_Associations
(N
, New_List
);
1724 Append
(Insert_Param
, Parameter_Associations
(N
));
1727 Insert_After
(Prev
, Insert_Param
);
1730 -- Case of insertion is not first named actual
1733 Set_Next_Named_Actual
1734 (Insert_Param
, Next_Named_Actual
(Parent
(Prev
)));
1735 Set_Next_Named_Actual
(Parent
(Prev
), Actual_Expr
);
1736 Append
(Insert_Param
, Parameter_Associations
(N
));
1739 Prev
:= Actual_Expr
;
1740 end Add_Actual_Parameter
;
1742 ----------------------
1743 -- Add_Extra_Actual --
1744 ----------------------
1746 procedure Add_Extra_Actual
(Expr
: Node_Id
; EF
: Entity_Id
) is
1747 Loc
: constant Source_Ptr
:= Sloc
(Expr
);
1750 if Extra_Actuals
= No_List
then
1751 Extra_Actuals
:= New_List
;
1752 Set_Parent
(Extra_Actuals
, N
);
1755 Append_To
(Extra_Actuals
,
1756 Make_Parameter_Association
(Loc
,
1757 Explicit_Actual_Parameter
=> Expr
,
1759 Make_Identifier
(Loc
, Chars
(EF
))));
1761 Analyze_And_Resolve
(Expr
, Etype
(EF
));
1762 end Add_Extra_Actual
;
1764 ---------------------------
1765 -- Inherited_From_Formal --
1766 ---------------------------
1768 function Inherited_From_Formal
(S
: Entity_Id
) return Entity_Id
is
1770 Gen_Par
: Entity_Id
;
1771 Gen_Prim
: Elist_Id
;
1776 -- If the operation is inherited, it is attached to the corresponding
1777 -- type derivation. If the parent in the derivation is a generic
1778 -- actual, it is a subtype of the actual, and we have to recover the
1779 -- original derived type declaration to find the proper parent.
1781 if Nkind
(Parent
(S
)) /= N_Full_Type_Declaration
1782 or else not Is_Derived_Type
(Defining_Identifier
(Parent
(S
)))
1783 or else Nkind
(Type_Definition
(Original_Node
(Parent
(S
)))) /=
1784 N_Derived_Type_Definition
1785 or else not In_Instance
1792 (Type_Definition
(Original_Node
(Parent
(S
)))));
1794 if Nkind
(Indic
) = N_Subtype_Indication
then
1795 Par
:= Entity
(Subtype_Mark
(Indic
));
1797 Par
:= Entity
(Indic
);
1801 if not Is_Generic_Actual_Type
(Par
)
1802 or else Is_Tagged_Type
(Par
)
1803 or else Nkind
(Parent
(Par
)) /= N_Subtype_Declaration
1804 or else not In_Open_Scopes
(Scope
(Par
))
1809 Gen_Par
:= Generic_Parent_Type
(Parent
(Par
));
1812 -- If the actual has no generic parent type, the formal is not
1813 -- a formal derived type, so nothing to inherit.
1815 if No
(Gen_Par
) then
1819 -- If the generic parent type is still the generic type, this is a
1820 -- private formal, not a derived formal, and there are no operations
1821 -- inherited from the formal.
1823 if Nkind
(Parent
(Gen_Par
)) = N_Formal_Type_Declaration
then
1827 Gen_Prim
:= Collect_Primitive_Operations
(Gen_Par
);
1829 Elmt
:= First_Elmt
(Gen_Prim
);
1830 while Present
(Elmt
) loop
1831 if Chars
(Node
(Elmt
)) = Chars
(S
) then
1837 F1
:= First_Formal
(S
);
1838 F2
:= First_Formal
(Node
(Elmt
));
1840 and then Present
(F2
)
1842 if Etype
(F1
) = Etype
(F2
)
1843 or else Etype
(F2
) = Gen_Par
1849 exit; -- not the right subprogram
1861 raise Program_Error
;
1862 end Inherited_From_Formal
;
1866 Remote
: constant Boolean := Is_Remote_Call
(N
);
1869 Orig_Subp
: Entity_Id
:= Empty
;
1870 Param_Count
: Natural := 0;
1871 Parent_Formal
: Entity_Id
;
1872 Parent_Subp
: Entity_Id
;
1876 Prev_Orig
: Node_Id
;
1877 -- Original node for an actual, which may have been rewritten. If the
1878 -- actual is a function call that has been transformed from a selected
1879 -- component, the original node is unanalyzed. Otherwise, it carries
1880 -- semantic information used to generate additional actuals.
1882 CW_Interface_Formals_Present
: Boolean := False;
1884 -- Start of processing for Expand_Call
1887 -- Ignore if previous error
1889 if Nkind
(N
) in N_Has_Etype
and then Etype
(N
) = Any_Type
then
1893 -- Call using access to subprogram with explicit dereference
1895 if Nkind
(Name
(N
)) = N_Explicit_Dereference
then
1896 Subp
:= Etype
(Name
(N
));
1897 Parent_Subp
:= Empty
;
1899 -- Case of call to simple entry, where the Name is a selected component
1900 -- whose prefix is the task, and whose selector name is the entry name
1902 elsif Nkind
(Name
(N
)) = N_Selected_Component
then
1903 Subp
:= Entity
(Selector_Name
(Name
(N
)));
1904 Parent_Subp
:= Empty
;
1906 -- Case of call to member of entry family, where Name is an indexed
1907 -- component, with the prefix being a selected component giving the
1908 -- task and entry family name, and the index being the entry index.
1910 elsif Nkind
(Name
(N
)) = N_Indexed_Component
then
1911 Subp
:= Entity
(Selector_Name
(Prefix
(Name
(N
))));
1912 Parent_Subp
:= Empty
;
1917 Subp
:= Entity
(Name
(N
));
1918 Parent_Subp
:= Alias
(Subp
);
1920 -- Replace call to Raise_Exception by call to Raise_Exception_Always
1921 -- if we can tell that the first parameter cannot possibly be null.
1922 -- This helps optimization and also generation of warnings.
1924 -- We do not do this if Raise_Exception_Always does not exist, which
1925 -- can happen in configurable run time profiles which provide only a
1926 -- Raise_Exception, which is in fact an unconditional raise anyway.
1928 if Is_RTE
(Subp
, RE_Raise_Exception
)
1929 and then RTE_Available
(RE_Raise_Exception_Always
)
1932 FA
: constant Node_Id
:= Original_Node
(First_Actual
(N
));
1935 -- The case we catch is where the first argument is obtained
1936 -- using the Identity attribute (which must always be
1939 if Nkind
(FA
) = N_Attribute_Reference
1940 and then Attribute_Name
(FA
) = Name_Identity
1942 Subp
:= RTE
(RE_Raise_Exception_Always
);
1943 Set_Name
(N
, New_Occurrence_Of
(Subp
, Loc
));
1948 if Ekind
(Subp
) = E_Entry
then
1949 Parent_Subp
:= Empty
;
1953 -- Ada 2005 (AI-345): We have a procedure call as a triggering
1954 -- alternative in an asynchronous select or as an entry call in
1955 -- a conditional or timed select. Check whether the procedure call
1956 -- is a renaming of an entry and rewrite it as an entry call.
1958 if Ada_Version
>= Ada_05
1959 and then Nkind
(N
) = N_Procedure_Call_Statement
1961 ((Nkind
(Parent
(N
)) = N_Triggering_Alternative
1962 and then Triggering_Statement
(Parent
(N
)) = N
)
1964 (Nkind
(Parent
(N
)) = N_Entry_Call_Alternative
1965 and then Entry_Call_Statement
(Parent
(N
)) = N
))
1969 Ren_Root
: Entity_Id
:= Subp
;
1972 -- This may be a chain of renamings, find the root
1974 if Present
(Alias
(Ren_Root
)) then
1975 Ren_Root
:= Alias
(Ren_Root
);
1978 if Present
(Original_Node
(Parent
(Parent
(Ren_Root
)))) then
1979 Ren_Decl
:= Original_Node
(Parent
(Parent
(Ren_Root
)));
1981 if Nkind
(Ren_Decl
) = N_Subprogram_Renaming_Declaration
then
1983 Make_Entry_Call_Statement
(Loc
,
1985 New_Copy_Tree
(Name
(Ren_Decl
)),
1986 Parameter_Associations
=>
1987 New_Copy_List_Tree
(Parameter_Associations
(N
))));
1995 -- First step, compute extra actuals, corresponding to any
1996 -- Extra_Formals present. Note that we do not access Extra_Formals
1997 -- directly, instead we simply note the presence of the extra
1998 -- formals as we process the regular formals and collect the
1999 -- corresponding actuals in Extra_Actuals.
2001 -- We also generate any required range checks for actuals as we go
2002 -- through the loop, since this is a convenient place to do this.
2004 Formal
:= First_Formal
(Subp
);
2005 Actual
:= First_Actual
(N
);
2007 while Present
(Formal
) loop
2009 -- Generate range check if required (not activated yet ???)
2011 -- if Do_Range_Check (Actual) then
2012 -- Set_Do_Range_Check (Actual, False);
2013 -- Generate_Range_Check
2014 -- (Actual, Etype (Formal), CE_Range_Check_Failed);
2017 -- Prepare to examine current entry
2020 Prev_Orig
:= Original_Node
(Prev
);
2022 -- The original actual may have been a call written in prefix
2023 -- form, and rewritten before analysis.
2025 if not Analyzed
(Prev_Orig
)
2027 (Nkind
(Actual
) = N_Function_Call
2029 Nkind
(Actual
) = N_Identifier
)
2034 -- Ada 2005 (AI-251): Check if any formal is a class-wide interface
2035 -- to expand it in a further round.
2037 CW_Interface_Formals_Present
:=
2038 CW_Interface_Formals_Present
2040 (Ekind
(Etype
(Formal
)) = E_Class_Wide_Type
2041 and then Is_Interface
(Etype
(Etype
(Formal
))))
2043 (Ekind
(Etype
(Formal
)) = E_Anonymous_Access_Type
2044 and then Is_Interface
(Directly_Designated_Type
2045 (Etype
(Etype
(Formal
)))));
2047 -- Create possible extra actual for constrained case. Usually, the
2048 -- extra actual is of the form actual'constrained, but since this
2049 -- attribute is only available for unconstrained records, TRUE is
2050 -- expanded if the type of the formal happens to be constrained (for
2051 -- instance when this procedure is inherited from an unconstrained
2052 -- record to a constrained one) or if the actual has no discriminant
2053 -- (its type is constrained). An exception to this is the case of a
2054 -- private type without discriminants. In this case we pass FALSE
2055 -- because the object has underlying discriminants with defaults.
2057 if Present
(Extra_Constrained
(Formal
)) then
2058 if Ekind
(Etype
(Prev
)) in Private_Kind
2059 and then not Has_Discriminants
(Base_Type
(Etype
(Prev
)))
2062 New_Occurrence_Of
(Standard_False
, Loc
),
2063 Extra_Constrained
(Formal
));
2065 elsif Is_Constrained
(Etype
(Formal
))
2066 or else not Has_Discriminants
(Etype
(Prev
))
2069 New_Occurrence_Of
(Standard_True
, Loc
),
2070 Extra_Constrained
(Formal
));
2072 -- Do not produce extra actuals for Unchecked_Union parameters.
2073 -- Jump directly to the end of the loop.
2075 elsif Is_Unchecked_Union
(Base_Type
(Etype
(Actual
))) then
2076 goto Skip_Extra_Actual_Generation
;
2079 -- If the actual is a type conversion, then the constrained
2080 -- test applies to the actual, not the target type.
2086 -- Test for unchecked conversions as well, which can occur
2087 -- as out parameter actuals on calls to stream procedures.
2090 while Nkind
(Act_Prev
) = N_Type_Conversion
2091 or else Nkind
(Act_Prev
) = N_Unchecked_Type_Conversion
2093 Act_Prev
:= Expression
(Act_Prev
);
2096 -- If the expression is a conversion of a dereference,
2097 -- this is internally generated code that manipulates
2098 -- addresses, e.g. when building interface tables. No
2099 -- check should occur in this case, and the discriminated
2100 -- object is not directly a hand.
2102 if not Comes_From_Source
(Actual
)
2103 and then Nkind
(Actual
) = N_Unchecked_Type_Conversion
2104 and then Nkind
(Act_Prev
) = N_Explicit_Dereference
2107 (New_Occurrence_Of
(Standard_False
, Loc
),
2108 Extra_Constrained
(Formal
));
2112 (Make_Attribute_Reference
(Sloc
(Prev
),
2114 Duplicate_Subexpr_No_Checks
2115 (Act_Prev
, Name_Req
=> True),
2116 Attribute_Name
=> Name_Constrained
),
2117 Extra_Constrained
(Formal
));
2123 -- Create possible extra actual for accessibility level
2125 if Present
(Extra_Accessibility
(Formal
)) then
2127 -- Ada 2005 (AI-252): If the actual was rewritten as an Access
2128 -- attribute, then the original actual may be an aliased object
2129 -- occurring as the prefix in a call using "Object.Operation"
2130 -- notation. In that case we must pass the level of the object,
2131 -- so Prev_Orig is reset to Prev and the attribute will be
2132 -- processed by the code for Access attributes further below.
2134 if Prev_Orig
/= Prev
2135 and then Nkind
(Prev
) = N_Attribute_Reference
2137 Get_Attribute_Id
(Attribute_Name
(Prev
)) = Attribute_Access
2138 and then Is_Aliased_View
(Prev_Orig
)
2143 -- Ada 2005 (AI-251): Thunks must propagate the extra actuals
2144 -- of accessibility levels.
2146 if Ekind
(Current_Scope
) in Subprogram_Kind
2147 and then Is_Thunk
(Current_Scope
)
2150 Parm_Ent
: Entity_Id
;
2153 if Is_Controlling_Actual
(Actual
) then
2155 -- Find the corresponding actual of the thunk
2157 Parm_Ent
:= First_Entity
(Current_Scope
);
2158 for J
in 2 .. Param_Count
loop
2159 Next_Entity
(Parm_Ent
);
2162 else pragma Assert
(Is_Entity_Name
(Actual
));
2163 Parm_Ent
:= Entity
(Actual
);
2167 (New_Occurrence_Of
(Extra_Accessibility
(Parm_Ent
), Loc
),
2168 Extra_Accessibility
(Formal
));
2171 elsif Is_Entity_Name
(Prev_Orig
) then
2173 -- When passing an access parameter, or a renaming of an access
2174 -- parameter, as the actual to another access parameter we need
2175 -- to pass along the actual's own access level parameter. This
2176 -- is done if we are within the scope of the formal access
2177 -- parameter (if this is an inlined body the extra formal is
2180 if (Is_Formal
(Entity
(Prev_Orig
))
2182 (Present
(Renamed_Object
(Entity
(Prev_Orig
)))
2184 Is_Entity_Name
(Renamed_Object
(Entity
(Prev_Orig
)))
2187 (Entity
(Renamed_Object
(Entity
(Prev_Orig
))))))
2188 and then Ekind
(Etype
(Prev_Orig
)) = E_Anonymous_Access_Type
2189 and then In_Open_Scopes
(Scope
(Entity
(Prev_Orig
)))
2192 Parm_Ent
: constant Entity_Id
:= Param_Entity
(Prev_Orig
);
2195 pragma Assert
(Present
(Parm_Ent
));
2197 if Present
(Extra_Accessibility
(Parm_Ent
)) then
2200 (Extra_Accessibility
(Parm_Ent
), Loc
),
2201 Extra_Accessibility
(Formal
));
2203 -- If the actual access parameter does not have an
2204 -- associated extra formal providing its scope level,
2205 -- then treat the actual as having library-level
2210 (Make_Integer_Literal
(Loc
,
2211 Intval
=> Scope_Depth
(Standard_Standard
)),
2212 Extra_Accessibility
(Formal
));
2216 -- The actual is a normal access value, so just pass the level
2217 -- of the actual's access type.
2221 (Make_Integer_Literal
(Loc
,
2222 Intval
=> Type_Access_Level
(Etype
(Prev_Orig
))),
2223 Extra_Accessibility
(Formal
));
2226 -- All cases other than thunks
2229 case Nkind
(Prev_Orig
) is
2231 when N_Attribute_Reference
=>
2232 case Get_Attribute_Id
(Attribute_Name
(Prev_Orig
)) is
2234 -- For X'Access, pass on the level of the prefix X
2236 when Attribute_Access
=>
2238 Make_Integer_Literal
(Loc
,
2240 Object_Access_Level
(Prefix
(Prev_Orig
))),
2241 Extra_Accessibility
(Formal
));
2243 -- Treat the unchecked attributes as library-level
2245 when Attribute_Unchecked_Access |
2246 Attribute_Unrestricted_Access
=>
2248 Make_Integer_Literal
(Loc
,
2249 Intval
=> Scope_Depth
(Standard_Standard
)),
2250 Extra_Accessibility
(Formal
));
2252 -- No other cases of attributes returning access
2253 -- values that can be passed to access parameters
2256 raise Program_Error
;
2260 -- For allocators we pass the level of the execution of
2261 -- the called subprogram, which is one greater than the
2262 -- current scope level.
2266 Make_Integer_Literal
(Loc
,
2267 Scope_Depth
(Current_Scope
) + 1),
2268 Extra_Accessibility
(Formal
));
2270 -- For other cases we simply pass the level of the
2271 -- actual's access type.
2275 Make_Integer_Literal
(Loc
,
2276 Intval
=> Type_Access_Level
(Etype
(Prev_Orig
))),
2277 Extra_Accessibility
(Formal
));
2283 -- Perform the check of 4.6(49) that prevents a null value from being
2284 -- passed as an actual to an access parameter. Note that the check is
2285 -- elided in the common cases of passing an access attribute or
2286 -- access parameter as an actual. Also, we currently don't enforce
2287 -- this check for expander-generated actuals and when -gnatdj is set.
2289 if Ada_Version
>= Ada_05
then
2291 -- Ada 2005 (AI-231): Check null-excluding access types
2293 if Is_Access_Type
(Etype
(Formal
))
2294 and then Can_Never_Be_Null
(Etype
(Formal
))
2295 and then Nkind
(Prev
) /= N_Raise_Constraint_Error
2296 and then (Known_Null
(Prev
)
2297 or else not Can_Never_Be_Null
(Etype
(Prev
)))
2299 Install_Null_Excluding_Check
(Prev
);
2302 -- Ada_Version < Ada_05
2305 if Ekind
(Etype
(Formal
)) /= E_Anonymous_Access_Type
2306 or else Access_Checks_Suppressed
(Subp
)
2310 elsif Debug_Flag_J
then
2313 elsif not Comes_From_Source
(Prev
) then
2316 elsif Is_Entity_Name
(Prev
)
2317 and then Ekind
(Etype
(Prev
)) = E_Anonymous_Access_Type
2321 elsif Nkind
(Prev
) = N_Allocator
2322 or else Nkind
(Prev
) = N_Attribute_Reference
2326 -- Suppress null checks when passing to access parameters of Java
2327 -- and CIL subprograms. (Should this be done for other foreign
2328 -- conventions as well ???)
2330 elsif Convention
(Subp
) = Convention_Java
2331 or else Convention
(Subp
) = Convention_CIL
2336 Install_Null_Excluding_Check
(Prev
);
2340 -- Perform appropriate validity checks on parameters that
2343 if Validity_Checks_On
then
2344 if (Ekind
(Formal
) = E_In_Parameter
2345 and then Validity_Check_In_Params
)
2347 (Ekind
(Formal
) = E_In_Out_Parameter
2348 and then Validity_Check_In_Out_Params
)
2350 -- If the actual is an indexed component of a packed type (or
2351 -- is an indexed or selected component whose prefix recursively
2352 -- meets this condition), it has not been expanded yet. It will
2353 -- be copied in the validity code that follows, and has to be
2354 -- expanded appropriately, so reanalyze it.
2356 -- What we do is just to unset analyzed bits on prefixes till
2357 -- we reach something that does not have a prefix.
2364 while Nkind
(Nod
) = N_Indexed_Component
2366 Nkind
(Nod
) = N_Selected_Component
2368 Set_Analyzed
(Nod
, False);
2369 Nod
:= Prefix
(Nod
);
2373 Ensure_Valid
(Actual
);
2377 -- For IN OUT and OUT parameters, ensure that subscripts are valid
2378 -- since this is a left side reference. We only do this for calls
2379 -- from the source program since we assume that compiler generated
2380 -- calls explicitly generate any required checks. We also need it
2381 -- only if we are doing standard validity checks, since clearly it
2382 -- is not needed if validity checks are off, and in subscript
2383 -- validity checking mode, all indexed components are checked with
2384 -- a call directly from Expand_N_Indexed_Component.
2386 if Comes_From_Source
(N
)
2387 and then Ekind
(Formal
) /= E_In_Parameter
2388 and then Validity_Checks_On
2389 and then Validity_Check_Default
2390 and then not Validity_Check_Subscripts
2392 Check_Valid_Lvalue_Subscripts
(Actual
);
2395 -- Mark any scalar OUT parameter that is a simple variable as no
2396 -- longer known to be valid (unless the type is always valid). This
2397 -- reflects the fact that if an OUT parameter is never set in a
2398 -- procedure, then it can become invalid on the procedure return.
2400 if Ekind
(Formal
) = E_Out_Parameter
2401 and then Is_Entity_Name
(Actual
)
2402 and then Ekind
(Entity
(Actual
)) = E_Variable
2403 and then not Is_Known_Valid
(Etype
(Actual
))
2405 Set_Is_Known_Valid
(Entity
(Actual
), False);
2408 -- For an OUT or IN OUT parameter, if the actual is an entity, then
2409 -- clear current values, since they can be clobbered. We are probably
2410 -- doing this in more places than we need to, but better safe than
2411 -- sorry when it comes to retaining bad current values!
2413 if Ekind
(Formal
) /= E_In_Parameter
2414 and then Is_Entity_Name
(Actual
)
2415 and then Present
(Entity
(Actual
))
2418 Ent
: constant Entity_Id
:= Entity
(Actual
);
2422 -- For an OUT parameter that is an assignable entity, we do not
2423 -- want to clobber the Last_Assignment field, since if it is
2424 -- set, it was precisely because it is indeed an OUT parameter!
2426 if Ekind
(Formal
) = E_Out_Parameter
2427 and then Is_Assignable
(Ent
)
2429 Sav
:= Last_Assignment
(Ent
);
2430 Kill_Current_Values
(Ent
);
2431 Set_Last_Assignment
(Ent
, Sav
);
2433 -- For all other cases, just kill the current values
2436 Kill_Current_Values
(Ent
);
2441 -- If the formal is class wide and the actual is an aggregate, force
2442 -- evaluation so that the back end who does not know about class-wide
2443 -- type, does not generate a temporary of the wrong size.
2445 if not Is_Class_Wide_Type
(Etype
(Formal
)) then
2448 elsif Nkind
(Actual
) = N_Aggregate
2449 or else (Nkind
(Actual
) = N_Qualified_Expression
2450 and then Nkind
(Expression
(Actual
)) = N_Aggregate
)
2452 Force_Evaluation
(Actual
);
2455 -- In a remote call, if the formal is of a class-wide type, check
2456 -- that the actual meets the requirements described in E.4(18).
2458 if Remote
and then Is_Class_Wide_Type
(Etype
(Formal
)) then
2459 Insert_Action
(Actual
,
2460 Make_Transportable_Check
(Loc
,
2461 Duplicate_Subexpr_Move_Checks
(Actual
)));
2464 -- This label is required when skipping extra actual generation for
2465 -- Unchecked_Union parameters.
2467 <<Skip_Extra_Actual_Generation
>>
2469 Param_Count
:= Param_Count
+ 1;
2470 Next_Actual
(Actual
);
2471 Next_Formal
(Formal
);
2474 -- If we are expanding a rhs of an assignment we need to check if tag
2475 -- propagation is needed. You might expect this processing to be in
2476 -- Analyze_Assignment but has to be done earlier (bottom-up) because the
2477 -- assignment might be transformed to a declaration for an unconstrained
2478 -- value if the expression is classwide.
2480 if Nkind
(N
) = N_Function_Call
2481 and then Is_Tag_Indeterminate
(N
)
2482 and then Is_Entity_Name
(Name
(N
))
2485 Ass
: Node_Id
:= Empty
;
2488 if Nkind
(Parent
(N
)) = N_Assignment_Statement
then
2491 elsif Nkind
(Parent
(N
)) = N_Qualified_Expression
2492 and then Nkind
(Parent
(Parent
(N
))) = N_Assignment_Statement
2494 Ass
:= Parent
(Parent
(N
));
2496 elsif Nkind
(Parent
(N
)) = N_Explicit_Dereference
2497 and then Nkind
(Parent
(Parent
(N
))) = N_Assignment_Statement
2499 Ass
:= Parent
(Parent
(N
));
2503 and then Is_Class_Wide_Type
(Etype
(Name
(Ass
)))
2505 if Is_Access_Type
(Etype
(N
)) then
2506 if Designated_Type
(Etype
(N
)) /=
2507 Root_Type
(Etype
(Name
(Ass
)))
2510 ("tag-indeterminate expression "
2511 & " must have designated type& (RM 5.2 (6))",
2512 N
, Root_Type
(Etype
(Name
(Ass
))));
2514 Propagate_Tag
(Name
(Ass
), N
);
2517 elsif Etype
(N
) /= Root_Type
(Etype
(Name
(Ass
))) then
2519 ("tag-indeterminate expression must have type&"
2520 & "(RM 5.2 (6))", N
, Root_Type
(Etype
(Name
(Ass
))));
2523 Propagate_Tag
(Name
(Ass
), N
);
2526 -- The call will be rewritten as a dispatching call, and
2527 -- expanded as such.
2534 -- Ada 2005 (AI-251): If some formal is a class-wide interface, expand
2535 -- it to point to the correct secondary virtual table
2537 if (Nkind
(N
) = N_Function_Call
2538 or else Nkind
(N
) = N_Procedure_Call_Statement
)
2539 and then CW_Interface_Formals_Present
2541 Expand_Interface_Actuals
(N
);
2544 -- Deals with Dispatch_Call if we still have a call, before expanding
2545 -- extra actuals since this will be done on the re-analysis of the
2546 -- dispatching call. Note that we do not try to shorten the actual
2547 -- list for a dispatching call, it would not make sense to do so.
2548 -- Expansion of dispatching calls is suppressed when VM_Target, because
2549 -- the VM back-ends directly handle the generation of dispatching
2550 -- calls and would have to undo any expansion to an indirect call.
2552 if (Nkind
(N
) = N_Function_Call
2553 or else Nkind
(N
) = N_Procedure_Call_Statement
)
2554 and then Present
(Controlling_Argument
(N
))
2555 and then VM_Target
= No_VM
2557 Expand_Dispatching_Call
(N
);
2559 -- The following return is worrisome. Is it really OK to
2560 -- skip all remaining processing in this procedure ???
2564 -- Similarly, expand calls to RCI subprograms on which pragma
2565 -- All_Calls_Remote applies. The rewriting will be reanalyzed
2566 -- later. Do this only when the call comes from source since we do
2567 -- not want such a rewritting to occur in expanded code.
2569 elsif Is_All_Remote_Call
(N
) then
2570 Expand_All_Calls_Remote_Subprogram_Call
(N
);
2572 -- Similarly, do not add extra actuals for an entry call whose entity
2573 -- is a protected procedure, or for an internal protected subprogram
2574 -- call, because it will be rewritten as a protected subprogram call
2575 -- and reanalyzed (see Expand_Protected_Subprogram_Call).
2577 elsif Is_Protected_Type
(Scope
(Subp
))
2578 and then (Ekind
(Subp
) = E_Procedure
2579 or else Ekind
(Subp
) = E_Function
)
2583 -- During that loop we gathered the extra actuals (the ones that
2584 -- correspond to Extra_Formals), so now they can be appended.
2587 while Is_Non_Empty_List
(Extra_Actuals
) loop
2588 Add_Actual_Parameter
(Remove_Head
(Extra_Actuals
));
2592 -- At this point we have all the actuals, so this is the point at
2593 -- which the various expansion activities for actuals is carried out.
2595 Expand_Actuals
(N
, Subp
);
2597 -- If the subprogram is a renaming, or if it is inherited, replace it
2598 -- in the call with the name of the actual subprogram being called.
2599 -- If this is a dispatching call, the run-time decides what to call.
2600 -- The Alias attribute does not apply to entries.
2602 if Nkind
(N
) /= N_Entry_Call_Statement
2603 and then No
(Controlling_Argument
(N
))
2604 and then Present
(Parent_Subp
)
2606 if Present
(Inherited_From_Formal
(Subp
)) then
2607 Parent_Subp
:= Inherited_From_Formal
(Subp
);
2609 while Present
(Alias
(Parent_Subp
)) loop
2610 Parent_Subp
:= Alias
(Parent_Subp
);
2614 -- The below setting of Entity is suspect, see F109-018 discussion???
2616 Set_Entity
(Name
(N
), Parent_Subp
);
2618 if Is_Abstract_Subprogram
(Parent_Subp
)
2619 and then not In_Instance
2622 ("cannot call abstract subprogram &!", Name
(N
), Parent_Subp
);
2625 -- Add an explicit conversion for parameter of the derived type.
2626 -- This is only done for scalar and access in-parameters. Others
2627 -- have been expanded in expand_actuals.
2629 Formal
:= First_Formal
(Subp
);
2630 Parent_Formal
:= First_Formal
(Parent_Subp
);
2631 Actual
:= First_Actual
(N
);
2633 -- It is not clear that conversion is needed for intrinsic
2634 -- subprograms, but it certainly is for those that are user-
2635 -- defined, and that can be inherited on derivation, namely
2636 -- unchecked conversion and deallocation.
2637 -- General case needs study ???
2639 if not Is_Intrinsic_Subprogram
(Parent_Subp
)
2640 or else Is_Generic_Instance
(Parent_Subp
)
2642 while Present
(Formal
) loop
2643 if Etype
(Formal
) /= Etype
(Parent_Formal
)
2644 and then Is_Scalar_Type
(Etype
(Formal
))
2645 and then Ekind
(Formal
) = E_In_Parameter
2647 not Subtypes_Statically_Match
2648 (Etype
(Parent_Formal
), Etype
(Actual
))
2649 and then not Raises_Constraint_Error
(Actual
)
2652 OK_Convert_To
(Etype
(Parent_Formal
),
2653 Relocate_Node
(Actual
)));
2656 Resolve
(Actual
, Etype
(Parent_Formal
));
2657 Enable_Range_Check
(Actual
);
2659 elsif Is_Access_Type
(Etype
(Formal
))
2660 and then Base_Type
(Etype
(Parent_Formal
)) /=
2661 Base_Type
(Etype
(Actual
))
2663 if Ekind
(Formal
) /= E_In_Parameter
then
2665 Convert_To
(Etype
(Parent_Formal
),
2666 Relocate_Node
(Actual
)));
2669 Resolve
(Actual
, Etype
(Parent_Formal
));
2672 Ekind
(Etype
(Parent_Formal
)) = E_Anonymous_Access_Type
2673 and then Designated_Type
(Etype
(Parent_Formal
))
2675 Designated_Type
(Etype
(Actual
))
2676 and then not Is_Controlling_Formal
(Formal
)
2678 -- This unchecked conversion is not necessary unless
2679 -- inlining is enabled, because in that case the type
2680 -- mismatch may become visible in the body about to be
2684 Unchecked_Convert_To
(Etype
(Parent_Formal
),
2685 Relocate_Node
(Actual
)));
2688 Resolve
(Actual
, Etype
(Parent_Formal
));
2692 Next_Formal
(Formal
);
2693 Next_Formal
(Parent_Formal
);
2694 Next_Actual
(Actual
);
2699 Subp
:= Parent_Subp
;
2702 -- Check for violation of No_Abort_Statements
2704 if Is_RTE
(Subp
, RE_Abort_Task
) then
2705 Check_Restriction
(No_Abort_Statements
, N
);
2707 -- Check for violation of No_Dynamic_Attachment
2709 elsif RTU_Loaded
(Ada_Interrupts
)
2710 and then (Is_RTE
(Subp
, RE_Is_Reserved
) or else
2711 Is_RTE
(Subp
, RE_Is_Attached
) or else
2712 Is_RTE
(Subp
, RE_Current_Handler
) or else
2713 Is_RTE
(Subp
, RE_Attach_Handler
) or else
2714 Is_RTE
(Subp
, RE_Exchange_Handler
) or else
2715 Is_RTE
(Subp
, RE_Detach_Handler
) or else
2716 Is_RTE
(Subp
, RE_Reference
))
2718 Check_Restriction
(No_Dynamic_Attachment
, N
);
2721 -- Deal with case where call is an explicit dereference
2723 if Nkind
(Name
(N
)) = N_Explicit_Dereference
then
2725 -- Handle case of access to protected subprogram type
2727 if Is_Access_Protected_Subprogram_Type
2728 (Base_Type
(Etype
(Prefix
(Name
(N
)))))
2730 -- If this is a call through an access to protected operation,
2731 -- the prefix has the form (object'address, operation'access).
2732 -- Rewrite as a for other protected calls: the object is the
2733 -- first parameter of the list of actuals.
2740 Ptr
: constant Node_Id
:= Prefix
(Name
(N
));
2742 T
: constant Entity_Id
:=
2743 Equivalent_Type
(Base_Type
(Etype
(Ptr
)));
2745 D_T
: constant Entity_Id
:=
2746 Designated_Type
(Base_Type
(Etype
(Ptr
)));
2750 Make_Selected_Component
(Loc
,
2751 Prefix
=> Unchecked_Convert_To
(T
, Ptr
),
2753 New_Occurrence_Of
(First_Entity
(T
), Loc
));
2756 Make_Selected_Component
(Loc
,
2757 Prefix
=> Unchecked_Convert_To
(T
, Ptr
),
2759 New_Occurrence_Of
(Next_Entity
(First_Entity
(T
)), Loc
));
2762 Make_Explicit_Dereference
(Loc
,
2765 if Present
(Parameter_Associations
(N
)) then
2766 Parm
:= Parameter_Associations
(N
);
2771 Prepend
(Obj
, Parm
);
2773 if Etype
(D_T
) = Standard_Void_Type
then
2775 Make_Procedure_Call_Statement
(Loc
,
2777 Parameter_Associations
=> Parm
);
2780 Make_Function_Call
(Loc
,
2782 Parameter_Associations
=> Parm
);
2785 Set_First_Named_Actual
(Call
, First_Named_Actual
(N
));
2786 Set_Etype
(Call
, Etype
(D_T
));
2788 -- We do not re-analyze the call to avoid infinite recursion.
2789 -- We analyze separately the prefix and the object, and set
2790 -- the checks on the prefix that would otherwise be emitted
2791 -- when resolving a call.
2795 Apply_Access_Check
(Nam
);
2802 -- If this is a call to an intrinsic subprogram, then perform the
2803 -- appropriate expansion to the corresponding tree node and we
2804 -- are all done (since after that the call is gone!)
2806 -- In the case where the intrinsic is to be processed by the back end,
2807 -- the call to Expand_Intrinsic_Call will do nothing, which is fine,
2808 -- since the idea in this case is to pass the call unchanged.
2809 -- If the intrinsic is an inherited unchecked conversion, and the
2810 -- derived type is the target type of the conversion, we must retain
2811 -- it as the return type of the expression. Otherwise the expansion
2812 -- below, which uses the parent operation, will yield the wrong type.
2814 if Is_Intrinsic_Subprogram
(Subp
) then
2815 Expand_Intrinsic_Call
(N
, Subp
);
2817 if Nkind
(N
) = N_Unchecked_Type_Conversion
2818 and then Parent_Subp
/= Orig_Subp
2819 and then Etype
(Parent_Subp
) /= Etype
(Orig_Subp
)
2821 Set_Etype
(N
, Etype
(Orig_Subp
));
2827 if Ekind
(Subp
) = E_Function
2828 or else Ekind
(Subp
) = E_Procedure
2830 if Is_Inlined
(Subp
) then
2832 Inlined_Subprogram
: declare
2834 Must_Inline
: Boolean := False;
2835 Spec
: constant Node_Id
:= Unit_Declaration_Node
(Subp
);
2836 Scop
: constant Entity_Id
:= Scope
(Subp
);
2838 function In_Unfrozen_Instance
return Boolean;
2839 -- If the subprogram comes from an instance in the same
2840 -- unit, and the instance is not yet frozen, inlining might
2841 -- trigger order-of-elaboration problems in gigi.
2843 --------------------------
2844 -- In_Unfrozen_Instance --
2845 --------------------------
2847 function In_Unfrozen_Instance
return Boolean is
2853 and then S
/= Standard_Standard
2855 if Is_Generic_Instance
(S
)
2856 and then Present
(Freeze_Node
(S
))
2857 and then not Analyzed
(Freeze_Node
(S
))
2866 end In_Unfrozen_Instance
;
2868 -- Start of processing for Inlined_Subprogram
2871 -- Verify that the body to inline has already been seen, and
2872 -- that if the body is in the current unit the inlining does
2873 -- not occur earlier. This avoids order-of-elaboration problems
2876 -- This should be documented in sinfo/einfo ???
2879 or else Nkind
(Spec
) /= N_Subprogram_Declaration
2880 or else No
(Body_To_Inline
(Spec
))
2882 Must_Inline
:= False;
2884 -- If this an inherited function that returns a private
2885 -- type, do not inline if the full view is an unconstrained
2886 -- array, because such calls cannot be inlined.
2888 elsif Present
(Orig_Subp
)
2889 and then Is_Array_Type
(Etype
(Orig_Subp
))
2890 and then not Is_Constrained
(Etype
(Orig_Subp
))
2892 Must_Inline
:= False;
2894 elsif In_Unfrozen_Instance
then
2895 Must_Inline
:= False;
2898 Bod
:= Body_To_Inline
(Spec
);
2900 if (In_Extended_Main_Code_Unit
(N
)
2901 or else In_Extended_Main_Code_Unit
(Parent
(N
))
2902 or else Is_Always_Inlined
(Subp
))
2903 and then (not In_Same_Extended_Unit
(Sloc
(Bod
), Loc
)
2905 Earlier_In_Extended_Unit
(Sloc
(Bod
), Loc
))
2907 Must_Inline
:= True;
2909 -- If we are compiling a package body that is not the main
2910 -- unit, it must be for inlining/instantiation purposes,
2911 -- in which case we inline the call to insure that the same
2912 -- temporaries are generated when compiling the body by
2913 -- itself. Otherwise link errors can occur.
2915 -- If the function being called is itself in the main unit,
2916 -- we cannot inline, because there is a risk of double
2917 -- elaboration and/or circularity: the inlining can make
2918 -- visible a private entity in the body of the main unit,
2919 -- that gigi will see before its sees its proper definition.
2921 elsif not (In_Extended_Main_Code_Unit
(N
))
2922 and then In_Package_Body
2924 Must_Inline
:= not In_Extended_Main_Source_Unit
(Subp
);
2929 Expand_Inlined_Call
(N
, Subp
, Orig_Subp
);
2932 -- Let the back end handle it
2934 Add_Inlined_Body
(Subp
);
2936 if Front_End_Inlining
2937 and then Nkind
(Spec
) = N_Subprogram_Declaration
2938 and then (In_Extended_Main_Code_Unit
(N
))
2939 and then No
(Body_To_Inline
(Spec
))
2940 and then not Has_Completion
(Subp
)
2941 and then In_Same_Extended_Unit
(Sloc
(Spec
), Loc
)
2944 ("cannot inline& (body not seen yet)?",
2948 end Inlined_Subprogram
;
2952 -- Check for a protected subprogram. This is either an intra-object
2953 -- call, or a protected function call. Protected procedure calls are
2954 -- rewritten as entry calls and handled accordingly.
2956 -- In Ada 2005, this may be an indirect call to an access parameter
2957 -- that is an access_to_subprogram. In that case the anonymous type
2958 -- has a scope that is a protected operation, but the call is a
2961 Scop
:= Scope
(Subp
);
2963 if Nkind
(N
) /= N_Entry_Call_Statement
2964 and then Is_Protected_Type
(Scop
)
2965 and then Ekind
(Subp
) /= E_Subprogram_Type
2967 -- If the call is an internal one, it is rewritten as a call to
2968 -- to the corresponding unprotected subprogram.
2970 Expand_Protected_Subprogram_Call
(N
, Subp
, Scop
);
2973 -- Functions returning controlled objects need special attention
2974 -- If the return type is limited the context is an initialization
2975 -- and different processing applies.
2977 if Controlled_Type
(Etype
(Subp
))
2978 and then not Is_Inherently_Limited_Type
(Etype
(Subp
))
2979 and then not Is_Limited_Interface
(Etype
(Subp
))
2981 Expand_Ctrl_Function_Call
(N
);
2984 -- Test for First_Optional_Parameter, and if so, truncate parameter
2985 -- list if there are optional parameters at the trailing end.
2986 -- Note we never delete procedures for call via a pointer.
2988 if (Ekind
(Subp
) = E_Procedure
or else Ekind
(Subp
) = E_Function
)
2989 and then Present
(First_Optional_Parameter
(Subp
))
2992 Last_Keep_Arg
: Node_Id
;
2995 -- Last_Keep_Arg will hold the last actual that should be
2996 -- retained. If it remains empty at the end, it means that
2997 -- all parameters are optional.
2999 Last_Keep_Arg
:= Empty
;
3001 -- Find first optional parameter, must be present since we
3002 -- checked the validity of the parameter before setting it.
3004 Formal
:= First_Formal
(Subp
);
3005 Actual
:= First_Actual
(N
);
3006 while Formal
/= First_Optional_Parameter
(Subp
) loop
3007 Last_Keep_Arg
:= Actual
;
3008 Next_Formal
(Formal
);
3009 Next_Actual
(Actual
);
3012 -- We have Formal and Actual pointing to the first potentially
3013 -- droppable argument. We can drop all the trailing arguments
3014 -- whose actual matches the default. Note that we know that all
3015 -- remaining formals have defaults, because we checked that this
3016 -- requirement was met before setting First_Optional_Parameter.
3018 -- We use Fully_Conformant_Expressions to check for identity
3019 -- between formals and actuals, which may miss some cases, but
3020 -- on the other hand, this is only an optimization (if we fail
3021 -- to truncate a parameter it does not affect functionality).
3022 -- So if the default is 3 and the actual is 1+2, we consider
3023 -- them unequal, which hardly seems worrisome.
3025 while Present
(Formal
) loop
3026 if not Fully_Conformant_Expressions
3027 (Actual
, Default_Value
(Formal
))
3029 Last_Keep_Arg
:= Actual
;
3032 Next_Formal
(Formal
);
3033 Next_Actual
(Actual
);
3036 -- If no arguments, delete entire list, this is the easy case
3038 if No
(Last_Keep_Arg
) then
3039 while Is_Non_Empty_List
(Parameter_Associations
(N
)) loop
3040 Delete_Tree
(Remove_Head
(Parameter_Associations
(N
)));
3043 Set_Parameter_Associations
(N
, No_List
);
3044 Set_First_Named_Actual
(N
, Empty
);
3046 -- Case where at the last retained argument is positional. This
3047 -- is also an easy case, since the retained arguments are already
3048 -- in the right form, and we don't need to worry about the order
3049 -- of arguments that get eliminated.
3051 elsif Is_List_Member
(Last_Keep_Arg
) then
3052 while Present
(Next
(Last_Keep_Arg
)) loop
3053 Delete_Tree
(Remove_Next
(Last_Keep_Arg
));
3056 Set_First_Named_Actual
(N
, Empty
);
3058 -- This is the annoying case where the last retained argument
3059 -- is a named parameter. Since the original arguments are not
3060 -- in declaration order, we may have to delete some fairly
3061 -- random collection of arguments.
3069 -- First step, remove all the named parameters from the
3070 -- list (they are still chained using First_Named_Actual
3071 -- and Next_Named_Actual, so we have not lost them!)
3073 Temp
:= First
(Parameter_Associations
(N
));
3075 -- Case of all parameters named, remove them all
3077 if Nkind
(Temp
) = N_Parameter_Association
then
3078 while Is_Non_Empty_List
(Parameter_Associations
(N
)) loop
3079 Temp
:= Remove_Head
(Parameter_Associations
(N
));
3082 -- Case of mixed positional/named, remove named parameters
3085 while Nkind
(Next
(Temp
)) /= N_Parameter_Association
loop
3089 while Present
(Next
(Temp
)) loop
3090 Remove
(Next
(Temp
));
3094 -- Now we loop through the named parameters, till we get
3095 -- to the last one to be retained, adding them to the list.
3096 -- Note that the Next_Named_Actual list does not need to be
3097 -- touched since we are only reordering them on the actual
3098 -- parameter association list.
3100 Passoc
:= Parent
(First_Named_Actual
(N
));
3102 Temp
:= Relocate_Node
(Passoc
);
3104 (Parameter_Associations
(N
), Temp
);
3106 Last_Keep_Arg
= Explicit_Actual_Parameter
(Passoc
);
3107 Passoc
:= Parent
(Next_Named_Actual
(Passoc
));
3110 Set_Next_Named_Actual
(Temp
, Empty
);
3113 Temp
:= Next_Named_Actual
(Passoc
);
3114 exit when No
(Temp
);
3115 Set_Next_Named_Actual
3116 (Passoc
, Next_Named_Actual
(Parent
(Temp
)));
3124 -- Special processing for Ada 2005 AI-329, which requires a call to
3125 -- Raise_Exception to raise Constraint_Error if the Exception_Id is
3126 -- null. Note that we never need to do this in GNAT mode, or if the
3127 -- parameter to Raise_Exception is a use of Identity, since in these
3128 -- cases we know that the parameter is never null.
3130 -- Note: We must check that the node has not been inlined. This is
3131 -- required because under zfp the Raise_Exception subprogram has the
3132 -- pragma inline_always (and hence the call has been expanded above
3133 -- into a block containing the code of the subprogram).
3135 if Ada_Version
>= Ada_05
3136 and then not GNAT_Mode
3137 and then Is_RTE
(Subp
, RE_Raise_Exception
)
3138 and then Nkind
(N
) = N_Procedure_Call_Statement
3139 and then (Nkind
(First_Actual
(N
)) /= N_Attribute_Reference
3140 or else Attribute_Name
(First_Actual
(N
)) /= Name_Identity
)
3143 RCE
: constant Node_Id
:=
3144 Make_Raise_Constraint_Error
(Loc
,
3145 Reason
=> CE_Null_Exception_Id
);
3147 Insert_After
(N
, RCE
);
3153 --------------------------
3154 -- Expand_Inlined_Call --
3155 --------------------------
3157 procedure Expand_Inlined_Call
3160 Orig_Subp
: Entity_Id
)
3162 Loc
: constant Source_Ptr
:= Sloc
(N
);
3163 Is_Predef
: constant Boolean :=
3164 Is_Predefined_File_Name
3165 (Unit_File_Name
(Get_Source_Unit
(Subp
)));
3166 Orig_Bod
: constant Node_Id
:=
3167 Body_To_Inline
(Unit_Declaration_Node
(Subp
));
3172 Decls
: constant List_Id
:= New_List
;
3173 Exit_Lab
: Entity_Id
:= Empty
;
3180 Ret_Type
: Entity_Id
;
3184 Temp_Typ
: Entity_Id
;
3186 Is_Unc
: constant Boolean :=
3187 Is_Array_Type
(Etype
(Subp
))
3188 and then not Is_Constrained
(Etype
(Subp
));
3189 -- If the type returned by the function is unconstrained and the
3190 -- call can be inlined, special processing is required.
3192 function Is_Null_Procedure
return Boolean;
3193 -- Predicate to recognize stubbed procedures and null procedures, for
3194 -- which there is no need for the full inlining mechanism.
3196 procedure Make_Exit_Label
;
3197 -- Build declaration for exit label to be used in Return statements
3199 function Process_Formals
(N
: Node_Id
) return Traverse_Result
;
3200 -- Replace occurrence of a formal with the corresponding actual, or
3201 -- the thunk generated for it.
3203 function Process_Sloc
(Nod
: Node_Id
) return Traverse_Result
;
3204 -- If the call being expanded is that of an internal subprogram,
3205 -- set the sloc of the generated block to that of the call itself,
3206 -- so that the expansion is skipped by the -next- command in gdb.
3207 -- Same processing for a subprogram in a predefined file, e.g.
3208 -- Ada.Tags. If Debug_Generated_Code is true, suppress this change
3209 -- to simplify our own development.
3211 procedure Rewrite_Function_Call
(N
: Node_Id
; Blk
: Node_Id
);
3212 -- If the function body is a single expression, replace call with
3213 -- expression, else insert block appropriately.
3215 procedure Rewrite_Procedure_Call
(N
: Node_Id
; Blk
: Node_Id
);
3216 -- If procedure body has no local variables, inline body without
3217 -- creating block, otherwise rewrite call with block.
3219 function Formal_Is_Used_Once
(Formal
: Entity_Id
) return Boolean;
3220 -- Determine whether a formal parameter is used only once in Orig_Bod
3222 -----------------------
3223 -- Is_Null_Procedure --
3224 -----------------------
3226 function Is_Null_Procedure
return Boolean is
3227 Decl
: constant Node_Id
:= Unit_Declaration_Node
(Subp
);
3230 if Ekind
(Subp
) /= E_Procedure
then
3233 elsif Nkind
(Orig_Bod
) /= N_Subprogram_Body
then
3236 -- Check if this is an Ada 2005 null procedure
3238 elsif Nkind
(Decl
) = N_Subprogram_Declaration
3239 and then Null_Present
(Specification
(Decl
))
3243 -- Check if the body contains only a null statement, followed by the
3244 -- return statement added during expansion.
3248 Stat
: constant Node_Id
:=
3250 (Statements
(Handled_Statement_Sequence
(Orig_Bod
)));
3252 Stat2
: constant Node_Id
:= Next
(Stat
);
3256 Nkind
(Stat
) = N_Null_Statement
3260 (Nkind
(Stat2
) = N_Simple_Return_Statement
3261 and then No
(Next
(Stat2
))));
3264 end Is_Null_Procedure
;
3266 ---------------------
3267 -- Make_Exit_Label --
3268 ---------------------
3270 procedure Make_Exit_Label
is
3272 -- Create exit label for subprogram if one does not exist yet
3274 if No
(Exit_Lab
) then
3276 Make_Identifier
(Loc
,
3277 Chars
=> New_Internal_Name
('L'));
3279 Make_Defining_Identifier
(Loc
, Chars
(Lab_Id
)));
3280 Exit_Lab
:= Make_Label
(Loc
, Lab_Id
);
3283 Make_Implicit_Label_Declaration
(Loc
,
3284 Defining_Identifier
=> Entity
(Lab_Id
),
3285 Label_Construct
=> Exit_Lab
);
3287 end Make_Exit_Label
;
3289 ---------------------
3290 -- Process_Formals --
3291 ---------------------
3293 function Process_Formals
(N
: Node_Id
) return Traverse_Result
is
3299 if Is_Entity_Name
(N
)
3300 and then Present
(Entity
(N
))
3305 and then Scope
(E
) = Subp
3307 A
:= Renamed_Object
(E
);
3309 -- Rewrite the occurrence of the formal into an occurrence of
3310 -- the actual. Also establish visibility on the proper view of
3311 -- the actual's subtype for the body's context (if the actual's
3312 -- subtype is private at the call point but its full view is
3313 -- visible to the body, then the inlined tree here must be
3314 -- analyzed with the full view).
3316 if Is_Entity_Name
(A
) then
3317 Rewrite
(N
, New_Occurrence_Of
(Entity
(A
), Loc
));
3318 Check_Private_View
(N
);
3320 elsif Nkind
(A
) = N_Defining_Identifier
then
3321 Rewrite
(N
, New_Occurrence_Of
(A
, Loc
));
3322 Check_Private_View
(N
);
3327 Rewrite
(N
, New_Copy
(A
));
3333 elsif Nkind
(N
) = N_Simple_Return_Statement
then
3334 if No
(Expression
(N
)) then
3337 Make_Goto_Statement
(Loc
,
3338 Name
=> New_Copy
(Lab_Id
)));
3341 if Nkind
(Parent
(N
)) = N_Handled_Sequence_Of_Statements
3342 and then Nkind
(Parent
(Parent
(N
))) = N_Subprogram_Body
3344 -- Function body is a single expression. No need for
3350 Num_Ret
:= Num_Ret
+ 1;
3354 -- Because of the presence of private types, the views of the
3355 -- expression and the context may be different, so place an
3356 -- unchecked conversion to the context type to avoid spurious
3357 -- errors, eg. when the expression is a numeric literal and
3358 -- the context is private. If the expression is an aggregate,
3359 -- use a qualified expression, because an aggregate is not a
3360 -- legal argument of a conversion.
3362 if Nkind
(Expression
(N
)) = N_Aggregate
3363 or else Nkind
(Expression
(N
)) = N_Null
3366 Make_Qualified_Expression
(Sloc
(N
),
3367 Subtype_Mark
=> New_Occurrence_Of
(Ret_Type
, Sloc
(N
)),
3368 Expression
=> Relocate_Node
(Expression
(N
)));
3371 Unchecked_Convert_To
3372 (Ret_Type
, Relocate_Node
(Expression
(N
)));
3375 if Nkind
(Targ
) = N_Defining_Identifier
then
3377 Make_Assignment_Statement
(Loc
,
3378 Name
=> New_Occurrence_Of
(Targ
, Loc
),
3379 Expression
=> Ret
));
3382 Make_Assignment_Statement
(Loc
,
3383 Name
=> New_Copy
(Targ
),
3384 Expression
=> Ret
));
3387 Set_Assignment_OK
(Name
(N
));
3389 if Present
(Exit_Lab
) then
3391 Make_Goto_Statement
(Loc
,
3392 Name
=> New_Copy
(Lab_Id
)));
3398 -- Remove pragma Unreferenced since it may refer to formals that
3399 -- are not visible in the inlined body, and in any case we will
3400 -- not be posting warnings on the inlined body so it is unneeded.
3402 elsif Nkind
(N
) = N_Pragma
3403 and then Chars
(N
) = Name_Unreferenced
3405 Rewrite
(N
, Make_Null_Statement
(Sloc
(N
)));
3411 end Process_Formals
;
3413 procedure Replace_Formals
is new Traverse_Proc
(Process_Formals
);
3419 function Process_Sloc
(Nod
: Node_Id
) return Traverse_Result
is
3421 if not Debug_Generated_Code
then
3422 Set_Sloc
(Nod
, Sloc
(N
));
3423 Set_Comes_From_Source
(Nod
, False);
3429 procedure Reset_Slocs
is new Traverse_Proc
(Process_Sloc
);
3431 ---------------------------
3432 -- Rewrite_Function_Call --
3433 ---------------------------
3435 procedure Rewrite_Function_Call
(N
: Node_Id
; Blk
: Node_Id
) is
3436 HSS
: constant Node_Id
:= Handled_Statement_Sequence
(Blk
);
3437 Fst
: constant Node_Id
:= First
(Statements
(HSS
));
3440 -- Optimize simple case: function body is a single return statement,
3441 -- which has been expanded into an assignment.
3443 if Is_Empty_List
(Declarations
(Blk
))
3444 and then Nkind
(Fst
) = N_Assignment_Statement
3445 and then No
(Next
(Fst
))
3448 -- The function call may have been rewritten as the temporary
3449 -- that holds the result of the call, in which case remove the
3450 -- now useless declaration.
3452 if Nkind
(N
) = N_Identifier
3453 and then Nkind
(Parent
(Entity
(N
))) = N_Object_Declaration
3455 Rewrite
(Parent
(Entity
(N
)), Make_Null_Statement
(Loc
));
3458 Rewrite
(N
, Expression
(Fst
));
3460 elsif Nkind
(N
) = N_Identifier
3461 and then Nkind
(Parent
(Entity
(N
))) = N_Object_Declaration
3463 -- The block assigns the result of the call to the temporary
3465 Insert_After
(Parent
(Entity
(N
)), Blk
);
3467 elsif Nkind
(Parent
(N
)) = N_Assignment_Statement
3469 (Is_Entity_Name
(Name
(Parent
(N
)))
3471 (Nkind
(Name
(Parent
(N
))) = N_Explicit_Dereference
3472 and then Is_Entity_Name
(Prefix
(Name
(Parent
(N
))))))
3474 -- Replace assignment with the block
3477 Original_Assignment
: constant Node_Id
:= Parent
(N
);
3480 -- Preserve the original assignment node to keep the complete
3481 -- assignment subtree consistent enough for Analyze_Assignment
3482 -- to proceed (specifically, the original Lhs node must still
3483 -- have an assignment statement as its parent).
3485 -- We cannot rely on Original_Node to go back from the block
3486 -- node to the assignment node, because the assignment might
3487 -- already be a rewrite substitution.
3489 Discard_Node
(Relocate_Node
(Original_Assignment
));
3490 Rewrite
(Original_Assignment
, Blk
);
3493 elsif Nkind
(Parent
(N
)) = N_Object_Declaration
then
3494 Set_Expression
(Parent
(N
), Empty
);
3495 Insert_After
(Parent
(N
), Blk
);
3498 Insert_Before
(Parent
(N
), Blk
);
3500 end Rewrite_Function_Call
;
3502 ----------------------------
3503 -- Rewrite_Procedure_Call --
3504 ----------------------------
3506 procedure Rewrite_Procedure_Call
(N
: Node_Id
; Blk
: Node_Id
) is
3507 HSS
: constant Node_Id
:= Handled_Statement_Sequence
(Blk
);
3509 -- If there is a transient scope for N, this will be the scope of the
3510 -- actions for N, and the statements in Blk need to be within this
3511 -- scope. For example, they need to have visibility on the constant
3512 -- declarations created for the formals.
3514 -- If N needs no transient scope, and if there are no declarations in
3515 -- the inlined body, we can do a little optimization and insert the
3516 -- statements for the body directly after N, and rewrite N to a
3517 -- null statement, instead of rewriting N into a full-blown block
3520 if not Scope_Is_Transient
3521 and then Is_Empty_List
(Declarations
(Blk
))
3523 Insert_List_After
(N
, Statements
(HSS
));
3524 Rewrite
(N
, Make_Null_Statement
(Loc
));
3528 end Rewrite_Procedure_Call
;
3530 -------------------------
3531 -- Formal_Is_Used_Once --
3532 -------------------------
3534 function Formal_Is_Used_Once
(Formal
: Entity_Id
) return Boolean is
3535 Use_Counter
: Int
:= 0;
3537 function Count_Uses
(N
: Node_Id
) return Traverse_Result
;
3538 -- Traverse the tree and count the uses of the formal parameter.
3539 -- In this case, for optimization purposes, we do not need to
3540 -- continue the traversal once more than one use is encountered.
3546 function Count_Uses
(N
: Node_Id
) return Traverse_Result
is
3548 -- The original node is an identifier
3550 if Nkind
(N
) = N_Identifier
3551 and then Present
(Entity
(N
))
3553 -- Original node's entity points to the one in the copied body
3555 and then Nkind
(Entity
(N
)) = N_Identifier
3556 and then Present
(Entity
(Entity
(N
)))
3558 -- The entity of the copied node is the formal parameter
3560 and then Entity
(Entity
(N
)) = Formal
3562 Use_Counter
:= Use_Counter
+ 1;
3564 if Use_Counter
> 1 then
3566 -- Denote more than one use and abandon the traversal
3577 procedure Count_Formal_Uses
is new Traverse_Proc
(Count_Uses
);
3579 -- Start of processing for Formal_Is_Used_Once
3582 Count_Formal_Uses
(Orig_Bod
);
3583 return Use_Counter
= 1;
3584 end Formal_Is_Used_Once
;
3586 -- Start of processing for Expand_Inlined_Call
3589 -- Check for special case of To_Address call, and if so, just do an
3590 -- unchecked conversion instead of expanding the call. Not only is this
3591 -- more efficient, but it also avoids problem with order of elaboration
3592 -- when address clauses are inlined (address expression elaborated at
3595 if Subp
= RTE
(RE_To_Address
) then
3597 Unchecked_Convert_To
3599 Relocate_Node
(First_Actual
(N
))));
3602 elsif Is_Null_Procedure
then
3603 Rewrite
(N
, Make_Null_Statement
(Loc
));
3607 -- Check for an illegal attempt to inline a recursive procedure. If the
3608 -- subprogram has parameters this is detected when trying to supply a
3609 -- binding for parameters that already have one. For parameterless
3610 -- subprograms this must be done explicitly.
3612 if In_Open_Scopes
(Subp
) then
3613 Error_Msg_N
("call to recursive subprogram cannot be inlined?", N
);
3614 Set_Is_Inlined
(Subp
, False);
3618 if Nkind
(Orig_Bod
) = N_Defining_Identifier
3619 or else Nkind
(Orig_Bod
) = N_Defining_Operator_Symbol
3621 -- Subprogram is a renaming_as_body. Calls appearing after the
3622 -- renaming can be replaced with calls to the renamed entity
3623 -- directly, because the subprograms are subtype conformant. If
3624 -- the renamed subprogram is an inherited operation, we must redo
3625 -- the expansion because implicit conversions may be needed.
3627 Set_Name
(N
, New_Occurrence_Of
(Orig_Bod
, Loc
));
3629 if Present
(Alias
(Orig_Bod
)) then
3636 -- Use generic machinery to copy body of inlined subprogram, as if it
3637 -- were an instantiation, resetting source locations appropriately, so
3638 -- that nested inlined calls appear in the main unit.
3640 Save_Env
(Subp
, Empty
);
3641 Set_Copied_Sloc_For_Inlined_Body
(N
, Defining_Entity
(Orig_Bod
));
3643 Bod
:= Copy_Generic_Node
(Orig_Bod
, Empty
, Instantiating
=> True);
3645 Make_Block_Statement
(Loc
,
3646 Declarations
=> Declarations
(Bod
),
3647 Handled_Statement_Sequence
=> Handled_Statement_Sequence
(Bod
));
3649 if No
(Declarations
(Bod
)) then
3650 Set_Declarations
(Blk
, New_List
);
3653 -- For the unconstrained case, capture the name of the local
3654 -- variable that holds the result. This must be the first declaration
3655 -- in the block, because its bounds cannot depend on local variables.
3656 -- Otherwise there is no way to declare the result outside of the
3657 -- block. Needless to say, in general the bounds will depend on the
3658 -- actuals in the call.
3661 Targ1
:= Defining_Identifier
(First
(Declarations
(Blk
)));
3664 -- If this is a derived function, establish the proper return type
3666 if Present
(Orig_Subp
)
3667 and then Orig_Subp
/= Subp
3669 Ret_Type
:= Etype
(Orig_Subp
);
3671 Ret_Type
:= Etype
(Subp
);
3674 -- Create temporaries for the actuals that are expressions, or that
3675 -- are scalars and require copying to preserve semantics.
3677 F
:= First_Formal
(Subp
);
3678 A
:= First_Actual
(N
);
3679 while Present
(F
) loop
3680 if Present
(Renamed_Object
(F
)) then
3681 Error_Msg_N
("cannot inline call to recursive subprogram", N
);
3685 -- If the argument may be a controlling argument in a call within
3686 -- the inlined body, we must preserve its classwide nature to insure
3687 -- that dynamic dispatching take place subsequently. If the formal
3688 -- has a constraint it must be preserved to retain the semantics of
3691 if Is_Class_Wide_Type
(Etype
(F
))
3692 or else (Is_Access_Type
(Etype
(F
))
3694 Is_Class_Wide_Type
(Designated_Type
(Etype
(F
))))
3696 Temp_Typ
:= Etype
(F
);
3698 elsif Base_Type
(Etype
(F
)) = Base_Type
(Etype
(A
))
3699 and then Etype
(F
) /= Base_Type
(Etype
(F
))
3701 Temp_Typ
:= Etype
(F
);
3704 Temp_Typ
:= Etype
(A
);
3707 -- If the actual is a simple name or a literal, no need to
3708 -- create a temporary, object can be used directly.
3710 -- If the actual is a literal and the formal has its address taken,
3711 -- we cannot pass the literal itself as an argument, so its value
3712 -- must be captured in a temporary.
3714 if (Is_Entity_Name
(A
)
3716 (not Is_Scalar_Type
(Etype
(A
))
3717 or else Ekind
(Entity
(A
)) = E_Enumeration_Literal
))
3719 -- When the actual is an identifier and the corresponding formal
3720 -- is used only once in the original body, the formal can be
3721 -- substituted directly with the actual parameter.
3723 or else (Nkind
(A
) = N_Identifier
3724 and then Formal_Is_Used_Once
(F
))
3727 ((Nkind
(A
) = N_Real_Literal
or else
3728 Nkind
(A
) = N_Integer_Literal
or else
3729 Nkind
(A
) = N_Character_Literal
)
3730 and then not Address_Taken
(F
))
3732 if Etype
(F
) /= Etype
(A
) then
3734 (F
, Unchecked_Convert_To
(Etype
(F
), Relocate_Node
(A
)));
3736 Set_Renamed_Object
(F
, A
);
3741 Make_Defining_Identifier
(Loc
,
3742 Chars
=> New_Internal_Name
('C'));
3744 -- If the actual for an in/in-out parameter is a view conversion,
3745 -- make it into an unchecked conversion, given that an untagged
3746 -- type conversion is not a proper object for a renaming.
3748 -- In-out conversions that involve real conversions have already
3749 -- been transformed in Expand_Actuals.
3751 if Nkind
(A
) = N_Type_Conversion
3752 and then Ekind
(F
) /= E_In_Parameter
3755 Make_Unchecked_Type_Conversion
(Loc
,
3756 Subtype_Mark
=> New_Occurrence_Of
(Etype
(F
), Loc
),
3757 Expression
=> Relocate_Node
(Expression
(A
)));
3759 elsif Etype
(F
) /= Etype
(A
) then
3760 New_A
:= Unchecked_Convert_To
(Etype
(F
), Relocate_Node
(A
));
3761 Temp_Typ
:= Etype
(F
);
3764 New_A
:= Relocate_Node
(A
);
3767 Set_Sloc
(New_A
, Sloc
(N
));
3769 -- If the actual has a by-reference type, it cannot be copied, so
3770 -- its value is captured in a renaming declaration. Otherwise
3771 -- declare a local constant initialized with the actual.
3773 if Ekind
(F
) = E_In_Parameter
3774 and then not Is_Limited_Type
(Etype
(A
))
3775 and then not Is_Tagged_Type
(Etype
(A
))
3778 Make_Object_Declaration
(Loc
,
3779 Defining_Identifier
=> Temp
,
3780 Constant_Present
=> True,
3781 Object_Definition
=> New_Occurrence_Of
(Temp_Typ
, Loc
),
3782 Expression
=> New_A
);
3785 Make_Object_Renaming_Declaration
(Loc
,
3786 Defining_Identifier
=> Temp
,
3787 Subtype_Mark
=> New_Occurrence_Of
(Temp_Typ
, Loc
),
3791 Append
(Decl
, Decls
);
3792 Set_Renamed_Object
(F
, Temp
);
3799 -- Establish target of function call. If context is not assignment or
3800 -- declaration, create a temporary as a target. The declaration for
3801 -- the temporary may be subsequently optimized away if the body is a
3802 -- single expression, or if the left-hand side of the assignment is
3803 -- simple enough, i.e. an entity or an explicit dereference of one.
3805 if Ekind
(Subp
) = E_Function
then
3806 if Nkind
(Parent
(N
)) = N_Assignment_Statement
3807 and then Is_Entity_Name
(Name
(Parent
(N
)))
3809 Targ
:= Name
(Parent
(N
));
3811 elsif Nkind
(Parent
(N
)) = N_Assignment_Statement
3812 and then Nkind
(Name
(Parent
(N
))) = N_Explicit_Dereference
3813 and then Is_Entity_Name
(Prefix
(Name
(Parent
(N
))))
3815 Targ
:= Name
(Parent
(N
));
3818 -- Replace call with temporary and create its declaration
3821 Make_Defining_Identifier
(Loc
, New_Internal_Name
('C'));
3822 Set_Is_Internal
(Temp
);
3824 -- For the unconstrained case. the generated temporary has the
3825 -- same constrained declaration as the result variable.
3826 -- It may eventually be possible to remove that temporary and
3827 -- use the result variable directly.
3831 Make_Object_Declaration
(Loc
,
3832 Defining_Identifier
=> Temp
,
3833 Object_Definition
=>
3834 New_Copy_Tree
(Object_Definition
(Parent
(Targ1
))));
3836 Replace_Formals
(Decl
);
3840 Make_Object_Declaration
(Loc
,
3841 Defining_Identifier
=> Temp
,
3842 Object_Definition
=>
3843 New_Occurrence_Of
(Ret_Type
, Loc
));
3845 Set_Etype
(Temp
, Ret_Type
);
3848 Set_No_Initialization
(Decl
);
3849 Append
(Decl
, Decls
);
3850 Rewrite
(N
, New_Occurrence_Of
(Temp
, Loc
));
3855 Insert_Actions
(N
, Decls
);
3857 -- Traverse the tree and replace formals with actuals or their thunks.
3858 -- Attach block to tree before analysis and rewriting.
3860 Replace_Formals
(Blk
);
3861 Set_Parent
(Blk
, N
);
3863 if not Comes_From_Source
(Subp
)
3869 if Present
(Exit_Lab
) then
3871 -- If the body was a single expression, the single return statement
3872 -- and the corresponding label are useless.
3876 Nkind
(Last
(Statements
(Handled_Statement_Sequence
(Blk
)))) =
3879 Remove
(Last
(Statements
(Handled_Statement_Sequence
(Blk
))));
3881 Append
(Lab_Decl
, (Declarations
(Blk
)));
3882 Append
(Exit_Lab
, Statements
(Handled_Statement_Sequence
(Blk
)));
3886 -- Analyze Blk with In_Inlined_Body set, to avoid spurious errors on
3887 -- conflicting private views that Gigi would ignore. If this is
3888 -- predefined unit, analyze with checks off, as is done in the non-
3889 -- inlined run-time units.
3892 I_Flag
: constant Boolean := In_Inlined_Body
;
3895 In_Inlined_Body
:= True;
3899 Style
: constant Boolean := Style_Check
;
3901 Style_Check
:= False;
3902 Analyze
(Blk
, Suppress
=> All_Checks
);
3903 Style_Check
:= Style
;
3910 In_Inlined_Body
:= I_Flag
;
3913 if Ekind
(Subp
) = E_Procedure
then
3914 Rewrite_Procedure_Call
(N
, Blk
);
3916 Rewrite_Function_Call
(N
, Blk
);
3918 -- For the unconstrained case, the replacement of the call has been
3919 -- made prior to the complete analysis of the generated declarations.
3920 -- Propagate the proper type now.
3923 if Nkind
(N
) = N_Identifier
then
3924 Set_Etype
(N
, Etype
(Entity
(N
)));
3926 Set_Etype
(N
, Etype
(Targ1
));
3933 -- Cleanup mapping between formals and actuals for other expansions
3935 F
:= First_Formal
(Subp
);
3936 while Present
(F
) loop
3937 Set_Renamed_Object
(F
, Empty
);
3940 end Expand_Inlined_Call
;
3942 ----------------------------
3943 -- Expand_N_Function_Call --
3944 ----------------------------
3946 procedure Expand_N_Function_Call
(N
: Node_Id
) is
3947 Typ
: constant Entity_Id
:= Etype
(N
);
3949 function Returned_By_Reference
return Boolean;
3950 -- If the return type is returned through the secondary stack; that is
3951 -- by reference, we don't want to create a temp to force stack checking.
3952 -- ???"sec stack" is not right -- Ada 95 return-by-reference object are
3953 -- returned wherever they are.
3954 -- Shouldn't this function be moved to exp_util???
3956 function Rhs_Of_Assign_Or_Decl
(N
: Node_Id
) return Boolean;
3957 -- If the call is the right side of an assignment or the expression in
3958 -- an object declaration, we don't need to create a temp as the left
3959 -- side will already trigger stack checking if necessary.
3961 -- If the call is a component in an extension aggregate, it will be
3962 -- expanded into assignments as well, so no temporary is needed. This
3963 -- also solves the problem of functions returning types with unknown
3964 -- discriminants, where it is not possible to declare an object of the
3967 ---------------------------
3968 -- Returned_By_Reference --
3969 ---------------------------
3971 function Returned_By_Reference
return Boolean is
3975 if Is_Inherently_Limited_Type
(Typ
) then
3978 elsif Nkind
(Parent
(N
)) /= N_Simple_Return_Statement
then
3981 elsif Requires_Transient_Scope
(Typ
) then
3983 -- Verify that the return type of the enclosing function has the
3984 -- same constrained status as that of the expression.
3987 while Ekind
(S
) /= E_Function
loop
3991 return Is_Constrained
(Typ
) = Is_Constrained
(Etype
(S
));
3995 end Returned_By_Reference
;
3997 ---------------------------
3998 -- Rhs_Of_Assign_Or_Decl --
3999 ---------------------------
4001 function Rhs_Of_Assign_Or_Decl
(N
: Node_Id
) return Boolean is
4003 if (Nkind
(Parent
(N
)) = N_Assignment_Statement
4004 and then Expression
(Parent
(N
)) = N
)
4006 (Nkind
(Parent
(N
)) = N_Qualified_Expression
4007 and then Nkind
(Parent
(Parent
(N
))) = N_Assignment_Statement
4008 and then Expression
(Parent
(Parent
(N
))) = Parent
(N
))
4010 (Nkind
(Parent
(N
)) = N_Object_Declaration
4011 and then Expression
(Parent
(N
)) = N
)
4013 (Nkind
(Parent
(N
)) = N_Component_Association
4014 and then Expression
(Parent
(N
)) = N
4015 and then Nkind
(Parent
(Parent
(N
))) = N_Aggregate
4016 and then Rhs_Of_Assign_Or_Decl
(Parent
(Parent
(N
))))
4018 (Nkind
(Parent
(N
)) = N_Extension_Aggregate
4019 and then Is_Private_Type
(Etype
(Typ
)))
4025 end Rhs_Of_Assign_Or_Decl
;
4027 -- Start of processing for Expand_N_Function_Call
4030 -- A special check. If stack checking is enabled, and the return type
4031 -- might generate a large temporary, and the call is not the right side
4032 -- of an assignment, then generate an explicit temporary. We do this
4033 -- because otherwise gigi may generate a large temporary on the fly and
4034 -- this can cause trouble with stack checking.
4036 -- This is unnecessary if the call is the expression in an object
4037 -- declaration, or if it appears outside of any library unit. This can
4038 -- only happen if it appears as an actual in a library-level instance,
4039 -- in which case a temporary will be generated for it once the instance
4040 -- itself is installed.
4042 if May_Generate_Large_Temp
(Typ
)
4043 and then not Rhs_Of_Assign_Or_Decl
(N
)
4044 and then not Returned_By_Reference
4045 and then Current_Scope
/= Standard_Standard
4047 if Stack_Checking_Enabled
then
4049 -- Note: it might be thought that it would be OK to use a call to
4050 -- Force_Evaluation here, but that's not good enough, because
4051 -- that can results in a 'Reference construct that may still need
4055 Loc
: constant Source_Ptr
:= Sloc
(N
);
4056 Temp_Obj
: constant Entity_Id
:=
4057 Make_Defining_Identifier
(Loc
,
4058 Chars
=> New_Internal_Name
('F'));
4059 Temp_Typ
: Entity_Id
:= Typ
;
4066 if Is_Tagged_Type
(Typ
)
4067 and then Present
(Controlling_Argument
(N
))
4069 if Nkind
(Parent
(N
)) /= N_Procedure_Call_Statement
4070 and then Nkind
(Parent
(N
)) /= N_Function_Call
4072 -- If this is a tag-indeterminate call, the object must
4075 if Is_Tag_Indeterminate
(N
) then
4076 Temp_Typ
:= Class_Wide_Type
(Typ
);
4080 -- If this is a dispatching call that is itself the
4081 -- controlling argument of an enclosing call, the
4082 -- nominal subtype of the object that replaces it must
4083 -- be classwide, so that dispatching will take place
4084 -- properly. If it is not a controlling argument, the
4085 -- object is not classwide.
4087 Proc
:= Entity
(Name
(Parent
(N
)));
4089 F
:= First_Formal
(Proc
);
4090 A
:= First_Actual
(Parent
(N
));
4096 if Is_Controlling_Formal
(F
) then
4097 Temp_Typ
:= Class_Wide_Type
(Typ
);
4103 Make_Object_Declaration
(Loc
,
4104 Defining_Identifier
=> Temp_Obj
,
4105 Object_Definition
=> New_Occurrence_Of
(Temp_Typ
, Loc
),
4106 Constant_Present
=> True,
4107 Expression
=> Relocate_Node
(N
));
4108 Set_Assignment_OK
(Decl
);
4110 Insert_Actions
(N
, New_List
(Decl
));
4111 Rewrite
(N
, New_Occurrence_Of
(Temp_Obj
, Loc
));
4115 -- If stack-checking is not enabled, increment serial number
4116 -- for internal names, so that subsequent symbols are consistent
4117 -- with and without stack-checking.
4119 Synchronize_Serial_Number
;
4121 -- Now we can expand the call with consistent symbol names
4126 -- Normal case, expand the call
4131 end Expand_N_Function_Call
;
4133 ---------------------------------------
4134 -- Expand_N_Procedure_Call_Statement --
4135 ---------------------------------------
4137 procedure Expand_N_Procedure_Call_Statement
(N
: Node_Id
) is
4140 end Expand_N_Procedure_Call_Statement
;
4142 ------------------------------
4143 -- Expand_N_Subprogram_Body --
4144 ------------------------------
4146 -- Add poll call if ATC polling is enabled, unless the body will be
4147 -- inlined by the back-end.
4149 -- Add dummy push/pop label nodes at start and end to clear any local
4150 -- exception indications if local-exception-to-goto optimization active.
4152 -- Add return statement if last statement in body is not a return statement
4153 -- (this makes things easier on Gigi which does not want to have to handle
4154 -- a missing return).
4156 -- Add call to Activate_Tasks if body is a task activator
4158 -- Deal with possible detection of infinite recursion
4160 -- Eliminate body completely if convention stubbed
4162 -- Encode entity names within body, since we will not need to reference
4163 -- these entities any longer in the front end.
4165 -- Initialize scalar out parameters if Initialize/Normalize_Scalars
4167 -- Reset Pure indication if any parameter has root type System.Address
4171 procedure Expand_N_Subprogram_Body
(N
: Node_Id
) is
4172 Loc
: constant Source_Ptr
:= Sloc
(N
);
4173 H
: constant Node_Id
:= Handled_Statement_Sequence
(N
);
4174 Body_Id
: Entity_Id
;
4175 Spec_Id
: Entity_Id
;
4182 procedure Add_Return
(S
: List_Id
);
4183 -- Append a return statement to the statement sequence S if the last
4184 -- statement is not already a return or a goto statement. Note that
4185 -- the latter test is not critical, it does not matter if we add a
4186 -- few extra returns, since they get eliminated anyway later on.
4192 procedure Add_Return
(S
: List_Id
) is
4197 -- Get last statement, ignoring any Pop_xxx_Label nodes, which are
4198 -- not relevant in this context since they are not executable.
4200 Last_Stm
:= Last
(S
);
4201 while Nkind
(Last_Stm
) in N_Pop_xxx_Label
loop
4205 -- Now insert return unless last statement is a transfer
4207 if not Is_Transfer
(Last_Stm
) then
4209 -- The source location for the return is the end label of the
4210 -- procedure if present. Otherwise use the sloc of the last
4211 -- statement in the list. If the list comes from a generated
4212 -- exception handler and we are not debugging generated code,
4213 -- all the statements within the handler are made invisible
4216 if Nkind
(Parent
(S
)) = N_Exception_Handler
4217 and then not Comes_From_Source
(Parent
(S
))
4219 Loc
:= Sloc
(Last_Stm
);
4221 elsif Present
(End_Label
(H
)) then
4222 Loc
:= Sloc
(End_Label
(H
));
4225 Loc
:= Sloc
(Last_Stm
);
4228 Append_To
(S
, Make_Simple_Return_Statement
(Loc
));
4232 -- Start of processing for Expand_N_Subprogram_Body
4235 -- Set L to either the list of declarations if present, or
4236 -- to the list of statements if no declarations are present.
4237 -- This is used to insert new stuff at the start.
4239 if Is_Non_Empty_List
(Declarations
(N
)) then
4240 L
:= Declarations
(N
);
4242 L
:= Statements
(H
);
4245 -- If local-exception-to-goto optimization active, insert dummy push
4246 -- statements at start, and dummy pop statements at end.
4248 if (Debug_Flag_Dot_G
4249 or else Restriction_Active
(No_Exception_Propagation
))
4250 and then Is_Non_Empty_List
(L
)
4253 FS
: constant Node_Id
:= First
(L
);
4254 FL
: constant Source_Ptr
:= Sloc
(FS
);
4259 -- LS points to either last statement, if statements are present
4260 -- or to the last declaration if there are no statements present.
4261 -- It is the node after which the pop's are generated.
4263 if Is_Non_Empty_List
(Statements
(H
)) then
4264 LS
:= Last
(Statements
(H
));
4271 Insert_List_Before_And_Analyze
(FS
, New_List
(
4272 Make_Push_Constraint_Error_Label
(FL
),
4273 Make_Push_Program_Error_Label
(FL
),
4274 Make_Push_Storage_Error_Label
(FL
)));
4276 Insert_List_After_And_Analyze
(LS
, New_List
(
4277 Make_Pop_Constraint_Error_Label
(LL
),
4278 Make_Pop_Program_Error_Label
(LL
),
4279 Make_Pop_Storage_Error_Label
(LL
)));
4283 -- Find entity for subprogram
4285 Body_Id
:= Defining_Entity
(N
);
4287 if Present
(Corresponding_Spec
(N
)) then
4288 Spec_Id
:= Corresponding_Spec
(N
);
4293 -- Need poll on entry to subprogram if polling enabled. We only do this
4294 -- for non-empty subprograms, since it does not seem necessary to poll
4295 -- for a dummy null subprogram. Do not add polling point if calls to
4296 -- this subprogram will be inlined by the back-end, to avoid repeated
4297 -- polling points in nested inlinings.
4299 if Is_Non_Empty_List
(L
) then
4300 if Is_Inlined
(Spec_Id
)
4301 and then Front_End_Inlining
4302 and then Optimization_Level
> 1
4306 Generate_Poll_Call
(First
(L
));
4310 -- If this is a Pure function which has any parameters whose root
4311 -- type is System.Address, reset the Pure indication, since it will
4312 -- likely cause incorrect code to be generated as the parameter is
4313 -- probably a pointer, and the fact that the same pointer is passed
4314 -- does not mean that the same value is being referenced.
4316 -- Note that if the programmer gave an explicit Pure_Function pragma,
4317 -- then we believe the programmer, and leave the subprogram Pure.
4319 -- This code should probably be at the freeze point, so that it
4320 -- happens even on a -gnatc (or more importantly -gnatt) compile
4321 -- so that the semantic tree has Is_Pure set properly ???
4323 if Is_Pure
(Spec_Id
)
4324 and then Is_Subprogram
(Spec_Id
)
4325 and then not Has_Pragma_Pure_Function
(Spec_Id
)
4331 F
:= First_Formal
(Spec_Id
);
4332 while Present
(F
) loop
4333 if Is_Descendent_Of_Address
(Etype
(F
)) then
4334 Set_Is_Pure
(Spec_Id
, False);
4336 if Spec_Id
/= Body_Id
then
4337 Set_Is_Pure
(Body_Id
, False);
4348 -- Initialize any scalar OUT args if Initialize/Normalize_Scalars
4350 if Init_Or_Norm_Scalars
and then Is_Subprogram
(Spec_Id
) then
4355 -- Loop through formals
4357 F
:= First_Formal
(Spec_Id
);
4358 while Present
(F
) loop
4359 if Is_Scalar_Type
(Etype
(F
))
4360 and then Ekind
(F
) = E_Out_Parameter
4362 -- Insert the initialization. We turn off validity checks
4363 -- for this assignment, since we do not want any check on
4364 -- the initial value itself (which may well be invalid).
4366 Insert_Before_And_Analyze
(First
(L
),
4367 Make_Assignment_Statement
(Loc
,
4368 Name
=> New_Occurrence_Of
(F
, Loc
),
4369 Expression
=> Get_Simple_Init_Val
(Etype
(F
), Loc
)),
4370 Suppress
=> Validity_Check
);
4378 Scop
:= Scope
(Spec_Id
);
4380 -- Add discriminal renamings to protected subprograms. Install new
4381 -- discriminals for expansion of the next subprogram of this protected
4384 if Is_List_Member
(N
)
4385 and then Present
(Parent
(List_Containing
(N
)))
4386 and then Nkind
(Parent
(List_Containing
(N
))) = N_Protected_Body
4388 Add_Discriminal_Declarations
4389 (Declarations
(N
), Scop
, Name_uObject
, Loc
);
4390 Add_Private_Declarations
4391 (Declarations
(N
), Scop
, Name_uObject
, Loc
);
4393 -- Associate privals and discriminals with the next protected
4394 -- operation body to be expanded. These are used to expand references
4395 -- to private data objects and discriminants, respectively.
4397 Next_Op
:= Next_Protected_Operation
(N
);
4399 if Present
(Next_Op
) then
4400 Dec
:= Parent
(Base_Type
(Scop
));
4401 Set_Privals
(Dec
, Next_Op
, Loc
);
4402 Set_Discriminals
(Dec
);
4406 -- Clear out statement list for stubbed procedure
4408 if Present
(Corresponding_Spec
(N
)) then
4409 Set_Elaboration_Flag
(N
, Spec_Id
);
4411 if Convention
(Spec_Id
) = Convention_Stubbed
4412 or else Is_Eliminated
(Spec_Id
)
4414 Set_Declarations
(N
, Empty_List
);
4415 Set_Handled_Statement_Sequence
(N
,
4416 Make_Handled_Sequence_Of_Statements
(Loc
,
4417 Statements
=> New_List
(
4418 Make_Null_Statement
(Loc
))));
4423 -- Returns_By_Ref flag is normally set when the subprogram is frozen
4424 -- but subprograms with no specs are not frozen.
4427 Typ
: constant Entity_Id
:= Etype
(Spec_Id
);
4428 Utyp
: constant Entity_Id
:= Underlying_Type
(Typ
);
4431 if not Acts_As_Spec
(N
)
4432 and then Nkind
(Parent
(Parent
(Spec_Id
))) /=
4433 N_Subprogram_Body_Stub
4437 elsif Is_Inherently_Limited_Type
(Typ
) then
4438 Set_Returns_By_Ref
(Spec_Id
);
4440 elsif Present
(Utyp
) and then CW_Or_Controlled_Type
(Utyp
) then
4441 Set_Returns_By_Ref
(Spec_Id
);
4445 -- For a procedure, we add a return for all possible syntactic ends
4446 -- of the subprogram. Note that reanalysis is not necessary in this
4447 -- case since it would require a lot of work and accomplish nothing.
4449 if Ekind
(Spec_Id
) = E_Procedure
4450 or else Ekind
(Spec_Id
) = E_Generic_Procedure
4452 Add_Return
(Statements
(H
));
4454 if Present
(Exception_Handlers
(H
)) then
4455 Except_H
:= First_Non_Pragma
(Exception_Handlers
(H
));
4456 while Present
(Except_H
) loop
4457 Add_Return
(Statements
(Except_H
));
4458 Next_Non_Pragma
(Except_H
);
4462 -- For a function, we must deal with the case where there is at least
4463 -- one missing return. What we do is to wrap the entire body of the
4464 -- function in a block:
4477 -- raise Program_Error;
4480 -- This approach is necessary because the raise must be signalled
4481 -- to the caller, not handled by any local handler (RM 6.4(11)).
4483 -- Note: we do not need to analyze the constructed sequence here,
4484 -- since it has no handler, and an attempt to analyze the handled
4485 -- statement sequence twice is risky in various ways (e.g. the
4486 -- issue of expanding cleanup actions twice).
4488 elsif Has_Missing_Return
(Spec_Id
) then
4490 Hloc
: constant Source_Ptr
:= Sloc
(H
);
4491 Blok
: constant Node_Id
:=
4492 Make_Block_Statement
(Hloc
,
4493 Handled_Statement_Sequence
=> H
);
4494 Rais
: constant Node_Id
:=
4495 Make_Raise_Program_Error
(Hloc
,
4496 Reason
=> PE_Missing_Return
);
4499 Set_Handled_Statement_Sequence
(N
,
4500 Make_Handled_Sequence_Of_Statements
(Hloc
,
4501 Statements
=> New_List
(Blok
, Rais
)));
4503 Push_Scope
(Spec_Id
);
4510 -- If subprogram contains a parameterless recursive call, then we may
4511 -- have an infinite recursion, so see if we can generate code to check
4512 -- for this possibility if storage checks are not suppressed.
4514 if Ekind
(Spec_Id
) = E_Procedure
4515 and then Has_Recursive_Call
(Spec_Id
)
4516 and then not Storage_Checks_Suppressed
(Spec_Id
)
4518 Detect_Infinite_Recursion
(N
, Spec_Id
);
4521 -- Finally, if we are in Normalize_Scalars mode, then any scalar out
4522 -- parameters must be initialized to the appropriate default value.
4524 if Ekind
(Spec_Id
) = E_Procedure
and then Normalize_Scalars
then
4531 Formal
:= First_Formal
(Spec_Id
);
4532 while Present
(Formal
) loop
4533 Floc
:= Sloc
(Formal
);
4535 if Ekind
(Formal
) = E_Out_Parameter
4536 and then Is_Scalar_Type
(Etype
(Formal
))
4539 Make_Assignment_Statement
(Floc
,
4540 Name
=> New_Occurrence_Of
(Formal
, Floc
),
4542 Get_Simple_Init_Val
(Etype
(Formal
), Floc
));
4543 Prepend
(Stm
, Declarations
(N
));
4547 Next_Formal
(Formal
);
4552 -- Set to encode entity names in package body before gigi is called
4554 Qualify_Entity_Names
(N
);
4555 end Expand_N_Subprogram_Body
;
4557 -----------------------------------
4558 -- Expand_N_Subprogram_Body_Stub --
4559 -----------------------------------
4561 procedure Expand_N_Subprogram_Body_Stub
(N
: Node_Id
) is
4563 if Present
(Corresponding_Body
(N
)) then
4564 Expand_N_Subprogram_Body
(
4565 Unit_Declaration_Node
(Corresponding_Body
(N
)));
4567 end Expand_N_Subprogram_Body_Stub
;
4569 -------------------------------------
4570 -- Expand_N_Subprogram_Declaration --
4571 -------------------------------------
4573 -- If the declaration appears within a protected body, it is a private
4574 -- operation of the protected type. We must create the corresponding
4575 -- protected subprogram an associated formals. For a normal protected
4576 -- operation, this is done when expanding the protected type declaration.
4578 -- If the declaration is for a null procedure, emit null body
4580 procedure Expand_N_Subprogram_Declaration
(N
: Node_Id
) is
4581 Loc
: constant Source_Ptr
:= Sloc
(N
);
4582 Subp
: constant Entity_Id
:= Defining_Entity
(N
);
4583 Scop
: constant Entity_Id
:= Scope
(Subp
);
4584 Prot_Decl
: Node_Id
;
4586 Prot_Id
: Entity_Id
;
4589 -- Deal with case of protected subprogram. Do not generate protected
4590 -- operation if operation is flagged as eliminated.
4592 if Is_List_Member
(N
)
4593 and then Present
(Parent
(List_Containing
(N
)))
4594 and then Nkind
(Parent
(List_Containing
(N
))) = N_Protected_Body
4595 and then Is_Protected_Type
(Scop
)
4597 if No
(Protected_Body_Subprogram
(Subp
))
4598 and then not Is_Eliminated
(Subp
)
4601 Make_Subprogram_Declaration
(Loc
,
4603 Build_Protected_Sub_Specification
4604 (N
, Scop
, Unprotected_Mode
));
4606 -- The protected subprogram is declared outside of the protected
4607 -- body. Given that the body has frozen all entities so far, we
4608 -- analyze the subprogram and perform freezing actions explicitly.
4609 -- including the generation of an explicit freeze node, to ensure
4610 -- that gigi has the proper order of elaboration.
4611 -- If the body is a subunit, the insertion point is before the
4612 -- stub in the parent.
4614 Prot_Bod
:= Parent
(List_Containing
(N
));
4616 if Nkind
(Parent
(Prot_Bod
)) = N_Subunit
then
4617 Prot_Bod
:= Corresponding_Stub
(Parent
(Prot_Bod
));
4620 Insert_Before
(Prot_Bod
, Prot_Decl
);
4621 Prot_Id
:= Defining_Unit_Name
(Specification
(Prot_Decl
));
4622 Set_Has_Delayed_Freeze
(Prot_Id
);
4624 Push_Scope
(Scope
(Scop
));
4625 Analyze
(Prot_Decl
);
4626 Insert_Actions
(N
, Freeze_Entity
(Prot_Id
, Loc
));
4627 Set_Protected_Body_Subprogram
(Subp
, Prot_Id
);
4631 -- Ada 2005 (AI-348): Generation of the null body
4633 elsif Nkind
(Specification
(N
)) = N_Procedure_Specification
4634 and then Null_Present
(Specification
(N
))
4637 Bod
: constant Node_Id
:=
4638 Make_Subprogram_Body
(Loc
,
4640 New_Copy_Tree
(Specification
(N
)),
4641 Declarations
=> New_List
,
4642 Handled_Statement_Sequence
=>
4643 Make_Handled_Sequence_Of_Statements
(Loc
,
4644 Statements
=> New_List
(Make_Null_Statement
(Loc
))));
4646 Set_Body_To_Inline
(N
, Bod
);
4647 Insert_After
(N
, Bod
);
4650 -- Corresponding_Spec isn't being set by Analyze_Subprogram_Body,
4651 -- evidently because Set_Has_Completion is called earlier for null
4652 -- procedures in Analyze_Subprogram_Declaration, so we force its
4653 -- setting here. If the setting of Has_Completion is not set
4654 -- earlier, then it can result in missing body errors if other
4655 -- errors were already reported (since expansion is turned off).
4657 -- Should creation of the empty body be moved to the analyzer???
4659 Set_Corresponding_Spec
(Bod
, Defining_Entity
(Specification
(N
)));
4662 end Expand_N_Subprogram_Declaration
;
4664 ---------------------------------------
4665 -- Expand_Protected_Object_Reference --
4666 ---------------------------------------
4668 function Expand_Protected_Object_Reference
4670 Scop
: Entity_Id
) return Node_Id
4672 Loc
: constant Source_Ptr
:= Sloc
(N
);
4680 Make_Identifier
(Loc
,
4681 Chars
=> Name_uObject
);
4682 Set_Etype
(Rec
, Corresponding_Record_Type
(Scop
));
4684 -- Find enclosing protected operation, and retrieve its first parameter,
4685 -- which denotes the enclosing protected object. If the enclosing
4686 -- operation is an entry, we are immediately within the protected body,
4687 -- and we can retrieve the object from the service entries procedure. A
4688 -- barrier function has has the same signature as an entry. A barrier
4689 -- function is compiled within the protected object, but unlike
4690 -- protected operations its never needs locks, so that its protected
4691 -- body subprogram points to itself.
4693 Proc
:= Current_Scope
;
4694 while Present
(Proc
)
4695 and then Scope
(Proc
) /= Scop
4697 Proc
:= Scope
(Proc
);
4700 Corr
:= Protected_Body_Subprogram
(Proc
);
4704 -- Previous error left expansion incomplete.
4705 -- Nothing to do on this call.
4712 (First
(Parameter_Specifications
(Parent
(Corr
))));
4714 if Is_Subprogram
(Proc
)
4715 and then Proc
/= Corr
4717 -- Protected function or procedure
4719 Set_Entity
(Rec
, Param
);
4721 -- Rec is a reference to an entity which will not be in scope when
4722 -- the call is reanalyzed, and needs no further analysis.
4727 -- Entry or barrier function for entry body. The first parameter of
4728 -- the entry body procedure is pointer to the object. We create a
4729 -- local variable of the proper type, duplicating what is done to
4730 -- define _object later on.
4734 Obj_Ptr
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
,
4736 New_Internal_Name
('T'));
4740 Make_Full_Type_Declaration
(Loc
,
4741 Defining_Identifier
=> Obj_Ptr
,
4743 Make_Access_To_Object_Definition
(Loc
,
4744 Subtype_Indication
=>
4746 (Corresponding_Record_Type
(Scop
), Loc
))));
4748 Insert_Actions
(N
, Decls
);
4749 Insert_Actions
(N
, Freeze_Entity
(Obj_Ptr
, Sloc
(N
)));
4752 Make_Explicit_Dereference
(Loc
,
4753 Unchecked_Convert_To
(Obj_Ptr
,
4754 New_Occurrence_Of
(Param
, Loc
)));
4756 -- Analyze new actual. Other actuals in calls are already analyzed
4757 -- and the list of actuals is not reanalyzed after rewriting.
4759 Set_Parent
(Rec
, N
);
4765 end Expand_Protected_Object_Reference
;
4767 --------------------------------------
4768 -- Expand_Protected_Subprogram_Call --
4769 --------------------------------------
4771 procedure Expand_Protected_Subprogram_Call
4779 -- If the protected object is not an enclosing scope, this is
4780 -- an inter-object function call. Inter-object procedure
4781 -- calls are expanded by Exp_Ch9.Build_Simple_Entry_Call.
4782 -- The call is intra-object only if the subprogram being
4783 -- called is in the protected body being compiled, and if the
4784 -- protected object in the call is statically the enclosing type.
4785 -- The object may be an component of some other data structure,
4786 -- in which case this must be handled as an inter-object call.
4788 if not In_Open_Scopes
(Scop
)
4789 or else not Is_Entity_Name
(Name
(N
))
4791 if Nkind
(Name
(N
)) = N_Selected_Component
then
4792 Rec
:= Prefix
(Name
(N
));
4795 pragma Assert
(Nkind
(Name
(N
)) = N_Indexed_Component
);
4796 Rec
:= Prefix
(Prefix
(Name
(N
)));
4799 Build_Protected_Subprogram_Call
(N
,
4800 Name
=> New_Occurrence_Of
(Subp
, Sloc
(N
)),
4801 Rec
=> Convert_Concurrent
(Rec
, Etype
(Rec
)),
4805 Rec
:= Expand_Protected_Object_Reference
(N
, Scop
);
4811 Build_Protected_Subprogram_Call
(N
,
4820 -- If it is a function call it can appear in elaboration code and
4821 -- the called entity must be frozen here.
4823 if Ekind
(Subp
) = E_Function
then
4824 Freeze_Expression
(Name
(N
));
4826 end Expand_Protected_Subprogram_Call
;
4828 --------------------------------
4829 -- Is_Build_In_Place_Function --
4830 --------------------------------
4832 function Is_Build_In_Place_Function
(E
: Entity_Id
) return Boolean is
4834 -- For now we test whether E denotes a function or access-to-function
4835 -- type whose result subtype is inherently limited. Later this test may
4836 -- be revised to allow composite nonlimited types. Functions with a
4837 -- foreign convention or whose result type has a foreign convention
4840 if Ekind
(E
) = E_Function
4841 or else Ekind
(E
) = E_Generic_Function
4842 or else (Ekind
(E
) = E_Subprogram_Type
4843 and then Etype
(E
) /= Standard_Void_Type
)
4845 -- Note: If you have Convention (C) on an inherently limited type,
4846 -- you're on your own. That is, the C code will have to be carefully
4847 -- written to know about the Ada conventions.
4849 if Has_Foreign_Convention
(E
)
4850 or else Has_Foreign_Convention
(Etype
(E
))
4854 -- If the return type is a limited interface it has to be treated
4855 -- as a return in place, even if the actual object is some non-
4856 -- limited descendant.
4858 elsif Is_Limited_Interface
(Etype
(E
)) then
4862 return Is_Inherently_Limited_Type
(Etype
(E
))
4863 and then Ada_Version
>= Ada_05
4864 and then not Debug_Flag_Dot_L
;
4870 end Is_Build_In_Place_Function
;
4872 -------------------------------------
4873 -- Is_Build_In_Place_Function_Call --
4874 -------------------------------------
4876 function Is_Build_In_Place_Function_Call
(N
: Node_Id
) return Boolean is
4877 Exp_Node
: Node_Id
:= N
;
4878 Function_Id
: Entity_Id
;
4881 -- Step past qualification or unchecked conversion (the latter can occur
4882 -- in cases of calls to 'Input).
4884 if Nkind
(Exp_Node
) = N_Qualified_Expression
4885 or else Nkind
(Exp_Node
) = N_Unchecked_Type_Conversion
4887 Exp_Node
:= Expression
(N
);
4890 if Nkind
(Exp_Node
) /= N_Function_Call
then
4894 if Is_Entity_Name
(Name
(Exp_Node
)) then
4895 Function_Id
:= Entity
(Name
(Exp_Node
));
4897 elsif Nkind
(Name
(Exp_Node
)) = N_Explicit_Dereference
then
4898 Function_Id
:= Etype
(Name
(Exp_Node
));
4901 return Is_Build_In_Place_Function
(Function_Id
);
4903 end Is_Build_In_Place_Function_Call
;
4905 ---------------------------------------
4906 -- Is_Build_In_Place_Function_Return --
4907 ---------------------------------------
4909 function Is_Build_In_Place_Function_Return
(N
: Node_Id
) return Boolean is
4911 if Nkind
(N
) = N_Simple_Return_Statement
4912 or else Nkind
(N
) = N_Extended_Return_Statement
4914 return Is_Build_In_Place_Function
4915 (Return_Applies_To
(Return_Statement_Entity
(N
)));
4919 end Is_Build_In_Place_Function_Return
;
4921 -----------------------
4922 -- Freeze_Subprogram --
4923 -----------------------
4925 procedure Freeze_Subprogram
(N
: Node_Id
) is
4926 Loc
: constant Source_Ptr
:= Sloc
(N
);
4928 procedure Register_Predefined_DT_Entry
(Prim
: Entity_Id
);
4929 -- (Ada 2005): Register a predefined primitive in all the secondary
4930 -- dispatch tables of its primitive type.
4932 ----------------------------------
4933 -- Register_Predefined_DT_Entry --
4934 ----------------------------------
4936 procedure Register_Predefined_DT_Entry
(Prim
: Entity_Id
) is
4937 Iface_DT_Ptr
: Elmt_Id
;
4938 Tagged_Typ
: Entity_Id
;
4939 Thunk_Id
: Entity_Id
;
4940 Thunk_Code
: Node_Id
;
4943 Tagged_Typ
:= Find_Dispatching_Type
(Prim
);
4945 if No
(Access_Disp_Table
(Tagged_Typ
))
4946 or else not Has_Abstract_Interfaces
(Tagged_Typ
)
4947 or else not RTE_Available
(RE_Interface_Tag
)
4948 or else Restriction_Active
(No_Dispatching_Calls
)
4953 -- Skip the first access-to-dispatch-table pointer since it leads
4954 -- to the primary dispatch table. We are only concerned with the
4955 -- secondary dispatch table pointers. Note that the access-to-
4956 -- dispatch-table pointer corresponds to the first implemented
4957 -- interface retrieved below.
4960 Next_Elmt
(First_Elmt
(Access_Disp_Table
(Tagged_Typ
)));
4962 while Present
(Iface_DT_Ptr
)
4963 and then Ekind
(Node
(Iface_DT_Ptr
)) = E_Constant
4965 Expand_Interface_Thunk
(Prim
, Thunk_Id
, Thunk_Code
);
4967 if Present
(Thunk_Code
) then
4968 Insert_Actions
(N
, New_List
(
4971 Build_Set_Predefined_Prim_Op_Address
(Loc
,
4972 Tag_Node
=> New_Reference_To
(Node
(Iface_DT_Ptr
), Loc
),
4973 Position
=> DT_Position
(Prim
),
4975 Make_Attribute_Reference
(Loc
,
4976 Prefix
=> New_Reference_To
(Thunk_Id
, Loc
),
4977 Attribute_Name
=> Name_Address
))));
4980 Next_Elmt
(Iface_DT_Ptr
);
4982 end Register_Predefined_DT_Entry
;
4986 Subp
: constant Entity_Id
:= Entity
(N
);
4989 -- We suppress the initialization of the dispatch table entry when
4990 -- VM_Target because the dispatching mechanism is handled internally
4993 if Is_Dispatching_Operation
(Subp
)
4994 and then not Is_Abstract_Subprogram
(Subp
)
4995 and then Present
(DTC_Entity
(Subp
))
4996 and then Present
(Scope
(DTC_Entity
(Subp
)))
4997 and then VM_Target
= No_VM
4998 and then not Restriction_Active
(No_Dispatching_Calls
)
4999 and then RTE_Available
(RE_Tag
)
5002 Typ
: constant Entity_Id
:= Scope
(DTC_Entity
(Subp
));
5005 -- Handle private overriden primitives
5007 if not Is_CPP_Class
(Typ
) then
5008 Check_Overriding_Operation
(Subp
);
5011 -- We assume that imported CPP primitives correspond with objects
5012 -- whose constructor is in the CPP side; therefore we don't need
5013 -- to generate code to register them in the dispatch table.
5015 if Is_CPP_Class
(Typ
) then
5018 -- Handle CPP primitives found in derivations of CPP_Class types.
5019 -- These primitives must have been inherited from some parent, and
5020 -- there is no need to register them in the dispatch table because
5021 -- Build_Inherit_Prims takes care of the initialization of these
5024 elsif Is_Imported
(Subp
)
5025 and then (Convention
(Subp
) = Convention_CPP
5026 or else Convention
(Subp
) = Convention_C
)
5030 -- Generate code to register the primitive in non statically
5031 -- allocated dispatch tables
5033 elsif not Static_Dispatch_Tables
5035 Is_Library_Level_Tagged_Type
(Scope
(DTC_Entity
(Subp
)))
5037 -- When a primitive is frozen, enter its name in its dispatch
5040 if not Is_Interface
(Typ
)
5041 or else Present
(Abstract_Interface_Alias
(Subp
))
5043 if Is_Predefined_Dispatching_Operation
(Subp
) then
5044 Register_Predefined_DT_Entry
(Subp
);
5047 Register_Primitive
(Loc
,
5055 -- Mark functions that return by reference. Note that it cannot be part
5056 -- of the normal semantic analysis of the spec since the underlying
5057 -- returned type may not be known yet (for private types).
5060 Typ
: constant Entity_Id
:= Etype
(Subp
);
5061 Utyp
: constant Entity_Id
:= Underlying_Type
(Typ
);
5063 if Is_Inherently_Limited_Type
(Typ
) then
5064 Set_Returns_By_Ref
(Subp
);
5065 elsif Present
(Utyp
) and then CW_Or_Controlled_Type
(Utyp
) then
5066 Set_Returns_By_Ref
(Subp
);
5069 end Freeze_Subprogram
;
5071 -------------------------------------------
5072 -- Make_Build_In_Place_Call_In_Allocator --
5073 -------------------------------------------
5075 procedure Make_Build_In_Place_Call_In_Allocator
5076 (Allocator
: Node_Id
;
5077 Function_Call
: Node_Id
)
5080 Func_Call
: Node_Id
:= Function_Call
;
5081 Function_Id
: Entity_Id
;
5082 Result_Subt
: Entity_Id
;
5083 Acc_Type
: constant Entity_Id
:= Etype
(Allocator
);
5084 New_Allocator
: Node_Id
;
5085 Return_Obj_Access
: Entity_Id
;
5088 -- Step past qualification or unchecked conversion (the latter can occur
5089 -- in cases of calls to 'Input).
5091 if Nkind
(Func_Call
) = N_Qualified_Expression
5092 or else Nkind
(Func_Call
) = N_Unchecked_Type_Conversion
5094 Func_Call
:= Expression
(Func_Call
);
5097 -- If the call has already been processed to add build-in-place actuals
5098 -- then return. This should not normally occur in an allocator context,
5099 -- but we add the protection as a defensive measure.
5101 if Is_Expanded_Build_In_Place_Call
(Func_Call
) then
5105 -- Mark the call as processed as a build-in-place call
5107 Set_Is_Expanded_Build_In_Place_Call
(Func_Call
);
5109 Loc
:= Sloc
(Function_Call
);
5111 if Is_Entity_Name
(Name
(Func_Call
)) then
5112 Function_Id
:= Entity
(Name
(Func_Call
));
5114 elsif Nkind
(Name
(Func_Call
)) = N_Explicit_Dereference
then
5115 Function_Id
:= Etype
(Name
(Func_Call
));
5118 raise Program_Error
;
5121 Result_Subt
:= Etype
(Function_Id
);
5123 -- When the result subtype is constrained, the return object must be
5124 -- allocated on the caller side, and access to it is passed to the
5127 -- Here and in related routines, we must examine the full view of the
5128 -- type, because the view at the point of call may differ from that
5129 -- that in the function body, and the expansion mechanism depends on
5130 -- the characteristics of the full view.
5132 if Is_Constrained
(Underlying_Type
(Result_Subt
)) then
5134 -- Replace the initialized allocator of form "new T'(Func (...))"
5135 -- with an uninitialized allocator of form "new T", where T is the
5136 -- result subtype of the called function. The call to the function
5137 -- is handled separately further below.
5140 Make_Allocator
(Loc
, New_Reference_To
(Result_Subt
, Loc
));
5142 Set_Storage_Pool
(New_Allocator
, Storage_Pool
(Allocator
));
5143 Set_Procedure_To_Call
(New_Allocator
, Procedure_To_Call
(Allocator
));
5144 Set_No_Initialization
(New_Allocator
);
5146 Rewrite
(Allocator
, New_Allocator
);
5148 -- Create a new access object and initialize it to the result of the
5149 -- new uninitialized allocator.
5151 Return_Obj_Access
:=
5152 Make_Defining_Identifier
(Loc
, New_Internal_Name
('R'));
5153 Set_Etype
(Return_Obj_Access
, Acc_Type
);
5155 Insert_Action
(Allocator
,
5156 Make_Object_Declaration
(Loc
,
5157 Defining_Identifier
=> Return_Obj_Access
,
5158 Object_Definition
=> New_Reference_To
(Acc_Type
, Loc
),
5159 Expression
=> Relocate_Node
(Allocator
)));
5161 -- When the function has a controlling result, an allocation-form
5162 -- parameter must be passed indicating that the caller is allocating
5163 -- the result object. This is needed because such a function can be
5164 -- called as a dispatching operation and must be treated similarly
5165 -- to functions with unconstrained result subtypes.
5167 Add_Alloc_Form_Actual_To_Build_In_Place_Call
5168 (Func_Call
, Function_Id
, Alloc_Form
=> Caller_Allocation
);
5170 Add_Final_List_Actual_To_Build_In_Place_Call
5171 (Func_Call
, Function_Id
, Acc_Type
);
5173 Add_Task_Actuals_To_Build_In_Place_Call
5174 (Func_Call
, Function_Id
, Master_Actual
=> Master_Id
(Acc_Type
));
5176 -- Add an implicit actual to the function call that provides access
5177 -- to the allocated object. An unchecked conversion to the (specific)
5178 -- result subtype of the function is inserted to handle cases where
5179 -- the access type of the allocator has a class-wide designated type.
5181 Add_Access_Actual_To_Build_In_Place_Call
5184 Make_Unchecked_Type_Conversion
(Loc
,
5185 Subtype_Mark
=> New_Reference_To
(Result_Subt
, Loc
),
5187 Make_Explicit_Dereference
(Loc
,
5188 Prefix
=> New_Reference_To
(Return_Obj_Access
, Loc
))));
5190 -- When the result subtype is unconstrained, the function itself must
5191 -- perform the allocation of the return object, so we pass parameters
5192 -- indicating that. We don't yet handle the case where the allocation
5193 -- must be done in a user-defined storage pool, which will require
5194 -- passing another actual or two to provide allocation/deallocation
5199 -- Pass an allocation parameter indicating that the function should
5200 -- allocate its result on the heap.
5202 Add_Alloc_Form_Actual_To_Build_In_Place_Call
5203 (Func_Call
, Function_Id
, Alloc_Form
=> Global_Heap
);
5205 Add_Final_List_Actual_To_Build_In_Place_Call
5206 (Func_Call
, Function_Id
, Acc_Type
);
5208 Add_Task_Actuals_To_Build_In_Place_Call
5209 (Func_Call
, Function_Id
, Master_Actual
=> Master_Id
(Acc_Type
));
5211 -- The caller does not provide the return object in this case, so we
5212 -- have to pass null for the object access actual.
5214 Add_Access_Actual_To_Build_In_Place_Call
5215 (Func_Call
, Function_Id
, Return_Object
=> Empty
);
5218 -- Finally, replace the allocator node with a reference to the result
5219 -- of the function call itself (which will effectively be an access
5220 -- to the object created by the allocator).
5222 Rewrite
(Allocator
, Make_Reference
(Loc
, Relocate_Node
(Function_Call
)));
5223 Analyze_And_Resolve
(Allocator
, Acc_Type
);
5224 end Make_Build_In_Place_Call_In_Allocator
;
5226 ---------------------------------------------------
5227 -- Make_Build_In_Place_Call_In_Anonymous_Context --
5228 ---------------------------------------------------
5230 procedure Make_Build_In_Place_Call_In_Anonymous_Context
5231 (Function_Call
: Node_Id
)
5234 Func_Call
: Node_Id
:= Function_Call
;
5235 Function_Id
: Entity_Id
;
5236 Result_Subt
: Entity_Id
;
5237 Return_Obj_Id
: Entity_Id
;
5238 Return_Obj_Decl
: Entity_Id
;
5241 -- Step past qualification or unchecked conversion (the latter can occur
5242 -- in cases of calls to 'Input).
5244 if Nkind
(Func_Call
) = N_Qualified_Expression
5245 or else Nkind
(Func_Call
) = N_Unchecked_Type_Conversion
5247 Func_Call
:= Expression
(Func_Call
);
5250 -- If the call has already been processed to add build-in-place actuals
5251 -- then return. One place this can occur is for calls to build-in-place
5252 -- functions that occur within a call to a protected operation, where
5253 -- due to rewriting and expansion of the protected call there can be
5254 -- more than one call to Expand_Actuals for the same set of actuals.
5256 if Is_Expanded_Build_In_Place_Call
(Func_Call
) then
5260 -- Mark the call as processed as a build-in-place call
5262 Set_Is_Expanded_Build_In_Place_Call
(Func_Call
);
5264 Loc
:= Sloc
(Function_Call
);
5266 if Is_Entity_Name
(Name
(Func_Call
)) then
5267 Function_Id
:= Entity
(Name
(Func_Call
));
5269 elsif Nkind
(Name
(Func_Call
)) = N_Explicit_Dereference
then
5270 Function_Id
:= Etype
(Name
(Func_Call
));
5273 raise Program_Error
;
5276 Result_Subt
:= Etype
(Function_Id
);
5278 -- When the result subtype is constrained, an object of the subtype is
5279 -- declared and an access value designating it is passed as an actual.
5281 if Is_Constrained
(Underlying_Type
(Result_Subt
)) then
5283 -- Create a temporary object to hold the function result
5286 Make_Defining_Identifier
(Loc
,
5287 Chars
=> New_Internal_Name
('R'));
5288 Set_Etype
(Return_Obj_Id
, Result_Subt
);
5291 Make_Object_Declaration
(Loc
,
5292 Defining_Identifier
=> Return_Obj_Id
,
5293 Aliased_Present
=> True,
5294 Object_Definition
=> New_Reference_To
(Result_Subt
, Loc
));
5296 Set_No_Initialization
(Return_Obj_Decl
);
5298 Insert_Action
(Func_Call
, Return_Obj_Decl
);
5300 -- When the function has a controlling result, an allocation-form
5301 -- parameter must be passed indicating that the caller is allocating
5302 -- the result object. This is needed because such a function can be
5303 -- called as a dispatching operation and must be treated similarly
5304 -- to functions with unconstrained result subtypes.
5306 Add_Alloc_Form_Actual_To_Build_In_Place_Call
5307 (Func_Call
, Function_Id
, Alloc_Form
=> Caller_Allocation
);
5309 Add_Final_List_Actual_To_Build_In_Place_Call
5310 (Func_Call
, Function_Id
, Acc_Type
=> Empty
);
5312 Add_Task_Actuals_To_Build_In_Place_Call
5313 (Func_Call
, Function_Id
, Make_Identifier
(Loc
, Name_uMaster
));
5315 -- Add an implicit actual to the function call that provides access
5316 -- to the caller's return object.
5318 Add_Access_Actual_To_Build_In_Place_Call
5319 (Func_Call
, Function_Id
, New_Reference_To
(Return_Obj_Id
, Loc
));
5321 -- When the result subtype is unconstrained, the function must allocate
5322 -- the return object in the secondary stack, so appropriate implicit
5323 -- parameters are added to the call to indicate that. A transient
5324 -- scope is established to ensure eventual cleanup of the result.
5328 -- Pass an allocation parameter indicating that the function should
5329 -- allocate its result on the secondary stack.
5331 Add_Alloc_Form_Actual_To_Build_In_Place_Call
5332 (Func_Call
, Function_Id
, Alloc_Form
=> Secondary_Stack
);
5334 Add_Final_List_Actual_To_Build_In_Place_Call
5335 (Func_Call
, Function_Id
, Acc_Type
=> Empty
);
5337 Add_Task_Actuals_To_Build_In_Place_Call
5338 (Func_Call
, Function_Id
, Make_Identifier
(Loc
, Name_uMaster
));
5340 -- Pass a null value to the function since no return object is
5341 -- available on the caller side.
5343 Add_Access_Actual_To_Build_In_Place_Call
5344 (Func_Call
, Function_Id
, Empty
);
5346 Establish_Transient_Scope
(Func_Call
, Sec_Stack
=> True);
5348 end Make_Build_In_Place_Call_In_Anonymous_Context
;
5350 ---------------------------------------------------
5351 -- Make_Build_In_Place_Call_In_Assignment --
5352 ---------------------------------------------------
5354 procedure Make_Build_In_Place_Call_In_Assignment
5356 Function_Call
: Node_Id
)
5358 Lhs
: constant Node_Id
:= Name
(Assign
);
5360 Func_Call
: Node_Id
:= Function_Call
;
5361 Function_Id
: Entity_Id
;
5362 Result_Subt
: Entity_Id
;
5363 Ref_Type
: Entity_Id
;
5364 Ptr_Typ_Decl
: Node_Id
;
5369 -- Step past qualification or unchecked conversion (the latter can occur
5370 -- in cases of calls to 'Input).
5372 if Nkind
(Func_Call
) = N_Qualified_Expression
5373 or else Nkind
(Func_Call
) = N_Unchecked_Type_Conversion
5375 Func_Call
:= Expression
(Func_Call
);
5378 -- If the call has already been processed to add build-in-place actuals
5379 -- then return. This should not normally occur in an assignment context,
5380 -- but we add the protection as a defensive measure.
5382 if Is_Expanded_Build_In_Place_Call
(Func_Call
) then
5386 -- Mark the call as processed as a build-in-place call
5388 Set_Is_Expanded_Build_In_Place_Call
(Func_Call
);
5390 Loc
:= Sloc
(Function_Call
);
5392 if Is_Entity_Name
(Name
(Func_Call
)) then
5393 Function_Id
:= Entity
(Name
(Func_Call
));
5395 elsif Nkind
(Name
(Func_Call
)) = N_Explicit_Dereference
then
5396 Function_Id
:= Etype
(Name
(Func_Call
));
5399 raise Program_Error
;
5402 Result_Subt
:= Etype
(Function_Id
);
5404 -- When the result subtype is unconstrained, an additional actual must
5405 -- be passed to indicate that the caller is providing the return object.
5406 -- This parameter must also be passed when the called function has a
5407 -- controlling result, because dispatching calls to the function needs
5408 -- to be treated effectively the same as calls to class-wide functions.
5410 Add_Alloc_Form_Actual_To_Build_In_Place_Call
5411 (Func_Call
, Function_Id
, Alloc_Form
=> Caller_Allocation
);
5413 Add_Final_List_Actual_To_Build_In_Place_Call
5414 (Func_Call
, Function_Id
, Acc_Type
=> Empty
);
5416 Add_Task_Actuals_To_Build_In_Place_Call
5417 (Func_Call
, Function_Id
, Make_Identifier
(Loc
, Name_uMaster
));
5419 -- Add an implicit actual to the function call that provides access to
5420 -- the caller's return object.
5422 Add_Access_Actual_To_Build_In_Place_Call
5425 Make_Unchecked_Type_Conversion
(Loc
,
5426 Subtype_Mark
=> New_Reference_To
(Result_Subt
, Loc
),
5427 Expression
=> Relocate_Node
(Lhs
)));
5429 -- Create an access type designating the function's result subtype
5432 Make_Defining_Identifier
(Loc
, New_Internal_Name
('A'));
5435 Make_Full_Type_Declaration
(Loc
,
5436 Defining_Identifier
=> Ref_Type
,
5438 Make_Access_To_Object_Definition
(Loc
,
5439 All_Present
=> True,
5440 Subtype_Indication
=>
5441 New_Reference_To
(Result_Subt
, Loc
)));
5443 Insert_After_And_Analyze
(Assign
, Ptr_Typ_Decl
);
5445 -- Finally, create an access object initialized to a reference to the
5449 Make_Defining_Identifier
(Loc
,
5450 Chars
=> New_Internal_Name
('R'));
5451 Set_Etype
(Def_Id
, Ref_Type
);
5454 Make_Reference
(Loc
,
5455 Prefix
=> Relocate_Node
(Func_Call
));
5457 Insert_After_And_Analyze
(Ptr_Typ_Decl
,
5458 Make_Object_Declaration
(Loc
,
5459 Defining_Identifier
=> Def_Id
,
5460 Object_Definition
=> New_Reference_To
(Ref_Type
, Loc
),
5461 Expression
=> New_Expr
));
5463 Rewrite
(Assign
, Make_Null_Statement
(Loc
));
5464 end Make_Build_In_Place_Call_In_Assignment
;
5466 ----------------------------------------------------
5467 -- Make_Build_In_Place_Call_In_Object_Declaration --
5468 ----------------------------------------------------
5470 procedure Make_Build_In_Place_Call_In_Object_Declaration
5471 (Object_Decl
: Node_Id
;
5472 Function_Call
: Node_Id
)
5475 Obj_Def_Id
: constant Entity_Id
:=
5476 Defining_Identifier
(Object_Decl
);
5478 Func_Call
: Node_Id
:= Function_Call
;
5479 Function_Id
: Entity_Id
;
5480 Result_Subt
: Entity_Id
;
5481 Caller_Object
: Node_Id
;
5482 Call_Deref
: Node_Id
;
5483 Ref_Type
: Entity_Id
;
5484 Ptr_Typ_Decl
: Node_Id
;
5487 Enclosing_Func
: Entity_Id
;
5488 Pass_Caller_Acc
: Boolean := False;
5491 -- Step past qualification or unchecked conversion (the latter can occur
5492 -- in cases of calls to 'Input).
5494 if Nkind
(Func_Call
) = N_Qualified_Expression
5495 or else Nkind
(Func_Call
) = N_Unchecked_Type_Conversion
5497 Func_Call
:= Expression
(Func_Call
);
5500 -- If the call has already been processed to add build-in-place actuals
5501 -- then return. This should not normally occur in an object declaration,
5502 -- but we add the protection as a defensive measure.
5504 if Is_Expanded_Build_In_Place_Call
(Func_Call
) then
5508 -- Mark the call as processed as a build-in-place call
5510 Set_Is_Expanded_Build_In_Place_Call
(Func_Call
);
5512 Loc
:= Sloc
(Function_Call
);
5514 if Is_Entity_Name
(Name
(Func_Call
)) then
5515 Function_Id
:= Entity
(Name
(Func_Call
));
5517 elsif Nkind
(Name
(Func_Call
)) = N_Explicit_Dereference
then
5518 Function_Id
:= Etype
(Name
(Func_Call
));
5521 raise Program_Error
;
5524 Result_Subt
:= Etype
(Function_Id
);
5526 -- In the constrained case, add an implicit actual to the function call
5527 -- that provides access to the declared object. An unchecked conversion
5528 -- to the (specific) result type of the function is inserted to handle
5529 -- the case where the object is declared with a class-wide type.
5531 if Is_Constrained
(Underlying_Type
(Result_Subt
)) then
5533 Make_Unchecked_Type_Conversion
(Loc
,
5534 Subtype_Mark
=> New_Reference_To
(Result_Subt
, Loc
),
5535 Expression
=> New_Reference_To
(Obj_Def_Id
, Loc
));
5537 -- When the function has a controlling result, an allocation-form
5538 -- parameter must be passed indicating that the caller is allocating
5539 -- the result object. This is needed because such a function can be
5540 -- called as a dispatching operation and must be treated similarly
5541 -- to functions with unconstrained result subtypes.
5543 Add_Alloc_Form_Actual_To_Build_In_Place_Call
5544 (Func_Call
, Function_Id
, Alloc_Form
=> Caller_Allocation
);
5546 -- If the function's result subtype is unconstrained and the object is
5547 -- a return object of an enclosing build-in-place function, then the
5548 -- implicit build-in-place parameters of the enclosing function must be
5549 -- passed along to the called function.
5551 elsif Nkind
(Parent
(Object_Decl
)) = N_Extended_Return_Statement
then
5552 Pass_Caller_Acc
:= True;
5554 Enclosing_Func
:= Enclosing_Subprogram
(Obj_Def_Id
);
5556 -- If the enclosing function has a constrained result type, then
5557 -- caller allocation will be used.
5559 if Is_Constrained
(Etype
(Enclosing_Func
)) then
5560 Add_Alloc_Form_Actual_To_Build_In_Place_Call
5561 (Func_Call
, Function_Id
, Alloc_Form
=> Caller_Allocation
);
5563 -- Otherwise, when the enclosing function has an unconstrained result
5564 -- type, the BIP_Alloc_Form formal of the enclosing function must be
5565 -- passed along to the callee.
5568 Add_Alloc_Form_Actual_To_Build_In_Place_Call
5573 (Build_In_Place_Formal
(Enclosing_Func
, BIP_Alloc_Form
),
5577 -- Retrieve the BIPacc formal from the enclosing function and convert
5578 -- it to the access type of the callee's BIP_Object_Access formal.
5581 Make_Unchecked_Type_Conversion
(Loc
,
5585 (Build_In_Place_Formal
(Function_Id
, BIP_Object_Access
)),
5589 (Build_In_Place_Formal
(Enclosing_Func
, BIP_Object_Access
),
5592 -- In other unconstrained cases, pass an indication to do the allocation
5593 -- on the secondary stack and set Caller_Object to Empty so that a null
5594 -- value will be passed for the caller's object address. A transient
5595 -- scope is established to ensure eventual cleanup of the result.
5598 Add_Alloc_Form_Actual_To_Build_In_Place_Call
5601 Alloc_Form
=> Secondary_Stack
);
5602 Caller_Object
:= Empty
;
5604 Establish_Transient_Scope
(Object_Decl
, Sec_Stack
=> True);
5607 Add_Final_List_Actual_To_Build_In_Place_Call
5608 (Func_Call
, Function_Id
, Acc_Type
=> Empty
);
5610 if Nkind
(Parent
(Object_Decl
)) = N_Extended_Return_Statement
5611 and then Has_Task
(Result_Subt
)
5613 Enclosing_Func
:= Enclosing_Subprogram
(Obj_Def_Id
);
5615 -- Here we're passing along the master that was passed in to this
5618 Add_Task_Actuals_To_Build_In_Place_Call
5619 (Func_Call
, Function_Id
,
5622 (Build_In_Place_Formal
(Enclosing_Func
, BIP_Master
), Loc
));
5625 Add_Task_Actuals_To_Build_In_Place_Call
5626 (Func_Call
, Function_Id
, Make_Identifier
(Loc
, Name_uMaster
));
5629 Add_Access_Actual_To_Build_In_Place_Call
5630 (Func_Call
, Function_Id
, Caller_Object
, Is_Access
=> Pass_Caller_Acc
);
5632 -- Create an access type designating the function's result subtype
5635 Make_Defining_Identifier
(Loc
, New_Internal_Name
('A'));
5638 Make_Full_Type_Declaration
(Loc
,
5639 Defining_Identifier
=> Ref_Type
,
5641 Make_Access_To_Object_Definition
(Loc
,
5642 All_Present
=> True,
5643 Subtype_Indication
=>
5644 New_Reference_To
(Result_Subt
, Loc
)));
5646 -- The access type and its accompanying object must be inserted after
5647 -- the object declaration in the constrained case, so that the function
5648 -- call can be passed access to the object. In the unconstrained case,
5649 -- the access type and object must be inserted before the object, since
5650 -- the object declaration is rewritten to be a renaming of a dereference
5651 -- of the access object.
5653 if Is_Constrained
(Underlying_Type
(Result_Subt
)) then
5654 Insert_After_And_Analyze
(Object_Decl
, Ptr_Typ_Decl
);
5656 Insert_Before_And_Analyze
(Object_Decl
, Ptr_Typ_Decl
);
5659 -- Finally, create an access object initialized to a reference to the
5663 Make_Defining_Identifier
(Loc
,
5664 Chars
=> New_Internal_Name
('R'));
5665 Set_Etype
(Def_Id
, Ref_Type
);
5668 Make_Reference
(Loc
,
5669 Prefix
=> Relocate_Node
(Func_Call
));
5671 Insert_After_And_Analyze
(Ptr_Typ_Decl
,
5672 Make_Object_Declaration
(Loc
,
5673 Defining_Identifier
=> Def_Id
,
5674 Object_Definition
=> New_Reference_To
(Ref_Type
, Loc
),
5675 Expression
=> New_Expr
));
5677 if Is_Constrained
(Underlying_Type
(Result_Subt
)) then
5678 Set_Expression
(Object_Decl
, Empty
);
5679 Set_No_Initialization
(Object_Decl
);
5681 -- In case of an unconstrained result subtype, rewrite the object
5682 -- declaration as an object renaming where the renamed object is a
5683 -- dereference of <function_Call>'reference:
5685 -- Obj : Subt renames <function_call>'Ref.all;
5689 Make_Explicit_Dereference
(Loc
,
5690 Prefix
=> New_Reference_To
(Def_Id
, Loc
));
5692 Rewrite
(Object_Decl
,
5693 Make_Object_Renaming_Declaration
(Loc
,
5694 Defining_Identifier
=> Make_Defining_Identifier
(Loc
,
5695 New_Internal_Name
('D')),
5696 Access_Definition
=> Empty
,
5697 Subtype_Mark
=> New_Occurrence_Of
(Result_Subt
, Loc
),
5698 Name
=> Call_Deref
));
5700 Set_Renamed_Object
(Defining_Identifier
(Object_Decl
), Call_Deref
);
5702 Analyze
(Object_Decl
);
5704 -- Replace the internal identifier of the renaming declaration's
5705 -- entity with identifier of the original object entity. We also have
5706 -- to exchange the entities containing their defining identifiers to
5707 -- ensure the correct replacement of the object declaration by the
5708 -- object renaming declaration to avoid homograph conflicts (since
5709 -- the object declaration's defining identifier was already entered
5710 -- in current scope). The Next_Entity links of the two entities also
5711 -- have to be swapped since the entities are part of the return
5712 -- scope's entity list and the list structure would otherwise be
5716 Renaming_Def_Id
: constant Entity_Id
:=
5717 Defining_Identifier
(Object_Decl
);
5718 Next_Entity_Temp
: constant Entity_Id
:=
5719 Next_Entity
(Renaming_Def_Id
);
5721 Set_Chars
(Renaming_Def_Id
, Chars
(Obj_Def_Id
));
5723 -- Swap next entity links in preparation for exchanging entities
5725 Set_Next_Entity
(Renaming_Def_Id
, Next_Entity
(Obj_Def_Id
));
5726 Set_Next_Entity
(Obj_Def_Id
, Next_Entity_Temp
);
5728 Exchange_Entities
(Renaming_Def_Id
, Obj_Def_Id
);
5732 -- If the object entity has a class-wide Etype, then we need to change
5733 -- it to the result subtype of the function call, because otherwise the
5734 -- object will be class-wide without an explicit intialization and won't
5735 -- be allocated properly by the back end. It seems unclean to make such
5736 -- a revision to the type at this point, and we should try to improve
5737 -- this treatment when build-in-place functions with class-wide results
5738 -- are implemented. ???
5740 if Is_Class_Wide_Type
(Etype
(Defining_Identifier
(Object_Decl
))) then
5741 Set_Etype
(Defining_Identifier
(Object_Decl
), Result_Subt
);
5743 end Make_Build_In_Place_Call_In_Object_Declaration
;