From a30647690de250eba61f941bb2a2fd35fe3894fc Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Sun, 14 Mar 2021 13:32:59 -0400 Subject: [PATCH] [Ada] Code cleanups in exp_ch6.adb gcc/ada/ * exp_ch6.adb (Expand_Call_Helper): Code cleanups. --- gcc/ada/exp_ch6.adb | 105 +++++++++++++++++++++++++--------------------------- 1 file changed, 51 insertions(+), 54 deletions(-) diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index 6314b0a..14c5d18 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -4248,6 +4248,16 @@ package body Exp_Ch6 is if Nkind (Call_Node) in N_Subprogram_Call and then Present (Controlling_Argument (Call_Node)) then + if Tagged_Type_Expansion then + Expand_Dispatching_Call (Call_Node); + + -- Expand_Dispatching_Call takes care of all the needed processing + + return; + end if; + + -- VM targets + declare Call_Typ : constant Entity_Id := Etype (Call_Node); Typ : constant Entity_Id := Find_Dispatching_Type (Subp); @@ -4257,69 +4267,56 @@ package body Exp_Ch6 is Prev_Call : Node_Id; begin + Apply_Tag_Checks (Call_Node); + if not Is_Limited_Type (Typ) then Eq_Prim_Op := Find_Prim_Op (Typ, Name_Op_Eq); end if; - if Tagged_Type_Expansion then - Expand_Dispatching_Call (Call_Node); - - -- The following return is worrisome. Is it really OK to skip - -- all remaining processing in this procedure ??? - - return; - - -- VM targets - - else - Apply_Tag_Checks (Call_Node); - - -- If this is a dispatching "=", we must first compare the - -- tags so we generate: x.tag = y.tag and then x = y - - if Subp = Eq_Prim_Op then + -- If this is a dispatching "=", we must first compare the + -- tags so we generate: x.tag = y.tag and then x = y - -- Mark the node as analyzed to avoid reanalyzing this - -- dispatching call (which would cause a never-ending loop) - - Prev_Call := Relocate_Node (Call_Node); - Set_Analyzed (Prev_Call); + if Subp = Eq_Prim_Op then - Param := First_Actual (Call_Node); - New_Call := - Make_And_Then (Loc, - Left_Opnd => - Make_Op_Eq (Loc, - Left_Opnd => - Make_Selected_Component (Loc, - Prefix => New_Value (Param), - Selector_Name => - New_Occurrence_Of - (First_Tag_Component (Typ), Loc)), + -- Mark the node as analyzed to avoid reanalyzing this + -- dispatching call (which would cause a never-ending loop) + + Prev_Call := Relocate_Node (Call_Node); + Set_Analyzed (Prev_Call); + + Param := First_Actual (Call_Node); + New_Call := + Make_And_Then (Loc, + Left_Opnd => + Make_Op_Eq (Loc, + Left_Opnd => + Make_Selected_Component (Loc, + Prefix => New_Value (Param), + Selector_Name => + New_Occurrence_Of + (First_Tag_Component (Typ), Loc)), + + Right_Opnd => + Make_Selected_Component (Loc, + Prefix => + Unchecked_Convert_To (Typ, + New_Value (Next_Actual (Param))), + Selector_Name => + New_Occurrence_Of + (First_Tag_Component (Typ), Loc))), + Right_Opnd => Prev_Call); - Right_Opnd => - Make_Selected_Component (Loc, - Prefix => - Unchecked_Convert_To (Typ, - New_Value (Next_Actual (Param))), - Selector_Name => - New_Occurrence_Of - (First_Tag_Component (Typ), Loc))), - Right_Opnd => Prev_Call); - - Rewrite (Call_Node, New_Call); - - Analyze_And_Resolve - (Call_Node, Call_Typ, Suppress => All_Checks); - end if; + Rewrite (Call_Node, New_Call); + Analyze_And_Resolve + (Call_Node, Call_Typ, Suppress => All_Checks); + end if; - -- 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. + -- 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; + Kill_Current_Values; -- If this is a dispatching "=" then we must update the reference -- to the call node because we generated: -- 2.7.4