From: Eric Botcazou Date: Tue, 13 Aug 2019 08:07:18 +0000 (+0000) Subject: [Ada] Spurious error on nested instantiation X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=258325dddf752c578f1da15f63577090b1db2de5;p=gcc.git [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 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 --- diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index a8ef30ff698..34f41fde3f0 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,12 @@ +2019-08-13 Eric Botcazou + + * 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 * gnat1drv.adb (Adjust_Global_Switches): Do not set diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index f7b99d4d939..c049f9db588 100644 --- a/gcc/ada/sem_ch4.adb +++ b/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 diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb index 7185c40f68f..8795dc07f95 100644 --- a/gcc/ada/sem_ch8.adb +++ b/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 @@ -6736,6 +6745,99 @@ package body Sem_Ch8 is -- Determine whether a candidate subprogram is defined within the -- 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; diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 8ec5ec02440..3ae70d6ee5a 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,10 @@ +2019-08-13 Eric Botcazou + + * 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 * gnat.dg/anon3.adb, gnat.dg/anon3.ads: New testcase. diff --git a/gcc/testsuite/gnat.dg/generic_inst9.adb b/gcc/testsuite/gnat.dg/generic_inst9.adb new file mode 100644 index 00000000000..1a5bbaf1978 --- /dev/null +++ b/gcc/testsuite/gnat.dg/generic_inst9.adb @@ -0,0 +1,5 @@ +-- { dg-do compile } + +package body Generic_Inst9 is + procedure Dummy is null; +end Generic_Inst9; diff --git a/gcc/testsuite/gnat.dg/generic_inst9.ads b/gcc/testsuite/gnat.dg/generic_inst9.ads new file mode 100644 index 00000000000..ace55662aab --- /dev/null +++ b/gcc/testsuite/gnat.dg/generic_inst9.ads @@ -0,0 +1,11 @@ +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; diff --git a/gcc/testsuite/gnat.dg/generic_inst9_pkg1-operator.ads b/gcc/testsuite/gnat.dg/generic_inst9_pkg1-operator.ads new file mode 100644 index 00000000000..f6bb43f130d --- /dev/null +++ b/gcc/testsuite/gnat.dg/generic_inst9_pkg1-operator.ads @@ -0,0 +1,10 @@ +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; diff --git a/gcc/testsuite/gnat.dg/generic_inst9_pkg1.ads b/gcc/testsuite/gnat.dg/generic_inst9_pkg1.ads new file mode 100644 index 00000000000..50b62f166de --- /dev/null +++ b/gcc/testsuite/gnat.dg/generic_inst9_pkg1.ads @@ -0,0 +1,12 @@ + +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; diff --git a/gcc/testsuite/gnat.dg/generic_inst9_pkg2.adb b/gcc/testsuite/gnat.dg/generic_inst9_pkg2.adb new file mode 100644 index 00000000000..d008888fbe2 --- /dev/null +++ b/gcc/testsuite/gnat.dg/generic_inst9_pkg2.adb @@ -0,0 +1,9 @@ +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; diff --git a/gcc/testsuite/gnat.dg/generic_inst9_pkg2.ads b/gcc/testsuite/gnat.dg/generic_inst9_pkg2.ads new file mode 100644 index 00000000000..4bd3dccbaef --- /dev/null +++ b/gcc/testsuite/gnat.dg/generic_inst9_pkg2.ads @@ -0,0 +1,17 @@ +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;