[gcc r12-5091] [Ada] Fix oversight in latest change to Has_Compatible_Type

[gcc r12-5091] [Ada] Fix oversight in latest change to Has_Compatible_Type

[Pierre-Marie de Rodat]

https://gcc.gnu.org/g:55a213950e9584ca84e96dc52ba496ff88de7bc8

commit r12-5091-g55a213950e9584ca84e96dc52ba496ff88de7bc8
Author: Eric Botcazou <ebotcazou@adacore.com>
Date:   Wed Nov 3 17:38:53 2021 +0100

    [Ada] Fix oversight in latest change to Has_Compatible_Type
    
    gcc/ada/
    
            * sem_type.ads (Has_Compatible_Type): Add For_Comparison parameter.
            * sem_type.adb (Has_Compatible_Type): Put back the reversed calls
            to Covers guarded with For_Comparison.
            * sem_ch4.adb (Analyze_Membership_Op) <Try_One_Interp>: Remove new
            reversed call to Covers and set For_Comparison to true instead.
            (Find_Comparison_Types) <Try_One_Interp>: Likewise
            (Find_Equality_Types) <Try_One_Interp>: Likewise.

Diff:
---
 gcc/ada/sem_ch4.adb  |  9 ++++-----
 gcc/ada/sem_type.adb | 16 ++++++++++++++--
 gcc/ada/sem_type.ads | 10 ++++++++--
 3 files changed, 26 insertions(+), 9 deletions(-)

diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb
index 6a3d8575964..77c1b97068c 100644
--- a/gcc/ada/sem_ch4.adb
+++ b/gcc/ada/sem_ch4.adb
@@ -3113,7 +3113,7 @@ package body Sem_Ch4 is
 
       procedure Try_One_Interp (T1 : Entity_Id) is
       begin
-         if Has_Compatible_Type (R, T1) or else Covers (Etype (R), T1) then
+         if Has_Compatible_Type (R, T1, For_Comparison => True) then
             if Found
               and then Base_Type (T1) /= Base_Type (T_F)
             then
@@ -6607,8 +6607,7 @@ package body Sem_Ch4 is
          end if;
 
          if Valid_Comparison_Arg (T1)
-           and then (Has_Compatible_Type (R, T1)
-                      or else Covers (Etype (R), T1))
+           and then Has_Compatible_Type (R, T1, For_Comparison => True)
          then
             if Found and then Base_Type (T1) /= Base_Type (T_F) then
                It := Disambiguate (L, I_F, Index, Any_Type);
@@ -7105,8 +7104,8 @@ package body Sem_Ch4 is
 
          if T1 /= Standard_Void_Type
            and then (Universal_Access
-                      or else Has_Compatible_Type (R, T1)
-                      or else Covers (Etype (R), T1))
+                      or else
+                     Has_Compatible_Type (R, T1, For_Comparison => True))
 
            and then
              ((not Is_Limited_Type (T1)
diff --git a/gcc/ada/sem_type.adb b/gcc/ada/sem_type.adb
index 923c8f94ee1..4419fb31bda 100644
--- a/gcc/ada/sem_type.adb
+++ b/gcc/ada/sem_type.adb
@@ -2438,8 +2438,9 @@ package body Sem_Type is
    -------------------------
 
    function Has_Compatible_Type
-     (N   : Node_Id;
-      Typ : Entity_Id) return Boolean
+     (N              : Node_Id;
+      Typ            : Entity_Id;
+      For_Comparison : Boolean := False) return Boolean
    is
       I  : Interp_Index;
       It : Interp;
@@ -2479,6 +2480,12 @@ package body Sem_Type is
            or else
              (Nkind (N) = N_String_Literal
                and then Present (Find_Aspect (Typ, Aspect_String_Literal)))
+
+           or else
+             (For_Comparison
+               and then not Is_Tagged_Type (Typ)
+               and then Ekind (Typ) /= E_Anonymous_Access_Type
+               and then Covers (Etype (N), Typ))
          then
             return True;
          end if;
@@ -2503,6 +2510,11 @@ package body Sem_Type is
                   and then Covers (Typ, Corresponding_Record_Type
                                                              (Etype (It.Typ))))
 
+             or else
+               (For_Comparison
+                 and then not Is_Tagged_Type (Typ)
+                 and then Ekind (Typ) /= E_Anonymous_Access_Type
+                 and then Covers (It.Typ, Typ))
             then
                return True;
             end if;
diff --git a/gcc/ada/sem_type.ads b/gcc/ada/sem_type.ads
index 018c2837fd7..dfe4c7c5019 100644
--- a/gcc/ada/sem_type.ads
+++ b/gcc/ada/sem_type.ads
@@ -186,11 +186,17 @@ package Sem_Type is
    --  right operand, which has one interpretation compatible with that of L.
    --  Return the type intersection of the two.
 
-   function Has_Compatible_Type (N : Node_Id; Typ : Entity_Id) return Boolean;
+   function Has_Compatible_Type
+     (N              : Node_Id;
+      Typ            : Entity_Id;
+      For_Comparison : Boolean := False) return Boolean;
    --  Verify that some interpretation of the node N has a type compatible with
    --  Typ. If N is not overloaded, then its unique type must be compatible
    --  with Typ. Otherwise iterate through the interpretations of N looking for
-   --  a compatible one.
+   --  a compatible one. If For_Comparison is true, the function is invoked for
+   --  a comparison (or equality) operator and also needs to verify the reverse
+   --  compatibility, because the implementation of type resolution for these
+   --  operators is not fully symmetrical.
 
    function Hides_Op (F : Entity_Id; Op : Entity_Id) return Boolean;
    --  A user-defined function hides a predefined operator if it matches the