From 7f078d5b3e3ae2cdf527e6a163edd73238726a80 Mon Sep 17 00:00:00 2001 From: Eric Botcazou Date: Tue, 13 Aug 2019 08:08:32 +0000 Subject: [PATCH] [Ada] Fix spurious instantiation error on private record type This change was initially aimed at fixing a spurious instantiation error due to a disambiguation issue which happens when a generic unit with two formal type parameters is instantiated on a single actual type that is private. The compiler internally sets the Is_Generic_Actual_Type flag on the actual subtypes built for the instantiation in order to ease the disambiguation, but it would fail to set it on the full view if the subtypes are private. The change makes it so that the flag is properly set and reset on the full view in this case. But this uncovered an issue in Subtypes_Statically_Match, which was relying on a stalled Is_Generic_Actual_Type flag set on a full view outside of the instantiation to return a positive answer. This bypass was meant to solve an issue arising with a private discriminated record type whose completion is a discriminated record type itself derived from a private discriminated record type, which is used as actual type in an instantiation in another unit, and the instantiation is used in a child unit of the original unit. In this case, the private and full views of the generic actual type are swapped in the child unit, but there was a mismatch between the chain of full and underlying full views of the private discriminated record type and that of the generic actual type. This secondary issue is solved by avoiding to skip the full view in the preparation of the completion of the private subtype and by directly constraining the underlying full view of the full view of the base type instead of building an underlying full view from scratch. 2019-08-13 Eric Botcazou gcc/ada/ * sem_ch3.adb (Build_Underlying_Full_View): Delete. (Complete_Private_Subtype): Do not set the full view on the private subtype here. If the full base is itself derived from private, do not re-derive the parent type but instead constrain an existing underlying full view. (Prepare_Private_Subtype_Completion): Do not get to the underlying full view, if any. Set the full view on the private subtype here. (Process_Full_View): Likewise. * sem_ch12.adb (Check_Generic_Actuals): Also set Is_Generic_Actual_Type on the full view if the type of the actual is private. (Restore_Private_Views): Also reset Is_Generic_Actual_Type on the full view if the type of the actual is private. * sem_eval.adb (Subtypes_Statically_Match): Remove bypass for generic actual types. gcc/testsuite/ * gnat.dg/generic_inst10.adb, gnat.dg/generic_inst10_pkg.ads: New testcase. From-SVN: r274357 --- gcc/ada/ChangeLog | 19 +++ gcc/ada/sem_ch12.adb | 11 +- gcc/ada/sem_ch3.adb | 162 +++---------------- gcc/ada/sem_eval.adb | 12 +- gcc/testsuite/ChangeLog | 5 + gcc/testsuite/gnat.dg/generic_inst10.adb | 26 +++ gcc/testsuite/gnat.dg/generic_inst10_pkg.ads | 11 ++ 7 files changed, 90 insertions(+), 156 deletions(-) create mode 100644 gcc/testsuite/gnat.dg/generic_inst10.adb create mode 100644 gcc/testsuite/gnat.dg/generic_inst10_pkg.ads diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 5e313305ed3..dc039a6d919 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,22 @@ +2019-08-13 Eric Botcazou + + * sem_ch3.adb (Build_Underlying_Full_View): Delete. + (Complete_Private_Subtype): Do not set the full view on the + private subtype here. If the full base is itself derived from + private, do not re-derive the parent type but instead constrain + an existing underlying full view. + (Prepare_Private_Subtype_Completion): Do not get to the + underlying full view, if any. Set the full view on the private + subtype here. + (Process_Full_View): Likewise. + * sem_ch12.adb (Check_Generic_Actuals): Also set + Is_Generic_Actual_Type on the full view if the type of the + actual is private. + (Restore_Private_Views): Also reset Is_Generic_Actual_Type on + the full view if the type of the actual is private. + * sem_eval.adb (Subtypes_Statically_Match): Remove bypass for + generic actual types. + 2019-08-13 Javier Miranda * sem_res.adb (Resolve_Selected_Component): When the type of the diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index 9f174948253..f98f2fa49a7 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -6804,7 +6804,12 @@ package body Sem_Ch12 is Check_Private_View (Subtype_Indication (Parent (E))); end if; - Set_Is_Generic_Actual_Type (E, True); + Set_Is_Generic_Actual_Type (E); + + if Is_Private_Type (E) and then Present (Full_View (E)) then + Set_Is_Generic_Actual_Type (Full_View (E)); + end if; + Set_Is_Hidden (E, False); Set_Is_Potentially_Use_Visible (E, In_Use (Instance)); @@ -14603,6 +14608,10 @@ package body Sem_Ch12 is null; else Set_Is_Generic_Actual_Type (E, False); + + if Is_Private_Type (E) and then Present (Full_View (E)) then + Set_Is_Generic_Actual_Type (Full_View (E), False); + end if; end if; -- An unusual case of aliasing: the actual may also be directly diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 645a024b7e0..ae8600c9803 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -232,18 +232,6 @@ package body Sem_Ch3 is -- Needs a more complete spec--what are the parameters exactly, and what -- exactly is the returned value, and how is Bound affected??? - procedure Build_Underlying_Full_View - (N : Node_Id; - Typ : Entity_Id; - Par : Entity_Id); - -- If the completion of a private type is itself derived from a private - -- type, or if the full view of a private subtype is itself private, the - -- back-end has no way to compute the actual size of this type. We build - -- an internal subtype declaration of the proper parent type to convey - -- this information. This extra mechanism is needed because a full - -- view cannot itself have a full view (it would get clobbered during - -- view exchanges). - procedure Check_Access_Discriminant_Requires_Limited (D : Node_Id; Loc : Node_Id); @@ -10447,111 +10435,6 @@ package body Sem_Ch3 is return New_Bound; end Build_Scalar_Bound; - -------------------------------- - -- Build_Underlying_Full_View -- - -------------------------------- - - procedure Build_Underlying_Full_View - (N : Node_Id; - Typ : Entity_Id; - Par : Entity_Id) - is - Loc : constant Source_Ptr := Sloc (N); - Subt : constant Entity_Id := - Make_Defining_Identifier - (Loc, New_External_Name (Chars (Typ), 'S')); - - Constr : Node_Id; - Indic : Node_Id; - C : Node_Id; - Id : Node_Id; - - procedure Set_Discriminant_Name (Id : Node_Id); - -- If the derived type has discriminants, they may rename discriminants - -- of the parent. When building the full view of the parent, we need to - -- recover the names of the original discriminants if the constraint is - -- given by named associations. - - --------------------------- - -- Set_Discriminant_Name -- - --------------------------- - - procedure Set_Discriminant_Name (Id : Node_Id) is - Disc : Entity_Id; - - begin - Set_Original_Discriminant (Id, Empty); - - if Has_Discriminants (Typ) then - Disc := First_Discriminant (Typ); - while Present (Disc) loop - if Chars (Disc) = Chars (Id) - and then Present (Corresponding_Discriminant (Disc)) - then - Set_Chars (Id, Chars (Corresponding_Discriminant (Disc))); - end if; - Next_Discriminant (Disc); - end loop; - end if; - end Set_Discriminant_Name; - - -- Start of processing for Build_Underlying_Full_View - - begin - if Nkind (N) = N_Full_Type_Declaration then - Constr := Constraint (Subtype_Indication (Type_Definition (N))); - - elsif Nkind (N) = N_Subtype_Declaration then - Constr := New_Copy_Tree (Constraint (Subtype_Indication (N))); - - elsif Nkind (N) = N_Component_Declaration then - Constr := - New_Copy_Tree - (Constraint (Subtype_Indication (Component_Definition (N)))); - - else - raise Program_Error; - end if; - - C := First (Constraints (Constr)); - while Present (C) loop - if Nkind (C) = N_Discriminant_Association then - Id := First (Selector_Names (C)); - while Present (Id) loop - Set_Discriminant_Name (Id); - Next (Id); - end loop; - end if; - - Next (C); - end loop; - - Indic := - Make_Subtype_Declaration (Loc, - Defining_Identifier => Subt, - Subtype_Indication => - Make_Subtype_Indication (Loc, - Subtype_Mark => New_Occurrence_Of (Par, Loc), - Constraint => New_Copy_Tree (Constr))); - - -- If this is a component subtype for an outer itype, it is not - -- a list member, so simply set the parent link for analysis: if - -- the enclosing type does not need to be in a declarative list, - -- neither do the components. - - if Is_List_Member (N) - and then Nkind (N) /= N_Component_Declaration - then - Insert_Before (N, Indic); - else - Set_Parent (Indic, Parent (N)); - end if; - - Analyze (Indic); - Set_Underlying_Full_View (Typ, Full_View (Subt)); - Set_Is_Underlying_Full_View (Full_View (Subt)); - end Build_Underlying_Full_View; - ------------------------------- -- Check_Abstract_Overriding -- ------------------------------- @@ -12471,7 +12354,6 @@ package body Sem_Ch3 is Set_Freeze_Node (Full, Empty); Set_Is_Frozen (Full, False); - Set_Full_View (Priv, Full); if Has_Discriminants (Full) then Set_Stored_Constraint_From_Discriminant_Constraint (Full); @@ -12492,26 +12374,24 @@ package body Sem_Ch3 is (Full, Related_Nod, Full_Base, Discriminant_Constraint (Priv)); -- If the full base is itself derived from private, build a congruent - -- subtype of its underlying type, for use by the back end. For a - -- constrained record component, the declaration cannot be placed on - -- the component list, but it must nevertheless be built an analyzed, to - -- supply enough information for Gigi to compute the size of component. + -- subtype of its underlying full view, for use by the back end. elsif Ekind (Full_Base) in Private_Kind - and then Is_Derived_Type (Full_Base) - and then Has_Discriminants (Full_Base) - and then (Ekind (Current_Scope) /= E_Record_Subtype) + and then Present (Underlying_Full_View (Full_Base)) then - if not Is_Itype (Priv) - and then - Nkind (Subtype_Indication (Parent (Priv))) = N_Subtype_Indication - then - Build_Underlying_Full_View - (Parent (Priv), Full, Etype (Full_Base)); - - elsif Nkind (Related_Nod) = N_Component_Declaration then - Build_Underlying_Full_View (Related_Nod, Full, Etype (Full_Base)); - end if; + declare + Underlying_Full_Base : constant Entity_Id + := Underlying_Full_View (Full_Base); + Underlying_Full : constant Entity_Id + := Make_Defining_Identifier (Sloc (Priv), Chars (Priv)); + begin + Set_Is_Itype (Underlying_Full); + Set_Associated_Node_For_Itype (Underlying_Full, Related_Nod); + Complete_Private_Subtype + (Priv, Underlying_Full, Underlying_Full_Base, Related_Nod); + Set_Underlying_Full_View (Full, Underlying_Full); + Set_Is_Underlying_Full_View (Underlying_Full); + end; elsif Is_Record_Type (Full_Base) then @@ -19928,20 +19808,12 @@ package body Sem_Ch3 is Related_Nod : Node_Id) is Id_B : constant Entity_Id := Base_Type (Id); - Full_B : Entity_Id := Full_View (Id_B); + Full_B : constant Entity_Id := Full_View (Id_B); Full : Entity_Id; begin if Present (Full_B) then - -- Get to the underlying full view if necessary - - if Is_Private_Type (Full_B) - and then Present (Underlying_Full_View (Full_B)) - then - Full_B := Underlying_Full_View (Full_B); - end if; - -- The Base_Type is already completed, we can complete the subtype -- now. We have to create a new entity with the same name, Thus we -- can't use Create_Itype. @@ -19950,6 +19822,7 @@ package body Sem_Ch3 is Set_Is_Itype (Full); Set_Associated_Node_For_Itype (Full, Related_Nod); Complete_Private_Subtype (Id, Full, Full_B, Related_Nod); + Set_Full_View (Id, Full); end if; -- The parent subtype may be private, but the base might not, in some @@ -20755,6 +20628,7 @@ package body Sem_Ch3 is end if; Complete_Private_Subtype (Full, Priv, Full_T, N); + Set_Full_View (Full, Priv); if Present (Priv_Scop) then Pop_Scope; diff --git a/gcc/ada/sem_eval.adb b/gcc/ada/sem_eval.adb index e417a0719d1..78740b956ee 100644 --- a/gcc/ada/sem_eval.adb +++ b/gcc/ada/sem_eval.adb @@ -6031,17 +6031,7 @@ package body Sem_Eval is -- same base type. if Has_Discriminants (T1) /= Has_Discriminants (T2) then - -- A generic actual type is declared through a subtype declaration - -- and may have an inconsistent indication of the presence of - -- discriminants, so check the type it renames. - - if Is_Generic_Actual_Type (T1) - and then not Has_Discriminants (Etype (T1)) - and then not Has_Discriminants (T2) - then - return True; - - elsif In_Instance then + if In_Instance then if Is_Private_Type (T2) and then Present (Full_View (T2)) and then Has_Discriminants (Full_View (T2)) diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 887b0c3c3e7..f3882db65fb 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2019-08-13 Eric Botcazou + + * gnat.dg/generic_inst10.adb, gnat.dg/generic_inst10_pkg.ads: + New testcase. + 2019-08-13 Javier Miranda * gnat.dg/tagged3.adb, gnat.dg/tagged3_pkg.adb, diff --git a/gcc/testsuite/gnat.dg/generic_inst10.adb b/gcc/testsuite/gnat.dg/generic_inst10.adb new file mode 100644 index 00000000000..75bb65a7f1a --- /dev/null +++ b/gcc/testsuite/gnat.dg/generic_inst10.adb @@ -0,0 +1,26 @@ +-- { dg-do compile } + +with Generic_Inst10_Pkg; use Generic_Inst10_Pkg; + +procedure Generic_Inst10 is + + function Image (S : XString) return String is (S.To_String); + + generic + type Left_Type (<>) is private; + type Right_Type (<>) is private; + with function Image (L : Left_Type) return String is <>; + with function Image (L : Right_Type) return String is <>; + procedure G (Left : Left_Type; Right : Right_Type); + + procedure G (Left : Left_Type; Right : Right_Type) is + A : String := Image (Left) & Image (Right); + begin + null; + end; + + procedure My_G is new G (XString, XString); + +begin + null; +end; diff --git a/gcc/testsuite/gnat.dg/generic_inst10_pkg.ads b/gcc/testsuite/gnat.dg/generic_inst10_pkg.ads new file mode 100644 index 00000000000..d9009ac3c32 --- /dev/null +++ b/gcc/testsuite/gnat.dg/generic_inst10_pkg.ads @@ -0,0 +1,11 @@ +package Generic_Inst10_Pkg is + + type XString is tagged private; + + function To_String (S : XString) return String; + +private + + type XString is tagged null record; + +end Generic_Inst10_Pkg; -- 2.30.2