From fa1608c29d80bfc90a408ff0ac02c0aeda046dcb Mon Sep 17 00:00:00 2001 From: Ed Schonberg Date: Fri, 5 Jul 2013 10:50:49 +0000 Subject: [PATCH] exp_ch3.adb (Build_Variant_Record_Equality): Add pairs of formals for each discriminant of an unchecked union. 2013-07-05 Ed Schonberg * exp_ch3.adb (Build_Variant_Record_Equality): Add pairs of formals for each discriminant of an unchecked union. (Make_Eq_Case): Suprogram accepts a list of discriminants. Nested variants are supported. New helper function Corresponding_Formal. * exp_ch4.adb (Build_Equality_Call): For unchecked unions, loop through discriminants to create list of inferred values, and modify call to equality routine accordingly. From-SVN: r200709 --- gcc/ada/ChangeLog | 10 +++ gcc/ada/exp_ch3.adb | 158 +++++++++++++++++++++++++++------------ gcc/ada/exp_ch4.adb | 178 ++++++++++++++++++++++++++++++-------------- 3 files changed, 241 insertions(+), 105 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 1c3bbabfc00f..24b3fd28fed7 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,13 @@ +2013-07-05 Ed Schonberg + + * exp_ch3.adb (Build_Variant_Record_Equality): Add pairs of + formals for each discriminant of an unchecked union. + (Make_Eq_Case): Suprogram accepts a list of discriminants. Nested + variants are supported. New helper function Corresponding_Formal. + * exp_ch4.adb (Build_Equality_Call): For unchecked unions, + loop through discriminants to create list of inferred values, + and modify call to equality routine accordingly. + 2013-07-05 Claire Dross * a-cfdlli.ads, a-cfhama.ads, a-cfhase.ads, a-cforma.ads, diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index 1e500367625f..4491d30aa9a3 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -237,16 +237,19 @@ package body Exp_Ch3 is -- user-defined equality. Factored out of Predefined_Primitive_Bodies. function Make_Eq_Case - (E : Entity_Id; - CL : Node_Id; - Discr : Entity_Id := Empty) return List_Id; + (E : Entity_Id; + CL : Node_Id; + Discrs : Elist_Id := New_Elmt_List) return List_Id; -- Building block for variant record equality. Defined to share the code -- between the tagged and non-tagged case. Given a Component_List node CL, -- it generates an 'if' followed by a 'case' statement that compares all -- components of local temporaries named X and Y (that are declared as -- formals at some upper level). E provides the Sloc to be used for the - -- generated code. Discr is used as the case statement switch in the case - -- of Unchecked_Union equality. + -- generated code. + -- + -- IF E is an unchecked_union, Discrs is the list of formals created for + -- the inferred discriminants of one operand. These formals are used in + -- the generated case statements for each variant of the unchecked union. function Make_Eq_If (E : Entity_Id; @@ -4335,8 +4338,7 @@ package body Exp_Ch3 is Result_Definition => New_Reference_To (Standard_Boolean, Loc)), Declarations => New_List, Handled_Statement_Sequence => - Make_Handled_Sequence_Of_Statements (Loc, - Statements => Stmts))); + Make_Handled_Sequence_Of_Statements (Loc, Statements => Stmts))); Append_To (Pspecs, Make_Parameter_Specification (Loc, @@ -4350,57 +4352,71 @@ package body Exp_Ch3 is -- Unchecked_Unions require additional machinery to support equality. -- Two extra parameters (A and B) are added to the equality function - -- parameter list in order to capture the inferred values of the - -- discriminants in later calls. + -- parameter list for each discriminant of the type, in order to + -- capture the inferred values of the discriminants in equality calls. + -- The names of the parameters match the names of the corresponding + -- discriminant, with an added suffix. if Is_Unchecked_Union (Typ) then declare - Discr_Type : constant Node_Id := Etype (First_Discriminant (Typ)); + Discr : Entity_Id; + Discr_Type : Entity_Id; + A, B : Entity_Id; + New_Discrs : Elist_Id; - A : constant Node_Id := - Make_Defining_Identifier (Loc, - Chars => Name_A); + begin + New_Discrs := New_Elmt_List; - B : constant Node_Id := - Make_Defining_Identifier (Loc, - Chars => Name_B); + Discr := First_Discriminant (Typ); + while Present (Discr) loop + Discr_Type := Etype (Discr); + A := Make_Defining_Identifier (Loc, + Chars => New_External_Name (Chars (Discr), 'A')); - begin - -- Add A and B to the parameter list + B := Make_Defining_Identifier (Loc, + Chars => New_External_Name (Chars (Discr), 'B')); - Append_To (Pspecs, - Make_Parameter_Specification (Loc, - Defining_Identifier => A, - Parameter_Type => New_Reference_To (Discr_Type, Loc))); + -- Add new parameters to the parameter list - Append_To (Pspecs, - Make_Parameter_Specification (Loc, - Defining_Identifier => B, - Parameter_Type => New_Reference_To (Discr_Type, Loc))); + Append_To (Pspecs, + Make_Parameter_Specification (Loc, + Defining_Identifier => A, + Parameter_Type => New_Reference_To (Discr_Type, Loc))); - -- Generate the following header code to compare the inferred - -- discriminants: + Append_To (Pspecs, + Make_Parameter_Specification (Loc, + Defining_Identifier => B, + Parameter_Type => New_Reference_To (Discr_Type, Loc))); - -- if a /= b then - -- return False; - -- end if; + Append_Elmt (A, New_Discrs); - Append_To (Stmts, - Make_If_Statement (Loc, - Condition => - Make_Op_Ne (Loc, - Left_Opnd => New_Reference_To (A, Loc), - Right_Opnd => New_Reference_To (B, Loc)), - Then_Statements => New_List ( - Make_Simple_Return_Statement (Loc, - Expression => New_Occurrence_Of (Standard_False, Loc))))); + -- Generate the following code to compare each of the inferred + -- discriminants: + + -- if a /= b then + -- return False; + -- end if; + + Append_To (Stmts, + Make_If_Statement (Loc, + Condition => + Make_Op_Ne (Loc, + Left_Opnd => New_Reference_To (A, Loc), + Right_Opnd => New_Reference_To (B, Loc)), + Then_Statements => New_List ( + Make_Simple_Return_Statement (Loc, + Expression => + New_Occurrence_Of (Standard_False, Loc))))); + Next_Discriminant (Discr); + end loop; -- Generate component-by-component comparison. Note that we must - -- propagate one of the inferred discriminant formals to act as - -- the case statement switch. + -- propagate the inferred discriminants formals to act as + -- the case statement switch. Their value is added when an + -- equality call on unchecked unions is expanded. Append_List_To (Stmts, - Make_Eq_Case (Typ, Comps, A)); + Make_Eq_Case (Typ, Comps, New_Discrs)); end; -- Normal case (not unchecked union) @@ -8578,13 +8594,56 @@ package body Exp_Ch3 is function Make_Eq_Case (E : Entity_Id; CL : Node_Id; - Discr : Entity_Id := Empty) return List_Id + Discrs : Elist_Id := New_Elmt_List) return List_Id is Loc : constant Source_Ptr := Sloc (E); Result : constant List_Id := New_List; Variant : Node_Id; Alt_List : List_Id; + function Corresponding_Formal (C : Node_Id) return Entity_Id; + -- Given the discriminant that controls a given variant of an unchecked + -- union, find the formal of the equality function that carries the + -- inferred value of the discriminant. + + function External_Name (E : Entity_Id) return Name_Id; + -- The value of a given discriminant is conveyed in the corresponding + -- formal parameter of the equality routine. The name of this formal + -- parameter carries a one-character suffix which is removed here. + + -------------------------- + -- Corresponding_Formal -- + -------------------------- + + function Corresponding_Formal (C : Node_Id) return Entity_Id is + Discr : constant Entity_Id := Entity (Name (Variant_Part (C))); + Elm : Elmt_Id; + + begin + Elm := First_Elmt (Discrs); + while Present (Elm) loop + if Chars (Discr) = External_Name (Node (Elm)) then + return Node (Elm); + end if; + Next_Elmt (Elm); + end loop; + + -- A formal of the proper name must be found + + raise Program_Error; + end Corresponding_Formal; + + ------------------- + -- External_Name -- + ------------------- + + function External_Name (E : Entity_Id) return Name_Id is + begin + Get_Name_String (Chars (E)); + Name_Len := Name_Len - 1; + return Name_Find; + end External_Name; + begin Append_To (Result, Make_Eq_If (E, Component_Items (CL))); @@ -8604,18 +8663,21 @@ package body Exp_Ch3 is Append_To (Alt_List, Make_Case_Statement_Alternative (Loc, Discrete_Choices => New_Copy_List (Discrete_Choices (Variant)), - Statements => Make_Eq_Case (E, Component_List (Variant)))); + Statements => + Make_Eq_Case (E, Component_List (Variant), Discrs))); Next_Non_Pragma (Variant); end loop; - -- If we have an Unchecked_Union, use one of the parameters that - -- captures the discriminants. + -- If we have an Unchecked_Union, use one of the parameters of the + -- enclosing equality routine that captures the discriminant, to use + -- as the expression in the generated case statement. if Is_Unchecked_Union (E) then Append_To (Result, Make_Case_Statement (Loc, - Expression => New_Reference_To (Discr, Loc), + Expression => + New_Reference_To (Corresponding_Formal (CL), Loc), Alternatives => Alt_List)); else diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index f4abc654d078..9b0fc02748aa 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -6939,17 +6939,26 @@ package body Exp_Ch4 is if Is_Unchecked_Union (Op_Type) then declare - Lhs_Type : constant Node_Id := Etype (L_Exp); - Rhs_Type : constant Node_Id := Etype (R_Exp); - Lhs_Discr_Val : Node_Id; - Rhs_Discr_Val : Node_Id; + Lhs_Type : constant Node_Id := Etype (L_Exp); + Rhs_Type : constant Node_Id := Etype (R_Exp); + + Lhs_Discr_Vals : Elist_Id; + -- List of inferred discriminant values for left operand. + + Rhs_Discr_Vals : Elist_Id; + -- List of inferred discriminant values for right operand. + + Discr : Entity_Id; begin + Lhs_Discr_Vals := New_Elmt_List; + Rhs_Discr_Vals := New_Elmt_List; + -- Per-object constrained selected components require special -- attention. If the enclosing scope of the component is an -- Unchecked_Union, we cannot reference its discriminants - -- directly. This is why we use the two extra parameters of - -- the equality function of the enclosing Unchecked_Union. + -- directly. This is why we use the extra parameters of the + -- equality function of the enclosing Unchecked_Union. -- type UU_Type (Discr : Integer := 0) is -- . . . @@ -6976,7 +6985,8 @@ package body Exp_Ch4 is -- A and B are the formal parameters of the equality function -- of Enclosing_UU_Type. The function always has two extra - -- formals to capture the inferred discriminant values. + -- formals to capture the inferred discriminant values for + -- each discriminant of the type. -- 2. Non-Unchecked_Union enclosing record: @@ -7001,86 +7011,140 @@ package body Exp_Ch4 is -- In this case we can directly reference the discriminants of -- the enclosing record. - -- Lhs of equality + -- Process left operand of equality if Nkind (Lhs) = N_Selected_Component and then Has_Per_Object_Constraint (Entity (Selector_Name (Lhs))) then - -- Enclosing record is an Unchecked_Union, use formal A + -- If enclosing record is an Unchecked_Union, use formals + -- corresponding to each discriminant. The name of the + -- formal is that of the discriminant, with added suffix, + -- see Exp_Ch3.Build_Record_Equality for details. if Is_Unchecked_Union (Scope (Entity (Selector_Name (Lhs)))) then - Lhs_Discr_Val := Make_Identifier (Loc, Name_A); + Discr := + First_Discriminant + (Scope (Entity (Selector_Name (Lhs)))); + while Present (Discr) loop + Append_Elmt ( + Make_Identifier (Loc, + Chars => New_External_Name (Chars (Discr), 'A')), + To => Lhs_Discr_Vals); + Next_Discriminant (Discr); + end loop; - -- Enclosing record is of a non-Unchecked_Union type, it is - -- possible to reference the discriminant. + -- If enclosing record is of a non-Unchecked_Union type, it + -- is possible to reference its discriminants directly. else - Lhs_Discr_Val := - Make_Selected_Component (Loc, - Prefix => Prefix (Lhs), - Selector_Name => - New_Copy - (Get_Discriminant_Value - (First_Discriminant (Lhs_Type), - Lhs_Type, - Stored_Constraint (Lhs_Type)))); + Discr := First_Discriminant (Lhs_Type); + while Present (Discr) loop + Append_Elmt ( + Make_Selected_Component (Loc, + Prefix => Prefix (Lhs), + Selector_Name => + New_Copy + (Get_Discriminant_Value (Discr, + Lhs_Type, + Stored_Constraint (Lhs_Type)))), + To => Lhs_Discr_Vals); + Next_Discriminant (Discr); + end loop; end if; - -- Comment needed here ??? + -- Otherwise operand is on object with a constrained type. + -- Infer the discriminant values from the constraint. else - -- Infer the discriminant value - - Lhs_Discr_Val := - New_Copy - (Get_Discriminant_Value - (First_Discriminant (Lhs_Type), - Lhs_Type, - Stored_Constraint (Lhs_Type))); + + Discr := First_Discriminant (Lhs_Type); + while Present (Discr) loop + Append_Elmt ( + New_Copy + (Get_Discriminant_Value (Discr, + Lhs_Type, + Stored_Constraint (Lhs_Type))), + To => Lhs_Discr_Vals); + Next_Discriminant (Discr); + end loop; end if; - -- Rhs of equality + -- Similar processing for right operand of equality if Nkind (Rhs) = N_Selected_Component and then Has_Per_Object_Constraint (Entity (Selector_Name (Rhs))) then if Is_Unchecked_Union - (Scope (Entity (Selector_Name (Rhs)))) + (Scope (Entity (Selector_Name (Rhs)))) then - Rhs_Discr_Val := Make_Identifier (Loc, Name_B); + Discr := + First_Discriminant + (Scope (Entity (Selector_Name (Rhs)))); + while Present (Discr) loop + Append_Elmt ( + Make_Identifier (Loc, + Chars => New_External_Name (Chars (Discr), 'B')), + To => Rhs_Discr_Vals); + Next_Discriminant (Discr); + end loop; else - Rhs_Discr_Val := - Make_Selected_Component (Loc, - Prefix => Prefix (Rhs), - Selector_Name => - New_Copy (Get_Discriminant_Value ( - First_Discriminant (Rhs_Type), - Rhs_Type, - Stored_Constraint (Rhs_Type)))); - + Discr := First_Discriminant (Rhs_Type); + while Present (Discr) loop + Append_Elmt ( + Make_Selected_Component (Loc, + Prefix => Prefix (Rhs), + Selector_Name => + New_Copy (Get_Discriminant_Value + (Discr, + Rhs_Type, + Stored_Constraint (Rhs_Type)))), + To => Rhs_Discr_Vals); + Next_Discriminant (Discr); + end loop; end if; - else - Rhs_Discr_Val := - New_Copy (Get_Discriminant_Value ( - First_Discriminant (Rhs_Type), - Rhs_Type, - Stored_Constraint (Rhs_Type))); + else + Discr := First_Discriminant (Rhs_Type); + while Present (Discr) loop + Append_Elmt ( + New_Copy (Get_Discriminant_Value + (Discr, + Rhs_Type, + Stored_Constraint (Rhs_Type))), + To => Rhs_Discr_Vals); + Next_Discriminant (Discr); + end loop; end if; - Rewrite (N, - Make_Function_Call (Loc, - Name => New_Reference_To (Eq, Loc), - Parameter_Associations => New_List ( - L_Exp, - R_Exp, - Lhs_Discr_Val, - Rhs_Discr_Val))); + -- Now merge the list of discriminant values so that values + -- of corresponding discriminants are adjacent. + + declare + Params : List_Id; + L_Elmt : Elmt_Id; + R_Elmt : Elmt_Id; + + begin + Params := New_List (L_Exp, R_Exp); + L_Elmt := First_Elmt (Lhs_Discr_Vals); + R_Elmt := First_Elmt (Rhs_Discr_Vals); + while Present (L_Elmt) loop + Append_To (Params, Node (L_Elmt)); + Append_To (Params, Node (R_Elmt)); + Next_Elmt (L_Elmt); + Next_Elmt (R_Elmt); + end loop; + + Rewrite (N, + Make_Function_Call (Loc, + Name => New_Reference_To (Eq, Loc), + Parameter_Associations => Params)); + end; end; -- Normal case, not an unchecked union @@ -7088,7 +7152,7 @@ package body Exp_Ch4 is else Rewrite (N, Make_Function_Call (Loc, - Name => New_Reference_To (Eq, Loc), + Name => New_Reference_To (Eq, Loc), Parameter_Associations => New_List (L_Exp, R_Exp))); end if; -- 2.47.2