From bdbb2a405541671bb427f6ff2f463a98c62b0a46 Mon Sep 17 00:00:00 2001 From: Ed Schonberg Date: Thu, 4 Jul 2019 08:06:35 +0000 Subject: [PATCH] [Ada] Bug in composition of equality for variant records This patch fixes an omission in the construction of equality routines for variant records, to take into account user-defined equality functions for components of the record. Previously the constructed equality routine for variant records used the predefined equality for all components, When composavility of equality was introduced for untagged records, expansion of record equality was modified properly, but not for the case of variant records, which use a different and more complex process to build the equality function. 2019-07-04 Ed Schonberg gcc/ada/ * exp_ch4.ads, exp_ch4.adb (Build_Eq_Call): New visible subprogram, extracted from Expand_Composite_Equality, to handle properly the composition of equality for variant record types. * exp_ch3.adb (MAke_Eq_If): Use Build_Eq_Call for each component, to handle properly the case of a component with a user-defined equality. Revert to predefined equality if the user-defined operation is abstract, to maintain compatibility with older versions, gcc/testsuite/ * gnat.dg/equal6.adb, gnat.dg/equal6_types.adb, gnat.dg/equal6_types.ads: New testcase. From-SVN: r273062 --- gcc/ada/ChangeLog | 11 ++++ gcc/ada/exp_ch3.adb | 63 ++++++++++++++++++---- gcc/ada/exp_ch4.adb | 96 +++++++++++++++++----------------- gcc/ada/exp_ch4.ads | 14 +++++ gcc/testsuite/ChangeLog | 5 ++ gcc/testsuite/gnat.dg/equal6.adb | 29 ++++++++++ gcc/testsuite/gnat.dg/equal6_types.adb | 15 ++++++ gcc/testsuite/gnat.dg/equal6_types.ads | 49 +++++++++++++++++ 8 files changed, 223 insertions(+), 59 deletions(-) create mode 100644 gcc/testsuite/gnat.dg/equal6.adb create mode 100644 gcc/testsuite/gnat.dg/equal6_types.adb create mode 100644 gcc/testsuite/gnat.dg/equal6_types.ads diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index b5e9bd6..1d6d8c0 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,14 @@ +2019-07-04 Ed Schonberg + + * exp_ch4.ads, exp_ch4.adb (Build_Eq_Call): New visible + subprogram, extracted from Expand_Composite_Equality, to handle + properly the composition of equality for variant record types. + * exp_ch3.adb (MAke_Eq_If): Use Build_Eq_Call for each + component, to handle properly the case of a component with a + user-defined equality. Revert to predefined equality if the + user-defined operation is abstract, to maintain compatibility + with older versions, + 2019-07-04 Justin Squirek * exp_ch3.adb (Build_Initialization_Call): Fixup diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index 49fcfd7..6308b42 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -9477,6 +9477,11 @@ package body Exp_Ch3 is -- or a null statement if the list L is empty + -- Equality may be user-defined for a given component type, in which case + -- a function call is constructed instead of an operator node. This is an + -- Ada 2012 change in the composability of equality for untagged composite + -- types. + function Make_Eq_If (E : Entity_Id; L : List_Id) return Node_Id @@ -9485,6 +9490,8 @@ package body Exp_Ch3 is C : Node_Id; Field_Name : Name_Id; Cond : Node_Id; + Next_Test : Node_Id; + Typ : Entity_Id; begin if No (L) then @@ -9495,6 +9502,7 @@ package body Exp_Ch3 is C := First_Non_Pragma (L); while Present (C) loop + Typ := Etype (Defining_Identifier (C)); Field_Name := Chars (Defining_Identifier (C)); -- The tags must not be compared: they are not part of the value. @@ -9507,22 +9515,55 @@ package body Exp_Ch3 is -- discriminants could be picked up in the private type case. if Field_Name = Name_uParent - and then Is_Interface (Etype (Defining_Identifier (C))) + and then Is_Interface (Typ) then null; elsif Field_Name /= Name_uTag then - Evolve_Or_Else (Cond, - Make_Op_Ne (Loc, - Left_Opnd => - Make_Selected_Component (Loc, - Prefix => Make_Identifier (Loc, Name_X), - Selector_Name => Make_Identifier (Loc, Field_Name)), + declare + Lhs : constant Node_Id := + Make_Selected_Component (Loc, + Prefix => Make_Identifier (Loc, Name_X), + Selector_Name => Make_Identifier (Loc, Field_Name)); - Right_Opnd => - Make_Selected_Component (Loc, - Prefix => Make_Identifier (Loc, Name_Y), - Selector_Name => Make_Identifier (Loc, Field_Name)))); + Rhs : constant Node_Id := + Make_Selected_Component (Loc, + Prefix => Make_Identifier (Loc, Name_Y), + Selector_Name => Make_Identifier (Loc, Field_Name)); + Eq_Call : Node_Id; + + begin + -- Build equality code with a user-defined operator, if + -- available, and with the predefined "=" otherwise. + -- For compatibility with older Ada versions, and preserve + -- the workings of some ASIS tools, we also use the + -- predefined operation if the component-type equality + -- is abstract, rather than raising Program_Error. + + if Ada_Version < Ada_2012 then + Next_Test := Make_Op_Ne (Loc, Lhs, Rhs); + + else + Eq_Call := Build_Eq_Call (Typ, Loc, Lhs, Rhs); + + if No (Eq_Call) then + Next_Test := Make_Op_Ne (Loc, Lhs, Rhs); + + -- If a component has a defined abstract equality, + -- its application raises Program_Error on that + -- component and therefore on the current variant. + + elsif Nkind (Eq_Call) = N_Raise_Program_Error then + Set_Etype (Eq_Call, Standard_Boolean); + Next_Test := Make_Op_Not (Loc, Eq_Call); + + else + Next_Test := Make_Op_Not (Loc, Eq_Call); + end if; + end if; + end; + + Evolve_Or_Else (Cond, Next_Test); end if; Next_Non_Pragma (C); diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index 7a757e4..cacc9d4 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -2338,52 +2338,6 @@ package body Exp_Ch4 is Full_Type : Entity_Id; Eq_Op : Entity_Id; - function Find_Primitive_Eq return Node_Id; - -- AI05-0123: Locate primitive equality for type if it exists, and - -- build the corresponding call. If operation is abstract, replace - -- call with an explicit raise. Return Empty if there is no primitive. - - ----------------------- - -- Find_Primitive_Eq -- - ----------------------- - - function Find_Primitive_Eq return Node_Id is - Prim_E : Elmt_Id; - Prim : Node_Id; - - begin - Prim_E := First_Elmt (Collect_Primitive_Operations (Typ)); - while Present (Prim_E) loop - Prim := Node (Prim_E); - - -- Locate primitive equality with the right signature - - if Chars (Prim) = Name_Op_Eq - and then Etype (First_Formal (Prim)) = - Etype (Next_Formal (First_Formal (Prim))) - and then Etype (Prim) = Standard_Boolean - then - if Is_Abstract_Subprogram (Prim) then - return - Make_Raise_Program_Error (Loc, - Reason => PE_Explicit_Raise); - - else - return - Make_Function_Call (Loc, - Name => New_Occurrence_Of (Prim, Loc), - Parameter_Associations => New_List (Lhs, Rhs)); - end if; - end if; - - Next_Elmt (Prim_E); - end loop; - - -- If not found, predefined operation will be used - - return Empty; - end Find_Primitive_Eq; - -- Start of processing for Expand_Composite_Equality begin @@ -2654,7 +2608,7 @@ package body Exp_Ch4 is -- a primitive equality declared for it. declare - Op : constant Node_Id := Find_Primitive_Eq; + Op : constant Node_Id := Build_Eq_Call (Typ, Loc, Lhs, Rhs); begin -- Use user-defined primitive if it exists, otherwise use @@ -12599,7 +12553,53 @@ package body Exp_Ch4 is Adjust_Result_Type (N, Typ); end Expand_Short_Circuit_Operator; - ------------------------------------- + ----------------------- + -- Build_Eq_Call -- + ----------------------- + + function Build_Eq_Call + (Typ : Entity_Id; + Loc : Source_Ptr; + Lhs : Node_Id; + Rhs : Node_Id) return Node_Id + is + Prim_E : Elmt_Id; + Prim : Node_Id; + + begin + Prim_E := First_Elmt (Collect_Primitive_Operations (Typ)); + while Present (Prim_E) loop + Prim := Node (Prim_E); + + -- Locate primitive equality with the right signature + + if Chars (Prim) = Name_Op_Eq + and then Etype (First_Formal (Prim)) = + Etype (Next_Formal (First_Formal (Prim))) + and then Etype (Prim) = Standard_Boolean + then + if Is_Abstract_Subprogram (Prim) then + return + Make_Raise_Program_Error (Loc, + Reason => PE_Explicit_Raise); + + else + return + Make_Function_Call (Loc, + Name => New_Occurrence_Of (Prim, Loc), + Parameter_Associations => New_List (Lhs, Rhs)); + end if; + end if; + + Next_Elmt (Prim_E); + end loop; + + -- If not found, predefined operation will be used + + return Empty; + end Build_Eq_Call; + + ------------------------------------ -- Fixup_Universal_Fixed_Operation -- ------------------------------------- diff --git a/gcc/ada/exp_ch4.ads b/gcc/ada/exp_ch4.ads index 5ff9fc4..f2deaae 100644 --- a/gcc/ada/exp_ch4.ads +++ b/gcc/ada/exp_ch4.ads @@ -29,6 +29,20 @@ with Types; use Types; package Exp_Ch4 is + function Build_Eq_Call + (Typ : Entity_Id; + Loc : Source_Ptr; + Lhs : Node_Id; + Rhs : Node_Id) return Node_Id; + -- AI05-0123: Locate primitive equality for type if it exists, and build + -- the corresponding call. If operation is abstract, replace call with + -- an explicit raise. Return Empty if there is no primitive. + -- Used in the construction of record-equality routines for records here + -- and for variant records in exp_ch3.adb. These two paths are distinct + -- for historical but also technical reasons: for variant records the + -- constructed function includes a case statement with nested returns, + -- while for records without variants only a simple expression is needed. + procedure Expand_N_Allocator (N : Node_Id); procedure Expand_N_And_Then (N : Node_Id); procedure Expand_N_Case_Expression (N : Node_Id); diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index c4b0046..996a0ec 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2019-07-04 Ed Schonberg + + * gnat.dg/equal6.adb, gnat.dg/equal6_types.adb, + gnat.dg/equal6_types.ads: New testcase. + 2019-07-04 Justin Squirek * gnat.dg/allocator.adb: New testcase. diff --git a/gcc/testsuite/gnat.dg/equal6.adb b/gcc/testsuite/gnat.dg/equal6.adb new file mode 100644 index 0000000..dea772f --- /dev/null +++ b/gcc/testsuite/gnat.dg/equal6.adb @@ -0,0 +1,29 @@ +-- { dg-do run } +with Text_IO; +with Equal6_Types; use Equal6_Types; + +procedure Equal6 is + Packets_In : To_Evc_Optional_Packet_List_T; + Packets_Out : To_Evc_Optional_Packet_List_T; +begin + Packets_In.list (1) := + (Data_Used_Outside_Ertms_System => + (Mail_Box => + (Receiver => 31, + Data => (Length => 12, Message => (0, others => 0))))); + + Packets_Out.list (1) := + (Data_Used_Outside_Ertms_System => + (Mail_Box => + (Receiver => 31, + Data => (Length => 12, Message => (0, others => 1))))); + + if not (Packets_In = Packets_Out) then + raise Program_Error; + end if; + + if not (Equal1_Called and then Equal2_Called) then + raise Program_Error; + end if; + +end Equal6; diff --git a/gcc/testsuite/gnat.dg/equal6_types.adb b/gcc/testsuite/gnat.dg/equal6_types.adb new file mode 100644 index 0000000..7105b07 --- /dev/null +++ b/gcc/testsuite/gnat.dg/equal6_types.adb @@ -0,0 +1,15 @@ +package body Equal6_Types is + + function "=" (L, R : in Mail_Box_Data_T) return Boolean is + use type Bits_T; + begin + Equal1_Called := True; + return L.Message (1) = R.Message (1); + end "="; + + function "=" (L, R : in To_Evc_Optional_Packet_List_T) return Boolean is + begin + Equal2_Called := True; + return L.List (1) = R.List (1); + end "="; +end Equal6_Types; diff --git a/gcc/testsuite/gnat.dg/equal6_types.ads b/gcc/testsuite/gnat.dg/equal6_types.ads new file mode 100644 index 0000000..90ec52b --- /dev/null +++ b/gcc/testsuite/gnat.dg/equal6_types.ads @@ -0,0 +1,49 @@ +package Equal6_Types is + type Bit_T is range 0 .. 1; + + type Bits_T is array (Positive range <>) of Bit_T; + + type Nid_Xuser_T is range 0 .. 511; + + Dispatch_P44_To_Ntc_C : constant Nid_Xuser_T := 102; + + type Mail_Box_Data_T is record + Length : Natural; + Message : Bits_T (1 .. 200); + end record; + function "=" (L, R : in Mail_Box_Data_T) return Boolean; + Equal1_Called : Boolean := False; + + type Mail_Box_T (Receiver : Nid_Xuser_T := Nid_Xuser_T'First) is record + Data : Mail_Box_Data_T; + case Receiver is + when Dispatch_P44_To_Ntc_C => + Stm_Id : Positive; + when others => + null; + end case; + end record; + + type Data_Used_Outside_Ertms_System_T is record + Mail_Box : Mail_Box_T; + end record; + + type To_Evc_Optional_Packet_T + is record + Data_Used_Outside_Ertms_System : Data_Used_Outside_Ertms_System_T; + end record; + + type To_Evc_Optional_Packet_List_Length_T is range 0 .. 50; + type To_Evc_Optional_Packet_Map_T is + array + (To_Evc_Optional_Packet_List_Length_T range <>) + of To_Evc_Optional_Packet_T; + + type To_Evc_Optional_Packet_List_T is record + List : To_Evc_Optional_Packet_Map_T + (1 .. To_Evc_Optional_Packet_List_Length_T'Last); + end record; + function "=" (L, R : in To_Evc_Optional_Packet_List_T) return Boolean; + Equal2_Called : Boolean := False; + +end Equal6_Types; -- 2.7.4