[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  <dismukes@adacore.com>

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 7c09cc0c32f067341e7b7056e001334813d3985d..1b9e28529fe4a6b19387dd3cb1270ef462d6b332 100644 (file)
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,12 @@
+2019-08-14  Gary Dismukes  <dismukes@adacore.com>
+
+       * 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  <duff@adacore.com>
 
        * 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 834aaa3a18f9f34c40893eda1e499b361a311379..1901ea573983d4ae4eff8dbd4d3a3db850582adf 100644 (file)
--- 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 e4d52f6e10f4e8fa135c6dd38bc721564d929bc0..78d1ed46fefd27852377bd6a2f027fa15f3383a7 100644 (file)
--- 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 dadeb4fecc07fbaa0b04a78c5d4a0cf221368476..cff4e5ed0a94518e2e20c31ac0be5a9b19825f84 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,9 @@
+2019-08-14  Gary Dismukes  <dismukes@adacore.com>
+
+       * 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  <duff@adacore.com>
 
        * 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 (file)
index 0000000..83cff18
--- /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 (file)
index 0000000..abc4415
--- /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 (file)
index 0000000..5528162
--- /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 (file)
index 0000000..09a1822
--- /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;