1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
11 -- Copyright (C) 1992-2001, Free Software Foundation, Inc. --
13 -- GNAT is free software; you can redistribute it and/or modify it under --
14 -- terms of the GNU General Public License as published by the Free Soft- --
15 -- ware Foundation; either version 2, or (at your option) any later ver- --
16 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
17 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
18 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
19 -- for more details. You should have received a copy of the GNU General --
20 -- Public License distributed with GNAT; see file COPYING. If not, write --
21 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
22 -- MA 02111-1307, USA. --
24 -- GNAT was originally developed by the GNAT team at New York University. --
25 -- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
27 ------------------------------------------------------------------------------
29 with Atree
; use Atree
;
30 with Checks
; use Checks
;
31 with Debug
; use Debug
;
32 with Einfo
; use Einfo
;
33 with Errout
; use Errout
;
34 with Elists
; use Elists
;
35 with Exp_Ch2
; use Exp_Ch2
;
36 with Exp_Ch3
; use Exp_Ch3
;
37 with Exp_Ch7
; use Exp_Ch7
;
38 with Exp_Ch9
; use Exp_Ch9
;
39 with Exp_Ch11
; use Exp_Ch11
;
40 with Exp_Dbug
; use Exp_Dbug
;
41 with Exp_Disp
; use Exp_Disp
;
42 with Exp_Dist
; use Exp_Dist
;
43 with Exp_Intr
; use Exp_Intr
;
44 with Exp_Pakd
; use Exp_Pakd
;
45 with Exp_Tss
; use Exp_Tss
;
46 with Exp_Util
; use Exp_Util
;
47 with Freeze
; use Freeze
;
48 with Hostparm
; use Hostparm
;
49 with Inline
; use Inline
;
51 with Nlists
; use Nlists
;
52 with Nmake
; use Nmake
;
54 with Restrict
; use Restrict
;
55 with Rtsfind
; use Rtsfind
;
57 with Sem_Ch6
; use Sem_Ch6
;
58 with Sem_Ch8
; use Sem_Ch8
;
59 with Sem_Ch12
; use Sem_Ch12
;
60 with Sem_Ch13
; use Sem_Ch13
;
61 with Sem_Disp
; use Sem_Disp
;
62 with Sem_Dist
; use Sem_Dist
;
63 with Sem_Res
; use Sem_Res
;
64 with Sem_Util
; use Sem_Util
;
65 with Sinfo
; use Sinfo
;
66 with Snames
; use Snames
;
67 with Stand
; use Stand
;
68 with Tbuild
; use Tbuild
;
69 with Uintp
; use Uintp
;
70 with Validsw
; use Validsw
;
72 package body Exp_Ch6
is
74 -----------------------
75 -- Local Subprograms --
76 -----------------------
78 procedure Check_Overriding_Operation
(Subp
: Entity_Id
);
79 -- Subp is a dispatching operation. Check whether it may override an
80 -- inherited private operation, in which case its DT entry is that of
81 -- the hidden operation, not the one it may have received earlier.
82 -- This must be done before emitting the code to set the corresponding
83 -- DT to the address of the subprogram. The actual placement of Subp in
84 -- the proper place in the list of primitive operations is done in
85 -- Declare_Inherited_Private_Subprograms, which also has to deal with
86 -- implicit operations. This duplication is unavoidable for now???
88 procedure Detect_Infinite_Recursion
(N
: Node_Id
; Spec
: Entity_Id
);
89 -- This procedure is called only if the subprogram body N, whose spec
90 -- has the given entity Spec, contains a parameterless recursive call.
91 -- It attempts to generate runtime code to detect if this a case of
92 -- infinite recursion.
94 -- The body is scanned to determine dependencies. If the only external
95 -- dependencies are on a small set of scalar variables, then the values
96 -- of these variables are captured on entry to the subprogram, and if
97 -- the values are not changed for the call, we know immediately that
98 -- we have an infinite recursion.
100 procedure Expand_Actuals
(N
: Node_Id
; Subp
: Entity_Id
);
101 -- For each actual of an in-out parameter which is a numeric conversion
102 -- of the form T(A), where A denotes a variable, we insert the declaration:
106 -- prior to the call. Then we replace the actual with a reference to Temp,
107 -- and append the assignment:
111 -- after the call. Here T' is the actual type of variable A.
112 -- For out parameters, the initial declaration has no expression.
113 -- If A is not an entity name, we generate instead:
115 -- Var : T' renames A;
116 -- Temp : T := Var; -- omitting expression for out parameter.
120 -- For other in-out parameters, we emit the required constraint checks
121 -- before and/or after the call.
123 -- For all parameter modes, actuals that denote components and slices
124 -- of packed arrays are expanded into suitable temporaries.
126 procedure Expand_Inlined_Call
129 Orig_Subp
: Entity_Id
);
130 -- If called subprogram can be inlined by the front-end, retrieve the
131 -- analyzed body, replace formals with actuals and expand call in place.
132 -- Generate thunks for actuals that are expressions, and insert the
133 -- corresponding constant declarations before the call. If the original
134 -- call is to a derived operation, the return type is the one of the
135 -- derived operation, but the body is that of the original, so return
136 -- expressions in the body must be converted to the desired type (which
137 -- is simply not noted in the tree without inline expansion).
139 function Expand_Protected_Object_Reference
144 procedure Expand_Protected_Subprogram_Call
148 -- A call to a protected subprogram within the protected object may appear
149 -- as a regular call. The list of actuals must be expanded to contain a
150 -- reference to the object itself, and the call becomes a call to the
151 -- corresponding protected subprogram.
153 --------------------------------
154 -- Check_Overriding_Operation --
155 --------------------------------
157 procedure Check_Overriding_Operation
(Subp
: Entity_Id
) is
158 Typ
: constant Entity_Id
:= Find_Dispatching_Type
(Subp
);
159 Op_List
: constant Elist_Id
:= Primitive_Operations
(Typ
);
165 if Is_Derived_Type
(Typ
)
166 and then not Is_Private_Type
(Typ
)
167 and then In_Open_Scopes
(Scope
(Etype
(Typ
)))
168 and then Typ
= Base_Type
(Typ
)
170 -- Subp overrides an inherited private operation if there is
171 -- an inherited operation with a different name than Subp (see
172 -- Derive_Subprogram) whose Alias is a hidden subprogram with
173 -- the same name as Subp.
175 Op_Elmt
:= First_Elmt
(Op_List
);
176 while Present
(Op_Elmt
) loop
177 Prim_Op
:= Node
(Op_Elmt
);
178 Par_Op
:= Alias
(Prim_Op
);
181 and then not Comes_From_Source
(Prim_Op
)
182 and then Chars
(Prim_Op
) /= Chars
(Par_Op
)
183 and then Chars
(Par_Op
) = Chars
(Subp
)
184 and then Is_Hidden
(Par_Op
)
185 and then Type_Conformant
(Prim_Op
, Subp
)
187 Set_DT_Position
(Subp
, DT_Position
(Prim_Op
));
193 end Check_Overriding_Operation
;
195 -------------------------------
196 -- Detect_Infinite_Recursion --
197 -------------------------------
199 procedure Detect_Infinite_Recursion
(N
: Node_Id
; Spec
: Entity_Id
) is
200 Loc
: constant Source_Ptr
:= Sloc
(N
);
202 Var_List
: Elist_Id
:= New_Elmt_List
;
203 -- List of globals referenced by body of procedure
205 Call_List
: Elist_Id
:= New_Elmt_List
;
206 -- List of recursive calls in body of procedure
208 Shad_List
: Elist_Id
:= New_Elmt_List
;
209 -- List of entity id's for entities created to capture the
210 -- value of referenced globals on entry to the procedure.
212 Scop
: constant Uint
:= Scope_Depth
(Spec
);
213 -- This is used to record the scope depth of the current
214 -- procedure, so that we can identify global references.
216 Max_Vars
: constant := 4;
217 -- Do not test more than four global variables
219 Count_Vars
: Natural := 0;
220 -- Count variables found so far
232 function Process
(Nod
: Node_Id
) return Traverse_Result
;
233 -- Function to traverse the subprogram body (using Traverse_Func)
239 function Process
(Nod
: Node_Id
) return Traverse_Result
is
243 if Nkind
(Nod
) = N_Procedure_Call_Statement
then
245 -- Case of one of the detected recursive calls
247 if Is_Entity_Name
(Name
(Nod
))
248 and then Has_Recursive_Call
(Entity
(Name
(Nod
)))
249 and then Entity
(Name
(Nod
)) = Spec
251 Append_Elmt
(Nod
, Call_List
);
254 -- Any other procedure call may have side effects
260 -- A call to a pure function can always be ignored
262 elsif Nkind
(Nod
) = N_Function_Call
263 and then Is_Entity_Name
(Name
(Nod
))
264 and then Is_Pure
(Entity
(Name
(Nod
)))
268 -- Case of an identifier reference
270 elsif Nkind
(Nod
) = N_Identifier
then
273 -- If no entity, then ignore the reference
275 -- Not clear why this can happen. To investigate, remove this
276 -- test and look at the crash that occurs here in 3401-004 ???
281 -- Ignore entities with no Scope, again not clear how this
282 -- can happen, to investigate, look at 4108-008 ???
284 elsif No
(Scope
(Ent
)) then
287 -- Ignore the reference if not to a more global object
289 elsif Scope_Depth
(Scope
(Ent
)) >= Scop
then
292 -- References to types, exceptions and constants are always OK
295 or else Ekind
(Ent
) = E_Exception
296 or else Ekind
(Ent
) = E_Constant
300 -- If other than a non-volatile scalar variable, we have some
301 -- kind of global reference (e.g. to a function) that we cannot
302 -- deal with so we forget the attempt.
304 elsif Ekind
(Ent
) /= E_Variable
305 or else not Is_Scalar_Type
(Etype
(Ent
))
306 or else Is_Volatile
(Ent
)
310 -- Otherwise we have a reference to a global scalar
313 -- Loop through global entities already detected
315 Elm
:= First_Elmt
(Var_List
);
317 -- If not detected before, record this new global reference
320 Count_Vars
:= Count_Vars
+ 1;
322 if Count_Vars
<= Max_Vars
then
323 Append_Elmt
(Entity
(Nod
), Var_List
);
330 -- If recorded before, ignore
332 elsif Node
(Elm
) = Entity
(Nod
) then
335 -- Otherwise keep looking
345 -- For all other node kinds, recursively visit syntactic children
352 function Traverse_Body
is new Traverse_Func
;
354 -- Start of processing for Detect_Infinite_Recursion
357 -- Do not attempt detection in No_Implicit_Conditional mode,
358 -- since we won't be able to generate the code to handle the
359 -- recursion in any case.
361 if Restrictions
(No_Implicit_Conditionals
) then
365 -- Otherwise do traversal and quit if we get abandon signal
367 if Traverse_Body
(N
) = Abandon
then
370 -- We must have a call, since Has_Recursive_Call was set. If not
371 -- just ignore (this is only an error check, so if we have a funny
372 -- situation, due to bugs or errors, we do not want to bomb!)
374 elsif Is_Empty_Elmt_List
(Call_List
) then
378 -- Here is the case where we detect recursion at compile time
380 -- Push our current scope for analyzing the declarations and
381 -- code that we will insert for the checking.
385 -- This loop builds temporary variables for each of the
386 -- referenced globals, so that at the end of the loop the
387 -- list Shad_List contains these temporaries in one-to-one
388 -- correspondence with the elements in Var_List.
391 Elm
:= First_Elmt
(Var_List
);
392 while Present
(Elm
) loop
395 Make_Defining_Identifier
(Loc
,
396 Chars
=> New_Internal_Name
('S'));
397 Append_Elmt
(Ent
, Shad_List
);
399 -- Insert a declaration for this temporary at the start of
400 -- the declarations for the procedure. The temporaries are
401 -- declared as constant objects initialized to the current
402 -- values of the corresponding temporaries.
405 Make_Object_Declaration
(Loc
,
406 Defining_Identifier
=> Ent
,
407 Object_Definition
=> New_Occurrence_Of
(Etype
(Var
), Loc
),
408 Constant_Present
=> True,
409 Expression
=> New_Occurrence_Of
(Var
, Loc
));
412 Prepend
(Decl
, Declarations
(N
));
414 Insert_After
(Last
, Decl
);
422 -- Loop through calls
424 Call
:= First_Elmt
(Call_List
);
425 while Present
(Call
) loop
427 -- Build a predicate expression of the form
430 -- and then global1 = temp1
431 -- and then global2 = temp2
434 -- This predicate determines if any of the global values
435 -- referenced by the procedure have changed since the
436 -- current call, if not an infinite recursion is assured.
438 Test
:= New_Occurrence_Of
(Standard_True
, Loc
);
440 Elm1
:= First_Elmt
(Var_List
);
441 Elm2
:= First_Elmt
(Shad_List
);
442 while Present
(Elm1
) loop
448 Left_Opnd
=> New_Occurrence_Of
(Node
(Elm1
), Loc
),
449 Right_Opnd
=> New_Occurrence_Of
(Node
(Elm2
), Loc
)));
455 -- Now we replace the call with the sequence
457 -- if no-changes (see above) then
458 -- raise Storage_Error;
463 Rewrite
(Node
(Call
),
464 Make_If_Statement
(Loc
,
466 Then_Statements
=> New_List
(
467 Make_Raise_Storage_Error
(Loc
)),
469 Else_Statements
=> New_List
(
470 Relocate_Node
(Node
(Call
)))));
472 Analyze
(Node
(Call
));
477 -- Remove temporary scope stack entry used for analysis
480 end Detect_Infinite_Recursion
;
486 procedure Expand_Actuals
(N
: Node_Id
; Subp
: Entity_Id
) is
487 Loc
: constant Source_Ptr
:= Sloc
(N
);
492 E_Formal
: Entity_Id
;
494 procedure Add_Call_By_Copy_Code
;
495 -- For In and In-Out parameters, where the parameter must be passed
496 -- by copy, this routine generates a temporary variable into which
497 -- the actual is copied, and then passes this as the parameter. This
498 -- routine also takes care of any constraint checks required for the
499 -- type conversion case (on both the way in and the way out).
501 procedure Add_Packed_Call_By_Copy_Code
;
502 -- This is used when the actual involves a reference to an element
503 -- of a packed array, where we can appropriately use a simpler
504 -- approach than the full call by copy code. We just copy the value
505 -- in and out of an appropriate temporary.
507 procedure Check_Fortran_Logical
;
508 -- A value of type Logical that is passed through a formal parameter
509 -- must be normalized because .TRUE. usually does not have the same
510 -- representation as True. We assume that .FALSE. = False = 0.
511 -- What about functions that return a logical type ???
513 function Make_Var
(Actual
: Node_Id
) return Entity_Id
;
514 -- Returns an entity that refers to the given actual parameter,
515 -- Actual (not including any type conversion). If Actual is an
516 -- entity name, then this entity is returned unchanged, otherwise
517 -- a renaming is created to provide an entity for the actual.
519 procedure Reset_Packed_Prefix
;
520 -- The expansion of a packed array component reference is delayed in
521 -- the context of a call. Now we need to complete the expansion, so we
522 -- unmark the analyzed bits in all prefixes.
524 ---------------------------
525 -- Add_Call_By_Copy_Code --
526 ---------------------------
528 procedure Add_Call_By_Copy_Code
is
537 Temp
:= Make_Defining_Identifier
(Loc
, New_Internal_Name
('T'));
539 if Nkind
(Actual
) = N_Type_Conversion
then
540 V_Typ
:= Etype
(Expression
(Actual
));
541 Var
:= Make_Var
(Expression
(Actual
));
542 Crep
:= not Same_Representation
543 (Etype
(Formal
), Etype
(Expression
(Actual
)));
545 V_Typ
:= Etype
(Actual
);
546 Var
:= Make_Var
(Actual
);
550 -- Setup initialization for case of in out parameter, or an out
551 -- parameter where the formal is an unconstrained array (in the
552 -- latter case, we have to pass in an object with bounds).
554 if Ekind
(Formal
) = E_In_Out_Parameter
555 or else (Is_Array_Type
(Etype
(Formal
))
557 not Is_Constrained
(Etype
(Formal
)))
559 if Nkind
(Actual
) = N_Type_Conversion
then
560 if Conversion_OK
(Actual
) then
561 Init
:= OK_Convert_To
562 (Etype
(Formal
), New_Occurrence_Of
(Var
, Loc
));
565 (Etype
(Formal
), New_Occurrence_Of
(Var
, Loc
));
568 Init
:= New_Occurrence_Of
(Var
, Loc
);
571 -- An initialization is created for packed conversions as
572 -- actuals for out parameters to enable Make_Object_Declaration
573 -- to determine the proper subtype for N_Node. Note that this
574 -- is wasteful because the extra copying on the call side is
575 -- not required for such out parameters. ???
577 elsif Ekind
(Formal
) = E_Out_Parameter
578 and then Nkind
(Actual
) = N_Type_Conversion
579 and then (Is_Bit_Packed_Array
(Etype
(Formal
))
581 Is_Bit_Packed_Array
(Etype
(Expression
(Actual
))))
583 if Conversion_OK
(Actual
) then
585 OK_Convert_To
(Etype
(Formal
), New_Occurrence_Of
(Var
, Loc
));
588 Convert_To
(Etype
(Formal
), New_Occurrence_Of
(Var
, Loc
));
595 Make_Object_Declaration
(Loc
,
596 Defining_Identifier
=> Temp
,
598 New_Occurrence_Of
(Etype
(Formal
), Loc
),
600 Set_Assignment_OK
(N_Node
);
601 Insert_Action
(N
, N_Node
);
603 -- Now, normally the deal here is that we use the defining
604 -- identifier created by that object declaration. There is
605 -- one exception to this. In the change of representation case
606 -- the above declaration will end up looking like:
608 -- temp : type := identifier;
610 -- And in this case we might as well use the identifier directly
611 -- and eliminate the temporary. Note that the analysis of the
612 -- declaration was not a waste of time in that case, since it is
613 -- what generated the necessary change of representation code. If
614 -- the change of representation introduced additional code, as in
615 -- a fixed-integer conversion, the expression is not an identifier
619 and then Present
(Expression
(N_Node
))
620 and then Is_Entity_Name
(Expression
(N_Node
))
622 Temp
:= Entity
(Expression
(N_Node
));
623 Rewrite
(N_Node
, Make_Null_Statement
(Loc
));
626 -- If type conversion, use reverse conversion on exit
628 if Nkind
(Actual
) = N_Type_Conversion
then
629 if Conversion_OK
(Actual
) then
630 Expr
:= OK_Convert_To
(V_Typ
, New_Occurrence_Of
(Temp
, Loc
));
632 Expr
:= Convert_To
(V_Typ
, New_Occurrence_Of
(Temp
, Loc
));
635 Expr
:= New_Occurrence_Of
(Temp
, Loc
);
638 Rewrite
(Actual
, New_Reference_To
(Temp
, Loc
));
641 Append_To
(Post_Call
,
642 Make_Assignment_Statement
(Loc
,
643 Name
=> New_Occurrence_Of
(Var
, Loc
),
644 Expression
=> Expr
));
646 Set_Assignment_OK
(Name
(Last
(Post_Call
)));
647 end Add_Call_By_Copy_Code
;
649 ----------------------------------
650 -- Add_Packed_Call_By_Copy_Code --
651 ----------------------------------
653 procedure Add_Packed_Call_By_Copy_Code
is
663 -- Prepare to generate code
665 Temp
:= Make_Defining_Identifier
(Loc
, New_Internal_Name
('T'));
666 Incod
:= Relocate_Node
(Actual
);
667 Outcod
:= New_Copy_Tree
(Incod
);
669 -- Generate declaration of temporary variable, initializing it
670 -- with the input parameter unless we have an OUT variable.
672 if Ekind
(Formal
) = E_Out_Parameter
then
677 Make_Object_Declaration
(Loc
,
678 Defining_Identifier
=> Temp
,
680 New_Occurrence_Of
(Etype
(Formal
), Loc
),
681 Expression
=> Incod
));
683 -- The actual is simply a reference to the temporary
685 Rewrite
(Actual
, New_Occurrence_Of
(Temp
, Loc
));
687 -- Generate copy out if OUT or IN OUT parameter
689 if Ekind
(Formal
) /= E_In_Parameter
then
691 Rhs
:= New_Occurrence_Of
(Temp
, Loc
);
693 -- Deal with conversion
695 if Nkind
(Lhs
) = N_Type_Conversion
then
696 Lhs
:= Expression
(Lhs
);
697 Rhs
:= Convert_To
(Etype
(Actual
), Rhs
);
700 Append_To
(Post_Call
,
701 Make_Assignment_Statement
(Loc
,
705 end Add_Packed_Call_By_Copy_Code
;
707 ---------------------------
708 -- Check_Fortran_Logical --
709 ---------------------------
711 procedure Check_Fortran_Logical
is
712 Logical
: Entity_Id
:= Etype
(Formal
);
715 -- Note: this is very incomplete, e.g. it does not handle arrays
716 -- of logical values. This is really not the right approach at all???)
719 if Convention
(Subp
) = Convention_Fortran
720 and then Root_Type
(Etype
(Formal
)) = Standard_Boolean
721 and then Ekind
(Formal
) /= E_In_Parameter
723 Var
:= Make_Var
(Actual
);
724 Append_To
(Post_Call
,
725 Make_Assignment_Statement
(Loc
,
726 Name
=> New_Occurrence_Of
(Var
, Loc
),
728 Unchecked_Convert_To
(
731 Left_Opnd
=> New_Occurrence_Of
(Var
, Loc
),
733 Unchecked_Convert_To
(
735 New_Occurrence_Of
(Standard_False
, Loc
))))));
737 end Check_Fortran_Logical
;
743 function Make_Var
(Actual
: Node_Id
) return Entity_Id
is
747 if Is_Entity_Name
(Actual
) then
748 return Entity
(Actual
);
751 Var
:= Make_Defining_Identifier
(Loc
, New_Internal_Name
('T'));
754 Make_Object_Renaming_Declaration
(Loc
,
755 Defining_Identifier
=> Var
,
757 New_Occurrence_Of
(Etype
(Actual
), Loc
),
758 Name
=> Relocate_Node
(Actual
));
760 Insert_Action
(N
, N_Node
);
765 -------------------------
766 -- Reset_Packed_Prefix --
767 -------------------------
769 procedure Reset_Packed_Prefix
is
770 Pfx
: Node_Id
:= Actual
;
774 Set_Analyzed
(Pfx
, False);
775 exit when Nkind
(Pfx
) /= N_Selected_Component
776 and then Nkind
(Pfx
) /= N_Indexed_Component
;
779 end Reset_Packed_Prefix
;
781 -- Start of processing for Expand_Actuals
784 Formal
:= First_Formal
(Subp
);
785 Actual
:= First_Actual
(N
);
787 Post_Call
:= New_List
;
789 while Present
(Formal
) loop
790 E_Formal
:= Etype
(Formal
);
792 if Is_Scalar_Type
(E_Formal
)
793 or else Nkind
(Actual
) = N_Slice
795 Check_Fortran_Logical
;
799 elsif Ekind
(Formal
) /= E_Out_Parameter
then
801 -- The unusual case of the current instance of a protected type
802 -- requires special handling. This can only occur in the context
803 -- of a call within the body of a protected operation.
805 if Is_Entity_Name
(Actual
)
806 and then Ekind
(Entity
(Actual
)) = E_Protected_Type
807 and then In_Open_Scopes
(Entity
(Actual
))
809 if Scope
(Subp
) /= Entity
(Actual
) then
810 Error_Msg_N
("operation outside protected type may not "
811 & "call back its protected operations?", Actual
);
815 Expand_Protected_Object_Reference
(N
, Entity
(Actual
)));
818 Apply_Constraint_Check
(Actual
, E_Formal
);
820 -- Out parameter case. No constraint checks on access type
823 elsif Is_Access_Type
(E_Formal
) then
828 elsif Has_Discriminants
(Base_Type
(E_Formal
))
829 or else Has_Non_Null_Base_Init_Proc
(E_Formal
)
831 Apply_Constraint_Check
(Actual
, E_Formal
);
836 Apply_Constraint_Check
(Actual
, Base_Type
(E_Formal
));
839 -- Processing for IN-OUT and OUT parameters
841 if Ekind
(Formal
) /= E_In_Parameter
then
843 -- For type conversions of arrays, apply length/range checks
845 if Is_Array_Type
(E_Formal
)
846 and then Nkind
(Actual
) = N_Type_Conversion
848 if Is_Constrained
(E_Formal
) then
849 Apply_Length_Check
(Expression
(Actual
), E_Formal
);
851 Apply_Range_Check
(Expression
(Actual
), E_Formal
);
855 -- If argument is a type conversion for a type that is passed
856 -- by copy, then we must pass the parameter by copy.
858 if Nkind
(Actual
) = N_Type_Conversion
860 (Is_Numeric_Type
(E_Formal
)
861 or else Is_Access_Type
(E_Formal
)
862 or else Is_Enumeration_Type
(E_Formal
)
863 or else Is_Bit_Packed_Array
(Etype
(Formal
))
864 or else Is_Bit_Packed_Array
(Etype
(Expression
(Actual
)))
866 -- Also pass by copy if change of representation
868 or else not Same_Representation
870 Etype
(Expression
(Actual
))))
872 Add_Call_By_Copy_Code
;
874 -- References to components of bit packed arrays are expanded
875 -- at this point, rather than at the point of analysis of the
876 -- actuals, to handle the expansion of the assignment to
877 -- [in] out parameters.
879 elsif Is_Ref_To_Bit_Packed_Array
(Actual
) then
880 Add_Packed_Call_By_Copy_Code
;
882 -- References to slices of bit packed arrays are expanded
884 elsif Is_Ref_To_Bit_Packed_Slice
(Actual
) then
885 Add_Call_By_Copy_Code
;
887 -- Deal with access types where the actual subtpe and the
888 -- formal subtype are not the same, requiring a check.
890 -- It is necessary to exclude tagged types because of "downward
891 -- conversion" errors and a strange assertion error in namet
892 -- from gnatf in bug 1215-001 ???
894 elsif Is_Access_Type
(E_Formal
)
895 and then not Same_Type
(E_Formal
, Etype
(Actual
))
896 and then not Is_Tagged_Type
(Designated_Type
(E_Formal
))
898 Add_Call_By_Copy_Code
;
900 elsif Is_Entity_Name
(Actual
)
901 and then Is_Volatile
(Entity
(Actual
))
902 and then not Is_Scalar_Type
(Etype
(Entity
(Actual
)))
903 and then not Is_Volatile
(E_Formal
)
905 Add_Call_By_Copy_Code
;
907 elsif Nkind
(Actual
) = N_Indexed_Component
908 and then Is_Entity_Name
(Prefix
(Actual
))
909 and then Has_Volatile_Components
(Entity
(Prefix
(Actual
)))
911 Add_Call_By_Copy_Code
;
914 -- The only processing required for IN parameters is in the packed
915 -- array case, where we expand the indexed component (the circuit
916 -- in Exp_Ch4 deliberately left indexed components appearing as
917 -- actuals untouched, so that the special processing above for
918 -- the OUT and IN OUT cases could be performed. We could make the
919 -- test in Exp_Ch4 more complex and have it detect the parameter
920 -- mode, but it is easier simply to handle all cases here.
922 -- Similarly, we have to expand slices of packed arrays here
925 if Nkind
(Actual
) = N_Indexed_Component
926 and then Is_Packed
(Etype
(Prefix
(Actual
)))
929 Expand_Packed_Element_Reference
(Actual
);
931 elsif Is_Ref_To_Bit_Packed_Array
(Actual
) then
932 Add_Packed_Call_By_Copy_Code
;
934 elsif Is_Ref_To_Bit_Packed_Slice
(Actual
) then
936 Typ
: constant Entity_Id
:= Etype
(Actual
);
938 Ent
: constant Entity_Id
:=
939 Make_Defining_Identifier
(Loc
,
940 Chars
=> New_Internal_Name
('T'));
942 Decl
: constant Node_Id
:=
943 Make_Object_Declaration
(Loc
,
944 Defining_Identifier
=> Ent
,
946 New_Occurrence_Of
(Typ
, Loc
));
949 Set_No_Initialization
(Decl
);
951 Insert_Actions
(N
, New_List
(
953 Make_Assignment_Statement
(Loc
,
954 Name
=> New_Occurrence_Of
(Ent
, Loc
),
955 Expression
=> Relocate_Node
(Actual
))));
958 (Actual
, New_Occurrence_Of
(Ent
, Loc
));
959 Analyze_And_Resolve
(Actual
, Typ
);
964 Next_Formal
(Formal
);
965 Next_Actual
(Actual
);
968 -- Find right place to put post call stuff if it is present
970 if not Is_Empty_List
(Post_Call
) then
972 -- If call is not a list member, it must be the triggering
973 -- statement of a triggering alternative or an entry call
974 -- alternative, and we can add the post call stuff to the
975 -- corresponding statement list.
977 if not Is_List_Member
(N
) then
979 P
: constant Node_Id
:= Parent
(N
);
982 pragma Assert
(Nkind
(P
) = N_Triggering_Alternative
983 or else Nkind
(P
) = N_Entry_Call_Alternative
);
985 if Is_Non_Empty_List
(Statements
(P
)) then
986 Insert_List_Before_And_Analyze
987 (First
(Statements
(P
)), Post_Call
);
989 Set_Statements
(P
, Post_Call
);
993 -- Otherwise, normal case where N is in a statement sequence,
994 -- just put the post-call stuff after the call statement.
997 Insert_Actions_After
(N
, Post_Call
);
1001 -- The call node itself is re-analyzed in Expand_Call.
1009 -- This procedure handles expansion of function calls and procedure call
1010 -- statements (i.e. it serves as the body for Expand_N_Function_Call and
1011 -- Expand_N_Procedure_Call_Statement. Processing for calls includes:
1013 -- Replace call to Raise_Exception by Raise_Exception always if possible
1014 -- Provide values of actuals for all formals in Extra_Formals list
1015 -- Replace "call" to enumeration literal function by literal itself
1016 -- Rewrite call to predefined operator as operator
1017 -- Replace actuals to in-out parameters that are numeric conversions,
1018 -- with explicit assignment to temporaries before and after the call.
1019 -- Remove optional actuals if First_Optional_Parameter specified.
1021 -- Note that the list of actuals has been filled with default expressions
1022 -- during semantic analysis of the call. Only the extra actuals required
1023 -- for the 'Constrained attribute and for accessibility checks are added
1026 procedure Expand_Call
(N
: Node_Id
) is
1027 Loc
: constant Source_Ptr
:= Sloc
(N
);
1028 Remote
: constant Boolean := Is_Remote_Call
(N
);
1030 Orig_Subp
: Entity_Id
:= Empty
;
1031 Parent_Subp
: Entity_Id
;
1032 Parent_Formal
: Entity_Id
;
1035 Prev
: Node_Id
:= Empty
;
1036 Prev_Orig
: Node_Id
;
1038 Extra_Actuals
: List_Id
:= No_List
;
1041 procedure Add_Actual_Parameter
(Insert_Param
: Node_Id
);
1042 -- Adds one entry to the end of the actual parameter list. Used for
1043 -- default parameters and for extra actuals (for Extra_Formals).
1044 -- The argument is an N_Parameter_Association node.
1046 procedure Add_Extra_Actual
(Expr
: Node_Id
; EF
: Entity_Id
);
1047 -- Adds an extra actual to the list of extra actuals. Expr
1048 -- is the expression for the value of the actual, EF is the
1049 -- entity for the extra formal.
1051 function Inherited_From_Formal
(S
: Entity_Id
) return Entity_Id
;
1052 -- Within an instance, a type derived from a non-tagged formal derived
1053 -- type inherits from the original parent, not from the actual. This is
1054 -- tested in 4723-003. The current derivation mechanism has the derived
1055 -- type inherit from the actual, which is only correct outside of the
1056 -- instance. If the subprogram is inherited, we test for this particular
1057 -- case through a convoluted tree traversal before setting the proper
1058 -- subprogram to be called.
1060 --------------------------
1061 -- Add_Actual_Parameter --
1062 --------------------------
1064 procedure Add_Actual_Parameter
(Insert_Param
: Node_Id
) is
1065 Actual_Expr
: constant Node_Id
:=
1066 Explicit_Actual_Parameter
(Insert_Param
);
1069 -- Case of insertion is first named actual
1071 if No
(Prev
) or else
1072 Nkind
(Parent
(Prev
)) /= N_Parameter_Association
1074 Set_Next_Named_Actual
(Insert_Param
, First_Named_Actual
(N
));
1075 Set_First_Named_Actual
(N
, Actual_Expr
);
1078 if not Present
(Parameter_Associations
(N
)) then
1079 Set_Parameter_Associations
(N
, New_List
);
1080 Append
(Insert_Param
, Parameter_Associations
(N
));
1083 Insert_After
(Prev
, Insert_Param
);
1086 -- Case of insertion is not first named actual
1089 Set_Next_Named_Actual
1090 (Insert_Param
, Next_Named_Actual
(Parent
(Prev
)));
1091 Set_Next_Named_Actual
(Parent
(Prev
), Actual_Expr
);
1092 Append
(Insert_Param
, Parameter_Associations
(N
));
1095 Prev
:= Actual_Expr
;
1096 end Add_Actual_Parameter
;
1098 ----------------------
1099 -- Add_Extra_Actual --
1100 ----------------------
1102 procedure Add_Extra_Actual
(Expr
: Node_Id
; EF
: Entity_Id
) is
1103 Loc
: constant Source_Ptr
:= Sloc
(Expr
);
1106 if Extra_Actuals
= No_List
then
1107 Extra_Actuals
:= New_List
;
1108 Set_Parent
(Extra_Actuals
, N
);
1111 Append_To
(Extra_Actuals
,
1112 Make_Parameter_Association
(Loc
,
1113 Explicit_Actual_Parameter
=> Expr
,
1115 Make_Identifier
(Loc
, Chars
(EF
))));
1117 Analyze_And_Resolve
(Expr
, Etype
(EF
));
1119 end Add_Extra_Actual
;
1121 ---------------------------
1122 -- Inherited_From_Formal --
1123 ---------------------------
1125 function Inherited_From_Formal
(S
: Entity_Id
) return Entity_Id
is
1127 Gen_Par
: Entity_Id
;
1128 Gen_Prim
: Elist_Id
;
1133 -- If the operation is inherited, it is attached to the corresponding
1134 -- type derivation. If the parent in the derivation is a generic
1135 -- actual, it is a subtype of the actual, and we have to recover the
1136 -- original derived type declaration to find the proper parent.
1138 if Nkind
(Parent
(S
)) /= N_Full_Type_Declaration
1139 or else not Is_Derived_Type
(Defining_Identifier
(Parent
(S
)))
1140 or else Nkind
(Type_Definition
(Original_Node
(Parent
(S
))))
1141 /= N_Derived_Type_Definition
1148 (Type_Definition
(Original_Node
(Parent
(S
)))));
1150 if Nkind
(Indic
) = N_Subtype_Indication
then
1151 Par
:= Entity
(Subtype_Mark
(Indic
));
1153 Par
:= Entity
(Indic
);
1157 if not Is_Generic_Actual_Type
(Par
)
1158 or else Is_Tagged_Type
(Par
)
1159 or else Nkind
(Parent
(Par
)) /= N_Subtype_Declaration
1160 or else not In_Open_Scopes
(Scope
(Par
))
1161 or else not In_Instance
1166 Gen_Par
:= Generic_Parent_Type
(Parent
(Par
));
1169 Gen_Prim
:= Collect_Primitive_Operations
(Gen_Par
);
1170 Elmt
:= First_Elmt
(Gen_Prim
);
1172 while Present
(Elmt
) loop
1173 if Chars
(Node
(Elmt
)) = Chars
(S
) then
1179 F1
:= First_Formal
(S
);
1180 F2
:= First_Formal
(Node
(Elmt
));
1183 and then Present
(F2
)
1186 if Etype
(F1
) = Etype
(F2
)
1187 or else Etype
(F2
) = Gen_Par
1193 exit; -- not the right subprogram
1205 raise Program_Error
;
1206 end Inherited_From_Formal
;
1208 -- Start of processing for Expand_Call
1211 -- Call using access to subprogram with explicit dereference
1213 if Nkind
(Name
(N
)) = N_Explicit_Dereference
then
1214 Subp
:= Etype
(Name
(N
));
1215 Parent_Subp
:= Empty
;
1217 -- Case of call to simple entry, where the Name is a selected component
1218 -- whose prefix is the task, and whose selector name is the entry name
1220 elsif Nkind
(Name
(N
)) = N_Selected_Component
then
1221 Subp
:= Entity
(Selector_Name
(Name
(N
)));
1222 Parent_Subp
:= Empty
;
1224 -- Case of call to member of entry family, where Name is an indexed
1225 -- component, with the prefix being a selected component giving the
1226 -- task and entry family name, and the index being the entry index.
1228 elsif Nkind
(Name
(N
)) = N_Indexed_Component
then
1229 Subp
:= Entity
(Selector_Name
(Prefix
(Name
(N
))));
1230 Parent_Subp
:= Empty
;
1235 Subp
:= Entity
(Name
(N
));
1236 Parent_Subp
:= Alias
(Subp
);
1238 -- Replace call to Raise_Exception by call to Raise_Exception_Always
1239 -- if we can tell that the first parameter cannot possibly be null.
1241 if not Restrictions
(No_Exception_Handlers
)
1242 and then Is_RTE
(Subp
, RE_Raise_Exception
)
1245 FA
: constant Node_Id
:= Original_Node
(First_Actual
(N
));
1248 -- The case we catch is where the first argument is obtained
1249 -- using the Identity attribute (which must always be non-null)
1251 if Nkind
(FA
) = N_Attribute_Reference
1252 and then Attribute_Name
(FA
) = Name_Identity
1254 Subp
:= RTE
(RE_Raise_Exception_Always
);
1255 Set_Entity
(Name
(N
), Subp
);
1260 if Ekind
(Subp
) = E_Entry
then
1261 Parent_Subp
:= Empty
;
1265 -- First step, compute extra actuals, corresponding to any
1266 -- Extra_Formals present. Note that we do not access Extra_Formals
1267 -- directly, instead we simply note the presence of the extra
1268 -- formals as we process the regular formals and collect the
1269 -- corresponding actuals in Extra_Actuals.
1271 Formal
:= First_Formal
(Subp
);
1272 Actual
:= First_Actual
(N
);
1274 while Present
(Formal
) loop
1276 Prev_Orig
:= Original_Node
(Prev
);
1278 -- Create possible extra actual for constrained case. Usually,
1279 -- the extra actual is of the form actual'constrained, but since
1280 -- this attribute is only available for unconstrained records,
1281 -- TRUE is expanded if the type of the formal happens to be
1282 -- constrained (for instance when this procedure is inherited
1283 -- from an unconstrained record to a constrained one) or if the
1284 -- actual has no discriminant (its type is constrained). An
1285 -- exception to this is the case of a private type without
1286 -- discriminants. In this case we pass FALSE because the
1287 -- object has underlying discriminants with defaults.
1289 if Present
(Extra_Constrained
(Formal
)) then
1290 if Ekind
(Etype
(Prev
)) in Private_Kind
1291 and then not Has_Discriminants
(Base_Type
(Etype
(Prev
)))
1294 New_Occurrence_Of
(Standard_False
, Loc
),
1295 Extra_Constrained
(Formal
));
1297 elsif Is_Constrained
(Etype
(Formal
))
1298 or else not Has_Discriminants
(Etype
(Prev
))
1301 New_Occurrence_Of
(Standard_True
, Loc
),
1302 Extra_Constrained
(Formal
));
1305 -- If the actual is a type conversion, then the constrained
1306 -- test applies to the actual, not the target type.
1309 Act_Prev
: Node_Id
:= Prev
;
1312 -- Test for unchecked conversions as well, which can
1313 -- occur as out parameter actuals on calls to stream
1316 if Nkind
(Act_Prev
) = N_Type_Conversion
1317 or else Nkind
(Act_Prev
) = N_Unchecked_Type_Conversion
1319 Act_Prev
:= Expression
(Act_Prev
);
1323 Make_Attribute_Reference
(Sloc
(Prev
),
1324 Prefix
=> Duplicate_Subexpr
(Act_Prev
, Name_Req
=> True),
1325 Attribute_Name
=> Name_Constrained
),
1326 Extra_Constrained
(Formal
));
1331 -- Create possible extra actual for accessibility level
1333 if Present
(Extra_Accessibility
(Formal
)) then
1334 if Is_Entity_Name
(Prev_Orig
) then
1336 -- When passing an access parameter as the actual to another
1337 -- access parameter we need to pass along the actual's own
1338 -- associated access level parameter. This is done is we are
1339 -- in the scope of the formal access parameter (if this is an
1340 -- inlined body the extra formal is irrelevant).
1342 if Ekind
(Entity
(Prev_Orig
)) in Formal_Kind
1343 and then Ekind
(Etype
(Prev_Orig
)) = E_Anonymous_Access_Type
1344 and then In_Open_Scopes
(Scope
(Entity
(Prev_Orig
)))
1347 Parm_Ent
: constant Entity_Id
:= Param_Entity
(Prev_Orig
);
1350 pragma Assert
(Present
(Parm_Ent
));
1352 if Present
(Extra_Accessibility
(Parm_Ent
)) then
1355 (Extra_Accessibility
(Parm_Ent
), Loc
),
1356 Extra_Accessibility
(Formal
));
1358 -- If the actual access parameter does not have an
1359 -- associated extra formal providing its scope level,
1360 -- then treat the actual as having library-level
1365 Make_Integer_Literal
(Loc
,
1366 Intval
=> Scope_Depth
(Standard_Standard
)),
1367 Extra_Accessibility
(Formal
));
1371 -- The actual is a normal access value, so just pass the
1372 -- level of the actual's access type.
1376 Make_Integer_Literal
(Loc
,
1377 Intval
=> Type_Access_Level
(Etype
(Prev_Orig
))),
1378 Extra_Accessibility
(Formal
));
1382 case Nkind
(Prev_Orig
) is
1384 when N_Attribute_Reference
=>
1386 case Get_Attribute_Id
(Attribute_Name
(Prev_Orig
)) is
1388 -- For X'Access, pass on the level of the prefix X
1390 when Attribute_Access
=>
1392 Make_Integer_Literal
(Loc
,
1394 Object_Access_Level
(Prefix
(Prev_Orig
))),
1395 Extra_Accessibility
(Formal
));
1397 -- Treat the unchecked attributes as library-level
1399 when Attribute_Unchecked_Access |
1400 Attribute_Unrestricted_Access
=>
1402 Make_Integer_Literal
(Loc
,
1403 Intval
=> Scope_Depth
(Standard_Standard
)),
1404 Extra_Accessibility
(Formal
));
1406 -- No other cases of attributes returning access
1407 -- values that can be passed to access parameters
1410 raise Program_Error
;
1414 -- For allocators we pass the level of the execution of
1415 -- the called subprogram, which is one greater than the
1416 -- current scope level.
1420 Make_Integer_Literal
(Loc
,
1421 Scope_Depth
(Current_Scope
) + 1),
1422 Extra_Accessibility
(Formal
));
1424 -- For other cases we simply pass the level of the
1425 -- actual's access type.
1429 Make_Integer_Literal
(Loc
,
1430 Intval
=> Type_Access_Level
(Etype
(Prev_Orig
))),
1431 Extra_Accessibility
(Formal
));
1437 -- Perform the check of 4.6(49) that prevents a null value
1438 -- from being passed as an actual to an access parameter.
1439 -- Note that the check is elided in the common cases of
1440 -- passing an access attribute or access parameter as an
1441 -- actual. Also, we currently don't enforce this check for
1442 -- expander-generated actuals and when -gnatdj is set.
1444 if Ekind
(Etype
(Formal
)) /= E_Anonymous_Access_Type
1445 or else Suppress_Accessibility_Checks
(Subp
)
1449 elsif Debug_Flag_J
then
1452 elsif not Comes_From_Source
(Prev
) then
1455 elsif Is_Entity_Name
(Prev
)
1456 and then Ekind
(Etype
(Prev
)) = E_Anonymous_Access_Type
1460 elsif Nkind
(Prev
) = N_Allocator
1461 or else Nkind
(Prev
) = N_Attribute_Reference
1465 -- Suppress null checks when passing to access parameters
1466 -- of Java subprograms. (Should this be done for other
1467 -- foreign conventions as well ???)
1469 elsif Convention
(Subp
) = Convention_Java
then
1475 Left_Opnd
=> Duplicate_Subexpr
(Prev
),
1476 Right_Opnd
=> Make_Null
(Loc
));
1477 Insert_Action
(Prev
, Make_Raise_Constraint_Error
(Loc
, Cond
));
1480 -- Perform appropriate validity checks on parameters
1482 if Validity_Checks_On
then
1484 if Ekind
(Formal
) = E_In_Parameter
1485 and then Validity_Check_In_Params
1487 Ensure_Valid
(Actual
);
1489 elsif Ekind
(Formal
) = E_In_Out_Parameter
1490 and then Validity_Check_In_Out_Params
1492 Ensure_Valid
(Actual
);
1496 -- For IN OUT and OUT parameters, ensure that subscripts are valid
1497 -- since this is a left side reference. We only do this for calls
1498 -- from the source program since we assume that compiler generated
1499 -- calls explicitly generate any required checks. We also need it
1500 -- only if we are doing standard validity checks, since clearly it
1501 -- is not needed if validity checks are off, and in subscript
1502 -- validity checking mode, all indexed components are checked with
1503 -- a call directly from Expand_N_Indexed_Component.
1505 if Comes_From_Source
(N
)
1506 and then Ekind
(Formal
) /= E_In_Parameter
1507 and then Validity_Checks_On
1508 and then Validity_Check_Default
1509 and then not Validity_Check_Subscripts
1511 Check_Valid_Lvalue_Subscripts
(Actual
);
1514 -- If the formal is class wide and the actual is an aggregate, force
1515 -- evaluation so that the back end who does not know about class-wide
1516 -- type, does not generate a temporary of the wrong size.
1518 if not Is_Class_Wide_Type
(Etype
(Formal
)) then
1521 elsif Nkind
(Actual
) = N_Aggregate
1522 or else (Nkind
(Actual
) = N_Qualified_Expression
1523 and then Nkind
(Expression
(Actual
)) = N_Aggregate
)
1525 Force_Evaluation
(Actual
);
1528 -- In a remote call, if the formal is of a class-wide type, check
1529 -- that the actual meets the requirements described in E.4(18).
1532 and then Is_Class_Wide_Type
(Etype
(Formal
))
1534 Insert_Action
(Actual
,
1535 Make_Implicit_If_Statement
(N
,
1538 Get_Remotely_Callable
(Duplicate_Subexpr
(Actual
))),
1539 Then_Statements
=> New_List
(
1540 Make_Procedure_Call_Statement
(Loc
,
1541 New_Occurrence_Of
(RTE
1542 (RE_Raise_Program_Error_For_E_4_18
), Loc
)))));
1545 Next_Actual
(Actual
);
1546 Next_Formal
(Formal
);
1549 -- If we are expanding a rhs of an assignement we need to check if
1550 -- tag propagation is needed. This code belongs theorically in Analyze
1551 -- Assignment but has to be done earlier (bottom-up) because the
1552 -- assignment might be transformed into a declaration for an uncons-
1553 -- trained value, if the expression is classwide.
1555 if Nkind
(N
) = N_Function_Call
1556 and then Is_Tag_Indeterminate
(N
)
1557 and then Is_Entity_Name
(Name
(N
))
1560 Ass
: Node_Id
:= Empty
;
1563 if Nkind
(Parent
(N
)) = N_Assignment_Statement
then
1566 elsif Nkind
(Parent
(N
)) = N_Qualified_Expression
1567 and then Nkind
(Parent
(Parent
(N
))) = N_Assignment_Statement
1569 Ass
:= Parent
(Parent
(N
));
1573 and then Is_Class_Wide_Type
(Etype
(Name
(Ass
)))
1575 Propagate_Tag
(Name
(Ass
), N
);
1581 -- Deals with Dispatch_Call if we still have a call, before expanding
1582 -- extra actuals since this will be done on the re-analysis of the
1583 -- dispatching call. Note that we do not try to shorten the actual
1584 -- list for a dispatching call, it would not make sense to do so.
1585 -- Expansion of dispatching calls is suppressed when Java_VM, because
1586 -- the JVM back end directly handles the generation of dispatching
1587 -- calls and would have to undo any expansion to an indirect call.
1589 if (Nkind
(N
) = N_Function_Call
1590 or else Nkind
(N
) = N_Procedure_Call_Statement
)
1591 and then Present
(Controlling_Argument
(N
))
1592 and then not Java_VM
1594 Expand_Dispatch_Call
(N
);
1597 -- Similarly, expand calls to RCI subprograms on which pragma
1598 -- All_Calls_Remote applies. The rewriting will be reanalyzed
1599 -- later. Do this only when the call comes from source since we do
1600 -- not want such a rewritting to occur in expanded code.
1602 elsif Is_All_Remote_Call
(N
) then
1603 Expand_All_Calls_Remote_Subprogram_Call
(N
);
1605 -- Similarly, do not add extra actuals for an entry call whose entity
1606 -- is a protected procedure, or for an internal protected subprogram
1607 -- call, because it will be rewritten as a protected subprogram call
1608 -- and reanalyzed (see Expand_Protected_Subprogram_Call).
1610 elsif Is_Protected_Type
(Scope
(Subp
))
1611 and then (Ekind
(Subp
) = E_Procedure
1612 or else Ekind
(Subp
) = E_Function
)
1616 -- During that loop we gathered the extra actuals (the ones that
1617 -- correspond to Extra_Formals), so now they can be appended.
1620 while Is_Non_Empty_List
(Extra_Actuals
) loop
1621 Add_Actual_Parameter
(Remove_Head
(Extra_Actuals
));
1625 if Ekind
(Subp
) = E_Procedure
1626 or else (Ekind
(Subp
) = E_Subprogram_Type
1627 and then Etype
(Subp
) = Standard_Void_Type
)
1628 or else Is_Entry
(Subp
)
1630 Expand_Actuals
(N
, Subp
);
1633 -- If the subprogram is a renaming, or if it is inherited, replace it
1634 -- in the call with the name of the actual subprogram being called.
1635 -- If this is a dispatching call, the run-time decides what to call.
1636 -- The Alias attribute does not apply to entries.
1638 if Nkind
(N
) /= N_Entry_Call_Statement
1639 and then No
(Controlling_Argument
(N
))
1640 and then Present
(Parent_Subp
)
1642 if Present
(Inherited_From_Formal
(Subp
)) then
1643 Parent_Subp
:= Inherited_From_Formal
(Subp
);
1645 while Present
(Alias
(Parent_Subp
)) loop
1646 Parent_Subp
:= Alias
(Parent_Subp
);
1650 Set_Entity
(Name
(N
), Parent_Subp
);
1652 if Is_Abstract
(Parent_Subp
)
1653 and then not In_Instance
1656 ("cannot call abstract subprogram &!", Name
(N
), Parent_Subp
);
1659 -- Add an explicit conversion for parameter of the derived type.
1660 -- This is only done for scalar and access in-parameters. Others
1661 -- have been expanded in expand_actuals.
1663 Formal
:= First_Formal
(Subp
);
1664 Parent_Formal
:= First_Formal
(Parent_Subp
);
1665 Actual
:= First_Actual
(N
);
1667 -- It is not clear that conversion is needed for intrinsic
1668 -- subprograms, but it certainly is for those that are user-
1669 -- defined, and that can be inherited on derivation, namely
1670 -- unchecked conversion and deallocation.
1671 -- General case needs study ???
1673 if not Is_Intrinsic_Subprogram
(Parent_Subp
)
1674 or else Is_Generic_Instance
(Parent_Subp
)
1676 while Present
(Formal
) loop
1678 if Etype
(Formal
) /= Etype
(Parent_Formal
)
1679 and then Is_Scalar_Type
(Etype
(Formal
))
1680 and then Ekind
(Formal
) = E_In_Parameter
1683 OK_Convert_To
(Etype
(Parent_Formal
),
1684 Relocate_Node
(Actual
)));
1687 Resolve
(Actual
, Etype
(Parent_Formal
));
1688 Enable_Range_Check
(Actual
);
1690 elsif Is_Access_Type
(Etype
(Formal
))
1691 and then Base_Type
(Etype
(Parent_Formal
))
1692 /= Base_Type
(Etype
(Actual
))
1694 if Ekind
(Formal
) /= E_In_Parameter
then
1696 Convert_To
(Etype
(Parent_Formal
),
1697 Relocate_Node
(Actual
)));
1700 Resolve
(Actual
, Etype
(Parent_Formal
));
1703 Ekind
(Etype
(Parent_Formal
)) = E_Anonymous_Access_Type
1705 Designated_Type
(Etype
(Parent_Formal
))
1706 /= Designated_Type
(Etype
(Actual
))
1707 and then not Is_Controlling_Formal
(Formal
)
1710 -- This unchecked conversion is not necessary unless
1711 -- inlining is unabled, because in that case the type
1712 -- mismatch may become visible in the body about to be
1716 Unchecked_Convert_To
(Etype
(Parent_Formal
),
1717 Relocate_Node
(Actual
)));
1720 Resolve
(Actual
, Etype
(Parent_Formal
));
1724 Next_Formal
(Formal
);
1725 Next_Formal
(Parent_Formal
);
1726 Next_Actual
(Actual
);
1731 Subp
:= Parent_Subp
;
1734 -- Some more special cases for cases other than explicit dereference
1736 if Nkind
(Name
(N
)) /= N_Explicit_Dereference
then
1738 -- Calls to an enumeration literal are replaced by the literal
1739 -- This case occurs only when we have a call to a function that
1740 -- is a renaming of an enumeration literal. The normal case of
1741 -- a direct reference to an enumeration literal has already been
1742 -- been dealt with by Resolve_Call. If the function is itself
1743 -- inherited (see 7423-001) the literal of the parent type must
1744 -- be explicitly converted to the return type of the function.
1746 if Ekind
(Subp
) = E_Enumeration_Literal
then
1747 if Base_Type
(Etype
(Subp
)) /= Base_Type
(Etype
(N
)) then
1749 (N
, Convert_To
(Etype
(N
), New_Occurrence_Of
(Subp
, Loc
)));
1751 Rewrite
(N
, New_Occurrence_Of
(Subp
, Loc
));
1752 Resolve
(N
, Etype
(N
));
1756 -- Handle case of access to protected subprogram type
1759 if Ekind
(Base_Type
(Etype
(Prefix
(Name
(N
))))) =
1760 E_Access_Protected_Subprogram_Type
1762 -- If this is a call through an access to protected operation,
1763 -- the prefix has the form (object'address, operation'access).
1764 -- Rewrite as a for other protected calls: the object is the
1765 -- first parameter of the list of actuals.
1772 Ptr
: Node_Id
:= Prefix
(Name
(N
));
1773 T
: Entity_Id
:= Equivalent_Type
(Base_Type
(Etype
(Ptr
)));
1774 D_T
: Entity_Id
:= Designated_Type
(Base_Type
(Etype
(Ptr
)));
1777 Obj
:= Make_Selected_Component
(Loc
,
1778 Prefix
=> Unchecked_Convert_To
(T
, Ptr
),
1779 Selector_Name
=> New_Occurrence_Of
(First_Entity
(T
), Loc
));
1781 Nam
:= Make_Selected_Component
(Loc
,
1782 Prefix
=> Unchecked_Convert_To
(T
, Ptr
),
1783 Selector_Name
=> New_Occurrence_Of
(
1784 Next_Entity
(First_Entity
(T
)), Loc
));
1786 Nam
:= Make_Explicit_Dereference
(Loc
, Nam
);
1788 if Present
(Parameter_Associations
(N
)) then
1789 Parm
:= Parameter_Associations
(N
);
1794 Prepend
(Obj
, Parm
);
1796 if Etype
(D_T
) = Standard_Void_Type
then
1797 Call
:= Make_Procedure_Call_Statement
(Loc
,
1799 Parameter_Associations
=> Parm
);
1801 Call
:= Make_Function_Call
(Loc
,
1803 Parameter_Associations
=> Parm
);
1806 Set_First_Named_Actual
(Call
, First_Named_Actual
(N
));
1808 Set_Etype
(Call
, Etype
(D_T
));
1810 -- We do not re-analyze the call to avoid infinite recursion.
1811 -- We analyze separately the prefix and the object, and set
1812 -- the checks on the prefix that would otherwise be emitted
1813 -- when resolving a call.
1817 Apply_Access_Check
(Nam
);
1824 -- If this is a call to an intrinsic subprogram, then perform the
1825 -- appropriate expansion to the corresponding tree node and we
1826 -- are all done (since after that the call is gone!)
1828 if Is_Intrinsic_Subprogram
(Subp
) then
1829 Expand_Intrinsic_Call
(N
, Subp
);
1833 if Ekind
(Subp
) = E_Function
1834 or else Ekind
(Subp
) = E_Procedure
1836 if Is_Inlined
(Subp
) then
1839 Spec
: constant Node_Id
:= Unit_Declaration_Node
(Subp
);
1842 -- Verify that the body to inline has already been seen,
1843 -- and that if the body is in the current unit the inlining
1844 -- does not occur earlier. This avoids order-of-elaboration
1845 -- problems in gigi.
1848 and then Nkind
(Spec
) = N_Subprogram_Declaration
1849 and then Present
(Body_To_Inline
(Spec
))
1850 and then (In_Extended_Main_Code_Unit
(N
)
1851 or else In_Extended_Main_Code_Unit
(Parent
(N
)))
1852 and then (not In_Same_Extended_Unit
1853 (Sloc
(Body_To_Inline
(Spec
)), Loc
)
1855 Earlier_In_Extended_Unit
1856 (Sloc
(Body_To_Inline
(Spec
)), Loc
))
1858 Expand_Inlined_Call
(N
, Subp
, Orig_Subp
);
1861 -- Let the back-end handle it.
1863 Add_Inlined_Body
(Subp
);
1865 if Front_End_Inlining
1866 and then Nkind
(Spec
) = N_Subprogram_Declaration
1867 and then (In_Extended_Main_Code_Unit
(N
))
1868 and then No
(Body_To_Inline
(Spec
))
1869 and then not Has_Completion
(Subp
)
1870 and then In_Same_Extended_Unit
(Sloc
(Spec
), Loc
)
1871 and then Ineffective_Inline_Warnings
1874 ("call cannot be inlined before body is seen?", N
);
1881 -- Check for a protected subprogram. This is either an intra-object
1882 -- call, or a protected function call. Protected procedure calls are
1883 -- rewritten as entry calls and handled accordingly.
1885 Scop
:= Scope
(Subp
);
1887 if Nkind
(N
) /= N_Entry_Call_Statement
1888 and then Is_Protected_Type
(Scop
)
1890 -- If the call is an internal one, it is rewritten as a call to
1891 -- to the corresponding unprotected subprogram.
1893 Expand_Protected_Subprogram_Call
(N
, Subp
, Scop
);
1896 -- Functions returning controlled objects need special attention
1898 if Controlled_Type
(Etype
(Subp
))
1899 and then not Is_Return_By_Reference_Type
(Etype
(Subp
))
1901 Expand_Ctrl_Function_Call
(N
);
1904 -- Test for First_Optional_Parameter, and if so, truncate parameter
1905 -- list if there are optional parameters at the trailing end.
1906 -- Note we never delete procedures for call via a pointer.
1908 if (Ekind
(Subp
) = E_Procedure
or else Ekind
(Subp
) = E_Function
)
1909 and then Present
(First_Optional_Parameter
(Subp
))
1912 Last_Keep_Arg
: Node_Id
;
1915 -- Last_Keep_Arg will hold the last actual that should be
1916 -- retained. If it remains empty at the end, it means that
1917 -- all parameters are optional.
1919 Last_Keep_Arg
:= Empty
;
1921 -- Find first optional parameter, must be present since we
1922 -- checked the validity of the parameter before setting it.
1924 Formal
:= First_Formal
(Subp
);
1925 Actual
:= First_Actual
(N
);
1926 while Formal
/= First_Optional_Parameter
(Subp
) loop
1927 Last_Keep_Arg
:= Actual
;
1928 Next_Formal
(Formal
);
1929 Next_Actual
(Actual
);
1932 -- Now we have Formal and Actual pointing to the first
1933 -- potentially droppable argument. We can drop all the
1934 -- trailing arguments whose actual matches the default.
1935 -- Note that we know that all remaining formals have
1936 -- defaults, because we checked that this requirement
1937 -- was met before setting First_Optional_Parameter.
1939 -- We use Fully_Conformant_Expressions to check for identity
1940 -- between formals and actuals, which may miss some cases, but
1941 -- on the other hand, this is only an optimization (if we fail
1942 -- to truncate a parameter it does not affect functionality).
1943 -- So if the default is 3 and the actual is 1+2, we consider
1944 -- them unequal, which hardly seems worrisome.
1946 while Present
(Formal
) loop
1947 if not Fully_Conformant_Expressions
1948 (Actual
, Default_Value
(Formal
))
1950 Last_Keep_Arg
:= Actual
;
1953 Next_Formal
(Formal
);
1954 Next_Actual
(Actual
);
1957 -- If no arguments, delete entire list, this is the easy case
1959 if No
(Last_Keep_Arg
) then
1960 while Is_Non_Empty_List
(Parameter_Associations
(N
)) loop
1961 Delete_Tree
(Remove_Head
(Parameter_Associations
(N
)));
1964 Set_Parameter_Associations
(N
, No_List
);
1965 Set_First_Named_Actual
(N
, Empty
);
1967 -- Case where at the last retained argument is positional. This
1968 -- is also an easy case, since the retained arguments are already
1969 -- in the right form, and we don't need to worry about the order
1970 -- of arguments that get eliminated.
1972 elsif Is_List_Member
(Last_Keep_Arg
) then
1973 while Present
(Next
(Last_Keep_Arg
)) loop
1974 Delete_Tree
(Remove_Next
(Last_Keep_Arg
));
1977 Set_First_Named_Actual
(N
, Empty
);
1979 -- This is the annoying case where the last retained argument
1980 -- is a named parameter. Since the original arguments are not
1981 -- in declaration order, we may have to delete some fairly
1982 -- random collection of arguments.
1991 -- First step, remove all the named parameters from the
1992 -- list (they are still chained using First_Named_Actual
1993 -- and Next_Named_Actual, so we have not lost them!)
1995 Temp
:= First
(Parameter_Associations
(N
));
1997 -- Case of all parameters named, remove them all
1999 if Nkind
(Temp
) = N_Parameter_Association
then
2000 while Is_Non_Empty_List
(Parameter_Associations
(N
)) loop
2001 Temp
:= Remove_Head
(Parameter_Associations
(N
));
2004 -- Case of mixed positional/named, remove named parameters
2007 while Nkind
(Next
(Temp
)) /= N_Parameter_Association
loop
2011 while Present
(Next
(Temp
)) loop
2012 Junk
:= Remove_Next
(Temp
);
2016 -- Now we loop through the named parameters, till we get
2017 -- to the last one to be retained, adding them to the list.
2018 -- Note that the Next_Named_Actual list does not need to be
2019 -- touched since we are only reordering them on the actual
2020 -- parameter association list.
2022 Passoc
:= Parent
(First_Named_Actual
(N
));
2024 Temp
:= Relocate_Node
(Passoc
);
2026 (Parameter_Associations
(N
), Temp
);
2028 Last_Keep_Arg
= Explicit_Actual_Parameter
(Passoc
);
2029 Passoc
:= Parent
(Next_Named_Actual
(Passoc
));
2032 Set_Next_Named_Actual
(Temp
, Empty
);
2035 Temp
:= Next_Named_Actual
(Passoc
);
2036 exit when No
(Temp
);
2037 Set_Next_Named_Actual
2038 (Passoc
, Next_Named_Actual
(Parent
(Temp
)));
2048 --------------------------
2049 -- Expand_Inlined_Call --
2050 --------------------------
2052 procedure Expand_Inlined_Call
2055 Orig_Subp
: Entity_Id
)
2057 Loc
: constant Source_Ptr
:= Sloc
(N
);
2061 Exit_Lab
: Entity_Id
:= Empty
;
2068 Orig_Bod
: constant Node_Id
:=
2069 Body_To_Inline
(Unit_Declaration_Node
(Subp
));
2070 Ret_Type
: Entity_Id
;
2073 Temp_Typ
: Entity_Id
;
2075 procedure Make_Exit_Label
;
2076 -- Build declaration for exit label to be used in Return statements.
2078 function Process_Formals
(N
: Node_Id
) return Traverse_Result
;
2079 -- Replace occurrence of a formal with the corresponding actual, or
2080 -- the thunk generated for it.
2082 procedure Rewrite_Function_Call
(N
: Node_Id
; Blk
: Node_Id
);
2083 -- If the function body is a single expression, replace call with
2084 -- expression, else insert block appropriately.
2086 procedure Rewrite_Procedure_Call
(N
: Node_Id
; Blk
: Node_Id
);
2087 -- If procedure body has no local variables, inline body without
2088 -- creating block, otherwise rewrite call with block.
2090 ---------------------
2091 -- Make_Exit_Label --
2092 ---------------------
2094 procedure Make_Exit_Label
is
2096 -- Create exit label for subprogram, if one doesn't exist yet.
2098 if No
(Exit_Lab
) then
2099 Lab_Id
:= Make_Identifier
(Loc
, New_Internal_Name
('L'));
2101 Make_Defining_Identifier
(Loc
, Chars
(Lab_Id
)));
2102 Exit_Lab
:= Make_Label
(Loc
, Lab_Id
);
2105 Make_Implicit_Label_Declaration
(Loc
,
2106 Defining_Identifier
=> Entity
(Lab_Id
),
2107 Label_Construct
=> Exit_Lab
);
2109 end Make_Exit_Label
;
2111 ---------------------
2112 -- Process_Formals --
2113 ---------------------
2115 function Process_Formals
(N
: Node_Id
) return Traverse_Result
is
2121 if Is_Entity_Name
(N
)
2122 and then Present
(Entity
(N
))
2127 and then Scope
(E
) = Subp
2129 A
:= Renamed_Object
(E
);
2131 if Is_Entity_Name
(A
) then
2132 Rewrite
(N
, New_Occurrence_Of
(Entity
(A
), Loc
));
2134 elsif Nkind
(A
) = N_Defining_Identifier
then
2135 Rewrite
(N
, New_Occurrence_Of
(A
, Loc
));
2137 else -- numeric literal
2138 Rewrite
(N
, New_Copy
(A
));
2144 elsif Nkind
(N
) = N_Return_Statement
then
2146 if No
(Expression
(N
)) then
2148 Rewrite
(N
, Make_Goto_Statement
(Loc
,
2149 Name
=> New_Copy
(Lab_Id
)));
2152 if Nkind
(Parent
(N
)) = N_Handled_Sequence_Of_Statements
2153 and then Nkind
(Parent
(Parent
(N
))) = N_Subprogram_Body
2155 -- function body is a single expression. No need for
2160 Num_Ret
:= Num_Ret
+ 1;
2164 -- Because of the presence of private types, the views of the
2165 -- expression and the context may be different, so place an
2166 -- unchecked conversion to the context type to avoid spurious
2167 -- errors, eg. when the expression is a numeric literal and
2168 -- the context is private. If the expression is an aggregate,
2169 -- use a qualified expression, because an aggregate is not a
2170 -- legal argument of a conversion.
2172 if Nkind
(Expression
(N
)) = N_Aggregate
then
2174 Make_Qualified_Expression
(Sloc
(N
),
2175 Subtype_Mark
=> New_Occurrence_Of
(Ret_Type
, Sloc
(N
)),
2176 Expression
=> Relocate_Node
(Expression
(N
)));
2179 Unchecked_Convert_To
2180 (Ret_Type
, Relocate_Node
(Expression
(N
)));
2183 if Nkind
(Targ
) = N_Defining_Identifier
then
2185 Make_Assignment_Statement
(Loc
,
2186 Name
=> New_Occurrence_Of
(Targ
, Loc
),
2187 Expression
=> Ret
));
2190 Make_Assignment_Statement
(Loc
,
2191 Name
=> New_Copy
(Targ
),
2192 Expression
=> Ret
));
2195 Set_Assignment_OK
(Name
(N
));
2197 if Present
(Exit_Lab
) then
2199 Make_Goto_Statement
(Loc
,
2200 Name
=> New_Copy
(Lab_Id
)));
2209 end Process_Formals
;
2211 procedure Replace_Formals
is new Traverse_Proc
(Process_Formals
);
2213 ---------------------------
2214 -- Rewrite_Function_Call --
2215 ---------------------------
2217 procedure Rewrite_Function_Call
(N
: Node_Id
; Blk
: Node_Id
) is
2218 HSS
: Node_Id
:= Handled_Statement_Sequence
(Blk
);
2219 Fst
: Node_Id
:= First
(Statements
(HSS
));
2223 -- Optimize simple case: function body is a single return statement,
2224 -- which has been expanded into an assignment.
2226 if Is_Empty_List
(Declarations
(Blk
))
2227 and then Nkind
(Fst
) = N_Assignment_Statement
2228 and then No
(Next
(Fst
))
2231 -- The function call may have been rewritten as the temporary
2232 -- that holds the result of the call, in which case remove the
2233 -- now useless declaration.
2235 if Nkind
(N
) = N_Identifier
2236 and then Nkind
(Parent
(Entity
(N
))) = N_Object_Declaration
2238 Rewrite
(Parent
(Entity
(N
)), Make_Null_Statement
(Loc
));
2241 Rewrite
(N
, Expression
(Fst
));
2243 elsif Nkind
(N
) = N_Identifier
2244 and then Nkind
(Parent
(Entity
(N
))) = N_Object_Declaration
2247 -- The block assigns the result of the call to the temporary.
2249 Insert_After
(Parent
(Entity
(N
)), Blk
);
2251 elsif Nkind
(Parent
(N
)) = N_Assignment_Statement
2252 and then Is_Entity_Name
(Name
(Parent
(N
)))
2255 -- replace assignment with the block.
2257 Rewrite
(Parent
(N
), Blk
);
2259 elsif Nkind
(Parent
(N
)) = N_Object_Declaration
then
2260 Set_Expression
(Parent
(N
), Empty
);
2261 Insert_After
(Parent
(N
), Blk
);
2263 end Rewrite_Function_Call
;
2265 ----------------------------
2266 -- Rewrite_Procedure_Call --
2267 ----------------------------
2269 procedure Rewrite_Procedure_Call
(N
: Node_Id
; Blk
: Node_Id
) is
2270 HSS
: Node_Id
:= Handled_Statement_Sequence
(Blk
);
2273 if Is_Empty_List
(Declarations
(Blk
)) then
2274 Insert_List_After
(N
, Statements
(HSS
));
2275 Rewrite
(N
, Make_Null_Statement
(Loc
));
2279 end Rewrite_Procedure_Call
;
2281 -- Start of processing for Expand_Inlined_Call
2284 if Nkind
(Orig_Bod
) = N_Defining_Identifier
then
2286 -- Subprogram is a renaming_as_body. Calls appearing after the
2287 -- renaming can be replaced with calls to the renamed entity
2288 -- directly, because the subprograms are subtype conformant.
2290 Set_Name
(N
, New_Occurrence_Of
(Orig_Bod
, Loc
));
2294 -- Use generic machinery to copy body of inlined subprogram, as if it
2295 -- were an instantiation, resetting source locations appropriately, so
2296 -- that nested inlined calls appear in the main unit.
2298 Save_Env
(Subp
, Empty
);
2299 Set_Copied_Sloc
(N
, Defining_Entity
(Orig_Bod
));
2302 Copy_Generic_Node
(Orig_Bod
, Empty
, Instantiating
=> True);
2305 Make_Block_Statement
(Loc
,
2306 Declarations
=> Declarations
(Bod
),
2307 Handled_Statement_Sequence
=> Handled_Statement_Sequence
(Bod
));
2309 if No
(Declarations
(Bod
)) then
2310 Set_Declarations
(Blk
, New_List
);
2313 -- If this is a derived function, establish the proper return type.
2315 if Present
(Orig_Subp
)
2316 and then Orig_Subp
/= Subp
2318 Ret_Type
:= Etype
(Orig_Subp
);
2320 Ret_Type
:= Etype
(Subp
);
2323 F
:= First_Formal
(Subp
);
2324 A
:= First_Actual
(N
);
2326 -- Create temporaries for the actuals that are expressions, or that
2327 -- are scalars and require copying to preserve semantics.
2329 while Present
(F
) loop
2331 if Present
(Renamed_Object
(F
)) then
2332 Error_Msg_N
(" cannot inline call to recursive subprogram", N
);
2336 -- If the argument may be a controlling argument in a call within
2337 -- the inlined body, we must preserve its classwide nature to
2338 -- insure that dynamic dispatching take place subsequently.
2339 -- If the formal has a constraint it must be preserved to retain
2340 -- the semantics of the body.
2342 if Is_Class_Wide_Type
(Etype
(F
))
2343 or else (Is_Access_Type
(Etype
(F
))
2345 Is_Class_Wide_Type
(Designated_Type
(Etype
(F
))))
2347 Temp_Typ
:= Etype
(F
);
2349 elsif Base_Type
(Etype
(F
)) = Base_Type
(Etype
(A
))
2350 and then Etype
(F
) /= Base_Type
(Etype
(F
))
2352 Temp_Typ
:= Etype
(F
);
2355 Temp_Typ
:= Etype
(A
);
2358 if (not Is_Entity_Name
(A
)
2359 and then Nkind
(A
) /= N_Integer_Literal
2360 and then Nkind
(A
) /= N_Real_Literal
)
2362 or else Is_Scalar_Type
(Etype
(A
))
2365 Make_Defining_Identifier
(Loc
,
2366 Chars
=> New_Internal_Name
('C'));
2368 -- If the actual for an in/in-out parameter is a view conversion,
2369 -- make it into an unchecked conversion, given that an untagged
2370 -- type conversion is not a proper object for a renaming.
2371 -- In-out conversions that involve real conversions have already
2372 -- been transformed in Expand_Actuals.
2374 if Nkind
(A
) = N_Type_Conversion
2376 (Ekind
(F
) = E_In_Out_Parameter
2377 or else not Is_Tagged_Type
(Etype
(F
)))
2379 New_A
:= Make_Unchecked_Type_Conversion
(Loc
,
2380 Subtype_Mark
=> New_Occurrence_Of
(Etype
(F
), Loc
),
2381 Expression
=> Relocate_Node
(Expression
(A
)));
2383 elsif Etype
(F
) /= Etype
(A
) then
2384 New_A
:= Unchecked_Convert_To
(Etype
(F
), Relocate_Node
(A
));
2385 Temp_Typ
:= Etype
(F
);
2388 New_A
:= Relocate_Node
(A
);
2391 Set_Sloc
(New_A
, Sloc
(N
));
2393 if Ekind
(F
) = E_In_Parameter
2394 and then not Is_Limited_Type
(Etype
(A
))
2397 Make_Object_Declaration
(Loc
,
2398 Defining_Identifier
=> Temp
,
2399 Constant_Present
=> True,
2400 Object_Definition
=> New_Occurrence_Of
(Temp_Typ
, Loc
),
2401 Expression
=> New_A
);
2404 Make_Object_Renaming_Declaration
(Loc
,
2405 Defining_Identifier
=> Temp
,
2406 Subtype_Mark
=> New_Occurrence_Of
(Temp_Typ
, Loc
),
2410 Prepend
(Decl
, Declarations
(Blk
));
2411 Set_Renamed_Object
(F
, Temp
);
2414 if Etype
(F
) /= Etype
(A
) then
2416 (F
, Unchecked_Convert_To
(Etype
(F
), Relocate_Node
(A
)));
2418 Set_Renamed_Object
(F
, A
);
2426 -- Establish target of function call. If context is not assignment or
2427 -- declaration, create a temporary as a target. The declaration for
2428 -- the temporary may be subsequently optimized away if the body is a
2429 -- single expression, or if the left-hand side of the assignment is
2432 if Ekind
(Subp
) = E_Function
then
2433 if Nkind
(Parent
(N
)) = N_Assignment_Statement
2434 and then Is_Entity_Name
(Name
(Parent
(N
)))
2436 Targ
:= Name
(Parent
(N
));
2439 -- Replace call with temporary, and create its declaration.
2442 Make_Defining_Identifier
(Loc
, New_Internal_Name
('C'));
2445 Make_Object_Declaration
(Loc
,
2446 Defining_Identifier
=> Temp
,
2447 Object_Definition
=>
2448 New_Occurrence_Of
(Ret_Type
, Loc
));
2450 Set_No_Initialization
(Decl
);
2451 Insert_Action
(N
, Decl
);
2452 Rewrite
(N
, New_Occurrence_Of
(Temp
, Loc
));
2457 -- Traverse the tree and replace formals with actuals or their thunks.
2458 -- Attach block to tree before analysis and rewriting.
2460 Replace_Formals
(Blk
);
2461 Set_Parent
(Blk
, N
);
2463 if Present
(Exit_Lab
) then
2465 -- If the body was a single expression, the single return statement
2466 -- and the corresponding label are useless.
2470 Nkind
(Last
(Statements
(Handled_Statement_Sequence
(Blk
)))) =
2473 Remove
(Last
(Statements
(Handled_Statement_Sequence
(Blk
))));
2475 Append
(Lab_Decl
, (Declarations
(Blk
)));
2476 Append
(Exit_Lab
, Statements
(Handled_Statement_Sequence
(Blk
)));
2480 -- Analyze Blk with In_Inlined_Body set, to avoid spurious errors on
2481 -- conflicting private views that Gigi would ignore.
2484 I_Flag
: constant Boolean := In_Inlined_Body
;
2487 In_Inlined_Body
:= True;
2489 In_Inlined_Body
:= I_Flag
;
2492 if Ekind
(Subp
) = E_Procedure
then
2493 Rewrite_Procedure_Call
(N
, Blk
);
2495 Rewrite_Function_Call
(N
, Blk
);
2500 -- Cleanup mapping between formals and actuals, for other expansions.
2502 F
:= First_Formal
(Subp
);
2504 while Present
(F
) loop
2505 Set_Renamed_Object
(F
, Empty
);
2508 end Expand_Inlined_Call
;
2510 ----------------------------
2511 -- Expand_N_Function_Call --
2512 ----------------------------
2514 procedure Expand_N_Function_Call
(N
: Node_Id
) is
2515 Typ
: constant Entity_Id
:= Etype
(N
);
2517 function Returned_By_Reference
return Boolean;
2518 -- If the return type is returned through the secondary stack. i.e.
2519 -- by reference, we don't want to create a temporary to force stack
2522 function Returned_By_Reference
return Boolean is
2523 S
: Entity_Id
:= Current_Scope
;
2526 if Is_Return_By_Reference_Type
(Typ
) then
2529 elsif Nkind
(Parent
(N
)) /= N_Return_Statement
then
2532 elsif Requires_Transient_Scope
(Typ
) then
2534 -- Verify that the return type of the enclosing function has
2535 -- the same constrained status as that of the expression.
2537 while Ekind
(S
) /= E_Function
loop
2541 return Is_Constrained
(Typ
) = Is_Constrained
(Etype
(S
));
2545 end Returned_By_Reference
;
2547 -- Start of processing for Expand_N_Function_Call
2550 -- A special check. If stack checking is enabled, and the return type
2551 -- might generate a large temporary, and the call is not the right
2552 -- side of an assignment, then generate an explicit temporary. We do
2553 -- this because otherwise gigi may generate a large temporary on the
2554 -- fly and this can cause trouble with stack checking.
2556 if May_Generate_Large_Temp
(Typ
)
2557 and then Nkind
(Parent
(N
)) /= N_Assignment_Statement
2559 (Nkind
(Parent
(N
)) /= N_Object_Declaration
2560 or else Expression
(Parent
(N
)) /= N
)
2561 and then not Returned_By_Reference
2563 -- Note: it might be thought that it would be OK to use a call to
2564 -- Force_Evaluation here, but that's not good enough, because that
2565 -- results in a 'Reference construct that may still need a temporary.
2568 Loc
: constant Source_Ptr
:= Sloc
(N
);
2569 Temp_Obj
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
,
2570 New_Internal_Name
('F'));
2571 Temp_Typ
: Entity_Id
:= Typ
;
2578 if Is_Tagged_Type
(Typ
)
2579 and then Present
(Controlling_Argument
(N
))
2581 if Nkind
(Parent
(N
)) /= N_Procedure_Call_Statement
2582 and then Nkind
(Parent
(N
)) /= N_Function_Call
2584 -- If this is a tag-indeterminate call, the object must
2587 if Is_Tag_Indeterminate
(N
) then
2588 Temp_Typ
:= Class_Wide_Type
(Typ
);
2592 -- If this is a dispatching call that is itself the
2593 -- controlling argument of an enclosing call, the nominal
2594 -- subtype of the object that replaces it must be classwide,
2595 -- so that dispatching will take place properly. If it is
2596 -- not a controlling argument, the object is not classwide.
2598 Proc
:= Entity
(Name
(Parent
(N
)));
2599 F
:= First_Formal
(Proc
);
2600 A
:= First_Actual
(Parent
(N
));
2607 if Is_Controlling_Formal
(F
) then
2608 Temp_Typ
:= Class_Wide_Type
(Typ
);
2614 Make_Object_Declaration
(Loc
,
2615 Defining_Identifier
=> Temp_Obj
,
2616 Object_Definition
=> New_Occurrence_Of
(Temp_Typ
, Loc
),
2617 Constant_Present
=> True,
2618 Expression
=> Relocate_Node
(N
));
2619 Set_Assignment_OK
(Decl
);
2621 Insert_Actions
(N
, New_List
(Decl
));
2622 Rewrite
(N
, New_Occurrence_Of
(Temp_Obj
, Loc
));
2625 -- Normal case, expand the call
2630 end Expand_N_Function_Call
;
2632 ---------------------------------------
2633 -- Expand_N_Procedure_Call_Statement --
2634 ---------------------------------------
2636 procedure Expand_N_Procedure_Call_Statement
(N
: Node_Id
) is
2639 end Expand_N_Procedure_Call_Statement
;
2641 ------------------------------
2642 -- Expand_N_Subprogram_Body --
2643 ------------------------------
2645 -- Add poll call if ATC polling is enabled
2647 -- Add return statement if last statement in body is not a return
2648 -- statement (this makes things easier on Gigi which does not want
2649 -- to have to handle a missing return).
2651 -- Add call to Activate_Tasks if body is a task activator
2653 -- Deal with possible detection of infinite recursion
2655 -- Eliminate body completely if convention stubbed
2657 -- Encode entity names within body, since we will not need to reference
2658 -- these entities any longer in the front end.
2660 -- Initialize scalar out parameters if Initialize/Normalize_Scalars
2662 -- Reset Pure indication if any parameter has root type System.Address
2664 procedure Expand_N_Subprogram_Body
(N
: Node_Id
) is
2665 Loc
: constant Source_Ptr
:= Sloc
(N
);
2666 H
: constant Node_Id
:= Handled_Statement_Sequence
(N
);
2667 Body_Id
: Entity_Id
;
2668 Spec_Id
: Entity_Id
;
2675 procedure Add_Return
(S
: List_Id
);
2676 -- Append a return statement to the statement sequence S if the last
2677 -- statement is not already a return or a goto statement. Note that
2678 -- the latter test is not critical, it does not matter if we add a
2679 -- few extra returns, since they get eliminated anyway later on.
2685 procedure Add_Return
(S
: List_Id
) is
2686 Last_S
: constant Node_Id
:= Last
(S
);
2687 -- Get original node, in case raise has been rewritten
2690 if not Is_Transfer
(Last_S
) then
2691 Append_To
(S
, Make_Return_Statement
(Sloc
(Last_S
)));
2695 -- Start of processing for Expand_N_Subprogram_Body
2698 -- Set L to either the list of declarations if present, or
2699 -- to the list of statements if no declarations are present.
2700 -- This is used to insert new stuff at the start.
2702 if Is_Non_Empty_List
(Declarations
(N
)) then
2703 L
:= Declarations
(N
);
2705 L
:= Statements
(Handled_Statement_Sequence
(N
));
2708 -- Need poll on entry to subprogram if polling enabled. We only
2709 -- do this for non-empty subprograms, since it does not seem
2710 -- necessary to poll for a dummy null subprogram.
2712 if Is_Non_Empty_List
(L
) then
2713 Generate_Poll_Call
(First
(L
));
2716 -- Find entity for subprogram
2718 Body_Id
:= Defining_Entity
(N
);
2720 if Present
(Corresponding_Spec
(N
)) then
2721 Spec_Id
:= Corresponding_Spec
(N
);
2726 -- If this is a Pure function which has any parameters whose root
2727 -- type is System.Address, reset the Pure indication, since it will
2728 -- likely cause incorrect code to be generated.
2730 if Is_Pure
(Spec_Id
)
2731 and then Is_Subprogram
(Spec_Id
)
2732 and then not Has_Pragma_Pure_Function
(Spec_Id
)
2735 F
: Entity_Id
:= First_Formal
(Spec_Id
);
2738 while Present
(F
) loop
2739 if Is_RTE
(Root_Type
(Etype
(F
)), RE_Address
) then
2740 Set_Is_Pure
(Spec_Id
, False);
2742 if Spec_Id
/= Body_Id
then
2743 Set_Is_Pure
(Body_Id
, False);
2754 -- Initialize any scalar OUT args if Initialize/Normalize_Scalars
2756 if Init_Or_Norm_Scalars
and then Is_Subprogram
(Spec_Id
) then
2758 F
: Entity_Id
:= First_Formal
(Spec_Id
);
2759 V
: constant Boolean := Validity_Checks_On
;
2762 -- We turn off validity checking, since we do not want any
2763 -- check on the initializing value itself (which we know
2764 -- may well be invalid!)
2766 Validity_Checks_On
:= False;
2768 -- Loop through formals
2770 while Present
(F
) loop
2771 if Is_Scalar_Type
(Etype
(F
))
2772 and then Ekind
(F
) = E_Out_Parameter
2774 Insert_Before_And_Analyze
(First
(L
),
2775 Make_Assignment_Statement
(Loc
,
2776 Name
=> New_Occurrence_Of
(F
, Loc
),
2777 Expression
=> Get_Simple_Init_Val
(Etype
(F
), Loc
)));
2783 Validity_Checks_On
:= V
;
2787 -- Clear out statement list for stubbed procedure
2789 if Present
(Corresponding_Spec
(N
)) then
2790 Set_Elaboration_Flag
(N
, Spec_Id
);
2792 if Convention
(Spec_Id
) = Convention_Stubbed
2793 or else Is_Eliminated
(Spec_Id
)
2795 Set_Declarations
(N
, Empty_List
);
2796 Set_Handled_Statement_Sequence
(N
,
2797 Make_Handled_Sequence_Of_Statements
(Loc
,
2798 Statements
=> New_List
(
2799 Make_Null_Statement
(Loc
))));
2804 Scop
:= Scope
(Spec_Id
);
2806 -- Returns_By_Ref flag is normally set when the subprogram is frozen
2807 -- but subprograms with no specs are not frozen
2810 Typ
: constant Entity_Id
:= Etype
(Spec_Id
);
2811 Utyp
: constant Entity_Id
:= Underlying_Type
(Typ
);
2814 if not Acts_As_Spec
(N
)
2815 and then Nkind
(Parent
(Parent
(Spec_Id
))) /=
2816 N_Subprogram_Body_Stub
2820 elsif Is_Return_By_Reference_Type
(Typ
) then
2821 Set_Returns_By_Ref
(Spec_Id
);
2823 elsif Present
(Utyp
) and then Controlled_Type
(Utyp
) then
2824 Set_Returns_By_Ref
(Spec_Id
);
2828 -- For a procedure, we add a return for all possible syntactic ends
2829 -- of the subprogram. Note that reanalysis is not necessary in this
2830 -- case since it would require a lot of work and accomplish nothing.
2832 if Ekind
(Spec_Id
) = E_Procedure
2833 or else Ekind
(Spec_Id
) = E_Generic_Procedure
2835 Add_Return
(Statements
(H
));
2837 if Present
(Exception_Handlers
(H
)) then
2838 Except_H
:= First_Non_Pragma
(Exception_Handlers
(H
));
2840 while Present
(Except_H
) loop
2841 Add_Return
(Statements
(Except_H
));
2842 Next_Non_Pragma
(Except_H
);
2846 -- For a function, we must deal with the case where there is at
2847 -- least one missing return. What we do is to wrap the entire body
2848 -- of the function in a block:
2861 -- raise Program_Error;
2864 -- This approach is necessary because the raise must be signalled
2865 -- to the caller, not handled by any local handler (RM 6.4(11)).
2867 -- Note: we do not need to analyze the constructed sequence here,
2868 -- since it has no handler, and an attempt to analyze the handled
2869 -- statement sequence twice is risky in various ways (e.g. the
2870 -- issue of expanding cleanup actions twice).
2872 elsif Has_Missing_Return
(Spec_Id
) then
2874 Hloc
: constant Source_Ptr
:= Sloc
(H
);
2875 Blok
: constant Node_Id
:=
2876 Make_Block_Statement
(Hloc
,
2877 Handled_Statement_Sequence
=> H
);
2878 Rais
: constant Node_Id
:=
2879 Make_Raise_Program_Error
(Hloc
);
2882 Set_Handled_Statement_Sequence
(N
,
2883 Make_Handled_Sequence_Of_Statements
(Hloc
,
2884 Statements
=> New_List
(Blok
, Rais
)));
2886 New_Scope
(Spec_Id
);
2893 -- Add discriminal renamings to protected subprograms.
2894 -- Install new discriminals for expansion of the next
2895 -- subprogram of this protected type, if any.
2897 if Is_List_Member
(N
)
2898 and then Present
(Parent
(List_Containing
(N
)))
2899 and then Nkind
(Parent
(List_Containing
(N
))) = N_Protected_Body
2901 Add_Discriminal_Declarations
2902 (Declarations
(N
), Scop
, Name_uObject
, Loc
);
2903 Add_Private_Declarations
(Declarations
(N
), Scop
, Name_uObject
, Loc
);
2905 -- Associate privals and discriminals with the next protected
2906 -- operation body to be expanded. These are used to expand
2907 -- references to private data objects and discriminants,
2910 Next_Op
:= Next_Protected_Operation
(N
);
2912 if Present
(Next_Op
) then
2913 Dec
:= Parent
(Base_Type
(Scop
));
2914 Set_Privals
(Dec
, Next_Op
, Loc
);
2915 Set_Discriminals
(Dec
, Next_Op
, Loc
);
2919 -- If subprogram contains a parameterless recursive call, then we may
2920 -- have an infinite recursion, so see if we can generate code to check
2921 -- for this possibility if storage checks are not suppressed.
2923 if Ekind
(Spec_Id
) = E_Procedure
2924 and then Has_Recursive_Call
(Spec_Id
)
2925 and then not Storage_Checks_Suppressed
(Spec_Id
)
2927 Detect_Infinite_Recursion
(N
, Spec_Id
);
2930 -- Finally, if we are in Normalize_Scalars mode, then any scalar out
2931 -- parameters must be initialized to the appropriate default value.
2933 if Ekind
(Spec_Id
) = E_Procedure
and then Normalize_Scalars
then
2940 Formal
:= First_Formal
(Spec_Id
);
2942 while Present
(Formal
) loop
2943 Floc
:= Sloc
(Formal
);
2945 if Ekind
(Formal
) = E_Out_Parameter
2946 and then Is_Scalar_Type
(Etype
(Formal
))
2949 Make_Assignment_Statement
(Floc
,
2950 Name
=> New_Occurrence_Of
(Formal
, Floc
),
2952 Get_Simple_Init_Val
(Etype
(Formal
), Floc
));
2953 Prepend
(Stm
, Declarations
(N
));
2957 Next_Formal
(Formal
);
2962 -- If the subprogram does not have pending instantiations, then we
2963 -- must generate the subprogram descriptor now, since the code for
2964 -- the subprogram is complete, and this is our last chance. However
2965 -- if there are pending instantiations, then the code is not
2966 -- complete, and we will delay the generation.
2968 if Is_Subprogram
(Spec_Id
)
2969 and then not Delay_Subprogram_Descriptors
(Spec_Id
)
2971 Generate_Subprogram_Descriptor_For_Subprogram
(N
, Spec_Id
);
2974 -- Set to encode entity names in package body before gigi is called
2976 Qualify_Entity_Names
(N
);
2977 end Expand_N_Subprogram_Body
;
2979 -----------------------------------
2980 -- Expand_N_Subprogram_Body_Stub --
2981 -----------------------------------
2983 procedure Expand_N_Subprogram_Body_Stub
(N
: Node_Id
) is
2985 if Present
(Corresponding_Body
(N
)) then
2986 Expand_N_Subprogram_Body
(
2987 Unit_Declaration_Node
(Corresponding_Body
(N
)));
2990 end Expand_N_Subprogram_Body_Stub
;
2992 -------------------------------------
2993 -- Expand_N_Subprogram_Declaration --
2994 -------------------------------------
2996 -- The first task to be performed is the construction of default
2997 -- expression functions for in parameters with default values. These
2998 -- are parameterless inlined functions that are used to evaluate
2999 -- default expressions that are more complicated than simple literals
3000 -- or identifiers referencing constants and variables.
3002 -- If the declaration appears within a protected body, it is a private
3003 -- operation of the protected type. We must create the corresponding
3004 -- protected subprogram an associated formals. For a normal protected
3005 -- operation, this is done when expanding the protected type declaration.
3007 procedure Expand_N_Subprogram_Declaration
(N
: Node_Id
) is
3008 Loc
: constant Source_Ptr
:= Sloc
(N
);
3009 Subp
: Entity_Id
:= Defining_Entity
(N
);
3010 Scop
: Entity_Id
:= Scope
(Subp
);
3011 Prot_Sub
: Entity_Id
;
3015 -- Deal with case of protected subprogram
3017 if Is_List_Member
(N
)
3018 and then Present
(Parent
(List_Containing
(N
)))
3019 and then Nkind
(Parent
(List_Containing
(N
))) = N_Protected_Body
3020 and then Is_Protected_Type
(Scop
)
3022 if No
(Protected_Body_Subprogram
(Subp
)) then
3024 Make_Subprogram_Declaration
(Loc
,
3026 Build_Protected_Sub_Specification
3027 (N
, Scop
, Unprotected
=> True));
3029 -- The protected subprogram is declared outside of the protected
3030 -- body. Given that the body has frozen all entities so far, we
3031 -- freeze the subprogram explicitly. If the body is a subunit,
3032 -- the insertion point is before the stub in the parent.
3034 Prot_Bod
:= Parent
(List_Containing
(N
));
3036 if Nkind
(Parent
(Prot_Bod
)) = N_Subunit
then
3037 Prot_Bod
:= Corresponding_Stub
(Parent
(Prot_Bod
));
3040 Insert_Before
(Prot_Bod
, Prot_Sub
);
3042 New_Scope
(Scope
(Scop
));
3044 Set_Protected_Body_Subprogram
(Subp
,
3045 Defining_Unit_Name
(Specification
(Prot_Sub
)));
3049 end Expand_N_Subprogram_Declaration
;
3051 ---------------------------------------
3052 -- Expand_Protected_Object_Reference --
3053 ---------------------------------------
3055 function Expand_Protected_Object_Reference
3060 Loc
: constant Source_Ptr
:= Sloc
(N
);
3067 Rec
:= Make_Identifier
(Loc
, Name_uObject
);
3068 Set_Etype
(Rec
, Corresponding_Record_Type
(Scop
));
3070 -- Find enclosing protected operation, and retrieve its first
3071 -- parameter, which denotes the enclosing protected object.
3072 -- If the enclosing operation is an entry, we are immediately
3073 -- within the protected body, and we can retrieve the object
3074 -- from the service entries procedure. A barrier function has
3075 -- has the same signature as an entry. A barrier function is
3076 -- compiled within the protected object, but unlike protected
3077 -- operations its never needs locks, so that its protected body
3078 -- subprogram points to itself.
3080 Proc
:= Current_Scope
;
3082 while Present
(Proc
)
3083 and then Scope
(Proc
) /= Scop
3085 Proc
:= Scope
(Proc
);
3088 Corr
:= Protected_Body_Subprogram
(Proc
);
3092 -- Previous error left expansion incomplete.
3093 -- Nothing to do on this call.
3100 (First
(Parameter_Specifications
(Parent
(Corr
))));
3102 if Is_Subprogram
(Proc
)
3103 and then Proc
/= Corr
3105 -- Protected function or procedure.
3107 Set_Entity
(Rec
, Param
);
3109 -- Rec is a reference to an entity which will not be in scope
3110 -- when the call is reanalyzed, and needs no further analysis.
3115 -- Entry or barrier function for entry body.
3116 -- The first parameter of the entry body procedure is a
3117 -- pointer to the object. We create a local variable
3118 -- of the proper type, duplicating what is done to define
3119 -- _object later on.
3123 Obj_Ptr
: Entity_Id
:= Make_Defining_Identifier
3124 (Loc
, New_Internal_Name
('T'));
3127 Make_Full_Type_Declaration
(Loc
,
3128 Defining_Identifier
=> Obj_Ptr
,
3130 Make_Access_To_Object_Definition
(Loc
,
3131 Subtype_Indication
=>
3133 (Corresponding_Record_Type
(Scop
), Loc
))));
3135 Insert_Actions
(N
, Decls
);
3136 Insert_Actions
(N
, Freeze_Entity
(Obj_Ptr
, Sloc
(N
)));
3139 Make_Explicit_Dereference
(Loc
,
3140 Unchecked_Convert_To
(Obj_Ptr
,
3141 New_Occurrence_Of
(Param
, Loc
)));
3143 -- Analyze new actual. Other actuals in calls are already
3144 -- analyzed and the list of actuals is not renalyzed after
3147 Set_Parent
(Rec
, N
);
3153 end Expand_Protected_Object_Reference
;
3155 --------------------------------------
3156 -- Expand_Protected_Subprogram_Call --
3157 --------------------------------------
3159 procedure Expand_Protected_Subprogram_Call
3167 -- If the protected object is not an enclosing scope, this is
3168 -- an inter-object function call. Inter-object procedure
3169 -- calls are expanded by Exp_Ch9.Build_Simple_Entry_Call.
3170 -- The call is intra-object only if the subprogram being
3171 -- called is in the protected body being compiled, and if the
3172 -- protected object in the call is statically the enclosing type.
3173 -- The object may be an component of some other data structure,
3174 -- in which case this must be handled as an inter-object call.
3176 if not In_Open_Scopes
(Scop
)
3177 or else not Is_Entity_Name
(Name
(N
))
3179 if Nkind
(Name
(N
)) = N_Selected_Component
then
3180 Rec
:= Prefix
(Name
(N
));
3183 pragma Assert
(Nkind
(Name
(N
)) = N_Indexed_Component
);
3184 Rec
:= Prefix
(Prefix
(Name
(N
)));
3187 Build_Protected_Subprogram_Call
(N
,
3188 Name
=> New_Occurrence_Of
(Subp
, Sloc
(N
)),
3189 Rec
=> Convert_Concurrent
(Rec
, Etype
(Rec
)),
3193 Rec
:= Expand_Protected_Object_Reference
(N
, Scop
);
3199 Build_Protected_Subprogram_Call
(N
,
3208 -- If it is a function call it can appear in elaboration code and
3209 -- the called entity must be frozen here.
3211 if Ekind
(Subp
) = E_Function
then
3212 Freeze_Expression
(Name
(N
));
3214 end Expand_Protected_Subprogram_Call
;
3216 -----------------------
3217 -- Freeze_Subprogram --
3218 -----------------------
3220 procedure Freeze_Subprogram
(N
: Node_Id
) is
3221 E
: constant Entity_Id
:= Entity
(N
);
3224 -- When a primitive is frozen, enter its name in the corresponding
3225 -- dispatch table. If the DTC_Entity field is not set this is an
3226 -- overridden primitive that can be ignored. We suppress the
3227 -- initialization of the dispatch table entry when Java_VM because
3228 -- the dispatching mechanism is handled internally by the JVM.
3230 if Is_Dispatching_Operation
(E
)
3231 and then not Is_Abstract
(E
)
3232 and then Present
(DTC_Entity
(E
))
3233 and then not Is_CPP_Class
(Scope
(DTC_Entity
(E
)))
3234 and then not Java_VM
3236 Check_Overriding_Operation
(E
);
3237 Insert_After
(N
, Fill_DT_Entry
(Sloc
(N
), E
));
3240 -- Mark functions that return by reference. Note that it cannot be
3241 -- part of the normal semantic analysis of the spec since the
3242 -- underlying returned type may not be known yet (for private types)
3245 Typ
: constant Entity_Id
:= Etype
(E
);
3246 Utyp
: constant Entity_Id
:= Underlying_Type
(Typ
);
3249 if Is_Return_By_Reference_Type
(Typ
) then
3250 Set_Returns_By_Ref
(E
);
3252 elsif Present
(Utyp
) and then Controlled_Type
(Utyp
) then
3253 Set_Returns_By_Ref
(E
);
3257 end Freeze_Subprogram
;