1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2002, 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 2, 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 COPYING. If not, write --
19 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
20 -- MA 02111-1307, USA. --
22 -- GNAT was originally developed by the GNAT team at New York University. --
23 -- Extensive contributions were provided by Ada Core Technologies Inc. --
25 ------------------------------------------------------------------------------
27 with Atree
; use Atree
;
28 with Checks
; use Checks
;
29 with Debug
; use Debug
;
30 with Einfo
; use Einfo
;
31 with Errout
; use Errout
;
32 with Elists
; use Elists
;
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_Ch11
; use Exp_Ch11
;
38 with Exp_Dbug
; use Exp_Dbug
;
39 with Exp_Disp
; use Exp_Disp
;
40 with Exp_Dist
; use Exp_Dist
;
41 with Exp_Intr
; use Exp_Intr
;
42 with Exp_Pakd
; use Exp_Pakd
;
43 with Exp_Tss
; use Exp_Tss
;
44 with Exp_Util
; use Exp_Util
;
45 with Freeze
; use Freeze
;
46 with Hostparm
; use Hostparm
;
47 with Inline
; use Inline
;
49 with Nlists
; use Nlists
;
50 with Nmake
; use Nmake
;
52 with Restrict
; use Restrict
;
53 with Rtsfind
; use Rtsfind
;
55 with Sem_Ch6
; use Sem_Ch6
;
56 with Sem_Ch8
; use Sem_Ch8
;
57 with Sem_Ch12
; use Sem_Ch12
;
58 with Sem_Ch13
; use Sem_Ch13
;
59 with Sem_Disp
; use Sem_Disp
;
60 with Sem_Dist
; use Sem_Dist
;
61 with Sem_Res
; use Sem_Res
;
62 with Sem_Util
; use Sem_Util
;
63 with Sinfo
; use Sinfo
;
64 with Snames
; use Snames
;
65 with Stand
; use Stand
;
66 with Tbuild
; use Tbuild
;
67 with Uintp
; use Uintp
;
68 with Validsw
; use Validsw
;
70 package body Exp_Ch6
is
72 -----------------------
73 -- Local Subprograms --
74 -----------------------
76 procedure Check_Overriding_Operation
(Subp
: Entity_Id
);
77 -- Subp is a dispatching operation. Check whether it may override an
78 -- inherited private operation, in which case its DT entry is that of
79 -- the hidden operation, not the one it may have received earlier.
80 -- This must be done before emitting the code to set the corresponding
81 -- DT to the address of the subprogram. The actual placement of Subp in
82 -- the proper place in the list of primitive operations is done in
83 -- Declare_Inherited_Private_Subprograms, which also has to deal with
84 -- implicit operations. This duplication is unavoidable for now???
86 procedure Detect_Infinite_Recursion
(N
: Node_Id
; Spec
: Entity_Id
);
87 -- This procedure is called only if the subprogram body N, whose spec
88 -- has the given entity Spec, contains a parameterless recursive call.
89 -- It attempts to generate runtime code to detect if this a case of
90 -- infinite recursion.
92 -- The body is scanned to determine dependencies. If the only external
93 -- dependencies are on a small set of scalar variables, then the values
94 -- of these variables are captured on entry to the subprogram, and if
95 -- the values are not changed for the call, we know immediately that
96 -- we have an infinite recursion.
98 procedure Expand_Actuals
(N
: Node_Id
; Subp
: Entity_Id
);
99 -- For each actual of an in-out parameter which is a numeric conversion
100 -- of the form T(A), where A denotes a variable, we insert the declaration:
104 -- prior to the call. Then we replace the actual with a reference to Temp,
105 -- and append the assignment:
109 -- after the call. Here T' is the actual type of variable A.
110 -- For out parameters, the initial declaration has no expression.
111 -- If A is not an entity name, we generate instead:
113 -- Var : T' renames A;
114 -- Temp : T := Var; -- omitting expression for out parameter.
118 -- For other in-out parameters, we emit the required constraint checks
119 -- before and/or after the call.
121 -- For all parameter modes, actuals that denote components and slices
122 -- of packed arrays are expanded into suitable temporaries.
124 procedure Expand_Inlined_Call
127 Orig_Subp
: Entity_Id
);
128 -- If called subprogram can be inlined by the front-end, retrieve the
129 -- analyzed body, replace formals with actuals and expand call in place.
130 -- Generate thunks for actuals that are expressions, and insert the
131 -- corresponding constant declarations before the call. If the original
132 -- call is to a derived operation, the return type is the one of the
133 -- derived operation, but the body is that of the original, so return
134 -- expressions in the body must be converted to the desired type (which
135 -- is simply not noted in the tree without inline expansion).
137 function Expand_Protected_Object_Reference
142 procedure Expand_Protected_Subprogram_Call
146 -- A call to a protected subprogram within the protected object may appear
147 -- as a regular call. The list of actuals must be expanded to contain a
148 -- reference to the object itself, and the call becomes a call to the
149 -- corresponding protected subprogram.
151 --------------------------------
152 -- Check_Overriding_Operation --
153 --------------------------------
155 procedure Check_Overriding_Operation
(Subp
: Entity_Id
) is
156 Typ
: constant Entity_Id
:= Find_Dispatching_Type
(Subp
);
157 Op_List
: constant Elist_Id
:= Primitive_Operations
(Typ
);
163 if Is_Derived_Type
(Typ
)
164 and then not Is_Private_Type
(Typ
)
165 and then In_Open_Scopes
(Scope
(Etype
(Typ
)))
166 and then Typ
= Base_Type
(Typ
)
168 -- Subp overrides an inherited private operation if there is
169 -- an inherited operation with a different name than Subp (see
170 -- Derive_Subprogram) whose Alias is a hidden subprogram with
171 -- the same name as Subp.
173 Op_Elmt
:= First_Elmt
(Op_List
);
174 while Present
(Op_Elmt
) loop
175 Prim_Op
:= Node
(Op_Elmt
);
176 Par_Op
:= Alias
(Prim_Op
);
179 and then not Comes_From_Source
(Prim_Op
)
180 and then Chars
(Prim_Op
) /= Chars
(Par_Op
)
181 and then Chars
(Par_Op
) = Chars
(Subp
)
182 and then Is_Hidden
(Par_Op
)
183 and then Type_Conformant
(Prim_Op
, Subp
)
185 Set_DT_Position
(Subp
, DT_Position
(Prim_Op
));
191 end Check_Overriding_Operation
;
193 -------------------------------
194 -- Detect_Infinite_Recursion --
195 -------------------------------
197 procedure Detect_Infinite_Recursion
(N
: Node_Id
; Spec
: Entity_Id
) is
198 Loc
: constant Source_Ptr
:= Sloc
(N
);
200 Var_List
: Elist_Id
:= New_Elmt_List
;
201 -- List of globals referenced by body of procedure
203 Call_List
: Elist_Id
:= New_Elmt_List
;
204 -- List of recursive calls in body of procedure
206 Shad_List
: Elist_Id
:= New_Elmt_List
;
207 -- List of entity id's for entities created to capture the
208 -- value of referenced globals on entry to the procedure.
210 Scop
: constant Uint
:= Scope_Depth
(Spec
);
211 -- This is used to record the scope depth of the current
212 -- procedure, so that we can identify global references.
214 Max_Vars
: constant := 4;
215 -- Do not test more than four global variables
217 Count_Vars
: Natural := 0;
218 -- Count variables found so far
230 function Process
(Nod
: Node_Id
) return Traverse_Result
;
231 -- Function to traverse the subprogram body (using Traverse_Func)
237 function Process
(Nod
: Node_Id
) return Traverse_Result
is
241 if Nkind
(Nod
) = N_Procedure_Call_Statement
then
243 -- Case of one of the detected recursive calls
245 if Is_Entity_Name
(Name
(Nod
))
246 and then Has_Recursive_Call
(Entity
(Name
(Nod
)))
247 and then Entity
(Name
(Nod
)) = Spec
249 Append_Elmt
(Nod
, Call_List
);
252 -- Any other procedure call may have side effects
258 -- A call to a pure function can always be ignored
260 elsif Nkind
(Nod
) = N_Function_Call
261 and then Is_Entity_Name
(Name
(Nod
))
262 and then Is_Pure
(Entity
(Name
(Nod
)))
266 -- Case of an identifier reference
268 elsif Nkind
(Nod
) = N_Identifier
then
271 -- If no entity, then ignore the reference
273 -- Not clear why this can happen. To investigate, remove this
274 -- test and look at the crash that occurs here in 3401-004 ???
279 -- Ignore entities with no Scope, again not clear how this
280 -- can happen, to investigate, look at 4108-008 ???
282 elsif No
(Scope
(Ent
)) then
285 -- Ignore the reference if not to a more global object
287 elsif Scope_Depth
(Scope
(Ent
)) >= Scop
then
290 -- References to types, exceptions and constants are always OK
293 or else Ekind
(Ent
) = E_Exception
294 or else Ekind
(Ent
) = E_Constant
298 -- If other than a non-volatile scalar variable, we have some
299 -- kind of global reference (e.g. to a function) that we cannot
300 -- deal with so we forget the attempt.
302 elsif Ekind
(Ent
) /= E_Variable
303 or else not Is_Scalar_Type
(Etype
(Ent
))
304 or else Is_Volatile
(Ent
)
308 -- Otherwise we have a reference to a global scalar
311 -- Loop through global entities already detected
313 Elm
:= First_Elmt
(Var_List
);
315 -- If not detected before, record this new global reference
318 Count_Vars
:= Count_Vars
+ 1;
320 if Count_Vars
<= Max_Vars
then
321 Append_Elmt
(Entity
(Nod
), Var_List
);
328 -- If recorded before, ignore
330 elsif Node
(Elm
) = Entity
(Nod
) then
333 -- Otherwise keep looking
343 -- For all other node kinds, recursively visit syntactic children
350 function Traverse_Body
is new Traverse_Func
;
352 -- Start of processing for Detect_Infinite_Recursion
355 -- Do not attempt detection in No_Implicit_Conditional mode,
356 -- since we won't be able to generate the code to handle the
357 -- recursion in any case.
359 if Restrictions
(No_Implicit_Conditionals
) then
363 -- Otherwise do traversal and quit if we get abandon signal
365 if Traverse_Body
(N
) = Abandon
then
368 -- We must have a call, since Has_Recursive_Call was set. If not
369 -- just ignore (this is only an error check, so if we have a funny
370 -- situation, due to bugs or errors, we do not want to bomb!)
372 elsif Is_Empty_Elmt_List
(Call_List
) then
376 -- Here is the case where we detect recursion at compile time
378 -- Push our current scope for analyzing the declarations and
379 -- code that we will insert for the checking.
383 -- This loop builds temporary variables for each of the
384 -- referenced globals, so that at the end of the loop the
385 -- list Shad_List contains these temporaries in one-to-one
386 -- correspondence with the elements in Var_List.
389 Elm
:= First_Elmt
(Var_List
);
390 while Present
(Elm
) loop
393 Make_Defining_Identifier
(Loc
,
394 Chars
=> New_Internal_Name
('S'));
395 Append_Elmt
(Ent
, Shad_List
);
397 -- Insert a declaration for this temporary at the start of
398 -- the declarations for the procedure. The temporaries are
399 -- declared as constant objects initialized to the current
400 -- values of the corresponding temporaries.
403 Make_Object_Declaration
(Loc
,
404 Defining_Identifier
=> Ent
,
405 Object_Definition
=> New_Occurrence_Of
(Etype
(Var
), Loc
),
406 Constant_Present
=> True,
407 Expression
=> New_Occurrence_Of
(Var
, Loc
));
410 Prepend
(Decl
, Declarations
(N
));
412 Insert_After
(Last
, Decl
);
420 -- Loop through calls
422 Call
:= First_Elmt
(Call_List
);
423 while Present
(Call
) loop
425 -- Build a predicate expression of the form
428 -- and then global1 = temp1
429 -- and then global2 = temp2
432 -- This predicate determines if any of the global values
433 -- referenced by the procedure have changed since the
434 -- current call, if not an infinite recursion is assured.
436 Test
:= New_Occurrence_Of
(Standard_True
, Loc
);
438 Elm1
:= First_Elmt
(Var_List
);
439 Elm2
:= First_Elmt
(Shad_List
);
440 while Present
(Elm1
) loop
446 Left_Opnd
=> New_Occurrence_Of
(Node
(Elm1
), Loc
),
447 Right_Opnd
=> New_Occurrence_Of
(Node
(Elm2
), Loc
)));
453 -- Now we replace the call with the sequence
455 -- if no-changes (see above) then
456 -- raise Storage_Error;
461 Rewrite
(Node
(Call
),
462 Make_If_Statement
(Loc
,
464 Then_Statements
=> New_List
(
465 Make_Raise_Storage_Error
(Loc
,
466 Reason
=> SE_Infinite_Recursion
)),
468 Else_Statements
=> New_List
(
469 Relocate_Node
(Node
(Call
)))));
471 Analyze
(Node
(Call
));
476 -- Remove temporary scope stack entry used for analysis
479 end Detect_Infinite_Recursion
;
485 procedure Expand_Actuals
(N
: Node_Id
; Subp
: Entity_Id
) is
486 Loc
: constant Source_Ptr
:= Sloc
(N
);
491 E_Formal
: Entity_Id
;
493 procedure Add_Call_By_Copy_Code
;
494 -- For In and In-Out parameters, where the parameter must be passed
495 -- by copy, this routine generates a temporary variable into which
496 -- the actual is copied, and then passes this as the parameter. This
497 -- routine also takes care of any constraint checks required for the
498 -- type conversion case (on both the way in and the way out).
500 procedure Add_Packed_Call_By_Copy_Code
;
501 -- This is used when the actual involves a reference to an element
502 -- of a packed array, where we can appropriately use a simpler
503 -- approach than the full call by copy code. We just copy the value
504 -- in and out of an appropriate temporary.
506 procedure Check_Fortran_Logical
;
507 -- A value of type Logical that is passed through a formal parameter
508 -- must be normalized because .TRUE. usually does not have the same
509 -- representation as True. We assume that .FALSE. = False = 0.
510 -- What about functions that return a logical type ???
512 function Make_Var
(Actual
: Node_Id
) return Entity_Id
;
513 -- Returns an entity that refers to the given actual parameter,
514 -- Actual (not including any type conversion). If Actual is an
515 -- entity name, then this entity is returned unchanged, otherwise
516 -- a renaming is created to provide an entity for the actual.
518 procedure Reset_Packed_Prefix
;
519 -- The expansion of a packed array component reference is delayed in
520 -- the context of a call. Now we need to complete the expansion, so we
521 -- unmark the analyzed bits in all prefixes.
523 ---------------------------
524 -- Add_Call_By_Copy_Code --
525 ---------------------------
527 procedure Add_Call_By_Copy_Code
is
536 Temp
:= Make_Defining_Identifier
(Loc
, New_Internal_Name
('T'));
538 if Nkind
(Actual
) = N_Type_Conversion
then
539 V_Typ
:= Etype
(Expression
(Actual
));
540 Var
:= Make_Var
(Expression
(Actual
));
541 Crep
:= not Same_Representation
542 (Etype
(Formal
), Etype
(Expression
(Actual
)));
544 V_Typ
:= Etype
(Actual
);
545 Var
:= Make_Var
(Actual
);
549 -- Setup initialization for case of in out parameter, or an out
550 -- parameter where the formal is an unconstrained array (in the
551 -- latter case, we have to pass in an object with bounds).
553 if Ekind
(Formal
) = E_In_Out_Parameter
554 or else (Is_Array_Type
(Etype
(Formal
))
556 not Is_Constrained
(Etype
(Formal
)))
558 if Nkind
(Actual
) = N_Type_Conversion
then
559 if Conversion_OK
(Actual
) then
560 Init
:= OK_Convert_To
561 (Etype
(Formal
), New_Occurrence_Of
(Var
, Loc
));
564 (Etype
(Formal
), New_Occurrence_Of
(Var
, Loc
));
567 Init
:= New_Occurrence_Of
(Var
, Loc
);
570 -- An initialization is created for packed conversions as
571 -- actuals for out parameters to enable Make_Object_Declaration
572 -- to determine the proper subtype for N_Node. Note that this
573 -- is wasteful because the extra copying on the call side is
574 -- not required for such out parameters. ???
576 elsif Ekind
(Formal
) = E_Out_Parameter
577 and then Nkind
(Actual
) = N_Type_Conversion
578 and then (Is_Bit_Packed_Array
(Etype
(Formal
))
580 Is_Bit_Packed_Array
(Etype
(Expression
(Actual
))))
582 if Conversion_OK
(Actual
) then
584 OK_Convert_To
(Etype
(Formal
), New_Occurrence_Of
(Var
, Loc
));
587 Convert_To
(Etype
(Formal
), New_Occurrence_Of
(Var
, Loc
));
594 Make_Object_Declaration
(Loc
,
595 Defining_Identifier
=> Temp
,
597 New_Occurrence_Of
(Etype
(Formal
), Loc
),
599 Set_Assignment_OK
(N_Node
);
600 Insert_Action
(N
, N_Node
);
602 -- Now, normally the deal here is that we use the defining
603 -- identifier created by that object declaration. There is
604 -- one exception to this. In the change of representation case
605 -- the above declaration will end up looking like:
607 -- temp : type := identifier;
609 -- And in this case we might as well use the identifier directly
610 -- and eliminate the temporary. Note that the analysis of the
611 -- declaration was not a waste of time in that case, since it is
612 -- what generated the necessary change of representation code. If
613 -- the change of representation introduced additional code, as in
614 -- a fixed-integer conversion, the expression is not an identifier
618 and then Present
(Expression
(N_Node
))
619 and then Is_Entity_Name
(Expression
(N_Node
))
621 Temp
:= Entity
(Expression
(N_Node
));
622 Rewrite
(N_Node
, Make_Null_Statement
(Loc
));
625 -- If type conversion, use reverse conversion on exit
627 if Nkind
(Actual
) = N_Type_Conversion
then
628 if Conversion_OK
(Actual
) then
629 Expr
:= OK_Convert_To
(V_Typ
, New_Occurrence_Of
(Temp
, Loc
));
631 Expr
:= Convert_To
(V_Typ
, New_Occurrence_Of
(Temp
, Loc
));
634 Expr
:= New_Occurrence_Of
(Temp
, Loc
);
637 Rewrite
(Actual
, New_Reference_To
(Temp
, Loc
));
640 Append_To
(Post_Call
,
641 Make_Assignment_Statement
(Loc
,
642 Name
=> New_Occurrence_Of
(Var
, Loc
),
643 Expression
=> Expr
));
645 Set_Assignment_OK
(Name
(Last
(Post_Call
)));
646 end Add_Call_By_Copy_Code
;
648 ----------------------------------
649 -- Add_Packed_Call_By_Copy_Code --
650 ----------------------------------
652 procedure Add_Packed_Call_By_Copy_Code
is
662 -- Prepare to generate code
664 Temp
:= Make_Defining_Identifier
(Loc
, New_Internal_Name
('T'));
665 Incod
:= Relocate_Node
(Actual
);
666 Outcod
:= New_Copy_Tree
(Incod
);
668 -- Generate declaration of temporary variable, initializing it
669 -- with the input parameter unless we have an OUT variable.
671 if Ekind
(Formal
) = E_Out_Parameter
then
676 Make_Object_Declaration
(Loc
,
677 Defining_Identifier
=> Temp
,
679 New_Occurrence_Of
(Etype
(Formal
), Loc
),
680 Expression
=> Incod
));
682 -- The actual is simply a reference to the temporary
684 Rewrite
(Actual
, New_Occurrence_Of
(Temp
, Loc
));
686 -- Generate copy out if OUT or IN OUT parameter
688 if Ekind
(Formal
) /= E_In_Parameter
then
690 Rhs
:= New_Occurrence_Of
(Temp
, Loc
);
692 -- Deal with conversion
694 if Nkind
(Lhs
) = N_Type_Conversion
then
695 Lhs
:= Expression
(Lhs
);
696 Rhs
:= Convert_To
(Etype
(Actual
), Rhs
);
699 Append_To
(Post_Call
,
700 Make_Assignment_Statement
(Loc
,
704 end Add_Packed_Call_By_Copy_Code
;
706 ---------------------------
707 -- Check_Fortran_Logical --
708 ---------------------------
710 procedure Check_Fortran_Logical
is
711 Logical
: Entity_Id
:= Etype
(Formal
);
714 -- Note: this is very incomplete, e.g. it does not handle arrays
715 -- of logical values. This is really not the right approach at all???)
718 if Convention
(Subp
) = Convention_Fortran
719 and then Root_Type
(Etype
(Formal
)) = Standard_Boolean
720 and then Ekind
(Formal
) /= E_In_Parameter
722 Var
:= Make_Var
(Actual
);
723 Append_To
(Post_Call
,
724 Make_Assignment_Statement
(Loc
,
725 Name
=> New_Occurrence_Of
(Var
, Loc
),
727 Unchecked_Convert_To
(
730 Left_Opnd
=> New_Occurrence_Of
(Var
, Loc
),
732 Unchecked_Convert_To
(
734 New_Occurrence_Of
(Standard_False
, Loc
))))));
736 end Check_Fortran_Logical
;
742 function Make_Var
(Actual
: Node_Id
) return Entity_Id
is
746 if Is_Entity_Name
(Actual
) then
747 return Entity
(Actual
);
750 Var
:= Make_Defining_Identifier
(Loc
, New_Internal_Name
('T'));
753 Make_Object_Renaming_Declaration
(Loc
,
754 Defining_Identifier
=> Var
,
756 New_Occurrence_Of
(Etype
(Actual
), Loc
),
757 Name
=> Relocate_Node
(Actual
));
759 Insert_Action
(N
, N_Node
);
764 -------------------------
765 -- Reset_Packed_Prefix --
766 -------------------------
768 procedure Reset_Packed_Prefix
is
769 Pfx
: Node_Id
:= Actual
;
773 Set_Analyzed
(Pfx
, False);
774 exit when Nkind
(Pfx
) /= N_Selected_Component
775 and then Nkind
(Pfx
) /= N_Indexed_Component
;
778 end Reset_Packed_Prefix
;
780 -- Start of processing for Expand_Actuals
783 Formal
:= First_Formal
(Subp
);
784 Actual
:= First_Actual
(N
);
786 Post_Call
:= New_List
;
788 while Present
(Formal
) loop
789 E_Formal
:= Etype
(Formal
);
791 if Is_Scalar_Type
(E_Formal
)
792 or else Nkind
(Actual
) = N_Slice
794 Check_Fortran_Logical
;
798 elsif Ekind
(Formal
) /= E_Out_Parameter
then
800 -- The unusual case of the current instance of a protected type
801 -- requires special handling. This can only occur in the context
802 -- of a call within the body of a protected operation.
804 if Is_Entity_Name
(Actual
)
805 and then Ekind
(Entity
(Actual
)) = E_Protected_Type
806 and then In_Open_Scopes
(Entity
(Actual
))
808 if Scope
(Subp
) /= Entity
(Actual
) then
809 Error_Msg_N
("operation outside protected type may not "
810 & "call back its protected operations?", Actual
);
814 Expand_Protected_Object_Reference
(N
, Entity
(Actual
)));
817 Apply_Constraint_Check
(Actual
, E_Formal
);
819 -- Out parameter case. No constraint checks on access type
822 elsif Is_Access_Type
(E_Formal
) then
827 elsif Has_Discriminants
(Base_Type
(E_Formal
))
828 or else Has_Non_Null_Base_Init_Proc
(E_Formal
)
830 Apply_Constraint_Check
(Actual
, E_Formal
);
835 Apply_Constraint_Check
(Actual
, Base_Type
(E_Formal
));
838 -- Processing for IN-OUT and OUT parameters
840 if Ekind
(Formal
) /= E_In_Parameter
then
842 -- For type conversions of arrays, apply length/range checks
844 if Is_Array_Type
(E_Formal
)
845 and then Nkind
(Actual
) = N_Type_Conversion
847 if Is_Constrained
(E_Formal
) then
848 Apply_Length_Check
(Expression
(Actual
), E_Formal
);
850 Apply_Range_Check
(Expression
(Actual
), E_Formal
);
854 -- If argument is a type conversion for a type that is passed
855 -- by copy, then we must pass the parameter by copy.
857 if Nkind
(Actual
) = N_Type_Conversion
859 (Is_Numeric_Type
(E_Formal
)
860 or else Is_Access_Type
(E_Formal
)
861 or else Is_Enumeration_Type
(E_Formal
)
862 or else Is_Bit_Packed_Array
(Etype
(Formal
))
863 or else Is_Bit_Packed_Array
(Etype
(Expression
(Actual
)))
865 -- Also pass by copy if change of representation
867 or else not Same_Representation
869 Etype
(Expression
(Actual
))))
871 Add_Call_By_Copy_Code
;
873 -- References to components of bit packed arrays are expanded
874 -- at this point, rather than at the point of analysis of the
875 -- actuals, to handle the expansion of the assignment to
876 -- [in] out parameters.
878 elsif Is_Ref_To_Bit_Packed_Array
(Actual
) then
879 Add_Packed_Call_By_Copy_Code
;
881 -- References to slices of bit packed arrays are expanded
883 elsif Is_Ref_To_Bit_Packed_Slice
(Actual
) then
884 Add_Call_By_Copy_Code
;
886 -- Deal with access types where the actual subtpe and the
887 -- formal subtype are not the same, requiring a check.
889 -- It is necessary to exclude tagged types because of "downward
890 -- conversion" errors and a strange assertion error in namet
891 -- from gnatf in bug 1215-001 ???
893 elsif Is_Access_Type
(E_Formal
)
894 and then not Same_Type
(E_Formal
, Etype
(Actual
))
895 and then not Is_Tagged_Type
(Designated_Type
(E_Formal
))
897 Add_Call_By_Copy_Code
;
899 elsif Is_Entity_Name
(Actual
)
900 and then Is_Volatile
(Entity
(Actual
))
901 and then not Is_Scalar_Type
(Etype
(Entity
(Actual
)))
902 and then not Is_Volatile
(E_Formal
)
904 Add_Call_By_Copy_Code
;
906 elsif Nkind
(Actual
) = N_Indexed_Component
907 and then Is_Entity_Name
(Prefix
(Actual
))
908 and then Has_Volatile_Components
(Entity
(Prefix
(Actual
)))
910 Add_Call_By_Copy_Code
;
913 -- The only processing required for IN parameters is in the packed
914 -- array case, where we expand the indexed component (the circuit
915 -- in Exp_Ch4 deliberately left indexed components appearing as
916 -- actuals untouched, so that the special processing above for
917 -- the OUT and IN OUT cases could be performed. We could make the
918 -- test in Exp_Ch4 more complex and have it detect the parameter
919 -- mode, but it is easier simply to handle all cases here.
921 -- Similarly, we have to expand slices of packed arrays here
924 if Nkind
(Actual
) = N_Indexed_Component
925 and then Is_Packed
(Etype
(Prefix
(Actual
)))
928 Expand_Packed_Element_Reference
(Actual
);
930 elsif Is_Ref_To_Bit_Packed_Array
(Actual
) then
931 Add_Packed_Call_By_Copy_Code
;
933 elsif Is_Ref_To_Bit_Packed_Slice
(Actual
) then
935 Typ
: constant Entity_Id
:= Etype
(Actual
);
937 Ent
: constant Entity_Id
:=
938 Make_Defining_Identifier
(Loc
,
939 Chars
=> New_Internal_Name
('T'));
941 Decl
: constant Node_Id
:=
942 Make_Object_Declaration
(Loc
,
943 Defining_Identifier
=> Ent
,
945 New_Occurrence_Of
(Typ
, Loc
));
948 Set_No_Initialization
(Decl
);
950 Insert_Actions
(N
, New_List
(
952 Make_Assignment_Statement
(Loc
,
953 Name
=> New_Occurrence_Of
(Ent
, Loc
),
954 Expression
=> Relocate_Node
(Actual
))));
957 (Actual
, New_Occurrence_Of
(Ent
, Loc
));
958 Analyze_And_Resolve
(Actual
, Typ
);
963 Next_Formal
(Formal
);
964 Next_Actual
(Actual
);
967 -- Find right place to put post call stuff if it is present
969 if not Is_Empty_List
(Post_Call
) then
971 -- If call is not a list member, it must be the triggering
972 -- statement of a triggering alternative or an entry call
973 -- alternative, and we can add the post call stuff to the
974 -- corresponding statement list.
976 if not Is_List_Member
(N
) then
978 P
: constant Node_Id
:= Parent
(N
);
981 pragma Assert
(Nkind
(P
) = N_Triggering_Alternative
982 or else Nkind
(P
) = N_Entry_Call_Alternative
);
984 if Is_Non_Empty_List
(Statements
(P
)) then
985 Insert_List_Before_And_Analyze
986 (First
(Statements
(P
)), Post_Call
);
988 Set_Statements
(P
, Post_Call
);
992 -- Otherwise, normal case where N is in a statement sequence,
993 -- just put the post-call stuff after the call statement.
996 Insert_Actions_After
(N
, Post_Call
);
1000 -- The call node itself is re-analyzed in Expand_Call.
1008 -- This procedure handles expansion of function calls and procedure call
1009 -- statements (i.e. it serves as the body for Expand_N_Function_Call and
1010 -- Expand_N_Procedure_Call_Statement. Processing for calls includes:
1012 -- Replace call to Raise_Exception by Raise_Exception always if possible
1013 -- Provide values of actuals for all formals in Extra_Formals list
1014 -- Replace "call" to enumeration literal function by literal itself
1015 -- Rewrite call to predefined operator as operator
1016 -- Replace actuals to in-out parameters that are numeric conversions,
1017 -- with explicit assignment to temporaries before and after the call.
1018 -- Remove optional actuals if First_Optional_Parameter specified.
1020 -- Note that the list of actuals has been filled with default expressions
1021 -- during semantic analysis of the call. Only the extra actuals required
1022 -- for the 'Constrained attribute and for accessibility checks are added
1025 procedure Expand_Call
(N
: Node_Id
) is
1026 Loc
: constant Source_Ptr
:= Sloc
(N
);
1027 Remote
: constant Boolean := Is_Remote_Call
(N
);
1029 Orig_Subp
: Entity_Id
:= Empty
;
1030 Parent_Subp
: Entity_Id
;
1031 Parent_Formal
: Entity_Id
;
1034 Prev
: Node_Id
:= Empty
;
1035 Prev_Orig
: Node_Id
;
1037 Extra_Actuals
: List_Id
:= No_List
;
1040 procedure Add_Actual_Parameter
(Insert_Param
: Node_Id
);
1041 -- Adds one entry to the end of the actual parameter list. Used for
1042 -- default parameters and for extra actuals (for Extra_Formals).
1043 -- The argument is an N_Parameter_Association node.
1045 procedure Add_Extra_Actual
(Expr
: Node_Id
; EF
: Entity_Id
);
1046 -- Adds an extra actual to the list of extra actuals. Expr
1047 -- is the expression for the value of the actual, EF is the
1048 -- entity for the extra formal.
1050 function Inherited_From_Formal
(S
: Entity_Id
) return Entity_Id
;
1051 -- Within an instance, a type derived from a non-tagged formal derived
1052 -- type inherits from the original parent, not from the actual. This is
1053 -- tested in 4723-003. The current derivation mechanism has the derived
1054 -- type inherit from the actual, which is only correct outside of the
1055 -- instance. If the subprogram is inherited, we test for this particular
1056 -- case through a convoluted tree traversal before setting the proper
1057 -- subprogram to be called.
1059 --------------------------
1060 -- Add_Actual_Parameter --
1061 --------------------------
1063 procedure Add_Actual_Parameter
(Insert_Param
: Node_Id
) is
1064 Actual_Expr
: constant Node_Id
:=
1065 Explicit_Actual_Parameter
(Insert_Param
);
1068 -- Case of insertion is first named actual
1070 if No
(Prev
) or else
1071 Nkind
(Parent
(Prev
)) /= N_Parameter_Association
1073 Set_Next_Named_Actual
(Insert_Param
, First_Named_Actual
(N
));
1074 Set_First_Named_Actual
(N
, Actual_Expr
);
1077 if not Present
(Parameter_Associations
(N
)) then
1078 Set_Parameter_Associations
(N
, New_List
);
1079 Append
(Insert_Param
, Parameter_Associations
(N
));
1082 Insert_After
(Prev
, Insert_Param
);
1085 -- Case of insertion is not first named actual
1088 Set_Next_Named_Actual
1089 (Insert_Param
, Next_Named_Actual
(Parent
(Prev
)));
1090 Set_Next_Named_Actual
(Parent
(Prev
), Actual_Expr
);
1091 Append
(Insert_Param
, Parameter_Associations
(N
));
1094 Prev
:= Actual_Expr
;
1095 end Add_Actual_Parameter
;
1097 ----------------------
1098 -- Add_Extra_Actual --
1099 ----------------------
1101 procedure Add_Extra_Actual
(Expr
: Node_Id
; EF
: Entity_Id
) is
1102 Loc
: constant Source_Ptr
:= Sloc
(Expr
);
1105 if Extra_Actuals
= No_List
then
1106 Extra_Actuals
:= New_List
;
1107 Set_Parent
(Extra_Actuals
, N
);
1110 Append_To
(Extra_Actuals
,
1111 Make_Parameter_Association
(Loc
,
1112 Explicit_Actual_Parameter
=> Expr
,
1114 Make_Identifier
(Loc
, Chars
(EF
))));
1116 Analyze_And_Resolve
(Expr
, Etype
(EF
));
1118 end Add_Extra_Actual
;
1120 ---------------------------
1121 -- Inherited_From_Formal --
1122 ---------------------------
1124 function Inherited_From_Formal
(S
: Entity_Id
) return Entity_Id
is
1126 Gen_Par
: Entity_Id
;
1127 Gen_Prim
: Elist_Id
;
1132 -- If the operation is inherited, it is attached to the corresponding
1133 -- type derivation. If the parent in the derivation is a generic
1134 -- actual, it is a subtype of the actual, and we have to recover the
1135 -- original derived type declaration to find the proper parent.
1137 if Nkind
(Parent
(S
)) /= N_Full_Type_Declaration
1138 or else not Is_Derived_Type
(Defining_Identifier
(Parent
(S
)))
1139 or else Nkind
(Type_Definition
(Original_Node
(Parent
(S
))))
1140 /= N_Derived_Type_Definition
1147 (Type_Definition
(Original_Node
(Parent
(S
)))));
1149 if Nkind
(Indic
) = N_Subtype_Indication
then
1150 Par
:= Entity
(Subtype_Mark
(Indic
));
1152 Par
:= Entity
(Indic
);
1156 if not Is_Generic_Actual_Type
(Par
)
1157 or else Is_Tagged_Type
(Par
)
1158 or else Nkind
(Parent
(Par
)) /= N_Subtype_Declaration
1159 or else not In_Open_Scopes
(Scope
(Par
))
1160 or else not In_Instance
1165 Gen_Par
:= Generic_Parent_Type
(Parent
(Par
));
1168 Gen_Prim
:= Collect_Primitive_Operations
(Gen_Par
);
1169 Elmt
:= First_Elmt
(Gen_Prim
);
1171 while Present
(Elmt
) loop
1172 if Chars
(Node
(Elmt
)) = Chars
(S
) then
1178 F1
:= First_Formal
(S
);
1179 F2
:= First_Formal
(Node
(Elmt
));
1182 and then Present
(F2
)
1185 if Etype
(F1
) = Etype
(F2
)
1186 or else Etype
(F2
) = Gen_Par
1192 exit; -- not the right subprogram
1204 raise Program_Error
;
1205 end Inherited_From_Formal
;
1207 -- Start of processing for Expand_Call
1210 -- Ignore if previous error
1212 if Nkind
(N
) in N_Has_Etype
and then Etype
(N
) = Any_Type
then
1216 -- Call using access to subprogram with explicit dereference
1218 if Nkind
(Name
(N
)) = N_Explicit_Dereference
then
1219 Subp
:= Etype
(Name
(N
));
1220 Parent_Subp
:= Empty
;
1222 -- Case of call to simple entry, where the Name is a selected component
1223 -- whose prefix is the task, and whose selector name is the entry name
1225 elsif Nkind
(Name
(N
)) = N_Selected_Component
then
1226 Subp
:= Entity
(Selector_Name
(Name
(N
)));
1227 Parent_Subp
:= Empty
;
1229 -- Case of call to member of entry family, where Name is an indexed
1230 -- component, with the prefix being a selected component giving the
1231 -- task and entry family name, and the index being the entry index.
1233 elsif Nkind
(Name
(N
)) = N_Indexed_Component
then
1234 Subp
:= Entity
(Selector_Name
(Prefix
(Name
(N
))));
1235 Parent_Subp
:= Empty
;
1240 Subp
:= Entity
(Name
(N
));
1241 Parent_Subp
:= Alias
(Subp
);
1243 -- Replace call to Raise_Exception by call to Raise_Exception_Always
1244 -- if we can tell that the first parameter cannot possibly be null.
1246 if not Restrictions
(No_Exception_Handlers
)
1247 and then Is_RTE
(Subp
, RE_Raise_Exception
)
1250 FA
: constant Node_Id
:= Original_Node
(First_Actual
(N
));
1253 -- The case we catch is where the first argument is obtained
1254 -- using the Identity attribute (which must always be non-null)
1256 if Nkind
(FA
) = N_Attribute_Reference
1257 and then Attribute_Name
(FA
) = Name_Identity
1259 Subp
:= RTE
(RE_Raise_Exception_Always
);
1260 Set_Entity
(Name
(N
), Subp
);
1265 if Ekind
(Subp
) = E_Entry
then
1266 Parent_Subp
:= Empty
;
1270 -- First step, compute extra actuals, corresponding to any
1271 -- Extra_Formals present. Note that we do not access Extra_Formals
1272 -- directly, instead we simply note the presence of the extra
1273 -- formals as we process the regular formals and collect the
1274 -- corresponding actuals in Extra_Actuals.
1276 Formal
:= First_Formal
(Subp
);
1277 Actual
:= First_Actual
(N
);
1279 while Present
(Formal
) loop
1281 Prev_Orig
:= Original_Node
(Prev
);
1283 -- Create possible extra actual for constrained case. Usually,
1284 -- the extra actual is of the form actual'constrained, but since
1285 -- this attribute is only available for unconstrained records,
1286 -- TRUE is expanded if the type of the formal happens to be
1287 -- constrained (for instance when this procedure is inherited
1288 -- from an unconstrained record to a constrained one) or if the
1289 -- actual has no discriminant (its type is constrained). An
1290 -- exception to this is the case of a private type without
1291 -- discriminants. In this case we pass FALSE because the
1292 -- object has underlying discriminants with defaults.
1294 if Present
(Extra_Constrained
(Formal
)) then
1295 if Ekind
(Etype
(Prev
)) in Private_Kind
1296 and then not Has_Discriminants
(Base_Type
(Etype
(Prev
)))
1299 New_Occurrence_Of
(Standard_False
, Loc
),
1300 Extra_Constrained
(Formal
));
1302 elsif Is_Constrained
(Etype
(Formal
))
1303 or else not Has_Discriminants
(Etype
(Prev
))
1306 New_Occurrence_Of
(Standard_True
, Loc
),
1307 Extra_Constrained
(Formal
));
1310 -- If the actual is a type conversion, then the constrained
1311 -- test applies to the actual, not the target type.
1314 Act_Prev
: Node_Id
:= Prev
;
1317 -- Test for unchecked conversions as well, which can
1318 -- occur as out parameter actuals on calls to stream
1321 if Nkind
(Act_Prev
) = N_Type_Conversion
1322 or else Nkind
(Act_Prev
) = N_Unchecked_Type_Conversion
1324 Act_Prev
:= Expression
(Act_Prev
);
1328 Make_Attribute_Reference
(Sloc
(Prev
),
1329 Prefix
=> Duplicate_Subexpr
(Act_Prev
, Name_Req
=> True),
1330 Attribute_Name
=> Name_Constrained
),
1331 Extra_Constrained
(Formal
));
1336 -- Create possible extra actual for accessibility level
1338 if Present
(Extra_Accessibility
(Formal
)) then
1339 if Is_Entity_Name
(Prev_Orig
) then
1341 -- When passing an access parameter as the actual to another
1342 -- access parameter we need to pass along the actual's own
1343 -- associated access level parameter. This is done is we are
1344 -- in the scope of the formal access parameter (if this is an
1345 -- inlined body the extra formal is irrelevant).
1347 if Ekind
(Entity
(Prev_Orig
)) in Formal_Kind
1348 and then Ekind
(Etype
(Prev_Orig
)) = E_Anonymous_Access_Type
1349 and then In_Open_Scopes
(Scope
(Entity
(Prev_Orig
)))
1352 Parm_Ent
: constant Entity_Id
:= Param_Entity
(Prev_Orig
);
1355 pragma Assert
(Present
(Parm_Ent
));
1357 if Present
(Extra_Accessibility
(Parm_Ent
)) then
1360 (Extra_Accessibility
(Parm_Ent
), Loc
),
1361 Extra_Accessibility
(Formal
));
1363 -- If the actual access parameter does not have an
1364 -- associated extra formal providing its scope level,
1365 -- then treat the actual as having library-level
1370 Make_Integer_Literal
(Loc
,
1371 Intval
=> Scope_Depth
(Standard_Standard
)),
1372 Extra_Accessibility
(Formal
));
1376 -- The actual is a normal access value, so just pass the
1377 -- level of the actual's access type.
1381 Make_Integer_Literal
(Loc
,
1382 Intval
=> Type_Access_Level
(Etype
(Prev_Orig
))),
1383 Extra_Accessibility
(Formal
));
1387 case Nkind
(Prev_Orig
) is
1389 when N_Attribute_Reference
=>
1391 case Get_Attribute_Id
(Attribute_Name
(Prev_Orig
)) is
1393 -- For X'Access, pass on the level of the prefix X
1395 when Attribute_Access
=>
1397 Make_Integer_Literal
(Loc
,
1399 Object_Access_Level
(Prefix
(Prev_Orig
))),
1400 Extra_Accessibility
(Formal
));
1402 -- Treat the unchecked attributes as library-level
1404 when Attribute_Unchecked_Access |
1405 Attribute_Unrestricted_Access
=>
1407 Make_Integer_Literal
(Loc
,
1408 Intval
=> Scope_Depth
(Standard_Standard
)),
1409 Extra_Accessibility
(Formal
));
1411 -- No other cases of attributes returning access
1412 -- values that can be passed to access parameters
1415 raise Program_Error
;
1419 -- For allocators we pass the level of the execution of
1420 -- the called subprogram, which is one greater than the
1421 -- current scope level.
1425 Make_Integer_Literal
(Loc
,
1426 Scope_Depth
(Current_Scope
) + 1),
1427 Extra_Accessibility
(Formal
));
1429 -- For other cases we simply pass the level of the
1430 -- actual's access type.
1434 Make_Integer_Literal
(Loc
,
1435 Intval
=> Type_Access_Level
(Etype
(Prev_Orig
))),
1436 Extra_Accessibility
(Formal
));
1442 -- Perform the check of 4.6(49) that prevents a null value
1443 -- from being passed as an actual to an access parameter.
1444 -- Note that the check is elided in the common cases of
1445 -- passing an access attribute or access parameter as an
1446 -- actual. Also, we currently don't enforce this check for
1447 -- expander-generated actuals and when -gnatdj is set.
1449 if Ekind
(Etype
(Formal
)) /= E_Anonymous_Access_Type
1450 or else Suppress_Accessibility_Checks
(Subp
)
1454 elsif Debug_Flag_J
then
1457 elsif not Comes_From_Source
(Prev
) then
1460 elsif Is_Entity_Name
(Prev
)
1461 and then Ekind
(Etype
(Prev
)) = E_Anonymous_Access_Type
1465 elsif Nkind
(Prev
) = N_Allocator
1466 or else Nkind
(Prev
) = N_Attribute_Reference
1470 -- Suppress null checks when passing to access parameters
1471 -- of Java subprograms. (Should this be done for other
1472 -- foreign conventions as well ???)
1474 elsif Convention
(Subp
) = Convention_Java
then
1480 Left_Opnd
=> Duplicate_Subexpr
(Prev
),
1481 Right_Opnd
=> Make_Null
(Loc
));
1482 Insert_Action
(Prev
,
1483 Make_Raise_Constraint_Error
(Loc
,
1485 Reason
=> CE_Access_Parameter_Is_Null
));
1488 -- Perform appropriate validity checks on parameters
1490 if Validity_Checks_On
then
1492 if Ekind
(Formal
) = E_In_Parameter
1493 and then Validity_Check_In_Params
1495 Ensure_Valid
(Actual
);
1497 elsif Ekind
(Formal
) = E_In_Out_Parameter
1498 and then Validity_Check_In_Out_Params
1500 Ensure_Valid
(Actual
);
1504 -- For IN OUT and OUT parameters, ensure that subscripts are valid
1505 -- since this is a left side reference. We only do this for calls
1506 -- from the source program since we assume that compiler generated
1507 -- calls explicitly generate any required checks. We also need it
1508 -- only if we are doing standard validity checks, since clearly it
1509 -- is not needed if validity checks are off, and in subscript
1510 -- validity checking mode, all indexed components are checked with
1511 -- a call directly from Expand_N_Indexed_Component.
1513 if Comes_From_Source
(N
)
1514 and then Ekind
(Formal
) /= E_In_Parameter
1515 and then Validity_Checks_On
1516 and then Validity_Check_Default
1517 and then not Validity_Check_Subscripts
1519 Check_Valid_Lvalue_Subscripts
(Actual
);
1522 -- If the formal is class wide and the actual is an aggregate, force
1523 -- evaluation so that the back end who does not know about class-wide
1524 -- type, does not generate a temporary of the wrong size.
1526 if not Is_Class_Wide_Type
(Etype
(Formal
)) then
1529 elsif Nkind
(Actual
) = N_Aggregate
1530 or else (Nkind
(Actual
) = N_Qualified_Expression
1531 and then Nkind
(Expression
(Actual
)) = N_Aggregate
)
1533 Force_Evaluation
(Actual
);
1536 -- In a remote call, if the formal is of a class-wide type, check
1537 -- that the actual meets the requirements described in E.4(18).
1540 and then Is_Class_Wide_Type
(Etype
(Formal
))
1542 Insert_Action
(Actual
,
1543 Make_Implicit_If_Statement
(N
,
1546 Get_Remotely_Callable
(Duplicate_Subexpr
(Actual
))),
1547 Then_Statements
=> New_List
(
1548 Make_Procedure_Call_Statement
(Loc
,
1549 New_Occurrence_Of
(RTE
1550 (RE_Raise_Program_Error_For_E_4_18
), Loc
)))));
1553 Next_Actual
(Actual
);
1554 Next_Formal
(Formal
);
1557 -- If we are expanding a rhs of an assignement we need to check if
1558 -- tag propagation is needed. This code belongs theorically in Analyze
1559 -- Assignment but has to be done earlier (bottom-up) because the
1560 -- assignment might be transformed into a declaration for an uncons-
1561 -- trained value, if the expression is classwide.
1563 if Nkind
(N
) = N_Function_Call
1564 and then Is_Tag_Indeterminate
(N
)
1565 and then Is_Entity_Name
(Name
(N
))
1568 Ass
: Node_Id
:= Empty
;
1571 if Nkind
(Parent
(N
)) = N_Assignment_Statement
then
1574 elsif Nkind
(Parent
(N
)) = N_Qualified_Expression
1575 and then Nkind
(Parent
(Parent
(N
))) = N_Assignment_Statement
1577 Ass
:= Parent
(Parent
(N
));
1581 and then Is_Class_Wide_Type
(Etype
(Name
(Ass
)))
1583 Propagate_Tag
(Name
(Ass
), N
);
1589 -- Deals with Dispatch_Call if we still have a call, before expanding
1590 -- extra actuals since this will be done on the re-analysis of the
1591 -- dispatching call. Note that we do not try to shorten the actual
1592 -- list for a dispatching call, it would not make sense to do so.
1593 -- Expansion of dispatching calls is suppressed when Java_VM, because
1594 -- the JVM back end directly handles the generation of dispatching
1595 -- calls and would have to undo any expansion to an indirect call.
1597 if (Nkind
(N
) = N_Function_Call
1598 or else Nkind
(N
) = N_Procedure_Call_Statement
)
1599 and then Present
(Controlling_Argument
(N
))
1600 and then not Java_VM
1602 Expand_Dispatch_Call
(N
);
1605 -- Similarly, expand calls to RCI subprograms on which pragma
1606 -- All_Calls_Remote applies. The rewriting will be reanalyzed
1607 -- later. Do this only when the call comes from source since we do
1608 -- not want such a rewritting to occur in expanded code.
1610 elsif Is_All_Remote_Call
(N
) then
1611 Expand_All_Calls_Remote_Subprogram_Call
(N
);
1613 -- Similarly, do not add extra actuals for an entry call whose entity
1614 -- is a protected procedure, or for an internal protected subprogram
1615 -- call, because it will be rewritten as a protected subprogram call
1616 -- and reanalyzed (see Expand_Protected_Subprogram_Call).
1618 elsif Is_Protected_Type
(Scope
(Subp
))
1619 and then (Ekind
(Subp
) = E_Procedure
1620 or else Ekind
(Subp
) = E_Function
)
1624 -- During that loop we gathered the extra actuals (the ones that
1625 -- correspond to Extra_Formals), so now they can be appended.
1628 while Is_Non_Empty_List
(Extra_Actuals
) loop
1629 Add_Actual_Parameter
(Remove_Head
(Extra_Actuals
));
1633 if Ekind
(Subp
) = E_Procedure
1634 or else (Ekind
(Subp
) = E_Subprogram_Type
1635 and then Etype
(Subp
) = Standard_Void_Type
)
1636 or else Is_Entry
(Subp
)
1638 Expand_Actuals
(N
, Subp
);
1641 -- If the subprogram is a renaming, or if it is inherited, replace it
1642 -- in the call with the name of the actual subprogram being called.
1643 -- If this is a dispatching call, the run-time decides what to call.
1644 -- The Alias attribute does not apply to entries.
1646 if Nkind
(N
) /= N_Entry_Call_Statement
1647 and then No
(Controlling_Argument
(N
))
1648 and then Present
(Parent_Subp
)
1650 if Present
(Inherited_From_Formal
(Subp
)) then
1651 Parent_Subp
:= Inherited_From_Formal
(Subp
);
1653 while Present
(Alias
(Parent_Subp
)) loop
1654 Parent_Subp
:= Alias
(Parent_Subp
);
1658 Set_Entity
(Name
(N
), Parent_Subp
);
1660 if Is_Abstract
(Parent_Subp
)
1661 and then not In_Instance
1664 ("cannot call abstract subprogram &!", Name
(N
), Parent_Subp
);
1667 -- Add an explicit conversion for parameter of the derived type.
1668 -- This is only done for scalar and access in-parameters. Others
1669 -- have been expanded in expand_actuals.
1671 Formal
:= First_Formal
(Subp
);
1672 Parent_Formal
:= First_Formal
(Parent_Subp
);
1673 Actual
:= First_Actual
(N
);
1675 -- It is not clear that conversion is needed for intrinsic
1676 -- subprograms, but it certainly is for those that are user-
1677 -- defined, and that can be inherited on derivation, namely
1678 -- unchecked conversion and deallocation.
1679 -- General case needs study ???
1681 if not Is_Intrinsic_Subprogram
(Parent_Subp
)
1682 or else Is_Generic_Instance
(Parent_Subp
)
1684 while Present
(Formal
) loop
1686 if Etype
(Formal
) /= Etype
(Parent_Formal
)
1687 and then Is_Scalar_Type
(Etype
(Formal
))
1688 and then Ekind
(Formal
) = E_In_Parameter
1689 and then not Raises_Constraint_Error
(Actual
)
1692 OK_Convert_To
(Etype
(Parent_Formal
),
1693 Relocate_Node
(Actual
)));
1696 Resolve
(Actual
, Etype
(Parent_Formal
));
1697 Enable_Range_Check
(Actual
);
1699 elsif Is_Access_Type
(Etype
(Formal
))
1700 and then Base_Type
(Etype
(Parent_Formal
))
1701 /= Base_Type
(Etype
(Actual
))
1703 if Ekind
(Formal
) /= E_In_Parameter
then
1705 Convert_To
(Etype
(Parent_Formal
),
1706 Relocate_Node
(Actual
)));
1709 Resolve
(Actual
, Etype
(Parent_Formal
));
1712 Ekind
(Etype
(Parent_Formal
)) = E_Anonymous_Access_Type
1714 Designated_Type
(Etype
(Parent_Formal
))
1715 /= Designated_Type
(Etype
(Actual
))
1716 and then not Is_Controlling_Formal
(Formal
)
1719 -- This unchecked conversion is not necessary unless
1720 -- inlining is unabled, because in that case the type
1721 -- mismatch may become visible in the body about to be
1725 Unchecked_Convert_To
(Etype
(Parent_Formal
),
1726 Relocate_Node
(Actual
)));
1729 Resolve
(Actual
, Etype
(Parent_Formal
));
1733 Next_Formal
(Formal
);
1734 Next_Formal
(Parent_Formal
);
1735 Next_Actual
(Actual
);
1740 Subp
:= Parent_Subp
;
1743 -- Some more special cases for cases other than explicit dereference
1745 if Nkind
(Name
(N
)) /= N_Explicit_Dereference
then
1747 -- Calls to an enumeration literal are replaced by the literal
1748 -- This case occurs only when we have a call to a function that
1749 -- is a renaming of an enumeration literal. The normal case of
1750 -- a direct reference to an enumeration literal has already been
1751 -- been dealt with by Resolve_Call. If the function is itself
1752 -- inherited (see 7423-001) the literal of the parent type must
1753 -- be explicitly converted to the return type of the function.
1755 if Ekind
(Subp
) = E_Enumeration_Literal
then
1756 if Base_Type
(Etype
(Subp
)) /= Base_Type
(Etype
(N
)) then
1758 (N
, Convert_To
(Etype
(N
), New_Occurrence_Of
(Subp
, Loc
)));
1760 Rewrite
(N
, New_Occurrence_Of
(Subp
, Loc
));
1761 Resolve
(N
, Etype
(N
));
1765 -- Handle case of access to protected subprogram type
1768 if Ekind
(Base_Type
(Etype
(Prefix
(Name
(N
))))) =
1769 E_Access_Protected_Subprogram_Type
1771 -- If this is a call through an access to protected operation,
1772 -- the prefix has the form (object'address, operation'access).
1773 -- Rewrite as a for other protected calls: the object is the
1774 -- first parameter of the list of actuals.
1781 Ptr
: Node_Id
:= Prefix
(Name
(N
));
1782 T
: Entity_Id
:= Equivalent_Type
(Base_Type
(Etype
(Ptr
)));
1783 D_T
: Entity_Id
:= Designated_Type
(Base_Type
(Etype
(Ptr
)));
1786 Obj
:= Make_Selected_Component
(Loc
,
1787 Prefix
=> Unchecked_Convert_To
(T
, Ptr
),
1788 Selector_Name
=> New_Occurrence_Of
(First_Entity
(T
), Loc
));
1790 Nam
:= Make_Selected_Component
(Loc
,
1791 Prefix
=> Unchecked_Convert_To
(T
, Ptr
),
1792 Selector_Name
=> New_Occurrence_Of
(
1793 Next_Entity
(First_Entity
(T
)), Loc
));
1795 Nam
:= Make_Explicit_Dereference
(Loc
, Nam
);
1797 if Present
(Parameter_Associations
(N
)) then
1798 Parm
:= Parameter_Associations
(N
);
1803 Prepend
(Obj
, Parm
);
1805 if Etype
(D_T
) = Standard_Void_Type
then
1806 Call
:= Make_Procedure_Call_Statement
(Loc
,
1808 Parameter_Associations
=> Parm
);
1810 Call
:= Make_Function_Call
(Loc
,
1812 Parameter_Associations
=> Parm
);
1815 Set_First_Named_Actual
(Call
, First_Named_Actual
(N
));
1817 Set_Etype
(Call
, Etype
(D_T
));
1819 -- We do not re-analyze the call to avoid infinite recursion.
1820 -- We analyze separately the prefix and the object, and set
1821 -- the checks on the prefix that would otherwise be emitted
1822 -- when resolving a call.
1826 Apply_Access_Check
(Nam
);
1833 -- If this is a call to an intrinsic subprogram, then perform the
1834 -- appropriate expansion to the corresponding tree node and we
1835 -- are all done (since after that the call is gone!)
1837 if Is_Intrinsic_Subprogram
(Subp
) then
1838 Expand_Intrinsic_Call
(N
, Subp
);
1842 if Ekind
(Subp
) = E_Function
1843 or else Ekind
(Subp
) = E_Procedure
1845 if Is_Inlined
(Subp
) then
1848 Spec
: constant Node_Id
:= Unit_Declaration_Node
(Subp
);
1851 -- Verify that the body to inline has already been seen,
1852 -- and that if the body is in the current unit the inlining
1853 -- does not occur earlier. This avoids order-of-elaboration
1854 -- problems in gigi.
1857 and then Nkind
(Spec
) = N_Subprogram_Declaration
1858 and then Present
(Body_To_Inline
(Spec
))
1859 and then (In_Extended_Main_Code_Unit
(N
)
1860 or else In_Extended_Main_Code_Unit
(Parent
(N
)))
1861 and then (not In_Same_Extended_Unit
1862 (Sloc
(Body_To_Inline
(Spec
)), Loc
)
1864 Earlier_In_Extended_Unit
1865 (Sloc
(Body_To_Inline
(Spec
)), Loc
))
1867 Expand_Inlined_Call
(N
, Subp
, Orig_Subp
);
1870 -- Let the back-end handle it.
1872 Add_Inlined_Body
(Subp
);
1874 if Front_End_Inlining
1875 and then Nkind
(Spec
) = N_Subprogram_Declaration
1876 and then (In_Extended_Main_Code_Unit
(N
))
1877 and then No
(Body_To_Inline
(Spec
))
1878 and then not Has_Completion
(Subp
)
1879 and then In_Same_Extended_Unit
(Sloc
(Spec
), Loc
)
1880 and then Ineffective_Inline_Warnings
1883 ("call cannot be inlined before body is seen?", N
);
1890 -- Check for a protected subprogram. This is either an intra-object
1891 -- call, or a protected function call. Protected procedure calls are
1892 -- rewritten as entry calls and handled accordingly.
1894 Scop
:= Scope
(Subp
);
1896 if Nkind
(N
) /= N_Entry_Call_Statement
1897 and then Is_Protected_Type
(Scop
)
1899 -- If the call is an internal one, it is rewritten as a call to
1900 -- to the corresponding unprotected subprogram.
1902 Expand_Protected_Subprogram_Call
(N
, Subp
, Scop
);
1905 -- Functions returning controlled objects need special attention
1907 if Controlled_Type
(Etype
(Subp
))
1908 and then not Is_Return_By_Reference_Type
(Etype
(Subp
))
1910 Expand_Ctrl_Function_Call
(N
);
1913 -- Test for First_Optional_Parameter, and if so, truncate parameter
1914 -- list if there are optional parameters at the trailing end.
1915 -- Note we never delete procedures for call via a pointer.
1917 if (Ekind
(Subp
) = E_Procedure
or else Ekind
(Subp
) = E_Function
)
1918 and then Present
(First_Optional_Parameter
(Subp
))
1921 Last_Keep_Arg
: Node_Id
;
1924 -- Last_Keep_Arg will hold the last actual that should be
1925 -- retained. If it remains empty at the end, it means that
1926 -- all parameters are optional.
1928 Last_Keep_Arg
:= Empty
;
1930 -- Find first optional parameter, must be present since we
1931 -- checked the validity of the parameter before setting it.
1933 Formal
:= First_Formal
(Subp
);
1934 Actual
:= First_Actual
(N
);
1935 while Formal
/= First_Optional_Parameter
(Subp
) loop
1936 Last_Keep_Arg
:= Actual
;
1937 Next_Formal
(Formal
);
1938 Next_Actual
(Actual
);
1941 -- Now we have Formal and Actual pointing to the first
1942 -- potentially droppable argument. We can drop all the
1943 -- trailing arguments whose actual matches the default.
1944 -- Note that we know that all remaining formals have
1945 -- defaults, because we checked that this requirement
1946 -- was met before setting First_Optional_Parameter.
1948 -- We use Fully_Conformant_Expressions to check for identity
1949 -- between formals and actuals, which may miss some cases, but
1950 -- on the other hand, this is only an optimization (if we fail
1951 -- to truncate a parameter it does not affect functionality).
1952 -- So if the default is 3 and the actual is 1+2, we consider
1953 -- them unequal, which hardly seems worrisome.
1955 while Present
(Formal
) loop
1956 if not Fully_Conformant_Expressions
1957 (Actual
, Default_Value
(Formal
))
1959 Last_Keep_Arg
:= Actual
;
1962 Next_Formal
(Formal
);
1963 Next_Actual
(Actual
);
1966 -- If no arguments, delete entire list, this is the easy case
1968 if No
(Last_Keep_Arg
) then
1969 while Is_Non_Empty_List
(Parameter_Associations
(N
)) loop
1970 Delete_Tree
(Remove_Head
(Parameter_Associations
(N
)));
1973 Set_Parameter_Associations
(N
, No_List
);
1974 Set_First_Named_Actual
(N
, Empty
);
1976 -- Case where at the last retained argument is positional. This
1977 -- is also an easy case, since the retained arguments are already
1978 -- in the right form, and we don't need to worry about the order
1979 -- of arguments that get eliminated.
1981 elsif Is_List_Member
(Last_Keep_Arg
) then
1982 while Present
(Next
(Last_Keep_Arg
)) loop
1983 Delete_Tree
(Remove_Next
(Last_Keep_Arg
));
1986 Set_First_Named_Actual
(N
, Empty
);
1988 -- This is the annoying case where the last retained argument
1989 -- is a named parameter. Since the original arguments are not
1990 -- in declaration order, we may have to delete some fairly
1991 -- random collection of arguments.
2000 -- First step, remove all the named parameters from the
2001 -- list (they are still chained using First_Named_Actual
2002 -- and Next_Named_Actual, so we have not lost them!)
2004 Temp
:= First
(Parameter_Associations
(N
));
2006 -- Case of all parameters named, remove them all
2008 if Nkind
(Temp
) = N_Parameter_Association
then
2009 while Is_Non_Empty_List
(Parameter_Associations
(N
)) loop
2010 Temp
:= Remove_Head
(Parameter_Associations
(N
));
2013 -- Case of mixed positional/named, remove named parameters
2016 while Nkind
(Next
(Temp
)) /= N_Parameter_Association
loop
2020 while Present
(Next
(Temp
)) loop
2021 Junk
:= Remove_Next
(Temp
);
2025 -- Now we loop through the named parameters, till we get
2026 -- to the last one to be retained, adding them to the list.
2027 -- Note that the Next_Named_Actual list does not need to be
2028 -- touched since we are only reordering them on the actual
2029 -- parameter association list.
2031 Passoc
:= Parent
(First_Named_Actual
(N
));
2033 Temp
:= Relocate_Node
(Passoc
);
2035 (Parameter_Associations
(N
), Temp
);
2037 Last_Keep_Arg
= Explicit_Actual_Parameter
(Passoc
);
2038 Passoc
:= Parent
(Next_Named_Actual
(Passoc
));
2041 Set_Next_Named_Actual
(Temp
, Empty
);
2044 Temp
:= Next_Named_Actual
(Passoc
);
2045 exit when No
(Temp
);
2046 Set_Next_Named_Actual
2047 (Passoc
, Next_Named_Actual
(Parent
(Temp
)));
2057 --------------------------
2058 -- Expand_Inlined_Call --
2059 --------------------------
2061 procedure Expand_Inlined_Call
2064 Orig_Subp
: Entity_Id
)
2066 Loc
: constant Source_Ptr
:= Sloc
(N
);
2070 Exit_Lab
: Entity_Id
:= Empty
;
2077 Orig_Bod
: constant Node_Id
:=
2078 Body_To_Inline
(Unit_Declaration_Node
(Subp
));
2079 Ret_Type
: Entity_Id
;
2082 Temp_Typ
: Entity_Id
;
2084 procedure Make_Exit_Label
;
2085 -- Build declaration for exit label to be used in Return statements.
2087 function Process_Formals
(N
: Node_Id
) return Traverse_Result
;
2088 -- Replace occurrence of a formal with the corresponding actual, or
2089 -- the thunk generated for it.
2091 procedure Rewrite_Function_Call
(N
: Node_Id
; Blk
: Node_Id
);
2092 -- If the function body is a single expression, replace call with
2093 -- expression, else insert block appropriately.
2095 procedure Rewrite_Procedure_Call
(N
: Node_Id
; Blk
: Node_Id
);
2096 -- If procedure body has no local variables, inline body without
2097 -- creating block, otherwise rewrite call with block.
2099 ---------------------
2100 -- Make_Exit_Label --
2101 ---------------------
2103 procedure Make_Exit_Label
is
2105 -- Create exit label for subprogram, if one doesn't exist yet.
2107 if No
(Exit_Lab
) then
2108 Lab_Id
:= Make_Identifier
(Loc
, New_Internal_Name
('L'));
2110 Make_Defining_Identifier
(Loc
, Chars
(Lab_Id
)));
2111 Exit_Lab
:= Make_Label
(Loc
, Lab_Id
);
2114 Make_Implicit_Label_Declaration
(Loc
,
2115 Defining_Identifier
=> Entity
(Lab_Id
),
2116 Label_Construct
=> Exit_Lab
);
2118 end Make_Exit_Label
;
2120 ---------------------
2121 -- Process_Formals --
2122 ---------------------
2124 function Process_Formals
(N
: Node_Id
) return Traverse_Result
is
2130 if Is_Entity_Name
(N
)
2131 and then Present
(Entity
(N
))
2136 and then Scope
(E
) = Subp
2138 A
:= Renamed_Object
(E
);
2140 if Is_Entity_Name
(A
) then
2141 Rewrite
(N
, New_Occurrence_Of
(Entity
(A
), Loc
));
2143 elsif Nkind
(A
) = N_Defining_Identifier
then
2144 Rewrite
(N
, New_Occurrence_Of
(A
, Loc
));
2146 else -- numeric literal
2147 Rewrite
(N
, New_Copy
(A
));
2153 elsif Nkind
(N
) = N_Return_Statement
then
2155 if No
(Expression
(N
)) then
2157 Rewrite
(N
, Make_Goto_Statement
(Loc
,
2158 Name
=> New_Copy
(Lab_Id
)));
2161 if Nkind
(Parent
(N
)) = N_Handled_Sequence_Of_Statements
2162 and then Nkind
(Parent
(Parent
(N
))) = N_Subprogram_Body
2164 -- function body is a single expression. No need for
2169 Num_Ret
:= Num_Ret
+ 1;
2173 -- Because of the presence of private types, the views of the
2174 -- expression and the context may be different, so place an
2175 -- unchecked conversion to the context type to avoid spurious
2176 -- errors, eg. when the expression is a numeric literal and
2177 -- the context is private. If the expression is an aggregate,
2178 -- use a qualified expression, because an aggregate is not a
2179 -- legal argument of a conversion.
2181 if Nkind
(Expression
(N
)) = N_Aggregate
2182 or else Nkind
(Expression
(N
)) = N_Null
2185 Make_Qualified_Expression
(Sloc
(N
),
2186 Subtype_Mark
=> New_Occurrence_Of
(Ret_Type
, Sloc
(N
)),
2187 Expression
=> Relocate_Node
(Expression
(N
)));
2190 Unchecked_Convert_To
2191 (Ret_Type
, Relocate_Node
(Expression
(N
)));
2194 if Nkind
(Targ
) = N_Defining_Identifier
then
2196 Make_Assignment_Statement
(Loc
,
2197 Name
=> New_Occurrence_Of
(Targ
, Loc
),
2198 Expression
=> Ret
));
2201 Make_Assignment_Statement
(Loc
,
2202 Name
=> New_Copy
(Targ
),
2203 Expression
=> Ret
));
2206 Set_Assignment_OK
(Name
(N
));
2208 if Present
(Exit_Lab
) then
2210 Make_Goto_Statement
(Loc
,
2211 Name
=> New_Copy
(Lab_Id
)));
2220 end Process_Formals
;
2222 procedure Replace_Formals
is new Traverse_Proc
(Process_Formals
);
2224 ---------------------------
2225 -- Rewrite_Function_Call --
2226 ---------------------------
2228 procedure Rewrite_Function_Call
(N
: Node_Id
; Blk
: Node_Id
) is
2229 HSS
: Node_Id
:= Handled_Statement_Sequence
(Blk
);
2230 Fst
: Node_Id
:= First
(Statements
(HSS
));
2234 -- Optimize simple case: function body is a single return statement,
2235 -- which has been expanded into an assignment.
2237 if Is_Empty_List
(Declarations
(Blk
))
2238 and then Nkind
(Fst
) = N_Assignment_Statement
2239 and then No
(Next
(Fst
))
2242 -- The function call may have been rewritten as the temporary
2243 -- that holds the result of the call, in which case remove the
2244 -- now useless declaration.
2246 if Nkind
(N
) = N_Identifier
2247 and then Nkind
(Parent
(Entity
(N
))) = N_Object_Declaration
2249 Rewrite
(Parent
(Entity
(N
)), Make_Null_Statement
(Loc
));
2252 Rewrite
(N
, Expression
(Fst
));
2254 elsif Nkind
(N
) = N_Identifier
2255 and then Nkind
(Parent
(Entity
(N
))) = N_Object_Declaration
2258 -- The block assigns the result of the call to the temporary.
2260 Insert_After
(Parent
(Entity
(N
)), Blk
);
2262 elsif Nkind
(Parent
(N
)) = N_Assignment_Statement
2263 and then Is_Entity_Name
(Name
(Parent
(N
)))
2266 -- replace assignment with the block.
2268 Rewrite
(Parent
(N
), Blk
);
2270 elsif Nkind
(Parent
(N
)) = N_Object_Declaration
then
2271 Set_Expression
(Parent
(N
), Empty
);
2272 Insert_After
(Parent
(N
), Blk
);
2274 end Rewrite_Function_Call
;
2276 ----------------------------
2277 -- Rewrite_Procedure_Call --
2278 ----------------------------
2280 procedure Rewrite_Procedure_Call
(N
: Node_Id
; Blk
: Node_Id
) is
2281 HSS
: Node_Id
:= Handled_Statement_Sequence
(Blk
);
2284 if Is_Empty_List
(Declarations
(Blk
)) then
2285 Insert_List_After
(N
, Statements
(HSS
));
2286 Rewrite
(N
, Make_Null_Statement
(Loc
));
2290 end Rewrite_Procedure_Call
;
2292 -- Start of processing for Expand_Inlined_Call
2295 if Nkind
(Orig_Bod
) = N_Defining_Identifier
then
2297 -- Subprogram is a renaming_as_body. Calls appearing after the
2298 -- renaming can be replaced with calls to the renamed entity
2299 -- directly, because the subprograms are subtype conformant.
2301 Set_Name
(N
, New_Occurrence_Of
(Orig_Bod
, Loc
));
2305 -- Use generic machinery to copy body of inlined subprogram, as if it
2306 -- were an instantiation, resetting source locations appropriately, so
2307 -- that nested inlined calls appear in the main unit.
2309 Save_Env
(Subp
, Empty
);
2310 Set_Copied_Sloc
(N
, Defining_Entity
(Orig_Bod
));
2313 Copy_Generic_Node
(Orig_Bod
, Empty
, Instantiating
=> True);
2316 Make_Block_Statement
(Loc
,
2317 Declarations
=> Declarations
(Bod
),
2318 Handled_Statement_Sequence
=> Handled_Statement_Sequence
(Bod
));
2320 if No
(Declarations
(Bod
)) then
2321 Set_Declarations
(Blk
, New_List
);
2324 -- If this is a derived function, establish the proper return type.
2326 if Present
(Orig_Subp
)
2327 and then Orig_Subp
/= Subp
2329 Ret_Type
:= Etype
(Orig_Subp
);
2331 Ret_Type
:= Etype
(Subp
);
2334 F
:= First_Formal
(Subp
);
2335 A
:= First_Actual
(N
);
2337 -- Create temporaries for the actuals that are expressions, or that
2338 -- are scalars and require copying to preserve semantics.
2340 while Present
(F
) loop
2342 if Present
(Renamed_Object
(F
)) then
2343 Error_Msg_N
(" cannot inline call to recursive subprogram", N
);
2347 -- If the argument may be a controlling argument in a call within
2348 -- the inlined body, we must preserve its classwide nature to
2349 -- insure that dynamic dispatching take place subsequently.
2350 -- If the formal has a constraint it must be preserved to retain
2351 -- the semantics of the body.
2353 if Is_Class_Wide_Type
(Etype
(F
))
2354 or else (Is_Access_Type
(Etype
(F
))
2356 Is_Class_Wide_Type
(Designated_Type
(Etype
(F
))))
2358 Temp_Typ
:= Etype
(F
);
2360 elsif Base_Type
(Etype
(F
)) = Base_Type
(Etype
(A
))
2361 and then Etype
(F
) /= Base_Type
(Etype
(F
))
2363 Temp_Typ
:= Etype
(F
);
2366 Temp_Typ
:= Etype
(A
);
2369 if (not Is_Entity_Name
(A
)
2370 and then Nkind
(A
) /= N_Integer_Literal
2371 and then Nkind
(A
) /= N_Real_Literal
)
2373 or else Is_Scalar_Type
(Etype
(A
))
2376 Make_Defining_Identifier
(Loc
,
2377 Chars
=> New_Internal_Name
('C'));
2379 -- If the actual for an in/in-out parameter is a view conversion,
2380 -- make it into an unchecked conversion, given that an untagged
2381 -- type conversion is not a proper object for a renaming.
2382 -- In-out conversions that involve real conversions have already
2383 -- been transformed in Expand_Actuals.
2385 if Nkind
(A
) = N_Type_Conversion
2387 (Ekind
(F
) = E_In_Out_Parameter
2388 or else not Is_Tagged_Type
(Etype
(F
)))
2390 New_A
:= Make_Unchecked_Type_Conversion
(Loc
,
2391 Subtype_Mark
=> New_Occurrence_Of
(Etype
(F
), Loc
),
2392 Expression
=> Relocate_Node
(Expression
(A
)));
2394 elsif Etype
(F
) /= Etype
(A
) then
2395 New_A
:= Unchecked_Convert_To
(Etype
(F
), Relocate_Node
(A
));
2396 Temp_Typ
:= Etype
(F
);
2399 New_A
:= Relocate_Node
(A
);
2402 Set_Sloc
(New_A
, Sloc
(N
));
2404 if Ekind
(F
) = E_In_Parameter
2405 and then not Is_Limited_Type
(Etype
(A
))
2408 Make_Object_Declaration
(Loc
,
2409 Defining_Identifier
=> Temp
,
2410 Constant_Present
=> True,
2411 Object_Definition
=> New_Occurrence_Of
(Temp_Typ
, Loc
),
2412 Expression
=> New_A
);
2415 Make_Object_Renaming_Declaration
(Loc
,
2416 Defining_Identifier
=> Temp
,
2417 Subtype_Mark
=> New_Occurrence_Of
(Temp_Typ
, Loc
),
2421 Prepend
(Decl
, Declarations
(Blk
));
2422 Set_Renamed_Object
(F
, Temp
);
2425 if Etype
(F
) /= Etype
(A
) then
2427 (F
, Unchecked_Convert_To
(Etype
(F
), Relocate_Node
(A
)));
2429 Set_Renamed_Object
(F
, A
);
2437 -- Establish target of function call. If context is not assignment or
2438 -- declaration, create a temporary as a target. The declaration for
2439 -- the temporary may be subsequently optimized away if the body is a
2440 -- single expression, or if the left-hand side of the assignment is
2443 if Ekind
(Subp
) = E_Function
then
2444 if Nkind
(Parent
(N
)) = N_Assignment_Statement
2445 and then Is_Entity_Name
(Name
(Parent
(N
)))
2447 Targ
:= Name
(Parent
(N
));
2450 -- Replace call with temporary, and create its declaration.
2453 Make_Defining_Identifier
(Loc
, New_Internal_Name
('C'));
2456 Make_Object_Declaration
(Loc
,
2457 Defining_Identifier
=> Temp
,
2458 Object_Definition
=>
2459 New_Occurrence_Of
(Ret_Type
, Loc
));
2461 Set_No_Initialization
(Decl
);
2462 Insert_Action
(N
, Decl
);
2463 Rewrite
(N
, New_Occurrence_Of
(Temp
, Loc
));
2468 -- Traverse the tree and replace formals with actuals or their thunks.
2469 -- Attach block to tree before analysis and rewriting.
2471 Replace_Formals
(Blk
);
2472 Set_Parent
(Blk
, N
);
2474 if Present
(Exit_Lab
) then
2476 -- If the body was a single expression, the single return statement
2477 -- and the corresponding label are useless.
2481 Nkind
(Last
(Statements
(Handled_Statement_Sequence
(Blk
)))) =
2484 Remove
(Last
(Statements
(Handled_Statement_Sequence
(Blk
))));
2486 Append
(Lab_Decl
, (Declarations
(Blk
)));
2487 Append
(Exit_Lab
, Statements
(Handled_Statement_Sequence
(Blk
)));
2491 -- Analyze Blk with In_Inlined_Body set, to avoid spurious errors on
2492 -- conflicting private views that Gigi would ignore.
2495 I_Flag
: constant Boolean := In_Inlined_Body
;
2498 In_Inlined_Body
:= True;
2500 In_Inlined_Body
:= I_Flag
;
2503 if Ekind
(Subp
) = E_Procedure
then
2504 Rewrite_Procedure_Call
(N
, Blk
);
2506 Rewrite_Function_Call
(N
, Blk
);
2511 -- Cleanup mapping between formals and actuals, for other expansions.
2513 F
:= First_Formal
(Subp
);
2515 while Present
(F
) loop
2516 Set_Renamed_Object
(F
, Empty
);
2519 end Expand_Inlined_Call
;
2521 ----------------------------
2522 -- Expand_N_Function_Call --
2523 ----------------------------
2525 procedure Expand_N_Function_Call
(N
: Node_Id
) is
2526 Typ
: constant Entity_Id
:= Etype
(N
);
2528 function Returned_By_Reference
return Boolean;
2529 -- If the return type is returned through the secondary stack. i.e.
2530 -- by reference, we don't want to create a temporary to force stack
2533 function Returned_By_Reference
return Boolean is
2534 S
: Entity_Id
:= Current_Scope
;
2537 if Is_Return_By_Reference_Type
(Typ
) then
2540 elsif Nkind
(Parent
(N
)) /= N_Return_Statement
then
2543 elsif Requires_Transient_Scope
(Typ
) then
2545 -- Verify that the return type of the enclosing function has
2546 -- the same constrained status as that of the expression.
2548 while Ekind
(S
) /= E_Function
loop
2552 return Is_Constrained
(Typ
) = Is_Constrained
(Etype
(S
));
2556 end Returned_By_Reference
;
2558 -- Start of processing for Expand_N_Function_Call
2561 -- A special check. If stack checking is enabled, and the return type
2562 -- might generate a large temporary, and the call is not the right
2563 -- side of an assignment, then generate an explicit temporary. We do
2564 -- this because otherwise gigi may generate a large temporary on the
2565 -- fly and this can cause trouble with stack checking.
2567 if May_Generate_Large_Temp
(Typ
)
2568 and then Nkind
(Parent
(N
)) /= N_Assignment_Statement
2570 (Nkind
(Parent
(N
)) /= N_Object_Declaration
2571 or else Expression
(Parent
(N
)) /= N
)
2572 and then not Returned_By_Reference
2574 -- Note: it might be thought that it would be OK to use a call to
2575 -- Force_Evaluation here, but that's not good enough, because that
2576 -- results in a 'Reference construct that may still need a temporary.
2579 Loc
: constant Source_Ptr
:= Sloc
(N
);
2580 Temp_Obj
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
,
2581 New_Internal_Name
('F'));
2582 Temp_Typ
: Entity_Id
:= Typ
;
2589 if Is_Tagged_Type
(Typ
)
2590 and then Present
(Controlling_Argument
(N
))
2592 if Nkind
(Parent
(N
)) /= N_Procedure_Call_Statement
2593 and then Nkind
(Parent
(N
)) /= N_Function_Call
2595 -- If this is a tag-indeterminate call, the object must
2598 if Is_Tag_Indeterminate
(N
) then
2599 Temp_Typ
:= Class_Wide_Type
(Typ
);
2603 -- If this is a dispatching call that is itself the
2604 -- controlling argument of an enclosing call, the nominal
2605 -- subtype of the object that replaces it must be classwide,
2606 -- so that dispatching will take place properly. If it is
2607 -- not a controlling argument, the object is not classwide.
2609 Proc
:= Entity
(Name
(Parent
(N
)));
2610 F
:= First_Formal
(Proc
);
2611 A
:= First_Actual
(Parent
(N
));
2618 if Is_Controlling_Formal
(F
) then
2619 Temp_Typ
:= Class_Wide_Type
(Typ
);
2625 Make_Object_Declaration
(Loc
,
2626 Defining_Identifier
=> Temp_Obj
,
2627 Object_Definition
=> New_Occurrence_Of
(Temp_Typ
, Loc
),
2628 Constant_Present
=> True,
2629 Expression
=> Relocate_Node
(N
));
2630 Set_Assignment_OK
(Decl
);
2632 Insert_Actions
(N
, New_List
(Decl
));
2633 Rewrite
(N
, New_Occurrence_Of
(Temp_Obj
, Loc
));
2636 -- Normal case, expand the call
2641 end Expand_N_Function_Call
;
2643 ---------------------------------------
2644 -- Expand_N_Procedure_Call_Statement --
2645 ---------------------------------------
2647 procedure Expand_N_Procedure_Call_Statement
(N
: Node_Id
) is
2650 end Expand_N_Procedure_Call_Statement
;
2652 ------------------------------
2653 -- Expand_N_Subprogram_Body --
2654 ------------------------------
2656 -- Add poll call if ATC polling is enabled
2658 -- Add return statement if last statement in body is not a return
2659 -- statement (this makes things easier on Gigi which does not want
2660 -- to have to handle a missing return).
2662 -- Add call to Activate_Tasks if body is a task activator
2664 -- Deal with possible detection of infinite recursion
2666 -- Eliminate body completely if convention stubbed
2668 -- Encode entity names within body, since we will not need to reference
2669 -- these entities any longer in the front end.
2671 -- Initialize scalar out parameters if Initialize/Normalize_Scalars
2673 -- Reset Pure indication if any parameter has root type System.Address
2675 procedure Expand_N_Subprogram_Body
(N
: Node_Id
) is
2676 Loc
: constant Source_Ptr
:= Sloc
(N
);
2677 H
: constant Node_Id
:= Handled_Statement_Sequence
(N
);
2678 Body_Id
: Entity_Id
;
2679 Spec_Id
: Entity_Id
;
2686 procedure Add_Return
(S
: List_Id
);
2687 -- Append a return statement to the statement sequence S if the last
2688 -- statement is not already a return or a goto statement. Note that
2689 -- the latter test is not critical, it does not matter if we add a
2690 -- few extra returns, since they get eliminated anyway later on.
2696 procedure Add_Return
(S
: List_Id
) is
2697 Last_S
: constant Node_Id
:= Last
(S
);
2698 -- Get original node, in case raise has been rewritten
2701 if not Is_Transfer
(Last_S
) then
2702 Append_To
(S
, Make_Return_Statement
(Sloc
(Last_S
)));
2706 -- Start of processing for Expand_N_Subprogram_Body
2709 -- Set L to either the list of declarations if present, or
2710 -- to the list of statements if no declarations are present.
2711 -- This is used to insert new stuff at the start.
2713 if Is_Non_Empty_List
(Declarations
(N
)) then
2714 L
:= Declarations
(N
);
2716 L
:= Statements
(Handled_Statement_Sequence
(N
));
2719 -- Need poll on entry to subprogram if polling enabled. We only
2720 -- do this for non-empty subprograms, since it does not seem
2721 -- necessary to poll for a dummy null subprogram.
2723 if Is_Non_Empty_List
(L
) then
2724 Generate_Poll_Call
(First
(L
));
2727 -- Find entity for subprogram
2729 Body_Id
:= Defining_Entity
(N
);
2731 if Present
(Corresponding_Spec
(N
)) then
2732 Spec_Id
:= Corresponding_Spec
(N
);
2737 -- If this is a Pure function which has any parameters whose root
2738 -- type is System.Address, reset the Pure indication, since it will
2739 -- likely cause incorrect code to be generated.
2741 if Is_Pure
(Spec_Id
)
2742 and then Is_Subprogram
(Spec_Id
)
2743 and then not Has_Pragma_Pure_Function
(Spec_Id
)
2746 F
: Entity_Id
:= First_Formal
(Spec_Id
);
2749 while Present
(F
) loop
2750 if Is_RTE
(Root_Type
(Etype
(F
)), RE_Address
) then
2751 Set_Is_Pure
(Spec_Id
, False);
2753 if Spec_Id
/= Body_Id
then
2754 Set_Is_Pure
(Body_Id
, False);
2765 -- Initialize any scalar OUT args if Initialize/Normalize_Scalars
2767 if Init_Or_Norm_Scalars
and then Is_Subprogram
(Spec_Id
) then
2769 F
: Entity_Id
:= First_Formal
(Spec_Id
);
2770 V
: constant Boolean := Validity_Checks_On
;
2773 -- We turn off validity checking, since we do not want any
2774 -- check on the initializing value itself (which we know
2775 -- may well be invalid!)
2777 Validity_Checks_On
:= False;
2779 -- Loop through formals
2781 while Present
(F
) loop
2782 if Is_Scalar_Type
(Etype
(F
))
2783 and then Ekind
(F
) = E_Out_Parameter
2785 Insert_Before_And_Analyze
(First
(L
),
2786 Make_Assignment_Statement
(Loc
,
2787 Name
=> New_Occurrence_Of
(F
, Loc
),
2788 Expression
=> Get_Simple_Init_Val
(Etype
(F
), Loc
)));
2794 Validity_Checks_On
:= V
;
2798 -- Clear out statement list for stubbed procedure
2800 if Present
(Corresponding_Spec
(N
)) then
2801 Set_Elaboration_Flag
(N
, Spec_Id
);
2803 if Convention
(Spec_Id
) = Convention_Stubbed
2804 or else Is_Eliminated
(Spec_Id
)
2806 Set_Declarations
(N
, Empty_List
);
2807 Set_Handled_Statement_Sequence
(N
,
2808 Make_Handled_Sequence_Of_Statements
(Loc
,
2809 Statements
=> New_List
(
2810 Make_Null_Statement
(Loc
))));
2815 Scop
:= Scope
(Spec_Id
);
2817 -- Returns_By_Ref flag is normally set when the subprogram is frozen
2818 -- but subprograms with no specs are not frozen
2821 Typ
: constant Entity_Id
:= Etype
(Spec_Id
);
2822 Utyp
: constant Entity_Id
:= Underlying_Type
(Typ
);
2825 if not Acts_As_Spec
(N
)
2826 and then Nkind
(Parent
(Parent
(Spec_Id
))) /=
2827 N_Subprogram_Body_Stub
2831 elsif Is_Return_By_Reference_Type
(Typ
) then
2832 Set_Returns_By_Ref
(Spec_Id
);
2834 elsif Present
(Utyp
) and then Controlled_Type
(Utyp
) then
2835 Set_Returns_By_Ref
(Spec_Id
);
2839 -- For a procedure, we add a return for all possible syntactic ends
2840 -- of the subprogram. Note that reanalysis is not necessary in this
2841 -- case since it would require a lot of work and accomplish nothing.
2843 if Ekind
(Spec_Id
) = E_Procedure
2844 or else Ekind
(Spec_Id
) = E_Generic_Procedure
2846 Add_Return
(Statements
(H
));
2848 if Present
(Exception_Handlers
(H
)) then
2849 Except_H
:= First_Non_Pragma
(Exception_Handlers
(H
));
2851 while Present
(Except_H
) loop
2852 Add_Return
(Statements
(Except_H
));
2853 Next_Non_Pragma
(Except_H
);
2857 -- For a function, we must deal with the case where there is at
2858 -- least one missing return. What we do is to wrap the entire body
2859 -- of the function in a block:
2872 -- raise Program_Error;
2875 -- This approach is necessary because the raise must be signalled
2876 -- to the caller, not handled by any local handler (RM 6.4(11)).
2878 -- Note: we do not need to analyze the constructed sequence here,
2879 -- since it has no handler, and an attempt to analyze the handled
2880 -- statement sequence twice is risky in various ways (e.g. the
2881 -- issue of expanding cleanup actions twice).
2883 elsif Has_Missing_Return
(Spec_Id
) then
2885 Hloc
: constant Source_Ptr
:= Sloc
(H
);
2886 Blok
: constant Node_Id
:=
2887 Make_Block_Statement
(Hloc
,
2888 Handled_Statement_Sequence
=> H
);
2889 Rais
: constant Node_Id
:=
2890 Make_Raise_Program_Error
(Hloc
,
2891 Reason
=> PE_Missing_Return
);
2894 Set_Handled_Statement_Sequence
(N
,
2895 Make_Handled_Sequence_Of_Statements
(Hloc
,
2896 Statements
=> New_List
(Blok
, Rais
)));
2898 New_Scope
(Spec_Id
);
2905 -- Add discriminal renamings to protected subprograms.
2906 -- Install new discriminals for expansion of the next
2907 -- subprogram of this protected type, if any.
2909 if Is_List_Member
(N
)
2910 and then Present
(Parent
(List_Containing
(N
)))
2911 and then Nkind
(Parent
(List_Containing
(N
))) = N_Protected_Body
2913 Add_Discriminal_Declarations
2914 (Declarations
(N
), Scop
, Name_uObject
, Loc
);
2915 Add_Private_Declarations
(Declarations
(N
), Scop
, Name_uObject
, Loc
);
2917 -- Associate privals and discriminals with the next protected
2918 -- operation body to be expanded. These are used to expand
2919 -- references to private data objects and discriminants,
2922 Next_Op
:= Next_Protected_Operation
(N
);
2924 if Present
(Next_Op
) then
2925 Dec
:= Parent
(Base_Type
(Scop
));
2926 Set_Privals
(Dec
, Next_Op
, Loc
);
2927 Set_Discriminals
(Dec
);
2931 -- If subprogram contains a parameterless recursive call, then we may
2932 -- have an infinite recursion, so see if we can generate code to check
2933 -- for this possibility if storage checks are not suppressed.
2935 if Ekind
(Spec_Id
) = E_Procedure
2936 and then Has_Recursive_Call
(Spec_Id
)
2937 and then not Storage_Checks_Suppressed
(Spec_Id
)
2939 Detect_Infinite_Recursion
(N
, Spec_Id
);
2942 -- Finally, if we are in Normalize_Scalars mode, then any scalar out
2943 -- parameters must be initialized to the appropriate default value.
2945 if Ekind
(Spec_Id
) = E_Procedure
and then Normalize_Scalars
then
2952 Formal
:= First_Formal
(Spec_Id
);
2954 while Present
(Formal
) loop
2955 Floc
:= Sloc
(Formal
);
2957 if Ekind
(Formal
) = E_Out_Parameter
2958 and then Is_Scalar_Type
(Etype
(Formal
))
2961 Make_Assignment_Statement
(Floc
,
2962 Name
=> New_Occurrence_Of
(Formal
, Floc
),
2964 Get_Simple_Init_Val
(Etype
(Formal
), Floc
));
2965 Prepend
(Stm
, Declarations
(N
));
2969 Next_Formal
(Formal
);
2974 -- If the subprogram does not have pending instantiations, then we
2975 -- must generate the subprogram descriptor now, since the code for
2976 -- the subprogram is complete, and this is our last chance. However
2977 -- if there are pending instantiations, then the code is not
2978 -- complete, and we will delay the generation.
2980 if Is_Subprogram
(Spec_Id
)
2981 and then not Delay_Subprogram_Descriptors
(Spec_Id
)
2983 Generate_Subprogram_Descriptor_For_Subprogram
(N
, Spec_Id
);
2986 -- Set to encode entity names in package body before gigi is called
2988 Qualify_Entity_Names
(N
);
2989 end Expand_N_Subprogram_Body
;
2991 -----------------------------------
2992 -- Expand_N_Subprogram_Body_Stub --
2993 -----------------------------------
2995 procedure Expand_N_Subprogram_Body_Stub
(N
: Node_Id
) is
2997 if Present
(Corresponding_Body
(N
)) then
2998 Expand_N_Subprogram_Body
(
2999 Unit_Declaration_Node
(Corresponding_Body
(N
)));
3002 end Expand_N_Subprogram_Body_Stub
;
3004 -------------------------------------
3005 -- Expand_N_Subprogram_Declaration --
3006 -------------------------------------
3008 -- The first task to be performed is the construction of default
3009 -- expression functions for in parameters with default values. These
3010 -- are parameterless inlined functions that are used to evaluate
3011 -- default expressions that are more complicated than simple literals
3012 -- or identifiers referencing constants and variables.
3014 -- If the declaration appears within a protected body, it is a private
3015 -- operation of the protected type. We must create the corresponding
3016 -- protected subprogram an associated formals. For a normal protected
3017 -- operation, this is done when expanding the protected type declaration.
3019 procedure Expand_N_Subprogram_Declaration
(N
: Node_Id
) is
3020 Loc
: constant Source_Ptr
:= Sloc
(N
);
3021 Subp
: Entity_Id
:= Defining_Entity
(N
);
3022 Scop
: Entity_Id
:= Scope
(Subp
);
3023 Prot_Sub
: Entity_Id
;
3027 -- Deal with case of protected subprogram
3029 if Is_List_Member
(N
)
3030 and then Present
(Parent
(List_Containing
(N
)))
3031 and then Nkind
(Parent
(List_Containing
(N
))) = N_Protected_Body
3032 and then Is_Protected_Type
(Scop
)
3034 if No
(Protected_Body_Subprogram
(Subp
)) then
3036 Make_Subprogram_Declaration
(Loc
,
3038 Build_Protected_Sub_Specification
3039 (N
, Scop
, Unprotected
=> True));
3041 -- The protected subprogram is declared outside of the protected
3042 -- body. Given that the body has frozen all entities so far, we
3043 -- freeze the subprogram explicitly. If the body is a subunit,
3044 -- the insertion point is before the stub in the parent.
3046 Prot_Bod
:= Parent
(List_Containing
(N
));
3048 if Nkind
(Parent
(Prot_Bod
)) = N_Subunit
then
3049 Prot_Bod
:= Corresponding_Stub
(Parent
(Prot_Bod
));
3052 Insert_Before
(Prot_Bod
, Prot_Sub
);
3054 New_Scope
(Scope
(Scop
));
3056 Set_Protected_Body_Subprogram
(Subp
,
3057 Defining_Unit_Name
(Specification
(Prot_Sub
)));
3061 end Expand_N_Subprogram_Declaration
;
3063 ---------------------------------------
3064 -- Expand_Protected_Object_Reference --
3065 ---------------------------------------
3067 function Expand_Protected_Object_Reference
3072 Loc
: constant Source_Ptr
:= Sloc
(N
);
3079 Rec
:= Make_Identifier
(Loc
, Name_uObject
);
3080 Set_Etype
(Rec
, Corresponding_Record_Type
(Scop
));
3082 -- Find enclosing protected operation, and retrieve its first
3083 -- parameter, which denotes the enclosing protected object.
3084 -- If the enclosing operation is an entry, we are immediately
3085 -- within the protected body, and we can retrieve the object
3086 -- from the service entries procedure. A barrier function has
3087 -- has the same signature as an entry. A barrier function is
3088 -- compiled within the protected object, but unlike protected
3089 -- operations its never needs locks, so that its protected body
3090 -- subprogram points to itself.
3092 Proc
:= Current_Scope
;
3094 while Present
(Proc
)
3095 and then Scope
(Proc
) /= Scop
3097 Proc
:= Scope
(Proc
);
3100 Corr
:= Protected_Body_Subprogram
(Proc
);
3104 -- Previous error left expansion incomplete.
3105 -- Nothing to do on this call.
3112 (First
(Parameter_Specifications
(Parent
(Corr
))));
3114 if Is_Subprogram
(Proc
)
3115 and then Proc
/= Corr
3117 -- Protected function or procedure.
3119 Set_Entity
(Rec
, Param
);
3121 -- Rec is a reference to an entity which will not be in scope
3122 -- when the call is reanalyzed, and needs no further analysis.
3127 -- Entry or barrier function for entry body.
3128 -- The first parameter of the entry body procedure is a
3129 -- pointer to the object. We create a local variable
3130 -- of the proper type, duplicating what is done to define
3131 -- _object later on.
3135 Obj_Ptr
: Entity_Id
:= Make_Defining_Identifier
3136 (Loc
, New_Internal_Name
('T'));
3139 Make_Full_Type_Declaration
(Loc
,
3140 Defining_Identifier
=> Obj_Ptr
,
3142 Make_Access_To_Object_Definition
(Loc
,
3143 Subtype_Indication
=>
3145 (Corresponding_Record_Type
(Scop
), Loc
))));
3147 Insert_Actions
(N
, Decls
);
3148 Insert_Actions
(N
, Freeze_Entity
(Obj_Ptr
, Sloc
(N
)));
3151 Make_Explicit_Dereference
(Loc
,
3152 Unchecked_Convert_To
(Obj_Ptr
,
3153 New_Occurrence_Of
(Param
, Loc
)));
3155 -- Analyze new actual. Other actuals in calls are already
3156 -- analyzed and the list of actuals is not renalyzed after
3159 Set_Parent
(Rec
, N
);
3165 end Expand_Protected_Object_Reference
;
3167 --------------------------------------
3168 -- Expand_Protected_Subprogram_Call --
3169 --------------------------------------
3171 procedure Expand_Protected_Subprogram_Call
3179 -- If the protected object is not an enclosing scope, this is
3180 -- an inter-object function call. Inter-object procedure
3181 -- calls are expanded by Exp_Ch9.Build_Simple_Entry_Call.
3182 -- The call is intra-object only if the subprogram being
3183 -- called is in the protected body being compiled, and if the
3184 -- protected object in the call is statically the enclosing type.
3185 -- The object may be an component of some other data structure,
3186 -- in which case this must be handled as an inter-object call.
3188 if not In_Open_Scopes
(Scop
)
3189 or else not Is_Entity_Name
(Name
(N
))
3191 if Nkind
(Name
(N
)) = N_Selected_Component
then
3192 Rec
:= Prefix
(Name
(N
));
3195 pragma Assert
(Nkind
(Name
(N
)) = N_Indexed_Component
);
3196 Rec
:= Prefix
(Prefix
(Name
(N
)));
3199 Build_Protected_Subprogram_Call
(N
,
3200 Name
=> New_Occurrence_Of
(Subp
, Sloc
(N
)),
3201 Rec
=> Convert_Concurrent
(Rec
, Etype
(Rec
)),
3205 Rec
:= Expand_Protected_Object_Reference
(N
, Scop
);
3211 Build_Protected_Subprogram_Call
(N
,
3220 -- If it is a function call it can appear in elaboration code and
3221 -- the called entity must be frozen here.
3223 if Ekind
(Subp
) = E_Function
then
3224 Freeze_Expression
(Name
(N
));
3226 end Expand_Protected_Subprogram_Call
;
3228 -----------------------
3229 -- Freeze_Subprogram --
3230 -----------------------
3232 procedure Freeze_Subprogram
(N
: Node_Id
) is
3233 E
: constant Entity_Id
:= Entity
(N
);
3236 -- When a primitive is frozen, enter its name in the corresponding
3237 -- dispatch table. If the DTC_Entity field is not set this is an
3238 -- overridden primitive that can be ignored. We suppress the
3239 -- initialization of the dispatch table entry when Java_VM because
3240 -- the dispatching mechanism is handled internally by the JVM.
3242 if Is_Dispatching_Operation
(E
)
3243 and then not Is_Abstract
(E
)
3244 and then Present
(DTC_Entity
(E
))
3245 and then not Is_CPP_Class
(Scope
(DTC_Entity
(E
)))
3246 and then not Java_VM
3248 Check_Overriding_Operation
(E
);
3249 Insert_After
(N
, Fill_DT_Entry
(Sloc
(N
), E
));
3252 -- Mark functions that return by reference. Note that it cannot be
3253 -- part of the normal semantic analysis of the spec since the
3254 -- underlying returned type may not be known yet (for private types)
3257 Typ
: constant Entity_Id
:= Etype
(E
);
3258 Utyp
: constant Entity_Id
:= Underlying_Type
(Typ
);
3261 if Is_Return_By_Reference_Type
(Typ
) then
3262 Set_Returns_By_Ref
(E
);
3264 elsif Present
(Utyp
) and then Controlled_Type
(Utyp
) then
3265 Set_Returns_By_Ref
(E
);
3269 end Freeze_Subprogram
;