From: Eric Botcazou <ebotcazou@adacore.com>
Date: Wed, 3 Nov 2021 16:38:53 +0000 (+0100)
Subject: [Ada] Fix oversight in latest change to Has_Compatible_Type
X-Git-Tag: basepoints/gcc-13~3222
X-Git-Url: http://git.ipfire.org/cgi-bin/gitweb.cgi?a=commitdiff_plain;h=55a213950e9584ca84e96dc52ba496ff88de7bc8;p=thirdparty%2Fgcc.git

[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 --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb
index 6a3d8575964a..77c1b97068c4 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 923c8f94ee14..4419fb31bdac 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 018c2837fd7e..dfe4c7c5019a 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