diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index ec135506857..1ad345e3e0d 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,18 @@ +2018-05-29 Javier Miranda + + * exp_ch4.adb (Expand_N_Op_Eq, Expand_Composite_Equality): Use the new + subprogram Inherits_From_Tagged_Full_View to identify more reliably + untagged private types completed with a derivation of an untagged + private whose full view is a tagged type. + * sem_util.ads, sem_util.adb (Inherits_From_Tagged_Full_View): New + subprogram. + (Collect_Primitive_Operations): Handle untagged private types completed + with a derivation of an untagged private type whose full view is a + tagged type. In such case, collecting the list of primitives we may + find two equality primitives: one associated with the untagged private + and another associated with the ultimate tagged type (and we must + remove from the returned list this latter one). + 2018-05-29 Ed Schonberg * exp_unst.adb (Visit_Node): Handle statement sequences that include an diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index 4cde8207694..bc504225a0c 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -2488,17 +2488,13 @@ package body Exp_Ch4 is Full_Type := Root_Type (Full_Type); end if; - -- If this is derived from an untagged private type completed with a - -- tagged type, it does not have a full view, so we use the primitive - -- operations of the private type. This check should no longer be - -- necessary when these types receive their full views ??? + -- If this is an untagged private type completed with a derivation of + -- an untagged private type whose full view is a tagged type, we use + -- the primitive operations of the private parent type (since it does + -- not have a full view, and also because its equality primitive may + -- have been overridden in its untagged full view). - if Is_Private_Type (Typ) - and then not Is_Tagged_Type (Typ) - and then not Is_Controlled (Typ) - and then Is_Derived_Type (Typ) - and then No (Full_View (Typ)) - then + if Inherits_From_Tagged_Full_View (Typ) then Prim := First_Elmt (Collect_Primitive_Operations (Typ)); else Prim := First_Elmt (Primitive_Operations (Full_Type)); @@ -7857,16 +7853,14 @@ package body Exp_Ch4 is return; end if; - -- If this is derived from an untagged private type completed with - -- a tagged type, it does not have a full view, so we use the - -- primitive operations of the private type. This check should no - -- longer be necessary when these types get their full views??? + -- If this is an untagged private type completed with a derivation + -- of an untagged private type whose full view is a tagged type, + -- we use the primitive operations of the private type (since it + -- does not have a full view, and also because its equality + -- primitive may have been overridden in its untagged full view). + + if Inherits_From_Tagged_Full_View (A_Typ) then - if Is_Private_Type (A_Typ) - and then not Is_Tagged_Type (A_Typ) - and then Is_Derived_Type (A_Typ) - and then No (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. diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 4cef1baea7d..ed66422cc00 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -5084,15 +5084,7 @@ package body Sem_Util is ---------------------------------- function Collect_Primitive_Operations (T : Entity_Id) return Elist_Id is - B_Type : constant Entity_Id := Base_Type (T); - B_Decl : constant Node_Id := Original_Node (Parent (B_Type)); - B_Scope : Entity_Id := Scope (B_Type); - Op_List : Elist_Id; - Formal : Entity_Id; - Is_Prim : Boolean; - Is_Type_In_Pkg : Boolean; - Formal_Derived : Boolean := False; - Id : Entity_Id; + B_Type : constant Entity_Id := Base_Type (T); function Match (E : Entity_Id) return Boolean; -- True if E's base type is B_Type, or E is of an anonymous access type @@ -5120,6 +5112,18 @@ package body Sem_Util is and then Full_View (Etyp) = B_Type); end Match; + -- Local variables + + B_Decl : constant Node_Id := Original_Node (Parent (B_Type)); + B_Scope : Entity_Id := Scope (B_Type); + Op_List : Elist_Id; + Eq_Prims_List : Elist_Id := No_Elist; + Formal : Entity_Id; + Is_Prim : Boolean; + Is_Type_In_Pkg : Boolean; + Formal_Derived : Boolean := False; + Id : Entity_Id; + -- Start of processing for Collect_Primitive_Operations begin @@ -5268,6 +5272,22 @@ package body Sem_Util is else Append_Elmt (Id, Op_List); + + -- Save collected equality primitives for later filtering + -- (if we are processing a private type for which we can + -- collect several candidates). + + if Inherits_From_Tagged_Full_View (T) + and then Chars (Id) = Name_Op_Eq + and then Etype (First_Formal (Id)) = + Etype (Next_Formal (First_Formal (Id))) + then + if No (Eq_Prims_List) then + Eq_Prims_List := New_Elmt_List; + end if; + + Append_Elmt (Id, Eq_Prims_List); + end if; end if; end if; end if; @@ -5285,6 +5305,43 @@ package body Sem_Util is Id := First_Entity (System_Aux_Id); end if; end loop; + + -- Filter collected equality primitives + + if Inherits_From_Tagged_Full_View (T) + and then Present (Eq_Prims_List) + then + declare + First : constant Elmt_Id := First_Elmt (Eq_Prims_List); + Second : Elmt_Id; + + begin + pragma Assert (No (Next_Elmt (First)) + or else No (Next_Elmt (Next_Elmt (First)))); + + -- No action needed if we have collected a single equality + -- primitive + + if Present (Next_Elmt (First)) then + Second := Next_Elmt (First); + + if Is_Dispatching_Operation + (Ultimate_Alias (Node (First))) + then + Remove (Op_List, Node (First)); + + elsif Is_Dispatching_Operation + (Ultimate_Alias (Node (Second))) + then + Remove (Op_List, Node (Second)); + + else + pragma Assert (False); + raise Program_Error; + end if; + end if; + end; + end if; end if; return Op_List; @@ -12615,6 +12672,20 @@ package body Sem_Util is end if; end Inherit_Rep_Item_Chain; + ------------------------------------ + -- Inherits_From_Tagged_Full_View -- + ------------------------------------ + + function Inherits_From_Tagged_Full_View (Typ : Entity_Id) return Boolean is + begin + return Is_Private_Type (Typ) + and then Present (Full_View (Typ)) + and then Is_Private_Type (Full_View (Typ)) + and then not Is_Tagged_Type (Full_View (Typ)) + and then Present (Underlying_Type (Full_View (Typ))) + and then Is_Tagged_Type (Underlying_Type (Full_View (Typ))); + end Inherits_From_Tagged_Full_View; + --------------------------------- -- Insert_Explicit_Dereference -- --------------------------------- diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index 739a4d06eb8..6cb7db87839 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -1452,6 +1452,12 @@ package Sem_Util is -- Inherit the rep item chain of type From_Typ without clobbering any -- existing rep items on Typ's chain. Typ is the destination type. + function Inherits_From_Tagged_Full_View (Typ : Entity_Id) return Boolean; + pragma Inline (Inherits_From_Tagged_Full_View); + -- Return True if Typ is an untagged private type completed with a + -- derivation of an untagged private type declaration whose full view + -- is a tagged type. + procedure Insert_Explicit_Dereference (N : Node_Id); -- In a context that requires a composite or subprogram type and where a -- prefix is an access type, rewrite the access type node N (which is the diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index bce064a523d..030573496eb 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,7 @@ +2018-05-29 Javier Miranda + + * gnat.dg/equal2.adb: New testcase. + 2018-05-29 Ed Schonberg * gnat.dg/float_attributes_overflows.adb: New testcase. diff --git a/gcc/testsuite/gnat.dg/equal2.adb b/gcc/testsuite/gnat.dg/equal2.adb new file mode 100644 index 00000000000..ca371772920 --- /dev/null +++ b/gcc/testsuite/gnat.dg/equal2.adb @@ -0,0 +1,41 @@ +-- { dg-do run } + +procedure Equal2 is + + package L1 is + type T is private; + overriding function "=" (Left, Right : T) return Boolean; + private + type T is tagged record + I : Integer := 0; + end record; + end L1; + + package L2 is + type T is private; + private + type T is new L1.T; + overriding function "=" (Left, Right : T) return Boolean; + end L2; + + package body L1 is + overriding function "=" (Left, Right : T) return Boolean is + begin + return False; + end "="; + end L1; + + package body L2 is + overriding function "=" (Left, Right : T) return Boolean is + begin + return True; + end "="; + end L2; + + use type L2.T; + Left, Right : L2.T; +begin + if Left /= Right then + raise Program_Error; + end if; +end;