From: Gary Dismukes Date: Wed, 14 Aug 2019 09:52:10 +0000 (+0000) Subject: [Ada] Equality for nonabstract type derived from interface treated as abstract X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=72e324b6d8cb43b07eb3927f7d150b93105d1add;p=gcc.git [Ada] Equality for nonabstract type derived from interface treated as abstract The compiler was creating an abstract function for the equality operation of a (nonlimited) interface type, and that could result in errors on generic instantiations that are passed nonabstract types derived from the interface type along with the derived type's inherited equality operation (complaining about an abstract subprogram being passed to a nonabstract formal). The "=" operation of an interface is supposed to be nonabstract (a direct consequence of the rule in RM 4.5.2(6-7)), so we now create an expression function rather than an abstract function. The function returns False, but the result is unimportant since a function of an abstract type can never actually be invoked (its arguments must generally be class-wide, since there can be no objects of the type, and calling it will dispatch). 2019-08-14 Gary Dismukes gcc/ada/ * exp_ch3.adb (Predef_Spec_Or_Body): For an equality operation of an interface type, create an expression function (that returns False) rather than declaring an abstract function. * freeze.adb (Check_Inherited_Conditions): Set Needs_Wrapper to False unconditionally at the start of the loop creating wrappers for inherited operations. gcc/testsuite/ * gnat.dg/equal11.adb, gnat.dg/equal11_interface.ads, gnat.dg/equal11_record.adb, gnat.dg/equal11_record.ads: New testcase. From-SVN: r274464 --- diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 7c09cc0c32f..1b9e28529fe 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,12 @@ +2019-08-14 Gary Dismukes + + * exp_ch3.adb (Predef_Spec_Or_Body): For an equality operation + of an interface type, create an expression function (that + returns False) rather than declaring an abstract function. + * freeze.adb (Check_Inherited_Conditions): Set Needs_Wrapper to + False unconditionally at the start of the loop creating wrappers + for inherited operations. + 2019-08-14 Bob Duff * table.adb: Assert that the table is not locked when increasing diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index 834aaa3a18f..1901ea57398 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -10313,8 +10313,24 @@ package body Exp_Ch3 is Result_Definition => New_Occurrence_Of (Ret_Type, Loc)); end if; + -- Declare an abstract subprogram for primitive subprograms of an + -- interface type (except for "="). + if Is_Interface (Tag_Typ) then - return Make_Abstract_Subprogram_Declaration (Loc, Spec); + if Name /= Name_Op_Eq then + return Make_Abstract_Subprogram_Declaration (Loc, Spec); + + -- The equality function (if any) for an interface type is defined + -- to be nonabstract, so we create an expression function for it that + -- always returns False. Note that the function can never actually be + -- invoked because interface types are abstract, so there aren't any + -- objects of such types (and their equality operation will always + -- dispatch). + + else + return Make_Expression_Function + (Loc, Spec, New_Occurrence_Of (Standard_False, Loc)); + end if; -- If body case, return empty subprogram body. Note that this is ill- -- formed, because there is not even a null statement, and certainly not diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index e4d52f6e10f..78d1ed46fef 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -1526,11 +1526,11 @@ package body Freeze is -- so that LSP can be verified/enforced. Op_Node := First_Elmt (Prim_Ops); - Needs_Wrapper := False; while Present (Op_Node) loop - Decls := Empty_List; - Prim := Node (Op_Node); + Decls := Empty_List; + Prim := Node (Op_Node); + Needs_Wrapper := False; if not Comes_From_Source (Prim) and then Present (Alias (Prim)) then Par_Prim := Alias (Prim); @@ -1601,8 +1601,6 @@ package body Freeze is (Par_R, New_List (New_Decl, New_Body)); end if; end; - - Needs_Wrapper := False; end if; Next_Elmt (Op_Node); diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index dadeb4fecc0..cff4e5ed0a9 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,9 @@ +2019-08-14 Gary Dismukes + + * gnat.dg/equal11.adb, gnat.dg/equal11_interface.ads, + gnat.dg/equal11_record.adb, gnat.dg/equal11_record.ads: New + testcase. + 2019-08-14 Bob Duff * gnat.dg/discr57.adb: New testcase. diff --git a/gcc/testsuite/gnat.dg/equal11.adb b/gcc/testsuite/gnat.dg/equal11.adb new file mode 100644 index 00000000000..83cff180ffe --- /dev/null +++ b/gcc/testsuite/gnat.dg/equal11.adb @@ -0,0 +1,37 @@ +-- { dg-do run } + +with Equal11_Record; + +procedure Equal11 is + + use Equal11_Record; + + R : My_Record_Type; + L : My_Record_Type_List_Pck.List; +begin + -- Single record + R.F := 42; + R.Put; + if Put_Result /= 42 then + raise Program_Error; + end if; + + -- List of records + L.Append ((F => 3)); + L.Append ((F => 2)); + L.Append ((F => 1)); + + declare + Expected : constant array (Positive range <>) of Integer := + (3, 2, 1); + I : Positive := 1; + begin + for LR of L loop + LR.Put; + if Put_Result /= Expected (I) then + raise Program_Error; + end if; + I := I + 1; + end loop; + end; +end Equal11; diff --git a/gcc/testsuite/gnat.dg/equal11_interface.ads b/gcc/testsuite/gnat.dg/equal11_interface.ads new file mode 100644 index 00000000000..abc44159e81 --- /dev/null +++ b/gcc/testsuite/gnat.dg/equal11_interface.ads @@ -0,0 +1,7 @@ +package Equal11_Interface is + + type My_Interface_Type is interface; + + procedure Put (R : in My_Interface_Type) is abstract; + +end Equal11_Interface; diff --git a/gcc/testsuite/gnat.dg/equal11_record.adb b/gcc/testsuite/gnat.dg/equal11_record.adb new file mode 100644 index 00000000000..55281620091 --- /dev/null +++ b/gcc/testsuite/gnat.dg/equal11_record.adb @@ -0,0 +1,10 @@ +with Ada.Text_IO; + +package body Equal11_Record is + + procedure Put (R : in My_Record_Type) is + begin + Put_Result := R.F; + end Put; + +end Equal11_Record; diff --git a/gcc/testsuite/gnat.dg/equal11_record.ads b/gcc/testsuite/gnat.dg/equal11_record.ads new file mode 100644 index 00000000000..09a18227f35 --- /dev/null +++ b/gcc/testsuite/gnat.dg/equal11_record.ads @@ -0,0 +1,21 @@ +with Ada.Containers.Doubly_Linked_Lists; +with Equal11_Interface; + +package Equal11_Record is + + use Equal11_Interface; + + type My_Record_Type is new My_Interface_Type with + record + F : Integer; + end record; + + overriding + procedure Put (R : in My_Record_Type); + + Put_Result : Integer; + + package My_Record_Type_List_Pck is + new Ada.Containers.Doubly_Linked_Lists (Element_Type => My_Record_Type); + +end Equal11_Record;