From: Hristian Kirtchev Date: Wed, 14 Nov 2018 11:40:41 +0000 (+0000) Subject: [Ada] Crash on tagged equality X-Git-Tag: basepoints/gcc-10~3068 X-Git-Url: http://git.ipfire.org/cgi-bin/gitweb.cgi?a=commitdiff_plain;h=e1a20c09aac4149f3099cfc313bbfcd6672064bc;p=thirdparty%2Fgcc.git [Ada] Crash on tagged equality This patch corrects the retrieval of the equality function when it is inherited from a parent tagged type. 2018-11-14 Hristian Kirtchev gcc/ada/ * exp_ch4.adb (Expand_N_Op_Eq): Remove duplicated code and use routine Find_Equality instead. (Find_Equality): New routine. gcc/testsuite/ * gnat.dg/equal4.adb, gnat.dg/equal4.ads, gnat.dg/equal4_controlled_filter.ads, gnat.dg/equal4_full_selector_filter.ads, gnat.dg/equal4_smart_pointers.ads: New testcase. From-SVN: r266114 --- diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index b1531d1c9282..cea73e9451f0 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,9 @@ +2018-11-14 Hristian Kirtchev + + * exp_ch4.adb (Expand_N_Op_Eq): Remove duplicated code and use + routine Find_Equality instead. + (Find_Equality): New routine. + 2018-11-14 Piotr Trojanek * sem_util.adb (First_From_Global_List): Do not expect diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index 98c1d3175340..079d64544a87 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -7298,16 +7298,16 @@ package body Exp_Ch4 is Bodies : constant List_Id := New_List; A_Typ : constant Entity_Id := Etype (Lhs); - Typl : Entity_Id := A_Typ; - Op_Name : Entity_Id; - Prim : Elmt_Id; - procedure Build_Equality_Call (Eq : Entity_Id); -- If a constructed equality exists for the type or for its parent, -- build and analyze call, adding conversions if the operation is -- inherited. - function Has_Unconstrained_UU_Component (Typ : Node_Id) return Boolean; + function Find_Equality (Prims : Elist_Id) return Entity_Id; + -- Find a primitive equality function within primitive operation list + -- Prims. + + function Has_Unconstrained_UU_Component (Typ : Entity_Id) return Boolean; -- Determines whether a type has a subcomponent of an unconstrained -- Unchecked_Union subtype. Typ is a record type. @@ -7456,7 +7456,6 @@ package body Exp_Ch4 is -- Infer the discriminant values from the constraint. else - Discr := First_Discriminant (Lhs_Type); while Present (Discr) loop Append_Elmt @@ -7556,12 +7555,70 @@ package body Exp_Ch4 is Analyze_And_Resolve (N, Standard_Boolean, Suppress => All_Checks); end Build_Equality_Call; + ------------------- + -- Find_Equality -- + ------------------- + + function Find_Equality (Prims : Elist_Id) return Entity_Id is + Formal_1 : Entity_Id; + Formal_2 : Entity_Id; + Prim : Entity_Id; + Prim_Elmt : Elmt_Id; + + begin + -- Assume that the tagged type lacks an equality + + Prim := Empty; + + -- Inspect the list of primitives looking for a suitable equality + + Prim_Elmt := First_Elmt (Prims); + while Present (Prim_Elmt) loop + + -- Traverse a potential chain of derivations to recover the parent + -- equality. + + Prim := Ultimate_Alias (Node (Prim_Elmt)); + + -- The current primitives denotes function "=" that returns a + -- Boolean. This could be the suitable equality if the formal + -- parameters agree. + + if Ekind (Prim) = E_Function + and then Chars (Prim) = Name_Op_Eq + and then Base_Type (Etype (Prim)) = Standard_Boolean + then + Formal_1 := First_Formal (Prim); + Formal_2 := Empty; + + if Present (Formal_1) then + Formal_2 := Next_Formal (Formal_1); + end if; + + if Present (Formal_1) + and then Present (Formal_2) + and then Etype (Formal_1) = Etype (Formal_2) + then + exit; + end if; + end if; + + Next_Elmt (Prim_Elmt); + end loop; + + -- A tagged type should have an equality in its list of primitives + + pragma Assert (Present (Prim)); + + return Prim; + end Find_Equality; + ------------------------------------ -- Has_Unconstrained_UU_Component -- ------------------------------------ function Has_Unconstrained_UU_Component - (Typ : Node_Id) return Boolean + (Typ : Entity_Id) return Boolean is Tdef : constant Node_Id := Type_Definition (Declaration_Node (Base_Type (Typ))); @@ -7697,6 +7754,10 @@ package body Exp_Ch4 is return False; end Has_Unconstrained_UU_Component; + -- Local variables + + Typl : Entity_Id; + -- Start of processing for Expand_N_Op_Eq begin @@ -7704,12 +7765,13 @@ package body Exp_Ch4 is -- Deal with private types + Typl := A_Typ; + if Ekind (Typl) = E_Private_Type then Typl := Underlying_Type (Typl); + elsif Ekind (Typl) = E_Private_Subtype then Typl := Underlying_Type (Base_Type (Typl)); - else - null; end if; -- It may happen in error situations that the underlying type is not @@ -7851,25 +7913,8 @@ package body Exp_Ch4 is -- primitive may have been overridden in its untagged full view). if Inherits_From_Tagged_Full_View (A_Typ) then - - -- Search for equality operation, checking that the operands - -- have the same type. Note that we must find a matching entry, - -- or something is very wrong. - - Prim := First_Elmt (Collect_Primitive_Operations (A_Typ)); - - while Present (Prim) loop - exit when Chars (Node (Prim)) = Name_Op_Eq - and then Etype (First_Formal (Node (Prim))) = - Etype (Next_Formal (First_Formal (Node (Prim)))) - and then - Base_Type (Etype (Node (Prim))) = Standard_Boolean; - - Next_Elmt (Prim); - end loop; - - pragma Assert (Present (Prim)); - Op_Name := Node (Prim); + Build_Equality_Call + (Find_Equality (Collect_Primitive_Operations (A_Typ))); -- Find the type's predefined equality or an overriding -- user-defined equality. The reason for not simply calling @@ -7883,23 +7928,10 @@ package body Exp_Ch4 is Typl := Find_Specific_Type (Typl); end if; - Prim := First_Elmt (Primitive_Operations (Typl)); - while Present (Prim) loop - exit when Chars (Node (Prim)) = Name_Op_Eq - and then Etype (First_Formal (Node (Prim))) = - Etype (Next_Formal (First_Formal (Node (Prim)))) - and then - Base_Type (Etype (Node (Prim))) = Standard_Boolean; - - Next_Elmt (Prim); - end loop; - - pragma Assert (Present (Prim)); - Op_Name := Node (Prim); + Build_Equality_Call + (Find_Equality (Primitive_Operations (Typl))); end if; - Build_Equality_Call (Op_Name); - -- Ada 2005 (AI-216): Program_Error is raised when evaluating the -- predefined equality operator for a type which has a subcomponent -- of an Unchecked_Union type whose nominal subtype is unconstrained. @@ -7967,22 +7999,9 @@ package body Exp_Ch4 is -- the root Super_String type. elsif Is_Bounded_String (Typl) then - Prim := - First_Elmt (Collect_Primitive_Operations (Root_Type (Typl))); - - while Present (Prim) loop - exit when Chars (Node (Prim)) = Name_Op_Eq - and then Etype (First_Formal (Node (Prim))) = - Etype (Next_Formal (First_Formal (Node (Prim)))) - and then Base_Type (Etype (Node (Prim))) = Standard_Boolean; - - Next_Elmt (Prim); - end loop; - - -- A Super_String type should always have a primitive equality - - pragma Assert (Present (Prim)); - Build_Equality_Call (Node (Prim)); + Build_Equality_Call + (Find_Equality + (Collect_Primitive_Operations (Root_Type (Typl)))); -- Otherwise expand the component by component equality. Note that -- we never use block-bit comparisons for records, because of the diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 5536abd8401a..43bfc8a78a4e 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,10 @@ +2018-11-14 Hristian Kirtchev + + * gnat.dg/equal4.adb, gnat.dg/equal4.ads, + gnat.dg/equal4_controlled_filter.ads, + gnat.dg/equal4_full_selector_filter.ads, + gnat.dg/equal4_smart_pointers.ads: New testcase. + 2018-11-14 Piotr Trojanek * gnat.dg/generic_actuals.adb: New testcase. diff --git a/gcc/testsuite/gnat.dg/equal4.adb b/gcc/testsuite/gnat.dg/equal4.adb new file mode 100644 index 000000000000..9c6861745270 --- /dev/null +++ b/gcc/testsuite/gnat.dg/equal4.adb @@ -0,0 +1,12 @@ +-- { dg-do compile } + +package body Equal4 is + procedure Compare (Obj : Equal4_Full_Selector_Filter.Object_T) is + use type Equal4_Full_Selector_Filter.Object_T; + + begin + if Obj = Equal4_Full_Selector_Filter.True then + null; + end if; + end Compare; +end Equal4; diff --git a/gcc/testsuite/gnat.dg/equal4.ads b/gcc/testsuite/gnat.dg/equal4.ads new file mode 100644 index 000000000000..0bc211340350 --- /dev/null +++ b/gcc/testsuite/gnat.dg/equal4.ads @@ -0,0 +1,5 @@ +with Equal4_Full_Selector_Filter; + +package Equal4 is + procedure Compare (Obj : Equal4_Full_Selector_Filter.Object_T); +end Equal4; diff --git a/gcc/testsuite/gnat.dg/equal4_controlled_filter.ads b/gcc/testsuite/gnat.dg/equal4_controlled_filter.ads new file mode 100644 index 000000000000..d7f1dd4fb87f --- /dev/null +++ b/gcc/testsuite/gnat.dg/equal4_controlled_filter.ads @@ -0,0 +1,13 @@ +with Equal4_Smart_Pointers; + +generic +package Equal4_Controlled_Filter is + type Object_T is private; + + function True return Object_T; + +private + package Smart is new Equal4_Smart_Pointers; + + type Object_T is new Smart.Pointer; +end Equal4_Controlled_Filter; diff --git a/gcc/testsuite/gnat.dg/equal4_full_selector_filter.ads b/gcc/testsuite/gnat.dg/equal4_full_selector_filter.ads new file mode 100644 index 000000000000..106df5be5706 --- /dev/null +++ b/gcc/testsuite/gnat.dg/equal4_full_selector_filter.ads @@ -0,0 +1,7 @@ +with Equal4_Controlled_Filter; + +package Equal4_Full_Selector_Filter is + package Equal4_Controlled_Filter_Instance is new Equal4_Controlled_Filter; + + type Object_T is new Equal4_Controlled_Filter_Instance.Object_T; +end Equal4_Full_Selector_Filter; diff --git a/gcc/testsuite/gnat.dg/equal4_smart_pointers.ads b/gcc/testsuite/gnat.dg/equal4_smart_pointers.ads new file mode 100644 index 000000000000..c5e03f58ee9f --- /dev/null +++ b/gcc/testsuite/gnat.dg/equal4_smart_pointers.ads @@ -0,0 +1,11 @@ +with Ada.Finalization; + +generic +package Equal4_Smart_Pointers is + type Pointer is private; + +private + type Pointer is new Ada.Finalization.Controlled with record + Data : Integer; + end record; +end Equal4_Smart_Pointers;