This happens only when one of the operands is of a tagged type, because the
handling of equality operators for tagged types is completely separate from
that of equality operators for untagged types. But it turns out that this
separate processing is intended to be used for symmetric equality operators
only, so the fix is to redirect that of all asymmetric equality operators
to the common processing instead.
This also fixes a small glitch in this common processing, whereby a derived
type would both inherit an implicit inequality operator from its parent type
per the RM 6.6(6) rule and have another implicit inequality operator created
from an equality operator inherited from its parent type.
Tested on x86-64/Linux, applied on the mainline.
2026-09-22 Eric Botcazou <[email protected]>
* exp_ch3.adb (Make_Predefined_Primitive_Eq_Spec): Fix pasto.
* sem_ch4.adb (wpo): Also accept untagged types.
* sem_ch6.adb (Make_Inequality_Operator): Also copy Is_Primitive.
(New_Overloaded_Entity): Create the implicit inequality operator
only for nonderived subprograms, but create it in the asymmetric
case even for tagged types. Deal with the inheritance of such an
implicit inequality operator.
* sem_disp.adb: Add clauses for Stand.
(Check_Dispatching_Operation): Bail out for inequality operators
whose result type is Boolean.
--
Eric Botcazoudiff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb
index c57949eb425..5f4a271d627 100644
--- a/gcc/ada/exp_ch3.adb
+++ b/gcc/ada/exp_ch3.adb
@@ -12351,7 +12351,7 @@ package body Exp_Ch3 is
-- Set to True if Tag_Typ has a primitive that renames the predefined
-- equality operator. Used to implement (RM 8-5-4(8)).
- -- Start of processing for Make_Predefined_Primitive_Specs
+ -- Start of processing for Make_Predefined_Primitive_Eq_Spec
begin
Renamed_Eq := Empty;
diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb
index 400fa4f8869..31786fd6ab7 100644
--- a/gcc/ada/sem_ch4.adb
+++ b/gcc/ada/sem_ch4.adb
@@ -11440,10 +11440,6 @@ package body Sem_Ch4 is
E : Elmt_Id;
begin
- if not Is_Tagged_Type (T) then
- return;
- end if;
-
E := First_Elmt (Primitive_Operations (Base_Type (T)));
while Present (E) loop
Op := Node (E);
diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb
index 2ed3b7c3f47..76da204abcf 100644
--- a/gcc/ada/sem_ch6.adb
+++ b/gcc/ada/sem_ch6.adb
@@ -11656,6 +11656,7 @@ package body Sem_Ch6 is
Set_Has_Completion (Op_Name);
Set_Corresponding_Equality (Op_Name, S);
Set_Is_Abstract_Subprogram (Op_Name, Is_Abstract_Subprogram (S));
+ Set_Is_Primitive (Op_Name, Is_Primitive (S));
end;
end Make_Inequality_Operator;
@@ -13274,23 +13275,22 @@ package body Sem_Ch6 is
-- operation was dispatching), so Check_Dispatching_Operation is not
-- called in that case.
- if No (Derived_Type)
- or else Is_Tagged_Type (Derived_Type)
- then
+ if No (Derived_Type) or else Is_Tagged_Type (Derived_Type) then
Check_Dispatching_Operation (S, Empty);
end if;
end if;
- -- If this is a user-defined equality operator that is not a derived
- -- subprogram, create the corresponding inequality. If the operation is
- -- dispatching, the expansion is done elsewhere, and we do not create
- -- an explicit inequality operation.
-
<<Check_Inequality>>
+ -- If this is an equality operator whose result type is Boolean and
+ -- that is not a derived subprogram, create the implicit inequality
+ -- operator (RM 6.6(6)), but not if it is a dispatching user-defined
+ -- equality operator because those are handled specially.
+
if Chars (S) = Name_Op_Eq
and then Base_Type (Etype (S)) = Standard_Boolean
- and then Present (Parent (S))
- and then not Is_Dispatching_Operation (S)
+ and then No (Alias (S))
+ and then not (Is_Dispatching_Operation (S)
+ and then Is_User_Defined_Equality (S))
then
Make_Inequality_Operator (S);
@@ -13302,6 +13302,48 @@ package body Sem_Ch6 is
then
Check_Untagged_Equality (S);
end if;
+
+ -- If this is an inherited implicit inequality operator, set its
+ -- Corresponding_Equality to the inherited equality operator.
+
+ elsif Chars (S) = Name_Op_Ne
+ and then Base_Type (Etype (S)) = Standard_Boolean
+ and then Present (Alias (S))
+ and then Present (Corresponding_Equality (Alias (S)))
+ then
+ declare
+ Eq : constant Entity_Id := Prev_Entity (S);
+
+ function Check_Correspondence return Boolean;
+ -- Check that the Corresponding_Equality of the immediate
+ -- ancestor of S is an ancestor of Eq. Note that we cannot
+ -- be more specific for Eq since Sem_Ch3.Derive_Subprogram
+ -- does not set the Alias field of derived subprograms the
+ -- same way for intrinsic and nonintrinsic subprograms.
+
+ --------------------------
+ -- Check_Correspondence --
+ --------------------------
+
+ function Check_Correspondence return Boolean is
+ A : Entity_Id := Alias (Eq);
+
+ begin
+ while Present (A) loop
+ if Corresponding_Equality (Alias (S)) = A then
+ return True;
+ end if;
+
+ A := Alias (A);
+ end loop;
+
+ return False;
+ end Check_Correspondence;
+
+ begin
+ pragma Assert (Check_Correspondence);
+ Set_Corresponding_Equality (S, Eq);
+ end;
end if;
end New_Overloaded_Entity;
diff --git a/gcc/ada/sem_disp.adb b/gcc/ada/sem_disp.adb
index c093d1122d0..cf12321cc5c 100644
--- a/gcc/ada/sem_disp.adb
+++ b/gcc/ada/sem_disp.adb
@@ -53,6 +53,7 @@ with Sem_Util; use Sem_Util;
with Snames; use Snames;
with Sinfo.Nodes; use Sinfo.Nodes;
with Sinfo.Utils; use Sinfo.Utils;
+with Stand; use Stand;
with Tbuild; use Tbuild;
with Uintp; use Uintp;
with Warnsw; use Warnsw;
@@ -1286,10 +1287,20 @@ package body Sem_Disp is
then
return;
- -- Wrappers of access to subprograms are not primitive subprograms.
+ -- Wrappers of access to subprograms are not dispatching operations
elsif Is_Access_To_Subprogram_Wrapper (Subp) then
return;
+
+ -- Inequality operators whose result type is Boolean are not dispatching
+ -- operations because they are always implicitly declared as giving the
+ -- complementary result of the sibling equality operator (RM 6.6(5-6)).
+
+ elsif Ekind (Subp) = E_Function
+ and then Chars (Subp) = Name_Op_Ne
+ and then Base_Type (Etype (Subp)) = Standard_Boolean
+ then
+ return;
end if;
Set_Is_Dispatching_Operation (Subp, False);
