1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2005, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 2, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING. If not, write --
19 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
20 -- MA 02111-1307, USA. --
22 -- GNAT was originally developed by the GNAT team at New York University. --
23 -- Extensive contributions were provided by Ada Core Technologies Inc. --
25 ------------------------------------------------------------------------------
27 with Atree
; use Atree
;
28 with Checks
; use Checks
;
29 with Debug
; use Debug
;
30 with Einfo
; use Einfo
;
31 with Errout
; use Errout
;
32 with Elists
; use Elists
;
33 with Exp_Ch2
; use Exp_Ch2
;
34 with Exp_Ch3
; use Exp_Ch3
;
35 with Exp_Ch7
; use Exp_Ch7
;
36 with Exp_Ch9
; use Exp_Ch9
;
37 with Exp_Ch11
; use Exp_Ch11
;
38 with Exp_Dbug
; use Exp_Dbug
;
39 with Exp_Disp
; use Exp_Disp
;
40 with Exp_Dist
; use Exp_Dist
;
41 with Exp_Intr
; use Exp_Intr
;
42 with Exp_Pakd
; use Exp_Pakd
;
43 with Exp_Tss
; use Exp_Tss
;
44 with Exp_Util
; use Exp_Util
;
45 with Fname
; use Fname
;
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 Rident
; use Rident
;
55 with Rtsfind
; use Rtsfind
;
57 with Sem_Ch6
; use Sem_Ch6
;
58 with Sem_Ch8
; use Sem_Ch8
;
59 with Sem_Ch12
; use Sem_Ch12
;
60 with Sem_Ch13
; use Sem_Ch13
;
61 with Sem_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 Ttypes
; use Ttypes
;
70 with Uintp
; use Uintp
;
71 with Validsw
; use Validsw
;
73 package body Exp_Ch6
is
75 -----------------------
76 -- Local Subprograms --
77 -----------------------
79 procedure Check_Overriding_Operation
(Subp
: Entity_Id
);
80 -- Subp is a dispatching operation. Check whether it may override an
81 -- inherited private operation, in which case its DT entry is that of
82 -- the hidden operation, not the one it may have received earlier.
83 -- This must be done before emitting the code to set the corresponding
84 -- DT to the address of the subprogram. The actual placement of Subp in
85 -- the proper place in the list of primitive operations is done in
86 -- Declare_Inherited_Private_Subprograms, which also has to deal with
87 -- implicit operations. This duplication is unavoidable for now???
89 procedure Detect_Infinite_Recursion
(N
: Node_Id
; Spec
: Entity_Id
);
90 -- This procedure is called only if the subprogram body N, whose spec
91 -- has the given entity Spec, contains a parameterless recursive call.
92 -- It attempts to generate runtime code to detect if this a case of
93 -- infinite recursion.
95 -- The body is scanned to determine dependencies. If the only external
96 -- dependencies are on a small set of scalar variables, then the values
97 -- of these variables are captured on entry to the subprogram, and if
98 -- the values are not changed for the call, we know immediately that
99 -- we have an infinite recursion.
101 procedure Expand_Actuals
(N
: Node_Id
; Subp
: Entity_Id
);
102 -- For each actual of an in-out parameter which is a numeric conversion
103 -- of the form T(A), where A denotes a variable, we insert the declaration:
105 -- Temp : T := T (A);
107 -- prior to the call. Then we replace the actual with a reference to Temp,
108 -- and append the assignment:
110 -- A := TypeA (Temp);
112 -- after the call. Here TypeA is the actual type of variable A.
113 -- For out parameters, the initial declaration has no expression.
114 -- If A is not an entity name, we generate instead:
116 -- Var : TypeA renames A;
117 -- Temp : T := Var; -- omitting expression for out parameter.
119 -- Var := TypeA (Temp);
121 -- For other in-out parameters, we emit the required constraint checks
122 -- before and/or after the call.
124 -- For all parameter modes, actuals that denote components and slices
125 -- of packed arrays are expanded into suitable temporaries.
127 -- For non-scalar objects that are possibly unaligned, add call by copy
128 -- code (copy in for IN and IN OUT, copy out for OUT and IN OUT).
130 procedure Expand_Inlined_Call
133 Orig_Subp
: Entity_Id
);
134 -- If called subprogram can be inlined by the front-end, retrieve the
135 -- analyzed body, replace formals with actuals and expand call in place.
136 -- Generate thunks for actuals that are expressions, and insert the
137 -- corresponding constant declarations before the call. If the original
138 -- call is to a derived operation, the return type is the one of the
139 -- derived operation, but the body is that of the original, so return
140 -- expressions in the body must be converted to the desired type (which
141 -- is simply not noted in the tree without inline expansion).
143 function Expand_Protected_Object_Reference
148 procedure Expand_Protected_Subprogram_Call
152 -- A call to a protected subprogram within the protected object may appear
153 -- as a regular call. The list of actuals must be expanded to contain a
154 -- reference to the object itself, and the call becomes a call to the
155 -- corresponding protected subprogram.
157 --------------------------------
158 -- Check_Overriding_Operation --
159 --------------------------------
161 procedure Check_Overriding_Operation
(Subp
: Entity_Id
) is
162 Typ
: constant Entity_Id
:= Find_Dispatching_Type
(Subp
);
163 Op_List
: constant Elist_Id
:= Primitive_Operations
(Typ
);
169 if Is_Derived_Type
(Typ
)
170 and then not Is_Private_Type
(Typ
)
171 and then In_Open_Scopes
(Scope
(Etype
(Typ
)))
172 and then Typ
= Base_Type
(Typ
)
174 -- Subp overrides an inherited private operation if there is
175 -- an inherited operation with a different name than Subp (see
176 -- Derive_Subprogram) whose Alias is a hidden subprogram with
177 -- the same name as Subp.
179 Op_Elmt
:= First_Elmt
(Op_List
);
180 while Present
(Op_Elmt
) loop
181 Prim_Op
:= Node
(Op_Elmt
);
182 Par_Op
:= Alias
(Prim_Op
);
185 and then not Comes_From_Source
(Prim_Op
)
186 and then Chars
(Prim_Op
) /= Chars
(Par_Op
)
187 and then Chars
(Par_Op
) = Chars
(Subp
)
188 and then Is_Hidden
(Par_Op
)
189 and then Type_Conformant
(Prim_Op
, Subp
)
191 Set_DT_Position
(Subp
, DT_Position
(Prim_Op
));
197 end Check_Overriding_Operation
;
199 -------------------------------
200 -- Detect_Infinite_Recursion --
201 -------------------------------
203 procedure Detect_Infinite_Recursion
(N
: Node_Id
; Spec
: Entity_Id
) is
204 Loc
: constant Source_Ptr
:= Sloc
(N
);
206 Var_List
: constant Elist_Id
:= New_Elmt_List
;
207 -- List of globals referenced by body of procedure
209 Call_List
: constant Elist_Id
:= New_Elmt_List
;
210 -- List of recursive calls in body of procedure
212 Shad_List
: constant Elist_Id
:= New_Elmt_List
;
213 -- List of entity id's for entities created to capture the
214 -- value of referenced globals on entry to the procedure.
216 Scop
: constant Uint
:= Scope_Depth
(Spec
);
217 -- This is used to record the scope depth of the current
218 -- procedure, so that we can identify global references.
220 Max_Vars
: constant := 4;
221 -- Do not test more than four global variables
223 Count_Vars
: Natural := 0;
224 -- Count variables found so far
236 function Process
(Nod
: Node_Id
) return Traverse_Result
;
237 -- Function to traverse the subprogram body (using Traverse_Func)
243 function Process
(Nod
: Node_Id
) return Traverse_Result
is
247 if Nkind
(Nod
) = N_Procedure_Call_Statement
then
249 -- Case of one of the detected recursive calls
251 if Is_Entity_Name
(Name
(Nod
))
252 and then Has_Recursive_Call
(Entity
(Name
(Nod
)))
253 and then Entity
(Name
(Nod
)) = Spec
255 Append_Elmt
(Nod
, Call_List
);
258 -- Any other procedure call may have side effects
264 -- A call to a pure function can always be ignored
266 elsif Nkind
(Nod
) = N_Function_Call
267 and then Is_Entity_Name
(Name
(Nod
))
268 and then Is_Pure
(Entity
(Name
(Nod
)))
272 -- Case of an identifier reference
274 elsif Nkind
(Nod
) = N_Identifier
then
277 -- If no entity, then ignore the reference
279 -- Not clear why this can happen. To investigate, remove this
280 -- test and look at the crash that occurs here in 3401-004 ???
285 -- Ignore entities with no Scope, again not clear how this
286 -- can happen, to investigate, look at 4108-008 ???
288 elsif No
(Scope
(Ent
)) then
291 -- Ignore the reference if not to a more global object
293 elsif Scope_Depth
(Scope
(Ent
)) >= Scop
then
296 -- References to types, exceptions and constants are always OK
299 or else Ekind
(Ent
) = E_Exception
300 or else Ekind
(Ent
) = E_Constant
304 -- If other than a non-volatile scalar variable, we have some
305 -- kind of global reference (e.g. to a function) that we cannot
306 -- deal with so we forget the attempt.
308 elsif Ekind
(Ent
) /= E_Variable
309 or else not Is_Scalar_Type
(Etype
(Ent
))
310 or else Treat_As_Volatile
(Ent
)
314 -- Otherwise we have a reference to a global scalar
317 -- Loop through global entities already detected
319 Elm
:= First_Elmt
(Var_List
);
321 -- If not detected before, record this new global reference
324 Count_Vars
:= Count_Vars
+ 1;
326 if Count_Vars
<= Max_Vars
then
327 Append_Elmt
(Entity
(Nod
), Var_List
);
334 -- If recorded before, ignore
336 elsif Node
(Elm
) = Entity
(Nod
) then
339 -- Otherwise keep looking
349 -- For all other node kinds, recursively visit syntactic children
356 function Traverse_Body
is new Traverse_Func
;
358 -- Start of processing for Detect_Infinite_Recursion
361 -- Do not attempt detection in No_Implicit_Conditional mode,
362 -- since we won't be able to generate the code to handle the
363 -- recursion in any case.
365 if Restriction_Active
(No_Implicit_Conditionals
) then
369 -- Otherwise do traversal and quit if we get abandon signal
371 if Traverse_Body
(N
) = Abandon
then
374 -- We must have a call, since Has_Recursive_Call was set. If not
375 -- just ignore (this is only an error check, so if we have a funny
376 -- situation, due to bugs or errors, we do not want to bomb!)
378 elsif Is_Empty_Elmt_List
(Call_List
) then
382 -- Here is the case where we detect recursion at compile time
384 -- Push our current scope for analyzing the declarations and
385 -- code that we will insert for the checking.
389 -- This loop builds temporary variables for each of the
390 -- referenced globals, so that at the end of the loop the
391 -- list Shad_List contains these temporaries in one-to-one
392 -- correspondence with the elements in Var_List.
395 Elm
:= First_Elmt
(Var_List
);
396 while Present
(Elm
) loop
399 Make_Defining_Identifier
(Loc
,
400 Chars
=> New_Internal_Name
('S'));
401 Append_Elmt
(Ent
, Shad_List
);
403 -- Insert a declaration for this temporary at the start of
404 -- the declarations for the procedure. The temporaries are
405 -- declared as constant objects initialized to the current
406 -- values of the corresponding temporaries.
409 Make_Object_Declaration
(Loc
,
410 Defining_Identifier
=> Ent
,
411 Object_Definition
=> New_Occurrence_Of
(Etype
(Var
), Loc
),
412 Constant_Present
=> True,
413 Expression
=> New_Occurrence_Of
(Var
, Loc
));
416 Prepend
(Decl
, Declarations
(N
));
418 Insert_After
(Last
, Decl
);
426 -- Loop through calls
428 Call
:= First_Elmt
(Call_List
);
429 while Present
(Call
) loop
431 -- Build a predicate expression of the form
434 -- and then global1 = temp1
435 -- and then global2 = temp2
438 -- This predicate determines if any of the global values
439 -- referenced by the procedure have changed since the
440 -- current call, if not an infinite recursion is assured.
442 Test
:= New_Occurrence_Of
(Standard_True
, Loc
);
444 Elm1
:= First_Elmt
(Var_List
);
445 Elm2
:= First_Elmt
(Shad_List
);
446 while Present
(Elm1
) loop
452 Left_Opnd
=> New_Occurrence_Of
(Node
(Elm1
), Loc
),
453 Right_Opnd
=> New_Occurrence_Of
(Node
(Elm2
), Loc
)));
459 -- Now we replace the call with the sequence
461 -- if no-changes (see above) then
462 -- raise Storage_Error;
467 Rewrite
(Node
(Call
),
468 Make_If_Statement
(Loc
,
470 Then_Statements
=> New_List
(
471 Make_Raise_Storage_Error
(Loc
,
472 Reason
=> SE_Infinite_Recursion
)),
474 Else_Statements
=> New_List
(
475 Relocate_Node
(Node
(Call
)))));
477 Analyze
(Node
(Call
));
482 -- Remove temporary scope stack entry used for analysis
485 end Detect_Infinite_Recursion
;
491 procedure Expand_Actuals
(N
: Node_Id
; Subp
: Entity_Id
) is
492 Loc
: constant Source_Ptr
:= Sloc
(N
);
497 E_Formal
: Entity_Id
;
499 procedure Add_Call_By_Copy_Code
;
500 -- For cases where the parameter must be passed by copy, this routine
501 -- generates a temporary variable into which the actual is copied and
502 -- then passes this as the parameter. For an OUT or IN OUT parameter,
503 -- an assignment is also generated to copy the result back. The call
504 -- also takes care of any constraint checks required for the type
505 -- conversion case (on both the way in and the way out).
507 procedure Add_Simple_Call_By_Copy_Code
;
508 -- This is similar to the above, but is used in cases where we know
509 -- that all that is needed is to simply create a temporary and copy
510 -- the value in and out of the temporary.
512 procedure Check_Fortran_Logical
;
513 -- A value of type Logical that is passed through a formal parameter
514 -- must be normalized because .TRUE. usually does not have the same
515 -- representation as True. We assume that .FALSE. = False = 0.
516 -- What about functions that return a logical type ???
518 function Make_Var
(Actual
: Node_Id
) return Entity_Id
;
519 -- Returns an entity that refers to the given actual parameter,
520 -- Actual (not including any type conversion). If Actual is an
521 -- entity name, then this entity is returned unchanged, otherwise
522 -- a renaming is created to provide an entity for the actual.
524 procedure Reset_Packed_Prefix
;
525 -- The expansion of a packed array component reference is delayed in
526 -- the context of a call. Now we need to complete the expansion, so we
527 -- unmark the analyzed bits in all prefixes.
529 ---------------------------
530 -- Add_Call_By_Copy_Code --
531 ---------------------------
533 procedure Add_Call_By_Copy_Code
is
539 F_Typ
: constant Entity_Id
:= Etype
(Formal
);
544 Temp
:= Make_Defining_Identifier
(Loc
, New_Internal_Name
('T'));
546 -- Use formal type for temp, unless formal type is an unconstrained
547 -- array, in which case we don't have to worry about bounds checks,
548 -- and we use the actual type, since that has appropriate bonds.
550 if Is_Array_Type
(F_Typ
) and then not Is_Constrained
(F_Typ
) then
551 Indic
:= New_Occurrence_Of
(Etype
(Actual
), Loc
);
553 Indic
:= New_Occurrence_Of
(Etype
(Formal
), Loc
);
556 if Nkind
(Actual
) = N_Type_Conversion
then
557 V_Typ
:= Etype
(Expression
(Actual
));
559 -- If the formal is an (in-)out parameter, capture the name
560 -- of the variable in order to build the post-call assignment.
562 Var
:= Make_Var
(Expression
(Actual
));
564 Crep
:= not Same_Representation
565 (F_Typ
, Etype
(Expression
(Actual
)));
568 V_Typ
:= Etype
(Actual
);
569 Var
:= Make_Var
(Actual
);
573 -- Setup initialization for case of in out parameter, or an out
574 -- parameter where the formal is an unconstrained array (in the
575 -- latter case, we have to pass in an object with bounds).
577 -- If this is an out parameter, the initial copy is wasteful, so as
578 -- an optimization for the one-dimensional case we extract the
579 -- bounds of the actual and build an uninitialized temporary of the
582 if Ekind
(Formal
) = E_In_Out_Parameter
583 or else (Is_Array_Type
(F_Typ
) and then not Is_Constrained
(F_Typ
))
585 if Nkind
(Actual
) = N_Type_Conversion
then
586 if Conversion_OK
(Actual
) then
587 Init
:= OK_Convert_To
(F_Typ
, New_Occurrence_Of
(Var
, Loc
));
589 Init
:= Convert_To
(F_Typ
, New_Occurrence_Of
(Var
, Loc
));
592 elsif Ekind
(Formal
) = E_Out_Parameter
593 and then Is_Array_Type
(F_Typ
)
594 and then Number_Dimensions
(F_Typ
) = 1
595 and then not Has_Non_Null_Base_Init_Proc
(F_Typ
)
597 -- Actual is a one-dimensional array or slice, and the type
598 -- requires no initialization. Create a temporary of the
599 -- right size, but do not copy actual into it (optimization).
603 Make_Subtype_Indication
(Loc
,
605 New_Occurrence_Of
(F_Typ
, Loc
),
607 Make_Index_Or_Discriminant_Constraint
(Loc
,
608 Constraints
=> New_List
(
611 Make_Attribute_Reference
(Loc
,
612 Prefix
=> New_Occurrence_Of
(Var
, Loc
),
613 Attribute_name
=> Name_First
),
615 Make_Attribute_Reference
(Loc
,
616 Prefix
=> New_Occurrence_Of
(Var
, Loc
),
617 Attribute_Name
=> Name_Last
)))));
620 Init
:= New_Occurrence_Of
(Var
, Loc
);
623 -- An initialization is created for packed conversions as
624 -- actuals for out parameters to enable Make_Object_Declaration
625 -- to determine the proper subtype for N_Node. Note that this
626 -- is wasteful because the extra copying on the call side is
627 -- not required for such out parameters. ???
629 elsif Ekind
(Formal
) = E_Out_Parameter
630 and then Nkind
(Actual
) = N_Type_Conversion
631 and then (Is_Bit_Packed_Array
(F_Typ
)
633 Is_Bit_Packed_Array
(Etype
(Expression
(Actual
))))
635 if Conversion_OK
(Actual
) then
636 Init
:= OK_Convert_To
(F_Typ
, New_Occurrence_Of
(Var
, Loc
));
638 Init
:= Convert_To
(F_Typ
, New_Occurrence_Of
(Var
, Loc
));
641 elsif Ekind
(Formal
) = E_In_Parameter
then
642 Init
:= New_Occurrence_Of
(Var
, Loc
);
649 Make_Object_Declaration
(Loc
,
650 Defining_Identifier
=> Temp
,
651 Object_Definition
=> Indic
,
653 Set_Assignment_OK
(N_Node
);
654 Insert_Action
(N
, N_Node
);
656 -- Now, normally the deal here is that we use the defining
657 -- identifier created by that object declaration. There is
658 -- one exception to this. In the change of representation case
659 -- the above declaration will end up looking like:
661 -- temp : type := identifier;
663 -- And in this case we might as well use the identifier directly
664 -- and eliminate the temporary. Note that the analysis of the
665 -- declaration was not a waste of time in that case, since it is
666 -- what generated the necessary change of representation code. If
667 -- the change of representation introduced additional code, as in
668 -- a fixed-integer conversion, the expression is not an identifier
672 and then Present
(Expression
(N_Node
))
673 and then Is_Entity_Name
(Expression
(N_Node
))
675 Temp
:= Entity
(Expression
(N_Node
));
676 Rewrite
(N_Node
, Make_Null_Statement
(Loc
));
679 -- For IN parameter, all we do is to replace the actual
681 if Ekind
(Formal
) = E_In_Parameter
then
682 Rewrite
(Actual
, New_Reference_To
(Temp
, Loc
));
685 -- Processing for OUT or IN OUT parameter
688 -- If type conversion, use reverse conversion on exit
690 if Nkind
(Actual
) = N_Type_Conversion
then
691 if Conversion_OK
(Actual
) then
692 Expr
:= OK_Convert_To
(V_Typ
, New_Occurrence_Of
(Temp
, Loc
));
694 Expr
:= Convert_To
(V_Typ
, New_Occurrence_Of
(Temp
, Loc
));
697 Expr
:= New_Occurrence_Of
(Temp
, Loc
);
700 Rewrite
(Actual
, New_Reference_To
(Temp
, Loc
));
703 Append_To
(Post_Call
,
704 Make_Assignment_Statement
(Loc
,
705 Name
=> New_Occurrence_Of
(Var
, Loc
),
706 Expression
=> Expr
));
708 Set_Assignment_OK
(Name
(Last
(Post_Call
)));
710 end Add_Call_By_Copy_Code
;
712 ----------------------------------
713 -- Add_Simple_Call_By_Copy_Code --
714 ----------------------------------
716 procedure Add_Simple_Call_By_Copy_Code
is
723 F_Typ
: constant Entity_Id
:= Etype
(Formal
);
726 -- Use formal type for temp, unless formal type is an unconstrained
727 -- array, in which case we don't have to worry about bounds checks,
728 -- and we use the actual type, since that has appropriate bonds.
730 if Is_Array_Type
(F_Typ
) and then not Is_Constrained
(F_Typ
) then
731 Indic
:= New_Occurrence_Of
(Etype
(Actual
), Loc
);
733 Indic
:= New_Occurrence_Of
(Etype
(Formal
), Loc
);
736 -- Prepare to generate code
740 Temp
:= Make_Defining_Identifier
(Loc
, New_Internal_Name
('T'));
741 Incod
:= Relocate_Node
(Actual
);
742 Outcod
:= New_Copy_Tree
(Incod
);
744 -- Generate declaration of temporary variable, initializing it
745 -- with the input parameter unless we have an OUT variable.
747 if Ekind
(Formal
) = E_Out_Parameter
then
752 Make_Object_Declaration
(Loc
,
753 Defining_Identifier
=> Temp
,
754 Object_Definition
=> Indic
,
755 Expression
=> Incod
));
757 -- The actual is simply a reference to the temporary
759 Rewrite
(Actual
, New_Occurrence_Of
(Temp
, Loc
));
761 -- Generate copy out if OUT or IN OUT parameter
763 if Ekind
(Formal
) /= E_In_Parameter
then
765 Rhs
:= New_Occurrence_Of
(Temp
, Loc
);
767 -- Deal with conversion
769 if Nkind
(Lhs
) = N_Type_Conversion
then
770 Lhs
:= Expression
(Lhs
);
771 Rhs
:= Convert_To
(Etype
(Actual
), Rhs
);
774 Append_To
(Post_Call
,
775 Make_Assignment_Statement
(Loc
,
778 Set_Assignment_OK
(Name
(Last
(Post_Call
)));
780 end Add_Simple_Call_By_Copy_Code
;
782 ---------------------------
783 -- Check_Fortran_Logical --
784 ---------------------------
786 procedure Check_Fortran_Logical
is
787 Logical
: constant Entity_Id
:= Etype
(Formal
);
790 -- Note: this is very incomplete, e.g. it does not handle arrays
791 -- of logical values. This is really not the right approach at all???)
794 if Convention
(Subp
) = Convention_Fortran
795 and then Root_Type
(Etype
(Formal
)) = Standard_Boolean
796 and then Ekind
(Formal
) /= E_In_Parameter
798 Var
:= Make_Var
(Actual
);
799 Append_To
(Post_Call
,
800 Make_Assignment_Statement
(Loc
,
801 Name
=> New_Occurrence_Of
(Var
, Loc
),
803 Unchecked_Convert_To
(
806 Left_Opnd
=> New_Occurrence_Of
(Var
, Loc
),
808 Unchecked_Convert_To
(
810 New_Occurrence_Of
(Standard_False
, Loc
))))));
812 end Check_Fortran_Logical
;
818 function Make_Var
(Actual
: Node_Id
) return Entity_Id
is
822 if Is_Entity_Name
(Actual
) then
823 return Entity
(Actual
);
826 Var
:= Make_Defining_Identifier
(Loc
, New_Internal_Name
('T'));
829 Make_Object_Renaming_Declaration
(Loc
,
830 Defining_Identifier
=> Var
,
832 New_Occurrence_Of
(Etype
(Actual
), Loc
),
833 Name
=> Relocate_Node
(Actual
));
835 Insert_Action
(N
, N_Node
);
840 -------------------------
841 -- Reset_Packed_Prefix --
842 -------------------------
844 procedure Reset_Packed_Prefix
is
845 Pfx
: Node_Id
:= Actual
;
849 Set_Analyzed
(Pfx
, False);
850 exit when Nkind
(Pfx
) /= N_Selected_Component
851 and then Nkind
(Pfx
) /= N_Indexed_Component
;
854 end Reset_Packed_Prefix
;
856 -- Start of processing for Expand_Actuals
859 Formal
:= First_Formal
(Subp
);
860 Actual
:= First_Actual
(N
);
862 Post_Call
:= New_List
;
864 while Present
(Formal
) loop
865 E_Formal
:= Etype
(Formal
);
867 if Is_Scalar_Type
(E_Formal
)
868 or else Nkind
(Actual
) = N_Slice
870 Check_Fortran_Logical
;
874 elsif Ekind
(Formal
) /= E_Out_Parameter
then
876 -- The unusual case of the current instance of a protected type
877 -- requires special handling. This can only occur in the context
878 -- of a call within the body of a protected operation.
880 if Is_Entity_Name
(Actual
)
881 and then Ekind
(Entity
(Actual
)) = E_Protected_Type
882 and then In_Open_Scopes
(Entity
(Actual
))
884 if Scope
(Subp
) /= Entity
(Actual
) then
885 Error_Msg_N
("operation outside protected type may not "
886 & "call back its protected operations?", Actual
);
890 Expand_Protected_Object_Reference
(N
, Entity
(Actual
)));
893 Apply_Constraint_Check
(Actual
, E_Formal
);
895 -- Out parameter case. No constraint checks on access type
898 elsif Is_Access_Type
(E_Formal
) then
903 elsif Has_Discriminants
(Base_Type
(E_Formal
))
904 or else Has_Non_Null_Base_Init_Proc
(E_Formal
)
906 Apply_Constraint_Check
(Actual
, E_Formal
);
911 Apply_Constraint_Check
(Actual
, Base_Type
(E_Formal
));
914 -- Processing for IN-OUT and OUT parameters
916 if Ekind
(Formal
) /= E_In_Parameter
then
918 -- For type conversions of arrays, apply length/range checks
920 if Is_Array_Type
(E_Formal
)
921 and then Nkind
(Actual
) = N_Type_Conversion
923 if Is_Constrained
(E_Formal
) then
924 Apply_Length_Check
(Expression
(Actual
), E_Formal
);
926 Apply_Range_Check
(Expression
(Actual
), E_Formal
);
930 -- If argument is a type conversion for a type that is passed
931 -- by copy, then we must pass the parameter by copy.
933 if Nkind
(Actual
) = N_Type_Conversion
935 (Is_Numeric_Type
(E_Formal
)
936 or else Is_Access_Type
(E_Formal
)
937 or else Is_Enumeration_Type
(E_Formal
)
938 or else Is_Bit_Packed_Array
(Etype
(Formal
))
939 or else Is_Bit_Packed_Array
(Etype
(Expression
(Actual
)))
941 -- Also pass by copy if change of representation
943 or else not Same_Representation
945 Etype
(Expression
(Actual
))))
947 Add_Call_By_Copy_Code
;
949 -- References to components of bit packed arrays are expanded
950 -- at this point, rather than at the point of analysis of the
951 -- actuals, to handle the expansion of the assignment to
952 -- [in] out parameters.
954 elsif Is_Ref_To_Bit_Packed_Array
(Actual
) then
955 Add_Simple_Call_By_Copy_Code
;
957 -- If a non-scalar actual is possibly unaligned, we need a copy
959 elsif Is_Possibly_Unaligned_Object
(Actual
)
960 and then not Represented_As_Scalar
(Etype
(Formal
))
962 Add_Simple_Call_By_Copy_Code
;
964 -- References to slices of bit packed arrays are expanded
966 elsif Is_Ref_To_Bit_Packed_Slice
(Actual
) then
967 Add_Call_By_Copy_Code
;
969 -- References to possibly unaligned slices of arrays are expanded
971 elsif Is_Possibly_Unaligned_Slice
(Actual
) then
972 Add_Call_By_Copy_Code
;
974 -- Deal with access types where the actual subtpe and the
975 -- formal subtype are not the same, requiring a check.
977 -- It is necessary to exclude tagged types because of "downward
978 -- conversion" errors and a strange assertion error in namet
979 -- from gnatf in bug 1215-001 ???
981 elsif Is_Access_Type
(E_Formal
)
982 and then not Same_Type
(E_Formal
, Etype
(Actual
))
983 and then not Is_Tagged_Type
(Designated_Type
(E_Formal
))
985 Add_Call_By_Copy_Code
;
987 -- If the actual is not a scalar and is marked for volatile
988 -- treatment, whereas the formal is not volatile, then pass
989 -- by copy unless it is a by-reference type.
991 elsif Is_Entity_Name
(Actual
)
992 and then Treat_As_Volatile
(Entity
(Actual
))
993 and then not Is_By_Reference_Type
(Etype
(Actual
))
994 and then not Is_Scalar_Type
(Etype
(Entity
(Actual
)))
995 and then not Treat_As_Volatile
(E_Formal
)
997 Add_Call_By_Copy_Code
;
999 elsif Nkind
(Actual
) = N_Indexed_Component
1000 and then Is_Entity_Name
(Prefix
(Actual
))
1001 and then Has_Volatile_Components
(Entity
(Prefix
(Actual
)))
1003 Add_Call_By_Copy_Code
;
1006 -- Processing for IN parameters
1009 -- For IN parameters is in the packed array case, we expand an
1010 -- indexed component (the circuit in Exp_Ch4 deliberately left
1011 -- indexed components appearing as actuals untouched, so that
1012 -- the special processing above for the OUT and IN OUT cases
1013 -- could be performed. We could make the test in Exp_Ch4 more
1014 -- complex and have it detect the parameter mode, but it is
1015 -- easier simply to handle all cases here.)
1017 if Nkind
(Actual
) = N_Indexed_Component
1018 and then Is_Packed
(Etype
(Prefix
(Actual
)))
1020 Reset_Packed_Prefix
;
1021 Expand_Packed_Element_Reference
(Actual
);
1023 -- If we have a reference to a bit packed array, we copy it,
1024 -- since the actual must be byte aligned.
1026 -- Is this really necessary in all cases???
1028 elsif Is_Ref_To_Bit_Packed_Array
(Actual
) then
1029 Add_Simple_Call_By_Copy_Code
;
1031 -- If a non-scalar actual is possibly unaligned, we need a copy
1033 elsif Is_Possibly_Unaligned_Object
(Actual
)
1034 and then not Represented_As_Scalar
(Etype
(Formal
))
1036 Add_Simple_Call_By_Copy_Code
;
1038 -- Similarly, we have to expand slices of packed arrays here
1039 -- because the result must be byte aligned.
1041 elsif Is_Ref_To_Bit_Packed_Slice
(Actual
) then
1042 Add_Call_By_Copy_Code
;
1044 -- Only processing remaining is to pass by copy if this is a
1045 -- reference to a possibly unaligned slice, since the caller
1046 -- expects an appropriately aligned argument.
1048 elsif Is_Possibly_Unaligned_Slice
(Actual
) then
1049 Add_Call_By_Copy_Code
;
1053 Next_Formal
(Formal
);
1054 Next_Actual
(Actual
);
1057 -- Find right place to put post call stuff if it is present
1059 if not Is_Empty_List
(Post_Call
) then
1061 -- If call is not a list member, it must be the triggering
1062 -- statement of a triggering alternative or an entry call
1063 -- alternative, and we can add the post call stuff to the
1064 -- corresponding statement list.
1066 if not Is_List_Member
(N
) then
1068 P
: constant Node_Id
:= Parent
(N
);
1071 pragma Assert
(Nkind
(P
) = N_Triggering_Alternative
1072 or else Nkind
(P
) = N_Entry_Call_Alternative
);
1074 if Is_Non_Empty_List
(Statements
(P
)) then
1075 Insert_List_Before_And_Analyze
1076 (First
(Statements
(P
)), Post_Call
);
1078 Set_Statements
(P
, Post_Call
);
1082 -- Otherwise, normal case where N is in a statement sequence,
1083 -- just put the post-call stuff after the call statement.
1086 Insert_Actions_After
(N
, Post_Call
);
1090 -- The call node itself is re-analyzed in Expand_Call
1098 -- This procedure handles expansion of function calls and procedure call
1099 -- statements (i.e. it serves as the body for Expand_N_Function_Call and
1100 -- Expand_N_Procedure_Call_Statement. Processing for calls includes:
1102 -- Replace call to Raise_Exception by Raise_Exception always if possible
1103 -- Provide values of actuals for all formals in Extra_Formals list
1104 -- Replace "call" to enumeration literal function by literal itself
1105 -- Rewrite call to predefined operator as operator
1106 -- Replace actuals to in-out parameters that are numeric conversions,
1107 -- with explicit assignment to temporaries before and after the call.
1108 -- Remove optional actuals if First_Optional_Parameter specified.
1110 -- Note that the list of actuals has been filled with default expressions
1111 -- during semantic analysis of the call. Only the extra actuals required
1112 -- for the 'Constrained attribute and for accessibility checks are added
1115 procedure Expand_Call
(N
: Node_Id
) is
1116 Loc
: constant Source_Ptr
:= Sloc
(N
);
1117 Remote
: constant Boolean := Is_Remote_Call
(N
);
1119 Orig_Subp
: Entity_Id
:= Empty
;
1120 Parent_Subp
: Entity_Id
;
1121 Parent_Formal
: Entity_Id
;
1124 Prev
: Node_Id
:= Empty
;
1125 Prev_Orig
: Node_Id
;
1127 Extra_Actuals
: List_Id
:= No_List
;
1130 procedure Add_Actual_Parameter
(Insert_Param
: Node_Id
);
1131 -- Adds one entry to the end of the actual parameter list. Used for
1132 -- default parameters and for extra actuals (for Extra_Formals).
1133 -- The argument is an N_Parameter_Association node.
1135 procedure Add_Extra_Actual
(Expr
: Node_Id
; EF
: Entity_Id
);
1136 -- Adds an extra actual to the list of extra actuals. Expr
1137 -- is the expression for the value of the actual, EF is the
1138 -- entity for the extra formal.
1140 function Inherited_From_Formal
(S
: Entity_Id
) return Entity_Id
;
1141 -- Within an instance, a type derived from a non-tagged formal derived
1142 -- type inherits from the original parent, not from the actual. This is
1143 -- tested in 4723-003. The current derivation mechanism has the derived
1144 -- type inherit from the actual, which is only correct outside of the
1145 -- instance. If the subprogram is inherited, we test for this particular
1146 -- case through a convoluted tree traversal before setting the proper
1147 -- subprogram to be called.
1149 --------------------------
1150 -- Add_Actual_Parameter --
1151 --------------------------
1153 procedure Add_Actual_Parameter
(Insert_Param
: Node_Id
) is
1154 Actual_Expr
: constant Node_Id
:=
1155 Explicit_Actual_Parameter
(Insert_Param
);
1158 -- Case of insertion is first named actual
1160 if No
(Prev
) or else
1161 Nkind
(Parent
(Prev
)) /= N_Parameter_Association
1163 Set_Next_Named_Actual
(Insert_Param
, First_Named_Actual
(N
));
1164 Set_First_Named_Actual
(N
, Actual_Expr
);
1167 if not Present
(Parameter_Associations
(N
)) then
1168 Set_Parameter_Associations
(N
, New_List
);
1169 Append
(Insert_Param
, Parameter_Associations
(N
));
1172 Insert_After
(Prev
, Insert_Param
);
1175 -- Case of insertion is not first named actual
1178 Set_Next_Named_Actual
1179 (Insert_Param
, Next_Named_Actual
(Parent
(Prev
)));
1180 Set_Next_Named_Actual
(Parent
(Prev
), Actual_Expr
);
1181 Append
(Insert_Param
, Parameter_Associations
(N
));
1184 Prev
:= Actual_Expr
;
1185 end Add_Actual_Parameter
;
1187 ----------------------
1188 -- Add_Extra_Actual --
1189 ----------------------
1191 procedure Add_Extra_Actual
(Expr
: Node_Id
; EF
: Entity_Id
) is
1192 Loc
: constant Source_Ptr
:= Sloc
(Expr
);
1195 if Extra_Actuals
= No_List
then
1196 Extra_Actuals
:= New_List
;
1197 Set_Parent
(Extra_Actuals
, N
);
1200 Append_To
(Extra_Actuals
,
1201 Make_Parameter_Association
(Loc
,
1202 Explicit_Actual_Parameter
=> Expr
,
1204 Make_Identifier
(Loc
, Chars
(EF
))));
1206 Analyze_And_Resolve
(Expr
, Etype
(EF
));
1207 end Add_Extra_Actual
;
1209 ---------------------------
1210 -- Inherited_From_Formal --
1211 ---------------------------
1213 function Inherited_From_Formal
(S
: Entity_Id
) return Entity_Id
is
1215 Gen_Par
: Entity_Id
;
1216 Gen_Prim
: Elist_Id
;
1221 -- If the operation is inherited, it is attached to the corresponding
1222 -- type derivation. If the parent in the derivation is a generic
1223 -- actual, it is a subtype of the actual, and we have to recover the
1224 -- original derived type declaration to find the proper parent.
1226 if Nkind
(Parent
(S
)) /= N_Full_Type_Declaration
1227 or else not Is_Derived_Type
(Defining_Identifier
(Parent
(S
)))
1228 or else Nkind
(Type_Definition
(Original_Node
(Parent
(S
))))
1229 /= N_Derived_Type_Definition
1230 or else not In_Instance
1237 (Type_Definition
(Original_Node
(Parent
(S
)))));
1239 if Nkind
(Indic
) = N_Subtype_Indication
then
1240 Par
:= Entity
(Subtype_Mark
(Indic
));
1242 Par
:= Entity
(Indic
);
1246 if not Is_Generic_Actual_Type
(Par
)
1247 or else Is_Tagged_Type
(Par
)
1248 or else Nkind
(Parent
(Par
)) /= N_Subtype_Declaration
1249 or else not In_Open_Scopes
(Scope
(Par
))
1254 Gen_Par
:= Generic_Parent_Type
(Parent
(Par
));
1257 -- If the generic parent type is still the generic type, this
1258 -- is a private formal, not a derived formal, and there are no
1259 -- operations inherited from the formal.
1261 if Nkind
(Parent
(Gen_Par
)) = N_Formal_Type_Declaration
then
1265 Gen_Prim
:= Collect_Primitive_Operations
(Gen_Par
);
1266 Elmt
:= First_Elmt
(Gen_Prim
);
1268 while Present
(Elmt
) loop
1269 if Chars
(Node
(Elmt
)) = Chars
(S
) then
1275 F1
:= First_Formal
(S
);
1276 F2
:= First_Formal
(Node
(Elmt
));
1279 and then Present
(F2
)
1282 if Etype
(F1
) = Etype
(F2
)
1283 or else Etype
(F2
) = Gen_Par
1289 exit; -- not the right subprogram
1301 raise Program_Error
;
1302 end Inherited_From_Formal
;
1304 -- Start of processing for Expand_Call
1307 -- Ignore if previous error
1309 if Nkind
(N
) in N_Has_Etype
and then Etype
(N
) = Any_Type
then
1313 -- Call using access to subprogram with explicit dereference
1315 if Nkind
(Name
(N
)) = N_Explicit_Dereference
then
1316 Subp
:= Etype
(Name
(N
));
1317 Parent_Subp
:= Empty
;
1319 -- Case of call to simple entry, where the Name is a selected component
1320 -- whose prefix is the task, and whose selector name is the entry name
1322 elsif Nkind
(Name
(N
)) = N_Selected_Component
then
1323 Subp
:= Entity
(Selector_Name
(Name
(N
)));
1324 Parent_Subp
:= Empty
;
1326 -- Case of call to member of entry family, where Name is an indexed
1327 -- component, with the prefix being a selected component giving the
1328 -- task and entry family name, and the index being the entry index.
1330 elsif Nkind
(Name
(N
)) = N_Indexed_Component
then
1331 Subp
:= Entity
(Selector_Name
(Prefix
(Name
(N
))));
1332 Parent_Subp
:= Empty
;
1337 Subp
:= Entity
(Name
(N
));
1338 Parent_Subp
:= Alias
(Subp
);
1340 -- Replace call to Raise_Exception by call to Raise_Exception_Always
1341 -- if we can tell that the first parameter cannot possibly be null.
1342 -- This helps optimization and also generation of warnings.
1344 if not Restriction_Active
(No_Exception_Handlers
)
1345 and then Is_RTE
(Subp
, RE_Raise_Exception
)
1348 FA
: constant Node_Id
:= Original_Node
(First_Actual
(N
));
1351 -- The case we catch is where the first argument is obtained
1352 -- using the Identity attribute (which must always be non-null)
1354 if Nkind
(FA
) = N_Attribute_Reference
1355 and then Attribute_Name
(FA
) = Name_Identity
1357 Subp
:= RTE
(RE_Raise_Exception_Always
);
1358 Set_Entity
(Name
(N
), Subp
);
1363 if Ekind
(Subp
) = E_Entry
then
1364 Parent_Subp
:= Empty
;
1368 -- First step, compute extra actuals, corresponding to any
1369 -- Extra_Formals present. Note that we do not access Extra_Formals
1370 -- directly, instead we simply note the presence of the extra
1371 -- formals as we process the regular formals and collect the
1372 -- corresponding actuals in Extra_Actuals.
1374 -- We also generate any required range checks for actuals as we go
1375 -- through the loop, since this is a convenient place to do this.
1377 Formal
:= First_Formal
(Subp
);
1378 Actual
:= First_Actual
(N
);
1379 while Present
(Formal
) loop
1381 -- Generate range check if required (not activated yet ???)
1383 -- if Do_Range_Check (Actual) then
1384 -- Set_Do_Range_Check (Actual, False);
1385 -- Generate_Range_Check
1386 -- (Actual, Etype (Formal), CE_Range_Check_Failed);
1389 -- Prepare to examine current entry
1392 Prev_Orig
:= Original_Node
(Prev
);
1394 -- Create possible extra actual for constrained case. Usually,
1395 -- the extra actual is of the form actual'constrained, but since
1396 -- this attribute is only available for unconstrained records,
1397 -- TRUE is expanded if the type of the formal happens to be
1398 -- constrained (for instance when this procedure is inherited
1399 -- from an unconstrained record to a constrained one) or if the
1400 -- actual has no discriminant (its type is constrained). An
1401 -- exception to this is the case of a private type without
1402 -- discriminants. In this case we pass FALSE because the
1403 -- object has underlying discriminants with defaults.
1405 if Present
(Extra_Constrained
(Formal
)) then
1406 if Ekind
(Etype
(Prev
)) in Private_Kind
1407 and then not Has_Discriminants
(Base_Type
(Etype
(Prev
)))
1410 New_Occurrence_Of
(Standard_False
, Loc
),
1411 Extra_Constrained
(Formal
));
1413 elsif Is_Constrained
(Etype
(Formal
))
1414 or else not Has_Discriminants
(Etype
(Prev
))
1417 New_Occurrence_Of
(Standard_True
, Loc
),
1418 Extra_Constrained
(Formal
));
1420 -- Do not produce extra actuals for Unchecked_Union parameters.
1421 -- Jump directly to the end of the loop.
1423 elsif Is_Unchecked_Union
(Base_Type
(Etype
(Actual
))) then
1424 goto Skip_Extra_Actual_Generation
;
1427 -- If the actual is a type conversion, then the constrained
1428 -- test applies to the actual, not the target type.
1431 Act_Prev
: Node_Id
:= Prev
;
1434 -- Test for unchecked conversions as well, which can
1435 -- occur as out parameter actuals on calls to stream
1438 while Nkind
(Act_Prev
) = N_Type_Conversion
1439 or else Nkind
(Act_Prev
) = N_Unchecked_Type_Conversion
1441 Act_Prev
:= Expression
(Act_Prev
);
1445 Make_Attribute_Reference
(Sloc
(Prev
),
1447 Duplicate_Subexpr_No_Checks
1448 (Act_Prev
, Name_Req
=> True),
1449 Attribute_Name
=> Name_Constrained
),
1450 Extra_Constrained
(Formal
));
1455 -- Create possible extra actual for accessibility level
1457 if Present
(Extra_Accessibility
(Formal
)) then
1458 if Is_Entity_Name
(Prev_Orig
) then
1460 -- When passing an access parameter as the actual to another
1461 -- access parameter we need to pass along the actual's own
1462 -- associated access level parameter. This is done if we are
1463 -- in the scope of the formal access parameter (if this is an
1464 -- inlined body the extra formal is irrelevant).
1466 if Ekind
(Entity
(Prev_Orig
)) in Formal_Kind
1467 and then Ekind
(Etype
(Prev_Orig
)) = E_Anonymous_Access_Type
1468 and then In_Open_Scopes
(Scope
(Entity
(Prev_Orig
)))
1471 Parm_Ent
: constant Entity_Id
:= Param_Entity
(Prev_Orig
);
1474 pragma Assert
(Present
(Parm_Ent
));
1476 if Present
(Extra_Accessibility
(Parm_Ent
)) then
1479 (Extra_Accessibility
(Parm_Ent
), Loc
),
1480 Extra_Accessibility
(Formal
));
1482 -- If the actual access parameter does not have an
1483 -- associated extra formal providing its scope level,
1484 -- then treat the actual as having library-level
1489 Make_Integer_Literal
(Loc
,
1490 Intval
=> Scope_Depth
(Standard_Standard
)),
1491 Extra_Accessibility
(Formal
));
1495 -- The actual is a normal access value, so just pass the
1496 -- level of the actual's access type.
1500 Make_Integer_Literal
(Loc
,
1501 Intval
=> Type_Access_Level
(Etype
(Prev_Orig
))),
1502 Extra_Accessibility
(Formal
));
1506 case Nkind
(Prev_Orig
) is
1508 when N_Attribute_Reference
=>
1510 case Get_Attribute_Id
(Attribute_Name
(Prev_Orig
)) is
1512 -- For X'Access, pass on the level of the prefix X
1514 when Attribute_Access
=>
1516 Make_Integer_Literal
(Loc
,
1518 Object_Access_Level
(Prefix
(Prev_Orig
))),
1519 Extra_Accessibility
(Formal
));
1521 -- Treat the unchecked attributes as library-level
1523 when Attribute_Unchecked_Access |
1524 Attribute_Unrestricted_Access
=>
1526 Make_Integer_Literal
(Loc
,
1527 Intval
=> Scope_Depth
(Standard_Standard
)),
1528 Extra_Accessibility
(Formal
));
1530 -- No other cases of attributes returning access
1531 -- values that can be passed to access parameters
1534 raise Program_Error
;
1538 -- For allocators we pass the level of the execution of
1539 -- the called subprogram, which is one greater than the
1540 -- current scope level.
1544 Make_Integer_Literal
(Loc
,
1545 Scope_Depth
(Current_Scope
) + 1),
1546 Extra_Accessibility
(Formal
));
1548 -- For other cases we simply pass the level of the
1549 -- actual's access type.
1553 Make_Integer_Literal
(Loc
,
1554 Intval
=> Type_Access_Level
(Etype
(Prev_Orig
))),
1555 Extra_Accessibility
(Formal
));
1561 -- Perform the check of 4.6(49) that prevents a null value
1562 -- from being passed as an actual to an access parameter.
1563 -- Note that the check is elided in the common cases of
1564 -- passing an access attribute or access parameter as an
1565 -- actual. Also, we currently don't enforce this check for
1566 -- expander-generated actuals and when -gnatdj is set.
1568 if Ekind
(Etype
(Formal
)) /= E_Anonymous_Access_Type
1569 or else Access_Checks_Suppressed
(Subp
)
1573 elsif Debug_Flag_J
then
1576 elsif not Comes_From_Source
(Prev
) then
1579 elsif Is_Entity_Name
(Prev
)
1580 and then Ekind
(Etype
(Prev
)) = E_Anonymous_Access_Type
1584 elsif Nkind
(Prev
) = N_Allocator
1585 or else Nkind
(Prev
) = N_Attribute_Reference
1589 -- Suppress null checks when passing to access parameters
1590 -- of Java subprograms. (Should this be done for other
1591 -- foreign conventions as well ???)
1593 elsif Convention
(Subp
) = Convention_Java
then
1596 -- Ada 2005 (AI-231): do not force the check in case of Ada 2005
1597 -- unless it is a null-excluding type
1599 elsif Ada_Version
< Ada_05
1600 or else Can_Never_Be_Null
(Etype
(Prev
))
1604 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Prev
),
1605 Right_Opnd
=> Make_Null
(Loc
));
1606 Insert_Action
(Prev
,
1607 Make_Raise_Constraint_Error
(Loc
,
1609 Reason
=> CE_Access_Parameter_Is_Null
));
1612 -- Perform appropriate validity checks on parameters that
1615 if Validity_Checks_On
then
1616 if (Ekind
(Formal
) = E_In_Parameter
1617 and then Validity_Check_In_Params
)
1619 (Ekind
(Formal
) = E_In_Out_Parameter
1620 and then Validity_Check_In_Out_Params
)
1622 -- If the actual is an indexed component of a packed
1623 -- type, it has not been expanded yet. It will be
1624 -- copied in the validity code that follows, and has
1625 -- to be expanded appropriately, so reanalyze it.
1627 if Nkind
(Actual
) = N_Indexed_Component
then
1628 Set_Analyzed
(Actual
, False);
1631 Ensure_Valid
(Actual
);
1635 -- For IN OUT and OUT parameters, ensure that subscripts are valid
1636 -- since this is a left side reference. We only do this for calls
1637 -- from the source program since we assume that compiler generated
1638 -- calls explicitly generate any required checks. We also need it
1639 -- only if we are doing standard validity checks, since clearly it
1640 -- is not needed if validity checks are off, and in subscript
1641 -- validity checking mode, all indexed components are checked with
1642 -- a call directly from Expand_N_Indexed_Component.
1644 if Comes_From_Source
(N
)
1645 and then Ekind
(Formal
) /= E_In_Parameter
1646 and then Validity_Checks_On
1647 and then Validity_Check_Default
1648 and then not Validity_Check_Subscripts
1650 Check_Valid_Lvalue_Subscripts
(Actual
);
1653 -- Mark any scalar OUT parameter that is a simple variable
1654 -- as no longer known to be valid (unless the type is always
1655 -- valid). This reflects the fact that if an OUT parameter
1656 -- is never set in a procedure, then it can become invalid
1657 -- on return from the procedure.
1659 if Ekind
(Formal
) = E_Out_Parameter
1660 and then Is_Entity_Name
(Actual
)
1661 and then Ekind
(Entity
(Actual
)) = E_Variable
1662 and then not Is_Known_Valid
(Etype
(Actual
))
1664 Set_Is_Known_Valid
(Entity
(Actual
), False);
1667 -- For an OUT or IN OUT parameter of an access type, if the
1668 -- actual is an entity, then it is no longer known to be non-null.
1670 if Ekind
(Formal
) /= E_In_Parameter
1671 and then Is_Entity_Name
(Actual
)
1672 and then Is_Access_Type
(Etype
(Actual
))
1674 Set_Is_Known_Non_Null
(Entity
(Actual
), False);
1677 -- If the formal is class wide and the actual is an aggregate, force
1678 -- evaluation so that the back end who does not know about class-wide
1679 -- type, does not generate a temporary of the wrong size.
1681 if not Is_Class_Wide_Type
(Etype
(Formal
)) then
1684 elsif Nkind
(Actual
) = N_Aggregate
1685 or else (Nkind
(Actual
) = N_Qualified_Expression
1686 and then Nkind
(Expression
(Actual
)) = N_Aggregate
)
1688 Force_Evaluation
(Actual
);
1691 -- In a remote call, if the formal is of a class-wide type, check
1692 -- that the actual meets the requirements described in E.4(18).
1695 and then Is_Class_Wide_Type
(Etype
(Formal
))
1697 Insert_Action
(Actual
,
1698 Make_Implicit_If_Statement
(N
,
1701 Get_Remotely_Callable
1702 (Duplicate_Subexpr_Move_Checks
(Actual
))),
1703 Then_Statements
=> New_List
(
1704 Make_Raise_Program_Error
(Loc
,
1705 Reason
=> PE_Illegal_RACW_E_4_18
))));
1708 -- This label is required when skipping extra actual generation for
1709 -- Unchecked_Union parameters.
1711 <<Skip_Extra_Actual_Generation
>>
1713 Next_Actual
(Actual
);
1714 Next_Formal
(Formal
);
1717 -- If we are expanding a rhs of an assignement we need to check if
1718 -- tag propagation is needed. This code belongs theorically in Analyze
1719 -- Assignment but has to be done earlier (bottom-up) because the
1720 -- assignment might be transformed into a declaration for an uncons-
1721 -- trained value, if the expression is classwide.
1723 if Nkind
(N
) = N_Function_Call
1724 and then Is_Tag_Indeterminate
(N
)
1725 and then Is_Entity_Name
(Name
(N
))
1728 Ass
: Node_Id
:= Empty
;
1731 if Nkind
(Parent
(N
)) = N_Assignment_Statement
then
1734 elsif Nkind
(Parent
(N
)) = N_Qualified_Expression
1735 and then Nkind
(Parent
(Parent
(N
))) = N_Assignment_Statement
1737 Ass
:= Parent
(Parent
(N
));
1741 and then Is_Class_Wide_Type
(Etype
(Name
(Ass
)))
1743 if Etype
(N
) /= Root_Type
(Etype
(Name
(Ass
))) then
1745 ("tag-indeterminate expression must have type&"
1746 & "('R'M 5.2 (6))", N
, Root_Type
(Etype
(Name
(Ass
))));
1748 Propagate_Tag
(Name
(Ass
), N
);
1751 -- The call will be rewritten as a dispatching call, and
1752 -- expanded as such.
1759 -- Deals with Dispatch_Call if we still have a call, before expanding
1760 -- extra actuals since this will be done on the re-analysis of the
1761 -- dispatching call. Note that we do not try to shorten the actual
1762 -- list for a dispatching call, it would not make sense to do so.
1763 -- Expansion of dispatching calls is suppressed when Java_VM, because
1764 -- the JVM back end directly handles the generation of dispatching
1765 -- calls and would have to undo any expansion to an indirect call.
1767 if (Nkind
(N
) = N_Function_Call
1768 or else Nkind
(N
) = N_Procedure_Call_Statement
)
1769 and then Present
(Controlling_Argument
(N
))
1770 and then not Java_VM
1772 Expand_Dispatching_Call
(N
);
1774 -- The following return is worrisome. Is it really OK to
1775 -- skip all remaining processing in this procedure ???
1779 -- Similarly, expand calls to RCI subprograms on which pragma
1780 -- All_Calls_Remote applies. The rewriting will be reanalyzed
1781 -- later. Do this only when the call comes from source since we do
1782 -- not want such a rewritting to occur in expanded code.
1784 elsif Is_All_Remote_Call
(N
) then
1785 Expand_All_Calls_Remote_Subprogram_Call
(N
);
1787 -- Similarly, do not add extra actuals for an entry call whose entity
1788 -- is a protected procedure, or for an internal protected subprogram
1789 -- call, because it will be rewritten as a protected subprogram call
1790 -- and reanalyzed (see Expand_Protected_Subprogram_Call).
1792 elsif Is_Protected_Type
(Scope
(Subp
))
1793 and then (Ekind
(Subp
) = E_Procedure
1794 or else Ekind
(Subp
) = E_Function
)
1798 -- During that loop we gathered the extra actuals (the ones that
1799 -- correspond to Extra_Formals), so now they can be appended.
1802 while Is_Non_Empty_List
(Extra_Actuals
) loop
1803 Add_Actual_Parameter
(Remove_Head
(Extra_Actuals
));
1807 -- At this point we have all the actuals, so this is the point at
1808 -- which the various expansion activities for actuals is carried out.
1810 Expand_Actuals
(N
, Subp
);
1812 -- If the subprogram is a renaming, or if it is inherited, replace it
1813 -- in the call with the name of the actual subprogram being called.
1814 -- If this is a dispatching call, the run-time decides what to call.
1815 -- The Alias attribute does not apply to entries.
1817 if Nkind
(N
) /= N_Entry_Call_Statement
1818 and then No
(Controlling_Argument
(N
))
1819 and then Present
(Parent_Subp
)
1821 if Present
(Inherited_From_Formal
(Subp
)) then
1822 Parent_Subp
:= Inherited_From_Formal
(Subp
);
1824 while Present
(Alias
(Parent_Subp
)) loop
1825 Parent_Subp
:= Alias
(Parent_Subp
);
1829 Set_Entity
(Name
(N
), Parent_Subp
);
1831 if Is_Abstract
(Parent_Subp
)
1832 and then not In_Instance
1835 ("cannot call abstract subprogram &!", Name
(N
), Parent_Subp
);
1838 -- Add an explicit conversion for parameter of the derived type.
1839 -- This is only done for scalar and access in-parameters. Others
1840 -- have been expanded in expand_actuals.
1842 Formal
:= First_Formal
(Subp
);
1843 Parent_Formal
:= First_Formal
(Parent_Subp
);
1844 Actual
:= First_Actual
(N
);
1846 -- It is not clear that conversion is needed for intrinsic
1847 -- subprograms, but it certainly is for those that are user-
1848 -- defined, and that can be inherited on derivation, namely
1849 -- unchecked conversion and deallocation.
1850 -- General case needs study ???
1852 if not Is_Intrinsic_Subprogram
(Parent_Subp
)
1853 or else Is_Generic_Instance
(Parent_Subp
)
1855 while Present
(Formal
) loop
1857 if Etype
(Formal
) /= Etype
(Parent_Formal
)
1858 and then Is_Scalar_Type
(Etype
(Formal
))
1859 and then Ekind
(Formal
) = E_In_Parameter
1860 and then not Raises_Constraint_Error
(Actual
)
1863 OK_Convert_To
(Etype
(Parent_Formal
),
1864 Relocate_Node
(Actual
)));
1867 Resolve
(Actual
, Etype
(Parent_Formal
));
1868 Enable_Range_Check
(Actual
);
1870 elsif Is_Access_Type
(Etype
(Formal
))
1871 and then Base_Type
(Etype
(Parent_Formal
))
1872 /= Base_Type
(Etype
(Actual
))
1874 if Ekind
(Formal
) /= E_In_Parameter
then
1876 Convert_To
(Etype
(Parent_Formal
),
1877 Relocate_Node
(Actual
)));
1880 Resolve
(Actual
, Etype
(Parent_Formal
));
1883 Ekind
(Etype
(Parent_Formal
)) = E_Anonymous_Access_Type
1884 and then Designated_Type
(Etype
(Parent_Formal
))
1886 Designated_Type
(Etype
(Actual
))
1887 and then not Is_Controlling_Formal
(Formal
)
1889 -- This unchecked conversion is not necessary unless
1890 -- inlining is enabled, because in that case the type
1891 -- mismatch may become visible in the body about to be
1895 Unchecked_Convert_To
(Etype
(Parent_Formal
),
1896 Relocate_Node
(Actual
)));
1899 Resolve
(Actual
, Etype
(Parent_Formal
));
1903 Next_Formal
(Formal
);
1904 Next_Formal
(Parent_Formal
);
1905 Next_Actual
(Actual
);
1910 Subp
:= Parent_Subp
;
1913 -- Check for violation of No_Abort_Statements
1915 if Is_RTE
(Subp
, RE_Abort_Task
) then
1916 Check_Restriction
(No_Abort_Statements
, N
);
1918 -- Check for violation of No_Dynamic_Attachment
1920 elsif RTU_Loaded
(Ada_Interrupts
)
1921 and then (Is_RTE
(Subp
, RE_Is_Reserved
) or else
1922 Is_RTE
(Subp
, RE_Is_Attached
) or else
1923 Is_RTE
(Subp
, RE_Current_Handler
) or else
1924 Is_RTE
(Subp
, RE_Attach_Handler
) or else
1925 Is_RTE
(Subp
, RE_Exchange_Handler
) or else
1926 Is_RTE
(Subp
, RE_Detach_Handler
) or else
1927 Is_RTE
(Subp
, RE_Reference
))
1929 Check_Restriction
(No_Dynamic_Attachment
, N
);
1932 -- Deal with case where call is an explicit dereference
1934 if Nkind
(Name
(N
)) = N_Explicit_Dereference
then
1936 -- Handle case of access to protected subprogram type
1938 if Ekind
(Base_Type
(Etype
(Prefix
(Name
(N
))))) =
1939 E_Access_Protected_Subprogram_Type
1941 -- If this is a call through an access to protected operation,
1942 -- the prefix has the form (object'address, operation'access).
1943 -- Rewrite as a for other protected calls: the object is the
1944 -- first parameter of the list of actuals.
1951 Ptr
: constant Node_Id
:= Prefix
(Name
(N
));
1953 T
: constant Entity_Id
:=
1954 Equivalent_Type
(Base_Type
(Etype
(Ptr
)));
1956 D_T
: constant Entity_Id
:=
1957 Designated_Type
(Base_Type
(Etype
(Ptr
)));
1961 Make_Selected_Component
(Loc
,
1962 Prefix
=> Unchecked_Convert_To
(T
, Ptr
),
1964 New_Occurrence_Of
(First_Entity
(T
), Loc
));
1967 Make_Selected_Component
(Loc
,
1968 Prefix
=> Unchecked_Convert_To
(T
, Ptr
),
1970 New_Occurrence_Of
(Next_Entity
(First_Entity
(T
)), Loc
));
1972 Nam
:= Make_Explicit_Dereference
(Loc
, Nam
);
1974 if Present
(Parameter_Associations
(N
)) then
1975 Parm
:= Parameter_Associations
(N
);
1980 Prepend
(Obj
, Parm
);
1982 if Etype
(D_T
) = Standard_Void_Type
then
1983 Call
:= Make_Procedure_Call_Statement
(Loc
,
1985 Parameter_Associations
=> Parm
);
1987 Call
:= Make_Function_Call
(Loc
,
1989 Parameter_Associations
=> Parm
);
1992 Set_First_Named_Actual
(Call
, First_Named_Actual
(N
));
1993 Set_Etype
(Call
, Etype
(D_T
));
1995 -- We do not re-analyze the call to avoid infinite recursion.
1996 -- We analyze separately the prefix and the object, and set
1997 -- the checks on the prefix that would otherwise be emitted
1998 -- when resolving a call.
2002 Apply_Access_Check
(Nam
);
2009 -- If this is a call to an intrinsic subprogram, then perform the
2010 -- appropriate expansion to the corresponding tree node and we
2011 -- are all done (since after that the call is gone!)
2013 -- In the case where the intrinsic is to be processed by the back end,
2014 -- the call to Expand_Intrinsic_Call will do nothing, which is fine,
2015 -- since the idea in this case is to pass the call unchanged.
2017 if Is_Intrinsic_Subprogram
(Subp
) then
2018 Expand_Intrinsic_Call
(N
, Subp
);
2022 if Ekind
(Subp
) = E_Function
2023 or else Ekind
(Subp
) = E_Procedure
2025 if Is_Inlined
(Subp
) then
2027 Inlined_Subprogram
: declare
2029 Must_Inline
: Boolean := False;
2030 Spec
: constant Node_Id
:= Unit_Declaration_Node
(Subp
);
2031 Scop
: constant Entity_Id
:= Scope
(Subp
);
2033 function In_Unfrozen_Instance
return Boolean;
2034 -- If the subprogram comes from an instance in the same
2035 -- unit, and the instance is not yet frozen, inlining might
2036 -- trigger order-of-elaboration problems in gigi.
2038 --------------------------
2039 -- In_Unfrozen_Instance --
2040 --------------------------
2042 function In_Unfrozen_Instance
return Boolean is
2043 S
: Entity_Id
:= Scop
;
2047 and then S
/= Standard_Standard
2049 if Is_Generic_Instance
(S
)
2050 and then Present
(Freeze_Node
(S
))
2051 and then not Analyzed
(Freeze_Node
(S
))
2060 end In_Unfrozen_Instance
;
2062 -- Start of processing for Inlined_Subprogram
2065 -- Verify that the body to inline has already been seen,
2066 -- and that if the body is in the current unit the inlining
2067 -- does not occur earlier. This avoids order-of-elaboration
2068 -- problems in gigi.
2071 or else Nkind
(Spec
) /= N_Subprogram_Declaration
2072 or else No
(Body_To_Inline
(Spec
))
2074 Must_Inline
:= False;
2076 -- If this an inherited function that returns a private
2077 -- type, do not inline if the full view is an unconstrained
2078 -- array, because such calls cannot be inlined.
2080 elsif Present
(Orig_Subp
)
2081 and then Is_Array_Type
(Etype
(Orig_Subp
))
2082 and then not Is_Constrained
(Etype
(Orig_Subp
))
2084 Must_Inline
:= False;
2086 elsif In_Unfrozen_Instance
then
2087 Must_Inline
:= False;
2090 Bod
:= Body_To_Inline
(Spec
);
2092 if (In_Extended_Main_Code_Unit
(N
)
2093 or else In_Extended_Main_Code_Unit
(Parent
(N
))
2094 or else Is_Always_Inlined
(Subp
))
2095 and then (not In_Same_Extended_Unit
(Sloc
(Bod
), Loc
)
2097 Earlier_In_Extended_Unit
(Sloc
(Bod
), Loc
))
2099 Must_Inline
:= True;
2101 -- If we are compiling a package body that is not the main
2102 -- unit, it must be for inlining/instantiation purposes,
2103 -- in which case we inline the call to insure that the same
2104 -- temporaries are generated when compiling the body by
2105 -- itself. Otherwise link errors can occur.
2107 -- If the function being called is itself in the main unit,
2108 -- we cannot inline, because there is a risk of double
2109 -- elaboration and/or circularity: the inlining can make
2110 -- visible a private entity in the body of the main unit,
2111 -- that gigi will see before its sees its proper definition.
2113 elsif not (In_Extended_Main_Code_Unit
(N
))
2114 and then In_Package_Body
2116 Must_Inline
:= not In_Extended_Main_Source_Unit
(Subp
);
2121 Expand_Inlined_Call
(N
, Subp
, Orig_Subp
);
2124 -- Let the back end handle it
2126 Add_Inlined_Body
(Subp
);
2128 if Front_End_Inlining
2129 and then Nkind
(Spec
) = N_Subprogram_Declaration
2130 and then (In_Extended_Main_Code_Unit
(N
))
2131 and then No
(Body_To_Inline
(Spec
))
2132 and then not Has_Completion
(Subp
)
2133 and then In_Same_Extended_Unit
(Sloc
(Spec
), Loc
)
2136 ("cannot inline& (body not seen yet)?",
2140 end Inlined_Subprogram
;
2144 -- Check for a protected subprogram. This is either an intra-object
2145 -- call, or a protected function call. Protected procedure calls are
2146 -- rewritten as entry calls and handled accordingly.
2148 Scop
:= Scope
(Subp
);
2150 if Nkind
(N
) /= N_Entry_Call_Statement
2151 and then Is_Protected_Type
(Scop
)
2153 -- If the call is an internal one, it is rewritten as a call to
2154 -- to the corresponding unprotected subprogram.
2156 Expand_Protected_Subprogram_Call
(N
, Subp
, Scop
);
2159 -- Functions returning controlled objects need special attention
2161 if Controlled_Type
(Etype
(Subp
))
2162 and then not Is_Return_By_Reference_Type
(Etype
(Subp
))
2164 Expand_Ctrl_Function_Call
(N
);
2167 -- Test for First_Optional_Parameter, and if so, truncate parameter
2168 -- list if there are optional parameters at the trailing end.
2169 -- Note we never delete procedures for call via a pointer.
2171 if (Ekind
(Subp
) = E_Procedure
or else Ekind
(Subp
) = E_Function
)
2172 and then Present
(First_Optional_Parameter
(Subp
))
2175 Last_Keep_Arg
: Node_Id
;
2178 -- Last_Keep_Arg will hold the last actual that should be
2179 -- retained. If it remains empty at the end, it means that
2180 -- all parameters are optional.
2182 Last_Keep_Arg
:= Empty
;
2184 -- Find first optional parameter, must be present since we
2185 -- checked the validity of the parameter before setting it.
2187 Formal
:= First_Formal
(Subp
);
2188 Actual
:= First_Actual
(N
);
2189 while Formal
/= First_Optional_Parameter
(Subp
) loop
2190 Last_Keep_Arg
:= Actual
;
2191 Next_Formal
(Formal
);
2192 Next_Actual
(Actual
);
2195 -- We have Formal and Actual pointing to the first potentially
2196 -- droppable argument. We can drop all the trailing arguments
2197 -- whose actual matches the default. Note that we know that all
2198 -- remaining formals have defaults, because we checked that this
2199 -- requirement was met before setting First_Optional_Parameter.
2201 -- We use Fully_Conformant_Expressions to check for identity
2202 -- between formals and actuals, which may miss some cases, but
2203 -- on the other hand, this is only an optimization (if we fail
2204 -- to truncate a parameter it does not affect functionality).
2205 -- So if the default is 3 and the actual is 1+2, we consider
2206 -- them unequal, which hardly seems worrisome.
2208 while Present
(Formal
) loop
2209 if not Fully_Conformant_Expressions
2210 (Actual
, Default_Value
(Formal
))
2212 Last_Keep_Arg
:= Actual
;
2215 Next_Formal
(Formal
);
2216 Next_Actual
(Actual
);
2219 -- If no arguments, delete entire list, this is the easy case
2221 if No
(Last_Keep_Arg
) then
2222 while Is_Non_Empty_List
(Parameter_Associations
(N
)) loop
2223 Delete_Tree
(Remove_Head
(Parameter_Associations
(N
)));
2226 Set_Parameter_Associations
(N
, No_List
);
2227 Set_First_Named_Actual
(N
, Empty
);
2229 -- Case where at the last retained argument is positional. This
2230 -- is also an easy case, since the retained arguments are already
2231 -- in the right form, and we don't need to worry about the order
2232 -- of arguments that get eliminated.
2234 elsif Is_List_Member
(Last_Keep_Arg
) then
2235 while Present
(Next
(Last_Keep_Arg
)) loop
2236 Delete_Tree
(Remove_Next
(Last_Keep_Arg
));
2239 Set_First_Named_Actual
(N
, Empty
);
2241 -- This is the annoying case where the last retained argument
2242 -- is a named parameter. Since the original arguments are not
2243 -- in declaration order, we may have to delete some fairly
2244 -- random collection of arguments.
2252 pragma Warnings
(Off
, Discard
);
2255 -- First step, remove all the named parameters from the
2256 -- list (they are still chained using First_Named_Actual
2257 -- and Next_Named_Actual, so we have not lost them!)
2259 Temp
:= First
(Parameter_Associations
(N
));
2261 -- Case of all parameters named, remove them all
2263 if Nkind
(Temp
) = N_Parameter_Association
then
2264 while Is_Non_Empty_List
(Parameter_Associations
(N
)) loop
2265 Temp
:= Remove_Head
(Parameter_Associations
(N
));
2268 -- Case of mixed positional/named, remove named parameters
2271 while Nkind
(Next
(Temp
)) /= N_Parameter_Association
loop
2275 while Present
(Next
(Temp
)) loop
2276 Discard
:= Remove_Next
(Temp
);
2280 -- Now we loop through the named parameters, till we get
2281 -- to the last one to be retained, adding them to the list.
2282 -- Note that the Next_Named_Actual list does not need to be
2283 -- touched since we are only reordering them on the actual
2284 -- parameter association list.
2286 Passoc
:= Parent
(First_Named_Actual
(N
));
2288 Temp
:= Relocate_Node
(Passoc
);
2290 (Parameter_Associations
(N
), Temp
);
2292 Last_Keep_Arg
= Explicit_Actual_Parameter
(Passoc
);
2293 Passoc
:= Parent
(Next_Named_Actual
(Passoc
));
2296 Set_Next_Named_Actual
(Temp
, Empty
);
2299 Temp
:= Next_Named_Actual
(Passoc
);
2300 exit when No
(Temp
);
2301 Set_Next_Named_Actual
2302 (Passoc
, Next_Named_Actual
(Parent
(Temp
)));
2311 --------------------------
2312 -- Expand_Inlined_Call --
2313 --------------------------
2315 procedure Expand_Inlined_Call
2318 Orig_Subp
: Entity_Id
)
2320 Loc
: constant Source_Ptr
:= Sloc
(N
);
2321 Is_Predef
: constant Boolean :=
2322 Is_Predefined_File_Name
2323 (Unit_File_Name
(Get_Source_Unit
(Subp
)));
2324 Orig_Bod
: constant Node_Id
:=
2325 Body_To_Inline
(Unit_Declaration_Node
(Subp
));
2330 Exit_Lab
: Entity_Id
:= Empty
;
2337 Ret_Type
: Entity_Id
;
2340 Temp_Typ
: Entity_Id
;
2342 procedure Make_Exit_Label
;
2343 -- Build declaration for exit label to be used in Return statements
2345 function Process_Formals
(N
: Node_Id
) return Traverse_Result
;
2346 -- Replace occurrence of a formal with the corresponding actual, or
2347 -- the thunk generated for it.
2349 function Process_Sloc
(Nod
: Node_Id
) return Traverse_Result
;
2350 -- If the call being expanded is that of an internal subprogram,
2351 -- set the sloc of the generated block to that of the call itself,
2352 -- so that the expansion is skipped by the -next- command in gdb.
2353 -- Same processing for a subprogram in a predefined file, e.g.
2354 -- Ada.Tags. If Debug_Generated_Code is true, suppress this change
2355 -- to simplify our own development.
2357 procedure Rewrite_Function_Call
(N
: Node_Id
; Blk
: Node_Id
);
2358 -- If the function body is a single expression, replace call with
2359 -- expression, else insert block appropriately.
2361 procedure Rewrite_Procedure_Call
(N
: Node_Id
; Blk
: Node_Id
);
2362 -- If procedure body has no local variables, inline body without
2363 -- creating block, otherwise rewrite call with block.
2365 function Formal_Is_Used_Once
(Formal
: Entity_Id
) return Boolean;
2366 -- Determine whether a formal parameter is used only once in Orig_Bod
2368 ---------------------
2369 -- Make_Exit_Label --
2370 ---------------------
2372 procedure Make_Exit_Label
is
2374 -- Create exit label for subprogram if one does not exist yet
2376 if No
(Exit_Lab
) then
2377 Lab_Id
:= Make_Identifier
(Loc
, New_Internal_Name
('L'));
2379 Make_Defining_Identifier
(Loc
, Chars
(Lab_Id
)));
2380 Exit_Lab
:= Make_Label
(Loc
, Lab_Id
);
2383 Make_Implicit_Label_Declaration
(Loc
,
2384 Defining_Identifier
=> Entity
(Lab_Id
),
2385 Label_Construct
=> Exit_Lab
);
2387 end Make_Exit_Label
;
2389 ---------------------
2390 -- Process_Formals --
2391 ---------------------
2393 function Process_Formals
(N
: Node_Id
) return Traverse_Result
is
2399 if Is_Entity_Name
(N
)
2400 and then Present
(Entity
(N
))
2405 and then Scope
(E
) = Subp
2407 A
:= Renamed_Object
(E
);
2409 if Is_Entity_Name
(A
) then
2410 Rewrite
(N
, New_Occurrence_Of
(Entity
(A
), Loc
));
2412 elsif Nkind
(A
) = N_Defining_Identifier
then
2413 Rewrite
(N
, New_Occurrence_Of
(A
, Loc
));
2415 else -- numeric literal
2416 Rewrite
(N
, New_Copy
(A
));
2422 elsif Nkind
(N
) = N_Return_Statement
then
2424 if No
(Expression
(N
)) then
2426 Rewrite
(N
, Make_Goto_Statement
(Loc
,
2427 Name
=> New_Copy
(Lab_Id
)));
2430 if Nkind
(Parent
(N
)) = N_Handled_Sequence_Of_Statements
2431 and then Nkind
(Parent
(Parent
(N
))) = N_Subprogram_Body
2433 -- Function body is a single expression. No need for
2439 Num_Ret
:= Num_Ret
+ 1;
2443 -- Because of the presence of private types, the views of the
2444 -- expression and the context may be different, so place an
2445 -- unchecked conversion to the context type to avoid spurious
2446 -- errors, eg. when the expression is a numeric literal and
2447 -- the context is private. If the expression is an aggregate,
2448 -- use a qualified expression, because an aggregate is not a
2449 -- legal argument of a conversion.
2451 if Nkind
(Expression
(N
)) = N_Aggregate
2452 or else Nkind
(Expression
(N
)) = N_Null
2455 Make_Qualified_Expression
(Sloc
(N
),
2456 Subtype_Mark
=> New_Occurrence_Of
(Ret_Type
, Sloc
(N
)),
2457 Expression
=> Relocate_Node
(Expression
(N
)));
2460 Unchecked_Convert_To
2461 (Ret_Type
, Relocate_Node
(Expression
(N
)));
2464 if Nkind
(Targ
) = N_Defining_Identifier
then
2466 Make_Assignment_Statement
(Loc
,
2467 Name
=> New_Occurrence_Of
(Targ
, Loc
),
2468 Expression
=> Ret
));
2471 Make_Assignment_Statement
(Loc
,
2472 Name
=> New_Copy
(Targ
),
2473 Expression
=> Ret
));
2476 Set_Assignment_OK
(Name
(N
));
2478 if Present
(Exit_Lab
) then
2480 Make_Goto_Statement
(Loc
,
2481 Name
=> New_Copy
(Lab_Id
)));
2487 -- Remove pragma Unreferenced since it may refer to formals that
2488 -- are not visible in the inlined body, and in any case we will
2489 -- not be posting warnings on the inlined body so it is unneeded.
2491 elsif Nkind
(N
) = N_Pragma
2492 and then Chars
(N
) = Name_Unreferenced
2494 Rewrite
(N
, Make_Null_Statement
(Sloc
(N
)));
2500 end Process_Formals
;
2502 procedure Replace_Formals
is new Traverse_Proc
(Process_Formals
);
2508 function Process_Sloc
(Nod
: Node_Id
) return Traverse_Result
is
2510 if not Debug_Generated_Code
then
2511 Set_Sloc
(Nod
, Sloc
(N
));
2512 Set_Comes_From_Source
(Nod
, False);
2518 procedure Reset_Slocs
is new Traverse_Proc
(Process_Sloc
);
2520 ---------------------------
2521 -- Rewrite_Function_Call --
2522 ---------------------------
2524 procedure Rewrite_Function_Call
(N
: Node_Id
; Blk
: Node_Id
) is
2525 HSS
: constant Node_Id
:= Handled_Statement_Sequence
(Blk
);
2526 Fst
: constant Node_Id
:= First
(Statements
(HSS
));
2529 -- Optimize simple case: function body is a single return statement,
2530 -- which has been expanded into an assignment.
2532 if Is_Empty_List
(Declarations
(Blk
))
2533 and then Nkind
(Fst
) = N_Assignment_Statement
2534 and then No
(Next
(Fst
))
2537 -- The function call may have been rewritten as the temporary
2538 -- that holds the result of the call, in which case remove the
2539 -- now useless declaration.
2541 if Nkind
(N
) = N_Identifier
2542 and then Nkind
(Parent
(Entity
(N
))) = N_Object_Declaration
2544 Rewrite
(Parent
(Entity
(N
)), Make_Null_Statement
(Loc
));
2547 Rewrite
(N
, Expression
(Fst
));
2549 elsif Nkind
(N
) = N_Identifier
2550 and then Nkind
(Parent
(Entity
(N
))) = N_Object_Declaration
2552 -- The block assigns the result of the call to the temporary
2554 Insert_After
(Parent
(Entity
(N
)), Blk
);
2556 elsif Nkind
(Parent
(N
)) = N_Assignment_Statement
2557 and then Is_Entity_Name
(Name
(Parent
(N
)))
2559 -- Replace assignment with the block
2562 Original_Assignment
: constant Node_Id
:= Parent
(N
);
2565 -- Preserve the original assignment node to keep the
2566 -- complete assignment subtree consistent enough for
2567 -- Analyze_Assignment to proceed (specifically, the
2568 -- original Lhs node must still have an assignment
2569 -- statement as its parent).
2571 -- We cannot rely on Original_Node to go back from the
2572 -- block node to the assignment node, because the
2573 -- assignment might already be a rewrite substitution.
2575 Discard_Node
(Relocate_Node
(Original_Assignment
));
2576 Rewrite
(Original_Assignment
, Blk
);
2579 elsif Nkind
(Parent
(N
)) = N_Object_Declaration
then
2580 Set_Expression
(Parent
(N
), Empty
);
2581 Insert_After
(Parent
(N
), Blk
);
2583 end Rewrite_Function_Call
;
2585 ----------------------------
2586 -- Rewrite_Procedure_Call --
2587 ----------------------------
2589 procedure Rewrite_Procedure_Call
(N
: Node_Id
; Blk
: Node_Id
) is
2590 HSS
: constant Node_Id
:= Handled_Statement_Sequence
(Blk
);
2592 if Is_Empty_List
(Declarations
(Blk
)) then
2593 Insert_List_After
(N
, Statements
(HSS
));
2594 Rewrite
(N
, Make_Null_Statement
(Loc
));
2598 end Rewrite_Procedure_Call
;
2600 -------------------------
2601 -- Formal_Is_Used_Once --
2602 ------------------------
2604 function Formal_Is_Used_Once
(Formal
: Entity_Id
) return Boolean is
2605 Use_Counter
: Int
:= 0;
2607 function Count_Uses
(N
: Node_Id
) return Traverse_Result
;
2608 -- Traverse the tree and count the uses of the formal parameter.
2609 -- In this case, for optimization purposes, we do not need to
2610 -- continue the traversal once more than one use is encountered.
2616 function Count_Uses
(N
: Node_Id
) return Traverse_Result
is
2618 -- The original node is an identifier
2620 if Nkind
(N
) = N_Identifier
2621 and then Present
(Entity
(N
))
2623 -- The original node's entity points to the one in the
2626 and then Nkind
(Entity
(N
)) = N_Identifier
2627 and then Present
(Entity
(Entity
(N
)))
2629 -- The entity of the copied node is the formal parameter
2631 and then Entity
(Entity
(N
)) = Formal
2633 Use_Counter
:= Use_Counter
+ 1;
2635 if Use_Counter
> 1 then
2637 -- Denote more than one use and abandon the traversal
2648 procedure Count_Formal_Uses
is new Traverse_Proc
(Count_Uses
);
2650 -- Start of processing for Formal_Is_Used_Once
2653 Count_Formal_Uses
(Orig_Bod
);
2654 return Use_Counter
= 1;
2655 end Formal_Is_Used_Once
;
2657 -- Start of processing for Expand_Inlined_Call
2660 -- Check for special case of To_Address call, and if so, just do an
2661 -- unchecked conversion instead of expanding the call. Not only is this
2662 -- more efficient, but it also avoids problem with order of elaboration
2663 -- when address clauses are inlined (address expr elaborated at wrong
2666 if Subp
= RTE
(RE_To_Address
) then
2668 Unchecked_Convert_To
2670 Relocate_Node
(First_Actual
(N
))));
2674 -- Check for an illegal attempt to inline a recursive procedure. If the
2675 -- subprogram has parameters this is detected when trying to supply a
2676 -- binding for parameters that already have one. For parameterless
2677 -- subprograms this must be done explicitly.
2679 if In_Open_Scopes
(Subp
) then
2680 Error_Msg_N
("call to recursive subprogram cannot be inlined?", N
);
2681 Set_Is_Inlined
(Subp
, False);
2685 if Nkind
(Orig_Bod
) = N_Defining_Identifier
2686 or else Nkind
(Orig_Bod
) = N_Defining_Operator_Symbol
2688 -- Subprogram is a renaming_as_body. Calls appearing after the
2689 -- renaming can be replaced with calls to the renamed entity
2690 -- directly, because the subprograms are subtype conformant. If
2691 -- the renamed subprogram is an inherited operation, we must redo
2692 -- the expansion because implicit conversions may be needed.
2694 Set_Name
(N
, New_Occurrence_Of
(Orig_Bod
, Loc
));
2696 if Present
(Alias
(Orig_Bod
)) then
2703 -- Use generic machinery to copy body of inlined subprogram, as if it
2704 -- were an instantiation, resetting source locations appropriately, so
2705 -- that nested inlined calls appear in the main unit.
2707 Save_Env
(Subp
, Empty
);
2708 Set_Copied_Sloc_For_Inlined_Body
(N
, Defining_Entity
(Orig_Bod
));
2710 Bod
:= Copy_Generic_Node
(Orig_Bod
, Empty
, Instantiating
=> True);
2712 Make_Block_Statement
(Loc
,
2713 Declarations
=> Declarations
(Bod
),
2714 Handled_Statement_Sequence
=> Handled_Statement_Sequence
(Bod
));
2716 if No
(Declarations
(Bod
)) then
2717 Set_Declarations
(Blk
, New_List
);
2720 -- If this is a derived function, establish the proper return type
2722 if Present
(Orig_Subp
)
2723 and then Orig_Subp
/= Subp
2725 Ret_Type
:= Etype
(Orig_Subp
);
2727 Ret_Type
:= Etype
(Subp
);
2730 F
:= First_Formal
(Subp
);
2731 A
:= First_Actual
(N
);
2733 -- Create temporaries for the actuals that are expressions, or that
2734 -- are scalars and require copying to preserve semantics.
2736 while Present
(F
) loop
2737 if Present
(Renamed_Object
(F
)) then
2738 Error_Msg_N
(" cannot inline call to recursive subprogram", N
);
2742 -- If the argument may be a controlling argument in a call within
2743 -- the inlined body, we must preserve its classwide nature to insure
2744 -- that dynamic dispatching take place subsequently. If the formal
2745 -- has a constraint it must be preserved to retain the semantics of
2748 if Is_Class_Wide_Type
(Etype
(F
))
2749 or else (Is_Access_Type
(Etype
(F
))
2751 Is_Class_Wide_Type
(Designated_Type
(Etype
(F
))))
2753 Temp_Typ
:= Etype
(F
);
2755 elsif Base_Type
(Etype
(F
)) = Base_Type
(Etype
(A
))
2756 and then Etype
(F
) /= Base_Type
(Etype
(F
))
2758 Temp_Typ
:= Etype
(F
);
2761 Temp_Typ
:= Etype
(A
);
2764 -- If the actual is a simple name or a literal, no need to
2765 -- create a temporary, object can be used directly.
2767 if (Is_Entity_Name
(A
)
2769 (not Is_Scalar_Type
(Etype
(A
))
2770 or else Ekind
(Entity
(A
)) = E_Enumeration_Literal
))
2772 -- When the actual is an identifier and the corresponding formal
2773 -- is used only once in the original body, the formal can be
2774 -- substituted directly with the actual parameter.
2776 or else (Nkind
(A
) = N_Identifier
2777 and then Formal_Is_Used_Once
(F
))
2779 or else Nkind
(A
) = N_Real_Literal
2780 or else Nkind
(A
) = N_Integer_Literal
2781 or else Nkind
(A
) = N_Character_Literal
2783 if Etype
(F
) /= Etype
(A
) then
2785 (F
, Unchecked_Convert_To
(Etype
(F
), Relocate_Node
(A
)));
2787 Set_Renamed_Object
(F
, A
);
2792 Make_Defining_Identifier
(Loc
,
2793 Chars
=> New_Internal_Name
('C'));
2795 -- If the actual for an in/in-out parameter is a view conversion,
2796 -- make it into an unchecked conversion, given that an untagged
2797 -- type conversion is not a proper object for a renaming.
2799 -- In-out conversions that involve real conversions have already
2800 -- been transformed in Expand_Actuals.
2802 if Nkind
(A
) = N_Type_Conversion
2803 and then Ekind
(F
) /= E_In_Parameter
2805 New_A
:= Make_Unchecked_Type_Conversion
(Loc
,
2806 Subtype_Mark
=> New_Occurrence_Of
(Etype
(F
), Loc
),
2807 Expression
=> Relocate_Node
(Expression
(A
)));
2809 elsif Etype
(F
) /= Etype
(A
) then
2810 New_A
:= Unchecked_Convert_To
(Etype
(F
), Relocate_Node
(A
));
2811 Temp_Typ
:= Etype
(F
);
2814 New_A
:= Relocate_Node
(A
);
2817 Set_Sloc
(New_A
, Sloc
(N
));
2819 if Ekind
(F
) = E_In_Parameter
2820 and then not Is_Limited_Type
(Etype
(A
))
2823 Make_Object_Declaration
(Loc
,
2824 Defining_Identifier
=> Temp
,
2825 Constant_Present
=> True,
2826 Object_Definition
=> New_Occurrence_Of
(Temp_Typ
, Loc
),
2827 Expression
=> New_A
);
2830 Make_Object_Renaming_Declaration
(Loc
,
2831 Defining_Identifier
=> Temp
,
2832 Subtype_Mark
=> New_Occurrence_Of
(Temp_Typ
, Loc
),
2836 Prepend
(Decl
, Declarations
(Blk
));
2837 Set_Renamed_Object
(F
, Temp
);
2844 -- Establish target of function call. If context is not assignment or
2845 -- declaration, create a temporary as a target. The declaration for
2846 -- the temporary may be subsequently optimized away if the body is a
2847 -- single expression, or if the left-hand side of the assignment is
2850 if Ekind
(Subp
) = E_Function
then
2851 if Nkind
(Parent
(N
)) = N_Assignment_Statement
2852 and then Is_Entity_Name
(Name
(Parent
(N
)))
2854 Targ
:= Name
(Parent
(N
));
2857 -- Replace call with temporary and create its declaration
2860 Make_Defining_Identifier
(Loc
, New_Internal_Name
('C'));
2863 Make_Object_Declaration
(Loc
,
2864 Defining_Identifier
=> Temp
,
2865 Object_Definition
=>
2866 New_Occurrence_Of
(Ret_Type
, Loc
));
2868 Set_No_Initialization
(Decl
);
2869 Insert_Action
(N
, Decl
);
2870 Rewrite
(N
, New_Occurrence_Of
(Temp
, Loc
));
2875 -- Traverse the tree and replace formals with actuals or their thunks.
2876 -- Attach block to tree before analysis and rewriting.
2878 Replace_Formals
(Blk
);
2879 Set_Parent
(Blk
, N
);
2881 if not Comes_From_Source
(Subp
)
2887 if Present
(Exit_Lab
) then
2889 -- If the body was a single expression, the single return statement
2890 -- and the corresponding label are useless.
2894 Nkind
(Last
(Statements
(Handled_Statement_Sequence
(Blk
)))) =
2897 Remove
(Last
(Statements
(Handled_Statement_Sequence
(Blk
))));
2899 Append
(Lab_Decl
, (Declarations
(Blk
)));
2900 Append
(Exit_Lab
, Statements
(Handled_Statement_Sequence
(Blk
)));
2904 -- Analyze Blk with In_Inlined_Body set, to avoid spurious errors on
2905 -- conflicting private views that Gigi would ignore. If this is
2906 -- predefined unit, analyze with checks off, as is done in the non-
2907 -- inlined run-time units.
2910 I_Flag
: constant Boolean := In_Inlined_Body
;
2913 In_Inlined_Body
:= True;
2917 Style
: constant Boolean := Style_Check
;
2919 Style_Check
:= False;
2920 Analyze
(Blk
, Suppress
=> All_Checks
);
2921 Style_Check
:= Style
;
2928 In_Inlined_Body
:= I_Flag
;
2931 if Ekind
(Subp
) = E_Procedure
then
2932 Rewrite_Procedure_Call
(N
, Blk
);
2934 Rewrite_Function_Call
(N
, Blk
);
2939 -- Cleanup mapping between formals and actuals for other expansions
2941 F
:= First_Formal
(Subp
);
2943 while Present
(F
) loop
2944 Set_Renamed_Object
(F
, Empty
);
2947 end Expand_Inlined_Call
;
2949 ----------------------------
2950 -- Expand_N_Function_Call --
2951 ----------------------------
2953 procedure Expand_N_Function_Call
(N
: Node_Id
) is
2954 Typ
: constant Entity_Id
:= Etype
(N
);
2956 function Returned_By_Reference
return Boolean;
2957 -- If the return type is returned through the secondary stack. that is
2958 -- by reference, we don't want to create a temp to force stack checking.
2959 -- Shouldn't this function be moved to exp_util???
2961 function Rhs_Of_Assign_Or_Decl
(N
: Node_Id
) return Boolean;
2962 -- If the call is the right side of an assignment or the expression in
2963 -- an object declaration, we don't need to create a temp as the left
2964 -- side will already trigger stack checking if necessary.
2966 ---------------------------
2967 -- Returned_By_Reference --
2968 ---------------------------
2970 function Returned_By_Reference
return Boolean is
2971 S
: Entity_Id
:= Current_Scope
;
2974 if Is_Return_By_Reference_Type
(Typ
) then
2977 elsif Nkind
(Parent
(N
)) /= N_Return_Statement
then
2980 elsif Requires_Transient_Scope
(Typ
) then
2982 -- Verify that the return type of the enclosing function has the
2983 -- same constrained status as that of the expression.
2985 while Ekind
(S
) /= E_Function
loop
2989 return Is_Constrained
(Typ
) = Is_Constrained
(Etype
(S
));
2993 end Returned_By_Reference
;
2995 ---------------------------
2996 -- Rhs_Of_Assign_Or_Decl --
2997 ---------------------------
2999 function Rhs_Of_Assign_Or_Decl
(N
: Node_Id
) return Boolean is
3001 if (Nkind
(Parent
(N
)) = N_Assignment_Statement
3002 and then Expression
(Parent
(N
)) = N
)
3004 (Nkind
(Parent
(N
)) = N_Qualified_Expression
3005 and then Nkind
(Parent
(Parent
(N
))) = N_Assignment_Statement
3006 and then Expression
(Parent
(Parent
(N
))) = Parent
(N
))
3008 (Nkind
(Parent
(N
)) = N_Object_Declaration
3009 and then Expression
(Parent
(N
)) = N
)
3011 (Nkind
(Parent
(N
)) = N_Component_Association
3012 and then Expression
(Parent
(N
)) = N
3013 and then Nkind
(Parent
(Parent
(N
))) = N_Aggregate
3014 and then Rhs_Of_Assign_Or_Decl
(Parent
(Parent
(N
))))
3020 end Rhs_Of_Assign_Or_Decl
;
3022 -- Start of processing for Expand_N_Function_Call
3025 -- A special check. If stack checking is enabled, and the return type
3026 -- might generate a large temporary, and the call is not the right side
3027 -- of an assignment, then generate an explicit temporary. We do this
3028 -- because otherwise gigi may generate a large temporary on the fly and
3029 -- this can cause trouble with stack checking.
3031 -- This is unecessary if the call is the expression in an object
3032 -- declaration, or if it appears outside of any library unit. This can
3033 -- only happen if it appears as an actual in a library-level instance,
3034 -- in which case a temporary will be generated for it once the instance
3035 -- itself is installed.
3037 if May_Generate_Large_Temp
(Typ
)
3038 and then not Rhs_Of_Assign_Or_Decl
(N
)
3039 and then not Returned_By_Reference
3040 and then Current_Scope
/= Standard_Standard
3042 if Stack_Checking_Enabled
then
3044 -- Note: it might be thought that it would be OK to use a call to
3045 -- Force_Evaluation here, but that's not good enough, because
3046 -- that can results in a 'Reference construct that may still need
3050 Loc
: constant Source_Ptr
:= Sloc
(N
);
3051 Temp_Obj
: constant Entity_Id
:=
3052 Make_Defining_Identifier
(Loc
,
3053 Chars
=> New_Internal_Name
('F'));
3054 Temp_Typ
: Entity_Id
:= Typ
;
3061 if Is_Tagged_Type
(Typ
)
3062 and then Present
(Controlling_Argument
(N
))
3064 if Nkind
(Parent
(N
)) /= N_Procedure_Call_Statement
3065 and then Nkind
(Parent
(N
)) /= N_Function_Call
3067 -- If this is a tag-indeterminate call, the object must
3070 if Is_Tag_Indeterminate
(N
) then
3071 Temp_Typ
:= Class_Wide_Type
(Typ
);
3075 -- If this is a dispatching call that is itself the
3076 -- controlling argument of an enclosing call, the
3077 -- nominal subtype of the object that replaces it must
3078 -- be classwide, so that dispatching will take place
3079 -- properly. If it is not a controlling argument, the
3080 -- object is not classwide.
3082 Proc
:= Entity
(Name
(Parent
(N
)));
3083 F
:= First_Formal
(Proc
);
3084 A
:= First_Actual
(Parent
(N
));
3091 if Is_Controlling_Formal
(F
) then
3092 Temp_Typ
:= Class_Wide_Type
(Typ
);
3098 Make_Object_Declaration
(Loc
,
3099 Defining_Identifier
=> Temp_Obj
,
3100 Object_Definition
=> New_Occurrence_Of
(Temp_Typ
, Loc
),
3101 Constant_Present
=> True,
3102 Expression
=> Relocate_Node
(N
));
3103 Set_Assignment_OK
(Decl
);
3105 Insert_Actions
(N
, New_List
(Decl
));
3106 Rewrite
(N
, New_Occurrence_Of
(Temp_Obj
, Loc
));
3110 -- If stack-checking is not enabled, increment serial number
3111 -- for internal names, so that subsequent symbols are consistent
3112 -- with and without stack-checking.
3114 Synchronize_Serial_Number
;
3116 -- Now we can expand the call with consistent symbol names
3121 -- Normal case, expand the call
3126 end Expand_N_Function_Call
;
3128 ---------------------------------------
3129 -- Expand_N_Procedure_Call_Statement --
3130 ---------------------------------------
3132 procedure Expand_N_Procedure_Call_Statement
(N
: Node_Id
) is
3135 end Expand_N_Procedure_Call_Statement
;
3137 ------------------------------
3138 -- Expand_N_Subprogram_Body --
3139 ------------------------------
3141 -- Add poll call if ATC polling is enabled, unless the body will be
3142 -- inlined by the back-end.
3144 -- Add return statement if last statement in body is not a return statement
3145 -- (this makes things easier on Gigi which does not want to have to handle
3146 -- a missing return).
3148 -- Add call to Activate_Tasks if body is a task activator
3150 -- Deal with possible detection of infinite recursion
3152 -- Eliminate body completely if convention stubbed
3154 -- Encode entity names within body, since we will not need to reference
3155 -- these entities any longer in the front end.
3157 -- Initialize scalar out parameters if Initialize/Normalize_Scalars
3159 -- Reset Pure indication if any parameter has root type System.Address
3163 procedure Expand_N_Subprogram_Body
(N
: Node_Id
) is
3164 Loc
: constant Source_Ptr
:= Sloc
(N
);
3165 H
: constant Node_Id
:= Handled_Statement_Sequence
(N
);
3166 Body_Id
: Entity_Id
;
3167 Spec_Id
: Entity_Id
;
3174 procedure Add_Return
(S
: List_Id
);
3175 -- Append a return statement to the statement sequence S if the last
3176 -- statement is not already a return or a goto statement. Note that
3177 -- the latter test is not critical, it does not matter if we add a
3178 -- few extra returns, since they get eliminated anyway later on.
3180 procedure Expand_Thread_Body
;
3181 -- Perform required expansion of a thread body
3187 procedure Add_Return
(S
: List_Id
) is
3189 if not Is_Transfer
(Last
(S
)) then
3191 -- The source location for the return is the end label
3192 -- of the procedure in all cases. This is a bit odd when
3193 -- there are exception handlers, but not much else we can do.
3195 Append_To
(S
, Make_Return_Statement
(Sloc
(End_Label
(H
))));
3199 ------------------------
3200 -- Expand_Thread_Body --
3201 ------------------------
3203 -- The required expansion of a thread body is as follows
3205 -- procedure <thread body procedure name> is
3207 -- _Secondary_Stack : aliased
3208 -- Storage_Elements.Storage_Array
3209 -- (1 .. Storage_Offset (Sec_Stack_Size));
3210 -- for _Secondary_Stack'Alignment use Standard'Maximum_Alignment;
3212 -- _Process_ATSD : aliased System.Threads.ATSD;
3215 -- System.Threads.Thread_Body_Enter;
3216 -- (_Secondary_Stack'Address,
3217 -- _Secondary_Stack'Length,
3218 -- _Process_ATSD'Address);
3221 -- <user declarations>
3223 -- <user statements>
3224 -- <user exception handlers>
3227 -- System.Threads.Thread_Body_Leave;
3230 -- when E : others =>
3231 -- System.Threads.Thread_Body_Exceptional_Exit (E);
3234 -- Note the exception handler is omitted if pragma Restriction
3235 -- No_Exception_Handlers is currently active.
3237 procedure Expand_Thread_Body
is
3238 User_Decls
: constant List_Id
:= Declarations
(N
);
3239 Sec_Stack_Len
: Node_Id
;
3241 TB_Pragma
: constant Node_Id
:=
3242 Get_Rep_Pragma
(Spec_Id
, Name_Thread_Body
);
3245 Ent_ATSD
: Entity_Id
;
3249 Decl_ATSD
: Node_Id
;
3251 Excep_Handlers
: List_Id
;
3254 New_Scope
(Spec_Id
);
3256 -- Get proper setting for secondary stack size
3258 if List_Length
(Pragma_Argument_Associations
(TB_Pragma
)) = 2 then
3260 Expression
(Last
(Pragma_Argument_Associations
(TB_Pragma
)));
3263 New_Occurrence_Of
(RTE
(RE_Default_Secondary_Stack_Size
), Loc
);
3266 Sec_Stack_Len
:= Convert_To
(RTE
(RE_Storage_Offset
), Sec_Stack_Len
);
3268 -- Build and set declarations for the wrapped thread body
3270 Ent_SS
:= Make_Defining_Identifier
(Loc
, Name_uSecondary_Stack
);
3271 Ent_ATSD
:= Make_Defining_Identifier
(Loc
, Name_uProcess_ATSD
);
3274 Make_Object_Declaration
(Loc
,
3275 Defining_Identifier
=> Ent_SS
,
3276 Aliased_Present
=> True,
3277 Object_Definition
=>
3278 Make_Subtype_Indication
(Loc
,
3280 New_Occurrence_Of
(RTE
(RE_Storage_Array
), Loc
),
3282 Make_Index_Or_Discriminant_Constraint
(Loc
,
3283 Constraints
=> New_List
(
3285 Low_Bound
=> Make_Integer_Literal
(Loc
, 1),
3286 High_Bound
=> Sec_Stack_Len
)))));
3289 Make_Object_Declaration
(Loc
,
3290 Defining_Identifier
=> Ent_ATSD
,
3291 Aliased_Present
=> True,
3292 Object_Definition
=> New_Occurrence_Of
(RTE
(RE_ATSD
), Loc
));
3294 Set_Declarations
(N
, New_List
(Decl_SS
, Decl_ATSD
));
3296 Analyze
(Decl_ATSD
);
3297 Set_Alignment
(Ent_SS
, UI_From_Int
(Maximum_Alignment
));
3299 -- Create new exception handler
3301 if Restriction_Active
(No_Exception_Handlers
) then
3302 Excep_Handlers
:= No_List
;
3305 Check_Restriction
(No_Exception_Handlers
, N
);
3307 Ent_EO
:= Make_Defining_Identifier
(Loc
, Name_uE
);
3309 Excep_Handlers
:= New_List
(
3310 Make_Exception_Handler
(Loc
,
3311 Choice_Parameter
=> Ent_EO
,
3312 Exception_Choices
=> New_List
(
3313 Make_Others_Choice
(Loc
)),
3314 Statements
=> New_List
(
3315 Make_Procedure_Call_Statement
(Loc
,
3318 (RTE
(RE_Thread_Body_Exceptional_Exit
), Loc
),
3319 Parameter_Associations
=> New_List
(
3320 New_Occurrence_Of
(Ent_EO
, Loc
))))));
3323 -- Now build new handled statement sequence and analyze it
3325 Set_Handled_Statement_Sequence
(N
,
3326 Make_Handled_Sequence_Of_Statements
(Loc
,
3327 Statements
=> New_List
(
3329 Make_Procedure_Call_Statement
(Loc
,
3330 Name
=> New_Occurrence_Of
(RTE
(RE_Thread_Body_Enter
), Loc
),
3331 Parameter_Associations
=> New_List
(
3333 Make_Attribute_Reference
(Loc
,
3334 Prefix
=> New_Occurrence_Of
(Ent_SS
, Loc
),
3335 Attribute_Name
=> Name_Address
),
3337 Make_Attribute_Reference
(Loc
,
3338 Prefix
=> New_Occurrence_Of
(Ent_SS
, Loc
),
3339 Attribute_Name
=> Name_Length
),
3341 Make_Attribute_Reference
(Loc
,
3342 Prefix
=> New_Occurrence_Of
(Ent_ATSD
, Loc
),
3343 Attribute_Name
=> Name_Address
))),
3345 Make_Block_Statement
(Loc
,
3346 Declarations
=> User_Decls
,
3347 Handled_Statement_Sequence
=> H
),
3349 Make_Procedure_Call_Statement
(Loc
,
3350 Name
=> New_Occurrence_Of
(RTE
(RE_Thread_Body_Leave
), Loc
))),
3352 Exception_Handlers
=> Excep_Handlers
));
3354 Analyze
(Handled_Statement_Sequence
(N
));
3356 end Expand_Thread_Body
;
3358 -- Start of processing for Expand_N_Subprogram_Body
3361 -- Set L to either the list of declarations if present, or
3362 -- to the list of statements if no declarations are present.
3363 -- This is used to insert new stuff at the start.
3365 if Is_Non_Empty_List
(Declarations
(N
)) then
3366 L
:= Declarations
(N
);
3368 L
:= Statements
(Handled_Statement_Sequence
(N
));
3371 -- Find entity for subprogram
3373 Body_Id
:= Defining_Entity
(N
);
3375 if Present
(Corresponding_Spec
(N
)) then
3376 Spec_Id
:= Corresponding_Spec
(N
);
3381 -- Need poll on entry to subprogram if polling enabled. We only
3382 -- do this for non-empty subprograms, since it does not seem
3383 -- necessary to poll for a dummy null subprogram. Do not add polling
3384 -- point if calls to this subprogram will be inlined by the back-end,
3385 -- to avoid repeated polling points in nested inlinings.
3387 if Is_Non_Empty_List
(L
) then
3388 if Is_Inlined
(Spec_Id
)
3389 and then Front_End_Inlining
3390 and then Optimization_Level
> 1
3394 Generate_Poll_Call
(First
(L
));
3398 -- If this is a Pure function which has any parameters whose root
3399 -- type is System.Address, reset the Pure indication, since it will
3400 -- likely cause incorrect code to be generated as the parameter is
3401 -- probably a pointer, and the fact that the same pointer is passed
3402 -- does not mean that the same value is being referenced.
3404 -- Note that if the programmer gave an explicit Pure_Function pragma,
3405 -- then we believe the programmer, and leave the subprogram Pure.
3407 -- This code should probably be at the freeze point, so that it
3408 -- happens even on a -gnatc (or more importantly -gnatt) compile
3409 -- so that the semantic tree has Is_Pure set properly ???
3411 if Is_Pure
(Spec_Id
)
3412 and then Is_Subprogram
(Spec_Id
)
3413 and then not Has_Pragma_Pure_Function
(Spec_Id
)
3416 F
: Entity_Id
:= First_Formal
(Spec_Id
);
3419 while Present
(F
) loop
3420 if Is_Descendent_Of_Address
(Etype
(F
)) then
3421 Set_Is_Pure
(Spec_Id
, False);
3423 if Spec_Id
/= Body_Id
then
3424 Set_Is_Pure
(Body_Id
, False);
3435 -- Initialize any scalar OUT args if Initialize/Normalize_Scalars
3437 if Init_Or_Norm_Scalars
and then Is_Subprogram
(Spec_Id
) then
3439 F
: Entity_Id
:= First_Formal
(Spec_Id
);
3440 V
: constant Boolean := Validity_Checks_On
;
3443 -- We turn off validity checking, since we do not want any
3444 -- check on the initializing value itself (which we know
3445 -- may well be invalid!)
3447 Validity_Checks_On
:= False;
3449 -- Loop through formals
3451 while Present
(F
) loop
3452 if Is_Scalar_Type
(Etype
(F
))
3453 and then Ekind
(F
) = E_Out_Parameter
3455 Insert_Before_And_Analyze
(First
(L
),
3456 Make_Assignment_Statement
(Loc
,
3457 Name
=> New_Occurrence_Of
(F
, Loc
),
3458 Expression
=> Get_Simple_Init_Val
(Etype
(F
), Loc
)));
3464 Validity_Checks_On
:= V
;
3468 Scop
:= Scope
(Spec_Id
);
3470 -- Add discriminal renamings to protected subprograms.
3471 -- Install new discriminals for expansion of the next
3472 -- subprogram of this protected type, if any.
3474 if Is_List_Member
(N
)
3475 and then Present
(Parent
(List_Containing
(N
)))
3476 and then Nkind
(Parent
(List_Containing
(N
))) = N_Protected_Body
3478 Add_Discriminal_Declarations
3479 (Declarations
(N
), Scop
, Name_uObject
, Loc
);
3480 Add_Private_Declarations
(Declarations
(N
), Scop
, Name_uObject
, Loc
);
3482 -- Associate privals and discriminals with the next protected
3483 -- operation body to be expanded. These are used to expand
3484 -- references to private data objects and discriminants,
3487 Next_Op
:= Next_Protected_Operation
(N
);
3489 if Present
(Next_Op
) then
3490 Dec
:= Parent
(Base_Type
(Scop
));
3491 Set_Privals
(Dec
, Next_Op
, Loc
);
3492 Set_Discriminals
(Dec
);
3496 -- Clear out statement list for stubbed procedure
3498 if Present
(Corresponding_Spec
(N
)) then
3499 Set_Elaboration_Flag
(N
, Spec_Id
);
3501 if Convention
(Spec_Id
) = Convention_Stubbed
3502 or else Is_Eliminated
(Spec_Id
)
3504 Set_Declarations
(N
, Empty_List
);
3505 Set_Handled_Statement_Sequence
(N
,
3506 Make_Handled_Sequence_Of_Statements
(Loc
,
3507 Statements
=> New_List
(
3508 Make_Null_Statement
(Loc
))));
3513 -- Returns_By_Ref flag is normally set when the subprogram is frozen
3514 -- but subprograms with no specs are not frozen
3517 Typ
: constant Entity_Id
:= Etype
(Spec_Id
);
3518 Utyp
: constant Entity_Id
:= Underlying_Type
(Typ
);
3521 if not Acts_As_Spec
(N
)
3522 and then Nkind
(Parent
(Parent
(Spec_Id
))) /=
3523 N_Subprogram_Body_Stub
3527 elsif Is_Return_By_Reference_Type
(Typ
) then
3528 Set_Returns_By_Ref
(Spec_Id
);
3530 elsif Present
(Utyp
) and then Controlled_Type
(Utyp
) then
3531 Set_Returns_By_Ref
(Spec_Id
);
3535 -- For a procedure, we add a return for all possible syntactic ends
3536 -- of the subprogram. Note that reanalysis is not necessary in this
3537 -- case since it would require a lot of work and accomplish nothing.
3539 if Ekind
(Spec_Id
) = E_Procedure
3540 or else Ekind
(Spec_Id
) = E_Generic_Procedure
3542 Add_Return
(Statements
(H
));
3544 if Present
(Exception_Handlers
(H
)) then
3545 Except_H
:= First_Non_Pragma
(Exception_Handlers
(H
));
3547 while Present
(Except_H
) loop
3548 Add_Return
(Statements
(Except_H
));
3549 Next_Non_Pragma
(Except_H
);
3553 -- For a function, we must deal with the case where there is at least
3554 -- one missing return. What we do is to wrap the entire body of the
3555 -- function in a block:
3568 -- raise Program_Error;
3571 -- This approach is necessary because the raise must be signalled
3572 -- to the caller, not handled by any local handler (RM 6.4(11)).
3574 -- Note: we do not need to analyze the constructed sequence here,
3575 -- since it has no handler, and an attempt to analyze the handled
3576 -- statement sequence twice is risky in various ways (e.g. the
3577 -- issue of expanding cleanup actions twice).
3579 elsif Has_Missing_Return
(Spec_Id
) then
3581 Hloc
: constant Source_Ptr
:= Sloc
(H
);
3582 Blok
: constant Node_Id
:=
3583 Make_Block_Statement
(Hloc
,
3584 Handled_Statement_Sequence
=> H
);
3585 Rais
: constant Node_Id
:=
3586 Make_Raise_Program_Error
(Hloc
,
3587 Reason
=> PE_Missing_Return
);
3590 Set_Handled_Statement_Sequence
(N
,
3591 Make_Handled_Sequence_Of_Statements
(Hloc
,
3592 Statements
=> New_List
(Blok
, Rais
)));
3594 New_Scope
(Spec_Id
);
3601 -- If subprogram contains a parameterless recursive call, then we may
3602 -- have an infinite recursion, so see if we can generate code to check
3603 -- for this possibility if storage checks are not suppressed.
3605 if Ekind
(Spec_Id
) = E_Procedure
3606 and then Has_Recursive_Call
(Spec_Id
)
3607 and then not Storage_Checks_Suppressed
(Spec_Id
)
3609 Detect_Infinite_Recursion
(N
, Spec_Id
);
3612 -- Finally, if we are in Normalize_Scalars mode, then any scalar out
3613 -- parameters must be initialized to the appropriate default value.
3615 if Ekind
(Spec_Id
) = E_Procedure
and then Normalize_Scalars
then
3622 Formal
:= First_Formal
(Spec_Id
);
3624 while Present
(Formal
) loop
3625 Floc
:= Sloc
(Formal
);
3627 if Ekind
(Formal
) = E_Out_Parameter
3628 and then Is_Scalar_Type
(Etype
(Formal
))
3631 Make_Assignment_Statement
(Floc
,
3632 Name
=> New_Occurrence_Of
(Formal
, Floc
),
3634 Get_Simple_Init_Val
(Etype
(Formal
), Floc
));
3635 Prepend
(Stm
, Declarations
(N
));
3639 Next_Formal
(Formal
);
3644 -- Deal with thread body
3646 if Is_Thread_Body
(Spec_Id
) then
3650 -- If the subprogram does not have pending instantiations, then we
3651 -- must generate the subprogram descriptor now, since the code for
3652 -- the subprogram is complete, and this is our last chance. However
3653 -- if there are pending instantiations, then the code is not
3654 -- complete, and we will delay the generation.
3656 if Is_Subprogram
(Spec_Id
)
3657 and then not Delay_Subprogram_Descriptors
(Spec_Id
)
3659 Generate_Subprogram_Descriptor_For_Subprogram
(N
, Spec_Id
);
3662 -- Set to encode entity names in package body before gigi is called
3664 Qualify_Entity_Names
(N
);
3665 end Expand_N_Subprogram_Body
;
3667 -----------------------------------
3668 -- Expand_N_Subprogram_Body_Stub --
3669 -----------------------------------
3671 procedure Expand_N_Subprogram_Body_Stub
(N
: Node_Id
) is
3673 if Present
(Corresponding_Body
(N
)) then
3674 Expand_N_Subprogram_Body
(
3675 Unit_Declaration_Node
(Corresponding_Body
(N
)));
3677 end Expand_N_Subprogram_Body_Stub
;
3679 -------------------------------------
3680 -- Expand_N_Subprogram_Declaration --
3681 -------------------------------------
3683 -- If the declaration appears within a protected body, it is a private
3684 -- operation of the protected type. We must create the corresponding
3685 -- protected subprogram an associated formals. For a normal protected
3686 -- operation, this is done when expanding the protected type declaration.
3688 procedure Expand_N_Subprogram_Declaration
(N
: Node_Id
) is
3689 Loc
: constant Source_Ptr
:= Sloc
(N
);
3690 Subp
: constant Entity_Id
:= Defining_Entity
(N
);
3691 Scop
: constant Entity_Id
:= Scope
(Subp
);
3692 Prot_Decl
: Node_Id
;
3694 Prot_Id
: Entity_Id
;
3697 -- Deal with case of protected subprogram. Do not generate
3698 -- protected operation if operation is flagged as eliminated.
3700 if Is_List_Member
(N
)
3701 and then Present
(Parent
(List_Containing
(N
)))
3702 and then Nkind
(Parent
(List_Containing
(N
))) = N_Protected_Body
3703 and then Is_Protected_Type
(Scop
)
3705 if No
(Protected_Body_Subprogram
(Subp
))
3706 and then not Is_Eliminated
(Subp
)
3709 Make_Subprogram_Declaration
(Loc
,
3711 Build_Protected_Sub_Specification
3712 (N
, Scop
, Unprotected
=> True));
3714 -- The protected subprogram is declared outside of the protected
3715 -- body. Given that the body has frozen all entities so far, we
3716 -- analyze the subprogram and perform freezing actions explicitly.
3717 -- If the body is a subunit, the insertion point is before the
3718 -- stub in the parent.
3720 Prot_Bod
:= Parent
(List_Containing
(N
));
3722 if Nkind
(Parent
(Prot_Bod
)) = N_Subunit
then
3723 Prot_Bod
:= Corresponding_Stub
(Parent
(Prot_Bod
));
3726 Insert_Before
(Prot_Bod
, Prot_Decl
);
3727 Prot_Id
:= Defining_Unit_Name
(Specification
(Prot_Decl
));
3729 New_Scope
(Scope
(Scop
));
3730 Analyze
(Prot_Decl
);
3731 Create_Extra_Formals
(Prot_Id
);
3732 Set_Protected_Body_Subprogram
(Subp
, Prot_Id
);
3736 end Expand_N_Subprogram_Declaration
;
3738 ---------------------------------------
3739 -- Expand_Protected_Object_Reference --
3740 ---------------------------------------
3742 function Expand_Protected_Object_Reference
3747 Loc
: constant Source_Ptr
:= Sloc
(N
);
3754 Rec
:= Make_Identifier
(Loc
, Name_uObject
);
3755 Set_Etype
(Rec
, Corresponding_Record_Type
(Scop
));
3757 -- Find enclosing protected operation, and retrieve its first
3758 -- parameter, which denotes the enclosing protected object.
3759 -- If the enclosing operation is an entry, we are immediately
3760 -- within the protected body, and we can retrieve the object
3761 -- from the service entries procedure. A barrier function has
3762 -- has the same signature as an entry. A barrier function is
3763 -- compiled within the protected object, but unlike protected
3764 -- operations its never needs locks, so that its protected body
3765 -- subprogram points to itself.
3767 Proc
:= Current_Scope
;
3769 while Present
(Proc
)
3770 and then Scope
(Proc
) /= Scop
3772 Proc
:= Scope
(Proc
);
3775 Corr
:= Protected_Body_Subprogram
(Proc
);
3779 -- Previous error left expansion incomplete.
3780 -- Nothing to do on this call.
3787 (First
(Parameter_Specifications
(Parent
(Corr
))));
3789 if Is_Subprogram
(Proc
)
3790 and then Proc
/= Corr
3792 -- Protected function or procedure
3794 Set_Entity
(Rec
, Param
);
3796 -- Rec is a reference to an entity which will not be in scope
3797 -- when the call is reanalyzed, and needs no further analysis.
3802 -- Entry or barrier function for entry body.
3803 -- The first parameter of the entry body procedure is a
3804 -- pointer to the object. We create a local variable
3805 -- of the proper type, duplicating what is done to define
3806 -- _object later on.
3810 Obj_Ptr
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
,
3812 New_Internal_Name
('T'));
3816 Make_Full_Type_Declaration
(Loc
,
3817 Defining_Identifier
=> Obj_Ptr
,
3819 Make_Access_To_Object_Definition
(Loc
,
3820 Subtype_Indication
=>
3822 (Corresponding_Record_Type
(Scop
), Loc
))));
3824 Insert_Actions
(N
, Decls
);
3825 Insert_Actions
(N
, Freeze_Entity
(Obj_Ptr
, Sloc
(N
)));
3828 Make_Explicit_Dereference
(Loc
,
3829 Unchecked_Convert_To
(Obj_Ptr
,
3830 New_Occurrence_Of
(Param
, Loc
)));
3832 -- Analyze new actual. Other actuals in calls are already
3833 -- analyzed and the list of actuals is not renalyzed after
3836 Set_Parent
(Rec
, N
);
3842 end Expand_Protected_Object_Reference
;
3844 --------------------------------------
3845 -- Expand_Protected_Subprogram_Call --
3846 --------------------------------------
3848 procedure Expand_Protected_Subprogram_Call
3856 -- If the protected object is not an enclosing scope, this is
3857 -- an inter-object function call. Inter-object procedure
3858 -- calls are expanded by Exp_Ch9.Build_Simple_Entry_Call.
3859 -- The call is intra-object only if the subprogram being
3860 -- called is in the protected body being compiled, and if the
3861 -- protected object in the call is statically the enclosing type.
3862 -- The object may be an component of some other data structure,
3863 -- in which case this must be handled as an inter-object call.
3865 if not In_Open_Scopes
(Scop
)
3866 or else not Is_Entity_Name
(Name
(N
))
3868 if Nkind
(Name
(N
)) = N_Selected_Component
then
3869 Rec
:= Prefix
(Name
(N
));
3872 pragma Assert
(Nkind
(Name
(N
)) = N_Indexed_Component
);
3873 Rec
:= Prefix
(Prefix
(Name
(N
)));
3876 Build_Protected_Subprogram_Call
(N
,
3877 Name
=> New_Occurrence_Of
(Subp
, Sloc
(N
)),
3878 Rec
=> Convert_Concurrent
(Rec
, Etype
(Rec
)),
3882 Rec
:= Expand_Protected_Object_Reference
(N
, Scop
);
3888 Build_Protected_Subprogram_Call
(N
,
3897 -- If it is a function call it can appear in elaboration code and
3898 -- the called entity must be frozen here.
3900 if Ekind
(Subp
) = E_Function
then
3901 Freeze_Expression
(Name
(N
));
3903 end Expand_Protected_Subprogram_Call
;
3905 -----------------------
3906 -- Freeze_Subprogram --
3907 -----------------------
3909 procedure Freeze_Subprogram
(N
: Node_Id
) is
3910 E
: constant Entity_Id
:= Entity
(N
);
3913 -- When a primitive is frozen, enter its name in the corresponding
3914 -- dispatch table. If the DTC_Entity field is not set this is an
3915 -- overridden primitive that can be ignored. We suppress the
3916 -- initialization of the dispatch table entry when Java_VM because
3917 -- the dispatching mechanism is handled internally by the JVM.
3919 if Is_Dispatching_Operation
(E
)
3920 and then not Is_Abstract
(E
)
3921 and then Present
(DTC_Entity
(E
))
3922 and then not Is_CPP_Class
(Scope
(DTC_Entity
(E
)))
3923 and then not Java_VM
3925 Check_Overriding_Operation
(E
);
3926 Insert_After
(N
, Fill_DT_Entry
(Sloc
(N
), E
));
3929 -- Mark functions that return by reference. Note that it cannot be
3930 -- part of the normal semantic analysis of the spec since the
3931 -- underlying returned type may not be known yet (for private types)
3934 Typ
: constant Entity_Id
:= Etype
(E
);
3935 Utyp
: constant Entity_Id
:= Underlying_Type
(Typ
);
3938 if Is_Return_By_Reference_Type
(Typ
) then
3939 Set_Returns_By_Ref
(E
);
3941 elsif Present
(Utyp
) and then Controlled_Type
(Utyp
) then
3942 Set_Returns_By_Ref
(E
);
3945 end Freeze_Subprogram
;