Skip to content

R
riscv-gcc-1
Commit 6dfc5592 by Robert Dewar Committed by Arnaud Charlet
Options

exp_ch6.adb: Code clean up. 

2010-10-11  Robert Dewar  <dewar@adacore.com>

	* exp_ch6.adb: Code clean up.
	* exp_util.adb: Minor reformatting.

From-SVN: r165294
parent 44bf8eb0
Showing with 158 additions and 113 deletions
gcc/ada/ChangeLog
2010-10-11 Robert Dewar <dewar@adacore.com>
* exp_ch6.adb: Code clean up.
* exp_util.adb: Minor reformatting.
2010-10-11 Arnaud Charlet <charlet@adacore.com> 2010-10-11 Arnaud Charlet <charlet@adacore.com>
* sem_ch3.adb, exp_ch6.adb * sem_ch3.adb, exp_ch6.adb
......
gcc/ada/exp_ch6.adb
...@@ -134,9 +134,10 @@ package body Exp_Ch6 is ...@@ -134,9 +134,10 @@ package body Exp_Ch6 is
-- expression to pass for the master. In most cases, this is the current -- expression to pass for the master. In most cases, this is the current
-- master (_master). The two exceptions are: If the function call is the -- master (_master). The two exceptions are: If the function call is the
-- initialization expression for an allocator, we pass the master of the -- initialization expression for an allocator, we pass the master of the
-- access type. If the function call is the initialization expression for -- access type. If the function call is the initialization expression for a
-- a return object, we pass along the master passed in by the caller. The -- return object, we pass along the master passed in by the caller. The
-- activation chain to pass is always the local one. -- activation chain to pass is always the local one. Note: Master_Actual
-- can be Empty, but only if there are no tasks
procedure Check_Overriding_Operation (Subp : Entity_Id); procedure Check_Overriding_Operation (Subp : Entity_Id);
-- Subp is a dispatching operation. Check whether it may override an -- Subp is a dispatching operation. Check whether it may override an
...@@ -473,10 +474,10 @@ package body Exp_Ch6 is ...@@ -473,10 +474,10 @@ package body Exp_Ch6 is
(Function_Call : Node_Id; (Function_Call : Node_Id;
Function_Id : Entity_Id; Function_Id : Entity_Id;
Master_Actual : Node_Id) Master_Actual : Node_Id)
-- Note: Master_Actual can be Empty, but only if there are no tasks
is is
Loc : constant Source_Ptr := Sloc (Function_Call); Loc : constant Source_Ptr := Sloc (Function_Call);
Actual : Node_Id := Master_Actual; Actual : Node_Id := Master_Actual;
begin begin
-- No such extra parameters are needed if there are no tasks -- No such extra parameters are needed if there are no tasks
...@@ -1755,6 +1756,7 @@ package body Exp_Ch6 is ...@@ -1755,6 +1756,7 @@ package body Exp_Ch6 is
procedure Expand_Call (N : Node_Id) is procedure Expand_Call (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N); Loc : constant Source_Ptr := Sloc (N);
Call_Node : Node_Id := N;
Extra_Actuals : List_Id := No_List; Extra_Actuals : List_Id := No_List;
Prev : Node_Id := Empty; Prev : Node_Id := Empty;
...@@ -1791,13 +1793,14 @@ package body Exp_Ch6 is ...@@ -1791,13 +1793,14 @@ package body Exp_Ch6 is
if No (Prev) or else if No (Prev) or else
Nkind (Parent (Prev)) /= N_Parameter_Association Nkind (Parent (Prev)) /= N_Parameter_Association
then then
Set_Next_Named_Actual (Insert_Param, First_Named_Actual (N)); Set_Next_Named_Actual
Set_First_Named_Actual (N, Actual_Expr); (Insert_Param, First_Named_Actual (Call_Node));
Set_First_Named_Actual (Call_Node, Actual_Expr);
if No (Prev) then if No (Prev) then
if No (Parameter_Associations (N)) then if No (Parameter_Associations (Call_Node)) then
Set_Parameter_Associations (N, New_List); Set_Parameter_Associations (Call_Node, New_List);
Append (Insert_Param, Parameter_Associations (N)); Append (Insert_Param, Parameter_Associations (Call_Node));
end if; end if;
else else
Insert_After (Prev, Insert_Param); Insert_After (Prev, Insert_Param);
...@@ -1809,7 +1812,7 @@ package body Exp_Ch6 is ...@@ -1809,7 +1812,7 @@ package body Exp_Ch6 is
Set_Next_Named_Actual Set_Next_Named_Actual
(Insert_Param, Next_Named_Actual (Parent (Prev))); (Insert_Param, Next_Named_Actual (Parent (Prev)));
Set_Next_Named_Actual (Parent (Prev), Actual_Expr); Set_Next_Named_Actual (Parent (Prev), Actual_Expr);
Append (Insert_Param, Parameter_Associations (N)); Append (Insert_Param, Parameter_Associations (Call_Node));
end if; end if;
Prev := Actual_Expr; Prev := Actual_Expr;
...@@ -1825,7 +1828,7 @@ package body Exp_Ch6 is ...@@ -1825,7 +1828,7 @@ package body Exp_Ch6 is
begin begin
if Extra_Actuals = No_List then if Extra_Actuals = No_List then
Extra_Actuals := New_List; Extra_Actuals := New_List;
Set_Parent (Extra_Actuals, N); Set_Parent (Extra_Actuals, Call_Node);
end if; end if;
Append_To (Extra_Actuals, Append_To (Extra_Actuals,
...@@ -1835,7 +1838,7 @@ package body Exp_Ch6 is ...@@ -1835,7 +1838,7 @@ package body Exp_Ch6 is
Analyze_And_Resolve (Expr, Etype (EF)); Analyze_And_Resolve (Expr, Etype (EF));
if Nkind (N) = N_Function_Call then if Nkind (Call_Node) = N_Function_Call then
Set_Is_Accessibility_Actual (Parent (Expr)); Set_Is_Accessibility_Actual (Parent (Expr));
end if; end if;
end Add_Extra_Actual; end Add_Extra_Actual;
...@@ -1941,7 +1944,7 @@ package body Exp_Ch6 is ...@@ -1941,7 +1944,7 @@ package body Exp_Ch6 is
-- Local variables -- Local variables
Remote : constant Boolean := Is_Remote_Call (N); Remote : constant Boolean := Is_Remote_Call (Call_Node);
Actual : Node_Id; Actual : Node_Id;
Formal : Entity_Id; Formal : Entity_Id;
Orig_Subp : Entity_Id := Empty; Orig_Subp : Entity_Id := Empty;
...@@ -1964,35 +1967,37 @@ package body Exp_Ch6 is ...@@ -1964,35 +1967,37 @@ package body Exp_Ch6 is
begin begin
-- Ignore if previous error -- Ignore if previous error
if Nkind (N) in N_Has_Etype and then Etype (N) = Any_Type then if Nkind (Call_Node) in N_Has_Etype
and then Etype (Call_Node) = Any_Type
then
return; return;
end if; end if;
-- Call using access to subprogram with explicit dereference -- Call using access to subprogram with explicit dereference
if Nkind (Name (N)) = N_Explicit_Dereference then if Nkind (Name (Call_Node)) = N_Explicit_Dereference then
Subp := Etype (Name (N)); Subp := Etype (Name (Call_Node));
Parent_Subp := Empty; Parent_Subp := Empty;
-- Case of call to simple entry, where the Name is a selected component -- Case of call to simple entry, where the Name is a selected component
-- whose prefix is the task, and whose selector name is the entry name -- whose prefix is the task, and whose selector name is the entry name
elsif Nkind (Name (N)) = N_Selected_Component then elsif Nkind (Name (Call_Node)) = N_Selected_Component then
Subp := Entity (Selector_Name (Name (N))); Subp := Entity (Selector_Name (Name (Call_Node)));
Parent_Subp := Empty; Parent_Subp := Empty;
-- Case of call to member of entry family, where Name is an indexed -- Case of call to member of entry family, where Name is an indexed
-- component, with the prefix being a selected component giving the -- component, with the prefix being a selected component giving the
-- task and entry family name, and the index being the entry index. -- task and entry family name, and the index being the entry index.
elsif Nkind (Name (N)) = N_Indexed_Component then elsif Nkind (Name (Call_Node)) = N_Indexed_Component then
Subp := Entity (Selector_Name (Prefix (Name (N)))); Subp := Entity (Selector_Name (Prefix (Name (Call_Node))));
Parent_Subp := Empty; Parent_Subp := Empty;
-- Normal case -- Normal case
else else
Subp := Entity (Name (N)); Subp := Entity (Name (Call_Node));
Parent_Subp := Alias (Subp); Parent_Subp := Alias (Subp);
-- Replace call to Raise_Exception by call to Raise_Exception_Always -- Replace call to Raise_Exception by call to Raise_Exception_Always
...@@ -2007,8 +2012,8 @@ package body Exp_Ch6 is ...@@ -2007,8 +2012,8 @@ package body Exp_Ch6 is
and then RTE_Available (RE_Raise_Exception_Always) and then RTE_Available (RE_Raise_Exception_Always)
then then
declare declare
FA : constant Node_Id := Original_Node (First_Actual (N)); FA : constant Node_Id := Original_Node
(First_Actual (Call_Node));
begin begin
-- The case we catch is where the first argument is obtained -- The case we catch is where the first argument is obtained
-- using the Identity attribute (which must always be -- using the Identity attribute (which must always be
...@@ -2018,7 +2023,7 @@ package body Exp_Ch6 is ...@@ -2018,7 +2023,7 @@ package body Exp_Ch6 is
and then Attribute_Name (FA) = Name_Identity and then Attribute_Name (FA) = Name_Identity
then then
Subp := RTE (RE_Raise_Exception_Always); Subp := RTE (RE_Raise_Exception_Always);
Set_Name (N, New_Occurrence_Of (Subp, Loc)); Set_Name (Call_Node, New_Occurrence_Of (Subp, Loc));
end if; end if;
end; end;
end if; end if;
...@@ -2034,13 +2039,13 @@ package body Exp_Ch6 is ...@@ -2034,13 +2039,13 @@ package body Exp_Ch6 is
-- is a renaming of an entry and rewrite it as an entry call. -- is a renaming of an entry and rewrite it as an entry call.
if Ada_Version >= Ada_2005 if Ada_Version >= Ada_2005
and then Nkind (N) = N_Procedure_Call_Statement and then Nkind (Call_Node) = N_Procedure_Call_Statement
and then and then
((Nkind (Parent (N)) = N_Triggering_Alternative ((Nkind (Parent (Call_Node)) = N_Triggering_Alternative
and then Triggering_Statement (Parent (N)) = N) and then Triggering_Statement (Parent (Call_Node)) = Call_Node)
or else or else
(Nkind (Parent (N)) = N_Entry_Call_Alternative (Nkind (Parent (Call_Node)) = N_Entry_Call_Alternative
and then Entry_Call_Statement (Parent (N)) = N)) and then Entry_Call_Statement (Parent (Call_Node)) = Call_Node))
then then
declare declare
Ren_Decl : Node_Id; Ren_Decl : Node_Id;
...@@ -2057,12 +2062,13 @@ package body Exp_Ch6 is ...@@ -2057,12 +2062,13 @@ package body Exp_Ch6 is
Ren_Decl := Original_Node (Parent (Parent (Ren_Root))); Ren_Decl := Original_Node (Parent (Parent (Ren_Root)));
if Nkind (Ren_Decl) = N_Subprogram_Renaming_Declaration then if Nkind (Ren_Decl) = N_Subprogram_Renaming_Declaration then
Rewrite (N, Rewrite (Call_Node,
Make_Entry_Call_Statement (Loc, Make_Entry_Call_Statement (Loc,
Name => Name =>
New_Copy_Tree (Name (Ren_Decl)), New_Copy_Tree (Name (Ren_Decl)),
Parameter_Associations => Parameter_Associations =>
New_Copy_List_Tree (Parameter_Associations (N)))); New_Copy_List_Tree
(Parameter_Associations (Call_Node))));
return; return;
end if; end if;
...@@ -2080,7 +2086,7 @@ package body Exp_Ch6 is ...@@ -2080,7 +2086,7 @@ package body Exp_Ch6 is
-- (Though it seems that this would be better done in Expand_Actuals???) -- (Though it seems that this would be better done in Expand_Actuals???)
Formal := First_Formal (Subp); Formal := First_Formal (Subp);
Actual := First_Actual (N); Actual := First_Actual (Call_Node);
Param_Count := 1; Param_Count := 1;
while Present (Formal) loop while Present (Formal) loop
...@@ -2469,7 +2475,7 @@ package body Exp_Ch6 is ...@@ -2469,7 +2475,7 @@ package body Exp_Ch6 is
-- checking mode, all indexed components are checked with a call -- checking mode, all indexed components are checked with a call
-- directly from Expand_N_Indexed_Component. -- directly from Expand_N_Indexed_Component.
if Comes_From_Source (N) if Comes_From_Source (Call_Node)
and then Ekind (Formal) /= E_In_Parameter and then Ekind (Formal) /= E_In_Parameter
and then Validity_Checks_On and then Validity_Checks_On
and then Validity_Check_Default and then Validity_Check_Default
...@@ -2568,50 +2574,53 @@ package body Exp_Ch6 is ...@@ -2568,50 +2574,53 @@ package body Exp_Ch6 is
-- assignment might be transformed to a declaration for an unconstrained -- assignment might be transformed to a declaration for an unconstrained
-- value if the expression is classwide. -- value if the expression is classwide.
if Nkind (N) = N_Function_Call if Nkind (Call_Node) = N_Function_Call
and then Is_Tag_Indeterminate (N) and then Is_Tag_Indeterminate (Call_Node)
and then Is_Entity_Name (Name (N)) and then Is_Entity_Name (Name (Call_Node))
then then
declare declare
Ass : Node_Id := Empty; Ass : Node_Id := Empty;
begin begin
if Nkind (Parent (N)) = N_Assignment_Statement then if Nkind (Parent (Call_Node)) = N_Assignment_Statement then
Ass := Parent (N); Ass := Parent (Call_Node);
elsif Nkind (Parent (N)) = N_Qualified_Expression elsif Nkind (Parent (Call_Node)) = N_Qualified_Expression
and then Nkind (Parent (Parent (N))) = N_Assignment_Statement and then Nkind (Parent (Parent (Call_Node)))
= N_Assignment_Statement
then then
Ass := Parent (Parent (N)); Ass := Parent (Parent (Call_Node));
elsif Nkind (Parent (N)) = N_Explicit_Dereference elsif Nkind (Parent (Call_Node)) = N_Explicit_Dereference
and then Nkind (Parent (Parent (N))) = N_Assignment_Statement and then Nkind (Parent (Parent (Call_Node)))
= N_Assignment_Statement
then then
Ass := Parent (Parent (N)); Ass := Parent (Parent (Call_Node));
end if; end if;
if Present (Ass) if Present (Ass)
and then Is_Class_Wide_Type (Etype (Name (Ass))) and then Is_Class_Wide_Type (Etype (Name (Ass)))
then then
if Is_Access_Type (Etype (N)) then if Is_Access_Type (Etype (Call_Node)) then
if Designated_Type (Etype (N)) /= if Designated_Type (Etype (Call_Node)) /=
Root_Type (Etype (Name (Ass))) Root_Type (Etype (Name (Ass)))
then then
Error_Msg_NE Error_Msg_NE
("tag-indeterminate expression " ("tag-indeterminate expression "
& " must have designated type& (RM 5.2 (6))", & " must have designated type& (RM 5.2 (6))",
N, Root_Type (Etype (Name (Ass)))); Call_Node, Root_Type (Etype (Name (Ass))));
else else
Propagate_Tag (Name (Ass), N); Propagate_Tag (Name (Ass), Call_Node);
end if; end if;
elsif Etype (N) /= Root_Type (Etype (Name (Ass))) then elsif Etype (Call_Node) /= Root_Type (Etype (Name (Ass))) then
Error_Msg_NE Error_Msg_NE
("tag-indeterminate expression must have type&" ("tag-indeterminate expression must have type&"
& "(RM 5.2 (6))", N, Root_Type (Etype (Name (Ass)))); & "(RM 5.2 (6))",
Call_Node, Root_Type (Etype (Name (Ass))));
else else
Propagate_Tag (Name (Ass), N); Propagate_Tag (Name (Ass), Call_Node);
end if; end if;
-- The call will be rewritten as a dispatching call, and -- The call will be rewritten as a dispatching call, and
...@@ -2625,10 +2634,10 @@ package body Exp_Ch6 is ...@@ -2625,10 +2634,10 @@ package body Exp_Ch6 is
-- Ada 2005 (AI-251): If some formal is a class-wide interface, expand -- Ada 2005 (AI-251): If some formal is a class-wide interface, expand
-- it to point to the correct secondary virtual table -- it to point to the correct secondary virtual table
if Nkind_In (N, N_Function_Call, N_Procedure_Call_Statement) if Nkind_In (Call_Node, N_Function_Call, N_Procedure_Call_Statement)
and then CW_Interface_Formals_Present and then CW_Interface_Formals_Present
then then
Expand_Interface_Actuals (N); Expand_Interface_Actuals (Call_Node);
end if; end if;
-- Deals with Dispatch_Call if we still have a call, before expanding -- Deals with Dispatch_Call if we still have a call, before expanding
...@@ -2639,27 +2648,49 @@ package body Exp_Ch6 is ...@@ -2639,27 +2648,49 @@ package body Exp_Ch6 is
-- back-ends directly handle the generation of dispatching calls and -- back-ends directly handle the generation of dispatching calls and
-- would have to undo any expansion to an indirect call. -- would have to undo any expansion to an indirect call.
if Nkind_In (N, N_Function_Call, N_Procedure_Call_Statement) if Nkind_In (Call_Node, N_Function_Call, N_Procedure_Call_Statement)
and then Present (Controlling_Argument (N)) and then Present (Controlling_Argument (Call_Node))
then then
if Tagged_Type_Expansion then declare
Expand_Dispatching_Call (N); Typ : constant Entity_Id := Find_Dispatching_Type (Subp);
Eq_Prim_Op : Entity_Id := Empty;
-- The following return is worrisome. Is it really OK to skip all begin
-- remaining processing in this procedure ??? if not Is_Limited_Type (Typ) then
Eq_Prim_Op := Find_Prim_Op (Typ, Name_Op_Eq);
end if;
return; if Tagged_Type_Expansion then
Expand_Dispatching_Call (Call_Node);
else -- The following return is worrisome. Is it really OK to skip
Apply_Tag_Checks (N); -- all remaining processing in this procedure ???
-- Expansion of a dispatching call results in an indirect call, return;
-- which in turn causes current values to be killed (see
-- Resolve_Call), so on VM targets we do the call here to ensure
-- consistent warnings between VM and non-VM targets.
Kill_Current_Values; -- VM targets
end if;
else
Apply_Tag_Checks (Call_Node);
-- Expansion of a dispatching call results in an indirect call,
-- which in turn causes current values to be killed (see
-- Resolve_Call), so on VM targets we do the call here to
-- ensure consistent warnings between VM and non-VM targets.
Kill_Current_Values;
end if;
-- If this is a dispatching "=" then we must update the reference
-- to the call node because we generated:
-- x.tag = y.tag and then x = y
if Subp = Eq_Prim_Op
and then Nkind (Call_Node) = N_Op_And
then
Call_Node := Right_Opnd (Call_Node);
end if;
end;
end if; end if;
-- Similarly, expand calls to RCI subprograms on which pragma -- Similarly, expand calls to RCI subprograms on which pragma
...@@ -2667,8 +2698,8 @@ package body Exp_Ch6 is ...@@ -2667,8 +2698,8 @@ package body Exp_Ch6 is
-- later. Do this only when the call comes from source since we -- later. Do this only when the call comes from source since we
-- do not want such a rewriting to occur in expanded code. -- do not want such a rewriting to occur in expanded code.
if Is_All_Remote_Call (N) then if Is_All_Remote_Call (Call_Node) then
Expand_All_Calls_Remote_Subprogram_Call (N); Expand_All_Calls_Remote_Subprogram_Call (Call_Node);
-- Similarly, do not add extra actuals for an entry call whose entity -- Similarly, do not add extra actuals for an entry call whose entity
-- is a protected procedure, or for an internal protected subprogram -- is a protected procedure, or for an internal protected subprogram
...@@ -2693,15 +2724,15 @@ package body Exp_Ch6 is ...@@ -2693,15 +2724,15 @@ package body Exp_Ch6 is
-- At this point we have all the actuals, so this is the point at which -- At this point we have all the actuals, so this is the point at which
-- the various expansion activities for actuals is carried out. -- the various expansion activities for actuals is carried out.
Expand_Actuals (N, Subp); Expand_Actuals (Call_Node, Subp);
-- If the subprogram is a renaming, or if it is inherited, replace it in -- If the subprogram is a renaming, or if it is inherited, replace it in
-- the call with the name of the actual subprogram being called. If this -- the call with the name of the actual subprogram being called. If this
-- is a dispatching call, the run-time decides what to call. The Alias -- is a dispatching call, the run-time decides what to call. The Alias
-- attribute does not apply to entries. -- attribute does not apply to entries.
if Nkind (N) /= N_Entry_Call_Statement if Nkind (Call_Node) /= N_Entry_Call_Statement
and then No (Controlling_Argument (N)) and then No (Controlling_Argument (Call_Node))
and then Present (Parent_Subp) and then Present (Parent_Subp)
then then
if Present (Inherited_From_Formal (Subp)) then if Present (Inherited_From_Formal (Subp)) then
...@@ -2712,13 +2743,14 @@ package body Exp_Ch6 is ...@@ -2712,13 +2743,14 @@ package body Exp_Ch6 is
-- The below setting of Entity is suspect, see F109-018 discussion??? -- The below setting of Entity is suspect, see F109-018 discussion???
Set_Entity (Name (N), Parent_Subp); Set_Entity (Name (Call_Node), Parent_Subp);
if Is_Abstract_Subprogram (Parent_Subp) if Is_Abstract_Subprogram (Parent_Subp)
and then not In_Instance and then not In_Instance
then then
Error_Msg_NE Error_Msg_NE
("cannot call abstract subprogram &!", Name (N), Parent_Subp); ("cannot call abstract subprogram &!",
Name (Call_Node), Parent_Subp);
end if; end if;
-- Inspect all formals of derived subprogram Subp. Compare parameter -- Inspect all formals of derived subprogram Subp. Compare parameter
...@@ -2754,7 +2786,7 @@ package body Exp_Ch6 is ...@@ -2754,7 +2786,7 @@ package body Exp_Ch6 is
Parent_Typ : Entity_Id; Parent_Typ : Entity_Id;
begin begin
Actual := First_Actual (N); Actual := First_Actual (Call_Node);
Formal := First_Formal (Subp); Formal := First_Formal (Subp);
Parent_Formal := First_Formal (Parent_Subp); Parent_Formal := First_Formal (Parent_Subp);
while Present (Formal) loop while Present (Formal) loop
...@@ -2842,7 +2874,7 @@ package body Exp_Ch6 is ...@@ -2842,7 +2874,7 @@ package body Exp_Ch6 is
-- Check for violation of No_Abort_Statements -- Check for violation of No_Abort_Statements
if Is_RTE (Subp, RE_Abort_Task) then if Is_RTE (Subp, RE_Abort_Task) then
Check_Restriction (No_Abort_Statements, N); Check_Restriction (No_Abort_Statements, Call_Node);
-- Check for violation of No_Dynamic_Attachment -- Check for violation of No_Dynamic_Attachment
...@@ -2855,17 +2887,17 @@ package body Exp_Ch6 is ...@@ -2855,17 +2887,17 @@ package body Exp_Ch6 is
Is_RTE (Subp, RE_Detach_Handler) or else Is_RTE (Subp, RE_Detach_Handler) or else
Is_RTE (Subp, RE_Reference)) Is_RTE (Subp, RE_Reference))
then then
Check_Restriction (No_Dynamic_Attachment, N); Check_Restriction (No_Dynamic_Attachment, Call_Node);
end if; end if;
-- Deal with case where call is an explicit dereference -- Deal with case where call is an explicit dereference
if Nkind (Name (N)) = N_Explicit_Dereference then if Nkind (Name (Call_Node)) = N_Explicit_Dereference then
-- Handle case of access to protected subprogram type -- Handle case of access to protected subprogram type
if Is_Access_Protected_Subprogram_Type if Is_Access_Protected_Subprogram_Type
(Base_Type (Etype (Prefix (Name (N))))) (Base_Type (Etype (Prefix (Name (Call_Node)))))
then then
-- If this is a call through an access to protected operation, the -- If this is a call through an access to protected operation, the
-- prefix has the form (object'address, operation'access). Rewrite -- prefix has the form (object'address, operation'access). Rewrite
...@@ -2877,7 +2909,7 @@ package body Exp_Ch6 is ...@@ -2877,7 +2909,7 @@ package body Exp_Ch6 is
Parm : List_Id; Parm : List_Id;
Nam : Node_Id; Nam : Node_Id;
Obj : Node_Id; Obj : Node_Id;
Ptr : constant Node_Id := Prefix (Name (N)); Ptr : constant Node_Id := Prefix (Name (Call_Node));
T : constant Entity_Id := T : constant Entity_Id :=
Equivalent_Type (Base_Type (Etype (Ptr))); Equivalent_Type (Base_Type (Etype (Ptr)));
...@@ -2902,8 +2934,8 @@ package body Exp_Ch6 is ...@@ -2902,8 +2934,8 @@ package body Exp_Ch6 is
Make_Explicit_Dereference (Loc, Make_Explicit_Dereference (Loc,
Prefix => Nam); Prefix => Nam);
if Present (Parameter_Associations (N)) then if Present (Parameter_Associations (Call_Node)) then
Parm := Parameter_Associations (N); Parm := Parameter_Associations (Call_Node);
else else
Parm := New_List; Parm := New_List;
end if; end if;
...@@ -2922,7 +2954,7 @@ package body Exp_Ch6 is ...@@ -2922,7 +2954,7 @@ package body Exp_Ch6 is
Parameter_Associations => Parm); Parameter_Associations => Parm);
end if; end if;
Set_First_Named_Actual (Call, First_Named_Actual (N)); Set_First_Named_Actual (Call, First_Named_Actual (Call_Node));
Set_Etype (Call, Etype (D_T)); Set_Etype (Call, Etype (D_T));
-- We do not re-analyze the call to avoid infinite recursion. -- We do not re-analyze the call to avoid infinite recursion.
...@@ -2930,7 +2962,7 @@ package body Exp_Ch6 is ...@@ -2930,7 +2962,7 @@ package body Exp_Ch6 is
-- the checks on the prefix that would otherwise be emitted -- the checks on the prefix that would otherwise be emitted
-- when resolving a call. -- when resolving a call.
Rewrite (N, Call); Rewrite (Call_Node, Call);
Analyze (Nam); Analyze (Nam);
Apply_Access_Check (Nam); Apply_Access_Check (Nam);
Analyze (Obj); Analyze (Obj);
...@@ -2952,13 +2984,13 @@ package body Exp_Ch6 is ...@@ -2952,13 +2984,13 @@ package body Exp_Ch6 is
-- parent operation, will yield the wrong type. -- parent operation, will yield the wrong type.
if Is_Intrinsic_Subprogram (Subp) then if Is_Intrinsic_Subprogram (Subp) then
Expand_Intrinsic_Call (N, Subp); Expand_Intrinsic_Call (Call_Node, Subp);
if Nkind (N) = N_Unchecked_Type_Conversion if Nkind (Call_Node) = N_Unchecked_Type_Conversion
and then Parent_Subp /= Orig_Subp and then Parent_Subp /= Orig_Subp
and then Etype (Parent_Subp) /= Etype (Orig_Subp) and then Etype (Parent_Subp) /= Etype (Orig_Subp)
then then
Set_Etype (N, Etype (Orig_Subp)); Set_Etype (Call_Node, Etype (Orig_Subp));
end if; end if;
return; return;
...@@ -2980,13 +3012,13 @@ package body Exp_Ch6 is ...@@ -2980,13 +3012,13 @@ package body Exp_Ch6 is
-- that tree generated is the same in both cases, for Inspector use. -- that tree generated is the same in both cases, for Inspector use.
if Is_RTE (Subp, RE_To_Address) then if Is_RTE (Subp, RE_To_Address) then
Rewrite (N, Rewrite (Call_Node,
Unchecked_Convert_To Unchecked_Convert_To
(RTE (RE_Address), Relocate_Node (First_Actual (N)))); (RTE (RE_Address), Relocate_Node (First_Actual (Call_Node))));
return; return;
elsif Is_Null_Procedure (Subp) then elsif Is_Null_Procedure (Subp) then
Rewrite (N, Make_Null_Statement (Loc)); Rewrite (Call_Node, Make_Null_Statement (Loc));
return; return;
end if; end if;
...@@ -3060,8 +3092,8 @@ package body Exp_Ch6 is ...@@ -3060,8 +3092,8 @@ package body Exp_Ch6 is
else else
Bod := Body_To_Inline (Spec); Bod := Body_To_Inline (Spec);
if (In_Extended_Main_Code_Unit (N) if (In_Extended_Main_Code_Unit (Call_Node)
or else In_Extended_Main_Code_Unit (Parent (N)) or else In_Extended_Main_Code_Unit (Parent (Call_Node))
or else Has_Pragma_Inline_Always (Subp)) or else Has_Pragma_Inline_Always (Subp))
and then (not In_Same_Extended_Unit (Sloc (Bod), Loc) and then (not In_Same_Extended_Unit (Sloc (Bod), Loc)
or else or else
...@@ -3081,7 +3113,7 @@ package body Exp_Ch6 is ...@@ -3081,7 +3113,7 @@ package body Exp_Ch6 is
-- visible a private entity in the body of the main unit, -- visible a private entity in the body of the main unit,
-- that gigi will see before its sees its proper definition. -- that gigi will see before its sees its proper definition.
elsif not (In_Extended_Main_Code_Unit (N)) elsif not (In_Extended_Main_Code_Unit (Call_Node))
and then In_Package_Body and then In_Package_Body
then then
Must_Inline := not In_Extended_Main_Source_Unit (Subp); Must_Inline := not In_Extended_Main_Source_Unit (Subp);
...@@ -3089,7 +3121,7 @@ package body Exp_Ch6 is ...@@ -3089,7 +3121,7 @@ package body Exp_Ch6 is
end if; end if;
if Must_Inline then if Must_Inline then
Expand_Inlined_Call (N, Subp, Orig_Subp); Expand_Inlined_Call (Call_Node, Subp, Orig_Subp);
else else
-- Let the back end handle it -- Let the back end handle it
...@@ -3098,13 +3130,13 @@ package body Exp_Ch6 is ...@@ -3098,13 +3130,13 @@ package body Exp_Ch6 is
if Front_End_Inlining if Front_End_Inlining
and then Nkind (Spec) = N_Subprogram_Declaration and then Nkind (Spec) = N_Subprogram_Declaration
and then (In_Extended_Main_Code_Unit (N)) and then (In_Extended_Main_Code_Unit (Call_Node))
and then No (Body_To_Inline (Spec)) and then No (Body_To_Inline (Spec))
and then not Has_Completion (Subp) and then not Has_Completion (Subp)
and then In_Same_Extended_Unit (Sloc (Spec), Loc) and then In_Same_Extended_Unit (Sloc (Spec), Loc)
then then
Cannot_Inline Cannot_Inline
("cannot inline& (body not seen yet)?", N, Subp); ("cannot inline& (body not seen yet)?", Call_Node, Subp);
end if; end if;
end if; end if;
end Inlined_Subprogram; end Inlined_Subprogram;
...@@ -3122,7 +3154,7 @@ package body Exp_Ch6 is ...@@ -3122,7 +3154,7 @@ package body Exp_Ch6 is
Scop := Scope (Subp); Scop := Scope (Subp);
if Nkind (N) /= N_Entry_Call_Statement if Nkind (Call_Node) /= N_Entry_Call_Statement
and then Is_Protected_Type (Scop) and then Is_Protected_Type (Scop)
and then Ekind (Subp) /= E_Subprogram_Type and then Ekind (Subp) /= E_Subprogram_Type
and then not Is_Eliminated (Subp) and then not Is_Eliminated (Subp)
...@@ -3130,7 +3162,7 @@ package body Exp_Ch6 is ...@@ -3130,7 +3162,7 @@ package body Exp_Ch6 is
-- If the call is an internal one, it is rewritten as a call to the -- If the call is an internal one, it is rewritten as a call to the
-- corresponding unprotected subprogram. -- corresponding unprotected subprogram.
Expand_Protected_Subprogram_Call (N, Subp, Scop); Expand_Protected_Subprogram_Call (Call_Node, Subp, Scop);
end if; end if;
-- Functions returning controlled objects need special attention: -- Functions returning controlled objects need special attention:
...@@ -3147,14 +3179,14 @@ package body Exp_Ch6 is ...@@ -3147,14 +3179,14 @@ package body Exp_Ch6 is
or else or else
not Is_Concurrent_Record_Type (Etype (First_Formal (Subp)))) not Is_Concurrent_Record_Type (Etype (First_Formal (Subp))))
then then
Expand_Ctrl_Function_Call (N); Expand_Ctrl_Function_Call (Call_Node);
-- Build-in-place function calls which appear in anonymous contexts -- Build-in-place function calls which appear in anonymous contexts
-- need a transient scope to ensure the proper finalization of the -- need a transient scope to ensure the proper finalization of the
-- intermediate result after its use. -- intermediate result after its use.
elsif Is_Build_In_Place_Function_Call (N) elsif Is_Build_In_Place_Function_Call (Call_Node)
and then Nkind_In (Parent (N), N_Attribute_Reference, and then Nkind_In (Parent (Call_Node), N_Attribute_Reference,
N_Function_Call, N_Function_Call,
N_Indexed_Component, N_Indexed_Component,
N_Object_Renaming_Declaration, N_Object_Renaming_Declaration,
...@@ -3162,7 +3194,7 @@ package body Exp_Ch6 is ...@@ -3162,7 +3194,7 @@ package body Exp_Ch6 is
N_Selected_Component, N_Selected_Component,
N_Slice) N_Slice)
then then
Establish_Transient_Scope (N, Sec_Stack => True); Establish_Transient_Scope (Call_Node, Sec_Stack => True);
end if; end if;
end if; end if;
...@@ -3187,7 +3219,7 @@ package body Exp_Ch6 is ...@@ -3187,7 +3219,7 @@ package body Exp_Ch6 is
-- the validity of the parameter before setting it. -- the validity of the parameter before setting it.
Formal := First_Formal (Subp); Formal := First_Formal (Subp);
Actual := First_Actual (N); Actual := First_Actual (Call_Node);
while Formal /= First_Optional_Parameter (Subp) loop while Formal /= First_Optional_Parameter (Subp) loop
Last_Keep_Arg := Actual; Last_Keep_Arg := Actual;
Next_Formal (Formal); Next_Formal (Formal);
...@@ -3221,8 +3253,8 @@ package body Exp_Ch6 is ...@@ -3221,8 +3253,8 @@ package body Exp_Ch6 is
-- If no arguments, delete entire list, this is the easy case -- If no arguments, delete entire list, this is the easy case
if No (Last_Keep_Arg) then if No (Last_Keep_Arg) then
Set_Parameter_Associations (N, No_List); Set_Parameter_Associations (Call_Node, No_List);
Set_First_Named_Actual (N, Empty); Set_First_Named_Actual (Call_Node, Empty);
-- Case where at the last retained argument is positional. This -- Case where at the last retained argument is positional. This
-- is also an easy case, since the retained arguments are already -- is also an easy case, since the retained arguments are already
...@@ -3234,7 +3266,7 @@ package body Exp_Ch6 is ...@@ -3234,7 +3266,7 @@ package body Exp_Ch6 is
Discard_Node (Remove_Next (Last_Keep_Arg)); Discard_Node (Remove_Next (Last_Keep_Arg));
end loop; end loop;
Set_First_Named_Actual (N, Empty); Set_First_Named_Actual (Call_Node, Empty);
-- This is the annoying case where the last retained argument -- This is the annoying case where the last retained argument
-- is a named parameter. Since the original arguments are not -- is a named parameter. Since the original arguments are not
...@@ -3251,14 +3283,22 @@ package body Exp_Ch6 is ...@@ -3251,14 +3283,22 @@ package body Exp_Ch6 is
-- list (they are still chained using First_Named_Actual -- list (they are still chained using First_Named_Actual
-- and Next_Named_Actual, so we have not lost them!) -- and Next_Named_Actual, so we have not lost them!)
Temp := First (Parameter_Associations (N)); Temp := First (Parameter_Associations (Call_Node));
-- Case of all parameters named, remove them all -- Case of all parameters named, remove them all
if Nkind (Temp) = N_Parameter_Association then if Nkind (Temp) = N_Parameter_Association then
while Is_Non_Empty_List (Parameter_Associations (N)) loop -- Suppress warnings to avoid warning on possible
Temp := Remove_Head (Parameter_Associations (N)); -- infinite loop (because Call_Node is not modified).
pragma Warnings (Off);
while Is_Non_Empty_List
(Parameter_Associations (Call_Node))
loop
Temp :=
Remove_Head (Parameter_Associations (Call_Node));
end loop; end loop;
pragma Warnings (On);
-- Case of mixed positional/named, remove named parameters -- Case of mixed positional/named, remove named parameters
...@@ -3278,11 +3318,11 @@ package body Exp_Ch6 is ...@@ -3278,11 +3318,11 @@ package body Exp_Ch6 is
-- touched since we are only reordering them on the actual -- touched since we are only reordering them on the actual
-- parameter association list. -- parameter association list.
Passoc := Parent (First_Named_Actual (N)); Passoc := Parent (First_Named_Actual (Call_Node));
loop loop
Temp := Relocate_Node (Passoc); Temp := Relocate_Node (Passoc);
Append_To Append_To
(Parameter_Associations (N), Temp); (Parameter_Associations (Call_Node), Temp);
exit when exit when
Last_Keep_Arg = Explicit_Actual_Parameter (Passoc); Last_Keep_Arg = Explicit_Actual_Parameter (Passoc);
Passoc := Parent (Next_Named_Actual (Passoc)); Passoc := Parent (Next_Named_Actual (Passoc));
......
gcc/ada/exp_util.adb
...@@ -4842,7 +4842,7 @@ package body Exp_Util is ...@@ -4842,7 +4842,7 @@ package body Exp_Util is
-- No action needed for renamings of class-wide expressions because for -- No action needed for renamings of class-wide expressions because for
-- class-wide types Remove_Side_Effects uses a renaming to capture the -- class-wide types Remove_Side_Effects uses a renaming to capture the
-- expression (and hence we would generate a never-ending loop in the -- expression (and hence we would generate a never-ending loop in the
-- frontend). -- front end).
if Is_Class_Wide_Type (Exp_Type) if Is_Class_Wide_Type (Exp_Type)
and then Nkind (Parent (Exp)) = N_Object_Renaming_Declaration and then Nkind (Parent (Exp)) = N_Object_Renaming_Declaration
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment