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