===================================================================
@@ -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;
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.