OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

[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
This commit is contained in:
Eric Botcazou 2019-08-13 08:07:18 +00:00 committed by Pierre-Marie de Rodat
parent 2e8362bc21
commit 258325dddf
10 changed files with 208 additions and 63 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
gcc/ada/ChangeLog
View File

@ -1,3 +1,12 @@
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

53
gcc/ada/sem_ch4.adb
View File

@ -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

138
gcc/ada/sem_ch8.adb
View File

@ -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
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.
-- Choose the innermost subprogram, which would
-- have hidden 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;
if Scope_Depth (It.Nam) <
Scope_Depth (Old_S)
then
return Old_S;
else
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;

7
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,10 @@
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.

5
gcc/testsuite/gnat.dg/generic_inst9.adb Normal file
View File

@ -0,0 +1,5 @@
-- { dg-do compile }
package body Generic_Inst9 is
procedure Dummy is null;
end Generic_Inst9;

11
gcc/testsuite/gnat.dg/generic_inst9.ads Normal file
View File

@ -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;

10
gcc/testsuite/gnat.dg/generic_inst9_pkg1-operator.ads Normal file
View File

@ -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;

12
gcc/testsuite/gnat.dg/generic_inst9_pkg1.ads Normal file
View File

@ -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;

9
gcc/testsuite/gnat.dg/generic_inst9_pkg2.adb Normal file
View File

@ -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;

17
gcc/testsuite/gnat.dg/generic_inst9_pkg2.ads Normal file
View File

@ -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;