diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 72528d3f0188..b69303240fc7 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,12 @@ +2019-08-14 Eric Botcazou + + * sem_ch7.adb (Install_Private_Declarations) + : Do not rely solely on the + Is_Child_Unit flag on the unit to recurse. + (Uninstall_Declarations) : New + function. Use it to recurse on the private dependent entities + for child units. + 2019-08-14 Javier Miranda * exp_aggr.adb (Is_CCG_Supported_Aggregate): Return False for diff --git a/gcc/ada/sem_ch7.adb b/gcc/ada/sem_ch7.adb index e0d20ef844b7..f7998c0d75bd 100644 --- a/gcc/ada/sem_ch7.adb +++ b/gcc/ada/sem_ch7.adb @@ -2261,13 +2261,14 @@ package body Sem_Ch7 is procedure Swap_Private_Dependents (Priv_Deps : Elist_Id); -- When the full view of a private type is made available, we do the -- same for its private dependents under proper visibility conditions. - -- When compiling a grandchild unit this needs to be done recursively. + -- When compiling a child unit this needs to be done recursively. ----------------------------- -- Swap_Private_Dependents -- ----------------------------- procedure Swap_Private_Dependents (Priv_Deps : Elist_Id) is + Cunit : Entity_Id; Deps : Elist_Id; Priv : Entity_Id; Priv_Elmt : Elmt_Id; @@ -2285,6 +2286,7 @@ package body Sem_Ch7 is if Present (Full_View (Priv)) and then Is_Visible_Dependent (Priv) then if Is_Private_Type (Priv) then + Cunit := Cunit_Entity (Current_Sem_Unit); Deps := Private_Dependents (Priv); Is_Priv := True; else @@ -2312,11 +2314,14 @@ package body Sem_Ch7 is Set_Is_Potentially_Use_Visible (Priv, Is_Potentially_Use_Visible (Node (Priv_Elmt))); - -- Within a child unit, recurse, except in generic child unit, - -- which (unfortunately) handle private_dependents separately. + -- Recurse for child units, except in generic child units, + -- which unfortunately handle private_dependents separately. + -- Note that the current unit may not have been analyzed, + -- for example a package body, so we cannot rely solely on + -- the Is_Child_Unit flag, but that's only an optimization. if Is_Priv - and then Is_Child_Unit (Cunit_Entity (Current_Sem_Unit)) + and then (No (Etype (Cunit)) or else Is_Child_Unit (Cunit)) and then not Is_Empty_Elmt_List (Deps) and then not Inside_A_Generic then @@ -2701,13 +2706,16 @@ package body Sem_Ch7 is Decl : constant Node_Id := Unit_Declaration_Node (P); Id : Entity_Id; Full : Entity_Id; - Priv_Elmt : Elmt_Id; - Priv_Sub : Entity_Id; procedure Preserve_Full_Attributes (Priv : Entity_Id; Full : Entity_Id); -- Copy to the private declaration the attributes of the full view that -- need to be available for the partial view also. + procedure Swap_Private_Dependents (Priv_Deps : Elist_Id); + -- When the full view of a private type is made unavailable, we do the + -- same for its private dependents under proper visibility conditions. + -- When compiling a child unit this needs to be done recursively. + function Type_In_Use (T : Entity_Id) return Boolean; -- Check whether type or base type appear in an active use_type clause @@ -2826,6 +2834,66 @@ package body Sem_Ch7 is end if; end Preserve_Full_Attributes; + ----------------------------- + -- Swap_Private_Dependents -- + ----------------------------- + + procedure Swap_Private_Dependents (Priv_Deps : Elist_Id) is + Cunit : Entity_Id; + Deps : Elist_Id; + Priv : Entity_Id; + Priv_Elmt : Elmt_Id; + Is_Priv : Boolean; + + begin + Priv_Elmt := First_Elmt (Priv_Deps); + while Present (Priv_Elmt) loop + Priv := Node (Priv_Elmt); + + -- Before we do the swap, we verify the presence of the Full_View + -- field, which may be empty due to a swap by a previous call to + -- End_Package_Scope (e.g. from the freezing mechanism). + + if Present (Full_View (Priv)) then + if Is_Private_Type (Priv) then + Cunit := Cunit_Entity (Current_Sem_Unit); + Deps := Private_Dependents (Priv); + Is_Priv := True; + else + Is_Priv := False; + end if; + + if Scope (Priv) = P + or else not In_Open_Scopes (Scope (Priv)) + then + Set_Is_Immediately_Visible (Priv, False); + end if; + + if Is_Visible_Dependent (Priv) then + Preserve_Full_Attributes (Priv, Full_View (Priv)); + Replace_Elmt (Priv_Elmt, Full_View (Priv)); + Exchange_Declarations (Priv); + + -- Recurse for child units, except in generic child units, + -- which unfortunately handle private_dependents separately. + -- Note that the current unit may not have been analyzed, + -- for example a package body, so we cannot rely solely on + -- the Is_Child_Unit flag, but that's only an optimization. + + if Is_Priv + and then (No (Etype (Cunit)) or else Is_Child_Unit (Cunit)) + and then not Is_Empty_Elmt_List (Deps) + and then not Inside_A_Generic + then + Swap_Private_Dependents (Deps); + end if; + end if; + end if; + + Next_Elmt (Priv_Elmt); + end loop; + end Swap_Private_Dependents; + ----------------- -- Type_In_Use -- ----------------- @@ -3077,31 +3145,7 @@ package body Sem_Ch7 is -- were compiled in this scope, or installed previously -- by Install_Private_Declarations. - -- Before we do the swap, we verify the presence of the Full_View - -- field which may be empty due to a swap by a previous call to - -- End_Package_Scope (e.g. from the freezing mechanism). - - Priv_Elmt := First_Elmt (Private_Dependents (Id)); - while Present (Priv_Elmt) loop - Priv_Sub := Node (Priv_Elmt); - - if Present (Full_View (Priv_Sub)) then - if Scope (Priv_Sub) = P - or else not In_Open_Scopes (Scope (Priv_Sub)) - then - Set_Is_Immediately_Visible (Priv_Sub, False); - end if; - - if Is_Visible_Dependent (Priv_Sub) then - Preserve_Full_Attributes - (Priv_Sub, Full_View (Priv_Sub)); - Replace_Elmt (Priv_Elmt, Full_View (Priv_Sub)); - Exchange_Declarations (Priv_Sub); - end if; - end if; - - Next_Elmt (Priv_Elmt); - end loop; + Swap_Private_Dependents (Private_Dependents (Id)); -- Now restore the type itself to its private view diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 64819ad96824..6b71b95ba3a5 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,13 @@ +2019-08-14 Eric Botcazou + + * gnat.dg/inline18.adb, gnat.dg/inline18.ads, + gnat.dg/inline18_gen1-inner_g.ads, gnat.dg/inline18_gen1.adb, + gnat.dg/inline18_gen1.ads, gnat.dg/inline18_gen2.adb, + gnat.dg/inline18_gen2.ads, gnat.dg/inline18_gen3.adb, + gnat.dg/inline18_gen3.ads, gnat.dg/inline18_pkg1.adb, + gnat.dg/inline18_pkg1.ads, gnat.dg/inline18_pkg2-child.ads, + gnat.dg/inline18_pkg2.ads: New testcase. + 2019-08-14 Ed Schonberg * gnat.dg/predicate12.adb, gnat.dg/predicate12.ads: New diff --git a/gcc/testsuite/gnat.dg/inline18.adb b/gcc/testsuite/gnat.dg/inline18.adb new file mode 100644 index 000000000000..29b3d4509e36 --- /dev/null +++ b/gcc/testsuite/gnat.dg/inline18.adb @@ -0,0 +1,6 @@ +-- { dg-do compile } +-- { dg-options "-O -gnatn" } + +package body Inline18 is + procedure Dummy is null; +end Inline18; diff --git a/gcc/testsuite/gnat.dg/inline18.ads b/gcc/testsuite/gnat.dg/inline18.ads new file mode 100644 index 000000000000..435ee7f60c7f --- /dev/null +++ b/gcc/testsuite/gnat.dg/inline18.ads @@ -0,0 +1,6 @@ +with Inline18_Pkg1; use Inline18_Pkg1; + +package Inline18 is + I : Integer := My_G.Next (0); + procedure Dummy; +end Inline18; diff --git a/gcc/testsuite/gnat.dg/inline18_gen1-inner_g.ads b/gcc/testsuite/gnat.dg/inline18_gen1-inner_g.ads new file mode 100644 index 000000000000..2c6544d98ee9 --- /dev/null +++ b/gcc/testsuite/gnat.dg/inline18_gen1-inner_g.ads @@ -0,0 +1,8 @@ +generic +package Inline18_Gen1.Inner_G is + + type T is new Inline18_Gen1.T; + + Val : T; + +end Inline18_Gen1.Inner_G; diff --git a/gcc/testsuite/gnat.dg/inline18_gen1.adb b/gcc/testsuite/gnat.dg/inline18_gen1.adb new file mode 100644 index 000000000000..3352624fff2f --- /dev/null +++ b/gcc/testsuite/gnat.dg/inline18_gen1.adb @@ -0,0 +1,9 @@ +package body Inline18_Gen1 is + + function Complete return T is + Dummy : T; + begin + return Dummy; + end; + +end Inline18_Gen1; diff --git a/gcc/testsuite/gnat.dg/inline18_gen1.ads b/gcc/testsuite/gnat.dg/inline18_gen1.ads new file mode 100644 index 000000000000..54e569302bc5 --- /dev/null +++ b/gcc/testsuite/gnat.dg/inline18_gen1.ads @@ -0,0 +1,14 @@ +generic + + type Bound_T is private; + +package Inline18_Gen1 is + + type T is private; + function Complete return T with Inline_Always; + +private + + type T is array (0 .. 1) of Bound_T; + +end Inline18_Gen1; diff --git a/gcc/testsuite/gnat.dg/inline18_gen2.adb b/gcc/testsuite/gnat.dg/inline18_gen2.adb new file mode 100644 index 000000000000..fe09fd0f395d --- /dev/null +++ b/gcc/testsuite/gnat.dg/inline18_gen2.adb @@ -0,0 +1,10 @@ +package body Inline18_Gen2 is + + function Func (I : Interval_T) return T is + pragma Unreferenced (I); + Dummy : T; + begin + return Dummy; + end; + +end Inline18_Gen2; diff --git a/gcc/testsuite/gnat.dg/inline18_gen2.ads b/gcc/testsuite/gnat.dg/inline18_gen2.ads new file mode 100644 index 000000000000..ca6302b694b7 --- /dev/null +++ b/gcc/testsuite/gnat.dg/inline18_gen2.ads @@ -0,0 +1,11 @@ +generic + + type Interval_T is private; + +package Inline18_Gen2 is + + type T is new Integer; + + function Func (I : Interval_T) return T; + +end Inline18_Gen2; diff --git a/gcc/testsuite/gnat.dg/inline18_gen3.adb b/gcc/testsuite/gnat.dg/inline18_gen3.adb new file mode 100644 index 000000000000..4f786c2de3fc --- /dev/null +++ b/gcc/testsuite/gnat.dg/inline18_gen3.adb @@ -0,0 +1,12 @@ +package body Inline18_Gen3 is + + package body Inner_G is + + function Next (Position : Index_T) return Index_T is + begin + return Position; + end; + + end Inner_G; + +end Inline18_Gen3; diff --git a/gcc/testsuite/gnat.dg/inline18_gen3.ads b/gcc/testsuite/gnat.dg/inline18_gen3.ads new file mode 100644 index 000000000000..798df5f298c9 --- /dev/null +++ b/gcc/testsuite/gnat.dg/inline18_gen3.ads @@ -0,0 +1,13 @@ +generic + + type Index_T is range <>; + +package Inline18_Gen3 is + + generic + package Inner_G is + function Next (Position : Index_T) return Index_T; + pragma Inline (Next); + end Inner_G; + +end Inline18_Gen3; diff --git a/gcc/testsuite/gnat.dg/inline18_pkg1.adb b/gcc/testsuite/gnat.dg/inline18_pkg1.adb new file mode 100644 index 000000000000..f266f099ccd4 --- /dev/null +++ b/gcc/testsuite/gnat.dg/inline18_pkg1.adb @@ -0,0 +1,8 @@ +package body Inline18_Pkg1 is + + procedure Proc (R : in out Rec) is + begin + R.Comp := My_G2.Func (Inline18_Pkg2.Child.General.Val); + end; + +end Inline18_Pkg1; diff --git a/gcc/testsuite/gnat.dg/inline18_pkg1.ads b/gcc/testsuite/gnat.dg/inline18_pkg1.ads new file mode 100644 index 000000000000..a0c184ccfffb --- /dev/null +++ b/gcc/testsuite/gnat.dg/inline18_pkg1.ads @@ -0,0 +1,19 @@ +with Inline18_Pkg2.Child; +with Inline18_Gen2; +with Inline18_Gen3; + +package Inline18_Pkg1 is + + package My_G2 is new Inline18_Gen2 (Inline18_Pkg2.Child.General.T); + + package My_G3 is new Inline18_Gen3 (Integer); + + type Rec is record + Comp : My_G2.T; + end record; + + procedure Proc (R : in out Rec); + + package My_G is new My_G3.Inner_G; + +end Inline18_Pkg1; diff --git a/gcc/testsuite/gnat.dg/inline18_pkg2-child.ads b/gcc/testsuite/gnat.dg/inline18_pkg2-child.ads new file mode 100644 index 000000000000..21f1ba13e364 --- /dev/null +++ b/gcc/testsuite/gnat.dg/inline18_pkg2-child.ads @@ -0,0 +1,9 @@ +with Inline18_Gen1.Inner_G; + +package Inline18_Pkg2.Child is + + package Base is new Inline18_Gen1 (Integer); + + package General is new Base.Inner_G; + +end Inline18_Pkg2.Child; diff --git a/gcc/testsuite/gnat.dg/inline18_pkg2.ads b/gcc/testsuite/gnat.dg/inline18_pkg2.ads new file mode 100644 index 000000000000..ae48bfc15414 --- /dev/null +++ b/gcc/testsuite/gnat.dg/inline18_pkg2.ads @@ -0,0 +1,2 @@ +package Inline18_Pkg2 is +end Inline18_Pkg2;