1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
10 -- Copyright (C) 1992-2002, Free Software Foundation, Inc. --
12 -- GNAT is free software; you can redistribute it and/or modify it under --
13 -- terms of the GNU General Public License as published by the Free Soft- --
14 -- ware Foundation; either version 2, or (at your option) any later ver- --
15 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
16 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
17 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
18 -- for more details. You should have received a copy of the GNU General --
19 -- Public License distributed with GNAT; see file COPYING. If not, write --
20 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
21 -- MA 02111-1307, USA. --
23 -- GNAT was originally developed by the GNAT team at New York University. --
24 -- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
26 ------------------------------------------------------------------------------
28 with Atree
; use Atree
;
29 with Checks
; use Checks
;
30 with Debug
; use Debug
;
31 with Einfo
; use Einfo
;
32 with Errout
; use Errout
;
33 with Elists
; use Elists
;
34 with Exp_Ch2
; use Exp_Ch2
;
35 with Exp_Ch3
; use Exp_Ch3
;
36 with Exp_Ch7
; use Exp_Ch7
;
37 with Exp_Ch9
; use Exp_Ch9
;
38 with Exp_Ch11
; use Exp_Ch11
;
39 with Exp_Dbug
; use Exp_Dbug
;
40 with Exp_Disp
; use Exp_Disp
;
41 with Exp_Dist
; use Exp_Dist
;
42 with Exp_Intr
; use Exp_Intr
;
43 with Exp_Pakd
; use Exp_Pakd
;
44 with Exp_Tss
; use Exp_Tss
;
45 with Exp_Util
; use Exp_Util
;
46 with Freeze
; use Freeze
;
47 with Hostparm
; use Hostparm
;
48 with Inline
; use Inline
;
50 with Nlists
; use Nlists
;
51 with Nmake
; use Nmake
;
53 with Restrict
; use Restrict
;
54 with Rtsfind
; use Rtsfind
;
56 with Sem_Ch6
; use Sem_Ch6
;
57 with Sem_Ch8
; use Sem_Ch8
;
58 with Sem_Ch12
; use Sem_Ch12
;
59 with Sem_Ch13
; use Sem_Ch13
;
60 with Sem_Disp
; use Sem_Disp
;
61 with Sem_Dist
; use Sem_Dist
;
62 with Sem_Res
; use Sem_Res
;
63 with Sem_Util
; use Sem_Util
;
64 with Sinfo
; use Sinfo
;
65 with Snames
; use Snames
;
66 with Stand
; use Stand
;
67 with Tbuild
; use Tbuild
;
68 with Uintp
; use Uintp
;
69 with Validsw
; use Validsw
;
71 package body Exp_Ch6
is
73 -----------------------
74 -- Local Subprograms --
75 -----------------------
77 procedure Check_Overriding_Operation
(Subp
: Entity_Id
);
78 -- Subp is a dispatching operation. Check whether it may override an
79 -- inherited private operation, in which case its DT entry is that of
80 -- the hidden operation, not the one it may have received earlier.
81 -- This must be done before emitting the code to set the corresponding
82 -- DT to the address of the subprogram. The actual placement of Subp in
83 -- the proper place in the list of primitive operations is done in
84 -- Declare_Inherited_Private_Subprograms, which also has to deal with
85 -- implicit operations. This duplication is unavoidable for now???
87 procedure Detect_Infinite_Recursion
(N
: Node_Id
; Spec
: Entity_Id
);
88 -- This procedure is called only if the subprogram body N, whose spec
89 -- has the given entity Spec, contains a parameterless recursive call.
90 -- It attempts to generate runtime code to detect if this a case of
91 -- infinite recursion.
93 -- The body is scanned to determine dependencies. If the only external
94 -- dependencies are on a small set of scalar variables, then the values
95 -- of these variables are captured on entry to the subprogram, and if
96 -- the values are not changed for the call, we know immediately that
97 -- we have an infinite recursion.
99 procedure Expand_Actuals
(N
: Node_Id
; Subp
: Entity_Id
);
100 -- For each actual of an in-out parameter which is a numeric conversion
101 -- of the form T(A), where A denotes a variable, we insert the declaration:
105 -- prior to the call. Then we replace the actual with a reference to Temp,
106 -- and append the assignment:
110 -- after the call. Here T' is the actual type of variable A.
111 -- For out parameters, the initial declaration has no expression.
112 -- If A is not an entity name, we generate instead:
114 -- Var : T' renames A;
115 -- Temp : T := Var; -- omitting expression for out parameter.
119 -- For other in-out parameters, we emit the required constraint checks
120 -- before and/or after the call.
122 -- For all parameter modes, actuals that denote components and slices
123 -- of packed arrays are expanded into suitable temporaries.
125 procedure Expand_Inlined_Call
128 Orig_Subp
: Entity_Id
);
129 -- If called subprogram can be inlined by the front-end, retrieve the
130 -- analyzed body, replace formals with actuals and expand call in place.
131 -- Generate thunks for actuals that are expressions, and insert the
132 -- corresponding constant declarations before the call. If the original
133 -- call is to a derived operation, the return type is the one of the
134 -- derived operation, but the body is that of the original, so return
135 -- expressions in the body must be converted to the desired type (which
136 -- is simply not noted in the tree without inline expansion).
138 function Expand_Protected_Object_Reference
143 procedure Expand_Protected_Subprogram_Call
147 -- A call to a protected subprogram within the protected object may appear
148 -- as a regular call. The list of actuals must be expanded to contain a
149 -- reference to the object itself, and the call becomes a call to the
150 -- corresponding protected subprogram.
152 --------------------------------
153 -- Check_Overriding_Operation --
154 --------------------------------
156 procedure Check_Overriding_Operation
(Subp
: Entity_Id
) is
157 Typ
: constant Entity_Id
:= Find_Dispatching_Type
(Subp
);
158 Op_List
: constant Elist_Id
:= Primitive_Operations
(Typ
);
164 if Is_Derived_Type
(Typ
)
165 and then not Is_Private_Type
(Typ
)
166 and then In_Open_Scopes
(Scope
(Etype
(Typ
)))
167 and then Typ
= Base_Type
(Typ
)
169 -- Subp overrides an inherited private operation if there is
170 -- an inherited operation with a different name than Subp (see
171 -- Derive_Subprogram) whose Alias is a hidden subprogram with
172 -- the same name as Subp.
174 Op_Elmt
:= First_Elmt
(Op_List
);
175 while Present
(Op_Elmt
) loop
176 Prim_Op
:= Node
(Op_Elmt
);
177 Par_Op
:= Alias
(Prim_Op
);
180 and then not Comes_From_Source
(Prim_Op
)
181 and then Chars
(Prim_Op
) /= Chars
(Par_Op
)
182 and then Chars
(Par_Op
) = Chars
(Subp
)
183 and then Is_Hidden
(Par_Op
)
184 and then Type_Conformant
(Prim_Op
, Subp
)
186 Set_DT_Position
(Subp
, DT_Position
(Prim_Op
));
192 end Check_Overriding_Operation
;
194 -------------------------------
195 -- Detect_Infinite_Recursion --
196 -------------------------------
198 procedure Detect_Infinite_Recursion
(N
: Node_Id
; Spec
: Entity_Id
) is
199 Loc
: constant Source_Ptr
:= Sloc
(N
);
201 Var_List
: Elist_Id
:= New_Elmt_List
;
202 -- List of globals referenced by body of procedure
204 Call_List
: Elist_Id
:= New_Elmt_List
;
205 -- List of recursive calls in body of procedure
207 Shad_List
: Elist_Id
:= New_Elmt_List
;
208 -- List of entity id's for entities created to capture the
209 -- value of referenced globals on entry to the procedure.
211 Scop
: constant Uint
:= Scope_Depth
(Spec
);
212 -- This is used to record the scope depth of the current
213 -- procedure, so that we can identify global references.
215 Max_Vars
: constant := 4;
216 -- Do not test more than four global variables
218 Count_Vars
: Natural := 0;
219 -- Count variables found so far
231 function Process
(Nod
: Node_Id
) return Traverse_Result
;
232 -- Function to traverse the subprogram body (using Traverse_Func)
238 function Process
(Nod
: Node_Id
) return Traverse_Result
is
242 if Nkind
(Nod
) = N_Procedure_Call_Statement
then
244 -- Case of one of the detected recursive calls
246 if Is_Entity_Name
(Name
(Nod
))
247 and then Has_Recursive_Call
(Entity
(Name
(Nod
)))
248 and then Entity
(Name
(Nod
)) = Spec
250 Append_Elmt
(Nod
, Call_List
);
253 -- Any other procedure call may have side effects
259 -- A call to a pure function can always be ignored
261 elsif Nkind
(Nod
) = N_Function_Call
262 and then Is_Entity_Name
(Name
(Nod
))
263 and then Is_Pure
(Entity
(Name
(Nod
)))
267 -- Case of an identifier reference
269 elsif Nkind
(Nod
) = N_Identifier
then
272 -- If no entity, then ignore the reference
274 -- Not clear why this can happen. To investigate, remove this
275 -- test and look at the crash that occurs here in 3401-004 ???
280 -- Ignore entities with no Scope, again not clear how this
281 -- can happen, to investigate, look at 4108-008 ???
283 elsif No
(Scope
(Ent
)) then
286 -- Ignore the reference if not to a more global object
288 elsif Scope_Depth
(Scope
(Ent
)) >= Scop
then
291 -- References to types, exceptions and constants are always OK
294 or else Ekind
(Ent
) = E_Exception
295 or else Ekind
(Ent
) = E_Constant
299 -- If other than a non-volatile scalar variable, we have some
300 -- kind of global reference (e.g. to a function) that we cannot
301 -- deal with so we forget the attempt.
303 elsif Ekind
(Ent
) /= E_Variable
304 or else not Is_Scalar_Type
(Etype
(Ent
))
305 or else Is_Volatile
(Ent
)
309 -- Otherwise we have a reference to a global scalar
312 -- Loop through global entities already detected
314 Elm
:= First_Elmt
(Var_List
);
316 -- If not detected before, record this new global reference
319 Count_Vars
:= Count_Vars
+ 1;
321 if Count_Vars
<= Max_Vars
then
322 Append_Elmt
(Entity
(Nod
), Var_List
);
329 -- If recorded before, ignore
331 elsif Node
(Elm
) = Entity
(Nod
) then
334 -- Otherwise keep looking
344 -- For all other node kinds, recursively visit syntactic children
351 function Traverse_Body
is new Traverse_Func
;
353 -- Start of processing for Detect_Infinite_Recursion
356 -- Do not attempt detection in No_Implicit_Conditional mode,
357 -- since we won't be able to generate the code to handle the
358 -- recursion in any case.
360 if Restrictions
(No_Implicit_Conditionals
) then
364 -- Otherwise do traversal and quit if we get abandon signal
366 if Traverse_Body
(N
) = Abandon
then
369 -- We must have a call, since Has_Recursive_Call was set. If not
370 -- just ignore (this is only an error check, so if we have a funny
371 -- situation, due to bugs or errors, we do not want to bomb!)
373 elsif Is_Empty_Elmt_List
(Call_List
) then
377 -- Here is the case where we detect recursion at compile time
379 -- Push our current scope for analyzing the declarations and
380 -- code that we will insert for the checking.
384 -- This loop builds temporary variables for each of the
385 -- referenced globals, so that at the end of the loop the
386 -- list Shad_List contains these temporaries in one-to-one
387 -- correspondence with the elements in Var_List.
390 Elm
:= First_Elmt
(Var_List
);
391 while Present
(Elm
) loop
394 Make_Defining_Identifier
(Loc
,
395 Chars
=> New_Internal_Name
('S'));
396 Append_Elmt
(Ent
, Shad_List
);
398 -- Insert a declaration for this temporary at the start of
399 -- the declarations for the procedure. The temporaries are
400 -- declared as constant objects initialized to the current
401 -- values of the corresponding temporaries.
404 Make_Object_Declaration
(Loc
,
405 Defining_Identifier
=> Ent
,
406 Object_Definition
=> New_Occurrence_Of
(Etype
(Var
), Loc
),
407 Constant_Present
=> True,
408 Expression
=> New_Occurrence_Of
(Var
, Loc
));
411 Prepend
(Decl
, Declarations
(N
));
413 Insert_After
(Last
, Decl
);
421 -- Loop through calls
423 Call
:= First_Elmt
(Call_List
);
424 while Present
(Call
) loop
426 -- Build a predicate expression of the form
429 -- and then global1 = temp1
430 -- and then global2 = temp2
433 -- This predicate determines if any of the global values
434 -- referenced by the procedure have changed since the
435 -- current call, if not an infinite recursion is assured.
437 Test
:= New_Occurrence_Of
(Standard_True
, Loc
);
439 Elm1
:= First_Elmt
(Var_List
);
440 Elm2
:= First_Elmt
(Shad_List
);
441 while Present
(Elm1
) loop
447 Left_Opnd
=> New_Occurrence_Of
(Node
(Elm1
), Loc
),
448 Right_Opnd
=> New_Occurrence_Of
(Node
(Elm2
), Loc
)));
454 -- Now we replace the call with the sequence
456 -- if no-changes (see above) then
457 -- raise Storage_Error;
462 Rewrite
(Node
(Call
),
463 Make_If_Statement
(Loc
,
465 Then_Statements
=> New_List
(
466 Make_Raise_Storage_Error
(Loc
,
467 Reason
=> SE_Infinite_Recursion
)),
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 -- Ignore if previous error
1213 if Nkind
(N
) in N_Has_Etype
and then Etype
(N
) = Any_Type
then
1217 -- Call using access to subprogram with explicit dereference
1219 if Nkind
(Name
(N
)) = N_Explicit_Dereference
then
1220 Subp
:= Etype
(Name
(N
));
1221 Parent_Subp
:= Empty
;
1223 -- Case of call to simple entry, where the Name is a selected component
1224 -- whose prefix is the task, and whose selector name is the entry name
1226 elsif Nkind
(Name
(N
)) = N_Selected_Component
then
1227 Subp
:= Entity
(Selector_Name
(Name
(N
)));
1228 Parent_Subp
:= Empty
;
1230 -- Case of call to member of entry family, where Name is an indexed
1231 -- component, with the prefix being a selected component giving the
1232 -- task and entry family name, and the index being the entry index.
1234 elsif Nkind
(Name
(N
)) = N_Indexed_Component
then
1235 Subp
:= Entity
(Selector_Name
(Prefix
(Name
(N
))));
1236 Parent_Subp
:= Empty
;
1241 Subp
:= Entity
(Name
(N
));
1242 Parent_Subp
:= Alias
(Subp
);
1244 -- Replace call to Raise_Exception by call to Raise_Exception_Always
1245 -- if we can tell that the first parameter cannot possibly be null.
1247 if not Restrictions
(No_Exception_Handlers
)
1248 and then Is_RTE
(Subp
, RE_Raise_Exception
)
1251 FA
: constant Node_Id
:= Original_Node
(First_Actual
(N
));
1254 -- The case we catch is where the first argument is obtained
1255 -- using the Identity attribute (which must always be non-null)
1257 if Nkind
(FA
) = N_Attribute_Reference
1258 and then Attribute_Name
(FA
) = Name_Identity
1260 Subp
:= RTE
(RE_Raise_Exception_Always
);
1261 Set_Entity
(Name
(N
), Subp
);
1266 if Ekind
(Subp
) = E_Entry
then
1267 Parent_Subp
:= Empty
;
1271 -- First step, compute extra actuals, corresponding to any
1272 -- Extra_Formals present. Note that we do not access Extra_Formals
1273 -- directly, instead we simply note the presence of the extra
1274 -- formals as we process the regular formals and collect the
1275 -- corresponding actuals in Extra_Actuals.
1277 Formal
:= First_Formal
(Subp
);
1278 Actual
:= First_Actual
(N
);
1280 while Present
(Formal
) loop
1282 Prev_Orig
:= Original_Node
(Prev
);
1284 -- Create possible extra actual for constrained case. Usually,
1285 -- the extra actual is of the form actual'constrained, but since
1286 -- this attribute is only available for unconstrained records,
1287 -- TRUE is expanded if the type of the formal happens to be
1288 -- constrained (for instance when this procedure is inherited
1289 -- from an unconstrained record to a constrained one) or if the
1290 -- actual has no discriminant (its type is constrained). An
1291 -- exception to this is the case of a private type without
1292 -- discriminants. In this case we pass FALSE because the
1293 -- object has underlying discriminants with defaults.
1295 if Present
(Extra_Constrained
(Formal
)) then
1296 if Ekind
(Etype
(Prev
)) in Private_Kind
1297 and then not Has_Discriminants
(Base_Type
(Etype
(Prev
)))
1300 New_Occurrence_Of
(Standard_False
, Loc
),
1301 Extra_Constrained
(Formal
));
1303 elsif Is_Constrained
(Etype
(Formal
))
1304 or else not Has_Discriminants
(Etype
(Prev
))
1307 New_Occurrence_Of
(Standard_True
, Loc
),
1308 Extra_Constrained
(Formal
));
1311 -- If the actual is a type conversion, then the constrained
1312 -- test applies to the actual, not the target type.
1315 Act_Prev
: Node_Id
:= Prev
;
1318 -- Test for unchecked conversions as well, which can
1319 -- occur as out parameter actuals on calls to stream
1322 if Nkind
(Act_Prev
) = N_Type_Conversion
1323 or else Nkind
(Act_Prev
) = N_Unchecked_Type_Conversion
1325 Act_Prev
:= Expression
(Act_Prev
);
1329 Make_Attribute_Reference
(Sloc
(Prev
),
1330 Prefix
=> Duplicate_Subexpr
(Act_Prev
, Name_Req
=> True),
1331 Attribute_Name
=> Name_Constrained
),
1332 Extra_Constrained
(Formal
));
1337 -- Create possible extra actual for accessibility level
1339 if Present
(Extra_Accessibility
(Formal
)) then
1340 if Is_Entity_Name
(Prev_Orig
) then
1342 -- When passing an access parameter as the actual to another
1343 -- access parameter we need to pass along the actual's own
1344 -- associated access level parameter. This is done is we are
1345 -- in the scope of the formal access parameter (if this is an
1346 -- inlined body the extra formal is irrelevant).
1348 if Ekind
(Entity
(Prev_Orig
)) in Formal_Kind
1349 and then Ekind
(Etype
(Prev_Orig
)) = E_Anonymous_Access_Type
1350 and then In_Open_Scopes
(Scope
(Entity
(Prev_Orig
)))
1353 Parm_Ent
: constant Entity_Id
:= Param_Entity
(Prev_Orig
);
1356 pragma Assert
(Present
(Parm_Ent
));
1358 if Present
(Extra_Accessibility
(Parm_Ent
)) then
1361 (Extra_Accessibility
(Parm_Ent
), Loc
),
1362 Extra_Accessibility
(Formal
));
1364 -- If the actual access parameter does not have an
1365 -- associated extra formal providing its scope level,
1366 -- then treat the actual as having library-level
1371 Make_Integer_Literal
(Loc
,
1372 Intval
=> Scope_Depth
(Standard_Standard
)),
1373 Extra_Accessibility
(Formal
));
1377 -- The actual is a normal access value, so just pass the
1378 -- level of the actual's access type.
1382 Make_Integer_Literal
(Loc
,
1383 Intval
=> Type_Access_Level
(Etype
(Prev_Orig
))),
1384 Extra_Accessibility
(Formal
));
1388 case Nkind
(Prev_Orig
) is
1390 when N_Attribute_Reference
=>
1392 case Get_Attribute_Id
(Attribute_Name
(Prev_Orig
)) is
1394 -- For X'Access, pass on the level of the prefix X
1396 when Attribute_Access
=>
1398 Make_Integer_Literal
(Loc
,
1400 Object_Access_Level
(Prefix
(Prev_Orig
))),
1401 Extra_Accessibility
(Formal
));
1403 -- Treat the unchecked attributes as library-level
1405 when Attribute_Unchecked_Access |
1406 Attribute_Unrestricted_Access
=>
1408 Make_Integer_Literal
(Loc
,
1409 Intval
=> Scope_Depth
(Standard_Standard
)),
1410 Extra_Accessibility
(Formal
));
1412 -- No other cases of attributes returning access
1413 -- values that can be passed to access parameters
1416 raise Program_Error
;
1420 -- For allocators we pass the level of the execution of
1421 -- the called subprogram, which is one greater than the
1422 -- current scope level.
1426 Make_Integer_Literal
(Loc
,
1427 Scope_Depth
(Current_Scope
) + 1),
1428 Extra_Accessibility
(Formal
));
1430 -- For other cases we simply pass the level of the
1431 -- actual's access type.
1435 Make_Integer_Literal
(Loc
,
1436 Intval
=> Type_Access_Level
(Etype
(Prev_Orig
))),
1437 Extra_Accessibility
(Formal
));
1443 -- Perform the check of 4.6(49) that prevents a null value
1444 -- from being passed as an actual to an access parameter.
1445 -- Note that the check is elided in the common cases of
1446 -- passing an access attribute or access parameter as an
1447 -- actual. Also, we currently don't enforce this check for
1448 -- expander-generated actuals and when -gnatdj is set.
1450 if Ekind
(Etype
(Formal
)) /= E_Anonymous_Access_Type
1451 or else Suppress_Accessibility_Checks
(Subp
)
1455 elsif Debug_Flag_J
then
1458 elsif not Comes_From_Source
(Prev
) then
1461 elsif Is_Entity_Name
(Prev
)
1462 and then Ekind
(Etype
(Prev
)) = E_Anonymous_Access_Type
1466 elsif Nkind
(Prev
) = N_Allocator
1467 or else Nkind
(Prev
) = N_Attribute_Reference
1471 -- Suppress null checks when passing to access parameters
1472 -- of Java subprograms. (Should this be done for other
1473 -- foreign conventions as well ???)
1475 elsif Convention
(Subp
) = Convention_Java
then
1481 Left_Opnd
=> Duplicate_Subexpr
(Prev
),
1482 Right_Opnd
=> Make_Null
(Loc
));
1483 Insert_Action
(Prev
,
1484 Make_Raise_Constraint_Error
(Loc
,
1486 Reason
=> CE_Access_Parameter_Is_Null
));
1489 -- Perform appropriate validity checks on parameters
1491 if Validity_Checks_On
then
1493 if Ekind
(Formal
) = E_In_Parameter
1494 and then Validity_Check_In_Params
1496 Ensure_Valid
(Actual
);
1498 elsif Ekind
(Formal
) = E_In_Out_Parameter
1499 and then Validity_Check_In_Out_Params
1501 Ensure_Valid
(Actual
);
1505 -- For IN OUT and OUT parameters, ensure that subscripts are valid
1506 -- since this is a left side reference. We only do this for calls
1507 -- from the source program since we assume that compiler generated
1508 -- calls explicitly generate any required checks. We also need it
1509 -- only if we are doing standard validity checks, since clearly it
1510 -- is not needed if validity checks are off, and in subscript
1511 -- validity checking mode, all indexed components are checked with
1512 -- a call directly from Expand_N_Indexed_Component.
1514 if Comes_From_Source
(N
)
1515 and then Ekind
(Formal
) /= E_In_Parameter
1516 and then Validity_Checks_On
1517 and then Validity_Check_Default
1518 and then not Validity_Check_Subscripts
1520 Check_Valid_Lvalue_Subscripts
(Actual
);
1523 -- If the formal is class wide and the actual is an aggregate, force
1524 -- evaluation so that the back end who does not know about class-wide
1525 -- type, does not generate a temporary of the wrong size.
1527 if not Is_Class_Wide_Type
(Etype
(Formal
)) then
1530 elsif Nkind
(Actual
) = N_Aggregate
1531 or else (Nkind
(Actual
) = N_Qualified_Expression
1532 and then Nkind
(Expression
(Actual
)) = N_Aggregate
)
1534 Force_Evaluation
(Actual
);
1537 -- In a remote call, if the formal is of a class-wide type, check
1538 -- that the actual meets the requirements described in E.4(18).
1541 and then Is_Class_Wide_Type
(Etype
(Formal
))
1543 Insert_Action
(Actual
,
1544 Make_Implicit_If_Statement
(N
,
1547 Get_Remotely_Callable
(Duplicate_Subexpr
(Actual
))),
1548 Then_Statements
=> New_List
(
1549 Make_Procedure_Call_Statement
(Loc
,
1550 New_Occurrence_Of
(RTE
1551 (RE_Raise_Program_Error_For_E_4_18
), Loc
)))));
1554 Next_Actual
(Actual
);
1555 Next_Formal
(Formal
);
1558 -- If we are expanding a rhs of an assignement we need to check if
1559 -- tag propagation is needed. This code belongs theorically in Analyze
1560 -- Assignment but has to be done earlier (bottom-up) because the
1561 -- assignment might be transformed into a declaration for an uncons-
1562 -- trained value, if the expression is classwide.
1564 if Nkind
(N
) = N_Function_Call
1565 and then Is_Tag_Indeterminate
(N
)
1566 and then Is_Entity_Name
(Name
(N
))
1569 Ass
: Node_Id
:= Empty
;
1572 if Nkind
(Parent
(N
)) = N_Assignment_Statement
then
1575 elsif Nkind
(Parent
(N
)) = N_Qualified_Expression
1576 and then Nkind
(Parent
(Parent
(N
))) = N_Assignment_Statement
1578 Ass
:= Parent
(Parent
(N
));
1582 and then Is_Class_Wide_Type
(Etype
(Name
(Ass
)))
1584 Propagate_Tag
(Name
(Ass
), N
);
1590 -- Deals with Dispatch_Call if we still have a call, before expanding
1591 -- extra actuals since this will be done on the re-analysis of the
1592 -- dispatching call. Note that we do not try to shorten the actual
1593 -- list for a dispatching call, it would not make sense to do so.
1594 -- Expansion of dispatching calls is suppressed when Java_VM, because
1595 -- the JVM back end directly handles the generation of dispatching
1596 -- calls and would have to undo any expansion to an indirect call.
1598 if (Nkind
(N
) = N_Function_Call
1599 or else Nkind
(N
) = N_Procedure_Call_Statement
)
1600 and then Present
(Controlling_Argument
(N
))
1601 and then not Java_VM
1603 Expand_Dispatch_Call
(N
);
1606 -- Similarly, expand calls to RCI subprograms on which pragma
1607 -- All_Calls_Remote applies. The rewriting will be reanalyzed
1608 -- later. Do this only when the call comes from source since we do
1609 -- not want such a rewritting to occur in expanded code.
1611 elsif Is_All_Remote_Call
(N
) then
1612 Expand_All_Calls_Remote_Subprogram_Call
(N
);
1614 -- Similarly, do not add extra actuals for an entry call whose entity
1615 -- is a protected procedure, or for an internal protected subprogram
1616 -- call, because it will be rewritten as a protected subprogram call
1617 -- and reanalyzed (see Expand_Protected_Subprogram_Call).
1619 elsif Is_Protected_Type
(Scope
(Subp
))
1620 and then (Ekind
(Subp
) = E_Procedure
1621 or else Ekind
(Subp
) = E_Function
)
1625 -- During that loop we gathered the extra actuals (the ones that
1626 -- correspond to Extra_Formals), so now they can be appended.
1629 while Is_Non_Empty_List
(Extra_Actuals
) loop
1630 Add_Actual_Parameter
(Remove_Head
(Extra_Actuals
));
1634 if Ekind
(Subp
) = E_Procedure
1635 or else (Ekind
(Subp
) = E_Subprogram_Type
1636 and then Etype
(Subp
) = Standard_Void_Type
)
1637 or else Is_Entry
(Subp
)
1639 Expand_Actuals
(N
, Subp
);
1642 -- If the subprogram is a renaming, or if it is inherited, replace it
1643 -- in the call with the name of the actual subprogram being called.
1644 -- If this is a dispatching call, the run-time decides what to call.
1645 -- The Alias attribute does not apply to entries.
1647 if Nkind
(N
) /= N_Entry_Call_Statement
1648 and then No
(Controlling_Argument
(N
))
1649 and then Present
(Parent_Subp
)
1651 if Present
(Inherited_From_Formal
(Subp
)) then
1652 Parent_Subp
:= Inherited_From_Formal
(Subp
);
1654 while Present
(Alias
(Parent_Subp
)) loop
1655 Parent_Subp
:= Alias
(Parent_Subp
);
1659 Set_Entity
(Name
(N
), Parent_Subp
);
1661 if Is_Abstract
(Parent_Subp
)
1662 and then not In_Instance
1665 ("cannot call abstract subprogram &!", Name
(N
), Parent_Subp
);
1668 -- Add an explicit conversion for parameter of the derived type.
1669 -- This is only done for scalar and access in-parameters. Others
1670 -- have been expanded in expand_actuals.
1672 Formal
:= First_Formal
(Subp
);
1673 Parent_Formal
:= First_Formal
(Parent_Subp
);
1674 Actual
:= First_Actual
(N
);
1676 -- It is not clear that conversion is needed for intrinsic
1677 -- subprograms, but it certainly is for those that are user-
1678 -- defined, and that can be inherited on derivation, namely
1679 -- unchecked conversion and deallocation.
1680 -- General case needs study ???
1682 if not Is_Intrinsic_Subprogram
(Parent_Subp
)
1683 or else Is_Generic_Instance
(Parent_Subp
)
1685 while Present
(Formal
) loop
1687 if Etype
(Formal
) /= Etype
(Parent_Formal
)
1688 and then Is_Scalar_Type
(Etype
(Formal
))
1689 and then Ekind
(Formal
) = E_In_Parameter
1690 and then not Raises_Constraint_Error
(Actual
)
1693 OK_Convert_To
(Etype
(Parent_Formal
),
1694 Relocate_Node
(Actual
)));
1697 Resolve
(Actual
, Etype
(Parent_Formal
));
1698 Enable_Range_Check
(Actual
);
1700 elsif Is_Access_Type
(Etype
(Formal
))
1701 and then Base_Type
(Etype
(Parent_Formal
))
1702 /= Base_Type
(Etype
(Actual
))
1704 if Ekind
(Formal
) /= E_In_Parameter
then
1706 Convert_To
(Etype
(Parent_Formal
),
1707 Relocate_Node
(Actual
)));
1710 Resolve
(Actual
, Etype
(Parent_Formal
));
1713 Ekind
(Etype
(Parent_Formal
)) = E_Anonymous_Access_Type
1715 Designated_Type
(Etype
(Parent_Formal
))
1716 /= Designated_Type
(Etype
(Actual
))
1717 and then not Is_Controlling_Formal
(Formal
)
1720 -- This unchecked conversion is not necessary unless
1721 -- inlining is unabled, because in that case the type
1722 -- mismatch may become visible in the body about to be
1726 Unchecked_Convert_To
(Etype
(Parent_Formal
),
1727 Relocate_Node
(Actual
)));
1730 Resolve
(Actual
, Etype
(Parent_Formal
));
1734 Next_Formal
(Formal
);
1735 Next_Formal
(Parent_Formal
);
1736 Next_Actual
(Actual
);
1741 Subp
:= Parent_Subp
;
1744 -- Some more special cases for cases other than explicit dereference
1746 if Nkind
(Name
(N
)) /= N_Explicit_Dereference
then
1748 -- Calls to an enumeration literal are replaced by the literal
1749 -- This case occurs only when we have a call to a function that
1750 -- is a renaming of an enumeration literal. The normal case of
1751 -- a direct reference to an enumeration literal has already been
1752 -- been dealt with by Resolve_Call. If the function is itself
1753 -- inherited (see 7423-001) the literal of the parent type must
1754 -- be explicitly converted to the return type of the function.
1756 if Ekind
(Subp
) = E_Enumeration_Literal
then
1757 if Base_Type
(Etype
(Subp
)) /= Base_Type
(Etype
(N
)) then
1759 (N
, Convert_To
(Etype
(N
), New_Occurrence_Of
(Subp
, Loc
)));
1761 Rewrite
(N
, New_Occurrence_Of
(Subp
, Loc
));
1762 Resolve
(N
, Etype
(N
));
1766 -- Handle case of access to protected subprogram type
1769 if Ekind
(Base_Type
(Etype
(Prefix
(Name
(N
))))) =
1770 E_Access_Protected_Subprogram_Type
1772 -- If this is a call through an access to protected operation,
1773 -- the prefix has the form (object'address, operation'access).
1774 -- Rewrite as a for other protected calls: the object is the
1775 -- first parameter of the list of actuals.
1782 Ptr
: Node_Id
:= Prefix
(Name
(N
));
1783 T
: Entity_Id
:= Equivalent_Type
(Base_Type
(Etype
(Ptr
)));
1784 D_T
: Entity_Id
:= Designated_Type
(Base_Type
(Etype
(Ptr
)));
1787 Obj
:= Make_Selected_Component
(Loc
,
1788 Prefix
=> Unchecked_Convert_To
(T
, Ptr
),
1789 Selector_Name
=> New_Occurrence_Of
(First_Entity
(T
), Loc
));
1791 Nam
:= Make_Selected_Component
(Loc
,
1792 Prefix
=> Unchecked_Convert_To
(T
, Ptr
),
1793 Selector_Name
=> New_Occurrence_Of
(
1794 Next_Entity
(First_Entity
(T
)), Loc
));
1796 Nam
:= Make_Explicit_Dereference
(Loc
, Nam
);
1798 if Present
(Parameter_Associations
(N
)) then
1799 Parm
:= Parameter_Associations
(N
);
1804 Prepend
(Obj
, Parm
);
1806 if Etype
(D_T
) = Standard_Void_Type
then
1807 Call
:= Make_Procedure_Call_Statement
(Loc
,
1809 Parameter_Associations
=> Parm
);
1811 Call
:= Make_Function_Call
(Loc
,
1813 Parameter_Associations
=> Parm
);
1816 Set_First_Named_Actual
(Call
, First_Named_Actual
(N
));
1818 Set_Etype
(Call
, Etype
(D_T
));
1820 -- We do not re-analyze the call to avoid infinite recursion.
1821 -- We analyze separately the prefix and the object, and set
1822 -- the checks on the prefix that would otherwise be emitted
1823 -- when resolving a call.
1827 Apply_Access_Check
(Nam
);
1834 -- If this is a call to an intrinsic subprogram, then perform the
1835 -- appropriate expansion to the corresponding tree node and we
1836 -- are all done (since after that the call is gone!)
1838 if Is_Intrinsic_Subprogram
(Subp
) then
1839 Expand_Intrinsic_Call
(N
, Subp
);
1843 if Ekind
(Subp
) = E_Function
1844 or else Ekind
(Subp
) = E_Procedure
1846 if Is_Inlined
(Subp
) then
1849 Spec
: constant Node_Id
:= Unit_Declaration_Node
(Subp
);
1852 -- Verify that the body to inline has already been seen,
1853 -- and that if the body is in the current unit the inlining
1854 -- does not occur earlier. This avoids order-of-elaboration
1855 -- problems in gigi.
1858 and then Nkind
(Spec
) = N_Subprogram_Declaration
1859 and then Present
(Body_To_Inline
(Spec
))
1860 and then (In_Extended_Main_Code_Unit
(N
)
1861 or else In_Extended_Main_Code_Unit
(Parent
(N
)))
1862 and then (not In_Same_Extended_Unit
1863 (Sloc
(Body_To_Inline
(Spec
)), Loc
)
1865 Earlier_In_Extended_Unit
1866 (Sloc
(Body_To_Inline
(Spec
)), Loc
))
1868 Expand_Inlined_Call
(N
, Subp
, Orig_Subp
);
1871 -- Let the back-end handle it.
1873 Add_Inlined_Body
(Subp
);
1875 if Front_End_Inlining
1876 and then Nkind
(Spec
) = N_Subprogram_Declaration
1877 and then (In_Extended_Main_Code_Unit
(N
))
1878 and then No
(Body_To_Inline
(Spec
))
1879 and then not Has_Completion
(Subp
)
1880 and then In_Same_Extended_Unit
(Sloc
(Spec
), Loc
)
1881 and then Ineffective_Inline_Warnings
1884 ("call cannot be inlined before body is seen?", N
);
1891 -- Check for a protected subprogram. This is either an intra-object
1892 -- call, or a protected function call. Protected procedure calls are
1893 -- rewritten as entry calls and handled accordingly.
1895 Scop
:= Scope
(Subp
);
1897 if Nkind
(N
) /= N_Entry_Call_Statement
1898 and then Is_Protected_Type
(Scop
)
1900 -- If the call is an internal one, it is rewritten as a call to
1901 -- to the corresponding unprotected subprogram.
1903 Expand_Protected_Subprogram_Call
(N
, Subp
, Scop
);
1906 -- Functions returning controlled objects need special attention
1908 if Controlled_Type
(Etype
(Subp
))
1909 and then not Is_Return_By_Reference_Type
(Etype
(Subp
))
1911 Expand_Ctrl_Function_Call
(N
);
1914 -- Test for First_Optional_Parameter, and if so, truncate parameter
1915 -- list if there are optional parameters at the trailing end.
1916 -- Note we never delete procedures for call via a pointer.
1918 if (Ekind
(Subp
) = E_Procedure
or else Ekind
(Subp
) = E_Function
)
1919 and then Present
(First_Optional_Parameter
(Subp
))
1922 Last_Keep_Arg
: Node_Id
;
1925 -- Last_Keep_Arg will hold the last actual that should be
1926 -- retained. If it remains empty at the end, it means that
1927 -- all parameters are optional.
1929 Last_Keep_Arg
:= Empty
;
1931 -- Find first optional parameter, must be present since we
1932 -- checked the validity of the parameter before setting it.
1934 Formal
:= First_Formal
(Subp
);
1935 Actual
:= First_Actual
(N
);
1936 while Formal
/= First_Optional_Parameter
(Subp
) loop
1937 Last_Keep_Arg
:= Actual
;
1938 Next_Formal
(Formal
);
1939 Next_Actual
(Actual
);
1942 -- Now we have Formal and Actual pointing to the first
1943 -- potentially droppable argument. We can drop all the
1944 -- trailing arguments whose actual matches the default.
1945 -- Note that we know that all remaining formals have
1946 -- defaults, because we checked that this requirement
1947 -- was met before setting First_Optional_Parameter.
1949 -- We use Fully_Conformant_Expressions to check for identity
1950 -- between formals and actuals, which may miss some cases, but
1951 -- on the other hand, this is only an optimization (if we fail
1952 -- to truncate a parameter it does not affect functionality).
1953 -- So if the default is 3 and the actual is 1+2, we consider
1954 -- them unequal, which hardly seems worrisome.
1956 while Present
(Formal
) loop
1957 if not Fully_Conformant_Expressions
1958 (Actual
, Default_Value
(Formal
))
1960 Last_Keep_Arg
:= Actual
;
1963 Next_Formal
(Formal
);
1964 Next_Actual
(Actual
);
1967 -- If no arguments, delete entire list, this is the easy case
1969 if No
(Last_Keep_Arg
) then
1970 while Is_Non_Empty_List
(Parameter_Associations
(N
)) loop
1971 Delete_Tree
(Remove_Head
(Parameter_Associations
(N
)));
1974 Set_Parameter_Associations
(N
, No_List
);
1975 Set_First_Named_Actual
(N
, Empty
);
1977 -- Case where at the last retained argument is positional. This
1978 -- is also an easy case, since the retained arguments are already
1979 -- in the right form, and we don't need to worry about the order
1980 -- of arguments that get eliminated.
1982 elsif Is_List_Member
(Last_Keep_Arg
) then
1983 while Present
(Next
(Last_Keep_Arg
)) loop
1984 Delete_Tree
(Remove_Next
(Last_Keep_Arg
));
1987 Set_First_Named_Actual
(N
, Empty
);
1989 -- This is the annoying case where the last retained argument
1990 -- is a named parameter. Since the original arguments are not
1991 -- in declaration order, we may have to delete some fairly
1992 -- random collection of arguments.
2001 -- First step, remove all the named parameters from the
2002 -- list (they are still chained using First_Named_Actual
2003 -- and Next_Named_Actual, so we have not lost them!)
2005 Temp
:= First
(Parameter_Associations
(N
));
2007 -- Case of all parameters named, remove them all
2009 if Nkind
(Temp
) = N_Parameter_Association
then
2010 while Is_Non_Empty_List
(Parameter_Associations
(N
)) loop
2011 Temp
:= Remove_Head
(Parameter_Associations
(N
));
2014 -- Case of mixed positional/named, remove named parameters
2017 while Nkind
(Next
(Temp
)) /= N_Parameter_Association
loop
2021 while Present
(Next
(Temp
)) loop
2022 Junk
:= Remove_Next
(Temp
);
2026 -- Now we loop through the named parameters, till we get
2027 -- to the last one to be retained, adding them to the list.
2028 -- Note that the Next_Named_Actual list does not need to be
2029 -- touched since we are only reordering them on the actual
2030 -- parameter association list.
2032 Passoc
:= Parent
(First_Named_Actual
(N
));
2034 Temp
:= Relocate_Node
(Passoc
);
2036 (Parameter_Associations
(N
), Temp
);
2038 Last_Keep_Arg
= Explicit_Actual_Parameter
(Passoc
);
2039 Passoc
:= Parent
(Next_Named_Actual
(Passoc
));
2042 Set_Next_Named_Actual
(Temp
, Empty
);
2045 Temp
:= Next_Named_Actual
(Passoc
);
2046 exit when No
(Temp
);
2047 Set_Next_Named_Actual
2048 (Passoc
, Next_Named_Actual
(Parent
(Temp
)));
2058 --------------------------
2059 -- Expand_Inlined_Call --
2060 --------------------------
2062 procedure Expand_Inlined_Call
2065 Orig_Subp
: Entity_Id
)
2067 Loc
: constant Source_Ptr
:= Sloc
(N
);
2071 Exit_Lab
: Entity_Id
:= Empty
;
2078 Orig_Bod
: constant Node_Id
:=
2079 Body_To_Inline
(Unit_Declaration_Node
(Subp
));
2080 Ret_Type
: Entity_Id
;
2083 Temp_Typ
: Entity_Id
;
2085 procedure Make_Exit_Label
;
2086 -- Build declaration for exit label to be used in Return statements.
2088 function Process_Formals
(N
: Node_Id
) return Traverse_Result
;
2089 -- Replace occurrence of a formal with the corresponding actual, or
2090 -- the thunk generated for it.
2092 procedure Rewrite_Function_Call
(N
: Node_Id
; Blk
: Node_Id
);
2093 -- If the function body is a single expression, replace call with
2094 -- expression, else insert block appropriately.
2096 procedure Rewrite_Procedure_Call
(N
: Node_Id
; Blk
: Node_Id
);
2097 -- If procedure body has no local variables, inline body without
2098 -- creating block, otherwise rewrite call with block.
2100 ---------------------
2101 -- Make_Exit_Label --
2102 ---------------------
2104 procedure Make_Exit_Label
is
2106 -- Create exit label for subprogram, if one doesn't exist yet.
2108 if No
(Exit_Lab
) then
2109 Lab_Id
:= Make_Identifier
(Loc
, New_Internal_Name
('L'));
2111 Make_Defining_Identifier
(Loc
, Chars
(Lab_Id
)));
2112 Exit_Lab
:= Make_Label
(Loc
, Lab_Id
);
2115 Make_Implicit_Label_Declaration
(Loc
,
2116 Defining_Identifier
=> Entity
(Lab_Id
),
2117 Label_Construct
=> Exit_Lab
);
2119 end Make_Exit_Label
;
2121 ---------------------
2122 -- Process_Formals --
2123 ---------------------
2125 function Process_Formals
(N
: Node_Id
) return Traverse_Result
is
2131 if Is_Entity_Name
(N
)
2132 and then Present
(Entity
(N
))
2137 and then Scope
(E
) = Subp
2139 A
:= Renamed_Object
(E
);
2141 if Is_Entity_Name
(A
) then
2142 Rewrite
(N
, New_Occurrence_Of
(Entity
(A
), Loc
));
2144 elsif Nkind
(A
) = N_Defining_Identifier
then
2145 Rewrite
(N
, New_Occurrence_Of
(A
, Loc
));
2147 else -- numeric literal
2148 Rewrite
(N
, New_Copy
(A
));
2154 elsif Nkind
(N
) = N_Return_Statement
then
2156 if No
(Expression
(N
)) then
2158 Rewrite
(N
, Make_Goto_Statement
(Loc
,
2159 Name
=> New_Copy
(Lab_Id
)));
2162 if Nkind
(Parent
(N
)) = N_Handled_Sequence_Of_Statements
2163 and then Nkind
(Parent
(Parent
(N
))) = N_Subprogram_Body
2165 -- function body is a single expression. No need for
2170 Num_Ret
:= Num_Ret
+ 1;
2174 -- Because of the presence of private types, the views of the
2175 -- expression and the context may be different, so place an
2176 -- unchecked conversion to the context type to avoid spurious
2177 -- errors, eg. when the expression is a numeric literal and
2178 -- the context is private. If the expression is an aggregate,
2179 -- use a qualified expression, because an aggregate is not a
2180 -- legal argument of a conversion.
2182 if Nkind
(Expression
(N
)) = N_Aggregate
2183 or else Nkind
(Expression
(N
)) = N_Null
2186 Make_Qualified_Expression
(Sloc
(N
),
2187 Subtype_Mark
=> New_Occurrence_Of
(Ret_Type
, Sloc
(N
)),
2188 Expression
=> Relocate_Node
(Expression
(N
)));
2191 Unchecked_Convert_To
2192 (Ret_Type
, Relocate_Node
(Expression
(N
)));
2195 if Nkind
(Targ
) = N_Defining_Identifier
then
2197 Make_Assignment_Statement
(Loc
,
2198 Name
=> New_Occurrence_Of
(Targ
, Loc
),
2199 Expression
=> Ret
));
2202 Make_Assignment_Statement
(Loc
,
2203 Name
=> New_Copy
(Targ
),
2204 Expression
=> Ret
));
2207 Set_Assignment_OK
(Name
(N
));
2209 if Present
(Exit_Lab
) then
2211 Make_Goto_Statement
(Loc
,
2212 Name
=> New_Copy
(Lab_Id
)));
2221 end Process_Formals
;
2223 procedure Replace_Formals
is new Traverse_Proc
(Process_Formals
);
2225 ---------------------------
2226 -- Rewrite_Function_Call --
2227 ---------------------------
2229 procedure Rewrite_Function_Call
(N
: Node_Id
; Blk
: Node_Id
) is
2230 HSS
: Node_Id
:= Handled_Statement_Sequence
(Blk
);
2231 Fst
: Node_Id
:= First
(Statements
(HSS
));
2235 -- Optimize simple case: function body is a single return statement,
2236 -- which has been expanded into an assignment.
2238 if Is_Empty_List
(Declarations
(Blk
))
2239 and then Nkind
(Fst
) = N_Assignment_Statement
2240 and then No
(Next
(Fst
))
2243 -- The function call may have been rewritten as the temporary
2244 -- that holds the result of the call, in which case remove the
2245 -- now useless declaration.
2247 if Nkind
(N
) = N_Identifier
2248 and then Nkind
(Parent
(Entity
(N
))) = N_Object_Declaration
2250 Rewrite
(Parent
(Entity
(N
)), Make_Null_Statement
(Loc
));
2253 Rewrite
(N
, Expression
(Fst
));
2255 elsif Nkind
(N
) = N_Identifier
2256 and then Nkind
(Parent
(Entity
(N
))) = N_Object_Declaration
2259 -- The block assigns the result of the call to the temporary.
2261 Insert_After
(Parent
(Entity
(N
)), Blk
);
2263 elsif Nkind
(Parent
(N
)) = N_Assignment_Statement
2264 and then Is_Entity_Name
(Name
(Parent
(N
)))
2267 -- replace assignment with the block.
2269 Rewrite
(Parent
(N
), Blk
);
2271 elsif Nkind
(Parent
(N
)) = N_Object_Declaration
then
2272 Set_Expression
(Parent
(N
), Empty
);
2273 Insert_After
(Parent
(N
), Blk
);
2275 end Rewrite_Function_Call
;
2277 ----------------------------
2278 -- Rewrite_Procedure_Call --
2279 ----------------------------
2281 procedure Rewrite_Procedure_Call
(N
: Node_Id
; Blk
: Node_Id
) is
2282 HSS
: Node_Id
:= Handled_Statement_Sequence
(Blk
);
2285 if Is_Empty_List
(Declarations
(Blk
)) then
2286 Insert_List_After
(N
, Statements
(HSS
));
2287 Rewrite
(N
, Make_Null_Statement
(Loc
));
2291 end Rewrite_Procedure_Call
;
2293 -- Start of processing for Expand_Inlined_Call
2296 if Nkind
(Orig_Bod
) = N_Defining_Identifier
then
2298 -- Subprogram is a renaming_as_body. Calls appearing after the
2299 -- renaming can be replaced with calls to the renamed entity
2300 -- directly, because the subprograms are subtype conformant.
2302 Set_Name
(N
, New_Occurrence_Of
(Orig_Bod
, Loc
));
2306 -- Use generic machinery to copy body of inlined subprogram, as if it
2307 -- were an instantiation, resetting source locations appropriately, so
2308 -- that nested inlined calls appear in the main unit.
2310 Save_Env
(Subp
, Empty
);
2311 Set_Copied_Sloc
(N
, Defining_Entity
(Orig_Bod
));
2314 Copy_Generic_Node
(Orig_Bod
, Empty
, Instantiating
=> True);
2317 Make_Block_Statement
(Loc
,
2318 Declarations
=> Declarations
(Bod
),
2319 Handled_Statement_Sequence
=> Handled_Statement_Sequence
(Bod
));
2321 if No
(Declarations
(Bod
)) then
2322 Set_Declarations
(Blk
, New_List
);
2325 -- If this is a derived function, establish the proper return type.
2327 if Present
(Orig_Subp
)
2328 and then Orig_Subp
/= Subp
2330 Ret_Type
:= Etype
(Orig_Subp
);
2332 Ret_Type
:= Etype
(Subp
);
2335 F
:= First_Formal
(Subp
);
2336 A
:= First_Actual
(N
);
2338 -- Create temporaries for the actuals that are expressions, or that
2339 -- are scalars and require copying to preserve semantics.
2341 while Present
(F
) loop
2343 if Present
(Renamed_Object
(F
)) then
2344 Error_Msg_N
(" cannot inline call to recursive subprogram", N
);
2348 -- If the argument may be a controlling argument in a call within
2349 -- the inlined body, we must preserve its classwide nature to
2350 -- insure that dynamic dispatching take place subsequently.
2351 -- If the formal has a constraint it must be preserved to retain
2352 -- the semantics of the body.
2354 if Is_Class_Wide_Type
(Etype
(F
))
2355 or else (Is_Access_Type
(Etype
(F
))
2357 Is_Class_Wide_Type
(Designated_Type
(Etype
(F
))))
2359 Temp_Typ
:= Etype
(F
);
2361 elsif Base_Type
(Etype
(F
)) = Base_Type
(Etype
(A
))
2362 and then Etype
(F
) /= Base_Type
(Etype
(F
))
2364 Temp_Typ
:= Etype
(F
);
2367 Temp_Typ
:= Etype
(A
);
2370 if (not Is_Entity_Name
(A
)
2371 and then Nkind
(A
) /= N_Integer_Literal
2372 and then Nkind
(A
) /= N_Real_Literal
)
2374 or else Is_Scalar_Type
(Etype
(A
))
2377 Make_Defining_Identifier
(Loc
,
2378 Chars
=> New_Internal_Name
('C'));
2380 -- If the actual for an in/in-out parameter is a view conversion,
2381 -- make it into an unchecked conversion, given that an untagged
2382 -- type conversion is not a proper object for a renaming.
2383 -- In-out conversions that involve real conversions have already
2384 -- been transformed in Expand_Actuals.
2386 if Nkind
(A
) = N_Type_Conversion
2388 (Ekind
(F
) = E_In_Out_Parameter
2389 or else not Is_Tagged_Type
(Etype
(F
)))
2391 New_A
:= Make_Unchecked_Type_Conversion
(Loc
,
2392 Subtype_Mark
=> New_Occurrence_Of
(Etype
(F
), Loc
),
2393 Expression
=> Relocate_Node
(Expression
(A
)));
2395 elsif Etype
(F
) /= Etype
(A
) then
2396 New_A
:= Unchecked_Convert_To
(Etype
(F
), Relocate_Node
(A
));
2397 Temp_Typ
:= Etype
(F
);
2400 New_A
:= Relocate_Node
(A
);
2403 Set_Sloc
(New_A
, Sloc
(N
));
2405 if Ekind
(F
) = E_In_Parameter
2406 and then not Is_Limited_Type
(Etype
(A
))
2409 Make_Object_Declaration
(Loc
,
2410 Defining_Identifier
=> Temp
,
2411 Constant_Present
=> True,
2412 Object_Definition
=> New_Occurrence_Of
(Temp_Typ
, Loc
),
2413 Expression
=> New_A
);
2416 Make_Object_Renaming_Declaration
(Loc
,
2417 Defining_Identifier
=> Temp
,
2418 Subtype_Mark
=> New_Occurrence_Of
(Temp_Typ
, Loc
),
2422 Prepend
(Decl
, Declarations
(Blk
));
2423 Set_Renamed_Object
(F
, Temp
);
2426 if Etype
(F
) /= Etype
(A
) then
2428 (F
, Unchecked_Convert_To
(Etype
(F
), Relocate_Node
(A
)));
2430 Set_Renamed_Object
(F
, A
);
2438 -- Establish target of function call. If context is not assignment or
2439 -- declaration, create a temporary as a target. The declaration for
2440 -- the temporary may be subsequently optimized away if the body is a
2441 -- single expression, or if the left-hand side of the assignment is
2444 if Ekind
(Subp
) = E_Function
then
2445 if Nkind
(Parent
(N
)) = N_Assignment_Statement
2446 and then Is_Entity_Name
(Name
(Parent
(N
)))
2448 Targ
:= Name
(Parent
(N
));
2451 -- Replace call with temporary, and create its declaration.
2454 Make_Defining_Identifier
(Loc
, New_Internal_Name
('C'));
2457 Make_Object_Declaration
(Loc
,
2458 Defining_Identifier
=> Temp
,
2459 Object_Definition
=>
2460 New_Occurrence_Of
(Ret_Type
, Loc
));
2462 Set_No_Initialization
(Decl
);
2463 Insert_Action
(N
, Decl
);
2464 Rewrite
(N
, New_Occurrence_Of
(Temp
, Loc
));
2469 -- Traverse the tree and replace formals with actuals or their thunks.
2470 -- Attach block to tree before analysis and rewriting.
2472 Replace_Formals
(Blk
);
2473 Set_Parent
(Blk
, N
);
2475 if Present
(Exit_Lab
) then
2477 -- If the body was a single expression, the single return statement
2478 -- and the corresponding label are useless.
2482 Nkind
(Last
(Statements
(Handled_Statement_Sequence
(Blk
)))) =
2485 Remove
(Last
(Statements
(Handled_Statement_Sequence
(Blk
))));
2487 Append
(Lab_Decl
, (Declarations
(Blk
)));
2488 Append
(Exit_Lab
, Statements
(Handled_Statement_Sequence
(Blk
)));
2492 -- Analyze Blk with In_Inlined_Body set, to avoid spurious errors on
2493 -- conflicting private views that Gigi would ignore.
2496 I_Flag
: constant Boolean := In_Inlined_Body
;
2499 In_Inlined_Body
:= True;
2501 In_Inlined_Body
:= I_Flag
;
2504 if Ekind
(Subp
) = E_Procedure
then
2505 Rewrite_Procedure_Call
(N
, Blk
);
2507 Rewrite_Function_Call
(N
, Blk
);
2512 -- Cleanup mapping between formals and actuals, for other expansions.
2514 F
:= First_Formal
(Subp
);
2516 while Present
(F
) loop
2517 Set_Renamed_Object
(F
, Empty
);
2520 end Expand_Inlined_Call
;
2522 ----------------------------
2523 -- Expand_N_Function_Call --
2524 ----------------------------
2526 procedure Expand_N_Function_Call
(N
: Node_Id
) is
2527 Typ
: constant Entity_Id
:= Etype
(N
);
2529 function Returned_By_Reference
return Boolean;
2530 -- If the return type is returned through the secondary stack. i.e.
2531 -- by reference, we don't want to create a temporary to force stack
2534 function Returned_By_Reference
return Boolean is
2535 S
: Entity_Id
:= Current_Scope
;
2538 if Is_Return_By_Reference_Type
(Typ
) then
2541 elsif Nkind
(Parent
(N
)) /= N_Return_Statement
then
2544 elsif Requires_Transient_Scope
(Typ
) then
2546 -- Verify that the return type of the enclosing function has
2547 -- the same constrained status as that of the expression.
2549 while Ekind
(S
) /= E_Function
loop
2553 return Is_Constrained
(Typ
) = Is_Constrained
(Etype
(S
));
2557 end Returned_By_Reference
;
2559 -- Start of processing for Expand_N_Function_Call
2562 -- A special check. If stack checking is enabled, and the return type
2563 -- might generate a large temporary, and the call is not the right
2564 -- side of an assignment, then generate an explicit temporary. We do
2565 -- this because otherwise gigi may generate a large temporary on the
2566 -- fly and this can cause trouble with stack checking.
2568 if May_Generate_Large_Temp
(Typ
)
2569 and then Nkind
(Parent
(N
)) /= N_Assignment_Statement
2571 (Nkind
(Parent
(N
)) /= N_Object_Declaration
2572 or else Expression
(Parent
(N
)) /= N
)
2573 and then not Returned_By_Reference
2575 -- Note: it might be thought that it would be OK to use a call to
2576 -- Force_Evaluation here, but that's not good enough, because that
2577 -- results in a 'Reference construct that may still need a temporary.
2580 Loc
: constant Source_Ptr
:= Sloc
(N
);
2581 Temp_Obj
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
,
2582 New_Internal_Name
('F'));
2583 Temp_Typ
: Entity_Id
:= Typ
;
2590 if Is_Tagged_Type
(Typ
)
2591 and then Present
(Controlling_Argument
(N
))
2593 if Nkind
(Parent
(N
)) /= N_Procedure_Call_Statement
2594 and then Nkind
(Parent
(N
)) /= N_Function_Call
2596 -- If this is a tag-indeterminate call, the object must
2599 if Is_Tag_Indeterminate
(N
) then
2600 Temp_Typ
:= Class_Wide_Type
(Typ
);
2604 -- If this is a dispatching call that is itself the
2605 -- controlling argument of an enclosing call, the nominal
2606 -- subtype of the object that replaces it must be classwide,
2607 -- so that dispatching will take place properly. If it is
2608 -- not a controlling argument, the object is not classwide.
2610 Proc
:= Entity
(Name
(Parent
(N
)));
2611 F
:= First_Formal
(Proc
);
2612 A
:= First_Actual
(Parent
(N
));
2619 if Is_Controlling_Formal
(F
) then
2620 Temp_Typ
:= Class_Wide_Type
(Typ
);
2626 Make_Object_Declaration
(Loc
,
2627 Defining_Identifier
=> Temp_Obj
,
2628 Object_Definition
=> New_Occurrence_Of
(Temp_Typ
, Loc
),
2629 Constant_Present
=> True,
2630 Expression
=> Relocate_Node
(N
));
2631 Set_Assignment_OK
(Decl
);
2633 Insert_Actions
(N
, New_List
(Decl
));
2634 Rewrite
(N
, New_Occurrence_Of
(Temp_Obj
, Loc
));
2637 -- Normal case, expand the call
2642 end Expand_N_Function_Call
;
2644 ---------------------------------------
2645 -- Expand_N_Procedure_Call_Statement --
2646 ---------------------------------------
2648 procedure Expand_N_Procedure_Call_Statement
(N
: Node_Id
) is
2651 end Expand_N_Procedure_Call_Statement
;
2653 ------------------------------
2654 -- Expand_N_Subprogram_Body --
2655 ------------------------------
2657 -- Add poll call if ATC polling is enabled
2659 -- Add return statement if last statement in body is not a return
2660 -- statement (this makes things easier on Gigi which does not want
2661 -- to have to handle a missing return).
2663 -- Add call to Activate_Tasks if body is a task activator
2665 -- Deal with possible detection of infinite recursion
2667 -- Eliminate body completely if convention stubbed
2669 -- Encode entity names within body, since we will not need to reference
2670 -- these entities any longer in the front end.
2672 -- Initialize scalar out parameters if Initialize/Normalize_Scalars
2674 -- Reset Pure indication if any parameter has root type System.Address
2676 procedure Expand_N_Subprogram_Body
(N
: Node_Id
) is
2677 Loc
: constant Source_Ptr
:= Sloc
(N
);
2678 H
: constant Node_Id
:= Handled_Statement_Sequence
(N
);
2679 Body_Id
: Entity_Id
;
2680 Spec_Id
: Entity_Id
;
2687 procedure Add_Return
(S
: List_Id
);
2688 -- Append a return statement to the statement sequence S if the last
2689 -- statement is not already a return or a goto statement. Note that
2690 -- the latter test is not critical, it does not matter if we add a
2691 -- few extra returns, since they get eliminated anyway later on.
2697 procedure Add_Return
(S
: List_Id
) is
2698 Last_S
: constant Node_Id
:= Last
(S
);
2699 -- Get original node, in case raise has been rewritten
2702 if not Is_Transfer
(Last_S
) then
2703 Append_To
(S
, Make_Return_Statement
(Sloc
(Last_S
)));
2707 -- Start of processing for Expand_N_Subprogram_Body
2710 -- Set L to either the list of declarations if present, or
2711 -- to the list of statements if no declarations are present.
2712 -- This is used to insert new stuff at the start.
2714 if Is_Non_Empty_List
(Declarations
(N
)) then
2715 L
:= Declarations
(N
);
2717 L
:= Statements
(Handled_Statement_Sequence
(N
));
2720 -- Need poll on entry to subprogram if polling enabled. We only
2721 -- do this for non-empty subprograms, since it does not seem
2722 -- necessary to poll for a dummy null subprogram.
2724 if Is_Non_Empty_List
(L
) then
2725 Generate_Poll_Call
(First
(L
));
2728 -- Find entity for subprogram
2730 Body_Id
:= Defining_Entity
(N
);
2732 if Present
(Corresponding_Spec
(N
)) then
2733 Spec_Id
:= Corresponding_Spec
(N
);
2738 -- If this is a Pure function which has any parameters whose root
2739 -- type is System.Address, reset the Pure indication, since it will
2740 -- likely cause incorrect code to be generated.
2742 if Is_Pure
(Spec_Id
)
2743 and then Is_Subprogram
(Spec_Id
)
2744 and then not Has_Pragma_Pure_Function
(Spec_Id
)
2747 F
: Entity_Id
:= First_Formal
(Spec_Id
);
2750 while Present
(F
) loop
2751 if Is_RTE
(Root_Type
(Etype
(F
)), RE_Address
) then
2752 Set_Is_Pure
(Spec_Id
, False);
2754 if Spec_Id
/= Body_Id
then
2755 Set_Is_Pure
(Body_Id
, False);
2766 -- Initialize any scalar OUT args if Initialize/Normalize_Scalars
2768 if Init_Or_Norm_Scalars
and then Is_Subprogram
(Spec_Id
) then
2770 F
: Entity_Id
:= First_Formal
(Spec_Id
);
2771 V
: constant Boolean := Validity_Checks_On
;
2774 -- We turn off validity checking, since we do not want any
2775 -- check on the initializing value itself (which we know
2776 -- may well be invalid!)
2778 Validity_Checks_On
:= False;
2780 -- Loop through formals
2782 while Present
(F
) loop
2783 if Is_Scalar_Type
(Etype
(F
))
2784 and then Ekind
(F
) = E_Out_Parameter
2786 Insert_Before_And_Analyze
(First
(L
),
2787 Make_Assignment_Statement
(Loc
,
2788 Name
=> New_Occurrence_Of
(F
, Loc
),
2789 Expression
=> Get_Simple_Init_Val
(Etype
(F
), Loc
)));
2795 Validity_Checks_On
:= V
;
2799 -- Clear out statement list for stubbed procedure
2801 if Present
(Corresponding_Spec
(N
)) then
2802 Set_Elaboration_Flag
(N
, Spec_Id
);
2804 if Convention
(Spec_Id
) = Convention_Stubbed
2805 or else Is_Eliminated
(Spec_Id
)
2807 Set_Declarations
(N
, Empty_List
);
2808 Set_Handled_Statement_Sequence
(N
,
2809 Make_Handled_Sequence_Of_Statements
(Loc
,
2810 Statements
=> New_List
(
2811 Make_Null_Statement
(Loc
))));
2816 Scop
:= Scope
(Spec_Id
);
2818 -- Returns_By_Ref flag is normally set when the subprogram is frozen
2819 -- but subprograms with no specs are not frozen
2822 Typ
: constant Entity_Id
:= Etype
(Spec_Id
);
2823 Utyp
: constant Entity_Id
:= Underlying_Type
(Typ
);
2826 if not Acts_As_Spec
(N
)
2827 and then Nkind
(Parent
(Parent
(Spec_Id
))) /=
2828 N_Subprogram_Body_Stub
2832 elsif Is_Return_By_Reference_Type
(Typ
) then
2833 Set_Returns_By_Ref
(Spec_Id
);
2835 elsif Present
(Utyp
) and then Controlled_Type
(Utyp
) then
2836 Set_Returns_By_Ref
(Spec_Id
);
2840 -- For a procedure, we add a return for all possible syntactic ends
2841 -- of the subprogram. Note that reanalysis is not necessary in this
2842 -- case since it would require a lot of work and accomplish nothing.
2844 if Ekind
(Spec_Id
) = E_Procedure
2845 or else Ekind
(Spec_Id
) = E_Generic_Procedure
2847 Add_Return
(Statements
(H
));
2849 if Present
(Exception_Handlers
(H
)) then
2850 Except_H
:= First_Non_Pragma
(Exception_Handlers
(H
));
2852 while Present
(Except_H
) loop
2853 Add_Return
(Statements
(Except_H
));
2854 Next_Non_Pragma
(Except_H
);
2858 -- For a function, we must deal with the case where there is at
2859 -- least one missing return. What we do is to wrap the entire body
2860 -- of the function in a block:
2873 -- raise Program_Error;
2876 -- This approach is necessary because the raise must be signalled
2877 -- to the caller, not handled by any local handler (RM 6.4(11)).
2879 -- Note: we do not need to analyze the constructed sequence here,
2880 -- since it has no handler, and an attempt to analyze the handled
2881 -- statement sequence twice is risky in various ways (e.g. the
2882 -- issue of expanding cleanup actions twice).
2884 elsif Has_Missing_Return
(Spec_Id
) then
2886 Hloc
: constant Source_Ptr
:= Sloc
(H
);
2887 Blok
: constant Node_Id
:=
2888 Make_Block_Statement
(Hloc
,
2889 Handled_Statement_Sequence
=> H
);
2890 Rais
: constant Node_Id
:=
2891 Make_Raise_Program_Error
(Hloc
,
2892 Reason
=> PE_Missing_Return
);
2895 Set_Handled_Statement_Sequence
(N
,
2896 Make_Handled_Sequence_Of_Statements
(Hloc
,
2897 Statements
=> New_List
(Blok
, Rais
)));
2899 New_Scope
(Spec_Id
);
2906 -- Add discriminal renamings to protected subprograms.
2907 -- Install new discriminals for expansion of the next
2908 -- subprogram of this protected type, if any.
2910 if Is_List_Member
(N
)
2911 and then Present
(Parent
(List_Containing
(N
)))
2912 and then Nkind
(Parent
(List_Containing
(N
))) = N_Protected_Body
2914 Add_Discriminal_Declarations
2915 (Declarations
(N
), Scop
, Name_uObject
, Loc
);
2916 Add_Private_Declarations
(Declarations
(N
), Scop
, Name_uObject
, Loc
);
2918 -- Associate privals and discriminals with the next protected
2919 -- operation body to be expanded. These are used to expand
2920 -- references to private data objects and discriminants,
2923 Next_Op
:= Next_Protected_Operation
(N
);
2925 if Present
(Next_Op
) then
2926 Dec
:= Parent
(Base_Type
(Scop
));
2927 Set_Privals
(Dec
, Next_Op
, Loc
);
2928 Set_Discriminals
(Dec
);
2932 -- If subprogram contains a parameterless recursive call, then we may
2933 -- have an infinite recursion, so see if we can generate code to check
2934 -- for this possibility if storage checks are not suppressed.
2936 if Ekind
(Spec_Id
) = E_Procedure
2937 and then Has_Recursive_Call
(Spec_Id
)
2938 and then not Storage_Checks_Suppressed
(Spec_Id
)
2940 Detect_Infinite_Recursion
(N
, Spec_Id
);
2943 -- Finally, if we are in Normalize_Scalars mode, then any scalar out
2944 -- parameters must be initialized to the appropriate default value.
2946 if Ekind
(Spec_Id
) = E_Procedure
and then Normalize_Scalars
then
2953 Formal
:= First_Formal
(Spec_Id
);
2955 while Present
(Formal
) loop
2956 Floc
:= Sloc
(Formal
);
2958 if Ekind
(Formal
) = E_Out_Parameter
2959 and then Is_Scalar_Type
(Etype
(Formal
))
2962 Make_Assignment_Statement
(Floc
,
2963 Name
=> New_Occurrence_Of
(Formal
, Floc
),
2965 Get_Simple_Init_Val
(Etype
(Formal
), Floc
));
2966 Prepend
(Stm
, Declarations
(N
));
2970 Next_Formal
(Formal
);
2975 -- If the subprogram does not have pending instantiations, then we
2976 -- must generate the subprogram descriptor now, since the code for
2977 -- the subprogram is complete, and this is our last chance. However
2978 -- if there are pending instantiations, then the code is not
2979 -- complete, and we will delay the generation.
2981 if Is_Subprogram
(Spec_Id
)
2982 and then not Delay_Subprogram_Descriptors
(Spec_Id
)
2984 Generate_Subprogram_Descriptor_For_Subprogram
(N
, Spec_Id
);
2987 -- Set to encode entity names in package body before gigi is called
2989 Qualify_Entity_Names
(N
);
2990 end Expand_N_Subprogram_Body
;
2992 -----------------------------------
2993 -- Expand_N_Subprogram_Body_Stub --
2994 -----------------------------------
2996 procedure Expand_N_Subprogram_Body_Stub
(N
: Node_Id
) is
2998 if Present
(Corresponding_Body
(N
)) then
2999 Expand_N_Subprogram_Body
(
3000 Unit_Declaration_Node
(Corresponding_Body
(N
)));
3003 end Expand_N_Subprogram_Body_Stub
;
3005 -------------------------------------
3006 -- Expand_N_Subprogram_Declaration --
3007 -------------------------------------
3009 -- The first task to be performed is the construction of default
3010 -- expression functions for in parameters with default values. These
3011 -- are parameterless inlined functions that are used to evaluate
3012 -- default expressions that are more complicated than simple literals
3013 -- or identifiers referencing constants and variables.
3015 -- If the declaration appears within a protected body, it is a private
3016 -- operation of the protected type. We must create the corresponding
3017 -- protected subprogram an associated formals. For a normal protected
3018 -- operation, this is done when expanding the protected type declaration.
3020 procedure Expand_N_Subprogram_Declaration
(N
: Node_Id
) is
3021 Loc
: constant Source_Ptr
:= Sloc
(N
);
3022 Subp
: Entity_Id
:= Defining_Entity
(N
);
3023 Scop
: Entity_Id
:= Scope
(Subp
);
3024 Prot_Sub
: Entity_Id
;
3028 -- Deal with case of protected subprogram
3030 if Is_List_Member
(N
)
3031 and then Present
(Parent
(List_Containing
(N
)))
3032 and then Nkind
(Parent
(List_Containing
(N
))) = N_Protected_Body
3033 and then Is_Protected_Type
(Scop
)
3035 if No
(Protected_Body_Subprogram
(Subp
)) then
3037 Make_Subprogram_Declaration
(Loc
,
3039 Build_Protected_Sub_Specification
3040 (N
, Scop
, Unprotected
=> True));
3042 -- The protected subprogram is declared outside of the protected
3043 -- body. Given that the body has frozen all entities so far, we
3044 -- freeze the subprogram explicitly. If the body is a subunit,
3045 -- the insertion point is before the stub in the parent.
3047 Prot_Bod
:= Parent
(List_Containing
(N
));
3049 if Nkind
(Parent
(Prot_Bod
)) = N_Subunit
then
3050 Prot_Bod
:= Corresponding_Stub
(Parent
(Prot_Bod
));
3053 Insert_Before
(Prot_Bod
, Prot_Sub
);
3055 New_Scope
(Scope
(Scop
));
3057 Set_Protected_Body_Subprogram
(Subp
,
3058 Defining_Unit_Name
(Specification
(Prot_Sub
)));
3062 end Expand_N_Subprogram_Declaration
;
3064 ---------------------------------------
3065 -- Expand_Protected_Object_Reference --
3066 ---------------------------------------
3068 function Expand_Protected_Object_Reference
3073 Loc
: constant Source_Ptr
:= Sloc
(N
);
3080 Rec
:= Make_Identifier
(Loc
, Name_uObject
);
3081 Set_Etype
(Rec
, Corresponding_Record_Type
(Scop
));
3083 -- Find enclosing protected operation, and retrieve its first
3084 -- parameter, which denotes the enclosing protected object.
3085 -- If the enclosing operation is an entry, we are immediately
3086 -- within the protected body, and we can retrieve the object
3087 -- from the service entries procedure. A barrier function has
3088 -- has the same signature as an entry. A barrier function is
3089 -- compiled within the protected object, but unlike protected
3090 -- operations its never needs locks, so that its protected body
3091 -- subprogram points to itself.
3093 Proc
:= Current_Scope
;
3095 while Present
(Proc
)
3096 and then Scope
(Proc
) /= Scop
3098 Proc
:= Scope
(Proc
);
3101 Corr
:= Protected_Body_Subprogram
(Proc
);
3105 -- Previous error left expansion incomplete.
3106 -- Nothing to do on this call.
3113 (First
(Parameter_Specifications
(Parent
(Corr
))));
3115 if Is_Subprogram
(Proc
)
3116 and then Proc
/= Corr
3118 -- Protected function or procedure.
3120 Set_Entity
(Rec
, Param
);
3122 -- Rec is a reference to an entity which will not be in scope
3123 -- when the call is reanalyzed, and needs no further analysis.
3128 -- Entry or barrier function for entry body.
3129 -- The first parameter of the entry body procedure is a
3130 -- pointer to the object. We create a local variable
3131 -- of the proper type, duplicating what is done to define
3132 -- _object later on.
3136 Obj_Ptr
: Entity_Id
:= Make_Defining_Identifier
3137 (Loc
, New_Internal_Name
('T'));
3140 Make_Full_Type_Declaration
(Loc
,
3141 Defining_Identifier
=> Obj_Ptr
,
3143 Make_Access_To_Object_Definition
(Loc
,
3144 Subtype_Indication
=>
3146 (Corresponding_Record_Type
(Scop
), Loc
))));
3148 Insert_Actions
(N
, Decls
);
3149 Insert_Actions
(N
, Freeze_Entity
(Obj_Ptr
, Sloc
(N
)));
3152 Make_Explicit_Dereference
(Loc
,
3153 Unchecked_Convert_To
(Obj_Ptr
,
3154 New_Occurrence_Of
(Param
, Loc
)));
3156 -- Analyze new actual. Other actuals in calls are already
3157 -- analyzed and the list of actuals is not renalyzed after
3160 Set_Parent
(Rec
, N
);
3166 end Expand_Protected_Object_Reference
;
3168 --------------------------------------
3169 -- Expand_Protected_Subprogram_Call --
3170 --------------------------------------
3172 procedure Expand_Protected_Subprogram_Call
3180 -- If the protected object is not an enclosing scope, this is
3181 -- an inter-object function call. Inter-object procedure
3182 -- calls are expanded by Exp_Ch9.Build_Simple_Entry_Call.
3183 -- The call is intra-object only if the subprogram being
3184 -- called is in the protected body being compiled, and if the
3185 -- protected object in the call is statically the enclosing type.
3186 -- The object may be an component of some other data structure,
3187 -- in which case this must be handled as an inter-object call.
3189 if not In_Open_Scopes
(Scop
)
3190 or else not Is_Entity_Name
(Name
(N
))
3192 if Nkind
(Name
(N
)) = N_Selected_Component
then
3193 Rec
:= Prefix
(Name
(N
));
3196 pragma Assert
(Nkind
(Name
(N
)) = N_Indexed_Component
);
3197 Rec
:= Prefix
(Prefix
(Name
(N
)));
3200 Build_Protected_Subprogram_Call
(N
,
3201 Name
=> New_Occurrence_Of
(Subp
, Sloc
(N
)),
3202 Rec
=> Convert_Concurrent
(Rec
, Etype
(Rec
)),
3206 Rec
:= Expand_Protected_Object_Reference
(N
, Scop
);
3212 Build_Protected_Subprogram_Call
(N
,
3221 -- If it is a function call it can appear in elaboration code and
3222 -- the called entity must be frozen here.
3224 if Ekind
(Subp
) = E_Function
then
3225 Freeze_Expression
(Name
(N
));
3227 end Expand_Protected_Subprogram_Call
;
3229 -----------------------
3230 -- Freeze_Subprogram --
3231 -----------------------
3233 procedure Freeze_Subprogram
(N
: Node_Id
) is
3234 E
: constant Entity_Id
:= Entity
(N
);
3237 -- When a primitive is frozen, enter its name in the corresponding
3238 -- dispatch table. If the DTC_Entity field is not set this is an
3239 -- overridden primitive that can be ignored. We suppress the
3240 -- initialization of the dispatch table entry when Java_VM because
3241 -- the dispatching mechanism is handled internally by the JVM.
3243 if Is_Dispatching_Operation
(E
)
3244 and then not Is_Abstract
(E
)
3245 and then Present
(DTC_Entity
(E
))
3246 and then not Is_CPP_Class
(Scope
(DTC_Entity
(E
)))
3247 and then not Java_VM
3249 Check_Overriding_Operation
(E
);
3250 Insert_After
(N
, Fill_DT_Entry
(Sloc
(N
), E
));
3253 -- Mark functions that return by reference. Note that it cannot be
3254 -- part of the normal semantic analysis of the spec since the
3255 -- underlying returned type may not be known yet (for private types)
3258 Typ
: constant Entity_Id
:= Etype
(E
);
3259 Utyp
: constant Entity_Id
:= Underlying_Type
(Typ
);
3262 if Is_Return_By_Reference_Type
(Typ
) then
3263 Set_Returns_By_Ref
(E
);
3265 elsif Present
(Utyp
) and then Controlled_Type
(Utyp
) then
3266 Set_Returns_By_Ref
(E
);
3270 end Freeze_Subprogram
;