From: Javier Miranda Date: Thu, 31 May 2018 10:45:51 +0000 (+0000) Subject: [Ada] Fix compiler crash for tagged private types X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=59f7c7167a75bdb3992f2c7fb3b358124aea8404;p=gcc.git [Ada] Fix compiler crash for tagged private types 2018-05-31 Javier Miranda gcc/ada/ * sem_util.ads, sem_util.adb (Find_Primitive_Eq): New subprogram. * exp_ch4.adb (Expand_Composite_Equality): Use the new subprogram Find_Primitive_Eq to search for the primitive of types whose underlying type is a tagged type. gcc/testsuite/ * gnat.dg/tagged1.adb, gnat.dg/tagged1.ads: New testcase. From-SVN: r260997 --- diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index e52386f6dfe..cec6c39879a 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,10 @@ +2018-05-31 Javier Miranda + + * sem_util.ads, sem_util.adb (Find_Primitive_Eq): New subprogram. + * exp_ch4.adb (Expand_Composite_Equality): Use the new subprogram + Find_Primitive_Eq to search for the primitive of types whose underlying + type is a tagged type. + 2018-05-31 Yannick Moy * sem_prag.adb (Analyze_Pragma.Check_Loop_Pragma_Placement): Inverse diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index 50333d3eb6b..0d836f85698 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -2335,7 +2335,6 @@ package body Exp_Ch4 is is Loc : constant Source_Ptr := Sloc (Nod); Full_Type : Entity_Id; - Prim : Elmt_Id; Eq_Op : Entity_Id; function Find_Primitive_Eq return Node_Id; @@ -2481,36 +2480,8 @@ package body Exp_Ch4 is -- Case of tagged record types elsif Is_Tagged_Type (Full_Type) then - - -- Call the primitive operation "=" of this type - - if Is_Class_Wide_Type (Full_Type) then - Full_Type := Root_Type (Full_Type); - end if; - - -- 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 Inherits_From_Tagged_Full_View (Typ) then - Prim := First_Elmt (Collect_Primitive_Operations (Typ)); - else - Prim := First_Elmt (Primitive_Operations (Full_Type)); - end if; - - loop - Eq_Op := Node (Prim); - exit when Chars (Eq_Op) = Name_Op_Eq - and then Etype (First_Formal (Eq_Op)) = - Etype (Next_Formal (First_Formal (Eq_Op))) - and then Base_Type (Etype (Eq_Op)) = Standard_Boolean; - Next_Elmt (Prim); - pragma Assert (Present (Prim)); - end loop; - - Eq_Op := Node (Prim); + Eq_Op := Find_Primitive_Eq (Typ); + pragma Assert (Present (Eq_Op)); return Make_Function_Call (Loc, diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index b629dbe8ae3..8fbad1d7e87 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -8325,6 +8325,93 @@ package body Sem_Util is end loop; end Find_Placement_In_State_Space; + ----------------------- + -- Find_Primitive_Eq -- + ----------------------- + + function Find_Primitive_Eq (Typ : Entity_Id) return Entity_Id is + function Find_Eq_Prim (Prims_List : Elist_Id) return Entity_Id; + -- Search for the equality primitive; return Empty if the primitive is + -- not found. + + function Find_Eq_Prim (Prims_List : Elist_Id) return Entity_Id is + Prim_E : Elmt_Id := First_Elmt (Prims_List); + Prim : Entity_Id; + + begin + 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 Base_Type (Etype (Prim)) = Standard_Boolean + then + return Prim; + end if; + + Next_Elmt (Prim_E); + end loop; + + return Empty; + end Find_Eq_Prim; + + -- Local Variables + + Full_Type : Entity_Id; + Eq_Prim : Entity_Id; + + -- Start of processing for Find_Primitive_Eq + + begin + if Is_Private_Type (Typ) then + Full_Type := Underlying_Type (Typ); + else + Full_Type := Typ; + end if; + + if No (Full_Type) then + return Empty; + end if; + + Full_Type := Base_Type (Full_Type); + + -- When the base type itself is private, use the full view + + if Is_Private_Type (Full_Type) then + Full_Type := Underlying_Type (Full_Type); + end if; + + if Is_Class_Wide_Type (Full_Type) then + Full_Type := Root_Type (Full_Type); + end if; + + if not Is_Tagged_Type (Full_Type) then + Eq_Prim := Find_Eq_Prim (Collect_Primitive_Operations (Typ)); + + -- 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 no equality was + -- defined for it then take its dispatching equality primitive. + + elsif Inherits_From_Tagged_Full_View (Typ) then + Eq_Prim := Find_Eq_Prim (Collect_Primitive_Operations (Typ)); + + if No (Eq_Prim) then + Eq_Prim := Find_Eq_Prim (Primitive_Operations (Full_Type)); + end if; + + else + Eq_Prim := Find_Eq_Prim (Primitive_Operations (Full_Type)); + end if; + + return Eq_Prim; + end Find_Primitive_Eq; + ------------------------ -- Find_Specific_Type -- ------------------------ diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index ad7760c0cbe..a2eca15b257 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -877,6 +877,10 @@ package Sem_Util is -- If the state space is that of a package, Pack_Id denotes its entity, -- otherwise Pack_Id is Empty. + function Find_Primitive_Eq (Typ : Entity_Id) return Entity_Id; + -- Locate primitive equality for type if it exists. Return Empty if it is + -- not available. + function Find_Specific_Type (CW : Entity_Id) return Entity_Id; -- Find specific type of a class-wide type, and handle the case of an -- incomplete type coming either from a limited_with clause or from an diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 47fd02efc55..d5f177e5ed5 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,7 @@ +2018-05-31 Javier Miranda + + * gnat.dg/tagged1.adb, gnat.dg/tagged1.ads: New testcase. + 2018-05-31 Sameera Deshpande * gcc.target/aarch64/advsimd-intrinsics/vld1x3.c: New test for diff --git a/gcc/testsuite/gnat.dg/tagged1.adb b/gcc/testsuite/gnat.dg/tagged1.adb new file mode 100644 index 00000000000..b8c4f60f1a4 --- /dev/null +++ b/gcc/testsuite/gnat.dg/tagged1.adb @@ -0,0 +1,5 @@ +-- { dg-do compile } + +package body Tagged1 is + procedure Dummy is null; +end Tagged1; diff --git a/gcc/testsuite/gnat.dg/tagged1.ads b/gcc/testsuite/gnat.dg/tagged1.ads new file mode 100644 index 00000000000..83c652bcb9a --- /dev/null +++ b/gcc/testsuite/gnat.dg/tagged1.ads @@ -0,0 +1,39 @@ +with Ada.Containers.Vectors; +with Ada.Containers; +with Ada.Finalization; + +package Tagged1 is + + generic + type Target_Type (<>) is limited private; + package A is + type Smart_Pointer_Type is private; + private + type Smart_Pointer_Type + is new Ada.Finalization.Controlled with null record; + end; + + generic + type Target_Type (<>) is limited private; + package SP is + type Smart_Pointer_Type is private; + private + package S is new A (Integer); + type Smart_Pointer_Type is new S.Smart_Pointer_Type; + end; + + type Root_Type is tagged record + Orders : Integer; + end record; + package Smarts is new SP + (Target_Type => Root_Type'Class); + + type Fat_Reference_Type is new Smarts.Smart_Pointer_Type; + type EST is record + Orders : Fat_Reference_Type; + end record; + + package V is new Ada.Containers.Vectors (Positive, EST); + + procedure Dummy; +end;