1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2004, 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 procedure Expand_Inlined_Call
130 Orig_Subp
: Entity_Id
);
131 -- If called subprogram can be inlined by the front-end, retrieve the
132 -- analyzed body, replace formals with actuals and expand call in place.
133 -- Generate thunks for actuals that are expressions, and insert the
134 -- corresponding constant declarations before the call. If the original
135 -- call is to a derived operation, the return type is the one of the
136 -- derived operation, but the body is that of the original, so return
137 -- expressions in the body must be converted to the desired type (which
138 -- is simply not noted in the tree without inline expansion).
140 function Expand_Protected_Object_Reference
145 procedure Expand_Protected_Subprogram_Call
149 -- A call to a protected subprogram within the protected object may appear
150 -- as a regular call. The list of actuals must be expanded to contain a
151 -- reference to the object itself, and the call becomes a call to the
152 -- corresponding protected subprogram.
154 --------------------------------
155 -- Check_Overriding_Operation --
156 --------------------------------
158 procedure Check_Overriding_Operation
(Subp
: Entity_Id
) is
159 Typ
: constant Entity_Id
:= Find_Dispatching_Type
(Subp
);
160 Op_List
: constant Elist_Id
:= Primitive_Operations
(Typ
);
166 if Is_Derived_Type
(Typ
)
167 and then not Is_Private_Type
(Typ
)
168 and then In_Open_Scopes
(Scope
(Etype
(Typ
)))
169 and then Typ
= Base_Type
(Typ
)
171 -- Subp overrides an inherited private operation if there is
172 -- an inherited operation with a different name than Subp (see
173 -- Derive_Subprogram) whose Alias is a hidden subprogram with
174 -- the same name as Subp.
176 Op_Elmt
:= First_Elmt
(Op_List
);
177 while Present
(Op_Elmt
) loop
178 Prim_Op
:= Node
(Op_Elmt
);
179 Par_Op
:= Alias
(Prim_Op
);
182 and then not Comes_From_Source
(Prim_Op
)
183 and then Chars
(Prim_Op
) /= Chars
(Par_Op
)
184 and then Chars
(Par_Op
) = Chars
(Subp
)
185 and then Is_Hidden
(Par_Op
)
186 and then Type_Conformant
(Prim_Op
, Subp
)
188 Set_DT_Position
(Subp
, DT_Position
(Prim_Op
));
194 end Check_Overriding_Operation
;
196 -------------------------------
197 -- Detect_Infinite_Recursion --
198 -------------------------------
200 procedure Detect_Infinite_Recursion
(N
: Node_Id
; Spec
: Entity_Id
) is
201 Loc
: constant Source_Ptr
:= Sloc
(N
);
203 Var_List
: constant Elist_Id
:= New_Elmt_List
;
204 -- List of globals referenced by body of procedure
206 Call_List
: constant Elist_Id
:= New_Elmt_List
;
207 -- List of recursive calls in body of procedure
209 Shad_List
: constant Elist_Id
:= New_Elmt_List
;
210 -- List of entity id's for entities created to capture the
211 -- value of referenced globals on entry to the procedure.
213 Scop
: constant Uint
:= Scope_Depth
(Spec
);
214 -- This is used to record the scope depth of the current
215 -- procedure, so that we can identify global references.
217 Max_Vars
: constant := 4;
218 -- Do not test more than four global variables
220 Count_Vars
: Natural := 0;
221 -- Count variables found so far
233 function Process
(Nod
: Node_Id
) return Traverse_Result
;
234 -- Function to traverse the subprogram body (using Traverse_Func)
240 function Process
(Nod
: Node_Id
) return Traverse_Result
is
244 if Nkind
(Nod
) = N_Procedure_Call_Statement
then
246 -- Case of one of the detected recursive calls
248 if Is_Entity_Name
(Name
(Nod
))
249 and then Has_Recursive_Call
(Entity
(Name
(Nod
)))
250 and then Entity
(Name
(Nod
)) = Spec
252 Append_Elmt
(Nod
, Call_List
);
255 -- Any other procedure call may have side effects
261 -- A call to a pure function can always be ignored
263 elsif Nkind
(Nod
) = N_Function_Call
264 and then Is_Entity_Name
(Name
(Nod
))
265 and then Is_Pure
(Entity
(Name
(Nod
)))
269 -- Case of an identifier reference
271 elsif Nkind
(Nod
) = N_Identifier
then
274 -- If no entity, then ignore the reference
276 -- Not clear why this can happen. To investigate, remove this
277 -- test and look at the crash that occurs here in 3401-004 ???
282 -- Ignore entities with no Scope, again not clear how this
283 -- can happen, to investigate, look at 4108-008 ???
285 elsif No
(Scope
(Ent
)) then
288 -- Ignore the reference if not to a more global object
290 elsif Scope_Depth
(Scope
(Ent
)) >= Scop
then
293 -- References to types, exceptions and constants are always OK
296 or else Ekind
(Ent
) = E_Exception
297 or else Ekind
(Ent
) = E_Constant
301 -- If other than a non-volatile scalar variable, we have some
302 -- kind of global reference (e.g. to a function) that we cannot
303 -- deal with so we forget the attempt.
305 elsif Ekind
(Ent
) /= E_Variable
306 or else not Is_Scalar_Type
(Etype
(Ent
))
307 or else Treat_As_Volatile
(Ent
)
311 -- Otherwise we have a reference to a global scalar
314 -- Loop through global entities already detected
316 Elm
:= First_Elmt
(Var_List
);
318 -- If not detected before, record this new global reference
321 Count_Vars
:= Count_Vars
+ 1;
323 if Count_Vars
<= Max_Vars
then
324 Append_Elmt
(Entity
(Nod
), Var_List
);
331 -- If recorded before, ignore
333 elsif Node
(Elm
) = Entity
(Nod
) then
336 -- Otherwise keep looking
346 -- For all other node kinds, recursively visit syntactic children
353 function Traverse_Body
is new Traverse_Func
;
355 -- Start of processing for Detect_Infinite_Recursion
358 -- Do not attempt detection in No_Implicit_Conditional mode,
359 -- since we won't be able to generate the code to handle the
360 -- recursion in any case.
362 if Restriction_Active
(No_Implicit_Conditionals
) then
366 -- Otherwise do traversal and quit if we get abandon signal
368 if Traverse_Body
(N
) = Abandon
then
371 -- We must have a call, since Has_Recursive_Call was set. If not
372 -- just ignore (this is only an error check, so if we have a funny
373 -- situation, due to bugs or errors, we do not want to bomb!)
375 elsif Is_Empty_Elmt_List
(Call_List
) then
379 -- Here is the case where we detect recursion at compile time
381 -- Push our current scope for analyzing the declarations and
382 -- code that we will insert for the checking.
386 -- This loop builds temporary variables for each of the
387 -- referenced globals, so that at the end of the loop the
388 -- list Shad_List contains these temporaries in one-to-one
389 -- correspondence with the elements in Var_List.
392 Elm
:= First_Elmt
(Var_List
);
393 while Present
(Elm
) loop
396 Make_Defining_Identifier
(Loc
,
397 Chars
=> New_Internal_Name
('S'));
398 Append_Elmt
(Ent
, Shad_List
);
400 -- Insert a declaration for this temporary at the start of
401 -- the declarations for the procedure. The temporaries are
402 -- declared as constant objects initialized to the current
403 -- values of the corresponding temporaries.
406 Make_Object_Declaration
(Loc
,
407 Defining_Identifier
=> Ent
,
408 Object_Definition
=> New_Occurrence_Of
(Etype
(Var
), Loc
),
409 Constant_Present
=> True,
410 Expression
=> New_Occurrence_Of
(Var
, Loc
));
413 Prepend
(Decl
, Declarations
(N
));
415 Insert_After
(Last
, Decl
);
423 -- Loop through calls
425 Call
:= First_Elmt
(Call_List
);
426 while Present
(Call
) loop
428 -- Build a predicate expression of the form
431 -- and then global1 = temp1
432 -- and then global2 = temp2
435 -- This predicate determines if any of the global values
436 -- referenced by the procedure have changed since the
437 -- current call, if not an infinite recursion is assured.
439 Test
:= New_Occurrence_Of
(Standard_True
, Loc
);
441 Elm1
:= First_Elmt
(Var_List
);
442 Elm2
:= First_Elmt
(Shad_List
);
443 while Present
(Elm1
) loop
449 Left_Opnd
=> New_Occurrence_Of
(Node
(Elm1
), Loc
),
450 Right_Opnd
=> New_Occurrence_Of
(Node
(Elm2
), Loc
)));
456 -- Now we replace the call with the sequence
458 -- if no-changes (see above) then
459 -- raise Storage_Error;
464 Rewrite
(Node
(Call
),
465 Make_If_Statement
(Loc
,
467 Then_Statements
=> New_List
(
468 Make_Raise_Storage_Error
(Loc
,
469 Reason
=> SE_Infinite_Recursion
)),
471 Else_Statements
=> New_List
(
472 Relocate_Node
(Node
(Call
)))));
474 Analyze
(Node
(Call
));
479 -- Remove temporary scope stack entry used for analysis
482 end Detect_Infinite_Recursion
;
488 procedure Expand_Actuals
(N
: Node_Id
; Subp
: Entity_Id
) is
489 Loc
: constant Source_Ptr
:= Sloc
(N
);
494 E_Formal
: Entity_Id
;
496 procedure Add_Call_By_Copy_Code
;
497 -- For cases where the parameter must be passed by copy, this routine
498 -- generates a temporary variable into which the actual is copied and
499 -- then passes this as the parameter. For an OUT or IN OUT parameter,
500 -- an assignment is also generated to copy the result back. The call
501 -- also takes care of any constraint checks required for the type
502 -- conversion case (on both the way in and the way out).
504 procedure Add_Packed_Call_By_Copy_Code
;
505 -- This is used when the actual involves a reference to an element
506 -- of a packed array, where we can appropriately use a simpler
507 -- approach than the full call by copy code. We just copy the value
508 -- in and out of an appropriate temporary.
510 procedure Check_Fortran_Logical
;
511 -- A value of type Logical that is passed through a formal parameter
512 -- must be normalized because .TRUE. usually does not have the same
513 -- representation as True. We assume that .FALSE. = False = 0.
514 -- What about functions that return a logical type ???
516 function Make_Var
(Actual
: Node_Id
) return Entity_Id
;
517 -- Returns an entity that refers to the given actual parameter,
518 -- Actual (not including any type conversion). If Actual is an
519 -- entity name, then this entity is returned unchanged, otherwise
520 -- a renaming is created to provide an entity for the actual.
522 procedure Reset_Packed_Prefix
;
523 -- The expansion of a packed array component reference is delayed in
524 -- the context of a call. Now we need to complete the expansion, so we
525 -- unmark the analyzed bits in all prefixes.
527 ---------------------------
528 -- Add_Call_By_Copy_Code --
529 ---------------------------
531 procedure Add_Call_By_Copy_Code
is
535 Indic
: Node_Id
:= New_Occurrence_Of
(Etype
(Formal
), Loc
);
537 F_Typ
: constant Entity_Id
:= Etype
(Formal
);
542 Temp
:= Make_Defining_Identifier
(Loc
, New_Internal_Name
('T'));
544 if Nkind
(Actual
) = N_Type_Conversion
then
545 V_Typ
:= Etype
(Expression
(Actual
));
547 -- If the formal is an (in-)out parameter, capture the name
548 -- of the variable in order to build the post-call assignment.
550 Var
:= Make_Var
(Expression
(Actual
));
552 Crep
:= not Same_Representation
553 (F_Typ
, Etype
(Expression
(Actual
)));
556 V_Typ
:= Etype
(Actual
);
557 Var
:= Make_Var
(Actual
);
561 -- Setup initialization for case of in out parameter, or an out
562 -- parameter where the formal is an unconstrained array (in the
563 -- latter case, we have to pass in an object with bounds).
565 -- If this is an out parameter, the initial copy is wasteful, so as
566 -- an optimization for the one-dimensional case we extract the
567 -- bounds of the actual and build an uninitialized temporary of the
570 if Ekind
(Formal
) = E_In_Out_Parameter
571 or else (Is_Array_Type
(F_Typ
) and then not Is_Constrained
(F_Typ
))
573 if Nkind
(Actual
) = N_Type_Conversion
then
574 if Conversion_OK
(Actual
) then
575 Init
:= OK_Convert_To
(F_Typ
, New_Occurrence_Of
(Var
, Loc
));
577 Init
:= Convert_To
(F_Typ
, New_Occurrence_Of
(Var
, Loc
));
580 elsif Ekind
(Formal
) = E_Out_Parameter
581 and then Is_Array_Type
(F_Typ
)
582 and then Number_Dimensions
(F_Typ
) = 1
583 and then not Has_Non_Null_Base_Init_Proc
(F_Typ
)
585 -- Actual is a one-dimensional array or slice, and the type
586 -- requires no initialization. Create a temporary of the
587 -- right size, but do copy actual into it (optimization).
591 Make_Subtype_Indication
(Loc
,
593 New_Occurrence_Of
(F_Typ
, Loc
),
595 Make_Index_Or_Discriminant_Constraint
(Loc
,
596 Constraints
=> New_List
(
599 Make_Attribute_Reference
(Loc
,
600 Prefix
=> New_Occurrence_Of
(Var
, Loc
),
601 Attribute_name
=> Name_First
),
603 Make_Attribute_Reference
(Loc
,
604 Prefix
=> New_Occurrence_Of
(Var
, Loc
),
605 Attribute_Name
=> Name_Last
)))));
608 Init
:= New_Occurrence_Of
(Var
, Loc
);
611 -- An initialization is created for packed conversions as
612 -- actuals for out parameters to enable Make_Object_Declaration
613 -- to determine the proper subtype for N_Node. Note that this
614 -- is wasteful because the extra copying on the call side is
615 -- not required for such out parameters. ???
617 elsif Ekind
(Formal
) = E_Out_Parameter
618 and then Nkind
(Actual
) = N_Type_Conversion
619 and then (Is_Bit_Packed_Array
(F_Typ
)
621 Is_Bit_Packed_Array
(Etype
(Expression
(Actual
))))
623 if Conversion_OK
(Actual
) then
625 OK_Convert_To
(F_Typ
, New_Occurrence_Of
(Var
, Loc
));
628 Convert_To
(F_Typ
, New_Occurrence_Of
(Var
, Loc
));
631 elsif Ekind
(Formal
) = E_In_Parameter
then
632 Init
:= New_Occurrence_Of
(Var
, Loc
);
639 Make_Object_Declaration
(Loc
,
640 Defining_Identifier
=> Temp
,
641 Object_Definition
=> Indic
,
643 Set_Assignment_OK
(N_Node
);
644 Insert_Action
(N
, N_Node
);
646 -- Now, normally the deal here is that we use the defining
647 -- identifier created by that object declaration. There is
648 -- one exception to this. In the change of representation case
649 -- the above declaration will end up looking like:
651 -- temp : type := identifier;
653 -- And in this case we might as well use the identifier directly
654 -- and eliminate the temporary. Note that the analysis of the
655 -- declaration was not a waste of time in that case, since it is
656 -- what generated the necessary change of representation code. If
657 -- the change of representation introduced additional code, as in
658 -- a fixed-integer conversion, the expression is not an identifier
662 and then Present
(Expression
(N_Node
))
663 and then Is_Entity_Name
(Expression
(N_Node
))
665 Temp
:= Entity
(Expression
(N_Node
));
666 Rewrite
(N_Node
, Make_Null_Statement
(Loc
));
669 -- For IN parameter, all we do is to replace the actual
671 if Ekind
(Formal
) = E_In_Parameter
then
672 Rewrite
(Actual
, New_Reference_To
(Temp
, Loc
));
675 -- Processing for OUT or IN OUT parameter
678 -- If type conversion, use reverse conversion on exit
680 if Nkind
(Actual
) = N_Type_Conversion
then
681 if Conversion_OK
(Actual
) then
682 Expr
:= OK_Convert_To
(V_Typ
, New_Occurrence_Of
(Temp
, Loc
));
684 Expr
:= Convert_To
(V_Typ
, New_Occurrence_Of
(Temp
, Loc
));
687 Expr
:= New_Occurrence_Of
(Temp
, Loc
);
690 Rewrite
(Actual
, New_Reference_To
(Temp
, Loc
));
693 Append_To
(Post_Call
,
694 Make_Assignment_Statement
(Loc
,
695 Name
=> New_Occurrence_Of
(Var
, Loc
),
696 Expression
=> Expr
));
698 Set_Assignment_OK
(Name
(Last
(Post_Call
)));
700 end Add_Call_By_Copy_Code
;
702 ----------------------------------
703 -- Add_Packed_Call_By_Copy_Code --
704 ----------------------------------
706 procedure Add_Packed_Call_By_Copy_Code
is
716 -- Prepare to generate code
718 Temp
:= Make_Defining_Identifier
(Loc
, New_Internal_Name
('T'));
719 Incod
:= Relocate_Node
(Actual
);
720 Outcod
:= New_Copy_Tree
(Incod
);
722 -- Generate declaration of temporary variable, initializing it
723 -- with the input parameter unless we have an OUT variable.
725 if Ekind
(Formal
) = E_Out_Parameter
then
730 Make_Object_Declaration
(Loc
,
731 Defining_Identifier
=> Temp
,
733 New_Occurrence_Of
(Etype
(Formal
), Loc
),
734 Expression
=> Incod
));
736 -- The actual is simply a reference to the temporary
738 Rewrite
(Actual
, New_Occurrence_Of
(Temp
, Loc
));
740 -- Generate copy out if OUT or IN OUT parameter
742 if Ekind
(Formal
) /= E_In_Parameter
then
744 Rhs
:= New_Occurrence_Of
(Temp
, Loc
);
746 -- Deal with conversion
748 if Nkind
(Lhs
) = N_Type_Conversion
then
749 Lhs
:= Expression
(Lhs
);
750 Rhs
:= Convert_To
(Etype
(Actual
), Rhs
);
753 Append_To
(Post_Call
,
754 Make_Assignment_Statement
(Loc
,
758 end Add_Packed_Call_By_Copy_Code
;
760 ---------------------------
761 -- Check_Fortran_Logical --
762 ---------------------------
764 procedure Check_Fortran_Logical
is
765 Logical
: constant Entity_Id
:= Etype
(Formal
);
768 -- Note: this is very incomplete, e.g. it does not handle arrays
769 -- of logical values. This is really not the right approach at all???)
772 if Convention
(Subp
) = Convention_Fortran
773 and then Root_Type
(Etype
(Formal
)) = Standard_Boolean
774 and then Ekind
(Formal
) /= E_In_Parameter
776 Var
:= Make_Var
(Actual
);
777 Append_To
(Post_Call
,
778 Make_Assignment_Statement
(Loc
,
779 Name
=> New_Occurrence_Of
(Var
, Loc
),
781 Unchecked_Convert_To
(
784 Left_Opnd
=> New_Occurrence_Of
(Var
, Loc
),
786 Unchecked_Convert_To
(
788 New_Occurrence_Of
(Standard_False
, Loc
))))));
790 end Check_Fortran_Logical
;
796 function Make_Var
(Actual
: Node_Id
) return Entity_Id
is
800 if Is_Entity_Name
(Actual
) then
801 return Entity
(Actual
);
804 Var
:= Make_Defining_Identifier
(Loc
, New_Internal_Name
('T'));
807 Make_Object_Renaming_Declaration
(Loc
,
808 Defining_Identifier
=> Var
,
810 New_Occurrence_Of
(Etype
(Actual
), Loc
),
811 Name
=> Relocate_Node
(Actual
));
813 Insert_Action
(N
, N_Node
);
818 -------------------------
819 -- Reset_Packed_Prefix --
820 -------------------------
822 procedure Reset_Packed_Prefix
is
823 Pfx
: Node_Id
:= Actual
;
827 Set_Analyzed
(Pfx
, False);
828 exit when Nkind
(Pfx
) /= N_Selected_Component
829 and then Nkind
(Pfx
) /= N_Indexed_Component
;
832 end Reset_Packed_Prefix
;
834 -- Start of processing for Expand_Actuals
837 Formal
:= First_Formal
(Subp
);
838 Actual
:= First_Actual
(N
);
840 Post_Call
:= New_List
;
842 while Present
(Formal
) loop
843 E_Formal
:= Etype
(Formal
);
845 if Is_Scalar_Type
(E_Formal
)
846 or else Nkind
(Actual
) = N_Slice
848 Check_Fortran_Logical
;
852 elsif Ekind
(Formal
) /= E_Out_Parameter
then
854 -- The unusual case of the current instance of a protected type
855 -- requires special handling. This can only occur in the context
856 -- of a call within the body of a protected operation.
858 if Is_Entity_Name
(Actual
)
859 and then Ekind
(Entity
(Actual
)) = E_Protected_Type
860 and then In_Open_Scopes
(Entity
(Actual
))
862 if Scope
(Subp
) /= Entity
(Actual
) then
863 Error_Msg_N
("operation outside protected type may not "
864 & "call back its protected operations?", Actual
);
868 Expand_Protected_Object_Reference
(N
, Entity
(Actual
)));
871 Apply_Constraint_Check
(Actual
, E_Formal
);
873 -- Out parameter case. No constraint checks on access type
876 elsif Is_Access_Type
(E_Formal
) then
881 elsif Has_Discriminants
(Base_Type
(E_Formal
))
882 or else Has_Non_Null_Base_Init_Proc
(E_Formal
)
884 Apply_Constraint_Check
(Actual
, E_Formal
);
889 Apply_Constraint_Check
(Actual
, Base_Type
(E_Formal
));
892 -- Processing for IN-OUT and OUT parameters
894 if Ekind
(Formal
) /= E_In_Parameter
then
896 -- For type conversions of arrays, apply length/range checks
898 if Is_Array_Type
(E_Formal
)
899 and then Nkind
(Actual
) = N_Type_Conversion
901 if Is_Constrained
(E_Formal
) then
902 Apply_Length_Check
(Expression
(Actual
), E_Formal
);
904 Apply_Range_Check
(Expression
(Actual
), E_Formal
);
908 -- If argument is a type conversion for a type that is passed
909 -- by copy, then we must pass the parameter by copy.
911 if Nkind
(Actual
) = N_Type_Conversion
913 (Is_Numeric_Type
(E_Formal
)
914 or else Is_Access_Type
(E_Formal
)
915 or else Is_Enumeration_Type
(E_Formal
)
916 or else Is_Bit_Packed_Array
(Etype
(Formal
))
917 or else Is_Bit_Packed_Array
(Etype
(Expression
(Actual
)))
919 -- Also pass by copy if change of representation
921 or else not Same_Representation
923 Etype
(Expression
(Actual
))))
925 Add_Call_By_Copy_Code
;
927 -- References to components of bit packed arrays are expanded
928 -- at this point, rather than at the point of analysis of the
929 -- actuals, to handle the expansion of the assignment to
930 -- [in] out parameters.
932 elsif Is_Ref_To_Bit_Packed_Array
(Actual
) then
933 Add_Packed_Call_By_Copy_Code
;
935 -- References to slices of bit packed arrays are expanded
937 elsif Is_Ref_To_Bit_Packed_Slice
(Actual
) then
938 Add_Call_By_Copy_Code
;
940 -- References to possibly unaligned slices of arrays are expanded
942 elsif Is_Possibly_Unaligned_Slice
(Actual
) then
943 Add_Call_By_Copy_Code
;
945 -- Deal with access types where the actual subtpe and the
946 -- formal subtype are not the same, requiring a check.
948 -- It is necessary to exclude tagged types because of "downward
949 -- conversion" errors and a strange assertion error in namet
950 -- from gnatf in bug 1215-001 ???
952 elsif Is_Access_Type
(E_Formal
)
953 and then not Same_Type
(E_Formal
, Etype
(Actual
))
954 and then not Is_Tagged_Type
(Designated_Type
(E_Formal
))
956 Add_Call_By_Copy_Code
;
958 elsif Is_Entity_Name
(Actual
)
959 and then Treat_As_Volatile
(Entity
(Actual
))
960 and then not Is_Scalar_Type
(Etype
(Entity
(Actual
)))
961 and then not Treat_As_Volatile
(E_Formal
)
963 Add_Call_By_Copy_Code
;
965 elsif Nkind
(Actual
) = N_Indexed_Component
966 and then Is_Entity_Name
(Prefix
(Actual
))
967 and then Has_Volatile_Components
(Entity
(Prefix
(Actual
)))
969 Add_Call_By_Copy_Code
;
972 -- Processing for IN parameters
975 -- For IN parameters is in the packed array case, we expand an
976 -- indexed component (the circuit in Exp_Ch4 deliberately left
977 -- indexed components appearing as actuals untouched, so that
978 -- the special processing above for the OUT and IN OUT cases
979 -- could be performed. We could make the test in Exp_Ch4 more
980 -- complex and have it detect the parameter mode, but it is
981 -- easier simply to handle all cases here.
983 if Nkind
(Actual
) = N_Indexed_Component
984 and then Is_Packed
(Etype
(Prefix
(Actual
)))
987 Expand_Packed_Element_Reference
(Actual
);
989 -- If we have a reference to a bit packed array, we copy it,
990 -- since the actual must be byte aligned.
992 -- Is this really necessary in all cases???
994 elsif Is_Ref_To_Bit_Packed_Array
(Actual
) then
995 Add_Packed_Call_By_Copy_Code
;
997 -- Similarly, we have to expand slices of packed arrays here
998 -- because the result must be byte aligned.
1000 elsif Is_Ref_To_Bit_Packed_Slice
(Actual
) then
1001 Add_Call_By_Copy_Code
;
1003 -- Only processing remaining is to pass by copy if this is a
1004 -- reference to a possibly unaligned slice, since the caller
1005 -- expects an appropriately aligned argument.
1007 elsif Is_Possibly_Unaligned_Slice
(Actual
) then
1008 Add_Call_By_Copy_Code
;
1012 Next_Formal
(Formal
);
1013 Next_Actual
(Actual
);
1016 -- Find right place to put post call stuff if it is present
1018 if not Is_Empty_List
(Post_Call
) then
1020 -- If call is not a list member, it must be the triggering
1021 -- statement of a triggering alternative or an entry call
1022 -- alternative, and we can add the post call stuff to the
1023 -- corresponding statement list.
1025 if not Is_List_Member
(N
) then
1027 P
: constant Node_Id
:= Parent
(N
);
1030 pragma Assert
(Nkind
(P
) = N_Triggering_Alternative
1031 or else Nkind
(P
) = N_Entry_Call_Alternative
);
1033 if Is_Non_Empty_List
(Statements
(P
)) then
1034 Insert_List_Before_And_Analyze
1035 (First
(Statements
(P
)), Post_Call
);
1037 Set_Statements
(P
, Post_Call
);
1041 -- Otherwise, normal case where N is in a statement sequence,
1042 -- just put the post-call stuff after the call statement.
1045 Insert_Actions_After
(N
, Post_Call
);
1049 -- The call node itself is re-analyzed in Expand_Call.
1057 -- This procedure handles expansion of function calls and procedure call
1058 -- statements (i.e. it serves as the body for Expand_N_Function_Call and
1059 -- Expand_N_Procedure_Call_Statement. Processing for calls includes:
1061 -- Replace call to Raise_Exception by Raise_Exception always if possible
1062 -- Provide values of actuals for all formals in Extra_Formals list
1063 -- Replace "call" to enumeration literal function by literal itself
1064 -- Rewrite call to predefined operator as operator
1065 -- Replace actuals to in-out parameters that are numeric conversions,
1066 -- with explicit assignment to temporaries before and after the call.
1067 -- Remove optional actuals if First_Optional_Parameter specified.
1069 -- Note that the list of actuals has been filled with default expressions
1070 -- during semantic analysis of the call. Only the extra actuals required
1071 -- for the 'Constrained attribute and for accessibility checks are added
1074 procedure Expand_Call
(N
: Node_Id
) is
1075 Loc
: constant Source_Ptr
:= Sloc
(N
);
1076 Remote
: constant Boolean := Is_Remote_Call
(N
);
1078 Orig_Subp
: Entity_Id
:= Empty
;
1079 Parent_Subp
: Entity_Id
;
1080 Parent_Formal
: Entity_Id
;
1083 Prev
: Node_Id
:= Empty
;
1084 Prev_Orig
: Node_Id
;
1086 Extra_Actuals
: List_Id
:= No_List
;
1089 procedure Add_Actual_Parameter
(Insert_Param
: Node_Id
);
1090 -- Adds one entry to the end of the actual parameter list. Used for
1091 -- default parameters and for extra actuals (for Extra_Formals).
1092 -- The argument is an N_Parameter_Association node.
1094 procedure Add_Extra_Actual
(Expr
: Node_Id
; EF
: Entity_Id
);
1095 -- Adds an extra actual to the list of extra actuals. Expr
1096 -- is the expression for the value of the actual, EF is the
1097 -- entity for the extra formal.
1099 function Inherited_From_Formal
(S
: Entity_Id
) return Entity_Id
;
1100 -- Within an instance, a type derived from a non-tagged formal derived
1101 -- type inherits from the original parent, not from the actual. This is
1102 -- tested in 4723-003. The current derivation mechanism has the derived
1103 -- type inherit from the actual, which is only correct outside of the
1104 -- instance. If the subprogram is inherited, we test for this particular
1105 -- case through a convoluted tree traversal before setting the proper
1106 -- subprogram to be called.
1108 --------------------------
1109 -- Add_Actual_Parameter --
1110 --------------------------
1112 procedure Add_Actual_Parameter
(Insert_Param
: Node_Id
) is
1113 Actual_Expr
: constant Node_Id
:=
1114 Explicit_Actual_Parameter
(Insert_Param
);
1117 -- Case of insertion is first named actual
1119 if No
(Prev
) or else
1120 Nkind
(Parent
(Prev
)) /= N_Parameter_Association
1122 Set_Next_Named_Actual
(Insert_Param
, First_Named_Actual
(N
));
1123 Set_First_Named_Actual
(N
, Actual_Expr
);
1126 if not Present
(Parameter_Associations
(N
)) then
1127 Set_Parameter_Associations
(N
, New_List
);
1128 Append
(Insert_Param
, Parameter_Associations
(N
));
1131 Insert_After
(Prev
, Insert_Param
);
1134 -- Case of insertion is not first named actual
1137 Set_Next_Named_Actual
1138 (Insert_Param
, Next_Named_Actual
(Parent
(Prev
)));
1139 Set_Next_Named_Actual
(Parent
(Prev
), Actual_Expr
);
1140 Append
(Insert_Param
, Parameter_Associations
(N
));
1143 Prev
:= Actual_Expr
;
1144 end Add_Actual_Parameter
;
1146 ----------------------
1147 -- Add_Extra_Actual --
1148 ----------------------
1150 procedure Add_Extra_Actual
(Expr
: Node_Id
; EF
: Entity_Id
) is
1151 Loc
: constant Source_Ptr
:= Sloc
(Expr
);
1154 if Extra_Actuals
= No_List
then
1155 Extra_Actuals
:= New_List
;
1156 Set_Parent
(Extra_Actuals
, N
);
1159 Append_To
(Extra_Actuals
,
1160 Make_Parameter_Association
(Loc
,
1161 Explicit_Actual_Parameter
=> Expr
,
1163 Make_Identifier
(Loc
, Chars
(EF
))));
1165 Analyze_And_Resolve
(Expr
, Etype
(EF
));
1166 end Add_Extra_Actual
;
1168 ---------------------------
1169 -- Inherited_From_Formal --
1170 ---------------------------
1172 function Inherited_From_Formal
(S
: Entity_Id
) return Entity_Id
is
1174 Gen_Par
: Entity_Id
;
1175 Gen_Prim
: Elist_Id
;
1180 -- If the operation is inherited, it is attached to the corresponding
1181 -- type derivation. If the parent in the derivation is a generic
1182 -- actual, it is a subtype of the actual, and we have to recover the
1183 -- original derived type declaration to find the proper parent.
1185 if Nkind
(Parent
(S
)) /= N_Full_Type_Declaration
1186 or else not Is_Derived_Type
(Defining_Identifier
(Parent
(S
)))
1187 or else Nkind
(Type_Definition
(Original_Node
(Parent
(S
))))
1188 /= N_Derived_Type_Definition
1189 or else not In_Instance
1196 (Type_Definition
(Original_Node
(Parent
(S
)))));
1198 if Nkind
(Indic
) = N_Subtype_Indication
then
1199 Par
:= Entity
(Subtype_Mark
(Indic
));
1201 Par
:= Entity
(Indic
);
1205 if not Is_Generic_Actual_Type
(Par
)
1206 or else Is_Tagged_Type
(Par
)
1207 or else Nkind
(Parent
(Par
)) /= N_Subtype_Declaration
1208 or else not In_Open_Scopes
(Scope
(Par
))
1213 Gen_Par
:= Generic_Parent_Type
(Parent
(Par
));
1216 -- If the generic parent type is still the generic type, this
1217 -- is a private formal, not a derived formal, and there are no
1218 -- operations inherited from the formal.
1220 if Nkind
(Parent
(Gen_Par
)) = N_Formal_Type_Declaration
then
1224 Gen_Prim
:= Collect_Primitive_Operations
(Gen_Par
);
1225 Elmt
:= First_Elmt
(Gen_Prim
);
1227 while Present
(Elmt
) loop
1228 if Chars
(Node
(Elmt
)) = Chars
(S
) then
1234 F1
:= First_Formal
(S
);
1235 F2
:= First_Formal
(Node
(Elmt
));
1238 and then Present
(F2
)
1241 if Etype
(F1
) = Etype
(F2
)
1242 or else Etype
(F2
) = Gen_Par
1248 exit; -- not the right subprogram
1260 raise Program_Error
;
1261 end Inherited_From_Formal
;
1263 -- Start of processing for Expand_Call
1266 -- Ignore if previous error
1268 if Nkind
(N
) in N_Has_Etype
and then Etype
(N
) = Any_Type
then
1272 -- Call using access to subprogram with explicit dereference
1274 if Nkind
(Name
(N
)) = N_Explicit_Dereference
then
1275 Subp
:= Etype
(Name
(N
));
1276 Parent_Subp
:= Empty
;
1278 -- Case of call to simple entry, where the Name is a selected component
1279 -- whose prefix is the task, and whose selector name is the entry name
1281 elsif Nkind
(Name
(N
)) = N_Selected_Component
then
1282 Subp
:= Entity
(Selector_Name
(Name
(N
)));
1283 Parent_Subp
:= Empty
;
1285 -- Case of call to member of entry family, where Name is an indexed
1286 -- component, with the prefix being a selected component giving the
1287 -- task and entry family name, and the index being the entry index.
1289 elsif Nkind
(Name
(N
)) = N_Indexed_Component
then
1290 Subp
:= Entity
(Selector_Name
(Prefix
(Name
(N
))));
1291 Parent_Subp
:= Empty
;
1296 Subp
:= Entity
(Name
(N
));
1297 Parent_Subp
:= Alias
(Subp
);
1299 -- Replace call to Raise_Exception by call to Raise_Exception_Always
1300 -- if we can tell that the first parameter cannot possibly be null.
1301 -- This helps optimization and also generation of warnings.
1303 if not Restriction_Active
(No_Exception_Handlers
)
1304 and then Is_RTE
(Subp
, RE_Raise_Exception
)
1307 FA
: constant Node_Id
:= Original_Node
(First_Actual
(N
));
1310 -- The case we catch is where the first argument is obtained
1311 -- using the Identity attribute (which must always be non-null)
1313 if Nkind
(FA
) = N_Attribute_Reference
1314 and then Attribute_Name
(FA
) = Name_Identity
1316 Subp
:= RTE
(RE_Raise_Exception_Always
);
1317 Set_Entity
(Name
(N
), Subp
);
1322 if Ekind
(Subp
) = E_Entry
then
1323 Parent_Subp
:= Empty
;
1327 -- First step, compute extra actuals, corresponding to any
1328 -- Extra_Formals present. Note that we do not access Extra_Formals
1329 -- directly, instead we simply note the presence of the extra
1330 -- formals as we process the regular formals and collect the
1331 -- corresponding actuals in Extra_Actuals.
1333 -- We also generate any required range checks for actuals as we go
1334 -- through the loop, since this is a convenient place to do this.
1336 Formal
:= First_Formal
(Subp
);
1337 Actual
:= First_Actual
(N
);
1338 while Present
(Formal
) loop
1340 -- Generate range check if required (not activated yet ???)
1342 -- if Do_Range_Check (Actual) then
1343 -- Set_Do_Range_Check (Actual, False);
1344 -- Generate_Range_Check
1345 -- (Actual, Etype (Formal), CE_Range_Check_Failed);
1348 -- Prepare to examine current entry
1351 Prev_Orig
:= Original_Node
(Prev
);
1353 -- Create possible extra actual for constrained case. Usually,
1354 -- the extra actual is of the form actual'constrained, but since
1355 -- this attribute is only available for unconstrained records,
1356 -- TRUE is expanded if the type of the formal happens to be
1357 -- constrained (for instance when this procedure is inherited
1358 -- from an unconstrained record to a constrained one) or if the
1359 -- actual has no discriminant (its type is constrained). An
1360 -- exception to this is the case of a private type without
1361 -- discriminants. In this case we pass FALSE because the
1362 -- object has underlying discriminants with defaults.
1364 if Present
(Extra_Constrained
(Formal
)) then
1365 if Ekind
(Etype
(Prev
)) in Private_Kind
1366 and then not Has_Discriminants
(Base_Type
(Etype
(Prev
)))
1369 New_Occurrence_Of
(Standard_False
, Loc
),
1370 Extra_Constrained
(Formal
));
1372 elsif Is_Constrained
(Etype
(Formal
))
1373 or else not Has_Discriminants
(Etype
(Prev
))
1376 New_Occurrence_Of
(Standard_True
, Loc
),
1377 Extra_Constrained
(Formal
));
1379 -- Do not produce extra actuals for Unchecked_Union parameters.
1380 -- Jump directly to the end of the loop.
1382 elsif Is_Unchecked_Union
(Base_Type
(Etype
(Actual
))) then
1383 goto Skip_Extra_Actual_Generation
;
1386 -- If the actual is a type conversion, then the constrained
1387 -- test applies to the actual, not the target type.
1390 Act_Prev
: Node_Id
:= Prev
;
1393 -- Test for unchecked conversions as well, which can
1394 -- occur as out parameter actuals on calls to stream
1397 while Nkind
(Act_Prev
) = N_Type_Conversion
1398 or else Nkind
(Act_Prev
) = N_Unchecked_Type_Conversion
1400 Act_Prev
:= Expression
(Act_Prev
);
1404 Make_Attribute_Reference
(Sloc
(Prev
),
1406 Duplicate_Subexpr_No_Checks
1407 (Act_Prev
, Name_Req
=> True),
1408 Attribute_Name
=> Name_Constrained
),
1409 Extra_Constrained
(Formal
));
1414 -- Create possible extra actual for accessibility level
1416 if Present
(Extra_Accessibility
(Formal
)) then
1417 if Is_Entity_Name
(Prev_Orig
) then
1419 -- When passing an access parameter as the actual to another
1420 -- access parameter we need to pass along the actual's own
1421 -- associated access level parameter. This is done if we are
1422 -- in the scope of the formal access parameter (if this is an
1423 -- inlined body the extra formal is irrelevant).
1425 if Ekind
(Entity
(Prev_Orig
)) in Formal_Kind
1426 and then Ekind
(Etype
(Prev_Orig
)) = E_Anonymous_Access_Type
1427 and then In_Open_Scopes
(Scope
(Entity
(Prev_Orig
)))
1430 Parm_Ent
: constant Entity_Id
:= Param_Entity
(Prev_Orig
);
1433 pragma Assert
(Present
(Parm_Ent
));
1435 if Present
(Extra_Accessibility
(Parm_Ent
)) then
1438 (Extra_Accessibility
(Parm_Ent
), Loc
),
1439 Extra_Accessibility
(Formal
));
1441 -- If the actual access parameter does not have an
1442 -- associated extra formal providing its scope level,
1443 -- then treat the actual as having library-level
1448 Make_Integer_Literal
(Loc
,
1449 Intval
=> Scope_Depth
(Standard_Standard
)),
1450 Extra_Accessibility
(Formal
));
1454 -- The actual is a normal access value, so just pass the
1455 -- level of the actual's access type.
1459 Make_Integer_Literal
(Loc
,
1460 Intval
=> Type_Access_Level
(Etype
(Prev_Orig
))),
1461 Extra_Accessibility
(Formal
));
1465 case Nkind
(Prev_Orig
) is
1467 when N_Attribute_Reference
=>
1469 case Get_Attribute_Id
(Attribute_Name
(Prev_Orig
)) is
1471 -- For X'Access, pass on the level of the prefix X
1473 when Attribute_Access
=>
1475 Make_Integer_Literal
(Loc
,
1477 Object_Access_Level
(Prefix
(Prev_Orig
))),
1478 Extra_Accessibility
(Formal
));
1480 -- Treat the unchecked attributes as library-level
1482 when Attribute_Unchecked_Access |
1483 Attribute_Unrestricted_Access
=>
1485 Make_Integer_Literal
(Loc
,
1486 Intval
=> Scope_Depth
(Standard_Standard
)),
1487 Extra_Accessibility
(Formal
));
1489 -- No other cases of attributes returning access
1490 -- values that can be passed to access parameters
1493 raise Program_Error
;
1497 -- For allocators we pass the level of the execution of
1498 -- the called subprogram, which is one greater than the
1499 -- current scope level.
1503 Make_Integer_Literal
(Loc
,
1504 Scope_Depth
(Current_Scope
) + 1),
1505 Extra_Accessibility
(Formal
));
1507 -- For other cases we simply pass the level of the
1508 -- actual's access type.
1512 Make_Integer_Literal
(Loc
,
1513 Intval
=> Type_Access_Level
(Etype
(Prev_Orig
))),
1514 Extra_Accessibility
(Formal
));
1520 -- Perform the check of 4.6(49) that prevents a null value
1521 -- from being passed as an actual to an access parameter.
1522 -- Note that the check is elided in the common cases of
1523 -- passing an access attribute or access parameter as an
1524 -- actual. Also, we currently don't enforce this check for
1525 -- expander-generated actuals and when -gnatdj is set.
1527 if Ekind
(Etype
(Formal
)) /= E_Anonymous_Access_Type
1528 or else Access_Checks_Suppressed
(Subp
)
1532 elsif Debug_Flag_J
then
1535 elsif not Comes_From_Source
(Prev
) then
1538 elsif Is_Entity_Name
(Prev
)
1539 and then Ekind
(Etype
(Prev
)) = E_Anonymous_Access_Type
1543 elsif Nkind
(Prev
) = N_Allocator
1544 or else Nkind
(Prev
) = N_Attribute_Reference
1548 -- Suppress null checks when passing to access parameters
1549 -- of Java subprograms. (Should this be done for other
1550 -- foreign conventions as well ???)
1552 elsif Convention
(Subp
) = Convention_Java
then
1555 -- Ada 2005 (AI-231): do not force the check in case of Ada 2005
1556 -- unless it is a null-excluding type
1558 elsif Ada_Version
< Ada_05
1559 or else Can_Never_Be_Null
(Etype
(Prev
))
1563 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Prev
),
1564 Right_Opnd
=> Make_Null
(Loc
));
1565 Insert_Action
(Prev
,
1566 Make_Raise_Constraint_Error
(Loc
,
1568 Reason
=> CE_Access_Parameter_Is_Null
));
1571 -- Perform appropriate validity checks on parameters that
1574 if Validity_Checks_On
then
1575 if (Ekind
(Formal
) = E_In_Parameter
1576 and then Validity_Check_In_Params
)
1578 (Ekind
(Formal
) = E_In_Out_Parameter
1579 and then Validity_Check_In_Out_Params
)
1581 -- If the actual is an indexed component of a packed
1582 -- type, it has not been expanded yet. It will be
1583 -- copied in the validity code that follows, and has
1584 -- to be expanded appropriately, so reanalyze it.
1586 if Nkind
(Actual
) = N_Indexed_Component
then
1587 Set_Analyzed
(Actual
, False);
1590 Ensure_Valid
(Actual
);
1594 -- For IN OUT and OUT parameters, ensure that subscripts are valid
1595 -- since this is a left side reference. We only do this for calls
1596 -- from the source program since we assume that compiler generated
1597 -- calls explicitly generate any required checks. We also need it
1598 -- only if we are doing standard validity checks, since clearly it
1599 -- is not needed if validity checks are off, and in subscript
1600 -- validity checking mode, all indexed components are checked with
1601 -- a call directly from Expand_N_Indexed_Component.
1603 if Comes_From_Source
(N
)
1604 and then Ekind
(Formal
) /= E_In_Parameter
1605 and then Validity_Checks_On
1606 and then Validity_Check_Default
1607 and then not Validity_Check_Subscripts
1609 Check_Valid_Lvalue_Subscripts
(Actual
);
1612 -- Mark any scalar OUT parameter that is a simple variable
1613 -- as no longer known to be valid (unless the type is always
1614 -- valid). This reflects the fact that if an OUT parameter
1615 -- is never set in a procedure, then it can become invalid
1616 -- on return from the procedure.
1618 if Ekind
(Formal
) = E_Out_Parameter
1619 and then Is_Entity_Name
(Actual
)
1620 and then Ekind
(Entity
(Actual
)) = E_Variable
1621 and then not Is_Known_Valid
(Etype
(Actual
))
1623 Set_Is_Known_Valid
(Entity
(Actual
), False);
1626 -- For an OUT or IN OUT parameter of an access type, if the
1627 -- actual is an entity, then it is no longer known to be non-null.
1629 if Ekind
(Formal
) /= E_In_Parameter
1630 and then Is_Entity_Name
(Actual
)
1631 and then Is_Access_Type
(Etype
(Actual
))
1633 Set_Is_Known_Non_Null
(Entity
(Actual
), False);
1636 -- If the formal is class wide and the actual is an aggregate, force
1637 -- evaluation so that the back end who does not know about class-wide
1638 -- type, does not generate a temporary of the wrong size.
1640 if not Is_Class_Wide_Type
(Etype
(Formal
)) then
1643 elsif Nkind
(Actual
) = N_Aggregate
1644 or else (Nkind
(Actual
) = N_Qualified_Expression
1645 and then Nkind
(Expression
(Actual
)) = N_Aggregate
)
1647 Force_Evaluation
(Actual
);
1650 -- In a remote call, if the formal is of a class-wide type, check
1651 -- that the actual meets the requirements described in E.4(18).
1654 and then Is_Class_Wide_Type
(Etype
(Formal
))
1656 Insert_Action
(Actual
,
1657 Make_Implicit_If_Statement
(N
,
1660 Get_Remotely_Callable
1661 (Duplicate_Subexpr_Move_Checks
(Actual
))),
1662 Then_Statements
=> New_List
(
1663 Make_Raise_Program_Error
(Loc
,
1664 Reason
=> PE_Illegal_RACW_E_4_18
))));
1667 -- This label is required when skipping extra actual generation for
1668 -- Unchecked_Union parameters.
1670 <<Skip_Extra_Actual_Generation
>>
1672 Next_Actual
(Actual
);
1673 Next_Formal
(Formal
);
1676 -- If we are expanding a rhs of an assignement we need to check if
1677 -- tag propagation is needed. This code belongs theorically in Analyze
1678 -- Assignment but has to be done earlier (bottom-up) because the
1679 -- assignment might be transformed into a declaration for an uncons-
1680 -- trained value, if the expression is classwide.
1682 if Nkind
(N
) = N_Function_Call
1683 and then Is_Tag_Indeterminate
(N
)
1684 and then Is_Entity_Name
(Name
(N
))
1687 Ass
: Node_Id
:= Empty
;
1690 if Nkind
(Parent
(N
)) = N_Assignment_Statement
then
1693 elsif Nkind
(Parent
(N
)) = N_Qualified_Expression
1694 and then Nkind
(Parent
(Parent
(N
))) = N_Assignment_Statement
1696 Ass
:= Parent
(Parent
(N
));
1700 and then Is_Class_Wide_Type
(Etype
(Name
(Ass
)))
1702 if Etype
(N
) /= Root_Type
(Etype
(Name
(Ass
))) then
1704 ("tag-indeterminate expression must have type&"
1705 & "('R'M 5.2 (6))", N
, Root_Type
(Etype
(Name
(Ass
))));
1707 Propagate_Tag
(Name
(Ass
), N
);
1710 -- The call will be rewritten as a dispatching call, and
1711 -- expanded as such.
1718 -- Deals with Dispatch_Call if we still have a call, before expanding
1719 -- extra actuals since this will be done on the re-analysis of the
1720 -- dispatching call. Note that we do not try to shorten the actual
1721 -- list for a dispatching call, it would not make sense to do so.
1722 -- Expansion of dispatching calls is suppressed when Java_VM, because
1723 -- the JVM back end directly handles the generation of dispatching
1724 -- calls and would have to undo any expansion to an indirect call.
1726 if (Nkind
(N
) = N_Function_Call
1727 or else Nkind
(N
) = N_Procedure_Call_Statement
)
1728 and then Present
(Controlling_Argument
(N
))
1729 and then not Java_VM
1731 Expand_Dispatch_Call
(N
);
1733 -- The following return is worrisome. Is it really OK to
1734 -- skip all remaining processing in this procedure ???
1738 -- Similarly, expand calls to RCI subprograms on which pragma
1739 -- All_Calls_Remote applies. The rewriting will be reanalyzed
1740 -- later. Do this only when the call comes from source since we do
1741 -- not want such a rewritting to occur in expanded code.
1743 elsif Is_All_Remote_Call
(N
) then
1744 Expand_All_Calls_Remote_Subprogram_Call
(N
);
1746 -- Similarly, do not add extra actuals for an entry call whose entity
1747 -- is a protected procedure, or for an internal protected subprogram
1748 -- call, because it will be rewritten as a protected subprogram call
1749 -- and reanalyzed (see Expand_Protected_Subprogram_Call).
1751 elsif Is_Protected_Type
(Scope
(Subp
))
1752 and then (Ekind
(Subp
) = E_Procedure
1753 or else Ekind
(Subp
) = E_Function
)
1757 -- During that loop we gathered the extra actuals (the ones that
1758 -- correspond to Extra_Formals), so now they can be appended.
1761 while Is_Non_Empty_List
(Extra_Actuals
) loop
1762 Add_Actual_Parameter
(Remove_Head
(Extra_Actuals
));
1766 if Ekind
(Subp
) = E_Procedure
1767 or else (Ekind
(Subp
) = E_Subprogram_Type
1768 and then Etype
(Subp
) = Standard_Void_Type
)
1769 or else Is_Entry
(Subp
)
1771 Expand_Actuals
(N
, Subp
);
1774 -- If the subprogram is a renaming, or if it is inherited, replace it
1775 -- in the call with the name of the actual subprogram being called.
1776 -- If this is a dispatching call, the run-time decides what to call.
1777 -- The Alias attribute does not apply to entries.
1779 if Nkind
(N
) /= N_Entry_Call_Statement
1780 and then No
(Controlling_Argument
(N
))
1781 and then Present
(Parent_Subp
)
1783 if Present
(Inherited_From_Formal
(Subp
)) then
1784 Parent_Subp
:= Inherited_From_Formal
(Subp
);
1786 while Present
(Alias
(Parent_Subp
)) loop
1787 Parent_Subp
:= Alias
(Parent_Subp
);
1791 Set_Entity
(Name
(N
), Parent_Subp
);
1793 if Is_Abstract
(Parent_Subp
)
1794 and then not In_Instance
1797 ("cannot call abstract subprogram &!", Name
(N
), Parent_Subp
);
1800 -- Add an explicit conversion for parameter of the derived type.
1801 -- This is only done for scalar and access in-parameters. Others
1802 -- have been expanded in expand_actuals.
1804 Formal
:= First_Formal
(Subp
);
1805 Parent_Formal
:= First_Formal
(Parent_Subp
);
1806 Actual
:= First_Actual
(N
);
1808 -- It is not clear that conversion is needed for intrinsic
1809 -- subprograms, but it certainly is for those that are user-
1810 -- defined, and that can be inherited on derivation, namely
1811 -- unchecked conversion and deallocation.
1812 -- General case needs study ???
1814 if not Is_Intrinsic_Subprogram
(Parent_Subp
)
1815 or else Is_Generic_Instance
(Parent_Subp
)
1817 while Present
(Formal
) loop
1819 if Etype
(Formal
) /= Etype
(Parent_Formal
)
1820 and then Is_Scalar_Type
(Etype
(Formal
))
1821 and then Ekind
(Formal
) = E_In_Parameter
1822 and then not Raises_Constraint_Error
(Actual
)
1825 OK_Convert_To
(Etype
(Parent_Formal
),
1826 Relocate_Node
(Actual
)));
1829 Resolve
(Actual
, Etype
(Parent_Formal
));
1830 Enable_Range_Check
(Actual
);
1832 elsif Is_Access_Type
(Etype
(Formal
))
1833 and then Base_Type
(Etype
(Parent_Formal
))
1834 /= Base_Type
(Etype
(Actual
))
1836 if Ekind
(Formal
) /= E_In_Parameter
then
1838 Convert_To
(Etype
(Parent_Formal
),
1839 Relocate_Node
(Actual
)));
1842 Resolve
(Actual
, Etype
(Parent_Formal
));
1845 Ekind
(Etype
(Parent_Formal
)) = E_Anonymous_Access_Type
1846 and then Designated_Type
(Etype
(Parent_Formal
))
1848 Designated_Type
(Etype
(Actual
))
1849 and then not Is_Controlling_Formal
(Formal
)
1851 -- This unchecked conversion is not necessary unless
1852 -- inlining is enabled, because in that case the type
1853 -- mismatch may become visible in the body about to be
1857 Unchecked_Convert_To
(Etype
(Parent_Formal
),
1858 Relocate_Node
(Actual
)));
1861 Resolve
(Actual
, Etype
(Parent_Formal
));
1865 Next_Formal
(Formal
);
1866 Next_Formal
(Parent_Formal
);
1867 Next_Actual
(Actual
);
1872 Subp
:= Parent_Subp
;
1875 -- Check for violation of No_Abort_Statements
1877 if Is_RTE
(Subp
, RE_Abort_Task
) then
1878 Check_Restriction
(No_Abort_Statements
, N
);
1880 -- Check for violation of No_Dynamic_Attachment
1882 elsif RTU_Loaded
(Ada_Interrupts
)
1883 and then (Is_RTE
(Subp
, RE_Is_Reserved
) or else
1884 Is_RTE
(Subp
, RE_Is_Attached
) or else
1885 Is_RTE
(Subp
, RE_Current_Handler
) or else
1886 Is_RTE
(Subp
, RE_Attach_Handler
) or else
1887 Is_RTE
(Subp
, RE_Exchange_Handler
) or else
1888 Is_RTE
(Subp
, RE_Detach_Handler
) or else
1889 Is_RTE
(Subp
, RE_Reference
))
1891 Check_Restriction
(No_Dynamic_Attachment
, N
);
1894 -- Deal with case where call is an explicit dereference
1896 if Nkind
(Name
(N
)) = N_Explicit_Dereference
then
1898 -- Handle case of access to protected subprogram type
1900 if Ekind
(Base_Type
(Etype
(Prefix
(Name
(N
))))) =
1901 E_Access_Protected_Subprogram_Type
1903 -- If this is a call through an access to protected operation,
1904 -- the prefix has the form (object'address, operation'access).
1905 -- Rewrite as a for other protected calls: the object is the
1906 -- first parameter of the list of actuals.
1913 Ptr
: constant Node_Id
:= Prefix
(Name
(N
));
1915 T
: constant Entity_Id
:=
1916 Equivalent_Type
(Base_Type
(Etype
(Ptr
)));
1918 D_T
: constant Entity_Id
:=
1919 Designated_Type
(Base_Type
(Etype
(Ptr
)));
1922 Obj
:= Make_Selected_Component
(Loc
,
1923 Prefix
=> Unchecked_Convert_To
(T
, Ptr
),
1924 Selector_Name
=> New_Occurrence_Of
(First_Entity
(T
), Loc
));
1926 Nam
:= Make_Selected_Component
(Loc
,
1927 Prefix
=> Unchecked_Convert_To
(T
, Ptr
),
1928 Selector_Name
=> New_Occurrence_Of
(
1929 Next_Entity
(First_Entity
(T
)), Loc
));
1931 Nam
:= Make_Explicit_Dereference
(Loc
, Nam
);
1933 if Present
(Parameter_Associations
(N
)) then
1934 Parm
:= Parameter_Associations
(N
);
1939 Prepend
(Obj
, Parm
);
1941 if Etype
(D_T
) = Standard_Void_Type
then
1942 Call
:= Make_Procedure_Call_Statement
(Loc
,
1944 Parameter_Associations
=> Parm
);
1946 Call
:= Make_Function_Call
(Loc
,
1948 Parameter_Associations
=> Parm
);
1951 Set_First_Named_Actual
(Call
, First_Named_Actual
(N
));
1952 Set_Etype
(Call
, Etype
(D_T
));
1954 -- We do not re-analyze the call to avoid infinite recursion.
1955 -- We analyze separately the prefix and the object, and set
1956 -- the checks on the prefix that would otherwise be emitted
1957 -- when resolving a call.
1961 Apply_Access_Check
(Nam
);
1968 -- If this is a call to an intrinsic subprogram, then perform the
1969 -- appropriate expansion to the corresponding tree node and we
1970 -- are all done (since after that the call is gone!)
1972 if Is_Intrinsic_Subprogram
(Subp
) then
1973 Expand_Intrinsic_Call
(N
, Subp
);
1977 if Ekind
(Subp
) = E_Function
1978 or else Ekind
(Subp
) = E_Procedure
1980 if Is_Inlined
(Subp
) then
1982 Inlined_Subprogram
: declare
1984 Must_Inline
: Boolean := False;
1985 Spec
: constant Node_Id
:= Unit_Declaration_Node
(Subp
);
1986 Scop
: constant Entity_Id
:= Scope
(Subp
);
1988 function In_Unfrozen_Instance
return Boolean;
1989 -- If the subprogram comes from an instance in the same
1990 -- unit, and the instance is not yet frozen, inlining might
1991 -- trigger order-of-elaboration problems in gigi.
1993 --------------------------
1994 -- In_Unfrozen_Instance --
1995 --------------------------
1997 function In_Unfrozen_Instance
return Boolean is
1998 S
: Entity_Id
:= Scop
;
2002 and then S
/= Standard_Standard
2004 if Is_Generic_Instance
(S
)
2005 and then Present
(Freeze_Node
(S
))
2006 and then not Analyzed
(Freeze_Node
(S
))
2015 end In_Unfrozen_Instance
;
2017 -- Start of processing for Inlined_Subprogram
2020 -- Verify that the body to inline has already been seen,
2021 -- and that if the body is in the current unit the inlining
2022 -- does not occur earlier. This avoids order-of-elaboration
2023 -- problems in gigi.
2026 or else Nkind
(Spec
) /= N_Subprogram_Declaration
2027 or else No
(Body_To_Inline
(Spec
))
2029 Must_Inline
:= False;
2031 -- If this an inherited function that returns a private
2032 -- type, do not inline if the full view is an unconstrained
2033 -- array, because such calls cannot be inlined.
2035 elsif Present
(Orig_Subp
)
2036 and then Is_Array_Type
(Etype
(Orig_Subp
))
2037 and then not Is_Constrained
(Etype
(Orig_Subp
))
2039 Must_Inline
:= False;
2041 elsif In_Unfrozen_Instance
then
2042 Must_Inline
:= False;
2045 Bod
:= Body_To_Inline
(Spec
);
2047 if (In_Extended_Main_Code_Unit
(N
)
2048 or else In_Extended_Main_Code_Unit
(Parent
(N
))
2049 or else Is_Always_Inlined
(Subp
))
2050 and then (not In_Same_Extended_Unit
(Sloc
(Bod
), Loc
)
2052 Earlier_In_Extended_Unit
(Sloc
(Bod
), Loc
))
2054 Must_Inline
:= True;
2056 -- If we are compiling a package body that is not the main
2057 -- unit, it must be for inlining/instantiation purposes,
2058 -- in which case we inline the call to insure that the same
2059 -- temporaries are generated when compiling the body by
2060 -- itself. Otherwise link errors can occur.
2062 -- If the function being called is itself in the main unit,
2063 -- we cannot inline, because there is a risk of double
2064 -- elaboration and/or circularity: the inlining can make
2065 -- visible a private entity in the body of the main unit,
2066 -- that gigi will see before its sees its proper definition.
2068 elsif not (In_Extended_Main_Code_Unit
(N
))
2069 and then In_Package_Body
2071 Must_Inline
:= not In_Extended_Main_Source_Unit
(Subp
);
2076 Expand_Inlined_Call
(N
, Subp
, Orig_Subp
);
2079 -- Let the back end handle it
2081 Add_Inlined_Body
(Subp
);
2083 if Front_End_Inlining
2084 and then Nkind
(Spec
) = N_Subprogram_Declaration
2085 and then (In_Extended_Main_Code_Unit
(N
))
2086 and then No
(Body_To_Inline
(Spec
))
2087 and then not Has_Completion
(Subp
)
2088 and then In_Same_Extended_Unit
(Sloc
(Spec
), Loc
)
2091 ("cannot inline& (body not seen yet)?",
2095 end Inlined_Subprogram
;
2099 -- Check for a protected subprogram. This is either an intra-object
2100 -- call, or a protected function call. Protected procedure calls are
2101 -- rewritten as entry calls and handled accordingly.
2103 Scop
:= Scope
(Subp
);
2105 if Nkind
(N
) /= N_Entry_Call_Statement
2106 and then Is_Protected_Type
(Scop
)
2108 -- If the call is an internal one, it is rewritten as a call to
2109 -- to the corresponding unprotected subprogram.
2111 Expand_Protected_Subprogram_Call
(N
, Subp
, Scop
);
2114 -- Functions returning controlled objects need special attention
2116 if Controlled_Type
(Etype
(Subp
))
2117 and then not Is_Return_By_Reference_Type
(Etype
(Subp
))
2119 Expand_Ctrl_Function_Call
(N
);
2122 -- Test for First_Optional_Parameter, and if so, truncate parameter
2123 -- list if there are optional parameters at the trailing end.
2124 -- Note we never delete procedures for call via a pointer.
2126 if (Ekind
(Subp
) = E_Procedure
or else Ekind
(Subp
) = E_Function
)
2127 and then Present
(First_Optional_Parameter
(Subp
))
2130 Last_Keep_Arg
: Node_Id
;
2133 -- Last_Keep_Arg will hold the last actual that should be
2134 -- retained. If it remains empty at the end, it means that
2135 -- all parameters are optional.
2137 Last_Keep_Arg
:= Empty
;
2139 -- Find first optional parameter, must be present since we
2140 -- checked the validity of the parameter before setting it.
2142 Formal
:= First_Formal
(Subp
);
2143 Actual
:= First_Actual
(N
);
2144 while Formal
/= First_Optional_Parameter
(Subp
) loop
2145 Last_Keep_Arg
:= Actual
;
2146 Next_Formal
(Formal
);
2147 Next_Actual
(Actual
);
2150 -- We have Formal and Actual pointing to the first potentially
2151 -- droppable argument. We can drop all the trailing arguments
2152 -- whose actual matches the default. Note that we know that all
2153 -- remaining formals have defaults, because we checked that this
2154 -- requirement was met before setting First_Optional_Parameter.
2156 -- We use Fully_Conformant_Expressions to check for identity
2157 -- between formals and actuals, which may miss some cases, but
2158 -- on the other hand, this is only an optimization (if we fail
2159 -- to truncate a parameter it does not affect functionality).
2160 -- So if the default is 3 and the actual is 1+2, we consider
2161 -- them unequal, which hardly seems worrisome.
2163 while Present
(Formal
) loop
2164 if not Fully_Conformant_Expressions
2165 (Actual
, Default_Value
(Formal
))
2167 Last_Keep_Arg
:= Actual
;
2170 Next_Formal
(Formal
);
2171 Next_Actual
(Actual
);
2174 -- If no arguments, delete entire list, this is the easy case
2176 if No
(Last_Keep_Arg
) then
2177 while Is_Non_Empty_List
(Parameter_Associations
(N
)) loop
2178 Delete_Tree
(Remove_Head
(Parameter_Associations
(N
)));
2181 Set_Parameter_Associations
(N
, No_List
);
2182 Set_First_Named_Actual
(N
, Empty
);
2184 -- Case where at the last retained argument is positional. This
2185 -- is also an easy case, since the retained arguments are already
2186 -- in the right form, and we don't need to worry about the order
2187 -- of arguments that get eliminated.
2189 elsif Is_List_Member
(Last_Keep_Arg
) then
2190 while Present
(Next
(Last_Keep_Arg
)) loop
2191 Delete_Tree
(Remove_Next
(Last_Keep_Arg
));
2194 Set_First_Named_Actual
(N
, Empty
);
2196 -- This is the annoying case where the last retained argument
2197 -- is a named parameter. Since the original arguments are not
2198 -- in declaration order, we may have to delete some fairly
2199 -- random collection of arguments.
2207 pragma Warnings
(Off
, Discard
);
2210 -- First step, remove all the named parameters from the
2211 -- list (they are still chained using First_Named_Actual
2212 -- and Next_Named_Actual, so we have not lost them!)
2214 Temp
:= First
(Parameter_Associations
(N
));
2216 -- Case of all parameters named, remove them all
2218 if Nkind
(Temp
) = N_Parameter_Association
then
2219 while Is_Non_Empty_List
(Parameter_Associations
(N
)) loop
2220 Temp
:= Remove_Head
(Parameter_Associations
(N
));
2223 -- Case of mixed positional/named, remove named parameters
2226 while Nkind
(Next
(Temp
)) /= N_Parameter_Association
loop
2230 while Present
(Next
(Temp
)) loop
2231 Discard
:= Remove_Next
(Temp
);
2235 -- Now we loop through the named parameters, till we get
2236 -- to the last one to be retained, adding them to the list.
2237 -- Note that the Next_Named_Actual list does not need to be
2238 -- touched since we are only reordering them on the actual
2239 -- parameter association list.
2241 Passoc
:= Parent
(First_Named_Actual
(N
));
2243 Temp
:= Relocate_Node
(Passoc
);
2245 (Parameter_Associations
(N
), Temp
);
2247 Last_Keep_Arg
= Explicit_Actual_Parameter
(Passoc
);
2248 Passoc
:= Parent
(Next_Named_Actual
(Passoc
));
2251 Set_Next_Named_Actual
(Temp
, Empty
);
2254 Temp
:= Next_Named_Actual
(Passoc
);
2255 exit when No
(Temp
);
2256 Set_Next_Named_Actual
2257 (Passoc
, Next_Named_Actual
(Parent
(Temp
)));
2266 --------------------------
2267 -- Expand_Inlined_Call --
2268 --------------------------
2270 procedure Expand_Inlined_Call
2273 Orig_Subp
: Entity_Id
)
2275 Loc
: constant Source_Ptr
:= Sloc
(N
);
2276 Is_Predef
: constant Boolean :=
2277 Is_Predefined_File_Name
2278 (Unit_File_Name
(Get_Source_Unit
(Subp
)));
2279 Orig_Bod
: constant Node_Id
:=
2280 Body_To_Inline
(Unit_Declaration_Node
(Subp
));
2285 Exit_Lab
: Entity_Id
:= Empty
;
2292 Ret_Type
: Entity_Id
;
2295 Temp_Typ
: Entity_Id
;
2297 procedure Make_Exit_Label
;
2298 -- Build declaration for exit label to be used in Return statements.
2300 function Process_Formals
(N
: Node_Id
) return Traverse_Result
;
2301 -- Replace occurrence of a formal with the corresponding actual, or
2302 -- the thunk generated for it.
2304 function Process_Sloc
(Nod
: Node_Id
) return Traverse_Result
;
2305 -- If the call being expanded is that of an internal subprogram,
2306 -- set the sloc of the generated block to that of the call itself,
2307 -- so that the expansion is skipped by the -next- command in gdb.
2308 -- Same processing for a subprogram in a predefined file, e.g.
2309 -- Ada.Tags. If Debug_Generated_Code is true, suppress this change
2310 -- to simplify our own development.
2312 procedure Rewrite_Function_Call
(N
: Node_Id
; Blk
: Node_Id
);
2313 -- If the function body is a single expression, replace call with
2314 -- expression, else insert block appropriately.
2316 procedure Rewrite_Procedure_Call
(N
: Node_Id
; Blk
: Node_Id
);
2317 -- If procedure body has no local variables, inline body without
2318 -- creating block, otherwise rewrite call with block.
2320 function Formal_Is_Used_Once
(Formal
: Entity_Id
) return Boolean;
2321 -- Determine whether a formal parameter is used only once in Orig_Bod
2323 ---------------------
2324 -- Make_Exit_Label --
2325 ---------------------
2327 procedure Make_Exit_Label
is
2329 -- Create exit label for subprogram, if one doesn't exist yet.
2331 if No
(Exit_Lab
) then
2332 Lab_Id
:= Make_Identifier
(Loc
, New_Internal_Name
('L'));
2334 Make_Defining_Identifier
(Loc
, Chars
(Lab_Id
)));
2335 Exit_Lab
:= Make_Label
(Loc
, Lab_Id
);
2338 Make_Implicit_Label_Declaration
(Loc
,
2339 Defining_Identifier
=> Entity
(Lab_Id
),
2340 Label_Construct
=> Exit_Lab
);
2342 end Make_Exit_Label
;
2344 ---------------------
2345 -- Process_Formals --
2346 ---------------------
2348 function Process_Formals
(N
: Node_Id
) return Traverse_Result
is
2354 if Is_Entity_Name
(N
)
2355 and then Present
(Entity
(N
))
2360 and then Scope
(E
) = Subp
2362 A
:= Renamed_Object
(E
);
2364 if Is_Entity_Name
(A
) then
2365 Rewrite
(N
, New_Occurrence_Of
(Entity
(A
), Loc
));
2367 elsif Nkind
(A
) = N_Defining_Identifier
then
2368 Rewrite
(N
, New_Occurrence_Of
(A
, Loc
));
2370 else -- numeric literal
2371 Rewrite
(N
, New_Copy
(A
));
2377 elsif Nkind
(N
) = N_Return_Statement
then
2379 if No
(Expression
(N
)) then
2381 Rewrite
(N
, Make_Goto_Statement
(Loc
,
2382 Name
=> New_Copy
(Lab_Id
)));
2385 if Nkind
(Parent
(N
)) = N_Handled_Sequence_Of_Statements
2386 and then Nkind
(Parent
(Parent
(N
))) = N_Subprogram_Body
2388 -- Function body is a single expression. No need for
2394 Num_Ret
:= Num_Ret
+ 1;
2398 -- Because of the presence of private types, the views of the
2399 -- expression and the context may be different, so place an
2400 -- unchecked conversion to the context type to avoid spurious
2401 -- errors, eg. when the expression is a numeric literal and
2402 -- the context is private. If the expression is an aggregate,
2403 -- use a qualified expression, because an aggregate is not a
2404 -- legal argument of a conversion.
2406 if Nkind
(Expression
(N
)) = N_Aggregate
2407 or else Nkind
(Expression
(N
)) = N_Null
2410 Make_Qualified_Expression
(Sloc
(N
),
2411 Subtype_Mark
=> New_Occurrence_Of
(Ret_Type
, Sloc
(N
)),
2412 Expression
=> Relocate_Node
(Expression
(N
)));
2415 Unchecked_Convert_To
2416 (Ret_Type
, Relocate_Node
(Expression
(N
)));
2419 if Nkind
(Targ
) = N_Defining_Identifier
then
2421 Make_Assignment_Statement
(Loc
,
2422 Name
=> New_Occurrence_Of
(Targ
, Loc
),
2423 Expression
=> Ret
));
2426 Make_Assignment_Statement
(Loc
,
2427 Name
=> New_Copy
(Targ
),
2428 Expression
=> Ret
));
2431 Set_Assignment_OK
(Name
(N
));
2433 if Present
(Exit_Lab
) then
2435 Make_Goto_Statement
(Loc
,
2436 Name
=> New_Copy
(Lab_Id
)));
2442 -- Remove pragma Unreferenced since it may refer to formals that
2443 -- are not visible in the inlined body, and in any case we will
2444 -- not be posting warnings on the inlined body so it is unneeded.
2446 elsif Nkind
(N
) = N_Pragma
2447 and then Chars
(N
) = Name_Unreferenced
2449 Rewrite
(N
, Make_Null_Statement
(Sloc
(N
)));
2455 end Process_Formals
;
2457 procedure Replace_Formals
is new Traverse_Proc
(Process_Formals
);
2463 function Process_Sloc
(Nod
: Node_Id
) return Traverse_Result
is
2465 if not Debug_Generated_Code
then
2466 Set_Sloc
(Nod
, Sloc
(N
));
2467 Set_Comes_From_Source
(Nod
, False);
2473 procedure Reset_Slocs
is new Traverse_Proc
(Process_Sloc
);
2475 ---------------------------
2476 -- Rewrite_Function_Call --
2477 ---------------------------
2479 procedure Rewrite_Function_Call
(N
: Node_Id
; Blk
: Node_Id
) is
2480 HSS
: constant Node_Id
:= Handled_Statement_Sequence
(Blk
);
2481 Fst
: constant Node_Id
:= First
(Statements
(HSS
));
2484 -- Optimize simple case: function body is a single return statement,
2485 -- which has been expanded into an assignment.
2487 if Is_Empty_List
(Declarations
(Blk
))
2488 and then Nkind
(Fst
) = N_Assignment_Statement
2489 and then No
(Next
(Fst
))
2492 -- The function call may have been rewritten as the temporary
2493 -- that holds the result of the call, in which case remove the
2494 -- now useless declaration.
2496 if Nkind
(N
) = N_Identifier
2497 and then Nkind
(Parent
(Entity
(N
))) = N_Object_Declaration
2499 Rewrite
(Parent
(Entity
(N
)), Make_Null_Statement
(Loc
));
2502 Rewrite
(N
, Expression
(Fst
));
2504 elsif Nkind
(N
) = N_Identifier
2505 and then Nkind
(Parent
(Entity
(N
))) = N_Object_Declaration
2508 -- The block assigns the result of the call to the temporary.
2510 Insert_After
(Parent
(Entity
(N
)), Blk
);
2512 elsif Nkind
(Parent
(N
)) = N_Assignment_Statement
2513 and then Is_Entity_Name
(Name
(Parent
(N
)))
2516 -- Replace assignment with the block
2519 Original_Assignment
: constant Node_Id
:= Parent
(N
);
2522 -- Preserve the original assignment node to keep the
2523 -- complete assignment subtree consistent enough for
2524 -- Analyze_Assignment to proceed (specifically, the
2525 -- original Lhs node must still have an assignment
2526 -- statement as its parent).
2528 -- We cannot rely on Original_Node to go back from the
2529 -- block node to the assignment node, because the
2530 -- assignment might already be a rewrite substitution.
2532 Discard_Node
(Relocate_Node
(Original_Assignment
));
2533 Rewrite
(Original_Assignment
, Blk
);
2536 elsif Nkind
(Parent
(N
)) = N_Object_Declaration
then
2537 Set_Expression
(Parent
(N
), Empty
);
2538 Insert_After
(Parent
(N
), Blk
);
2540 end Rewrite_Function_Call
;
2542 ----------------------------
2543 -- Rewrite_Procedure_Call --
2544 ----------------------------
2546 procedure Rewrite_Procedure_Call
(N
: Node_Id
; Blk
: Node_Id
) is
2547 HSS
: constant Node_Id
:= Handled_Statement_Sequence
(Blk
);
2549 if Is_Empty_List
(Declarations
(Blk
)) then
2550 Insert_List_After
(N
, Statements
(HSS
));
2551 Rewrite
(N
, Make_Null_Statement
(Loc
));
2555 end Rewrite_Procedure_Call
;
2557 -------------------------
2558 -- Formal_Is_Used_Once --
2559 ------------------------
2561 function Formal_Is_Used_Once
(Formal
: Entity_Id
) return Boolean is
2562 Use_Counter
: Int
:= 0;
2564 function Count_Uses
(N
: Node_Id
) return Traverse_Result
;
2565 -- Traverse the tree and count the uses of the formal parameter.
2566 -- In this case, for optimization purposes, we do not need to
2567 -- continue the traversal once more than one use is encountered.
2573 function Count_Uses
(N
: Node_Id
) return Traverse_Result
is
2575 -- The original node is an identifier
2577 if Nkind
(N
) = N_Identifier
2578 and then Present
(Entity
(N
))
2580 -- The original node's entity points to the one in the
2583 and then Nkind
(Entity
(N
)) = N_Identifier
2584 and then Present
(Entity
(Entity
(N
)))
2586 -- The entity of the copied node is the formal parameter
2588 and then Entity
(Entity
(N
)) = Formal
2590 Use_Counter
:= Use_Counter
+ 1;
2592 if Use_Counter
> 1 then
2594 -- Denote more than one use and abandon the traversal
2605 procedure Count_Formal_Uses
is new Traverse_Proc
(Count_Uses
);
2607 -- Start of processing for Formal_Is_Used_Once
2610 Count_Formal_Uses
(Orig_Bod
);
2611 return Use_Counter
= 1;
2612 end Formal_Is_Used_Once
;
2614 -- Start of processing for Expand_Inlined_Call
2617 -- Check for special case of To_Address call, and if so, just
2618 -- do an unchecked conversion instead of expanding the call.
2619 -- Not only is this more efficient, but it also avoids a
2620 -- problem with order of elaboration when address clauses
2621 -- are inlined (address expr elaborated at wrong point).
2623 if Subp
= RTE
(RE_To_Address
) then
2625 Unchecked_Convert_To
2627 Relocate_Node
(First_Actual
(N
))));
2631 if Nkind
(Orig_Bod
) = N_Defining_Identifier
then
2633 -- Subprogram is a renaming_as_body. Calls appearing after the
2634 -- renaming can be replaced with calls to the renamed entity
2635 -- directly, because the subprograms are subtype conformant.
2637 Set_Name
(N
, New_Occurrence_Of
(Orig_Bod
, Loc
));
2641 -- Use generic machinery to copy body of inlined subprogram, as if it
2642 -- were an instantiation, resetting source locations appropriately, so
2643 -- that nested inlined calls appear in the main unit.
2645 Save_Env
(Subp
, Empty
);
2646 Set_Copied_Sloc_For_Inlined_Body
(N
, Defining_Entity
(Orig_Bod
));
2648 Bod
:= Copy_Generic_Node
(Orig_Bod
, Empty
, Instantiating
=> True);
2650 Make_Block_Statement
(Loc
,
2651 Declarations
=> Declarations
(Bod
),
2652 Handled_Statement_Sequence
=> Handled_Statement_Sequence
(Bod
));
2654 if No
(Declarations
(Bod
)) then
2655 Set_Declarations
(Blk
, New_List
);
2658 -- If this is a derived function, establish the proper return type.
2660 if Present
(Orig_Subp
)
2661 and then Orig_Subp
/= Subp
2663 Ret_Type
:= Etype
(Orig_Subp
);
2665 Ret_Type
:= Etype
(Subp
);
2668 F
:= First_Formal
(Subp
);
2669 A
:= First_Actual
(N
);
2671 -- Create temporaries for the actuals that are expressions, or that
2672 -- are scalars and require copying to preserve semantics.
2674 while Present
(F
) loop
2675 if Present
(Renamed_Object
(F
)) then
2676 Error_Msg_N
(" cannot inline call to recursive subprogram", N
);
2680 -- If the argument may be a controlling argument in a call within
2681 -- the inlined body, we must preserve its classwide nature to
2682 -- insure that dynamic dispatching take place subsequently.
2683 -- If the formal has a constraint it must be preserved to retain
2684 -- the semantics of the body.
2686 if Is_Class_Wide_Type
(Etype
(F
))
2687 or else (Is_Access_Type
(Etype
(F
))
2689 Is_Class_Wide_Type
(Designated_Type
(Etype
(F
))))
2691 Temp_Typ
:= Etype
(F
);
2693 elsif Base_Type
(Etype
(F
)) = Base_Type
(Etype
(A
))
2694 and then Etype
(F
) /= Base_Type
(Etype
(F
))
2696 Temp_Typ
:= Etype
(F
);
2699 Temp_Typ
:= Etype
(A
);
2702 -- If the actual is a simple name or a literal, no need to
2703 -- create a temporary, object can be used directly.
2705 if (Is_Entity_Name
(A
)
2707 (not Is_Scalar_Type
(Etype
(A
))
2708 or else Ekind
(Entity
(A
)) = E_Enumeration_Literal
))
2710 -- When the actual is an identifier and the corresponding formal
2711 -- is used only once in the original body, the formal can be
2712 -- substituted directly with the actual parameter.
2714 or else (Nkind
(A
) = N_Identifier
2715 and then Formal_Is_Used_Once
(F
))
2717 or else Nkind
(A
) = N_Real_Literal
2718 or else Nkind
(A
) = N_Integer_Literal
2719 or else Nkind
(A
) = N_Character_Literal
2721 if Etype
(F
) /= Etype
(A
) then
2723 (F
, Unchecked_Convert_To
(Etype
(F
), Relocate_Node
(A
)));
2725 Set_Renamed_Object
(F
, A
);
2730 Make_Defining_Identifier
(Loc
,
2731 Chars
=> New_Internal_Name
('C'));
2733 -- If the actual for an in/in-out parameter is a view conversion,
2734 -- make it into an unchecked conversion, given that an untagged
2735 -- type conversion is not a proper object for a renaming.
2737 -- In-out conversions that involve real conversions have already
2738 -- been transformed in Expand_Actuals.
2740 if Nkind
(A
) = N_Type_Conversion
2741 and then Ekind
(F
) /= E_In_Parameter
2743 New_A
:= Make_Unchecked_Type_Conversion
(Loc
,
2744 Subtype_Mark
=> New_Occurrence_Of
(Etype
(F
), Loc
),
2745 Expression
=> Relocate_Node
(Expression
(A
)));
2747 elsif Etype
(F
) /= Etype
(A
) then
2748 New_A
:= Unchecked_Convert_To
(Etype
(F
), Relocate_Node
(A
));
2749 Temp_Typ
:= Etype
(F
);
2752 New_A
:= Relocate_Node
(A
);
2755 Set_Sloc
(New_A
, Sloc
(N
));
2757 if Ekind
(F
) = E_In_Parameter
2758 and then not Is_Limited_Type
(Etype
(A
))
2761 Make_Object_Declaration
(Loc
,
2762 Defining_Identifier
=> Temp
,
2763 Constant_Present
=> True,
2764 Object_Definition
=> New_Occurrence_Of
(Temp_Typ
, Loc
),
2765 Expression
=> New_A
);
2768 Make_Object_Renaming_Declaration
(Loc
,
2769 Defining_Identifier
=> Temp
,
2770 Subtype_Mark
=> New_Occurrence_Of
(Temp_Typ
, Loc
),
2774 Prepend
(Decl
, Declarations
(Blk
));
2775 Set_Renamed_Object
(F
, Temp
);
2782 -- Establish target of function call. If context is not assignment or
2783 -- declaration, create a temporary as a target. The declaration for
2784 -- the temporary may be subsequently optimized away if the body is a
2785 -- single expression, or if the left-hand side of the assignment is
2788 if Ekind
(Subp
) = E_Function
then
2789 if Nkind
(Parent
(N
)) = N_Assignment_Statement
2790 and then Is_Entity_Name
(Name
(Parent
(N
)))
2792 Targ
:= Name
(Parent
(N
));
2795 -- Replace call with temporary, and create its declaration.
2798 Make_Defining_Identifier
(Loc
, New_Internal_Name
('C'));
2801 Make_Object_Declaration
(Loc
,
2802 Defining_Identifier
=> Temp
,
2803 Object_Definition
=>
2804 New_Occurrence_Of
(Ret_Type
, Loc
));
2806 Set_No_Initialization
(Decl
);
2807 Insert_Action
(N
, Decl
);
2808 Rewrite
(N
, New_Occurrence_Of
(Temp
, Loc
));
2813 -- Traverse the tree and replace formals with actuals or their thunks.
2814 -- Attach block to tree before analysis and rewriting.
2816 Replace_Formals
(Blk
);
2817 Set_Parent
(Blk
, N
);
2819 if not Comes_From_Source
(Subp
)
2825 if Present
(Exit_Lab
) then
2827 -- If the body was a single expression, the single return statement
2828 -- and the corresponding label are useless.
2832 Nkind
(Last
(Statements
(Handled_Statement_Sequence
(Blk
)))) =
2835 Remove
(Last
(Statements
(Handled_Statement_Sequence
(Blk
))));
2837 Append
(Lab_Decl
, (Declarations
(Blk
)));
2838 Append
(Exit_Lab
, Statements
(Handled_Statement_Sequence
(Blk
)));
2842 -- Analyze Blk with In_Inlined_Body set, to avoid spurious errors on
2843 -- conflicting private views that Gigi would ignore. If this is a
2844 -- predefined unit, analyze with checks off, as is done in the non-
2845 -- inlined run-time units.
2848 I_Flag
: constant Boolean := In_Inlined_Body
;
2851 In_Inlined_Body
:= True;
2855 Style
: constant Boolean := Style_Check
;
2857 Style_Check
:= False;
2858 Analyze
(Blk
, Suppress
=> All_Checks
);
2859 Style_Check
:= Style
;
2866 In_Inlined_Body
:= I_Flag
;
2869 if Ekind
(Subp
) = E_Procedure
then
2870 Rewrite_Procedure_Call
(N
, Blk
);
2872 Rewrite_Function_Call
(N
, Blk
);
2877 -- Cleanup mapping between formals and actuals, for other expansions.
2879 F
:= First_Formal
(Subp
);
2881 while Present
(F
) loop
2882 Set_Renamed_Object
(F
, Empty
);
2885 end Expand_Inlined_Call
;
2887 ----------------------------
2888 -- Expand_N_Function_Call --
2889 ----------------------------
2891 procedure Expand_N_Function_Call
(N
: Node_Id
) is
2892 Typ
: constant Entity_Id
:= Etype
(N
);
2894 function Returned_By_Reference
return Boolean;
2895 -- If the return type is returned through the secondary stack. that is
2896 -- by reference, we don't want to create a temp to force stack checking.
2897 -- Shouldn't this function be moved to exp_util???
2899 ---------------------------
2900 -- Returned_By_Reference --
2901 ---------------------------
2903 function Returned_By_Reference
return Boolean is
2904 S
: Entity_Id
:= Current_Scope
;
2907 if Is_Return_By_Reference_Type
(Typ
) then
2910 elsif Nkind
(Parent
(N
)) /= N_Return_Statement
then
2913 elsif Requires_Transient_Scope
(Typ
) then
2915 -- Verify that the return type of the enclosing function has
2916 -- the same constrained status as that of the expression.
2918 while Ekind
(S
) /= E_Function
loop
2922 return Is_Constrained
(Typ
) = Is_Constrained
(Etype
(S
));
2926 end Returned_By_Reference
;
2928 -- Start of processing for Expand_N_Function_Call
2931 -- A special check. If stack checking is enabled, and the return type
2932 -- might generate a large temporary, and the call is not the right
2933 -- side of an assignment, then generate an explicit temporary. We do
2934 -- this because otherwise gigi may generate a large temporary on the
2935 -- fly and this can cause trouble with stack checking.
2937 if May_Generate_Large_Temp
(Typ
)
2938 and then Nkind
(Parent
(N
)) /= N_Assignment_Statement
2940 (Nkind
(Parent
(N
)) /= N_Qualified_Expression
2941 or else Nkind
(Parent
(Parent
(N
))) /= N_Assignment_Statement
)
2943 (Nkind
(Parent
(N
)) /= N_Object_Declaration
2944 or else Expression
(Parent
(N
)) /= N
)
2945 and then not Returned_By_Reference
2947 if Stack_Checking_Enabled
then
2949 -- Note: it might be thought that it would be OK to use a call
2950 -- to Force_Evaluation here, but that's not good enough, because
2951 -- that can results in a 'Reference construct that may still
2952 -- need a temporary.
2955 Loc
: constant Source_Ptr
:= Sloc
(N
);
2956 Temp_Obj
: constant Entity_Id
:=
2957 Make_Defining_Identifier
(Loc
,
2958 Chars
=> New_Internal_Name
('F'));
2959 Temp_Typ
: Entity_Id
:= Typ
;
2966 if Is_Tagged_Type
(Typ
)
2967 and then Present
(Controlling_Argument
(N
))
2969 if Nkind
(Parent
(N
)) /= N_Procedure_Call_Statement
2970 and then Nkind
(Parent
(N
)) /= N_Function_Call
2972 -- If this is a tag-indeterminate call, the object must
2975 if Is_Tag_Indeterminate
(N
) then
2976 Temp_Typ
:= Class_Wide_Type
(Typ
);
2980 -- If this is a dispatching call that is itself the
2981 -- controlling argument of an enclosing call, the
2982 -- nominal subtype of the object that replaces it must
2983 -- be classwide, so that dispatching will take place
2984 -- properly. If it is not a controlling argument, the
2985 -- object is not classwide.
2987 Proc
:= Entity
(Name
(Parent
(N
)));
2988 F
:= First_Formal
(Proc
);
2989 A
:= First_Actual
(Parent
(N
));
2996 if Is_Controlling_Formal
(F
) then
2997 Temp_Typ
:= Class_Wide_Type
(Typ
);
3003 Make_Object_Declaration
(Loc
,
3004 Defining_Identifier
=> Temp_Obj
,
3005 Object_Definition
=> New_Occurrence_Of
(Temp_Typ
, Loc
),
3006 Constant_Present
=> True,
3007 Expression
=> Relocate_Node
(N
));
3008 Set_Assignment_OK
(Decl
);
3010 Insert_Actions
(N
, New_List
(Decl
));
3011 Rewrite
(N
, New_Occurrence_Of
(Temp_Obj
, Loc
));
3015 -- If stack-checking is not enabled, increment serial number
3016 -- for internal names, so that subsequent symbols are consistent
3017 -- with and without stack-checking.
3019 Synchronize_Serial_Number
;
3021 -- Now we can expand the call with consistent symbol names
3026 -- Normal case, expand the call
3031 end Expand_N_Function_Call
;
3033 ---------------------------------------
3034 -- Expand_N_Procedure_Call_Statement --
3035 ---------------------------------------
3037 procedure Expand_N_Procedure_Call_Statement
(N
: Node_Id
) is
3040 end Expand_N_Procedure_Call_Statement
;
3042 ------------------------------
3043 -- Expand_N_Subprogram_Body --
3044 ------------------------------
3046 -- Add poll call if ATC polling is enabled
3048 -- Add return statement if last statement in body is not a return
3049 -- statement (this makes things easier on Gigi which does not want
3050 -- to have to handle a missing return).
3052 -- Add call to Activate_Tasks if body is a task activator
3054 -- Deal with possible detection of infinite recursion
3056 -- Eliminate body completely if convention stubbed
3058 -- Encode entity names within body, since we will not need to reference
3059 -- these entities any longer in the front end.
3061 -- Initialize scalar out parameters if Initialize/Normalize_Scalars
3063 -- Reset Pure indication if any parameter has root type System.Address
3067 procedure Expand_N_Subprogram_Body
(N
: Node_Id
) is
3068 Loc
: constant Source_Ptr
:= Sloc
(N
);
3069 H
: constant Node_Id
:= Handled_Statement_Sequence
(N
);
3070 Body_Id
: Entity_Id
;
3071 Spec_Id
: Entity_Id
;
3078 procedure Add_Return
(S
: List_Id
);
3079 -- Append a return statement to the statement sequence S if the last
3080 -- statement is not already a return or a goto statement. Note that
3081 -- the latter test is not critical, it does not matter if we add a
3082 -- few extra returns, since they get eliminated anyway later on.
3084 procedure Expand_Thread_Body
;
3085 -- Perform required expansion of a thread body
3091 procedure Add_Return
(S
: List_Id
) is
3093 if not Is_Transfer
(Last
(S
)) then
3095 -- The source location for the return is the end label
3096 -- of the procedure in all cases. This is a bit odd when
3097 -- there are exception handlers, but not much else we can do.
3099 Append_To
(S
, Make_Return_Statement
(Sloc
(End_Label
(H
))));
3103 ------------------------
3104 -- Expand_Thread_Body --
3105 ------------------------
3107 -- The required expansion of a thread body is as follows
3109 -- procedure <thread body procedure name> is
3111 -- _Secondary_Stack : aliased
3112 -- Storage_Elements.Storage_Array
3113 -- (1 .. Storage_Offset (Sec_Stack_Size));
3114 -- for _Secondary_Stack'Alignment use Standard'Maximum_Alignment;
3116 -- _Process_ATSD : aliased System.Threads.ATSD;
3119 -- System.Threads.Thread_Body_Enter;
3120 -- (_Secondary_Stack'Address,
3121 -- _Secondary_Stack'Length,
3122 -- _Process_ATSD'Address);
3125 -- <user declarations>
3127 -- <user statements>
3128 -- <user exception handlers>
3131 -- System.Threads.Thread_Body_Leave;
3134 -- when E : others =>
3135 -- System.Threads.Thread_Body_Exceptional_Exit (E);
3138 -- Note the exception handler is omitted if pragma Restriction
3139 -- No_Exception_Handlers is currently active.
3141 procedure Expand_Thread_Body
is
3142 User_Decls
: constant List_Id
:= Declarations
(N
);
3143 Sec_Stack_Len
: Node_Id
;
3145 TB_Pragma
: constant Node_Id
:=
3146 Get_Rep_Pragma
(Spec_Id
, Name_Thread_Body
);
3149 Ent_ATSD
: Entity_Id
;
3153 Decl_ATSD
: Node_Id
;
3155 Excep_Handlers
: List_Id
;
3158 New_Scope
(Spec_Id
);
3160 -- Get proper setting for secondary stack size
3162 if List_Length
(Pragma_Argument_Associations
(TB_Pragma
)) = 2 then
3164 Expression
(Last
(Pragma_Argument_Associations
(TB_Pragma
)));
3167 New_Occurrence_Of
(RTE
(RE_Default_Secondary_Stack_Size
), Loc
);
3170 Sec_Stack_Len
:= Convert_To
(RTE
(RE_Storage_Offset
), Sec_Stack_Len
);
3172 -- Build and set declarations for the wrapped thread body
3174 Ent_SS
:= Make_Defining_Identifier
(Loc
, Name_uSecondary_Stack
);
3175 Ent_ATSD
:= Make_Defining_Identifier
(Loc
, Name_uProcess_ATSD
);
3178 Make_Object_Declaration
(Loc
,
3179 Defining_Identifier
=> Ent_SS
,
3180 Aliased_Present
=> True,
3181 Object_Definition
=>
3182 Make_Subtype_Indication
(Loc
,
3184 New_Occurrence_Of
(RTE
(RE_Storage_Array
), Loc
),
3186 Make_Index_Or_Discriminant_Constraint
(Loc
,
3187 Constraints
=> New_List
(
3189 Low_Bound
=> Make_Integer_Literal
(Loc
, 1),
3190 High_Bound
=> Sec_Stack_Len
)))));
3193 Make_Object_Declaration
(Loc
,
3194 Defining_Identifier
=> Ent_ATSD
,
3195 Aliased_Present
=> True,
3196 Object_Definition
=> New_Occurrence_Of
(RTE
(RE_ATSD
), Loc
));
3198 Set_Declarations
(N
, New_List
(Decl_SS
, Decl_ATSD
));
3200 Analyze
(Decl_ATSD
);
3201 Set_Alignment
(Ent_SS
, UI_From_Int
(Maximum_Alignment
));
3203 -- Create new exception handler
3205 if Restriction_Active
(No_Exception_Handlers
) then
3206 Excep_Handlers
:= No_List
;
3209 Check_Restriction
(No_Exception_Handlers
, N
);
3211 Ent_EO
:= Make_Defining_Identifier
(Loc
, Name_uE
);
3213 Excep_Handlers
:= New_List
(
3214 Make_Exception_Handler
(Loc
,
3215 Choice_Parameter
=> Ent_EO
,
3216 Exception_Choices
=> New_List
(
3217 Make_Others_Choice
(Loc
)),
3218 Statements
=> New_List
(
3219 Make_Procedure_Call_Statement
(Loc
,
3222 (RTE
(RE_Thread_Body_Exceptional_Exit
), Loc
),
3223 Parameter_Associations
=> New_List
(
3224 New_Occurrence_Of
(Ent_EO
, Loc
))))));
3227 -- Now build new handled statement sequence and analyze it
3229 Set_Handled_Statement_Sequence
(N
,
3230 Make_Handled_Sequence_Of_Statements
(Loc
,
3231 Statements
=> New_List
(
3233 Make_Procedure_Call_Statement
(Loc
,
3234 Name
=> New_Occurrence_Of
(RTE
(RE_Thread_Body_Enter
), Loc
),
3235 Parameter_Associations
=> New_List
(
3237 Make_Attribute_Reference
(Loc
,
3238 Prefix
=> New_Occurrence_Of
(Ent_SS
, Loc
),
3239 Attribute_Name
=> Name_Address
),
3241 Make_Attribute_Reference
(Loc
,
3242 Prefix
=> New_Occurrence_Of
(Ent_SS
, Loc
),
3243 Attribute_Name
=> Name_Length
),
3245 Make_Attribute_Reference
(Loc
,
3246 Prefix
=> New_Occurrence_Of
(Ent_ATSD
, Loc
),
3247 Attribute_Name
=> Name_Address
))),
3249 Make_Block_Statement
(Loc
,
3250 Declarations
=> User_Decls
,
3251 Handled_Statement_Sequence
=> H
),
3253 Make_Procedure_Call_Statement
(Loc
,
3254 Name
=> New_Occurrence_Of
(RTE
(RE_Thread_Body_Leave
), Loc
))),
3256 Exception_Handlers
=> Excep_Handlers
));
3258 Analyze
(Handled_Statement_Sequence
(N
));
3260 end Expand_Thread_Body
;
3262 -- Start of processing for Expand_N_Subprogram_Body
3265 -- Set L to either the list of declarations if present, or
3266 -- to the list of statements if no declarations are present.
3267 -- This is used to insert new stuff at the start.
3269 if Is_Non_Empty_List
(Declarations
(N
)) then
3270 L
:= Declarations
(N
);
3272 L
:= Statements
(Handled_Statement_Sequence
(N
));
3275 -- Need poll on entry to subprogram if polling enabled. We only
3276 -- do this for non-empty subprograms, since it does not seem
3277 -- necessary to poll for a dummy null subprogram.
3279 if Is_Non_Empty_List
(L
) then
3280 Generate_Poll_Call
(First
(L
));
3283 -- Find entity for subprogram
3285 Body_Id
:= Defining_Entity
(N
);
3287 if Present
(Corresponding_Spec
(N
)) then
3288 Spec_Id
:= Corresponding_Spec
(N
);
3293 -- If this is a Pure function which has any parameters whose root
3294 -- type is System.Address, reset the Pure indication, since it will
3295 -- likely cause incorrect code to be generated as the parameter is
3296 -- probably a pointer, and the fact that the same pointer is passed
3297 -- does not mean that the same value is being referenced.
3299 -- Note that if the programmer gave an explicit Pure_Function pragma,
3300 -- then we believe the programmer, and leave the subprogram Pure.
3302 -- This code should probably be at the freeze point, so that it
3303 -- happens even on a -gnatc (or more importantly -gnatt) compile
3304 -- so that the semantic tree has Is_Pure set properly ???
3306 if Is_Pure
(Spec_Id
)
3307 and then Is_Subprogram
(Spec_Id
)
3308 and then not Has_Pragma_Pure_Function
(Spec_Id
)
3311 F
: Entity_Id
:= First_Formal
(Spec_Id
);
3314 while Present
(F
) loop
3315 if Is_Descendent_Of_Address
(Etype
(F
)) then
3316 Set_Is_Pure
(Spec_Id
, False);
3318 if Spec_Id
/= Body_Id
then
3319 Set_Is_Pure
(Body_Id
, False);
3330 -- Initialize any scalar OUT args if Initialize/Normalize_Scalars
3332 if Init_Or_Norm_Scalars
and then Is_Subprogram
(Spec_Id
) then
3334 F
: Entity_Id
:= First_Formal
(Spec_Id
);
3335 V
: constant Boolean := Validity_Checks_On
;
3338 -- We turn off validity checking, since we do not want any
3339 -- check on the initializing value itself (which we know
3340 -- may well be invalid!)
3342 Validity_Checks_On
:= False;
3344 -- Loop through formals
3346 while Present
(F
) loop
3347 if Is_Scalar_Type
(Etype
(F
))
3348 and then Ekind
(F
) = E_Out_Parameter
3350 Insert_Before_And_Analyze
(First
(L
),
3351 Make_Assignment_Statement
(Loc
,
3352 Name
=> New_Occurrence_Of
(F
, Loc
),
3353 Expression
=> Get_Simple_Init_Val
(Etype
(F
), Loc
)));
3359 Validity_Checks_On
:= V
;
3363 Scop
:= Scope
(Spec_Id
);
3365 -- Add discriminal renamings to protected subprograms.
3366 -- Install new discriminals for expansion of the next
3367 -- subprogram of this protected type, if any.
3369 if Is_List_Member
(N
)
3370 and then Present
(Parent
(List_Containing
(N
)))
3371 and then Nkind
(Parent
(List_Containing
(N
))) = N_Protected_Body
3373 Add_Discriminal_Declarations
3374 (Declarations
(N
), Scop
, Name_uObject
, Loc
);
3375 Add_Private_Declarations
(Declarations
(N
), Scop
, Name_uObject
, Loc
);
3377 -- Associate privals and discriminals with the next protected
3378 -- operation body to be expanded. These are used to expand
3379 -- references to private data objects and discriminants,
3382 Next_Op
:= Next_Protected_Operation
(N
);
3384 if Present
(Next_Op
) then
3385 Dec
:= Parent
(Base_Type
(Scop
));
3386 Set_Privals
(Dec
, Next_Op
, Loc
);
3387 Set_Discriminals
(Dec
);
3391 -- Clear out statement list for stubbed procedure
3393 if Present
(Corresponding_Spec
(N
)) then
3394 Set_Elaboration_Flag
(N
, Spec_Id
);
3396 if Convention
(Spec_Id
) = Convention_Stubbed
3397 or else Is_Eliminated
(Spec_Id
)
3399 Set_Declarations
(N
, Empty_List
);
3400 Set_Handled_Statement_Sequence
(N
,
3401 Make_Handled_Sequence_Of_Statements
(Loc
,
3402 Statements
=> New_List
(
3403 Make_Null_Statement
(Loc
))));
3408 -- Returns_By_Ref flag is normally set when the subprogram is frozen
3409 -- but subprograms with no specs are not frozen
3412 Typ
: constant Entity_Id
:= Etype
(Spec_Id
);
3413 Utyp
: constant Entity_Id
:= Underlying_Type
(Typ
);
3416 if not Acts_As_Spec
(N
)
3417 and then Nkind
(Parent
(Parent
(Spec_Id
))) /=
3418 N_Subprogram_Body_Stub
3422 elsif Is_Return_By_Reference_Type
(Typ
) then
3423 Set_Returns_By_Ref
(Spec_Id
);
3425 elsif Present
(Utyp
) and then Controlled_Type
(Utyp
) then
3426 Set_Returns_By_Ref
(Spec_Id
);
3430 -- For a procedure, we add a return for all possible syntactic ends
3431 -- of the subprogram. Note that reanalysis is not necessary in this
3432 -- case since it would require a lot of work and accomplish nothing.
3434 if Ekind
(Spec_Id
) = E_Procedure
3435 or else Ekind
(Spec_Id
) = E_Generic_Procedure
3437 Add_Return
(Statements
(H
));
3439 if Present
(Exception_Handlers
(H
)) then
3440 Except_H
:= First_Non_Pragma
(Exception_Handlers
(H
));
3442 while Present
(Except_H
) loop
3443 Add_Return
(Statements
(Except_H
));
3444 Next_Non_Pragma
(Except_H
);
3448 -- For a function, we must deal with the case where there is at
3449 -- least one missing return. What we do is to wrap the entire body
3450 -- of the function in a block:
3463 -- raise Program_Error;
3466 -- This approach is necessary because the raise must be signalled
3467 -- to the caller, not handled by any local handler (RM 6.4(11)).
3469 -- Note: we do not need to analyze the constructed sequence here,
3470 -- since it has no handler, and an attempt to analyze the handled
3471 -- statement sequence twice is risky in various ways (e.g. the
3472 -- issue of expanding cleanup actions twice).
3474 elsif Has_Missing_Return
(Spec_Id
) then
3476 Hloc
: constant Source_Ptr
:= Sloc
(H
);
3477 Blok
: constant Node_Id
:=
3478 Make_Block_Statement
(Hloc
,
3479 Handled_Statement_Sequence
=> H
);
3480 Rais
: constant Node_Id
:=
3481 Make_Raise_Program_Error
(Hloc
,
3482 Reason
=> PE_Missing_Return
);
3485 Set_Handled_Statement_Sequence
(N
,
3486 Make_Handled_Sequence_Of_Statements
(Hloc
,
3487 Statements
=> New_List
(Blok
, Rais
)));
3489 New_Scope
(Spec_Id
);
3496 -- If subprogram contains a parameterless recursive call, then we may
3497 -- have an infinite recursion, so see if we can generate code to check
3498 -- for this possibility if storage checks are not suppressed.
3500 if Ekind
(Spec_Id
) = E_Procedure
3501 and then Has_Recursive_Call
(Spec_Id
)
3502 and then not Storage_Checks_Suppressed
(Spec_Id
)
3504 Detect_Infinite_Recursion
(N
, Spec_Id
);
3507 -- Finally, if we are in Normalize_Scalars mode, then any scalar out
3508 -- parameters must be initialized to the appropriate default value.
3510 if Ekind
(Spec_Id
) = E_Procedure
and then Normalize_Scalars
then
3517 Formal
:= First_Formal
(Spec_Id
);
3519 while Present
(Formal
) loop
3520 Floc
:= Sloc
(Formal
);
3522 if Ekind
(Formal
) = E_Out_Parameter
3523 and then Is_Scalar_Type
(Etype
(Formal
))
3526 Make_Assignment_Statement
(Floc
,
3527 Name
=> New_Occurrence_Of
(Formal
, Floc
),
3529 Get_Simple_Init_Val
(Etype
(Formal
), Floc
));
3530 Prepend
(Stm
, Declarations
(N
));
3534 Next_Formal
(Formal
);
3539 -- Deal with thread body
3541 if Is_Thread_Body
(Spec_Id
) then
3545 -- If the subprogram does not have pending instantiations, then we
3546 -- must generate the subprogram descriptor now, since the code for
3547 -- the subprogram is complete, and this is our last chance. However
3548 -- if there are pending instantiations, then the code is not
3549 -- complete, and we will delay the generation.
3551 if Is_Subprogram
(Spec_Id
)
3552 and then not Delay_Subprogram_Descriptors
(Spec_Id
)
3554 Generate_Subprogram_Descriptor_For_Subprogram
(N
, Spec_Id
);
3557 -- Set to encode entity names in package body before gigi is called
3559 Qualify_Entity_Names
(N
);
3560 end Expand_N_Subprogram_Body
;
3562 -----------------------------------
3563 -- Expand_N_Subprogram_Body_Stub --
3564 -----------------------------------
3566 procedure Expand_N_Subprogram_Body_Stub
(N
: Node_Id
) is
3568 if Present
(Corresponding_Body
(N
)) then
3569 Expand_N_Subprogram_Body
(
3570 Unit_Declaration_Node
(Corresponding_Body
(N
)));
3572 end Expand_N_Subprogram_Body_Stub
;
3574 -------------------------------------
3575 -- Expand_N_Subprogram_Declaration --
3576 -------------------------------------
3578 -- If the declaration appears within a protected body, it is a private
3579 -- operation of the protected type. We must create the corresponding
3580 -- protected subprogram an associated formals. For a normal protected
3581 -- operation, this is done when expanding the protected type declaration.
3583 procedure Expand_N_Subprogram_Declaration
(N
: Node_Id
) is
3584 Loc
: constant Source_Ptr
:= Sloc
(N
);
3585 Subp
: constant Entity_Id
:= Defining_Entity
(N
);
3586 Scop
: constant Entity_Id
:= Scope
(Subp
);
3587 Prot_Decl
: Node_Id
;
3589 Prot_Id
: Entity_Id
;
3592 -- Deal with case of protected subprogram. Do not generate
3593 -- protected operation if operation is flagged as eliminated.
3595 if Is_List_Member
(N
)
3596 and then Present
(Parent
(List_Containing
(N
)))
3597 and then Nkind
(Parent
(List_Containing
(N
))) = N_Protected_Body
3598 and then Is_Protected_Type
(Scop
)
3600 if No
(Protected_Body_Subprogram
(Subp
))
3601 and then not Is_Eliminated
(Subp
)
3604 Make_Subprogram_Declaration
(Loc
,
3606 Build_Protected_Sub_Specification
3607 (N
, Scop
, Unprotected
=> True));
3609 -- The protected subprogram is declared outside of the protected
3610 -- body. Given that the body has frozen all entities so far, we
3611 -- analyze the subprogram and perform freezing actions explicitly.
3612 -- If the body is a subunit, the insertion point is before the
3613 -- stub in the parent.
3615 Prot_Bod
:= Parent
(List_Containing
(N
));
3617 if Nkind
(Parent
(Prot_Bod
)) = N_Subunit
then
3618 Prot_Bod
:= Corresponding_Stub
(Parent
(Prot_Bod
));
3621 Insert_Before
(Prot_Bod
, Prot_Decl
);
3622 Prot_Id
:= Defining_Unit_Name
(Specification
(Prot_Decl
));
3624 New_Scope
(Scope
(Scop
));
3625 Analyze
(Prot_Decl
);
3626 Create_Extra_Formals
(Prot_Id
);
3627 Set_Protected_Body_Subprogram
(Subp
, Prot_Id
);
3631 end Expand_N_Subprogram_Declaration
;
3633 ---------------------------------------
3634 -- Expand_Protected_Object_Reference --
3635 ---------------------------------------
3637 function Expand_Protected_Object_Reference
3642 Loc
: constant Source_Ptr
:= Sloc
(N
);
3649 Rec
:= Make_Identifier
(Loc
, Name_uObject
);
3650 Set_Etype
(Rec
, Corresponding_Record_Type
(Scop
));
3652 -- Find enclosing protected operation, and retrieve its first
3653 -- parameter, which denotes the enclosing protected object.
3654 -- If the enclosing operation is an entry, we are immediately
3655 -- within the protected body, and we can retrieve the object
3656 -- from the service entries procedure. A barrier function has
3657 -- has the same signature as an entry. A barrier function is
3658 -- compiled within the protected object, but unlike protected
3659 -- operations its never needs locks, so that its protected body
3660 -- subprogram points to itself.
3662 Proc
:= Current_Scope
;
3664 while Present
(Proc
)
3665 and then Scope
(Proc
) /= Scop
3667 Proc
:= Scope
(Proc
);
3670 Corr
:= Protected_Body_Subprogram
(Proc
);
3674 -- Previous error left expansion incomplete.
3675 -- Nothing to do on this call.
3682 (First
(Parameter_Specifications
(Parent
(Corr
))));
3684 if Is_Subprogram
(Proc
)
3685 and then Proc
/= Corr
3687 -- Protected function or procedure.
3689 Set_Entity
(Rec
, Param
);
3691 -- Rec is a reference to an entity which will not be in scope
3692 -- when the call is reanalyzed, and needs no further analysis.
3697 -- Entry or barrier function for entry body.
3698 -- The first parameter of the entry body procedure is a
3699 -- pointer to the object. We create a local variable
3700 -- of the proper type, duplicating what is done to define
3701 -- _object later on.
3705 Obj_Ptr
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
,
3707 New_Internal_Name
('T'));
3711 Make_Full_Type_Declaration
(Loc
,
3712 Defining_Identifier
=> Obj_Ptr
,
3714 Make_Access_To_Object_Definition
(Loc
,
3715 Subtype_Indication
=>
3717 (Corresponding_Record_Type
(Scop
), Loc
))));
3719 Insert_Actions
(N
, Decls
);
3720 Insert_Actions
(N
, Freeze_Entity
(Obj_Ptr
, Sloc
(N
)));
3723 Make_Explicit_Dereference
(Loc
,
3724 Unchecked_Convert_To
(Obj_Ptr
,
3725 New_Occurrence_Of
(Param
, Loc
)));
3727 -- Analyze new actual. Other actuals in calls are already
3728 -- analyzed and the list of actuals is not renalyzed after
3731 Set_Parent
(Rec
, N
);
3737 end Expand_Protected_Object_Reference
;
3739 --------------------------------------
3740 -- Expand_Protected_Subprogram_Call --
3741 --------------------------------------
3743 procedure Expand_Protected_Subprogram_Call
3751 -- If the protected object is not an enclosing scope, this is
3752 -- an inter-object function call. Inter-object procedure
3753 -- calls are expanded by Exp_Ch9.Build_Simple_Entry_Call.
3754 -- The call is intra-object only if the subprogram being
3755 -- called is in the protected body being compiled, and if the
3756 -- protected object in the call is statically the enclosing type.
3757 -- The object may be an component of some other data structure,
3758 -- in which case this must be handled as an inter-object call.
3760 if not In_Open_Scopes
(Scop
)
3761 or else not Is_Entity_Name
(Name
(N
))
3763 if Nkind
(Name
(N
)) = N_Selected_Component
then
3764 Rec
:= Prefix
(Name
(N
));
3767 pragma Assert
(Nkind
(Name
(N
)) = N_Indexed_Component
);
3768 Rec
:= Prefix
(Prefix
(Name
(N
)));
3771 Build_Protected_Subprogram_Call
(N
,
3772 Name
=> New_Occurrence_Of
(Subp
, Sloc
(N
)),
3773 Rec
=> Convert_Concurrent
(Rec
, Etype
(Rec
)),
3777 Rec
:= Expand_Protected_Object_Reference
(N
, Scop
);
3783 Build_Protected_Subprogram_Call
(N
,
3792 -- If it is a function call it can appear in elaboration code and
3793 -- the called entity must be frozen here.
3795 if Ekind
(Subp
) = E_Function
then
3796 Freeze_Expression
(Name
(N
));
3798 end Expand_Protected_Subprogram_Call
;
3800 -----------------------
3801 -- Freeze_Subprogram --
3802 -----------------------
3804 procedure Freeze_Subprogram
(N
: Node_Id
) is
3805 E
: constant Entity_Id
:= Entity
(N
);
3808 -- When a primitive is frozen, enter its name in the corresponding
3809 -- dispatch table. If the DTC_Entity field is not set this is an
3810 -- overridden primitive that can be ignored. We suppress the
3811 -- initialization of the dispatch table entry when Java_VM because
3812 -- the dispatching mechanism is handled internally by the JVM.
3814 if Is_Dispatching_Operation
(E
)
3815 and then not Is_Abstract
(E
)
3816 and then Present
(DTC_Entity
(E
))
3817 and then not Is_CPP_Class
(Scope
(DTC_Entity
(E
)))
3818 and then not Java_VM
3820 Check_Overriding_Operation
(E
);
3821 Insert_After
(N
, Fill_DT_Entry
(Sloc
(N
), E
));
3824 -- Mark functions that return by reference. Note that it cannot be
3825 -- part of the normal semantic analysis of the spec since the
3826 -- underlying returned type may not be known yet (for private types)
3829 Typ
: constant Entity_Id
:= Etype
(E
);
3830 Utyp
: constant Entity_Id
:= Underlying_Type
(Typ
);
3833 if Is_Return_By_Reference_Type
(Typ
) then
3834 Set_Returns_By_Ref
(E
);
3836 elsif Present
(Utyp
) and then Controlled_Type
(Utyp
) then
3837 Set_Returns_By_Ref
(E
);
3840 end Freeze_Subprogram
;