[Ada] Spurious error on nested instantiation

This fixes a spurious error given by the compiler for a call to a
subprogram which is the formal subprogram parameter of a generic
package, if the generic package is instantiated in the body of an
enclosing generic package with two formal types and two formal
subprogram parameter homonyms taking them, and this instantiation takes
one the two formal types as actual, and the enclosing generic package is
instantiated on the same actual type with a single actual subprogram
parameter, and the aforementioned call is overloaded.

In this case, the renaming generated for the actual subprogram parameter
in the nested instantiation is ambiguous and must be disambiguated using
the corresponding formal parameter of the enclosing instantiation,
otherwise a (sub)type mismatch is created and later subprogram
disambiguation is not really possible.

2019-08-13  Eric Botcazou  <ebotcazou@adacore.com>

gcc/ada/

	* sem_ch4.adb (Analyze_One_Call): Remove bypass for type
	mismatch in nested instantiations.
	* sem_ch8.adb (Find_Nearer_Entity): New function.
	(Find_Renamed_Entity): Use it to disambiguate the candidates for
	the renaming generated for an instantiation when it is
	ambiguous.

gcc/testsuite/

	* gnat.dg/generic_inst9.adb, gnat.dg/generic_inst9.ads,
	gnat.dg/generic_inst9_pkg1-operator.ads,
	gnat.dg/generic_inst9_pkg1.ads, gnat.dg/generic_inst9_pkg2.adb,
	gnat.dg/generic_inst9_pkg2.ads: New testcase.

From-SVN: r274343

gcc/ada/ChangeLog

 2019-08-13  Eric Botcazou  <ebotcazou@adacore.com>
 
+	* sem_ch4.adb (Analyze_One_Call): Remove bypass for type
+	mismatch in nested instantiations.
+	* sem_ch8.adb (Find_Nearer_Entity): New function.
+	(Find_Renamed_Entity): Use it to disambiguate the candidates for
+	the renaming generated for an instantiation when it is
+	ambiguous.
+
+2019-08-13  Eric Botcazou  <ebotcazou@adacore.com>
+
 	* gnat1drv.adb (Adjust_Global_Switches): Do not set
 	Back_End_Inlining in ASIS mode either.
 

gcc/ada/sem_ch4.adb

@@ -3619,59 +3619,6 @@ package body Sem_Ch4 is
                   Next_Actual (Actual);
                   Next_Formal (Formal);
 
-               --  In a complex case where an enclosing generic and a nested
-               --  generic package, both declared with partially parameterized
-               --  formal subprograms with the same names, are instantiated
-               --  with the same type, the types of the actual parameter and
-               --  that of the formal may appear incompatible at first sight.
-
-               --   generic
-               --      type Outer_T is private;
-               --      with function Func (Formal : Outer_T)
-               --                         return ... is <>;
-
-               --   package Outer_Gen is
-               --      generic
-               --         type Inner_T is private;
-               --         with function Func (Formal : Inner_T)   --  (1)
-               --           return ... is <>;
-
-               --      package Inner_Gen is
-               --         function Inner_Func (Formal : Inner_T)  --  (2)
-               --           return ... is (Func (Formal));
-               --      end Inner_Gen;
-               --   end Outer_Generic;
-
-               --   package Outer_Inst is new Outer_Gen (Actual_T);
-               --   package Inner_Inst is new Outer_Inst.Inner_Gen (Actual_T);
-
-               --  In the example above, the type of parameter
-               --  Inner_Func.Formal at (2) is incompatible with the type of
-               --  Func.Formal at (1) in the context of instantiations
-               --  Outer_Inst and Inner_Inst. In reality both types are generic
-               --  actual subtypes renaming base type Actual_T as part of the
-               --  generic prologues for the instantiations.
-
-               --  Recognize this case and add a type conversion to allow this
-               --  kind of generic actual subtype conformance. Note that this
-               --  is done only when the call is non-overloaded because the
-               --  resolution mechanism already has the means to disambiguate
-               --  similar cases.
-
-               elsif not Is_Overloaded (Name (N))
-                 and then Is_Type (Etype (Actual))
-                 and then Is_Type (Etype (Formal))
-                 and then Is_Generic_Actual_Type (Etype (Actual))
-                 and then Is_Generic_Actual_Type (Etype (Formal))
-                 and then Base_Type (Etype (Actual)) =
-                          Base_Type (Etype (Formal))
-               then
-                  Rewrite (Actual,
-                    Convert_To (Etype (Formal), Relocate_Node (Actual)));
-                  Analyze_And_Resolve (Actual, Etype (Formal));
-                  Next_Actual (Actual);
-                  Next_Formal (Formal);
-
                --  Handle failed type check
 
                else

gcc/ada/sem_ch8.adb

@@ -6721,6 +6721,15 @@ package body Sem_Ch8 is
       Old_S : Entity_Id;
       Inst  : Entity_Id;
 
+      function Find_Nearer_Entity
+        (New_S  : Entity_Id;
+         Old1_S : Entity_Id;
+         Old2_S : Entity_Id) return Entity_Id;
+      --  Determine whether one of Old_S1 and Old_S2 is nearer to New_S than
+      --  the other, and return it if so. Return Empty otherwise. We use this
+      --  in conjunction with Inherit_Renamed_Profile to simplify later type
+      --  disambiguation for actual subprograms in instances.
+
       function Is_Visible_Operation (Op : Entity_Id) return Boolean;
       --  If the renamed entity is an implicit operator, check whether it is
       --  visible because its operand type is properly visible. This check
@@ -6737,6 +6746,99 @@ package body Sem_Ch8 is
       --  enclosing instance. If yes, it has precedence over outer candidates.
 
       --------------------------
+      --  Find_Nearer_Entity  --
+      --------------------------
+
+      function Find_Nearer_Entity
+        (New_S  : Entity_Id;
+         Old1_S : Entity_Id;
+         Old2_S : Entity_Id) return Entity_Id
+      is
+         New_F  : Entity_Id;
+         Old1_F : Entity_Id;
+         Old2_F : Entity_Id;
+         Anc_T  : Entity_Id;
+
+      begin
+         New_F  := First_Formal (New_S);
+         Old1_F := First_Formal (Old1_S);
+         Old2_F := First_Formal (Old2_S);
+
+         --  The criterion is whether the type of the formals of one of Old1_S
+         --  and Old2_S is an ancestor subtype of the type of the corresponding
+         --  formals of New_S while the other is not (we already know that they
+         --  are all subtypes of the same base type).
+
+         --  This makes it possible to find the more correct renamed entity in
+         --  the case of a generic instantiation nested in an enclosing one for
+         --  which different formal types get the same actual type, which will
+         --  in turn make it possible for Inherit_Renamed_Profile to preserve
+         --  types on formal parameters and ultimately simplify disambiguation.
+
+         --  Consider the follow package G:
+
+         --    generic
+         --       type Item_T is private;
+         --       with function Compare (L, R: Item_T) return Boolean is <>;
+
+         --       type Bound_T is private;
+         --       with function Compare (L, R : Bound_T) return Boolean is <>;
+         --    package G is
+         --       ...
+         --    end G;
+
+         --    package body G is
+         --       package My_Inner is Inner_G (Bound_T);
+         --       ...
+         --    end G;
+
+         --    with the following package Inner_G:
+
+         --    generic
+         --       type T is private;
+         --       with function Compare (L, R: T) return Boolean is <>;
+         --    package Inner_G is
+         --       function "<" (L, R: T) return Boolean is (Compare (L, R));
+         --    end Inner_G;
+
+         --  If G is instantiated on the same actual type with a single Compare
+         --  function:
+
+         --    type T is ...
+         --    function Compare (L, R : T) return Boolean;
+         --    package My_G is new (T, T);
+
+         --  then the renaming generated for Compare in the inner instantiation
+         --  is ambiguous: it can rename either of the renamings generated for
+         --  the outer instantiation. Now if the first one is picked up, then
+         --  the subtypes of the formal parameters of the renaming will not be
+         --  preserved in Inherit_Renamed_Profile because they are subtypes of
+         --  the Bound_T formal type and not of the Item_T formal type, so we
+         --  need to arrange for the second one to be picked up instead.
+
+         while Present (New_F) loop
+            if Etype (Old1_F) /= Etype (Old2_F) then
+               Anc_T := Ancestor_Subtype (Etype (New_F));
+
+               if Etype (Old1_F) = Anc_T then
+                  return Old1_S;
+               elsif Etype (Old2_F) = Anc_T then
+                  return Old2_S;
+               end if;
+            end if;
+
+            Next_Formal (New_F);
+            Next_Formal (Old1_F);
+            Next_Formal (Old2_F);
+         end loop;
+
+         pragma Assert (No (Old1_F));
+         pragma Assert (No (Old2_F));
+
+         return Empty;
+      end Find_Nearer_Entity;
+
+      --------------------------
       -- Is_Visible_Operation --
       --------------------------
 
@@ -6860,21 +6962,37 @@ package body Sem_Ch8 is
                      if Present (Inst) then
                         if Within (It.Nam, Inst) then
                            if Within (Old_S, Inst) then
-
-                              --  Choose the innermost subprogram, which would
-                              --  have hidden the outer one in the generic.
-
-                              if Scope_Depth (It.Nam) <
-                                Scope_Depth (Old_S)
-                              then
-                                 return Old_S;
-                              else
-                                 return It.Nam;
-                              end if;
+                              declare
+                                 It_D  : constant Uint := Scope_Depth (It.Nam);
+                                 Old_D : constant Uint := Scope_Depth (Old_S);
+                                 N_Ent : Entity_Id;
+                              begin
+                                 --  Choose the innermost subprogram, which
+                                 --  would hide the outer one in the generic.
+
+                                 if Old_D > It_D then
+                                    return Old_S;
+                                 elsif It_D > Old_D then
+                                    return It.Nam;
+                                 end if;
+
+                                 --  Otherwise, if we can determine that one
+                                 --  of the entities is nearer to the renaming
+                                 --  than the other, choose it. If not, then
+                                 --  return the newer one as done historically.
+
+                                 N_Ent :=
+                                     Find_Nearer_Entity (New_S, Old_S, It.Nam);
+                                 if Present (N_Ent) then
+                                    return N_Ent;
+                                 else
+                                    return It.Nam;
+                                 end if;
+                              end;
                            end if;
 
                         elsif Within (Old_S, Inst) then
-                           return (Old_S);
+                           return Old_S;
 
                         else
                            return Report_Overload;

gcc/testsuite/ChangeLog

+2019-08-13  Eric Botcazou  <ebotcazou@adacore.com>
+
+	* gnat.dg/generic_inst9.adb, gnat.dg/generic_inst9.ads,
+	gnat.dg/generic_inst9_pkg1-operator.ads,
+	gnat.dg/generic_inst9_pkg1.ads, gnat.dg/generic_inst9_pkg2.adb,
+	gnat.dg/generic_inst9_pkg2.ads: New testcase.
+
 2019-08-13  Justin Squirek  <squirek@adacore.com>
 
 	* gnat.dg/anon3.adb, gnat.dg/anon3.ads: New testcase.

gcc/testsuite/gnat.dg/generic_inst9.adb

+--  { dg-do compile }
+
+package body Generic_Inst9 is
+  procedure Dummy is null;
+end Generic_Inst9;

gcc/testsuite/gnat.dg/generic_inst9.ads

+with Generic_Inst9_Pkg2;
+with Generic_Inst9_Pkg1; use Generic_Inst9_Pkg1;
+
+package Generic_Inst9 is
+
+  package Partition is new Generic_Inst9_Pkg2
+    (Item_T => Generic_Inst9_Pkg1.R, Bound_T => Generic_Inst9_Pkg1.R);
+
+  procedure Dummy;
+
+end Generic_Inst9;

gcc/testsuite/gnat.dg/generic_inst9_pkg1-operator.ads

+generic
+  type T is private;
+  with function Compare
+    (Left, Right: T) return Generic_Inst9_Pkg1.T is <>;
+package Generic_Inst9_Pkg1.Operator is
+  function Compare (Left, Right: Integer) return Generic_Inst9_Pkg1.T is
+    (Equal);
+  function "<"  (Left, Right: T) return Boolean is
+    (Compare (Left, Right) = Smaller);
+end Generic_Inst9_Pkg1.Operator;

gcc/testsuite/gnat.dg/generic_inst9_pkg1.ads

+
+package Generic_Inst9_Pkg1 is
+
+  type T is (None, Smaller, Equal, Larger);
+
+  type R is record
+    Val : Integer;
+  end record;
+
+  function Compare (Left, Right : R) return T;
+
+end;

gcc/testsuite/gnat.dg/generic_inst9_pkg2.adb

+with Generic_Inst9_Pkg1.Operator;
+
+package body Generic_Inst9_Pkg2 is
+
+  package My_Operator is new Generic_Inst9_Pkg1.Operator (Bound_T);
+
+  procedure Dummy is begin null; end;
+
+end Generic_Inst9_Pkg2;

gcc/testsuite/gnat.dg/generic_inst9_pkg2.ads

+with Generic_Inst9_Pkg1;
+
+generic
+
+  type Item_T is private;
+  with function Compare
+    (Left, Right: Item_T) return Generic_Inst9_Pkg1.T is <>;
+
+  type Bound_T is private;
+  with function Compare
+    (Left, Right : Bound_T) return Generic_Inst9_Pkg1.T is <>;
+
+package Generic_Inst9_Pkg2 is
+
+  procedure Dummy;
+
+end Generic_Inst9_Pkg2;