[Ada] Fix spurious visibility error for tagged type with inlining

This fixes a spurious visibility error for the very peculiar case where
an operator that operates on the class-wide type of a tagged type is
declared in a package, the operator is renamed in another package where
a subtype of the tagged type is declared, and both packages end up in
the transititive closure of a unit compiled with optimization and
inter-inlining (-gnatn).

2019-07-22  Eric Botcazou  <ebotcazou@adacore.com>

gcc/ada/

	* sem_ch8.adb (End_Use_Type): Reset the In_Use flag on the
	class-wide type if the type is tagged.
	(Use_One_Type): Add commentary on the handling of the class-wide
	type.

gcc/testsuite/

	* gnat.dg/inline17.adb, gnat.dg/inline17_pkg1.adb,
	gnat.dg/inline17_pkg1.ads, gnat.dg/inline17_pkg2.ads,
	gnat.dg/inline17_pkg3.adb, gnat.dg/inline17_pkg3.ads: New
	testcase.

From-SVN: r273683
This commit is contained in:
Eric Botcazou 2019-07-22 13:57:37 +00:00 committed by Pierre-Marie de Rodat
parent ff9d220ede
commit 1169925707
9 changed files with 97 additions and 1 deletions

View File

@ -1,3 +1,10 @@
2019-07-22 Eric Botcazou <ebotcazou@adacore.com>
* sem_ch8.adb (End_Use_Type): Reset the In_Use flag on the
class-wide type if the type is tagged.
(Use_One_Type): Add commentary on the handling of the class-wide
type.
2019-07-22 Eric Botcazou <ebotcazou@adacore.com>
* einfo.ads (Is_For_Access_Subtype): Delete.

View File

@ -4836,6 +4836,13 @@ package body Sem_Ch8 is
Set_In_Use (Base_Type (T), False);
Set_Current_Use_Clause (T, Empty);
Set_Current_Use_Clause (Base_Type (T), Empty);
-- See Use_One_Type for the rationale. This is a bit on the naive
-- side, but should be good enough in practice.
if Is_Tagged_Type (T) then
Set_In_Use (Class_Wide_Type (T), False);
end if;
end if;
end if;
@ -9985,7 +9992,10 @@ package body Sem_Ch8 is
Set_In_Use (T);
-- If T is tagged, primitive operators on class-wide operands are
-- also available.
-- also deemed available. Note that this is really necessary only
-- in semantics-only mode, because the primitive operators are not
-- fully constructed in this mode, but we do it in all modes for the
-- sake of uniformity, as this should not matter in practice.
if Is_Tagged_Type (T) then
Set_In_Use (Class_Wide_Type (T));

View File

@ -1,3 +1,10 @@
2019-07-22 Eric Botcazou <ebotcazou@adacore.com>
* gnat.dg/inline17.adb, gnat.dg/inline17_pkg1.adb,
gnat.dg/inline17_pkg1.ads, gnat.dg/inline17_pkg2.ads,
gnat.dg/inline17_pkg3.adb, gnat.dg/inline17_pkg3.ads: New
testcase.
2019-07-22 Eric Botcazou <ebotcazou@adacore.com>
* gnat.dg/iter5.adb, gnat.dg/iter5_pkg.ads: New testcase.

View File

@ -0,0 +1,10 @@
-- { dg-do compile }
-- { dg-options "-O -gnatn" }
with Inline17_Pkg1; use Inline17_Pkg1;
with Inline17_Pkg2; use Inline17_Pkg2;
procedure Inline17 is
use type SQL_Field;
begin
Test;
end;

View File

@ -0,0 +1,15 @@
with Inline17_Pkg2; use Inline17_Pkg2;
package body Inline17_Pkg1 is
procedure Test is
begin
null;
end;
function Get (Field : SQL_Field) return Integer is
begin
return +Field;
end;
end Inline17_Pkg1;

View File

@ -0,0 +1,7 @@
package Inline17_Pkg1 is
procedure Test;
pragma Inline (Test);
end Inline17_Pkg1;

View File

@ -0,0 +1,10 @@
with Inline17_Pkg3; use Inline17_Pkg3;
package Inline17_Pkg2 is
subtype SQL_Field is Inline17_Pkg3.SQL_Field;
function "+" (Field : SQL_Field'Class) return Integer renames
Inline17_Pkg3."+";
end Inline17_Pkg2;

View File

@ -0,0 +1,14 @@
package body Inline17_Pkg3 is
function "+" (Field : SQL_Field'Class) return Integer is
begin
return 0;
end;
function Unchecked_Get (Self : Ref) return Integer is
begin
return Self.Data;
end;
end Inline17_Pkg3;

View File

@ -0,0 +1,16 @@
package Inline17_Pkg3 is
type SQL_Field is tagged null record;
function "+" (Field : SQL_Field'Class) return Integer;
type Ref is record
Data : Integer;
end record;
function Unchecked_Get (Self : Ref) return Integer with Inline_Always;
function Get (Self : Ref) return Integer is (Unchecked_Get (Self));
end Inline17_Pkg3;