1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2005 Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 2, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING. If not, write --
19 -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
20 -- Boston, MA 02110-1301, 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_Dbug
; use Exp_Dbug
;
38 with Exp_Disp
; use Exp_Disp
;
39 with Exp_Dist
; use Exp_Dist
;
40 with Exp_Intr
; use Exp_Intr
;
41 with Exp_Pakd
; use Exp_Pakd
;
42 with Exp_Tss
; use Exp_Tss
;
43 with Exp_Util
; use Exp_Util
;
44 with Fname
; use Fname
;
45 with Freeze
; use Freeze
;
46 with Hostparm
; use Hostparm
;
47 with Inline
; use Inline
;
49 with Nlists
; use Nlists
;
50 with Nmake
; use Nmake
;
52 with Restrict
; use Restrict
;
53 with Rident
; use Rident
;
54 with Rtsfind
; use Rtsfind
;
56 with Sem_Ch6
; use Sem_Ch6
;
57 with Sem_Ch8
; use Sem_Ch8
;
58 with Sem_Ch12
; use Sem_Ch12
;
59 with Sem_Ch13
; use Sem_Ch13
;
60 with Sem_Disp
; use Sem_Disp
;
61 with Sem_Dist
; use Sem_Dist
;
62 with Sem_Mech
; use Sem_Mech
;
63 with Sem_Res
; use Sem_Res
;
64 with Sem_Util
; use Sem_Util
;
65 with Sinfo
; use Sinfo
;
66 with Snames
; use Snames
;
67 with Stand
; use Stand
;
68 with Tbuild
; use Tbuild
;
69 with Ttypes
; use Ttypes
;
70 with Uintp
; use Uintp
;
71 with Validsw
; use Validsw
;
73 package body Exp_Ch6
is
75 -----------------------
76 -- Local Subprograms --
77 -----------------------
79 procedure Check_Overriding_Operation
(Subp
: Entity_Id
);
80 -- Subp is a dispatching operation. Check whether it may override an
81 -- inherited private operation, in which case its DT entry is that of
82 -- the hidden operation, not the one it may have received earlier.
83 -- This must be done before emitting the code to set the corresponding
84 -- DT to the address of the subprogram. The actual placement of Subp in
85 -- the proper place in the list of primitive operations is done in
86 -- Declare_Inherited_Private_Subprograms, which also has to deal with
87 -- implicit operations. This duplication is unavoidable for now???
89 procedure Detect_Infinite_Recursion
(N
: Node_Id
; Spec
: Entity_Id
);
90 -- This procedure is called only if the subprogram body N, whose spec
91 -- has the given entity Spec, contains a parameterless recursive call.
92 -- It attempts to generate runtime code to detect if this a case of
93 -- infinite recursion.
95 -- The body is scanned to determine dependencies. If the only external
96 -- dependencies are on a small set of scalar variables, then the values
97 -- of these variables are captured on entry to the subprogram, and if
98 -- the values are not changed for the call, we know immediately that
99 -- we have an infinite recursion.
101 procedure Expand_Actuals
(N
: Node_Id
; Subp
: Entity_Id
);
102 -- For each actual of an in-out parameter which is a numeric conversion
103 -- of the form T(A), where A denotes a variable, we insert the declaration:
105 -- Temp : T := T (A);
107 -- prior to the call. Then we replace the actual with a reference to Temp,
108 -- and append the assignment:
110 -- A := TypeA (Temp);
112 -- after the call. Here TypeA is the actual type of variable A.
113 -- For out parameters, the initial declaration has no expression.
114 -- If A is not an entity name, we generate instead:
116 -- Var : TypeA renames A;
117 -- Temp : T := Var; -- omitting expression for out parameter.
119 -- Var := TypeA (Temp);
121 -- For other in-out parameters, we emit the required constraint checks
122 -- before and/or after the call.
124 -- For all parameter modes, actuals that denote components and slices
125 -- of packed arrays are expanded into suitable temporaries.
127 -- For non-scalar objects that are possibly unaligned, add call by copy
128 -- code (copy in for IN and IN OUT, copy out for OUT and IN OUT).
130 procedure Expand_Inlined_Call
133 Orig_Subp
: Entity_Id
);
134 -- If called subprogram can be inlined by the front-end, retrieve the
135 -- analyzed body, replace formals with actuals and expand call in place.
136 -- Generate thunks for actuals that are expressions, and insert the
137 -- corresponding constant declarations before the call. If the original
138 -- call is to a derived operation, the return type is the one of the
139 -- derived operation, but the body is that of the original, so return
140 -- expressions in the body must be converted to the desired type (which
141 -- is simply not noted in the tree without inline expansion).
143 function Expand_Protected_Object_Reference
148 procedure Expand_Protected_Subprogram_Call
152 -- A call to a protected subprogram within the protected object may appear
153 -- as a regular call. The list of actuals must be expanded to contain a
154 -- reference to the object itself, and the call becomes a call to the
155 -- corresponding protected subprogram.
157 --------------------------------
158 -- Check_Overriding_Operation --
159 --------------------------------
161 procedure Check_Overriding_Operation
(Subp
: Entity_Id
) is
162 Typ
: constant Entity_Id
:= Find_Dispatching_Type
(Subp
);
163 Op_List
: constant Elist_Id
:= Primitive_Operations
(Typ
);
169 if Is_Derived_Type
(Typ
)
170 and then not Is_Private_Type
(Typ
)
171 and then In_Open_Scopes
(Scope
(Etype
(Typ
)))
172 and then Typ
= Base_Type
(Typ
)
174 -- Subp overrides an inherited private operation if there is an
175 -- inherited operation with a different name than Subp (see
176 -- Derive_Subprogram) whose Alias is a hidden subprogram with the
177 -- same name as Subp.
179 Op_Elmt
:= First_Elmt
(Op_List
);
180 while Present
(Op_Elmt
) loop
181 Prim_Op
:= Node
(Op_Elmt
);
182 Par_Op
:= Alias
(Prim_Op
);
185 and then not Comes_From_Source
(Prim_Op
)
186 and then Chars
(Prim_Op
) /= Chars
(Par_Op
)
187 and then Chars
(Par_Op
) = Chars
(Subp
)
188 and then Is_Hidden
(Par_Op
)
189 and then Type_Conformant
(Prim_Op
, Subp
)
191 Set_DT_Position
(Subp
, DT_Position
(Prim_Op
));
197 end Check_Overriding_Operation
;
199 -------------------------------
200 -- Detect_Infinite_Recursion --
201 -------------------------------
203 procedure Detect_Infinite_Recursion
(N
: Node_Id
; Spec
: Entity_Id
) is
204 Loc
: constant Source_Ptr
:= Sloc
(N
);
206 Var_List
: constant Elist_Id
:= New_Elmt_List
;
207 -- List of globals referenced by body of procedure
209 Call_List
: constant Elist_Id
:= New_Elmt_List
;
210 -- List of recursive calls in body of procedure
212 Shad_List
: constant Elist_Id
:= New_Elmt_List
;
213 -- List of entity id's for entities created to capture the value of
214 -- referenced globals on entry to the procedure.
216 Scop
: constant Uint
:= Scope_Depth
(Spec
);
217 -- This is used to record the scope depth of the current procedure, so
218 -- that we can identify global references.
220 Max_Vars
: constant := 4;
221 -- Do not test more than four global variables
223 Count_Vars
: Natural := 0;
224 -- Count variables found so far
236 function Process
(Nod
: Node_Id
) return Traverse_Result
;
237 -- Function to traverse the subprogram body (using Traverse_Func)
243 function Process
(Nod
: Node_Id
) return Traverse_Result
is
247 if Nkind
(Nod
) = N_Procedure_Call_Statement
then
249 -- Case of one of the detected recursive calls
251 if Is_Entity_Name
(Name
(Nod
))
252 and then Has_Recursive_Call
(Entity
(Name
(Nod
)))
253 and then Entity
(Name
(Nod
)) = Spec
255 Append_Elmt
(Nod
, Call_List
);
258 -- Any other procedure call may have side effects
264 -- A call to a pure function can always be ignored
266 elsif Nkind
(Nod
) = N_Function_Call
267 and then Is_Entity_Name
(Name
(Nod
))
268 and then Is_Pure
(Entity
(Name
(Nod
)))
272 -- Case of an identifier reference
274 elsif Nkind
(Nod
) = N_Identifier
then
277 -- If no entity, then ignore the reference
279 -- Not clear why this can happen. To investigate, remove this
280 -- test and look at the crash that occurs here in 3401-004 ???
285 -- Ignore entities with no Scope, again not clear how this
286 -- can happen, to investigate, look at 4108-008 ???
288 elsif No
(Scope
(Ent
)) then
291 -- Ignore the reference if not to a more global object
293 elsif Scope_Depth
(Scope
(Ent
)) >= Scop
then
296 -- References to types, exceptions and constants are always OK
299 or else Ekind
(Ent
) = E_Exception
300 or else Ekind
(Ent
) = E_Constant
304 -- If other than a non-volatile scalar variable, we have some
305 -- kind of global reference (e.g. to a function) that we cannot
306 -- deal with so we forget the attempt.
308 elsif Ekind
(Ent
) /= E_Variable
309 or else not Is_Scalar_Type
(Etype
(Ent
))
310 or else Treat_As_Volatile
(Ent
)
314 -- Otherwise we have a reference to a global scalar
317 -- Loop through global entities already detected
319 Elm
:= First_Elmt
(Var_List
);
321 -- If not detected before, record this new global reference
324 Count_Vars
:= Count_Vars
+ 1;
326 if Count_Vars
<= Max_Vars
then
327 Append_Elmt
(Entity
(Nod
), Var_List
);
334 -- If recorded before, ignore
336 elsif Node
(Elm
) = Entity
(Nod
) then
339 -- Otherwise keep looking
349 -- For all other node kinds, recursively visit syntactic children
356 function Traverse_Body
is new Traverse_Func
;
358 -- Start of processing for Detect_Infinite_Recursion
361 -- Do not attempt detection in No_Implicit_Conditional mode, since we
362 -- won't be able to generate the code to handle the recursion in any
365 if Restriction_Active
(No_Implicit_Conditionals
) then
369 -- Otherwise do traversal and quit if we get abandon signal
371 if Traverse_Body
(N
) = Abandon
then
374 -- We must have a call, since Has_Recursive_Call was set. If not just
375 -- ignore (this is only an error check, so if we have a funny situation,
376 -- due to bugs or errors, we do not want to bomb!)
378 elsif Is_Empty_Elmt_List
(Call_List
) then
382 -- Here is the case where we detect recursion at compile time
384 -- Push our current scope for analyzing the declarations and code that
385 -- we will insert for the checking.
389 -- This loop builds temporary variables for each of the referenced
390 -- globals, so that at the end of the loop the list Shad_List contains
391 -- these temporaries in one-to-one correspondence with the elements in
395 Elm
:= First_Elmt
(Var_List
);
396 while Present
(Elm
) loop
399 Make_Defining_Identifier
(Loc
,
400 Chars
=> New_Internal_Name
('S'));
401 Append_Elmt
(Ent
, Shad_List
);
403 -- Insert a declaration for this temporary at the start of the
404 -- declarations for the procedure. The temporaries are declared as
405 -- constant objects initialized to the current values of the
406 -- corresponding temporaries.
409 Make_Object_Declaration
(Loc
,
410 Defining_Identifier
=> Ent
,
411 Object_Definition
=> New_Occurrence_Of
(Etype
(Var
), Loc
),
412 Constant_Present
=> True,
413 Expression
=> New_Occurrence_Of
(Var
, Loc
));
416 Prepend
(Decl
, Declarations
(N
));
418 Insert_After
(Last
, Decl
);
426 -- Loop through calls
428 Call
:= First_Elmt
(Call_List
);
429 while Present
(Call
) loop
431 -- Build a predicate expression of the form
434 -- and then global1 = temp1
435 -- and then global2 = temp2
438 -- This predicate determines if any of the global values
439 -- referenced by the procedure have changed since the
440 -- current call, if not an infinite recursion is assured.
442 Test
:= New_Occurrence_Of
(Standard_True
, Loc
);
444 Elm1
:= First_Elmt
(Var_List
);
445 Elm2
:= First_Elmt
(Shad_List
);
446 while Present
(Elm1
) loop
452 Left_Opnd
=> New_Occurrence_Of
(Node
(Elm1
), Loc
),
453 Right_Opnd
=> New_Occurrence_Of
(Node
(Elm2
), Loc
)));
459 -- Now we replace the call with the sequence
461 -- if no-changes (see above) then
462 -- raise Storage_Error;
467 Rewrite
(Node
(Call
),
468 Make_If_Statement
(Loc
,
470 Then_Statements
=> New_List
(
471 Make_Raise_Storage_Error
(Loc
,
472 Reason
=> SE_Infinite_Recursion
)),
474 Else_Statements
=> New_List
(
475 Relocate_Node
(Node
(Call
)))));
477 Analyze
(Node
(Call
));
482 -- Remove temporary scope stack entry used for analysis
485 end Detect_Infinite_Recursion
;
491 procedure Expand_Actuals
(N
: Node_Id
; Subp
: Entity_Id
) is
492 Loc
: constant Source_Ptr
:= Sloc
(N
);
497 E_Formal
: Entity_Id
;
499 procedure Add_Call_By_Copy_Code
;
500 -- For cases where the parameter must be passed by copy, this routine
501 -- generates a temporary variable into which the actual is copied and
502 -- then passes this as the parameter. For an OUT or IN OUT parameter,
503 -- an assignment is also generated to copy the result back. The call
504 -- also takes care of any constraint checks required for the type
505 -- conversion case (on both the way in and the way out).
507 procedure Add_Simple_Call_By_Copy_Code
;
508 -- This is similar to the above, but is used in cases where we know
509 -- that all that is needed is to simply create a temporary and copy
510 -- the value in and out of the temporary.
512 procedure Check_Fortran_Logical
;
513 -- A value of type Logical that is passed through a formal parameter
514 -- must be normalized because .TRUE. usually does not have the same
515 -- representation as True. We assume that .FALSE. = False = 0.
516 -- What about functions that return a logical type ???
518 function Is_Legal_Copy
return Boolean;
519 -- Check that an actual can be copied before generating the temporary
520 -- to be used in the call. If the actual is of a by_reference type then
521 -- the program is illegal (this can only happen in the presence of
522 -- rep. clauses that force an incorrect alignment). If the formal is
523 -- a by_reference parameter imposed by a DEC pragma, emit a warning to
524 -- the effect that this might lead to unaligned arguments.
526 function Make_Var
(Actual
: Node_Id
) return Entity_Id
;
527 -- Returns an entity that refers to the given actual parameter,
528 -- Actual (not including any type conversion). If Actual is an
529 -- entity name, then this entity is returned unchanged, otherwise
530 -- a renaming is created to provide an entity for the actual.
532 procedure Reset_Packed_Prefix
;
533 -- The expansion of a packed array component reference is delayed in
534 -- the context of a call. Now we need to complete the expansion, so we
535 -- unmark the analyzed bits in all prefixes.
537 ---------------------------
538 -- Add_Call_By_Copy_Code --
539 ---------------------------
541 procedure Add_Call_By_Copy_Code
is
547 F_Typ
: constant Entity_Id
:= Etype
(Formal
);
552 if not Is_Legal_Copy
then
556 Temp
:= Make_Defining_Identifier
(Loc
, New_Internal_Name
('T'));
558 -- Use formal type for temp, unless formal type is an unconstrained
559 -- array, in which case we don't have to worry about bounds checks,
560 -- and we use the actual type, since that has appropriate bounds.
562 if Is_Array_Type
(F_Typ
) and then not Is_Constrained
(F_Typ
) then
563 Indic
:= New_Occurrence_Of
(Etype
(Actual
), Loc
);
565 Indic
:= New_Occurrence_Of
(Etype
(Formal
), Loc
);
568 if Nkind
(Actual
) = N_Type_Conversion
then
569 V_Typ
:= Etype
(Expression
(Actual
));
571 -- If the formal is an (in-)out parameter, capture the name
572 -- of the variable in order to build the post-call assignment.
574 Var
:= Make_Var
(Expression
(Actual
));
576 Crep
:= not Same_Representation
577 (F_Typ
, Etype
(Expression
(Actual
)));
580 V_Typ
:= Etype
(Actual
);
581 Var
:= Make_Var
(Actual
);
585 -- Setup initialization for case of in out parameter, or an out
586 -- parameter where the formal is an unconstrained array (in the
587 -- latter case, we have to pass in an object with bounds).
589 -- If this is an out parameter, the initial copy is wasteful, so as
590 -- an optimization for the one-dimensional case we extract the
591 -- bounds of the actual and build an uninitialized temporary of the
594 if Ekind
(Formal
) = E_In_Out_Parameter
595 or else (Is_Array_Type
(F_Typ
) and then not Is_Constrained
(F_Typ
))
597 if Nkind
(Actual
) = N_Type_Conversion
then
598 if Conversion_OK
(Actual
) then
599 Init
:= OK_Convert_To
(F_Typ
, New_Occurrence_Of
(Var
, Loc
));
601 Init
:= Convert_To
(F_Typ
, New_Occurrence_Of
(Var
, Loc
));
604 elsif Ekind
(Formal
) = E_Out_Parameter
605 and then Is_Array_Type
(F_Typ
)
606 and then Number_Dimensions
(F_Typ
) = 1
607 and then not Has_Non_Null_Base_Init_Proc
(F_Typ
)
609 -- Actual is a one-dimensional array or slice, and the type
610 -- requires no initialization. Create a temporary of the
611 -- right size, but do not copy actual into it (optimization).
615 Make_Subtype_Indication
(Loc
,
617 New_Occurrence_Of
(F_Typ
, Loc
),
619 Make_Index_Or_Discriminant_Constraint
(Loc
,
620 Constraints
=> New_List
(
623 Make_Attribute_Reference
(Loc
,
624 Prefix
=> New_Occurrence_Of
(Var
, Loc
),
625 Attribute_name
=> Name_First
),
627 Make_Attribute_Reference
(Loc
,
628 Prefix
=> New_Occurrence_Of
(Var
, Loc
),
629 Attribute_Name
=> Name_Last
)))));
632 Init
:= New_Occurrence_Of
(Var
, Loc
);
635 -- An initialization is created for packed conversions as
636 -- actuals for out parameters to enable Make_Object_Declaration
637 -- to determine the proper subtype for N_Node. Note that this
638 -- is wasteful because the extra copying on the call side is
639 -- not required for such out parameters. ???
641 elsif Ekind
(Formal
) = E_Out_Parameter
642 and then Nkind
(Actual
) = N_Type_Conversion
643 and then (Is_Bit_Packed_Array
(F_Typ
)
645 Is_Bit_Packed_Array
(Etype
(Expression
(Actual
))))
647 if Conversion_OK
(Actual
) then
648 Init
:= OK_Convert_To
(F_Typ
, New_Occurrence_Of
(Var
, Loc
));
650 Init
:= Convert_To
(F_Typ
, New_Occurrence_Of
(Var
, Loc
));
653 elsif Ekind
(Formal
) = E_In_Parameter
then
654 Init
:= New_Occurrence_Of
(Var
, Loc
);
661 Make_Object_Declaration
(Loc
,
662 Defining_Identifier
=> Temp
,
663 Object_Definition
=> Indic
,
665 Set_Assignment_OK
(N_Node
);
666 Insert_Action
(N
, N_Node
);
668 -- Now, normally the deal here is that we use the defining
669 -- identifier created by that object declaration. There is
670 -- one exception to this. In the change of representation case
671 -- the above declaration will end up looking like:
673 -- temp : type := identifier;
675 -- And in this case we might as well use the identifier directly
676 -- and eliminate the temporary. Note that the analysis of the
677 -- declaration was not a waste of time in that case, since it is
678 -- what generated the necessary change of representation code. If
679 -- the change of representation introduced additional code, as in
680 -- a fixed-integer conversion, the expression is not an identifier
684 and then Present
(Expression
(N_Node
))
685 and then Is_Entity_Name
(Expression
(N_Node
))
687 Temp
:= Entity
(Expression
(N_Node
));
688 Rewrite
(N_Node
, Make_Null_Statement
(Loc
));
691 -- For IN parameter, all we do is to replace the actual
693 if Ekind
(Formal
) = E_In_Parameter
then
694 Rewrite
(Actual
, New_Reference_To
(Temp
, Loc
));
697 -- Processing for OUT or IN OUT parameter
700 -- If type conversion, use reverse conversion on exit
702 if Nkind
(Actual
) = N_Type_Conversion
then
703 if Conversion_OK
(Actual
) then
704 Expr
:= OK_Convert_To
(V_Typ
, New_Occurrence_Of
(Temp
, Loc
));
706 Expr
:= Convert_To
(V_Typ
, New_Occurrence_Of
(Temp
, Loc
));
709 Expr
:= New_Occurrence_Of
(Temp
, Loc
);
712 Rewrite
(Actual
, New_Reference_To
(Temp
, Loc
));
715 Append_To
(Post_Call
,
716 Make_Assignment_Statement
(Loc
,
717 Name
=> New_Occurrence_Of
(Var
, Loc
),
718 Expression
=> Expr
));
720 Set_Assignment_OK
(Name
(Last
(Post_Call
)));
722 end Add_Call_By_Copy_Code
;
724 ----------------------------------
725 -- Add_Simple_Call_By_Copy_Code --
726 ----------------------------------
728 procedure Add_Simple_Call_By_Copy_Code
is
736 F_Typ
: constant Entity_Id
:= Etype
(Formal
);
739 if not Is_Legal_Copy
then
743 -- Use formal type for temp, unless formal type is an unconstrained
744 -- array, in which case we don't have to worry about bounds checks,
745 -- and we use the actual type, since that has appropriate bounds.
747 if Is_Array_Type
(F_Typ
) and then not Is_Constrained
(F_Typ
) then
748 Indic
:= New_Occurrence_Of
(Etype
(Actual
), Loc
);
750 Indic
:= New_Occurrence_Of
(Etype
(Formal
), Loc
);
753 -- Prepare to generate code
757 Temp
:= Make_Defining_Identifier
(Loc
, New_Internal_Name
('T'));
758 Incod
:= Relocate_Node
(Actual
);
759 Outcod
:= New_Copy_Tree
(Incod
);
761 -- Generate declaration of temporary variable, initializing it
762 -- with the input parameter unless we have an OUT formal or
763 -- this is an initialization call.
765 -- If the formal is an out parameter with discriminants, the
766 -- discriminants must be captured even if the rest of the object
767 -- is in principle uninitialized, because the discriminants may
768 -- be read by the called subprogram.
770 if Ekind
(Formal
) = E_Out_Parameter
then
773 if Has_Discriminants
(Etype
(Formal
)) then
774 Indic
:= New_Occurrence_Of
(Etype
(Actual
), Loc
);
777 elsif Inside_Init_Proc
then
779 -- Could use a comment here to match comment below ???
781 if Nkind
(Actual
) /= N_Selected_Component
783 not Has_Discriminant_Dependent_Constraint
784 (Entity
(Selector_Name
(Actual
)))
788 -- Otherwise, keep the component in order to generate the proper
789 -- actual subtype, that depends on enclosing discriminants.
797 Make_Object_Declaration
(Loc
,
798 Defining_Identifier
=> Temp
,
799 Object_Definition
=> Indic
,
800 Expression
=> Incod
);
805 -- If the call is to initialize a component of a composite type,
806 -- and the component does not depend on discriminants, use the
807 -- actual type of the component. This is required in case the
808 -- component is constrained, because in general the formal of the
809 -- initialization procedure will be unconstrained. Note that if
810 -- the component being initialized is constrained by an enclosing
811 -- discriminant, the presence of the initialization in the
812 -- declaration will generate an expression for the actual subtype.
814 Set_No_Initialization
(Decl
);
815 Set_Object_Definition
(Decl
,
816 New_Occurrence_Of
(Etype
(Actual
), Loc
));
819 Insert_Action
(N
, Decl
);
821 -- The actual is simply a reference to the temporary
823 Rewrite
(Actual
, New_Occurrence_Of
(Temp
, Loc
));
825 -- Generate copy out if OUT or IN OUT parameter
827 if Ekind
(Formal
) /= E_In_Parameter
then
829 Rhs
:= New_Occurrence_Of
(Temp
, Loc
);
831 -- Deal with conversion
833 if Nkind
(Lhs
) = N_Type_Conversion
then
834 Lhs
:= Expression
(Lhs
);
835 Rhs
:= Convert_To
(Etype
(Actual
), Rhs
);
838 Append_To
(Post_Call
,
839 Make_Assignment_Statement
(Loc
,
842 Set_Assignment_OK
(Name
(Last
(Post_Call
)));
844 end Add_Simple_Call_By_Copy_Code
;
846 ---------------------------
847 -- Check_Fortran_Logical --
848 ---------------------------
850 procedure Check_Fortran_Logical
is
851 Logical
: constant Entity_Id
:= Etype
(Formal
);
854 -- Note: this is very incomplete, e.g. it does not handle arrays
855 -- of logical values. This is really not the right approach at all???)
858 if Convention
(Subp
) = Convention_Fortran
859 and then Root_Type
(Etype
(Formal
)) = Standard_Boolean
860 and then Ekind
(Formal
) /= E_In_Parameter
862 Var
:= Make_Var
(Actual
);
863 Append_To
(Post_Call
,
864 Make_Assignment_Statement
(Loc
,
865 Name
=> New_Occurrence_Of
(Var
, Loc
),
867 Unchecked_Convert_To
(
870 Left_Opnd
=> New_Occurrence_Of
(Var
, Loc
),
872 Unchecked_Convert_To
(
874 New_Occurrence_Of
(Standard_False
, Loc
))))));
876 end Check_Fortran_Logical
;
882 function Is_Legal_Copy
return Boolean is
884 -- An attempt to copy a value of such a type can only occur if
885 -- representation clauses give the actual a misaligned address.
887 if Is_By_Reference_Type
(Etype
(Formal
)) then
889 ("misaligned actual cannot be passed by reference", Actual
);
892 -- For users of Starlet, we assume that the specification of by-
893 -- reference mechanism is mandatory. This may lead to unligned
894 -- objects but at least for DEC legacy code it is known to work.
895 -- The warning will alert users of this code that a problem may
898 elsif Mechanism
(Formal
) = By_Reference
899 and then Is_Valued_Procedure
(Scope
(Formal
))
902 ("by_reference actual may be misaligned?", Actual
);
914 function Make_Var
(Actual
: Node_Id
) return Entity_Id
is
918 if Is_Entity_Name
(Actual
) then
919 return Entity
(Actual
);
922 Var
:= Make_Defining_Identifier
(Loc
, New_Internal_Name
('T'));
925 Make_Object_Renaming_Declaration
(Loc
,
926 Defining_Identifier
=> Var
,
928 New_Occurrence_Of
(Etype
(Actual
), Loc
),
929 Name
=> Relocate_Node
(Actual
));
931 Insert_Action
(N
, N_Node
);
936 -------------------------
937 -- Reset_Packed_Prefix --
938 -------------------------
940 procedure Reset_Packed_Prefix
is
941 Pfx
: Node_Id
:= Actual
;
944 Set_Analyzed
(Pfx
, False);
945 exit when Nkind
(Pfx
) /= N_Selected_Component
946 and then Nkind
(Pfx
) /= N_Indexed_Component
;
949 end Reset_Packed_Prefix
;
951 -- Start of processing for Expand_Actuals
954 Post_Call
:= New_List
;
956 Formal
:= First_Formal
(Subp
);
957 Actual
:= First_Actual
(N
);
958 while Present
(Formal
) loop
959 E_Formal
:= Etype
(Formal
);
961 if Is_Scalar_Type
(E_Formal
)
962 or else Nkind
(Actual
) = N_Slice
964 Check_Fortran_Logical
;
968 elsif Ekind
(Formal
) /= E_Out_Parameter
then
970 -- The unusual case of the current instance of a protected type
971 -- requires special handling. This can only occur in the context
972 -- of a call within the body of a protected operation.
974 if Is_Entity_Name
(Actual
)
975 and then Ekind
(Entity
(Actual
)) = E_Protected_Type
976 and then In_Open_Scopes
(Entity
(Actual
))
978 if Scope
(Subp
) /= Entity
(Actual
) then
979 Error_Msg_N
("operation outside protected type may not "
980 & "call back its protected operations?", Actual
);
984 Expand_Protected_Object_Reference
(N
, Entity
(Actual
)));
987 Apply_Constraint_Check
(Actual
, E_Formal
);
989 -- Out parameter case. No constraint checks on access type
992 elsif Is_Access_Type
(E_Formal
) then
997 elsif Has_Discriminants
(Base_Type
(E_Formal
))
998 or else Has_Non_Null_Base_Init_Proc
(E_Formal
)
1000 Apply_Constraint_Check
(Actual
, E_Formal
);
1005 Apply_Constraint_Check
(Actual
, Base_Type
(E_Formal
));
1008 -- Processing for IN-OUT and OUT parameters
1010 if Ekind
(Formal
) /= E_In_Parameter
then
1012 -- For type conversions of arrays, apply length/range checks
1014 if Is_Array_Type
(E_Formal
)
1015 and then Nkind
(Actual
) = N_Type_Conversion
1017 if Is_Constrained
(E_Formal
) then
1018 Apply_Length_Check
(Expression
(Actual
), E_Formal
);
1020 Apply_Range_Check
(Expression
(Actual
), E_Formal
);
1024 -- If argument is a type conversion for a type that is passed
1025 -- by copy, then we must pass the parameter by copy.
1027 if Nkind
(Actual
) = N_Type_Conversion
1029 (Is_Numeric_Type
(E_Formal
)
1030 or else Is_Access_Type
(E_Formal
)
1031 or else Is_Enumeration_Type
(E_Formal
)
1032 or else Is_Bit_Packed_Array
(Etype
(Formal
))
1033 or else Is_Bit_Packed_Array
(Etype
(Expression
(Actual
)))
1035 -- Also pass by copy if change of representation
1037 or else not Same_Representation
1039 Etype
(Expression
(Actual
))))
1041 Add_Call_By_Copy_Code
;
1043 -- References to components of bit packed arrays are expanded
1044 -- at this point, rather than at the point of analysis of the
1045 -- actuals, to handle the expansion of the assignment to
1046 -- [in] out parameters.
1048 elsif Is_Ref_To_Bit_Packed_Array
(Actual
) then
1049 Add_Simple_Call_By_Copy_Code
;
1051 -- If a non-scalar actual is possibly unaligned, we need a copy
1053 elsif Is_Possibly_Unaligned_Object
(Actual
)
1054 and then not Represented_As_Scalar
(Etype
(Formal
))
1056 Add_Simple_Call_By_Copy_Code
;
1058 -- References to slices of bit packed arrays are expanded
1060 elsif Is_Ref_To_Bit_Packed_Slice
(Actual
) then
1061 Add_Call_By_Copy_Code
;
1063 -- References to possibly unaligned slices of arrays are expanded
1065 elsif Is_Possibly_Unaligned_Slice
(Actual
) then
1066 Add_Call_By_Copy_Code
;
1068 -- Deal with access types where the actual subtpe and the
1069 -- formal subtype are not the same, requiring a check.
1071 -- It is necessary to exclude tagged types because of "downward
1072 -- conversion" errors and a strange assertion error in namet
1073 -- from gnatf in bug 1215-001 ???
1075 elsif Is_Access_Type
(E_Formal
)
1076 and then not Same_Type
(E_Formal
, Etype
(Actual
))
1077 and then not Is_Tagged_Type
(Designated_Type
(E_Formal
))
1079 Add_Call_By_Copy_Code
;
1081 -- If the actual is not a scalar and is marked for volatile
1082 -- treatment, whereas the formal is not volatile, then pass
1083 -- by copy unless it is a by-reference type.
1085 elsif Is_Entity_Name
(Actual
)
1086 and then Treat_As_Volatile
(Entity
(Actual
))
1087 and then not Is_By_Reference_Type
(Etype
(Actual
))
1088 and then not Is_Scalar_Type
(Etype
(Entity
(Actual
)))
1089 and then not Treat_As_Volatile
(E_Formal
)
1091 Add_Call_By_Copy_Code
;
1093 elsif Nkind
(Actual
) = N_Indexed_Component
1094 and then Is_Entity_Name
(Prefix
(Actual
))
1095 and then Has_Volatile_Components
(Entity
(Prefix
(Actual
)))
1097 Add_Call_By_Copy_Code
;
1100 -- Processing for IN parameters
1103 -- For IN parameters is in the packed array case, we expand an
1104 -- indexed component (the circuit in Exp_Ch4 deliberately left
1105 -- indexed components appearing as actuals untouched, so that
1106 -- the special processing above for the OUT and IN OUT cases
1107 -- could be performed. We could make the test in Exp_Ch4 more
1108 -- complex and have it detect the parameter mode, but it is
1109 -- easier simply to handle all cases here.)
1111 if Nkind
(Actual
) = N_Indexed_Component
1112 and then Is_Packed
(Etype
(Prefix
(Actual
)))
1114 Reset_Packed_Prefix
;
1115 Expand_Packed_Element_Reference
(Actual
);
1117 -- If we have a reference to a bit packed array, we copy it,
1118 -- since the actual must be byte aligned.
1120 -- Is this really necessary in all cases???
1122 elsif Is_Ref_To_Bit_Packed_Array
(Actual
) then
1123 Add_Simple_Call_By_Copy_Code
;
1125 -- If a non-scalar actual is possibly unaligned, we need a copy
1127 elsif Is_Possibly_Unaligned_Object
(Actual
)
1128 and then not Represented_As_Scalar
(Etype
(Formal
))
1130 Add_Simple_Call_By_Copy_Code
;
1132 -- Similarly, we have to expand slices of packed arrays here
1133 -- because the result must be byte aligned.
1135 elsif Is_Ref_To_Bit_Packed_Slice
(Actual
) then
1136 Add_Call_By_Copy_Code
;
1138 -- Only processing remaining is to pass by copy if this is a
1139 -- reference to a possibly unaligned slice, since the caller
1140 -- expects an appropriately aligned argument.
1142 elsif Is_Possibly_Unaligned_Slice
(Actual
) then
1143 Add_Call_By_Copy_Code
;
1147 Next_Formal
(Formal
);
1148 Next_Actual
(Actual
);
1151 -- Find right place to put post call stuff if it is present
1153 if not Is_Empty_List
(Post_Call
) then
1155 -- If call is not a list member, it must be the triggering statement
1156 -- of a triggering alternative or an entry call alternative, and we
1157 -- can add the post call stuff to the corresponding statement list.
1159 if not Is_List_Member
(N
) then
1161 P
: constant Node_Id
:= Parent
(N
);
1164 pragma Assert
(Nkind
(P
) = N_Triggering_Alternative
1165 or else Nkind
(P
) = N_Entry_Call_Alternative
);
1167 if Is_Non_Empty_List
(Statements
(P
)) then
1168 Insert_List_Before_And_Analyze
1169 (First
(Statements
(P
)), Post_Call
);
1171 Set_Statements
(P
, Post_Call
);
1175 -- Otherwise, normal case where N is in a statement sequence,
1176 -- just put the post-call stuff after the call statement.
1179 Insert_Actions_After
(N
, Post_Call
);
1183 -- The call node itself is re-analyzed in Expand_Call
1191 -- This procedure handles expansion of function calls and procedure call
1192 -- statements (i.e. it serves as the body for Expand_N_Function_Call and
1193 -- Expand_N_Procedure_Call_Statement. Processing for calls includes:
1195 -- Replace call to Raise_Exception by Raise_Exception always if possible
1196 -- Provide values of actuals for all formals in Extra_Formals list
1197 -- Replace "call" to enumeration literal function by literal itself
1198 -- Rewrite call to predefined operator as operator
1199 -- Replace actuals to in-out parameters that are numeric conversions,
1200 -- with explicit assignment to temporaries before and after the call.
1201 -- Remove optional actuals if First_Optional_Parameter specified.
1203 -- Note that the list of actuals has been filled with default expressions
1204 -- during semantic analysis of the call. Only the extra actuals required
1205 -- for the 'Constrained attribute and for accessibility checks are added
1208 procedure Expand_Call
(N
: Node_Id
) is
1209 Loc
: constant Source_Ptr
:= Sloc
(N
);
1210 Remote
: constant Boolean := Is_Remote_Call
(N
);
1212 Orig_Subp
: Entity_Id
:= Empty
;
1213 Parent_Subp
: Entity_Id
;
1214 Parent_Formal
: Entity_Id
;
1217 Prev
: Node_Id
:= Empty
;
1219 Prev_Orig
: Node_Id
;
1220 -- Original node for an actual, which may have been rewritten. If the
1221 -- actual is a function call that has been transformed from a selected
1222 -- component, the original node is unanalyzed. Otherwise, it carries
1223 -- semantic information used to generate additional actuals.
1226 Extra_Actuals
: List_Id
:= No_List
;
1228 CW_Interface_Formals_Present
: Boolean := False;
1230 procedure Add_Actual_Parameter
(Insert_Param
: Node_Id
);
1231 -- Adds one entry to the end of the actual parameter list. Used for
1232 -- default parameters and for extra actuals (for Extra_Formals). The
1233 -- argument is an N_Parameter_Association node.
1235 procedure Add_Extra_Actual
(Expr
: Node_Id
; EF
: Entity_Id
);
1236 -- Adds an extra actual to the list of extra actuals. Expr is the
1237 -- expression for the value of the actual, EF is the entity for the
1240 function Inherited_From_Formal
(S
: Entity_Id
) return Entity_Id
;
1241 -- Within an instance, a type derived from a non-tagged formal derived
1242 -- type inherits from the original parent, not from the actual. This is
1243 -- tested in 4723-003. The current derivation mechanism has the derived
1244 -- type inherit from the actual, which is only correct outside of the
1245 -- instance. If the subprogram is inherited, we test for this particular
1246 -- case through a convoluted tree traversal before setting the proper
1247 -- subprogram to be called.
1249 --------------------------
1250 -- Add_Actual_Parameter --
1251 --------------------------
1253 procedure Add_Actual_Parameter
(Insert_Param
: Node_Id
) is
1254 Actual_Expr
: constant Node_Id
:=
1255 Explicit_Actual_Parameter
(Insert_Param
);
1258 -- Case of insertion is first named actual
1260 if No
(Prev
) or else
1261 Nkind
(Parent
(Prev
)) /= N_Parameter_Association
1263 Set_Next_Named_Actual
(Insert_Param
, First_Named_Actual
(N
));
1264 Set_First_Named_Actual
(N
, Actual_Expr
);
1267 if not Present
(Parameter_Associations
(N
)) then
1268 Set_Parameter_Associations
(N
, New_List
);
1269 Append
(Insert_Param
, Parameter_Associations
(N
));
1272 Insert_After
(Prev
, Insert_Param
);
1275 -- Case of insertion is not first named actual
1278 Set_Next_Named_Actual
1279 (Insert_Param
, Next_Named_Actual
(Parent
(Prev
)));
1280 Set_Next_Named_Actual
(Parent
(Prev
), Actual_Expr
);
1281 Append
(Insert_Param
, Parameter_Associations
(N
));
1284 Prev
:= Actual_Expr
;
1285 end Add_Actual_Parameter
;
1287 ----------------------
1288 -- Add_Extra_Actual --
1289 ----------------------
1291 procedure Add_Extra_Actual
(Expr
: Node_Id
; EF
: Entity_Id
) is
1292 Loc
: constant Source_Ptr
:= Sloc
(Expr
);
1295 if Extra_Actuals
= No_List
then
1296 Extra_Actuals
:= New_List
;
1297 Set_Parent
(Extra_Actuals
, N
);
1300 Append_To
(Extra_Actuals
,
1301 Make_Parameter_Association
(Loc
,
1302 Explicit_Actual_Parameter
=> Expr
,
1304 Make_Identifier
(Loc
, Chars
(EF
))));
1306 Analyze_And_Resolve
(Expr
, Etype
(EF
));
1307 end Add_Extra_Actual
;
1309 ---------------------------
1310 -- Inherited_From_Formal --
1311 ---------------------------
1313 function Inherited_From_Formal
(S
: Entity_Id
) return Entity_Id
is
1315 Gen_Par
: Entity_Id
;
1316 Gen_Prim
: Elist_Id
;
1321 -- If the operation is inherited, it is attached to the corresponding
1322 -- type derivation. If the parent in the derivation is a generic
1323 -- actual, it is a subtype of the actual, and we have to recover the
1324 -- original derived type declaration to find the proper parent.
1326 if Nkind
(Parent
(S
)) /= N_Full_Type_Declaration
1327 or else not Is_Derived_Type
(Defining_Identifier
(Parent
(S
)))
1328 or else Nkind
(Type_Definition
(Original_Node
(Parent
(S
)))) /=
1329 N_Derived_Type_Definition
1330 or else not In_Instance
1337 (Type_Definition
(Original_Node
(Parent
(S
)))));
1339 if Nkind
(Indic
) = N_Subtype_Indication
then
1340 Par
:= Entity
(Subtype_Mark
(Indic
));
1342 Par
:= Entity
(Indic
);
1346 if not Is_Generic_Actual_Type
(Par
)
1347 or else Is_Tagged_Type
(Par
)
1348 or else Nkind
(Parent
(Par
)) /= N_Subtype_Declaration
1349 or else not In_Open_Scopes
(Scope
(Par
))
1354 Gen_Par
:= Generic_Parent_Type
(Parent
(Par
));
1357 -- If the generic parent type is still the generic type, this is a
1358 -- private formal, not a derived formal, and there are no operations
1359 -- inherited from the formal.
1361 if Nkind
(Parent
(Gen_Par
)) = N_Formal_Type_Declaration
then
1365 Gen_Prim
:= Collect_Primitive_Operations
(Gen_Par
);
1367 Elmt
:= First_Elmt
(Gen_Prim
);
1368 while Present
(Elmt
) loop
1369 if Chars
(Node
(Elmt
)) = Chars
(S
) then
1375 F1
:= First_Formal
(S
);
1376 F2
:= First_Formal
(Node
(Elmt
));
1378 and then Present
(F2
)
1380 if Etype
(F1
) = Etype
(F2
)
1381 or else Etype
(F2
) = Gen_Par
1387 exit; -- not the right subprogram
1399 raise Program_Error
;
1400 end Inherited_From_Formal
;
1402 -- Start of processing for Expand_Call
1405 -- Ignore if previous error
1407 if Nkind
(N
) in N_Has_Etype
and then Etype
(N
) = Any_Type
then
1411 -- Call using access to subprogram with explicit dereference
1413 if Nkind
(Name
(N
)) = N_Explicit_Dereference
then
1414 Subp
:= Etype
(Name
(N
));
1415 Parent_Subp
:= Empty
;
1417 -- Case of call to simple entry, where the Name is a selected component
1418 -- whose prefix is the task, and whose selector name is the entry name
1420 elsif Nkind
(Name
(N
)) = N_Selected_Component
then
1421 Subp
:= Entity
(Selector_Name
(Name
(N
)));
1422 Parent_Subp
:= Empty
;
1424 -- Case of call to member of entry family, where Name is an indexed
1425 -- component, with the prefix being a selected component giving the
1426 -- task and entry family name, and the index being the entry index.
1428 elsif Nkind
(Name
(N
)) = N_Indexed_Component
then
1429 Subp
:= Entity
(Selector_Name
(Prefix
(Name
(N
))));
1430 Parent_Subp
:= Empty
;
1435 Subp
:= Entity
(Name
(N
));
1436 Parent_Subp
:= Alias
(Subp
);
1438 -- Replace call to Raise_Exception by call to Raise_Exception_Always
1439 -- if we can tell that the first parameter cannot possibly be null.
1440 -- This helps optimization and also generation of warnings.
1442 if not Restriction_Active
(No_Exception_Handlers
)
1443 and then Is_RTE
(Subp
, RE_Raise_Exception
)
1446 FA
: constant Node_Id
:= Original_Node
(First_Actual
(N
));
1449 -- The case we catch is where the first argument is obtained
1450 -- using the Identity attribute (which must always be
1453 if Nkind
(FA
) = N_Attribute_Reference
1454 and then Attribute_Name
(FA
) = Name_Identity
1456 Subp
:= RTE
(RE_Raise_Exception_Always
);
1457 Set_Entity
(Name
(N
), Subp
);
1462 if Ekind
(Subp
) = E_Entry
then
1463 Parent_Subp
:= Empty
;
1467 -- First step, compute extra actuals, corresponding to any
1468 -- Extra_Formals present. Note that we do not access Extra_Formals
1469 -- directly, instead we simply note the presence of the extra
1470 -- formals as we process the regular formals and collect the
1471 -- corresponding actuals in Extra_Actuals.
1473 -- We also generate any required range checks for actuals as we go
1474 -- through the loop, since this is a convenient place to do this.
1476 Formal
:= First_Formal
(Subp
);
1477 Actual
:= First_Actual
(N
);
1478 while Present
(Formal
) loop
1480 -- Generate range check if required (not activated yet ???)
1482 -- if Do_Range_Check (Actual) then
1483 -- Set_Do_Range_Check (Actual, False);
1484 -- Generate_Range_Check
1485 -- (Actual, Etype (Formal), CE_Range_Check_Failed);
1488 -- Prepare to examine current entry
1491 Prev_Orig
:= Original_Node
(Prev
);
1493 if not Analyzed
(Prev_Orig
)
1494 and then Nkind
(Actual
) = N_Function_Call
1499 -- Ada 2005 (AI-251): Check if any formal is a class-wide interface
1500 -- to expand it in a further round.
1502 CW_Interface_Formals_Present
:=
1503 CW_Interface_Formals_Present
1505 (Ekind
(Etype
(Formal
)) = E_Class_Wide_Type
1506 and then Is_Interface
(Etype
(Etype
(Formal
))))
1508 (Ekind
(Etype
(Formal
)) = E_Anonymous_Access_Type
1509 and then Is_Interface
(Directly_Designated_Type
1510 (Etype
(Etype
(Formal
)))));
1512 -- Create possible extra actual for constrained case. Usually, the
1513 -- extra actual is of the form actual'constrained, but since this
1514 -- attribute is only available for unconstrained records, TRUE is
1515 -- expanded if the type of the formal happens to be constrained (for
1516 -- instance when this procedure is inherited from an unconstrained
1517 -- record to a constrained one) or if the actual has no discriminant
1518 -- (its type is constrained). An exception to this is the case of a
1519 -- private type without discriminants. In this case we pass FALSE
1520 -- because the object has underlying discriminants with defaults.
1522 if Present
(Extra_Constrained
(Formal
)) then
1523 if Ekind
(Etype
(Prev
)) in Private_Kind
1524 and then not Has_Discriminants
(Base_Type
(Etype
(Prev
)))
1527 New_Occurrence_Of
(Standard_False
, Loc
),
1528 Extra_Constrained
(Formal
));
1530 elsif Is_Constrained
(Etype
(Formal
))
1531 or else not Has_Discriminants
(Etype
(Prev
))
1534 New_Occurrence_Of
(Standard_True
, Loc
),
1535 Extra_Constrained
(Formal
));
1537 -- Do not produce extra actuals for Unchecked_Union parameters.
1538 -- Jump directly to the end of the loop.
1540 elsif Is_Unchecked_Union
(Base_Type
(Etype
(Actual
))) then
1541 goto Skip_Extra_Actual_Generation
;
1544 -- If the actual is a type conversion, then the constrained
1545 -- test applies to the actual, not the target type.
1551 -- Test for unchecked conversions as well, which can occur
1552 -- as out parameter actuals on calls to stream procedures.
1555 while Nkind
(Act_Prev
) = N_Type_Conversion
1556 or else Nkind
(Act_Prev
) = N_Unchecked_Type_Conversion
1558 Act_Prev
:= Expression
(Act_Prev
);
1562 Make_Attribute_Reference
(Sloc
(Prev
),
1564 Duplicate_Subexpr_No_Checks
1565 (Act_Prev
, Name_Req
=> True),
1566 Attribute_Name
=> Name_Constrained
),
1567 Extra_Constrained
(Formal
));
1572 -- Create possible extra actual for accessibility level
1574 if Present
(Extra_Accessibility
(Formal
)) then
1575 if Is_Entity_Name
(Prev_Orig
) then
1577 -- When passing an access parameter as the actual to another
1578 -- access parameter we need to pass along the actual's own
1579 -- associated access level parameter. This is done if we are
1580 -- in the scope of the formal access parameter (if this is an
1581 -- inlined body the extra formal is irrelevant).
1583 if Ekind
(Entity
(Prev_Orig
)) in Formal_Kind
1584 and then Ekind
(Etype
(Prev_Orig
)) = E_Anonymous_Access_Type
1585 and then In_Open_Scopes
(Scope
(Entity
(Prev_Orig
)))
1588 Parm_Ent
: constant Entity_Id
:= Param_Entity
(Prev_Orig
);
1591 pragma Assert
(Present
(Parm_Ent
));
1593 if Present
(Extra_Accessibility
(Parm_Ent
)) then
1596 (Extra_Accessibility
(Parm_Ent
), Loc
),
1597 Extra_Accessibility
(Formal
));
1599 -- If the actual access parameter does not have an
1600 -- associated extra formal providing its scope level,
1601 -- then treat the actual as having library-level
1606 Make_Integer_Literal
(Loc
,
1607 Intval
=> Scope_Depth
(Standard_Standard
)),
1608 Extra_Accessibility
(Formal
));
1612 -- The actual is a normal access value, so just pass the
1613 -- level of the actual's access type.
1617 Make_Integer_Literal
(Loc
,
1618 Intval
=> Type_Access_Level
(Etype
(Prev_Orig
))),
1619 Extra_Accessibility
(Formal
));
1623 case Nkind
(Prev_Orig
) is
1625 when N_Attribute_Reference
=>
1627 case Get_Attribute_Id
(Attribute_Name
(Prev_Orig
)) is
1629 -- For X'Access, pass on the level of the prefix X
1631 when Attribute_Access
=>
1633 Make_Integer_Literal
(Loc
,
1635 Object_Access_Level
(Prefix
(Prev_Orig
))),
1636 Extra_Accessibility
(Formal
));
1638 -- Treat the unchecked attributes as library-level
1640 when Attribute_Unchecked_Access |
1641 Attribute_Unrestricted_Access
=>
1643 Make_Integer_Literal
(Loc
,
1644 Intval
=> Scope_Depth
(Standard_Standard
)),
1645 Extra_Accessibility
(Formal
));
1647 -- No other cases of attributes returning access
1648 -- values that can be passed to access parameters
1651 raise Program_Error
;
1655 -- For allocators we pass the level of the execution of
1656 -- the called subprogram, which is one greater than the
1657 -- current scope level.
1661 Make_Integer_Literal
(Loc
,
1662 Scope_Depth
(Current_Scope
) + 1),
1663 Extra_Accessibility
(Formal
));
1665 -- For other cases we simply pass the level of the
1666 -- actual's access type.
1670 Make_Integer_Literal
(Loc
,
1671 Intval
=> Type_Access_Level
(Etype
(Prev_Orig
))),
1672 Extra_Accessibility
(Formal
));
1678 -- Perform the check of 4.6(49) that prevents a null value from being
1679 -- passed as an actual to an access parameter. Note that the check is
1680 -- elided in the common cases of passing an access attribute or
1681 -- access parameter as an actual. Also, we currently don't enforce
1682 -- this check for expander-generated actuals and when -gnatdj is set.
1684 if Ada_Version
>= Ada_05
then
1686 -- Ada 2005 (AI-231): Check null-excluding access types
1688 if Is_Access_Type
(Etype
(Formal
))
1689 and then Can_Never_Be_Null
(Etype
(Formal
))
1690 and then Nkind
(Prev
) /= N_Raise_Constraint_Error
1691 and then (Nkind
(Prev
) = N_Null
1692 or else not Can_Never_Be_Null
(Etype
(Prev
)))
1694 Install_Null_Excluding_Check
(Prev
);
1697 -- Ada_Version < Ada_05
1700 if Ekind
(Etype
(Formal
)) /= E_Anonymous_Access_Type
1701 or else Access_Checks_Suppressed
(Subp
)
1705 elsif Debug_Flag_J
then
1708 elsif not Comes_From_Source
(Prev
) then
1711 elsif Is_Entity_Name
(Prev
)
1712 and then Ekind
(Etype
(Prev
)) = E_Anonymous_Access_Type
1716 elsif Nkind
(Prev
) = N_Allocator
1717 or else Nkind
(Prev
) = N_Attribute_Reference
1721 -- Suppress null checks when passing to access parameters of Java
1722 -- subprograms. (Should this be done for other foreign conventions
1725 elsif Convention
(Subp
) = Convention_Java
then
1729 Install_Null_Excluding_Check
(Prev
);
1733 -- Perform appropriate validity checks on parameters that
1736 if Validity_Checks_On
then
1737 if (Ekind
(Formal
) = E_In_Parameter
1738 and then Validity_Check_In_Params
)
1740 (Ekind
(Formal
) = E_In_Out_Parameter
1741 and then Validity_Check_In_Out_Params
)
1743 -- If the actual is an indexed component of a packed
1744 -- type, it has not been expanded yet. It will be
1745 -- copied in the validity code that follows, and has
1746 -- to be expanded appropriately, so reanalyze it.
1748 if Nkind
(Actual
) = N_Indexed_Component
then
1749 Set_Analyzed
(Actual
, False);
1752 Ensure_Valid
(Actual
);
1756 -- For IN OUT and OUT parameters, ensure that subscripts are valid
1757 -- since this is a left side reference. We only do this for calls
1758 -- from the source program since we assume that compiler generated
1759 -- calls explicitly generate any required checks. We also need it
1760 -- only if we are doing standard validity checks, since clearly it
1761 -- is not needed if validity checks are off, and in subscript
1762 -- validity checking mode, all indexed components are checked with
1763 -- a call directly from Expand_N_Indexed_Component.
1765 if Comes_From_Source
(N
)
1766 and then Ekind
(Formal
) /= E_In_Parameter
1767 and then Validity_Checks_On
1768 and then Validity_Check_Default
1769 and then not Validity_Check_Subscripts
1771 Check_Valid_Lvalue_Subscripts
(Actual
);
1774 -- Mark any scalar OUT parameter that is a simple variable
1775 -- as no longer known to be valid (unless the type is always
1776 -- valid). This reflects the fact that if an OUT parameter
1777 -- is never set in a procedure, then it can become invalid
1778 -- on return from the procedure.
1780 if Ekind
(Formal
) = E_Out_Parameter
1781 and then Is_Entity_Name
(Actual
)
1782 and then Ekind
(Entity
(Actual
)) = E_Variable
1783 and then not Is_Known_Valid
(Etype
(Actual
))
1785 Set_Is_Known_Valid
(Entity
(Actual
), False);
1788 -- For an OUT or IN OUT parameter of an access type, if the
1789 -- actual is an entity, then it is no longer known to be non-null.
1791 if Ekind
(Formal
) /= E_In_Parameter
1792 and then Is_Entity_Name
(Actual
)
1793 and then Is_Access_Type
(Etype
(Actual
))
1795 Set_Is_Known_Non_Null
(Entity
(Actual
), False);
1798 -- If the formal is class wide and the actual is an aggregate, force
1799 -- evaluation so that the back end who does not know about class-wide
1800 -- type, does not generate a temporary of the wrong size.
1802 if not Is_Class_Wide_Type
(Etype
(Formal
)) then
1805 elsif Nkind
(Actual
) = N_Aggregate
1806 or else (Nkind
(Actual
) = N_Qualified_Expression
1807 and then Nkind
(Expression
(Actual
)) = N_Aggregate
)
1809 Force_Evaluation
(Actual
);
1812 -- In a remote call, if the formal is of a class-wide type, check
1813 -- that the actual meets the requirements described in E.4(18).
1816 and then Is_Class_Wide_Type
(Etype
(Formal
))
1818 Insert_Action
(Actual
,
1819 Make_Implicit_If_Statement
(N
,
1822 Get_Remotely_Callable
1823 (Duplicate_Subexpr_Move_Checks
(Actual
))),
1824 Then_Statements
=> New_List
(
1825 Make_Raise_Program_Error
(Loc
,
1826 Reason
=> PE_Illegal_RACW_E_4_18
))));
1829 -- This label is required when skipping extra actual generation for
1830 -- Unchecked_Union parameters.
1832 <<Skip_Extra_Actual_Generation
>>
1834 Next_Actual
(Actual
);
1835 Next_Formal
(Formal
);
1838 -- If we are expanding a rhs of an assignement we need to check if
1839 -- tag propagation is needed. This code belongs theorically in Analyze
1840 -- Assignment but has to be done earlier (bottom-up) because the
1841 -- assignment might be transformed into a declaration for an uncons-
1842 -- trained value, if the expression is classwide.
1844 if Nkind
(N
) = N_Function_Call
1845 and then Is_Tag_Indeterminate
(N
)
1846 and then Is_Entity_Name
(Name
(N
))
1849 Ass
: Node_Id
:= Empty
;
1852 if Nkind
(Parent
(N
)) = N_Assignment_Statement
then
1855 elsif Nkind
(Parent
(N
)) = N_Qualified_Expression
1856 and then Nkind
(Parent
(Parent
(N
))) = N_Assignment_Statement
1858 Ass
:= Parent
(Parent
(N
));
1862 and then Is_Class_Wide_Type
(Etype
(Name
(Ass
)))
1864 if Etype
(N
) /= Root_Type
(Etype
(Name
(Ass
))) then
1866 ("tag-indeterminate expression must have type&"
1867 & "('R'M 5.2 (6))", N
, Root_Type
(Etype
(Name
(Ass
))));
1869 Propagate_Tag
(Name
(Ass
), N
);
1872 -- The call will be rewritten as a dispatching call, and
1873 -- expanded as such.
1880 -- Ada 2005 (AI-251): If some formal is a class-wide interface, expand
1881 -- it to point to the correct secondary virtual table
1883 if (Nkind
(N
) = N_Function_Call
1884 or else Nkind
(N
) = N_Procedure_Call_Statement
)
1885 and then CW_Interface_Formals_Present
1887 Expand_Interface_Actuals
(N
);
1890 -- Deals with Dispatch_Call if we still have a call, before expanding
1891 -- extra actuals since this will be done on the re-analysis of the
1892 -- dispatching call. Note that we do not try to shorten the actual
1893 -- list for a dispatching call, it would not make sense to do so.
1894 -- Expansion of dispatching calls is suppressed when Java_VM, because
1895 -- the JVM back end directly handles the generation of dispatching
1896 -- calls and would have to undo any expansion to an indirect call.
1898 if (Nkind
(N
) = N_Function_Call
1899 or else Nkind
(N
) = N_Procedure_Call_Statement
)
1900 and then Present
(Controlling_Argument
(N
))
1901 and then not Java_VM
1903 Expand_Dispatching_Call
(N
);
1905 -- The following return is worrisome. Is it really OK to
1906 -- skip all remaining processing in this procedure ???
1910 -- Similarly, expand calls to RCI subprograms on which pragma
1911 -- All_Calls_Remote applies. The rewriting will be reanalyzed
1912 -- later. Do this only when the call comes from source since we do
1913 -- not want such a rewritting to occur in expanded code.
1915 elsif Is_All_Remote_Call
(N
) then
1916 Expand_All_Calls_Remote_Subprogram_Call
(N
);
1918 -- Similarly, do not add extra actuals for an entry call whose entity
1919 -- is a protected procedure, or for an internal protected subprogram
1920 -- call, because it will be rewritten as a protected subprogram call
1921 -- and reanalyzed (see Expand_Protected_Subprogram_Call).
1923 elsif Is_Protected_Type
(Scope
(Subp
))
1924 and then (Ekind
(Subp
) = E_Procedure
1925 or else Ekind
(Subp
) = E_Function
)
1929 -- During that loop we gathered the extra actuals (the ones that
1930 -- correspond to Extra_Formals), so now they can be appended.
1933 while Is_Non_Empty_List
(Extra_Actuals
) loop
1934 Add_Actual_Parameter
(Remove_Head
(Extra_Actuals
));
1938 -- At this point we have all the actuals, so this is the point at
1939 -- which the various expansion activities for actuals is carried out.
1941 Expand_Actuals
(N
, Subp
);
1943 -- If the subprogram is a renaming, or if it is inherited, replace it
1944 -- in the call with the name of the actual subprogram being called.
1945 -- If this is a dispatching call, the run-time decides what to call.
1946 -- The Alias attribute does not apply to entries.
1948 if Nkind
(N
) /= N_Entry_Call_Statement
1949 and then No
(Controlling_Argument
(N
))
1950 and then Present
(Parent_Subp
)
1952 if Present
(Inherited_From_Formal
(Subp
)) then
1953 Parent_Subp
:= Inherited_From_Formal
(Subp
);
1955 while Present
(Alias
(Parent_Subp
)) loop
1956 Parent_Subp
:= Alias
(Parent_Subp
);
1960 Set_Entity
(Name
(N
), Parent_Subp
);
1962 if Is_Abstract
(Parent_Subp
)
1963 and then not In_Instance
1966 ("cannot call abstract subprogram &!", Name
(N
), Parent_Subp
);
1969 -- Add an explicit conversion for parameter of the derived type.
1970 -- This is only done for scalar and access in-parameters. Others
1971 -- have been expanded in expand_actuals.
1973 Formal
:= First_Formal
(Subp
);
1974 Parent_Formal
:= First_Formal
(Parent_Subp
);
1975 Actual
:= First_Actual
(N
);
1977 -- It is not clear that conversion is needed for intrinsic
1978 -- subprograms, but it certainly is for those that are user-
1979 -- defined, and that can be inherited on derivation, namely
1980 -- unchecked conversion and deallocation.
1981 -- General case needs study ???
1983 if not Is_Intrinsic_Subprogram
(Parent_Subp
)
1984 or else Is_Generic_Instance
(Parent_Subp
)
1986 while Present
(Formal
) loop
1987 if Etype
(Formal
) /= Etype
(Parent_Formal
)
1988 and then Is_Scalar_Type
(Etype
(Formal
))
1989 and then Ekind
(Formal
) = E_In_Parameter
1990 and then not Raises_Constraint_Error
(Actual
)
1993 OK_Convert_To
(Etype
(Parent_Formal
),
1994 Relocate_Node
(Actual
)));
1997 Resolve
(Actual
, Etype
(Parent_Formal
));
1998 Enable_Range_Check
(Actual
);
2000 elsif Is_Access_Type
(Etype
(Formal
))
2001 and then Base_Type
(Etype
(Parent_Formal
)) /=
2002 Base_Type
(Etype
(Actual
))
2004 if Ekind
(Formal
) /= E_In_Parameter
then
2006 Convert_To
(Etype
(Parent_Formal
),
2007 Relocate_Node
(Actual
)));
2010 Resolve
(Actual
, Etype
(Parent_Formal
));
2013 Ekind
(Etype
(Parent_Formal
)) = E_Anonymous_Access_Type
2014 and then Designated_Type
(Etype
(Parent_Formal
))
2016 Designated_Type
(Etype
(Actual
))
2017 and then not Is_Controlling_Formal
(Formal
)
2019 -- This unchecked conversion is not necessary unless
2020 -- inlining is enabled, because in that case the type
2021 -- mismatch may become visible in the body about to be
2025 Unchecked_Convert_To
(Etype
(Parent_Formal
),
2026 Relocate_Node
(Actual
)));
2029 Resolve
(Actual
, Etype
(Parent_Formal
));
2033 Next_Formal
(Formal
);
2034 Next_Formal
(Parent_Formal
);
2035 Next_Actual
(Actual
);
2040 Subp
:= Parent_Subp
;
2043 -- Check for violation of No_Abort_Statements
2045 if Is_RTE
(Subp
, RE_Abort_Task
) then
2046 Check_Restriction
(No_Abort_Statements
, N
);
2048 -- Check for violation of No_Dynamic_Attachment
2050 elsif RTU_Loaded
(Ada_Interrupts
)
2051 and then (Is_RTE
(Subp
, RE_Is_Reserved
) or else
2052 Is_RTE
(Subp
, RE_Is_Attached
) or else
2053 Is_RTE
(Subp
, RE_Current_Handler
) or else
2054 Is_RTE
(Subp
, RE_Attach_Handler
) or else
2055 Is_RTE
(Subp
, RE_Exchange_Handler
) or else
2056 Is_RTE
(Subp
, RE_Detach_Handler
) or else
2057 Is_RTE
(Subp
, RE_Reference
))
2059 Check_Restriction
(No_Dynamic_Attachment
, N
);
2062 -- Deal with case where call is an explicit dereference
2064 if Nkind
(Name
(N
)) = N_Explicit_Dereference
then
2066 -- Handle case of access to protected subprogram type
2068 if Ekind
(Base_Type
(Etype
(Prefix
(Name
(N
))))) =
2069 E_Access_Protected_Subprogram_Type
2071 -- If this is a call through an access to protected operation,
2072 -- the prefix has the form (object'address, operation'access).
2073 -- Rewrite as a for other protected calls: the object is the
2074 -- first parameter of the list of actuals.
2081 Ptr
: constant Node_Id
:= Prefix
(Name
(N
));
2083 T
: constant Entity_Id
:=
2084 Equivalent_Type
(Base_Type
(Etype
(Ptr
)));
2086 D_T
: constant Entity_Id
:=
2087 Designated_Type
(Base_Type
(Etype
(Ptr
)));
2091 Make_Selected_Component
(Loc
,
2092 Prefix
=> Unchecked_Convert_To
(T
, Ptr
),
2094 New_Occurrence_Of
(First_Entity
(T
), Loc
));
2097 Make_Selected_Component
(Loc
,
2098 Prefix
=> Unchecked_Convert_To
(T
, Ptr
),
2100 New_Occurrence_Of
(Next_Entity
(First_Entity
(T
)), Loc
));
2102 Nam
:= Make_Explicit_Dereference
(Loc
, Nam
);
2104 if Present
(Parameter_Associations
(N
)) then
2105 Parm
:= Parameter_Associations
(N
);
2110 Prepend
(Obj
, Parm
);
2112 if Etype
(D_T
) = Standard_Void_Type
then
2113 Call
:= Make_Procedure_Call_Statement
(Loc
,
2115 Parameter_Associations
=> Parm
);
2117 Call
:= Make_Function_Call
(Loc
,
2119 Parameter_Associations
=> Parm
);
2122 Set_First_Named_Actual
(Call
, First_Named_Actual
(N
));
2123 Set_Etype
(Call
, Etype
(D_T
));
2125 -- We do not re-analyze the call to avoid infinite recursion.
2126 -- We analyze separately the prefix and the object, and set
2127 -- the checks on the prefix that would otherwise be emitted
2128 -- when resolving a call.
2132 Apply_Access_Check
(Nam
);
2139 -- If this is a call to an intrinsic subprogram, then perform the
2140 -- appropriate expansion to the corresponding tree node and we
2141 -- are all done (since after that the call is gone!)
2143 -- In the case where the intrinsic is to be processed by the back end,
2144 -- the call to Expand_Intrinsic_Call will do nothing, which is fine,
2145 -- since the idea in this case is to pass the call unchanged.
2147 if Is_Intrinsic_Subprogram
(Subp
) then
2148 Expand_Intrinsic_Call
(N
, Subp
);
2152 if Ekind
(Subp
) = E_Function
2153 or else Ekind
(Subp
) = E_Procedure
2155 if Is_Inlined
(Subp
) then
2157 Inlined_Subprogram
: declare
2159 Must_Inline
: Boolean := False;
2160 Spec
: constant Node_Id
:= Unit_Declaration_Node
(Subp
);
2161 Scop
: constant Entity_Id
:= Scope
(Subp
);
2163 function In_Unfrozen_Instance
return Boolean;
2164 -- If the subprogram comes from an instance in the same
2165 -- unit, and the instance is not yet frozen, inlining might
2166 -- trigger order-of-elaboration problems in gigi.
2168 --------------------------
2169 -- In_Unfrozen_Instance --
2170 --------------------------
2172 function In_Unfrozen_Instance
return Boolean is
2178 and then S
/= Standard_Standard
2180 if Is_Generic_Instance
(S
)
2181 and then Present
(Freeze_Node
(S
))
2182 and then not Analyzed
(Freeze_Node
(S
))
2191 end In_Unfrozen_Instance
;
2193 -- Start of processing for Inlined_Subprogram
2196 -- Verify that the body to inline has already been seen, and
2197 -- that if the body is in the current unit the inlining does
2198 -- not occur earlier. This avoids order-of-elaboration problems
2201 -- This should be documented in sinfo/einfo ???
2204 or else Nkind
(Spec
) /= N_Subprogram_Declaration
2205 or else No
(Body_To_Inline
(Spec
))
2207 Must_Inline
:= False;
2209 -- If this an inherited function that returns a private
2210 -- type, do not inline if the full view is an unconstrained
2211 -- array, because such calls cannot be inlined.
2213 elsif Present
(Orig_Subp
)
2214 and then Is_Array_Type
(Etype
(Orig_Subp
))
2215 and then not Is_Constrained
(Etype
(Orig_Subp
))
2217 Must_Inline
:= False;
2219 elsif In_Unfrozen_Instance
then
2220 Must_Inline
:= False;
2223 Bod
:= Body_To_Inline
(Spec
);
2225 if (In_Extended_Main_Code_Unit
(N
)
2226 or else In_Extended_Main_Code_Unit
(Parent
(N
))
2227 or else Is_Always_Inlined
(Subp
))
2228 and then (not In_Same_Extended_Unit
(Sloc
(Bod
), Loc
)
2230 Earlier_In_Extended_Unit
(Sloc
(Bod
), Loc
))
2232 Must_Inline
:= True;
2234 -- If we are compiling a package body that is not the main
2235 -- unit, it must be for inlining/instantiation purposes,
2236 -- in which case we inline the call to insure that the same
2237 -- temporaries are generated when compiling the body by
2238 -- itself. Otherwise link errors can occur.
2240 -- If the function being called is itself in the main unit,
2241 -- we cannot inline, because there is a risk of double
2242 -- elaboration and/or circularity: the inlining can make
2243 -- visible a private entity in the body of the main unit,
2244 -- that gigi will see before its sees its proper definition.
2246 elsif not (In_Extended_Main_Code_Unit
(N
))
2247 and then In_Package_Body
2249 Must_Inline
:= not In_Extended_Main_Source_Unit
(Subp
);
2254 Expand_Inlined_Call
(N
, Subp
, Orig_Subp
);
2257 -- Let the back end handle it
2259 Add_Inlined_Body
(Subp
);
2261 if Front_End_Inlining
2262 and then Nkind
(Spec
) = N_Subprogram_Declaration
2263 and then (In_Extended_Main_Code_Unit
(N
))
2264 and then No
(Body_To_Inline
(Spec
))
2265 and then not Has_Completion
(Subp
)
2266 and then In_Same_Extended_Unit
(Sloc
(Spec
), Loc
)
2269 ("cannot inline& (body not seen yet)?",
2273 end Inlined_Subprogram
;
2277 -- Check for a protected subprogram. This is either an intra-object
2278 -- call, or a protected function call. Protected procedure calls are
2279 -- rewritten as entry calls and handled accordingly.
2281 Scop
:= Scope
(Subp
);
2283 if Nkind
(N
) /= N_Entry_Call_Statement
2284 and then Is_Protected_Type
(Scop
)
2286 -- If the call is an internal one, it is rewritten as a call to
2287 -- to the corresponding unprotected subprogram.
2289 Expand_Protected_Subprogram_Call
(N
, Subp
, Scop
);
2292 -- Functions returning controlled objects need special attention
2294 if Controlled_Type
(Etype
(Subp
))
2295 and then not Is_Return_By_Reference_Type
(Etype
(Subp
))
2297 Expand_Ctrl_Function_Call
(N
);
2300 -- Test for First_Optional_Parameter, and if so, truncate parameter
2301 -- list if there are optional parameters at the trailing end.
2302 -- Note we never delete procedures for call via a pointer.
2304 if (Ekind
(Subp
) = E_Procedure
or else Ekind
(Subp
) = E_Function
)
2305 and then Present
(First_Optional_Parameter
(Subp
))
2308 Last_Keep_Arg
: Node_Id
;
2311 -- Last_Keep_Arg will hold the last actual that should be
2312 -- retained. If it remains empty at the end, it means that
2313 -- all parameters are optional.
2315 Last_Keep_Arg
:= Empty
;
2317 -- Find first optional parameter, must be present since we
2318 -- checked the validity of the parameter before setting it.
2320 Formal
:= First_Formal
(Subp
);
2321 Actual
:= First_Actual
(N
);
2322 while Formal
/= First_Optional_Parameter
(Subp
) loop
2323 Last_Keep_Arg
:= Actual
;
2324 Next_Formal
(Formal
);
2325 Next_Actual
(Actual
);
2328 -- We have Formal and Actual pointing to the first potentially
2329 -- droppable argument. We can drop all the trailing arguments
2330 -- whose actual matches the default. Note that we know that all
2331 -- remaining formals have defaults, because we checked that this
2332 -- requirement was met before setting First_Optional_Parameter.
2334 -- We use Fully_Conformant_Expressions to check for identity
2335 -- between formals and actuals, which may miss some cases, but
2336 -- on the other hand, this is only an optimization (if we fail
2337 -- to truncate a parameter it does not affect functionality).
2338 -- So if the default is 3 and the actual is 1+2, we consider
2339 -- them unequal, which hardly seems worrisome.
2341 while Present
(Formal
) loop
2342 if not Fully_Conformant_Expressions
2343 (Actual
, Default_Value
(Formal
))
2345 Last_Keep_Arg
:= Actual
;
2348 Next_Formal
(Formal
);
2349 Next_Actual
(Actual
);
2352 -- If no arguments, delete entire list, this is the easy case
2354 if No
(Last_Keep_Arg
) then
2355 while Is_Non_Empty_List
(Parameter_Associations
(N
)) loop
2356 Delete_Tree
(Remove_Head
(Parameter_Associations
(N
)));
2359 Set_Parameter_Associations
(N
, No_List
);
2360 Set_First_Named_Actual
(N
, Empty
);
2362 -- Case where at the last retained argument is positional. This
2363 -- is also an easy case, since the retained arguments are already
2364 -- in the right form, and we don't need to worry about the order
2365 -- of arguments that get eliminated.
2367 elsif Is_List_Member
(Last_Keep_Arg
) then
2368 while Present
(Next
(Last_Keep_Arg
)) loop
2369 Delete_Tree
(Remove_Next
(Last_Keep_Arg
));
2372 Set_First_Named_Actual
(N
, Empty
);
2374 -- This is the annoying case where the last retained argument
2375 -- is a named parameter. Since the original arguments are not
2376 -- in declaration order, we may have to delete some fairly
2377 -- random collection of arguments.
2385 pragma Warnings
(Off
, Discard
);
2388 -- First step, remove all the named parameters from the
2389 -- list (they are still chained using First_Named_Actual
2390 -- and Next_Named_Actual, so we have not lost them!)
2392 Temp
:= First
(Parameter_Associations
(N
));
2394 -- Case of all parameters named, remove them all
2396 if Nkind
(Temp
) = N_Parameter_Association
then
2397 while Is_Non_Empty_List
(Parameter_Associations
(N
)) loop
2398 Temp
:= Remove_Head
(Parameter_Associations
(N
));
2401 -- Case of mixed positional/named, remove named parameters
2404 while Nkind
(Next
(Temp
)) /= N_Parameter_Association
loop
2408 while Present
(Next
(Temp
)) loop
2409 Discard
:= Remove_Next
(Temp
);
2413 -- Now we loop through the named parameters, till we get
2414 -- to the last one to be retained, adding them to the list.
2415 -- Note that the Next_Named_Actual list does not need to be
2416 -- touched since we are only reordering them on the actual
2417 -- parameter association list.
2419 Passoc
:= Parent
(First_Named_Actual
(N
));
2421 Temp
:= Relocate_Node
(Passoc
);
2423 (Parameter_Associations
(N
), Temp
);
2425 Last_Keep_Arg
= Explicit_Actual_Parameter
(Passoc
);
2426 Passoc
:= Parent
(Next_Named_Actual
(Passoc
));
2429 Set_Next_Named_Actual
(Temp
, Empty
);
2432 Temp
:= Next_Named_Actual
(Passoc
);
2433 exit when No
(Temp
);
2434 Set_Next_Named_Actual
2435 (Passoc
, Next_Named_Actual
(Parent
(Temp
)));
2444 --------------------------
2445 -- Expand_Inlined_Call --
2446 --------------------------
2448 procedure Expand_Inlined_Call
2451 Orig_Subp
: Entity_Id
)
2453 Loc
: constant Source_Ptr
:= Sloc
(N
);
2454 Is_Predef
: constant Boolean :=
2455 Is_Predefined_File_Name
2456 (Unit_File_Name
(Get_Source_Unit
(Subp
)));
2457 Orig_Bod
: constant Node_Id
:=
2458 Body_To_Inline
(Unit_Declaration_Node
(Subp
));
2463 Exit_Lab
: Entity_Id
:= Empty
;
2470 Ret_Type
: Entity_Id
;
2473 Temp_Typ
: Entity_Id
;
2475 procedure Make_Exit_Label
;
2476 -- Build declaration for exit label to be used in Return statements
2478 function Process_Formals
(N
: Node_Id
) return Traverse_Result
;
2479 -- Replace occurrence of a formal with the corresponding actual, or
2480 -- the thunk generated for it.
2482 function Process_Sloc
(Nod
: Node_Id
) return Traverse_Result
;
2483 -- If the call being expanded is that of an internal subprogram,
2484 -- set the sloc of the generated block to that of the call itself,
2485 -- so that the expansion is skipped by the -next- command in gdb.
2486 -- Same processing for a subprogram in a predefined file, e.g.
2487 -- Ada.Tags. If Debug_Generated_Code is true, suppress this change
2488 -- to simplify our own development.
2490 procedure Rewrite_Function_Call
(N
: Node_Id
; Blk
: Node_Id
);
2491 -- If the function body is a single expression, replace call with
2492 -- expression, else insert block appropriately.
2494 procedure Rewrite_Procedure_Call
(N
: Node_Id
; Blk
: Node_Id
);
2495 -- If procedure body has no local variables, inline body without
2496 -- creating block, otherwise rewrite call with block.
2498 function Formal_Is_Used_Once
(Formal
: Entity_Id
) return Boolean;
2499 -- Determine whether a formal parameter is used only once in Orig_Bod
2501 ---------------------
2502 -- Make_Exit_Label --
2503 ---------------------
2505 procedure Make_Exit_Label
is
2507 -- Create exit label for subprogram if one does not exist yet
2509 if No
(Exit_Lab
) then
2510 Lab_Id
:= Make_Identifier
(Loc
, New_Internal_Name
('L'));
2512 Make_Defining_Identifier
(Loc
, Chars
(Lab_Id
)));
2513 Exit_Lab
:= Make_Label
(Loc
, Lab_Id
);
2516 Make_Implicit_Label_Declaration
(Loc
,
2517 Defining_Identifier
=> Entity
(Lab_Id
),
2518 Label_Construct
=> Exit_Lab
);
2520 end Make_Exit_Label
;
2522 ---------------------
2523 -- Process_Formals --
2524 ---------------------
2526 function Process_Formals
(N
: Node_Id
) return Traverse_Result
is
2532 if Is_Entity_Name
(N
)
2533 and then Present
(Entity
(N
))
2538 and then Scope
(E
) = Subp
2540 A
:= Renamed_Object
(E
);
2542 if Is_Entity_Name
(A
) then
2543 Rewrite
(N
, New_Occurrence_Of
(Entity
(A
), Loc
));
2545 elsif Nkind
(A
) = N_Defining_Identifier
then
2546 Rewrite
(N
, New_Occurrence_Of
(A
, Loc
));
2548 else -- numeric literal
2549 Rewrite
(N
, New_Copy
(A
));
2555 elsif Nkind
(N
) = N_Return_Statement
then
2557 if No
(Expression
(N
)) then
2559 Rewrite
(N
, Make_Goto_Statement
(Loc
,
2560 Name
=> New_Copy
(Lab_Id
)));
2563 if Nkind
(Parent
(N
)) = N_Handled_Sequence_Of_Statements
2564 and then Nkind
(Parent
(Parent
(N
))) = N_Subprogram_Body
2566 -- Function body is a single expression. No need for
2572 Num_Ret
:= Num_Ret
+ 1;
2576 -- Because of the presence of private types, the views of the
2577 -- expression and the context may be different, so place an
2578 -- unchecked conversion to the context type to avoid spurious
2579 -- errors, eg. when the expression is a numeric literal and
2580 -- the context is private. If the expression is an aggregate,
2581 -- use a qualified expression, because an aggregate is not a
2582 -- legal argument of a conversion.
2584 if Nkind
(Expression
(N
)) = N_Aggregate
2585 or else Nkind
(Expression
(N
)) = N_Null
2588 Make_Qualified_Expression
(Sloc
(N
),
2589 Subtype_Mark
=> New_Occurrence_Of
(Ret_Type
, Sloc
(N
)),
2590 Expression
=> Relocate_Node
(Expression
(N
)));
2593 Unchecked_Convert_To
2594 (Ret_Type
, Relocate_Node
(Expression
(N
)));
2597 if Nkind
(Targ
) = N_Defining_Identifier
then
2599 Make_Assignment_Statement
(Loc
,
2600 Name
=> New_Occurrence_Of
(Targ
, Loc
),
2601 Expression
=> Ret
));
2604 Make_Assignment_Statement
(Loc
,
2605 Name
=> New_Copy
(Targ
),
2606 Expression
=> Ret
));
2609 Set_Assignment_OK
(Name
(N
));
2611 if Present
(Exit_Lab
) then
2613 Make_Goto_Statement
(Loc
,
2614 Name
=> New_Copy
(Lab_Id
)));
2620 -- Remove pragma Unreferenced since it may refer to formals that
2621 -- are not visible in the inlined body, and in any case we will
2622 -- not be posting warnings on the inlined body so it is unneeded.
2624 elsif Nkind
(N
) = N_Pragma
2625 and then Chars
(N
) = Name_Unreferenced
2627 Rewrite
(N
, Make_Null_Statement
(Sloc
(N
)));
2633 end Process_Formals
;
2635 procedure Replace_Formals
is new Traverse_Proc
(Process_Formals
);
2641 function Process_Sloc
(Nod
: Node_Id
) return Traverse_Result
is
2643 if not Debug_Generated_Code
then
2644 Set_Sloc
(Nod
, Sloc
(N
));
2645 Set_Comes_From_Source
(Nod
, False);
2651 procedure Reset_Slocs
is new Traverse_Proc
(Process_Sloc
);
2653 ---------------------------
2654 -- Rewrite_Function_Call --
2655 ---------------------------
2657 procedure Rewrite_Function_Call
(N
: Node_Id
; Blk
: Node_Id
) is
2658 HSS
: constant Node_Id
:= Handled_Statement_Sequence
(Blk
);
2659 Fst
: constant Node_Id
:= First
(Statements
(HSS
));
2662 -- Optimize simple case: function body is a single return statement,
2663 -- which has been expanded into an assignment.
2665 if Is_Empty_List
(Declarations
(Blk
))
2666 and then Nkind
(Fst
) = N_Assignment_Statement
2667 and then No
(Next
(Fst
))
2670 -- The function call may have been rewritten as the temporary
2671 -- that holds the result of the call, in which case remove the
2672 -- now useless declaration.
2674 if Nkind
(N
) = N_Identifier
2675 and then Nkind
(Parent
(Entity
(N
))) = N_Object_Declaration
2677 Rewrite
(Parent
(Entity
(N
)), Make_Null_Statement
(Loc
));
2680 Rewrite
(N
, Expression
(Fst
));
2682 elsif Nkind
(N
) = N_Identifier
2683 and then Nkind
(Parent
(Entity
(N
))) = N_Object_Declaration
2685 -- The block assigns the result of the call to the temporary
2687 Insert_After
(Parent
(Entity
(N
)), Blk
);
2689 elsif Nkind
(Parent
(N
)) = N_Assignment_Statement
2690 and then Is_Entity_Name
(Name
(Parent
(N
)))
2692 -- Replace assignment with the block
2695 Original_Assignment
: constant Node_Id
:= Parent
(N
);
2698 -- Preserve the original assignment node to keep the complete
2699 -- assignment subtree consistent enough for Analyze_Assignment
2700 -- to proceed (specifically, the original Lhs node must still
2701 -- have an assignment statement as its parent).
2703 -- We cannot rely on Original_Node to go back from the block
2704 -- node to the assignment node, because the assignment might
2705 -- already be a rewrite substitution.
2707 Discard_Node
(Relocate_Node
(Original_Assignment
));
2708 Rewrite
(Original_Assignment
, Blk
);
2711 elsif Nkind
(Parent
(N
)) = N_Object_Declaration
then
2712 Set_Expression
(Parent
(N
), Empty
);
2713 Insert_After
(Parent
(N
), Blk
);
2715 end Rewrite_Function_Call
;
2717 ----------------------------
2718 -- Rewrite_Procedure_Call --
2719 ----------------------------
2721 procedure Rewrite_Procedure_Call
(N
: Node_Id
; Blk
: Node_Id
) is
2722 HSS
: constant Node_Id
:= Handled_Statement_Sequence
(Blk
);
2724 if Is_Empty_List
(Declarations
(Blk
)) then
2725 Insert_List_After
(N
, Statements
(HSS
));
2726 Rewrite
(N
, Make_Null_Statement
(Loc
));
2730 end Rewrite_Procedure_Call
;
2732 -------------------------
2733 -- Formal_Is_Used_Once --
2734 ------------------------
2736 function Formal_Is_Used_Once
(Formal
: Entity_Id
) return Boolean is
2737 Use_Counter
: Int
:= 0;
2739 function Count_Uses
(N
: Node_Id
) return Traverse_Result
;
2740 -- Traverse the tree and count the uses of the formal parameter.
2741 -- In this case, for optimization purposes, we do not need to
2742 -- continue the traversal once more than one use is encountered.
2748 function Count_Uses
(N
: Node_Id
) return Traverse_Result
is
2750 -- The original node is an identifier
2752 if Nkind
(N
) = N_Identifier
2753 and then Present
(Entity
(N
))
2755 -- Original node's entity points to the one in the copied body
2757 and then Nkind
(Entity
(N
)) = N_Identifier
2758 and then Present
(Entity
(Entity
(N
)))
2760 -- The entity of the copied node is the formal parameter
2762 and then Entity
(Entity
(N
)) = Formal
2764 Use_Counter
:= Use_Counter
+ 1;
2766 if Use_Counter
> 1 then
2768 -- Denote more than one use and abandon the traversal
2779 procedure Count_Formal_Uses
is new Traverse_Proc
(Count_Uses
);
2781 -- Start of processing for Formal_Is_Used_Once
2784 Count_Formal_Uses
(Orig_Bod
);
2785 return Use_Counter
= 1;
2786 end Formal_Is_Used_Once
;
2788 -- Start of processing for Expand_Inlined_Call
2791 -- Check for special case of To_Address call, and if so, just do an
2792 -- unchecked conversion instead of expanding the call. Not only is this
2793 -- more efficient, but it also avoids problem with order of elaboration
2794 -- when address clauses are inlined (address expression elaborated at
2797 if Subp
= RTE
(RE_To_Address
) then
2799 Unchecked_Convert_To
2801 Relocate_Node
(First_Actual
(N
))));
2805 -- Check for an illegal attempt to inline a recursive procedure. If the
2806 -- subprogram has parameters this is detected when trying to supply a
2807 -- binding for parameters that already have one. For parameterless
2808 -- subprograms this must be done explicitly.
2810 if In_Open_Scopes
(Subp
) then
2811 Error_Msg_N
("call to recursive subprogram cannot be inlined?", N
);
2812 Set_Is_Inlined
(Subp
, False);
2816 if Nkind
(Orig_Bod
) = N_Defining_Identifier
2817 or else Nkind
(Orig_Bod
) = N_Defining_Operator_Symbol
2819 -- Subprogram is a renaming_as_body. Calls appearing after the
2820 -- renaming can be replaced with calls to the renamed entity
2821 -- directly, because the subprograms are subtype conformant. If
2822 -- the renamed subprogram is an inherited operation, we must redo
2823 -- the expansion because implicit conversions may be needed.
2825 Set_Name
(N
, New_Occurrence_Of
(Orig_Bod
, Loc
));
2827 if Present
(Alias
(Orig_Bod
)) then
2834 -- Use generic machinery to copy body of inlined subprogram, as if it
2835 -- were an instantiation, resetting source locations appropriately, so
2836 -- that nested inlined calls appear in the main unit.
2838 Save_Env
(Subp
, Empty
);
2839 Set_Copied_Sloc_For_Inlined_Body
(N
, Defining_Entity
(Orig_Bod
));
2841 Bod
:= Copy_Generic_Node
(Orig_Bod
, Empty
, Instantiating
=> True);
2843 Make_Block_Statement
(Loc
,
2844 Declarations
=> Declarations
(Bod
),
2845 Handled_Statement_Sequence
=> Handled_Statement_Sequence
(Bod
));
2847 if No
(Declarations
(Bod
)) then
2848 Set_Declarations
(Blk
, New_List
);
2851 -- If this is a derived function, establish the proper return type
2853 if Present
(Orig_Subp
)
2854 and then Orig_Subp
/= Subp
2856 Ret_Type
:= Etype
(Orig_Subp
);
2858 Ret_Type
:= Etype
(Subp
);
2861 -- Create temporaries for the actuals that are expressions, or that
2862 -- are scalars and require copying to preserve semantics.
2864 F
:= First_Formal
(Subp
);
2865 A
:= First_Actual
(N
);
2866 while Present
(F
) loop
2867 if Present
(Renamed_Object
(F
)) then
2868 Error_Msg_N
("cannot inline call to recursive subprogram", N
);
2872 -- If the argument may be a controlling argument in a call within
2873 -- the inlined body, we must preserve its classwide nature to insure
2874 -- that dynamic dispatching take place subsequently. If the formal
2875 -- has a constraint it must be preserved to retain the semantics of
2878 if Is_Class_Wide_Type
(Etype
(F
))
2879 or else (Is_Access_Type
(Etype
(F
))
2881 Is_Class_Wide_Type
(Designated_Type
(Etype
(F
))))
2883 Temp_Typ
:= Etype
(F
);
2885 elsif Base_Type
(Etype
(F
)) = Base_Type
(Etype
(A
))
2886 and then Etype
(F
) /= Base_Type
(Etype
(F
))
2888 Temp_Typ
:= Etype
(F
);
2891 Temp_Typ
:= Etype
(A
);
2894 -- If the actual is a simple name or a literal, no need to
2895 -- create a temporary, object can be used directly.
2897 if (Is_Entity_Name
(A
)
2899 (not Is_Scalar_Type
(Etype
(A
))
2900 or else Ekind
(Entity
(A
)) = E_Enumeration_Literal
))
2902 -- When the actual is an identifier and the corresponding formal
2903 -- is used only once in the original body, the formal can be
2904 -- substituted directly with the actual parameter.
2906 or else (Nkind
(A
) = N_Identifier
2907 and then Formal_Is_Used_Once
(F
))
2909 or else Nkind
(A
) = N_Real_Literal
2910 or else Nkind
(A
) = N_Integer_Literal
2911 or else Nkind
(A
) = N_Character_Literal
2913 if Etype
(F
) /= Etype
(A
) then
2915 (F
, Unchecked_Convert_To
(Etype
(F
), Relocate_Node
(A
)));
2917 Set_Renamed_Object
(F
, A
);
2922 Make_Defining_Identifier
(Loc
,
2923 Chars
=> New_Internal_Name
('C'));
2925 -- If the actual for an in/in-out parameter is a view conversion,
2926 -- make it into an unchecked conversion, given that an untagged
2927 -- type conversion is not a proper object for a renaming.
2929 -- In-out conversions that involve real conversions have already
2930 -- been transformed in Expand_Actuals.
2932 if Nkind
(A
) = N_Type_Conversion
2933 and then Ekind
(F
) /= E_In_Parameter
2935 New_A
:= Make_Unchecked_Type_Conversion
(Loc
,
2936 Subtype_Mark
=> New_Occurrence_Of
(Etype
(F
), Loc
),
2937 Expression
=> Relocate_Node
(Expression
(A
)));
2939 elsif Etype
(F
) /= Etype
(A
) then
2940 New_A
:= Unchecked_Convert_To
(Etype
(F
), Relocate_Node
(A
));
2941 Temp_Typ
:= Etype
(F
);
2944 New_A
:= Relocate_Node
(A
);
2947 Set_Sloc
(New_A
, Sloc
(N
));
2949 if Ekind
(F
) = E_In_Parameter
2950 and then not Is_Limited_Type
(Etype
(A
))
2953 Make_Object_Declaration
(Loc
,
2954 Defining_Identifier
=> Temp
,
2955 Constant_Present
=> True,
2956 Object_Definition
=> New_Occurrence_Of
(Temp_Typ
, Loc
),
2957 Expression
=> New_A
);
2960 Make_Object_Renaming_Declaration
(Loc
,
2961 Defining_Identifier
=> Temp
,
2962 Subtype_Mark
=> New_Occurrence_Of
(Temp_Typ
, Loc
),
2966 Prepend
(Decl
, Declarations
(Blk
));
2967 Set_Renamed_Object
(F
, Temp
);
2974 -- Establish target of function call. If context is not assignment or
2975 -- declaration, create a temporary as a target. The declaration for
2976 -- the temporary may be subsequently optimized away if the body is a
2977 -- single expression, or if the left-hand side of the assignment is
2980 if Ekind
(Subp
) = E_Function
then
2981 if Nkind
(Parent
(N
)) = N_Assignment_Statement
2982 and then Is_Entity_Name
(Name
(Parent
(N
)))
2984 Targ
:= Name
(Parent
(N
));
2987 -- Replace call with temporary and create its declaration
2990 Make_Defining_Identifier
(Loc
, New_Internal_Name
('C'));
2991 Set_Is_Internal
(Temp
);
2994 Make_Object_Declaration
(Loc
,
2995 Defining_Identifier
=> Temp
,
2996 Object_Definition
=>
2997 New_Occurrence_Of
(Ret_Type
, Loc
));
2999 Set_No_Initialization
(Decl
);
3000 Insert_Action
(N
, Decl
);
3001 Rewrite
(N
, New_Occurrence_Of
(Temp
, Loc
));
3006 -- Traverse the tree and replace formals with actuals or their thunks.
3007 -- Attach block to tree before analysis and rewriting.
3009 Replace_Formals
(Blk
);
3010 Set_Parent
(Blk
, N
);
3012 if not Comes_From_Source
(Subp
)
3018 if Present
(Exit_Lab
) then
3020 -- If the body was a single expression, the single return statement
3021 -- and the corresponding label are useless.
3025 Nkind
(Last
(Statements
(Handled_Statement_Sequence
(Blk
)))) =
3028 Remove
(Last
(Statements
(Handled_Statement_Sequence
(Blk
))));
3030 Append
(Lab_Decl
, (Declarations
(Blk
)));
3031 Append
(Exit_Lab
, Statements
(Handled_Statement_Sequence
(Blk
)));
3035 -- Analyze Blk with In_Inlined_Body set, to avoid spurious errors on
3036 -- conflicting private views that Gigi would ignore. If this is
3037 -- predefined unit, analyze with checks off, as is done in the non-
3038 -- inlined run-time units.
3041 I_Flag
: constant Boolean := In_Inlined_Body
;
3044 In_Inlined_Body
:= True;
3048 Style
: constant Boolean := Style_Check
;
3050 Style_Check
:= False;
3051 Analyze
(Blk
, Suppress
=> All_Checks
);
3052 Style_Check
:= Style
;
3059 In_Inlined_Body
:= I_Flag
;
3062 if Ekind
(Subp
) = E_Procedure
then
3063 Rewrite_Procedure_Call
(N
, Blk
);
3065 Rewrite_Function_Call
(N
, Blk
);
3070 -- Cleanup mapping between formals and actuals for other expansions
3072 F
:= First_Formal
(Subp
);
3073 while Present
(F
) loop
3074 Set_Renamed_Object
(F
, Empty
);
3077 end Expand_Inlined_Call
;
3079 ----------------------------
3080 -- Expand_N_Function_Call --
3081 ----------------------------
3083 procedure Expand_N_Function_Call
(N
: Node_Id
) is
3084 Typ
: constant Entity_Id
:= Etype
(N
);
3086 function Returned_By_Reference
return Boolean;
3087 -- If the return type is returned through the secondary stack. that is
3088 -- by reference, we don't want to create a temp to force stack checking.
3089 -- Shouldn't this function be moved to exp_util???
3091 function Rhs_Of_Assign_Or_Decl
(N
: Node_Id
) return Boolean;
3092 -- If the call is the right side of an assignment or the expression in
3093 -- an object declaration, we don't need to create a temp as the left
3094 -- side will already trigger stack checking if necessary.
3096 ---------------------------
3097 -- Returned_By_Reference --
3098 ---------------------------
3100 function Returned_By_Reference
return Boolean is
3104 if Is_Return_By_Reference_Type
(Typ
) then
3107 elsif Nkind
(Parent
(N
)) /= N_Return_Statement
then
3110 elsif Requires_Transient_Scope
(Typ
) then
3112 -- Verify that the return type of the enclosing function has the
3113 -- same constrained status as that of the expression.
3116 while Ekind
(S
) /= E_Function
loop
3120 return Is_Constrained
(Typ
) = Is_Constrained
(Etype
(S
));
3124 end Returned_By_Reference
;
3126 ---------------------------
3127 -- Rhs_Of_Assign_Or_Decl --
3128 ---------------------------
3130 function Rhs_Of_Assign_Or_Decl
(N
: Node_Id
) return Boolean is
3132 if (Nkind
(Parent
(N
)) = N_Assignment_Statement
3133 and then Expression
(Parent
(N
)) = N
)
3135 (Nkind
(Parent
(N
)) = N_Qualified_Expression
3136 and then Nkind
(Parent
(Parent
(N
))) = N_Assignment_Statement
3137 and then Expression
(Parent
(Parent
(N
))) = Parent
(N
))
3139 (Nkind
(Parent
(N
)) = N_Object_Declaration
3140 and then Expression
(Parent
(N
)) = N
)
3142 (Nkind
(Parent
(N
)) = N_Component_Association
3143 and then Expression
(Parent
(N
)) = N
3144 and then Nkind
(Parent
(Parent
(N
))) = N_Aggregate
3145 and then Rhs_Of_Assign_Or_Decl
(Parent
(Parent
(N
))))
3151 end Rhs_Of_Assign_Or_Decl
;
3153 -- Start of processing for Expand_N_Function_Call
3156 -- A special check. If stack checking is enabled, and the return type
3157 -- might generate a large temporary, and the call is not the right side
3158 -- of an assignment, then generate an explicit temporary. We do this
3159 -- because otherwise gigi may generate a large temporary on the fly and
3160 -- this can cause trouble with stack checking.
3162 -- This is unecessary if the call is the expression in an object
3163 -- declaration, or if it appears outside of any library unit. This can
3164 -- only happen if it appears as an actual in a library-level instance,
3165 -- in which case a temporary will be generated for it once the instance
3166 -- itself is installed.
3168 if May_Generate_Large_Temp
(Typ
)
3169 and then not Rhs_Of_Assign_Or_Decl
(N
)
3170 and then not Returned_By_Reference
3171 and then Current_Scope
/= Standard_Standard
3173 if Stack_Checking_Enabled
then
3175 -- Note: it might be thought that it would be OK to use a call to
3176 -- Force_Evaluation here, but that's not good enough, because
3177 -- that can results in a 'Reference construct that may still need
3181 Loc
: constant Source_Ptr
:= Sloc
(N
);
3182 Temp_Obj
: constant Entity_Id
:=
3183 Make_Defining_Identifier
(Loc
,
3184 Chars
=> New_Internal_Name
('F'));
3185 Temp_Typ
: Entity_Id
:= Typ
;
3192 if Is_Tagged_Type
(Typ
)
3193 and then Present
(Controlling_Argument
(N
))
3195 if Nkind
(Parent
(N
)) /= N_Procedure_Call_Statement
3196 and then Nkind
(Parent
(N
)) /= N_Function_Call
3198 -- If this is a tag-indeterminate call, the object must
3201 if Is_Tag_Indeterminate
(N
) then
3202 Temp_Typ
:= Class_Wide_Type
(Typ
);
3206 -- If this is a dispatching call that is itself the
3207 -- controlling argument of an enclosing call, the
3208 -- nominal subtype of the object that replaces it must
3209 -- be classwide, so that dispatching will take place
3210 -- properly. If it is not a controlling argument, the
3211 -- object is not classwide.
3213 Proc
:= Entity
(Name
(Parent
(N
)));
3215 F
:= First_Formal
(Proc
);
3216 A
:= First_Actual
(Parent
(N
));
3222 if Is_Controlling_Formal
(F
) then
3223 Temp_Typ
:= Class_Wide_Type
(Typ
);
3229 Make_Object_Declaration
(Loc
,
3230 Defining_Identifier
=> Temp_Obj
,
3231 Object_Definition
=> New_Occurrence_Of
(Temp_Typ
, Loc
),
3232 Constant_Present
=> True,
3233 Expression
=> Relocate_Node
(N
));
3234 Set_Assignment_OK
(Decl
);
3236 Insert_Actions
(N
, New_List
(Decl
));
3237 Rewrite
(N
, New_Occurrence_Of
(Temp_Obj
, Loc
));
3241 -- If stack-checking is not enabled, increment serial number
3242 -- for internal names, so that subsequent symbols are consistent
3243 -- with and without stack-checking.
3245 Synchronize_Serial_Number
;
3247 -- Now we can expand the call with consistent symbol names
3252 -- Normal case, expand the call
3257 end Expand_N_Function_Call
;
3259 ---------------------------------------
3260 -- Expand_N_Procedure_Call_Statement --
3261 ---------------------------------------
3263 procedure Expand_N_Procedure_Call_Statement
(N
: Node_Id
) is
3266 end Expand_N_Procedure_Call_Statement
;
3268 ------------------------------
3269 -- Expand_N_Subprogram_Body --
3270 ------------------------------
3272 -- Add poll call if ATC polling is enabled, unless the body will be
3273 -- inlined by the back-end.
3275 -- Add return statement if last statement in body is not a return statement
3276 -- (this makes things easier on Gigi which does not want to have to handle
3277 -- a missing return).
3279 -- Add call to Activate_Tasks if body is a task activator
3281 -- Deal with possible detection of infinite recursion
3283 -- Eliminate body completely if convention stubbed
3285 -- Encode entity names within body, since we will not need to reference
3286 -- these entities any longer in the front end.
3288 -- Initialize scalar out parameters if Initialize/Normalize_Scalars
3290 -- Reset Pure indication if any parameter has root type System.Address
3294 procedure Expand_N_Subprogram_Body
(N
: Node_Id
) is
3295 Loc
: constant Source_Ptr
:= Sloc
(N
);
3296 H
: constant Node_Id
:= Handled_Statement_Sequence
(N
);
3297 Body_Id
: Entity_Id
;
3298 Spec_Id
: Entity_Id
;
3305 procedure Add_Return
(S
: List_Id
);
3306 -- Append a return statement to the statement sequence S if the last
3307 -- statement is not already a return or a goto statement. Note that
3308 -- the latter test is not critical, it does not matter if we add a
3309 -- few extra returns, since they get eliminated anyway later on.
3311 procedure Expand_Thread_Body
;
3312 -- Perform required expansion of a thread body
3318 procedure Add_Return
(S
: List_Id
) is
3320 if not Is_Transfer
(Last
(S
)) then
3322 -- The source location for the return is the end label
3323 -- of the procedure in all cases. This is a bit odd when
3324 -- there are exception handlers, but not much else we can do.
3326 Append_To
(S
, Make_Return_Statement
(Sloc
(End_Label
(H
))));
3330 ------------------------
3331 -- Expand_Thread_Body --
3332 ------------------------
3334 -- The required expansion of a thread body is as follows
3336 -- procedure <thread body procedure name> is
3338 -- _Secondary_Stack : aliased
3339 -- Storage_Elements.Storage_Array
3340 -- (1 .. Storage_Offset (Sec_Stack_Size));
3341 -- for _Secondary_Stack'Alignment use Standard'Maximum_Alignment;
3343 -- _Process_ATSD : aliased System.Threads.ATSD;
3346 -- System.Threads.Thread_Body_Enter;
3347 -- (_Secondary_Stack'Address,
3348 -- _Secondary_Stack'Length,
3349 -- _Process_ATSD'Address);
3352 -- <user declarations>
3354 -- <user statements>
3355 -- <user exception handlers>
3358 -- System.Threads.Thread_Body_Leave;
3361 -- when E : others =>
3362 -- System.Threads.Thread_Body_Exceptional_Exit (E);
3365 -- Note the exception handler is omitted if pragma Restriction
3366 -- No_Exception_Handlers is currently active.
3368 procedure Expand_Thread_Body
is
3369 User_Decls
: constant List_Id
:= Declarations
(N
);
3370 Sec_Stack_Len
: Node_Id
;
3372 TB_Pragma
: constant Node_Id
:=
3373 Get_Rep_Pragma
(Spec_Id
, Name_Thread_Body
);
3376 Ent_ATSD
: Entity_Id
;
3380 Decl_ATSD
: Node_Id
;
3382 Excep_Handlers
: List_Id
;
3385 New_Scope
(Spec_Id
);
3387 -- Get proper setting for secondary stack size
3389 if List_Length
(Pragma_Argument_Associations
(TB_Pragma
)) = 2 then
3391 Expression
(Last
(Pragma_Argument_Associations
(TB_Pragma
)));
3394 New_Occurrence_Of
(RTE
(RE_Default_Secondary_Stack_Size
), Loc
);
3397 Sec_Stack_Len
:= Convert_To
(RTE
(RE_Storage_Offset
), Sec_Stack_Len
);
3399 -- Build and set declarations for the wrapped thread body
3401 Ent_SS
:= Make_Defining_Identifier
(Loc
, Name_uSecondary_Stack
);
3402 Ent_ATSD
:= Make_Defining_Identifier
(Loc
, Name_uProcess_ATSD
);
3405 Make_Object_Declaration
(Loc
,
3406 Defining_Identifier
=> Ent_SS
,
3407 Aliased_Present
=> True,
3408 Object_Definition
=>
3409 Make_Subtype_Indication
(Loc
,
3411 New_Occurrence_Of
(RTE
(RE_Storage_Array
), Loc
),
3413 Make_Index_Or_Discriminant_Constraint
(Loc
,
3414 Constraints
=> New_List
(
3416 Low_Bound
=> Make_Integer_Literal
(Loc
, 1),
3417 High_Bound
=> Sec_Stack_Len
)))));
3420 Make_Object_Declaration
(Loc
,
3421 Defining_Identifier
=> Ent_ATSD
,
3422 Aliased_Present
=> True,
3423 Object_Definition
=> New_Occurrence_Of
(RTE
(RE_ATSD
), Loc
));
3425 Set_Declarations
(N
, New_List
(Decl_SS
, Decl_ATSD
));
3427 Analyze
(Decl_ATSD
);
3428 Set_Alignment
(Ent_SS
, UI_From_Int
(Maximum_Alignment
));
3430 -- Create new exception handler
3432 if Restriction_Active
(No_Exception_Handlers
) then
3433 Excep_Handlers
:= No_List
;
3436 Check_Restriction
(No_Exception_Handlers
, N
);
3438 Ent_EO
:= Make_Defining_Identifier
(Loc
, Name_uE
);
3440 Excep_Handlers
:= New_List
(
3441 Make_Exception_Handler
(Loc
,
3442 Choice_Parameter
=> Ent_EO
,
3443 Exception_Choices
=> New_List
(
3444 Make_Others_Choice
(Loc
)),
3445 Statements
=> New_List
(
3446 Make_Procedure_Call_Statement
(Loc
,
3449 (RTE
(RE_Thread_Body_Exceptional_Exit
), Loc
),
3450 Parameter_Associations
=> New_List
(
3451 New_Occurrence_Of
(Ent_EO
, Loc
))))));
3454 -- Now build new handled statement sequence and analyze it
3456 Set_Handled_Statement_Sequence
(N
,
3457 Make_Handled_Sequence_Of_Statements
(Loc
,
3458 Statements
=> New_List
(
3460 Make_Procedure_Call_Statement
(Loc
,
3461 Name
=> New_Occurrence_Of
(RTE
(RE_Thread_Body_Enter
), Loc
),
3462 Parameter_Associations
=> New_List
(
3464 Make_Attribute_Reference
(Loc
,
3465 Prefix
=> New_Occurrence_Of
(Ent_SS
, Loc
),
3466 Attribute_Name
=> Name_Address
),
3468 Make_Attribute_Reference
(Loc
,
3469 Prefix
=> New_Occurrence_Of
(Ent_SS
, Loc
),
3470 Attribute_Name
=> Name_Length
),
3472 Make_Attribute_Reference
(Loc
,
3473 Prefix
=> New_Occurrence_Of
(Ent_ATSD
, Loc
),
3474 Attribute_Name
=> Name_Address
))),
3476 Make_Block_Statement
(Loc
,
3477 Declarations
=> User_Decls
,
3478 Handled_Statement_Sequence
=> H
),
3480 Make_Procedure_Call_Statement
(Loc
,
3481 Name
=> New_Occurrence_Of
(RTE
(RE_Thread_Body_Leave
), Loc
))),
3483 Exception_Handlers
=> Excep_Handlers
));
3485 Analyze
(Handled_Statement_Sequence
(N
));
3487 end Expand_Thread_Body
;
3489 -- Start of processing for Expand_N_Subprogram_Body
3492 -- Set L to either the list of declarations if present, or
3493 -- to the list of statements if no declarations are present.
3494 -- This is used to insert new stuff at the start.
3496 if Is_Non_Empty_List
(Declarations
(N
)) then
3497 L
:= Declarations
(N
);
3499 L
:= Statements
(Handled_Statement_Sequence
(N
));
3502 -- Find entity for subprogram
3504 Body_Id
:= Defining_Entity
(N
);
3506 if Present
(Corresponding_Spec
(N
)) then
3507 Spec_Id
:= Corresponding_Spec
(N
);
3512 -- Need poll on entry to subprogram if polling enabled. We only
3513 -- do this for non-empty subprograms, since it does not seem
3514 -- necessary to poll for a dummy null subprogram. Do not add polling
3515 -- point if calls to this subprogram will be inlined by the back-end,
3516 -- to avoid repeated polling points in nested inlinings.
3518 if Is_Non_Empty_List
(L
) then
3519 if Is_Inlined
(Spec_Id
)
3520 and then Front_End_Inlining
3521 and then Optimization_Level
> 1
3525 Generate_Poll_Call
(First
(L
));
3529 -- If this is a Pure function which has any parameters whose root
3530 -- type is System.Address, reset the Pure indication, since it will
3531 -- likely cause incorrect code to be generated as the parameter is
3532 -- probably a pointer, and the fact that the same pointer is passed
3533 -- does not mean that the same value is being referenced.
3535 -- Note that if the programmer gave an explicit Pure_Function pragma,
3536 -- then we believe the programmer, and leave the subprogram Pure.
3538 -- This code should probably be at the freeze point, so that it
3539 -- happens even on a -gnatc (or more importantly -gnatt) compile
3540 -- so that the semantic tree has Is_Pure set properly ???
3542 if Is_Pure
(Spec_Id
)
3543 and then Is_Subprogram
(Spec_Id
)
3544 and then not Has_Pragma_Pure_Function
(Spec_Id
)
3550 F
:= First_Formal
(Spec_Id
);
3551 while Present
(F
) loop
3552 if Is_Descendent_Of_Address
(Etype
(F
)) then
3553 Set_Is_Pure
(Spec_Id
, False);
3555 if Spec_Id
/= Body_Id
then
3556 Set_Is_Pure
(Body_Id
, False);
3567 -- Initialize any scalar OUT args if Initialize/Normalize_Scalars
3569 if Init_Or_Norm_Scalars
and then Is_Subprogram
(Spec_Id
) then
3572 V
: constant Boolean := Validity_Checks_On
;
3575 -- We turn off validity checking, since we do not want any
3576 -- check on the initializing value itself (which we know
3577 -- may well be invalid!)
3579 Validity_Checks_On
:= False;
3581 -- Loop through formals
3583 F
:= First_Formal
(Spec_Id
);
3584 while Present
(F
) loop
3585 if Is_Scalar_Type
(Etype
(F
))
3586 and then Ekind
(F
) = E_Out_Parameter
3588 Insert_Before_And_Analyze
(First
(L
),
3589 Make_Assignment_Statement
(Loc
,
3590 Name
=> New_Occurrence_Of
(F
, Loc
),
3591 Expression
=> Get_Simple_Init_Val
(Etype
(F
), Loc
)));
3597 Validity_Checks_On
:= V
;
3601 Scop
:= Scope
(Spec_Id
);
3603 -- Add discriminal renamings to protected subprograms. Install new
3604 -- discriminals for expansion of the next subprogram of this protected
3607 if Is_List_Member
(N
)
3608 and then Present
(Parent
(List_Containing
(N
)))
3609 and then Nkind
(Parent
(List_Containing
(N
))) = N_Protected_Body
3611 Add_Discriminal_Declarations
3612 (Declarations
(N
), Scop
, Name_uObject
, Loc
);
3613 Add_Private_Declarations
(Declarations
(N
), Scop
, Name_uObject
, Loc
);
3615 -- Associate privals and discriminals with the next protected
3616 -- operation body to be expanded. These are used to expand references
3617 -- to private data objects and discriminants, respectively.
3619 Next_Op
:= Next_Protected_Operation
(N
);
3621 if Present
(Next_Op
) then
3622 Dec
:= Parent
(Base_Type
(Scop
));
3623 Set_Privals
(Dec
, Next_Op
, Loc
);
3624 Set_Discriminals
(Dec
);
3628 -- Clear out statement list for stubbed procedure
3630 if Present
(Corresponding_Spec
(N
)) then
3631 Set_Elaboration_Flag
(N
, Spec_Id
);
3633 if Convention
(Spec_Id
) = Convention_Stubbed
3634 or else Is_Eliminated
(Spec_Id
)
3636 Set_Declarations
(N
, Empty_List
);
3637 Set_Handled_Statement_Sequence
(N
,
3638 Make_Handled_Sequence_Of_Statements
(Loc
,
3639 Statements
=> New_List
(
3640 Make_Null_Statement
(Loc
))));
3645 -- Returns_By_Ref flag is normally set when the subprogram is frozen
3646 -- but subprograms with no specs are not frozen.
3649 Typ
: constant Entity_Id
:= Etype
(Spec_Id
);
3650 Utyp
: constant Entity_Id
:= Underlying_Type
(Typ
);
3653 if not Acts_As_Spec
(N
)
3654 and then Nkind
(Parent
(Parent
(Spec_Id
))) /=
3655 N_Subprogram_Body_Stub
3659 elsif Is_Return_By_Reference_Type
(Typ
) then
3660 Set_Returns_By_Ref
(Spec_Id
);
3662 elsif Present
(Utyp
) and then Controlled_Type
(Utyp
) then
3663 Set_Returns_By_Ref
(Spec_Id
);
3667 -- For a procedure, we add a return for all possible syntactic ends
3668 -- of the subprogram. Note that reanalysis is not necessary in this
3669 -- case since it would require a lot of work and accomplish nothing.
3671 if Ekind
(Spec_Id
) = E_Procedure
3672 or else Ekind
(Spec_Id
) = E_Generic_Procedure
3674 Add_Return
(Statements
(H
));
3676 if Present
(Exception_Handlers
(H
)) then
3677 Except_H
:= First_Non_Pragma
(Exception_Handlers
(H
));
3678 while Present
(Except_H
) loop
3679 Add_Return
(Statements
(Except_H
));
3680 Next_Non_Pragma
(Except_H
);
3684 -- For a function, we must deal with the case where there is at least
3685 -- one missing return. What we do is to wrap the entire body of the
3686 -- function in a block:
3699 -- raise Program_Error;
3702 -- This approach is necessary because the raise must be signalled
3703 -- to the caller, not handled by any local handler (RM 6.4(11)).
3705 -- Note: we do not need to analyze the constructed sequence here,
3706 -- since it has no handler, and an attempt to analyze the handled
3707 -- statement sequence twice is risky in various ways (e.g. the
3708 -- issue of expanding cleanup actions twice).
3710 elsif Has_Missing_Return
(Spec_Id
) then
3712 Hloc
: constant Source_Ptr
:= Sloc
(H
);
3713 Blok
: constant Node_Id
:=
3714 Make_Block_Statement
(Hloc
,
3715 Handled_Statement_Sequence
=> H
);
3716 Rais
: constant Node_Id
:=
3717 Make_Raise_Program_Error
(Hloc
,
3718 Reason
=> PE_Missing_Return
);
3721 Set_Handled_Statement_Sequence
(N
,
3722 Make_Handled_Sequence_Of_Statements
(Hloc
,
3723 Statements
=> New_List
(Blok
, Rais
)));
3725 New_Scope
(Spec_Id
);
3732 -- If subprogram contains a parameterless recursive call, then we may
3733 -- have an infinite recursion, so see if we can generate code to check
3734 -- for this possibility if storage checks are not suppressed.
3736 if Ekind
(Spec_Id
) = E_Procedure
3737 and then Has_Recursive_Call
(Spec_Id
)
3738 and then not Storage_Checks_Suppressed
(Spec_Id
)
3740 Detect_Infinite_Recursion
(N
, Spec_Id
);
3743 -- Finally, if we are in Normalize_Scalars mode, then any scalar out
3744 -- parameters must be initialized to the appropriate default value.
3746 if Ekind
(Spec_Id
) = E_Procedure
and then Normalize_Scalars
then
3753 Formal
:= First_Formal
(Spec_Id
);
3754 while Present
(Formal
) loop
3755 Floc
:= Sloc
(Formal
);
3757 if Ekind
(Formal
) = E_Out_Parameter
3758 and then Is_Scalar_Type
(Etype
(Formal
))
3761 Make_Assignment_Statement
(Floc
,
3762 Name
=> New_Occurrence_Of
(Formal
, Floc
),
3764 Get_Simple_Init_Val
(Etype
(Formal
), Floc
));
3765 Prepend
(Stm
, Declarations
(N
));
3769 Next_Formal
(Formal
);
3774 -- Deal with thread body
3776 if Is_Thread_Body
(Spec_Id
) then
3780 -- Set to encode entity names in package body before gigi is called
3782 Qualify_Entity_Names
(N
);
3783 end Expand_N_Subprogram_Body
;
3785 -----------------------------------
3786 -- Expand_N_Subprogram_Body_Stub --
3787 -----------------------------------
3789 procedure Expand_N_Subprogram_Body_Stub
(N
: Node_Id
) is
3791 if Present
(Corresponding_Body
(N
)) then
3792 Expand_N_Subprogram_Body
(
3793 Unit_Declaration_Node
(Corresponding_Body
(N
)));
3795 end Expand_N_Subprogram_Body_Stub
;
3797 -------------------------------------
3798 -- Expand_N_Subprogram_Declaration --
3799 -------------------------------------
3801 -- If the declaration appears within a protected body, it is a private
3802 -- operation of the protected type. We must create the corresponding
3803 -- protected subprogram an associated formals. For a normal protected
3804 -- operation, this is done when expanding the protected type declaration.
3806 -- If the declaration is for a null procedure, emit null body
3808 procedure Expand_N_Subprogram_Declaration
(N
: Node_Id
) is
3809 Loc
: constant Source_Ptr
:= Sloc
(N
);
3810 Subp
: constant Entity_Id
:= Defining_Entity
(N
);
3811 Scop
: constant Entity_Id
:= Scope
(Subp
);
3812 Prot_Decl
: Node_Id
;
3814 Prot_Id
: Entity_Id
;
3817 -- Deal with case of protected subprogram. Do not generate protected
3818 -- operation if operation is flagged as eliminated.
3820 if Is_List_Member
(N
)
3821 and then Present
(Parent
(List_Containing
(N
)))
3822 and then Nkind
(Parent
(List_Containing
(N
))) = N_Protected_Body
3823 and then Is_Protected_Type
(Scop
)
3825 if No
(Protected_Body_Subprogram
(Subp
))
3826 and then not Is_Eliminated
(Subp
)
3829 Make_Subprogram_Declaration
(Loc
,
3831 Build_Protected_Sub_Specification
3832 (N
, Scop
, Unprotected_Mode
));
3834 -- The protected subprogram is declared outside of the protected
3835 -- body. Given that the body has frozen all entities so far, we
3836 -- analyze the subprogram and perform freezing actions explicitly.
3837 -- If the body is a subunit, the insertion point is before the
3838 -- stub in the parent.
3840 Prot_Bod
:= Parent
(List_Containing
(N
));
3842 if Nkind
(Parent
(Prot_Bod
)) = N_Subunit
then
3843 Prot_Bod
:= Corresponding_Stub
(Parent
(Prot_Bod
));
3846 Insert_Before
(Prot_Bod
, Prot_Decl
);
3847 Prot_Id
:= Defining_Unit_Name
(Specification
(Prot_Decl
));
3849 New_Scope
(Scope
(Scop
));
3850 Analyze
(Prot_Decl
);
3851 Create_Extra_Formals
(Prot_Id
);
3852 Set_Protected_Body_Subprogram
(Subp
, Prot_Id
);
3856 elsif Nkind
(Specification
(N
)) = N_Procedure_Specification
3857 and then Null_Present
(Specification
(N
))
3860 Bod
: constant Node_Id
:=
3861 Make_Subprogram_Body
(Loc
,
3863 New_Copy_Tree
(Specification
(N
)),
3864 Declarations
=> New_List
,
3865 Handled_Statement_Sequence
=>
3866 Make_Handled_Sequence_Of_Statements
(Loc
,
3867 Statements
=> New_List
(Make_Null_Statement
(Loc
))));
3869 Set_Body_To_Inline
(N
, Bod
);
3870 Insert_After
(N
, Bod
);
3873 -- Corresponding_Spec isn't being set by Analyze_Subprogram_Body,
3874 -- evidently because Set_Has_Completion is called earlier for null
3875 -- procedures in Analyze_Subprogram_Declaration, so we force its
3876 -- setting here. If the setting of Has_Completion is not set
3877 -- earlier, then it can result in missing body errors if other
3878 -- errors were already reported (since expansion is turned off).
3880 -- Should creation of the empty body be moved to the analyzer???
3882 Set_Corresponding_Spec
(Bod
, Defining_Entity
(Specification
(N
)));
3885 end Expand_N_Subprogram_Declaration
;
3887 ---------------------------------------
3888 -- Expand_Protected_Object_Reference --
3889 ---------------------------------------
3891 function Expand_Protected_Object_Reference
3896 Loc
: constant Source_Ptr
:= Sloc
(N
);
3903 Rec
:= Make_Identifier
(Loc
, Name_uObject
);
3904 Set_Etype
(Rec
, Corresponding_Record_Type
(Scop
));
3906 -- Find enclosing protected operation, and retrieve its first parameter,
3907 -- which denotes the enclosing protected object. If the enclosing
3908 -- operation is an entry, we are immediately within the protected body,
3909 -- and we can retrieve the object from the service entries procedure. A
3910 -- barrier function has has the same signature as an entry. A barrier
3911 -- function is compiled within the protected object, but unlike
3912 -- protected operations its never needs locks, so that its protected
3913 -- body subprogram points to itself.
3915 Proc
:= Current_Scope
;
3916 while Present
(Proc
)
3917 and then Scope
(Proc
) /= Scop
3919 Proc
:= Scope
(Proc
);
3922 Corr
:= Protected_Body_Subprogram
(Proc
);
3926 -- Previous error left expansion incomplete.
3927 -- Nothing to do on this call.
3934 (First
(Parameter_Specifications
(Parent
(Corr
))));
3936 if Is_Subprogram
(Proc
)
3937 and then Proc
/= Corr
3939 -- Protected function or procedure
3941 Set_Entity
(Rec
, Param
);
3943 -- Rec is a reference to an entity which will not be in scope when
3944 -- the call is reanalyzed, and needs no further analysis.
3949 -- Entry or barrier function for entry body. The first parameter of
3950 -- the entry body procedure is pointer to the object. We create a
3951 -- local variable of the proper type, duplicating what is done to
3952 -- define _object later on.
3956 Obj_Ptr
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
,
3958 New_Internal_Name
('T'));
3962 Make_Full_Type_Declaration
(Loc
,
3963 Defining_Identifier
=> Obj_Ptr
,
3965 Make_Access_To_Object_Definition
(Loc
,
3966 Subtype_Indication
=>
3968 (Corresponding_Record_Type
(Scop
), Loc
))));
3970 Insert_Actions
(N
, Decls
);
3971 Insert_Actions
(N
, Freeze_Entity
(Obj_Ptr
, Sloc
(N
)));
3974 Make_Explicit_Dereference
(Loc
,
3975 Unchecked_Convert_To
(Obj_Ptr
,
3976 New_Occurrence_Of
(Param
, Loc
)));
3978 -- Analyze new actual. Other actuals in calls are already analyzed
3979 -- and the list of actuals is not renalyzed after rewriting.
3981 Set_Parent
(Rec
, N
);
3987 end Expand_Protected_Object_Reference
;
3989 --------------------------------------
3990 -- Expand_Protected_Subprogram_Call --
3991 --------------------------------------
3993 procedure Expand_Protected_Subprogram_Call
4001 -- If the protected object is not an enclosing scope, this is
4002 -- an inter-object function call. Inter-object procedure
4003 -- calls are expanded by Exp_Ch9.Build_Simple_Entry_Call.
4004 -- The call is intra-object only if the subprogram being
4005 -- called is in the protected body being compiled, and if the
4006 -- protected object in the call is statically the enclosing type.
4007 -- The object may be an component of some other data structure,
4008 -- in which case this must be handled as an inter-object call.
4010 if not In_Open_Scopes
(Scop
)
4011 or else not Is_Entity_Name
(Name
(N
))
4013 if Nkind
(Name
(N
)) = N_Selected_Component
then
4014 Rec
:= Prefix
(Name
(N
));
4017 pragma Assert
(Nkind
(Name
(N
)) = N_Indexed_Component
);
4018 Rec
:= Prefix
(Prefix
(Name
(N
)));
4021 Build_Protected_Subprogram_Call
(N
,
4022 Name
=> New_Occurrence_Of
(Subp
, Sloc
(N
)),
4023 Rec
=> Convert_Concurrent
(Rec
, Etype
(Rec
)),
4027 Rec
:= Expand_Protected_Object_Reference
(N
, Scop
);
4033 Build_Protected_Subprogram_Call
(N
,
4042 -- If it is a function call it can appear in elaboration code and
4043 -- the called entity must be frozen here.
4045 if Ekind
(Subp
) = E_Function
then
4046 Freeze_Expression
(Name
(N
));
4048 end Expand_Protected_Subprogram_Call
;
4050 -----------------------
4051 -- Freeze_Subprogram --
4052 -----------------------
4054 procedure Freeze_Subprogram
(N
: Node_Id
) is
4055 Loc
: constant Source_Ptr
:= Sloc
(N
);
4056 E
: constant Entity_Id
:= Entity
(N
);
4058 procedure Check_Overriding_Inherited_Interfaces
(E
: Entity_Id
);
4059 -- (Ada 2005): Check if the primitive E covers some interface already
4060 -- implemented by some ancestor of the tagged-type associated with E.
4062 procedure Register_Interface_DT_Entry
4064 Ancestor_Iface_Prim
: Entity_Id
:= Empty
);
4065 -- (Ada 2005): Register an interface primitive in a secondary dispatch
4066 -- table. If Prim overrides an ancestor primitive of its associated
4067 -- tagged-type then Ancestor_Iface_Prim indicates the entity of that
4068 -- immediate ancestor associated with the interface; otherwise Prim and
4069 -- Ancestor_Iface_Prim have the same info.
4071 -------------------------------------------
4072 -- Check_Overriding_Inherited_Interfaces --
4073 -------------------------------------------
4075 procedure Check_Overriding_Inherited_Interfaces
(E
: Entity_Id
) is
4078 Prim_Op
: Entity_Id
;
4079 Overriden_Op
: Entity_Id
:= Empty
;
4082 if Ada_Version
< Ada_05
4083 or else not Is_Overriding_Operation
(E
)
4084 or else Is_Predefined_Dispatching_Operation
(E
)
4085 or else Present
(Alias
(E
))
4090 -- Get the entity associated with this primitive operation
4092 Typ
:= Scope
(DTC_Entity
(E
));
4093 while Etype
(Typ
) /= Typ
loop
4095 -- Climb to the immediate ancestor
4099 if Present
(Abstract_Interfaces
(Typ
)) then
4101 -- Look for the overriden subprogram in the primary dispatch
4102 -- table of the ancestor.
4104 Overriden_Op
:= Empty
;
4105 Elmt
:= First_Elmt
(Primitive_Operations
(Typ
));
4106 while Present
(Elmt
) loop
4107 Prim_Op
:= Node
(Elmt
);
4109 if Chars
(Prim_Op
) = Chars
(E
)
4110 and then Type_Conformant
4113 Skip_Controlling_Formals
=> True)
4114 and then DT_Position
(Prim_Op
) = DT_Position
(E
)
4115 and then Etype
(DTC_Entity
(Prim_Op
)) = RTE
(RE_Tag
)
4116 and then not Present
(Abstract_Interface_Alias
(Prim_Op
))
4118 if Overriden_Op
= Empty
then
4119 Overriden_Op
:= Prim_Op
;
4121 -- Additional check to ensure that if two candidates have
4122 -- been found then they refer to the same subprogram.
4131 while Present
(Alias
(A1
)) loop
4136 while Present
(Alias
(A2
)) loop
4141 raise Program_Error
;
4150 -- If not found this is the first overriding of some abstract
4153 if Overriden_Op
/= Empty
then
4155 -- Find the entries associated with interfaces that are
4156 -- alias of this primitive operation in the ancestor.
4158 Elmt
:= First_Elmt
(Primitive_Operations
(Typ
));
4159 while Present
(Elmt
) loop
4160 Prim_Op
:= Node
(Elmt
);
4162 if Present
(Abstract_Interface_Alias
(Prim_Op
))
4163 and then Alias
(Prim_Op
) = Overriden_Op
4165 Register_Interface_DT_Entry
(E
, Prim_Op
);
4173 end Check_Overriding_Inherited_Interfaces
;
4175 ---------------------------------
4176 -- Register_Interface_DT_Entry --
4177 ---------------------------------
4179 procedure Register_Interface_DT_Entry
4181 Ancestor_Iface_Prim
: Entity_Id
:= Empty
)
4183 Prim_Typ
: Entity_Id
;
4184 Prim_Op
: Entity_Id
;
4185 Iface_Typ
: Entity_Id
;
4186 Iface_DT_Ptr
: Entity_Id
;
4187 Iface_Tag
: Entity_Id
;
4188 New_Thunk
: Node_Id
;
4189 Thunk_Id
: Entity_Id
;
4192 if not Present
(Ancestor_Iface_Prim
) then
4193 Prim_Typ
:= Scope
(DTC_Entity
(Alias
(Prim
)));
4194 Iface_Typ
:= Scope
(DTC_Entity
(Abstract_Interface_Alias
(Prim
)));
4195 Iface_Tag
:= Find_Interface_Tag
4197 Iface
=> Iface_Typ
);
4199 -- Generate the code of the thunk only when this primitive
4200 -- operation is associated with a secondary dispatch table.
4202 if Etype
(Iface_Tag
) = RTE
(RE_Interface_Tag
) then
4203 Thunk_Id
:= Make_Defining_Identifier
(Loc
,
4204 New_Internal_Name
('T'));
4206 Expand_Interface_Thunk
4208 Thunk_Alias
=> Alias
(Prim
),
4209 Thunk_Id
=> Thunk_Id
,
4210 Thunk_Tag
=> Iface_Tag
);
4212 Insert_After
(N
, New_Thunk
);
4217 Iface
=> Iface_Typ
);
4219 Insert_After
(New_Thunk
,
4220 Fill_Secondary_DT_Entry
(Sloc
(Prim
),
4222 Iface_DT_Ptr
=> Iface_DT_Ptr
,
4223 Thunk_Id
=> Thunk_Id
));
4228 Scope
(DTC_Entity
(Abstract_Interface_Alias
4229 (Ancestor_Iface_Prim
)));
4233 (T
=> Scope
(DTC_Entity
(Alias
(Ancestor_Iface_Prim
))),
4234 Iface
=> Iface_Typ
);
4236 -- Generate the thunk only if the associated tag is an interface
4237 -- tag. The case in which the associated tag is the primary tag
4238 -- occurs when a tagged type is a direct derivation of an
4239 -- interface. For example:
4241 -- type I is interface;
4243 -- type T is new I with ...
4245 if Etype
(Iface_Tag
) = RTE
(RE_Interface_Tag
) then
4246 Thunk_Id
:= Make_Defining_Identifier
(Loc
,
4247 New_Internal_Name
('T'));
4249 if Present
(Alias
(Prim
)) then
4250 Prim_Op
:= Alias
(Prim
);
4256 Expand_Interface_Thunk
4257 (N
=> Ancestor_Iface_Prim
,
4258 Thunk_Alias
=> Prim_Op
,
4259 Thunk_Id
=> Thunk_Id
,
4260 Thunk_Tag
=> Iface_Tag
);
4262 Insert_After
(N
, New_Thunk
);
4266 (T
=> Scope
(DTC_Entity
(Prim_Op
)),
4267 Iface
=> Iface_Typ
);
4269 Insert_After
(New_Thunk
,
4270 Fill_Secondary_DT_Entry
(Sloc
(Prim
),
4271 Prim
=> Ancestor_Iface_Prim
,
4272 Iface_DT_Ptr
=> Iface_DT_Ptr
,
4273 Thunk_Id
=> Thunk_Id
));
4276 end Register_Interface_DT_Entry
;
4278 -- Start of processing for Freeze_Subprogram
4281 -- When a primitive is frozen, enter its name in the corresponding
4282 -- dispatch table. If the DTC_Entity field is not set this is an
4283 -- overridden primitive that can be ignored. We suppress the
4284 -- initialization of the dispatch table entry when Java_VM because
4285 -- the dispatching mechanism is handled internally by the JVM.
4287 if Is_Dispatching_Operation
(E
)
4288 and then not Is_Abstract
(E
)
4289 and then Present
(DTC_Entity
(E
))
4290 and then not Java_VM
4291 and then not Is_CPP_Class
(Scope
(DTC_Entity
(E
)))
4293 Check_Overriding_Operation
(E
);
4295 if Ada_Version
< Ada_05
then
4297 Fill_DT_Entry
(Sloc
(N
), Prim
=> E
));
4300 -- Ada 2005 (AI-251): Check if this entry corresponds with
4301 -- a subprogram that covers an abstract interface type.
4303 if Present
(Abstract_Interface_Alias
(E
)) then
4304 Register_Interface_DT_Entry
(E
);
4306 -- Common case: Primitive subprogram
4310 Fill_DT_Entry
(Sloc
(N
), Prim
=> E
));
4311 Check_Overriding_Inherited_Interfaces
(E
);
4316 -- Mark functions that return by reference. Note that it cannot be
4317 -- part of the normal semantic analysis of the spec since the
4318 -- underlying returned type may not be known yet (for private types).
4321 Typ
: constant Entity_Id
:= Etype
(E
);
4322 Utyp
: constant Entity_Id
:= Underlying_Type
(Typ
);
4325 if Is_Return_By_Reference_Type
(Typ
) then
4326 Set_Returns_By_Ref
(E
);
4328 elsif Present
(Utyp
) and then Controlled_Type
(Utyp
) then
4329 Set_Returns_By_Ref
(E
);
4332 end Freeze_Subprogram
;