ada: Fix incorrect resolution of overloaded function call in instance

The problem occurs when the function call is the operand of an equality
operator, the type used to do the comparison is declared outside of the
generic construct but visible inside it, and this generic construct also
declares two functions with the same profile except for the result type,
one result type being the aforementioned type, the other being derived
from this type but not visible inside the generic construct.  When the
second operand is either a literal or also overloaded, the call may be
resolved to the second function instead of the first in instances.

gcc/ada/

	* gen_il-fields.ads (Opt_Field_Enum): Add Compare_Type.
	* gen_il-gen-gen_nodes.adb (N_Op_Eq): Likewise.
	(N_Op_Ge): Likewise.
	(N_Op_Gt): Likewise.
	(N_Op_Le): Likewise.
	(N_Op_Lt): Likewise.
	(N_Op_Ne): Likewise.
	* sinfo.ads (Compare_Type): Document new field.
	* sem_ch4.adb (Analyze_Comparison_Equality_Op): If the entity is
	already present, set the Compare_Type on overloaded operands if it
	is present on the node.
	* sem_ch12.adb (Check_Private_View): Look into the Compare_Type
	instead of the Etype for comparison operators.
	(Copy_Generic_Node): Remove obsolete code for comparison
	operators.
	(Save_Global_References.Save_References): Do not walk into the
	descendants of N_Implicit_Label_Declaration nodes.
	(Save_Global_References.Set_Global_Type): Look into the
	Compare_Type instead of the Etype for comparison operators.
	* sem_res.adb (Resolve_Comparison_Op): Set Compare_Type.
	(Resolve_Equality_Op): Likewise.

diff --git a/gcc/ada/gen_il-fields.ads b/gcc/ada/gen_il-fields.ads
index 1b40cd9472ef42e7483c748e56b35cbf0f046637..a0bfb398ebb3163db26e303d6ce2ff52da048eaa 100644 (file)
--- a/gcc/ada/gen_il-fields.ads
+++ b/gcc/ada/gen_il-fields.ads
@@ -99,6 +99,7 @@ package Gen_IL.Fields is
       Comes_From_Check_Or_Contract,
       Comes_From_Extended_Return_Statement,
       Comes_From_Iterator,
+      Compare_Type,
       Compile_Time_Known_Aggregate,
       Component_Associations,
       Component_Clauses,

diff --git a/gcc/ada/gen_il-gen-gen_nodes.adb b/gcc/ada/gen_il-gen-gen_nodes.adb
index fdf928d60a37800a82ed46fc4a2c1a912df1cc00..996d8d78aeae1798e95faa039a7ea517a10e8d59 100644 (file)
--- a/gcc/ada/gen_il-gen-gen_nodes.adb
+++ b/gcc/ada/gen_il-gen-gen_nodes.adb
@@ -267,32 +267,38 @@ begin -- Gen_IL.Gen.Gen_Nodes
    Cc (N_Op_Eq, N_Op_Compare,
        (Sm (Chars, Name_Id),
         Sy (Left_Opnd, Node_Id),
-        Sy (Right_Opnd, Node_Id)));
+        Sy (Right_Opnd, Node_Id),
+        Sm (Compare_Type, Node_Id)));
 
    Cc (N_Op_Ge, N_Op_Compare,
        (Sm (Chars, Name_Id),
         Sy (Left_Opnd, Node_Id),
-        Sy (Right_Opnd, Node_Id)));
+        Sy (Right_Opnd, Node_Id),
+        Sm (Compare_Type, Node_Id)));
 
    Cc (N_Op_Gt, N_Op_Compare,
        (Sm (Chars, Name_Id),
         Sy (Left_Opnd, Node_Id),
-        Sy (Right_Opnd, Node_Id)));
+        Sy (Right_Opnd, Node_Id),
+        Sm (Compare_Type, Node_Id)));
 
    Cc (N_Op_Le, N_Op_Compare,
        (Sm (Chars, Name_Id),
         Sy (Left_Opnd, Node_Id),
-        Sy (Right_Opnd, Node_Id)));
+        Sy (Right_Opnd, Node_Id),
+        Sm (Compare_Type, Node_Id)));
 
    Cc (N_Op_Lt, N_Op_Compare,
        (Sm (Chars, Name_Id),
         Sy (Left_Opnd, Node_Id),
-        Sy (Right_Opnd, Node_Id)));
+        Sy (Right_Opnd, Node_Id),
+        Sm (Compare_Type, Node_Id)));
 
    Cc (N_Op_Ne, N_Op_Compare,
        (Sm (Chars, Name_Id),
         Sy (Left_Opnd, Node_Id),
-        Sy (Right_Opnd, Node_Id)));
+        Sy (Right_Opnd, Node_Id),
+        Sm (Compare_Type, Node_Id)));
 
    Cc (N_Op_Or, N_Op_Boolean,
        (Sm (Chars, Name_Id),

diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb
index 582940da74bcbbd4a335003d56e0e0205182f420..f73e1b53b0e3df89dc354ad74f92686e1eae1690 100644 (file)
--- a/gcc/ada/sem_ch12.adb
+++ b/gcc/ada/sem_ch12.adb
@@ -7685,7 +7685,9 @@ package body Sem_Ch12 is
    ------------------------
 
    procedure Check_Private_View (N : Node_Id) is
-      Typ : constant Entity_Id := Etype (N);
+      Comparison : constant Boolean := Nkind (N) in N_Op_Compare;
+      Typ        : constant Entity_Id :=
+        (if Comparison then Compare_Type (N) else Etype (N));
 
       procedure Check_Private_Type (T : Entity_Id; Private_View : Boolean);
       --  Check that the available view of T matches Private_View and, if not,
@@ -7749,10 +7751,16 @@ package body Sem_Ch12 is
            and then (not In_Open_Scopes (Scope (Typ))
                       or else Nkind (Parent (N)) = N_Subtype_Declaration)
          then
-            --  In the generic, only the private declaration was visible
+            declare
+               Assoc : constant Node_Id := Get_Associated_Node (N);
+
+            begin
+               --  In the generic, only the private declaration was visible
 
-            Prepend_Elmt (Typ, Exchanged_Views);
-            Exchange_Declarations (Etype (Get_Associated_Node (N)));
+               Prepend_Elmt (Typ, Exchanged_Views);
+               Exchange_Declarations
+                 (if Comparison then Compare_Type (Assoc) else Etype (Assoc));
+            end;
 
          --  Check that the available views of Typ match their respective flag.
          --  Note that the type of a visible discriminant is never private.
@@ -8166,30 +8174,6 @@ package body Sem_Ch12 is
                      Set_Entity (New_N, Entity (Assoc));
                      Check_Private_View (N);
 
-                     --  For the comparison and equality operators, the Etype
-                     --  of the operator does not provide any information so,
-                     --  if one of the operands is of a universal type, we need
-                     --  to manually restore the full view of private types.
-
-                     if Nkind (N) in N_Op_Compare then
-                        if Yields_Universal_Type (Left_Opnd (Assoc)) then
-                           if Present (Etype (Right_Opnd (Assoc)))
-                             and then
-                               Is_Private_Type (Etype (Right_Opnd (Assoc)))
-                           then
-                              Switch_View (Etype (Right_Opnd (Assoc)));
-                           end if;
-
-                        elsif Yields_Universal_Type (Right_Opnd (Assoc)) then
-                           if Present (Etype (Left_Opnd (Assoc)))
-                             and then
-                               Is_Private_Type (Etype (Left_Opnd (Assoc)))
-                           then
-                              Switch_View (Etype (Left_Opnd (Assoc)));
-                           end if;
-                        end if;
-                     end if;
-
                   --  The node is a reference to a global type and acts as the
                   --  subtype mark of a qualified expression created in order
                   --  to aid resolution of accidental overloading in instances.
@@ -16883,6 +16867,11 @@ package body Sem_Ch12 is
                end if;
             end;
 
+         --  Do not walk the node pointed to by Label_Construct twice
+
+         elsif Nkind (N) = N_Implicit_Label_Declaration then
+            null;
+
          else
             Save_References_In_Descendants (N);
          end if;
@@ -16894,10 +16883,27 @@ package body Sem_Ch12 is
       ---------------------
 
       procedure Set_Global_Type (N : Node_Id; N2 : Node_Id) is
-         Typ : constant Entity_Id := Etype (N2);
+         Comparison : constant Boolean   := Nkind (N2) in N_Op_Compare;
+         Typ        : constant Entity_Id :=
+           (if Comparison then Compare_Type (N2) else Etype (N2));
 
       begin
-         Set_Etype (N, Typ);
+         --  For a comparison (or equality) operator, the Etype is Boolean, so
+         --  it is always global. But the type subject to the Has_Private_View
+         --  processing is the Compare_Type, so we must specifically check it.
+
+         if Comparison then
+            Set_Etype (N, Etype (N2));
+
+            if not Is_Global (Typ) then
+               return;
+            end if;
+
+            Set_Compare_Type (N, Typ);
+
+         else
+            Set_Etype (N, Typ);
+         end if;
 
          --  If the entity of N is not the associated node, this is a
          --  nested generic and it has an associated node as well, whose
@@ -16939,7 +16945,11 @@ package body Sem_Ch12 is
             Set_Has_Private_View (N);
 
             if Present (Full_View (Typ)) then
-               Set_Etype (N2, Full_View (Typ));
+               if Comparison then
+                  Set_Compare_Type (N2, Full_View (Typ));
+               else
+                  Set_Etype (N2, Full_View (Typ));
+               end if;
             end if;
          end if;
 

diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb
index 78249258f55c0a655524cfecdae850660142cae6..83705b9dae1b10296745dc7b29b2d692af1bfac6 100644 (file)
--- a/gcc/ada/sem_ch4.adb
+++ b/gcc/ada/sem_ch4.adb
@@ -2057,8 +2057,9 @@ package body Sem_Ch4 is
       --  For the predefined case, the result is Boolean, regardless of the
       --  type of the operands. The operands may even be limited, if they are
       --  generic actuals. If they are overloaded, label the operands with the
-      --  common type that must be present, or with the type of the formal of
-      --  the user-defined function.
+      --  compare type if it is present, typically because it is a global type
+      --  in a generic instance, or with the common type that must be present,
+      --  or with the type of the formal of the user-defined function.
 
       if Present (Entity (N)) then
          Op_Id := Entity (N);
@@ -2071,7 +2072,10 @@ package body Sem_Ch4 is
 
          if Is_Overloaded (L) then
             if Ekind (Op_Id) = E_Operator then
-               Set_Etype (L, Intersect_Types (L, R));
+               Set_Etype (L,
+                 (if Present (Compare_Type (N))
+                  then Compare_Type (N)
+                  else Intersect_Types (L, R)));
             else
                Set_Etype (L, Etype (First_Formal (Op_Id)));
             end if;
@@ -2079,7 +2083,10 @@ package body Sem_Ch4 is
 
          if Is_Overloaded (R) then
             if Ekind (Op_Id) = E_Operator then
-               Set_Etype (R, Intersect_Types (L, R));
+               Set_Etype (R,
+                 (if Present (Compare_Type (N))
+                  then Compare_Type (N)
+                  else Intersect_Types (L, R)));
             else
                Set_Etype (R, Etype (Next_Formal (First_Formal (Op_Id))));
             end if;

diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb
index fa1365c26417c696cfc84cfd3ad7c97c60631a18..42f7c10c5c59bf92695b8eeff59c991aceef57ad 100644 (file)
--- a/gcc/ada/sem_res.adb
+++ b/gcc/ada/sem_res.adb
@@ -7611,6 +7611,7 @@ package body Sem_Res is
 
       Resolve (L, T);
       Resolve (R, T);
+      Set_Compare_Type (N, T);
       Check_Unset_Reference (L);
       Check_Unset_Reference (R);
       Generate_Operator_Reference (N, T);
@@ -9119,6 +9120,7 @@ package body Sem_Res is
 
          Resolve (L, T);
          Resolve (R, T);
+         Set_Compare_Type (N, T);
 
          --  AI12-0413: user-defined primitive equality of an untagged record
          --  type hides the predefined equality operator, including within a

diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads
index fc9bcfbd44db74984507c7f64940aeb0c62dea78..8f9626019853e543d2d260f531c48263e0ed45b6 100644 (file)
--- a/gcc/ada/sinfo.ads
+++ b/gcc/ada/sinfo.ads
@@ -962,6 +962,20 @@ package Sinfo is
    --    was constructed as part of the expansion of an iterator
    --    specification.
 
+   --  Compare_Type
+   --    Present in N_Op_Compare nodes. Set during resolution to the type of
+   --    the operands. It is used to propagate the type of the operands from
+   --    a N_Op_Compare node in a generic construct to the nodes created from
+   --    it in the various instances, when this type is global to the generic
+   --    construct. Resolution for global types cannot be redone in instances
+   --    because the instantiation can be done out of context, e.g. for bodies,
+   --    and the visibility of global types is incorrect in this case; that is
+   --    why the result of the resolution done in the generic construct needs
+   --    to be available in the instances but, unlike for arithmetic operators,
+   --    the Etype cannot be used to that effect for comparison operators. It
+   --    is also used as the type subject to the Has_Private_View processing on
+   --    the nodes instead of the Etype.
+
    --  Compile_Time_Known_Aggregate
    --    Present in N_Aggregate nodes. Set for aggregates which can be fully
    --    evaluated at compile time without raising constraint error. Such
@@ -4507,31 +4521,37 @@ package Sinfo is
 
       --  N_Op_Eq
       --  Sloc points to =
+      --  Compare_Type
       --  plus fields for binary operator
       --  plus fields for expression
 
       --  N_Op_Ne
       --  Sloc points to /=
+      --  Compare_Type
       --  plus fields for binary operator
       --  plus fields for expression
 
       --  N_Op_Lt
       --  Sloc points to <
+      --  Compare_Type
       --  plus fields for binary operator
       --  plus fields for expression
 
       --  N_Op_Le
       --  Sloc points to <=
+      --  Compare_Type
       --  plus fields for binary operator
       --  plus fields for expression
 
       --  N_Op_Gt
       --  Sloc points to >
+      --  Compare_Type
       --  plus fields for binary operator
       --  plus fields for expression
 
       --  N_Op_Ge
       --  Sloc points to >=
+      --  Compare_Type
       --  plus fields for binary operator
       --  plus fields for expression