From patchwork Thu Jun 17 15:29:53 2010
Content-Type: text/plain; charset="utf-8"
MIME-Version: 1.0
Content-Transfer-Encoding: 7bit
Subject: [Ada] Ambiguity on "=" inherited from untagged private with tagged
 full type
Date: Thu, 17 Jun 2010 05:29:53 -0000
From: Arnaud Charlet <charlet@adacore.com>
X-Patchwork-Id: 56063
Message-Id: <20100617152953.GA24852@adacore.com>
To: gcc-patches@gcc.gnu.org
Cc: Gary Dismukes <dismukes@adacore.com>

The compiler incorrectly reports an ambiguity on an equality comparison
involving operands of a type derived from an untagged private type in the
case where the full type is tagged and extends a type with an equality
function declared in its package's private part (such as an extension of
Ada.Finalization.Controlled, which declares such a private equality op).
The collection of the untagged private type's primitive operations mistakenly
includes both the inherited equality and the tagged full type's constructed
equality as visible operations of the derived type. This case is now tested
for in the primitive collection routine, so that only the overriding equality
of the parent type is added to the primitive list.


The following test must compile and execute quietly:

$ gnatmake inherited_equals_bug
$ inherited_equals_bug


package Pkg_A0 is

   type TT0 is tagged private;

   User_Defined_Equality_Called : Boolean := False;

private

   type TT0 is tagged null record;

   function "=" (a, b : TT0) return Boolean;

end Pkg_A0;
package body Pkg_A0 is

   function "=" (a, b : TT0) return Boolean is
   begin
      User_Defined_Equality_Called := True;
      return True;
   end "=";

end Pkg_A0;
with Pkg_A0;  use Pkg_A0;

package Pkg_A1 is

   type TT1 is private;

private

   type TT1 is new TT0 with null record;

end Pkg_A1;
with Pkg_A1;  use Pkg_A1;

package Pkg_A2 is

   type TT2 is new TT1;

end Pkg_A2;
package Pkg_B0 is

   type TT0 is tagged private;

private

   type TT0 is tagged null record;

end Pkg_B0;
with Pkg_B0;  use Pkg_B0;

package Pkg_B1 is

   type TT1 is private;

   User_Defined_Equality_Called : Boolean := False;

private

   type TT1 is new TT0 with null record;

   function "=" (a, b : TT1) return Boolean;

end;
package body Pkg_B1 is

   function "=" (a, b : TT1) return Boolean is
   begin
      User_Defined_Equality_Called := True;
      return True;
   end "=";

end;
with Pkg_B1;  use Pkg_B1;

package Pkg_B2 is

   type TT2 is new TT1;

end Pkg_B2;

with Pkg_A0;
with Pkg_A2;  use Pkg_A2;
with Pkg_B1;
with Pkg_B2;  use Pkg_B2;

procedure Inherited_Equals_Bug is

   Obj_A2_1, Obj_A2_2 : Pkg_A2.TT2;

   Obj_B2_1, Obj_B2_2 : Pkg_B2.TT2;

begin
   if Obj_A2_1 = Obj_A2_2 then
      null;
   end if;

   if not Pkg_A0.User_Defined_Equality_Called then
      raise Program_Error;
   end if;

   if Obj_B2_1 = Obj_B2_2 then
      null;
   end if;

   if not Pkg_B1.User_Defined_Equality_Called then
      raise Program_Error;
   end if;
end Inherited_Equals_Bug;

Tested on x86_64-pc-linux-gnu, committed on trunk

2010-06-17  Gary Dismukes  <dismukes@adacore.com>

	* sem_util.adb (Collect_Primitive_Operations): In the of an untagged
	type with a dispatching equality operator that is overridden (for a
	tagged full type), don't include the overridden equality in the list of
	primitives. The overridden equality is detected by testing for an
	Aliased field that references the overriding equality.


Index: sem_util.adb
===================================================================
--- sem_util.adb	(revision 160923)
+++ sem_util.adb	(working copy)
@@ -1670,7 +1670,30 @@ package body Sem_Util is
                  and then (not Formal_Derived
                             or else Present (Alias (Id)))
                then
-                  Append_Elmt (Id, Op_List);
+                  --  In the special case of an equality operator aliased to
+                  --  an overriding dispatching equality belonging to the same
+                  --  type, we don't include it in the list of primitives.
+                  --  This avoids inheriting multiple equality operators when
+                  --  deriving from untagged private types whose full type is
+                  --  tagged, which can otherwise cause ambiguities. Note that
+                  --  this should only happen for this kind of untagged parent
+                  --  type, since normally dispatching operations are inherited
+                  --  using the type's Primitive_Operations list.
+
+                  if Chars (Id) = Name_Op_Eq
+                    and then Is_Dispatching_Operation (Id)
+                    and then Present (Alias (Id))
+                    and then Is_Overriding_Operation (Alias (Id))
+                    and then Base_Type (Etype (First_Entity (Id))) =
+                               Base_Type (Etype (First_Entity (Alias (Id))))
+                  then
+                     null;
+
+                  --  Include the subprogram in the list of primitives
+
+                  else
+                     Append_Elmt (Id, Op_List);
+                  end if;
                end if;
             end if;